#' fun_xgboost_to_sql(): view a XGBoost model as SQL
#' v0.1
#' USAGE:
#' fun_xgboost_to_sql(xgb_fit, output_file_name="model_output.SQL", input_table_name="[database].[table]","unique_id")

fun_xgboost_to_sql <- function(xgbModel,output_file_name,input_table_name,unique_id){

  xgb_dump <- xgboost::xgb.dump(xgbModel)
  first_letter <- substring(xgb_dump,1,1)

  all_tree_index <-which(first_letter == "b")

  fun_recurse_tree <- function(g,local_dump,dump_index,branch_index,out){

    if(grepl("leaf",local_dump[dump_index])==TRUE){
      cat(as.numeric(sub(".*leaf= *(.*?)", "\\1", local_dump[dump_index])))
    } else{
      cur_var_name <- g$feature_names[as.numeric(regmatches(local_dump[dump_index],regexec("f(.*?)[<]",local_dump[dump_index]))[[1]][2])+1]
      cur_var_val <- as.numeric(regmatches(local_dump[dump_index],regexec("[<](.*?)[]]",local_dump[dump_index]))[[1]][2])

      # if YES
      left_local_index <-  as.numeric(regmatches(local_dump[dump_index],regexec("yes=(.*?)[,]",local_dump[dump_index]))[[1]][2])
      left_dump_index <- which(branch_index==left_local_index)

      # if NO
      right_local_index <-  as.numeric(regmatches(local_dump[dump_index],regexec("no=(.*?)[,]",local_dump[dump_index]))[[1]][2])
      right_dump_index <- which(branch_index == right_local_index)

      # if missing
      missing_local_index <-  as.numeric(regmatches(local_dump[dump_index],regexec("missing=(.*?)$",local_dump[dump_index]))[[1]][2])
      missing_dump_index <- which(branch_index == missing_local_index)

      cat("\n ( CASE WHEN ",cur_var_name,"< ",cur_var_val, "THEN ")
      cat(fun_recurse_tree(g,local_dump,left_dump_index,branch_index,""))
      cat("\n  WHEN ",cur_var_name,">= ",cur_var_val, "THEN ")
      cat(fun_recurse_tree(g,local_dump,right_dump_index,branch_index,""))
      cat("\n  WHEN ",cur_var_name,"IS NULL", "THEN ")
      cat(fun_recurse_tree(g,local_dump,missing_dump_index,branch_index,""))
      cat(" END)")
    }

  }

  sink(output_file_name,type = "output")

  cat("SELECT ",unique_id,", ")
  if(xgbModel$params$objective == "binary:logistic" | xgbModel$params$objective =="reg:logistic"){
    p0 <- ifelse(is.null(xgbModel$params$base_score),0.5,xgbModel$params$base_score)
    b0 <- log(p0/(1-p0))
    cat("1/(1+exp(-(",b0,"+ SUM(tree)))) AS PRED")
  } else if(xgbModel$params$objective == "reg:linear"){
    b0 <- ifelse(is.null(xgbModel$params$base_score),0.5,xgbModel$params$base_score)
    cat(b0,"+ SUM(tree) AS PRED")
  } else if(xgbModel$params$objective == "reg:gamma" | xgbModel$params$objective == "count:poisson"){
    mu0 <- ifelse(is.null(xgbModel$params$base_score),0.5,xgbModel$params$base_score)
    b0 <- log(mu0)
    cat("exp(",b0,"+ SUM(tree)) AS PRED")
  } else if(xgbModel$params$objective == "reg:tweedie"){
    b0 <- ifelse(is.null(xgbModel$params$base_score),0.5,xgbModel$params$base_score)
    cat("exp(",b0,"+ SUM(tree)) AS PRED")
  }

  cat("\n FROM (  ")

  for(tree_num in 1:length(all_tree_index)){
    cat(paste(" \n SELECT ",unique_id, ", \n"))

    tree_begin <- all_tree_index[tree_num]+1
    if(is.na(all_tree_index[tree_num+1])){
      tree_end <- length(xgb_dump)
    } else {
      tree_end <- all_tree_index[tree_num+1] - 1
    }

    all_branch_index <- as.numeric(sub("\\D*(\\d+).*", "\\1", xgb_dump))

    branch_index <- all_branch_index[tree_begin:tree_end]
    local_dump <- xgb_dump[tree_begin:tree_end]

    dump_index <- 1

    out <- ""
    fun_recurse_tree(xgbModel,local_dump,dump_index,branch_index,out)
    cat(" AS ", paste0("tree"))
    if(tree_num != length(all_tree_index)){
      cat(paste(" FROM ",input_table_name,"\n UNION ALL \n"))
    }
  }

  cat("\n FROM ",input_table_name,") AS TREETABLE \n GROUP BY ",unique_id)

  sink()
}


# With this skript I intend to analyze whether there is a significant
#  difference between the populations in the control (absolute gene
#  expression) and in the treatment groups (fold change/relative gene
#  expression).

library("nparLD")

#####################################################################
#####################################################################
########## Relative expression of treatment samples #################
#####################################################################
#####################################################################

# An arcsine transformation does not make sense, since my values do
# not only reach from 0 to 1.  I try with a log transformation.  The
# tests showed that not all data can be normalized by log-transforming
# them. Thus, I need to analyze the data with with PERMANOVA

AllBoxplotOutliersRemoved32 <- read.table("/home/alj/Documents/org_files/data/ScientificJournal/2012ScientificJournal/Dec/2012-12-18-Fs_32_FoldChange_AllBoxplotOutliersRemoved.txt",header=TRUE)

AllBoxplotOutliersRemoved28 <- read.table("/home/alj/Documents/org_files/data/ScientificJournal/2012ScientificJournal/Dec/2012-12-18-Fs_28_FoldChange_AllBoxplotOutliersRemoved.txt",header=TRUE)

# Identify missing NA values

FT32 <- rbind(AllBoxplotOutliersRemoved32,
      c(NA,NA,NA,NA,NA,NA,"Denmark","D16",NA,NA,NA,"HSP70","24h",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Denmark","D16",NA,NA,NA,"HSP90","24h",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Denmark","D16",NA,NA,NA,"sHSP","24h",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Denmark","D21",NA,NA,NA,"HSP70","15",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Denmark","D21",NA,NA,NA,"HSP90","15",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Denmark","D21",NA,NA,NA,"sHSP","15",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Denmark","D21",NA,NA,NA,"HSP70","60",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Denmark","D21",NA,NA,NA,"HSP90","60",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Denmark","D21",NA,NA,NA,"sHSP","60",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"France","R7",NA,NA,NA,"sHSP","24h",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"France","R3",NA,NA,NA,"HSP70","60",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"France","R3",NA,NA,NA,"HSP90","60",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"France","R3",NA,NA,NA,"sHSP","60",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"France","R7",NA,NA,NA,"HSP70","60",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"France","R7",NA,NA,NA,"HSP90","60",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"France","R7",NA,NA,NA,"sHSP","60",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Norway","K28",NA,NA,NA,"HSP70","15",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Norway","K16",NA,NA,NA,"HSP70","24h",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Norway","K27",NA,NA,NA,"sHSP","60",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Spain","S39",NA,NA,NA,"HSP70","15",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Spain","S39",NA,NA,NA,"HSP90","15",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Spain","S39",NA,NA,NA,"sHSP","15",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Spain","S40",NA,NA,NA,"HSP70","15",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Spain","S40",NA,NA,NA,"HSP90","15",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Spain","S40",NA,NA,NA,"sHSP","15",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Spain","S46",NA,NA,NA,"sHSP","24h",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Spain","S40",NA,NA,NA,"sHSP","60",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Spain","S46",NA,NA,NA,"HSP70","60",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Spain","S46",NA,NA,NA,"HSP90","60",NA,NA,NA,32,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Spain","S46",NA,NA,NA,"sHSP","60",NA,NA,NA,32,NA,NA,NA,NA)
      )

