#' Plot recruitment deviations
#'
#' Shows both line and bar plots of SR residuals.
#' @param asap name of the variable that read in the asap.rdat file
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

PlotRecruitmentDevs <- function(asap,save.plots,od,plotf){
  par(mfrow=c(2,1), mar=c(4,4,2,2) )
  #__annual esitmates of Recruitment deviations (2 panel plot)____

  years<-  asap$SR.resids[,1]
  recr <- asap$SR.resids[,2]
  recr.no.devs <- asap$SR.resids[,3]
  resids <- asap$SR.resids[,4]

  plot( years, recr.no.devs, type='l', col='#114466', lty=1, lwd=2,
        xlab="Year", ylab="Recruits ",
        ylim=c(0, 1.1*max(recr, recr.no.devs))  )
  lines(years, recr, col="grey35", lwd=2)
  points (years, recr, pch=19)

  plot( years, resids, type='h', col='black',
        xlab="Year", ylab="Ln(Recruitment deviations)", lwd=2,
        ylim=c(1.1*min(resids) , 1.1*max(resids))  )
  abline(h=0, lwd=1)

  if (save.plots==T) savePlot(paste0(od, "Recruit.Yr.Devs.",plotf), type=plotf)

  return()
} # end function


# Name of Mongo File
aaIndexMongoFile <- "AAPrinCompsIndicesForMongo.json"
fileLocation <- "/Users/mercer/p4/data/PrinComps/"

#alpha
nameOfFile <-  paste(fileLocation,"alpha_prin_comps.csv",sep="")
savedAlpha <- read.delim(nameOfFile,stringsAsFactors=FALSE, header = TRUE,sep=",")

# beta
nameOfFile <-  paste(fileLocation,"beta_prin_comps.csv",sep="")
savedBeta <- read.delim(nameOfFile,stringsAsFactors=FALSE, header = TRUE,sep=",")

# composition
nameOfFile <-  paste(fileLocation,"composition_prin_comps.csv",sep="")
savedComposition <- read.delim(nameOfFile,stringsAsFactors=FALSE, header = TRUE,sep=",")

# hydro
nameOfFile <-  paste(fileLocation,"hydro_prin_comps.csv",sep="")
savedHydro <- read.delim(nameOfFile,stringsAsFactors=FALSE, header = TRUE,sep=",")

#other
nameOfFile <-  paste(fileLocation,"other_prin_comps.csv",sep="")
savedOther <- read.delim(nameOfFile,stringsAsFactors=FALSE, header = TRUE,sep=",")

#physico

nameOfFile <-  paste(fileLocation,"physico_prin_comps.csv",sep="")
savedPhysico <- read.delim(nameOfFile,stringsAsFactors=FALSE, header = TRUE,sep=",")

fileLocation <- "/Users/mercer/p4/data/"
setwd(fileLocation)
sink(aaIndexMongoFile)

writePC <- function(indices, accession, desc,category){

    indexElements <- "["
    for(ie in 1:length(indices)){
      if(ie==20){
        indexElements <- paste(indexElements, indices[ie],"]",sep="")
      }else{
        indexElements <- paste(indexElements,  indices[ie],",",sep="")
      }

    }

    thisIndex <- paste(    '{ "accession": ', paste('"',accession,'"',sep=""),
                           ',"description": ', paste('"',desc,'"',sep=""),
                           ',"category": ',paste('"',category,'"',sep=""),
                           ',"indices": ',indexElements,
                           '}', sep="" )

    cat(thisIndex)
    cat('\n')
}

indices <- unlist(savedAlpha$PC1)
writePC(indices,"AlphaHelixPC1","1st Principal Component of Alpha Helix Propensity","Alpha & Turn Propensity" )
indices <- unlist(savedBeta$PC1)
writePC(indices,"BetaSheetPC1","1st Principal Component of Beta Sheet Propensity","Beta Sheet Propensity" )
indices <- unlist(savedComposition$PC1)
writePC(indices,"CompositionPC1","1st Principal Component of Composition","Composition" )
indices <- unlist(savedHydro$PC1)
writePC(indices,"HydrophobicityPC1","1st Principal Component of Hydrophobicity","Hydrophobicity" )
indices <- unlist(savedOther$PC1)
writePC(indices,"OtherPropertiesPC1","1st Principal Component of Other Properties","Other Properties" )
indices <- unlist(savedPhysico$PC1)
writePC(indices,"PhysicoChemicalPC1","1st Principal Component of Physico-Chemical Properties","Physico-Chemical Properties" )

sink()

#./mongoimport -d mu8 -c AAIndices --file /Users/mercer/p4/data/AAIndicesForMongo.json


sample_matrix <- function(file_name, file_dir = getwd(), num_perm = 1, perm_type = "sample_rand", write_files = 1, perm_dir = "./permutations/", verbose = 0, debug = 0){ #10-18-11 - function to generate permuations of data

  if ( nargs() == 0){print_usage()}

  # check to see if the permutations directory exists - if not, create one
  if ( file.exists(perm_dir)==FALSE ){
    dir.create(perm_dir)
  }

  file_path_name <<- gsub(" ", "",paste(file_dir, "/", file_name))
  my_data <<- data.matrix(read.table(file_path_name, row.names=1, check.names=FALSE, header=TRUE, sep="\t", comment.char="", quote=""))

  if(verbose==TRUE){print(my_data)}

  row_names <<- dimnames(my_data)[[1]]
  col_names <<- dimnames(my_data)[[2]]

  sum_data <<- base::sum(my_data)

  n_rows <<- dim(my_data)[1]
  index_rows <<- matrix( nrow=1, ncol=n_rows)
  for (i in 1:n_rows){
    index_rows[i] = i
  }

  n_cols <<- dim(my_data)[2]
  index_cols = matrix( nrow=1, ncol=n_cols)
  for (j in 1:n_cols){
    index_cols[j] = j
  }

  if(identical(perm_type, "sample_rand")){
    sample_rand_func(perm_dir, file_name, my_data, num_perm, sum_data, n_rows, n_cols, row_names, col_names, index_cols, index_rows, write_files, verbose, debug)
  }else if(identical(perm_type, "dataset_rand")){
    dataset_rand_func(perm_dir, file_name, my_data, num_perm, sum_data, n_rows, n_cols, row_names, col_names, index_cols, index_rows, write_files, verbose, debug)
  }else if(identical(perm_type, "rowwise_rand")){
    rowwise_rand_func(perm_dir, file_name, my_data, num_perm, sum_data, n_rows, n_cols, row_names, col_names, index_cols, index_rows, write_files, verbose, debug)
  }else if(identical(perm_type, "sampleid_rand")){
    sampleid_rand_func(perm_dir, file_name, my_data, num_perm, sum_data, n_rows, n_cols, row_names, col_names, index_cols, index_rows, write_files, verbose, debug)
  }else if(identical(perm_type, "complete_rand")){
    complete_rand_func(perm_dir, file_name,          num_perm, sum_data, n_rows, n_cols, row_names, col_names, index_cols, index_rows, write_files, verbose, debug)
  }else{
    print("you did not supply a valid argument for perm_type")
    print_usage()
  }

}

##### SUB FUNCTIONS #####

# perform randomization that just shuffles values among fields within a sample (column) - dataset distribution is maintained, as is the distribution for each sample (column)
# shuld try to keep randomization in a sample
sample_rand_func <- function(perm_dir, file_name, my_data, num_perm, sum_data, n_rows, n_cols, row_names, col_names, index_cols, index_rows, write_files, verbose, debug) {
  for (k in 1:num_perm) {
    rand_data <<- matrix(0, n_rows, n_cols)
    dimnames(rand_data)[[1]] <<- row_names
    dimnames(rand_data)[[2]] <<- col_names
    for (cn in 1:n_cols){
      rand_data[,cn] <<- sample(my_data[,cn])
    }
    if (verbose > 0) { sum_rand_data = base::sum(rand_data); verbose_report(k, sum_data, sum_rand_data, rand_data) }
    if (write_files > 0) { write_files(perm_dir, file_name, rand_data, k) }
  }
}

#perform randomizaton that shuffles values among fields across the whole dataset - dataset distribution is maintained, column (sample) distributions are not
dataset_rand_func<- function(perm_dir, file_name, my_data, num_perm, sum_data, n_rows, n_cols, row_names, col_names, index_cols, index_rows, write_files, verbose, debug) {
  for (k in 1:num_perm) {
    rand_data <<- matrix(0, n_rows, n_cols)
    dimnames(rand_data)[[1]] <<- row_names
    dimnames(rand_data)[[2]] <<- col_names
    rand_values <- sample(matrix(as.numeric(paste(my_data))))
    #if ( debug == 1 ) { print("rand_values:   "); print(rand_values) }
    #if ( debug == 1 ) { print("num_rand_values"); print(n_rows*n_cols) }
    rand_values_index = 1
    if(rand_values_index<=(n_rows*n_cols)) {
    for (nr in 1:n_rows) {
        for (nc in 1:n_cols) {
          rand_data[nr,nc] <<- (rand_values[rand_values_index])
          rand_values_index = rand_values_index+1
        }
      }
    }
    if (verbose > 0) { sum_rand_data = base::sum(rand_data); verbose_report(k, sum_data, sum_rand_data, rand_data) }
    if (write_files > 0) { write_files(perm_dir, file_name, rand_data, k) }
  }
}

# perform a complete randomization of counts; all counts are randomly distributed -- should lose the sample and data set distributions
# draws from the uniform multinomial distribution with exactly sum_data events in n_rows * n_cols buckets
complete_rand_func <- function(perm_dir, file_name, num_perm, sum_data, n_rows, n_cols, row_names, col_names,  index_cols, index_rows, write_files, verbose, debug) {
  for (k in 1:num_perm) {
    rand_data <<- matrix(0, n_rows, n_cols)
    dimnames(rand_data)[[1]] <<- row_names
    dimnames(rand_data)[[2]] <<- col_names
    for (l in 1:sum_data) {
      sample_row <<- sample(index_rows, size=1)
      sample_col <<- sample(index_cols, size=1)
      rand_data[sample_row, sample_col] <<- (rand_data[sample_row, sample_col] + 1)
    }
    if (verbose > 0) { sum_rand_data = base::sum(rand_data); verbose_report(k, sum_data, sum_rand_data, rand_data) }
    if (write_files > 0) { write_files(perm_dir, file_name, rand_data, k) }
  }
}

# scramble rows
rowwise_rand_func <- function(perm_dir, file_name, my_data, num_perm, sum_data, n_rows, n_cols, row_names, col_names, index_cols, index_rows, write_files, verbose, debug) {
  for (k in 1:num_perm) {
    rand_data <<- matrix(0, n_rows, n_cols)
    dimnames(rand_data)[[1]] <<- row_names
    dimnames(rand_data)[[2]] <<- col_names
    for (cr in 1:n_rows){
      rand_data[cr,] <<- sample(my_data[cr,])
    }
    if (verbose > 0) { sum_rand_data = base::sum(rand_data); verbose_report(k, sum_data, sum_rand_data, rand_data) }
    if (write_files > 0) { write_files(perm_dir, file_name, rand_data, k) }
  }
}

# scramble sample labels only
sampleid_rand_func <- function(perm_dir, file_name, my_data, num_perm, sum_data, n_rows, n_cols, row_names, col_names, index_cols, index_rows, write_files, verbose, debug) {
  for (k in 1:num_perm) {
    rand_data <<- matrix(0, n_rows, n_cols)
    dimnames(rand_data)[[1]] <<- row_names
    dimnames(rand_data)[[2]] <<- col_names
    scramble_col<<- sample(index_cols)

    for (cn in 1:n_cols){
      rand_data[,cn] <<- my_data[,scramble_col[cn]]
    }
    if (verbose > 0) { sum_rand_data = base::sum(rand_data); verbose_report(k, sum_data, sum_rand_data, rand_data) }
    if (write_files > 0) { write_files(perm_dir, file_name, rand_data, k) }
  }
}

verbose_report <- function(k, sum_data, sum_rand_data, rand_data) {
  print('-----------------------------------')
  print(paste("iteration:     (", k, ")"))
  print(paste("sum_data:      (", sum_data, ")"))
  print(paste("sum_rand_data: (", sum_rand_data, ")"))
  print(paste("*******rand_data:*******"))
  print(rand_data)
  print('-----------------------------------')
}

write_files <- function(perm_dir, file_name, rand_data, k) {
  file_out <- gsub(" ", "", paste(perm_dir, file_name, ".permutation.", k))
  write.table(rand_data, file=file_out, col.names=NA, row.names=TRUE, append = FALSE, sep="\t", quote = FALSE)
}

