rm(list = ls())
#
## SET YOUR WORKING DIRECTORY HERE (SAVE DATA FILES IN THIS DIRECTORY)
workdir <- c("~/Dropbox/data/rollcall/dipMex")
#workdir <- c("d:/01/Dropbox/data/rollcall/DipMex")
#workdir <- c("C:/Documents and Settings/emagarm/Mis documentos/My Dropbox/data/rollcall/DipMex")
#workdir <- c("C:/Documents and Settings/emm/Mis documentos/My Dropbox/data/rollcall/DipMex")
setwd(workdir)

# load and prepare data objects
load(file="rc60.RData")
rc60 <- list(dgaceta=dgaceta, dipdat=dipdat, rc=rc, votdat=votdat)
rm(dgaceta, dipdat, rc, votdat)
load(file="rc61.RData")
rc61 <- list(dgaceta=dgaceta, dipdat=dipdat, rc=rc, votdat=votdat)
rm(dgaceta, dipdat, rc, votdat)

# summarize votes by party
tmp <- rc60$rc[,rc60$dipdat$part=="pan"]
pan60 <- pri60 <- prd60 <- data.frame(vote=1:nrow(tmp), ayes=rep(NA,nrow(tmp)), nays=rep(NA,nrow(tmp)), abs=rep(NA,nrow(tmp)), noshow=rep(NA,nrow(tmp)))
tmp2 <- tmp;
tmp2[,] <- 0; tmp2[tmp==1] <- 1; pan60$ayes <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==2] <- 1; pan60$nays <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==3 | tmp==4] <- 1; pan60$abs <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==5] <- 1; pan60$noshow <- apply(tmp2, 1, sum)
#
tmp <- rc60$rc[,rc60$dipdat$part=="pri"]
tmp2 <- tmp;
tmp2[,] <- 0; tmp2[tmp==1] <- 1; pri60$ayes <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==2] <- 1; pri60$nays <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==3 | tmp==4] <- 1; pri60$abs <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==5] <- 1; pri60$noshow <- apply(tmp2, 1, sum)
#
tmp <- rc60$rc[,rc60$dipdat$part=="prd"]
tmp2 <- tmp;
tmp2[,] <- 0; tmp2[tmp==1] <- 1; prd60$ayes <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==2] <- 1; prd60$nays <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==3 | tmp==4] <- 1; prd60$abs <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==5] <- 1; prd60$noshow <- apply(tmp2, 1, sum)
#
tmp <- rc61$rc[,rc61$dipdat$part=="pan"]
pan61 <- pri61 <- prd61 <- data.frame(vote=1:nrow(tmp), ayes=rep(NA,nrow(tmp)), nays=rep(NA,nrow(tmp)), abs=rep(NA,nrow(tmp)), noshow=rep(NA,nrow(tmp)))
tmp2 <- tmp;
tmp2[,] <- 0; tmp2[tmp==1] <- 1; pan61$ayes <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==2] <- 1; pan61$nays <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==3 | tmp==4] <- 1; pan61$abs <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==5] <- 1; pan61$noshow <- apply(tmp2, 1, sum)
#
tmp <- rc61$rc[,rc61$dipdat$part=="pri"]
tmp2 <- tmp;
tmp2[,] <- 0; tmp2[tmp==1] <- 1; pri61$ayes <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==2] <- 1; pri61$nays <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==3 | tmp==4] <- 1; pri61$abs <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==5] <- 1; pri61$noshow <- apply(tmp2, 1, sum)
#
tmp <- rc61$rc[,rc61$dipdat$part=="prd"]
tmp2 <- tmp;
tmp2[,] <- 0; tmp2[tmp==1] <- 1; prd61$ayes <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==2] <- 1; prd61$nays <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==3 | tmp==4] <- 1; prd61$abs <- apply(tmp2, 1, sum)
tmp2[,] <- 0; tmp2[tmp==5] <- 1; prd61$noshow <- apply(tmp2, 1, sum)

# total votes excluding abstentions and no-shows
pan60$tot <- pan60$ayes + pan60$nays
pri60$tot <- pri60$ayes + pri60$nays
prd60$tot <- prd60$ayes + prd60$nays
pan61$tot <- pan61$ayes + pan61$nays
pri61$tot <- pri61$ayes + pri61$nays
prd61$tot <- prd61$ayes + prd61$nays

## rice index of intra-party likeness: vote i, party j: abs(aye-nay)/(aye+nay)
pan60$likeness <- abs(pan60$ayes - pan60$nays) / pan60$tot
pri60$likeness <- abs(pri60$ayes - pri60$nays) / pri60$tot
prd60$likeness <- abs(prd60$ayes - prd60$nays) / prd60$tot
pan61$likeness <- abs(pan61$ayes - pan61$nays) / pan61$tot
pri61$likeness <- abs(pri61$ayes - pri61$nays) / pri61$tot
prd61$likeness <- abs(prd61$ayes - prd61$nays) / prd61$tot
#
prd60$likeness[prd60$tot==0] <- 1 ## all prd no-showed in one vote
pan61$likeness[pan61$tot==0] <- 1 ## all pan no-showed in one vote
prd61$likeness[prd61$tot==0] <- 1 ## all prd no-showed in one vote

## rice index of inter-party disimilarity:  vote i, parties j and k: absolute difference in proportion of j voting aye and proportion of k voting aye
pan60$panpri <- pri60$panpri <- abs(pan60$ayes/pan60$tot - pri60$ayes/pri60$tot)
pan60$panprd <- prd60$panprd <- abs(pan60$ayes/pan60$tot - prd60$ayes/prd60$tot)
pri60$priprd <- prd60$priprd <- abs(pri60$ayes/pri60$tot - prd60$ayes/prd60$tot)
pan61$panpri <- pri61$panpri <- abs(pan61$ayes/pan61$tot - pri61$ayes/pri61$tot)
pan61$panprd <- prd61$panprd <- abs(pan61$ayes/pan61$tot - prd61$ayes/prd61$tot)
pri61$priprd <- prd61$priprd <- abs(pri61$ayes/pri61$tot - prd61$ayes/prd61$tot)
#
pan60$panprd[prd60$tot==0] <- prd60$panprd[prd60$tot==0] <- abs(pan60$ayes[prd60$tot==0]/pan60$tot[prd60$tot==0] - 0)
pri60$priprd[prd60$tot==0] <- prd60$priprd[prd60$tot==0] <- abs(pri60$ayes[prd60$tot==0]/pri60$tot[prd60$tot==0] - 0)
#
pan61$panpri[pan61$tot==0] <- pri61$panpri[pan61$tot==0] <- abs(0 - pri61$ayes[pan61$tot==0]/pri61$tot[pan61$tot==0])
pan61$panprd[pan61$tot==0] <- prd61$panprd[pan61$tot==0] <- abs(0 - prd61$ayes[pan61$tot==0]/prd61$tot[pan61$tot==0])
#
pan61$panprd[prd61$tot==0] <- prd61$panprd[prd61$tot==0] <- abs(pan61$ayes[prd61$tot==0]/pan61$tot[prd61$tot==0] - 0)
pri61$priprd[prd61$tot==0] <- prd61$priprd[prd61$tot==0] <- abs(pri61$ayes[prd61$tot==0]/pri61$tot[prd61$tot==0] - 0)

## general summary
paste("pan likeness 60th =", sprintf("%.2f", mean(pan60$likeness)))
paste("pri likeness 60th =", sprintf("%.2f", mean(pri60$likeness)))
paste("prd likeness 60th =", sprintf("%.2f", mean(prd60$likeness)))
paste("pan likeness 61th =", sprintf("%.2f", mean(pan61$likeness)))
paste("pri likeness 61th =", sprintf("%.2f", mean(pri61$likeness)))
paste("prd likeness 61th =", sprintf("%.2f", mean(prd61$likeness)))
#
paste("pan-pri disimmilarity 60th =", sprintf("%.2f", mean(pan60$panpri)))
paste("pan-prd disimmilarity 60th =", sprintf("%.2f", mean(pan60$panprd)))
paste("pri-prd disimmilarity 60th =", sprintf("%.2f", mean(pri60$priprd)))
paste("pan-pri disimmilarity 61th =", sprintf("%.2f", mean(pan61$panpri)))
paste("pan-prd disimmilarity 61th =", sprintf("%.2f", mean(pan61$panprd)))
paste("pri-prd disimmilarity 61th =", sprintf("%.2f", mean(pri61$priprd)))
#
paste("(pan likeness 60th | pan-pri disim > .5) =", sprintf("%.2f", mean(pan60$likeness[pan60$panpri>.5])))
paste("(pan likeness 60th | pan-prd disim > .5) =", sprintf("%.2f", mean(pan60$likeness[pan60$panprd>.5])))
paste("(pri likeness 60th | pan-pri disim > .5) =", sprintf("%.2f", mean(pri60$likeness[pan60$panpri>.5])))
paste("(pri likeness 60th | pri-prd disim > .5) =", sprintf("%.2f", mean(pri60$likeness[pri60$priprd>.5])))
paste("(prd likeness 60th | pan-prd disim > .5) =", sprintf("%.2f", mean(prd60$likeness[pan60$panprd>.5])))
paste("(prd likeness 60th | pri-prd disim > .5) =", sprintf("%.2f", mean(prd60$likeness[pri60$priprd>.5])))
#
paste("(pan likeness 61th | pan-pri disim > .5) =", sprintf("%.2f", mean(pan61$likeness[pan61$panpri>.5])))
paste("(pan likeness 61th | pan-prd disim > .5) =", sprintf("%.2f", mean(pan61$likeness[pan61$panprd>.5])))
paste("(pri likeness 61th | pan-pri disim > .5) =", sprintf("%.2f", mean(pri61$likeness[pan61$panpri>.5])))
paste("(pri likeness 61th | pri-prd disim > .5) =", sprintf("%.2f", mean(pri61$likeness[pri61$priprd>.5])))
paste("(prd likeness 61th | pan-prd disim > .5) =", sprintf("%.2f", mean(prd61$likeness[pan61$panprd>.5])))
paste("(prd likeness 61th | pri-prd disim > .5) =", sprintf("%.2f", mean(prd61$likeness[pri61$priprd>.5])))


  figure.timeseries.errorbars = function( dat, outdir, fname="tmp" ) {

    x = dat[,1]
    y = dat[,2]

    if ( ncol(dat) == 4 ) {
      lb = dat[,3]
      ub = dat[,4]
    } else if( ncol(dat) ==3 ) {
      e = dat[,3]
      ub = y + e
      lb = y - e
    }

    sdy = sd( y )

    xlim = range( x, na.rm=T )
    xlim[1] = xlim[1]-0.5
    xlim[2] = xlim[2]+0.5

    ylim = range( c( ub, lb, 0) , na.rm=T)

    par( cex = 2, cex.lab=4 )

    plot( x, y, type="p", pch=19, xlim=xlim, ylim=ylim, ylab="", xlab="")
    lines (  x,y,  col="gray50" , lwd = 2 )
    lines ( lowess( x,y, f=0.25 ), col="blue" , lwd = 3 )
    arrows( x, ub, x, lb,  col="gray50", length=0.1, angle=90, code=3, lwd=1.5)

    Pr(dev="png", dname=outdir, fname=fname, width=16, height=12)

    return("Done")
  }


##########################################################################################
## Visualization
##########################################################################################

## Modules
##########################################################################################
data.loading <- function(datLink=NULL, dirName=NA, chrom=NA, start=NA, end=NA, labels=NA, nbins=end-start+1, name=NA, pattern="bdg", header=TRUE, sep="\t") {

  label.checking <- function(fileName, labels) {
    is.lable <- FALSE
    for(l in labels) {
      if(any(grepl(l, fileName, ignore.case=TRUE))) return(TRUE)
    }
    is.lable
  }

  if(is.null(datLink)){
    files <- dir(path=dirName, pattern=pattern, all.files=T, full.names=T)
    datList <- list(); datNames <- c()
    for(f in files) if(file.exists(f)) {
      dat <- read.table(f, header=header, sep=sep) # format: chrom[sep]start[sep]end[sep]value[sep]...
      datList <- c(datList, list(dat))
      datNames <- c(datNames, f)
    }
    names(datList) <- datNames
    save(list = c("datList", "files"), file = sprintf("%s/%s_tracking.RData", dirName, name))

    if(file.exists(sprintf("%s/%s_tracking.RData", dirName, name))) TRUE else FALSE

  } else {
    load(datLink)

    bins <- seq(start, end, length=nbins)
    visual.dat <- c(); lab.order <- c()
    for(f in files) {
      if(!label.checking(f, labels)) next

      dat <- datList[[f]]
      dat <- dat[dat[,1] == chrom & dat[,2] >= start & dat[,3] <= end,]
      dat <- dat[order(dat[,2]),]

      density <- rep(0, length(bins)-1); i <- c(1)
      for(j in 2:length(bins)) {
        while(i<=nrow(dat) && dat[i,3]<bins[j-1]) {
          i <- i + 1
          if(i>nrow(dat)) break
        }

        if(i>nrow(dat) || dat[i,2]>bins[j]) {
          density[j-1] <- c(-1)
          next
        }

        if(!(dat[i,3]<bins[j-1] || dat[i,2]>bins[j])) i.pre <- i

        tmp <- c()
        while(i<=nrow(dat) && !(dat[i,3]<bins[j-1] || dat[i,2]>bins[j])) {
          tmp <- c(tmp, dat[i,4])
          i <- i + 1
        }

        if(!is.null(tmp)) {
          density[j-1] <- mean(tmp)
          i <- i.pre
        }
      }
      visual.dat <- cbind(visual.dat, density)
      lab.order <- c(lab.order, f)
    }
    idx.lab <- 1:ncol(visual.dat); ord <- c(); labs <- c()
    for(i in 1:length(labels)) if(any(grepl(labels[i], lab.order))) {
       labs <- c(labs, labels[i])
       ord <- c(ord, idx.lab[grepl(labels[i], lab.order)])
    }

    list(dat=visual.dat, bin=bins, labOrder=ord, label=labs, chrom=chrom, start=start, end=end)
  }
}