FT28 <- rbind(AllBoxplotOutliersRemoved28,
      c(NA,NA,NA,NA,NA,NA,"Denmark","D32",NA,NA,NA,"HSP70","15",NA,NA,NA,28,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Denmark","D41",NA,NA,NA,"sHSP","15",NA,NA,NA,28,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Denmark","D38",NA,NA,NA,"HSP70","60",NA,NA,NA,28,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Denmark","D41",NA,NA,NA,"sHSP","60",NA,NA,NA,28,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"France","R33",NA,NA,NA,"sHSP","0",NA,NA,NA,28,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"France","R21",NA,NA,NA,"sHSP","15",NA,NA,NA,28,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"France","R33",NA,NA,NA,"sHSP","15",NA,NA,NA,28,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"France","R33",NA,NA,NA,"sHSP","24h",NA,NA,NA,28,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"France","R21",NA,NA,NA,"sHSP","60",NA,NA,NA,28,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"France","R33",NA,NA,NA,"sHSP","60",NA,NA,NA,28,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Norway","K13",NA,NA,NA,"HSP90","24h",NA,NA,NA,28,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Norway","K6",NA,NA,NA,"sHSP","24h",NA,NA,NA,28,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Norway","K6",NA,NA,NA,"sHSP","60",NA,NA,NA,28,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Spain","S25",NA,NA,NA,"sHSP","24h",NA,NA,NA,28,NA,NA,NA,NA),
      c(NA,NA,NA,NA,NA,NA,"Spain","S15",NA,NA,NA,"HSP70","60",NA,NA,NA,28,NA,NA,NA,NA)
)

# Remove all data with FoldChange==NA
# At this step I decide whether to take AllOutliersRemoved or AllBoxplotOutliersRemoved

#FT32 <- AllBoxplotOutliersRemoved32[is.na(AllBoxplotOutliersRemoved32$FoldChange)!=TRUE,]
#Data32.1 <- tapply(FT32$MeanCT,list(FT32$Gene,FT32$Population,FT32$Treatment),length)

#FT28 <- AllBoxplotOutliersRemoved28[is.na(AllBoxplotOutliersRemoved28$FoldChange)!=TRUE,]
#Data28.1 <- tapply(FT28$MeanCT,list(FT28$Gene,FT28$Population,FT28$Treatment),length)

# Do the analysis for the 32°C and the 28°C stress experiment and put
# the results for the three Hsps in a list.

FT <- rbind(FT28,FT32)
# Combine the stress data

HSP70Compare <- subset(FT,FT$Gene=="HSP70")
HSP90Compare <- subset(FT,FT$Gene=="HSP90")
sHSPCompare <- subset(FT,FT$Gene=="sHSP")

HSPs <- c("HSP70Compare","HSP90Compare","sHSPCompare")

Meanslist <- vector("list",2*length(HSPs))
SElist <- vector("list",2*length(HSPs))
significancelist <- vector("list",2*length(HSPs))
significancenumbers <- vector("list",2*length(HSPs))
ANOVAlist <- vector("list",2*length(HSPs))
CIsignificances <- vector("list",2*length(HSPs))
ciulist <- vector("list",2*length(HSPs))
cillist <- vector("list",2*length(HSPs))
Comparison15 <- vector("list",2*length(HSPs))
Comparison60 <- vector("list",2*length(HSPs))
Comparison24 <- vector("list",2*length(HSPs))

for (l in 1:length(HSPs)){
# Here I can change which gene shall be analyzed
overall <- get(HSPs[l])

for (t in c(28,32)){

if (t==28){H=l
       }else{H=l+3
         }
d <- subset(overall,overall$Temperature==t,drop=TRUE)

d.Means <- as.matrix(tapply(as.numeric(as.vector(d$FoldChange)),list(as.factor(as.vector(d$Population)),as.vector(d$Treatment)),mean,na.rm=TRUE))
d.Means <- as.matrix(rbind(d.Means[3,c(1,2,4,3)],d.Means[1,c(1,2,4,3)],d.Means[2,c(1,2,4,3)],d.Means[4,c(1,2,4,3)]))
rownames(d.Means) <- c("Norway","Denmark","France","Spain")

Meanslist[[H]] <- d.Means

library(plotrix)

d.SEs <- tapply(as.numeric(as.vector(d$FoldChange)),list(as.factor(as.vector(d$Population)),as.vector(d$Treatment)),std.error)
d.SEs <- as.matrix(rbind(d.SEs[3,c(1,2,4,3)],d.SEs[1,c(1,2,4,3)],d.SEs[2,c(1,2,4,3)],d.SEs[4,c(1,2,4,3)]))
rownames(d.SEs) <- c("Norway","Denmark","France","Spain")

SElist[[H]] <- d.SEs

d.ANOVA <- f1.ld.f1(y=d$FoldChange,time=d$Treatment,group=d$Population,subject=d$PopInd,time.name="Duration",group.name="Population",time.order=c("0","15","60","24h"),group.order=c("Norway","Denmark","France","Spain"),plot.RTE=TRUE, show.covariance=TRUE,order.warning=TRUE,description=FALSE)

d.A <- d.ANOVA$ANOVA.test
ANOVAlist[[H]] <- d.A

# Making a Dunnett-wise comparison with confidence intervals to see if
# the hsp gene expression is significantly upregulated

Du <- c("0","15","60","24h")
Po <- c("Norway","Denmark","France","Spain")

Ds <- numeric(0)
Ps <- character(0)
ls <- numeric(0)
us <- numeric(0)

for (D in Du){
for (P in Po){
Ds <- c(Ds,D)
Ps <- c(Ps,P)
V <- as.numeric(as.vector(subset(d$FoldChange,d$Treatment==D&d$Population==P,drop=TRUE)))
a=numeric(1000)
for (i in 1:1000){
a[i] <- mean(sample(V,length(V),replace=TRUE),na.rm=TRUE)
}
low=quantile(a,0.025,na.rm=TRUE)
up=quantile(a,0.975,na.rm=TRUE)

ls <- c(ls,low)
us <- c(us,up)
}
}

# Alternatively, I might test for each species a dunnett-wise
# comparsion (to the PI_Abs values) with the function mctp.rm in the
# package nparcomp

d.CIus <-  matrix(data = us, nrow = 4, ncol = 4, byrow = FALSE)
rownames(d.CIus) <- c("Norway","Denmark","France","Spain")
colnames(d.CIus) <- c(0,15,60,24)
ciulist[[H]] <- d.CIus

d.CIls <-  matrix(data = ls, nrow = 4, ncol = 4, byrow = FALSE)
rownames(d.CIls) <- c("Norway","Denmark","France","Spain")
colnames(d.CIls) <- c(0,15,60,24)
cillist[[H]] <- d.CIls

d.CIsignificance <- character(length(ls))
d.CIsignificance[which(ls>1)]="*"
d.CIsign.matrix <- matrix(data=d.CIsignificance, nrow = 4, ncol = 4, byrow = FALSE)
rownames(d.CIsign.matrix) <- c("Norway","Denmark","France","Spain")
colnames(d.CIsign.matrix) <- c(0,15,60,24)
CIsignificances[[H]] <- d.CIsign.matrix

library("nparcomp")
# At each of the time points, comparing the populations to each other

# For time point 0, I have made a separate analysis.

# 15 mins
Hs.Pop15 <- subset(d,d$Treatment=="15",drop=TRUE)

Paircomp <- nparcomp(as.numeric(as.vector(Hs.Pop15$FoldChange))~Hs.Pop15$Population,data=Hs.Pop15,type="Tukey",conf.level=0.95,alternative="two.sided",plot.simci=TRUE,info=TRUE,asy.method="mult.t")

Comparison15[[H]]=Paircomp$Analysis

significancenumbers.15=Paircomp$Analysis[c(2,4,6,1,3,5),6]
significancesTrue <- significancenumbers.15<0.05
names(significancesTrue) <- c("N-D","N-F","N-S",
                       "D-F","D-S",
                       "F-S")
library("multcompView")
Comparisons <- c("N","D","F","S")
Letters.15 <- multcompLetters(significancesTrue)$Letters[match(c("N","D","F","S"),names(multcompLetters(significancesTrue)$Letters))]

if(length(unique(Letters.15)) == 1){
  Letters.15=rep("",4)
}else{Letters.15=Letters.15}

# 60 mins
Hs.Pop60 <- subset(d,d$Treatment=="60",drop=TRUE)

Paircomp <- nparcomp(as.numeric(as.vector(Hs.Pop60$FoldChange))~Hs.Pop60$Population,data=Hs.Pop60,type="Tukey",conf.level=0.95,alternative="two.sided",plot.simci=TRUE,info=TRUE,asy.method="mult.t")

Comparison60[[H]]=Paircomp$Analysis

significancenumbers.60=Paircomp$Analysis[c(2,4,6,1,3,5),6]
significancesTrue <- significancenumbers.60<0.05
names(significancesTrue) <- c("N-D","N-F","N-S",
                       "D-F","D-S",
                       "F-S")
library("multcompView")
Comparisons <- c("N","D","F","S")
Letters.60 <- multcompLetters(significancesTrue)$Letters[match(c("N","D","F","S"),names(multcompLetters(significancesTrue)$Letters))]

if(length(unique(Letters.60)) == 1){
  Letters.60=rep("",4)
}else{Letters.60=Letters.60}

# 24 h
Hs.Pop24 <- subset(d,d$Treatment=="24h",drop=TRUE)

Paircomp <- nparcomp(as.numeric(as.vector(Hs.Pop24$FoldChange))~Hs.Pop24$Population,data=Hs.Pop24,type="Tukey",conf.level=0.95,alternative="two.sided",plot.simci=TRUE,info=TRUE,asy.method="mult.t")

Comparison24[[H]]=Paircomp$Analysis

significancenumbers.24=Paircomp$Analysis[c(2,4,6,1,3,5),6]
significancesTrue <- significancenumbers.24<0.05
names(significancesTrue) <- c("N-D","N-F","N-S",
                       "D-F","D-S",
                       "F-S")
library("multcompView")
Comparisons <- c("N","D","F","S")
Letters.24 <- multcompLetters(significancesTrue)$Letters[match(c("N","D","F","S"),names(multcompLetters(significancesTrue)$Letters))]

if(length(unique(Letters.24)) == 1){
  Letters.24=rep("",4)
}else{Letters.24=Letters.24}

significancelist[[H]] <-  as.data.frame(cbind(Letters.15,Letters.60,Letters.24))
significancenumbers[[H]] <-  as.data.frame(cbind(significancenumbers.15,significancenumbers.60,significancenumbers.24))
rownames(significancenumbers[[H]])=c("N-D","N-F","N-S",
                       "D-F","D-S",
                       "F-S")

}}

listnames <- c("HSP70.28","HSP90.28","sHSP.28","HSP70.32","HSP90.32","sHSP.32")

names(Meanslist) <- listnames
names(SElist) <- listnames
names(significancelist) <- listnames
names(significancenumbers) <- listnames
names(ANOVAlist) <- listnames
names(ciulist) <- listnames
names(cillist) <- listnames
names(Comparison15) <- listnames
names(Comparison60) <- listnames
names(Comparison24) <- listnames
names(CIsignificances) <- listnames

##### Plotting the results

error.bar <- function(x, y, upper, lower=upper, length=0.05,...){
        if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
        stop("vectors must be same length")
        arrows(x,upper, x, lower, angle=90, code=3, length=length, ...)
        }

error.bar2 <- function(x, y, upper, lower=upper, length=0.05,...){
        if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
        stop("vectors must be same length")
        arrows(x,y+upper, x, y-lower, angle=90, code=3, length=length, ...)
        }

######################################################
############# Plotting ###############################
######################################################

error.bar3 <- function(x, y, upper, lower=upper, length=0.05,...){
        if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
        stop("vectors must be same length")
        arrows(lower,x,upper, x, angle=90, code=3, length=length, ...)
        }

cnorway <- "#fdfdfd"
cdenmark <- "#808080"
cfrance<- "#dfdfdf"
cspain <- "#202020"

################ Plot for sHSP:
png(filename="/home/alj/Documents/writing/2012HSR/2012HeatShockResponse/Audioslides/images/TreatmentComparisonsSHSP.png",width=60,height=65,units='mm',res=700,pointsize=10)
#The line width of 1 is 1/96 inch which is about 0.25mm
par(xpd=NA,mar=c(1,0,2,0),oma=c(3,6.5,0,0),mgp=c(4,2,1),font=1,ps=10,mfrow=c(2,1),bg=NA)

# 28°C stress

Means28 <- Meanslist$sHSP.28[,2:4]
SEs28 <- SElist$sHSP.28[,2:4]
significance28 <- c(as.character(significancelist$sHSP.28[,1]),
                    as.character(significancelist$sHSP.28[,2]),
                    as.character(significancelist$sHSP.28[,3]))

CIsignificance28 <- c(as.character(CIsignificances$sHSP.28[,2]),
                    as.character(CIsignificances$sHSP.28[,3]),
                    as.character(CIsignificances$sHSP.28[,4]))

barx <- barplot(Means28[,3], beside=TRUE,col=c(rgb(51,102,0,maxColorValue=255),rgb(255,221,17,maxColorValue=255),rgb(102,51,153,maxColorValue=255),rgb(51,221,238,maxColorValue=255)),border="white",names.arg=c("15 min","60 min","24 h"),xaxt="n",main="28 °C", ylim=c(1,10000),axis.lty=1,xlab="", ylab="",lwd=1,cex.lab=1,cex.axis=1,las=1,cex.names=1,cex.main=0.8,ylog=TRUE,log="y",axis=FALSE)
axis(2, at=c(1,10,100,1000,10000),las=1)
error.bar2(barx,Means28[,3],SEs28[,3],lwd=1)

distances <- Means28[,3]
distances <- distances+7000
text(barx,distances,significance28[9:12],cex=1)

#if (ANOVAlist$sHSP.28[2,3]<=0.05){
#text(barx,distances,CIsignificance28,cex=2)
#}

## Means28 <- Meanslist28$sHSPCompare[,2:4]
## SEs28 <- SElist28$sHSPCompare[,2:4]
## significance28 <- c(as.character(significancelist28$sHSPCompare[,1]),
##                     as.character(significancelist28$sHSPCompare[,2]),
##                     as.character(significancelist28$sHSPCompare[,3]))

## barx <- barplot(Means28[,3], beside=TRUE,col=c(rgb(51,102,0,maxColorValue=255),rgb(255,221,17,maxColorValue=255),rgb(102,51,153,maxColorValue=255),rgb(51,221,238,maxColorValue=255)),border="white",names.arg=c("15 min","60 min","24 h"),xaxt="n",main="28°C", ylim=c(1,10000),axis.lty=1,xlab="", ylab="",lwd=1,cex.main=1,cex.lab=1,cex.axis=1,las=1,cex.names=1,cex.main=1,ylog=TRUE,log="y",axis=FALSE)
## axis(2, at=c(1,10,100,1000,10000),las=1)
## error.bar2(barx,Means28[,3],SEs28[,3],lwd=1)

## distances <- Means28[,3]
##

# 32°C stress

# 32°C stress
Means32 <- Meanslist$sHSP.32[,2:4]
SEs32 <- SElist$sHSP.32[,2:4]
significance32 <- c(as.character(significancelist$sHSP.32[,1]),
                    as.character(significancelist$sHSP.32[,2]),
                    as.character(significancelist$sHSP.32[,3]))

CIsignificance32 <- c(as.character(CIsignificances$sHSP.32[,2]),
                    as.character(CIsignificances$sHSP.32[,3]),
                    as.character(CIsignificances$sHSP.32[,4]))

barx <- barplot(Means32[,3], beside=TRUE,col=c(rgb(51,102,0,maxColorValue=255),rgb(255,221,17,maxColorValue=255),rgb(102,51,153,maxColorValue=255),rgb(51,221,238,maxColorValue=255)),border="white",names.arg="",main="32 °C", ylim=c(1,10000),axis.lty=1,xlab="", ylab="",lwd=1,cex.main=1,cex.lab=1,cex.axis=1,las=1,cex.names=1,cex.main=0.8,ylog=TRUE,log="y",axes=FALSE,xaxt="n")
axis(2, at=c(1,10,100,1000,10000),las=1)

error.bar2(barx,Means32[,3],SEs32[,3],lwd=1)

distances <- Means32+7000

#text(barx,distances,significance32[9:12],cex=1)

#mtext(side = 2, text = expression(paste("Fold change in relative normalized gene expression")), line = 5, ps=10,outer=TRUE,cex=1.2,at=0.45)

dev.off()
dev.off(dev.prev())


calcpvalue <- function(wordlistSize, seg1Count, seg2Count, seg1Seg2Count)
{
  seg1NotSeg2Count <- seg1Count - seg1Seg2Count
  notSeg1Seg2Count <- seg2Count - seg1Seg2Count
  notSeg1NotSeg2Count = wordlistSize - seg1Seg2Count - notSeg1Seg2Count - seg1NotSeg2Count
  x <- matrix(c(seg1Seg2Count, notSeg1Seg2Count, seg1NotSeg2Count, notSeg1NotSeg2Count), 2)
  p <- chisq.test(x, simulate.p.value = TRUE, B = 100000)$p.value
  return(p / 2)
}

dowork <- function(wordlistSize)
{
  data <- c(0, 0, 0, 0)
  startCount <- 2
  for (seg1Count in 2:round(wordlistSize * 0.3))
  {
    firstCount <- 0
    prevCount <- 1
    for (seg2Count in seg1Count:round(wordlistSize * 0.3))
    {
      found <- FALSE
      for (seg1Seg2Count in max(prevCount, startCount):seg1Count)
      {
        p <- calcpvalue(wordlistSize, seg1Count, seg2Count, seg1Seg2Count)
        if (p < 0.01)
        {
          if (prevCount != seg1Seg2Count)
            data <- rbind(data, c(wordlistSize, seg1Count, seg2Count, seg1Seg2Count))
          if (firstCount == 0)
            firstCount <- seg1Seg2Count
          prevCount = seg1Seg2Count
          found <- TRUE
          break
        }
      }
      if (!found)
        break
      if (prevCount == seg1Count)
        break;
    }
    startCount <- firstCount
  }
  if (dim(data)[1] == 2)
  {
    data <- data[-1,]
    dim(data) <- c(1, 4)
  }
  else
  {
    data <- data[-1,]
  }
  return(data)
}

require("parallel")

filename <- "RegularSoundCorrespondenceThresholdTable.txt"
file.create(filename)
cl <- makeCluster(detectCores())
clusterExport(cl, list("calcpvalue"))
for (data in parLapply(cl, seq(10, 1000, 10), dowork))
  write.table(data, filename, TRUE, sep = "\t", row.names = FALSE, col.names = FALSE)
stopCluster(cl)

system(paste("powershell -file compress.ps1 -i ", filename, " -o RegularSoundCorrespondenceThresholdTable.bin", ""))


# downClipGPM.R
# from Anton Surunis (thanks!)
# NASA DEVELOP: Navajo Nation Climate Summer 2015
#
# checks which gpm data is missing, fetches those missing, and
# clips it to the area of interest.

downClipGPM <- function(progress) {
  #Checks if required packages are installed. If not, they are installed.
  list.of.packages <- c("rhdf5", "raster","rgdal","sp","httr","lubridate")
  new.packages <- list.of.packages[!(list.of.packages %in% installed.packages()[,"Package"])]
  if(length(new.packages)) install.packages(new.packages)

  #directories
  DIR_RAW     <- "data/downloadGPM/raw/"
  DIR_CLIPPED <- "data/downloadGPM/clipped/"

  #Loads required packages.
  library(rhdf5)
  library(raster)
  library(rgdal)
  library(sp)
  library(httr)
  library(lubridate)

  n <- 10
  progress$inc(1/n, detail = paste("Checking for new GPM Data"))
  enddate=Sys.Date()
  datecheck=format(Sys.Date(), "%d")
  #if (datecheck>27){
  #  enddate=Sys.Date()-days(10)
  #}

  #Creates list of dates from CHIRPS start date to current date.
  times <- seq(as.Date("1981-01-01"),enddate,by="1 month") #1981
  #Create function for building file names from given dates.
  make_names <- function(x) {
    strdate <- as.character(x)
    year    <- substring(strdate,1,4)
    month   <- substring(strdate,6,7)
    return(paste0(year,month,"_CHIRPS.tif"))
  }

  #Create list of file names for CHIRPS rasters.
  names <- make_names(times)

  #Function for creating necessary ftp links.
  makeftp_link <- function(x){
    strdate <- as.character(x)
    year    <- substring(strdate,1,4)
    month   <- substring(strdate,6,7)
    result  <- sprintf("ftp://ftp.chg.ucsb.edu/pub/org/chg/products/CHIRPS-2.0/global_monthly/tifs/chirps-v2.0.%s.%s.tif.gz", year, month)
    return(result)
  }

  #Use function on list of dates to make list of links.
  links <- lapply(times, makeftp_link)
  #Check which files need to be downloaded.
  # setwd("C:/2015Su_ARC_NNClimate_FileStructure/GPM Data/Unprocessed Files")
  links <- links[!(substr(links,76,nchar(links))%in%list.files(DIR_RAW))]

  progress$inc(1/n, detail = paste("Checking for new data ..."))

  #Downloads all missing files, stopping when the first non-existent file is found.
  numDownloaded <- 0
  for(i in seq(links)) {
    url <- as.character(links[i])
    output_file <- substr(links[i],76,nchar(links[i]))
    output_file <- paste0(DIR_RAW, output_file)
    try({
      if(file.exists(substr(output_file,1,nchar(output_file)-3))=="FALSE"){
        GET(url, write_disk(output_file))
      }
      numDownloaded <- numDownloaded + 1
      progress$inc(0, detail = paste("Downloading", i+1, "of", length(links), "..."))
    }, silent=TRUE)

    #if(file.size(output_file) == 0){
    #  unlink(output_file)
    #  break
    #}
  }

  progress$inc(1/n, detail = paste("Finished Downloading ..."))

  #if(numDownloaded == 0)
  #  print("0.1")
  #  return(numDownloaded)
  #  print("0.2")

  progress$inc(2/n, detail = paste("Clipping the data to study area"))

  #List contents of unprocessed GPM folder.
  files <- list.files(DIR_RAW, full.names = TRUE)
  require(R.utils)
  library(R.utils)
  filelen=length(files)
  filecnt=0
  for (i in files) {
    filecnt=filecnt+1
    #if no data in file, delete it
    if(file.size(i)==0){
      file.remove(i)
    } else if(file.size(i)>0){
      if(substr(i,nchar(i)-2,nchar(i))==".gz")
        gunzip(i)
    }
  }
  files <- list.files(DIR_RAW, full.names = TRUE)

  GPMProcess <- function(GPMPrecip){
    ##Define boundaries.
    xmin = -180
    xmax = 180
    ymin = -50
    ymax = 50

    rast <- raster(GPMPrecip)

    #Define extent and projection of raster.
    extent(rast) <- c(xmin,xmax,ymin,ymax)
    projection(rast) <- CRS("+proj=longlat +datum=WGS84")
    #Create cropping boundary and crop raster.
    e <- extent(c(-113.149999004,-104.349998873,33.2999997512,38.499149))
    cropped_rast <- crop(rast,e)
    return(cropped_rast)
  }
  progress$inc(1/n, detail = paste("Clipping the data to study area ..."))

  #Use GPMProcess function to read in hdf5 files, convert them to rasters, define their projections, and crop to a smaller extent.
  cropped <- lapply(files, GPMProcess)

  ##Use function to make names for files and clips to length of files.
  names <- names[1:length(files)]
  times <- times[1:length(files)]
  for(i in seq(length(names))){
    writeRaster(cropped[[i]], filename=paste0(DIR_CLIPPED, names[i]), format="GTiff", overwrite = TRUE)
  }

  progress$inc(4/n, detail = paste("Done."))
  return(numDownloaded)
}


##############################################################################
# FIPEX_run_DCI_reg.r
# original DCI file from pre-2020
write("ERROR",file='out.txt')
# write environment file to redirect temp folder, in cases where user does not
# have permissions to the LocalApps folder - GO, 20200105
write( paste(paste(paste("TMP = ", Sys.getenv('R_USER'), sep=""),paste("\nTMPDIR = ", Sys.getenv('R_USER'), sep="")),paste("\nTEMP = ", Sys.getenv('R_USER'), sep="")), file=file.path(Sys.getenv('R_USER'), '.Renviron'))
source("FIPEX_output_to_R_input.r")
FIPEX_output_to_R_input()
source("dci_fxs.r")
x = try(dci_fxs(),silent=FALSE)
if(class(x)=='data.frame' | class(x)=='list'){
  write.table(x,file='out.txt')
} else{
  write("ERROR",file='out.txt')
}

dci_fxs<-function(all_sections=F){

  #source in the 7 functions in R
  #see each function for an explanation of inputs and outputs

  source("convert_gis_output_to_r_format.r")
  source("get_adj_matrix_from_gis.r")
  source("graph_fx.r")
  source("sum_fx.r")
  source("graph_and_data_setup_for_DCI.r")
  source("dci_calc_fx.r")
  source("dci_calc.r")

  convert_gis_output_to_r_format()
  adj_matrix<-get_adj_matrix_from_gis()
  #have to assign it an object name as this function gets called in in "graph.and.data.setup.for.DCI.r" and "sum.fx.r"

  graph_fx(plot_it=F)
  passability<-read.csv("segments_and_barriers.csv")

  NB<-graph_and_data_setup_for_DCI(passability=passability, adj_matrix=adj_matrix)
  dci_calc(NB,all_sections=all_sections)
}


#' A wrapper of `colorRamp2`
#' @param i,j Integer scalar. Indices of ego and alter from 1 through n.
#' @param p Numeric scalar from 0 to 1. Proportion of mixing.
#' @param vcols Vector of colors.
#' @param alpha Numeric scalar from 0 to 1. Passed to [colorRamp2]
#' @return A color.
#' @noRd
edge_color_mixer <- function(i, j, vcols, p = .5, alpha = .15) {

  grDevices::adjustcolor(grDevices::rgb(
    colorRamp2(vcols[c(i,j)], alpha = FALSE)(p),
    maxColorValue = 255
  ), alpha = alpha)

}

#' Plot a network
#'
#' @param x An `igraph` object.
#' @param bg.col Color of the background.
#' @param layout Numeric two-column matrix with the graph layout.
#' @param vertex.size Numeric vector of length `vcount(x)`. Absolute size of the vertex.
#' @param vertex.nsides Numeric vector of length `vcount(x)`. Number of sizes of
#' the vertex. E.g. three is a triangle, and 100 approximates a circle.
#' @param vertex.color Vector of length `vcount(x)`. Vertex colors.
#' @param vertex.size.range Vector of length `vcount(x)`.
#' @param vertex.frame.color Vector of length `vcount(x)`.
#' @param vertex.frame.prop Vector of length `vcount(x)`. What proportion of the
#' vertex does the frame occupy (values between 0 and 1).
#' @param vertex.rot Vector of length `vcount(x)`. Passed to [npolygon],
#' elevation degree from which the polygon is drawn.
#' @param vertex.label Character vector of length `vcount(x)`. Labels.
#' @param vertex.label.fontsize Numeric vector.
#' @param vertex.label.color Vector of colors of length `vcount(x)`.
#' @param vertex.label.fontfamily Character vector of length `vcount(x)`.
#' @param vertex.label.fontface See [grid::gpar]
#' @param vertex.label.show Numeric scalar. Proportion of labels to show as the
#' top ranking according to `vertex.size`.
#' @param vertex.label.range Numeric vector of size 2 or 3. Relative scale of
#' `vertex.label.fontsize` in points (see [grid::gpar]).
#' @param edge.color A vector of length `ecount(x)`. Can be `NULL` in which case
#' the color is picked as a mixture between ego and alters' `vertex.color` values.
#' @param edge.width Vector of length `ecount(x)`.
#' @param edge.width.range Vector of length `ecount(x)`.
#' @param edge.arrow.size Vector of length `ecount(x)`.
#' @param edge.curvature Numeric vector of length `ecount(x)`. Curvature of edges
#' in terms of radians.
#' @param edge.line.lty Vector of length `ecount(x)`.
#' @param edge.line.breaks Vector of length `ecount(x)`. Number of vertices to
#' draw (approximate) the arc (edge).
#' @param sample.edges Numeric scalar between 0 and 1. Proportion of edges to sample.
#' @param skip.vertex,skip.edges,skip.arrows Logical scalar. When `TRUE` the object
#' is not plotted.
#' @param add Logical scalar.
#' @param zero.margins Logical scalar.
#' @importFrom igraph layout_with_fr degree vcount ecount
#' @importFrom grDevices adjustcolor rgb
#' @importFrom graphics lines par plot polygon rect segments plot.new plot.window
#'
#' @details
#' In the case of `edge.color`, the user can specify colors using [netplot-formulae].
#' @return An object of class `c("netplot", "gTree", "grob", "gDesc")`. The object
#' has an additional set of attributes:
#' * `.xlim, .ylim` vector of size two with the x-asis/y-axis limits.
#' * `.layout` A numeric matrix of size `vcount(x) * 2` with the vertices positions
#' * `.edgelist` A numeric matrix, The edgelist.
#'
#' @examples
#' library(igraph)
#' library(netplot)
#' set.seed(1)
#' x <- sample_smallworld(1, 200, 5, 0.03)
#'
#' plot(x) # ala igraph
#' nplot(x) # ala netplot
#' @name nplot
#' @aliases netplot
NULL

#' @export
#' @rdname nplot
nplot <- function(...) UseMethod("nplot")

#' @export
#' @rdname nplot
nplot.igraph <- function(
  x,
  layout       = igraph::layout_nicely(x),
  vertex.size  = igraph::degree(x, mode="in"),
  vertex.label = igraph::vertex_attr(x, "name"),
  edge.width   = igraph::edge_attr(x, "weight"),
  skip.arrows  = !igraph::is_directed(x),
  ...
  ) {

  if (!length(edge.width))
    edge.width <- 1L

  nplot.default(
    edgelist     = igraph::as_edgelist(x, names = FALSE),
    layout       = layout,
    vertex.size  = vertex.size,
    vertex.label = vertex.label,
    edge.width   = edge.width,
    skip.arrows = skip.arrows,
    ...
  )

}

#' @export
#' @rdname nplot
#' @importFrom network as.edgelist
#' @importFrom sna gplot.layout.kamadakawai
nplot.network <- function(
  x,
  layout       = sna::gplot.layout.kamadakawai(x, NULL),
  vertex.size  = sna::degree(x, cmode="indegree"),
  vertex.label = network::get.vertex.attribute(x, "vertex.names"),
  skip.arrows  = !network::is.directed(x),
  ...
) {

  nplot.default(
    edgelist    = network::as.edgelist(x),
    layout      = layout,
    vertex.size = vertex.size,
    vertex.label = vertex.label,
    skip.arrows = skip.arrows,
    ...
  )

}

netplot_theme <- (function() {

  v <- grDevices::hcl.colors(1)
  darkv <- adjustcolor(
    v,
    red.f   = .5,
    green.f = .5,
    blue.f  = .5
  )

  default <- list(
    vertex.core.col   = v,
    vertex.core.fill  = v,
    vertex.frame.col  = darkv,
    vertex.frame.fill = darkv,
    edge.col = ~ego(alpha=0) + alter(alpha = .7),
    name      = "default"
  )

  current <- default

  list(
    set = function(...) {
      dots <- list(...)
      if (!length(dots$name))
        dots$name <- "user"

      current <<- rev(dots)
    },
    get = function() current,
    reset = function() {
      message("Restablishing the default theme")
      current <<- default
    },
    vertex_defaults = function() {
      str(current[grepl("^vertex\\.", names(current))])
    },
    edge_defaults = function() {
      str(current[grepl("^edge\\.", names(current))])
    }
  )

})()

#' @export
#' @rdname nplot
#' @param edgelist An edgelist.
#' @return
#' In the case of `nplot.default`, an object of class `netplot` and `grob` (see
#' [grid::grob]) with the following slots:
#'
#' - `children` The main `grob` of the object.
#' - `name` Character scalar. The name of the plot
#' - `.xlim` and `.ylim` Two vectors indicating the limits of the plot
#' - `.layout` A two-column matrix with the location of the vertices.
#' - `.edgelist` A two-column matrix, an edgelist.
#' - `.N` Integer. The number of vertices.
#' - `.M` Integer. The number of edges.
#'
#' The `children` `grob` contains the following two objects:
#'
#' - `background` a `grob` rectangule.
#' - `graph` a `gTree` that contains each vertex and each edge
#' of the figure.
#' @seealso [nplot_base]
nplot.default <- function(
  edgelist,
  layout,
  vertex.size             = 1,
  bg.col                  = "transparent",
  vertex.nsides           = 15,
  vertex.color            = grDevices::hcl.colors(1),
  vertex.size.range       = c(.01, .03),
  vertex.frame.color      = grDevices::adjustcolor(vertex.color, red.f = .75, green.f = .75, blue.f = .75),
  vertex.rot              = 0,
  vertex.frame.prop       = .2,
  vertex.label            = NULL,
  vertex.label.fontsize   = NULL,
  vertex.label.color      = "black",
  vertex.label.fontfamily = "HersheySans",
  vertex.label.fontface   = "bold",
  vertex.label.show       = .3,
  vertex.label.range      = c(5, 15),
  edge.width              = 1,
  edge.width.range        = c(1, 2),
  edge.arrow.size         = NULL,
  edge.color              = ~ ego(alpha = .25) + alter,
  edge.curvature          = pi/3,
  edge.line.lty           = "solid",
  edge.line.breaks        = 10,
  sample.edges            = 1,
  skip.vertex             = FALSE,
  skip.edges              = FALSE,
  skip.arrows             = skip.edges,
  add                     = FALSE,
  zero.margins            = TRUE,
  ...
  ) {

  # listing objects
  netenv <- environment()

  netenv$N <- nrow(layout)
  netenv$M <- nrow(edgelist)

  # This function will repeat a patter taking into account the number of columns
  .rep <- function(x, .times) {
    if (grepl("range$", p) | inherits(x, "formula"))
      return(x)
    matrix(rep(x, .times), ncol = length(x), byrow = TRUE)
  }

  # Checking defaults for vertex
  vertex_par <- ls(pattern = "^vertex\\.", envir = netenv)
  for (p in vertex_par)
    if (length(netenv[[p]]) > 0 && length(netenv[[p]]) < netenv$N)
      netenv[[p]] <- .rep(netenv[[p]], netenv$N)

  # Checking defaults for edges
  edge_par <- ls(pattern = "^edge\\.", envir = netenv)
  for (p in edge_par)
    if (length(netenv[[p]]) > 0 && length(netenv[[p]]) < netenv$M)
      netenv[[p]] <- .rep(netenv[[p]], netenv$M)

  # Adjusting size -------------------------------------------------------------

  # Adjusting layout to fit the device
  netenv$layout <- fit_coords_to_dev(netenv$layout)

  # Rescaling size
  if (!skip.vertex) {
    netenv$vertex.size <- rescale_size(
      netenv$vertex.size,
      rel = netenv$vertex.size.range
      )
  } else
    netenv$vertex.size <- rep(0, netenv$N)

  # Rescaling edges
  netenv$edge.width <- rescale_size(
    netenv$edge.width/max(netenv$edge.width, na.rm=TRUE),
    rel = netenv$edge.width.range
    )

  # Rescaling arrows
  if (!length(netenv$edge.arrow.size))
    netenv$edge.arrow.size <- netenv$vertex.size[edgelist[,1]]/1.5

  if (netenv$skip.arrows)
    netenv$edge.arrow.size <- rep(0.0, length(netenv$edge.arrow.size))

  # Rescaling text
  if (!length(netenv$vertex.label.fontsize))
    netenv$vertex.label.fontsize <- rescale_size(
      netenv$vertex.size,
      rel = netenv$vertex.label.range
      )

  # Computing label threshold
  netenv$label_threshold <- stats::quantile(
    netenv$vertex.size, 1 - netenv$vertex.label.show[1])

  # Calculating arrow adjustment
  netenv$arrow.size.adj <- netenv$edge.arrow.size*cos(pi/6)/(
    cos(pi/6) + cos(pi - pi/6 - pi/1.5)
  )/cos(pi/6)

  # Creating viewport with fixed aspectt ratio ----------------------------------
  netenv$xlim <- range(netenv$layout[,1], na.rm=TRUE)
  netenv$ylim <- range(netenv$layout[,2], na.rm=TRUE)

  # Creating layout
  # Solution from this answer https://stackoverflow.com/a/48084527
  asp <- grDevices::dev.size()
  lo  <- grid::grid.layout(
    widths  = grid::unit(1, "null"),
    heights = grid::unit(asp[2]/asp[1], "null"),
    respect = TRUE # This forcces it to the aspectt ratio
    )

  vp_graph <- grid::viewport(
    xscale         = netenv$xlim + .04*diff(netenv$xlim)*c(-1,1),
    yscale         = netenv$ylim + .04*diff(netenv$ylim)*c(-1,1),
    clip           = "off",
    layout.pos.col = 1,
    layout.pos.row = 1,
    name           = "graph-vp"
  )

  # Generating grobs -----------------------------------------------------------
  if (!skip.vertex) {
    grob.vertex <- vector("list", netenv$N)
    for (v in 1:netenv$N)
      grob.vertex[[v]] <- grob_vertex(netenv, v)
  } else
    grob.vertex <- NULL

  if (!skip.edges | !skip.arrows) {

    grob.edge <- vector("list", netenv$M)
    for (e in 1:netenv$M)
      grob.edge[[e]] <- grob_edge(netenv, e)

  } else
    grob.edge <- NULL

  # Agregated grob -------------------------------------------------------------
  ans <- do.call(
    grid::gTree,
    list(
      children = do.call(grid::gList, c(grob.edge, grob.vertex)),
      name     = "graph",
      vp       = grid::vpTree(
        parent   = grid::viewport(layout = lo, name = "frame-vp"),
        children = grid::vpList(vp_graph)
      )
    )
  )

  # Changing the plotting order
  ans$childrenOrder <- with(
    ans,
    c(
      childrenOrder[grepl("^edge.[0-9]+[-][0-9]+$", childrenOrder)],
      childrenOrder[grepl("^vertex[.][0-9]+$", childrenOrder)]
    ))

  # Adding background
  background <- grid::rectGrob(
    gp = grid::gpar(
      fill = bg.col,
      col  = grDevices::adjustcolor(bg.col, red.f = .75, green.f = .75, blue.f = .75)
    ),
    name = "background",
    vp   = grid::viewport(name = "background-vp")
  )

  ans <- grid::gTree(
    children  = grid::gList(background, ans),
    name      = netplot_name$new(),
    .xlim     = netenv$xlim,
    .ylim     = netenv$ylim,
    .layout   = netenv$layout,
    .edgelist = netenv$edgelist,
    .N        = netenv$N,
    .M        = netenv$M
  )

  class(ans) <- c("netplot", class(ans))

  # Passing edge color
  if (length(vertex.color))
    ans <- set_vertex_gpar(
      x       = ans,
      element = "core",
      fill    = vertex.color,
      col     = vertex.color
    )

  if (length(vertex.frame.color))
    ans <- set_vertex_gpar(
      x       = ans,
      element = "frame",
      fill    = vertex.frame.color,
      col     = vertex.frame.color
    )

  if (length(edge.color)) {

    ans <- set_edge_gpar(x = ans, element = "line", col = edge.color)

    gp <- get_edge_gpar(x = ans, element = "line", "col", simplify=FALSE)$col
    gp <- sapply(seq_along(gp), function(i) gp[[i]][netenv$edge.line.breaks[i]])

    ans <- set_edge_gpar(x = ans, "arrow", fill = gp, col=gp)
  }

  ans

}

#' Tracker of last printed (plotted) values of `netplot`
#' @noRd
.Last.netplot <- eval({

  env       <- new.env(parent = emptyenv())
  env$value <- NULL

  list(
    get = function() {
      env$value
    },
    set = function(x) {
      env$value <- x
      invisible()
    }
  )

})

#' @rdname nplot
#' @export
#' @param newpage Logical scalar. When `TRUE` calls [grid::grid.newpage].
#' @param y,... Ignored
print.netplot <- function(x, y = NULL, newpage=TRUE, ...) {

  # Drawing
  if (newpage) {
    grid::grid.newpage()
  }

  grid::grid.draw(x)

  # Storing the value
  .Last.netplot$set(x)

  # Returning
  invisible(x)

}

locate_vertex <- function(x) {

  # Trying to fecth the
  on.exit(grid::upViewport(0L))
  res <- tryCatch(grid::downViewport("graph-vp"), error = function(e) e)

  if (inherits(res, "error"))
    stop("Couldn't find the network region. Perhaps there's none?", call. = FALSE)

  loc <- grid::grid.locator()
  loc <- as.vector(unlist(loc))
  loc <- matrix(loc, ncol = 2, nrow = nrow(x$layout), byrow = TRUE)

  # Which is the closests one
  v <- which.min(abs(x$layout - loc))

  list(
    name = sprintf("vertex.%i", v),
    x    = loc[1,1],
    y    = loc[1,2],
    vp   = grid::current.viewport()
    )

}

# Look at `chull` from `grDevices`


#!/usr/bin/Rscript

##
# Plot the data with ggplot.
#
# For each plot their are two facets - the average of the _gsi_ being
# being summarised for each data and proportion of the runs for each
# paramater that have a significant (P < 0.05) result. There is probably
# some clever way to do this in one go with `viewports` and the like.
# I'm not clever enough, so just made two plots for each and pasted them
# together in Inkscape...
#
##

library(reshape)
library(ggplot2)

stat_sum_single <- function(fun=mean, geom="point", ...) {
       stat_summary(fun=fun, colour="black", geom=geom)
}

plot_div <- function(){
    theme_set(theme_bw())
    gsi_sims <- read.csv("data/gsi_2v4.csv")
    molten_sims <- melt(gsi_sims, id.var=c("comp", "t_div"))

    p <- ggplot(molten_sims, aes(t_div, value, colour=factor(comp)))

    svg("figures/divergence_pval.svg", width=8.5, height=4)
    print(p + stat_summary(fun.y=function(x) mean(x < 0.05), geom='line', size=1) +
        facet_grid(variable~.) + scale_colour_brewer(palette="Set1") )
    dev.off()

    svg("figures/divergence_gsi.svg", width=8.5, height=4)
    print(
        p +  stat_summary(fun.y='mean', geom='line', size=1) +
        facet_grid(variable~.) + scale_colour_brewer(palette="Set1")
    )
    dev.off()
}

plot_mig <- function(){
    theme_set(theme_bw())
    mig_sims <- read.csv("data/gsi_migration.csv")
    molten_sims <- melt(mig_sims, id.var=c("m"))
    p <- ggplot(molten_sims, aes(m, value, group=m))

    svg("figures/mig_pval.svg", width=8.5, height=4)
    print(
           p + geom_point(position='jitter', colour='grey70', size=1.2) +
               scale_x_log10() +
               stat_summary(fun.y=function(x) mean(x <0.05), geom='point') +
               facet_grid(variable~.)
               )
    dev.off()

    svg("figures/mig_pwgsi.svg", width=8.5, height=4)
    print(
           p + geom_boxplot() + facet_grid(variable~.) + scale_x_log10()
    )
    dev.off()
}

if(!interactive()){
    plot_div()
    plot_mig()
}


#---Demo of the code used for simulation of various models
# Dependencies on simulators.r and chartr-helperfunction.r
# Important parameters
# nCoh -- number of coherences
# nmc  -- number of simulated trials
# model

library(tictoc);
FASTRAND=FALSE;
source("chartr-HelperFunctions.r")

# Organize 4 rows, provide proper margins
par(mfrow = c(2,2), mar=c(6, 6, 1, 1))
nCoh = 5;

tic("all")
# Simulate 50000 trials to show clear trends
nmc = 10000;

# Vanilla DDM model, variable drift rate
model = "DDM"
fP = paramsandlims(model,nCoh, fakePars = TRUE)
currParams = fP$fakeParams
currParams["aU"] = 0.09
tic("DDM")
R = simulateRTs(model, currParams , n=nmc, nds=nCoh, FASTRAND=FASTRAND)
toc();

# DDM model with variable drift rate, baseline and non-decision time
model = "DDMSvSzSt"
fP = paramsandlims(model,nCoh, fakePars = TRUE)
currParams = fP$fakeParams
currParams["zmin"] = 0.9*currParams["aU"]/2;
currParams["zmax"] = 1.1*currParams["aU"]/2;
tic("DDMSvSzSt")
R = simulateRTs(model, currParams , n=nmc, nds=nCoh,FASTRAND=FASTRAND)
toc();

# Urgency gating model, variable drift rate
model = "UGMSv"
fP = paramsandlims(model,nCoh, fakePars = TRUE)
currParams = fP$fakeParams
currParams["aU"] = 3000;
tic("UGMSv")
R = simulateRTs(model, currParams , n=nmc, nds=nCoh,FASTRAND=FASTRAND)
toc();

# Ditterich model with variable drift rate.
model = "dDDMSv"
fP = paramsandlims(model,nCoh, fakePars = TRUE)
currParams = fP$fakeParams
currParams["aU"] = 0.09
tic("dDDMSv")
R = simulateRTs(model, currParams , n=nmc, nds=nCoh,FASTRAND=FASTRAND)
toc();

mtext('Probability Correct', side=1, outer=TRUE, line = -5, cex=1.5)
mtext('Reaction time (s)', side=2, outer=TRUE, line = -4, cex=1.5)
toc();


## 2. Getting Familiar With The Data ##

library(tidyverse)
recent_grads <- read_csv("recent_grads.csv")
glimpse(recent_grads)
names(recent_grads)
num_rows <- nrow(recent_grads)
num_cols <- ncol(recent_grads)

## 3. Selecting Columns ##

library(tidyverse)
recent_grads <- read_csv("recent_grads.csv")
rank_major_tibble <- select(recent_grads, Rank, Major)
no_major_code_tibble <- select(recent_grads, -Major_code)

## 4. Filtering Rows ##

library(tidyverse)
recent_grads <- read_csv("recent_grads.csv")
large_sample_majors <- filter(recent_grads, Sample_size > 100)
non_engineering_majors <- filter(recent_grads,
                                 Total < 70000,
                                 Median > 40000,
                                 Major_category != "Engineering")

## 5. Piping With The %>% Operator ##

library(tidyverse)
recent_grads <- read_csv("recent_grads.csv")
pipeline_output <- recent_grads %>%
  select(-Rank, -Major) %>%
  filter(Median < 50000)

## 6. Creating New Columns ##

library(tidyverse)
recent_grads <- read_csv("recent_grads.csv")
new_recent_grads <- recent_grads %>%
  mutate(
    prop_employed = Employed / Total,
    prop_women = Women / Total,
    prop_women_gt_employed = prop_women > prop_employed
  )

## 7. Sorting Data ##

library(tidyverse)
recent_grads <- read_csv("recent_grads.csv")
least_employed <- recent_grads %>%
  mutate(
    prop_employed = Employed / Total
  ) %>%
  arrange(prop_employed) %>%
  select(Major, Employed, Total, prop_employed)

head(least_employed)
least_employed_major <- "MILITARY TECHNOLOGIES"

## 8. Summarizing Data ##

library(tidyverse)
recent_grads <- read_csv("recent_grads.csv")
minmax_median_income <- recent_grads %>%
  summarize(
    min_income = min(Median),
    max_income = max(Median)
  )

## 9. Using Tibble Columns As Vectors ##

library(tidyverse)
recent_grads <- read_csv("recent_grads.csv")
medians <- recent_grads %>% pull(Median)
highest_median <- medians %>% max

Data Analyst in R/Step 1 - Introduction to R/2. Data Structures in R/4. Dataframes in R.r


#' Occupancy index
#'
#' @description Plots the estimates of the occupancy index,
#' as described in Diana et al. (2021).
#'
#' @param modelResults Output of the function \code{runModel}
#'
#' @importFrom magrittr %>%
#'
#' @export
#'
#' @return A plot with of the estimates. The interval represents the
#' 95\% credible interval and the dots represent the median.
#'
#' @examples
#'
#' plotOccupancyIndex(sampleResults)
#'
plotOccupancyIndex <- function(modelResults){

  years <- modelResults$dataCharacteristics$Years
  Y <- length(years)

  psi_mean_output <- modelResults$modelOutput$psi_mean_output
  psi_mean_output <- apply(psi_mean_output, 3, c)

  CI_psi_mean <- apply(psi_mean_output, 2, function(x){
    c(stats::quantile(x, probs = c(0.025, 0.975, .5)))
  })

  ggplot2::ggplot(data = NULL, ggplot2::aes(x = years,
                                            y = CI_psi_mean[3,],
                                            ymin = CI_psi_mean[1,],
                                            ymax = CI_psi_mean[2,])) + ggplot2::geom_point() + ggplot2::geom_errorbar() +
    ggplot2::geom_line() +
    ggplot2::ylab("Occupancy index") + ggplot2::scale_x_continuous(name = "Year", breaks = years) +
    ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5, size = 20),
                   axis.title = ggplot2::element_text(size = 20, face = "bold"),
                   axis.text = ggplot2::element_text(size = 13, face = "bold", angle = 90),
                   panel.grid.major = ggplot2::element_line(colour="grey", size=0.15),
                   panel.background = ggplot2::element_rect(fill = "white", color = "black")) +
    ggplot2::ylim(c(0,1))

}