print_usage <- function() {
  writeLines("  ------------------------------------------------------------------------------
  sample_matrix.r
  ------------------------------------------------------------------------------
  DESCRIPTION:
  This script will calculate permutations and derived stats abundance count data

  USAGE:
  sample_matrix(file_name, num_perm = 1, perm_type = \"sample_rand\", write_files = 0, perm_dir = \"./permutations/\", verbose = 0, debug = 0)

       file_name   : boolean, required name of file to process
       file_dir    : string, default = getwd()  :path for the file to process
       num_perm    : integer, number of permutations
       perm_type   : string, select type of permuations to perform from
                     \"sample_rand\"   - uses \"sample\" function to shuffle fields within each column (sample)
                     (maintains total counts, the original data set distribution, and distribution in each sample(column))
                     \"dataset_rand\"  - shuffles fields within the entire data set
                     (maintains total counts and the original data set distribution)
                     \"complete_rand\" - randomly distributes sum of counts about equally sized matrix (only works with integers!!)
                     (maintains total counts, but not distribution)
       write_files : default = 0               : boolean, write a file for each permutation/iteration
       perm_dir    : default = \"./permutations/\", directory for permutation files
       verbose     : default = 0               : boolean, print verbose output to STDOUT
       debug       : default = 0               : boolean, print debug output to STDOUT
  ------------------------------------------------------------------------------
Arguents you supplied:")
  print(paste("file_name: ", file_name))
  print(paste("file_dir:  ", file_dir))
  print(paste("num_perm:  ", num_perm))
  print(paste("perm_type: ", perm_type))
  print(paste("verbose:   ", verbose))
  print(paste("debug:     ", debug))
  print("------------------------------------------------------------------------------")
  stop("you did not enter the correct args -- see above")
}


library(stringr)
get.datetimestamp <- function(){
  return(format(Sys.time(), "%Y%m%dT%H%M%S"))
}
timestamp=get.datetimestamp()
get.keypress.between.plots<-FALSE
#redirects output to file rather than to matlab window.
matplot.tf<-function(...){
  #loop
  iter<-1
  repeat{
    candidate.filename<-paste0("fig_",timestamp,"_",str_pad(iter,4,pad="0"),".png")
    if(!file.exists(candidate.filename)) break;
    iter<-iter+1
  }
  png(paste0(candidate.filename))
  out<-matplot(...)
  dev.off()
  return(out)
}
hist.tf<-function(...){
  #loop
  iter<-1
  repeat{
    candidate.filename<-paste0("fig_",timestamp,"_",str_pad(iter,4,pad="0"),".png")
    if(!file.exists(candidate.filename)) break;
    iter<-iter+1
  }
  png(paste0(candidate.filename))
  out<-hist(...)
  dev.off()
  return(out)
}

setwd(file.path(mainDir, subDir))
tnmc=length(keep.samples)

if(plot.phi==TRUE)phi=array(NA,c(n.chains,n.hpars,tnmc))
if(plot.lower==TRUE)theta=array(NA,c(n.chains,n.pars,S,tnmc))
if(plot.weights==TRUE)weights=array(NA,c(n.chains,S,tnmc))
if(plot.sigma==TRUE | plot.rho==TRUE)Sigma=array(NA,c(n.chains,n.Sigma,tnmc))
if(plot.mu==TRUE)mu=array(NA,c(n.chains,n.mu,tnmc))

#iterating through chains I guess?
for(q in 1:n.chains){
  if(plot.lower==TRUE){#iterate through subjects.
    for(j in 1:S){
      temp=t(as.matrix(read.table(paste("chain",q,"_sub",j,"_lower.txt",sep=""),header=F)))
      theta[q,,j,]=temp[,-1]
    }}
  if(plot.sigma==TRUE | plot.rho==TRUE){
    temp=t(as.matrix(read.table(paste("chain",q,"_Sigma.txt",sep=""),header=F)));Sigma[q,,]=temp[,-1];
  }
  if(plot.mu==TRUE){
    temp=t(as.matrix(read.table(paste("chain",q,"_mu.txt",sep=""),header=F)));mu[q,,]=temp[,-1];
  }
  if(plot.phi==TRUE){temp=t(as.matrix(read.table(paste("chain",q,"_hyper.txt",sep=""),header=F)));phi[q,,]=temp[,-1]}
  if(plot.weights==TRUE){temp=t(as.matrix(read.table(paste("chain",q,"_weights.txt",sep=""),header=F)));weights[q,,]=temp[,-1]}
  #if(plot.weights.delta==TRUE){temp=t(as.matrix(read.table(paste("chain",q,"_weights_delta.txt",sep=""),header=F)));weight.delta[q,,]=temp[,-1]}
  print(round(q/n.chains*100))
}

#######################################################################################

breaks=50

if(plot.lower==TRUE){#iterate through subjects.
par(mfrow=c(2,2),ask=get.keypress.between.plots)
for(j in 1:S){
for(k in 1:n.pars){
matplot.tf(t(theta[,k,j,start:tnmc]),type="l",lty=1,main=paste("Subject ",j),ylab=par.names[k])
#if(any(k==c(1,2,3,6)))abline(h=log(true$vec[k]),lwd=3)
#if(any(k==c(4,5)))abline(h=logit(true$vec[k]),lwd=3)
hist(theta[,k,j,start:tnmc],prob=T,breaks=breaks,main=paste("Subject ",j),xlab=par.names[k])
#if(any(k==c(1,2,3,6)))abline(v=log(true$vec[k]),lwd=3,col="red")
#if(any(k==c(4,5)))abline(v=logit(true$vec[k]),lwd=3,col="red")
}}}

count=1
if(plot.phi==TRUE){
par(mfrow=c(2,2),ask=get.keypress.between.plots)
for(k in 1:n.hpars){
if(plot.priors==TRUE){
if(k==(n.pars+1))count=1
xs=seq(min(phi[,k,start:tnmc]),max(phi[,k,start:tnmc]),length=200)
if(k<=n.pars)ys=dnorm(xs,prior[[count]]$mu,prior[[count]]$sigma)
if(k>n.pars)ys=dinvgamma(xs,prior[[count]]$alpha,prior[[count]]$beta)
}
matplot.tf(t(phi[,k,start:tnmc]),type="l",lty=1,main="",ylab=hpar.names[k])
hist(phi[,k,start:tnmc],prob=T,breaks=breaks,main="",xlab=hpar.names[k])
if(plot.priors==TRUE){
lines(xs,ys,lty=2)
count=count+1
}}}

if(plot.sigma==TRUE){
  par(mfrow=c(2,2),ask=get.keypress.between.plots)
  for(k in 1:n.Sigma){
    matplot.tf(t(Sigma[,k,start:tnmc]),type="l",lty=1,main=paste("Sigma1",k))
    hist(Sigma[,k,start:tnmc],prob=T,breaks=breaks)
  }
}

if(plot.mu==TRUE){
  par(mfrow=c(2,2),ask=get.keypress.between.plots)
  for(k in 1:n.mu){
    matplot.tf(t(mu[,k,start:tnmc]),type="l",lty=1,main=paste("mu1",k))
    hist(mu[,k,start:tnmc],prob=T,breaks=breaks)
  }
}

if(plot.rho==TRUE){
  par(mfrow=c(2,2),ask=get.keypress.between.plots)
  shift=n.mu
  for(k in 3:shift){
    temp=Sigma[,k,start:tnmc]/(sqrt(Sigma[,shift*(k-1)+k,start:tnmc])*sqrt(Sigma[,1,start:tnmc]))
    matplot.tf(t(temp),type="l",lty=1,main=paste("Sigma1",k))
    hist(temp,prob=T,breaks=breaks)

    temp=Sigma[,k+shift,start:tnmc]/(sqrt(Sigma[,shift*(k-1)+k,start:tnmc])*sqrt(Sigma[,shift+2,start:tnmc]))
    matplot.tf(t(temp),type="l",lty=1,main=paste("Sigma2",k))
    hist(temp,prob=T,breaks=breaks)
  }
}

if(plot.weights==TRUE){
par(mfrow=c(2,2),ask=get.keypress.between.plots)
for(j in 1:S){
matplot.tf(t(weights[,j,start.weights:tnmc]),type="l",lty=1,main=paste("Subject ",j),ylab="log likelihood")
}}

setwd(file.path(mainDir))


require(effsize)

projects <- c("bugzilla", "platform","mozilla","jdt","columba","postgres")
# projects <- c("columba")   ################################### <<<<<<<<----------------------changed!
GetMagnitude <- function(str) {
    lbl <- NULL
    if (str == "large") {
        lbl <- "L"
    } else if (str == "medium") {
        lbl <- "M"
    } else if (str == "small") {
        lbl <- "S"
    } else if (str == "negligible") {
        lbl <- "T"
    } else {
        stop("error")
    }
    return(lbl)
}

GetOverall <- function(data, xnames, base, fname, pth=0.05, mth=c("negligible")) {

    tt.pvs <- wt.pvs <- NULL
    for (i in seq(xnames)) {
        treat <- data[, xnames[i]]

        tt.pvs <- c(tt.pvs, t.test(treat, base, paired=TRUE)$"p.value")
        apvs <- wilcox.test(treat, base, paired=TRUE)$"p.value"
        if (is.na(apvs)) { apvs <- 1 }
        wt.pvs <- c(wt.pvs, apvs)
    }

    wt.pvs <- p.adjust(wt.pvs, method="BH")
    tt.pvs <- p.adjust(tt.pvs, method="BH")

    dt.out <- data.frame(matrix(0, nrow=length(xnames), ncol=12))
    rownames(dt.out) <- xnames
    colnames(dt.out) <- c("avg", "improve.avg", "cohend", "cohend.magnitude", "tt.p-value", "med", "improve.med", "cliffd", "cliffd.magnitude", "wt.p-value", "overall", "colsall")

    base.out <- c(mean(base), 0, NA, NA, NA, median(base), NA, NA, NA, NA, NA, NA)
    dt.out[, "tt.p-value"] <- tt.pvs
    dt.out[, "wt.p-value"] <- wt.pvs
    dt.out[, "med"] <- apply(data[, xnames], MARGIN=2, FUN=median)
    dt.out[, "avg"] <- apply(data[, xnames], MARGIN=2, FUN=mean)

    colsall <- overall <- NULL
    cohend <- cliffd <- NULL
    cohend.magnitudes <- cliffd.magnitudes <- NULL
    for (i in seq(xnames)) {
        d2 <- data[, xnames[i]]

        cd <- effsize::cohen.d(d2, base, paired=TRUE)
        cohend <- c(cohend, cd$estimate)
        cohend.magnitudes <- c(cohend.magnitudes, cd$magnitude)

        cd <- effsize::cliff.delta(d2, base)
        cliffd <- c(cliffd, cd$estimate)
        cliffd.magnitudes <- c(cliffd.magnitudes, cd$magnitude)

        if (wt.pvs[i]<=pth) {
            if (median(d2, na.rm=TRUE) > median(base, na.rm=TRUE)) {
                if (cd$magnitude %in% mth) {
                    overall <- c(overall, "==")
                    colsall <- c(colsall, "black")
                } else {
                    overall <- c(overall, "vv")
                    colsall <- c(colsall, "blue")
                }
            } else {
                if (cd$magnitude %in% mth) {
                    overall <- c(overall, "==")
                    colsall <- c(colsall, "black")
                } else {
                    overall <- c(overall, "xx")
                    colsall <- c(colsall, "red")
                }
            }
        } else {
            overall <- c(overall, "==")
            colsall <- c(colsall, "black")
        }
    }

    return(data.frame(overall=overall, colsall=colsall, stringsAsFactors=FALSE))
}

Plot_SKtest.test <- function (validation="cv", criteria="ACC", types="UP", cnames=cnames,num_sup=4,all.projects=F) {

    require(ScottKnott)
    smnames <- cnames[1:num_sup]
    smlabels <- substr(cnames[1:num_sup],1,(nchar(cnames)-1-nchar(criteria)))
    uslabels <- substr(cnames[num_sup+1:length(cnames)],1,(nchar(cnames[num_sup+1:length(cnames)])-4-nchar(criteria)))
    # lbls.org <- c(lbnames, lbls.org)
    lbls.org <- c(smlabels, uslabels)
    xlabels <- c("EALR","RF","J48","IBk","NS","ND","NF","Entropy","LT","FIX","NDEV","AGE","EXP","REXP","SEXP","NUC")
    lbls.org <-xlabels
    cols.org <- c(rep("black", length(smnames)), rep("blue", length(uslabels)))

    df.1st <- NULL
    if (validation=="cv") {
        for (i in 1:length(projects)) {
            project <- projects[i]
            out.fname <- sprintf("../output/cross-validation/out_%s_%s.txt", project, criteria)
            rdata <- dget(out.fname)
            rdata <- rdata[, cnames]

            for (cname in cnames) {
                arun <- rdata[, cname]
                df.1st <- rbind(df.1st, data.frame(tr=xlabels, r=i, y=mean(rdata[, cname])))
            }
        }
    } else if (validation=="cv-tw") {
        # if(!all.projects){
          pdf(file=sprintf("results/SK-%s-%s-%s.pdf", validation, criteria,"ALL"), width=3, height=5,paper = "special")
          par(mfrow=c(6, 1), mai=c(0, 0, 0, 0), omi=c(0.15, 0.25, 0.30, 0), mex=1, cex=0.75)
        for (i in seq(length(projects))) {
            project <- projects[i]
            out.fname <- sprintf("../output/cross-validation-timewise/out_%s_%s.txt", project, criteria)
            rdata <- dget(out.fname)
            rdata <- rdata[, cnames]
            if(!all.projects){
              df.1st <-NULL
              for (cname in cnames) {
                arun <- rdata[, cname]
                df.1st <- rbind(df.1st, data.frame(tr=cname, r=i, y=(rdata[, cname])))
              }
              sk.1st <- with(df.1st, SK(x=df.1st, y=y, model='y ~ tr', which='tr'))
              lbls <- lbls.org[sk.1st$ord]
              cols <- cols.org[sk.1st$ord]

              plot(sk.1st, rl=FALSE, col=rep("black", length(lbls)), id.lab=rep("", length(lbls)), xlab=NA, ylab=NA, id.col=FALSE,xaxt="n", yaxt="n", main="", title="")###, col=rainbow(max(sk.1st$groups)), xlim=c(2, length(lbls)),

              box(bty="L")
              for (group in unique(sk.1st$groups)) {
                if (group == max(unique(sk.1st$groups))) {
                  next
                }
                abline(v=max(which(sk.1st$groups==group))+0.5, lty=2, col="black", lwd=1.5)
              }
              # mtext("Avg", side=2, line=2.5, adj=0.1, cex=0.6)
              axis(2, mgp=c(0.15, 0.15, 0), las=0, tck=-0.02, cex.axis=0.6, font=1,lwd=1,)
              text(x=seq(length(lbls)), y=par("usr")[3], srt=30, adj=c(1, 1.2), xpd=NA, cex=0.6, labels=lbls, col=cols)
              if(i==1){
                legend(x="top",ncol = 2, legend=expression(italic("Supervised"), italic("Unsupervised")), lty=c(1, 1), lwd=c(2, 2), col=c("black", "blue"), cex=0.8, merge=FALSE, bty="n")
              }
            }
            else{
              for (cname in cnames) {
                arun <- rdata[, cname]
                df.1st <- rbind(df.1st, data.frame(tr=cname, r=i, y=mean(rdata[, cname])))
              }

            }
        }
        dev.off()
    } else if (validation=="cp") {
        for(i in seq(length(projects))) {
            project1 <- projects[i]
            rdata <- NULL
            for(j in seq(length(projects))) {
                if(i != j) {
                    project2 <- projects[j]
                    out.fname <- sprintf("../output/cross-project/out_%s_cross_%s_%s.txt", project1, project2, criteria)
                    srdata <- dget(out.fname)

                    rdata <- rbind(rdata, srdata)
                }
            }

            rdata <- rdata[, cnames]
            for (cname in cnames) {
                df.1st <- rbind(df.1st, data.frame(tr=cname, r=i, y=mean(rdata[, cname])))
            }
        }
    }
    if(all.projects){
      sk.1st <- with(df.1st, SK(x=df.1st, y=y, model='y ~ tr', which='tr'))
      browser()
      lbls <- lbls.org[sk.1st$ord]
      cols <- cols.org[sk.1st$ord]

      png(file=sprintf("results/SK-%s-%s.png", validation, criteria), width=6, height=1.0, units="in", res=600, pointsize=10)
      par(mai=c(0, 0, 0, 0), omi=c(0.35, 0.3, 0.05, 0), mex=0.4, cex=1.0, cex.axis=0.7)

      plot(sk.1st, rl=FALSE, col=rep("black", length(lbls)), id.lab=rep("", length(lbls)), xlab=NA, ylab=NA, id.col=FALSE, xaxt="n", yaxt="n", main="", title="", mex=0.4, cex=0.6, cex.axis=0.7)###, col=rainbow(max(sk.1st$groups)), xlim=c(2, length(lbls)),

      box(bty="L")
      for (group in unique(sk.1st$groups)) {
        if (group == max(unique(sk.1st$groups))) {
          next
        }
        abline(v=max(which(sk.1st$groups==group))+0.5, lty=2, col="black", lwd=1.5)
      }
      # mtext("Avg", side=2, line=2.5, adj=0.5, cex=0.8)
      axis(2, mgp=c(0.15, 0.15, 0), las=0, tck=-0.02, cex.axis=0.6, font=1,lwd=1,)
      text(x=seq(length(lbls)), y=par("usr")[3], srt=60, adj=c(1, 1.2), xpd=NA, cex=0.6, labels=lbls, col=cols)

      legend(x="top", ncol=2, legend=expression(italic("Supervised"), italic("Unsupervised")), lty=c(1, 1), lwd=c(2, 2), col=c("black", "blue"), cex=0.8, merge=FALSE, bty="n")

      dev.off()

    }

}

plot_hist_single <- function(validation="cv", criteria="ACC", types="UP",all.projects=F,num_sup=12) {
    # smnames <- c("EALR", "NaiveBayes", "SimpleLogistic", "RBFNetwork", "SMO", "J48", "LMT", "RandomForest", "Ridor", "JRip", "IBk", "Bagging+LMT", "Bagging+NaiveBayes", "Bagging+SimpleLogistic", "Bagging+SMO", "Bagging+J48", "RotationForest+LMT", "RotationForest+NaiveBayes", "RotationForest+SimpleLogistic", "RotationForest+SMO", "RotationForest+J48", "AdaBoostM1+LMT", "AdaBoostM1+NaiveBayes", "AdaBoostM1+SimpleLogistic", "AdaBoostM1+SMO", "AdaBoostM1+J48", "RandomSubSpace+LMT", "RandomSubSpace+NaiveBayes", "RandomSubSpace+SimpleLogistic", "RandomSubSpace+SMO", "RandomSubSpace+J48")
    # lbnames <- c("EALR", "NB", "SL", "RBFN", "SMO", "J48", "LMT", "RF", "Ridor", "JRip", "IBk", "BG+LMT", "BG+NB", "BG+SL", "BG+SMO", "BG+J48", "RF+LMT", "RF+NB", "RF+SL", "RF+SMO", "RF+J48", "AB+LMT", "AB+NB", "AB+SL", "AB+SMO", "AB+J48", "RS+LMT", "RS+NB", "RS+SL", "RS+SMO", "RS+J48")
  smnames <- c("EALR","J48","J48.tuned","IBk","IBk.tuned","RandomForest","RandomForest.tuned")
  lbnames <- c("EALR","J48","J48.tuned","IBk","IBk.tuned","RandomForest","RandomForest.tuned")
  smnames <- c("EALR") ################################### <<<<<<<<----------------------changed!
  lbnames <- c("EALR","RF","J48","IBk","","NS","ND","NF","Entropy","LT","FIX","NDEV","AGE","EXP","REXP","SEXP","NUC","OneWay") ################################### <<<<<<<<----------------------changed!
    title <- NULL
    data <- data.all <- NULL
    if (validation=="cv") {
        for (project in projects) {
            out.fname <- sprintf("../output/cross-validation/out_%s_%s.txt", project, criteria)
            if (!file.exists(out.fname)) { next }
            rdata <- dget(out.fname)

            data.all[[project]] <- rdata[, cnames]
            data  <- rbind(data, rdata[, cnames])
        }
    } else if (validation=="cv-tw") {
        for (project in projects) {
            out.fname <- sprintf("../output/cross-validation-timewise/out_%s_%s.txt", project, criteria)
            if (!file.exists(out.fname)) { next }
            rdata <- dget(out.fname)

            data.all[[project]] <- rdata[, 5:length(rdata)]
            data  <- rbind(data, rdata[, 5:length(rdata)])
            # browser()
        }
    } else if (validation=="cp") {
        for (project1 in projects) {
            for (project2 in projects) {
                if (project1!=project2) {
                    out.fname <- sprintf("../output/cross-project/out_%s_cross_%s_%s.txt", project1, project2, criteria)
                    if (!file.exists(out.fname)) { next }
                    rdata <- dget(out.fname)

                    data <- rbind(data, rdata[, cnames])
                }
            }
        }
    }
    umnames <-NULL
    cnames <- names(data)
    cnames <- cnames[c(5,6,7,8,9,10,11,12,14,15,16,17,18)]  ## get rid of npt
    # browser()
    smnames <- cnames[1:num_sup]
    smlabels <- substr(cnames[1:num_sup],1,(nchar(cnames)-1-nchar(criteria)))
    uslabels <- substr(cnames[num_sup+1:length(cnames)],1,(nchar(cnames[num_sup+1:length(cnames)])-4-nchar(criteria)))
    # xlabels <- c(smlabels, uslabels)
    xlabels <- c("EALR","RF","J48","IBk","NS","ND","NF","Entropy","LT","FIX","NDEV","AGE","EXP","REXP","SEXP","NUC","OneWay")
    # xlabels <- c("A","B","C","D","E","F","G","H","I","J","K","L","M","N","O","P")
    xlabels <- c("NS","ND","NF","Entropy","LT","FIX","NDEV","AGE","EXP","REXP","SEXP","NUC","OneWay")
    ################ get colors for boxplot border ####################

    overall <- data.frame(matrix(0, nrow=length(cnames), ncol=length(projects)))
    colnames(overall) <- projects
    overall <- apply(overall, c(1, 2), as.character)
    colsall <- overall
    if (validation!="cp") {
        for (project in projects) {
            # browser()
            s.index <- which.max(apply(data.all[[project]][, cnames[length(cnames)], drop=FALSE], 2, median))
            ares <- GetOverall(data=data.all[[project]], xnames=cnames, base=data.all[[project]][, names(data)[18]], fname=sprintf("results/(%s)%s-all-out-%s.csv", validation, project, criteria))
            overall[, project] <- ares$overall
            colsall[, project] <- ares$colsall
        }
    }

    s.index <- which.max(apply(data[, smnames, drop=FALSE], 2, median))
    ares <- GetOverall(data=data, xnames=cnames, base=data[, smnames[s.index]], fname=sprintf("results/(%s)all-out-%s.csv", validation, criteria))
    overall <- cbind(overall, ares$overall)
    colsall <- cbind(colsall, ares$colsall)

    # browser()
    ################ get colors for boxplot filledin, if better than best1 ####################
    overallOO <- data.frame(matrix(0, nrow=length(cnames), ncol=length(projects)))
    colnames(overallOO) <- projects
    overallOO <- apply(overallOO, c(1, 2), as.character)
    colsallOO <- overallOO
    if (validation!="cp") {
      for (project in projects) {
        # browser()
        s.index <- which.max(apply(data.all[[project]][, smnames, drop=FALSE], 2, median))
        ares <- GetOverall(data=data.all[[project]], xnames=cnames, base=data.all[[project]][, cnames[length(cnames)]], fname=sprintf("results/(%s)%s-all-out-%s.csv", validation, project, criteria))
        overallOO[, project] <- ares$overall
        colsallOO[, project] <- ares$colsall
      }
    }

    box.col <- gsub("black|red",NA,colsallOO,fixed=FALSE)
    box.col <- gsub("blue","green",box.col)

    #### parameters for plots
    ##### plots for each project
    par(mfrow = c(3, 2))
    pdf(file=sprintf("results/hist-%s-%s-%s.pdf", validation,"Unsup-OneWay",criteria), width=4, height=4,paper = "special")
    par(mfrow=c(6, 1), mai=c(0, 0, 0, 0), omi=c(0.35, 0.25, 0.30, 0), mex=1, cex=0.75)
    text_count<-1
    if(!all.projects){
      for(project in projects ){
        len <- length(smnames)

        pos <- c(1:len, (len+2):(length(cnames)+1))
        # browser()

        ylab.names <- projects

        cols <- colsall[, project]
        if(project !="bugzilla" && (criteria %in% c("Precision","PREC","F1"))){
          if(project == "mozilla"){
            boxplot(data.all[[project]][, cnames], xlab=NA, ylab=NA, xaxt="n", yaxt="n", at=pos, border=cols,boxwex=0.8, frame=FALSE, outline=FALSE,ylim=c(0,0.24)) ### xlim=c(2, len+12),
            axis(2, mgp=c(0.5, 0.15, 0), las=0, tck=-0.02, cex.axis=1, font=1,lwd=1,)
          }else{
            boxplot(data.all[[project]][, cnames], xlab=NA, ylab=NA, xaxt="n", yaxt="n", at=pos, border=cols,boxwex=0.8, frame=FALSE, outline=FALSE,ylim=c(0,0.7)) ### xlim=c(2, len+12),
            axis(2, mgp=c(0.5, 0.15, 0), las=0, tck=-0.02, cex.axis=1, font=1,lwd=1,)
          }
        }else{
          boxplot(data.all[[project]][, cnames], xlab=NA, ylab=NA, xaxt="n", yaxt="n", at=pos, border=cols,boxwex=0.8, frame=FALSE, outline=FALSE,ylim=c(0,1.1)) ### xlim=c(2, len+12),
          axis(2, mgp=c(0.5, 0.15, 0), las=0, tck=-0.02, cex.axis=1, font=1,lwd=1,)
        }

        ### tck: length of tick marks ### las: vertical or horizontal

        box(bty="L", lwd=1)

        ### xpd=NA print text outside plot margin

        temp <- max(apply(data.all[[project]][, cnames[len+1], drop=FALSE], 2, median))[1]

        points(x=c(1, length(c(smnames, uslabels))), y=c(temp, temp), type="l", lty="dashed")
        abline(v=len+1,  lty="dashed", col="black")
        if(text_count ==6){
          text(x=pos, y=par("usr")[3], srt=35, adj=c(0.9, 1.6), labels=xlabels, font=1, xpd=NA, cex=1) ### the model names
          # text(x=0,y=sum(par("usr")[3:4])*4/2,str=90,adj=c(0, 1.1),labels=criteria, cex=0.5)
          # browser()
        }
        if(text_count ==1){
          text(x=c((1+len)/2, (length(cnames))/2+0.4+(1+len)/2), y=par("usr")[4], adj=c(0.5, -0.5), font=3, xpd=NA, labels=c("Unsupervised", "Proposed"), cex=1)
          if(criteria == "ACC")
          {criteria <- "Recall"}
          if(criteria == "PREC")
          {criteria <- "Precision"}

          text(x=length(cnames)/2, y=par("usr")[4]+0.25, adj=c(0.5, -0.5), font=3, xpd=NA, labels=criteria, cex=1)
        }
        text_count <- text_count +1

      }
    }
  else{
    #### plots for all projects in one
    len <- length(smnames)
    pos <- c(1:len, (len+2):(len+13))

    png(file=sprintf("results/hist-%s-%s.png", validation, criteria), width=6, height=1.0, units="in", res=600, pointsize=10)
    par(mfrow=c(1, 1), mai=c(0, 0, 0, 0), omi=c(0.35, 0.15, 0.15, 0), mex=0.4, cex=1.0)
    ylab.names <- projects

    cols <- colsall[, length(projects)+1]
    boxplot(data[, cnames], xlab=NA, ylab=NA, xaxt="n", yaxt="n", at=pos, border=cols, boxwex=0.6, frame=FALSE, outline=FALSE) ### xlim=c(2, len+12),

    ### tck: length of tick marks ### las: vertical or horizontal
    axis(2, mgp=c(0.5, 0.5, 0), las=0, tck=-0.02, cex.axis=0.8, lwd=1.5)
    box(bty="L", lwd=1.5)

    ### xpd=NA print text outside plot margin
    temp <- max(apply(data[, cnames[1:len], drop=FALSE], 2, median))[1]
    points(x=c(1, length(c(smnames, umnames))), y=c(temp, temp), type="l", lty="dashed")
    abline(v=len+1,  lty="dashed", col="black")

    text(x=pos, y=par("usr")[3], srt=60, adj=c(1, 1.2), labels=xlabels, xpd=NA, cex=0.6) ### the model names
    text(x=c((1+len)/2, len+6.5), y=par("usr")[4], adj=c(0.5, -0.5), font=3, xpd=NA, labels=c("Supervised", "Unsupervised"), cex=0.8)

    # dev.off()

  }

  dev.off()
  return(cnames)
}

All_simple_models.tbl <- function (validation="cv", criteria="ACC", types="UP",cnames=NULL) {
    smname <- cnames[length(cnames)]
    n.row <- NULL
    a.names <- NULL
    if (validation=="cp") {
        n.row <- 1
        a.names <- "ALL"
    } else {
        n.row <- length(projects)
        a.names <- projects
    }

    data.out.r <- matrix(0, nrow=n.row+3, ncol=length(cnames))
    data.out.r <- as.data.frame(data.out.r)
    rownames(data.out.r) <- c(a.names, "AVG", "WTL", "Improve.e")
    colnames(data.out.r) <- cnames

    data.cliffd.r <- matrix(0, nrow=n.row, ncol=length(cnames))
    data.cliffd.r <- as.data.frame(data.cliffd.r)
    rownames(data.cliffd.r) <- paste(a.names, "cliff", sep="-")
    colnames(data.cliffd.r) <- cnames

    data.all <- NULL
    if (validation=="cv") {
        for (i in seq(projects)) {
            project <- projects[i]
            out.fname <- sprintf("../output/cross-validation/out_%s_%s.txt", project, criteria)
            rdata <- dget(out.fname)

            data.all[[i]] <- rdata
            data.out.r[i, ] <- apply(rdata[, cnames], MARGIN=2, FUN=median, na.rm=FALSE)
        }
    } else if (validation=="cv-tw") {
        for (i in seq(length(projects))) {
            project <- projects[i]
            out.fname <- sprintf("../output/cross-validation-timewise/out_%s_%s.txt", project, criteria)
            rdata <- dget(out.fname)

            data.all[[i]] <- rdata
            data.out.r[i, ] <- apply(rdata[, cnames], MARGIN=2, FUN=median, na.rm=FALSE)
        }
    } else if (validation=="cp") {
        rdata <- NULL
        cnamed <- NULL
        for(i in seq(length(projects))) {
            for(j in seq(length(projects))) {
                if(i != j) {
                    project1 <- projects[i]
                    project2 <- projects[j]
                    out.fname <- sprintf("../output/cross-project/out_%s_cross_%s_%s.txt", project1, project2, criteria)
                    srdata <- dget(out.fname)

                    rdata <- rbind(rdata, srdata[, cnames])
                    cnamed <- rbind(cnamed, c(project1, project2))
                }
            }
        }

        cnamed <- rbind(cnamed, c(" ", " "))
        avg <- apply(rdata, MARGIN=2, FUN=mean, na.rm=FALSE)
        write.csv(cbind(cnamed, round(rbind(rdata, avg), 3)), file=sprintf("results/(cp)-(%s).csv", criteria))

        data.out.r[1, ] <- apply(rdata[, cnames], MARGIN=2, FUN=median, na.rm=FALSE)
        data.all[[1]] <- rdata
    }

    data.out.r["AVG", ]       <- colMeans(data.out.r[1:n.row, ], na.rm=TRUE)
    data.out.r["Improve.e", ] <- 100*(data.out.r["AVG", ]-data.out.r["AVG", 1])/data.out.r["AVG", 1]

    data.out.r <- round(data.out.r, 3)
    data.out.r <- apply(data.out.r, c(1, 2), as.character)

    data.out.cliff <- data.out.r
    data.out.cliff <- 0

    PVs <- matrix(0, nrow=n.row, ncol=length(cnames))
    for (i in seq(cnames)) {
        for(j in seq(n.row)) {
            rdata <- data.all[[j]]
            base <- rdata[, smname]
            d1 <- rdata[, cnames[i]]
            err_catch <- try(wt.r <- wilcox.test(d1, base, paired=TRUE))
            if (class(err_catch)=="try-error") {
                PVs[j, i] <- NA
            } else {
                PVs[j, i] <- wt.r$"p.value"
            }
        }
    }

    BH.PVs <- PVs
    for (i in ncol(PVs)) {
        BH.PVs[, i] <- p.adjust(p=PVs[, i], method="BH")
    } ### BH.PVs <- matrix(BH.PVs, nrow=nrow(PVs), ncol=ncol(PVs))

    for (i in seq(cnames)) {
        wtl <- 0
        for(j in seq(n.row)) {
            rdata <- data.all[[j]]
            base <- rdata[, smname]
            d1 <- rdata[, cnames[i]]

            wt.r <- BH.PVs[j, i]
            if (!is.na(wt.r)) {
                if(wt.r <= 0.05) {
                    if(median(d1, na.rm=TRUE) > median(base, na.rm=TRUE)) {
                        wtl <- wtl + 100  ### win
                        data.out.r[j, i] <- paste(data.out.r[j, i], "v", sep="")
                    } else {
                        wtl <- wtl + 1 ### loss
                        data.out.r[j, i] <- paste(data.out.r[j, i], "x", sep="")
                    }
                } else {
                    wtl <- wtl + 10   ### tie
                }
            }

            err_catch <- try(cd.r <- effsize::cliff.delta(d1, base))
            if (class(err_catch)=="try-error") {
                data.cliffd.r[j, i] <- "NA"
            } else {
                if (is.na(cd.r$magnitude) || is.na(cd.r$estimate)) {
                    data.cliffd.r[j, i] <- "NA"
                } else {
                    data.cliffd.r[j, i] <- paste(GetMagnitude(cd.r$magnitude), as.character(round(cd.r$estimate, 3)), sep="")
                }
            }
        }

        data.out.r["WTL", i] <- as.character(wtl)
    }

    if (validation=="cp") {
        data.out.r["AVG", ] <- data.out.r["ALL", ]
    }

    data.out.r <- rbind(data.out.r, data.cliffd.r)

    if (validation!="cp") {
        fname <- sprintf("results/(%s)all-out-%s-models(All).csv", validation, criteria)
        write.table(c("class"), file=fname, row.names=FALSE, col.names=FALSE, append=FALSE, eol=",")
        write.table(data.out.r,   file=fname, row.names=TRUE,  col.names=TRUE,  append=TRUE, sep=",")
    }
}

# validations <- c("cv", "cv-tw", "cp")
validations <- c("cv-tw")
for (validation in validations) {
    criterias <- c("Popt","ACC","F1","PREC")
    # criterias <- c("PREC")
    for (criteria in criterias) {
        cat(validation, criteria, "\n")
        cnames=plot_hist_single(validation=validation, criteria=criteria)
        All_simple_models.tbl(validation=validation, criteria=criteria,cnames=cnames)
        # Plot_SKtest.test(validation=validation, criteria=criteria, cnames=cnames)
    }
}


#' Binds arrays together disregarding names
#'
#' @param ...    N-dimensional arrays, or a list thereof
#' @param along  Along which axis to bind them together (default: new axis)
#' @return       A joined array
#' @export
bind = function(..., along=length(dim(arrayList[[1]]))+1) {
    arrayList = list(...)
    if (length(arrayList) == 1 && is.list(arrayList[[1]]))
        arrayList = arrayList[[1]]

    arrayList = vectors_to_row_or_col(arrayList, along=along)

    ndim = dim(arrayList[[1]])
    ndim[along] = sum(sapply(arrayList, function(a) dim(a)[along]))

    dimNames = dimnames(arrayList[[1]])
    names_along = unlist(lapply(arrayList, dimnames, along=along))
    if (length(names_along) != ndim[along])
        dimNames[along] = list(NULL)
    else
        dimNames[[along]] = names_along

    offset = 0
    index = base::rep(list(TRUE), length(ndim))
    result = array(NA, dim=ndim, dimnames=dimNames)

    for (i in seq_along(arrayList)) {
        cur = arrayList[[i]]
        index[[along]] = offset + seq_len(dim(cur)[along])
        result = do.call("[<-", c(list(result), index, list(cur)))
        offset = offset + length(index[[along]])
    }

    if (dim(result)[along] == length(arrayList) && !is.null(names(arrayList)))
        dimnames(result)[[along]] = names(arrayList)

    restore_null_dimnames(result)
}


#' Perform assessments based on sample & exceedance counts (conventional & toxic assessments)
#'
#' Performs site level (site-parameter-use-criterion specific) water quality assessments based on sample & exceedance counts by applying IR method flowcharts with user specified inputs.
#'
#' When percentage arguments are supplied, specified percentages are used to calculate the maximum allowable number of whole samples exceeding a standard for that site/parameter to be considered supporting. Note that the min_n argument is >= and all other arguments are >.
#' @param data Site-use-parameter-criterion specific sample and  exceedance counts(i.e. output from countExceedances() )
#' @param min_n Minimum sample size for sufficient data assessment (sample counts >= min_n are considered sufficient)
#' @param max_exc_count Maximum allowable exceedance count for full support (exceedance counts > max_exc_count are considered not supporting) - one of max_exc_count or max_exc_pct must be specified
#' @param max_exc_pct Maximum allowable exceedance percentage for full support (exceedance pcts > max_exc_pct are considered not supporting - one of max_exc_count or max_exc_pct must be specified
#' @param max_exc_count_id Maximum allowable exceedance count for insufficient data with exceedances (for sites/parameters with insufficient data, exceedance counts > max_exc_count_id are considered insufficient data with exceedances) - one of max_exc_count_id or max_exc_pct_id must be specified
#' @param max_exc_pct_id Maximum allowable exceedance percentage for insufficient data with exceedances (for sites/parameters with insufficient data, exceedance pcts > max_exc_count_id are considered insufficient data with exceedances) - one of max_exc_count_id or max_exc_pct_id must be specified

#' @return Returns input data frame with site-use-parameter-criterion specific assessment categories appended.

#' @export
assessExcCounts=function(data, min_n, max_exc_count=NA, max_exc_pct=NA, max_exc_count_id=NA, max_exc_pct_id=NA, id_cols=c()){

##Set up####
#data=conv_exc
#min_n=10
#
#max_exc_count=NA
#max_exc_pct=10
#
#max_exc_count_id=1
#max_exc_pct_id=NA
#########

	#Check args
	if(is.na(max_exc_count) & is.na(max_exc_pct)){stop("Error: one of max_exc_count or max_exc_pct must be supplied.")}
	if(!is.na(max_exc_count) & !is.na(max_exc_pct)){stop("Error: Only one of max_exc_count or max_exc_pct may be supplied.")}
	if(is.na(max_exc_count_id) & is.na(max_exc_pct_id)){stop("Error: one of max_exc_count_id or max_exc_pct_id must be supplied.")}
	if(!is.na(max_exc_count_id) & !is.na(max_exc_pct_id)){stop("Error: Only one of max_exc_count_id or max_exc_pct_id may be supplied.")}

	data$IR_Cat=NA

	# rounding = function(x,max_exc_pct){
	#   y = x*max_exc_pct/100+0.5
	#   z = floor(y)
	#   return(z)
	# }

	# data=within(data,{
	# 	max_allow_exc=rounding(SampleCount,max_exc_pct) #Note, will produce all NAs if is.na(max_exc_pct)
	# 	max_allow_exc_id=ceiling(SampleCount*max_exc_pct_id/100) #Note, will produce all NAs if is.na(max_exc_pct_id)
	# })

	if(!is.na(max_exc_pct)){ #Exceedance pct based sufficient data assessments
		if(!is.na(max_exc_count_id)){ #Exceedance count based insufficient data assessments
			data=within(data,{
			  Percent_Exceed = NA
				IR_Cat[SampleCount>=min_n & (ExcCount/SampleCount)>max_exc_pct]="NS"
				IR_Cat[SampleCount>=min_n & (ExcCount/SampleCount)<=max_exc_pct]="FS"
				IR_Cat[SampleCount<min_n & ExcCount>max_exc_count_id]="IDEX"
				IR_Cat[SampleCount<min_n & ExcCount<=max_exc_count_id]="IDNE"
			})
		}else{  #Exceedance pct based insufficient data assessments
			data=within(data,{
			  Percent_Exceed = NA
				IR_Cat[SampleCount>=min_n & (ExcCount/SampleCount)>max_exc_pct]="NS"
				IR_Cat[SampleCount>=min_n & (ExcCount/SampleCount)<=max_exc_pct]="FS"
				IR_Cat[SampleCount<min_n & (ExcCount/SampleCount)>max_exc_pct_id]="IDEX"
				IR_Cat[SampleCount<min_n & (ExcCount/SampleCount)<=max_exc_pct_id]="IDNE"
			})
		}
	  data$Percent_Exceed = ifelse(data$SampleCount>=min_n, data$ExcCount/data$SampleCount, NA)
	}else{ #Exceedance count based assessments
		if(!is.na(max_exc_count_id)){ #Exceedance count based insufficient data assessments
			data=within(data,{
				IR_Cat[SampleCount>=min_n & ExcCount>max_exc_count]="NS"
				IR_Cat[SampleCount>=min_n & ExcCount<=max_exc_count]="FS"
				IR_Cat[SampleCount<min_n & ExcCount>max_exc_count_id]="IDEX"
				IR_Cat[SampleCount<min_n & ExcCount<=max_exc_count_id]="IDNE"
			})
		}else{  #Exceedance pct based insufficient data assessments
			data=within(data,{
				IR_Cat[SampleCount>=min_n & ExcCount>max_exc_count]="NS"
				IR_Cat[SampleCount>=min_n & ExcCount<=max_exc_count]="FS"
				IR_Cat[SampleCount<min_n & (ExcCount/SampleCount)>max_exc_pct_id]="IDEX"
				IR_Cat[SampleCount<min_n & (ExcCount/SampleCount)<=max_exc_pct_id]="IDNE"
			})
		}
	}

return(data)

}


library(pROC)
library(cowplot)

# load gene signature  ---------------------------------------------------------
gene.sig = toupper(fread(file.path(PROJECT_DIR, "generated_data/signatures/CD38_ge_sig.txt"), header=F)[[1]])

box.df = data.frame()
roc.df = data.frame()
df.text = data.frame()

for (year in as.character(c(2008:2011)) ) {
  if(year=="2008") {
    study = "GSE29619"
    load(sprintf(file.path(PROJECT_DIR, "data/Emory/%s.RData"), study,study))
    si = info$year == year & !is.na(info$Subject.ID) & info$time.point=="D0"
  } else {
    study = "GSE74817"
    load(sprintf(file.path(PROJECT_DIR, "data/Emory/%s_healthy.RData"), study,study))
    si = info$year == year & !is.na(info$Subject.ID) & info$time.point=="D0" & info$AGE<=60
  }

# load data
ihl = info$fc.adj.d30[si] %in% c(0,2)
isig = toupper(rownames(dat)) %in% gene.sig
cat(year, sum(isig), "genes\n")
Y = info$fc.adj.d30[si][ihl]
X = dat[isig,si]
if(sum(isig)>1) {
  X = t(scale(t(X)))
  X = colMeans(X)[ihl]
}
w.pv = wilcox.test(X[Y==2], X[Y==0], exact=F, alternative="greater")$p.value

r = roc(Y,X, direction="<", quiet = T)
N_perm = 1000
set.seed(123)
r.null = vector("numeric", N_perm)
for(i in 1:N_perm) {
  r.null[i] = roc(Y, sample(X), direction="<", quiet = T)$auc
}
r.p = sum(r.null > r$auc) / N_perm

r.df = data.frame(Specificity = r$specificities, Sensitivity=r$sensitivities, auc=as.numeric(r$auc), Year=year) %>%
  arrange(Sensitivity, Specificity)
roc.df = rbind(roc.df, r.df)

df.text = rbind(df.text,
                data.frame(Study = study, Year=year, label.wpv = sprintf("p = %.2f", w.pv),
                           label.auc=sprintf("AUC = %.2f\np = %.2g", r$auc, r.p)))
b.df = data.frame(score=X, Response=Y, Year=year)
box.df = rbind(box.df, b.df)
}

df = box.df %>%
  mutate(Response = factor(ifelse(Response==0, "low","high"), levels=c("low","high")))

source(file.path(PROJECT_DIR, "R/functions/gg_color_hue.r"))
cm = gg_color_hue(4)
p1 = ggplot(df, aes(Response, score, fill=Year)) + geom_boxplot() +
  geom_dotplot(binaxis = "y", stackdir = "center", aes(fill=Response)) +
  scale_fill_manual(values=c(cm, "black","white")) +
  facet_wrap(~Year, nrow=1) +
  geom_text(data=df.text, aes(label=label.wpv), x=-Inf, y=Inf, col="black", hjust = -0.3, vjust = 1.5) +
  ylab("Relative TGSig score") +
  theme_bw() +
  theme(legend.position="none",
        panel.border = element_blank(), strip.background = element_blank(),
        strip.text.x = element_text(size=12),
        panel.spacing = unit(0,"mm"), panel.grid.major.x = element_blank(),
        axis.ticks = element_blank())
p2 = list()
for(year in levels(df.text$Year)) {
  p2[[year]] = ggplot(roc.df %>% dplyr::filter(Year==year), aes(x=Specificity, y=Sensitivity)) +
    geom_line(size=1) +
    geom_abline(intercept = 1, slope = 1, lty=2) +
    scale_x_reverse() +
    geom_text(data=df.text %>% dplyr::filter(Year==year), aes(label=label.auc), x=Inf, y=-Inf, hjust=1.1, vjust=-0.1) +
    coord_fixed() +
    theme_bw() + theme(panel.grid = element_blank())
}

bottom_row <- do.call("plot_grid", c(p2, align = "h", nrow=1))
plot_grid(p1, bottom_row, ncol=1, rel_heights = c(2, 1))

fn.fig = file.path(PROJECT_DIR, "figure_generation/Emory_CD38.10gene.sig_vs_response_4yrs")
ggsave(paste0(fn.fig, ".png"), w=7, h=6)
ggsave(paste0(fn.fig, ".pdf"), w=7, h=6, useDingbats=F)


#' Predicts transcription factors driving differential gene expression based on a list of
#' differentially expressed genes
#'
#' @param gene_ids vector of Entrez Gene IDs of differentially expressed genes
#' @param species three-letter species ID (currently, function works only with human genes ('hsa'))
#'
#' @return data frame with transcription factors ranked according to their probability scores
#'
#' @examples
#' tfpred(c(5714, 135114, 26958, 5899, 494514, 26502, 388325, 79007, 4688, 1428, 259307))
#'
#' @import glmnet
#'
#' @export
tfpred <- function(gene_ids, species = 'hsa'){

  #Checks the input data
  gene_ids <- unlist(gene_ids)
  gene_ids <- unique(gene_ids)
  if (!is.null(dim(gene_ids))) stop('The list of gene IDs should be flat')
  if (length(gene_ids) < 10) stop('The list of genes is too short')
  gene_ids <- as.integer(gene_ids)
  if (any(is.na(gene_ids))) stop("'gene_ids' should be a list of numeric Entrez IDs")
  if (species!='hsa') stop("Only 'hsa' option is currently supported.")

  # Used data
  # pathways_hsa - table of pathways attributed to human genes
  # go_hsa - table of GO terms attributed to human genes
  # tf_names - list of TFs
  # lr_model - logistic regression model

  if (nrow(pathways_hsa[pathways_hsa$gene_id %in% gene_ids,]) < 10) {
    stop ("Too few or none of provided gene IDs were found in the database.")
  }

  # Data frame to store results
  full_data_df <- data.frame(TF = character(),
                             TF_id = character(),
                             p_share = double(),
                             p_all = double(),
                             p_score = double(),
                             go_share = double(),
                             go_all = double(),
                             go_score = double())

  max_pw_count = max(table(pathways_hsa$pathway))
  max_go_count = max(table(go_hsa$GO_term))

  for (i in seq_len(nrow(tf_names))){
    tf_id <- tf_names[[i, 'index']]
    tf_name <- tf_names[[i, 'gene']]

    # Get unique pathways and terms related to the TF and their counts
    tf_ptws <- pathways_hsa[pathways_hsa$gene_id==tf_id,]$pathway
    tf_terms <- go_hsa[go_hsa$gene_id==tf_id,]$GO_term
    tf_pw_count <- table(tf_ptws)
    tf_term_count <- table(tf_terms)
    p_all <- length(tf_pw_count)
    go_all <- length(tf_term_count)

    # Get pathways and terms related to differentially expressed genes
    case_ptws <- pathways_hsa[pathways_hsa$gene_id %in% gene_ids,]$pathway
    case_terms <- go_hsa[go_hsa$gene_id %in% gene_ids,]$GO_term

    # Calculate relative pathway/GO term importance
    pw_df <- as.data.frame(table(case_ptws))
    pw_df['importance'] <- sapply(pw_df$Freq, function(f) dbeta(f/max_pw_count, 2, 2) )
    go_df <- as.data.frame(table(case_terms))
    go_df['importance'] <- sapply(go_df$Freq, function(f) dbeta(f/max_go_count, 2, 2) )

    # Keep only common pathways and terms
    pw_df <- pw_df[pw_df$case_ptws %in% tf_ptws,]
    go_df <- go_df[go_df$case_terms %in% tf_terms,]

    # Calculate relative pathway/term overlap and scores based on 'importance'
    p_common <- go_common <- p_score <- go_score <- p_share <- go_share <- 0.0
    if (p_all > 0 & nrow(pw_df) > 0) {
      p_common <- length(pw_df$case_ptws[pw_df$case_ptws %in% names(tf_pw_count)])
      p_score <- sum(sapply(seq_len(nrow(pw_df)), function(f)  100 * pw_df$importance[f] * pw_df$Freq[f] / length(gene_ids)))
      p_share <- p_common/p_all
    }

    if (go_all > 0 & nrow(go_df) > 0) {
      go_common <- length(go_df$case_terms[go_df$case_terms %in% names(tf_term_count)])
      go_score <- sum(sapply(seq_len(nrow(go_df)), function(f) 100 * go_df$importance[f] * go_df$Freq[f] / length(gene_ids)))
      go_share <- go_common/go_all
    }

    full_data_df <- rbind(full_data_df,
                          data.frame(TF = as.character(tf_name),
                                     TF_id = as.character(tf_id),
                                     p_share = as.double(p_share),
                                     p_all = as.double(p_all),
                                     p_score = as.double(p_score),
                                     go_share = as.double(go_share),
                                     go_all = as.double(go_all),
                                     go_score = as.double(go_score)),
                          stringsAsFactors=FALSE)
  }

  # Check whether there are enough pathways/terms associated with each TF
  full_data_df <- full_data_df[full_data_df$p_all>2,]
  full_data_df <- full_data_df[full_data_df$go_all>2,]

  # Predictions of Logistic Regression model
  lr_pred <- predict(lr_model,
                     as.matrix(full_data_df[, c('p_share',
                                                'p_score',
                                                'go_share',
                                                'go_score')]),
                     type="response")
  full_data_df$LR_prob <- as.vector(lr_pred)

  # Preparing results
  full_data_df <- full_data_df[,c('TF', 'TF_id', 'LR_prob')]
  full_data_df <- full_data_df[!full_data_df$TF_id %in% gene_ids,]
  full_data_df <- full_data_df[order(full_data_df$LR_prob, decreasing = TRUE),]
  rownames(full_data_df) <- 1:nrow(full_data_df)

  full_data_df
}


# land use maps

require(rgeos)
require(rgdal)
require(raster)
require(dplyr)
require(tidyr)
library(ggplot2)

# Location of input data
setwd( 'P:/is-wel/indus/message_indus' )

# Local location of indus ix model - MAKE SURE TO ADD TO SYSTEM ENVIRONMENT VARIABLES
indus_ix_path = Sys.getenv("INDUS_IX_PATH")

# Basin analyzed
basin = 'Indus'

#path with yield data, from GAEZ
maps_path = paste0(getwd(),'/input/land_maps_crop_yields')

#basin shape file
basin.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), paste( basin, 'bcu', sep = '_' ), verbose = FALSE )