browser <- function(visual.dat, bins, labels, colors, chrom, start, end, show.ylim=TRUE, layout.config=NA, is.smooth=FALSE, is.commmon=FALSE, ylim=c(0, max(visual.dat)*1.3), nbins=1000, cex=1, main=NULL,
  xlab=NULL, at=NULL, layout.mode="separate", scale.show=5000, species="mm10", layout.width=c(1,10), scale.signal=1) {

  chrom.id <- sprintf("%s:", chrom)
  if(scale.signal != 1) {
    visual.dat[visual.dat>0] <- visual.dat[visual.dat>0] / scale.signal
  }

  if(!is.matrix(ylim) && length(ylim)<=2) ylim <- matrix(c(rep(0, ncol(visual.dat)), apply(visual.dat, 2, max, na.rm=T)), ncol=2) # matrix(rep(ylim, ncol(visual.dat)), ncol=2, byrow=T)
  if(length(show.ylim)!=ncol(visual.dat)) show.ylim <- rep(TRUE, ncol(visual.dat))
  if(length(is.smooth)!=ncol(visual.dat)) is.smooth <- rep(FALSE, ncol(visual.dat))

  x.axis <- (bins[2:length(bins)] + bins[1:(length(bins)-1)]) / 2
  if(is.commmon) {
    x.axis <- x.axis[rowSums(visual.dat<0)<=0]
    visual.dat <- visual.dat[rowSums(visual.dat<0)<=0,]
  }

  if(any(is.na(layout.config))) {layout(cbind(rep(0,ncol(visual.dat)+1), matrix(1:(ncol(visual.dat)+1),ncol=1)), w=layout.width, h=c(5, rep(3,ncol(visual.dat))))} else {layout(cbind(rep(0,ncol(visual.dat)+1), matrix(1:(ncol(visual.dat)+1),ncol=1)), w=layout.width, h=c(5, layout.config))}

  par(mar=c(1,1,6,10)*0.5)
  plot(NA, bg='gray', ann=F, ylim=c(0, 1), xlim=c(start, end), cex=cex, cex.lab=cex, cex.main=cex, xaxs='i', axes=F)
  lines(seq(start+0.3*(end-start), start+0.3*(end-start)+scale.show, len=5), rep(0.5,5), lwd=cex/2)
  lines(rep(start+0.3*(end-start),3), c(0, 0.1, 0.2)+0.4, lwd=cex/2)
  lines(rep(start+0.3*(end-start)+scale.show,3), c(0, 0.1, 0.2)+0.4, lwd=cex/2)
  if(scale.show > 1000) text(start+0.3*(end-start), 0.5, labels=sprintf("%.fkb", scale.show/1000), cex=0.5*cex, pos=2) else text(start+0.3*(end-start), 0.5, labels=sprintf("%.fbp", scale.show), cex=0.5*cex, pos=2)
  text(start+0.3*(end-start)+scale.show, 0.5, labels=species, cex=0.5*cex, pos=4)
  axis(3, at=seq(start,end,len=5), label=print.money(seq(start,end,len=5)), cex.axis=0.5*cex, las=1, lwd=0, lwd.ticks=cex/2)
  axis(2, at=par()$usr[4], labels=chrom.id, las=2, cex.axis=0.5*cex, lwd=2, font.axis=2, col.axis="black", tick=F, hadj=1+min(c(nchar(chrom.id), nchar(labels)))/nchar(chrom.id))

  for(i in 1:ncol(visual.dat)) {
    density <- visual.dat[,i]
    if(is.smooth[i]) fit <- smooth.spline(x.axis, density, df=ifelse(length(x.axis) > nbins, nbins, length(x.axis))) else fit <- list(x=x.axis, y=density)
    fit$y[fit$y<0] <- 0
    if(all(ylim[i,] == 0)) ylim[i,] <- c(0, max(visual.dat)*1.3)

    if(layout.mode == "collapse") {
      if(i == 1) {
        par(mar=c(0,1,1,10)*0.5)
        plot(NA, bg='gray', ann=F, yaxt='n', xaxt='n', ylim=ylim[i,], xlim=c(start, end), frame.plot=T, cex=cex, cex.lab=cex, cex.main=cex, xaxs='i')
      } else if(i == ncol(visual.dat)){
        par(mar=c(1,1,0,10)*0.5)
        plot(NA, bg='gray', ann=F, yaxt='n', xaxt='n', ylim=ylim[i,], xlim=c(start, end), frame.plot=T, cex=cex, cex.lab=cex, cex.main=cex, xaxs='i')
      } else {
        par(mar=c(0,1,0,10)*0.5)
        plot(NA, bg='gray', ann=F, yaxt='n', xaxt='n', ylim=ylim[i,], xlim=c(start, end), frame.plot=T, cex=cex, cex.lab=cex, cex.main=cex, xaxs='i')
      }
      axis(2, at=ylim[i,2]/2, labels=labels[i], las=2, cex.lab=cex, cex.axis=cex, lwd=2, font.axis=2, col.axis=colors[i])
      if(show.ylim[i]) text(start+0.05*(end-start), 0.9*ylim[i,2], ifelse(ylim[i,2]>1000 || ylim[i,2] < 1e-2, format(ylim[i,2], sci=T, digits=2), sprintf("[0,%.2f]", ylim[i,2])), cex=0.8*cex, font=2)
      if(i == ncol(visual.dat) && !is.null(xlab)) axis(1, at=at, labels=xlab, cex.axis=cex, cex.lab=cex, cex=cex)
      if(i == 1 && !is.null(main)) axis(3, at=start+(end-start)/2, tick=F, labels=sprintf("%s (%s:%s-%s)", main, chrom, start, end), cex.axis=cex, cex.lab=cex, cex=cex)
    } else if(layout.mode == "separate") {
        par(mar=c(1,1,1,10)*0.5)
        plot(NA, bg='gray', ann=F, ylim=ylim[i,], xlim=c(start, end), cex=cex, cex.lab=cex, cex.main=cex, xaxs='i', axes=F)
        if(show.ylim[i]) axis(2, at=ylim[i,], labels=c("0", ifelse(ylim[i,2]>1000 || ylim[i,2] < 1e-2, format(ylim[i,2], sci=T, digits=2), sprintf("%.2f", ylim[i,2]))), cex.axis=0.5*cex, las=2, col.axis=colors[i], col=colors[i])
        axis(2, at=ylim[i,2]/2, labels=labels[i], las=2, cex.axis=0.5*cex, lwd=2, font.axis=2, col.axis=colors[i], col=colors[i], tick=F, hadj=1+min(c(nchar(chrom.id), nchar(labels)))/nchar(labels[i]))
    }

    if(is.smooth[i]) polygon(c(rev(fit$x), fit$x), c(rev(fit$y), 0*fit$y), col = colors[i], border = NA) else {
      for(k in 1:length(fit$x)) {
        if(!show.ylim[i] && fit$y[k] <= 0) col <- "transparent" else col <- colors[i]
        if(fit$y[k]>=0) {
          lines(c(fit$x[k],fit$x[k]), c(0, fit$y[k]), col = col, lwd=1)
        } else {
          lines(c(fit$x[k],fit$x[k]), c(fit$y[k], 0), col = col, lwd=1)
        }
      }
    }
  }

}

.screener <- function(dirName, chrom, start, end, tmpDir=sprintf("%s/tmp_%.4f", dirName, runif(1)), pattern="bdg") {
  if(!dir.exists(tmpDir)) dir.create(tmpDir)

  for(f in dir(path=dirName, pattern=pattern, full.names=T)) {
    outFile <- sprintf("%s/%s", tmpDir, gsub(".*/", "", f))
    if(grepl("gz$", f)) {
      system(sprintf("gunzip -c %s | awk '{if($1==\"%s\" && $2>=%d && $3<=%d) printf(\"%%s\\t%%s\\t%%s\\t%%s\\n\", $1, $2, $3, $4);}' | gzip -c > %s", f, chrom, start, end, outFile))
    } else {
      system(sprintf("cat %s | awk '{if($1==\"%s\" && $2>=%d && $3<=%d) printf(\"%%s\\t%%s\\t%%s\\t%%s\\n\", $1, $2, $3, $4);}' > %s", f, chrom, start, end, outFile))
    }
  }

  return(tmpDir)
}

.plot.visual <- function(dirName="data", tmpDir=NA, outdir=NA, show.ylim=FALSE, layout.config=NA, colors=NA, chrom=NA, start=NA, end=NA, is.commmon=FALSE, is.bigDat=FALSE, layout.mode="separate", scale.show=5000, cex=3.5, species="mm10",
  pattern="bdg.gz", labels=NA, header=FALSE, name=NA, is.smooth=FALSE, nbins=1000, main=NULL, xlab=NULL, at=NULL, fwidth=2000, fheight=500, layout.width=c(1,10), scale.signal=1) {
  ## import data
  if(is.bigDat && !file.exists(sprintf("%s/%s_tracking.RData", dirName, name))) {
    tmpDir <- .screener(dirName, chrom, start, end, pattern=pattern)
    if(is.na(outdir)) outdir <- dirName
    dirName <- tmpDir
  }

  datLink <- sprintf("%s/%s_tracking.RData", dirName, name)
  if(!file.exists(datLink)) {
    data.loading(dirName=dirName, header=FALSE, pattern=pattern, name=name)
  }
  mat <- data.loading(datLink=datLink, chrom=chrom, start=start, end=end, labels=labels, header=FALSE, name=name)

  ## plot
  if(is.na(outdir)) bmp(sprintf("%s/%s.tracking.tiff", dirName, name), width = fwidth, height = fheight) else bmp(sprintf("%s/%s.tracking.tiff", outdir, name), width = fwidth, height = fheight)
  if(all(is.na(layout.config))) layout.config <- rep(3,ncol(mat$dat))
  browser(visual.dat=mat$dat[,mat$labOrder], bins=mat$bin, show.ylim=show.ylim, layout.config=layout.config, labels=labels, is.smooth=is.smooth, is.commmon=is.commmon, colors=colors, chrom=chrom, start=start,
    layout.mode=layout.mode, end=end, scale.show=scale.show, cex=cex, species=species, layout.width=layout.width, scale.signal=scale.signal)
  dev.off()

  if(file.exists(sprintf("%s/%s_tracking.RData", tmpDir, name))) system(sprintf("mv %s/%s_tracking.RData %s", tmpDir, name, outdir))
  if(dir.exists(sprintf("%s", tmpDir))) unlink(tmpDir, recursive=TRUE, force=TRUE)
}

makeTransparent = function(..., alpha=0.5) {
  if(alpha<0 | alpha>1) stop("alpha must be between 0 and 1")
  alpha = floor(255*alpha)
  newColor = col2rgb(col=unlist(list(...)), alpha=FALSE)
  .makeTransparent = function(col, alpha) {
    rgb(red=col[1], green=col[2], blue=col[3], alpha=alpha, maxColorValue=255)
  }
  newColor = apply(newColor, 2, .makeTransparent, alpha=alpha)
  return(newColor)
}

print.money <- function(x, ...) {
  paste0(formatC(as.double(x), format="f", digits=0, big.mark=","))
}

makeColors <- function(files, labels, sep=".*/|rep.*", alpha=1) {
  colbars <- gsub(sep, "", files)
  warning(sprintf("The default colors will be grouped by labels: %s", paste0(colbars, collapse=",")))

  labels <- labels[order(colbars)]
  colbars <- colbars[order(colbars)]
  cols <- rainbow(length(unique(colbars)))
  names(cols) <- unique(colbars)
  colors <- colbars
  for(lab in unique(colbars)) {
    colors[colbars %in% lab] <- makeTransparent(cols[lab], alpha=alpha)
  }

  colors
}

makeScale_Show <- function(n) {
  scale <- as.integer(n/4)
  if(scale < 1000 && scale >= 100) {
    round(scale / 100) * 100
  } else if(scale >= 1000 && scale < 10000) {
    round(scale / 1000) * 1000
  } else if(scale >= 10000) {
    round(scale / 5000) * 5000
  } else {
    50
  }
}

makeLabelsColors <- function(opt, name) {
  if(is.na(opt$labels)) {
    labels <- gsub(sprintf(".*/|%s.*", opt$pattern), "", dir(opt$directory, pattern=opt$pattern, full.names=T))
  } else {
    labels <- unlist(strsplit(opt$labels, ","))
    label.check <- rep(FALSE, length(labels))
    names(label.check) <- labels
    Files <- dir(opt$directory, pattern=opt$pattern, full.names=T)
    for(lab in labels) {
      if(length(Files) == length(labels)) {
        if(any(grepl(lab, Files))) label.check[lab] <- TRUE
      } else if(file.exists(sprintf("%s/%s_tracking.RData", opt$directory, name))) {
        load(sprintf("%s/%s_tracking.RData", opt$directory, name))
        if(any(grepl(lab, files))) label.check[lab] <- TRUE
      }
    }
    if(!all(label.check)) {
      warning(sprintf("Invalid labels: %s", opt$labels))
      labels <- gsub(sprintf(".*/|%s.*", opt$pattern), "", dir(opt$directory, pattern=opt$pattern, full.names=T))
      warning(sprintf("The default labels will be used: %s", paste0(labels, collapse=",")))
    }
  }

  if(is.na(opt$colors)) {
    colors <- makeColors(dir(opt$directory, pattern=opt$pattern, full.names=T), labels, sep=opt$colorPattern, alpha=opt$color_transparent)
  } else {
    colors <- unlist(strsplit(opt$colors, ","))
    if(length(colors) != length(labels)) {
      colors <- makeColors(dir(opt$directory, pattern=opt$pattern, full.names=T), labels, sep=opt$colorPattern, alpha=opt$color_transparent)
    }
  }

  if(length(unique(labels)) != length(labels)){
    stop("Must have the unique labels for all tracks")
  }

  if(length(colors) != length(labels)){
    warning("Number of colors different from the number of labels")
    if(length(colors) > length(labels)) colors <- colors[1:length(labels)]
    if(length(colors) < length(labels)) colors <- rep(colors, ceiling(length(labels)/length(colors)))[1:length(labels)]
  }

  list(labels=labels, colors=colors)
}
##########################################################################################

###############################
local({
  r <- getOption("repos")
  r["CRAN"] <- "http://cran.cnr.berkeley.edu/"
  options(repos = r)
})

tryCatch(
  library("optparse"),
  error=function(e) {
    print(e)
    install.packages("optparse", lib=.libPaths()[1L], quiet=F)
  },
  finally=library("optparse")
)