#' Spatial Site Effect
#'
#' @description Plots the estimates of the the spatial site effects
#'
#' @param modelResults Output of the function \code{runModel}
#'
#' @importFrom magrittr %>%
#'
#' @export
#'
#' @return The posterior means of the spatial effect of each site on the map.
#'
#' @examples
#'
#' plotSpatialSitesEffect(sampleResults)
#'
plotSpatialSitesEffect <- function(modelResults){

  usingSpatial <- modelResults$dataCharacteristics$usingSpatial

  if(usingSpatial){

    X_tilde <- modelResults$dataCharacteristics$X_tilde
    X_centers <- nrow(X_tilde)

    years <- modelResults$dataCharacteristics$Years
    Y <- length(years)

    eps_unique_output <- modelResults$modelOutput$eps_unique_output
    beta_psi_output <- modelResults$modelOutput$beta_psi_output

    eps_unique_output <- apply(eps_unique_output, 2, c)
    beta_psi_output <- apply(beta_psi_output, 3, c)

    XY_sp_unique <- modelResults$dataCharacteristics$XY_sp_unique

    nSites <- nrow(XY_sp_unique)
    idxSite <- findClosestPoint(XY_sp_unique, X_tilde)
    SiteEffect <- sapply(1:nSites, function(i){
      # mean(beta_psi_output[,Y + idxSite[i]] + eps_unique_output[i])
      median(beta_psi_output[,Y + idxSite[i]] + eps_unique_output[i])
    })

    ggplot2::ggplot() +
      ggplot2::geom_point(data = NULL, ggplot2::aes(x = XY_sp_unique[,1],
                                                    y = XY_sp_unique[,2],  color = SiteEffect),
                          size = .5,
                          alpha = .5) +
      ggplot2::xlab("") + ggplot2::ylab("") + #theme(legend.title = element_blank())
      ggplot2::scale_color_gradientn(colors = c("red", "#00FF00"),
                                     limits = c(min(SiteEffect), max(SiteEffect))) +
      ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5, size = 20),
                     axis.title = ggplot2::element_text(size = 20, face = "bold"),
                     axis.text = ggplot2::element_text(size = 13, face = "bold", angle = 90),
                     panel.background = ggplot2::element_rect(fill = "white", color = "black"))

  } else {
    print("No spatial effect")
  }

}

