LogPlots <- function(Infile)
{

  Infile <- "log.txt"  #NAME OF LOG.TXT FILE FROM ATLANTIS
  Name_File <- "Group_Names.csv" # FILE CONTAINING NAMES OF FUNCTIONAL GROUPS

  StartDay <- 150
  StartYear <- 2008

  #READ LOG.TXT FILE BY STRING INTO VARIABLE 'X'
  data <- readLines(Infile)

  #READ IN NAMES OF FUNCTIONAL GROUPS
  Group_Names <- read.table(Name_File, header=TRUE, sep=",")

  for (i in 1:length(data))
  {
   if (data[i] == "")
   {
      data[i] <- c("-999", "-999", "-999")
   }
  }

  #FIND THE NUMBER OF TIMESTEPS IN LOG.TXT
  timesteps <- 0
  for (i in 2:length(data))
  {
    current_row <- strsplit(data[i], split=" ")
    prior_row <- strsplit(data[i-1], split=" ")

    if(is.na(current_row[[1]][1]))
    {
      current_row[[1]][1] <- "-999"
    }

    if(is.na(prior_row[[1]][1]))
    {
      prior_row[[1]][1] <- "-999"
    }

    if(current_row[[1]][1] == "Time:" & prior_row[[1]][1] != "Time:")
    {
     timesteps <- timesteps + 1
    }
  }

  #DECLARE ARRAYS TO HOLD DATA FROM LOG.TXT
  Biomass <- array(dim=c(length(Group_Names[ ,1]), timesteps))  #X=GROUP, Y=TIMESTEP -- HOLD TOTAL BIOMASS
  Res_N <- array(dim=c(length(Group_Names[ ,1]), 10, timesteps)) #X=GROUP, Y=AGECLASS, Z=TIMESTEP -- HOLDS RESERVE NITROGEN
  Str_N <- array(dim=c(length(Group_Names[ ,1]), 10, timesteps)) #X=GROUP, Y=AGECLASS, Z=TIMESTEP -- HOLD STRUCTURAL NITROGEN
  Den <- array(dim=c(length(Group_Names[ ,1]), 10, timesteps)) #X=GROUP, Y=AGECLASS, Z=TIMESTEP -- HOLDS NUMBERS
  Timestep <- 0

  #FIND FIRST TIME STEP (BEYOND INITIAL CONDITIONS)
  i <- 1
  current_row <- strsplit(data[i], split=" ")
  while (current_row[[1]][1] != "Time:")
  {
   i <- i + 1
   current_row <- strsplit(data[i], split=" ")
   if(is.na(current_row[[1]][1]))
   {
    current_row[[1]] <- c("-999", "-999", "-999")
   }
  }

  i <- i + 1
  current_row <- strsplit(data[i], split=" ")
  while (current_row[[1]][1] == "Time:")
  {
   i <- i + 1
   current_row <- strsplit(data[i], split=" ")
   if(is.na(current_row[[1]][1]))
   {
    current_row[[1]] <- c("-999", "-999", "-999")
   }
  }

  i <- i + 1
  current_row <- strsplit(data[i], split=" ")
  while (current_row[[1]][1] != "Time:")
  {
   i <- i + 1
   current_row <- strsplit(data[i], split=" ")
   if(is.na(current_row[[1]][1] == TRUE))
   {
    current_row[[1]] <- c("-999", "-999", "-999")
   }
  }

  #i IS NOW THE ROW NUMBER FOR FIRST TIMESTEP
  #BEGIN READING DATA

  for (j in 2:timesteps) #J WILL BE COUNTER FOR TIMESTEPS
  {
    #BIOMASS DATA WILL BE FIRST IN FILE
    while (current_row[[1]][1] == "Time:")
    {
      current_grp <- current_row[[1]][4]
      grp_index <- which(Group_Names[ ,1] == current_grp)

      if (j == 2) #RECORD INITIAL CONDITIONS
      {
        Biomass[grp_index, 1] <-  current_row[[1]][16]
        Timestep[1] <- 0
      }

      Biomass[grp_index, j] <-  current_row[[1]][12]
      tmp <- strsplit(current_row[[1]][2], split=",")
      Timestep[j] <- tmp[[1]][1]

      i <- i + 1

      current_row <- strsplit(data[i], split=" ")
      if(is.na(current_row[[1]][1]))
      {
        current_row[[1]] <- c("-999", "-999", "-999")
      }
    }

    #NOW READ NITROGEN AND DENSITY NUMBERS
    while (current_row[[1]][1] != "Time:" & i < length(data))
    {
      tmp <- strsplit(current_row[[1]][2], split="-")

      if(is.na(tmp))
      {
      	tmp <- "-999"
      }

      if (tmp[[1]][1] == "sn")
      {
        current_grp <- strsplit(current_row[[1]][1], split="-")
        grp_index <- which(Group_Names[ ,1] == current_grp[[1]][1])

        if (j == 2) #RECORD INITIAL CONDITIONS
        {
          tmp <- strsplit(current_row[[1]][18], split=",")
          Res_N[grp_index, as.numeric(current_grp[[1]][2])+1, 1] <-  tmp[[1]][1]

          tmp <- strsplit(current_row[[1]][16], split=",")
          Str_N[grp_index, as.numeric(current_grp[[1]][2])+1, 1] <-  tmp[[1]][1]

          tmp <- strsplit(current_row[[1]][20], ")")
          Den[grp_index, as.numeric(current_grp[[1]][2])+1, 1] <-  tmp[[1]][1]
        }

        tmp <- strsplit(current_row[[1]][11], split=",")
        Res_N[grp_index, as.numeric(current_grp[[1]][2])+1, j] <-  tmp[[1]][1]

        tmp <- strsplit(current_row[[1]][9], split=",")
        Str_N[grp_index, as.numeric(current_grp[[1]][2])+1, j] <-  tmp[[1]][1]

        Den[grp_index, as.numeric(current_grp[[1]][2])+1, j] <-  current_row[[1]][13]
      }

      i <- i + 1

      current_row <- strsplit(data[i], split=" ")
      if(is.na(current_row[[1]][1]))
      {
        current_row[[1]] <- c("-999", "-999", "-999")
      }
    } #END OF WHILE LOOP FOR READING NITROGEN AND DENSITY NUMBERS

  } #END OF TIMESTEP LOOP FOR READING NUMBERS FROM LOG.TXT

  #CONVERT STRING ARRAYS TO NUMERIC
  Biomass_Num <- array(as.double(Biomass), dim=dim(Biomass))
  Res_Num <- array(as.double(Res_N), dim=dim(Res_N))
  Str_Num <- array(as.double(Str_N), dim=dim(Str_N))
  Den_Num <- array(as.double(Den), dim=dim(Den))
  Time_Num <- array(as.numeric(Timestep))

  ##################  NOW PLOT DATA  ######################

  #GET NAME OF DIRECTORY FOR NAMING

  dirname <- getwd()
  dirname <- strsplit(dirname, split="/")
  dirlength <- length(dirname[[1]])
  dirname <- dirname[[1]][dirlength]

  #BIOMASS

  Outfile <- paste("Biomass_Plots_", dirname, ".pdf", sep="")
  pdf(Outfile)

  ylabel <- "Biomass (Metric Tons)"
  xlabel <- "Year"

  k <- 1
  while (k <= length(Group_Names[ , 1]))
  {
    par(mfrow=c(3,2))

    for (l in 1:6)
    {
      if (k <= length(Group_Names[ , 1]))
      {
        if(is.na(Biomass_Num[k, 1]))
        {
          Biomass_Num[k, ] <- 0
          plottitle <- paste(Group_Names[k, 5], "\n", Group_Names[k, 1], ", ", Group_Names[k, 4], "\n", "(Not in Model)", sep="")
          ymin <- -1
          ymax <- 1
        }else
        {
          plottitle <- paste(Group_Names[k, 5], "\n", Group_Names[k, 1], ", ", Group_Names[k, 4], sep="")

          virgin <- array(dim=length(Time_Num), Biomass_Num[k,1]*Group_Names[k, 6])

          ymin <- 0.9 * min(Biomass_Num[k, ], virgin)
          ymax <- 1.1 * max(Biomass_Num[k, ], virgin)
        }

        plot((Time_Num + StartDay)/360 + StartYear, Biomass_Num[k, ], ylim=c(0, ymax), ylab = ylabel, xlab=xlabel, main=plottitle, lwd=3, type='l', cex.lab=1, cex.axis=1, col='black',lty='dashed')

        ###NEW###
        virgin <- array(dim=length(Time_Num), Biomass_Num[k,1]*Group_Names[k, 6])
        lines((Time_Num + StartDay)/360 + StartYear, virgin, col="green")
      }
      k <- k+1
    }

  }

  dev.off()

  msg=paste("Biomass Plots Saved To:", Outfile)
  print(msg)

  #RESERVE NITROGEN / INITITAL RESERVE NITROGEN , X=GROUP, Y=AGECLASS, Z=TIMESTEP

  Outfile <- paste("Res_N_Plots_", dirname, ".pdf", sep="")

  pdf(Outfile)

  ylabel <- "Res_N / Initial Res_N"
  xlabel <- "Year"

  rainbowColors<-rainbow(10)

  k <- 28
  while (k <= length(Group_Names[ , 1]))
  {
    par(mfrow=c(3,2))

    for (l in 1:6)
    {
      if (k <=length(Group_Names[ , 1]))
      {
        if(is.na(Res_Num[k, 1, 1]))
        {
          Res_Num[k, 1, ] <- 0
          plottitle <- paste(Group_Names[k, 5], "\n", Group_Names[k, 1], ", ", Group_Names[k, 4], "\n", "(Not in Model)", sep="")
          plot((Time_Num + StartDay)/360 + StartYear, Res_Num[k, 1, ], ylab = ylabel, xlab=xlabel, main=plottitle, lwd=1,type='l', cex.lab=1, cex.axis=1, col = rainbowColors[m],lty=m)
        }else
        {
          ymin <- 0.9 * min(Res_Num[k, , ]/Res_Num[k, ,1], na.rm =TRUE)
          ymax <- 1.1 * max(Res_Num[k, , ]/Res_Num[k, ,1], na.rm =TRUE)

          for (m in 1:10)
          {
            if (m == 1)
            {
              plottitle <- paste(Group_Names[k, 5], "\n", Group_Names[k, 1], ", ", Group_Names[k, 4], sep="")
              plot((Time_Num + StartDay)/360 + StartYear, Res_Num[k, m, ]/Res_Num[k, m, 1], ylim=c(0, ymax), ylab = ylabel, xlab=xlabel, main=plottitle, lwd=1,type='l', cex.lab=1, cex.axis=1, col = rainbowColors[m],lty=m)
            }else
            {
              lines((Time_Num + StartDay)/360 + StartYear, Res_Num[k, m, ]/Res_Num[k, m, 1], lwd=1,type='l', col = rainbowColors[m],lty=m)
            }
          }
        }
      }
      k <- k+1
    }
  }

  dev.off()

  msg=paste("Reserve N Plots Saved To:", Outfile)
  print(msg)

  #STRUCTURAL NITROGEN / INITITAL STRUCTURAL NITROGEN , X=GROUP, Y=AGECLASS, Z=TIMESTEP

  Outfile <- paste("Str_N_Plots_", dirname, ".pdf", sep="")
  pdf(Outfile)

  ylabel <- "Str_N / Initial Str_N"
  xlabel <- "Year"

  rainbowColors<-rainbow(10)

  k <- 28
  while (k <= length(Group_Names[ , 1]))
  {
    par(mfrow=c(3,2))

    for (l in 1:6)
    {
      if (k <=length(Group_Names[ , 1]))
      {
        if(is.na(Str_Num[k, 1, 1]))
        {
          Str_Num[k, 1, ] <- 0
          plottitle <- paste(Group_Names[k, 5], "\n", Group_Names[k, 1], ", ", Group_Names[k, 4], "\n", "(Not in Model)", sep="")
          plot((Time_Num + StartDay)/360 + StartYear, Str_Num[k, 1, ], ylab = ylabel, xlab=xlabel, main=plottitle, lwd=1,type='l', cex.lab=1, cex.axis=1, col = rainbowColors[m],lty=m)
        }else
        {
          ymin <- 0.9 * min(Str_Num[k, , ]/Str_Num[k, ,1], na.rm =TRUE)
          ymax <- 1.1 * max(Str_Num[k, , ]/Str_Num[k, ,1], na.rm =TRUE)

          for (m in 1:10)
          {
            if (m == 1)
            {
              plottitle <- paste(Group_Names[k, 5], "\n", Group_Names[k, 1], ", ", Group_Names[k, 4], sep="")
              plot((Time_Num + StartDay)/360 + StartYear, Str_Num[k, m, ]/Str_Num[k, m, 1], ylim=c(0, ymax), ylab = ylabel, xlab=xlabel, main=plottitle, lwd=1,type='l', cex.lab=1, cex.axis=1, col = rainbowColors[m],lty=m)
            }else
            {
              lines((Time_Num + StartDay)/360 + StartYear, Str_Num[k, m, ]/Str_Num[k, m, 1], lwd=1,type='l', col = rainbowColors[m],lty=m)
            }
          }
        }
      }
      k <- k+1
    }
  }

  dev.off()

  msg=paste("Structural N Plots Saved To:", Outfile)
  print(msg)

  #DENSITY (NUMBERS) , X=GROUP, Y=AGECLASS, Z=TIMESTEP

  Outfile <- paste("Density_Plots_", dirname, ".pdf", sep="")
  pdf(Outfile)

  ylabel <- "Numbers"
  xlabel <- "Year"

  rainbowColors<-rainbow(10)

  k <- 28
  while (k <= length(Group_Names[ , 1]))
  {
    par(mfrow=c(3,2))

    for (l in 1:6)
    {
      if (k <=length(Group_Names[ , 1]))
      {
        if(is.na(Den_Num[k, 1, 1]))
        {
          Den_Num[k, 1, ] <- 0
          plottitle <- paste(Group_Names[k, 5], "\n", Group_Names[k, 1], ", ", Group_Names[k, 4], "\n", "(Not in Model)", sep="")
          plot((Time_Num + StartDay)/360 + StartYear, Den_Num[k, 1, ], ylab = ylabel, xlab=xlabel, main=plottitle, lwd=1,type='l', cex.lab=1, cex.axis=1, col = rainbowColors[m],lty=m)
        }else
        {
          ymin <- 0.9 * min(Den_Num[k, , ], na.rm =TRUE)
          ymax <- 1.1 * max(Den_Num[k, , ], na.rm =TRUE)

          for (m in 1:10)
          {
            if (m == 1)
            {
              plottitle <- paste(Group_Names[k, 5], "\n", Group_Names[k, 1], ", ", Group_Names[k, 4], sep="")
              plot((Time_Num + StartDay)/360 + StartYear, Den_Num[k, m, ], ylim=c(0, ymax), ylab = ylabel, xlab=xlabel, main=plottitle, lwd=1,type='l', cex.lab=1, cex.axis=1, col = rainbowColors[m],lty=m)
            }else
            {
              lines((Time_Num + StartDay)/360 + StartYear, Den_Num[k, m, ], lwd=1,type='l', col = rainbowColors[m],lty=m)
            }
          }
        }
      }
      k <- k+1
    }
  }

  dev.off()

  msg=paste("Biomass Plots Saved To:", Outfile)
  print(msg)

  graphics.off()

} #END OF FUNCTION