option_list = list(
  make_option(c("-d", "--directory"), type="character", default=NULL, help="To specify a directory which stores BEDGRAPH files. Default: NULL. Required.", metavar="character"),
  make_option(c("-o", "--out_directory"), type="character", default=NA, help="To specify an output directory. Default: the same with directory.", metavar="character"),
  make_option(c("-m", "--mode"), type="character", default="single", help="To specify a way for single task or a batch of tasks (single or batch). Default: single.", metavar="character"),
  make_option(c("-f", "--filename"), type="character", default=NULL, help="To specify a filenames to store a series of genomic coordinates, such as: 'chrom start end...' by TAB. Default: NULL.", metavar="character"),
  make_option(c("-c", "--chrom"), type="character", default=NULL, help="To specify a chromosome name. Default: NULL.", metavar="character"),
  make_option(c("-s", "--start"), type="integer", default=NULL, help="To specify a start of genomic coordinate. Default: NULL.", metavar="character"),
  make_option(c("-e", "--end"), type="integer", default=NULL, help="To specify an end of genomic coordinate. Default: NULL.", metavar="character"),
  make_option(c("-p", "--pattern"), type="character", default="bdg", help="To specify a string pattern embedding in file names of BEDGRAPH files. Default: bdg.", metavar="character"),
  make_option(c("-n", "--name"), type="character", default=NA, help="To specify a string pattern in the output figures. Default: Region.chrom_start_end.", metavar="character"),
  make_option(c("--show_ylim"), type="character", default=NA, help="To specify whether to show ylim. Default: TRUE for each.", metavar="character"),
  make_option(c("--is_commmon_ylim"), type="logical", default=FALSE, help="To specify whether to draw the same scale of ylim. Default: FALSE.", metavar="character"),
  make_option(c("--is_bigData"), type="logical", default=TRUE, help="To specify whether to use AWK mode. Default: TRUE.", metavar="character"),
  make_option(c("--layout_mode"), type="character", default="separate", help="To specify which layout mode will be used (speparate or collapse). Default: speparate.", metavar="character"),
  make_option(c("--scale_show"), type="integer", default=5000, help="To specify the length to show in visualization figure. Default: 5000 (that is 5kb).", metavar="character"),
  make_option(c("--cex"), type="integer", default=3.5, help="To specify the size to show labels. Default: 3.5.", metavar="character"),
  make_option(c("--figure_width"), type="integer", default=2500, help="To specify the width of figure. Default: 2500.", metavar="character"),
  make_option(c("--figure_height"), type="integer", default=600, help="To specify the height of figure. Default: 600.", metavar="character"),
  make_option(c("--is_smooth"), type="logical", default=FALSE, help="To specify whether to smooth read signals. Default: FALSE.", metavar="character"),
  make_option(c("--labels"), type="character", default=NA, help="To specify the labels to show; format: lab1,lab2,...labN. Default: the labels are splitted by 'PATTEN'.", metavar="character"),
  make_option(c("--colors"), type="character", default=NA, help="To specify the colors corresponding to labels; format: color1,color2,...colorN. Default: colors will be grouped by labels (split by 'rep').", metavar="character"),
  make_option(c("--species"), type="character", default="mm10", help="To specify the species name to show. Default: mm10.", metavar="character"),
  make_option(c("--colorPattern"), type="character", default=".*/|rep.*", help="To specify a pattern to split file names to group them for showing. Default:'.*/|rep.*'.", metavar="character"),
  make_option(c("--color_transparent"), type="double", default=1, help="To specify the degree of transparent color between 0 (transparent) and 1. Default: 1.", metavar="character"),
  make_option(c("--layout_width"), type="character", default="1:10", help="To specify the ratio of the label panel over the figure panel. Default: '1:10'.", metavar="character"),
  make_option(c("--scale_signal"), type="integer", default=1, help="To specify an integer factor to scale the read signal data. Default: '1:10'.", metavar="character"),
  make_option(c("--layout_config"), type="character", default=NA, help="To specify the height for each track. Default: 3 for each.", metavar="character")
);

opt_parser = OptionParser(option_list=option_list);
opt = parse_args(opt_parser);
### configuration
if(is.null(opt$directory)) {
  stop("Must specifiy a directory which stores BEDGRAPH files.")
}

dirName <- opt$directory
trim_pattern <- opt$pattern
pattern <- opt$pattern

if(is.na(opt$out_directory)) {
  outdir <- dirName
} else {
  outdir <- opt$out_directory
  if(!dir.exists(outdir)) dir.create(outdir)
}

if(is.na(opt$show_ylim)) show.ylim <- TRUE else {
  show.ylim <- as.logical(unlist(strsplit(opt$show_ylim, ",")))
}
is.bigDat <- as.logical(opt$is_bigData)
if(is.bigDat) warning("To extract data from BEDGRAPH files based on AWK environment")
is.commmon <- as.logical(opt$is_commmon_ylim)
cex <- opt$cex
scale.show <- opt$scale_show
fwidth <- opt$figure_width
fheight <- opt$figure_height
is.smooth <- as.logical(opt$is_smooth)
layout.mode <- opt$layout_mode
species <- opt$species
layout.width <- as.double(unlist(strsplit(opt$layout_width, ":")))
scale.signal <- as.double(opt$scale_signal)

if(opt$mode == "single") {
  if(is.null(opt$chrom) || is.null(opt$chrom) || is.null(opt$end)) stop ("Must specify a valid genomic coordinate")
  chrom <- opt$chrom
  start <- as.double(opt$start)
  end <- as.double(opt$end)

  if(!is.na(opt$name)) {
    name <- opt$name
  } else {
    name <- sprintf("Region.%s_%s_%s", chrom, start, end)
  }

  labCol.list <- makeLabelsColors(opt, name)
  labels <- labCol.list$labels
  colors <- labCol.list$colors
  if(is.na(opt$layout_config)) layout.config <- rep(3,length(labels)) else {
    layout.config <- as.integer(unlist(strsplit(opt$layout_config, ",")))
  }

  # to draw figure
  .plot.visual(dirName=dirName, outdir=outdir, chrom=chrom, start=start, end=end, show.ylim=show.ylim, layout.config=layout.config, labels=labels, is.bigDat=is.bigDat, pattern=pattern, cex=cex, scale.show=scale.show,
    name=name, colors=colors, is.commmon=is.commmon, fwidth=fwidth, fheight=fheight, is.smooth=is.smooth, layout.mode=layout.mode, species=species, layout.width=layout.width, scale.signal=scale.signal)
} else if(opt$mode == "batch") {
  if(!file.exists(opt$filename)) stop(sprintf("Invalid file name: %s", opt$filename))
  warning("By default, there is a file header: chrom start end ...")
  regions <- read.table(opt$filename, header=T)
  if(ncol(regions)>=4) warning("By default, the 4th column will be uased as a part of the output file name.")

  for(i in 1:nrow(regions)) {
    chrom <- paste0(regions[i,1])
    start <- as.double(regions[i,2])
    end <- as.double(regions[i,3])
    if(ncol(regions)>=4) {
      name <- paste0(regions[i,4])
    } else {
      name <- sprintf("Region.%s_%s_%s", chrom, start, end)
    }

    var.logical <- file.exists(sprintf("%s/%s_tracking.RData", dirName, name)) ||
      length(dir(dirName, pattern=pattern, full.names=T)) > 0

    # to draw figure
    if(var.logical) {
      labCol.list <- makeLabelsColors(opt, name)
      labels <- labCol.list$labels
      colors <- labCol.list$colors
      if(is.na(opt$layout_config)) layout.config <- rep(3,length(labels)) else {
        layout.config <- as.integer(unlist(strsplit(opt$layout_config, ",")))
      }

      scale.show <- makeScale_Show(end - start)
      warning(sprintf("The reset scale showing in figure when using a BATCH mode: %s", scale.show))

      .plot.visual(dirName=dirName, outdir=outdir, chrom=chrom, start=start, end=end, show.ylim=show.ylim, layout.config=layout.config, labels=labels, is.bigDat=is.bigDat, pattern=pattern, cex=cex, scale.show=scale.show,
        name=name, colors=colors, is.commmon=is.commmon, fwidth=fwidth, fheight=fheight, is.smooth=is.smooth, layout.mode=layout.mode, species=species, layout.width=layout.width, scale.signal=scale.signal)
    } else {
      next
    }
  }
}

for(d in dir(path=dirName, pattern="tmp_", full.name=F)) {
  unlink(d, recursive=TRUE, force=TRUE)
}


setwd("C:/MasseyOffice1/Research/R-Script2019/")
rm(list=ls())

detachAllPackages <- function() {

  basic.packages <- c("package:ggplot2","package:lattice","package:caret","package:foreach","package:iterators","package:parallel","package:doParallel","package:reshape","package:plyr","package:utils","package:stats","package:graphics","package:grDevices","package:utils","package:datasets","package:methods","package:base")

  package.list <- search()[ifelse(unlist(gregexpr("package:",search()))==1,TRUE,FALSE)]

  package.list <- setdiff(package.list,basic.packages)

  if (length(package.list)>0)  for (package in package.list) detach(package, character.only=TRUE)

}

library(caret)
library(doParallel)
cl <- makeCluster(3)
registerDoParallel(cl)
library(reshape)
library(plyr)
library(utils)
library(dplyr)
set.seed(7)

control <- trainControl(method="LOOCV")
name_fmask='WithMasking'
metric <- "Accuracy"

library(readxl)
ML_LS8_S1_LEE_S2_2019_5class_surveyV2 <- read_excel("C:/MasseyOffice1/Research/R-Script2019/ML_LS8_S1_LEE_S2_2019_5class_surveyV2.xlsx")

ML_LS8_S1_LEE_S2_2019_5class_surveyV2$Phase <- as.factor(ML_LS8_S1_LEE_S2_2019_5class_surveyV2$Phase)
set.seed(7)
#
# NR <- filter(ML_LS8_S1_LEE_S2_2019_5class_surveyV2, Phase == "1")
# VEG <- filter(ML_LS8_S1_LEE_S2_2019_5class_surveyV2, Phase == "2")
# REPR <- filter(ML_LS8_S1_LEE_S2_2019_5class_surveyV2, Phase == "3")
# RIPE <- filter(ML_LS8_S1_LEE_S2_2019_5class_surveyV2, Phase == "4")
#
# numberofrows <- c(nrow(NR),nrow(VEG),nrow(REPR),nrow(RIPE))
# minrows <- min(numberofrows)
# index <- sample(1:nrow(NR), minrows)
# NR_sample <- NR[index, ]
# index <- sample(1:nrow(VEG), minrows)
# VEG_sample <- VEG[index, ]
# index <- sample(1:nrow(REPR), minrows)
# REPR_sample <- REPR[index, ]
# index <- sample(1:nrow(RIPE), minrows)
# RIPE_sample <- RIPE[index, ]
#
# ML_LS8_S1_LEE_S2_2019_5class_surveyV2_sampling_down <- rbind(NR_sample, VEG_sample,REPR_sample,RIPE_sample)
# ML_LS8_S1_LEE_S2_2019_5class_surveyV2_sampling_down <-  ML_LS8_S1_LEE_S2_2019_5class_surveyV2_sampling_down[sample(1:nrow(ML_LS8_S1_LEE_S2_2019_5class_surveyV2_sampling_down)), ]
ML_LS8_S1_LEE_S2_2019_5class_surveyV2_sampling_down <- ML_LS8_S1_LEE_S2_2019_5class_surveyV2
rice_fmask <- ML_LS8_S1_LEE_S2_2019_5class_surveyV2_sampling_down
trainIndex <- createDataPartition(rice_fmask$Phase, p=0.7, list=FALSE)
train.data <- rice_fmask[ trainIndex,]
test.data <- rice_fmask[-trainIndex,]
# write.csv(train.data,file="ML_LS8_S1_LEE_S2_2019_5class_surveyV2 train data ML.csv")
# write.csv(test.data,file="ML_LS8_S1_LEE_S2_2019_5class_surveyV2 test data ML.csv")

rice <-ML_LS8_S1_LEE_S2_2019_5class_surveyV2_sampling_down
rice$PHASE <- factor(rice$Phase)
print(summary(rice))

allModelsList <- c("Phase ~ S2_B02 + S2_B03 + S2_B04 + S2_B05 + S2_B06 + S2_B07 + S2_B08 + S2_B11 + S2_B12 + S2_B8A",
                   "Phase ~ NDVI"

)
library(stringr)

NoOfCoef <- str_count(allModelsList,"\\+") + 1
#
#
# control <- rfeControl(functions=rfFuncs, method="cv", number=10)
# # run the RFE algorithm
# results <- rfe(train.data[,5:28], train.data[[29]], sizes=c(1:24), rfeControl=control)
# # summarize the results
# print(results)
# print(results$optVariables)
# # list the chosen features
# predictors(results)
# # plot the results
# plot(results, type=c("g", "o"))

#rice_all_indexes <- rice[,c("Blue","Green","Red","NIR","SWIR1","SWIR2")]

# for (limit in c(0.4, 0.5, 0.6, 0.7, 0.8, 0.9)) {
#   x05 <- findCorrelation(rice_all_indexes, cutoff = limit, exact = FALSE)
#   formula05 <- rice_all_indexes[,-x05]
#   formula05_colnames <- colnames(formula05)
#   formula05_colnumber <- length(formula05_colnames)
#   formula05List <- gsub("~  [+]","~", paste(c("Phase ~ ", formula05_colnames), collapse=" + "))
#   if (formula05List %in% allModelsList==FALSE){
#     allModelsList <- append(allModelsList,formula05List)
#     NoOfCoef <- append(NoOfCoef,formula05_colnumber)
#   }
#
# }

allModelsList

#Leave One Out Cross Validation
name_data='LOOCV'