#little function to crop raster with basin extent, and assign pids
assign_pid_to_raster = function(input.rs){
  input_cropped.rs = crop( input.rs, basin.spdf )
  input_cropped.sp = rasterToPoints(input_cropped.rs, spatial = T)

  input_cropped.sp = spTransform(input_cropped.sp, crs(  basin.spdf ) )
  names(input_cropped.sp) = 'value'
  input_cropped.sp$node = as.character(over(input_cropped.sp , basin.spdf)[,'PID'] )
  input_cropped.sp = input_cropped.sp[!is.na(input_cropped.sp$node),]
  return(input_cropped.sp)
}

# some data should be raster and go to CWaTM
# for MESSAGE model we need to aggregate into catchments:
# - historical harvested area of crops >> becomes installed capacity
# - land availability for rain-fed and irrigated crops
map_cwatm_msg <- data.frame(cwatm = c('forest','grassland', 'irr_rice','non_irr_rice',
                                      'non_irr_rice', 'non_irr_rice', 'non_irr_rice',
                                      'non_irr_rice', 'built_up_land', 'water_bodies'),
                            msg = c('non_crop', 'non_crop', 'rice', 'wheat', 'cotton',
                                    'fodder', 'sugarcane', 'pulses', 'non_crop', 'non_crop') )

