# Test the amount of time needed for the various models

rm(list=ls())
require(gridExtra);

library(ggplot2)
source("chartr-ModelSelection.r")
VERBOSE = TRUE;

allValidModels = returnListOfModels()
modelList = unname(allValidModels$modelNames)
usemodel = modelList

whatToRun = "cs2, slow, 400, 10000"
whatToRun = "cs2, fast, 400, 10000"
whatToRun = "cs2, fast, 200, 10000"
whatToRun = "cs2, fast, 200, 5000"

switch(whatToRun,
       "cs1, slow, 400, 10000"={
         dataDir = "caseStudy1";
         resultsDir = "caseStudy1_Fits/"
         runs = seq(1,5);
       },
       "cs2, slow, 400, 10000"={
         dataDir = "caseStudy2";
         resultsDir = "caseStudy2_Fits/"
         runs = seq(1,5);
       },
       "cs1, fast, 400, 10000"={
         dataDir = "caseStudy1";
         resultsDir = "caseStudy1_FastFits/"
         runs = seq(1,5);
       },
       "cs2, fast, 400, 10000"={
         dataDir = "caseStudy2";
         resultsDir = "caseStudy2_FastFits/"
         runs = seq(1,5);
       },
       "cs1, fast, 200, 10000"={
         dataDir = "caseStudy1";
         resultsDir = "caseStudy1_FastFits/"
         runs = seq(1,5)+5;
       },
       "cs2, fast, 200, 10000"={
         dataDir = "caseStudy2";
         resultsDir = "caseStudy2_FastFits/"
         runs = seq(1,5)+5;
       },
       "cs1, fast, 200, 5000"={
         dataDir = "caseStudy1";
         resultsDir = "caseStudy1_FastFits/"
         runs = seq(1,5)+15;
       },
       "cs2, fast, 200, 5000"={
         dataDir = "caseStudy2";
         resultsDir = "caseStudy2_FastFits/"
         runs = seq(1,5)+15;
       }
)

nreps = length(runs);

timingResults = data.frame(matrix(0,length(modelList), nreps+1));

snams = dir(dataDir)
snams = c('Subj1','Subj2','Subj3','Subj4','Subj5')
# snams = c('Subj2');

allTimingResults = data.frame(matrix(0,length(modelList),length(snams)));
colnames(allTimingResults) = snams;

allNums = data.frame(matrix(0,length(snams),length(runs)+1))
rownames(allNums) = snams;
cnt = 1;

npars = c();

validNames = letters[runs];
validNames[length(validNames)+1] = "best";
colnames(allNums) = validNames;

for(s in snams)
{
  subjnam = s
  allRuns = letters[runs];
  nreps = length(allRuns);

  timingResults = data.frame(matrix(0,length(modelList), nreps+1));
  rownames(timingResults) = modelList;

  colnames(timingResults) = validNames;

  for(b in seq(1,length(modelList)))
  {

    model = modelList[b]
    # Pick best fit from the lot
    bestTime=Inf ; uselet=NULL # Fits cannot be worse than -Inf

    if(VERBOSE)
      cat(sprintf("\n%15s: ", model))

    # cat(paste("\n", "Model:", model,"\t"));
    for(m in seq(1,length(allRuns)))
    {
      fnam = allRuns[m];
      fileName = paste(resultsDir,subjnam,"-",model,"-",fnam,sep="") ;
      if(file.exists(fileName))
      {

        load(fileName)

        currTime = unname(out$timings[2])
        timingResults[model, m] = currTime

        npars[model] = length(out$pars);
        # Pick best model fit from each iteration
        if(currTime < bestTime)
        {
          # If fit for the current letter is better than the other fit, then
          # use this letter

          bestTime= currTime ;
          uselet=fnam;
          timingResults[model,"best"] = bestTime;
        }

        # Finish selecting
      }
      else
      {
        print(paste("Model:",model,'-',fnam, " not found",sep=""))
      }

    }

    if(VERBOSE)
      cat(paste("choosing ", uselet))
  }
  allNums[s,] = colSums(timingResults)
  allTimingResults[,subjnam]=rowMeans(timingResults);
  if(cnt==1){
    newData = timingResults[,1:5];
  }else
  {

    newData = cbind(newData, timingResults[,1:5]);
  }
  cnt = cnt + 1;

}

data = c()
cnt = 1;
for(s in snams)
{
  for(b in allRuns)
  {
        data[cnt] = allNums[s,b]
        cnt = cnt +1
  }
}

rownames(allTimingResults) = rownames(timingResults)

allTimingResults["meanV"] = rowMeans(allTimingResults);
allTimingResults = transform(allTimingResults, SEV=apply(allTimingResults/3600,1, sd, na.rm = TRUE)/sqrt(5));
allTimingResults["npars"] = npars;

currentModels = rownames(allTimingResults);
x = allTimingResults["meanV"]/3600
orderV = order(x)
dataFrame = data.frame(V=unname(x),Ve = unname(allTimingResults["SEV"]), npars=allTimingResults["npars"], modelId = as.factor(currentModels));
dataFrame$modelId = factor(dataFrame$modelId,
                           levels = dataFrame$modelId[order(dataFrame$V)])

p1=ggplot(dataFrame, aes(modelId,V), stat="identity");
p1=p1 + geom_col(alpha=0.3);
# p1 = p1 + geom_segment(aes(y=0,yend=V,x=modelId,xend=modelId));
p1=p1 + geom_errorbar(aes(ymin=V-Ve,ymax=V+Ve), width=0.2, position=position_dodge(.9));
p1=p1 + coord_flip() + theme_minimal()
p1=p1 + ggtitle(paste("Average Time"));
p1=p1 + theme(text = element_text(size=14));
p1=p1 + theme(aspect.ratio = 1) + labs(y = "Run time (Hrs)", x='Model');
p1=p1 + theme(panel.grid.minor = element_blank(), panel.grid.major.y = element_blank());

p2 = ggplot(dataFrame, aes(npars,V), stat="identity") +   geom_jitter(alpha=0.4, position = position_jitter(w=0.4,h=0.2, seed=1), size=5);
# p2 = p2 +  geom_errorbar(aes(ymin=V-Ve,ymax=V+Ve), width=0.2, position=position_dodge(.9));
p2 = p2 + theme_minimal()  + geom_text(label=rownames(dataFrame), position = position_jitter(w=0.5,h=0,seed=1));
p2 = p2 +  theme(aspect.ratio = 1) + theme(panel.grid.minor = element_blank(), panel.grid.major.y = element_blank());
p2 = p2 + theme(text = element_text(size=14));
p2 = p2 + theme(axis.line.x = element_line(color="black", size = .5),
      axis.line.y = element_line(color="black", size = .5), axis.ticks = element_line(size=0.5),axis.ticks.length = unit(.25, "cm") )
p2 = p2 +  labs(y = "Run time (Hrs)", x='Number of parameters');

library(reshape2)
newData[,"npars"] = npars;
d = melt(newData, id.vars="npars")
p3 = ggplot(d, aes(npars, value/3600), stat="identity");
p3 = p3 + geom_jitter(alpha=0.4, position = position_jitter(w=0.2,h=0.1, seed=1), size=2);
p3 = p3 +  theme(aspect.ratio = 1) + theme(panel.grid.minor = element_blank(), panel.grid.major.y = element_blank());
p3 = p3 + theme_minimal();
p3 = p3 + theme(axis.line.x = element_line(color="black", size = .5),
                axis.line.y = element_line(color="black", size = .5), axis.ticks = element_line(size=0.5),axis.ticks.length = unit(.25, "cm") )
p3 = p3 +  labs(y = "Run time (Hrs)", x='Number of parameters');
cor.test(formula=~value+npars, data = d)
grid.arrange(p1, p3, nrow=2, ncol=2)

out = list(timingData=d, allTiming = allTimingResults[,c("meanV", "SEV","npars")],
           allDurations=allNums);
save(out,file=whatToRun);


# last known normal line plotting
library(tidyr)
library(ggplot2)
library(scales)
library(dplyr, warn.conflicts = FALSE)
library(here)
library(readr)
library(cowplot)

# Read raw data.

col_names <- c('grp','month',paste('bin',c(1:14),sep='_'), 'unk_1','unk_2','total', paste('stat',c(1:4), sep='_'))
# "grp"     "month" "bin_1"   "bin_2"   "bin_3"   "bin_4"
# "bin_5"   "bin_6"   "bin_7"   "bin_8"   "bin_9"   "bin_10"
# "bin_11"  "bin_12"  "bin_13"  "bin_14"  "unk_1"   "unk_2"
# "total"   "stat_1"  "stat_2"  "stat_3"  "stat_4"

file_path <- file.path( here(), 'data', 'last_known_well.csv')
df <- read_csv( file_path, skip = 1, col_names = col_names)

# Munge raw data.
# Remove unused columns
# Strip out "helpful" percentages embedded in count data
# Add 'Q' and minor increments to time values (assuming they're in order)
# Convert the time bin variables to integers
df1 <- df %>%
  select(-grp, -starts_with('stat'), -starts_with('unk_')) %>%
  mutate_if(is.character, .funs='sub', pattern=' (.*)', replacement='') %>%
  mutate(month=factor(month.abb[month], levels=unique(month.abb[month]))) %>%
  mutate_at(vars(starts_with("bin_")), .funs=as.integer)

# Make plot data
# Sum the time bins as the numerator
# calculate the fraction of total cases with documented LKN
plot_data <- df1 %>%
  group_by(month) %>%
  gather(key=time_bin, value=count, starts_with("bin_")) %>%
  group_by(month, total) %>% summarize(numer=sum(count)) %>%
  mutate(fract=numer/total)

# Make a line plot with point size indicating number of cases
plot <- ggplot(plot_data, aes(x = month, y = 100*fract, group=1)) +
  geom_line() +
  geom_point(aes(size=total)) +
  scale_size_continuous(guide=guide_legend(title="Number\nof Cases")) +
  scale_y_continuous(breaks=pretty_breaks(), limits=c(0,100), expand=c(0,0)) +
  labs(title = "Last Known Well Documented", x = "Time Point", y = "% of Cases Documented")
plot_pointsize

# Make a line plot
plot <- ggplot(plot_data, aes(x = month, y = 100*fract, group=1)) +
  geom_line(size=2) +
  geom_point(size=2) +
  scale_y_continuous(breaks=pretty_breaks(), limits=c(0,100), expand=c(0,0)) +
  labs(title = "Last Known Well Documented", x = "Month", y = "% of Cases Documented")
plot

# Make a table to go with it. Export csv or xlsx
outpath = file.path(here(), "last_known_well_summary.csv")
export_data <- plot_data %>%
  mutate(perc=fract*100) %>%
  rename(Month=month, "Documented Cases"=numer, "Total Cases"=total, "% Documented"=perc) %>%
  select(-fract) %>%
  write_csv(outpath)


#' @export
DipIndex <- function(){
  preInums <- unique(alleleMat[,1])
  tetNums <- array()
  dipNums <- array()
  for(i in 1:length(preInums)){
    rowRef <- which(grepl(paste(c("^I",preInums[i],"$"), collapse = ""), info$Individual))
    if (info$PrePloidy[rowRef]==4){
      tetNums <- c(tetNums, preInums[i])
    }
    else if (info$PrePloidy[rowRef]==2){
      dipNums <- c(dipNums, preInums[i])
    }
    else{}
  }
  tetNums <- tetNums[2:length(tetNums)]
  dipNums <- dipNums[2:length(dipNums)]
  alleleAgreeMat <- matrix(nrow=length(tetNums)+6, ncol=numLoci+1)
  alleleAgreeMat[1,] <- c("Individual",testLoci)
  alleleAgreeMat[,1] <- c("Individual", tetNums, "Individuals with 4 alleles", "Percent Individuals Retained", "Retention against reference", "Avg", "Y/N Non-Dip")
  nonDipLoci <- array()

  refAgreeMat <- matrix(nrow=length(dipNums)+4, ncol=numLoci+1)
  refAgreeMat[1,] <- c("Individual",testLoci)
  refAgreeMat[,1] <- c("Individual", dipNums, "Individuals with 4 alleles", "Percent Individuals Retained", "Avg")
  library(Matrix)
  for (i in 1:length(tetNums)){
    tempAllele <- alleleMat[alleleMat[,1]==tetNums[i],]
    for (j in 1:numLoci){
      allAgree <- 0
      if (testLoci[j] %in% tempAllele[,2] == TRUE){
        tempLoc <- matrix(ncol = length(tempAllele[1,]))
        tempLoc <- rbind(tempLoc, tempAllele[tempAllele[,2]==testLoci[j],])
        for(k in 1:(length(tempLoc[,1])-1)){
          #if(nnzero(tempLoc[k+1,3:8]) == 6){
          #	allAgree <- 1
          #}
          #else{}
          allAgree <- nnzero(tempLoc[k+1,3:8])
          if(allAgree == 0){

          }
          else{allAgree <- allAgree - 2}
        }
      }
      else{}
      alleleAgreeMat[i+1,j+1] <- allAgree
    }

  }

  for (i in 1:length(dipNums)){
    tempAllele <- alleleMat[alleleMat[,1]==dipNums[i],]
    for (j in 1:numLoci){
      allAgree <- 0
      if (testLoci[j] %in% tempAllele[,2] == TRUE){
        tempLoc <- matrix(ncol = length(tempAllele[1,]))
        tempLoc <- rbind(tempLoc, tempAllele[tempAllele[,2]==testLoci[j],])
        for(k in 1:(length(tempLoc[,1])-1)){
          if(nnzero(tempLoc[k+1,3:8]) >= 4){
            allAgree <- 2
          }
          else{allAgree <- nnzero(tempLoc[k+1,3:8])
          if(allAgree == 0){}
          else{allAgree <- allAgree - 2}
          }
        }
      }
      else{}
      refAgreeMat[i+1,j+1] <- allAgree
    }

  }

  for (i in 1:numLoci){

    tempCol <- refAgreeMat[2:(length(refAgreeMat[,1])-3), i+1]
    refAgreeMat[length(refAgreeMat[,1])-2,i+1] <- sum(as.numeric(tempCol==2))
    refDiv <- sum(as.numeric(tempCol==2))/length(tempCol)
    refAgreeMat[length(refAgreeMat[,1])-1,i+1] <- refDiv
    refAgreeMat[length(refAgreeMat[,1]),i+1] <- mean(as.numeric(tempCol))
    projAlleleNum <- mean(as.numeric(tempCol))*2 ##### Really div by 2 and times 4 but you know

    tempCol <- alleleAgreeMat[2:(length(alleleAgreeMat[,1])-5), i+1]
    alleleAgreeMat[length(alleleAgreeMat[,1])-4,i+1] <- sum(as.numeric(tempCol==4))
    tetDiv <- sum(as.numeric(tempCol==4))/length(tempCol)
    alleleAgreeMat[length(alleleAgreeMat[,1])-3,i+1] <- tetDiv
    retPercent <- if(tetDiv==0 & refDiv==0) {"Conserved Across"} else{tetDiv/refDiv}
    alleleAgreeMat[length(alleleAgreeMat[,1])-2,i+1] <- retPercent
    meanAlleleComps <- mean(as.numeric(tempCol))
    alleleAgreeMat[length(alleleAgreeMat[,1])-1,i+1] <- meanAlleleComps
    if(meanAlleleComps <= projAlleleNum+-0.1){
      alleleAgreeMat[length(alleleAgreeMat[,1]),i+1]	<- 0
    }
    else{
      alleleAgreeMat[length(alleleAgreeMat[,1]),i+1]	<- 1
      nonDipLoci <- c(nonDipLoci, alleleAgreeMat[1,i+1])

    }
  }
  nonDipLoci <- as.numeric(nonDipLoci[2:length(nonDipLoci)])
  assign("nonDipLoci", nonDipLoci, globalenv())
  write.table(nonDipLoci, file = paste(c(str1,"/PloidyRFiles/nonDipLoci.txt"), collapse = ""), row.names=FALSE, 		col.names=FALSE, sep=",")
  assign("alleleAgreeMat", alleleAgreeMat, globalenv())
  write.table(alleleAgreeMat, file = paste(c(str1,"/PloidyRFiles/DiploidizationIndex.csv"), collapse = ""), row.names=FALSE, 		col.names=FALSE, sep=",")

  assign("refAgreeMat", refAgreeMat, globalenv())
  write.table(refAgreeMat, file = paste(c(str1,"/PloidyRFiles/RefDipIndex.csv"), collapse = ""), row.names=FALSE, 			   col.names=FALSE, sep=",")
}