#model <- names(getModelInfo())
#model_filter <- c('AdaBag','amdai','avNNet','bagFDA','bagFDAGCV','bayesglm','BstLm','bstSm','bstTree','C5.0','C5.0Rules','C5.0Tree','cforest','CSimca','ctree','ctree2','dnn','earth','elm','fda','gam','gamLoess','gamSpline','gbm','gcvEarth','glmnet','hda','hdda','hdrda','J48','JRip','kernelpls','kknn','knn','lda','lda2','Linda','LMT','loclda','LogitBoost','lvq','mda','Mlda','mlpSGD','monmlp','multinom','naive_bayes','nnet','OneR','ownn','pam','parRF','PART','partDSA','pcaNNet','pda','PenalizedLDA','plr','pls','polr','qda','QdaCov','rda','regLogistic','rf','RFlda','rlda','rmda','rpart','rpart1SE','rpart2','rpartScore','rrlda','RSimca','sda','sdwd','simpls','snn','sparseLDA','spls','stepLDA','stepQDA','svmLinear','svmLinear2','svmLinear3','svmPoly','svmRadial','svmRadialCost','svmRadialSigma','treebag','vglmAdjCat','widekernelpls','wsrf')
#model_filter <- c('amdai','avNNet','bagFDA','bagFDAGCV','bayesglm','BstLm','bstSm','bstTree','C5.0','C5.0Rules','C5.0Tree','cforest','CSimca','ctree','ctree2','dnn','earth','elm','fda','gam','gamLoess','gamSpline','gbm','gcvEarth','glmnet','hda','hdda','hdrda','J48','JRip','kernelpls','kknn','knn','lda','lda2','Linda','LMT','loclda','LogitBoost','lvq','mda','Mlda','mlpSGD','monmlp','multinom','naive_bayes','nnet','OneR','ownn','pam','parRF','PART','partDSA','pcaNNet','pda','PenalizedLDA','plr','pls','polr','qda','QdaCov','rda','regLogistic','rf','RFlda','rlda','rmda','rpart','rpart1SE','rpart2','rpartScore','rrlda','RSimca','sda','sdwd','simpls','snn','sparseLDA','spls','stepLDA','stepQDA','svmLinear','svmLinear2','svmLinear3','svmPoly','svmRadial','svmRadialCost','svmRadialSigma','treebag','vglmAdjCat','widekernelpls','wsrf')
#model_filter <- c('avNNet','bagFDA','bagFDAGCV','bayesglm','BstLm','bstSm','bstTree','C5.0','C5.0Rules','C5.0Tree','cforest','CSimca','ctree','ctree2','dnn','earth','elm','fda','gam','gamLoess','gamSpline','gbm','gcvEarth','glmnet','hda','hdda','hdrda','J48','JRip','kernelpls','kknn','knn','lda','lda2','Linda','LMT','loclda','LogitBoost','lvq','mda','Mlda','mlpSGD','monmlp','multinom','naive_bayes','nnet','OneR','ownn','pam','parRF','PART','partDSA','pcaNNet','pda','PenalizedLDA','plr','pls','polr','qda','QdaCov','rda','regLogistic','rf','RFlda','rlda','rmda','rpart','rpart1SE','rpart2','rpartScore','rrlda','RSimca','sda','sdwd','simpls','snn','sparseLDA','spls','stepLDA','stepQDA','svmLinear','svmLinear2','svmLinear3','svmPoly','svmRadial','svmRadialCost','svmRadialSigma','treebag','vglmAdjCat','widekernelpls','wsrf')

model_filter <- c('C5.0','C5.0Rules','C5.0Tree','C5.0Cost','nnet','fda','rf','svmLinear','svmPoly','svmRadial')
model_filter <- c('nnet','rf','svmLinear','svmPoly','svmRadial')

model_filter <- c('svmRadial','rf')

mainDir <- paste("C:/MasseyOffice1/Research/R-Script2019/ML_LS8_S1_LEE_S2_2019_5class_surveyV2/",collapse = "",sep = "")
if (file.exists(mainDir)==FALSE) {
  dir.create(file.path(mainDir), showWarnings = FALSE)
}
for (model_ML in model_filter) {

  subDir <- model_ML
  dir.create(file.path(mainDir, subDir), showWarnings = FALSE)
  setwd(file.path(mainDir, subDir))

  print (model_ML)
  set.seed(7)
  detachAllPackages()

  for(i_formula in 1:length(allModelsList)) {
    formula_current <- as.formula(allModelsList[[i_formula]])

    for(i_preName in 1:1) {

      if (i_preName==1) {
        preName_current ='noProc'
        preName_current_string <- "noProc"
      }
      if (i_preName==2) {
        preName_current =c('center','scale')
        preName_current_string <- "center_scale"
      }
      if (i_preName==3) {
        preName_current =c('corr')
        preName_current_string <- "corr"
      }
      if (i_preName==4) {
        preName_current =c('pca')
        preName_current_string <- "pca"
      }
      if (i_preName==5) {
        preName_current =c("BoxCox", "center", "scale", "pca")
        preName_current_string <- "BoxCox_center_scale_pca"
      }
      numbering <- sprintf("%04d", i_formula)
      filename <- paste(name_fmask,"_",name_data,"_", "ML_LS8_S1_LEE_S2_2019_5class_surveyV2_",model_ML,"_",preName_current_string,"_",numbering,".csv", sep="")
      if (file.exists(filename)) {
        next
      }
      print(paste(model_ML,i_formula,format(Sys.time(), "%a %b %d %X %Y"),as.character(formula_current[3]),sep=" | "))

      if (model_ML=="fda") {
        TuneGrid <- expand.grid(.degree = c(1,2,3),
                                .nprune = (1:100) * 2)
      } else if (model_ML=="nnet") {
        TuneGrid <-  expand.grid(size = seq(from = 1, to = 10, by = 1),decay = c(0, 0.0001,0.001,0.01,0.1))
      } else  if (model_ML=="rf") {
        TuneGrid <-  expand.grid(mtry  = seq(from = 1, to = 20, by = 1))
      } else  if (model_ML=="svmLinear") {
        TuneGrid <-  expand.grid(C= 2^c(0:10))
      } else  if (model_ML=="svmPoly") {
        TuneGrid <- expand.grid(degree=(1:5), scale=c(0.001,0.01,0.1), C=c(0.01,0.1,1,3,5,10,20))
      }else  if (model_ML=="svmRadial") {
        TuneGrid <- expand.grid(sigma= 2^c(-25, -20, -15,-10, -5, 0), C= 2^c(0:10))
      }

      model_other <-  c('nnet','fda','rf','svmLinear','svmPoly','svmRadial')
      if (any(model_other == model_ML) ) {
        if (preName_current=="noProc") {
          allModelsResults <- train(formula_current, data=train.data, tuneGrid = TuneGrid, method=model_ML, metric=metric, trControl=control)
        } else {
          allModelsResults <- train(formula_current, data=train.data, tuneGrid = TuneGrid, preProcess = c(preName_current), method=model_ML, metric=metric, trControl=control)
        }
      } else {
        if (preName_current=="noProc") {
          allModelsResults <- train(formula_current, data=train.data, method=model_ML, metric=metric, trControl=control)
        } else {
          allModelsResults <- train(formula_current, data=train.data, preProcess = c(preName_current), method=model_ML, metric=metric, trControl=control)
        }
      }
      filename_save <- paste(name_fmask,"_",name_data,"_", "ML_LS8_S1_LEE_S2_2019_5class_surveyV2_",model_ML,"_",preName_current_string,"_",numbering,".rds", sep="")
      saveRDS(allModelsResults, filename_save)
      model_varimp <-  c('nnet','fda','rf')
      if (any(model_varimp == model_ML) ) {
        allModelsResults_varImp <- varImp(allModelsResults)
        allModelsResults_varImp_1 <- allModelsResults_varImp$importance
        filename_varImp <- paste("varImp_",name_fmask,"_",name_data,"_", "ML_LS8_S1_LEE_S2_2019_5class_surveyV2_",model_ML,"_",preName_current_string,"_",numbering,"_all.csv", sep="")
        write.csv(allModelsResults_varImp_1, file = filename_varImp)
      }
      allModelsResults_predictions <- predict(allModelsResults,test.data)

      allModelsResults_confusionMatrix <- confusionMatrix(allModelsResults_predictions, test.data$Phase)

      filename_rfc_overall <- paste("ConMat_overall_",name_fmask,"_",name_data,"_", "ML_LS8_S1_LEE_S2_2019_5class_surveyV2_",model_ML,"_",preName_current_string,"_",numbering,".csv", sep="")
      filename_rfc_table <- paste("ConMat_table_",name_fmask,"_",name_data,"_", "ML_LS8_S1_LEE_S2_2019_5class_surveyV2_",model_ML,"_",preName_current_string,"_",numbering,".csv", sep="")
      filename_rfc_class <- paste("ConMat_class_",name_fmask,"_",name_data,"_", "ML_LS8_S1_LEE_S2_2019_5class_surveyV2_",model_ML,"_",preName_current_string,"_",numbering,".csv", sep="")

      write.csv(allModelsResults_confusionMatrix$table, file = filename_rfc_table)
      write.csv(allModelsResults_confusionMatrix$overall, file = filename_rfc_overall)
      write.csv(allModelsResults_confusionMatrix$byClass, file = filename_rfc_class)

      dfTest  <- as.data.frame(allModelsResults_confusionMatrix$overall)

      y =paste("test.",names(allModelsResults_confusionMatrix$overall),sep="")

      rownames(dfTest) <- y

      #CM
      dfTest_CM  <- as.data.frame(allModelsResults_confusionMatrix$byClass)

      dfTest_CM <- melt(allModelsResults_confusionMatrix$byClass)
      y <- paste(dfTest_CM[,1],dfTest_CM[,2],sep='.')
      y <- gsub(": ", ".", y)

      rownames(dfTest_CM) <- paste("testCM.",y,sep="")
      dfTest_CM$X1 <- NULL
      dfTest_CM$X2 <- NULL

      dfCoefNum   <- as.data.frame(allModelsResults["results"])

      dfLengthData_train <- as.data.frame(c(nrow(train.data)))
      colnames(dfLengthData_train) <- c("Count.Train")

      dfLengthData_test <- as.data.frame(c(nrow(test.data)))
      colnames(dfLengthData_test) <- c("Count.Test")
      names_formula <- paste(as.character(formula_current)[c(2,1,3)], collapse = " ")
      NoOfCoef_current <- NoOfCoef[[i_formula]]
      results <- data.frame( model = names_formula, Method=model_ML,
                             dfLengthData_train,
                             dfLengthData_test,
                             NoOfCoef = NoOfCoef_current,
                             preProc=preName_current_string,
                             dfCoefNum,
                             t(dfTest),
                             t(dfTest_CM),
                             stringsAsFactors=FALSE
      )

      write.csv(results, file = filename)

      model_varimp <-  c('nnet','fda','rf')
      if (any(model_varimp == model_ML) ) {
        allModelsResults_varImp <- varImp(allModelsResults)
        allModelsResults_varImp_1 <- allModelsResults_varImp$importance
        filename_varImp <- paste("varImp_",name_fmask,"_",name_data,"_", "ML_LS8_S1_LEE_S2_2019_5class_surveyV2_",model_ML,"_",preName_current_string,".csv", sep="")
        write.csv(allModelsResults_varImp_1, file = filename_varImp)
      }

    }
  }
}

setwd("C:/MasseyOffice1/Research/R-Script2019/")