#' Estimates of covariates on occupancy probability
#'
#' @description Plots the estimates of the covariates on the occupancy probability.
#'
#' @param modelResults Output of the function \code{runModel}
#'
#' @importFrom magrittr %>%
#'
#' @export
#'
#' @return A plot with of the estimates. The interval represents the
#' 95\% credible interval.
#'
#' @examples
#'
#' plotOccupancyCovariatesEffect(sampleResults)
#'
plotOccupancyCovariatesEffect <- function(modelResults) {
  usingSpatial <- modelResults$dataCharacteristics$usingSpatial

  X_tilde <- modelResults$dataCharacteristics$X_tilde
  if (usingSpatial) {
    X_centers <- nrow(X_tilde)
  } else {
    X_centers <- 0
  }

  years <- modelResults$dataCharacteristics$Years
  Y <- length(years)

  numTimeSpaceCov <-
    modelResults$dataCharacteristics$numTimeSpaceCov

  namesCovariates <-
    modelResults$dataCharacteristics$nameVariables_psi
  ncov_psi <- length(namesCovariates)

  if (usingSpatial) {
    namesCovariates_xt <- c("X_T", "Y_T")
  } else {
    namesCovariates_xt <- c()
  }

  namesCovariates_all <- c(namesCovariates_xt, namesCovariates)
  ncov_psi_all <- ncov_psi + numTimeSpaceCov

  beta_psi_output <- modelResults$modelOutput$beta_psi_output

  beta_psi_output <- apply(beta_psi_output, 3, c)

  betaeffect <-
    apply(beta_psi_output[, Y + X_centers + 1:ncov_psi_all], 2, function(x) {
      stats::quantile(x, probs = c(0.025, 0.5, 0.975))
    })

  colnames(betaeffect) <- namesCovariates_all

  ggplot2::ggplot(data = NULL,
                  ggplot2::aes(
                    x = colnames(betaeffect),
                    y = betaeffect[2, ],
                    ymin = betaeffect[1, ],
                    ymax = betaeffect[3, ]
                  )) + ggplot2::geom_point() + ggplot2::geom_errorbar() +
    ggplot2::ylab("Effect") + ggplot2::scale_x_discrete(name = "Covariates") +
    ggplot2::theme(
      plot.title = ggplot2::element_text(hjust = 0.5, size = 20),
      axis.title = ggplot2::element_text(size = 20, face = "bold"),
      axis.text = ggplot2::element_text(size = 16, face = "bold"),
      panel.grid.major = ggplot2::element_line(colour = "grey", size = 0.15),
      panel.background = ggplot2::element_rect(fill = "white", color = "black")
    )

}

