library(ggplot2)
#setwd("~/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/experiments/sinking-marbles-prior/results/")
setwd("~/Dropbox/sinking_marbles/sinking-marbles/experiments/1_sinking-marbles-prior/results/")
source("rscripts/summarySE.r")
r = read.table("data/sinking-marbles-prior.tsv", sep="\t", header=T)
r = r[,c("workerid", "rt", "effect", "cause", "object_level", "response", "object")]

r$object_level = factor(r$object_level, levels=c("object_high", "object_mid", "object_low"))
s = summarySE(r, measurevar="response", groupvars=c("effect", "object_level", "object"))
priors = s
save(priors, file="data/priors.RData")
load("data/priors.RData")

graph_title = "sinking-marbles-prior"
ggplot(s, aes(x=effect, y=response)) +
  geom_point(aes(colour=factor(object_level)), stat="identity") +
  geom_errorbar(aes(ymin=response-ci, ymax=response+ci, colour=factor(object_level)), width=.3) +
  ylab("") +
  xlab("") +
  theme_bw(18) +
  theme(
    axis.text.x = element_text(size=10, angle=-45, hjust=0)
    ,plot.background = element_blank()
    ,panel.grid.minor = element_blank()
  )
ggsave(file=paste(c("graphs/",graph_title, ".png"), collapse=""), width=15, height=6, title=graph_title)

graph_title = "sinking-marbles-prior-with-labels"
ggplot(s, aes(x=effect, y=response)) +
  geom_point(aes(colour=factor(object_level)), stat="identity") +
  geom_errorbar(aes(ymin=response-ci, ymax=response+ci, colour=factor(object_level)), width=.3) +
  geom_text(aes(label=object), size=3) +
  ylab("") +
  xlab("") +
  theme_bw(18) +
  theme(
    axis.text.x = element_text(size=10, angle=-45, hjust=0)
    ,plot.background = element_blank()
    ,panel.grid.minor = element_blank()
  )
ggsave(file=paste(c("graphs/",graph_title, ".png"), collapse=""), width=15, height=6, title=graph_title)

s$y = 0
s$yobject = as.numeric(ifelse(s$object_level == "object_high",0.25,ifelse(s$object_level =="object_mid",0,-0.25)))
ggplot(s, aes(x=response, y=yobject)) +
  geom_point(aes(colour=factor(object_level)))  +
  geom_text(aes(label=effect,y=yobject-0.05),angle=45) +
  theme_bw(18) +
  theme(
    axis.text.x = element_text(size=10, angle=-45, hjust=0)
    ,plot.background = element_blank()
    ,panel.grid.minor = element_blank()
  )
graph_title = "sinking-marbles-prior-distribution"
ggsave(file=paste(c("graphs/",graph_title, ".png"), collapse=""), width=15, height=6, title=graph_title)

ggplot(s, aes(x=response, fill=factor(object_level))) +
  geom_histogram(position="dodge")  +
  theme_bw(18) +
  theme(
    axis.text.x = element_text(size=10, angle=-45, hjust=0)
    ,plot.background = element_blank()
    ,panel.grid.minor = element_blank()
  )
graph_title = "sinking-marbles-prior-histogram"
ggsave(file=paste(c("graphs/",graph_title, ".png"), collapse=""), width=15, height=6, title=graph_title)

## plot variance histogram
ggplot(priors, aes(x=sd)) +
  geom_histogram()

## plot individual items
r$Combo = as.factor(paste(r$effect,r$object))
ggplot(r, aes(x=response)) +
  geom_histogram() +
  facet_wrap(~Combo)
ggsave(file="graphs/item_variability.pdf",width=20,height=15)

r$Bin = as.factor(ifelse(r$response == 0, 0, ifelse(r$response < 51, 50, ifelse(r$response < 100, 99, 100))))
ggplot(r, aes(x=Bin)) +
  geom_histogram() +
  facet_wrap(~Combo)
ggsave(file="graphs/item_variability_binned.pdf",width=20,height=15)

t = as.data.frame(prop.table(table(r$Bin,r$Combo),mar=2))
colnames(t) = c("Bin","Combo","Proportion")
tail(t)
t$Proportion = round(t$Proportion,digits=3)
t$SmoothedProportion = t$Proportion + 0.001
library(reshape2)
casted = dcast(t, Combo ~ Bin, value.var="Proportion")
write.table(casted,file="data/binned_priors_norownames.txt",row.names=F,quote=F,sep="\t")
write.table(casted[,c("0","50","99","100")],file="data/binned_priors.txt",row.names=F,quote=F,sep="\t")
write.table(casted[,c("0","50","99","100")],file="data/binned_priors.txt",row.names=F,quote=F,sep=" ")
nrow(casted) # 90 different priors
# get smoothed probs (no zero-probs) so model doesn't freak out
casted = dcast(t, Combo ~ Bin, value.var="SmoothedProportion")
write.table(casted[,c("0","50","99","100")],file="data/binned_priors_smoothed.txt",row.names=F,quote=F,sep=" ")
row.names(casted) = as.character(casted$Combo)
head(casted)

head(priors)
row.names(priors) = paste(priors$effect, priors$object)
priors$r_all = casted[paste(priors$effect, priors$object),5]
priors$r_upper_half = casted[paste(priors$effect, priors$object),4]
priors$r_lower_half = casted[paste(priors$effect, priors$object),3]
priors$r_none = casted[paste(priors$effect, priors$object),2]

# plot all-prior mean vs proportion all against each other
priors$resp = priors$response/100
ggplot(priors, aes(x=resp,y=r_all)) +
  geom_point() +
  xlab("all-prior (mean)") +
  ylab("all-prior (proportion)") +
  geom_abline(intercept=0,slope=1)
ggsave("~/Dropbox/sinking_marbles/sinking-marbles/experiments/1_sinking-marbles-prior/results/graphs/mean-vs-proportion-allprior.pdf")

sank = subset(r, effect == "sank" & object == "balloons")
sank
ds = density(sank$response,n=101,from=0,to=100)#,bw=5)#,bw=2)
plot(ds$x,ds$y)
sum(ds$x*ds$y)
str(ds)

ds = density(sank$response,n=16,from=0,to=15)#,bw=5)#,bw=2)
plot(ds$x,ds$y)

seeds = subset(r, effect == "ate the seeds" & object == "birds")
seeds
d = density(seeds$response,n=101,from=0,to=100)#,bw=2)
plot(d$x,d$y)
sum(d$x*d$y)

felldown = subset(r, effect == "fell down" & object == "card towers")
felldown
df = density(felldown$response,n=101,from=0,to=100)#,bw=2)
plot(df$x,df$y)
sum(df$x*df$y)

expectations = ddply(r, .(effect,object), summarize, expectation=sum(density(response,n=101,from=0,to=100)$x*density(response,n=101,from=0,to=100)$y))
expectations5 = ddply(r, .(effect,object), summarize, expectation=sum(density(response,n=101,from=0,to=100,bw=5)$x*density(response,n=101,from=0,to=100,bw=5)$y))
mean(expectations$expectation)
median(expectations$expectation)
mean(expectations5$expectation)
median(expectations5$expectation)

ggplot(expectations, aes(x=expectation)) +
  geom_histogram() +
  scale_x_continuous(limits=c(0,100))

ggplot(expectations5, aes(x=expectation)) +
  geom_histogram() +
  scale_x_continuous(limits=c(0,100))

head(expectations)
nrow(priors)
nrow(expectations)
write.table(expectations,row.names=F,sep="\t",quote=F,file="data/expectations.txt")
write.table(expectations5,row.names=F,sep="\t",quote=F,file="data/expectations5.txt")

smoothedpriors = ddply(r, .(effect,object), summarize, smoothprior=density(response,n=101,from=0,to=100)$x*density(response,n=101,from=0,to=100)$y)


view(CO2)
names(CO2)
CO2
CO2 %>%
  ggplot( aes(conc, uptake,
              colour = Treatment))+
 geom_point(size = 3,alpha=0.5)+
  geom_smooth(method = lm, se = F)+
  facet_wrap(~Type)+
  labs(title = "Concentration of CO2")


saa = read.csv("sa-scpa1.txt", header = FALSE, sep = ";")
sab = read.csv("sa-scpb1.txt", header = FALSE, sep = ";")
sac = read.csv("sa-scpc1.txt", header = FALSE, sep = ";")
sad = read.csv("sa-scpd1.txt", header = FALSE, sep = ";")
acoa = read.csv("aco-scpa1.txt", header = FALSE, sep = ";")
acob = read.csv("aco-scpb1.txt", header = FALSE, sep = ";")
acoc = read.csv("aco-scpc1.txt", header = FALSE, sep = ";")
acod = read.csv("aco-scpd1.txt", header = FALSE, sep = ";")

saa$V3 <- 100*(1-((saa$V2-253)/253))
sab$V3 <- 100*(1-((sab$V2-69)/69))
sac$V3 <- 100*(1-((sac$V2-227)/227))
sad$V3 <- 100*(1-((sad$V2-60)/60))
acoa$V3 <- 100*(1-((acoa$V2-253)/253))
acob$V3 <- 100*(1-((acob$V2-69)/69))
acoc$V3 <- 100*(1-((acoc$V2-227)/227))
acod$V3 <- 100*(1-((acod$V2-60)/60))

interpsaa <- approx(saa$V1, saa$V3)
interpsab <- approx(sab$V1, sab$V3)
interpsac <- approx(sac$V1, sac$V3)
interpsad <- approx(sad$V1, sad$V3)
interpacoa <- approx(acoa$V1, acoa$V3)
interpacob <- approx(acob$V1, acob$V3)
interpacoc <- approx(acoc$V1, acoc$V3)
interpacod <- approx(acod$V1, acod$V3)

modsaa <- lm(interpsaa$y ~ poly(interpsaa$x,5))
modsab <- lm(interpsab$y ~ poly(interpsab$x,5))
modsac <- lm(interpsac$y ~ poly(interpsac$x,5))
modsad <- lm(interpsad$y ~ poly(interpsad$x,5))
modacoa <- lm(interpacoa$y ~ poly(interpacoa$x,5))
modacob <- lm(interpacob$y ~ poly(interpacob$x,5))
modacoc <- lm(interpacoc$y ~ poly(interpacoc$x,5))
modacod <- lm(interpacod$y ~ poly(interpacod$x,5))

predicted.intervals.saa <- predict(model,data.frame(x=interpsaa$x),interval='confidence',level=0.99)
predicted.intervals.sab <- predict(model,data.frame(x=interpsab$x),interval='confidence',level=0.99)
predicted.intervals.sac <- predict(model,data.frame(x=interpsac$x),interval='confidence',level=0.99)
predicted.intervals.sad <- predict(model,data.frame(x=interpsad$x),interval='confidence',level=0.99)
predicted.intervals.acoa <- predict(model,data.frame(x=interpacoa$x),interval='confidence',level=0.99)
predicted.intervals.acob <- predict(model,data.frame(x=interpacob$x),interval='confidence',level=0.99)
predicted.intervals.acoc <- predict(model,data.frame(x=interpacoc$x),interval='confidence',level=0.99)
predicted.intervals.acod <- predict(model,data.frame(x=interpacod$x),interval='confidence',level=0.99)

plot(1, main="title", sub="subtitle", xlab="X-axis label", ylab="y-axix label", xlim=c(0, 50000), ylim=c(85, 100))

lines(interpsaa$x,predicted.intervals.saa[,1],col='green')
lines(interpsab$x,predicted.intervals.sab[,1],col='blue')
lines(interpsac$x,predicted.intervals.sac[,1],col='red')
lines(interpsad$x,predicted.intervals.sad[,1],col='black')
lines(interpacoa$x,predicted.intervals.acoa[,1],col='green', lwd=3)
lines(interpacob$x,predicted.intervals.acob[,1],col='blue', lwd=3)
lines(interpacoc$x,predicted.intervals.acoc[,1],col='red', lwd=3)
lines(interpacod$x,predicted.intervals.acod[,1],col='black', lwd=3)

plot(1, main="Quality - Time", xlab="CPU - Time (milliseconds)", ylab="Quality (%)", xlim=c(0, 55000), ylim=c(85, 100))

lines(interpsaa$x,predicted.intervals.saa[,1],col='green')
lines(interpsab$x,predicted.intervals.sab[,1],col='blue')
lines(interpsac$x,predicted.intervals.sac[,1],col='red')
lines(interpsad$x,predicted.intervals.sad[,1],col='black')
lines(interpacoa$x,predicted.intervals.acoa[,1],col='green', type="c")
lines(interpacob$x,predicted.intervals.acob[,1],col='blue', type="c")
lines(interpacoc$x,predicted.intervals.acoc[,1],col='red', type="c")
lines(interpacod$x,predicted.intervals.acod[,1],col='black', type="c")

legend(1, 95, legend=c("SA - SCPA1", "SA - SCPB1", "SA - SCPC1", "SA - SCPD1", "ACO - SCPA1", "ACO - SCPB1", "ACO - SCPC1", "ACO - SCPD1"), col=c("green", "blue", "red", "black", "green", "blue", "red", "black"), lty=c(1,1,1,1,2,2,2,2), cex=0.8)


test_that("dates in segment annotation work", {
  dt <- structure(list(month = structure(c(1364774400, 1377993600),
      class = c("POSIXct", "POSIXt"), tzone = "UTC"), total = c(-10.3,
      11.7)), .Names = c("month", "total"), row.names = c(NA, -2L), class =
      "data.frame")

  p <- ggplot(dt, aes(month, total)) +
    geom_point() +
    annotate("segment",
      x = as.POSIXct("2013-04-01"),
      xend = as.POSIXct("2013-07-01"),
      y = -10,
      yend = 10
    )

  expect_true(all(c("xend", "yend") %in% names(layer_data(p, 2))))
})

test_that("segment annotations transform with scales", {
  # Line should match data points
  df <- data_frame(x = c(1, 10), y = c(10, 1))
  plot <- ggplot(df, aes(x, y)) +
    geom_point() +
    annotate("segment", x = 1, y = 10, xend = 10, yend = 1, colour = "red") +
    scale_y_reverse(NULL, breaks = NULL) +
    scale_x_continuous(NULL, breaks = NULL)

  expect_doppelganger("line matches points", plot)
})