# land use maps as % of used land for different purposes
land_maps_names = c('forest','grassland','built_up_land', 'water_bodies', 'all_cultivated')

for (ii in seq_along(land_maps_names)){
  print(paste0(land_maps_names[ii ] ))
  land_folder = list.dirs(path = maps_path)
  land_folder = land_folder[ grep( paste0( land_maps_names[ii]), land_folder)]
  land_file = list.files(path = land_folder,pattern = '.tif')

  tmp_land.rs = raster(paste0(land_folder,'/', land_file) )/100

  assign(paste0('land_use_',land_maps_names[ii],'.rs'),tmp_land.rs)
}
# for MESSAGE # land availability = land_use_all_cultivated * area [km2]
area_cultivated.rs = area(land_use_all_cultivated.rs) # km2
land_av_agriculture.rs = area_cultivated.rs * land_use_all_cultivated.rs
land_av_agriculture.sp = assign_pid_to_raster(land_av_agriculture.rs)
land_av_agriculture.df = land_av_agriculture.sp@data %>%
  group_by(node) %>%
  summarise(value = sum(value)/10^4) %>%  #from km2 to Mha
  mutate(units = 'Mha')

# crop use maps in terms of 1000 ha per pixel (in year 2000)
crop_names = c('wheat','rice','cotton','fodder','sugarcane','pulses','maize','fruit','vegetables')
irr_land.df = NULL
for (ii in seq_along(crop_names)){
  print(paste0(crop_names[ii ] ))
  crop_land_folder = list.dirs(path = maps_path)
  crop_land_folder = (crop_land_folder[ grep( paste0( crop_names[ii]), crop_land_folder)])[1]
  crop_land_file = list.files(path = crop_land_folder,pattern = '.tif')

  # 1000 ha
  tmp_land.rs = raster(paste0(crop_land_folder,'/',crop_land_file) ) * 1000 #makes it in ha

  # for CWaTM
  assign(paste0('land_ha_',crop_names[ii],'.rs'),tmp_land.rs)

  #process for MESSAGE,
  # historical capacity: crop to basin catchments and aggregate potential in Mha
  tmp_land.sp = assign_pid_to_raster(tmp_land.rs)
  tmp_land.df = tmp_land.sp@data %>%
    group_by(node) %>%
    summarise(value = sum(value )/10^6) %>%
    mutate(crop = crop_names[ii]) %>%
    mutate(par = 'crop_irr_land_2000') %>%
    mutate(unit = 'Mha') %>%
    mutate(time = 'year') %>%
    select(crop,par,node,time,unit,value)

  irr_land.df = bind_rows(irr_land.df,tmp_land.df)
}
#rainfed land
rainfed_land.df = NULL
for (ii in seq_along(crop_names)){
  print(paste0(crop_names[ii ] ))
  crop_land_folder = list.dirs(path = maps_path)
  crop_land_folder = (crop_land_folder[ grepl( paste0( '_r_', crop_names[ii]), crop_land_folder)])[1]
  crop_land_file = list.files(path = crop_land_folder,pattern = '.tif')

  # 1000 ha
  tmp_land.rs = raster(paste0(crop_land_folder,'/',crop_land_file) ) * 1000 #makes it in ha

  # for CWaTM
  assign(paste0('land_ha_',crop_names[ii],'.rs'),tmp_land.rs)

  #process for MESSAGE,
  # historical capacity: crop to basin catchments and aggregate potential in Mha
  tmp_land.sp = assign_pid_to_raster(tmp_land.rs)
  tmp_land.df = tmp_land.sp@data %>%
    group_by(node) %>%
    summarise(value = sum(value )/10^6) %>%
    mutate(crop = crop_names[ii]) %>%
    mutate(par = 'crop_rainfed_land_2000') %>%
    mutate(unit = 'Mha') %>%
    mutate(time = 'year') %>%
    select(crop,par,node,time,unit,value)

  rainfed_land.df = bind_rows(rainfed_land.df,tmp_land.df)
}