#' Estimates of detection probability
#'
#' @description Plots the estimates of the detection probability. This will plot
#' one value if \code{usingYearDetProb} is set to \code{FALSE} and if set to \code{TRUE}
#' will plot as many values as the number of years.
#'
#' @param modelResults Output of the function \code{runModel}
#'
#' @importFrom magrittr %>%
#'
#' @export
#'
#' @return A plot with of the estimates. The interval represents the
#' 95\% credible interval.
#'
#' @examples
#'
#' plotBaseLineCaptureProb(sampleResults)
#'
plotBaseLineCaptureProb <- function(modelResults) {

  usingYearDetProb <- modelResults$dataCharacteristics$usingYearDetProb
  years <- modelResults$dataCharacteristics$Years
  Y <- length(years)

  p_intercepts <- ifelse(usingYearDetProb, Y, 1)

  beta_p_output <- modelResults$modelOutput$beta_p_output

  beta_p_output <- apply(beta_p_output, 3, c)

  peffect <-
    apply(beta_p_output[, 1:p_intercepts,drop = F], 2, function(x) {
      stats::quantile(logit(x), probs = c(0.025, 0.5, 0.975))
    })

  if(usingYearDetProb){
    x_axis <- years
  } else {
    x_axis <- ""
  }

  p_plot <- ggplot2::ggplot(data = NULL, ggplot2::aes(
    x = x_axis,
    y = peffect[2,],
    ymin = peffect[1,],
    ymax = peffect[3,]
  )) + ggplot2::geom_point() + ggplot2::geom_errorbar() +
    # ylim(c(0,1)) +
    ggplot2::ylab("Detection probability") +
    ggplot2::theme(
      plot.title = ggplot2::element_text(hjust = 0.5, size = 20),
      axis.title = ggplot2::element_text(size = 20, face = "bold"),
      axis.text = ggplot2::element_text(size = 13, face = "bold", angle = 90),
      panel.grid.major = ggplot2::element_line(colour = "grey", size = 0.15),
      panel.background = ggplot2::element_rect(fill = "white", color = "black")
    ) + ggplot2::ylim(c(min(peffect) / 2, max(peffect) * 1.2))

  if(usingYearDetProb){
    p_plot <- p_plot + ggplot2::scale_x_continuous(name = "Years",
                                                   breaks = x_axis)
  } else {
    p_plot <- p_plot + ggplot2::scale_x_discrete(name = "Detection probability")
  }

  p_plot

}

#' Estimates of covariates on detection probability
#'
#' @description Plots the estimates of the covariates on the detection probability.
#'
#' @param modelResults Output of the function \code{runModel}
#'
#' @importFrom magrittr %>%
#'
#' @export
#'
#' @return A plot with of the estimates. The interval represents the
#' 95\% credible interval.
#'
#' @examples
#'
#' plotDetectionCovariatesEffect(sampleResults)
#'
plotDetectionCovariatesEffect <- function(modelResults){

  usingYearDetProb <- modelResults$dataCharacteristics$usingYearDetProb
  years <- modelResults$dataCharacteristics$Years
  Y <- length(years)

  p_intercepts <- ifelse(usingYearDetProb, Y, 1)

  namesCovariates <- modelResults$dataCharacteristics$nameVariables_p
  ncov_p <- length(namesCovariates)

  if (ncov_p > 0) {
    beta_p_output <- modelResults$modelOutput$beta_p_output

    beta_p_output <- apply(beta_p_output, 3, c)

    betaeffect <- apply(beta_p_output[, -(1:p_intercepts), drop = F], 2, function(x) {
      stats::quantile(x, probs = c(0.025, 0.5, 0.975))
    })

    ggplot2::ggplot(data = NULL,
                    ggplot2::aes(
                      x = namesCovariates,
                      y = betaeffect[2, ],
                      ymin = betaeffect[1, ],
                      ymax = betaeffect[3, ]
                    )) + ggplot2::geom_point() + ggplot2::geom_errorbar() +
      ggplot2::ylab("Effect") + ggplot2::scale_x_discrete(name = "Covariates") +
      ggplot2::theme(
        plot.title = ggplot2::element_text(hjust = 0.5, size = 20),
        axis.title = ggplot2::element_text(size = 20, face = "bold"),
        axis.text = ggplot2::element_text(size = 16, face = "bold"),
        panel.grid.major = ggplot2::element_line(colour = "grey", size = 0.15),
        panel.background = ggplot2::element_rect(fill = "white", color = "black")
      )
  } else {
    print("No detection covariates")
  }

}


#  James Rekow

#  output array has each value as a list of 1 instead of 2 DF's, fix this

DOCNSDFListCreator = function(conGraph, M = 80, N = 20, iStrength = 1, univ = 1, sigmaMax = 0.1,
                              thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4, tStep = 10 ^ (-2),
                              intTime = 1, interSmplMult = 0.01, lambda = 10 ^ (-1),
                              synthM = floor(M / 4), numSynthChrt = 10, numSample = 100,
                              maxIters = 100){

  #  ARGS: conGraph - supplied connectivity graph
  #        synthM - number of samples in each synthetic cohort
  #        numSynthChrt - number of synthetic cohorts (there will be this many of both the
  #                       interacting and non-interacting cohorts)
  #
  #  RETURNS:

  #  import libraries and functions
  library(igraph)
  library(snow)
  source("abdListCreator.r")
  source("DOCProcedure.r")
  source("conSynthChrtCreator.r")
  source("DOCNSSelector.r")
  source("plotDensDiff.r")

  #  check that conGraph is undirected
  if(is.directed(conGraph)){
    stop("conGraph must be undirected.")
  } #  end if

  #  check that conGraph has the appropriate number of vertices
  if(vcount(conGraph) != M){
    stop("conGraph must have M vertices.")
  } #  end if

  #  create abundance list after interacting cohort using the connectivity given in conGraph
  abdList = abdListCreator(M = M, N = N, iStrength = iStrength, univ = univ, sigmaMax = sigmaMax,
                           thresholdMult = thresholdMult, maxSteps = maxSteps, tStep = tStep,
                           intTime = intTime, interSmplMult = interSmplMult, lambda = lambda,
                           returnParams = FALSE, conGraph = conGraph)

  #  create a synthetic cohort from abdList and return the points in the NS region of the OD
  #  plane
  #  create a data frame of the aggregate OD NS region points from numSynthChrt number of
  #  synthetic cohorts
  produceSynthDOCNSDF = function(int){

    #  create synthetic cohort
    synthChrtList = conSynthChrtCreator(synthM = synthM, conGraph = conGraph, abdList = abdList,
                                        int = int, numSample = numSample, maxIters = maxIters,
                                        numSynthChrt = numSynthChrt)

    produceNSPoints = function(synthChrt){
      doc = DOCProcedure(synthChrt)
      docNS = DOCNSSelector(doc)

      return(docNS)

    } #  end produceNSPoints function

    docList = lapply(synthChrtList, produceNSPoints)
    docList = docList[!unlist(lapply(docList, is.null))]

    aggOver = unlist(lapply(docList, "[[", 1))
    dissOver = unlist(lapply(docList, "[[", 2))

    DOCNSDF = data.frame(x = aggOver, y = dissOver)

    return(DOCNSDF)

  } #  end produceSynthDOCNS function

  #  produce a list of the aggregate data frames containing the OD NS points from the
  #  non-interacting and interacting synthetic cohorts
  docNSDFList = lapply(list(FALSE, TRUE), produceSynthDOCNSDF)

  return(docNSDFList)

} #  end DOCNSDFListCreator function