#' plot a heatmap of number of cells per metacell and metadata factor (e.g. patient, condition, sample etc.)
#'
#' @param mc_id id of metacell object ina scdb
#' @param mat_id matrix object to us (default is the mc_id - assuming they use the same ID), if some cells in the mc object are missing from the matrix, the function will generate an error
#' @param fig_fn file name for the figure. Color bars are generated in separate files with names starting with fig_fn. If null figures will be created under <mc_id>.mc_comp_by_<meta_field> directory, with name composed of the plotting parameters.
#' @param meta_field metdata column name used to break down cells on metacells
#' @param meta_field_annotate_by metadata column names describing the meta_field (should be a one-to-one match between each meta_field_value and the values in these columns). Expecting a yaml parameter named mcp_metadata_annot_colors which is a list mapping meta_field_annotate_by values to list of value-color mapping.
#' @param meta_field_min_count Minimal number of cells per meta_field value
#' @param norm_by_factor Normalize cell counts by factor (default) or by metacell
#' @param hclust_mcs If true, re-order metacells by clustering the heatmap. Otherwise, use original metacells ordering (default)
#' @param filter_values vector of meta_field values to display
#' @param hclust_values Hierarchical cluster of value in value-mc matrix
#' @param custom_made_fields project specific metadata fields, that the code handles specifically.
#'
#' @export
#'
mcell_mc_plot_by_factor = function(mc_id, meta_field, mat_id = mc_id, fig_fn = NULL, meta_field_annotate_by=NULL, meta_field_min_count=0, norm_by_factor=T, hclust_mcs=F, ord_mcs=NULL, filter_values=NULL, hclust_values=T, custom_made_fields=NULL)
{
	mcp_heatmap_width = get_param("mcp_heatmap_width")
	mcp_heatmap_shades = get_param("mcp_heatmap_seq_shades")
   mcp_metadata_annot_colors = get_param("mcp_metadata_annot_colors")
   mcp_heatmap_text_cex = get_param("mcp_heatmap_text_cex")

	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
	  stop(sprintf("undefined metacell object when trying to plot metacells by %s, id = %s", meta_field , mc_id))
	}

	scmat = scdb_mat(mat_id)
	if(is.null(scmat)) {
		stop(sprintf("undefined mat object when trying to plot metacells by %s, id = %s", meta_field, mat_id))
	}
	if(length(intersect(names(mc@mc), colnames(scmat@mat))) != length(names(mc@mc))) {
		stop("cells in meta cell are missing from provided matrix in mcell_mc_plot_by_factor")
	}

	if (!(meta_field %in% colnames(scmat@cell_metadata))) {
		stop(sprintf("Column named %s not found in metadata of mat_id %s", meta_field, mat_id))
	}
	mc_t = table(mc@mc, scmat@cell_metadata[names(mc@mc), meta_field])
	mc_t = mc_t[, colSums(mc_t) >= meta_field_min_count]
	if (!is.null(filter_values)) {
		diff_values = setdiff(filter_values, colnames(mc_t))
		if (length(diff_values) > 0) {
			stop(sprintf("Missing values (%s) in mcell_mc_plot_by_factor", past0(diff_values, collapse=", ")))
		}
		mc_t = mc_t[, filter_values]
	}
	if (ncol(mc_t) == 0) {
		stop(sprintf("nothing to plot in mcell_mc_plot_by_factor by %s when requiring at least %d cells %s for factor %s", meta_field, meta_field_min_count, ifelse(is.null(filter_values), "", paste0(" and these values: ", paste0(filter_values, collapse=", ")))))
	}

	if (norm_by_factor) {
		mc_t_n = t(t(mc_t) / colSums(mc_t))
	}
	else {
		mc_t_n = mc_t / rowSums(mc_t)
	}

	if(is.null(fig_fn)) {
		fig_fn = scfigs_fn(mc_id,
											 sprintf("mc_comp_by_%d_%s_norm%s%s", ncol(mc_t), meta_field, ifelse(norm_by_factor, meta_field, "MC"), ifelse(hclust_mcs, "_hclust_mcs", "")),
											 sprintf("%s/%s.mc_comp_by_%s", .scfigs_base, mc_id, meta_field))
	}

	.plot_start(fig_fn, w=mcp_heatmap_width,h=300 + ncol(mc_t) * 15)

	n_ann = 1 + ifelse(is.null(meta_field_annotate_by), 0, length(meta_field_annotate_by)) + length(custom_made_fields)
  layout(matrix(c(rep(n_ann+3, n_ann), n_ann+1, 1:n_ann, n_ann+2), nrow=2, byrow=T), heights = c(2, ncol(mc_t)), widths = c(rep(1, n_ann), n_ann * 16))

	par(mar=c(1,1,1,10))

	chc = hclust(dist(t(mc_t_n)), method="ward.D2")
	if(!is.null(ord_mcs)) {
		rord = ord_mcs
	} else if(hclust_mcs) {
		rhc = hclust(dist(mc_t_n), method="ward.D2")
		rord = rhc$order
	} else {
		rord = 1:nrow(mc_t_n)
	}

	if (hclust_values) {
		cord = chc$order
	}
	else {
		cord = 1:ncol(mc_t_n)
	}

	mf_ann = data.frame(row.names=colnames(mc_t), n_cells=colSums(mc_t))
	if (!is.null(meta_field_annotate_by)) {
		missing_fields = setdiff(meta_field_annotate_by, colnames(scmat@cell_metadata))
		if (length(missing_fields) > 0) {
			stop(sprintf("Columns %s not found in metadata of mat_id %s", paste0(missing_fields, collapse=", "), mat_id))
		}
	  uniq_md = unique(scmat@cell_metadata[names(mc@mc), c(meta_field, meta_field_annotate_by, custom_made_fields)])
	  if (nrow(uniq_md) != length(unique(uniq_md[, meta_field]))) {
	    stop(sprintf("annotation fields (%s) are not unique for metadata field %s", paste0(meta_field_annotate_by, collapse=", "), meta_field))
	  }
	  rownames(uniq_md) = uniq_md[, meta_field]
	  mf_ann = cbind(mf_ann, uniq_md[rownames(mf_ann), c(meta_field_annotate_by, custom_made_fields)])
	  mf_ann[is.na(mf_ann)] = "N/A"
	  mf_ann[mf_ann == ""] = "N/A"

	  mf_ann = mf_ann[cord, ]
	}

	par(mar=c(10,0.5,0.5,0.5))

	for (annot in meta_field_annotate_by) {
	  annot_vals = unlist(mcp_metadata_annot_colors[[annot]])
	  image(t(1:nrow(mf_ann)), col=annot_vals[mf_ann[, annot]], xaxt='n', yaxt='n', xlab="", ylab="")
	  mtext(annot, 1, line=0.5, cex = mcp_heatmap_text_cex, las=2)
	}

	if ("Patient CD3+ % from CD45+" %in% custom_made_fields) {
		f_nm = "Patient CD3+ % from CD45+"
		image(t(as.numeric(mf_ann[, f_nm])), zlim=c(0, 100), col=colorRampPalette(RColorBrewer::brewer.pal(n=9, 'OrRd'))(101), xaxt='n', yaxt='n', xlab="", ylab="")
		mtext("% CD3", 1, line=0.5, cex = mcp_heatmap_text_cex, las=2)
	}

	n_cells_zlim = c(0, 100 * ceiling(max(mf_ann$n_cells)/100))
	par(mar=c(10,0.5,0.5,0.5))
	image(t(mf_ann$n_cells), zlim=n_cells_zlim, col=colorRampPalette(RColorBrewer::brewer.pal(n=9, 'Blues'))(101), xaxt='n', yaxt='n', xlab="", ylab="")
	mtext("#cells", 1, line=0.5, cex = mcp_heatmap_text_cex, las=2)

	par(mar=c(0.5, 0.5, 0.5, 20))
	image(as.matrix(1:nrow(mc_t)), col=mc@colors[rord], xaxt='n', yaxt='n', xlab="", ylab="")

	par(mar=c(10, 0.5, 0.5, 20))
	mc_t_n = mc_t_n[rord, cord]
	#mc_t_enr = mc_t_enr[, chc$order]

	max_p = ceiling(100 * quantile(mc_t_n, 0.99))/100
	image(pmin(mc_t_n, max_p), col=colorRampPalette(mcp_heatmap_shades)(101), zlim=c(0, max_p), xaxt='n', yaxt='n', xlab="", ylab="")
	mtext(text=rownames(mc_t_n), at=seq(0, 1, length=nrow(mc_t_n)), side=1, line=0.5, cex = mcp_heatmap_text_cex/2, las=2)
	mtext(colnames(mc_t_n), at=seq(0, 1, length=ncol(mc_t_n)), side=4, line=0.5, cex = mcp_heatmap_text_cex, las=2)
	abline(h=seq(0.5/ncol(mc_t_n), 1, by=1/(ncol(mc_t_n)-1)), col="grey80")

  dev.off()

	# plot color bars
	plot_color_bar(vals=seq(0, max_p, length=101), cols=colorRampPalette(mcp_heatmap_shades)(101), title="fraction", show_vals_ind=c(1, 101), fig_fn=gsub(".png", "_color_bar_main.png", fig_fn))

	plot_color_bar(vals=seq(n_cells_zlim[1], n_cells_zlim[2], length=101), cols=colorRampPalette(RColorBrewer::brewer.pal(n=9, 'Blues'))(101), title="# cells", show_vals_ind=c(1, 101), fig_fn=gsub(".png", "_color_bar_n_cells.png", fig_fn))

	if ("Patient CD3+ % from CD45+" %in% custom_made_fields) {
		plot_color_bar(vals=seq(0, 100, length=101), cols=colorRampPalette(RColorBrewer::brewer.pal(n=9, 'OrRd'))(101), title="% CD3", show_vals_ind=c(1, 101), fig_fn=gsub(".png", "_color_bar_frac_CD3.png", fig_fn))

	}
	plot_color_bar(vals=seq(n_cells_zlim[1], n_cells_zlim[2], length=101), cols=colorRampPalette(RColorBrewer::brewer.pal(n=9, 'Blues'))(101), title="# cells", show_vals_ind=c(1, 101), fig_fn=gsub(".png", "_color_bar_n_cells.png", fig_fn))

	for (annot in meta_field_annotate_by) {
		if (is.null(mcp_metadata_annot_colors[[annot]])) {
			stop(sprintf("Missing value-color mapping entry for %s in parameter mcp_metadata_annot_colors", annot))
		}
	  annot_vals = rev(unlist(mcp_metadata_annot_colors[[annot]]))
	  annot_vals = annot_vals[ names(annot_vals) %in% mf_ann[, annot] ]
	  plot_color_bar(vals=names(annot_vals), cols=annot_vals, title=annot, fig_fn=gsub(".png", paste0("_color_bar_", gsub(" ", "_", gsub("[%+]", "", annot)), ".png"), fig_fn))
	}

}


#############################################################################################################################
# Setup working directory

setwd("")
##############################################################################################################################
# Load libraries & functions . Check if packages were previously installed.

source("load_lib.r")
source("aux_mycosources.r")

##############################################################################################################################
# load data

res_tot=readRDS("data/res_tot_min5.rds")
res_data=readRDS("data/res_data_min5.rds")
res_names=readRDS("data/res_names_min5.rds")
res_pooled=readRDS("data/res_pooled_min5.rds")
plant_myco_db=readRDS("data/plant_myco_db.rds")
plant_myco_db_occ=readRDS("data/plant_myco_db_occ_tot.rds")

#########################################################################################################
# filtering by general final bibliometrics score

tresh=2.5

index=which(plant_myco_db$scoreGEN>tresh)

plant_myco_db_sel=plant_myco_db[index,]

names(plant_myco_db_sel)

#########################################################################################################
# create color palette

col.pal2=colorRampPalette(c("white", "yellow", "red"))(216)

for ( i in c(5:7,9:13) )  {

tdata=dcast(plant_myco_db_sel, mycotoxins  ~ plants ,
            value.var = as.character(names(plant_myco_db_sel)[i]),
            fun.aggregate = sum)

row.names(tdata)=tdata$mycotoxins

data=tdata[,2:length(tdata)]

######################################################################################
# Plotting heatmaps

pheatmap(data, color = col.pal2,cluster_rows = F,
         cluster_cols = F,
         angle_col=0,
         border_color="gray",
         cellwidth = 60, cellheight = 30,
         main=paste("Heatmap  of ",firstup(names(plant_myco_db_sel)[i])),
         fontsize_row=10,
         filename = paste0("Heatmap_",as.character(names(plant_myco_db_sel)[i]),".png")
         )
}

mycotoxs =unique(as.character(plant_myco_db_sel$mycotoxins))

for ( j in 1:length(mycotoxs)) {

  data=subset(plant_myco_db_sel,mycotoxins==mycotoxs[j])[,c(1,5:7,9:12)]
  row.names(data)=data$plants
  data=data[,2:length(data)]
  pheatmap(data, color = col.pal2,cluster_rows = F,
           cluster_cols = F,
           angle_col=0,
           border_color="gray",
           cellwidth = 60, cellheight = 30,
           main=paste("Heatmap  of ",as.character(mycotoxs[j])),
           fontsize=8,
           height=3,
           filename = paste0("Heatmap_",as.character(mycotoxs[j]),".png")
  )
}

######################################################################################
# Plotting distrib fits

plant_myco_db_sel$check_names=unlist(res_names[index])
plant_myco_db_sel[,c(1:2,14)] # check only
res_dists=list()
res_dists_names=list()
res_summary=list()

z=1

for ( i in index) {

x=as.numeric(res_pooled[[i]])

outfilepdf=gsub(" ","_",paste0(as.character(res_names[i]),"_dists.pdf"))
outfilepng=gsub(" ","_",paste0(as.character(res_names[i]),"_dists.png"))

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

dists=list()
j=1
idlist=c(NULL)
fw <- try(fitdist(x,"weibull"))
if (!grepl("Error",fw)) {dists[[j]]=fw;idlist=c("weibull");j=j+1}

fg <- try(fitdist(x,"gamma"))
if (!grepl("Error",fg)) {dists[[j]]=fg;idlist=c(idlist,"gamma"); j=j+1 }

fln <- try(fitdist(x,"lnorm"))
if (!grepl("Error",fln)) {dists[[j]]=fln;idlist=c(idlist,"lognormal");j=j+1 }

flnor <- try(fitdist(x,"norm"))
if (!grepl("Error",flnor)) {dists[[j]]=flnor;idlist=c(idlist,"normal") }

ds=denscomp(dists,legendtext=eval(idlist),plotstyle = "ggplot")
qq=qqcomp(dists,legendtext=eval(idlist),plotstyle = "ggplot")
cd=cdfcomp(dists,legendtext=eval(idlist),plotstyle = "ggplot")
pp=ppcomp(dists,legendtext=eval(idlist),plotstyle = "ggplot")

out=ggarrange(ds, qq, cd,pp + rremove("x.text"), ncol = 2, nrow = 2)

options(warn=0)

#ggsave(outfilepdf,plot=out, width = 8, height = 7,device="pdf")
#ggsave(outfilepng,plot=out, width = 8, height = 7,device="png")

#######################################################
res_dists_names[[z]]=idlist
res_dists[[z]]=dists
res_summary[[z]]=summary_large(x)
z=z+1
}

###########################################################################################################################################
# WRITE DATA FIT STATITICS AND SCORES

b=melt(unlist(lapply(res_dists,length)))
b$names=rownames(b)

res=list()

for ( i in 1:nrow(b)) {res[[i]]=rep(b$names[i],b$value[i])}

names_dist=unlist(res)
names(res_dists)=NULL

list_results=do.call(c, res_dists)
list_results_type=do.call(c,res_dists_names)

resdf=data.frame(plant_myco_db_sel[as.numeric(c(names_dist)),c("check_names")],
                 c(list_results_type),
                 do.call("rbind",lapply(list_results,function(x) names(x$estimate))),
                 do.call("rbind",lapply(list_results,function(x) as.numeric(x$estimate))),
                 do.call("rbind",lapply(list_results,function(x) c(x$aic,x$bic)))
          )

names(resdf)=c("Planttox","Type_distrib","Namepar_1","Namepar_2","Valpar_1","Valpar_2","AIC","BIC")

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

table_describe=data.frame(PlantTox=unlist(res_names[index]),do.call("rbind",res_summary))

file.remove("data/PlantTox_select_score.xls")
XLConnect::writeWorksheetToFile("data/PlantTox_select_score.xls",plant_myco_db_sel,"data_bib_scores")
XLConnect::writeWorksheetToFile("data/PlantTox_select_score.xls",resdf,"Fit stasts")
XLConnect::writeWorksheetToFile("data/PlantTox_select_score.xls",table_describe,"data summaries")
file.remove("data/PlantTox_full_score.xls")
XLConnect::writeWorksheetToFile("data/PlantTox_full_score.xls",plant_myco_db,"data_bib_scores fiveD")

plant_sel=c("barley","cereals","maize","oat","rice","rye","wheat")

png("images/boxplot_occurence_score_GEN.png")
bwplot(scoreGEN~plants, data =plant_myco_db[which(plant_myco_db$plants %in%  plant_sel ==T),])
dev.off()

png("images/boxplot_co_occurenze_score_GEN.png")
bwplot(scoreGEN~plants, data =plant_myco_db_occ[which(plant_myco_db_occ$plants %in%  plant_sel ==T),])
dev.off()

#############################################################################################################################################
# @references
#  http://ddar.datavis.ca/
#
#' Friendly, M. & Meyer, D. (2016). Discrete Data Analysis with R: Visualization and Modeling Techniques for Categorical and Count Data. Boca Raton, FL: Chapman & Hall/CRC.
#


context("test for lgenerator")