# check sum or irr area for different crops vs total area for agriculture
check_area = bind_rows(irr_land.df,rainfed_land.df) %>%
  group_by(node,par) %>% summarise(value = sum(value)) %>% ungroup() %>%
  tidyr::spread(par,value) %>%
  left_join(land_av_agriculture.df %>% select(-units) %>%
              rename( tot_land_av = value)) %>%
  mutate(diff = (tot_land_av - (crop_rainfed_land_2000 + crop_irr_land_2000)  )/tot_land_av *100 ) %>%
  mutate(tot_crop_area = crop_rainfed_land_2000 + crop_irr_land_2000) %>%
  select(node,diff,everything())
# for four nodes the sum of irrigated land is higher than total land available
# the max difference is 16% in PAK_5
ggplot(check_area %>%
         tidyr::gather('type','value',3:6))+
  geom_point(aes(x = node, y = value, color = type))+
  theme_bw()

check_rain_irr_ratio = check_area %>% select(node,crop_irr_land_2000,crop_rainfed_land_2000) %>%
  mutate(ratio = crop_irr_land_2000/crop_rainfed_land_2000,
         perc_on_tot = crop_rainfed_land_2000/(crop_irr_land_2000 + crop_rainfed_land_2000)*100)

national_trend.path = path.expand(paste0(maps_path,'/FAO_hist_national_prod'))
nat_trend.files = list.files(path = national_trend.path,pattern = '.csv')