#' Parse rpart rules for one predictor
#'
#' This function is not intended to be used by end user. It is used by iv.num function.
#'
#' @param x Predictor variable
#' @param rpart.rules Output from path.rpart for leaf nodes
#'
iv.parse.rpart.rule <- function(x,rpart.rules) {

out_rule <- data.frame(min=numeric(0),max=numeric(0),
                       min_comp=character(0),max_comp=character(0),
                       class_label=character(0),sql=character(0),
                       tree_node = character(0),
                       stringsAsFactors=F)

for (i in seq_along(rpart.rules)) {

t1 <- (gsub("df[, x]",fixed=TRUE,replacement="",x=rpart.rules[[i]]))
t1
ge <- gsub(pattern=">=",x=(t1[which(grepl("*>=[:digit:]*",x=t1,))]),fixed=T,replacement="")
g  <- gsub(pattern=">" ,x=(t1[which(grepl("*> [:digit:]*",x=t1,))]),fixed=T,replacement="")
l  <- gsub(pattern="<" ,x=(t1[which(grepl("*< [:digit:]*",x=t1,))]),fixed=T,replacement="")
le <- gsub(pattern="<=",x=(t1[which(grepl("*<=[:digit:]*",x=t1,))]),fixed=T,replacement="")

ge <- ifelse(length(ge)==0,NA,max(as.numeric(ge)))
g  <- ifelse(length(g) ==0,NA,max(as.numeric(g)))
le <- ifelse(length(le)==0,NA,min(as.numeric(le)))
l  <- ifelse(length(l) ==0,NA,min(as.numeric(l)))

out_rule[i,"min"] <- if (!(is.na(ge) && is.na(g))) max(ge,g,na.rm=T) else NA
out_rule[i,"max"] <- if (!(is.na(le) && is.na(l))) max(le,l,na.rm=T) else NA
out_rule[i,"min_comp"] <- ifelse(!is.na(ge),">=",ifelse(!is.na(g),">",""))
out_rule[i,"max_comp"] <- ifelse(!is.na(le),"<=",ifelse(!is.na(l),"<",""))
out_rule[i,"class_label"] <- paste0(
                    ifelse(!is.na(ge),"<","("),
                    ifelse(is.na(out_rule$min[i]),"",out_rule$min[i]),
                    ";",
                    ifelse(is.na(out_rule$max[i]),"",out_rule$max[i]),
                    ifelse(!is.na(le),">",")")
                    )
out_rule[i,"sql"] <- paste0("when ",
                              ifelse(is.na(out_rule$min[i]),"",paste(x,out_rule$min_comp[i],out_rule$min[i])),
                              ifelse (!is.na(out_rule$min[i]) && !is.na(out_rule$max[i])," AND ", ""),
                              ifelse(is.na(out_rule$max[i]),"",paste(x,out_rule$max_comp[i],out_rule$max[i])),
                            " then ")
out_rule[i,"tree_node"] <- names(rpart.rules)[i]
}

out_rule
}


## helper functions for Blin et al 2021
## LL 20201026
## laurent.lacroix@inserm.fr

library(GenomicAlignments)

makeRFD <- function(gr,bs=1000,lr=1,na2zero=F,bin=T,datatype='OKseq',export=F,saveRData=F,retur=T,outname='myRFDdata',OKcheck=T)
{
### Import data from GenomicRanges with the convention that strand=- for right progressing forks and strand=+ for left progressing forks
### Output total, R anf L coverage as well as RFD. It also filters out low reads regions from the RFD and export the coordinates of those regions.
### Output also BigWig files for the 3 coverages and the low reads regions filtered RFD
require(GenomicRanges)
require(rtracklayer)
corpm <- 1
if (datatype=='OKseq')
{
# check for strand symetry
pl <- length(gr[strand(gr)=='+'])
mi <- length(gr[strand(gr)=='-'])
(corpm <- pl/mi)
}
# strand inversion if not classical OKseq data
if (datatype=='nanopore')
	{
# invert 'strand' as in the datafile, -=left progressing and +=right progressing
	stra <- strand(gr)
	str2 <- stra
	str2[stra=='+'] <- '-'
	str2[stra=='-'] <- '+'
	strand(gr) <- str2
	}
# optionnal binning of the data to compute coverages
if (bin)
	{
	bingen <- tileGenome(seqinfo(gr),tilewidth=bs, cut.last.tile.in.chrom=T)

	bingenp <- countOverlaps(bingen,gr[strand(gr)=='+'])
	bingenm <- countOverlaps(bingen,gr[strand(gr)=='-'])
	cv_L <- coverage(bingen,weight=bingenp)	# left progressing fork, plus for Xia's data, W in OKseq paper
	cv_R <- coverage(bingen,weight=bingenm)	# right progressing fork, minus for Xia's data, C in OKseq paper
	}
else
	{
	cv_L <- coverage(gr[strand(gr)=='+'])
	cv_R <- coverage(gr[strand(gr)=='-'])
	bs=1
	}
# in a whole genome OKseq experiment, plus and minus strand shold be balanced, if not a correction is implemented
if (OKcheck)
{
if (abs(corpm-1)>0.01) {print('data are imbalanced, correction required');print(corpm); cv_R <- cv_R*corpm}
}

# compute RFD and filter for regions where total coverage is below a defined (lr) threshold
cv <- cv_L+cv_R
RFD <- (cv_R-cv_L)/(cv_R+cv_L)
lr_index <- which(cv<=lr)
RFD2 <- RFD
RFD2[lr_index] <- NA
lowread <- do.call(c,lapply(1:length(seqlevels(gr)), function(i) { toto <-Views(cv[[i]],cv[[i]]<=lr);if (length(toto)!=0) {nono=GRanges(seqnames=names(cv)[i], IRanges(start(toto),end(toto)), strand='*', seqinfo=seqinfo(gr))}else{nono=GRanges()};return(nono)}))

# Option to set out NA to 0 in RFD for easier import of the files in IGV but beware that it could change correlation
naname <- '_wiNA'
if (na2zero)
	{
	RFD[is.na(RFD)] <- 0
	RFD2[is.na(RFD2)] <- 0
	naname <- '_noNA'
	}
# Option to export resuls into BigWig files
if (export)
	{
		rtracklayer::export(cv,con=paste0(outname,'_cov_tot_bs',bs/1000,'k_lr',lr,'.bw'))
		rtracklayer::export(cv_L,con=paste0(outname,'_cov_2left_bs',bs/1000,'k_lr',lr,'.bw'))
		rtracklayer::export(cv_R,con=paste0(outname,'_cov_2right_bs',bs/1000,'k_lr',lr,'.bw'))
		rtracklayer::export(RFD2,con=paste0(outname,'_RFD_bs',bs/1000,'k_lr',lr,naname,'.bw'))
	}
res <- list(cv,cv_L,cv_R,RFD,RFD2,lowread)
names(res) <- c('cv','cv_L','cv_R','RFD','RFD2','lowread')
# Option to save the results in a RData file
if (saveRData)
{
save(res,file=paste0(outname,'_bs',bs/1000,'k_lr',lr,naname,'.RData'))
}
# Option to output the result of the funtion in the current R session
if (retur) {return(res)}
}

newXLSX_track_import <- function(xlfile="Coordonnees_polarite.xlsx",feuille=1)
{
# function used to import tracks coordinate from the XLSX file
require("openxlsx")
require("GenomicRanges")
df1 <- read.xlsx(xlfile,sheet=feuille)
# set strand/fork orientation as for OKseq reads
df1$strand <- '*'
df1$strand[df1$Orientation=='G'] <- '+'
df1$strand[df1$Orientation=='D'] <- '-'

df1.GR <- sort(GRanges(seqnames=df1$Chromosome,ranges=IRanges(df1$start,df1$end),strand=df1$strand))
return(df1.GR)
}

### a function to check correlation genome-wide between RFD disregarding places with NA
### for binned values
cor.rfd.test2 <- function(a,b,met='s',binned=T,bs0=bs,...)
{
if (binned==T)
{
a.b <- endoapply(a, function(x) {y <-x ;runLength(y) <- runLength(x)%/%bs0;return(y)})
b.b <- endoapply(b, function(x) {y <-x ;runLength(y) <- runLength(x)%/%bs0;return(y)})
a <- a.b
b<- b.b
}
cor.test(as.numeric(unlist(a)[!is.na(unlist(a)) & !is.na(unlist(b))]),as.numeric(unlist(b)[!is.na(unlist(a)) & !is.na(unlist(b))]),method=met)
}
### for a single gene/chromosome with binning
cor.rfd.test3 <- function(a,b,met='s',binned=T,bs0=bs,...)
{
if (binned==T)
{
a.b <- a
runLength(a.b) <- runLength(a)/bs0
b.b <- b
runLength(b.b) <- runLength(b)/bs0
a <- a.b
b<- b.b
}
cor.test(as.numeric(unlist(a)[!is.na(unlist(a)) & !is.na(unlist(b))]),as.numeric(unlist(b)[!is.na(unlist(a)) & !is.na(unlist(b))]),method=met)
}


source("helpers.r")

####
####
#### Read the Data
####
alldata = read.csv("alldata_elisa.csv", sep = ",")

predNames20 <- c("PSA_Dens", "BX_GS", "FN1_ELISA", "VTN_ELISA")
predNames20 <- sort(predNames20)

alldata <- removeNas(alldata, unique(c(predNamesRef_PSABX, predNames20, targetname)))

# Prepare CV dataset and Test Dataset

# Train on one batch ProCOC x
train_data_global <- alldata[which(alldata$reading==1 & alldata$ProCOC==batchj), ]
test_data_global <- alldata[which(alldata$reading==1 & alldata$ProCOC!=batchj), ]

require(sampling)
set.seed(rseed)

dat_train <- train_data_global
dat_test  <- test_data_global # for overall validation, will not be used in CV

dat_train <- removeNas(dat_train, unique(c(predNamesRef_PSABX, predNames20, targetname)))
dat_test  <- removeNas(dat_test, unique(c(predNamesRef_PSABX, predNames20, targetname)))

X <- dat_train

# END prepare CV dataset and Test Dataset

# calculate reference models PSA
RF_refs_PSABX <- list()
GLM_refs_PSABX <- list()
RF_refs_PSA <- list()
GLM_refs_PSA <- list()

RF_refs_PSABX_errors <- c()
GLM_refs_PSABX_errors <- c()
RF_refs_PSA_errors <- c()
GLM_refs_PSA_errors <- c()

train_inds <- list()
test_inds <- list()
set.seed(rseed)
for (i in 1:k) {
  set.seed(i)
  ind <- order(dat_train[,targetname])[sampling::strata(dat_train[order(dat_train[,targetname]),], targetname, round(0.69 * as.numeric(summary(dat_train[, targetname])[2:3])), "srswor")$ID_unit]
  ind_oob <- (1:nrow(dat_train))[-ind]

  train_inds <- c(train_inds, list(ind))
  test_inds <- c(test_inds, list(ind_oob))

  dat_fold_train <- dat_train[ind, ]
  dat_fold_test  <- dat_train[ind_oob, ]

  if (length(unique(dat_fold_test[, targetname]))>1) {

    ##
    ## Random Forest
    ##
    require(randomForest)
    set.seed(rseed)
    rf_fit <- randomForest(formula(paste(c("as.factor(", targetname, ")~", paste(predNamesRef_PSABX, collapse="+")), collapse="")), data.frame(dat_fold_train), importance=TRUE, na.action=na.omit, ntree = ntree, mtry=length(predNamesRef_PSABX))
    if (errorfun == "aucerror") {
      RF_refs_PSABX_errors <- c(RF_refs_PSABX_errors, errormeasureAUC(dat_fold_test[, targetname], predict(rf_fit, newdata = dat_fold_test, type="prob")[,2]))
    }
    RF_refs_PSABX <- c(RF_refs_PSABX, list(rf_fit))

    set.seed(rseed)
    rf_fit <- randomForest(formula(paste(c("as.factor(", targetname, ")~", paste(predNamesRef_PSA, collapse="+")), collapse="")), data.frame(dat_fold_train), importance=TRUE, na.action=na.omit, ntree = ntree, mtry=length(predNamesRef_PSA))
    if (errorfun == "aucerror") {
      RF_refs_PSA_errors <- c(RF_refs_PSA_errors, errormeasureAUC(dat_fold_test[, targetname], predict(rf_fit, newdata = dat_fold_test, type="prob")[,2]))
    }
    RF_refs_PSA <- c(RF_refs_PSA, list(rf_fit))
  }
}