test_that("annotation_* has dummy data assigned and don't inherit aes", {
  skip_if(packageVersion("base") < "3.5.0")
  custom <- annotation_custom(zeroGrob())
  logtick <- annotation_logticks()
  library(maps)
  usamap <- map_data("state")
  map <- annotation_map(usamap)
  rainbow <- matrix(hcl(seq(0, 360, length.out = 50 * 50), 80, 70), nrow = 50)
  raster <- annotation_raster(rainbow, 15, 20, 3, 4)
  dummy <- dummy_data()
  expect_equal(custom$data, dummy)
  expect_equal(logtick$data, dummy)
  expect_equal(map$data, dummy)
  expect_equal(raster$data, dummy)

  expect_false(custom$inherit.aes)
  expect_false(logtick$inherit.aes)
  expect_false(map$inherit.aes)
  expect_false(raster$inherit.aes)
})


ml.datasets.df <- as.data.frame(fread(paste(output.local.data.dir,"ml-dataset-summaries-clustered.csv",sep="")))
dataset.names <- sort(unique(ml.datasets.df$dataset))

final.weights.viz.df <- NULL
for(this.dataset in dataset.names){

  # this.dataset <- dataset.names[1]
  print(paste0("Preparing: ", this.dataset))

  this.dataset.metadata <- subset(ml.datasets.df, dataset == this.dataset)

  load(file=paste0(output.data.dir, "saved-weights/", this.dataset, "-weights-list.RData"))
  load(file=paste0(output.data.dir, "saved-weights/", this.dataset, "-dropout-weights-list.RData"))

  activation.hash <- hash()
  .set(activation.hash, "rectifier", dnn.weights.list)
  .set(activation.hash, "RectifierWithDropout", dnn.dropout.weights.list)

  this.weights.df <- NULL
  activation.types <- keys(activation.hash)
  for(activation.type in activation.types){

    layer.index <- 0
    dnn.weights.list <- activation.hash[[activation.type]]
    n.layers <- length(dnn.weights.list)

    for(dnn.layer.weights in dnn.weights.list){

      layer.index <- layer.index + 1
      if(layer.index == 1 || layer.index == n.layers){
        next
      }else{
        n.cols <- ncol(dnn.layer.weights); n.rows <- nrow(dnn.layer.weights)
        prefix <- paste0("h",layer.index,"_w")
        for(col in 1:n.cols){
          this.label <- paste0(prefix, (col-1))
          these.labels <- paste(this.label, 0:(n.rows-1), sep="")
          these.values <- dnn.layer.weights[,col]
          this.weights.df <- rbind(this.weights.df, data.frame(weightid=these.labels, weight=these.values,activation.type=activation.type))
        }
      }
    }
  }

  this.weights.df <- cbind(this.weights.df, this.dataset.metadata)

  final.weights.viz.df <- rbind(final.weights.viz.df, this.weights.df)

}

final.weights.viz.df$layer[grepl("h2", final.weights.viz.df$weightid, fixed = TRUE)] <- "Hidden2"
final.weights.viz.df$layer[grepl("h3", final.weights.viz.df$weightid, fixed = TRUE)] <- "Hidden3"
final.weights.viz.df$layer[grepl("h4", final.weights.viz.df$weightid, fixed = TRUE)] <- "Hidden4"

write.table(final.weights.viz.df, file = paste(output.local.data.dir, "annotated-weights-data.csv",sep=""),row.names=FALSE, sep=",", na="")

final.weights.viz.df.metadata <- subset(final.weights.viz.df, select=-weight)
final.weights.viz.df.weights <- subset(final.weights.viz.df, select=c(weightid, weight))

final.weights.viz.df.weights$one <- 1
final.weights.viz.df.weights.wide <- final.weights.viz.df.weights %>% group_by(weightid) %>% mutate(cumsum = cumsum(one))
final.weights.viz.df.weights.wide <- subset(final.weights.viz.df.weights.wide, select=-one)
final.weights.viz.df.weights.wide <- arrange(final.weights.viz.df.weights.wide, weightid)
final.weights.viz.df.weights.wide <- as.data.frame(final.weights.viz.df.weights.wide)
final.weights.viz.df.weights.wide <- reshape(final.weights.viz.df.weights.wide, timevar = "cumsum",idvar = "weightid",v.names = "weight",direction = "wide")
head(final.weights.viz.df.weights.wide)

final.weights.viz.df.weights.wide$layer[grepl("h2", final.weights.viz.df.weights.wide$weightid, fixed = TRUE)] <- "Hidden2"
final.weights.viz.df.weights.wide$layer[grepl("h3", final.weights.viz.df.weights.wide$weightid, fixed = TRUE)] <- "Hidden3"
final.weights.viz.df.weights.wide$layer[grepl("h4", final.weights.viz.df.weights.wide$weightid, fixed = TRUE)] <- "Hidden4"

n.cols <- ncol(final.weights.viz.df.weights.wide)
final.weights.viz.df.weights.wide <- final.weights.viz.df.weights.wide[,c(1,n.cols, 2:(n.cols-1))]


#' Return dimension names of an array respecting the number of dimensions
#'
#' Act on each element if 'x' is a list
#'
#' @param x      An n-dimensional array
#' @param along  Limit to dimension (default: all)
#' @param null_as_integer  Whether nameless dimensions should be \code{NULL} or
#'               numbered
#' @param drop   Drop list of only one axis requested (default: if not
#'               returning all dimensions)
#' @return       A list of dimension names with length \code{length(ndim(X))}
#' @export
dimnames = function(x, along=TRUE, null_as_integer=FALSE, drop=!identical(along, TRUE)) {
    if (is.list(x) && !is.data.frame(x))
        return(lapply(x, function(x1) dimnames(x1, along=along,
                    null_as_integer=null_as_integer, drop=drop)))
    if (is.data.frame(x))
        x = as.matrix(x)
    if (is.vector(x)) {
        x = as.array(x)
        if (!identical(along, TRUE))
            along = 1
    }

    dn = base::dimnames(x)

    if (is.null(dn))
        dn = base::rep(list(NULL), length(dim(x)))

    if (null_as_integer == TRUE && length(dn) > 0)
        dn = lapply(1:length(dn), function(i) {
            if (is.null(dn[[i]]))
                seq_len(dim(x)[i])
            else
                dn[[i]]
        })

    if (length(along) == 1 && drop==TRUE)
        dn[[along]]
    else
        dn[along]
}


setwd("/home/remoteuser/Code/ROnAzure")
source("SetComputeContext.r")

# For local compute context, skip the following line
startRxSpark()

finalData <- RxXdfData(file.path(dataDir, "airDFXDFSubset"))

################################################
# Split out Training and Test Datasets
################################################

# split out the training data

trainDS <- RxXdfData( file.path(dataDir, "finalDataTrainSubset" ))

rxDataStep( inData = finalData, outFile = trainDS,
            rowSelection = ( Year != 2012 ), overwrite = T )

# split out the testing data

testDS <- RxXdfData( file.path(dataDir, "finalDataTestSubset" ))

rxDataStep( inData = finalData, outFile = testDS,
            rowSelection = ( Year == 2012 ), overwrite = T )

# system('hadoop fs -ls /user/RevoShare/remoteuser/Data')

################################################
# Train and Test a Logistic Regression model
################################################

formula <- as.formula(ArrDel15 ~ Month + DayofMonth + DayOfWeek + Carrier + OriginAirportID +
                        DestAirportID + CRSDepTime + CRSArrTime)

# Use the scalable rxLogit() function

logitModel <- rxLogit(formula, data = trainDS)

options(max.print = 100)
base::summary(logitModel)

# Predict over test data (Logistic Regression).

logitPredict <- RxXdfData(file.path(dataDir, "logitPredictSubset"))

# Use the scalable rxPredict() function

rxPredict(logitModel, data = testDS, outData = logitPredict,
          extraVarsToWrite = c("ArrDel15"),
          type = 'response', overwrite = TRUE)

# Calculate ROC and Area Under the Curve (AUC).

logitRoc <- rxRoc("ArrDel15", "ArrDel15_Pred", logitPredict)
logitAuc <- rxAuc(logitRoc)

plot(logitRoc)

save(logitModel, file = "logitModelSubset.RData")

# For local compute context, skip the following line
rxSparkDisconnect(rxGetComputeContext())

Applied Machine Learning for Developers/R server Tools for scaling R using Azure/code/ROnAzure/2-Train-Test-Subset.r


#' Expand a PhenoCam time series from 3-day to a 1-day time step
#'
#' Necessary step to guarantee consistent data processing between 1 and 3-day
#' data products. .
#'
#' @param data a PhenoCam dataframe from API
#' @param truncate year (numerical), limit the time series
#' to a particular year (default = NULL)
#' (\code{TRUE} = default/ \code{FALSE} )
#' @return Expanded PhenoCam data structure or file, including 90 day padding
#' if requested.
#' @keywords time series, post-processing, phenocam

expand_phenocam = function(phenocam_data,
                           truncate = NULL,
                           internal = TRUE,
                           out_dir = tempdir()) {

  # convert dates
  phenocam_data$dates = as.Date(phenocam_data$date)

  ## # remove dates that were filled before expanding again
  ## # this is similar to phenocam_contract() but includes
  ## # the removal of the padding

  # truncate the data if necessary
  max_date = max(phenocam_data$date)

  # pad with 90 days (regardless)
  min_range = min(phenocam_data$date) - 90
  max_range = max(phenocam_data$date) + 90

  # create vectors to populate final output with
  all_dates = seq(as.Date(min_range), as.Date(max_range), "days")
  all_years = as.integer(format(all_dates, "%Y"))
  all_doy = as.integer(format(all_dates, "%j"))

  # create data frame with dates to merge with original data
  all_dates = as.data.frame(all_dates)
  colnames(all_dates) = "date"

  output=left_join(all_dates, phenocam_data)
  output$year = all_years
  output$doy = all_doy

  # stuff expanded data back into original data structure
  data = output

#return data

    return(data)

}


#' @export
#' @title Bounding box of zeros around Cardinaldata
#' @description Adds zeros around "MSImageSet" object to so that datasets can be combined after registration
#' @param cardinaldata an object of class "MSImageSet"
#' @param xmax maximum of bounding box in x
#' @param ymax maximum of bounding box in y
#' @param boolean, whether to center the imaging data in the bounding box
#' @return msset an object of class "MSImageSet"

boundBox <- function(cardinaldata, xmax=300, ymax=250, center=F){

  #size of zero box
  xseq <- c(1:xmax)
  yseq <- c(1:ymax)

  #grab pixel and intensity data
  intensity_data <- data.frame(pData(cardinaldata)[1:2],t(iData(cardinaldata)))

  #make empty data.frame expanded to size of bounding box
  empty_df<-data.frame(expand.grid(xseq,yseq),sampleNames(cardinaldata))
  empty_df[4:(nrow(cardinaldata)+3)] <- 0
  colnames(empty_df) <- c("x","y","sample")

  #sort pixels by x then y
  empty_df <- arrange(empty_df,x,y)
  intensity_data <- arrange(intensity_data,x,y)

  #make character vector of pixel names combining x & y
  zero_pixels  <- paste0("X",empty_df$x,"Y",empty_df$y)

  #center data in bounding box
  if(center == T){
    mpx <- round(max(pData(cardinaldata)$x) / 2, 0)
    mpy <- round(max(pData(cardinaldata)$y) / 2, 0)

    mpx <- (xmax / 2) - mpx
    mpy <- (xmax / 2) - mpy

    cdata_pixels <- paste0("X",intensity_data$x + mpx,"Y",intensity_data$y + mpy)

  } else {

    #bounding box extends after the data

    cdata_pixels <- paste0("X",intensity_data$x,"Y",intensity_data$y)

  }

  #fill empty pixels with intensity data
  non_zero_idx = which(zero_pixels %in% cdata_pixels)
  empty_df[non_zero_idx, 4:length(empty_df)] <- intensity_data[3:length(intensity_data)]

  #make cardinal data
  msset <- MSImageSet(spectra=t(empty_df[,4:length(empty_df)]), coord=empty_df[c("x","y","sample")],
                      mz=Cardinal::mz(cardinaldata),
                      processingData = processingData(cardinaldata),
                      protocolData = protocolData(cardinaldata),
                      experimentData = experimentData(cardinaldata))

  msset$binary_mask = 0
  msset$binary_mask[non_zero_idx] = 1

  return(msset)
}


#!/bin/env Rscript

# Copyright (c) 2015 Hanspeter Portner (dev@open-music-kontrollers.ch)
#
# This is free software: you can redistribute it and/or modify
# it under the terms of the Artistic License 2.0 as published by
# The Perl Foundation.
#
# This source is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# Artistic License 2.0 for more details.
#
# You should have received a copy of the Artistic License 2.0
# along the source as a COPYING file. If not, obtain it from
# http://www.perlfoundation.org/artistic_license_2_0.

pdf('stat.pdf')
#svg('33_%02d.svg', width=8, height=8, pointsize=16)

{
	f <- file('stat.dump.osc', 'rb')

	head <- readChar(f, 8)
	srate <- readBin(f, 'integer', 1, 4, endian='big')

	print(head)
	print(srate)

	a <- NULL
	i <- 0
	while(i < 3000)
	{
		time <- readBin(f, 'integer', 1, 4, endian='big')
		if(!length(time))
			break;
		size <- readBin(f, 'integer', 1, 4, endian='big')
		path <- readChar(f, 8) # '/dump000'
		fmt <- readChar(f, 4) # ',ib0'
		fid <- readBin(f, 'integer', 1, 4, endian='big')
		len <- readBin(f, 'integer', 1, 4, endian='big')
		blob <- readBin(f, 'integer', len/2, 2, endian='big')
		a <- rbind(a, c(blob))

		i <- i + 1
	}

	close(f)
}