###### Figure 4
# depends on a bunch of data!
# TP-FP-yeast-setup.r, TP-FP-ty-setup.r
# TP-FP-yeast-summary-parallel.r, TP-FP-summary-parallel-ty.r
# TP-FP-summary-parallel-edgeR.r

# summarize the data

# calculated on yeast dataset
med.data.yeast <- matrix(data=NA, nrow=(max.samples - 1), ncol=13)
colnames(med.data.yeast) <- c('N samples', colnames(output.summary.yeast[[1]]) )
for( i in 1:(max.samples - 1) ){
  med.data.yeast[i,1] <- i+1
  med.data.yeast[i,2:13] <- apply(output.summary.yeast[[i]], 2, median)
}

# calculated on yeast dataset
med.data.edgeR <- matrix(data=NA, nrow=(max.samples - 1), ncol=7)
for( i in 1:(max.samples - 1) ){
  med.data.edgeR[i,1] <- i+1
  med.data.edgeR[i,2:7] <- apply(output.summary.edgeR[[i]], 2, median)
}

# calculated on ty 16S dataset
med.data.ty <- matrix(data=NA, nrow=(max.samples - 1), ncol=13)
colnames(med.data.ty) <- c('N samples', colnames(output.summary.ty[[1]]) )
for( i in 1:(max.samples - 1) ){
  med.data.ty[i,1] <- i+1
  med.data.ty[i,2:13] <- apply(output.summary.ty[[i]], 2, median)
}

####### lets plot

pdf('TPvsFP.pdf', height=6.5, width=11)
par(mfrow=c(1,2))

# TP open, FP closed in yeast dataset
# proportion of TP found
plot(med.data.yeast[,1], med.data.yeast[,2]/length(yeast.eff), ylim=c(0,1), main='A: Yeast TP/FP',
  xlab='N samples per group',
  ylab='TP and FP rate')
points(med.data.edgeR[,1], med.data.edgeR[,2]/length(diff.p), type='b', col="grey70", lwd=2)
points(med.data.edgeR[,1], med.data.edgeR[,6]/length(diff.p.FC), type='b', col="grey40", lwd=2)
points(med.data.yeast[,1], med.data.yeast[,4]/length(yeast.diff), col="cornflowerblue")
#points(med.data.yeast[,1], med.data.yeast[,6]/length(yeast.diff.eff), col="blue")
points(med.data.yeast[,1], med.data.yeast[,8]/length(yeast.ol), col="brown")
points(med.data.yeast[,1], med.data.yeast[,12]/length(yeast.diff.eff), col="orange")

# FP - proportion of all that are FP
points(med.data.edgeR[,1], med.data.edgeR[,3]/(med.data.edgeR[,2] + med.data.edgeR[,3]), type='b', pch=19, col="grey70", lwd=2)
points(med.data.edgeR[,1], med.data.edgeR[,7]/(med.data.edgeR[,6] + med.data.edgeR[,7]), type='b', pch=19, col="grey40", lwd=2)
points(med.data.yeast[,1], med.data.yeast[,3]/(med.data.yeast[,2] + med.data.yeast[,3]), pch=19)
points(med.data.yeast[,1], med.data.yeast[,5]/(med.data.yeast[,4] + med.data.yeast[,5]), pch=19, col="cornflowerblue")
#points(med.data.yeast[,1], med.data.yeast[,7]/(med.data.yeast[,6] + med.data.yeast[,7]), pch=19, col="blue")
points(med.data.yeast[,1], med.data.yeast[,9]/(med.data.yeast[,8] + med.data.yeast[,9]), pch=19, col="brown")
points(med.data.yeast[,1], med.data.yeast[,13]/(med.data.yeast[,12] + med.data.yeast[,13]), pch=19, col="orange")

legend(15.5,0.75, legend=c('effect','difference','overlap','triple','q','q+diff'),pch=19, col=c("black", "cornflowerblue", 'brown','orange','grey70','grey40'))

legend(12.8,0.75, legend=c('TP','FP'),pch=c(1,19))
abline(h=0.8, lty=2, lwd=3, col='darkgrey')
abline(h=0.1, lty=2, lwd=3, col='darkgrey')

# TP open, FP closed in ty dataset
# proportion of TP found
plot(med.data.ty[,1], med.data.ty[,2]/length(ty.eff), ylim=c(0,1),
  main='B: 16S TP/FP', xlab='N samples per group',
  ylab='TP and FP rate')
points(med.data.ty[,1], med.data.ty[,4]/length(ty.diff), col="cornflowerblue")
points(med.data.ty[,1], med.data.ty[,8]/length(ty.ol), col="brown")
points(med.data.ty[,1], med.data.ty[,12]/length(ty.diff.eff), col="orange")

# FP - proportion of all that are FP
points(med.data.ty[,1], med.data.ty[,3]/(med.data.ty[,2] + med.data.ty[,3]), pch=19)
points(med.data.ty[,1], med.data.ty[,5]/(med.data.ty[,4] + med.data.ty[,5]), pch=19, col="cornflowerblue")
points(med.data.ty[,1], med.data.ty[,9]/(med.data.ty[,8] + med.data.ty[,9]), pch=19, col="brown")
points(med.data.ty[,1], med.data.ty[,13]/(med.data.ty[,12] + med.data.ty[,11]), pch=19, col="orange")

legend(15.5,0.5, legend=c('effect','difference','overlap','triple'),pch=19, col=c("black", "cornflowerblue",'brown','orange','grey70','grey40'))

legend(12.8,0.5, legend=c('TP','FP'),pch=c(1,19))
abline(h=0.8, lty=2, lwd=3, col='darkgrey')
abline(h=0.1, lty=2, lwd=3, col='darkgrey')

dev.off()


#' @title dispersion parameter extraction
#' @description determines dispersion parameter for models fitted using various functions
#' @param x model result.
#' @return dispersion parameter.
#' @details supports models fitted using \code{glm}, \code{glm.nb\{MASS\}}, \code{glmer\{lme4\}}, \code{glmer.nb\{lme4\}},
#' \code{zeroinfl\{pscl\}}, and \code{glmmTMB\{glmmTMB\}} fitted with family being one of binomial, poisson, beta, nbinom1, nbinom2, or Gamma.
#' @examples
#' m=glm(rpois(n=50, lambda=pi)~1, family=poisson)
#' disp.par(m)
#' @export
disp.par<-function(x){
  ##last updated Nov 26 2019
  ##additions/changes: bugfix for zeroinfl; deals with glmmTMB (beta and nbinom family)
  ##function needed for Gamma family:
  if(class(x)[[1]]!="glmmTMB"){
    pr=residuals(x, type ="pearson")
    sum.dp=sum(pr^2)
  }
  n.model.terms=NULL
  if(class(x)[[1]]=="glmerMod"){
    n.model.terms=length(fixef(x))+nrow(as.data.frame(summary(x)$varcor))
    if(family(x)$family%in%c("negative.binomial", "Gamma", "inverse.gaussian")){
			n.model.terms=n.model.terms+1
			#browser()
			if(family(x)$family=="inverse.gaussian"){
				if(family(x)$link=="log"){
					pr=as.vector(residuals(x, type ="response"))
					fitted.var=(fitted(x)^3)/(1/sigma(x))
					sum.dp = sum((pr/sqrt(fitted.var))^2)
				}else{
					stop("inverse Gaussian with link other than log isn't supported")
				}
			}
		}
  }else if(class(x)[[1]]=="glm"){
		n.model.terms=length(x$coefficients)
		if(class(x)[[1]]=="negbin"){
			n.model.terms=n.model.terms+length(summary(x)$theta)
		}else if(family(x)$family%in%c("Gamma", "inverse.gaussian")){
			n.model.terms=n.model.terms+1
			if(family(x)$family=="inverse.gaussian"){
				if(x$family$link=="log"){
					pr=as.vector(residuals(x, type ="response"))
					fitted.var=(fitted(x)^3)/(1/summary(x)$dispersion)
					sum.dp = sum((pr/sqrt(fitted.var))^2)
				}else{
					stop("inverse Gaussian with link other than log isn't supported")
				}
			}
		}
  }else if(class(x)[[1]]=="zeroinfl"){
    n.model.terms=sum(unlist(lapply(x$coefficients, length)))
    n.model.terms=n.model.terms+length(summary(x)$theta)
  }else if(class(x)[[1]]=="betareg"){
    n.model.terms=sum(unlist(lapply(x$coefficients, length)))
  }else if(class(x)[[1]]=="glmmTMB"){
    print("caution: support for models of class glmmTMB is experimental and embryonic")
    print("and don't worry if it takes some time")
    #n.model.terms=sum(unlist(lapply(fixef(x), length)))+nrow(extract.ranef.from.glmmTB(x))
    pr=residuals(x, type ="response")
    if(x$modelInfo$family$family=="poisson"){
      fitted.var = fitted(x)
    }else{
      #model.terms=attr(terms(x$call$dispformula), "term.labels")#attr(terms(x$call$dispformula), "intercept")
      sigma.f=exp(as.vector(model.matrix(object=x$call$dispformula, data=x$frame)[, names(fixef(x)$disp), drop=F]%*%fixef(x)$disp))
      if(x$modelInfo$family$family=="nbinom2"){
        fitted.var = fitted(x)*(1+fitted(x)/sigma.f)#fitted(x) + fitted(x)^2/sigma(x)
      }else if(x$modelInfo$family$family=="nbinom1"){
        fitted.var = fitted(x)*(1+sigma.f)#fitted(x) + fitted(x)/sigma(x)
      }else if(x$modelInfo$family$family=="beta"){
        xfitted=fitted(x)
        shape1 = xfitted * sigma.f
        shape2 = (1 - xfitted) * sigma.f
        #xfitted(1-xfitted)/(1+sigma(x))#according to the glmmTMB help page for sigma
        fitted.var = shape1*shape2/((shape1+shape2)^2*(shape1+shape2+1))
      }else if(x$modelInfo$family$family=="Gamma"){
        #x.disp=exp(as.vector(model.matrix(object=x$call$dispformula, data=x$frame)%*%log(sigma(x))))
        xx=gamma.par.transf(mean=fitted(x), var=NULL, shape=1/sigma.f, scale=NULL)
        fitted.var = xx$var
        xdf=length(residuals(x))-n.model.terms
      }
    }

    n.model.terms=sum(c(unlist(lapply(fixef(x), length))), nrow(extract.ranef.glmmTMB(x)))
    #xdf=length(pr)-n.model.terms
    sum.dp=sum((pr/sqrt(fitted.var))^2)
    #if(as.numeric(substr(sessionInfo()[["otherPkgs"]][["glmmTMB"]]$Version, start=1, stop=1))>0){
    #sum.dp=sum(residuals(x, type ="pearson")^2)
    #}
  }
  if(!is.null(n.model.terms)){
    xdf=length(pr)-n.model.terms
    #return(data.frame(chisq=sum.dp, df=xdf, P=1-pchisq(sum.dp, xdf), dispersion.parameter=sum.dp/xdf))
    return(as.vector(sum.dp/xdf))
  }else{
    stop("model isn't of any of the currently supported classes (glm, negbin, begareg, zeroinfl, glmerMod, glmmTMB) or error distributions")
  }
}


#!/usr/bin/env R
#
# monophorce.r
#
# author = thomas huber
# mail = thomas.huber@evobio.eu
#
# script to infer the branch lengths and topologies for each taxon within a given snp set - we force monophyly!!!
# input: (1) folder, which has SNP fasta files of replicates
#
# output: nexus files of bionj trees of hamming distances for each taxon within dataset
#