f <- lforce
l <- liota(10)
lfib <- 0 %:% (1 %:% lzipWith(`+`, lfib, ltail(lfib)))
test_that("test", {
  expect_identical(f(0%..%9), f(l))
  expect_identical(f(liota(10, 2, 3)), f(larith(2, 5, 30)))
  expect_identical(f(liota(10, 2, 3)), f(lrange(2, 3, 30)))
  expect_identical(f(larith(2, 5, 30)), f(lrange(2, 3, 30)))
  expect_equal(
    lseq_gen(0, 1, f = function(x, y) x + y) %!!% 10,
    lfib %!!% 10)
})


##
## Create dyadic data frame for all dyads of license owners ('siida shares')
## - for each pair, we'll know how they're related, whether one gave the other a gift (and how much), and whether they belong to the same siida
##
library(data.table)

covars = c("SiidaID")

#########################################################################
## Data wrangling
##
# convert dataframes to data tables and set keys
herders    = as.data.table(herders)
herders.r  = as.data.table(herders.r)
gifts      = as.data.table(gifts)

setkey(herders,    HerderID)
setkey(herders.r,  Ego, Alter)
setkey(gifts,      Ego, Alter)

# keep only siida shares and chop out unnecessary covars
herders2 = subset(herders, SiidaShareYN==1, select=c("HerderID", covars))

#########################################################################
## Make main dyadic data frame in wide format
##
herders.wide = data.table(expand.grid(Ego=herders2$HerderID, Alter=herders2$HerderID))
setkeyv(herders.wide, c("Ego", "Alter"))
herders.wide = herders.wide[Ego!=Alter]  # remove dyads where ego==alter

#########################################################################
## Set dyad IDs for each ego/alter pair
##
# set dyad ID to be the smallest of ego/alter followed by the largest
herders.wide[, DyadID := ifelse(Ego < Alter, paste(Ego, Alter, sep=""), paste(Alter, Ego, sep=""))]
herders.wide$DyadID = as.integer(herders.wide$DyadID)  # paste() makes it character; convert to number

#########################################################################
## Merge in gifts
##
herders.wide = gifts[herders.wide]
setkeyv(herders.wide, c("Ego", "Alter"))  # need to reset keys after merge

# remove NAs
herders.wide[is.na(GiftSize), GiftSize := 0]

# create binary response variable for gifts
herders.wide[, GiftGiven := 0]
herders.wide[GiftSize > 0, GiftGiven := 1]

# figure out whether ego also received a gift from ego
gift.received = subset(herders.wide, GiftGiven==1, select=c(Ego, Alter, GiftGiven))  # keep only instances where alters received gifts from egos
setnames(gift.received, c("Alter", "Ego", "GiftReceived"))                           # alters become egos (because we want to know who received gifts from whom)
setkey(gift.received, Ego, Alter)
herders.wide = gift.received[herders.wide]            # merge gifts received into main table
herders.wide[is.na(GiftReceived), GiftReceived := 0]  # remove NAs

#########################################################################
## Merge in relatedness
##
# merge coefficients of relatedness
herders.wide = herders.r[herders.wide]
# set NAs to zero
herders.wide[is.na(r), r := 0]

#########################################################################
## Merge in covariates for ego and alter
##
setkey(herders.wide, Ego)
herders.wide = herders2[herders.wide]
# repeat for alter
setkey(herders.wide, Alter)
herders.wide = herders2[herders.wide]

# sort out column names and keys
setnames(herders.wide, "HerderID", "Alter")
setnames(herders.wide, "i.HerderID", "Ego")

setnames(herders.wide, covars, paste("Alter", covars, sep="."))
setnames(herders.wide, paste("i", covars, sep="."), paste("Ego", covars, sep="."))

setkey(herders.wide, Ego, Alter)

# calculate within-dyad covariates
## same siida?
herders.wide[, SameSiida := 0]
herders.wide[Ego.SiidaID==Alter.SiidaID, SameSiida := 1]  # belong to same siida?

#########################################################################
## Sort out column order and save dyadic data file
##
# reorder the columns into something more sensible
setcolorder(herders.wide, c("DyadID", "Ego", paste("Ego", covars, sep="."),
                            "Alter", paste("Alter", covars, sep="."),
                            "r", "SameSiida", "GiftSize", "GiftGiven", "GiftReceived"
))
setkey(herders.wide, DyadID)

rm(covars, herders2, gift.received)


library(Seurat)
library(SeuratDisk)
library(dplyr)
library(cowplot)
library(argparse)
library(aricode)
library(reticulate)
reticulate::use_python("python")

print_memory_usage <- function() {
    library(reticulate)
    py_run_string('import psutil; pmem = psutil.Process().memory_info(); print(pmem); rss_mb = pmem.rss/1024')
    return(py$rss_mb)
}

parser <- ArgumentParser()
parser$add_argument("--h5seurat-path", type = "character", help = "path to the h5seurat file to be processed")
parser$add_argument("--resolutions", type = "double", nargs = "+", default = c(0.02, 0.03, 0.04, 0.05, 0.08, 0.1, 0.2, 0.25, 0.3, 0.4), help = "resolution of leiden/louvain clustering")
parser$add_argument("--subset-genes", type = "integer", default = 3000, help = "number of features (genes) to select, 0 for don't select")
parser$add_argument("--no-eval", action = "store_true", help = "do not eval")
parser$add_argument('--ckpt-dir', type = "character", help='path to checkpoint directory', default = file.path('..', 'results'))
parser$add_argument("--seed", type = "integer", default = -1, help = "random seed.")

args <- parser$parse_args()

if (args$seed >= 0) {
    set.seed(args$seed)
}

library(reticulate)
reticulate::use_python("python")
matplotlib <- import("matplotlib")
matplotlib$use("Agg")
sc <- import("scanpy")
sc$settings$set_figure_params(
    dpi=120,
    dpi_save=250,
    facecolor="white",
    fontsize=10,
    figsize=c(10, 10)
)

dataset_str <- basename(args$h5seurat_path)
dataset_str <- substring(dataset_str, 1, nchar(dataset_str) - 9)
dataset <- LoadH5Seurat(args$h5seurat_path)
batches <- names(table(dataset@meta.data$batch_indices))
print(batches)

ckpt_dir <- file.path(args$ckpt_dir, sprintf("%s_Seuratv2_%d_seed%d_%s", dataset_str, args$subset_genes, args$seed, strftime(Sys.time(),"%m_%d-%H_%M_%S")))
if (!dir.exists((ckpt_dir))) {
    dir.create(ckpt_dir)
}
scETM <- import("scETM")
scETM$initialize_logger(ckpt_dir = ckpt_dir)
anndata <- import("anndata")

start_time <- proc.time()[3]
start_mem <- print_memory_usage()

dataset <- NormalizeData(dataset)
dataset <- FindVariableFeatures(
    object = dataset,
    selection.method = "vst",
    nfeatures = args$subset_genes,
    verbose = FALSE
)
dataset <- ScaleData(dataset, features = rownames(dataset))
dataset <- RunPCA(dataset, npcs = 50L)

time_cost <- proc.time()[3] - start_time
mem_cost <- print_memory_usage() - start_mem
writeLines(sprintf("Duration: %.1f s (%.1f min)", time_cost, time_cost / 60))

fpath <- file.path(ckpt_dir, sprintf("%s_Seuratv2_seed%d.h5ad", dataset_str, args$seed))
X <- dataset@reductions$pca@cell.embeddings
processed_data <- anndata$AnnData(
    X = X,
    obs = dataset@meta.data
)
processed_data$write_h5ad(fpath)

if (!args$no_eval) {
    result <- scETM$evaluate(
        processed_data,
        embedding_key = "X",
        resolutions = args$resolutions,
        plot_dir = ckpt_dir,
        plot_fname = sprintf("%s_Seuratv2_seed%d_eval", dataset_str, args$seed),
        n_jobs = 1L
    )
    line <- sprintf("%s\tSeuratv2\t%s\t%.4f\t%.4f\t%.4f\t%.5f\t%.5f\t%.2f\t%.0f",
        dataset_str, args$seed,
        result$ari, result$nmi, result$asw, result$ebm, result$k_bet,
        time_cost, mem_cost)
    write(line, file = file.path(args$ckpt_dir, "table1.tsv"), append = T)
}


# -------------------------------------
# -------- WEATHER SENSOR DATA --------
# -------------------------------------

# get sensor data from Chicago Open Data Portal
weather_sensors <- read.csv("https://data.cityofchicago.org/api/views/k7hf-8y75/rows.csv?accessType=DOWNLOAD", stringsAsFactors = F, header = T)
sensor_locations <- read.csv("https://data.cityofchicago.org/api/views/g3ip-u8rb/rows.csv?accessType=DOWNLOAD", stringsAsFactors = F, header = T)

# merge sensor data
weather_sensors <- merge(weather_sensors, sensor_locations, by.x="Station.Name", by.y="Sensor.Name")

# drop unecessary columns
drop <- c("Sensor.Type","Location")
weather_sensors <- weather_sensors[,!(names(weather_sensors) %in% drop)]

# normalize names
weather_sensors$Station.Name <- substr(weather_sensors$Station.Name,1,nchar(weather_sensors$Station.Name)-16)

# match beaches with water and weather stations
beach_mappings <- read.csv("data/ExternalData/Beach_Mappings.csv", stringsAsFactors=FALSE)
weathernames <- setNames(beach_mappings$weather, beach_mappings$beach)
beach_readings$Weather.Station <- weathernames[beach_readings$Client.ID]

# parse dates for water and weather
weather_sensors$Date <- substr(weather_sensors$Measurement.Timestamp,1,10)
weather_sensors$Date<- as.Date(weather_sensors$Date, format="%m/%d/%Y")

# Find average, max, and min values for all water and weather metrics per day per senser location
df_min_air_temp <- aggregate(weather_sensors$Air.Temperature, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=min)
df_max_air_temp <- aggregate(weather_sensors$Air.Temperature, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=max)
df_avg_air_temp <- aggregate(weather_sensors$Air.Temperature, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=mean)
air_temp <- join_all(list(df_min_air_temp, df_max_air_temp, df_avg_air_temp), by=c("Group.1", "Group.2"))
names(air_temp) <- c("Weather.Station", "Full_date", "Air.Temp.Min", "Air.Temp.Max", "Air.Temp.Mean")

df_min_bulb_temp <- aggregate(weather_sensors$Wet.Bulb.Temperature, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=min)
df_max_bulb_temp <- aggregate(weather_sensors$Wet.Bulb.Temperature, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=max)
df_avg_bulb_temp <- aggregate(weather_sensors$Wet.Bulb.Temperature, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=mean)
bulb_temp <- join_all(list(df_min_bulb_temp, df_max_bulb_temp, df_avg_bulb_temp), by=c("Group.1", "Group.2"))
names(bulb_temp) <- c("Weather.Station", "Full_date", "Wet.Bulb.Temp.Min", "Wet.Bulb.Temp.Max", "Wet.Bulb.Temp.Mean")

df_min_humidity <- aggregate(weather_sensors$Humidity, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=min)
df_max_humidity <- aggregate(weather_sensors$Humidity, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=max)
df_avg_humidity <- aggregate(weather_sensors$Humidity, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=mean)
humidity <- join_all(list(df_min_humidity, df_max_humidity, df_avg_humidity), by=c("Group.1", "Group.2"))
names(humidity) <- c("Weather.Station", "Full_date", "Humidity.Min", "Humidity.Max", "Humidity.Mean")

df_min_rain_intensity <- aggregate(weather_sensors$Rain.Intensity, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=min)
df_max_rain_intensity <- aggregate(weather_sensors$Rain.Intensity, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=max)
df_avg_rain_intensity <- aggregate(weather_sensors$Rain.Intensity, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=mean)
rain_intensity <- join_all(list(df_min_rain_intensity, df_max_rain_intensity, df_avg_rain_intensity), by=c("Group.1", "Group.2"))
names(rain_intensity) <- c("Weather.Station", "Full_date", "Rain.Intensity.Min", "Rain.Intensity.Max", "Rain.Intensity.Mean")

df_min_interval_rain <- aggregate(weather_sensors$Interval.Rain, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=min)
df_max_interval_rain <- aggregate(weather_sensors$Interval.Rain, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=max)
df_avg_interval_rain <- aggregate(weather_sensors$Interval.Rain, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=mean)
interval_rain <- join_all(list(df_min_interval_rain, df_max_interval_rain, df_avg_interval_rain), by=c("Group.1", "Group.2"))
names(interval_rain) <- c("Weather.Station", "Full_date", "Interval.Rain.Min", "Interval.Rain.Max", "Interval.Rain.Mean")

df_min_total_rain <- aggregate(weather_sensors$Total.Rain, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=min)
df_max_total_rain <- aggregate(weather_sensors$Total.Rain, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=max)
df_avg_total_rain <- aggregate(weather_sensors$Total.Rain, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=mean)
total_rain <- join_all(list(df_min_total_rain, df_max_total_rain, df_avg_total_rain), by=c("Group.1", "Group.2"))
names(total_rain) <- c("Weather.Station", "Full_date", "Total.Rain.Min", "Total.Rain.Max", "Total.Rain.Mean")

df_min_wind_direction <- aggregate(weather_sensors$Wind.Direction, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=min)
df_max_wind_direction <- aggregate(weather_sensors$Wind.Direction, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=max)
df_avg_wind_direction <- aggregate(weather_sensors$Wind.Direction, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=mean)
wind_direction <- join_all(list(df_min_wind_direction, df_max_wind_direction, df_avg_wind_direction), by=c("Group.1", "Group.2"))
names(wind_direction) <- c("Weather.Station", "Full_date", "Wind.Direction.Min", "Wind.Direction.Max", "Wind.Direction.Mean")

df_min_wind_speed <- aggregate(weather_sensors$Wind.Speed, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=min)
df_max_wind_speed <- aggregate(weather_sensors$Wind.Speed, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=max)
df_avg_wind_speed <- aggregate(weather_sensors$Wind.Speed, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=mean)
wind_speed <- join_all(list(df_min_wind_speed, df_max_wind_speed, df_avg_wind_speed), by=c("Group.1", "Group.2"))
names(wind_speed) <- c("Weather.Station", "Full_date", "Wind.Speed.Min", "Wind.Speed.Max", "Wind.Speed.Mean")