#############################################################################
##
#W  id1600.r               GAP library of id's             Hans Ulrich Besche
##

ID_GROUP_TREE.next[1600].next[18]:=
rec(
  fp:= [ 43497, 77397 ],
  next:= [, rec(
    fp:= [ 1736, 4636, 12307, 25627, 26575, 27523, 28471, 36698, 39542,
40724, 42386, 45230, 45585, 50446, 55307, 55789, 65029, 69890, 73644, 74751,
74932, 79612, 79827, 85515, 89334, 91203, 94195 ],
    next:= [ rec(
      desc:= [ 106002 ],
      fp:= [ 16, 412 ],
      next:= [ 10108, 10129 ] ), rec(
      fp:= [ 17094, 17554, 53328, 58068, 71560, 86232 ],
      next:= [ 8885, 8261, 8886, 8263, 8259, 8260 ] ), rec(
      fp:= [ 431, 2337, 4030, 24279, 41385, 47524, 53103, 64127, 70165,
71081, 88546, 92642, 92672, 96104, 98077 ],
      next:= [ 8150, 8148, 8113, 8138, 8149, 8151, 8137, 8109, 8108, 8139,
8110, 8112, 8165, 8111, 8147 ] ), 10150, rec(
      fp:= [ 24685, 29865 ],
      next:= [ 10138, 10137 ] ), rec(
      fp:= [ 1808, 29821, 34644, 68752 ],
      next:= [ 10132, 10146, 10133, 10145 ] ), rec(
      fp:= [ 83877, 98549 ],
      next:= [ 10142, 10141 ] ), rec(
      fp:= [ 28541, 40587, 60224, 67858 ],
      next:= [ 9935, 9938, 9937, rec(
        desc:= [ 113003 ],
        fp:= [ 28, 820 ],
        next:= [ 9934, 9936 ] ) ] ), rec(
      fp:= [ 30216, 71720 ],
      next:= [ 9917, 9918 ] ), rec(
      fp:= [ 29560, 36637, 91224 ],
      next:= [ 9960, 9958, 9961 ] ), rec(
      fp:= [ 230, 1199, 6512, 23062, 82542, 89443, 92624 ],
      next:= [ rec(
        desc:= [ 114003 ],
        fp:= [ 18, 414 ],
        next:= [ 9903, 9905 ] ), 9906, 9901, rec(
        desc:= [ 117003 ],
        fp:= [ 18, 414 ],
        next:= [ 9900, 9902 ] ), 9898, rec(
        desc:= [ 115003 ],
        fp:= [ 22, 814 ],
        next:= [ 9899, 9897 ] ), 9904 ] ), rec(
      fp:= [ 1771, 66516 ],
      next:= [ 9924, 9925 ] ), rec(
      fp:= [ 81628, 95129 ],
      next:= [ 10001, 9999 ] ), rec(
      fp:= [ 16307, 82649 ],
      next:= [ 9985, 9982 ] ), rec(
      fp:= [ 55637, 89990 ],
      next:= [ 9976, 9974 ] ), rec(
      fp:= [ 2695, 18737, 54763 ],
      next:= [ 9699, 9661, 9698 ] ), rec(
      fp:= [ 20003, 39112, 61573, 67371, 75511, 95736, 96775, 97375 ],
      next:= [ 9953, 9952, 9955, 9962, 9950, 9957, 9959, 9954 ] ), rec(
      fp:= [ 29495, 53479, 61314 ],
      next:= [ 9996, 9997, 9994 ] ), rec(
      fp:= [ 32163, 35134, 36096, 41707, 48701, 71488, 99108 ],
      next:= [ 8257, 8262, 8255, 8883, 8256, 8254, 8884 ] ), rec(
      fp:= [ 39478, 83051 ],
      next:= [ 9984, 9983 ] ), rec(
      fp:= [ 12579, 15609, 19148, 45579, 84287, 86731, 95368 ],
      next:= [ 9630, 9625, 9629, 9624, 9623, 9618, 9617 ] ), rec(
      fp:= [ 15834, 36276 ],
      next:= [ 9975, 9973 ] ), rec(
      fp:= [ 47673, 76089 ],
      next:= [ rec(
        desc:= [ 108002 ],
        fp:= [ 16, 412 ],
        next:= [ 10095, 10116 ] ), rec(
        desc:= [ 108002 ],
        fp:= [ 16, 412 ],
        next:= [ 10096, 10117 ] ) ] ), rec(
      fp:= [ 13666, 35854, 60619, 66668 ],
      next:= [ rec(
        desc:= [ 106002 ],
        fp:= [ 16, 412 ],
        next:= [ 10090, 10111 ] ), rec(
        desc:= [ 108002 ],
        fp:= [ 16, 412 ],
        next:= [ 10104, 10125 ] ), rec(
        desc:= [ 110002 ],
        fp:= [ 16, 412 ],
        next:= [ 10103, 10124 ] ), rec(
        desc:= [ 110002 ],
        fp:= [ 16, 412 ],
        next:= [ 10091, 10112 ] ) ] ), rec(
      fp:= [ 39996, 44853, 99124 ],
      next:= [ 9949, 9951, 9956 ] ), rec(
      fp:= [ 15152, 34638 ],
      next:= [ rec(
        desc:= [ 106002 ],
        fp:= [ 16, 412 ],
        next:= [ 10099, 10120 ] ), rec(
        desc:= [ 108002 ],
        fp:= [ 16, 412 ],
        next:= [ 10100, 10121 ] ) ] ), rec(
      fp:= [ 66975, 72848 ],
      next:= [ 10000, 9995 ] ) ] ) ] );


library(ggplot2)

# this one weird value will appear in your data for no reason
weirdval=0.179973493896357
#weirdval=-0.229395386677444

timedata<-function(time){
     gs<-read.table(paste0("FP_",time,"min.gs.predictions.bedGraph.gz"))
     gb<-read.table(paste0("FP_",time,"min.gb.predictions.bedGraph.gz"))
     ng<-read.table(paste0("FP_",time,"min.ng.predictions.bedGraph.gz"))
     region<-c(rep("gene_start",nrow(gs)),rep("gene_body",nrow(gb)),rep("non_gene",nrow(ng)))
     region<-factor(region,c("gene_start","gene_body","non_gene"))
     score<-c(gs[,4],gb[,4],ng[,4])
     time<-rep(paste0(time,"min"),length(score))
     td<-data.frame(score,region,time)
     return(td)
}

alldata<-timedata(0)
cat("Loaded 0min\n")
alldata<-rbind(alldata,timedata(2))
cat("Loaded 2min\n")
alldata<-rbind(alldata,timedata(5))
cat("Loaded 5min\n")
alldata<-rbind(alldata,timedata(12.5))
cat("Loaded 12.5min\n")
alldata<-rbind(alldata,timedata(25))
cat("Loaded 25min\n")
alldata<-rbind(alldata,timedata(50))
cat("Loaded 50min\n")

# Check for that weird value, delete it...
print(mean(alldata$score==weirdval))
alldata<-alldata[alldata$score!=weirdval,]

region_cols<-c("firebrick1","orange1","turquoise3","gray")
ggplot(alldata,aes(x=score,fill=region))+geom_histogram(binwidth=0.01)+facet_wrap(time~region,ncol=3,scales="free")+scale_fill_manual(values=region_cols)+theme_bw()
ggsave("dREG_scores_hist.pdf")


### Seq-Gen output analysis
### CIR Project
### Advisors: Steve Freedberg, Matthew Richey

#######installing packages:
if (!require('seqinr')) {
	install.packages('seqinr', repos="http://cran.rstudio.com/")
	library('seqinr')
}
if (!require('mosaic')) {
	install.packages('mosaic', repos="http://cran.rstudio.com/")
	install.packages('mosaicData', repos="http://cran.rstudio.com/")
	library('mosaic')
}

options(echo=FALSE) # if you want see commands in output file
args <- commandArgs(trailingOnly = TRUE)
print(args)

##################################################
# We want to compare the two individuals to find a Hamming
# distance between them. That is, how many base pairs differ
# between the two sequences.

# To do this, we must compare each base pair, one at a time.
# Let's make a function for comparing the pieces of the string:
Hamming <- function (x,y) {
 # note that the parameters x and y should be
 counter <- 0   # to track the number of base pairs different
 index <- 1     # to keep track of indices in for loop
 for (i in x) {
   if (i != y[index]) {
     counter <- counter + 1
   }
   index <- index + 1
 }
 return(counter)    #returns number of base pairs that differ
}

LoadDataFromFile <- function(fname) {
  ##################################################
  ##################################################
  # Generalizing to Larger Files
  # The above code works for a file of only two individuals, but
  # we wish to generalize this so that it can be used for multiple
  # pairs of individuals and store the appropriate data.

  # Note that for now, we will assume that all sequences in a
  # single file have the same length.

  ### First Steps
  # read in the data:
  # --infile ~/Desktop/test_seq.txt
  # store to filename variable
  data <- read.fasta(file=fname, as.string=TRUE)
  # head(data)     # look at the data
  # get the number of sequences included in the data
  len <- length(data)
  # create a vector of every other integer up to len for the loop
  list <- seq(1, len, 2)
  # store the original names of the sequences:
  orig_names <- names(data)

  ##################################################
  # We create a for loop to cycle through the pairs and compare
  # each one. The loop will record it's findings in a list called
  # out.
  out <- seq(1:(len/2))    # out is initialized with fillers

  for (i in list) {
   names(data)[i] <- "indiv1"
   names(data)[i+1] <- "indiv2"
   length <- nchar(data$indiv1[1])
   taxon1 <- substring(data$indiv1[1],
                       seq(1,length,1), seq(1,length,1))
   taxon2 <- substring(data$indiv2[1],
                       seq(1,length,1), seq(1,length,1))
   index <- (i-1)/2 + 1
   out[index] <- Hamming(taxon1, taxon2)
  }

  # Now "out" is filled with Hamming distances of all pairs
  print(out)    # desired output

  ##################################################
  # Simple Statistics from the data:
  avgOfRange <- mean(out)      # average
  minOfRange <- min(out)       # minimum of range
  maxOfRange <- max(out)       # maximum of range
  percent <- avgOfRange / len

  print(avgOfRange)
  print(minOfRange)
  print(maxOfRange)
  print(percent)

}

# LoadDataFromFile("~/Desktop/test_seq.txt")

EstimateGenerations <- function(genlength, percent) {
  ##################################################
  ##################################################
  # Estimating Generations:
  # Assume 2% per million years (standard for cytochrome B)
  # mutation rate. This allows us to calculate a likely divergence
  # time, from which we can estimate generations:
  divtime <- percent/0.02
  print(divtime)   # divergence time in million years
  gen <- divtime*1000000/genlength
  print(gen)       # number of generations (used for seq gen parameters)
}

# EstimateGenerations(10, 0.2)#?


#########################################################################################
# Script to average disclosure features across each disclosure
# Eleanor Collier
# 11/01/21
#########################################################################################

# Set up workspace
library(tidyverse)

get_data_here  <- "/Volumes/GoogleDrive/My Drive/UCR/UCR SNL/Research Projects/SyncDisclosures/Pilot/Analysis/Data/processed/moment_to_moment/"
save_data_here <- "/Volumes/GoogleDrive/My Drive/UCR/UCR SNL/Research Projects/SyncDisclosures/Pilot/Analysis/Data/processed/mean_by_disclosure/"