library(ape)
library(phangorn)
library(stringr)

##### constants #####
ARGS = commandArgs(trailingOnly = TRUE)

setwd(ARGS[1])
# setwd('/Users/Thomsn/Desktop/Studium/MEME Programme [current]/Universite de Montpellier [Sem2]/internship_scornavacca_lab/git_lab/phylogenetto/data/real_data/vitis/phylonet/2020_04_vitis_USA_2_summary_20_reps')
all_dirs = list.dirs()
rep_dirs = all_dirs[grep('rep_', all_dirs)]
for (rep_dir in rep_dirs){
  for (s_file in c('/rep_std_asgnmt.fasta', '/rep_new_asgnmt.fasta')){
    sp_file = paste(rep_dir,s_file, sep = '')
    type_an = str_split(s_file, '_')[[1]][2]
    phyo = read.phyDat(sp_file, format = "fasta", type = "DNA")
    splits = sapply(names(phyo), function(xx) strsplit(xx, '[|]'))

    new_labels = c()
    for (spl in splits){
      pasta = strsplit(spl[1], '[.]')
      tax = tolower(paste(pasta[[1]], collapse = ''))

      rasta = strsplit(spl[2], '[_]')
      ind = as.character(str_sub(tolower(paste(rasta[[1]], collapse = ''))[1], -10, -1))
      indl = setNames(tax, ind)
      new_labels = c(new_labels, indl)
    }
    names(phyo) = names(new_labels)
    for (taxon in unique(new_labels)) {
      taxsel = which(new_labels == taxon)
      taxset = subset(phyo, subset = taxsel)
      if (taxon == 'vitisusa2'){
        taxon = 'vitisusa'
      }
      file_name = paste(paste(strsplit(sp_file, '/')[[1]][1:2], collapse = '/'), '/topo_', type_an, '_', taxon, '.nex', sep = '')

      if (length(taxset) > 1) {
        mat = dist.hamming(taxset, ratio = TRUE, exclude = "none")
        trset = bionj(mat)
        trset = multi2di(trset)
        wrong_way = sapply(trset$tip.label, function(x) paste(rev(strsplit(as.character(x), '')[[1]])[1:9][!is.na(rev(strsplit(as.character(x), '')[[1]])[1:9])], collapse = ''))
        rightway = sapply(wrong_way, function(x) paste(rev(strsplit(x, '')[[1]]), collapse = ''))
        trset$tip.label = unname(rightway)
        write.nexus(trset, file = file_name, translate = F)
      } else {
        wrong_way = sapply(names(taxset),
                           function(x) paste(rev(strsplit(as.character(x), '')[[1]])[1:9][!is.na(rev(strsplit(as.character(x), '')[[1]])[1:9])],
                                             collapse = ''))
        rightway = sapply(wrong_way, function(x) paste(rev(strsplit(x, '')[[1]]), collapse = ''))

        single_str = paste('[&R] (', unname(rightway), ');', sep = '')
        write(single_str, file = file_name)
      }
    }
  }
}


vcov.ivmodel<-function(object, ...){
  ivmodel<-object
  vcovmat <- matrix(NA, ncol=2, nrow=0)
  colnames(vcovmat) <- c("k","Endogenous variable")
  if(!is.null(ivmodel$kClass)){
    temp<-cbind(as.numeric(rownames(ivmodel$kClass$ci)),ivmodel$kClass$std.err)
	rownames(temp) <- rep("k-class", nrow(temp))
    rownames(temp)[temp[,1]==0] <- "OLS"
    rownames(temp)[temp[,1]==1] <- "TSLS"
    vcovmat <- rbind(vcovmat, temp)
  }
  if(!is.null(ivmodel$LIML)){
    temp<-cbind(ivmodel$LIML$k, ivmodel$LIML$std.err)
	rownames(temp) <- "LIML"
    vcovmat <- rbind(vcovmat, temp)
  }
  if(!is.null(ivmodel$Fuller)){
    temp<-cbind(ivmodel$Fuller$k, ivmodel$Fuller$std.err)
	rownames(temp) <- "Fuller"
    vcovmat <- rbind(vcovmat, temp)
  }

  vcovmat<-vcovmat[sort(vcovmat[,1], index.return=T)$ix,]
  vcovmat[,"Endogenous variable"] = (vcovmat[,"Endogenous variable"])^2
  return(vcovmat)
}


  landings.aggregate = function( format="default"  ) {

    landings = landings.db()
    # year is year of capture
    # yr is "fishing year" relative to the assessment cycle

    if (format=="default") {
      landings.north = landings[ which(landings$cfa =="cfanorth"), ]
      ln = aggregate(landings.north$landings, list(yr=landings.north$yr), function(x) sum(x, na.rm=T))
      names(ln) = c("yr", "landings")
      ln = factor2number(ln, c("yr", "landings"))
      ln$id = paste(ln$yr, "cfanorth", sep=".")

      landings.south = landings[ which(landings$cfa =="cfasouth") , ]
      ls = aggregate(landings.south$landings, list(yr=landings.south$yr), function(x) sum(x, na.rm=T))
      names(ls) = c("yr", "landings")
      ls = factor2number(ls, c("yr", "landings"))
      ls$id = paste(ls$yr, "cfasouth", sep=".")

      landings.4x = landings[ which(landings$cfa =="cfa4x" ) , ]
      lx = aggregate(landings.4x$landings, list(yr=landings.4x$yr), function(x) sum(x, na.rm=T))
      names(lx) = c("yr", "landings")
      lx = factor2number(lx, c("yr", "landings"))
      lx$id = paste(lx$yr, "cfa4x", sep=".")

      # lx$landings[2:(nrow(lx))] = lx$landings[1:(nrow(lx)-1)]  # offset due to the fishing season being after the Survey

      la = rbind(ln, ls, lx)
      la$yr = NULL
      la$landings.kt = as.numeric(as.character(la$landings))/1000/1000
      return(la)
    }

    if (format=="bugs") {
      regs =  c( "cfanorth", "cfasouth", "cfa4x" )
      landings = landings[ which (landings$cfa %in% regs) , ]
      yrs = sort(unique( landings$yr ) )
      L = tapply( landings$landings, INDEX=landings[,c("yr", "cfa")], FUN=sum, na.rm=T )
      nL = nrow(L)
      L[2:nL,"cfa4x"] = L[1:(nL-1),"cfa4x"]  ## bugs/stn expects terminal year as year for 4x
      cfaall = tapply( landings$landings, INDEX=landings[,c("yr")], FUN=sum, na.rm=T )
      L = cbind( L, cfaall )
      L = L / 1000/1000  # convert to kt
      return (L)
    }

  }