df_min_barometric_pressure <- aggregate(weather_sensors$Barometric.Pressure, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=min)
df_max_barometric_pressure <- aggregate(weather_sensors$Barometric.Pressure, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=max)
df_avg_barometric_pressure <- aggregate(weather_sensors$Barometric.Pressure, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=mean)
barometric_pressure <- join_all(list(df_min_barometric_pressure, df_max_barometric_pressure, df_avg_barometric_pressure), by=c("Group.1", "Group.2"))
names(barometric_pressure) <- c("Weather.Station", "Full_date", "Barometric.Pressure.Min", "Barometric.Pressure.Max", "Barometric.Pressure.Mean")

df_min_solar_radiation <- aggregate(weather_sensors$Solar.Radiation, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=min)
df_max_solar_radiation <- aggregate(weather_sensors$Solar.Radiation, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=max)
df_avg_solar_radiation <- aggregate(weather_sensors$Solar.Radiation, by=list(weather_sensors$Station.Name, weather_sensors$Date), FUN=mean)
solar_radiation <- join_all(list(df_min_solar_radiation, df_max_solar_radiation, df_avg_solar_radiation), by=c("Group.1", "Group.2"))
names(solar_radiation) <- c("Weather.Station", "Full_date", "Solar.Radiation.Min", "Solar.Radiation.Max", "Solar.Radiation.Mean")

weather_sensors_daily <- join_all(list(air_temp, bulb_temp, humidity, rain_intensity, interval_rain, total_rain, wind_direction, wind_speed, barometric_pressure, solar_radiation), by=c("Weather.Station", "Full_date"))

# merge with beach_readings
beach_readings <- merge(beach_readings, weather_sensors_daily, all.x = TRUE)

# clean up workspace
rm(list = ls(pattern = "^df_min_"))
rm(list = ls(pattern = "^df_max_"))
rm(list = ls(pattern = "^df_avg_"))
rm(list=c("air_temp", "bulb_temp", "humidity", "rain_intensity", "interval_rain", "total_rain", "wind_direction", "wind_speed", "barometric_pressure", "solar_radiation"))

# clean up order
beach_readings <- beach_readings[order(-as.numeric(beach_readings$Full_date)), c(
  "Client.ID",  "Full_date", "Year", "Date",
  "Laboratory.ID", "Reading.1", "Reading.2",
  "Escherichia.coli", "Units", "Sample.Collection.Time",
  "Weekday", "Month", "Day",
  "Drek_Reading", "Drek_Prediction", "Drek_Worst_Swim_Status",
  "e_coli_geomean_actual_calculated", "elevated_levels_actual_calculated", "Drek_elevated_levels_predicted_calculated",
  "Water.Station", "Water.Temp.Min", "Water.Temp.Max","Water.Temp.Mean",
  "Turbidity.Min","Trubidity.Max", "Turbidity.Mean",
  "Transducer.Depth.Min","Transducer.Depth.Max", "Transducer.Depth.Mean",
  "Wave.Height.Min","Wave.Height.Max", "Wave.Height.Mean",
  "Wave.Period.Min","Wave.Period.Max","Wave.Period.Mean",
  "Weather.Station", "Air.Temp.Min","Air.Temp.Max","Air.Temp.Mean",
  "Wet.Bulb.Temp.Min","Wet.Bulb.Temp.Max","Wet.Bulb.Temp.Mean",
  "Humidity.Min","Humidity.Max","Humidity.Mean",
  "Rain.Intensity.Min","Rain.Intensity.Max","Rain.Intensity.Mean",
  "Interval.Rain.Min","Interval.Rain.Max","Interval.Rain.Mean",
  "Total.Rain.Min","Total.Rain.Max","Total.Rain.Mean",
  "Wind.Direction.Min","Wind.Direction.Max","Wind.Direction.Mean",
  "Wind.Speed.Min","Wind.Speed.Max","Wind.Speed.Mean",
  "Barometric.Pressure.Min","Barometric.Pressure.Max","Barometric.Pressure.Mean",
  "Solar.Radiation.Min","Solar.Radiation.Max","Solar.Radiation.Mean"
)]


library(brms)

df = read.table("meta_mix.csv", sep=",", header=1)
fml = P3b ~ 1 + Dopamine_transporter + Noradrenaline_transporter + Alpha_1_Beta_adrenergic_receptor + D2_dopamine_receptor + Alpha_2_adrenergic_receptor + D1_dopamine_receptor + (1 | Study) + (Dosage_.standardized. | X)
mdl <- brm(fml, data=df, iter=5000, cores=2)
summary(mdl)


#Making a spatial forecast for functional groups at multiple sequence depths.
#downstream this will log transform map, which prevents this from generalizing beyond the dirichlet example.
#This script depends on the following packages: DirichletReg.
#clear environment, source paths, packages and functions.
rm(list=ls())
library(runjags)
source('paths.r')
source('NEFI_functions/precision_matrix_match.r')
source('NEFI_functions/ddirch_forecast.r')

#set output path.----
output.path <- ted_fg_seq.depth_ddirch_foreacsts.path

#load model results.----
mod_all <- readRDS(ted_fg_ddirch_fit_seqdepth.path)
#we need to loop the below code over each model in the "mod_all" object. Each model is some level of sequence depth.
#for(kk in 1:length(mod_all)){mod <- mod_all[[kk]]}

#get core-level covariate means and sd.----
dat <- readRDS(hierarch_filled.path)
core_mu <- dat$core.core.mu
plot_mu <- dat$plot.plot.mu
site_mu <- dat$site.site.mu
#merge together.
plot_mu$siteID <- NULL
core.preds <- merge(core_mu   , plot_mu)
core.preds <- merge(core.preds, site_mu)
core.preds$relEM <- NULL
names(core.preds)[names(core.preds)=="b.relEM"] <- "relEM"

#get core-level SD.
core_sd <- dat$core.core.sd
plot_sd <- dat$plot.plot.sd
site_sd <- dat$site.site.sd
#merge together.
plot_sd$siteID <- NULL
core.sd <- merge(core_sd   , plot_sd)
core.sd <- merge(core.sd, site_sd)
core.sd$relEM <- NULL
names(core.sd)[names(core.sd)=="b.relEM"] <- "relEM"

#get plot-level covariate means and sd.----
core_mu <- dat$core.plot.mu
plot_mu <- dat$plot.plot.mu
site_mu <- dat$site.site.mu
#merge together, .
plot_mu$siteID <- NULL
plot.preds <- merge(core_mu,plot_mu)
plot.preds <- merge(plot.preds,site_mu)
plot.preds$relEM <- NULL
names(plot.preds)[names(plot.preds)=="b.relEM"] <- "relEM"

#get plot-level SD.
core_sd <- dat$core.plot.sd
plot_sd <- dat$plot.plot.sd
site_sd <- dat$site.site.sd
#merge together
plot_sd$siteID <- NULL
plot.sd <- merge(core_sd,plot_sd)
plot.sd <- merge(plot.sd,site_sd)
plot.sd$relEM <- NULL
names(plot.sd)[names(plot.sd)=='b.relEM'] <- "relEM"

#get site-level covariate means and sd.----
core_mu <- dat$core.site.mu
plot_mu <- dat$plot.site.mu
site_mu <- dat$site.site.mu
#merge together
site.preds <- merge(core_mu, plot_mu)
site.preds <- merge(site.preds,site_mu)
names(site.preds)[names(site.preds)=='b.relEM'] <- "relEM"

#get site-level SD.
core_sd <- dat$core.site.sd
plot_sd <- dat$plot.site.sd
site_sd <- dat$site.site.sd
#merge together.
site.sd <- merge(core_sd,plot_sd)
site.sd <- merge(site.sd,site_sd)
names(site.sd)[names(site.sd)=='b.relEM'] <- "relEM"

#Get forecasts from ddirch_forecast.----
fcast_list <- list()
for(i in 1:length(mod_all)){
  mod <- mod_all[[i]]
  core.fit <- ddirch_forecast(mod=mod, cov_mu=core.preds, cov_sd=core.sd, names=core.preds$sampleID, n.samp = 10000)
  plot.fit <- ddirch_forecast(mod=mod, cov_mu=plot.preds, cov_sd=plot.sd, names=plot.preds$plotID, n.samp = 10000)
  site.fit <- ddirch_forecast(mod=mod, cov_mu=site.preds, cov_sd=site.sd, names=site.preds$siteID, n.samp = 10000)

  #store output as a list and save.----
  output <- list(core.fit,plot.fit,site.fit,core.preds,plot.preds,site.preds,core.sd,plot.sd,site.sd)
  names(output) <- c('core.fit','plot.fit','site.fit',
                     'core.preds','plot.preds','site.preds',
                     'core.sd','plot.sd','site.sd')
  #store in list
  fcast_list[[i]] <- output
}
names(fcast_list) <- names(mod_all)

#save output.----
saveRDS(fcast_list, output.path)


# plot-02.r
# RBLandau 20150922
# Using the basic R plotting functions, do a few graphs
#  for the NDSA meeting.

dall <- data.frame(read.table("dataforndsa-00.txt",header=TRUE))
d <- dall[dall$lifem>=10,]
c1 <- d[d$copies==1,]
c2 <- d[d$copies==2,]
c3 <- d[d$copies==3,]
c4 <- d[d$copies==4,]
c5 <- d[d$copies==5,]
safelog <- function(x){return(log10(x+1)) }
safe    <- function(x){return(x+1)}

# C1
png("c1.png",width=860,height=452,pointsize=16)
plot(c1$lifem,safe(c1$loss.a0),type="b",lty="dashed",log="xy",pch=16,
     ylab="permanent losses out of 10000 docs",
     xlab="sector lifetime (megahours)",
     main="For copies = 1, \nlosses are unacceptable (auditing can't help)")
#points(c2$lifem,safe(c2$loss.ay),type="b",pch=16,col="red")
#points(c2$lifem,safe(c2$loss.aq),type="b",pch=16,col="blue")
#legend(300,700,c("No audit","Annual audit","Quarterly audit"),col=c("black","red","blue"),pch=c(16,16,16))
text(18,1500,"No auditing",col="black")
#text(14,350,"Annual audit",col="red")
#text(13,40,"Quarterly audit",col="blue")
dev.off()

# C2
png("c2.png",width=860,height=452,pointsize=16)
plot(c2$lifem,safe(c2$loss.a0),type="b",lty="dashed",log="xy",pch=16,
    ylab="permanent losses out of 10000 docs",
    xlab="sector lifetime (megahours)",
    main="For copies = 2, \nlosses decline a lot with increased auditing")
points(c2$lifem,safe(c2$loss.ay),type="b",pch=16,col="red")
points(c2$lifem,safe(c2$loss.aq),type="b",pch=16,col="blue")
legend(300,700,c("No audit","Annual audit","Quarterly audit"),col=c("black","red","blue"),pch=c(16,16,16))
text(18,1500,"No audit",col="black")
text(14,350,"Annual audit",col="red")
text(13,40,"Quarterly audit",col="blue")
dev.off()

# C3
png("c3.png",width=860,height=452,pointsize=16)
plot(c3$lifem,safe(c3$loss.a0),type="b",lty="dashed",log="xy",pch=16,
    ylab="permanent losses out of 10000 docs",
    xlab="sector lifetime (megahours)",
    main="For copies = 3, \nlosses decline slightly with increased auditing")
points((c3$lifem),safe(c3$loss.ay),type="b",pch=16,col="red")
points((c3$lifem),safe(c3$loss.aq),type="b",pch=16,col="blue")
legend(300,300,c("No audit","Annual audit","Quarterly audit"),col=c("black","red","blue"),pch=c(16,16,16))
text(15,500,"No audit",col="black")
text(15,15,"Annual audit",col="red")
text(12,1.4,"Quarterly audit",col="blue")
dev.off()

# C4
png("c4.png",width=860,height=452,pointsize=16)
plot(c4$lifem,safe(c4$loss.a0),type="b",lty="dashed",log="xy",pch=16,
    ylab="permanent losses out of 10000 docs",
    xlab="sector lifetime (megahours)",
    main="For copies = 4, \nlosses decline only very slightly with increased auditing")
points(c4$lifem,safe(c4$loss.ay),type="b",pch=16,col="red")
points(c4$lifem,safe(c4$loss.aq),type="b",pch=16,col="blue")
legend(300,100,c("No audit","Annual audit","Quarterly audit"),col=c("black","red","blue"),pch=c(16,16,16))
text(15,210,"No audit",col="black")
text(14,2.4,"Annual audit",col="red")
text(12,1.4,"Quarterly audit",col="blue")
dev.off()

# C5
png("c5.png",width=860,height=452,pointsize=16)
plot(c5$lifem,safe(c5$loss.a0),type="b",lty="dashed",log="xy",pch=16,
    ylab="permanent losses out of 10000 docs",
    xlab="sector lifetime (megahours)",
    main="For copies = 5, \nlosses are probably negligible with any auditing")
points(c5$lifem,safe(c5$loss.aq),type="b",pch=16,col="blue")
points(c5$lifem,safe(c5$loss.ay),type="b",pch=16,col="red")
legend(300,100,c("No audit","Annual audit","Quarterly audit"),col=c("black","red","blue"),pch=c(16,16,16))
text(14,90,"No audit",col="black")
text(12,1.8,"Annual audit or",col="red")
text(12,1.4,"Quarterly audit",col="blue")
dev.off()

#END


# xfp-jmh
# palisades dot lakes at gmail dot com
# version 2019-04-05
#-----------------------------------------------------------------
if (file.exists('e:/porta/projects/xfp-jmh')) {
  setwd('e:/porta/projects/xfp-jmh')
  model <- '20ERCTO1WW' # P70
} else {
  setwd('c:/porta/projects/xfp-jmh')
  model <- '20HRCTO1WW' # X1
}
source('src/scripts/r/functions.r')
#-----------------------------------------------------------------
prefix <- 'Sums-20190404-192600'
#-----------------------------------------------------------------
runtime <- read.runtimes(prefix=prefix)
summary(runtime)
#-----------------------------------------------------------------
accuracy <- read.accuracy(benchmarks=c('Dot','L2','Sum'))
summary(accuracy)
#-----------------------------------------------------------------
data <- merge(
  x=runtime,
  y=accuracy,
  by=c('benchmark','algorithm','dim'))
cols <- c('benchmark','algorithm','dim','ms','residual50','abs.residual50')
data <- data[,cols]
summary(data)
#-----------------------------------------------------------------
source('src/scripts/r/functions.r')