{
	mavg <- apply(a, c(2), mean)
	msd <- apply(a, c(2), sd)
	print(summary(msd))

	plot(mavg, type='l', ylim=c(-5,5), col=2, xlab='Sensor', ylab='Mean')
	plot(msd, type='l', ylim=c(0,5), col=2, xlab='Sensor', ylab='Standard deviation')
}

for(path in c('stat.none.osc', 'stat.quadratic.osc', 'stat.catmullrom.osc', 'stat.lagrange.osc'))
{
	print(path)
	f <- file(path, 'rb')

	head <- readChar(f, 8)
	srate <- readBin(f, 'integer', 1, 4, endian='big')

	print(head)
	print(srate)

	a <- NULL
	i <- 0
	while(i< 48000)
	{
		time <- readBin(f, 'integer', 1, 4, endian='big')
		if(!length(time))
			break;
		size <- readBin(f, 'integer', 1, 4, endian='big')
		path <- readChar(f, 8) # '/set0000'
		fmt <- readChar(f, 8) # ',iiiff00'
		sid <- readBin(f, 'integer', 1, 4, endian='big')
		gid <- readBin(f, 'integer', 1, 4, endian='big')
		pid <- readBin(f, 'integer', 1, 4, endian='big')
		x <- readBin(f, 'numeric', 1, 4, endian='big')
		y <- readBin(f, 'numeric', 1, 4, endian='big')
		a <- rbind(a, c(x, y))

		i <- i + 1
	}

	close(f)

	len <- length(a[,1])
	s <- function(o)
	{
		return(c(mean(o), sd(o)))
	}

	dx <- abs(a[2:len,1] - a[1:(len-1),1])
	dx <- dx[dx > 0]
	bx <- log(1/dx) / log(2)
	print(s(bx))
	hist(bx, border=2, breaks=1000, xlab='x-dimension bitdepth', main='', xlim=c(5,20))

#	dz <- abs(a[2:len,2] - a[1:(len-1),2])
#	dz <- dz[dz > 0]
#	bz <- log(1/dz) / log(2)
#	print(s(bz))
#	hist(bz, border=2, breaks=1000, xlab='z-dimension bitdepth', main='', xlim=c(5,20))

	plot(a[,1], type='l', ylim=c(0,1), col=2, xlab='Sample', ylab='x-dimension')
	plot(a[,2], type='l', ylim=c(0,1), col=2, xlab='Sample', ylab='z-dimension')
	plot(a[,2] ~ a[,1], type='l', xlim=c(0,1), ylim=c(0,1), col=2, xlab='x-dimension', ylab='z-dimension')
}

dev.off()


# This is the script for processing Buckingham CGMS data into the common format.
# Author: Rucha Bhat, edited by Shaun Cass
# Date: April 16, 2021

library(tidyverse)
library(magrittr)

# This study downloads as a folder containing data tables and forms
# First download the entire dataset. Do not rename the downloaded folder
# Place the downloaded folder into a folder of your creation specific for this dataset
# You may name your created folder however you like
# Here we have named the created folder by first author last name and date of the original paper
dataset <- "Buckingham2007"
# If you have a different naming method, you will need to adjust this, eg.
# dataset <- "insert_your_name"

# We will set the working directory here in the created folder
setwd(dataset)

# This is the relative path to the Medtronic CGMS CGM file with original names
file.path <- "DirecNetNavigatorPilotStudy/DataTables/tblFNavGlucose.csv"
# Alternatively, if the file structure has been changed, simply place the CGM.txt file into the created folder
# Then run the file path as follows:
# file.path <- "tblCDataCGMS.csv"

# Read the raw data in
curr = read.csv(file.path, header = TRUE, stringsAsFactors = FALSE)

# combine date and time into standard format (POSIX1t format)
curr$time = strptime(paste(as.Date(curr$NavReadDt), curr$NavReadTm),
                     format = "%Y-%m-%d %H:%M:%S")

# reorder and select only id, time, gl columns
curr = curr[, c(2,6,5)]

# Renaming the columns with the standard format names
colnames(curr) = c("id","time","gl")

#Ensure glucose values are recorded as numeric
curr$gl = as.numeric(curr$gl)

# Change all values less than 32 mg/dL and above 450 mg/dL to NA
curr$gl[curr$gl <= 32] <- NA
curr$gl[curr$gl > 450] <- NA

# This dataset has some NA values for glucose readings,
# If you would like to filter them out, simply uncomment this code:
# curr = na.omit(curr)

# The following function is used to remove regions of zero variability
# These regions likely arise from cgm sensor errors.

zero.remove = function(tab){
  tab %>%
    mutate(diff = gl - lag(gl)) %>%
    filter(diff != 0, diff != lag(diff), diff != lag(diff, 2)) %>%
    select(-diff)
}

curr = curr %>% group_split(id) %>% map_dfr(zero.remove)

# Save the cleaned data to the created dataset folder
# The cleaned file will be named "dataset"_processed.csv
write.table(curr, file = paste(dataset, "_processed.csv", sep = ""), row.names = F,
            col.names = !file.exists(paste(dataset, "_processed.csv", sep = "")),
            sep = ",")

# If instead you want to save the cleaned dataset as an .RData file uncomment:
# save(curr, file = paste(dataset, "_processed.RData", sep = ""))


require(tfestimators)
require(nzr)

nzConnectDSN('DBM_SANDBOX')

nzdata <- nzQuery(paste('SELECT * FROM MODEL_12MO_VAL'))

nzDisconnect()

head(nzdata)

vars <- c('SALES_R12','SALES_R24','SALES_R48','SALES_RLT',
          'FISHING_MARINE_SALES_LT','CAMPING_WATERSPORTS_SALES_LT','HUNTING_HUNTCLOTH_SALES_LT',
          'FOOTWEAR_SALES_LT','SHOOTING_SALES_LT','GIFT_SALES_LT','APPAREL_SALES_LT',
          'OTHER_SALES_LT','VISITS_LT','FISH_MARINE_PERC','CAMPING_WATERSPORTS_PERC',
          'HUNTING_PERC','FOOTWEAR_PERC','SHOOTING_PERC','GIFT_PERC','APPAREL_PERC',
          'OTHER_PERC','DAYS_SINCE_PURCHASE','DAYS_AS_CUSTOMER','REWARDS_CUSTOMER',
          'YOY_TREND','SALES_TARGET_N12')

vars.x <- c('SALES_R12','SALES_R24','SALES_R48','SALES_RLT',
            'FISHING_MARINE_SALES_LT','CAMPING_WATERSPORTS_SALES_LT','HUNTING_HUNTCLOTH_SALES_LT',
            'FOOTWEAR_SALES_LT','SHOOTING_SALES_LT','GIFT_SALES_LT','APPAREL_SALES_LT',
            'OTHER_SALES_LT','VISITS_LT','FISH_MARINE_PERC','CAMPING_WATERSPORTS_PERC',
            'HUNTING_PERC','FOOTWEAR_PERC','SHOOTING_PERC','GIFT_PERC','APPAREL_PERC',
            'OTHER_PERC','DAYS_SINCE_PURCHASE','DAYS_AS_CUSTOMER','REWARDS_CUSTOMER',
            'YOY_TREND')
vars.y <- c('SALES_TARGET_N12')

datasub <- nzdata[, vars]

datasub_input_fn <- function(data, num_epochs = 1) {
  input_fn(data,
           features = vars.x,
           response = vars.y,
           batch_size = 64,
           num_epochs = num_epochs)
}

cols <- feature_columns(
  column_numeric('SALES_R12','SALES_R24','SALES_R48','SALES_RLT',
                 'FISHING_MARINE_SALES_LT','CAMPING_WATERSPORTS_SALES_LT','HUNTING_HUNTCLOTH_SALES_LT',
                 'FOOTWEAR_SALES_LT','SHOOTING_SALES_LT','GIFT_SALES_LT','APPAREL_SALES_LT',
                 'OTHER_SALES_LT','VISITS_LT','FISH_MARINE_PERC','CAMPING_WATERSPORTS_PERC',
                 'HUNTING_PERC','FOOTWEAR_PERC','SHOOTING_PERC','GIFT_PERC','APPAREL_PERC',
                 'OTHER_PERC','DAYS_SINCE_PURCHASE','DAYS_AS_CUSTOMER',
                 'YOY_TREND','REWARDS_CUSTOMER')
)

mod = dnn_regressor(hidden_units = c(10, 20, 10),
                    feature_columns = cols,
                    optimizer = "Adagrad",
                    activation_fn = "relu")

indices <- sample(1:nrow(datasub), size=0.80 *nrow(datasub))
train <- datasub[indices, ]
test <- datasub[-indices, ]

mod %>% train(datasub_input_fn(train, num_epochs=10))


##' Produce a table of prevalence ratios in counties
##'
##' @importFrom dplyr mutate select arrange matches left_join
##' @importFrom kableExtra kable add_header_above save_kable
##' @importFrom tools file_ext
##' @param file file name to save the table to (pdf)
##' @return NULL (invisibly)
##' @export
county_table <- function(file = NULL) {

  options(knitr.kable.NA = "")

  ms.R <- ms.tst %>%
    dplyr::select(county, region, pop,
                  dplyr::matches("attendance_[0-9]"),
                  dplyr::matches("positive_[0-9]")) %>%
    simplify_names() %>%
    dplyr::left_join(Rt.county %>%
                     rename(simple_name = county), by = "simple_name") %>%
    dplyr::select(-simple_name) %>%
    mutate(pop = round(pop))

  additional_rows <- ms.R %>%
    mutate(county = if_else(!is.na(attendance_1),
                            "Pilot and Round 1 & 2", NA_character_),
           county = if_else(is.na(county) & !is.na(attendance_3),
                            "Round 1 & 2", county),
           R = NA_real_) %>%
    replace_na(list(county = "Round 1 only")) %>%
    group_by(county) %>%
    summarise_if(is.numeric, sum) %>%
    mutate(level = "zaggregate")

  print_table <- ms.R %>%
    mutate(level = "acounty") %>%
    bind_rows(additional_rows) %>%
    mutate(pilot_prev = round(positive_1 / attendance_1 * 100, 2),
           round2_prev = round(positive_2 / attendance_2 * 100, 2),
           round3_prev = round(positive_3 / attendance_3 * 100, 2),
           R = round(R, 1)) %>%
    select(level, county, region, pop, R,
           ends_with("_1"), pilot_prev,
           ends_with("_2"), round2_prev,
           ends_with("_3"), round3_prev) %>%
    arrange(level, county) %>%
    select(-level)

  if (!is.null(file)) {
    col.names <-
      c("County", "Region", "Population", "R",
        rep(c("Positive", "Attendance", "%"), times = 3))

    if (file_ext(file) == "pdf") {
      format <- "latex"
    } else if (file_ext(file) == "html") {
      format <- "html"
    }

    k <- kable(print_table,
               format = format,
               col.names = col.names,
               align = c('l', 'l', 'r', 'r', rep('r', 3), 'r',
                         rep('r', 2), 'r', rep('r', 2)),
               booktabs = TRUE) %>%
      pack_rows(index = c("County level" = nrow(ms.R),
                          "Aggregate level" = nrow(additional_rows)))

    k <-
      add_header_above(k, c(" " = 4, "Pilot" =  3,
                            "Round 1" = 3, "Round 2" = 3))

    save_kable(k, file)
    invisible(NULL)
  } else {
    return(print_table)
  }
}


library(changepoint)
library(jsonlite)
library("rjson")

file_names = list.files(path = "E:\\project\\20160517_testfile_device_id", pattern = NULL, all.files = FALSE, full.names = FALSE, recursive = FALSE, ignore.case = FALSE, include.dirs = FALSE, no.. = FALSE)

i = 1
id = vector()
device_cpt = vector()
gps_lat = vector()
gps_lon = vector()
for (json_file in file_names){
	#-----------------$device_id $gps_lat $gps_lon $s_d0(pm2.5值) $time------------------#
	my_path = paste0("E:\\project\\20160517_testfile_device_id\\", json_file)
	json_data <- fromJSON(file=my_path)
	if(length(json_data$s_d0) < 30) next
	#-------------change in mean and variance--------------#
	ansmeanvar=cpt.meanvar(json_data$s_d0)

	ch_id <- cpts(ansmeanvar) #回傳編號
	ch_time <- json_data$time[ch_id]

	#print(ch_time)

	id[i] = json_data$device_id
	gps_lat[i] = json_data$gps_lat
	gps_lon[i] = json_data$gps_lon
	device_cpt[i] = ch_time
	i = i+1

	#pic
	if(is.na(ch_id)) {
			print(i)
			next
		}
	zz_b = 1:ch_id
	xx_b = json_data$time[zz_b]
	yy_b = rep(mean(json_data$s_d0[zz_b]), times = length(zz_b))
	zz_f = (ch_id+1):length(json_data$s_d0)
	xx_f = json_data$time[zz_f]
	yy_f = rep(mean(json_data$s_d0[zz_f]), times = length(zz_f))
	plot(as.POSIXct(strptime(json_data$time, "%H:%M:%S")), json_data$s_d0 ,type = "l", xlab = "PM2.5", ylab = "Time")
	lines(xx_b,yy_b,col="red")
	lines(xx_f,yy_f,col="red")

	#curve(x=sensor_of_day$PM25[ch_id],as.numeric(sensor_of_day$f_time[1]), as.numeric(sensor_of_day$f_time[ch_id]))

	pic_name <- paste0("E:\\LASS_Graph\\", i,".png")
	dev.copy(png,pic_name)
	dev.off()
}

device_order <- as.integer( as.POSIXct(strptime(device_cpt, "%H:%M:%S")) )
data_end <- data.frame(id, gps_lat, gps_lon, device_cpt, device_order)
write.table(data_end, file = "E:\\20160517_testfile_device_id\\test.CSV", sep = ",")


print(paste0(Sys.time(), " --- Describers profiles (for appendix)"))
des <- df_describers[, c("full.name.of.describer.n", "last.name",
                         "spp_per_pub_mean", "n_pubs",
                         "spp_per_pub_mean_20y", "n_pubs_20y",
                         "spp_per_pub_mean_5y", "n_pubs_5y",
                         "n_spp_20y", "n_spp_5y",
                         "dob.describer.n", "dod.describer.n",
                         "spp_N",
                         "max", "pub_years")]