#for matrixizing Solidity files
library(stringr)
solList <- list.files(path = "~/set-protocol-contracts/contracts", pattern = "\\.sol$", recursive = TRUE, full.names = TRUE)
#flatten the Solidity files representing each as a single character vector
flatCode <- lapply(solList, readLines)
#extract all numbers in the code
flatCodeNumbers <- str_extract_all(flatCode,"[0-9]+")
flatCodeNumeric<-as.numeric(flatCodeNumbers)
vector <- unlist(flatCodeNumbers)
numbers <- as.numeric(vector)
sortedNumbers <-  sort.int(numbers)
library(plyr)
countedNumbers <- count(numbers)
library(dplyr)
str_count(flatCode, "withdraw")
#find all functions with "withdraw" in them
str_count(flatCode, "deposit")
#find all functions with "deposit" in them
str_count(flatCode, "transfer")
#find all functions with "transfer" in them
#str_count(flatCode, "token")
#str_count(flatCode, "set")
#for matrixizing Solidity files
library(stringr)
solList <- list.files(path = "~/set-protocol-contracts/contracts", pattern = "\\.sol$", recursive = TRUE, full.names = TRUE)
#flatten the Solidity files representing each as a single character vector
flatCode <- lapply(solList, readLines)
#extract all numbers in the code
flatCodeNumbers <- str_extract_all(flatCode,"[0-9]+")
flatCodeNumeric<-as.numeric(flatCodeNumbers)
vector <- unlist(flatCodeNumbers)
numbers <- as.numeric(vector)
sortedNumbers <-  sort.int(numbers)
#library(plyr)
countedNumbers <- count(numbers)
#library(dplyr)
str_count(flatCode, "withdraw")
#find all functions with "withdraw" in them
str_count(flatCode, "deposit")
#find all functions with "deposit" in them
str_count(flatCode, "transfer")
#find all functions with "transfer" in them
#str_count(flatCode, "token")
#str_count(flatCode, "set")
solList
print("solList")
print(solList)
flatCode <- lapply(solList, readLines)
flatCode
flatCode <- lapply(solList, readLines)
flatCode <- lapply(solList, readLines) warnings()
flatCode <- lapply(solList, readLines)
warnings()
flatCodeNumbers <- str_extract_all(flatCode,"[0-9]+")
flatCodeNumbers
flatCodeNumeric<-as.numeric(flatCodeNumbers)
flatCodeNumeric
#for matrixizing Solidity files
library(stringr)
solList <- list.files(path = "~/set-protocol-contracts/contracts", pattern = "\\.sol$", recursive = TRUE, full.names = TRUE)
#flatten the Solidity files representing each as a single character vector
flatCode <- lapply(solList, readLines)
#extract all numbers in the code
flatCodeNumbers <- str_extract_all(flatCode,"[0-9]+")
library(ggplot2)
library(ggpubr)
theme_set(theme_pubr())
#flatCodeNumeric<-as.numeric(flatCodeNumbers)
vector <- unlist(flatCodeNumbers)
numbers <- as.numeric(vector)
sortedNumbers <-  sort.int(numbers)
#library(plyr)
countedNumbers <- count(numbers)
#library(dplyr)
str_count(flatCode, "withdraw")
#find all functions with "withdraw" in them
str_count(flatCode, "deposit")
#find all functions with "deposit" in them
str_count(flatCode, "transfer")
#find all functions with "transfer" in them
#str_count(flatCode, "token")
#str_count(flatCode, "set")
ggplot(flatCodeNumbers)
hist(flatCodeNumbers)
as.matrix(flatCodeNumbers)
as.numeric(flatCodeNumbers)
as.list(flatCodeNumbers)
apply(flatCodeNumbers, 2, as.numeric)
as.data.frame(flatCodeNumbers)
as.data.frame(lapply((flatCodeNumbers, as.numeric))
as.data.frame(lapply(flatCodeNumbers, as.numeric))
rbindlist(flatCodeNumbers, fill=TRUE)
library(stringi)
rbindlist(flatCodeNumbers, fill=TRUE)
library(data.table)
rbindlist(flatCodeNumbers, fill=TRUE)
as.data.frame(lapply(flatCodeNumbers, as.numeric))
as.data.frame(lapply(flatCodeNumbers, as.numeric))
table(unlist(flatCodeNumeric))
table(unlist(flatCodeNumbers))
lapply(flatCodeNumbers, table)
plot(flatCodeTable)
flatCodeTable<-lapply(flatCodeNumbers, table)
plot(flatCodeTable)
flatCodeTable<-lapply(flatCodeNumbers, table)[76]
flatCodeTable<-lapply(flatCodeNumbers, table)
plot(flatCodeTable)
make.frequency.list(flatCodeTable)
make.table.of.frequencies
library(make.frequency.list)
freq
()
Freq
library(ggplot2)
library(reshape2)
df
df$xvalues = 1:102
flatCodeTable
x <- 1, 2, 3
x <- (1, 2, 3)
x <- print(1, 2, 3)
x
xxx
x
x x x
x
x
x
x
x
x
x
x <- print(1:10)
x <- print([1:10])
x <- print(1:10[1:20])
x <- print(1:50)
plot(x)
plot(flatCodeTable)
typeof(x)
as.integer(flatCodeTable)
as.numeric(flatCodeTable)
flatCodeTable
as.vector(flatCodeTable)
flatCodeTableVector<-as.vector(flatCodeTable)
as.numeric(flatCodeTableVector)
as.table(flatCodeTable)
as.table(flatCodeTable)[102]
print(flatCodeTable)[102]
print(flatCodeTable[102])
as.table(print(flatCodeTable[102]))
as.numeric(print(flatCodeTable[102]))
type.convert(numeric(flatCodeNumbers))
type.convert(numeric(flatCodeTable))
type.convert(numeric(x, flatCodeTable))
type.convert(numeric(flatCodeTable, ...))
type.convert(numeric(flatCodeTable, 1))
type.convert(numeric(flatCodeTable, y))
## Numeric to integer
class(rivers)
x <- type.convert(rivers)
class(x)
output <- matrix(unlist(flatCodeTable), ncol = 10, byrow = TRUE)
do.call(cbind, flatCodeNumbers)
do.call(cbind, flatCodeTable)
do.call(cbind, flatCodeTable[100])
plot(do.call(cbind, flatCodeTable[100]))
plot(do.call(cbind, flatCodeTable[3]))
plot(do.call(cbind, flatCodeNumbers[3]))
plot(do.call(cbind, flatCodeNumbers[3, 4, 5]))
plot(do.call(cbind, flatCodeNumbers))
table(do.call(cbind, flatCodeNumbers))
(do.call(cbind, flatCodeNumbers))
do.call(cbind, flatCodeTable)
do.call(cbind, flatCodeTable[102])
do.call(cbind, flatCodeTable)
do.call(cbind, flatCodeTable[102])
x <- do.call(cbind, flatCodeTable[102])
plot(x)
x <- do.call(cbind, flatCodeTable)
x
plot(x)
x <- do.call(cbind, flatCodeTable[100])
x
x <- do.call(cbind, flatCodeTable[99])
x
plot(x)
table(x)
par()
opar <- par
par (col.lab="red")
plot(x)
hist(x)
par(help)
help(par)
ggplot(x)
ggplot(x = 1)
ggplot(x = hi)
x
plot(d, type="n", main="robbery")
set.seed(1234)
dat <- data.frame(cond = factor(rep(c("A","B"), each=200)),
rating = c(rnorm(200),rnorm(200, mean=.8)))
head(dat)
library(ggplot2)
ggplot(dat, aes(x=rating)) + geom_histogram(binwidth=.5)
ggplot(dat, aes(x=rating)) +
ggplot(dat, aes(x=rating)) +
geom_histogram(binwidth=.5, colour="black", fill="white")
x
ggplot(dat, aes(x=rating)) + geom_density()
ggplot(dat, aes(x=rating))
ggplot(dat, aes(x=[,1]))
library(rattle)
# To generate a density plot.
library(ggplot2)
cities <- c("Canberra", "Darwin", "Melbourne", "Sydney")
ds <- subset(weatherAUS, Location %in% cities & ! is.na(Temp3pm))
p  <- ggplot(ds, aes(Temp3pm, colour=Location, fill=Location))
p  <- p + geom_density(alpha=0.55)
p
library(lattice)
densityplot(~ x)
x
x <- do.call(cbind, flatCodeTable[98])
x
densityplot(~ x)
y <- do.call(cbind, flatCodeTable[99])
z <- do.call(cbind, flatCodeTable[100])
densityplot(~ x)
y
z
densityplot(~ x, y, z)
densityplot(~ x + y + z)
z <- do.call(cbind, flatCodeTable)
densityplot(~ z)
z <- do.call(cbind, flatCodeTable[1, 2])
z <- do.call(cbind, flatCodeTable[1])
z <- do.call(cbind, flatCodeTable[1, 2, 3])
z <- do.call(cbind, flatCodeTable[1, 2, 3, 4])
z <- do.call(cbind, flatCodeTable[100-102])
z <- do.call(cbind, flatCodeTable[100])
z
z <- do.call(cbind, flatCodeTable[3])
z
densityplot(~ z)
z <- do.call(cbind, flatCodeNumbers[3])
z
densityplot(~ z)
z <- do.call(cbind, flatCodeNumbers)
z
densityplot(~ z)
#for matrixizing Solidity files
library(stringr)
solList <- list.files(path = "~/set-protocol-contracts/contracts", pattern = "\\.sol$", recursive = TRUE, full.names = TRUE)
#flatten the Solidity files representing each as a single character vector
flatCode <- lapply(solList, readLines)
#extract all numbers in the code
flatCodeNumbers <- str_extract_all(flatCode,"[0-9]+")
library(ggplot2)
library(ggpubr)
theme_set(theme_pubr())
#total numbers: table(unlist(flatCodeNumbers))
flatCodeTable<-lapply(flatCodeNumbers, table)
#z <- do.call(cbind, flatCodeTable[3])
vector <- unlist(flatCodeNumbers)
numbers <- as.numeric(vector)
sortedNumbers <-  sort.int(numbers)
#library(plyr)
countedNumbers <- count(numbers)
#library(dplyr)
str_count(flatCode, "withdraw")
#find all functions with "withdraw" in them
str_count(flatCode, "deposit")
#find all functions with "deposit" in them
str_count(flatCode, "transfer")
#find all functions with "transfer" in them
#str_count(flatCode, "token")
#str_count(flatCode, "set")
z <- do.call(cbind, flatCodeTable[3])vector
vector
numbers
sortedNumbers
#for matrixizing Solidity files
library(stringr)
solList <- list.files(path = "~/set-protocol-contracts/contracts", pattern = "\\.sol$", recursive = TRUE, full.names = TRUE)
#flatten the Solidity files representing each as a single character vector
flatCode <- lapply(solList, readLines)
#extract all numbers in the code
flatCodeNumbers <- str_extract_all(flatCode,"[0-9]+")
#flatCodeTable<-lapply(flatCodeNumbers, table)
#z <- do.call(cbind, flatCodeTable[3])
vector <- unlist(flatCodeNumbers)
numbers <- as.numeric(vector)
sortedNumbers <-  sort.int(numbers)
#library(plyr)
countedNumbers <- count(numbers)
#library(dplyr)
str_count(flatCode, "withdraw")
#find all functions with "withdraw" in them
str_count(flatCode, "deposit")
#find all functions with "deposit" in them
str_count(flatCode, "transfer")
#find all functions with "transfer" in them
#str_count(flatCode, "token")
#str_count(flatCode, "set")
#for matrixizing Solidity files
library(stringr)
solList <- list.files(path = "~/set-protocol-contracts/contracts", pattern = "\\.sol$", recursive = TRUE, full.names = TRUE)
#flatten the Solidity files representing each as a single character vector
flatCode <- lapply(solList, readLines)
#extract all numbers in the code
flatCodeNumbers <- str_extract_all(flatCode,"[0-9]+")
#flatCodeTable<-lapply(flatCodeNumbers, table)
#z <- do.call(cbind, flatCodeTable[3])
vector <- unlist(flatCodeNumbers)
numbers <- as.numeric(vector)
sortedNumbers <-  sort.int(numbers)
#library(plyr)
countedNumbers <- count(numbers)
#library(dplyr)
str_count(flatCode, "withdraw")
#find all functions with "withdraw" in them
str_count(flatCode, "deposit")
#find all functions with "deposit" in them
str_count(flatCode, "transfer")
#find all functions with "transfer" in them
sortedNumbers
countedNumbers
#for matrixizing Solidity files
library(stringr)
solList <- list.files(path = "~/set-protocol-contracts/contracts", pattern = "\\.sol$", recursive = TRUE, full.names = TRUE)
#flatten the Solidity files representing each as a single character vector
flatCode <- lapply(solList, readLines)
#extract all numbers in the code
flatCodeNumbers <- str_extract_all(flatCode,"[0-9]+")
#flatCodeTable<-lapply(flatCodeNumbers, table)
#z <- do.call(cbind, flatCodeTable[3])
vector <- unlist(flatCodeNumbers)
numbers <- as.numeric(vector)
sortedNumbers <-  sort.int(numbers)
library(plyr)
countedNumbers <- count(numbers)
library(dplyr)
str_count(flatCode, "withdraw")
#find all functions with "withdraw" in them
str_count(flatCode, "deposit")
#find all functions with "deposit" in them
str_count(flatCode, "transfer")
#find all functions with "transfer" in them
countedNumbers
count
count(numbers)
numbers
typeof(flatCode)
flatCodeNumbers
vector
plot vector
plot(vector)
graph(vector)
chart(vector)
frequency(vector)
par(vector)
boxplot(vector)
codeNumericVector <- as.numeric(vector)
typeof(codeNumericVector)
codeNumericVector
plot(codeNumericVector)
boxplot(codeNumericVector)
frequency(codeNumericVector)
x<-codeNumericVector seq(-5, 5, 0.1)
x
plot(x)
plot(codeNumericVector)
plot(x, sin(x))
plot(x, sin(5))
plot(x, sin(y))
as.data.frame(codeNumericVector)
dataFrameVector<-as.data.frame(codeNumericVector)
plot(dataFrameVector)
plot(dataFrameVector)
write.csv(dataFrameVector, 'dataFrameVector.csv')
colnames(dataFrameVector[1]<-"number")
write.csv(dataFrameVector, 'dataFrameVector.csv')
dataFrameVector<-as.data.frame(codeNumericVector)
write.csv(dataFrameVector, 'dataFrameVector.csv')
dataFrameVector<-as.data.frame(codeNumericVector)
dataFrameVector<-c("number", "value")
write.csv(dataFrameVector, 'dataFrameVector.csv')
write.csv(dataFrameVector, 'dataFrameVector.csv')
dataFrameVector<-as.data.frame(codeNumericVector)
names(dataFrameVector)[1]<-"hi"
write.csv(dataFrameVector, 'dataFrameVector.csv')
names(dataFrameVector)[0]<-"hi"
write.csv(dataFrameVector, 'dataFrameVector.csv')
names(dataFrameVector)<-"hi"
write.csv(dataFrameVector, 'dataFrameVector.csv')
names(dataFrameVector)[5]<-"hi"
names(dataFrameVector)[2]<-"hi"
names(dataFrameVector)[1]<-"hi"
write.csv(dataFrameVector, 'dataFrameVector.csv')
dataFrameVector<-as.data.frame(codeNumericVector)
write.csv(dataFrameVector, 'dataFrameVector.csv')
as.numeric(codeNumericVector)
dataNumericVector<-as.numeric(codeNumericVector)
write.csv(dataNumericVector, 'dataFrameVector.csv')
plot(dataNumericVector)
cat(dataNumericVector)
dataNumericList<-cat(dataNumericVector)
dataNumericList
dataNumericList <- cat(dataNumericVector)
frequency(cat(dataNumericVector))
data.table(dataNumericVector)
dataNumericTable<-data.table(dataNumericVector)
dataNumericTable
plot(dataNumericTable)
data(dataNumericTable)
cat(dataNumericTable)
View(dataNumericTable)
names(data)
names(dataNumericTable)
table(dataNumericVector$table)
freq(dataNumericVector)
Freq(dataNumericVector)
dataNumericVector
dataNumericList
dataNumericTable
dataNumericTable[names(dataNumericTable)==2556]
sum(dataNumericVector == x)
dataNumericVector
plot(sortedNumbers)
flattenedCodeDf<-as.data.frame(sortedNumbers)
flattenedCodeDf
plot(flattenedCodeDf)
unlistedNumbers<-unlist(flatCodeNumbers)
sortNumbers<-sort(unlistedNumbers)
dfNumbers<-as.data.frame(sortNumbers)
plot(dfNumbers)
dfNumbers
sort(dfNumbers, decreasing = TRUE)
sort(dfNumbers, decreasing = FALSE)
sort(dfNumbers)
vector <- unlist(flatCodeNumbers)
numbers <- as.numeric(vector)
sortedNumbers <-  sort.int(numbers)
sortedNumbers
plot(sortedNumbers)
boxplot(sortedNumbers)
options(max.print=1000000)
boxplot(sortedNumbers)
sortedNumbers
library(stringr)
library(tokenizers)
library(tidyverse)
list.of.packages <- c("ggplot2", "Rcpp", "stringr", "tokenizers", "tidyverse")
new.packages <- list.of.packages[!(list.of.packages %in% installed.packages()[,"Package"])]
if(length(new.packages)) install.packages(new.packages)
sentencesList <- tokenize_sentences(solList)
sentencesList
sentencesList <- tokenize_sentences(flatCode)
flatCode
sentencesList <- tokenize_regex(flatCode)
sentencesList <- tokenize_lines(flatCode)
flatVector <- flatCode
flatVector <- as.vector(flatCode)
flatVector
sentencesList <- tokenize_lines(flatCode)
sentencesList <- tokenize_lines(flatVector)
flatList <- as.list(flatCode)
flatList
sentencesList <- tokenize_lines(flatList)
flatCharacter <- as.character(flatCode)
sentencesList <- tokenize_lines(flatCharacter)
sentencesList
sentencesList <- tokenize_sentences(flatCharacter)
sentencesList
sentencesList <- tokenize_lines(flatCharacter)
length(sentencesList)
length(flatCharacter)
length(flatCode)
length(sentencesList[[1]])
length(sentencesList[[2]])
list.of.packages <- c("ggplot2", "Rcpp", "stringr", "tokenizers", "tidyverse", "plyr", "dplyr")
new.packages <- list.of.packages[!(list.of.packages %in% installed.packages()[,"Package"])]
if(length(new.packages)) install.packages(new.packages)
length(sentencesList[[2]])
savehistory("~/scripts/R/hist2.r")


#--------------------------------------------
# scCountProc
#--------------------------------------------
#' Reading cellranger processed 10x data as a seurat object.
#'
#' Read the cell ranger processed 10x data, assign a sample name, normalize, and find veriable genes
#'
#' @param data_path path of ceranger preocessed result (one upper from "outs" directory)
#' @param sample_name charector a sample name
#' @param normalization logical, if TRUE, normalization is performed
#' @param nfetures integer, number of variable genes to be found
#'
#' @importFrom Seurat Read10X CreateSeuratObject RenameCells NormalizeData FindVariableFeatures
#'
#' @return a seurat object
#'
#' @keywords seurat 10x
#' @export

scCountProc <- function(data_path, sample_name = sample_name, normalization = FALSE, nfeatures =2000){
    ## Count
    library(Seurat)
    data.counts <- Read10X(data.dir = paste0(data_path, "/outs/filtered_feature_bc_matrix/"))
    data <- CreateSeuratObject(counts = data.counts)    # conversion to Seurat object
    data$sample <- sample_name    #サンプル名の付加
    data <- RenameCells(object=data, add.cell.id = sample_name)
    if (normalization == TRUE){
        data <- NormalizeData(object = data)    #正規化
    }
    data <- FindVariableFeatures(object = data, selection.method = "vst", nfeatures = nfeatures)    #変動の大きい遺伝子の抽出
    return(data)
}

#--------------------------------------------
# QC
#--------------------------------------------
#' QC for 10x data
#'
#' this function output ggplot object to vidualize nFeature_RNA, nCount_RNA, and percent of mitochondria genes
#'
#' @param data a Seurat objects
#'
#' @importFrom Seurat PercentageFeatureSet VlnPlot FeatureScatter CombinePlots
#' @importFrom ggplot2 ggsave
#'
#' @return a list of data of percent.mt and ggplot objects
#'
#' @keywords seurat 10x
#' @export

QC <- function(data){
    data[["percent.mt"]] <- PercentageFeatureSet(object = data, pattern = "^mt-")
    vp <- VlnPlot(data, features = c("nFeature_RNA", "nCount_RNA", "percent.mt"), ncol = 3)
    sp <- CombinePlots(plots = list(
        FeatureScatter(data, feature1 = "nCount_RNA", feature2 = "percent.mt"),
        FeatureScatter(data, feature1 = "nCount_RNA", feature2 = "nFeature_RNA")
    ))
    out <- list(percent.mt = data[["percent.mt"]], violin_plot = vp, scatter_plot = sp)
    return(out)
}

#--------------------------------------------
# ccReg
#--------------------------------------------
#' Cell cycle regression
#'
#' this function regress the effect of cell cycle
#'
#' @param data a Seurat object
#'
#' @importFrom Seurat PercentageFeatureSet VlnPlot FeatureScatter CombinePlots
#' @importFrom ggplot2 ggsave
#'
#' @return a list of data of percent.mt and ggplot objects
#'
#' @keywords seurat 10x
#' @export

ccReg <- function(data){
    #load cell cycle markers(Tirosh et al, 2015)
    s.genes <- sapply(cc.genes.updated.2019$s.genes, function(x){ paste0(substr(x, 1, 1), tolower(substr(x, 2, nchar(x)))) })
    g2m.genes <- sapply(cc.genes.updated.2019$g2m.genes, function(x){ paste0(substr(x, 1, 1), tolower(substr(x, 2, nchar(x)))) })

    #Initialization step
    cat("Initialization step running...\n")
    data <- ScaleData(object = data, verbose = FALSE)
    data <- RunPCA(object = data, npcs = 30, verbose = FALSE)

    #cell-cycle scoring
    cat("cell-cycle scoring running...\n")
    data <- CellCycleScoring(data, s.features = s.genes, g2m.features = g2m.genes, set.ident = TRUE)

    #PCA before regression
    cat("PCA before regression...\n")
    data <- RunPCA(data, features = c(s.genes, g2m.genes))

    pca1 <- DimPlot(data)
    ggsave(pca1, file="ccReg_results/CC.pca.pdf")

    #Cell-Cycle regression
    cat("Cell Cycle Regression running...\n")
    data$CC.Difference <- data$S.Score - data$G2M.Score
    data <- ScaleData(data, vars.to.regress = c("S.Score", "G2M.Score"), features = rownames(data))
    # data <- ScaleData(data, vars.to.regress = "CC.Difference", features = rownames(data))

    #PCA after regression
    cat("PCA after regression...\n")
    data <- RunPCA(data, features = VariableFeatures(data), nfeatures.print = 10)
    data <- RunPCA(data, features = c(s.genes, g2m.genes))

    pca2 <- DimPlot(data)
    ggsave(pca2, file="ccReg_results/reg_CC.pca.pdf")

    cat("cell-cycle regression succeeded! \n")
    cat("all output files are stored in ccReg_results \n")
    return(data)
}

#--------------------------------------------
# subsetUmapClust
#--------------------------------------------
#' Extract subset and do clustering
#'
#' Extract the subsets from a seurat object and do scaling, and PCA, UMAP and tSNE dimensionality reductions
#'
#' @param data A seurat object
#' @param subset.name Parameter to subset on. Eg, the name of a gene, PC_1, a column name in object@meta.data, etc. Any argument that can be retreived using FetchData
#' @param subset.value Returns cells with the subset name equal to this value
#' @param resolution resolution for clustering
#'
#' @importFrom Seurat Read10X CreateSeuratObject RenameCells NormalizeData FindVariableFeatures
#'
#' @return a seurat object
#'
#' @keywords seurat 10x
#' @export
#'
subsetUmapClust <- function(data,  subset.name = "seurat_clusters", subset.value, npcs = 30, dims = 1:30, resolution = 0.6){
    if(length(subset.value) == 1){
        data.subset <- eval(parse(text=paste0("subset(data, subset = ", subset.name, " == ", subset.value, ")" )))
    }else{
        multisub <- paste0("subset(data, ",
                                paste(paste(subset.name, paste0("'",subset.value,"'"), sep="=="), collapse = "|"),
                                ")"
        )
        data.subset <- eval(parse(text=multisub))
    }
    data.subset <- RunPCA(object = data.subset, npcs = npcs, verbose = FALSE)
    data.subset <- RunUMAP(object = data.subset, reduction = "pca", dims = dims)
    data.subset <- FindNeighbors(object = data.subset, dims = dims)
    data.subset <- FindClusters(object = data.subset, reduction.type = "umap", resolution =  resolution)
    return(data.subset)
}

#--------------------------------------------
# gg_color_hue
#--------------------------------------------
#' Get the Default ggplot2 Color Palette
#'
#' \code{gg_color_hue} returns the default ggplot color palette for a given
#' number of colors
#'
#' @author John Colby \url{http://stackoverflow.com/questions/8197559/emulate-ggplot2-default-color-palette}
#
#' @param n Number of Coolors
#'
#' @export

gg_color_hue <- function(n){
    hues = seq(15, 375, length = n + 1)
    hcl(h = hues, l = 65, c = 100)[1:n]
}

#--------------------------------------------
# Deg
#--------------------------------------------
#' compute defferentially expressed genes and output as a text file
#'
#' compute defferentially expressed genes and output as a text file
#'
#' @param seurat_object a seurat object
#' @param control control for the comarison. a element of the comp key.
#' @param treatment comparison for the comarison. a element of the comp key.
#' @param outID ID for output files

#'
#' @importFrom Seurat FindMarkers
#'
#' @return a dataframe of differentially expressed genes
#'
#' @keywords DEG
#' @export

Deg <- function(seurat_object, control, treatment, outID,...){
    diff_genes <- FindMarkers(object=seurat_object, ident.1 = treatment, ident.2 = control,...)

    out_file <- paste0(outID, "_diff_genes_", treatment, ".", control, ".txt")
    write.table(diff_genes, file=out_file, sep="\t", quote=FALSE)

    return(diff_genes)
}

#--------------------------------------------
# averageDegMA
#--------------------------------------------
#' plot a MA-plot for two average gene expression data sets
#'
#'  plot a MA-plot for two average gene expression data sets.
#'
#' @param seurat_object a seurat object
#' @param cluster_key key for categorization. a header of meta.data of the seurat object
#' @param clust a charactor of cluster
#' @param comp_key key for comparison. a header of meta.data of the seurat object
#' @param control control for the comarison. a element of the comp key.
#' @param treatment comparison for the comarison. a element of the comp key.
#' @param sig_genes = a vector of significant gene names. Points correspondng to these genes are painted as red.
#' @param genes_to_label a vector of gene symbols to be labeled.
#' @param title a charactor. title of the MA-plot.

#'
#' @importFrom Seurat Idents RotatedAxis DotPlot AverageExpression LabelPoints
#' @importFrom ggplot2 element_blank theme ggtitle xlim ylim geom_point ggplot
#' @importFrom cowplot plot_grid
#' @importFrom dplyr mutate %>%
#'
#' @return a pdf file of MA-plot
#'
#' @keywords DEG, MA-plot
#' @export

averageDegMA <- function(seurat_object,
    cluster_key = "seurat_clusters",
    clust,
    comp_key,
    control,
    treatment,
    sig_genes = NULL,
    genes_to_label = NULL,
    title = NULL
    ){
    library(ggplot2)
    library(cowplot)
    message("extracting a subet data...")
    data_subset <- eval(parse(text=paste0("subset(seurat_object, subset = ", cluster_key, " == clust)")))
    Idents(data_subset) <- eval(parse(text=paste0("data_subset@meta.data$", comp_key)))

    #at least one sample does not have any cells, skip the comparison
    sample_included <- eval(parse(text=paste0(
        "all(c(any(data_subset@meta.data$",
        comp_key,
        " == treatment",
        "), any(data_subset@meta.data$",
        comp_key,
        " == control",
        ")))"
    )))

    if(sample_included == FALSE){
        warning("The cluster does not have the cell.", immediate. = TRUE)
        p1 <- NULL
    }else{
        #create averaged data model
        message("creating the averaged data model...")
        avg.data_subset <- log1p(AverageExpression(data_subset, verbose = FALSE)$RNA)
        avg.data_subset <- as.data.frame(apply(avg.data_subset, 2, function(x){replace(x, which(x==0), 1e-06)}))

        R <- round(cor(avg.data_subset[,treatment],avg.data_subset[,control]), digits = 2)
        nsig <- length(sig_genes)

        M <- eval(parse(text=paste0("avg.data_subset$", treatment, "- avg.data_subset$", control)))
        A <- apply(avg.data_subset[,c(treatment, control)], 1, mean)
        MA <- data.frame(M,A)

        sigs <- factor(rep("Insignificant", nrow(MA)), levels = c("Insignificant", "Significant"))
        if(!is.null(sig_genes)){
            sigs <- replace(sigs, which(rownames(MA) %in% sig_genes), "Significant")
        }
        MA <- cbind(MA, sigs)
        MA <- MA[sort.list(MA$sigs),]

        #plot
        message("plotting the MA-Plot...")
        p1 <- ggplot(MA, aes(x = A, y = M, color=sigs))
        p1 <- p1 + geom_point(size=1.80, alpha = 0.4)
        p1 <- p1 + scale_color_manual(values = c(Insignificant="gray40", Significant="red"))
        if(is.null(title)){
            p1 <- p1 + ggtitle(paste0("Cluster ", clust, "_", control, " vs. ", treatment))
        }else{
            p1 <- p1 + ggtitle(title)
        }
        p1 <- p1 + geom_hline(yintercept=0, linetype="dashed", colour="gray30", size=1)
        p1 <- p1 + theme(panel.grid.major = element_blank(),
                panel.grid.minor = element_blank(),
                panel.background = element_blank(),
                panel.border = element_rect(colour="gray1", fill=NA),
                axis.text = element_text(size=18),
				axis.title = element_text(size=18),
				plot.title = element_text(size=18, face="bold", hjust = 0.5),
				aspect.ratio = 1,
				legend.text = element_text(size =18),
				legend.title = element_blank(),
                legend.key = element_blank(),
                legend.position = c(.18,.92),
                legend.background = element_rect(fill = "gray97")
                )
        if(length(genes_to_label) !=0){
            p1 <- LabelPoints(plot = p1, points = genes_to_label, repel = TRUE, colour="black", size=5)
        }
        p1 <- p1 + annotate("text", size = 6, x=Inf,y=-Inf, hjust=1.26,vjust=-3.5, label = paste0("R = ", R))
        p1 <- p1 + annotate("text", size = 6, x=Inf,y=-Inf, hjust=1.1,vjust=-1.5, label = paste0("Number of DEGs: ",as.character(nsig)) , colour="red")

        plot(p1)

        plot_file=paste0("Cluster ", clust, "_", control, ".", treatment, "_MAPlot.pdf")
        ggsave(file=plot_file, plot=p1, width=7, height=7)

        message("Done\n")
    }
    return(p1)
}

#--------------------------------------------
# multiVlnPlot
#--------------------------------------------
#' plot a integrated multiple violin plots from seurat object
#'
#' plot a integrated multiple violin plots from seurat object. wrapper of VlnPlot
#'
#' @param object Seurat object
#' @param features Features to plot (gene expression, metrics, PC scores, anything that can be retreived by FetchData)
#' @param pt.size Point size for geom_violin
#' @param log plot the feature axis on log scale
#' @param title a charactor. title of the plot
#' @param out_file a charactor. file name of exprted plot

#'
#' @importFrom Seurat VlnPlot
#' @importFrom ggplot2 scale_y_continuous scale_fill_discrete ylab theme element_blank element_text element_rect get_legend guides guide_legend ggdraw draw_label
#' @importFrom cowplot plot_grid
#'
#' @return a pdf file of violon plots
#'
#' @keywords VlnPlot, Violin plot
#' @export

multiVlnPlot <- function(object, features, pt.size = 0, log = FALSE, title = NULL, out_file = NULL, ...){
    library(Seurat)
    library(ggplot2)
    library(cowplot)

    scaleFUN <- function(x) sprintf("%.1f", x)

    gplot.list <- list()
    for(i in 1:length(features)){
        vg <- VlnPlot(object = object, features = features[i], pt.size = pt.size, log = log,...)
        vg <- vg + scale_y_continuous(labels=scaleFUN)
        vg <- vg + scale_fill_discrete(name="Cluster")
        vg <- vg + ylab(features[i])
        vg <- vg + theme(legend.position = 'none',
                        axis.title.x = element_blank(),
                        axis.title.y = element_text(face="bold", vjust = 0.5),
                        plot.title = element_blank(),
                        axis.text.x = element_blank(),
                        panel.border = element_rect(colour = "gray1", fill = NA),
                        )
        gplot.list <- c(gplot.list, list(vg))
    }

    legend <- get_legend(
        gplot.list[[1]] +
            theme(legend.position = "bottom", legend.justification="center") +
            guides(fill = guide_legend(nrow = 1, label.position = "bottom"))
    )

    # now add the title
    if(!is.null(title)){
        gtitle <- ggdraw() +
            draw_label(
                title,
                fontface = 'bold',
                x = 0.5,
                hjust = 0.5
            )
    }else gtitle <- NULL

    gplot_all <- plot_grid(plotlist = gplot.list, ncol=1, align = "v", axis = "tblr")
    gplot_all <- plot_grid(
        gtitle,
        gplot_all,
        legend,
        nrow = 3,
        rel_heights = c(0.5 / (length(features) + 0.5), length(features) / (length(features) + 0.5), 0.5 / (length(features) + 0.5))
        )

    plot(gplot_all)

    if (!is.null(out_file)){
        ggsave(file=out_file, plot=gplot_all, width=14, height=length(features) * 1.3 +0.5)
    }
    return (gplot_all)
}


source("load_data.R")
source("utils.R")

# pick out date, label, latitude and longitude
afg_ts <- data.frame(
    date = as.Date(afg$DateOccurred),
    year = format(as.Date(afg$DateOccurred),"%y"),
    lat = afg$Latitude,
    lon = afg$Longitude,
    type = factor(apply(cbind(afg$AttackOn,afg$Type),1,function(row)paste(row[1],row[2],sep="_")))
)

# rough lat/lon limits of Afghanistan:
max_lat = max(afg.poly$lat)
min_lat = min(afg.poly$lat)
max_lon = max(afg.poly$lon)
min_lon = min(afg.poly$lon)

# filter out events not in Afghanistan (?!)
to_keep <- (afg_ts$lat > min_lat) & (afg_ts$lat < max_lat) & (afg_ts$lon > min_lon) & (afg_ts$lon < max_lon)
afg_ts <- afg_ts[to_keep,]

# filter out NA events
to_throw <- is.na(afg_ts$type)
afg_ts <- afg_ts[!to_throw,]
afg_ts$type = factor(as.character(afg_ts$type))

png("images/events_by_type.png",width=1200,height=750,res=100)
p <- ggplot(afg_ts,aes(y=lat,x=lon)) + geom_point(aes(color=type,alpha=0.4))+facet_wrap(~year)
print(p)
dev.off()

# New plot with regional map of Afghanistan overlayed on attack data
png("images/events_by_year_map.png",width=1200,height=750,res=100)
year.map<-ggplot(subset(afg_ts,type=="ENEMY_Explosive Hazard"),aes(y=lat,x=lon))+geom_point(aes(colour="darkblue",alpha=0.45,size=1))+facet_wrap(~year)
year.map<-year.map+geom_path(data=intl.poly,aes(y=lat,x=long,group=group))+
    scale_x_continuous(breaks=NA)+scale_y_continuous(breaks=NA)+scale_alpha(legend=FALSE)+scale_colour_manual(values=c("darkblue"="darkblue"),legend=FALSE)+scale_size_continuous(legend=FALSE)+
    opts(title="Wikileaks Geospatial Enemy Explosize Hazard Data by Year",panel.grid.major=theme_blank())+
    theme_bw()+ylab("Latitude")+xlab("Longitude")+coord_map()
print(year.map)
dev.off()

setwd("images")
type.dir<-"by_type"
dir.create(type.dir)
attack.types<-levels(afg_ts$type)
point.cols<-c(brewer.pal(8,"Set1"),brewer.pal(8,"Set2"))
col.index<-1

for(t in attack.types) {
    type.subset<-subset(afg_ts,afg_ts$type==t)
    type.subset<-data.frame(type.subset,row.names=1:nrow(type.subset))
    png(paste(type.dir,"/",t,"_by_year.png",sep=""),width=1200,height=750,res=100)
    t.map<-ggplot(type.subset,aes(y=lat,x=lon))+geom_point(aes(colour="c",alpha=0.4))+facet_wrap(~year)
    t.map<-t.map+geom_path(data=afg.poly,aes(y=lat,x=long,group=group,alpha=0.4))
    t.map<-t.map+scale_x_continuous(breaks=NA)+scale_y_continuous(breaks=NA)+scale_alpha(legend=FALSE)
    t.map<-t.map+scale_colour_manual(values=c("c"=point.cols[col.index]),name="",breaks="c",labels=t)
    t.map<-t.map+opts(title=paste("Wikileaks Geospatial Data by for ",t,"\nby Year with District Boundaries",sep=""),panel.grid.major=theme_blank())
    t.map<-t.map+ylab("Latitude")+xlab("Longitude")+theme_bw()+coord_map()
    print(t.map)
    dev.off()
    col.index<-col.index+1
}
setwd("..")


library(ggplot2)
library(GenomicRanges)

load("/dcl01/lieber/ajaffe/lab/brain-epigenomics/rdas/DMR/DMR_objects.rda", verbose = T)
load("/dcl01/lieber/ajaffe/lab/brain-epigenomics/rdas/CREs/PMDs_100kb_noGaps.rda", verbose = T)
load("/dcl01/lieber/ajaffe/lab/brain-epigenomics/rdas/CREs/UMRs_LMRs_annotated.rda", verbose = T)
load("/dcl01/lieber/ajaffe/lab/brain-epigenomics/rdas/CREs/dmvs_annotated.rda", verbose = T)
load("/dcl01/lieber/ajaffe/lab/brain-epigenomics/bumphunting/rda/limma_Neuron_CpGs_minCov_3_ageInfo_dmrs.Rdata")

## Prepare DMRs

dmrs = split(dmrs, dmrs$k6cluster_label)
oo = lapply(dmrs, function(x) findOverlaps(x, makeGRangesFromDataFrame(DMR$Interaction)))
dmrs = c(lapply(DMR[which(names(DMR) %in% c("CellType","Age"))], function(x) x[which(x$sig=="FWER < 0.05"),]), lapply(oo, function(x) DMR$Interaction[subjectHits(x),]))
names(dmrs) = c("CellType","Age","Gr1","Gr2","Gr3","Gr4","Gr5","Gr6")
rdmrs = lapply(dmrs, function(x) reduce(makeGRangesFromDataFrame(x)))
elementNROWS(rdmrs)
#CellType      Age      Gr1      Gr2      Gr3      Gr4      Gr5      Gr6
#   11179      129      567      423      362       96      170      560

## Prepare methylation features

methfeatures = list(UMR = lapply(uDMR, makeGRangesFromDataFrame, keep=T), LMR = lapply(lDMR, makeGRangesFromDataFrame, keep=T),
                    PMD = lapply(total.nogaps[-grep("GSM", names(total.nogaps))], function(x) x[which(x$type=="PMD")]),
                    DMV = lapply(dmvDMR, makeGRangesFromDataFrame, keep=T))
methfeatures$UMR = mapply(function(u,d) u[!u %in% d],  methfeatures$UMR, methfeatures$DMV, SIMPLIFY = F) # because DMV is a special case of UMR, remove DMVs from UMR list

rmethfeatures = lapply(methfeatures, function(m) lapply(m, reduce))
do.call(cbind, lapply(rmethfeatures, elementNROWS))

## Count the hits for each type of DMR for each person, for each

oo = lapply(rdmrs, function(d) lapply(rmethfeatures, function(m) lapply(m, function(x) findOverlaps(makeGRangesFromDataFrame(d),x))))

df = lapply(oo, function(d) lapply(d, function(m) do.call(rbind, Map(cbind, lapply(m, function(i)
  data.frame(dmrHits = length(unique(queryHits(i))), featureHits = length(unique(subjectHits(i))))), id = as.list(names(m))))))
df = lapply(df, function(d) Map(cbind, d, num.features = lapply(rmethfeatures, elementNROWS),
                                num.bases = lapply(rmethfeatures, function(m) unlist(lapply(m, function(i) sum(as.numeric(width(i))))))))
df = lapply(df, function(d) do.call(rbind, Map(cbind, d, feature = as.list(names(d)))))
df = do.call(rbind, Map(cbind, df, group = as.list(names(df)), num.dmrs = as.list(elementNROWS(rdmrs))))

df$perc.dmrHits = round(df$dmrHits / df$num.dmrs * 100, 1)
df$perc.dmrHits.transf = df$perc.dmrHits / df$num.bases * 1000000
df$perc.featureHits = round(df$featureHits / df$num.features * 100, 1)
df$group = gsub("CellType","Cell Type (11179)", df$group)
df$group = gsub("Age","Age (129)", df$group)
df$group = gsub("Gr1","1:G-N+ (567)", df$group)
df$group = gsub("Gr2","2:G0N+ (423)", df$group)
df$group = gsub("Gr3","3:G0N- (362)", df$group)
df$group = gsub("Gr4","4:G+N0 (96)", df$group)
df$group = gsub("Gr5","5:G+N- (170)", df$group)
df$group = gsub("Gr6","6:G-N0 (560)", df$group)
df$celltype = ifelse(df$id %in% pd$Data.ID, pd[match(df$id, pd$Data.ID),"Cell.Type"], "Prenatal")
df$age = pd[match(df$id, pd$Data.ID),"Age"]
df$feature = factor(df$feature, levels = c("UMR","LMR","DMV","PMD"))
df$group = factor(df$group, levels = c("Cell Type (11179)","Age (129)","1:G-N+ (567)","2:G0N+ (423)","3:G0N- (362)","4:G+N0 (96)","5:G+N- (170)","6:G-N0 (560)"))
df$celltype = factor(df$celltype, levels = c("Prenatal","Glia","Neuron"))

write.csv(df, quote=F,file = "/dcl01/lieber/ajaffe/lab/brain-epigenomics/rdas/CREs/methFeatures_Overlap_withDMRs.csv")

df = read.csv("/dcl01/lieber/ajaffe/lab/brain-epigenomics/rdas/CREs/methFeatures_Overlap_withDMRs.csv")
df$feature = factor(df$feature, levels = c("UMR","LMR","DMV","PMD"))

pdf("/dcl01/lieber/ajaffe/lab/brain-epigenomics/CREs/figures/methFeatures_Overlap_withDMRs.pdf", width = 12, height = 8)
ggplot(df[which(df$group %in% c("Cell Type (11179)","Age (129)")),], aes(x = celltype, y = perc.dmrHits)) + geom_boxplot() +
  labs(fill="") + facet_grid(group ~ feature) +
  ylab("Percent") +
  xlab("") +
  ggtitle("Percent DMRs Overlapped by Methylation Features") +
  theme(title = element_text(size = 20)) +
  theme(text = element_text(size = 20), legend.title=element_blank()) + theme(legend.position="bottom")
ggplot(df[-which(df$group %in% c("Cell Type (11179)","Age (129)")),], aes(x = celltype, y = perc.dmrHits, fill = group)) + geom_boxplot() +
  labs(fill="") + facet_grid(feature ~ group) +
  scale_fill_brewer(8, palette="Dark2") +
  ylab("Percent") + xlab("") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
  ggtitle("Percent cdDMRs Overlapped by Methylation Features") +
  theme(title = element_text(size = 20)) +
  theme(text = element_text(size = 20), legend.title=element_blank()) + theme(legend.position="bottom")
w = df[-which(df$group %in% c("Cell Type (11179)","Age (129)")),]
ggplot(w[which(w$celltype!="Prenatal"),], aes(x = age, y = perc.dmrHits, colour = celltype)) + geom_point() +
  geom_smooth(method="loess", se=T, fullrange=TRUE) + scale_colour_brewer(8, palette="Dark2") +
  labs(fill="") + facet_grid(feature ~ group) +
  ylab("Percent") + xlab("Age (Years)") +
  ggtitle("Percent cdDMRs Overlapped by Methylation Features") +
  theme(title = element_text(size = 20)) +
  theme(text = element_text(size = 20), legend.title=element_blank()) + theme(legend.position="bottom")
ggplot(w[which(w$celltype!="Prenatal"),], aes(x = age, y = perc.dmrHits, colour = celltype)) + geom_point() +
  geom_smooth(method=lm, se=T, fullrange=TRUE) + scale_colour_brewer(8, palette="Dark2") +
  labs(fill="") + facet_grid(feature ~ group) +
  ylab("Percent") + xlab("Age (Years)") +
  ggtitle("Percent cdDMRs Overlapped by Methylation Features") +
  theme(title = element_text(size = 20)) +
  theme(text = element_text(size = 20), legend.title=element_blank()) + theme(legend.position="bottom")
ggplot(df[-which(df$group %in% c("Cell Type (11179)","Age (129)")),], aes(x = celltype, y = perc.dmrHits.transf, fill = group)) + geom_boxplot() +
  labs(fill="") + facet_grid(feature ~ group) +
  scale_fill_brewer(8, palette="Dark2") +
  ylab("Percent / Mb") + xlab("") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
  ggtitle("Percent cdDMRs Overlapped by Methylation Features") +
  theme(title = element_text(size = 20)) +
  theme(text = element_text(size = 20), legend.title=element_blank()) + theme(legend.position="bottom")
w = df[-which(df$group %in% c("Cell Type (11179)","Age (129)")),]
ggplot(w[which(w$celltype!="Prenatal"),], aes(x = age, y = perc.dmrHits.transf, colour = celltype)) + geom_point() +
  geom_smooth(method="loess", se=T, fullrange=TRUE) + scale_colour_brewer(8, palette="Dark2") +
  labs(fill="") + facet_grid(feature ~ group) +
  ylab("Percent / Mb") + xlab("Age (Years)") +
  ggtitle("Percent cdDMRs Overlapped by Methylation Features") +
  theme(title = element_text(size = 20)) +
  theme(text = element_text(size = 20), legend.title=element_blank()) + theme(legend.position="bottom")
ggplot(w[which(w$celltype!="Prenatal"),], aes(x = age, y = perc.dmrHits.transf, colour = celltype)) + geom_point() +
  geom_smooth(method=lm, se=T, fullrange=TRUE) + scale_colour_brewer(8, palette="Dark2") +
  labs(fill="") + facet_grid(feature ~ group) +
  ylab("Percent / Mb") + xlab("Age (Years)") +
  ggtitle("Percent cdDMRs Overlapped by Methylation Features") +
  theme(title = element_text(size = 20)) +
  theme(text = element_text(size = 20), legend.title=element_blank()) + theme(legend.position="bottom")
dev.off()

## Calculate correlation from last plot

w = w[which(w$celltype!="Prenatal"),]
f = unique(w$feature)
group = unique(w$group)
cor = list()
for (i in 1:length(group)) {
  cor[[i]] = list()
  for (j in 1:length(f)) {
    cor[[i]][[j]] = list(Neuron = cor.test(w[which(w[,"group"]==group[i] & w[,"feature"]==f[j] & w$celltype=="Neuron"),"perc.dmrHits"],
                                           w[which(w[,"group"]==group[i] & w[,"feature"]==f[j] & w$celltype=="Neuron"),"age"]),
                         Glia = cor.test(w[which(w[,"group"]==group[i] & w[,"feature"]==f[j] & w$celltype=="Glia"),"perc.dmrHits"],
                                         w[which(w[,"group"]==group[i] & w[,"feature"]==f[j] & w$celltype=="Glia"),"age"]))
  }
  names(cor[[i]]) = f
}
names(cor) = group
cor = lapply(cor, function(g) lapply(g, function(f)
  do.call(rbind, Map(cbind, lapply(f, function(cell) data.frame(pval = cell$p.value, tstat = cell$statistic, cor = cell$estimate)), celltype = as.list(names(f))))))
cor = do.call(rbind, Map(cbind, lapply(cor, function(g) do.call(rbind, Map(cbind, g, feature = as.list(names(g))))), group = names(cor)))
cor$fdr = p.adjust(cor$pval, method = "fdr")
rownames(cor) = c()
write.csv(cor, quote=F,file = "/dcl01/lieber/ajaffe/lab/brain-epigenomics/rdas/CREs/methFeatures_intCluster_overlap_correlation_byAge.csv")

cor = cor[order(cor$celltype,cor$feature,cor$group),]
cor[which(cor$fdr<=0.05),]

means = data.table(df)[,mean(perc.dmrHits), by=c("celltype","group","feature")]
means = means[order(feature),,]
write.csv(means, quote=F,file = "/dcl01/lieber/ajaffe/lab/brain-epigenomics/rdas/CREs/methFeatures_meanOverlap_withDMRs.csv")


#' Resize a watershed's reaches
#' @details By default watersheds are created with simple reaches that stretch between confluences. These can be
#' quite long, however, so this function will resize them, starting at headwaters.
#'
#' The size parameter only gives a target size, reaches can be smaller or larger in specific circumstances. Resizing
#' starts at headwaters, When a confluence is reached, the final reach before the confluence will often be smaller than
#' `size`. Thus, it is also necessary to specify `min_size`. If the reach upstream of a confluence is smaller than
#' `min_size`, the reach will be incorporated into the next reach upstream. If there is no reach upstream, the reach will
#' be deleted. If it is larger than `min_size`, it will be left as a separate reach. Thus, the largest reaches will be
#' `size + min_size` in length, and the smallest will be `min_size`
#'
#' @param ws A watershed
#' @param size Reach size; the desired reach size, see 'details'
#' @param min_size Minimum reach size
#' @param parallel Use the parallel package to speed computation on mac/linux?
#' @return A modified watershed
#' @export
resize_reaches = function(ws, size, min_size, parallel=TRUE) {
	ws = trim_reaches(ws, min_size, rebuild = FALSE)
	vals = rep(0, nrow(ws$data))
	reaches = unique(ws$data$reachID)
	pixes = lapply(reaches, function(x) which(ws$data$reachID == x))
	adj = lapply(pixes, function(x) ws$adjacency[x,x, drop=FALSE])
	len = lapply(pixes, function(x) ws$data$length[x])

	if(parallel) {
		nums = parallel::mcmapply(.resize_reach, adj, len, MoreArgs = list(size = size, min_size = min_size), SIMPLIFY=FALSE)
	} else {
		nums = mapply(.resize_reach, adj, len, MoreArgs = list(size = size, min_size = min_size), SIMPLIFY=FALSE)
	}

	if(length(nums) > 1) {
		for(i in 2:length(nums))
			nums[[i]] = nums[[i]] + max(nums[[i-1]])
	}
	for(i in seq_along(pixes)) {
		vals[pixes[[i]]] = nums[[i]]
	}
	ws$data$reachID = vals

	.rebuild_reach_topology(ws)
}

#' Remove short headwater reaches below a certain threshold
#' @param ws A watershed
#' @param size The minimum size of a reach to retain, in map units
#' @param rebuild Boolean; should topology be rebuilt? Normally yes, but can set to FALSE if it will be rebuilt later
#' @return A modified watershed
#' @export
trim_reaches = function(ws, size, rebuild = TRUE) {
	find_short_reaches = function(ws, size) {
		lens = tapply(ws$data$length, ws$data$reachID, sum)
		reaches = data.table::data.table(reachID = as.integer(names(lens)), length = unname(lens))
		reaches$hw = 0
		hw = headwaters(ws)$reachID
		reaches$hw[match(hw, reaches$reachID)] = 1
		reaches = reaches[length < size & hw == 1]
		pix_ids = which(ws$data$reachID %in% reaches$reachID)
		pix_ids
	}

	changed = FALSE
	pix_ids = find_short_reaches(ws, size)
	while(length(pix_ids) > 0) {
		changed = TRUE
		ws$data = ws$data[-pix_ids,]
		ws$data$id = 1:nrow(ws$data)
		ws$adjacency = ws$adjacency[-pix_ids, -pix_ids]
		rownames(ws$adjacency) = colnames(ws$adjacency) = ws$data$id
		pix_ids = find_short_reaches(ws, size)
	}
	if(rebuild && changed)
		ws = .rebuild_reach_topology(ws)
	return(ws)
}

#' Splits a reachID at selected points
#' @param ws A watershed object
#' @param points A vector of ids at which to split reaches
#' @param na_ignore Logical, if `TRUE` NAs will be dropped from the data. If `FALSE`, any NAs
#' 		in `points` will cause an error.
#' @return A modified watershed with new reachIDs
#' @export
splitReaches <- function(ws, points, na_ignore = FALSE) {
	if(na_ignore & any(is.na(points))) {
		points <- points[!is.na(points)]
	} else if(any(is.na(points))) {
		stop("NA in points; use na_ignore = TRUE to ignore")
	}
	for(pt in points) {
		ids <- which(ws$data$reachID == ws$data$reachID[pt])
		reachAdj <- ws$adjacency[ids, ids]
		mostUpstream <- ids[which(Matrix::rowSums(reachAdj) == 0)]
		if(pt != mostUpstream) {
			chIds <- connect(ws, mostUpstream, pt)
			ws$data$reachID[chIds] <- max(ws$data$reachID) + 1
		}
	}

	# re-create topology
	.rebuild_reach_topology(ws)
}

#' Reconstruct the reach topology
#'
#' After editing a watershed's pixels or reaches, the reach topology will need to be rebuilt using this function.
#' @param ws A watershed
#' @return A modified watershed
#' @keywords internal
.rebuild_reach_topology = function(ws) {
	ws = .renumber_reaches(ws)
	ws$reach_adjacency = .create_reach_adjacency(ws)
	ws$reach_connectivity = .create_reach_connectivity(ws, self = FALSE)
	ws
}

#' Resize a single reach
#' @details reach numbers will start from 1
#' @param adj subsetted adjacency matrix from a watershed, with just the entries for a single reach
#' @param len length of each pixel
#' @param start The reach number to start with
#' @param size Reach size; the desired reach size, see 'details'
#' @param min_size Minimum reach size
.resize_reach = function(adj, len, size, min_size, start = 1) {
	if(sum(len) <= size) {
		rnums = rep(start, nrow(adj))
	} else {
		rnums = rep(0, nrow(adj))
	}
	c_reach = which(Matrix::rowSums(adj) == 0)
	while(any(rnums == 0)) {
		while(sum(len[c_reach]) < size) {
			nxt = which(adj[,c_reach[length(c_reach)]] == 1)
			c_reach = c(c_reach, nxt)
		}
		rnums[c_reach] = start
		ind = which(rnums == 0)
		if(length(ind) > 0) {
			if(sum(len[ind]) < min_size) {
				rnums[ind] = start
			} else if(sum(len[ind]) < size) {
				rnums[ind] = start + 1
			} else {
				start = start + 1
				c_reach = which(adj[,c_reach[length(c_reach)]] == 1)
			}
		}
	}

	return(rnums)
}

#' Renumber reachIDs to start at 1 and increase one at a time, preserving ordering
#' @keywords internal
renumberReaches <- function(rIDs) {
	stop("Function is deprecated, use .renumber_reaches")
	newNums <- 1:length(unique(rIDs))
	oldNums <- sort(unique(rIDs))
	newNums[match(rIDs, oldNums)]
}

#' Renumber reaches, starting with one at the headwaters
#' @param ws A watershed
.renumber_reaches = function(ws) {
	result = rep(0, nrow(ws$data))
	reaches = headwaters(ws)$reachID
	while(any(result == 0)) {
		start = max(result)
		pixes = lapply(reaches, function(x) which(ws$data$reachID == x))
		vals = seq_along(pixes) + start
		newvals = mapply(function(pp, vv) rep(vv, length(pp)), pixes, vals, SIMPLIFY = FALSE)
		newvals = cbind(unlist(pixes), unlist(newvals))
		result[newvals[,1]] = newvals[,2]
		ids = outlets(ws, reaches)$id
		nxt = unique(unlist(apply(ws$adjacency[, ids, drop=FALSE], 2, function(x) which(x != 0))))
		nxt = nxt[which(result[nxt] == 0)]
		reaches = ws$data$reachID[nxt]
	}
	ws$data$reachID = result
	ws
}

#' Produce a reach by reach connectivity matrix
#'
#' @param ws A watershed
#' @param self If TRUE, a reach is considered connected to itself
#' Nonzero values indicate that a reachID in a row is downstream from that column
#' @return A [Matrix::sparseMatrix()]
#' @keywords internal
.create_reach_connectivity <- function(ws, self = TRUE) {
	adj <- ws$reach_adjacency
	if(self)
		diag(adj) <- 1
	for(i in 1:nrow(adj))
		adj <- adj %*% adj + adj
	adj[adj != 0] <- 1
	adj
}

#' Produce a reach by reach adjacency matrix
#' @keywords internal
.create_reach_adjacency = function(ws) {
	if(max(ws$data$reachID) != length(unique(ws$data$reachID)))
		stop("ReachIDs not in 1:length(unique(reachID)); they must be renumbered")

	reaches = sort(unique(ws$data$reachID))
	adjMat = parallel::mclapply(reaches, function(r) reachAdj(ws, r))
	adjMat = do.call(rbind, adjMat)
	adjspMat = Matrix::sparseMatrix(adjMat[,1], adjMat[,2], dims=rep(max(ws$data$reachID), 2),
									 dimnames = list(reaches, reaches))
	adjspMat
}

#' Find all reaches directly upstream from a given reach
#' @keywords internal
reachAdj <- function(ws, rch) {
	ids <- which(ws$data$reachID == rch)
	reachAdj <- ws$adjacency[ids,ids, drop = FALSE]
	mostUpstream <- ids[which(Matrix::rowSums(reachAdj) == 0)]
	adjMatUp <- as.matrix(ws$adjacency[mostUpstream,])
	upRch <- which(adjMatUp == 1)
	if(length(upRch) > 0) {
		upRch <- ws$data$reachID[upRch]
		return(cbind(rch, upRch))
	} else return(NULL)
}


\name{hc_rect-GenomicHilbertCurve-method}
\alias{hc_rect,GenomicHilbertCurve-method}
\title{
Add rectangles on Hilbert curve
}
\description{
Add rectangles on Hilbert curve
}
\usage{
\S4method{hc_rect}{GenomicHilbertCurve}(object, gr, gp = gpar(fill = "red", col = "red"),
    mean_mode = c("w0", "absolute", "weighted", "max_freq"))
}
\arguments{

  \item{object}{a \code{\link{GenomicHilbertCurve-class}} object}
  \item{gr}{a \code{\link[GenomicRanges:GRanges-class]{GRanges}} object which contains the genomic regions to be mapped to the curve}
  \item{gp}{pass to \code{\link{hc_rect,HilbertCurve-method}}}
  \item{mean_mode}{pass to \code{\link{hc_rect,HilbertCurve-method}}}

}
\details{
It is basically a wrapper of \code{\link{hc_rect,HilbertCurve-method}}.
}
\value{
Refer to \code{\link{hc_rect,HilbertCurve-method}}
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
require(circlize)
require(GenomicRanges)
bed = generateRandomBed(nr = 100)
gr = GRanges(seqnames = bed[[1]], ranges = IRanges(bed[[2]], bed[[3]]))
hc = GenomicHilbertCurve()
hc_rect(hc, gr, gp = gpar(fill = rand_color(length(gr))))
}


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

#set output path.----
output.path <- 'Fig._1._cal.val_r2_rmse.png'

#Load calibration data.----
d <- readRDS(NEON_dmilti.ddirch_analysis_summary.path)
d2 <- readRDS(NEON_dmilti.ddirch_analysis_summary_16S.path)

#Get RSQ and RMSE densities and means for ITS.----
core.rsq <- d$validation$val.stat.predictable$core.stat
core.rsq <- data.frame(do.call(rbind, core.rsq))
plot.rsq <- d$validation$val.stat.predictable$plot.stat
plot.rsq <- data.frame(do.call(rbind, plot.rsq))
site.rsq <- d$validation$val.stat.predictable$site.stat
site.rsq <- data.frame(do.call(rbind, site.rsq))
core.d <- zero_truncated_density(core.rsq$rsq)
plot.d <- zero_truncated_density(plot.rsq$rsq)
site.d <- zero_truncated_density(site.rsq$rsq)
core.rmse.d <- zero_truncated_density(core.rsq$rmse.norm)
plot.rmse.d <- zero_truncated_density(plot.rsq$rmse.norm)
site.rmse.d <- zero_truncated_density(site.rsq$rmse.norm)
#get calibration values by group.
cal.mu <- d$calibration$cal.stat.predictable.sum$rsq
val.mu <- d$validation$site.stat.predictable.sim$rsq
cal.rmse <- d$calibration$cal.stat.predictable.sum$rmse.norm
val.rmse <- d$validation$site.stat.predictable.sim$rmse.norm
names(cal.mu) <- rownames(d$calibration$cal.stat.predictable.sum)

#for 16S.----
core.rsq.2 <- d2$validation$val.stat.predictable$core.stat
core.rsq.2 <- data.frame(do.call(rbind, core.rsq.2))
plot.rsq.2 <- d2$validation$val.stat.predictable$plot.stat
plot.rsq.2 <- data.frame(do.call(rbind, plot.rsq.2))
site.rsq.2 <- d2$validation$val.stat.predictable$site.stat
site.rsq.2 <- data.frame(do.call(rbind, site.rsq.2))
core.d.2 <- zero_truncated_density(core.rsq.2$rsq)
plot.d.2 <- zero_truncated_density(plot.rsq.2$rsq)
site.d.2 <- zero_truncated_density(site.rsq.2$rsq)
core.rmse.d.2 <- zero_truncated_density(core.rsq.2$rmse.norm)
plot.rmse.d.2 <- zero_truncated_density(plot.rsq.2$rmse.norm)
site.rmse.d.2 <- zero_truncated_density(site.rsq.2$rmse.norm)
#get calibration values by group.
cal.mu.2 <- d2$calibration$cal.stat.predictable.sum$rsq
val.mu.2 <- d2$validation$site.stat.predictable.sim$rsq
cal.rmse.2 <- d2$calibration$cal.stat.predictable.sum$rmse.norm
val.rmse.2 <- d2$validation$site.stat.predictable.sim$rmse.norm
names(cal.mu.2) <- rownames(d2$calibration$cal.stat.predictable.sum)

#png save line.----
png(filename=output.path,width=9,height=6,units='in',res=300)
#global plot settings.----
par(mfrow = c(2,4), 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')

#Validation R2 denisty plot 16S.-----
dat.a <- core.d.2
dat.b <- plot.d.2
dat.c <- site.d.2
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('(a)', side = 3, adj = 0.95, line = -2)

#Validation RMSE denisty plot 16S.-----
dat.a <- core.rmse.d.2
dat.b <- plot.rmse.d.2
dat.c <- site.rmse.d.2
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)))
limx <- c(0, 10)
#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"["norm"])), 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('(b)', side = 3, adj = 0.95, line = -2)