#calculate the multiplication factor for 2015, China data just remain unchanged as in 2000
# from FAO national harvested area 1990-2015 trends, used as multiplication factors for the spatial harvested area in 2000
# this gives the historical capacity of crop technologies in 2015
perc_inc2015 = NULL
for (jj in seq_along(nat_trend.files)){

  tmp_national = read.csv(paste0(national_trend.path,'/',nat_trend.files[jj])) %>%
    filter(Unit == 'ha', Year %in% c(2000,2015) ) %>%
#    mutate(Value = Value * 1E-6, Unit = 'Mha') %>% # Mha
    group_by(Area,Item) %>%
#    mutate(mult = (lm(Value ~ Year)$coefficients[[2]]) ) %>%
    mutate(Year = paste0('v',Year)) %>%
    select(Area,Item,Year,Unit,Value) %>%
    spread(Year,Value) %>%
    mutate(perc_inc = (v2015-v2000)/v2000) %>%
    select(Area,Item,Unit,perc_inc)
  # we want only mult at the end
  perc_inc2015 = bind_rows(perc_inc2015,tmp_national)
}

perc_inc2015[ perc_inc2015$Area == 'Pakistan' & perc_inc2015$Item == 'Oranges',]$Item = 'Fruit, citrus nes'
veg_to_aggregate = perc_inc2015 %>%
  filter(Item %in% c('Onions, dry', 'Potatoes')) %>%
  group_by(Area,Unit) %>% summarise(perc_inc = mean(perc_inc)) %>% ungroup() %>%
  mutate(Item = 'vegetables') %>% select(Area,Item,Unit,perc_inc)

perc_inc2015 = perc_inc2015 %>%
  filter(!Item %in% c('Onions, dry', 'Potatoes')) %>%
  bind_rows(veg_to_aggregate)

crop_item_map = data.frame(Item = unique(perc_inc2015$Item),
                           crop = c('cotton', 'pulses', 'rice','sugarcane','wheat','fodder','maize','fruit','vegetables' ) )
country_map = data.frame(Area = unique(perc_inc2015$Area),
                         node2 = c('AFG', 'IND', 'PAK') )

perc_inc2015 = perc_inc2015 %>% left_join(crop_item_map) %>%
  left_join(country_map) %>% ungroup() %>%
  select(node2,crop,perc_inc) %>% unique() %>%
  bind_rows(expand.grid(node2 = 'CHN',crop = crop_names, perc_inc = 0) )

out_df = bind_rows(irr_land.df,rainfed_land.df) %>%
  mutate(node2 = gsub('_.*','',node) ) %>%
  left_join(perc_inc2015) %>%
  mutate(value = if_else(value == 0,0 ,value + (value* perc_inc)) ) %>%
  mutate(par = if_else(grepl('2000',par), gsub('2000','2015',par), par)) %>%
  select(crop,par,node,time,unit,value)

# check after 2015 upscaling
check_area2 = out_df %>%
  group_by(node,par) %>% summarise(value = sum(value)) %>% ungroup() %>%
  tidyr::spread(par,value) %>%
  left_join(land_av_agriculture.df %>% select(-units) %>%
              rename( tot_land_av = value)) %>%
  mutate(diff = (tot_land_av - (crop_rainfed_land_2015 + crop_irr_land_2015)  )/tot_land_av *100 ) %>%
  mutate(tot_crop_area = crop_rainfed_land_2015 + crop_irr_land_2015) %>%
  select(node,diff,everything())

#write available land for agriculture, use tot available land 2000 when it is greater than the sum of rainfed+irr land in 2015
# otherwise use rainfed + irr land 2015
land_av_agriculture.df = check_area2 %>%
  group_by(node) %>%
  mutate(value = max(tot_land_av,tot_crop_area),
         units = 'Mha') %>% ungroup() %>%
  select(node,value,units)

write.csv(land_av_agriculture.df, paste0(getwd(),'/input/land_availability_map.csv'), row.names = F  )

existing_csv = read.csv(paste0(getwd(), '/input/crop_input_data.csv')) %>%
  filter(unit != 'Mha')
to_csv = bind_rows(existing_csv, out_df)
write.csv(to_csv, paste0(getwd(), '/input/crop_input_data.csv'), row.names = F )

## FOR CWATM
# km2 = 100 ha
area_rice.rs = area(land_ha_rice.rs) * 100
b = values(area_rice.rs)
hist(b)

# for CWaTM we need % of land with paddy and non paddy
# percentage of land avalable for rice in each pixel
# where land_rice is not define, we get Na, should reconvested to 0
perc_rice.rs = land_ha_rice.rs / (area_rice.rs)
perc_rice.rs[is.na(perc_rice.rs)] = 0
c = values(perc_rice.rs)
c = c[c != 0]
hist(c)
max(c) # should be lower than 1, when cropping to basin is <1 but if we want to use global maps is not good
plot(perc_rice.rs)

#chekc sumof other crops for CWatm, it should not exceed 1
sum_other_crops.rs = land_ha_cotton.rs + land_ha_fodder.rs + land_ha_pulses.rs + land_ha_sugarcane.rs + land_ha_wheat.rs
perc_other.rs = sum_other_crops.rs / (area_rice.rs)
perc_other.rs[is.na(perc_other.rs)] = 0
d = values(perc_other.rs)
d = d[d != 0]
hist(d)
max(d)

# perc_rice.rs = crop( perc_rice.rs, basin.spdf )
#
# perc_other.rs = crop( perc_other.rs, basin.spdf )

perc_rice.rs = crop( perc_rice.rs, basin.spdf )


## run this script to calculate QC metrics
## first it excludes samples with really low intensities values
## requires gdsfile to already be generated and sample sheet to be loaded
##

setwd(dataDir)
library(e1071)

gfile<-openfn.gds(gdsFile, readonly = FALSE, allow.fork = TRUE)

## see if any QC data already exists
if(file.exists(qcData)){
	load(qcData)
	## check contains all required samples
	if(nrow(QCmetrics) == nrow(sampleSheet)){
		print("QC file loaded")
	} else {
		QCmetrics<-sampleSheet
	}
} else{
	QCmetrics<-sampleSheet
}

#QCmetrics$Age<-as.numeric(as.character(QCmetrics$Age))

## extract a few useful matrices
rawbetas<-betas(gfile)[,]

# calculate median M & U intensity
if(!"M.median" %in% colnames(QCmetrics)){

	m_intensities<-methylated(gfile)
	u_intensities<-unmethylated(gfile)
	M.median<-unlist(apply.gdsn(m_intensities, 2, median))
	U.median<-unlist(apply.gdsn(u_intensities, 2, median))
	#M.quant<-matrix(unlist(apply.gdsn(m_intensities, 2, quantile)), ncol = 5, byrow = TRUE)
	#U.quant<-matrix(unlist(apply.gdsn(u_intensities, 2, quantile)), ncol = 5, byrow = TRUE)
	#M.skew<-unlist(apply.gdsn(m_intensities, 2, skewness))
	#U.skew<-unlist(apply.gdsn(u_intensities, 2, skewness))
	#M.sigma<-unlist(apply.gdsn(m_intensities, 2, sd))
	#U.sigma<-unlist(apply.gdsn(u_intensities, 2, sd))
	intens.ratio<-M.median/U.median
	## exclude really poor intensity samples from beginning so rest of QC is not dominated by them
	intensPASS<-M.median > 500
	## exclude fully methylated control samples
	intensPASS[which(intens.ratio > 4)]<-FALSE
	QCmetrics<-cbind(QCmetrics,M.median, U.median, intens.ratio, intensPASS)

}

# calculate bisulfite conversion statistic
if(!"bisulfCon" %in% colnames(QCmetrics)){
	bisulfCon<-bscon(gfile)
	bisulfCon[which(intensPASS == FALSE)]<-NA
	QCmetrics<-cbind(QCmetrics,bisulfCon)
}

## PCA of control-probe intensities
if(!"PC1_cp" %in% colnames(QCmetrics)){
	## exclude really poor intensity samples
	qc.meth<-QCmethylated(gfile)[,QCmetrics$intensPASS]
	qc.unmeth<-QCunmethylated(gfile)[,QCmetrics$intensPASS]
	# remove negative controls
	qc.meth<-qc.meth[grep("Negative", rownames(qc.meth), invert=TRUE),]
	qc.unmeth<-qc.unmeth[grep("Negative", rownames(qc.unmeth), invert=TRUE),]
	ctrl.all<-t(rbind(qc.meth, qc.unmeth))

	## exclude columns where all NAs
	ctrl.all<-ctrl.all[,which(colSums(is.na(ctrl.all)) < nrow(ctrl.all))]

	pca <- prcomp(na.omit(ctrl.all))
	ctrlprobes.scores = pca$x
	colnames(ctrlprobes.scores) = paste(colnames(ctrlprobes.scores), '_cp', sep='')
	ctrl.pca<-pca$sdev^2/sum(pca$sdev^2)
	ctrlprobes.scores<-ctrlprobes.scores[match(QCmetrics$Basename, QCmetrics$Basename[QCmetrics$intensPASS]),]
	rownames(ctrlprobes.scores)<-QCmetrics$Basename
	## only save PCs which explain > 1% of the variance
	QCmetrics<-cbind(QCmetrics,ctrlprobes.scores[,which(ctrl.pca > 0.01)])
}

## perform PCA on beta values
if(!"PC1_betas" %in% colnames(QCmetrics)){
	## filter to autosomal only
	auto.probes<-which(fData(gfile)$chr != "chrX" & fData(gfile)$chr != "chrY")

	pca <- prcomp(t(na.omit(rawbetas[auto.probes,QCmetrics$intensPASS])))
	betas.scores = pca$x
	colnames(betas.scores) = paste(colnames(betas.scores), '_betas', sep='')
	betas.pca<-pca$sdev^2/sum(pca$sdev^2)
	betas.scores<-betas.scores[match(QCmetrics$Basename, QCmetrics$Basename[QCmetrics$intensPASS]),]
	rownames(betas.scores)<-QCmetrics$Basename
	## only save PCs which explain > 1% of the variance
	QCmetrics<-cbind(QCmetrics,betas.scores[,which(betas.pca > 0.01)])

}

## Identify outlier samples
## excluded as comparable to PC filtering already included
#if(!"iqr" %in% colnames(QCmetrics)){
	#outlierDetect<- outlyx(rawbetas, plot = FALSE)
	#QCmetrics<-cbind(QCmetrics,outlierDetect)
#}

## detection p value filtering at this stage only interested in sample filtering, will repeat later for probe filtering
if(!"pFilter" %in% colnames(QCmetrics)){

	pFOut<-pfilter.gds(gfile, pn = pvals(gfile), bc = index.gdsn(gfile, "NBeads"))
	pFOut[!QCmetrics$intensPASS]<-NA
	QCmetrics<-cbind(QCmetrics,"pFilter"= pFOut$samples)
}

## calc Horvaths epigenetic age
if(!"DNAmAge" %in% colnames(QCmetrics)){
	data(coef)
	DNAmAge<-agep(gfile, coef=coef)
	DNAmAge[!QCmetrics$intensPASS]<-NA
	QCmetrics<-cbind(QCmetrics,DNAmAge)
}

## calc Cortical Clock Age
if(!"CCDNAmAge" %in% colnames(QCmetrics)){
	CC_coef<-read.csv(paste0(refFiles, "/CortexClock/CorticalClockCoefficients.csv"), stringsAsFactors = FALSE)
	anti.trafo= function(x,adult.age=20) { ifelse(x<0, (1+adult.age)*exp(x)-1, (1+adult.age)*x+adult.age) }
	CCDNAmAge<-	anti.trafo(as.numeric(CC_coef[1,2] + t(rawbetas[CC_coef[-1,1],])  %*% CC_coef[-1,2]))
	CCDNAmAge[!QCmetrics$intensPASS]<-NA
	QCmetrics<-cbind(QCmetrics,CCDNAmAge)
}

## check sex
# idenitfy X chromosome probes
if(!"predSex" %in% colnames(QCmetrics)){
	x.probes<-which(fData(gfile)$chr == "chrX")
	y.probes<-which(fData(gfile)$chr == "chrY")
	ints.auto<-methylated(gfile)[c(x.probes, y.probes),]+unmethylated(gfile)[c(x.probes, y.probes),]
	ints.X<-methylated(gfile)[x.probes,]+unmethylated(gfile)[x.probes,]
	ints.Y<-methylated(gfile)[y.probes,]+unmethylated(gfile)[y.probes,]

	x.cp<-colMeans(ints.X, na.rm = TRUE)/colMeans(ints.auto, na.rm = TRUE)
	y.cp<-colMeans(ints.Y, na.rm = TRUE)/colMeans(ints.auto, na.rm = TRUE)

	## base prediction on y chromosome
	predSex.y<-rep(NA, length(y.cp))
	predSex.y[which(y.cp > 1 & intensPASS == TRUE)]<-"M"
	predSex.y[which(y.cp < 1 & intensPASS == TRUE)]<-"F"

	## base prediction on x chromosome
	predSex.x<-rep(NA, length(x.cp))
	predSex.x[which(x.cp < 1 & intensPASS == TRUE)]<-"M"
	predSex.x[which(x.cp > 1 & intensPASS == TRUE)]<-"F"

	## check for consistent prediction
	predSex<-rep(NA, length(x.cp))
	predSex[which(predSex.x == predSex.y)]<-predSex.x[which(predSex.x == predSex.y)]
	QCmetrics<-cbind(QCmetrics,x.cp,y.cp,predSex.x, predSex.y, predSex)
}