des$dod.describer.n <- as.numeric(des$dod.describer.n)
des$dob.describer.n <- as.numeric(des$dob.describer.n)
des$max <- as.numeric(des$max)

des <- des[!(is.na(dod.describer.n) | is.na(dob.describer.n))]
dim(des)
des$years_last_pub_death <- des$dod.describer.n - des$max
des$age_at_death <- des$dod.describer.n - des$dob.describer.n

mround <- function(x,base) base*round(x/base)
des$date.century <- substr(as.character((des$dod.describer.n - des$dob.describer.n)/2 +
    des$dob.describer.n), 1, 3)
# des$date.century <- substr(as.character(des$dob.describer.n), 1, 3)
des$date.century <- mround(as.numeric(des$date.century), 5)
des$date.century <- paste0(des$date.century, "0s")
table(des$date.century)

des$check_young <- ifelse(des$age_at_death >=40, "T", "F") #young
des$check_few.spp <- ifelse(des$spp_N <= 12, "T", "F") #few spp (than median)
des$check_few.spp.pub <- ifelse(des$spp_per_pub_mean <=10, "T", "F") #few spp/pub
des$check_few.pub <- ifelse(des$n_pubs <=3, "T", "F") # few pub
des$check_few.pub.near.death <- ifelse(is.na(des$n_spp_20y), "T", ifelse(
    des$n_spp_20y/des$spp_N >=0.8, "F", "T")) # few pub

summary(des$age_at_death)

des0 <- des[, list(names=paste0(full.name.of.describer.n, collapse="; "),
                   med_age_at_death=median(age_at_death, na.rm=T),
                   med_spp_N = median(as.numeric(spp_N), na.rm=T),
                   med_spp_per_pub_mean = median(spp_per_pub_mean, na.rm=T),
                   med_prop_20y = median(n_spp_20y/spp_N, na.rm=T)
                   ),
            by=c("check_young")]

des1 <- des[, list(names=paste0(full.name.of.describer.n, collapse="; "),
                   med_age_at_death=median(age_at_death, na.rm=T),
                   med_spp_N = median(as.numeric(spp_N), na.rm=T),
                   med_spp_per_pub_mean = median(spp_per_pub_mean, na.rm=T),
                   med_prop_20y = median(n_spp_20y/spp_N, na.rm=T)
                   ),
    by=c("check_young", "check_few.spp", "check_few.spp.pub", "check_few.pub.near.death")]

des2 <- des[, list(.N),
    by=c("check_young", "check_few.spp", "check_few.spp.pub", "check_few.pub.near.death", "date.century")]

des3 <- dcast(des2,
              check_young + check_few.spp.pub + check_few.pub.near.death + check_few.spp  ~ date.century,
              value.var="N", fun=sum)
des4 <- merge(des1, des3,
              by=c("check_young", "check_few.spp.pub", "check_few.pub.near.death", "check_few.spp"))

write.csv(des4, paste0(dir_data_ch1, '2019-10-02-taxonomist-one-large-mono.csv'),
          row.names=F)

# Checks
table(is.na(des$check_young))
table(is.na(des$check_few.spp))
table(is.na(des$check_few.spp.pub))
table(is.na(des$check_few.pub.near.death))

# Throughout life proportion
auth_throughout_life <- table(des[check_young=="T",]$check_few.pub.near.death)
prop.table(auth_throughout_life)*100

# Group that died young, few publications, few species, average number of species per pub
# Group that did not die young, few publications, few species, average number of species per pub
# Group that did not die young, large number of publications, large number of species, large number of species per pub
# Group that did not die young, few publications, large number of species {N and when}


###Analysis to see the model assumptions.
# Question to ask ? is it necessary to run a complex model or a simple linear model??
#
#   Y=a+b+e or Y=a+b+c*e   is c necessary? is this a constant error or not??
#
# ANSWER: 1.definitely the array effects due to primary or secondary antibodies
#		are multiplicative instead of simply additive. Please see the results
#		in Analysis_proteinWithControl.r
# 		2. the block effects are checked in this analysis.
#
# only if you install a Bioconductor package for the first time
# source("http://www.bioconductor.org/biocLite.R")
# # else
# library("BiocInstaller")
# biocLite("PAA", dependencies=TRUE)

 #library(PAA)

library(ARPPA) #this is the my own package to run analysis

#now start reading the text exported data
#this is the batch done on 10/08/2015
datapath<-system.file("extdata", package="ARPPA")
targets <- list.files(system.file("extdata", package="ARPPA"),
	 pattern = "targets_text_Batch1", full.names=TRUE)
elist2<-importTextData(dataFilePath=datapath, targetFile=targets, start.data=51, nrows.data=18803-53,
			start.control=18803, nrows.control=23286,aggregation="geoMean",
			as.is=TRUE, header=TRUE,sep="\t",na.strings="", quote="")

#===>background correction
library(limma)

elist2 <- backgroundCorrect(elist2, method="normexp",
 normexp.method="saddle")

 #now we need to rearrange the control and testing proteins to background correct control
 #it works this way that background correction only working on elist$E
 #so we have to do the rearrangement
 elist_c<-elist2
 elist_c$E<-elist2$C
 elist_c$Eb<-elist2$Cb
 #this is good enough, we don't have to change elistC$C, since other fields are not touched
 elist_c<-backgroundCorrect(elist_c, method="normexp",
 normexp.method="saddle")

 #now change it back
 elist2$C<-elist_c$E
 elist2$Cb<-elist_c$Eb
 ##=====>end of background correction

 indices<-grep("HumanIgG", elist2$cgenes$Name)
 elist2$cgenes[indices,]

#now we need to start checking the error models
# we need to check the block effects

 setwd("E:\\feng\\LAB\\MSI\\AbSynthesis\\proteinArray\\Run2015_10_08\\AnalysisResults");
groups<-c("HumanIgG",
			"HumanIgG", "Anti-HumanIgG",
			"Anti-HumanIgG1","Anti-HumanIgG2","Anti-HumanIgG3","Anti-HumanIgG4",
			"HumanIgG1","HumanIgG2","HumanIgG3","HumanIgG4"
			)
 #first plot the all IgGs
indices<-grep(groups[1], elist2$cgenes$Name)
expByBlock<-cbind(elist2$C[indices,],elist2$cgenes[indices,c("Block","Name")])

pdf("BlockEffects_100082015_poolAllIgGs.pdf")
op<-par(mfrow=c(3,2),
	pty="m" #"s" for square, "m" for maximal plot area
	)
numArrays<-length(colnames(elist2$C))
#by each array now
for(i in c(1:length(colnames(elist2$C))))#<-1 ##array one
{
	arrayName<-colnames(elist2$C)[i]
	#colnames(expByBlock)<-paste("a",colnames(expByBlock),sep="")
	boxplot(expByBlock[,i]~Block, data=expByBlock,log="y",
		main=paste("Array ",arrayName, sep=""),
		xlab="Block",ylab="Expression (log)",
		ylim=c(min(expByBlock[,c(1:numArrays)]),max(expByBlock[,c(1:numArrays)])),
		col=i+1
		)
 }
 par(op)
 dev.off()

#second plot the all anti-IgGs
for(k in c(2:length(groups)))
{
	indices<-grep(paste("^",groups[k],sep=""), elist2$cgenes$Name)
	expByBlock<-cbind(elist2$C[indices,],elist2$cgenes[indices,c("Block","Name")])
	numArrays<-length(colnames(elist2$C))

	pdf(paste("BlockEffects_100082015_",groups[k],".pdf",sep=""))
	op<-par(mfrow=c(3,2),
		pty="m" #"s" for square, "m" for maximal plot area
		)

	#by each array now
	for(i in c(1:length(colnames(elist2$C))))#<-1 ##array one
	{
		arrayName<-colnames(elist2$C)[i]
		#colnames(expByBlock)<-paste("a",colnames(expByBlock),sep="")
		boxplot(expByBlock[,i]~Block, data=expByBlock,log="y",
			main=paste("Array ",arrayName, sep=""),
			xlab="Block",ylab="Expression (log)",
			ylim=c(min(expByBlock[,c(1:numArrays)]),max(expByBlock[,c(1:numArrays)])),
			col=i+1
			)
	 }
	 par(op)
	 dev.off()
}

 ####code to "debugging"
 ctrData_IgG<-elist3_c$E[indices,]
 indices<-grep("HumanIgG1", elist3_c$genes$Name)
 ctrData_IgG1<-elist3_c$E[indices,]
boxplot(ctrData_IgG1)
 indices<-grep("HumanIgG2", elist3_c$genes$Name)
 ctrData_IgG2<-elist3_c$E[indices,]
boxplot(ctrData_IgG2)
indices<-grep("HumanIgG3", elist3_c$genes$Name)
 ctrData_IgG3<-elist3_c$E[indices,]
 ctrData_IgG3N<-cbind(ctrData_IgG3,elist3_c$genes$Name[indices])
boxplot(ctrData_IgG3)
indices<-grep("HumanIgG4", elist3_c$genes$Name)
 ctrData_IgG4<-elist3_c$E[indices,]
boxplot(ctrData_IgG4)


#DECKER_INFO640_Final_Project_Code
#John Decker
#INFO 640
#Prof. McSweeney
#Fall, 2020
#Pratt Institute

#R-code
#load libraries
library(lubridate)
library(tidyverse)
library(readxl)
library(gmodels)
library(dplyr)
library(ggthemes)

#load congress information
congress <- read.csv("~/Documents/GitHub/R_work/data/Congressional_Majorities_1970_2020.csv")
head(congress)

#read in dataset with NEA data
nea_funding_data <- read.csv("~/Documents/GitHub/R_work/data/State_Arts_Funding_w_NEA_data_and_Majority.csv")
names(nea_funding_data)

#strip dollar signs from dollar amount columns
nea_funding_data$Total.Legislative.Appropriations <- gsub("\\$", "", nea_funding_data$Total.Legislative.Appropriations)
nea_funding_data$Total.Other.State.funding <- gsub("\\$", "", nea_funding_data$Total.Other.State.funding)
nea_funding_data$Total.National.Endowment.for.the.Arts.Funding <- gsub("\\$", "", nea_funding_data$Total.National.Endowment.for.the.Arts.Funding)
nea_funding_data$Total.Private.and.Misc..Funding <- gsub("\\$", "", nea_funding_data$Total.Private.and.Misc..Funding)
nea_funding_data$Total.Revenue <- gsub("\\$", "", nea_funding_data$Total.Revenue)

#strip commas from dollar amount columns
nea_funding_data$Total.Legislative.Appropriations <- gsub(",", "", nea_funding_data$Total.Legislative.Appropriations)
nea_funding_data$Total.Other.State.funding <- gsub(",","", nea_funding_data$Total.Other.State.funding)
nea_funding_data$Total.National.Endowment.for.the.Arts.Funding <- gsub(",", "", nea_funding_data$Total.National.Endowment.for.the.Arts.Funding)
nea_funding_data$Total.Private.and.Misc..Funding <- gsub(",", "", nea_funding_data$Total.Private.and.Misc..Funding)
nea_funding_data$Total.Revenue <- gsub(",", "", nea_funding_data$Total.Revenue)

#convert dollar amount columns to numeric
nea_funding_data$Total.Legislative.Appropriations <- as.numeric(nea_funding_data$Total.Legislative.Appropriations, rm.na = TRUE)
nea_funding_data$Total.Other.State.funding <- as.numeric(nea_funding_data$Total.Other.State.funding, rm.na = TRUE)
nea_funding_data$Total.National.Endowment.for.the.Arts.Funding <- as.numeric(nea_funding_data$Total.National.Endowment.for.the.Arts.Funding, rm.na = TRUE)
nea_funding_data$Total.Private.and.Misc..Funding <- as.numeric(nea_funding_data$Total.Private.and.Misc..Funding, rm.na=TRUE)
nea_funding_data$Total.Revenue <- as.numeric(nea_funding_data$Total.Revenue, rm.na=TRUE)

#initial analysis of funding data
summary(nea_funding_data)

#separate out states with high, medium, and low state-wide arts funding
nea_just_cali <- nea_funding_data %>% filter(State.or.Jurisdiction == "California")
nea_just_tx <- nea_funding_data %>% filter(State.or.Jurisdiction == "Texas")
nea_just_ny <- nea_funding_data %>% filter(State.or.Jurisdiction == "New York")
nea_just_il <- nea_funding_data %>% filter(State.or.Jurisdiction == "Illinois")
nea_just_ak <- nea_funding_data %>% filter(State.or.Jurisdiction == "Alaska")
nea_just_nv <- nea_funding_data %>% filter(State.or.Jurisdiction == "Nevada")

#calculate mean for all of the test states
total_test_state_mean <-(mean(nea_just_cali$Total.National.Endowment.for.the.Arts.Funding) + mean(nea_just_tx$Total.National.Endowment.for.the.Arts.Funding) + mean(nea_just_ny$Total.National.Endowment.for.the.Arts.Funding) + mean(nea_just_il$Total.National.Endowment.for.the.Arts.Funding) + mean(nea_just_ak$Total.National.Endowment.for.the.Arts.Funding) + mean(nea_just_nv$Total.National.Endowment.for.the.Arts.Funding))/6

#t test for all states in unadjusted dollars
t.test(nea_funding_data$Total.National.Endowment.for.the.Arts.Funding~nea_funding_data$Congress.Majority)

#subset all state data for culture wars period
culture_wars_states_rep_maj <- nea_funding_data %>% filter(Fiscal.Year >= 1995)

#t test for all states in unadjusted dollars from 1995 to 2020
t.test(culture_wars_states_rep_maj$Total.National.Endowment.for.the.Arts.Funding~culture_wars_states_rep_maj$Congress.Majority)

# move to dataset with inflation adjusted dollars to refine testing
nea_adjusted_data <-read.csv("~/Documents/GitHub/R_work/data/nea_adjusted_to_2020_w_majority_and_gdp.csv")
head(nea_adjusted_data)
#t test for aggregated appropriations in unadjusted dollars
t.test(nea_adjusted_data$Total.NEA.Appropriation~nea_adjusted_data$Congress.Majority)