#Calibration and Validation rsq ~ function/phylo scale 16S.----
x <- 1:length(cal.mu.2)
limy <- c(0,max(cal.mu.2)*1.1)
plot(cal.mu.2 ~ 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.2, lty = 2)
#lines(x, val.mu.2, lty = 2)
#points(val.mu.2 ~ 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 = limy[1] - limy[2]*0.1, 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)
mtext('(c)', side = 3, adj = 0.95, line = -2)

#Calibration and Validation RMSE ~ function/phylo scale 16S.----
x <- 1:length(cal.rmse.2)
limy <- c(0,max(cal.rmse.2)*1.2)
plot(cal.rmse.2 ~ 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.rmse.2, lty = 2)
#lines(x, val.rmse.2, lty = 2)
#points(val.rmse.2 ~ x, cex = 2.5, pch = 16, col = 'gray')
mtext(expression(paste("Site-Level RMSE"["norm"])), side = 2, line = 2.5, cex = o.cex)
axis(1, labels = F)
text(x=x+0.05, y = limy[1] - limy[2]*0.1, labels= names(cal.mu), srt=45, adj=1, xpd=TRUE, cex = 1.25)
#legend
#legend(x = 2, y = 0.6, legend = c('calibration','validation'), col =c('black','gray'), bty = 'n', pch = 16, pt.cex = 2.5, cex = 1.2)
mtext('(d)', side = 3, adj = 0.95, line = -2)