doClassifierSurvivalFitWithClassifier2 = function (data, classifier, tit, classifierPSA = NA, classifierPSABX = NA,
                                                   legend = TRUE, doPlot = TRUE, plotSurvivalRatherThanROC = TRUE,
                                                   plotPSA = TRUE, plotPSABX = TRUE, plotNCCN = TRUE, cutoff = 0.5,
                                                   cutoffPSA = 0.5, cutoffPSABX = 0.5, ctype = "rf", mark = 3,
                                                   lwd = 1, ...)
{
  require(pROC)
  require(survival)
  data. <- data
  if (ctype == "rf") {
    data.$Score <- predict(classifier, newdata = data., type = "prob")[,
                                                                       2]
  }
  else {
    data.$Score <- predict(classifier, newdata = data., type = "response")
  }
  rocScore = roc(data.[, targetname], data.$Score)
  if (cutoff < 0) {
    cutoff = rocScore$thresholds[which.max(rocScore$specificities +
                                             rocScore$sensitivities)[1]]
  }
  if (class(data.$Score) == "numeric") {
    data.$Score <- factor(data.$Score >= cutoff)
  }
  levels(data.$Score) <- c("LOW", "HIGH")
  Pred.surv <- survfit(Surv(time = Time_BCR_free_survival,
                            event = Status_BCR, type = "right") ~ Score, data = data.)
  Pred.cox <- coxph(Surv(time = Time_BCR_free_survival, event = Status_BCR,
                         type = "right") ~ Score, data = data.)
  if (doPlot) {
    if (plotSurvivalRatherThanROC) {
      plot(Pred.surv, col = 1:2, ylab = "Cumulative Survival",
           xlab = "Months", main = tit, sub = paste(c("n = ",
                                                      paste(Pred.surv$n, collapse = " / "), ",  p=",
                                                      format(summary(Pred.cox)$logtest[3], digits = 3,
                                                             nsmall = 2)), collapse = ""), lwd = lwd,
           mark = mark, ...)
      if (legend && !is.null(names(Pred.surv$strata))) {
        leg = names(Pred.surv$strata)
        leglty = c(1, 1)
        legcol = c("black", "red")
        legend("bottomleft", leg, col = legcol, lty = leglty,
               bty = "n", cex = 0.8)
      }
    }
    else {
      plot(rocScore, col = 1, main = tit, sub = paste(c("n = ",
                                                        length(rocScore$cases) + length(rocScore$controls),
                                                        " (p=", format(summary(Pred.cox)$logtest[3],
                                                                       digits = 3, nsmall = 2), ")"), collapse = ""),
           mar = c(5.1, 4.1, 4.2, 2.1), ...)
      text(x = 0.4, y = 0.4, labels = paste(c("AUC ", format(auc(rocScore),
                                                             digits = 3, nsmall = 2)), collapse = ""), pos = 4,
           col = 1)
    }
    if (plotPSA && !is.na(classifierPSA)) {
      if (ctype == "rf") {
        data.$PSAScore <- predict(classifierPSA, newdata = data.,
                                  type = "prob")[, 2]
      }
      else {
        data.$PSAScore <- predict(classifierPSA, newdata = data.,
                                  type = "response")
      }
      rocPSA = roc(data.[, targetname], data.$PSAScore)
      if (cutoffPSA < 0) {
        cutoffPSA = rocPSA$thresholds[which.max(rocPSA$specificities +
                                                  rocPSA$sensitivities)[1]]
      }
      if (class(data.$PSAScore) == "numeric") {
        data.$PSAScore <- factor(data.$PSAScore >= cutoffPSA)
      }
      levels(data.$PSAScore) <- c("LOW", "HIGH")
      PredPSA.surv <- survfit(Surv(time = Time_BCR_free_survival,
                                   event = Status_BCR, type = "right") ~ PSAScore,
                              data = data.)
      PredPSA.cox <- coxph(Surv(time = Time_BCR_free_survival,
                                event = Status_BCR, type = "right") ~ PSAScore,
                           data = data.)
      if (plotSurvivalRatherThanROC) {
        plot(PredPSA.surv, col = 1:2, ylab = "Cumulative Survival",
             xlab = "Months", main = paste(c("PSA_Dens"),
                                           collapse = " + "), sub = paste(c("n = ",
                                                                            paste(PredPSA.surv$n, collapse = " / "),
                                                                            ",  p=", format(summary(PredPSA.cox)$logtest[3],
                                                                                digits = 3, nsmall = 2)), collapse = ""),
             lwd = lwd, mark = mark, ...)
        if (legend) {
          leg = names(PredPSA.surv$strata)
          leglty = c(1, 1)
          legcol = c("black", "red")
          legend("bottomleft", leg, col = legcol, lty = leglty,
                 bty = "n", cex = 0.8)
        }
      }
      else {
        plot(rocPSA, col = 1, main = paste(c("PSA_Dens"),
                                           collapse = " + "), sub = paste(c("n = ", length(rocPSA$cases) +
                                                                              length(rocPSA$controls), " (p=", format(summary(PredPSA.cox)$logtest[3],
                                                                                digits = 3, nsmall = 2), ")"), collapse = ""),
             mar = c(5.1, 4.1, 4.2, 2.1), ...)
        text(x = 0.4, y = 0.3, labels = paste(c("AUC ",
                                                format(auc(rocPSA), digits = 3, nsmall = 2)),
                                              collapse = ""), pos = 4, col = "darkgray")
      }
    }
    if (plotPSABX && !is.na(classifierPSABX)) {
      if (ctype == "rf") {
        data.$PSABXScore <- predict(classifierPSABX,
                                    newdata = data., type = "prob")[, 2]
      }
      else {
        data.$PSABXScore <- predict(classifierPSABX,
                                    newdata = data., type = "response")
      }
      rocPSABX = roc(data.[, targetname], data.$PSABXScore)
      if (cutoffPSABX < 0) {
        cutoffPSABX = rocPSABX$thresholds[which.max(rocPSABX$specificities +
                                                      rocPSABX$sensitivities)[1]]
      }
      if (class(data.$PSABXScore) == "numeric") {
        data.$PSABXScore <- factor(data.$PSABXScore >=
                                     cutoffPSABX)
      }
      levels(data.$PSABXScore) <- c("LOW", "HIGH")
      PredPSABX.surv <- survfit(Surv(time = Time_BCR_free_survival,
                                     event = Status_BCR, type = "right") ~ PSABXScore,
                                data = data.)
      PredPSABX.cox <- coxph(Surv(time = Time_BCR_free_survival,
                                  event = Status_BCR, type = "right") ~ PSABXScore,
                             data = data.)
      if (plotSurvivalRatherThanROC) {
        plot(PredPSABX.surv, col = 1:2, ylab = "Cumulative Survival",
             xlab = "Months", main = paste(c("PSA_Dens",
                                             "BX_GS"), collapse = " + "), sub = paste(c("n = ",
                                                                                paste(PredPSABX.surv$n, collapse = " / "),
                                                                                ",  p=", format(summary(PredPSABX.cox)$logtest[3],
                                                                                digits = 3, nsmall = 2)), collapse = ""),
             lwd = lwd, mark = mark, ...)
        if (legend) {
          leg = names(PredPSABX.surv$strata)
          leglty = c(1, 1)
          legcol = c("black", "red")
          legend("bottomleft", leg, col = legcol, lty = leglty,
                 bty = "n", cex = 0.8)
        }
      }
      else {
        plot(rocPSABX, col = 1, main = paste(c("PSA_Dens",
                                               "BX_GS"), collapse = " + "), sub = paste(c("n = ",
                                                                                length(rocPSABX$cases) + length(rocPSABX$controls),
                                                                                " (p=", format(summary(PredPSABX.cox)$logtest[3],
                                                                                digits = 3, nsmall = 2), ")"), collapse = ""),
             mar = c(5.1, 4.1, 4.2, 2.1), ...)
        text(x = 0.4, y = 0.2, labels = paste(c("AUC ",
                                                format(auc(rocPSABX), digits = 3, nsmall = 2)),
                                              collapse = ""), pos = 4, col = "lightblue3")
      }
    }
    if (plotNCCN) {
      rocNCCN = roc(data.[, targetname], data.$NCCN_risk_group_Bx)
      PredNCCN.surv <- survfit(Surv(time = Time_BCR_free_survival,
                                    event = Status_BCR, type = "right") ~ NCCN_risk_group_Bx >
                                 2, data = data.)
      PredNCCN.cox <- coxph(Surv(time = Time_BCR_free_survival,
                                 event = Status_BCR, type = "right") ~ NCCN_risk_group_Bx >
                              2, data = data.)
      if (plotSurvivalRatherThanROC) {
        plot(PredNCCN.surv, col = 1:2, ylab = "Cumulative Survival",
             xlab = "Months", main = paste(c("NCCN"), collapse = " + "),
             sub = paste(c("n = ", paste(PredNCCN.surv$n,
                                         collapse = " / "), ",  p=", format(summary(PredNCCN.cox)$logtest[3],
                                                                            digits = 3, nsmall = 2)), collapse = ""),
             lwd = lwd, mark = mark, ...)
        if (legend) {
          leg = names(PredNCCN.surv$strata)
          leglty = c(1, 1)
          legcol = c("black", "red")
          legend("bottomleft", leg, col = legcol, lty = leglty,
                 bty = "n", cex = 0.8)
        }
      }
      else {
        plot(rocNCCN, col = 1, main = paste(c("NCCN"),
                                            collapse = " + "), sub = paste(c("n = ", length(rocNCCN$cases) +
                                                                               length(rocNCCN$controls), " (p=", format(roc.test(rocScore,
                                                                                rocNCCN)$p.value, digits = 3, nsmall = 2),
                                                                             ")"), collapse = ""), mar = c(5.1, 4.1, 4.2,
                                                                                2.1), ...)
        text(x = 0.4, y = 0.1, labels = paste(c("AUC ",
                                                format(auc(rocNCCN), digits = 3, nsmall = 2)),
                                              collapse = ""), pos = 4, col = "palegreen3")
      }
    }
  }
  return(summary(Pred.cox)$logtest[3])
}

doClassifierSurvivalFitWithPrednames2 = function (datatrain, datatest, predNames, targetname, tit = "",
          ranseed = rseed, ktree = ntree, doPlot = TRUE, cutoff = 0.5,
          cutoffPSA = 0.5, cutoffPSABX = 0.5, ctype = "rf", plotSurvivalRatherThanROC = TRUE,
          ...)
{
  set.seed(ranseed)
  if (ctype == "rf") {
    require(randomForest)
    classifier = randomForest(formula(paste(c("as.factor(",
                                              targetname, ")~", paste(unique(predNames), collapse = "+")),
                                            collapse = "")), data.frame(datatrain), importance = TRUE,
                              na.action = na.omit, ntree = ktree, mtry = length(unique(predNames)))
  }
  set.seed(ranseed)
  if (ctype == "rf") {
    classifierPSA = randomForest(formula(paste(c("as.factor(",
                                                 targetname, ")~", paste("PSA_Dens", collapse = "+")),
                                               collapse = "")), data.frame(datatrain), importance = TRUE,
                                 na.action = na.omit, ntree = ktree)
  }
  set.seed(ranseed)
  if (ctype == "rf") {
    classifierPSABX = randomForest(formula(paste(c("as.factor(",
                                                   targetname, ")~", paste(unique(c("PSA_Dens", "BX_GS")),
                                                                           collapse = "+")), collapse = "")), data.frame(datatrain),
                                   importance = TRUE, na.action = na.omit, ntree = ktree,
                                   mtry = 2)
  }
  if (is.na(tit) || tit == "") {
    tit = paste(predNames, collapse = " + ")
  }
  return(doClassifierSurvivalFitWithClassifier2(datatest, classifier,
                                                tit, classifierPSA, classifierPSABX, doPlot = doPlot,
                                                cutoff = cutoff, cutoffPSA = cutoffPSA, cutoffPSABX = cutoffPSABX,
                                                ctype = ctype, plotSurvivalRatherThanROC = plotSurvivalRatherThanROC,
                                                ...))
}

## plots for paper
pdf(paste(c("validate-", paste(predNames20, collapse="-"), ".pdf"), collapse=""))

## Classification error on test_data_global
predNames    <- predNames20

# classifier retrained on whole training set

# best classifier from cross validation
result = doCV(X, predNames, targetname, rseed = rseed, k_fold=k, ncores=1)
GS_RF_CVAll_ = unlist(lapply(result, function(x) x$fit_RF_error))
inds_fold <- train_inds[[which.max(GS_RF_CVAll_)]]
inds_oob_fold <- test_inds[[which.max(GS_RF_CVAll_)]]
dat_fold_train <- X[inds_fold, ]
dat_fold_test  <- X[inds_oob_fold, ]
set.seed(rseed)
if (ctype=="rf") {
  val_RF = randomForest(formula(paste(c("as.factor(", targetname, ")~", paste(unique(c(predNames)), collapse="+")), collapse="")), X[inds_fold, ], importance=TRUE, na.action=na.omit, mtry=length(unique(c(predNames))))
}

if (errorfun == "aucerror") {
  if (ctype=="rf") {
    val_RF_error <- errormeasureAUC(test_data_global[, targetname], predict(val_RF, newdata = test_data_global, type="prob")[,2])
  }
}

cutoffs <- comparisonAUCPlotsWReferences(unique(c(predNames)), X[inds_fold, ], test_data_global, r_seed = rseed, ctype=ctype)
cutoff <- cutoffs[1]
cutoffPSA <- cutoffs[2]
cutoffPSABX <- cutoffs[3]

# do the AUC on the 118 subset patients only
train_data_global$usable = !is.na(train_data_global$Time_BCR_free_survival) & !is.na(train_data_global$PSA_Dens)
doClassifierSurvivalFitWithPrednames(X[inds_fold, ], train_data_global[train_data_global$usable,], predNames, targetname, paste(c(paste(predNames, collapse=" + ")), collapse=" "), ctype=ctype, plotSurvivalRatherThanROC=FALSE)

## Survival Curve on test_data_global
doClassifierSurvivalFitWithPrednames(X[inds_fold, ], test_data_global, predNames, targetname, paste(c(paste(predNames, collapse=" + ")), collapse=" "), cutoff=cutoff, cutoffPSA=cutoffPSA, cutoffPSABX=cutoffPSABX, ctype=ctype, lwd=4)
doClassifierSurvivalFitWithPrednames2(X[inds_fold, ], test_data_global, predNames, targetname, paste(c(paste(predNames, collapse=" + ")), collapse=" "), cutoff=cutoff, cutoffPSA=cutoffPSA, cutoffPSABX=cutoffPSABX, ctype=ctype, lwd=4)
doClassifierSurvivalFitWithPrednames(X[inds_fold, ], test_data_global, predNames, targetname, paste(c(paste(predNames, collapse=" + ")), collapse=" "), cutoff=cutoff, cutoffPSA=cutoffPSA, cutoffPSABX=cutoffPSABX, ctype=ctype, plotSurvivalRatherThanROC=FALSE)

dev.off()


# This function will run the ssPopModel for the given cell distribtion, varying
# this dt between 0 and 30 minutes
# parallel ‘Rscript run_model_matrix.r {}’ ::: {1..69}