## check duplicate samples using SNPs on array
if(!exists("snpCor")){
	rsbetas<-rawbetas[grep("rs", rownames(rawbetas)),]
	snpCor<-cor(rsbetas, use = "pairwise.complete.obs")
}

## compare to SNP data

if(!"genoCheck"%in% colnames(QCmetrics) & !is.null(genoFile)){
	geno<-read.table(genoFile, stringsAsFactors = FALSE, header = TRUE)
	geno.all<-geno
	geno<-geno[match(gsub("-", "_", QCmetrics$Indidivual.ID), geno$IID),]
	rsIDs<-gsub("_.", "", colnames(geno)[-c(1:6)])
	betas.rs<-rawbetas[rsIDs,]

	### first check direction of minor alleles
	cors<-vector(length = length(rsIDs))
	for(i in 1:length(rsIDs)){
		cors[i]<-cor(geno[,i+6], betas.rs[i,], use = "pairwise.complete.obs")
	}
	### change minor allele in genotype data if negative correlation
	for(each in which(cors < 0)){
		geno[,each+6]<-(2-geno[,each+6])
		geno.all[,each+6]<-(2-geno.all[,each+6])
	}
	geno.mat<-as.matrix(geno[,-c(1:6)])
	geno.all.mat<-as.matrix(geno.all[,-c(1:6)])
	rownames(geno.all.mat)<-geno.all$IID

	genoCheck<-rep(NA, nrow(QCmetrics))
	for(i in 1:ncol(betas.rs)){
		if(!is.na(geno[i,1]) & intensPASS[i] == TRUE){
			genoCheck[i]<-cor(geno.mat[i,], betas.rs[,i], use = "pairwise.complete.obs")
		}
	}

	## if any incongruent perform search for best using all geno data
	## first though check if any geno combinations present multiple times in this cohort:
	## count how many individuals with each geno combination in sample
	indGenoCombo<-apply(geno.all.mat, 1, paste, collapse = ";")
	tabGeneticInd<-table(indGenoCombo)
	#table(tabGeneticInd)

	## pull out list of samples which identical genotypes across these variants
	dupCombos<-names(tabGeneticInd[which(tabGeneticInd > 1)])
	if(length(dupCombos) > 0){
		dupIDs<-NULL
		for(each in dupCombos){
			dupIDs<-c(dupIDs, paste(rownames(geno.all.mat)[which(indGenoCombo == each)], collapse = ";"))
		}
		write.csv(dupIDs, paste0(qcOutFolder,"/IndividualsWithIdenticlaGenotypeCombinationsInComparisionWithSNPData.csv"))
	}

	genoMatch<-rep(NA, nrow(QCmetrics))
	genoMatchVal<-rep(NA, nrow(QCmetrics))
	for(i in 1:ncol(betas.rs)){
		if(intensPASS[i] == TRUE){
			corVals<-rep(NA, nrow(geno.all.mat))
			for(j in 1:nrow(geno.all.mat)){
				corVals[j]<-cor(geno.all.mat[j,], betas.rs[,i], use = "pairwise.complete.obs")
				}
			}
		if(max(corVals, na.rm = TRUE) > 0.9){ ## NB threshold to say
			## as possible to match multipe, save all
			genoMatch[i]<-paste(rownames(geno.all.mat)[which(corVals > 0.9)], collapse = ";")
			genoMatchVal[i]<-paste(corVals[which(corVals > 0.9)], collapse = ";")
		}
	}
	QCmetrics<-cbind(QCmetrics,genoCheck, genoMatch, genoMatchVal)
}

# check effect of normalisation
if(!"rmsd" %in% colnames(QCmetrics)){
	dasen(gfile, node="normbeta")
	normbetas<-index.gdsn(gfile, "normbeta")[,]
	qualDat<-qual(rawbetas, normbetas)
	qualDat[which(intensPASS == FALSE),]<-NA
	QCmetrics<-cbind(QCmetrics,qualDat)
}

## need to close gds file in order to open in another R session
closefn.gds(gfile)

# save QC metrics and SNP correlations to generate QC report
if(!is.null(genoFile)){
	save(QCmetrics, snpCor, betas.pca, ctrl.pca, pFOut, geno.mat, file = qcData)
} else {
	save(QCmetrics, snpCor, betas.pca, ctrl.pca, pFOut, file = qcData)
}


exposureMaxItems = as.numeric(settings$exposureMaxItems)
exposureLimit = as.numeric(settings$exposureLimit)
exposureMinSessions = as.numeric(settings$exposureMinSessions)

concerto.log(exposureMaxItems, "exposure max items")

if(is.na(exposureMaxItems) || exposureMaxItems == 0) {
  return()
}

if(!is.list(session) || is.null(session$id)) {
  concerto.log("session is required for item exposure")
  return()
}

responseTable = fromJSON(settings$responseBank)
if(!is.character(responseTable$table) || nchar(responseTable$table) == 0) {
  concerto.log("no response bank defined, skipping exposure")
  return()
}

responsesRecords = concerto.table.query("
SELECT id,
{{itemIdCol}} AS item_id
FROM {{table}}
WHERE {{sessionIdCol}}={{sessionId}}", params=list(
  itemIdCol = responseTable$columns$item_id,
  table = responseTable$table,
  sessionIdCol = responseTable$columns$session_id,
  sessionId = session$id
))

itemsAnswered = items[items[,"id"] %in% responsesRecords[,"item_id"],]
itemsAnsweredNum = dim(itemsAnswered)[1]
itemsLeft = items
if(itemsAnsweredNum > 0) {
  itemsLeft = items[-as.numeric(rownames(itemsAnswered)),]
}
itemsLeftNum = dim(itemsLeft)[1]

if(itemsLeftNum == 0) {
  return()
}

sessionNum = concerto.table.query("
SELECT COUNT(DISTINCT session_id) AS sessionNum
FROM {{table}}", params=list(
  table = responseTable$table
))[1,1]

if(sessionNum == 0 || exposureMinSessions > sessionNum) {
  concerto.log(sessionNum, "session number to low for item exposure")
  return()
}

exposureCount = concerto.table.query("
SELECT COUNT(*) AS sessionNum,
{{itemIdCol}} AS item_id
FROM {{table}}
WHERE {{itemIdCol}} IN ({{itemsLeftIds}})
GROUP BY {{itemIdCol}}", params=list(
  itemIdCol = responseTable$columns$item_id,
  table = responseTable$table,
  itemsLeftIds=paste(itemsLeft[,"id"], collapse=",")
))

excludedIndices = c()
for(i in 1:itemsLeftNum) {
  itemIndex = itemsAnsweredNum + i
  exposure = exposureCount[i, "sessionNum"] / sessionNum

  if(exposure >= exposureLimit) {
    excludedIndices = c(excludedIndices, itemIndex)
  }

  if(length(excludedIndices) >= exposureMaxItems) {
    break
  }
}

concerto.log(excludedIndices, "excluded item indices by item exposure")
if(length(excludedIndices) > 0) {
  items = items[-excludedIndices,]
  paramBank = paramBank[-excludedIndices,]
}


nox<-2; noy<-3;
paper<-F        # graphics on paper=file (TRUE) or on screen (FALSE)

by_quarter<-TRUE

run.ID<-'retro-N'         # file id used for paper output
cleanup()

first.year.on.plot<-1974
last.year.on.plot<-2016

doGrid<-T
incl.sp<-c("N.horse mac","W.horse mac","G. gurnards","R.radiata")                      # species to be included. Name(s) or "all"
#incl.sp<-"all"

first.pch<-1    # first pch symbol
first.color<-1   # first color

palette("default")                # good for clolorfull plots
#palette(gray(seq(0,.9,len=6)))  # gray scale for papers, use len =500 to get black only

if (F) {    # sometimes the dir and labels are defined outside this script !

  dirs<-c("baltic-2012-keyRun-WGSAM2012","baltic-2012-keyRun-updated")
  labels<-c("Key run 2012","Updated")

  dirs<-c("bal-1-area-run-01-final","baltic-2012-keyRun-updated","bal-4-areas-run-01-final","baltic-2012-keyRun-4-areas")
  dirs<-c("bal-1-area-final - afterMeeting","baltic-2012-keyRun-updated","bal-4-areas-run-01-final","baltic-2012-keyRun-4-areas")
  labels<-c("WKmultbal","Key run 2012 updated","4 areas 2011","4 areas 2012")

  dirs<-c("baltic-2012-keyRun-updated","baltic-2012-keyRun-4-areas")
  labels<-c("Key run 2012 updated","4 areas 2012")

  dirs<-c("NS_key-2014-ver17","NS_key-2017-ver02")
  labels<-c("2014-run", "2017-run")

}

for (dir in dirs) {
  if ( file.access(file.path(root,dir,"sms.dat"), mode = 0)!=0)  stop(paste('Directory',dir,'does not exist'))
}

Init.function() # get SMS.contol object  including sp.names

plotN<-function (q=1){
  for (dir in dirs) {
    Init.function(dir=file.path(root,dir)) # get SMS.contol object  including sp.names

     a<-Read.summary.data(dir=file.path(root,dir),read.init.function=F)
     a<-subset(a,(Year>=first.year.on.plot & Year<=last.year.on.plot & Quarter==q & Age<=6),
               select=c(Species, Year,Age,N))
     M2<-data.frame(scen=labels[which(dirs==dir)],vari='N',a)
     names(M2)<-c("scenario","Variable","Species","Year","Age","Value")
   if (dir==dirs[1]) all<-rbind(M2) else all<-rbind(all,M2)
  }
  values<-tapply(all$Value,list(all$Year,all$scenario,all$Species,all$Variable,all$Age),sum)
  values<-values/1000
  y<-as.numeric(dimnames(values)[[1]])

  if (paper) dev<-"wmf" else dev<-"screen"
  if (incl.sp=="all") sp.plot<-sp.names else sp.plot<-incl.sp

  len.dir<-length(dirs)

   plotvar<-function(sp=sp,vari='M2',ylab='') {
     if (sp %in% dimnames(values)[[3]]) {
      v<-values[,,sp,vari,]
      #print(v)
      maxval<-max(v,na.rm=T)
      if (maxval>0) {
        if ((gi %% (nox*noy))==0  | gi==0) {
          newplot(dev,nox,noy,filename=paste("com_",run.ID,'_',sp,"Q",q,sep=''),Portrait=F);

           par(mar=c(0,0,0,0))
          # make legends
          if (paper) lwds<-2
          else  lwds<-2
          plot(10,10,axes=FALSE,xlab=' ',ylab=' ',xlim=c(0,1),ylim=c(0,1))
          legend("center",legend=labels,col=first.color:(first.color+len.dir-1),
                pch=first.pch:(first.pch+len.dir-1),cex=2,title=paste0(sp,' Q:',q))
          gi<<-gi+1

          par(mar=c(3,3,3,1)) # c(bottom, left, top, right)
        }

        gi<<-gi+1

        ages<-dimnames(v)[[3]][1:min(nox*noy-1,dim(v)[[3]])]
        for (ag in ages) {
          maxval<-max(v[,,ag],na.rm=T)
          minval<-min(0,v[,,ag],na.rm=T)
          if (maxval>0) {
            plot(y,v[,labels[1],ag],main=paste("age",ag),xlab="",ylab=ylab,type='b',lwd=lwds,ylim=c(minval,maxval),
                      col=first.color,pch=first.pch)
             if (doGrid) grid()
            for (i in (2:len.dir)) {
              if (paper) lwds<-1
              else  lwds<-2;
              lines(y,v[,labels[i],ag],col=first.color+i-1,pch=first.pch+i-1,type='b',lwd=lwds)
             }
          }
         }
       }
     }
    }

   for (sp in (sp.plot)) {
    gi<-0
    plotvar(sp=sp,vari="N",ylab="N")
  }
}
plotN(q=1)

plotN(q=2)
plotN(q=3)
plotN(q=4)
if (paper) cleanup();


empty <- function() length(l) == 0
push <- function(x)
{
   l <<- c(l, list(x))
   print(l)
   invisible()
}
pop <- function()
{
   if(empty()) stop("can't pop from an empty list")
   l[[1]] <<- NULL
   print(l)
   invisible()
}
l <- list()
empty()
# [1] TRUE
push(3)
# [[1]]
# [1] 3
push("abc")
# [[1]]
# [1] 3
# [[2]]
# [1] "abc"
push(matrix(1:6, nrow=2))
# [[1]]
# [1] 3
# [[2]]
# [1] "abc"
# [[3]]
#      [,1] [,2] [,3]
# [1,]    1    3    5
# [2,]    2    4    6
empty()
# [1] FALSE
pop()
# [[1]]
# [1] 3
# [[2]]
# [1] "abc"
pop()
# [[1]]
# [1] 3
pop()
# list()
pop()
# Error in pop() : can't pop from an empty list