#Validation R2 denisty plot ITS.-----
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('(e)', side = 3, adj = 0.95, line = -2)

#Validation RMSE denisty plot ITS.-----
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)))
limx <- c(0, 10)
#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"["norm"])), 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('(f)', side = 3, adj = 0.95, line = -2)

#Calibration and Validation rsq ~ function/phylo scale ITS.----
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 = limy[1] - limy[2]*0.1, 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)
mtext('(g)', side = 3, adj = 0.95, line = -2)

#Calibration and Validation RMSE ~ function/phylo scale ITS.----
x <- 1:length(cal.rmse)
limy <- c(0,max(cal.rmse)*1.2)
plot(cal.rmse ~ 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.rmse, lty = 2)
lines(x, val.rmse, lty = 2)
points(val.rmse ~ x, cex = 2.5, pch = 16, col = 'gray')
mtext(expression(paste("Site-Level RMSE"["norm"])), side = 2, line = 2.5, cex = o.cex)
axis(1, labels = F)
text(x=x+0.05, y = limy[1] - limy[2]*0.1, labels= names(cal.mu), srt=45, adj=1, xpd=TRUE, cex = 1.25)
#legend
#legend(x = 2, y = 0.6, legend = c('calibration','validation'), col =c('black','gray'), bty = 'n', pch = 16, pt.cex = 2.5, cex = 1.2)
mtext('(h)', side = 3, adj = 0.95, line = -2)

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

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