args <- commandArgs(TRUE)
distribution.num <- as.numeric(args[1])

# Path to the input distribtions
path.to.git.repository <- "~/ssPopModel_sensitivity_test"
setwd(path.to.git.repository)
Par <- read.csv("Par.csv")
list.dist  <- list.files("input", "size.distribution_Prochlorococcus",full.names=T)

# Get the correct distribtion from the list of distribution
distribtion <- list.dist[distribution_num]
load(distribtion)

# Get the width of the size class
width <- unlist(list(strsplit(list.dist, "_")))[3]

# set the start time to 1, this will not be changed
t <- 1

# Now we will run the ssPopModel for the cell distribtuion, saving
# the output in the format: type.distribtuion_Prochlorococcus_width_dt
for(dt in seq(1, 30, by=0.5)) {
    print(paste0("Time = ", dt))
    freq.distribution2 <- distribution[[2]][37:61] # biomass data for 1 day only
    freq.distribution1 <- distribution[[1]][37:61] # size data for 1 day only
    Ntot <- distribution[[3]][37:61]
    # 1. calculating division rate based on biomass
    model2 <- run.ssPopModel(freq.distribution2, Ntot, Par, time.delay=t, dt=dt)
    save(model2, file=paste0('output/biomass_modeloutput_', width, '_', dt))
    # 2. calculating division rate based on size
    model1 <- run.ssPopModel(freq.distribution1, Ntot, Par, time.delay=t, dt=dt)
    save(model1, file=paste0('output/size_modeloutput_', width, '_', dt))
}

print(paste0("Completed ", distribution_num))


# fit EAM and UGM to two PHS2005 participants #
#     one that's best fit by EAM, the other by UGM
rm(list=ls())
currwd = getwd();

source("chartr-FitRoutines.r")
source("chartr-HelperFunctions.r")
source("chartr-PlotUtils.r")
source("chartr-ModelSelection.r")

# load C functions
dyn.load("chartr-ModelSpecFast.so")

# load RS2002 data sets to find suitable subjects

dataDir = "colgrid";
resultsDir = "../colgrid_Fits"

setwd(dataDir)
RS2002 =  FALSE;

# set up plot for predicted distributions from the 3x3 of changing drift rate and changing threshold
par(mfrow=c(1,2),mar=c(4,4,2,1))
qps=seq(.1,.9,.2) ; nq=length(qps)
fnams=dir()
# fnams = fnams[c(1,2,3)]
fnams = fnams[c(1,2)]
data=list()
for(s in fnams) {
  load(s)
  data[[s]]=dat
  plotQuantiles(dat);
}

#
setwd(resultsDir);

if(RS2002)
 {
  usemodel = c("DDMSvSzSt","uDDMSvSb","bUGMSvSb","uDDMSvSt","bUGMSvSt")
  # usemodel = c("DDMSvSzSt","UGMSt","bUGMSt","uDDMSt");
  #usemodel = c("DDMSt","bUGMSt","uDDMSt")
}else
{
    # modelList = c('DDMSvSzSt','uDDMSvSbSt','bUGMSvSbSt','nluDDMSvSbSt','cDDMSvSzSt')
    usemodel = c("DDMSvSt","uDDMSbSu","nluDDMSbSu")
}
#
snams=names(data) ;
nsubj=length(data);
nreps=15;
lets=letters[seq(1,nreps)];

# for now, only get reobj value (parameters later)
landouts=array(dim=c(nsubj,length(usemodel)),dimnames=list(snams,usemodel))
landAIC=array(dim=c(nsubj,length(usemodel)),dimnames=list(snams,usemodel))
landBIC=array(dim=c(nsubj,length(usemodel)),dimnames=list(snams,usemodel))

logLike = landAIC;

landpars=list(stone=list(),stoneUGM=list())
numpars = array(length(usemodel));
modelOutput=list()

# Load each and every model, check which model fit is best. Use best fitting model
#
#
#
for(s in snams) {
  for(mod in usemodel) {
    # iterate over jobs per subject to get best fit
    bestfit=-Inf ; uselet=NULL
    for(l in lets) {
      fnam=paste(s,mod,l,sep="-")
      if(!file.exists(fnam)) next else load(fnam)
      if(out$reobj>bestfit)
      {
          bestfit=out$reobj ;
          uselet=l
          modelOutput[[mod]]=out;
      }
      rm(fnam,out)
    }
    load(paste(s,mod,uselet,sep="-"));

    landouts[s,mod]=out$reobj
    used=paste("data",dat,sep="-") ;
    usem=paste("model",mod,sep="-")
    landpars[[mod]]=rbind(landpars[[mod]],out$pars)
    numpars[mod] = length(out$pars)
    Temp = calcIC(bestfit, numpars[mod], sum(data[[s]]$n))
    landAIC[s,mod] = Temp$AIC;
    landBIC[s,mod] = Temp$BIC;
    logLike[s,mod] = out$reobj;

    rm(out)
    rm(bestfit,uselet)

    # rownames(landpars[[mod]]) = snams[s]
  }
}

for(mod in usemodel) {
  rownames(landpars[[mod]]) = snams
}

setwd("../")
# End loading
ms=modelSelection(models=modelOutput, data=dat)

# Now simulate data using the existing parameters from these models.

bailouttime=8
trlsteps=seq(0,bailouttime,.001)
maxTimeStep=as.double(length(trlsteps))
nmc=5e4

# array to hold predictions
nd=length(data[[1]]$p)  # number of drifts
predrts=array(dim=c(nq,2,nd,length(usemodel),nsubj),dimnames=list(qps,c("cor","err"),NULL,
                                                                  usemodel,snams))
predps=array(dim=c(nd,length(usemodel),nsubj),dimnames=list(NULL,usemodel,snams))
# predictions for the fitted models

interval=0.00001;
LUT=qnorm(seq(interval,1-interval,interval));
nLUT = length(LUT);

for(mod in usemodel) {
  m=paste("model",mod,sep="-")
  cat("\n   ",m,"\n")
  # loop over nsims landscaping fits
  for(s in snams) {
    cat(" ",s)
    ps=c(unlist(landpars[[mod]][s,]))  # add 0 drift for 0% coherence condition

    Ter = ps["Ter"]
    st0 = ps["st0"]
    eta = ps["eta"]
    aU = ps["aU"]

    nds=nd  # v1 is 0% coherence, will be set to 0 drift in internal function

    actualParams = paramsandlims(mod, nds)
    fitUGM = unname(actualParams$fitUGM)
    lowers = actualParams$lowers
    uppers = actualParams$uppers
    parnames = actualParams$parnames

    stepsize=ifelse(fitUGM < 0,.001,1)  # time step for diffusion process: .001s (Stone), 1ms (UGM)
    stoch.s=ifelse(fitUGM < 0,.1,100)   # diffusion constant
    timecons=ifelse(fitUGM < 0,0,100)   # time constant for low pass filter
    usign=ifelse(fitUGM < 0,0,1)

    if(fitUGM < 0) {
      aL=0 ; z=ps["aU"]/2
      dt=.001 ; stoch.s=.1 ; usign=0 ; timecons=0
    } else {
      aL=-ps["aU"] ; z=0
      dt=1 ; stoch.s=100 ; usign=1 ; timecons=100
    }
    # predictions for fitted parameters
    for(v in 1:nd) {
      rts <- resps <- numeric(nmc)
      driftRate = ps[paste("v",v,sep="")]
      if(v==1 & RS2002)
      {
          driftRate = 0;
      }

    # Analyse and run each model with the parameters that are present
      tmp = diffusionC(v=driftRate, eta=ps["eta"], aU = ps["aU"], aL = aL, Ter=ps["Ter"],
                       intercept=ps["intercept"], ieta=ps["ieta"], st0 = ps["st0"], z=z, zmin=ps["zmin"],
                       zmax=ps["zmax"], timecons_var=ps["timecons_var"], usign_var=ps["usign_var"], usigneta = ps["usigneta"],
                       sx=ps["sx"], sy=ps["sy"], delay=ps["delay"], lambda=ps["lambda"],
                       aprime=ps["aprime"], k=ps["k"], timecons=timecons, usign=usign, s=stoch.s,dt=dt,
                       n=nmc,maxTimeStep=maxTimeStep, fitUGM=fitUGM, FASTRAND=TRUE, nLUT=nLUT, LUT=LUT)
      predps[v,mod,s]=(table(tmp$resps)/nmc)["1"]
      predrts[,"cor",v,mod,s]=quantile(tmp$rt[tmp$resps==1],probs=qps)
      predrts[,"err",v,mod,s]=quantile(tmp$rt[tmp$resps==2],probs=qps)
    }
  }
}

usesubj=fnams
snamplot=usesubj ; names(snamplot)=usesubj

# Setup some simple parameters for plotting
lwds=2.5
ptcexs=2
axcexs=1.1
labcexs=1.1
dataMarker=4;
modelFitMarker=21;

# xaxes go from 0 to 1, make sure they show as . instead of 0.
xaxs=seq(0,1,.2) ; xaxs[xaxs<1]=gsub("0.",".",xaxs[xaxs<1])

# Define colors for plotting
bluecol=rgb(red=30,green=144,blue=255,alpha=210,maxColorValue=255)
yellowcol=rgb(red=255,green=165,blue=0,alpha=190,maxColorValue=255)
graycol=rgb(red=79,green=79,blue=79,alpha=180,maxColorValue=255)
graybgcol=rgb(red=129,green=129,blue=129,alpha=180,maxColorValue=255)

# Set margins and figure layout. We have chosen five models to be plotted in this example, so
par(mfrow=c(length(usesubj),length(usemodel)))
# par(mar=c(10,6,10,4))

minprob = 0.01;

for(s in usesubj) {
  dat=data[[s]] ; dat$q=dat$q[as.character(qps),,]
  # different y axis scaling for different subjects
  use=(1-predps[,mod,s])>minprob

  yaxs=seq(.2,1.2*round(max(predrts[1:5,1:2,use,1:1,s]),2),.2)
  yaxs[yaxs<1]=gsub("0.",".",yaxs[yaxs<1])
  for(mod in usemodel) {
    plot(y=NULL,x=NULL,ylim=c(0.2,1.2*max(predrts[1:5,1:2,use,1:1,s])),
         xlim=c(0,1),ylab="",xlab="",axes=F)
    axis(side=1,at=xaxs,NA,tcl=-.3, lwd=2)
    axis(side=2,at=yaxs,NA,tcl=-.3, lwd=2)
    text(x=1.05,y=max(as.numeric(yaxs))-0.03,labels=paste('AIC:',round(landAIC[s,mod]-landAIC[s,usemodel[1]]),sep=''),pos=2,cex=labcexs*1.2)
    text(x=1.05,y=max(as.numeric(yaxs))-.06,labels=paste('BIC:',round(landBIC[s,mod]-landBIC[s,usemodel[1]]),sep=''),pos=2,cex=labcexs*1.2)

    # text(x=1.05,y=max(as.numeric(yaxs)),labels=paste('LL:',round(logLike[s,mod]-logLike[s,usemodel[1]]),sep=''),pos=2,cex=labcexs*1.2)
    text(x=1.05,y=max(as.numeric(yaxs)),labels=paste('LL:',round(logLike[s,mod]),sep=''),pos=2,cex=labcexs*1.2)

    if(which(s==usesubj)==1)
        mtext(side=3,mod,cex=labcexs*0.8,line=-4,las=1, at=0.3)
    mtext(side=2,at=yaxs,yaxs,line=.8,cex=axcexs,las=1)
    mtext(side=1,at=xaxs,xaxs,line=.8,cex=axcexs,las=1)

    if(mod==usemodel[1]){
       mtext(side=2,"Response Time (seconds)",cex=labcexs,line=3, at=0.5);
       mtext(side=3, s, cex=labcexs*1.2, line=0, at=0, col="blue")
      }
    if(mod==usemodel[ceiling(length(usemodel)/2)])
        mtext(side=1,"Probability Correct",cex=labcexs,line=3.5,at=.5)

    # plot predicted quantiles from fit
     # only plot if more than X% corrects

    # Plot the predicted RTs
    for(i in 1:nq)
    {
      points(y=c(rev(predrts[i,"err",use,mod,s]),predrts[i,"cor",,mod,s]),
                          x=c(rev(1-predps[use,mod,s]),predps[,mod,s]),pch=modelFitMarker,col=graycol,
                          bg=graybgcol,cex=ptcexs,type="b",lwd=lwds*1.2)
    }

    # Plot the actual data in the appropriate markers. Colors
    points(x=rep(dat$p,each=nrow(dat$q)),y=dat$q[,"cor",],pch=dataMarker,col=bluecol,lwd=lwds,cex=ptcexs)
    use=(1-dat$p)> minprob   # only plot if more than X% corrects
    points(x=rep(1-dat$p[use],each=nrow(dat$q[,,use])),y=dat$q[,"err",use],
           pch=dataMarker,col=yellowcol,lwd=lwds,cex=ptcexs)
  }
}

setwd(currwd)


library(devtools)
devtools::load_all()
RNGkind("L'Ecuyer-CMRG")

seed <- 999983
s_k <- 5000
s_n <- 500
s_m <- 6

sim_type1_5006 <- type_1(seed, s_k, s_n, s_m, L = 1000,
                fast.tn = T, semi.iter = F, center.bs = F)
save(sim_type1_5006, file = "sim_type1_5006.RData")


formulaBuilder <- function(family, list_length, site_effect, overdispersion){

  # If we include list_length then the family must be Bernoulli
  if(list_length){

    family <- 'Bernoulli'

  }

  # Build our formula depending on our arguements
  model_formula <- ifelse(family == 'Bernoulli',
                          'taxa ~ year',
                          'cbind(successes, failures) ~ year')
  if(list_length) model_formula <- paste(model_formula, '+ log(listLength)')
  if(site_effect) model_formula <- paste(model_formula, '+ (1|site)')
  if(overdispersion) model_formula <- paste(model_formula, '+ (1|obs)')

  return(model_formula)

}