runtime.accuracy.plot(
  data=data,
  y='abs.residual50',
  ylabel='median absolute residual',
  prefix='rxa-median-absolute-residual',
  scales='fixed')

runtime.accuracy.plot(
  data=data,
  y='abs.residual50',
  ylabel='median absolute residual',
  prefix='rxa-median-absolute-residual-free',
  scales='free')


#!/usr/bin/Rscript

med <- function(firstLabels, secondLabels) {
	first <- read.table(firstLabels)[,1];
	second <- read.table(secondLabels)[,1];

	if (length(first) != length(second)) {
		return ("length of first != second")
	}

	return (adjustedRandIndex(first, second))
}

args <- commandArgs(trailingOnly=TRUE);

if (length(args) == 2) {
	suppressMessages(library(mclust))
	med(args[1], args[2]);
} else {
	print("Give me two files with labels dude!");
}


#' standardev: a standard deviation calculator
#'
#' A simple standard deviation calculator to help user calculate standard deviation
#' of a given numeric/integer vector
#'
#' @name standardev
#' @docType package
NULL


# PROPOSAL TO CALCULATE WINDOW MEAN
# =================================
# =================================

# Idea: Get Data From all words in timespan, calculate, write back

# Steps
#   Connect to DB
#   Get all data from DB
#   Reshape 1: make big table
#   Calculation
#   Plot Example Word "Flugzeug"
#   Reshape II: make tall table (date, w_id, window_value)
#   Write back into DB

# WRITE IN MySQL
# ==============
# overwrite Data in mysql in table "aliss15a_windows_of_r"
dbWriteTable(mydb, "aliss15a_windows_of_r", data_for_mysql, overwrite = TRUE, append=FALSE, row.names=FALSE, field.types=list(date="date", w_id="int (10)", window8="float"))
#das dauert jetzt lange wegen meiner internetverbindung


#=================================================================================================#
# utilities.r
# Generic utility methods
# Adam Erickson, PhD, Washington State University
# Contact: adam.michael.erickson@gmail.com
# March 14, 2019
# License: Apache 2.0
#
# Copyright 2019 Washington State University
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#=================================================================================================#

#' Estimate empirical PDF and sample from CDF; bw = SD of density kernel; value range = 0:1.
#' @param x Numeric vector of empirical values.
#' @param n Numeric number of samples to draw.
#' @param from Numeric minimum sample value.
#' @param to Numeric maximum sample value.
#' @param bw Numeric smoothing bandwidth or standard deviation for Gaussian kernel.
#' @return Numeric vector.
sample_empirical_cdf = function(x, n, from=0, to=1, bw=0.1, ...) {
  x = x[!is.na(x) & is.finite(x)]
  if (length(x) < 1) { return(NA) }
  x_pdf = stats::density(x=x, kernel="gaussian", from=from, to=to, bw=bw, n=512)
  return(stats::approx(cumsum(x_pdf$y)/sum(x_pdf$y), x_pdf$x, stats::runif(n=n))$y)
}

#' Helper function to calculate mean from arbitrary inputs.
#' @param ... Numeric vector or multiple numeric arguments.
#' @return Numeric value.
mean0 = function(...) {
  x = as.numeric(unlist(list(...)))
  return(sum(x, na.rm=TRUE) / length(x))
}

#' Coefficient of determination (R2) helper method.
#' @note Different methods of calculating R2 produce slightly different results.
#' @note Similar to Nash-Sutcliffe efficiency coefficient in the general case.
#' @param x Numeric observation values.
#' @param y Numeric prediction values.
#' @return Numeric value.
r_squared = function(x, y) {
  if (length(x) != length(y)) { stop("Lengths of y and y_hat differ") }
  #return(1 - sum((x-y)^2) / sum((x-mean(x))^2))
  #return(cov(x, y, method="pearson") / (sd(x) * sd(y)))
  return(cor(x, y, method="pearson")^2)
}

#' Nash-Sutcliffe efficiency coefficient (NSE) helper method.
#' @note Implementation based on R2 in Nash and Sutcliffe (1970) River flow forecasting through conceptual models.
#' @note This metric is "analogous to the coefficent of determination."
#' @param x Numeric observation values.
#' @param y Numeric prediction values.
#' @return Numeric value.
nse = function(x, y) {
  if (length(x) != length(y)) { stop("Lengths of y and y_hat differ") }
  return((sum((x-mean(x))^2) - sum((x-y)^2)) / sum((x-mean(x))^2))
}

#' Root mean squared error (RMSE) helper method.
#' @param x Numeric observation values.
#' @param y Numeric prediction values.
#' @return Numeric value.
rmse = function(x, y) {
  if (length(x) != length(y)) { stop("Lengths of y and y_hat differ") }
  return(sqrt(sum((y-x)^2) / length(x)))
}

#' Mean absolute error (MAE) helper method.
#' @param x Numeric observation values.
#' @param y Numeric prediction values.
#' @return Numeric value.
mae = function(x, y) {
  if (length(x) != length(y)) { stop("Lengths of y and y_hat differ") }
  return(mean(abs(y-x)))
}

#' Mean error (ME) helper method.
#' @note Equivalent to bias.
#' @param x Numeric observation values.
#' @param y Numeric prediction values.
#' @return Numeric value.
me = function(x, y) {
  if (length(x) != length(y)) { stop("Lengths of y and y_hat differ") }
  return(mean(y-x))
}

#' Helper method for listing files.
#' @note List files in folder with extension matching pattern
#' @param folder Character folder path containing files.
#' @param filnames Character vector of filenames to search.
#' @param extension Character file extension to search.
#' @return Character vector of files matching pattern.
get_files = function(path, filenames, extension, ...) {
  pattern = paste0("^(", paste(filenames, collapse="|"), ").*?", ".", extension, "$")
  return(list.files(path=path, pattern=pattern, full.names=TRUE))
}

#' Helper method for moving multiple files.
#' @param files Character vector of file paths
#' @param to Character directory target
#' @param recursive Boolean recursive switch
#' @param overwrite Boolean overwrite switch
#' @return 0
files_move = function(files, to, recursive=TRUE, overwrite=TRUE) {
  if (!dir.exists(file.path(to))) { dir.create(path=file.path(to), recursive=recursive) }
  file.copy(from=files, to=file.path(to), recursive=recursive, overwrite=overwrite, copy.mode=TRUE)
  file.remove(files)
  return(invisible(0))
}

#' Helper method for moving directories.
#' @param from Character directory origin
#' @param to Character directory target
#' @param recursive Boolean recursive switch
#' @param overwrite Boolean overwrite switch
#' @return 0
dir_move = function(from, to, recursive=TRUE, overwrite=TRUE) {
  if (!dir.exists(paths=file.path(to))) { dir.create(path=file.path(to), recursive=recursive) }
  files = list.files(from, full.names=TRUE, recursive=FALSE)
  file.copy(from=files, to=file.path(to), recursive=recursive, overwrite=overwrite, copy.mode=TRUE)
  unlink(file.path(from), recursive=recursive)
  return(invisible(0))
}

#' Helper method for downloading files
#' @note Download observation data and add to list
#' @param url Character url to a file.
#' @param destination Character path to save downloaded file.
download_file = function(url, destination) {
  curl::curl_download(url=url, destfile=destination, quiet=FALSE, mode="w")
  message(paste("Download successful:", destination))
  return(invisible(0))
}

#' Helper method to interpolate points to raster
#' @param x Numeric x,y coordinates or n-dimensional vector of predictor variables.
#' @param y Numeric 1-d vector for target variable.
#' @param xi Numeric x,y coordinates or n-dimensional data.frame() for imputing values.
#' @param method Character method selection.
#' @param fun Function for caret trainControl or RandomFields model.
#' @param multicore Boolean flag for multicore computation using OpenMP.
#' @param spatial Boolean flag for whether xi contains x,y coordinates.
#' @param proj4string Character Proj4 projection string for raster image.
#' @param plot Boolean flag for plotting results.
#' @examples
#' Classification
#' data(iris)
#' intrain = caret::createDataPartition(iris$Species, p=0.7, list=FALSE)
#' train   = iris[ intrain,]
#' test    = iris[-intrain,]
#' x       = train[,1:4]
#' y       = train[,5]
#' xi      = test[,1:4]
#' yi      = test[,5]
#' p = interpolate_points(x=x, y=y, xi=xi, method="knn", multicore=FALSE, spatial=FALSE, plot=TRUE)
#' sum(p == yi) / length(p)
#' p = interpolate_points(x=x, y=y, xi=xi, method="xgbTree", multicore=TRUE, spatial=FALSE, plot=TRUE)
#' sum(p == yi) / length(p)
#' Spatial regression
#' x  = cbind(x=runif(100, 1, 100), y=runif(100, 1, 100))
#' y  = rowSums(xy)
#' xi = expand.grid(x=seq(1, 100, length.out=100), y=seq(1, 100, length.out=100))
#' p = interpolate_points(x=x, y=y, xi=xi, method="knn", fun=NA, multicore=FALSE, spatial=TRUE,
#'                        proj4string="+proj=longlat +ellps=WGS84 +datum=WGS84", plot=TRUE)
#' or
#' p = interpolate_points(x=x, y=y, xi=xi, method="rf", fun=NA, multicore=TRUE, spatial=TRUE,
#'                        proj4string="+proj=longlat +ellps=WGS84 +datum=WGS84", plot=TRUE)
#' Kriging
#' xi  = data.frame(x=seq(1, 100, length.out=100), y=seq(1, 100, length.out=100))
#' fun = RandomFields::RMexp() + RandomFields::RMtrend(mean=NA)
#' fun = ~1 + RandomFields::RMwhittle(scale=NA, var=NA, nu=NA) + RandomFields::RMnugget(var=NA)
#' p = interpolate_points(x=x, y=y, xi=xi, method="kriging", fun=fun, multicore=FALSE, spatial=TRUE,
#'                        proj4string="+proj=longlat +ellps=WGS84 +datum=WGS84", plot=TRUE)
interpolate_points = function(x, y, xi=NA, method="knn", fun=NA, multicore=FALSE, spatial=TRUE,
                              proj4string="+proj=longlat +ellps=WGS84 +datum=WGS84", plot=FALSE, ...) {
  if (method != "kriging") {
    if (multicore == TRUE) { doMC::registerDoMC(cores=parallel::detectCores()-1) }
    if (!is.na(fun)) {
      ctl = fun
    } else {
      ctl  = caret::trainControl(method="repeatedcv", number=3, repeats=3, search="grid")
    }
    mod  = caret::train(x, y, method=method, trControl=ctl, preProcess=c("center","scale"), tuneLength=10)
    yhat = predict(mod, newdata=xi)
    if (spatial == TRUE) {
      coords = colnames(x) %in% c("x","y","lat","lon","latitude","longitude")
      proj4crs = sp::CRS(proj4string)
      yhat = sp::SpatialPixelsDataFrame(points=sp::SpatialPoints(xi[,coords]), data=data.frame(y=yhat),
                                        proj4string=proj4crs)
    }
  } else if (method == "kriging" & spatial == TRUE) {
    if (length(unique(round(diff(xi[,1]),6))) > 2 | length(unique(round(diff(xi[,2]),6))) > 2) {
      stop("Please enter an evenly spaced grid for xi parameter")
    }
    if (any(duplicated(xi[,1]) | duplicated(xi[,2]))) {
      warning("Parameter xi appears to be a grid, creating list of unique coordinates", immediate.=TRUE)
      xi = data.frame(x=min(xi[,1]):max(xi[,1]), y=min(xi[,2]):max(xi[,2]))
    }
    proj4crs = sp::CRS(proj4string)
    coords = colnames(x) %in% c("x","y","lat","lon","latitude","longitude")
    spdf = sp::SpatialPointsDataFrame(coords=x[,coords], data=data.frame(y=y), proj4string=proj4crs)
    fit  = RandomFields::RFfit(fun, data=spdf)
    yhat = RandomFields::RFinterpolate(fit, x=xi[,coords], grid=TRUE, data=spdf)
  } else {
    stop("Parameters incorrectly specified")
  }
  if (spatial == TRUE) {
    yhat = raster::raster(yhat)
    if (plot == TRUE) { raster::plot(yhat, col=viridis::magma(256)) }
  }
  return(yhat)
}

#' Helper method to generate raster image
#' @note Used to generate random maps, point value maps, or matrix maps.
#' @note A RandomFields model can also be passed to generator.
#' @param values Numeric matrix, single value, "random", or "scrf" for spatially correlated random fields.
#' @param path Character file path for saving the result.
#' @param format Character raster file format.
#' @param params Optional numeric vector of parameters to pass to distribution function.
#' @param generator Optional statistical generator for drawing random values. Default is runif().
#' @param size Optional numeric vector of length 2 for the n*n size of the map.
#' @param extent Optional numeric vector of length 4 for the image bounds.
#' @param crs Optional character vector proj4-compatible coordinate reference system.
#' @examples
#' f  = "/Users/julia/rasters"
#' g = RandomFields::RMexp(var=3, scale=5) + RandomFields::RMnugget(var=3)
#' r = generate_raster("randomfield", size=c(100,100), generator=g, filename=f)
generate_raster = function(values="random", size=c(10,10), bounds=c(-1,1,-1,1), generator=runif,
                           params=c(prod(size)), filename=NA, format="GTiff",
                           proj4string="+proj=longlat +ellps=WGS84 +datum=WGS84", plot=TRUE, ...) {
  if (values != "random" & class(values) == "numeric" & class(values) != "matrix") {
    if (length(values) != prod(size)) { stop("Number of values must equal the product of size") }
    values = matrix(values, nrow=size[1], ncol=size[2])
  } else if (values == "random" & class(generator) == "function") {
    values = do.call(generator, as.list(params))
    values = matrix(values, nrow=size[1], ncol=size[2])
  } else if (values == "randomfields" & class(generator)[1] == "RMmodel") {
    x = 1:size[1]
    y = 1:size[2]
    values = RandomFields::RFsimulate(generator, x, y, grid=TRUE)
  } else {
    stop("Parameters incorrectly specified")
  }
  ri = raster::raster(values)
  raster::extent(ri) = bounds
  raster::projection(ri) = raster::crs(proj4string)
  if (!is.na(filename) == TRUE) { raster::writeRaster(ri, filename=filename, format=format) }
  if (plot == TRUE) { raster::plot(ri, col=viridis::magma(256)) }
  return(ri)
}