#' @title Calculate Category Sums
#' @description Sum the counts for categories of numerators.  This function assumes there is only a single denominator.
#' @param flt_data dataframe of filtered data
#' @param id_cols names of columns to use as id
#' @param numer_categories list of numerator groupings each containing a vector of names of column names which belong to the numerator group.
#' @param preserve_cols names of columns to be preserved for subsquent use in faceting for further processing.
#' @return dataframe of category sums
calc_category_sums <- function(flt_data, id_cols, numer_categories, preserve_cols){
  id          <- apply(flt_data[,id_cols, drop=FALSE], 1, FUN=paste, sep="", collapse="")
  timepoint   <- flt_data$report_month
  cat_sums    <- lapply(numer_categories, FUN=function(x, df){rowSums(df[,x,drop=FALSE])}, df=flt_data)
  preserved   <- as.data.frame(flt_data[, preserve_cols])
  names(preserved) <- preserve_cols

  data.frame(id, timepoint, cat_sums, preserved)
}


#read in this data, for next export, clean up the name please
#f2.v<-fura2 video
f2.frames<-read.delim("video_dataImage.txt", header=T, sep="/t")
#these are all the names from the data set.  as you can see we
#have some added types of data.
all.names<-names(f2.v)

#will need to convert image number to a time value
# based on what the user specifies
##Or
#based on a 1.5s/frame conversion
time.name<-"ImageNumber"