#' Data Simulation Plots
#'
#' Plots simulated and experimental data. The created plots are: Reaction times densities for
#' correct and incorrect responses and the proportion of correct answeres for each one of
#' six reaction time bins. A folder with the model name is created and the plots saved
#' automatically in the current working directory.
#' @export
#' @param experim_dat Experimental data in the form produced by \code{\link{experimental_data_processing}}.
#' @param experim_dat Simulated data in the form produced by \code{\link{simulDat}}.
#' @param model_name Optional name for the model to distinguish to which data/model the
#' function was applied to. Default is 'NAME_UNDEFINED'.
#' @return Generates and saves plots in a directory with name of \code{model_name}.
models_plots <- function(experim_dat, simul_dat, model_name='NAME_UNDEFINED'){

    ggplot2::theme_set(theme_bw())

    if(is.null(model_name) | nchar(model_name) < 4 | model_name=='NAME_UNDEFINED'){
        model_name <- "NAME_UNDEFINED"
        dir.create(paste(model_name), showWarnings = FALSE)
    }

    the_combine <- rbind(data.frame(experim_dat, 'cond'='Data'), simul_dat$data)

    #------------------------------------------------------------
    plot1 <-  ggplot() +
        geom_density(aes(x=rt, group=cor, fill=cor),data=simul_dat$data, alpha=.3) +
        theme(legend.position="bottom") +
        labs(title = paste(model_name),
             subtitle = "Comparison of Simulated Correct vs. Incorrect RTs",
             x = "Reaction Times",
             y = 'Density',
             fill='Correct') +
        scale_colour_hue(name="Data Types:")
    ggsave(plot1, filename = paste(model_name, '/',model_name, '_simRTcorvsncorr.pdf',sep = ''),
           device = 'pdf',
           scale = 1, width = 12, height = 8, units = "in")
    #------------------------------------------------------------

    #------------------------------------------------------------
    plot2tmp <- the_combine
    plot2tmp$rt[plot2tmp$cor==0] <- plot2tmp$rt[plot2tmp$cor==0] *-1
    plot2 <-  ggplot() +
        geom_density(aes(x=rt,y=..density..,color=cond),data=plot2tmp) +
        # geom_density(aes(x=value,y=..density..,color=cond),data=c) +
        facet_wrap(~plot2tmp$suj) +
        labs(title = paste(model_name),
             subtitle = "Comparison of Data and Simulated RTs",
             x = "Reaction Times",
             y = 'Density',
             caption = 'Note: Negative/Positive RTs belong to incorrect/correct trials respectively') +
        theme(legend.position="bottom") +
        scale_colour_hue(name="Data Types:")
    ggsave(plot2, filename = paste(model_name, '/', model_name, '_simRTcomparison.pdf',sep = ''), device = 'pdf',
           scale = 1, width = 12, height = 8, units = c("in"))
    #------------------------------------------------------------

    #PLOT3: Check in what range the error rates are Sim vs. Data
    #------------------------------------------------------------
    nbins <- 6

    dat_cuants <- quantile(experim_dat$rt, probs = seq(0, 1, length.out = nbins+1)) ; dat_cuants[length(dat_cuants)] <- tail(dat_cuants, n=1)+0.1

    sim_cuants <- quantile(simul_dat$data$rt, probs = seq(0, 1, length.out = nbins+1)) ; sim_cuants[length(sim_cuants)] <- tail(sim_cuants, n=1)+0.1

    the_combine$cuants[the_combine$cond=='Data'] <-  experim_dat %>%
        split(experim_dat$suj) %>%  map(c('rt')) %>%
        map(function(x) {cut(x, breaks = dat_cuants, right=FALSE, na.rm = TRUE)}) %>%
        as_tibble() %>% tidyr::pivot_longer(cols=everything(), names_to = 'variable', values_to = 'value')  %>%  .$value

    the_combine$cuants[the_combine$cond=='Sim'] <-  simul_dat$data %>%
        split(simul_dat$data$suj) %>%  map(c('rt')) %>%
        map(function(x) {cut(x, breaks = sim_cuants, right=FALSE, na.rm = TRUE)}) %>%
        as_tibble() %>% tidyr::pivot_longer(cols=everything(), names_to = 'variable', values_to = 'value')  %>%  .$value

    the_combine$cuants <- unlist(the_combine$cuants) %>% as.factor()
    the_combine$cor <- as.numeric(levels(the_combine$cor))[the_combine$cor]

    smrzd <- ddply(the_combine, c("cond","cuants"), summarise,
                   N    = length(cor),
                   mean = mean(cor),
                   sd   = sd(cor),
                   se   = sd / sqrt(N))

    pd <- position_dodge(0.1)  #The errorbars overlapped, so use position_dodge to move them horizontally
    plot3 <- ggplot(smrzd, aes(x=cuants, y=mean, colour=cond, group=cond)) +
        geom_errorbar(aes(ymin=mean-se, ymax=mean+se), width=.1,position=pd) +
        geom_line(position=pd) +
        geom_point(position=pd) +
        labs(title = paste(model_name),
             subtitle = "Comparison of Response correctness per RT Quantiles",
             x = "RT Quantile",
             y = 'Proportion Correct Answers',
             caption = 'Note: Bars represent standard errors') +
        theme(legend.position="bottom") +
        scale_colour_hue(name="Data Types:") + ylim(0, 1) +
        theme(legend.position="bottom")

    ggsave(plot3, filename = paste(model_name, '/', model_name, '_cuan_comp.pdf',sep = ''),
           device = 'pdf',
           scale = 1, width = 12, height = 8, units = "in")
    #------------------------------------------------------------

    #------------------------------------------------------------
    smrzd <- ddply(the_combine, c("suj","cond","cuants"), summarise,
                   N    = length(cor),
                   mean = mean(cor),
                   sd   = sd(cor),
                   se   = sd / sqrt(N))
    pd <- position_dodge(0.1)  #The errorbars overlapped, so use position_dodge to move them horizontally
    plot4 <- ggplot(smrzd, aes(x=cuants, y=mean, colour=cond, group=cond)) +
        geom_errorbar(aes(ymin=mean-se, ymax=mean+se), width=.1,position=pd) +
        geom_line(position=pd) +
        geom_point(position=pd) +
        labs(title = paste(model_name),
             subtitle = "Comparison of Response correctness per RT Quantiles and Subject",
             x = "RT Quantile",
             y = 'Proportion Correct Answers',
             caption = 'Note: Bars represent standard errors') +
        theme(legend.position="bottom") +
        scale_colour_hue(name="Data Types:") + ylim(0, 1) +
        theme(legend.position="bottom") + facet_wrap(~smrzd$suj)
    ggsave(plot4, filename = paste(model_name, '/', model_name, '_cuan_comp_suj.pdf',sep = ''),
           device = 'pdf',
           scale = 1, width = 12, height = 8, units = "in")

}


# KNMI series analysis similar to v04 en v10.

logger.names <- grep('barometer/', gwloggeR.data::enumerate(), value = TRUE)
logger.names <- c(logger.names, 'KNMI_20200312_hourly')
logger.names <- setdiff(logger.names, 'barometer/BAOL016X_W1666.csv')
logger.names <- setdiff(logger.names, 'barometer/BAOL050X_56819.csv') # high freq manu in range of 80 cmH2O

round_timestamp <- function(ts, scalefactor.sec = 3600*12) {
  as.POSIXct(round(as.numeric(ts)/scalefactor.sec) * scalefactor.sec, origin = '1970-01-01', tz = 'UTC')
}

read.baro <- function(logger.name) {
  df <- gwloggeR.data::read(logger.name)$df
  if (nrow(df) == 0L) return(df)
  df <- df[!is.na(TIMESTAMP_UTC), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]
  df[, 'FILE' := basename(logger.name)]
  df[, 'N' := .N]
  data.table::setkey(df, TIMESTAMP_UTC)
  structure(df, 'logger.name' = logger.name)
}

# read.baro('barometer/BAOL553X_B_004BA.csv')
data <- sapply(logger.names, read.baro, simplify = FALSE, USE.NAMES = TRUE)

with(data[['KNMI_20200312_hourly']], plot(x = TIMESTAMP_UTC, y = PRESSURE_VALUE, type = 'l'))

compare <- function(df1, df2) {
  if (nrow(df1) == 0L || nrow(df2) == 0L) return(data.table::data.table())

  diff.df <- df1[J(df2), .('PRESSURE_DIFF' = x.PRESSURE_VALUE - i.PRESSURE_VALUE, TIMESTAMP_UTC)][!is.na(PRESSURE_DIFF), ]

  diff.df
}

compute <- function(logger.name, make.plot = TRUE) {
  logger.names <- setdiff(logger.names, logger.name)
  logger.df <- data[[logger.name]]

  df.diff <- lapply(logger.names, function(other.name) {
    other.df <- data[[other.name]]
    compare(logger.df, other.df)
  })
  df.diff <- data.table::rbindlist(df.diff, use.names = TRUE, fill = TRUE)

  if (nrow(df.diff) == 0L) return()

  df.quant <- df.diff[
    , .(Q.025 = quantile(PRESSURE_DIFF, 0.025),
        Q.5 = quantile(PRESSURE_DIFF, 0.5),
        Q.975 = quantile(PRESSURE_DIFF, 0.975)),
    by = TIMESTAMP_UTC]

  plt.logger <- ggplot2::ggplot(data = logger.df, mapping = ggplot2::aes(x = TIMESTAMP_UTC, y = PRESSURE_VALUE)) +
    ggplot2::geom_line() +
    ggplot2::coord_cartesian(ylim = quantile(logger.df$PRESSURE_VALUE, probs = c(0.005, 0.995)),
                             xlim = range(logger.df$TIMESTAMP_UTC)) +
    ggplot2::theme_light() +
    ggplot2::theme(axis.title.x = ggplot2::element_blank(),
                   axis.text.x = ggplot2::element_blank(),
                   axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5))

  plt.diff <- ggplot2::ggplot(data = df.diff, mapping = ggplot2::aes(x = TIMESTAMP_UTC, y = PRESSURE_DIFF)) +
    ggplot2::geom_point(pch = '.') +
    ggplot2::geom_line(data = df.quant, mapping = ggplot2::aes(y = Q.5), col = 'red', alpha = 0.5) +
    ggplot2::stat_smooth(method = 'gam', formula = y ~ s(x, k = 40), color = 'yellow', se = FALSE) +
    ggplot2::coord_cartesian(ylim = quantile(df.diff$PRESSURE_DIFF, probs = c(0.025, 0.975)),
                             xlim = range(logger.df$TIMESTAMP_UTC)) +
    #ggplot2::scale_x_datetime(date_breaks = '1 year', date_labels = '%Y') +
    ggplot2::theme_light() +
    ggplot2::theme(axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5))

  layout_matrix <- rbind(1,2)
  grob.title <- grid::textGrob(sprintf('%s (#%s vs. #%s observations)',
                                       basename(logger.name), nrow(logger.df), nrow(df.diff)),
                               x = 0.05, hjust = 0)

  filename <- sprintf('./drifts/analysis_11/%s.png', tools::file_path_sans_ext(basename(logger.name)))

  local({
    if (!make.plot) return()
    png(filename, width = 1280, height = 720)
    on.exit(dev.off())
    print(gridExtra::grid.arrange(plt.logger, plt.diff,
                                  layout_matrix = layout_matrix,
                                  top = grob.title))
  })

  structure(df.diff, 'logger.name' = logger.name)
}

result <- compute('KNMI_20200312_hourly')

# ANALYSIS similar to v10

list.quant <- lapply(list(result), function(df) {
  if (is.null(df)) return(data.table::data.table())
  df.Q <- df[, .(Q.5 = quantile(PRESSURE_DIFF, 0.5), N.GROUP = .N), by = TIMESTAMP_UTC]
  df.Q <- df.Q[N.GROUP >= 10, ]
  wiskers <- boxplot.stats(df.Q[, Q.5])$stats[c(1, 5)]
  df.Q[, Q.5.centered := Q.5 - mean(wiskers)]
  df.Q[, FILE := basename(attr(df, 'logger.name'))]
  df.Q[, N := .N]
  df.Q[, IQR := IQR(Q.5)]
  df.Q[, WISK := wiskers[2L] - wiskers[1L]]
  df.Q[, PERC.95 := quantile(Q.5, 0.975) - quantile(Q.5, 0.025)]
  df.Q[, SD := sd(Q.5)]
  df.Q
})

local(with(list.quant[[1L]], {
  print(ggplot2::ggplot(mapping = ggplot2::aes(x = TIMESTAMP_UTC)) +
          ggplot2::geom_line(mapping = ggplot2::aes(y = Q.5), col = 'red', alpha = 0.5) +
          ggplot2::theme_light() +
          ggplot2::theme(axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5)))
  plot(x = TIMESTAMP_UTC, y = Q.5, pch = '.')

  par(mfrow = c(1, 2))
  on.exit(par(mfrow = c(1, 1)))
  hist(Q.5, breaks = 50, main = '')
  boxplot(Q.5)
  boxplot.stats(Q.5)$stats
}))

df.quant <- data.table::rbindlist(list.quant) # 424332 observations, 414692 with df.quant[N.GROUP >= 10, ]
df.quant[, LABEL := sprintf('%s (#%i) [%.2f WISK]', FILE, N, WISK)]
df.quant <- df.quant[order(WISK, LABEL), ]
df.quant[, LABEL := factor(LABEL, levels = unique(LABEL))]
df.quant[1L,]


print(paste0(Sys.time(), " --- Paragraph on taxonomic effort"))

# Count number of statuses
df_years <- rbind(df[, c("idx", "status", "date.n")], df2)
status <- table(df_years$status)
sum(status)
round(prop.table(status)*100, 1)

# Get data
df_tax <- df_describers[spp_N_1st_auth_s>0]; dim(df)
df_tax$diff <- df_tax$max - df_tax$ns_max
df_tax$non_valid_spp_N <- df_tax$spp_N - df_tax$ns_spp_N

# Segregate authors with only non-valid and valid w/ non-valid species
tax_only_non_valid <- df_tax[ns_spp_N==0]$full.name.of.describer.n
tax_valid_and_non_valid <-  df_tax[ns_spp_N > 0 & non_valid_spp_N > 0]$full.name.of.describer.n

# Total number of author-years
total_author_years <- dim(df_describers_year)[1]

# Author-years: Only non-valid species
length(tax_only_non_valid)
length(df_describers_year[full.name.of.describer %in% tax_only_non_valid]$N)
length(df_describers_year[full.name.of.describer %in% tax_only_non_valid]$N) / total_author_years * 100

# Did not shift the median
summary(df_describers_year$N)
summary(df_describers_year[!full.name.of.describer %in% c(tax_only_non_valid)]$N)
summary(df_describers_year[!full.name.of.describer %in% c(tax_only_non_valid, tax_valid_and_non_valid)]$N)

# Author-years: At least valid species and at least 1 non-valid species
length(tax_valid_and_non_valid)
round(prop.table(table(df_tax[full.name.of.describer.n %in% tax_valid_and_non_valid]$diff==0))*100, 1)
summary(df_tax[full.name.of.describer.n %in% tax_valid_and_non_valid & diff >0]$diff)
sum(df_tax[full.name.of.describer.n %in% tax_valid_and_non_valid & diff >0]$diff)

# Proportion of author-years
(721+524)/ total_author_years * 100

# Plot number of authors-years in a density plot
p1 <- ggplot(df_describers_year) +
    geom_density(aes(x = N), alpha = 0.2) +
    xlim(c(0, 20)) + theme
p2 <- ggplot(df_describers_year[!full.name.of.describer %in% c(tax_only_non_valid)]) +
    geom_density(aes(x = N), alpha = 0.2) + xlim(c(0,20)) + theme
grid.arrange(p1, p2) # they look similar