#t test for aggregated appropriations in adjusted dollars
t.test(nea_adjusted_data$In.2020.Dollars~nea_adjusted_data$Congress.Majority)

#t test for culture wars period in unadjusted dollars
culture_wars <- nea_adjusted_data %>% filter(Fiscal.Year >= 1995)
t.test(culture_wars$Total.NEA.Appropriation~culture_wars$Congress.Majority)

#t test for culture wars period in adjusted dollars
culture_wars <- nea_adjusted_data %>% filter(Fiscal.Year >= 1995)
t.test(culture_wars$In.2020.Dollars~culture_wars$Congress.Majority)

nea_adjusted_data_national <- read.csv("~/Documents/GitHub/R_work/data/national_NEA_appropriations_w_Majority.csv")
head(nea_adjusted_data_national)

#examine national appropriations to test hypothesis
#t test for all states in unadjusted dollars (Congress)
t.test(nea_adjusted_data_national$National.NEA.Appropriation~nea_adjusted_data_national$Congress.Majority)

#examine national appropriations to test hypothesis
#t test for all states in 2020 dollars (House)
t.test(nea_adjusted_data_national$Adjusted.National.NEA.Appropriation~nea_adjusted_data_national$Congress.Majority)

#t test for culture wars period in unadjusted dollars for national appropriations (House)
culture_wars_2 <- nea_adjusted_data_national %>% filter(Fiscal.Year >= 1995)
t.test(culture_wars_2$National.NEA.Appropriation~culture_wars_2$Congress.Majority)

#t test for culture wars period in 2020 dollars for national appropriations (House)
culture_wars_2 <- nea_adjusted_data_national %>% filter(Fiscal.Year >= 1995)
t.test(culture_wars_2$Adjusted.National.NEA.Appropriation~culture_wars_2$Congress.Majority)

# Discover for why national nea appropriations show strong congressional effect but weak economic effect and state nea appropriations show the opposite

# linear models for funding by larger economy
funding_lm_just_GDP <- lm(formula = Total.NEA.Appropriation ~ GDP.Per.Capita, data = nea_adjusted_data)

funding_lm_just_GrowthRate <- lm(formula = Total.NEA.Appropriation ~ Growth.Rate, data = nea_adjusted_data)

# multivariable linear model for funding by larger economy
funding_lm_GDP_and_GrowthRate <- lm(formula = Total.NEA.Appropriation ~ Growth.Rate + GDP.Per.Capita, data = nea_adjusted_data)

# multivariable linear model for funding by larger economy with inflation
funding_lm_GDP_GrowthRate_Inflation <- lm(formula = Total.NEA.Appropriation ~ Growth.Rate + GDP.Per.Capita + Avg.Yearly.Inflation, data = nea_adjusted_data)

#report statistics for each model
summary(funding_lm_just_GDP)
summary(funding_lm_just_GrowthRate)
summary(funding_lm_GDP_and_GrowthRate)
summary(funding_lm_GDP_GrowthRate_Inflation)

#use best linear model for test prediction
unknown_funding <- data.frame(Growth.Rate = 3.62, GDP.Per.Capita = 47975.97, Avg.Yearly.Inflation = 2.8)
predict(funding_lm_GDP_GrowthRate_Inflation, unknown_funding)

#code for figures used in paper
#Figure 1
ggplot(nea_adjusted_data, aes(x=Fiscal.Year, y=Total.NEA.Appropriation, color=Congress.Majority)) + geom_line() + scale_y_continuous(labels = scales::comma) +

geom_hline(yintercept = mean(nea_adjusted_data$Total.NEA.Appropriation), color = "dark green", linetype="dashed") +

theme_tufte() +
labs(title = "Total State NEA Funding per Year (in unadjusted dollars)",
     x = "Fiscal Year",
     y = "Dollar Amount",
     tag = "Figure 1",
     caption = "Light Blue = Democratic Majority \nDark Blue = Republican Majority \nGreen = Mean Funding Level") +
theme(legend.position = "none") +
theme(plot.title = element_text(hjust = 0.5)) +
theme(plot.caption = element_text(hjust = 0.0)) +
theme(plot.tag = element_text(size = 10))

#ggsave("Figure1.jpg", width = 6, height = 4)

#Figure 2
ggplot(culture_wars, aes(x=Fiscal.Year, y=Total.NEA.Appropriation, color=Congress.Majority)) + geom_line() + scale_y_continuous(labels = scales::comma) +

geom_hline(yintercept = mean(culture_wars$Total.NEA.Appropriation), color = "dark green", linetype="dashed") +

theme_tufte() +
labs(title = "State NEA Funding per Year 1995-2020 (in unadjusted dollars)",
     x = "Fiscal Year",
     y = "Dollar Amount",
     tag = "Figure 2",
     caption = "Light Blue = Democratic Majority \nDark Blue = Republican Majority \nGreen = Mean Funding Level") +
theme(legend.position = "none") +
theme(plot.title = element_text(hjust = 0.5)) +
theme(plot.caption = element_text(hjust = 0.0)) +
theme(plot.tag = element_text(size = 10))

#ggsave("Figure2.jpg", width = 6, height = 4)

#Figure 3
ggplot(nea_adjusted_data, aes(x=Fiscal.Year, y=In.2020.Dollars, color=Congress.Majority)) + geom_line() + scale_y_continuous(labels = scales::comma) +

geom_hline(yintercept = mean(nea_adjusted_data$In.2020.Dollars), color = "dark green", linetype="dashed") +

theme_tufte() +
labs(title = "Total State NEA Funding per Year (in 2020 Dollars)",
     x = "Fiscal Year",
     y = "Dollar Amount",
     tag = "Figure 3",
     caption = "Light Blue = Democratic Majority \nDark Blue = Republican Majority \nGreen = Mean Funding Level") +
theme(legend.position = "none") +
theme(plot.title = element_text(hjust = 0.5)) +
theme(plot.caption = element_text(hjust = 0.0)) +
theme(plot.tag = element_text(size = 10))

#ggsave("Figure3.jpg", width = 6, height = 4)

#Figure 4
ggplot(culture_wars, aes(x=Fiscal.Year, y=In.2020.Dollars, color=Congress.Majority)) + geom_line() + scale_y_continuous(labels = scales::comma) +

geom_hline(yintercept = mean(nea_adjusted_data$In.2020.Dollars), color = "dark green", linetype="dashed") +

theme_tufte() +
labs(title = "State NEA Funding 1995-2020 (in 2020 dollars)",
     x = "Fiscal Year",
     y = "Dollar Amount",
     tag = "Figure 4",
     caption = "Light Blue = Democratic Majority \nDark Blue = Republican Majority \nGreen = Mean Funding Level (in 2020 dollars)") +
theme(legend.position = "none") +
theme(plot.title = element_text(hjust = 0.5)) +
theme(plot.caption = element_text(hjust = 0.0)) +
theme(plot.tag = element_text(size = 10))

#ggsave("Figure4.jpg", width = 6, height = 4)

#Figure 5
ggplot(nea_adjusted_data_national, aes(x=Fiscal.Year, y=National.NEA.Appropriation, color=Congress.Majority)) + geom_line() +
  scale_y_continuous(labels = scales::comma) +

geom_hline(yintercept = mean(nea_adjusted_data_national$National.NEA.Appropriation), color = "dark green", linetype="dashed") +

theme_tufte() +
labs(title = "National NEA Funding per Year (in unadjusted dollars)",
     x = "Fiscal Year",
     y = "Dollar Amount",
     tag = "Figure 5",
     caption = "Light Blue = Democratic Majority \nDark Blue = Republican Majority \nHorizontal Green Line = Mean of National NEA Appropriations") +
theme(legend.position = "none") +
theme(plot.title = element_text(hjust = 0.5)) +
theme(plot.caption = element_text(hjust = 0.0)) +
theme(plot.tag = element_text(size = 10))

#ggsave("Figure5.jpg", width = 6, height = 4)

#Figure 6
ggplot(culture_wars_2, aes(x=Fiscal.Year, y=National.NEA.Appropriation, color=Congress.Majority)) + geom_line() +
  scale_y_continuous(labels = scales::comma) +

geom_hline(yintercept = mean(culture_wars_2$National.NEA.Appropriation), color = " dark green", linetype="dashed") +

theme_tufte() +
labs(title = "National NEA Funding 1995-2020 (in unadjusted dollars)",
     x = "Fiscal Year",
     y = "Dollar Amount",
     tag = "Figure 6",
     caption = "Light Blue = Democratic Majority \nDark Blue = Republican Majority \nHorizontal Green Line = Mean of National NEA Appropriations") +
theme(legend.position = "none") +
theme(plot.title = element_text(hjust = 0.5)) +
theme(plot.caption = element_text(hjust = 0.0)) +
theme(plot.tag = element_text(size = 10))

#ggsave("Figure6.jpg", width = 6, height = 4)

#Figure 7
ggplot(nea_adjusted_data_national, aes(x=Fiscal.Year, y=Adjusted.National.NEA.Appropriation, color=Congress.Majority)) + geom_line() +
  scale_y_continuous(labels = scales::comma) +

geom_hline(yintercept = mean(nea_adjusted_data_national$Adjusted.National.NEA.Appropriation), color = "green", linetype="dashed") +

theme_tufte() +
labs(title = "National NEA Funding per Year (in 2020 dollars)",
     x = "Fiscal Year",
     y = "Dollar Amount",
     tag = "Figure 7",
     caption = "Light Blue = Democratic Majority \nDark Blue = Republican Majority \nHorizontal Green Line = Mean of National NEA Appropriations") +
theme(legend.position = "none") +
theme(plot.title = element_text(hjust = 0.5)) +
theme(plot.caption = element_text(hjust = 0.0)) +
theme(plot.tag = element_text(size = 10))

#ggsave("Figure7.jpg", width = 6, height = 4)

#Figure 8
ggplot(culture_wars_2, aes(x=Fiscal.Year, y=Adjusted.National.NEA.Appropriation, color=Congress.Majority)) + geom_line() +
  scale_y_continuous(labels = scales::comma) +

geom_hline(yintercept = mean(culture_wars_2$Adjusted.National.NEA.Appropriation), color = "green", linetype="dashed") +

theme_tufte() +
labs(title = "National NEA Funding 1995-2020 (in 2020 dollars)",
     x = "Fiscal Year",
     y = "Dollar Amount",
     tag = "Figure 8",
     caption = "Light Blue = Democratic Majority \nDark Blue = Republican Majority \nHorizontal Green Line = Mean of National NEA Appropriations") +
theme(legend.position = "none") +
theme(plot.title = element_text(hjust = 0.5)) +
theme(plot.caption = element_text(hjust = 0.0)) +
theme(plot.tag = element_text(size = 10))

#ggsave("Figure8.jpg", width = 6, height = 4)

#Figure 9
#plot several states with vertical lines showing majority change in congress
ggplot(nea_just_cali, aes(x=Fiscal.Year, y=Total.National.Endowment.for.the.Arts.Funding, color = State.or.Jurisdiction)) + geom_line() + scale_y_continuous(labels = scales::comma) +
geom_line(data = nea_just_tx, aes(x=Fiscal.Year, y=Total.National.Endowment.for.the.Arts.Funding, color = State.or.Jurisdiction)) +
geom_line(data = nea_just_ny, aes(x=Fiscal.Year, y=Total.National.Endowment.for.the.Arts.Funding, color = State.or.Jurisdiction)) +
geom_line(data = nea_just_il, aes(x=Fiscal.Year, y=Total.National.Endowment.for.the.Arts.Funding, color = State.or.Jurisdiction)) +
geom_line(data = nea_just_ak, aes(x=Fiscal.Year, y=Total.National.Endowment.for.the.Arts.Funding, color = State.or.Jurisdiction)) +
geom_line(data = nea_just_nv, aes(x=Fiscal.Year, y=Total.National.Endowment.for.the.Arts.Funding, color = State.or.Jurisdiction)) +

#vertical lines for congressional majorities (red = repub, blue = dem)
geom_vline(xintercept = 1995, color = "red", linetype = "dotted") +
geom_vline(xintercept = 2007, color = "blue", linetype = "dotted") +
geom_vline(xintercept = 2011, color = "red", linetype = "dotted") +
geom_vline(xintercept = 2019, color = "blue", linetype = "dotted") +

#mean of funding for all states in sample
geom_hline(yintercept = total_test_state_mean, linetype = "dashed", color = "brown") +

theme_tufte() +
labs(title="NEA Funding by State",
     x = "Fiscal Year",
     y = "NEA Funding Amount",
     color = "State",
     tag = "Figure 9",
     subtitle = "Source: National Assembly of State Arts Agencies, \nAnnual Appropriations and Revenue Survey Data",
     caption = "Red Vertical Lines = Start of Republican Majorty \nBlue Vertical Lines = Start of Democratic Majority\nBrown Horizontal Line = Mean Funding for all Test States") +
theme(plot.title = element_text(hjust = 0.5)) +
theme(plot.subtitle = element_text(hjust = 0.5, size=10)) +
theme(plot.caption = element_text(hjust = 0.0, size=6)) +
theme(plot.tag = element_text(size = 10))

#ggsave("Figure9.jpg", width = 6, height = 4)

#Figure 10
#plot several states with vertical lines showing majority change in congress
ggplot(nea_just_cali, aes(x=Fiscal.Year, y=Total.National.Endowment.for.the.Arts.Funding, color = State.or.Jurisdiction)) + geom_line() + scale_y_continuous(labels = scales::comma) +
geom_line(data = nea_just_tx, aes(x=Fiscal.Year, y=Total.National.Endowment.for.the.Arts.Funding, color = State.or.Jurisdiction)) +
geom_line(data = nea_just_ny, aes(x=Fiscal.Year, y=Total.National.Endowment.for.the.Arts.Funding, color = State.or.Jurisdiction)) +
geom_line(data = nea_just_il, aes(x=Fiscal.Year, y=Total.National.Endowment.for.the.Arts.Funding, color = State.or.Jurisdiction)) +
geom_line(data = nea_just_ak, aes(x=Fiscal.Year, y=Total.National.Endowment.for.the.Arts.Funding, color = State.or.Jurisdiction)) +
geom_line(data = nea_just_nv, aes(x=Fiscal.Year, y=Total.National.Endowment.for.the.Arts.Funding, color = State.or.Jurisdiction)) +