#########################################################################################
## Collapse transcripts by word across each disclosure ----
# Load data
transcripts_by_word <- read_csv(paste0(get_data_here, "transcripts_by_word.csv"))

# Collapse transcripts across disclosures
transcripts <- transcripts_by_word %>%
  group_by(ID, disclosure) %>%
  summarise(text = paste(text, collapse=" ")) %>%
  ungroup()

# Save data
write_csv(transcripts, paste0(save_data_here, "transcripts.csv"))

#########################################################################################
## Average accoustic features across each disclosure ----
# Load data
accoustic_features_by_time <- read_csv(paste0(get_data_here, "accoustic_features_by_time.csv"))

# Average across disclosures (only including instances of speech)
mean_accoustic_features <- accoustic_features_by_time %>%
  mutate(sound = case_when(pitch > 0 ~ 'speaking', pitch == 0 ~ 'silence')) %>%
  filter(sound=='speaking') %>%
  group_by(ID, disclosure) %>%
  summarise_at(
    vars(pitch:f4),
    ~ mean(., na.rm=T)
  ) %>%
  ungroup()

# Get max accoustic features (only including instances of speech)
max_accoustic_features <- accoustic_features_by_time %>%
  mutate(sound = case_when(pitch > 0 ~ 'speaking', pitch == 0 ~ 'silence')) %>%
  filter(sound=='speaking') %>%
  group_by(ID, disclosure) %>%
  summarise_at(
    vars(pitch:shimmer),
    ~ max(., na.rm=T)
  ) %>%
  rename_at(vars(pitch:shimmer), ~paste0(., "_max")) %>%
  ungroup()

# Get span of accoustic features (only including instances of speech)
span_accoustic_features <- accoustic_features_by_time %>%
  mutate(sound = case_when(pitch > 0 ~ 'speaking', pitch == 0 ~ 'silence')) %>%
  filter(sound=='speaking') %>%
  group_by(ID, disclosure) %>%
  summarise_at(
    vars(pitch:intensity),
    ~ max(., na.rm=T) - min(., na.rm=T)
  ) %>%
  rename_at(vars(pitch:intensity), ~paste0(., "_span")) %>%
  ungroup()

accoustic_features <- mean_accoustic_features %>%
  left_join(max_accoustic_features, by=c("ID", "disclosure")) %>%
  left_join(span_accoustic_features, by=c("ID", "disclosure"))

# Save data
write_csv(accoustic_features, paste0(save_data_here, "accoustic_features.csv"))

#########################################################################################
## Average prosody across each disclosure ----


# Data Wrangling in R
# Austin Water Quality Case Study

# Load in the libraries that we'll need
library(tidyverse)
library(stringr)
library(lubridate)

# Read in the dataset
water <- read_csv('http://594442.youcanlearnit.net/austinwater.csv')

# Let's take a look at what we have
glimpse(water)


#rm(list=ls(all=TRUE))
#data_fn="tmp/"
#folder_fn="results-benchmark-binary"
#results_fn=paste(data_fn,folder_fn,"/raw",sep="")
#outtxt_fn=paste(data_fn,folder_fn,"/results-text.txt",sep="")
#results_fn="raw"
#outtxt_fn="results-text.txt"

configs.threads=1
#configs.loop=10
#configs.recursion=c(10)
#configs.labels=c("No Probe","Inactive Probe","Collecting Data","Writing Data (ASCII)", "Writing Data (Bin)")
configs.count=length(configs.labels)
#results.count=2000000
#results.skip=1000000

#bars.minval=500
#bars.maxval=600

throughput = array(list(),dim=c(length(configs.recursion),configs.count))
## "[ recursion , config , loop ]"
resultsBIG <- array(dim=c(length(configs.recursion),configs.count,configs.threads*configs.loop*(results.count-results.skip)),dimnames=list(configs.recursion,configs.labels,c(1:(configs.threads*configs.loop*(results.count-results.skip)))))
for (cr in configs.recursion) {
  for (cc in (1:configs.count)) {
    recordsPerSecond = c()
    rpsLastTime = 0
    rpsCount = 0
    for (cl in (1:configs.loop)) {
      results_fn_temp=paste(results_fn, "-", cl, "-", cr, "-", cc, ".csv", sep="")
      for (ct in (1:configs.threads)) {
        results=read.csv2(results_fn_temp,nrows=(results.count-results.skip),skip=(ct-1)*results.count+results.skip,quote="",colClasses=c("NULL","numeric"),comment.char="",col.names=c("thread_id","duration_nsec"),header=FALSE)
        resultsBIG[(1:length(configs.recursion))[configs.recursion==cr],cc,c(((cl-1)*configs.threads*(results.count-results.skip)+1):(cl*configs.threads*(results.count-results.skip)))] <- results[["duration_nsec"]]/(1000)

        for (timeForRecord in results[["duration_nsec"]]) {
          if (rpsLastTime + timeForRecord >= 1000000000) {
						recordsPerSecond <- c(recordsPerSecond, rpsCount)
						rpsCount = 0
						rpsLastTime = 1000000000 - rpsLastTime
					}
					while (timeForRecord > 1000000000) {
						recordsPerSecond <- c(recordsPerSecond, 0)
						timeForRecord = timeForRecord - 1000000000
					}
					rpsCount = rpsCount + 1
					rpsLastTime = rpsLastTime + timeForRecord
				}
      }
      rm(results,results_fn_temp)
    }
    recordsPerSecond <- c(recordsPerSecond, rpsCount)
    throughput[[(1:length(configs.recursion))[configs.recursion==cr],cc]] <- recordsPerSecond
    rm(recordsPerSecond,rpsLastTime,rpsCount)
  }
}

for (cr in configs.recursion) {
  printvalues = matrix(nrow=7,ncol=configs.count,dimnames=list(c("mean","ci95%","md25%","md50%","md75%","max","min"),c(1:configs.count)))
  printthrough = matrix(nrow=7,ncol=configs.count,dimnames=list(c("mean","ci95%","md25%","md50%","md75%","max","min"),c(1:configs.count)))
  for (cc in (1:configs.count)) {
    printvalues["mean",cc]=mean(resultsBIG[(1:length(configs.recursion))[configs.recursion==cr],cc,c(1:(results.count-results.skip))])
    printvalues["ci95%",cc]=qnorm(0.975)*sd(resultsBIG[(1:length(configs.recursion))[configs.recursion==cr],cc,c(1:(results.count-results.skip))])/sqrt(length(resultsBIG[(1:length(configs.recursion))[configs.recursion==cr],cc,c(1:(results.count-results.skip))]))
    printvalues[c("md25%","md50%","md75%"),cc]=quantile(resultsBIG[(1:length(configs.recursion))[configs.recursion==cr],cc,c(1:(results.count-results.skip))],probs=c(0.25,0.5,0.75))
    printvalues["max",cc]=max(resultsBIG[(1:length(configs.recursion))[configs.recursion==cr],cc,c(1:(results.count-results.skip))])
    printvalues["min",cc]=min(resultsBIG[(1:length(configs.recursion))[configs.recursion==cr],cc,c(1:(results.count-results.skip))])
    printthrough["mean",cc]=mean(throughput[[(1:length(configs.recursion))[configs.recursion==cr],cc]])
    printthrough["ci95%",cc]=qnorm(0.975)*sd(throughput[[(1:length(configs.recursion))[configs.recursion==cr],cc]])/sqrt(length(throughput[[(1:length(configs.recursion))[configs.recursion==cr],cc]]))
    printthrough[c("md25%","md50%","md75%"),cc]=quantile(throughput[[(1:length(configs.recursion))[configs.recursion==cr],cc]],probs=c(0.25,0.5,0.75))
    printthrough["max",cc]=max(throughput[[(1:length(configs.recursion))[configs.recursion==cr],cc]])
    printthrough["min",cc]=min(throughput[[(1:length(configs.recursion))[configs.recursion==cr],cc]])
  }
  resultstext=formatC(printvalues,format="f",digits=4,width=8)
  throughtext=formatC(printthrough,format="f",digits=1,width=12)
  print(resultstext)
  print(throughtext)
  write(paste("Recursion Depth: ", cr),file=outtxt_fn,append=TRUE)
  write("response time",file=outtxt_fn,append=TRUE)
  write.table(resultstext,file=outtxt_fn,append=TRUE,quote=FALSE,sep="\t",col.names=FALSE)
  write("Throughput",file=outtxt_fn,append=TRUE)
  write.table(throughtext,file=outtxt_fn,append=TRUE,quote=FALSE,sep="\t",col.names=FALSE)

  concResult <- ""
  headResult <- ""
  for (cc in (1:(configs.count-1))) {
    headResult <- paste(headResult, configs.labels[cc], ",");
	concResult <- paste(concResult, printvalues["mean",cc], ",")
  }
  headResult <- paste(headResult, configs.labels[configs.count])
  concResult <- paste(concResult, printvalues["mean",configs.count])

  write(headResult,file=outcsv_fn,append=TRUE)
  write(concResult,file=outcsv_fn,append=TRUE)
}


#Governance - 'Branch as Colored Coin' Version
rm(list=ls())
#Function Library
tryCatch(expr=setwd("~/GitHub/Truthcoin/lib"), error=function(e) setwd(choose.dir(caption="Failed to set working directory automatically. Choose 'lib' folder:")) )
source(file="market/Markets.r")
source(file="consensus/ConsensusMechanism.r")
Sha256 <- function(x) digest(unlist(x),algo='sha256',serialize=FALSE)

GenesisBlock <- list(

  # Block Ordering Stuff
  "Bn"=1,               # Block Number
  "h.B.1"=Sha256(""),   # Hash of previous block
  "Time"=Sys.time(),    # System Date and Time
  "Nonce"=1,

  "Branches"=Branches,  # Branch Data (List)
  "Markets"=Markets,    # Market Data (List)

  "Funds"=data.frame("id"=c("A","B","C"),
                     "value"=c(30, 999, 2))   # Cash

  )

BlockChain <- list(NA,GenesisBlock)
# Setup Complete

# Problem: Current functions optimized for testing/collaborate-knowledge.
# Getting more specific would tangle these functions into blockchain-specific data structures, and integrate the moving parts.
# This would make understanding (even running) the code much more difficult.
# Therefore, I think it is time to stop the reference implementation. The remaining design specification, ValidateBlock(), is below.
# Please email me at truthcoin@gmail.com or visit the Development section of our forum ( forum.truthcoin.info ) for help from this point.

### - ValidateBlock - ###

## Chain Integrity
# contains hash of previous block
# hash is below target

## Branch Integrity
# branches added correctly
# existing branches are paying fees
# is it time for Voting? if so, freeze Reputation-Currency, build VoteMatrix and ask for encrypted votes
# is it time for Unsealing? if so, freeze VoteMatrix and ask for unseals
# is it time for SVD? if so, run Factory()

## Decisions Integrity
# Decisions added correctly
# Did SVD resolve any decisions last period? if so update 'Decisions'

## Market Integrity
# Did a Market's Decisions SVD-resolve? if so GetFinalPrices( Market )

## Transactions
# are all transactions valid
# (reminder: reputation cannot be moved during vote-periods)


# takes g_inputdir,g_filetable and g_outputdir
##and g_supress_paints
# return general plots, speed walks,..

### R CODE ###
##############
group_ids = levels(factor(group))
message("starting general.r")

### speed boxplot
average_speeds = c()

#compute speeds for each individum
for (i in c(1:nrow(id_table))) {
	speeds = c.speeds(traj[id(traj)==id_table$id[i]])$speed_det
	speeds = speeds[speeds>0]
	speeds = speeds[!speeds>50]
#   hist (speeds, breaks=50)
	average_speeds = c(average_speeds,median(speeds,na.rm=TRUE))
}

#speed_table = data.frame(speeds=average_speeds,group=id_table$group)

#speed_mtable = create.mean.table(speed_table,group_ids)

#mybarplot(speed_mtable$means$speeds,speed_mtable$ses$speeds, rownames = group_ids,
#	main="Speed plot",ylab="Average walking speed [mm/s]", ylim = c(0,ylim_speed))

### distance boxplot
#compute distance for each individum
distances = c()
for (i in c(1:nrow(id_table))) {
	dist = c.distance(traj[id(traj)==id_table$id[i]])
	distances = c(distances,dist)
}

f_table = data.frame(f_table,median_speed=average_speeds,distance_traveled_mm__permin=distances)

f_table_positive= data.frame(f_table_positive,median_speed=average_speeds,distance_traveled_mm__permin=distances)

#dist_table = data.frame(dist=distances,group=id_table$group)
#dist_mtable = create.mean.table(dist_table,group_ids)

# mybarplot(dist_mtable$means$dist,dist_mtable$ses$dist, rownames = group_ids,
	# main="Walking distance plot",ylab="Total walking distance [mm]", ylim = c(0,ylim_walkdist))

#walk_table = data.frame(walks,group=id_table$group)
#walk_mtable = create.mean.table(walk_table,group_ids)
# mybarplot(walk_mtable$means$walks,walk_mtable$ses$walks,rownames = group_ids,
	# main="Walks between stripes",ylab="Number of walks", ylim = c(0,ylim_walks))

#setwd(rgghome)


#' Generate a Random Alphanumeric.
#'
#' @param len The length of the alphanumeric to produce.
#'
#' @return An alphanumeric string.
rand_alphanumeric = function(len = 3) {
    population <- c(rep(0:9, each = 5), LETTERS, letters)
    samp <- sample(population, len, replace = TRUE)
    return(paste(samp, collapse = ''))
}


rma_norm = function(path, out_path, time, event,target){
  pacman::p_load(survminer)

  data = read.csv(path, check.names = F, header = TRUE, row.names = 1)

  res = surv_cutpoint(data = data, time = time, event = event, variables = target)

  write.csv(res$cutpoint, file = out_path)

return(df_result_r)
}