#will need to align objects by XY location
# need to think about this
id.name<-"ObjectNumber"

# Unique measurements.  If memory allows, we should have 6 initial
# trace dataframes within our list of dataframes, RD

#fura2 meanintensity from each object
#f2.mean.340
f2.mean.340<-"Intensity_MeanIntensity_f2_340"
#f2.mean.380
m2.mean.380<-"Intensity_MeanIntensity_f2_380"

#fura2 meanintensityedge from the single pixel on the edge of the ROI
#f2.meanedge.380
f2.meanedge.340<-"Intensity_MeanIntensityEdge_f2_380"
#f2.meanedge.380
f2.meanedge.380<-"Intensity_MeanIntensityEdge_f2_380"

# to maintain a constant sorting order i will order the data frame first
# by y cooridinates, then by x cooridinates
# first thing

cell.names<-unique(f2_v[,id.name])
cell.names
x.tab<-table(f2_v[,id.name])
x.tab[1:5,1:5]
head(x.tab)
max(x.tab)
min(x.tab)
(x.row<-max(x.tab))
t.dat<-matrix(f2_v[,f2_340],byrow=FALSE, nrow=x.row)
t.dat[1:5,1:5]
savehistory()


#--------------------------------------------------------------
# getWaveData -- Load data for SRL .wav file with .pps & .seg
#               information (if available).
#
# Usage: waveData <- getWaveData(basename)
#
#  Args:
#   basename -- The basename (with path but sans extension) to
#               the .wav file. This is also assumed to be the
#               basename of the .pps and .seg file in the same
#               location.
#
# Returns:
#   A list of three elements:
#     wav -- A class "Wave" object from package "tuneR".
#     pps -- A data.frame with columns time, f0, and vcd that
#            are the time in msec of the epoch marker, the f0
#            if a voiced epoch or 0 if unvoiced, and the voicing
#            status (1=voiced; 0=unvoiced) respectively.
#     seg -- A data.frame with columns segnam, beg, end listing
#            the segment name, beginning time, and ending time
#            of the segment in microseconds.
# Note: If .wav file is not found, the function returns NULL
#       rather than a list. If either or both of .pps or .seg
#       files is not found, that list element is set to NULL.
#
# 1/11/20 -- htb
#-------------------------------------------------------------
#
getWaveData <- function(basename) {
  require(tuneR)

  wname <- paste0(basename,".wav")
  pname <- paste0(basename,".pps")
  sname <- paste0(basename,".seg")

  if (!file.exists(wname))
    return(NULL)
  w <- readWave(wname)
  if(file.exists(pname)) {
    p <- read.table(pname)
    names(p) <- c("time","f0","vcd")
  } else {
    p <- NULL
  }
  if(file.exists(sname)) {
    s <- read.table(sname)
    names(s) <- c("segnam","beg","end")
  } else {
    s <- NULL
  }
  rtn <- list(wav=w, pps=p, seg=s)
  rtn
}


library(Cairo)
Cairo(file="generated/graphs/pie-base-publish.png", type="png", units="px", width=800, height=480, dpi=72)
slices <- c(314, 144, 102, 99, 74, 58, 16, 16, 12, 12, 11, 11, 10, 4)
lbls <- c("The Web", "Android
Store", "itch.io", "iOS
Store", "Other", "Steam", "Amazon
Store", "Mac
Store", "Nintendo
Switch", "PS4", "GOG.com", "Xbox One", "Windows
Store", "PSVita")
pct <- round(slices/sum(slices)*100)
lbls <- paste(lbls, " (", sep="")
lbls <- paste(lbls, pct)
lbls <- paste(lbls, "% )", sep="")
pie(slices, labels=lbls, col=rainbow(length(lbls)), main="Where do you publish your Haxe applications?")
invisible(dev.off())


# Over lunch though of this.  Add CentreXpx with CentreYpx sory by that value and see if RoiID matches up
centerxy.pic["XplusY"]<-centerxy.pic[,"CentreYpx"]+centerxy.pic[,"CentreXpx"]
centerxy.vid["XplusY"]<-centerxy.vid[,"CentreYpx"]+centerxy.vid[,"CentreXpx"]

#Still dont match up
centerxy.pic[order(centerxy.pic[,"XplusY"]),]
centerxy.vid[order(centerxy.vid[,"XplusY"]),]

centerxy.pic[order(centerxy.pic[,"XplusY"]),"XplusY"]
centerxy.vid[order(centerxy.vid[,"XplusY"]),"XplusY"]

centerxy.pic[order(centerxy.pic[,"XplusY"]),"XplusY"]=centerxy.vid[order(centerxy.vid[,"XplusY"]),"XplusY"]
centerxy.pic[order(centerxy.pic[,"XplusY"]),"XplusY"]-centerxy.vid[order(centerxy.vid[,"XplusY"]),"XplusY"]

cbind(centerxy.pic[order(centerxy.pic[,"XplusY"]),"RoiID"],centerxy.vid[order(centerxy.vid[,"XplusY"]),"RoiID"])


topo.colors2 = function (n)
{
    if ((n <- as.integer(n[1])) > 0) {
        j <- n%/%3
        k <- n%/%3
        i <- n - j - k
        c(  if (i > 0) hsv(h = seq(from = 45/60, to = 31/60, length = i)),
            if (j > 0) hsv(h = seq(from = 30/60, to = 16/60, length = j)),
            if (k > 0) hsv(h = seq(from = 15/60, to = 1/60, length = k),
              s = 0.5, v = 1))
    }
    else character(0)
}