#Vertical lines for major economic events.
#1970s recession 1
geom_vline(xintercept = 1972, color = "gray") +
#1970s recession 2
geom_vline(xintercept = 1976, color = "gray") +
#1980s recession
geom_vline(xintercept = 1982, color = "gray") +
#black monday
geom_vline(xintercept = 1987, color = "gray") +
#1990-1991 recession
geom_vline(xintercept = 1991, color = "gray") +
#major recession tied to Asian Banking Crisis
geom_vline(xintercept = 1997, color = "gray") +
#dot com crash
geom_vline(xintercept = 1999, color = "gray") +
#september 11
geom_vline(xintercept = 2001, color = "gray") +
#2008 recession
geom_vline(xintercept = 2008, color = "gray") +
#global oil drop
geom_vline(xintercept = 2014, color = "gray") +

#mean of funding for all states in sample
geom_hline(yintercept = total_test_state_mean, linetype = "dashed", color = "brown") +

theme_tufte() +
labs(title="NEA Funding by State",
     x = "Fiscal Year",
     y = "NEA Funding Amount",
     color = "State",
     tag = "Figure 10",
     subtitle = "Source: National Assembly of State Arts Agencies, \nAnnual Appropriations and Revenue Survey Data",
     caption = "Brown Horizontal Line = Mean Funding for all Test States \nGray Vertical Lines = Major Economic Events \n\t\tMajor Recession: 1970, Major Recession: 1976, Major Recession: 1982 \n\t\tBlack Monday: 1987, Major Recession: 1990-91, Asian Banking Crisis: 1997, Dot Com Crash: 1999 \n\t\t9/11: 2001, Great Recession: 2008, Global Oil Drop: 2014") +
theme(plot.title = element_text(hjust = 0.5)) +
theme(plot.subtitle = element_text(hjust = 0.5, size=10)) +
theme(plot.caption = element_text(hjust = 0.0, size=6)) +
theme(plot.tag = element_text(size = 10))

#ggsave("Figure10.jpg", width = 6, height = 4)

#Figure 11

# scale amount used to adjust total dollars to amount in thousands of dollars so that both measures are the same scale
scale_amount = 1000

ggplot(nea_adjusted_data, aes(x=Fiscal.Year, y= GDP.Per.Capita)) + geom_line(color="blue") +
  geom_line(data=nea_adjusted_data, aes(x=Fiscal.Year, y=Total.NEA.Appropriation/scale_amount, color = "red")) +
  stat_smooth(method="lm", formula = y~x, linetype = "dashed", color = "brown", size = 0.3) +
  theme_tufte() +
  labs(title = "GDP Per Capita & State NEA Allocation by Year",
       subtitle = "NEA Scaled to GDP: (NEA/1000)",
       caption = "Blue = GDP Per Capita\nRed = NEA Appropriation\nBrown Dashed = Line of Best Fit",
       tag = "Figure 11",
       x = "Fiscal Year",
       y = "Dollar Amount") +
  theme(legend.position = "none") +
  theme(plot.title = element_text(hjust = 0.5)) +
  theme(plot.subtitle = element_text(hjust = 0.5, size=10)) +
  theme(plot.caption = element_text(hjust = 0.0)) +
  theme(plot.tag = element_text(size = 10))

#ggsave("Figure11.jpg", width = 6, height = 4)

#Figure 12
scale_amount = 1000

ggplot(nea_adjusted_data, aes(x=Fiscal.Year, y=GDP.Per.Capita/Growth.Rate)) + geom_line(color = "blue") +
  geom_line(data=nea_adjusted_data, aes(x=Fiscal.Year, y=Total.NEA.Appropriation/(scale_amount*Growth.Rate), color = "red")) +
  stat_smooth(method="lm", formula = y~x, linetype = "dashed", color = "brown", size = 0.3) +

  theme_tufte() +
  labs(title = "GDP Per Capita & State NEA Allocation by Year & Growth Rate",
       subtitle = "Formula: GDP/Growth Rate ~= NEA/(1,000*Growth Rate)",
       caption = "Blue = GDP Per Capita\nRed = NEA Appropriation\nBrown Dashed = Line of Best Fit",
       tag = "Figure 12",
       x = "Fiscal Year",
       y = "Dollar Amount in Thousands of Dollars") +
  theme(legend.position = "none") +
  theme(plot.title = element_text(hjust = 0.5)) +
  theme(plot.subtitle = element_text(hjust = 0.5, size=8)) +
  theme(plot.caption = element_text(hjust = 0.0)) +
  theme(plot.tag = element_text(size = 10))

#ggsave("Figure12.jpg", width = 6, height = 4)

#Figure 13
#shows GDP and funding in relation to economic health indicators, specifically Growth Rate and Inflation.

scale_amount = 1000

ggplot(nea_adjusted_data, aes(x=Fiscal.Year, y=(GDP.Per.Capita/Growth.Rate)*Avg.Yearly.Inflation)) + geom_line(color="blue") +
  geom_line(data=nea_adjusted_data, aes(x=Fiscal.Year, y=Total.NEA.Appropriation/(scale_amount*Growth.Rate)*Avg.Yearly.Inflation, color = "red")) +
  stat_smooth(method="lm", formula=y~x, linetype = "dashed", color = "brown", size = 0.3) +

  theme_tufte() +
  labs(title = "GDP Per Capita & State NEA Allocation by Year\nMapped by Growth Rate and Average Yearly Inflation",
       subtitle = "Formula: (GDP/Growth Rate)*Inflation ~= (NEA/(1,000*Growth Rate)*Inflation",
       caption = "Blue = GDP Per Capita\nRed = NEA Appropriation\nBrown Dashed = Line of Best Fit",
       tag = "Figure 13",
       x = "Fiscal Year",
       y = "Dollar Amount in Thousands of Dollars") +
  theme(legend.position = "none") +
  theme(plot.title = element_text(hjust = 0.5)) +
  theme(plot.subtitle = element_text(hjust = 0.5, size=8)) +
  theme(plot.caption = element_text(hjust = 0.0)) +
  theme(plot.tag = element_text(size = 10))

#ggsave("Figure13.jpg", width = 6, height = 4)


require(dplyr)
data = read.csv("merge.csv")

plotMerge = function(n, yaxt = 's') {
  if (yaxt == 'n') {
    ylab = NA
    old = par(mar=c(3.5, 0.5, 2, 0.2))
  } else {
    ylab = "Absolute error (ppm)"
    old = par(mar=c(3.5, 4.0, 2, 0.2))
  }
  par(las=1)
  par(lwd=0.5)
  par(cex.lab=1.3)
  par(cex.axis=0.9)
  par(mgp=c(2.4, 0.5, 0))
  par(tcl=-0.3)

  our.data = data %>% filter(type == "quantile", parts == n)
  boxplot(e1*1e6 ~ q, at=(1:6)-0.23, xaxt='n', boxwex=0.19, our.data,
            ylim=c(-3000, 3000), cex=0.5, yaxt = yaxt,
          col=rgb(0.95, 0.95, 0.95),
          xlab=NA, ylab=NA)
  title(xlab=expression('Quantile '(italic(q))), mgp=c(2.2, 0.5, 0))
  title(ylab=ylab, mgp=c(2.8, 0.0, 0))
  boxplot(e3*1e6 ~ q, at=1:6, xaxt='n', boxwex=0.19, add=T, our.data,
          col=rgb(0.7, 0.7, 0.7), cex=0.5, yaxt = yaxt)
  boxplot(e2*1e6 ~ q, at=1:6+0.23, xaxt='n', boxwex=0.19, add=T, our.data,
          col=rgb(0.4, 0.4, 0.4), cex=0.5, yaxt = yaxt)
  axis(side=1, at=1:6,
       labels=c(expression(10^-3), expression(10^-2), 0.1, 0.2, 0.3, 0.5),
       )
  legend(0.13, -1300,
         expression("Direct "(delta==100),
                    "Stratified merge "(delta==200,100),
                    "Flat merge "(delta==100,100)),
         fill = c(rgb(0.95, 0.95, 0.95), rgb(0.7, 0.7, 0.7), rgb(0.4, 0.4, 0.4)),
         cex=0.75)
  abline(h=0, col=rgb(0.4, 0.4, 0.4))
  title(paste(n, " parts"), cex.main=1.3)
  box()
  par(old)
}

#setEPS()
pdf("merge.pdf", width=6, height=2.4, pointsize=9, family='serif')
layout(matrix(c(1,2,3), 1, 3, byrow=T), widths=c(1.285,1,1))
par(cex=1)

plotMerge(5, 's')
plotMerge(20, 'n')
plotMerge(100, 'n')

dev.off()


# Copyright (c) 2020, Zolisa Bleki
# SPDX-License-Identifier: BSD-3-Clause

hypertruncated_mvn_data <- function() {
    k1 <- 100
    k2 <- 20
    out <- list()
    out$mean <- rnorm(k1)
    cov <- matrix(rnorm(k1 * k1), ncol = k1)
    out$cov <- cov %*% t(cov)
    out$g <- matrix(rep(k2, k1), ncol = k1)
    out$r <- rnorm(k2)
    out$gnrow <- k2
    out$gncol <- k1

    out
}

structured_mvn_data <- function() {
    out <- hypertruncated_mvn_data()
    k1 <- out$gncol
    k2 <- out$gnrow
    eig <- eigen(out$cov)
    out$phi <- eig$vector[1:k2, ]
    out$omega <- diag(eig$values[1:k2])
    out$a <- diag(runif(k1))

    out
}

test_that("wrong generator name parameter", {
    expect_that(HTNGenerator(gen = "blah"), throws_error())
    expect_that(HTNGenerator()$rng, is_a("externalptr"))
    expect_that(HTNGenerator(gen = "xrs128p"), is_a("HTNGenerator"))
    expect_that(HTNGenerator(gen = "pcg64"), is_a("HTNGenerator"))
})

test_that("hyperplane truncated norm method", {
    out <- hypertruncated_mvn_data()
    mean <- out$mean
    cov <- out$cov
    g <- out$g
    r <- out$r

    gen <- HTNGenerator(10)
    hpmvn <- gen$hyperplane_truncated_mvnorm
    expect_that(hpmvn(matrix(mean), cov, g, r), throws_error())
    expect_that(hpmvn(mean[2:out$gncol], cov, g, r), throws_error())
    expect_that(hpmvn(mean, cov, g[, 2:out$gncol], r), throws_error())
    # test consistency of output when `diag=True` is used for same seed
    cov_diag <- diag(runif(out$gncol))
    gen1 <- HTNGenerator(10)$hyperplane_truncated_mvnorm(mean, cov_diag, g, r)
    gen2 <- HTNGenerator(10)$hyperplane_truncated_mvnorm(
        mean, cov_diag, g, r, diag = TRUE
    )
    expect_equal(gen1, gen2)
    # test results of passing output array through the `out` parameter
    res <- rep(1, out$gncol)
    hpmvn(mean, cov, g, r, out = res)
    expect_false(length(sum(res == rep(1, out$gncol))) == length(res))
    # test results of samples truncated on the hyperplane sum(x) = 0
    gg <- matrix(rep(1, out$gncol), ncol = out$gncol)
    r <- c(0)
    expect_equal(sum(hpmvn(mean, cov, gg, r)), 0)
    # test for non-SPD covariance input
    c <- diag(rnorm(out$gncol))
    expect_that(hpmvn(mean, c, g, r), throws_error())
})

test_that("structured precision normal", {
    out <- structured_mvn_data()
    mean <- out$mean
    a <- out$a
    phi <- out$phi
    omega <- out$omega

    gen <- HTNGenerator(10)
    spmvn <- gen$structured_precision_mvnorm
    expect_that(spmvn(matrix(mean), a, phi, omega), throws_error())
    expect_that(spmvn(mean, a, phi[2:nrow(phi), ], omega), throws_error())
    # raise error if invalid matrix structure is specified
    expect_that(spmvn(mean, a, phi, omega, a_type = -1000), throws_error())
    # test consistency of output when `a_type` or `o_type` is given
    gen1 <- HTNGenerator(10)$structured_precision_mvnorm(mean, a, phi, omega)
    gen2 <- HTNGenerator(10)$structured_precision_mvnorm(
        mean, a, phi, omega, a_type = "diagonal", o_type = "diagonal"
    )
    expect_equal(gen1, gen2)
    # test results of passing output array through the `out` parameter
    m <- length(mean)
    res <- rep(0, m)
    spmvn(mean, a, phi, omega, out = res)
    expect_false(length(sum(res == rep(0, m))) == length(res))
    # test for non-SPD a input
    aa <- diag(rnorm(ncol(phi)))
    expect_that(hpmvn(mean, aa, g, r), throws_error())
})

test_that("reproducability via seeding", {
    out <- hypertruncated_mvn_data()
    mean <- out$mean
    cov <- out$cov
    g <- out$g
    r <- out$r

    gen1 <- HTNGenerator(10)
    res1 <- gen1$hyperplane_truncated_mvnorm(mean, cov, g, r)
    gen2 <- HTNGenerator(10)
    res2 <- gen2$hyperplane_truncated_mvnorm(mean, cov, g, r)
    gen3 <- HTNGenerator(233)
    res3 <- gen3$hyperplane_truncated_mvnorm(mean, cov, g, r)
    expect_equal(res1, res2)
    expect_false(length(sum(res1 == res3)) == length(res1))
    # test if the errors are raised when the wrong input for seed is given
    expect_that(HTNGenerator(-100), throws_error("cannot be negative"))
    expect_that(HTNGenerator("100"), throws_error("non-numeric"))
})


n <- function(x) function()x

A <- function(k, x1, x2, x3, x4, x5) {
  B <- function() A(k <<- k-1, B, x1, x2, x3, x4)
  if (k <= 0) x4() + x5() else B()
}