arguments = function(){
  pacman::p_load(optparse)
  option_list = list(
    make_option(c("-f", "--file"), type="character", default=NULL,
                help="dataset file name", metavar="character"),
    make_option(c("-o", "--out"), type="character", default=NULL,
                help="Out file name/path", metavar="character"),
    make_option(c("-t", "--time"), type="character", default="time",
                help="Time Column", metavar="character"),
    make_option(c("-e", "--event"), type="character", default="event",
                help="Event Column", metavar="character"),
    make_option(c("-g", "--target"), type="character", default="target",
                help="Event Column", metavar="character")
  );

  opt_parser = OptionParser(option_list=option_list);
  opt = parse_args(opt_parser);
  return(opt)
}

arg = arguments()

print(rma_norm(arg$file, arg$out, arg$time, arg$event,arg$target))


#r script
#Visualising the data, obs can be used by copy and paste the commands into the r script where the data is loaded and DEseq2 analysis is run.

#plotting the results
#MA plot (but Volcanoplot is better)
par(mfrow=c(2,2))
plotMA(res_All_Body_contr_plant, main= "All, Lot vs Dor")
plotMA(res_Instar3_Pop_Host, main="Instar3, Lot vs Dor")
plotMA(res_Instar5M_Pop_Host, main="Instar5M, Lot vs Dor")
plotMA(res_Instar5F_Pop_Host, main="Instar5F, Lot vs Dor")
plotMA(res_All_Body_contr, main="All, span vs swe")
plotMA(res_Instar3_contr1_Pop, main="Instar3, span vs swe")
plotMA(res_Instar5M_contr1_Pop, main="Instar5M, span vs swe")
plotMA(res_Instar5F_contr1_Pop, main="Instar5F, span vs swe")

plotCounts(ddsAll_Body, gene=which.min(res_All_Body$padj), intgroup="Hostplant", xlab = "All")
plotCounts(ddsInstar3_Pop_Host, gene=which.min(res_Instar3_Pop_Host$padj), intgroup="Hostplant", xlab = "Instar 3")
plotCounts(ddsInstar5M_Pop_Host, gene=which.min(res_Instar5M_Pop_Host$padj), intgroup="Hostplant", xlab = "Instar 5 Male")
plotCounts(ddsInstar5F_Pop_Host, gene=which.min(res_Instar5F_Pop_Host$padj), intgroup="Hostplant", xlab = "Instar 5 Female")

#Heatmap
install.packages("pheatmap")
library("pheatmap")

#All
All_Body.ntd <- normTransform(ddsAll_Body)
select_All_Body <- order(rowMeans(counts(ddsAll_Body,normalized=TRUE)),
                         decreasing=TRUE)

All_Body.df <- as.data.frame(colData(ddsAll_Body)[,c("Population", "Hostplant")])
pheatmap(assay(All_Body.ntd)[select_All_Body,order(All_Body.ntd$Hostplant)], cluster_rows=FALSE, show_rownames=FALSE,
         cluster_cols=FALSE, annotation_col=All_Body.df)

#cluster columns
All_Body.df <- as.data.frame(colData(ddsAll_Body)[,c("Population", "Hostplant", "Stage")])
pheatmap(assay(All_Body.ntd)[select_All_Body,order(All_Body.ntd$Hostplant)], cluster_rows=FALSE, show_rownames=FALSE,
         cluster_cols=TRUE, annotation_col=All_Body.df)

#Instar5
Instar5_Body.ntd <- normTransform(ddsInstar5_Body)
select_Instar5_Body <- order(rowMeans(counts(ddsInstar5_Body,normalized=TRUE)),
                             decreasing=TRUE)
Instar5_Body.df <- as.data.frame(colData(ddsInstar5_Body)[,c("Population", "Hostplant")])
pheatmap(assay(Instar5_Body.ntd)[select_Instar5_Body,order(Instar5_Body.ntd$Hostplant)], cluster_rows=FALSE, show_rownames=FALSE,
         cluster_cols=FALSE, annotation_col=Instar5_Body.df)

#Instar3
Instar3.ntd <- normTransform(ddsInstar3_Pop_Host)
select_Instar3 <- order(rowMeans(counts(ddsInstar3_Pop_Host,normalized=TRUE)),
                        decreasing=TRUE)
Instar3.df <- as.data.frame(colData(ddsInstar3_Pop_Host)[,c("Population", "Hostplant")])
pheatmap(assay(Instar3.ntd)[select_Instar3,order(Instar3.ntd$Hostplant)], cluster_rows=FALSE, show_rownames=FALSE,
         cluster_cols=FALSE, annotation_col=Instar3.df)

#PCA
library(ggplot2)
All_Body.vsd <- varianceStabilizingTransformation(ddsAll_Body, blind = T)
plotPCA(All_Body.vsd, intgroup=c("Hostplant","Population")) + theme_minimal() + ggtitle("PCA All")

par(mfrow=c(2,2))
plotPCA(All_Body.vsd, intgroup=c("Hostplant","Population", "Stage")) + theme_minimal()
plotPCA(All_Body.vsd, intgroup=c("Stage")) + theme_minimal() + ggtitle("PCA All Instar 3 vs 5")
plotPCA(All_Body.vsd, intgroup=c("Population")) + theme_minimal() + ggtitle("PCA All Population")
plotPCA(All_Body.vsd, intgroup=c("Hostplant")) + theme_minimal() + ggtitle("PCA All Hostplant")

Instar5_Body.vsd <- varianceStabilizingTransformation(ddsInstar5_Body, blind = T)
pcaInstar5_body <- plotPCA(Instar5_Body.vsd, intgroup=c("Population", "Hostplant")) + ggtitle("PCA Instar 5")
plotPCA(Instar5_Body.vsd, intgroup=c("Hostplant")) + theme_minimal() + ggtitle("PCA Instar 5 Hostplant")
plotPCA(Instar5_Body.vsd, intgroup=c("Population")) + theme_minimal() + ggtitle("PCA Instar 5 Population")
plotPCA(Instar5_Body.vsd, intgroup=c("Sex")) + theme_minimal() + ggtitle("PCA Instar 5 Sex")
plotPCA(Instar5_Body.vsd, intgroup=c("Family")) + theme_minimal() + ggtitle("PCA Instar 5 Family")

Instar3.vsd <- varianceStabilizingTransformation(ddsInstar3_Pop_Host, blind = T)
plotPCA(Instar3.vsd, intgroup=c("Population", "Hostplant")) + theme_minimal() + ggtitle("PCA Instar 3")
plotPCA(Instar3.vsd, intgroup=c("Hostplant")) + theme_minimal() + ggtitle("PCA Instar 3 Hostplant")
plotPCA(Instar3.vsd, intgroup=c("Population")) + theme_minimal() + ggtitle("PCA Instar 3 Population")
plotPCA(Instar3.vsd, intgroup=c("Family")) + theme_minimal() + ggtitle("PCA Instar 3 Family")


#' mph2ms
#'
#' Conversion miles per hour in meters per second.
#'
#' @param mph numeric  Speed miles per hour.
#' @return meters per second
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  mph2ms
#'
#' @export
#'
#'
#'
#'

mph2ms=function(mph) {
                         ct$assign("mph", as.array(mph))
                         ct$eval("var res=[]; for(var i=0, len=mph.length; i < len; i++){ res[i]=mph2ms(mph[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


library(readr)
library(ggplot2)
library(Cairo)

GraphPerf <- function(path) {
  data <- read_table2(path, col_types = cols(threads = col_integer(),
                                             time    = col_integer()))
  data$perf <- 1000 / data$time

  dpi <- 72 * 1.5

  plot <- ggplot(data, aes(threads, perf)) + stat_summary(aes(y=perf), fun.y=mean, colour="gray", geom="line") + geom_point()

  plot_path <- paste(tools::file_path_sans_ext(path), ".png", sep="")

  ggsave(plot=plot, plot_path, h=1080/dpi, w=1920/dpi, type="cairo-png", dpi=dpi)
}

GraphPerf("render perf (tr1920x).txt")
GraphPerf("voxel perf (tr1920x).txt")


# Functions for testing enrichment between sets of genomic ranges and generating background sets

# ====================================================================
# Exported Functions

# --------------------------------------------------------------------
#' Draw a length-matched pool of sequences from the genome
#'
#' Given a query set of ranges, draw a length-matched pool of sequences. Returned ranges are required to (1) not overlap with each other or the query, (2) not extend off chromosome ends, (3) not extend over assembly gaps as defined in the UCSC "gap" table for the given genome assembly.
#' @param query A data.frame or data.table with columns "chr", "start", and "end" and any other columns. If a data.frame or data.table, must contain the columns "chr", "start", "end", where the "start" coordinates are 1-based.
#' @param n Number of times greater than the query set that the size of the returned background pool will be
#' @param chrs Vector of chromosome names to draw from. Useful for restricting to canonical chromosomes only, i.e. chr1 to chr22, chrX, and chrY for hg19. If not given, will restrict to the chromosome names present in query.
#' @param genome The UCSC name specific to the genome of the query coordinates (e.g. "hg19", "hg18", "mm10", etc)
#' @param cachedir A path to a directory where a local cache of UCSC tables are stored. If equal to \code{NULL} (default), the data will be downloaded to temporary files and loaded on the fly. Caching is highly recommended to save time and bandwidth.
#' @return A GRanges of the background sequences.
#' @export
drawGenomePool <- function(query, n, chrs=NULL, genome, cachedir, sync=TRUE)
{
	target.gr <- makeGRanges(query)
	if(is.null(chrs))
	{
		message("Drawing from chrs: ",toString(seqlevels(target.gr))," because these were present in query. Please provide the \"chrs\" option if you wish to draw from additional chromosomes.")
		chrs <- unique(seqnames(target.gr))
	}

	#target.gr <- dmrs.gr
	lens <- width(target.gr)
	# duplicate the sizes by the number of regions we want to draw per size
	lens <- rep(lens,n)

	# Get chromosome lengths
	chromsizes <- getUCSCTable("chromInfo", genome, cachedir, sync=sync)
	chromsizes <- chromsizes[chromsizes$chrom %in% chrs,]

	# Get gaps GR
	gaps <- getUCSCTable("gap", genome, cachedir, sync=sync)
	gaps.gr <- with(gaps, GRanges(seqnames=chrom, ranges=IRanges(start=chromStart+1, end=chromEnd)))

	# For each size, draw n random non-gap positions

	dodraw <- function(lens)
	{
		chrs <- sample(chrs,length(lens),replace=T)
		dt <- data.table(len=lens,chr=chrs)
		dt <- dt[,list(len=len, start=sample(1:(chromsizes[chromsizes$chrom==chr,]$size),length(len))), by=chr]
		draw.gr <- GRanges(dt$chr,IRanges(start=dt$start,width=dt$len))
		return(draw.gr)
	}
	draw.gr <- dodraw(lens)

	# Exclude the bads and redraw them
	isbad <- TRUE
	iter <- 1
	while(isbad)
	{
		# Check for overlapping regions
		dups <- data.table(as.data.frame(findOverlaps(draw.gr,draw.gr)))
		dups <- dups[queryHits!=subjectHits,]$queryHits
		# Check for those that hit gap regions
		gaps <- data.table(as.data.frame(findOverlaps(draw.gr,gaps.gr)))
		gaps <- gaps[queryHits!=subjectHits,]$queryHits
		# Check for those that extend beyond chr ends
		if(sum(end(draw.gr) > chromsizes[match(as.vector(seqnames(draw.gr)),chromsizes$chrom),]$size)>0){bigs <- seq(1,length(draw.gr))[end(draw.gr) > chromsizes[match(as.vector(seqnames(draw.gr)),chromsizes$chrom),]$size]} else {bigs<-c()}
		#seqlengths(draw.gr) <- chromsizes[match(seqlevels(draw.gr),chromsizes$chrom),]$size
		#1:length(draw.gr)[end(draw.gr) > chromsizes[match(as.vector(seqnames(draw.gr)),chromsizes$chrom),]$size]

		# Need to account for if they are both gaps and dups, otherwise we start building up extra lengths we don't need
		# I fixed this by using unique()
		toget <- unique(c(gaps,dups,bigs))

		# Redraw these widths
		if(length(toget)==0)
		{
			isbad <- FALSE
		} else
		{
			message("Draw iter ",iter," had ", length(dups)," overlapping, ",length(gaps)," in gap regions, and ", length(bigs)," off chromosome ends. Redrawing these...")
			iter <- iter+1
			draw.gr <- c(draw.gr[-c(toget)],dodraw(width(draw.gr[c(toget)])))
		}
	}

	# Make sure the length distribution of the output matches that of the input times the number of draws for each
	if(!all((table(width(target.gr))*n)==table(width(draw.gr)))){stop("Final length tables did not match, the drawing did not work.")}

	draw.gr
}
# --------------------------------------------------------------------


library(DESeq2)
library(ggplot2)
library(reshape2)
library(plyr)

files <- c("data_gne.202.csv", "data_gne.201.csv", "data_gne.204.csv", "data_gne.203.csv")
condition <- factor(c("nonactivated", "activated", "nonactivated", "activated"), levels=c("nonactivated", "activated"))
pool <- factor(c("1","1","2","2"))
name <- mdply(data.frame(a=condition, b=pool), 'paste', sep='-')[,3]
sampleTable <- data.frame(sampleName=1:4, fileName=files, condition=condition, pool=pool, name=name, stringsAsFactors=F)

fct <- function(file, data, ytext, ltext) {
#  mal <- cbind(data, sampleTable[c(2,1,4,3),])
st <- data.frame(name=factor(c("activated-1", "nonactivated-1", "activated-2", "nonactivated-2"), levels=c("nonactivated-1","activated-1","nonactivated-2","activated-2")))
mal <- cbind(data, st)
  mml <- melt(mal, id.vars=colnames(st))
  pdf(file)
  print(ggplot(mml, aes(x=name, y=value, fill=variable)) + xlab('Sample') + ylab(ytext) + guides(fill=guide_legend(title=ltext)) +
		  geom_bar(stat="identity", position="fill") + theme(axis.text.x = element_text(angle = 90)))
  dev.off()
}

aln <- read.csv('data_aln.csv')
fct('data_anl.map.pdf', as.data.frame(data.matrix(aln)[,1] / 100 * data.matrix(aln)[,2:7]), 'Read ratio', 'Mapping class')
fct('data_anl.ftc.pdf', read.csv('data_ftc.csv'), 'Read count', 'Feature class')

ftc <- c("data_ftc.202.csv", "data_ftc.201.csv", "data_ftc.204.csv", "data_ftc.203.csv")
cnt <- do.call(cbind,lapply(ftc, function(x) read.table(x, header=T)))[, c(1:4 * 7)]
colnames(cnt) <- sampleTable$name
png('data_anl.crr.png', width=2048, height=2048)
pairs(log2(as.matrix(cnt)+0.5), pch=20)
dev.off()

dds <- DESeqDataSetFromHTSeqCount(sampleTable=sampleTable, directory=".", design= ~ pool + condition)
dds <- estimateSizeFactors(dds)
rld <- rlogTransformation(dds, blind=T)

pdf('data_gdf.pca.pdf')
pca <- plotPCA(rld, intgroup=c("condition", "pool"), returnData=T)
percentVar <- round(100*attr(pca,"percentVar"))
ggplot(pca, aes(PC1, PC2, color=condition, shape=pool)) + geom_point(size=3) + xlab(paste0("PC1: ",percentVar[1],"% variance")) + ylab(paste0("PC2: ",percentVar[2],"% variance"))
dev.off()

dds <- estimateDispersions(dds)

pdf('data_gdf.dsp.pdf')
plotDispEsts(dds)
dev.off()

dds <- nbinomWaldTest(dds)
res <- results(dds)

ngc <- as.data.frame(counts(dds, normalized=T))
colnames(ngc) <- sampleTable$name
ens <- cbind(read.table('data_ref.ens', header=T), as.data.frame(res), ngc)
write.table(ens[order(ens$padj),], file='data_gdf.csv', quote=F, sep='\t', row.names=F)

pdf('data_gdf.maa.pdf')
plotMA(dds,ylim=c(-2,2),main="DESeq2")
dev.off()

pdf('data_gdf.htm.pdf')
top <- ens[order(ens$padj), c("gene", sampleTable$name)][1:20,]
top$gene <- factor(as.vector(top$gene), levels=ens[order(ens$padj),"gene"][1:20])
ggplot(melt(top, id.vars="gene"), aes(y=gene, x=variable)) + geom_tile(aes(fill=value)) +
		 scale_fill_gradient(name="read count", low="green", high="red", trans="log", labels=function(x) as.character(signif(x,2))) +
		 ylim(rev(levels(top$gene))) + xlab("sample")
dev.off()


/*
 * fconv.r -- abs, cset, integer, numeric, proc, real, string.
 */

"abs(N) - produces the absolute value of N."

function{1} abs(n)
   /*
    * If n is convertible to a (large or small) integer or real,
    * this code returns -n if n is negative
    */
   if cnv:(exact)C_integer(n) then {
      abstract {
         return integer
         }
      inline {
	 C_integer i;
	 int over_flow = 0;

	 if (n >= 0)
	    i = n;
	 else {
	    i = neg(n, &over_flow);
	    if (over_flow) {
#ifdef LargeInts
	       struct descrip tmp;
	       MakeInt(n,&tmp);
	       if (bigneg(&tmp, &result) == RunError)  /* alcbignum failed */
	          runerr(0);
               return result;
#else					/* LargeInts */
	       irunerr(203,n);
               errorfail;
#endif					/* LargeInts */
	       }
	    }
         return C_integer i;
         }
      }

#ifdef LargeInts
   else if cnv:(exact)integer(n) then {
      abstract {
         return integer
         }
      inline {
	 if (BlkD(n, Lrgint)->sign == 0)
	    result = n;
	 else {
	    if (bigneg(&n, &result) == RunError)  /* alcbignum failed */
	       runerr(0);
	    }
         return result;
         }
      }
#endif					/* LargeInts */

   else if cnv:C_double(n) then {
      abstract {
         return real
         }
      inline {
         return C_double Abs(n);
         }
      }
   else
      runerr(102,n)
end

/*
 * The convertible types cset, integer, and real are identical
 *  enough to be expansions of a single macro, parameterized by type.
 */
#begdef ReturnYourselfAs(t)
#t "(x) - produces a value of type " #t " resulting from the conversion of x, "
   "but fails if the conversion is not possible."
function{0,1} t(x)

   if cnv:t(x) then {
      abstract {
         return t
         }
      inline {
         return x;
         }
      }
   else {
      abstract {
         return empty_type
         }
      inline {
         fail;
         }
      }
end

#enddef

ReturnYourselfAs(cset)     /* cset(x) - convert to cset or fail */
ReturnYourselfAs(integer)  /* integer(x) - convert to integer or fail */
ReturnYourselfAs(real)     /* real(x) - convert to real or fail */

"string(x) - produces a value of type string resulting from the conversion"
" of x, but fails if the conversion is not possible."
function{0,1} string(x[n])

   abstract {
      return string ++ empty_type
      }
   body {
      int i, j, len;
      char *tmp, *s, *s2;
      tended struct descrip t;
      if (n == 0)
	 return emptystr;

      /*
       * convert x[0] to a string
       */
      if (!cnv:string(x[0], x[0]))
	 fail;
      t = x[0];

      for (i = 1; i < n; i++) {
	 /*
	  * if t is not at the end of the string region, make it so
	  */
	 if (StrLoc(t) + StrLen(t) != strfree) {
	    Protect(StrLoc(t) = alcstr(StrLoc(t), StrLen(t)), runerr(0));
	    }
	 if (!cnv:string(x[i], x[i])) fail;

	 /*
	  * concatenate t and x[i] and store result in t
	  */
	 if (StrLoc(t) + StrLen(t) == StrLoc(x[i])) {
	    StrLen(t) += StrLen(x[i]);
	    }
	 else if ((StrLoc(t) + StrLen(t) == strfree) && (DiffPtrs(strend,strfree) > StrLen(x[i]))) {
	    Protect(alcstr(StrLoc(x[i]), StrLen(x[i])), runerr(0));
	    StrLen(t) += StrLen(x[i]);
	    }
	 else {
	    Protect(tmp = alcstr(NULL, StrLen(t)+StrLen(x[i])), runerr(0));
	    s = tmp;
	    s2 = StrLoc(t);
	    len = StrLen(t);
	    for (j = 0; j < len; j++)
	       *s++ = *s2++;
	    s2 = StrLoc(x[i]);
	    len = StrLen(x[i]);
	    for (j = 0; j < len; j++)
	       *s++ = *s2++;
	    StrLoc(t) = tmp;
	    StrLen(t) += len;
	    }
         }
      return t;
      }
end

"numeric(x) - produces an integer or real number resulting from the "
"type conversion of x, but fails if the conversion is not possible."

function{0,1} numeric(n)

   if cnv:(exact)integer(n) then {
      abstract {
         return integer
         }
      inline {
         return n;
         }
      }
   else if cnv:real(n) then {
      abstract {
         return real
         }
      inline {
         return n;
         }
      }
   else {
      abstract {
         return empty_type
         }
      inline {
         fail;
         }
      }
end

"proc(x,i) - convert x to a procedure if possible; use i to resolve "
"ambiguous string names."

#ifdef MultiProgram
function{0,1} proc(x,i,c)
#else					/* MultiProgram */
function{0,1} proc(x,i)
#endif					/* MultiProgram */

#ifdef MultiProgram
   if is:coexpr(x) then {
      if !def:C_integer(i, 1) then
         runerr(101, i)
      abstract {
         return proc
         }
      body {
	 struct b_coexpr *ce = NULL;
	 struct b_proc *bp = NULL;
	 struct pf_marker *fp;
	 dptr dp=NULL;
	 CURTSTATE_AND_CE();
	 if (BlkLoc(x) != BlkLoc(k_current)) {
	    ce = (struct b_coexpr *)BlkLoc(x);
	    dp = ce->es_argp;
	    fp = ce->es_pfp;
	    if (dp == NULL) fail;
	    }
	 else {
	    fp = pfp;
	    dp = glbl_argp;
	    }
	 /* follow upwards, i levels */
	 while (i--) {
	    if (fp == NULL) fail;
#if COMPILER
	    dp = fp->old_argp;
	    fp = fp->old_pfp;
#else					/* COMPILER */
	    dp = fp->pf_argp;
	    fp = fp->pf_pfp;
#endif					/* COMPILER */
	    }
	 if (fp == NULL) fail;
	 if (dp)
	    bp = (struct b_proc *)BlkLoc(*(dp));
	 else fail;
	 return proc(bp);
	 }
      }
#endif					/* MultiProgram */

   if is:proc(x) then {
      abstract {
         return proc
         }
      inline {

#ifdef MultiProgram
	 if (!is:null(c)) {
	    struct progstate *p;
	    if (!is:coexpr(c)) runerr(118,c);
	    /*
	     * Test to see whether a given procedure belongs to a given
	     * program.  Currently this is a sleazy pointer arithmetic check.
	     */
	    p = BlkD(c,Coexpr)->program;
	    if (! InRange(p, BlkD(x,Proc)->entryp.icode, (char *)p + p->hsize))
	       fail;
	    }
#endif					/* MultiProgram */
         return x;
         }
      }

   else if cnv:tmp_string(x) then {
      /*
       * i must be 0, 1, 2, or 3; it defaults to 1.
       */
      if !def:C_integer(i, 1) then
         runerr(101, i)
      inline {
         if (i < 0 || i > 3) {
            irunerr(205, i);
            errorfail;
            }
         }

      abstract {
         return proc
         }
      inline {
         struct b_proc *prc;

#ifdef MultiProgram
	 struct progstate *prog, *savedprog;

	 savedprog = curpstate;
	 if (is:null(c)) {
	    prog = curpstate;
	    }
	 else if (is:coexpr(c)) {
	    prog = BlkD(c,Coexpr)->program;
	    }
	 else {
	    runerr(118,c);
	    }

	 ENTERPSTATE(prog);
#endif						/* MultiProgram */

         /*
          * Attempt to convert Arg0 to a procedure descriptor using i to
          *  discriminate between procedures with the same names.  If i
          *  is zero, only check builtins and ignore user procedures.
          *  Fail if the conversion isn't successful.
          */
	 if (i == 0)
            prc = bi_strprc(&x, 0);
	 else
         prc = strprc(&x, i);

#ifdef MultiProgram
	 ENTERPSTATE(savedprog);
#endif						/* MultiProgram */
         if (prc == NULL)
            fail;
         else
            return proc(prc);
         }
      }
   else {
      abstract {
         return empty_type
         }
      inline {
         fail;
         }
      }
end


#' Smoothed conditional means
#'
#' Aids the eye in seeing patterns in the presence of overplotting.
#' `geom_smooth()` and `stat_smooth()` are effectively aliases: they
#' both use the same arguments. Use `stat_smooth()` if you want to
#' display the results with a non-standard geom.
#'
#' Calculation is performed by the (currently undocumented)
#' `predictdf()` generic and its methods.  For most methods the standard
#' error bounds are computed using the [predict()] method -- the
#' exceptions are `loess()`, which uses a t-based approximation, and
#' `glm()`, where the normal confidence interval is constructed on the link
#' scale and then back-transformed to the response scale.
#'
#' @eval rd_orientation()
#'
#' @eval rd_aesthetics("geom", "smooth")
#' @inheritParams layer
#' @inheritParams geom_bar
#' @param geom,stat Use to override the default connection between
#'   `geom_smooth()` and `stat_smooth()`.
#' @seealso See individual modelling functions for more details:
#'   [lm()] for linear smooths,
#'   [glm()] for generalised linear smooths, and
#'   [loess()] for local smooths.
#' @export
#' @examples
#' ggplot(mpg, aes(displ, hwy)) +
#'   geom_point() +
#'   geom_smooth()
#'
#' # If you need the fitting to be done along the y-axis set the orientation
#' ggplot(mpg, aes(displ, hwy)) +
#'   geom_point() +
#'   geom_smooth(orientation = "y")
#'
#' # Use span to control the "wiggliness" of the default loess smoother.
#' # The span is the fraction of points used to fit each local regression:
#' # small numbers make a wigglier curve, larger numbers make a smoother curve.
#' ggplot(mpg, aes(displ, hwy)) +
#'   geom_point() +
#'   geom_smooth(span = 0.3)
#'
#' # Instead of a loess smooth, you can use any other modelling function:
#' ggplot(mpg, aes(displ, hwy)) +
#'   geom_point() +
#'   geom_smooth(method = lm, se = FALSE)
#'
#' ggplot(mpg, aes(displ, hwy)) +
#'   geom_point() +
#'   geom_smooth(method = lm, formula = y ~ splines::bs(x, 3), se = FALSE)
#'
#' # Smooths are automatically fit to each group (defined by categorical
#' # aesthetics or the group aesthetic) and for each facet.
#'
#' ggplot(mpg, aes(displ, hwy, colour = class)) +
#'   geom_point() +
#'   geom_smooth(se = FALSE, method = lm)
#' ggplot(mpg, aes(displ, hwy)) +
#'   geom_point() +
#'   geom_smooth(span = 0.8) +
#'   facet_wrap(~drv)
#'
#' \donttest{
#' binomial_smooth <- function(...) {
#'   geom_smooth(method = "glm", method.args = list(family = "binomial"), ...)
#' }
#' # To fit a logistic regression, you need to coerce the values to
#' # a numeric vector lying between 0 and 1.
#' ggplot(rpart::kyphosis, aes(Age, Kyphosis)) +
#'   geom_jitter(height = 0.05) +
#'   binomial_smooth()
#'
#' ggplot(rpart::kyphosis, aes(Age, as.numeric(Kyphosis) - 1)) +
#'   geom_jitter(height = 0.05) +
#'   binomial_smooth()
#'
#' ggplot(rpart::kyphosis, aes(Age, as.numeric(Kyphosis) - 1)) +
#'   geom_jitter(height = 0.05) +
#'   binomial_smooth(formula = y ~ splines::ns(x, 2))
#'
#' # But in this case, it's probably better to fit the model yourself
#' # so you can exercise more control and see whether or not it's a good model.
#' }
geom_smooth <- function(mapping = NULL, data = NULL,
                        stat = "smooth", position = "identity",
                        ...,
                        method = NULL,
                        formula = NULL,
                        se = TRUE,
                        na.rm = FALSE,
                        orientation = NA,
                        show.legend = NA,
                        inherit.aes = TRUE) {

  params <- list(
    na.rm = na.rm,
    orientation = orientation,
    se = se,
    ...
  )
  if (identical(stat, "smooth")) {
    params$method <- method
    params$formula <- formula
  }

  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomSmooth,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = params
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
GeomSmooth <- ggproto("GeomSmooth", Geom,
  setup_params = function(data, params) {
    params$flipped_aes <- has_flipped_aes(data, params, range_is_orthogonal = TRUE, ambiguous = TRUE)
    params
  },

  extra_params = c("na.rm", "orientation"),

  setup_data = function(data, params) {
    GeomLine$setup_data(data, params)
  },

  # The `se` argument is set to false here to make sure drawing the
  # geom and drawing the legend is in synch. If the geom is used by a
  # stat that doesn't set the `se` argument then `se` will be missing
  # and the legend key won't be drawn. With `se = FALSE` here the
  # ribbon won't be drawn either in that case, keeping the overall
  # behavior predictable and sensible. The user will realize that they
  # need to set `se = TRUE` to obtain the ribbon and the legend key.
  draw_group = function(data, panel_params, coord, lineend = "butt", linejoin = "round",
                        linemitre = 10, se = FALSE, flipped_aes = FALSE) {
    ribbon <- transform(data, colour = NA)
    path <- transform(data, alpha = NA)

    ymin = flipped_names(flipped_aes)$ymin
    ymax = flipped_names(flipped_aes)$ymax
    has_ribbon <- se && !is.null(data[[ymax]]) && !is.null(data[[ymin]])

    gList(
      if (has_ribbon) GeomRibbon$draw_group(ribbon, panel_params, coord, flipped_aes = flipped_aes),
      GeomLine$draw_panel(path, panel_params, coord, lineend = lineend, linejoin = linejoin, linemitre = linemitre)
    )
  },

  draw_key = draw_key_smooth,

  required_aes = c("x", "y"),
  optional_aes = c("ymin", "ymax"),

  default_aes = aes(colour = "#3366FF", fill = "grey60", size = 1,
    linetype = 1, weight = 1, alpha = 0.4)
)


library(ggplot2)

#' plotLines
#'
#' Lineplots comparing continuous variable scores across levels of another var
#'
#' Inputs:
#'     df:       Dataframe with vars of interest.
#'     title:    Title above chart
#'     outDir:   Directory to save plot to
plotLines <- function(df, title, outDir){
    # Create plot
    p <- ggplot(data=df, aes(x=scd_slp_to_obj_slp, y=prop, color=Path,
                group=Path, fill=Path))

    # Add lines for each group
    p <- p + geom_line(aes(linetype=Path), stat='identity', size=.85, alpha=0.9)

    # Unique shape for each group placed at each data point
    p <- p + geom_point(aes(shape=Path), size=2.5, alpha=.45)

    # Pad the distance between the x-axis and smallest plotted value slightly
    p <- p + scale_y_continuous(limits=c(0,1))

    # Pad/add extra space to the ends of the x-axis
    p <- p + scale_x_continuous(expand=c(0.05, 0.05))

    # Reverse x-axis when dealing with negative numbers
    p <- p + scale_x_reverse()

    # Remove gray background, format x-axis text, format legend
    p <- p + theme(panel.grid.major=element_blank(),
                   panel.grid.minor=element_blank(),
                   panel.background=element_blank(),
                   axis.line=element_line(colour="black"),
                   axis.text.x=element_text(angle=0, size=14),
                   axis.text.y=element_text(angle=0, size=14),
                   legend.key=element_rect(color=NA, fill=NA),
                   legend.background=element_blank(),
                   legend.key.width=unit(3, "line"),
                   legend.justification=c(1, 1),
                   legend.position=c(1, 1))

    # Add axis labels
    p <- p + labs(y='Proportion of Simulations with RMSEA<.05 and Path of Interest P<.05',
                  x='Path Coefficient for Objective Performance Slope ON SCD Slope')

    # Remove any components to the legend that could relate to alpha or size
    p <- p + scale_alpha(guide='none')
    p <- p + scale_size(guide='none')

    # Add a title to the plot
    p <- p + ggtitle(title)

    # Save Plots
    pngOut <- paste(outDir, "/parallelGrowthPower-linePlot.png", sep="")
    svgOut <- paste(outDir, "/parallelGrowthPower-linePlot.svg", sep="")

    ggsave(pngOut, p)
    ggsave(svgOut, p)
}

# Path to your csv file
csv_path <- ""

df <- read.csv(csv_path)

temp1 <- df[,c('scd_slp_to_obj_slp', 'rmsea05_si_path05_prop')]
temp2 <- df[,c('scd_slp_to_obj_slp', 'rmsea05_ss_path05_prop')]

colnames(temp1) <- c('scd_slp_to_obj_slp','prop')
temp1[,'Path'] <- "Objective Performance Slope ON SCD Intercept"

colnames(temp2) <- c('scd_slp_to_obj_slp','prop')
temp2[,'Path'] <- "Objective Performance Slope ON SCD Slope"

df <- rbind(temp1, temp2)
df$Path <- as.factor(df$Path)

# # Save data as csv
# write.csv(df, "./parallelGrowth.csv")

plotLines(df, 'Parallel Growth Power Analysis. 100 Control, 100 MCI', './')


health_data =
  read_csv(
    "data/analytic_data2020.csv",
    col_types = list(
      fipscode = col_double()
    ),
    # The first row just has descriptions.
    # Might be nice to read them in and use them for selection instead.
    skip = 1,
    # Parse the whole thing first to verify column types
    guess_max = 3194
  ) %>%
  select(
    county_code = fipscode,
    proportion_obsese = v011_rawvalue,
    proportion_smoke = v009_rawvalue
  )


read.iris = function(file="iris.csv")
{
  if (comm.rank() == 0)
  {
    iris = read.csv(file=file)
    species = iris$Species
    iris$Species = NULL
    iris = as.matrix(iris)
  }
  else
  {
    iris = NULL
    species = NULL
  }

  iris = kazaam::expand(iris)
  species = kazaam::expand(species)
  list(iris=iris, species=species)
}

# reference: https://en.wikipedia.org/wiki/Rand_index
rand_measure = function(l1, l2)
{
  n = length(l1)
  a = b = 0L

  for (i in 1:n)
  {
    for (j in (i+1L):n)
    {
      if (j > n) # R indexing is stupid
        break

      same1 = (l1[i] == l1[j])
      same2 = (l2[i] == l2[j])

      if (same1 && same2)
        a = a + 1L
      else if (!same1 && !same2)
        b = b + 1L
    }
  }

  (a + b) / choose(n, 2)
}

rand_measure = compiler::cmpfun(rand_measure)


library(plyr)
library(ggplot2)
library(RColorBrewer)
library(grid)
library(RSQLite)

setwd(dirname(sys.frame(1)$ofile))
theme_update(plot.margin = unit(c(0,0,0,0), "cm"))

source("common.r")

results.na = read.results("results/results-nofail-rle.csv")
#xxx: deal with last NA
results = na.omit(results.na)
results = subset(results, coder != "log-huffman")
results$sizeorig = as.numeric(results$sizeorig)
results$sizecomp = as.numeric(results$sizecomp)
results$dectime = as.numeric(results$dectime)
results$enctime = as.numeric(results$enctime)

results.bydset = ddply(results, .(dataset,coder), summarize,
                       sizemean=mean(sizeorig/sizecomp),
                       sizesd=sd(sizeorig/sizecomp),
                       decspeed=mean(sizeorig/dectime/1e6),
                       encspeed=mean(sizeorig/enctime/1e6),
                       decspeedsd=sd(sizeorig/dectime/1e6),
                       encspeedsd=sd(sizeorig/enctime/1e6))
results.bycoder = ddply(results, .(coder), summarize,
                       sizemean=mean(sizeorig/sizecomp),
                       sizesd=sd(sizeorig/sizecomp),
                       decspeed=mean(sizeorig/dectime/1e6),
                       encspeed=mean(sizeorig/enctime/1e6),
                       decspeedsd=sd(sizeorig/dectime/1e6),
                       encspeedsd=sd(sizeorig/enctime/1e6))

ggplot(results, aes(x=sizeorig/dectime/1e6, y=sizeorig/sizecomp, color=coder)) +
  geom_density2d() +
  scale_y_log10("Uncompressed / compressed ratio (log scale)", breaks=c(1,2,4,8)) +
  scale_x_log10("Decompression rate (MB/s) (log scale)", breaks=c(10,20,40,80)) +
  guides(color=guide_legend(override.aes=list(alpha=1, size=8)))
ggsave("figs/all-results.pdf", width=7, height=5.5)

ggplot(results, aes(x=sizeorig/enctime/1e6, y=sizeorig/sizecomp, color=coder)) +
  geom_density2d() +
  scale_y_log10("Uncompressed / compressed ratio (log scale)", breaks=c(1,2,4,8)) +
  scale_x_log10("Compression rate (MB/s) (log scale)", breaks=c(10,20,40,80)) +
  guides(color=guide_legend(override.aes=list(alpha=1, size=8))) +
  theme(legend.position="none")
ggsave("figs/all-results-encode.pdf", width=4, height=5.5)

ggplot(results.bydset, aes(x=decspeed, y=sizemean, color=coder)) +
  geom_point(size=3) +
  geom_point(data=results.bycoder, size=10) +
  scale_y_log10("Uncompressed / compressed ratio (log scale)", breaks=c(1,2,4,8,16,32)) +
  scale_x_log10("Decompression rate (MB/s) (log scale)", breaks=c(10,20,40,80,160,320)) +
  guides(color=guide_legend(override.aes=list(alpha=1, size=8)))
ggsave("figs/all-results-bydset.pdf", width=7, height=5.5)

ggplot(results.bydset, aes(x=encspeed, y=sizemean, color=coder)) +
  geom_point(size=3) +
  geom_point(data=results.bycoder, size=10) +
  scale_y_log10("Uncompressed / compressed ratio (log scale)", breaks=c(1,2,4,8,16,32)) +
  scale_x_log10("Compression rate (MB/s) (log scale)", breaks=c(10,20,40,80)) +
  guides(color=guide_legend(override.aes=list(alpha=1, size=8))) +
  theme(legend.position="none")
ggsave("figs/all-results-encode-bydset.pdf", width=4, height=5.5)

ggplot(results.bydset, aes(
  x=reorder(dataset,sizemean,mean),
  y=sizemean, ymin=sizemean-sizesd/4, ymax=sizemean+sizesd/4, color=coder,
  group=coder)) +
  geom_pointrange(size=1) +
  scale_y_log10("Uncompressed / compressed ratio (log scale)",
                breaks=c(1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192)) +
  scale_x_discrete("Dataset") +
#  theme(axis.text.x=element_text(angle=-90, hjust=0), legend.position="top") +
  theme(axis.text.x=element_blank(), legend.position="top") +
  coord_cartesian(ylim=c(0.5,5000))
ggsave("figs/dataset-sizes.pdf", width=5, height=4)

bydset.smean = results.bydset[order(results.bydset$sizemean) ,]

if (FALSE) {
  ggplot(head(results,40000), aes(x=sizeorig/enctime/1e6, y=sizeorig/sizecomp, color=coder)) +
    geom_point(alpha=0.15) +
    scale_y_log10("Uncompressed / compressed ratio (log scale)", breaks=c(1,2,4,8)) +
    scale_x_log10("Compression rate (MB/s) (log scale)", breaks=c(10,20,40,80)) +
    guides(color=guide_legend(override.aes=list(alpha=1, size=8))) +
    theme(legend.position="none")
  ggsave("figs/all-results-scatter.pdf", width=4, height=5.5)
}


#plott calibration and validation R2 distributions for Fungi and bacteria as 6-panel plot.
rm(list=ls())
source('paths.r')
source('paths_fall2019.r')
#source('NEFI_functions/zero_truncated_density.r')
source('NEFI_functions/rsq_1.1.r')
library(Metrics)
library(RCurl)

script <- getURL("https://raw.githubusercontent.com/colinaverill/NEFI_microbe/master/NEFI_functions/zero_truncated_density.r", ssl.verifypeer = FALSE)
eval(parse(text = script))
script <- getURL("https://raw.githubusercontent.com/colinaverill/NEFI_microbe/master/NEFI_functions/rsq_1.1.r", ssl.verifypeer = FALSE)
eval(parse(text = script))

#set output path.----
output.path <- paste0(scc_gen_16S_dir, "figures/Fig1_cal_val_scale.png")

#Load calibration data.----
cal <- readRDS(prior_delgado_ddirch_16S.path)  #dirichlet-only.

#Get calibration r2 values.----
cal.r2 <- list()
lev.cal.out <- list()
for(i in 1:length(cal)){
  lev <- cal[[i]]
  obs <- lev$observed
  pred <- lev$predicted
  lev.r2 <- list()
  for(j in 1:ncol(obs)){lev.r2[[j]] <- summary(lm(obs[,j] ~ pred[,j]))$r.squared}
  lev.r2 <- unlist(lev.r2)
  names(lev.r2) <- colnames(obs)
  lev.r2 <- lev.r2[names(lev.r2) != 'other']
  cal.r2[[i]] <- lev.r2
  #names(pl.r2)[[i]] <- names(pl)[i]
}
#names(cal.r2) <- names(cal)

cal.r2.fg <- list(unlist(cal.r2[6:18]))
cal.r2 <- c(cal.r2.fg, cal.r2[1:5])
names(cal.r2) <- c('functional','phylum','class','order','family','genus')

#cal.rsq <- unlist(all.r2)

#Subset to ones we can actually predict (r2 > 0.1).
lev.cal.r2 <- list()
for(i in 1:length(cal.r2)){
  lev.cal.r2[[i]] <- cal.r2[[i]][cal.r2[[i]] > 0.1]
}
names(lev.cal.r2) <- names(cal.r2)
cal.mu <- unlist(lapply(lev.cal.r2, mean  ))
cal.sd <- unlist(lapply(lev.cal.r2, sd    ))
cal.N  <- unlist(lapply(lev.cal.r2, length))
cal.se <- cal.sd / sqrt(cal.N)
names(cal.mu) <- names(cal.r2)
lev.cal.r2 <- unlist(lev.cal.r2)

#load forecasts predicted and observed.----
#val.cast <- readRDS(NEON_dmulti.ddirch_fcast_fg.path)
val.truth <- readRDS(NEON_phylo_fg_plot.site_obs_16S.path)
val.cast <- readRDS(NEON_cps_fcast_ddirch_16S.path)
map <- readRDS(core_obs_16S.path)

#get core, plot site R2 and RMSE values out of sample.----
all.core.rsq  <- list()
all.plot.rsq  <- list()
all.site.rsq  <- list()
all.core.rmse <- list()
all.plot.rmse <- list()
all.site.rmse <- list()
all.core.stat <- list()
all.plot.stat <- list()
all.site.stat <- list()
for(i in 1:length(val.cast)){
  fcast <- val.cast[[i]]
  core.rsq <- list()
  plot.rsq <- list()
  site.rsq <- list()
  core.rmse <- list()
  plot.rmse <- list()
  site.rmse <- list()
  core.stat <- list()
  plot.stat <- list()
  site.stat <- list()
  #core.level----
  y <- val.truth[[i]]$core.fit
  x <- fcast$core.fit$mean
  #fix rownames
  y.fix <- as.data.frame(y)
  y.fix$deprecatedVialID <- rownames(y.fix)
  y.fix <- merge(y.fix, map[,c("deprecatedVialID", "geneticSampleID")], by = "deprecatedVialID")
  y.fix <- y.fix[!duplicated(y.fix$geneticSampleID),]
  rownames(y.fix) <- gsub('-GEN','',y.fix$geneticSampleID )
  y.fix$geneticSampleID <- NULL
  y <- y.fix
  #make sure rownames and col
  y <- y[rownames(y) %in% rownames(x),]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[,colnames(y) %in% colnames(x)]
  x <- x[,colnames(x) %in% colnames(y)]
  x <- x[order(match(rownames(x),rownames(y))),]
  x <- x[,order(match(colnames(x),colnames(y)))]
  #fit model, grab r2.
  for(k in 1:ncol(fcast$core.fit$mean)){
    fungi_name <- colnames(x)[k]
    rsq <- summary(lm(y[,k] ~ x[,k]))$r.squared
    obs.rmse <- rmse(y[,k], x[,k])
    rsq.1 <- rsq_1.1(y[,k], x[,k])
    names(rsq) <- fungi_name
    if(fungi_name == 'other'){next}
    core.rsq [[k]] <- rsq
    core.rmse[[k]] <- obs.rmse
    stat.return <- c(fungi_name, rsq, rsq.1, obs.rmse)
    names(stat.return) <- c('name','rsq','rsq.1','rmse')
    core.stat[[k]] <- stat.return
  }
  #plot.level----
  x <- fcast$plot.fit$mean
  y <- val.truth[[i]]$plot.fit$mean

  #fix rownames
  rownames(y) <- gsub('\\.','_',rownames(y))
  #make sure row and column order match.
  y <- y[rownames(y) %in% rownames(x),]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[,colnames(y) %in% colnames(x)]
  x <- x[,colnames(x) %in% colnames(y)]
  x <- x[order(match(rownames(x),rownames(y))),]
  x <- x[,order(match(colnames(x),colnames(y)))]
  #fit model, grab r2.
  for(k in 1:ncol(y)){
    fungi_name <- colnames(x)[k]
    rsq <- summary(lm(y[,k] ~ x[,k]))$r.squared
    rsq.1 <- rsq_1.1(y[,k], x[,k])
    obs.rmse <- rmse(y[,k], x[,k])
    names(obs.rmse) <- names(rsq)
    names(rsq) <- fungi_name
    if(fungi_name == 'other'){next}
    plot.rsq [[k]] <- rsq
    plot.rmse[[k]] <- obs.rmse
    stat.return <- c(fungi_name, rsq, rsq.1, obs.rmse)
    names(stat.return) <- c('name','rsq','rsq.1','rmse')
    plot.stat[[k]] <- stat.return
  }
  #site.level----
  x <- fcast$site.fit$mean
  y <- val.truth[[i]]$site.fit$mean
  #make sure row and column order match.
  y <- y[rownames(y) %in% rownames(x),]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[,colnames(y) %in% colnames(x)]
  x <- x[,colnames(x) %in% colnames(y)]
  x <- x[order(match(rownames(x),rownames(y))),]
  x <- x[,order(match(colnames(x),colnames(y)))]
  #fit model, grab r2.
  for(k in 1:ncol(y)){
    fungi_name <- colnames(x)[k]
    rsq <- summary(lm(y[,k] ~ x[,k]))$r.squared
    rsq.1 <- rsq_1.1(y[,k], x[,k])
    obs.rmse <- rmse(y[,k],x[,k])
    names(obs.rmse) <- names(rsq)
    names(rsq) <- fungi_name
    if(fungi_name == 'other'){next}
    site.rsq [[k]] <- rsq
    site.rmse[[k]] <- obs.rmse
    stat.return <- c(fungi_name, rsq, rsq.1, obs.rmse)
    names(stat.return) <- c('name','rsq','rsq.1','rmse')
    site.stat[[k]] <- stat.return
  }
  #wrap up for return.----
  all.core.rsq [[i]] <- unlist(core.rsq)
  all.plot.rsq [[i]] <- unlist(plot.rsq)
  all.site.rsq [[i]] <- unlist(site.rsq)
  all.core.rmse[[i]] <- unlist(core.rmse)
  all.plot.rmse[[i]] <- unlist(plot.rmse)
  all.site.rmse[[i]] <- unlist(site.rmse)
  all.core.stat[[i]] <- do.call(rbind, core.stat)
  all.plot.stat[[i]] <- do.call(rbind, plot.stat)
  all.site.stat[[i]] <- do.call(rbind, site.stat)
}

# fix functional groupings for output
#core-level
core.rsq.fg <- list(unlist(all.core.rsq[6:18]))
all.core.rsq <- c(core.rsq.fg, all.core.rsq[1:5])
core.rmse.fg <- list(unlist(all.core.rmse[6:18]))
all.core.rmse <- c(core.rmse.fg, all.core.rmse[1:5])
names(all.core.rmse) <- c('functional','phylum','class','order','family','genus')
names(all.core.rsq) <- c('functional','phylum','class','order','family','genus')
#plot-level
plot.rsq.fg <- list(unlist(all.plot.rsq[6:18]))
all.plot.rsq <- c(plot.rsq.fg, all.plot.rsq[1:5])
plot.rmse.fg <- list(unlist(all.plot.rmse[6:18]))
all.plot.rmse <- c(plot.rmse.fg, all.plot.rmse[1:5])
names(all.plot.rsq) <- c('functional','phylum','class','order','family','genus')
names(all.plot.rmse) <- c('functional','phylum','class','order','family','genus')
#site-level
site.rsq.fg <- list(unlist(all.site.rsq[6:18]))
all.site.rsq <- c(site.rsq.fg, all.site.rsq[1:5])
site.rmse.fg <- list(unlist(all.site.rmse[6:18]))
all.site.rmse <- c(site.rmse.fg, all.site.rmse[1:5])
names(all.site.rsq) <- c('functional','phylum','class','order','family','genus')
names(all.site.rmse) <- c('functional','phylum','class','order','family','genus')

# means by taxonomic rank
val.mu <- unlist(lapply(all.site.rsq, mean  ))
val.sd <- unlist(lapply(all.site.rsq, sd    ))
val.N  <- unlist(lapply(all.site.rsq, length))
val.se <- val.sd / sqrt(val.N)

names(val.mu) <- names(all.site.rsq)
core.rsq <- unlist(all.core.rsq)
plot.rsq <- unlist(all.plot.rsq)
site.rsq <- unlist(all.site.rsq)
core.rmse <- unlist(all.core.rmse)
plot.rmse <- unlist(all.plot.rmse)
site.rmse <- unlist(all.site.rmse)
names(core.rmse) <- names(core.rsq)
names(plot.rmse) <- names(plot.rsq)
names(site.rmse) <- names(site.rsq)

#Subset to observations that have a minimum calibration R2 value.----
pass <- lev.cal.r2
core.rsq <- core.rsq[names(core.rsq) %in% names(pass)]
plot.rsq <- plot.rsq[names(plot.rsq) %in% names(pass)]
site.rsq <- site.rsq[names(site.rsq) %in% names(pass)]
core.rmse <- core.rmse[names(core.rmse) %in% names(pass)]
plot.rmse <- plot.rmse[names(plot.rmse) %in% names(pass)]
site.rmse <- site.rmse[names(site.rmse) %in% names(pass)]
core.d <- zero_truncated_density(core.rsq)
plot.d <- zero_truncated_density(plot.rsq)
site.d <- zero_truncated_density(site.rsq)
core.rmse.d <- zero_truncated_density(core.rmse)
plot.rmse.d <- zero_truncated_density(plot.rmse)
site.rmse.d <- zero_truncated_density(site.rmse)

#png save line.----
png(filename=output.path,width=8,height=6,units='in',res=300)

#global plot settings.----
#par(mfrow = c(2,3), mar = c(5,4,2,1), oma = c(1,1,1,1))
par(mfrow = c(1,3), mar = c(5,4,2,1), oma = c(1,1,1,1))
limx <- c(0,1)
limy <- c(0, 5.1)
trans <- 0.2 #shading transparency.
o.cex <- 1.0 #outer label size.
cols <- c('purple','cyan','yellow')

#Calibration R2 denisty plot (retired).-----
#dat <- unlist(cal.r2)
#dat <- zero_truncated_density(dat)
#limy <- c(0, max(dat$y)*1.05)
#limx <- c(0, max(dat$x))
##Density plot.
#plot(dat,xlim = limx, ylim = limy, bty = 'l', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1, lwd = 0)
#polygon(dat, col = adjustcolor(cols[3],trans))
#mtext('Density', side = 2, line = 2.5, cex = o.cex)
#mtext(expression(paste("Calibration R"^"2")), side = 1, line = 3, cex = o.cex)
#mtext('(a)', side = 3, adj = 0.95, line = -2)

#Validation R2 denisty plot.-----
dat.a <- core.d
dat.b <- plot.d
dat.c <- site.d
limy <- c(0, max(c(dat.a$y, dat.b$y, dat.c$y))*1.05)
limx <- c(0, max(c(dat.a$x, dat.b$x, dat.c$x)))
#Density plot.
plot(dat.a,xlim = limx, ylim = limy, bty = 'l', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1, lwd = 0)
polygon(dat.a, col = adjustcolor(cols[1],trans))
polygon(dat.b, col = adjustcolor(cols[2],trans))
polygon(dat.c, col = adjustcolor(cols[3],trans))
mtext('Density', side = 2, line = 2.5, cex = o.cex)
mtext(expression(paste("Validation R"^"2")), side = 1, line = 3, cex = o.cex)
#legend
legend(x = 0.5, y = 12.5, legend = c('core','plot','site'), col ='black', pt.bg=adjustcolor(cols,trans), bty = 'n', pch = 22, pt.cex = 1.5, cex = 1.2)
mtext('(d)', side = 3, adj = 0.95, line = -2)

#Validation RMSE denisty plot.-----
dat.a <- core.rmse.d
dat.b <- plot.rmse.d
dat.c <- site.rmse.d
limy <- c(0, max(c(dat.a$y, dat.b$y, dat.c$y))*1.05)
limx <- c(0, max(c(dat.a$x, dat.b$x, dat.c$x)))
#Density plot.
plot(dat.a,xlim = limx, ylim = limy, bty = 'l', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1, lwd = 0)
polygon(dat.a, col = adjustcolor(cols[1],trans))
polygon(dat.b, col = adjustcolor(cols[2],trans))
polygon(dat.c, col = adjustcolor(cols[3],trans))
mtext('Density', side = 2, line = 2.5, cex = o.cex)
mtext(expression(paste("Validation RMSE")), side = 1, line = 3, cex = o.cex)
#legend
legend(x = 0.5, y = 12.5, legend = c('core','plot','site'), col ='black', pt.bg=adjustcolor(cols,trans), bty = 'n', pch = 22, pt.cex = 1.5, cex = 1.2)
mtext('(e)', side = 3, adj = 0.95, line = -2)

#Calibration and Validation rsq ~ function/phylo scale.----
x <- 1:length(cal.mu)
limy <- c(0,max(cal.mu)*1.1)
plot(cal.mu ~ x, cex = 2.5, ylim = limy, pch = 16, ylab = NA, xlab = NA, bty='l', xaxt = 'n', yaxs='i', las = 1, lwd = 0)
#arrows(x, lev.mu - lev.se, x1 = x, y1 = lev.mu + lev.se, length=0.00, angle=90, code=3, col = 'black')
lines(x, cal.mu, lty = 2)
lines(x, val.mu, lty = 2)
points(val.mu ~ x, cex = 2.5, pch = 16, col = 'gray')
mtext(expression(paste("Site-Level R"^"2")), side = 2, line = 2.5, cex = o.cex)
axis(1, labels = F)

text(x=x+0.05, y = -.03, labels= names(cal.mu), srt=45, adj=1, xpd=TRUE, cex = 1.25)
#legend
legend(x = 1, y = 0.1, legend = c('calibration','validation'), col =c('black','gray'), bty = 'n', pch = 16, pt.cex = 2.5, cex = 1.2, y.intersp = 2.6)
mtext('(f)', side = 3, adj = 0.95, line = -2)

#Outer labels.----
mtext('Bacteria'   , cex = 1.5, side = 3, outer = T, adj = 0.01, line = -1)
#mtext('Bacteria', cex = 1.5, side = 3, outer = T, adj = 0.01, line = -23)

#end plot.----
dev.off()


#!/usr/bin/env Rscript
# Written by:
# Jose Rodrigo Flores Espinosa <joserodrigo.floresespinosa@unil.ch>
# Daniele Silvestro <daniele.silvestro@unil.ch>
# In colaboration with:
# Martha Serrano <martha.serrano@unil.ch>

#####################################
#####################################
### B-Diversitree is a module that runs a bayesian implementation of the Musse, Geosse and Classe models present in the package Diversitree.
###
###
###
###
#####################################
#####################################
# Loading Libraries Required

suppressPackageStartupMessages(library("optparse"))
suppressPackageStartupMessages(library("diversitree"))
suppressPackageStartupMessages(library("picante"))

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

#####################################
# Parsing Command Line Options

option_list <- list(

    make_option("--i", type="integer", default=1000000,
        help=("Number of iterations to run [default %default]."),
        metavar="Iterations"),

    make_option("--s", type="integer", default=100,
        help="Frequency of sampling [default %default]",
        metavar="Freq_of_Sampling"),

    make_option("--b", type="integer", default=1000,
        help=("Skip results of the first # of iterations [default %default]."),
        metavar="Burnin"),

    make_option("--p", type="integer", default=100,
        help=("Print frequency [default %default]."),
        metavar="Prnt_freq"),

    make_option("--d", type="double", default=0.05,
        help=("Window size update parameters [default %default]."),
        metavar="D-Range"),

    make_option("--r", type="integer", default=5,
        help=("Rate to use for the calculation of the prior [default %default]."),
        metavar="Rate"),

    make_option("--t", type="integer", default=1,
        help=("Number of trees [default %default]."),
        metavar="Tree"),

        make_option("--rho",  default="1 1 1",
            help=("Taxon sampling (in quotations, space separated) [default %default]."),
            metavar="Rate"),

    make_option("--c", default="NULL",
        help="Parameters to be constrained. Introduce \"lamdas\", \"mus\" or \"qs\". \n\t\t Alternatively a string representing the desired contraints can be introduced. \n\t\t E.g. For three states under a Musse model: \"1,2,2,4,5,6,7,8,9,10,8,12\" \n\t\t This indicates lamda3 ~ lamda2 and q31 ~ q13 [default %default]",
        metavar="Constraints")

    )

# number of traits is pending
# number of trees is pending
parser_object <- OptionParser(usage = "Usage: %prog [Options] [TREE] [STATES] [MODEL]\n\n[TREE] Path to a file containig one or more phylogenetic tree(s).\n[STATES] Path to a file containig the name of each species in the pylogenetic file, along with their respective state.\n[MODEL] Model to be used for the bayesian calculations. The model can be \"musse\", \"geosse\" or \"classe\". \n", option_list=option_list, description="B-Diversitree is a module that runs a bayesian implementation of Musse, Geosse and Classe models present in the R package Diversitree.")
opt <- parse_args(parser_object, args = commandArgs(trailingOnly = TRUE), positional_arguments=TRUE)

#####################################
# Handling User Input and/or Option Errors

if (length(opt$args) < 3){
   cat("Error message: At least one of the input files is missing and/or the model has not been specified.\n\n"); print_help(parser_object); quit(status=1)
}

#####################################
# Defining Variables and Objects

#set.seed(2)
file_tree <- opt$args[1]
file_states <- opt$args[2]
model <- opt$args[3]

######################################
# Reading Input Files
tree=read.nexus(file=file_tree)

if (class(tree)=="multiPhylo"){current_tree=tree[[1]]
}else{current_tree=tree}

states_frame <- read.table(file=file_states, h=T, row.names=1)
matched_tree <- match.phylo.data(current_tree,states_frame) # Drop tips with no info
states_vector <- matched_tree$data[,1] # vector of states
names(states_vector) <- row.names(matched_tree$data) # adding names to each state
no_states <- length(unique(states_vector))
current_tree <- matched_tree$phy

#####################################
# Defining Variables and Objects
print(model)
if (model == "musse"){
  initial_parameters <- starting.point.musse(current_tree, no_states, q.div=5, yule=FALSE)   # Starting conditions
} else if (model == "geosse") {
  initial_parameters <- starting.point.geosse(current_tree, eps=0.5)
} else if (model == "classe") {
  initial_parameters <- starting.point.classe(current_tree, no_states, eps=0.5)
}

d <- rep(opt$options$d, length(initial_parameters))
sampling_freq <- opt$options$s
print_freq<- opt$options$p
burnin <- opt$options$b
rate <- opt$options$r
iterations <- opt$options$i
constraint <- opt$options$c
nTREES <- opt$options$t

rhos_str <- opt$options$rho
rhos <- as.numeric(strsplit(rhos_str," ")[[1]])
print(rhos)
acc=0

######################################
# Defining Functions
#

# Function to calculate the prior
#
exp_prior = function(values, rate){
  new_values = dexp(values, rate=1/rate,log=T) # lamda set to 5 default
  return(new_values)
}

# Function to change all parameters of one kind
update_parameters <- function(accepted_state_values, indexes, d, M) {
  i = accepted_state_values[indexes]
  ii = NULL
  ii= abs(i+(runif(length(i),0,1)-.5)*d[indexes])
  #for (j in 1:length(i)){
  #  ii[j] = abs(i[j]+(runif(1,0,1)-.5)*d[indexes[j]])
  #}
  if (max(ii) > M) {ii=abs((M-(ii-M)))}
  accepted_state_values[indexes]=ii
  return(accepted_state_values)
}

# Function to construct the constraint vector
#

get_constraint <- function(temp_state, constraint, model, no_states) {

  vec = rep(1:length(temp_state))

  if (constraint == "lamdas"){

    if ( (model == "musse") | (model == "geosse") ) {
      vec_temp = rep(1, no_states)                      # lamdas == to number of states (in geosse this is always 3)
      vec[1:no_states] = vec_temp
    }
    if (model == "classe") {
      x = no_states*no_states*(no_states+1)/2           # lamdas == to n*n*(n+1)/2  # length(parameters) = (k + 3) * k * k/2)
      vec_temp = rep(1, x)
      vec[1:x] = vec_temp
    }

  } else if (constraint == "mus"){

    if (model == "musse") {
      vec_temp = rep(no_states+1, no_states)            # mus == to number of states
      vec[(no_states+1):(no_states*2)] = vec_temp       # length(parameters) = k(k+1)
    }
    if (model == "geosse") {                            # number of mus is always 2
      vec_temp = rep(no_states+1, 2)                    # length(parameters) is always 7
      vec[(no_states+1):(no_states+2)] = vec_temp
    }
    if (model == "classe") {                            # mus = to number of states  # length(parameters) = (k + 3) * k * k/2)
      x = no_states*no_states*(no_states+1)/2           # number of lamdas
      vec_temp = rep((x+1),(no_states))                 # from #_lamdas to #_lamdas + #_states
      vec[(x+1):(x+no_states)] = vec_temp
    }

  } else if (constraint == "qs"){

    if (model == "musse") {                                                  # qs == k(k+1) - (no_states*2)
      vec_temp = rep((no_states*2+1),(length(temp_state)-no_states*2))       # length(parameters) = k(k+1)
      vec[(no_states*2+1):(length(temp_state))] = vec_temp
    }
    if (model == "geosse") {                            # number of mus is always 2
      vec_temp = rep(3+2+1, 2)                          # length(parameters) is always 7
      vec[(3+2+1):(7)] = vec_temp                       # number of lamdas is always 3
    }
    if (model == "classe") {                                            # lamdas == to n*n*(n+1)/2  # length(parameters) = (k + 3) * k * k/2)
      x = no_states*no_states*(no_states+1)/2                           # mus = to number of states
      vec_temp = rep((x+no_states+1),(length(temp_state)-x-no_states))
      vec[(x+no_states+1):(length(temp_state))] = vec_temp
    }

  } else {

    vec = as.numeric(unlist(strsplit(constraint, ",")))

  }
  return(vec)
}

##################################
# Main Program

cat(paste("Writing to File: ", opt$args[1], "_", opt$args[3], "_mcmc.log\n", sep=""))

real_it=0
for (J in 1:nTREES){
	if (class(tree)=="multiPhylo"){current_tree=tree[[J]]}
	else{current_tree=tree}

	states_frame <- read.table(file=file_states, h=T, row.names=1)
	matched_tree <- match.phylo.data(current_tree,states_frame) # Drop tips with no info
	states_vector <- matched_tree$data[,1] # vector of states
	names(states_vector) <- row.names(matched_tree$data) # adding names to each state
	current_tree <- matched_tree$phy

	for (it in 1:iterations){

	  # First Iteration / Initial Conditions
	  #
	  if (it==1) {
	     if (model == "musse"){
	       initial_parameters <- starting.point.musse(current_tree, no_states, q.div=5, yule=FALSE)   # Starting conditions
	     } else if (model == "geosse") {
	       initial_parameters <- starting.point.geosse(current_tree, eps=0.5)
	     } else if (model == "classe") {
	       initial_parameters <- starting.point.classe(current_tree, no_states, eps=0.5)
	     }
 	    current_state=initial_parameters
 	    accepted_state=current_state
 	    accepted_lik=-Inf
 	    accepted_prior=-Inf
    }

   	  if (real_it==0) {
	    cat(c("Iteration", "likelihood", "prior", "acceptance", "tree", names(accepted_state)), "\n", append=FALSE, file=paste(opt$args[1], "_", opt$args[3], "_mcmc.log", sep=""), sep="\t")
	  }

	  # Likelihood Calculation
	  #

	  if (model == "musse"){
		  LIKELIHOOD <- make.musse(current_tree, states_vector, no_states, strict=T, sampling.f=rhos)
	  } else if (model == "geosse") {
		  LIKELIHOOD <- make.geosse(current_tree, states_vector, strict=T, sampling.f=rhos)
	  } else if (model == "classe") {
	    LIKELIHOOD <- make.classe(current_tree, states_vector, no_states, strict=T, sampling.f=rhos)
	  }  else if (model == "quasse") {
	    LIKELIHOOD <- make.quasse(current_tree, states_vector, states.sd,lambda=constant.x, mu=constant.x, sampling.f=rhos)
          }
		# More models to implement ..

	  # Updating Parameters
	  #

	  flag <- sample(c("lamdas","mus","qs"), 1)

	  if (model == "musse"){

	    if (flag == "lamdas") { indexes = c(1:no_states)
	    } else if (flag == "mus") { indexes = c((no_states+1):(no_states*2))
	    } else if (flag == "qs")  { indexes = c((no_states*2+1):(length(initial_parameters)) ) }

	  } else if (model == "geosse") {

	    if (flag == "lamdas") { indexes = c(1:no_states)
	    } else if (flag == "mus") { indexes = c((no_states+1):(no_states+2))
	    } else if (flag == "qs")  { indexes = c((no_states+3):(length(initial_parameters)) ) }

	  } else if (model == "classe") {
	    x = no_states*no_states*(no_states+1)/2
	    if (flag == "lamdas") { indexes = c(1:x)
	    } else if (flag == "mus") { indexes = c((x+1):(x+no_states))
	    } else if (flag == "qs")  { indexes = c((x+no_states+1):(length(initial_parameters)) )}

  	  } else if (model == "quasse") {
  	    x = no_states*no_states*(no_states+1)/2
  	    if (flag == "lamdas") { indexes = c(1:x)
  	    } else if (flag == "mus") { indexes = c((x+1):(x+no_states))
  	    } else if (flag == "qs")  { indexes = c((x+no_states+1):(length(initial_parameters)) )}

  	  }

	  # Updating the parameters
	  #

	  temporal_state <- update_parameters(accepted_state, indexes, d, 1000)

	  # Updatig the parameters according to the constraints specified, if any.
	  #

	  if (constraint == "NULL") {
	    current_state = temporal_state
	  } else {
	    constraint_vector <- get_constraint(temporal_state, constraint, model, no_states)
	    current_state = temporal_state[constraint_vector]
	  }

	  # Prior calculation
	  #
		current_prior <- sum(exp_prior(current_state, rate))

		# Lik Calculation
	  #
		current_lik <- try(LIKELIHOOD(c(current_state)))
		if (is.na(current_lik) | (class(current_lik) == "try-error" )) {current_lik = -Inf}

		# Acceptance Conditions
	  #
		if ( (current_lik-accepted_lik) + (current_prior-accepted_prior) >= log(runif(1,0,1)) | it==0 ){
			accepted_lik=current_lik
			accepted_prior=current_prior
			accepted_state=current_state
			acc = acc + 1
		}

		if (it==0) {acc=1}

	  # Appending % of accepted states
		if ( (it %% sampling_freq == 0) & (it >= burnin) ) {
			cat(sprintf("%s\t", c(real_it, accepted_lik, accepted_prior, acc/it, J, accepted_state)), "\n", append=TRUE, file=paste(opt$args[1], "_", opt$args[3], "_mcmc.log", sep=""))
			real_it=real_it+sampling_freq
		}
		if ( (it %% print_freq == 0)) {
			cat(sprintf("%s\t", round(c(real_it,it, accepted_lik, accepted_prior, acc/it, J, accepted_state),3)), "\n", sep="")
		}

	}

}