A(10, n(1), n(-1), n(-1), n(1), n(0))


#!/usr/bin/env Rscript

library(modules, warn.conflicts = FALSE, quietly = TRUE)
sys = import('sys')

plot_te = function (data, summary) {
    import_package('ggplot2', attach = TRUE)

    data$Which = factor(data$Which,
                        levels = c('All', 'Upregulated', 'GO', 'Housekeeping', 'Ribosomal', 'Proliferation'),
                        ordered = TRUE)

    plot = ggplot(data, aes(x = Mode, y = TE)) +
        (if (summary)
            geom_boxplot(width = 0.4)
        else
            geom_boxplot(width = 0.2, outlier.size = 0)) +
        scale_y_continuous(limits = c(0.1, 0.85)) +
        facet_wrap(~ Which, nrow = 1) +
        theme_bw()

    if (summary)
        plot
    else {
        import_package('ggbeeswarm', attach = TRUE)
        plot +
            geom_point(aes(color = mRNA, shape = tRNA),
                       position = position_beeswarm()) +
            scale_color_manual(limits = names(config$celltype_colors),
                               values = config$celltype_colors) +
            scale_shape_manual(limits = names(config$celltype_colors),
                               values = c(15, 4, 5, 16))
    }
}

mean_center = function (all_te) {
    import_package('dplyr', attach = TRUE)
    trna_zscores = all_te %>%
        filter(Mode == 'Match') %>%
        group_by(Which) %>%
        mutate(AllMedian = median(TE)) %>%
        group_by(tRNA, add = TRUE) %>%
        mutate(tRNAMedian = median(TE)) %>%
        summarize(Scaling = first(tRNAMedian / AllMedian))

    inner_join(all_te, trna_zscores, by = c('Which', 'tRNA')) %>%
        mutate(TE = TE / Scaling)
}

sys$run({
    valid_te_methods = c('simple-te', 'wobble-te', 'tai')
    args = sys$cmdline$parse(opt('t', 'te',
                                 do.call(sprintf,
                                         c('the method to calculate translation efficiency (%s, %s or %s)',
                                           lapply(valid_te_methods, dQuote))),
                                 valid_te_methods[1],
                                 function (x) x %in% valid_te_methods),
                             opt('c', 'mean-center', 'center tRNA strata before plotting?', FALSE),
                             opt('s', 'summary', 'plot summary rather than detailed points?', FALSE),
                             opt('i', 'ramp-up', 'use codons at start of transcript (“ramp up”) only', FALSE),
                             arg('species', 'the species'),
                             arg('outfile', 'the filename of the PDF output'))

    config = import(sprintf('../config_%s', args$species))
    te = readRDS(sprintf('results/%s%s-%s.rds',
                         if (args$ramp_up) 'init-' else '',
                         args$te, args$species))
    if (args$mean_center)
        te = mean_center(te)

    # Required by ggplot2, see <https://github.com/hadley/ggplot2/issues/1384>
    library(methods)
    on.exit(dev.off())
    pdf(args$outfile)
    plot(plot_te(te, args$summary))
})

# vim: ft=r


#08/14/2018
#christina bandaragoda

##Installations (if needed)
#install.packages("xlsx")
## installing/loading the package:
#if(!require(installr)) {
#  install.packages("installr");
#  require(installr)
#} #load / install+load installr
## using the package:
#updateR()

# change param options
options(java.parameters = "-Xmx1024m")
library(xlsx)
library(data.table)
library(dplyr)
library(hydroGOF)

# home directories
if(dir.exists('C:/Users/Jimmy/Google Drive/Watershed Dynamics Group/Projects/Bertrand Creek/2016 Project')){ # for jim
  Project2016 <- 'C:/Users/Jimmy/Google Drive/Watershed Dynamics Group/Projects/Bertrand Creek/2016 Project'
} else if (dir.exists('C:/Users/cband/Nooksack/Bertrand Creek/2016 Project')) { # for Christina
  Project2016 <- 'C:/Users/cband/Nooksack/Bertrand Creek/2016 Project'
}
# home directories
if(dir.exists('C:/Users/Jimmy/Google Drive/Watershed Dynamics Group/Projects/Bertrand Creek/2016 Project')){ # for jim
  Project2018 <- 'C:/Users/Jimmy/Google Drive/Watershed Dynamics Group/Projects/Bertrand Creek/2016 Project'
} else if (dir.exists('C:/Users/cband/Nooksack/Bertrand Creek/2018 Project')) { # for Christina
  Project2018 <- 'C:/Users/cband/Nooksack/Bertrand Creek/2018 Project'
}
# subdirectories

WMoff2018_Models <- paste(Project2018, 'modelruns_1952WRIA1_081418/modelruns_1952WRIA1_110912_WMoff', sep='/')
WMon2012_Models <- paste(Project2018, 'modelruns_1952WRIA1_081418/modelruns_1952WRIA1_110912_WMon', sep='/')
#WMon2018_Models <- paste(Project2018, 'modelruns_1952WRIA1_081418', sep='/')
# set working directory

# for (ModelSet_folder in c(Test1, Test2, Test3, Test4, Test5)){
#for (ModelSet_folder in c(Test2, Test3, Test4, Test5)){
#ModelSet_folder=WMoff2018_Models
ModelSet_folder=WMon2012_Models
for (ModelSet_folder in c(WMoff2018_Models,WMon2012_Models)){

  print(paste('start' ModelSet_folder))

  setwd(ModelSet_folder)
  getwd()
  # read in topsbd_v8
  topsbd <- read.table('topsbd_v8.txt', skip = 1, header = T) %>% data.table()

  # if statement for colnames that have been removed
  if (!'TimeStep' %in% colnames(topsbd)){
    topsbd <- read.table('topsbd_v8.txt', skip = 0, header = F) %>%
      data.table() %>%
      setnames(., colnames(.), c('Basin', 'TimeStep', 'IrrDrainCat', 'Afrac', 'SWInput_mm', 'Qlat_mm', 'Qtot_mm', 'Qb_mm', 'Recharge_mm', 'SatEx_mm', 'InfEx_mm', 'SurfRo_mm', 'SatAfrac', 'InfAfrac', 'IntStore_mm', 'WTDepth_mm', 'SoilStore_mm', 'Pet_mm', 'Aet_mm', 'Irrig_mm', 'GWTake_mm', 'IrrDem_mm', 'Prec_mm', 'SWE_mm', 'Sublim_mm', 'Tave_C', 'Tdew_C', 'Trange_C', 'ErrClosure_mm'))
  }

  # generate TimeStep by subbasin matrices
  Zbar <- dcast(topsbd %>% select(TimeStep, Basin, WTDepth_mm), TimeStep~Basin, value.var = 'WTDepth_mm', fill = 0)
  PET <- dcast(topsbd %>% select(TimeStep, Basin, Pet_mm), TimeStep~Basin, value.var = 'Pet_mm', fill = 0)
  AET <- dcast(topsbd %>% select(TimeStep, Basin, Aet_mm), TimeStep~Basin, value.var = 'Aet_mm', fill = 0)
  Rain <- dcast(topsbd %>% select(TimeStep, Basin, Prec_mm), TimeStep~Basin, value.var = 'Prec_mm', fill = 0)
  SatEx <- dcast(topsbd %>% select(TimeStep, Basin, SatEx_mm), TimeStep~Basin, value.var = 'SatEx_mm', fill = 0)
  InfEx <- dcast(topsbd %>% select(TimeStep, Basin, InfEx_mm), TimeStep~Basin, value.var = 'InfEx_mm', fill = 0)
  SurfRO <- dcast(topsbd %>% select(TimeStep, Basin, SurfRo_mm), TimeStep~Basin, value.var = 'SurfRo_mm', fill = 0)
  SoilStore <- dcast(topsbd %>% select(TimeStep, Basin, SoilStore_mm), TimeStep~Basin, value.var = 'SoilStore_mm', fill = 0)

  # load Recharge inputs
  Basins <- read.table("basin.txt", header=T)
  Precipitation_mm <- Rain
  Evaporation_mm = read.table("Evaporation_mm.txt", header=T)
  Depth_to_Water_mm <- Zbar
  # Make if statement here
  #Surface_runoff_cms = read.table("TotalRunoff_cms.txt", header=T)
  Surface_runoff_cms = read.table("TotalRunoff_noWithdrawal_cms.txt", header=T)

  # print these outputs to xlsx using these names
  for (mat in c('InfEx', 'PET', 'AET', 'SatEx', 'Rain', 'Zbar', 'SoilStore', 'Surface_runoff_cms')){

    print(paste('starting to print', mat))
    write.table(mat %>% get() %>% data.frame(), file = paste0(mat, '.txt'), col.names = T, row.names = F, append = F)
    print(paste(mat, 'printed to', paste0(mat, '.txt')))
  }
  rm(mat)

  # source the RechargeCalculator_kbcb.R script
  # output is the object totalRecharge
  source(paste(WMon2018_Models, "RechargeCalculator_kbcb_jp.R", sep = '/'))
}


### Finding the best hospital in a state

best <- function(state, outcome) {
    ## Read outcome caredata
    caredata <- read.csv("outcome-of-care-measures.csv", colClasses = "character")
    caredataframe   <- as.data.frame(cbind(caredata[, 2],   # col 2 for hospital
                                caredata[, 7],                  # col 7 for state
                                caredata[, 11],                 # col 11 for heart attack
                                caredata[, 17],                 # col 17 for heart failure
                                caredata[, 23]),                # col 23 for  pneumonia
                       stringsAsFactors = FALSE)
    colnames(caredataframe) <- c("hospital", "state", "heart attack", "heart failure", "pneumonia")

    ## Check that state and outcome are valid
    if(!state %in% caredataframe[, "state"]){
        stop('invalid state')
    } else if(!outcome %in% c("heart attack", "heart failure", "pneumonia")){
        stop('invalid outcome')
    } else {
        si <- which(caredataframe[, "state"] == state)
        ts <- caredataframe[si, ]    # extracting data for the called state
        oi <- as.numeric(ts[, eval(outcome)])
        min_val <- min(oi, na.rm = TRUE)
        result  <- ts[, "hospital"][which(oi == min_val)]
        output  <- result[order(result)]
    }
return(output)
}


########################################################################
##########################   Exp1: GLMMS   #############################
########################################################################

getwd()
# setwd("D:/Uni-Stuttgart/thesis/Corpora/Exp3")
setwd("/mount/projekte50/projekte/semrel/Users/reem/thesis/Corpora/Exp3/")
getwd()

# load libs
library(lsr)
library(lme4)
library(ggplot2)  # load the package

##STEP 0: set gloabal option to ignore scientific notation (numbers with E at the end)
options(scipen = 999)

## STEP 1: Load data frames
library(readr)
sample.grain.10k <- read.delim("samples/sample-grain-unigrams-10K-1.tsv", encoding="UTF8")

sample.kidko.10k <- read.delim("samples/sample-kidko-unigrams-10K-1.tsv", encoding="UTF8")

## STEP 1.1: Concatenate data frames
# use row bind | requires both dataframes to have the same columns
data.20k.sampled.df <- rbind(sample.grain.10k, sample.kidko.10k)

# STEP 1.2 shuffle rows
# By default sample() randomly reorders the elements passed as the first argument.
# This means that the default size is the size of the passed array.
# Passing parameter replace=FALSE (the default) to sample(...)
# ensures that sampling is done without replacement which accomplishes a row wise shuffle.
data.20k.sampled.df <- data.20k.sampled.df[sample(nrow(data.20k.sampled.df)),]

# Rename column where names is "isKD"
names(data.20k.sampled.df)[names(data.20k.sampled.df) == "isKD"] <- "corpus_type"

#View(data.20k.sampled.df)
# summary(data.20k.sampled.df)

print(length(unique(data.20k.sampled.df[["pos_seq"]])))

# STEP 1.3 factor our predictors and outcome
data.20k.sampled.df$pos_seq <- factor(data.20k.sampled.df$pos_seq)
lvls <- levels(data.20k.sampled.df$pos_seq)
write.table(lvls, file = "output/unigrams-20k-grand-mean-ngram-levels.csv", sep = "\t")

# STEP 2 create null/baseline model
# model only the intercept
null.glm = glm(corpus_type ~ 1, family = "binomial", data = data.20k.sampled.df)
summary(null.glm)

# STEP 3 create POSt model and compare to previous model
# set contrast to "contr.sum"
# sum contrasts compare the mean of each group\level to the grand mean/mean of all levels
# https://stats.idre.ucla.edu/r/library/r-library-contrast-coding-systems-for-categorical-variables/#DEVIATION
# see novarro book p.536
# contrasts(data.20k.sampled.df$pos_seq) <- "contr.sum"
my.contrasts <- list(pos_seq = contr.sum)

# use family=binomial to turn our factor columns into numerical values
start_time <- Sys.time()

#POSt.glm <- glm(corpus_type ~ 1 + pos_seq, contrasts = my.contrasts,
#                  family = "binomial", data = data.20k.sampled.df)

library(boot)
library(parallel)

# function to return bootstrapped coefficients
myLogitCoef <- function(data, indices, formula, contrs) {
    d <- data[indices,]
    fit <- glm(formula, data=d, family = binomial(link = "logit"))
    return(coef(fit))
}

# set up cluster of 4 CPU cores
cl<-makeCluster(4)
clusterExport(cl, 'myLogitCoef')

# set random seed to ensure reproducibility
set.seed(333)
# bootstrap data 500 times
coef.boot <- boot(data=data.20k.sampled.df, statistic=myLogitCoef, R=500,
                  formula= corpus_type ~ 1 + pos_seq,
                  # process in parallel across 4 CPU cores
                  parallel = 'snow', ncpus=4, cl=cl)
stopCluster(cl)

end_time <- Sys.time()
total_time <- end_time - start_time

print(total_time)

# STEP 3.2 analyze model

# STEP 3.2.1 summary of the model
model.summary <- coef.boot$t0
write.table(model.summary, file = "output/unigrams-20k-grand-mean-coeff.csv", sep = "\t")

# STEP 3.2.2 summary of the model
boots.summary <- coef.boot$t
write.table(boots.summary, file = "output/unigrams-20k-grand-mean-coeff-boots.csv", sep = "\t")

# STEP 3.3 confidence intervals
con-int <- boot.ci(myBootstrap, index=1, type='norm')$norm
write.table(con-int, file = "output/unigrams-20k-grand-mean-boots-conf-int.csv", sep = "\t")

# STEP 4 get the estimate for the last level (VERB) using emmeans
# Estimated Marginal Means, aka Least-Squares Means (emmeans)
library(emmeans)
groups <- emmeans(POSt.glm, "pos_seq")

em.df <- summary(groups)

# save emmeans
write.table(em.df, file = "output/unigrams-20k-grand-mean-emmeans.csv", sep = "\t")

# plot distribution of bootstrap realizations
# https://www.datacamp.com/community/tutorials/bootstrap-r
svg(filename = 'output/pos-unigram-grand-mean-boots.svg')
plot(myBootstrap, index=1)
dev.off()


# Working with data that is taken from statistical packages
# Examples are shown for SAS, STATA and SPSS

# A. haven
# This is one of the packages that can be used to import data
# A very fast package for working with external data types
# 1. Import SAS data
# Load the haven package
library(haven)

# Import sales.sas7bdat: sales
sales <- read_sas("sales.sas7bdat")

# Display the structure of sales
str(sales)

# 2. Import STATA data
# haven is already loaded

# Import the data from the URL: sugar
sugar <- read_dta("http://assets.datacamp.com/production/course_1478/datasets/trade.dta")

# Structure of sugar
str(sugar)

# Convert values in Date column to dates. When character variables are imported then convert the data type to the unique levels.
# This method helps to ensure that the variable is converted to the correct format
sugar$Date <- as.Date(as_factor(sugar$Date))

# Structure of sugar again
str(sugar)

# 3. Import SPSS data
# haven is already loaded

# Import person.sav: traits
traits <- read_sav("person.sav")

# Summarize traits
summary(traits)

# Print out a subset. Method allows us to pass filters to the second positional parameter (subset)
subset(traits, traits$Extroversion > 40 & traits$Agreeableness > 40)

# 4. Factorize, round two
# Import SPSS data from the URL: work
work <- read_sav("http://s3.amazonaws.com/assets.datacamp.com/production/course_1478/datasets/employee.sav")

# Display summary of work$GENDER
summary(work$GENDER)

# Convert work$GENDER to a factor
work$GENDER <- as_factor(work$GENDER)

# Display summary of work$GENDER again
summary(work$GENDER)

# B. foreign
# 1. Import STATA data
# Load the foreign package
library(foreign)

# Import florida.dta and name the resulting data frame florida
florida <- read.dta("florida.dta")

# Check tail() of florida
tail(florida)

# 2. Import STATA data (2)
# foreign is already loaded

# Specify the file path using file.path(): path
path <- file.path("worldbank/edequality.dta")

# Create and print structure of edu_equal_1
edu_equal_1 <- read.dta(path)
str(edu_equal_1)

# Create and print structure of edu_equal_2
edu_equal_2 <- read.dta(path, convert.factors = FALSE)
str(edu_equal_2)

# Create and print structure of edu_equal_3
edu_equal_3 <- read.dta(path, convert.underscore = TRUE)
str(edu_equal_3)

# Review the number of rows that match the subset filtering
nrow(subset(edu_equal_1, ethnicity_head == "Bulgaria" & income > 1000))

# 3. Import SPSS
# foreign is already loaded

# Import international.sav as a data frame: demo
demo <- read.spss("international.sav", to.data.frame = TRUE)

# Create boxplot of gdp variable of demo
boxplot(demo$gdp)

# 4. Import SPSS
# foreign is already loaded

# Import international.sav as demo_1
demo_1 <- read.spss("international.sav", to.data.frame = TRUE)

# Print out the head of demo_1
head(demo_1)

# Import international.sav as demo_2
demo_2 <- read.spss("international.sav", to.data.frame = TRUE, use.value.labels = FALSE)

# Print out the head of demo_2
head(demo_2)


 #SNOPSIS

 #runs ANOVA.

 #AUTHOR
 # Isaak Y Tecle (iyt2@cornell.edu)

options(echo = FALSE)

#library(dplyr)
library(data.table)
library(phenoAnalysis)
library(methods)

allArgs     <- commandArgs()

outputFiles <- scan(grep("output_files", allArgs, value = TRUE),
                    what = "character")

inputFiles  <- scan(grep("input_files", allArgs, value = TRUE),
                   what = "character")

phenoDataFile <- grep("phenotype_data", inputFiles, value = TRUE)
message('pheno file: ', phenoDataFile)

traitsFile <- grep("traits", inputFiles, value = TRUE)
message('traits file: ', traitsFile)

metadataFile <- grep("metadata", inputFiles, value = TRUE)
message('metadata file: ', metadataFile)

metaData <- scan(metadataFile, what="character")

designFactors <- c('germplasmName','studyYear', 'studyDesign', 'blockNumber', 'locationName', 'replicate')
dropCols <-  metaData[! metaData %in% designFactors]

phenoData <- fread(phenoDataFile,
                   header = TRUE,
                   sep="\t",
                   drop=dropCols,
                   na.strings=c("NA", "-", " ", ".", ".."))

phenoData <- data.frame(phenoData)

traits  <- scan(traitsFile,  what = "character")
traits  <- strsplit(traits, "\t")

#needs more work for multi traits anova
for (trait in traits) {

    message('trait: ', trait)
    anovaFiles     <- grep("anova_table",
                           outputFiles,
                           value = TRUE)

    message('anova file: ', anovaFiles)
    anovaHtmlFile  <- grep("html",
                           anovaFiles,
                           value = TRUE)

    message('anova html file: ', anovaHtmlFile)
    anovaTxtFile   <- grep("txt",
                           anovaFiles,
                           value = TRUE)

    message('anova txt file: ', anovaTxtFile)
    modelSummFile <- grep("anova_model",
                          outputFiles,
                          value = TRUE)

    message('model file: ', modelSummFile)
    adjMeansFile  <- grep("adj_means",
                          outputFiles,
                          value = TRUE)

    message('means file: ', adjMeansFile)

    diagnosticsFile  <- grep("anova_diagnostics",
                             outputFiles,
                             value = TRUE)

    errorFile  <- grep("anova_error",
                       outputFiles,
                       value = TRUE)

    anovaOut <- runAnova(phenoData, trait)

    if (class(anovaOut) == 'character') {
        cat(anovaOut, file=errorFile)
    } else if (is.null(anovaOut)) {

        cat('Error occured fitting anova model to this trait data.
             Please check the trait data and design factors.',
            file=errorFile)

    } else if (class(anovaOut)[1] == 'lmerModLmerTest' ||
               class(anovaOut)[1] == 'merModLmerTest') {

        png(diagnosticsFile, 960, 480)
        par(mfrow=c(1,2))
        plot(fitted(anovaOut), resid(anovaOut),
             xlab="Fitted values",
             ylab="Residuals",
             main="Fitted values vs Residuals")
        abline(0,0)
        qqnorm(resid(anovaOut))
        dev.off()

        anovaTable <- getAnovaTable(anovaOut,
                                    tableType="html",
                                    traitName=trait,
                                    out=anovaHtmlFile)

        anovaTable <- getAnovaTable(anovaOut,
                                    tableType="text",
                                    traitName=trait,
                                    out=anovaTxtFile)

        adjMeans   <- getAdjMeans(traitName=trait, modelOut=anovaOut)

        fwrite(adjMeans,
               file      = adjMeansFile,
               row.names = FALSE,
               sep       = "\t",
               quote     = FALSE,
               )

        sink(modelSummFile)
        print(anovaOut)
        sink()
    }

}

q(save = "no", runLast = FALSE)


# Differential expression analysis with limma
source("http://www.bioconductor.org/biocLite.R")
library("Biobase")
library("GEOquery")
library("limma")

# load series and platform data from GEO
setwd("~/work/abe516/project1")
cwd = getwd()

gset <- getGEO("GSE95636", GSEMatrix = TRUE, AnnotGPL = TRUE)
if (length(gset) > 1) idx <- grep("GPL200", attr(gset, "names")) else idx <- 1
gset <- gset[[idx]]

# make proper column names to match toptable
fvarLabels(gset) <- make.names(fvarLabels(gset))

# group names for all samples
gsms <- "3311100022233"
sml <- c()
for (i in 1:nchar(gsms)) { sml[i] <- substr(gsms,i,i) }

# log2 transform
ex <- exprs(gset)
qx <- as.numeric(quantile(ex, c(0., 0.25, 0.5, 0.75, 0.99, 1.0), na.rm=T))
LogC <- (qx[5] > 100) ||
  (qx[6]-qx[1] > 50 && qx[2] > 0) ||
  (qx[2] > 0 && qx[2] < 1 && qx[4] > 1 && qx[4] < 2)
if (LogC) { ex[which(ex <= 0)] <- NaN
exprs(gset) <- log2(ex) }

# set up the data and proceed with analysis
groups = c("C", "Bs", "Efs", "Efm")
fl <- factor(c(rep('0', 2), rep('1', 3), rep('2', 3), rep('3', 3), rep('0', 2)),
             labels=groups)
# sml <- paste("G", sml, sep="")    # set group names
# fl <- as.factor(sml)
gset$description <- fl
design <- model.matrix(~ description + 0, gset)
colnames(design) <- levels(fl)
fit <- lmFit(gset, design)
contrast.matrix <- makeContrasts(Efm-C, Efs-C, Bs-C, Efs-Bs, Efm-Efs, levels = design)
fit2   = contrasts.fit(fit, contrast.matrix)
fit2   = eBayes(fit2, 0.01)
tT     = topTable(fit2, adjust = "fdr", sort.by = "B", number = 250)
cnames = c("ID","adj.P.Val","P.Value","Gene.symbol","Gene.title","GO.Function","GO.Process","GO.Component")
tT      = subset(tT, select = cnames)

write.table(tT, file=file.path(cwd, "top250.tab"), row.names=F, sep="\t")

results = decideTests(fit2, adjust="fdr", p=0.05)
summary(results)
table(efm.c=results[,1], bs.c=results[,2])

png(filename = file.path(cwd, "venn.png"), width = 400, height = 800)
par(mfrow = c(3, 1))
vennDiagram(results, main="Diff Exp Genes")
vennDiagram(results, include="down", main="Down")
vennDiagram(results, include="up", main="Up")
dev.off()

png(filename = file.path(cwd, "volcano.png"), width = 800, height = 800)
par(mfrow = c(2,2))
volcanoplot(fit2,
            coef=1,
            main="E_faecium-Control",
            names=row.names(fit2$coefficients),
            highlight=10)

volcanoplot(fit2,
            coef=2,
            main="B_subtilis-Control",
            names=row.names(fit2$coefficients),
            highlight=10)

volcanoplot(fit2,
            coef=3,
            main="E_faecium-B_subtilis",
            names=row.names(fit2$coefficients),
            highlight=10)

volcanoplot(fit2,
            coef=3,
            main="E_faecium-E_faecalis",
            names=row.names(fit2$coefficients),
            highlight=10)
dev.off()


pattern_matching <- function(pattern, genome) {
  pattern_length <- nchar(pattern)
  for (i in 0:nchar(genome) - pattern_length) {
    if (substr(genome, i + 1, i + pattern_length) == pattern)
      print(i)
  }
}

message("File")
file <- scan("stdin", what="character", nlines=1)
pattern <- scan(file, what="character", nlines=1)
genome <- scan(file, what="character", skip=1, nlines=1)

pattern_matching(pattern, genome)


context("Kmeans")
#source('../../h2o-runit.R')
library(h2o)

print(Sys.getenv("H2O_IP"))
print(Sys.getenv("H2O_PORT"))

#conn <- h2o.init(ip=Sys.getenv("H2O_IP"), port=as.integer(Sys.getenv("H2O_PORT"), startH2O=FALSE))
conn <- h2o.init( startH2O=FALSE )
hex <- as.h2o( conn, iris )

#model <- tryCatch({
#	h2o.kmeans(data=hex, centers=5)
#}, error = function(err) {
#	return(err)
#})

model <- h2o.kmeans(data=hex, centers=5)

if(is(model, "H2OKMeansModel")) {
	test_that("Correct # of centers returned: ", {
		expect_equal(5, length(model@model$centers))
	})
} else {
	test_that("Input permutation foo: ", fail(message=toString(model)))
}


#' dim
#'
#' Dimension information for a float vector/matrix.
#'
#' @param x
#' A float vector/matrix.
#' @param value
#' The right hand side for the "setter" (\code{dim<-}).
#'
#' @return
#' The requested integer values.
#'
#' @examples
#' library(float)
#'
#' s = flrunif(10, 3)
#' dim(s)
#' nrow(s)
#' ncol(s)
#'
#' @name dims
#' @rdname dims
NULL

DATA = function(x) x@Data
isavec = function(x) !is.matrix(DATA(x))

#' @rdname dims
#' @export
setMethod("nrow", signature(x="float32"), function(x) NROW(DATA(x)))

#' @rdname dims
#' @export
setMethod("ncol", signature(x="float32"), function(x) NCOL(DATA(x)))

#' @rdname dims
#' @export
setMethod("NROW", signature(x="float32"), function(x) NROW(DATA(x)))

#' @rdname dims
#' @export
setMethod("NCOL", signature(x="float32"), function(x) NCOL(DATA(x)))

#' @rdname dims
#' @export
setMethod("dim", signature(x="float32"), function(x) c(nrow(x), ncol(x)))

#' @rdname dims
#' @export
setMethod("length", signature(x="float32"),
  function(x)
  {
    len = tryCatch(nrow(x) * ncol(x), warning=identity)
    if (inherits(len, "warning"))
      len = as.double(nrow(x)) * as.double(ncol(x))

    len
  }
)

dimset_float32 = function(x, value)
{
  dim(x@Data) = value
  x
}

#' @rdname dims
#' @export
setReplaceMethod("dim", signature(x="float32"), dimset_float32)