#' Draw meanfield model attractor
#'
#' @param model
#' @param times
#' @param parms
#' @param method
#' @param rho
#' @param colors
#'
#' @import foreach
#'
#' @return
#' @export
#' @examples
#'
#' p <- set_parms(livestock$parms, set = list(b = 0.1, f = 0.5, p = 0.9, L = 1.5))
#' par(mfrow = c(1,2))
#' plot_pairapproximation(livestock, parms = p) -> out
#' plot_pairapproximation(out, parms = p, side = "plain")

plot_pairapproximation <- function(
  model,
  parms = model$parms,
  side = "rho",
  rho_1_ini = seq(0,1, length = 11),
  rho_11_ini = seq(0,1, length = 11),
  times = c(0,1000),
  method = "ode45",
  rho = seq(0,1,length = 100),
  colors = c("#000000","#009933"),
  #fog = TRUE,
  new = TRUE,
  ...
) {

  #par(mfrow = c(1,3))
  # open new base plot if none exists
  if(dev.cur() == 1 | new == TRUE) plot_base(ylim = switch(side, plain = c(0,1), c(0,0.25) ),
                                             ylab = switch(side, plain = "local cover", "plant mortality/growth" ),
                                             xlab = switch(side, q = "local cover","vegetation cover"), ...)

  # draw trajectories of mortality and growth
  if(class(model) == "attractor") {
    trajectories <- model$trajectories
  } else {
    trajectories <- sim_trajectories(model = model, parms = parms, rho_1_ini = rho_1_ini, times = times, method = method)
  }

  # visualize trajectories to the attractor
  sapply(trajectories, function(x){
    rho <- ini_rho(x$rho_1, x$rho_11)
    mort <- limit(mortality(rho, parms))
    grow <- limit(growth(rho, parms))
    q_11_vec <- q_11(rho)
    #fog_m <- highlight(q_11_vec, colrange = c(paste0(colors[1],"88"),colors[1]))
    #fog_g <- highlight(q_11_vec, colrange = c(paste0(colors[2],"88"),colors[2]))

    switch(side,
        rho = {
          lines(rho$rho_1,  mort)
          #arrows(tail(rho$rho_1,2)[1],tail(mort,2)[1],tail(rho$rho_1,1),tail(mort,1), length = 0.1 )
          lines(rho$rho_1, grow, col = "#009933")
          #arrows(tail(rho$rho_1,2)[1],tail(grow,2)[1],tail(rho$rho_1,1),tail(grow,1), length = 0.1 , col = "#009933")

          },
        q = {
          lines(q_11_vec,  mort)
          #arrows(tail(q_11_vec,2)[1],tail(mort,2)[1],tail(q_11_vec,1),tail(mort,1), length = 0.1 )
          lines(q_11_vec, grow, col = "#009933")
          #arrows(tail(q_11_vec,2)[1],tail(grow,2)[1],tail(q_11_vec,1),tail(grow,1), length = 0.1 , col = "#009933")

        },
        plain = {
          lines(rho$rho_1,  q_11_vec)
          #arrows(tail(rho$rho_1,2)[1],tail(q_11_vec,2)[1],tail(rho$rho_1,1),tail(q_11_vec,1), length = 0.1 )
          lines(rho$rho_1+0.002, q_11_vec+0.002, col = "#009933")
          #arrows(tail(rho$rho_1,2)[1],tail(q_11_vec,2)[1],tail(rho$rho_1,1),tail(q_11_vec,1), length = 0.1 , col = "#009933")

        }

    )

  }
  )

  if(class(model) == "attractor") {
    eq <- model$eq
  } else {
    eq <- get_equilibria(y = model$template, func = model$pair, parms = parms, method = method, t_max = 130)
  }

    rho_steady <- ini_rho(c(eq$lo[1],eq$hi[1]),c(eq$lo[2],eq$hi[2]))
  q_steady <- q_11(rho_steady)
  switch(side,
         rho = {
           points(rho_steady$rho_1, mortality(rho_steady, parms = parms), xpd = TRUE, pch = 20, cex = 2)

         },
         q = {
           points(q_steady, mortality(rho_steady, parms = parms), xpd = TRUE, pch = 20, cex = 2)

         },
         plain = {
           points(rho_steady$rho_1, q_steady, xpd = TRUE, pch = 20, cex = 2)

         }

  )

  output <- list(trajectories = trajectories,
                 eq = eq
                 )
  class(output) <- "attractor"
  return(output)

}


### tripsAndDip uses read counts for biallelic SNPS to determine if a sample is diploid or triploid
### Input
### counts is either a matrix or a dataframe with each row corresponding to a different sample
### the columns correspond to the read counts for each locus, in a two column per locus format
### So, column 1 is the read counts for locus1Allele1, column two is the read counts for locus1Allele2, locus2Allele1, locus2Allele2, ...
### the rownames of the matrix or dataframe should be the sample names
### h is a list of h values for each locus in the same order that the loci are ordered in counts
### eps is a list of epsilon (error rate per read) values for each locus in the same order that the loci are ordered in counts
### min_reads is the minimum number of reads needed to use a locus in the algorithm
### min_loci is the minimum number of loci needed to attempt to calculate an LLR
### Output
### a dataframe with column 1 containing sample names, column 2 containing calculated LLRs (larger means more likely triploid)
###    and column 3 containing the number of loci used to calculate the LLR
######
### note that constant values for h and epsilon can be easily implemented usign the rep() function in R, for example
###### constant_h <- rep(1, (ncol(allele_counts))/2)
###### constant_eps <- rep(.01, (ncol(allele_counts))/2)
###### results <- tripsAndDip(allele_counts, constant_h, constant_eps)

tripsAndDip <- function(counts, h, eps, min_reads = 30, min_loci = 15, binom_p_value = .05){
	### input error checking
	if(!is.matrix(counts) && !is.data.frame(counts)){
		cat("\nError. Counts must be either a matrix or a dataframe.\n")
		return()
	}
	if((ncol(counts)/2) != length(h)){
		cat("\nError. The number of columns of counts is not equal to twice the length of h.\n")
		return()
	}
	if(length(eps) != length(h)){
		cat("\nError. The length of h is not equal to the length of eps.\n")
		return()
	}
	if(min_reads < 1){
		cat("\nError. min_reads must be 1 or greater.\n")
		return()
	}
	if(min_loci < 1){
		cat("\nError. min_loci must be 1 or greater.\n")
		return()
	}
	if(binom_p_value < 0 || binom_p_value > 1){
		cat("\nError. binom_p_value must be between 0 and 1.\n")
		return()
	}

	### calculate llr for each sample
	num_counts <- ncol(counts)
	llr <- apply(counts, 1, function(x){
		#separate allele1 and allele2
		count1 <- x[seq(1, (num_counts - 1), 2)]
		count2 <- x[seq(2, num_counts, 2)]
		#caluculate total read count and which is larger
		n <- count1 + count2
		#determine whether to include loci based on read count
		count1 <- count1[n >= min_reads]
		count2 <- count2[n >= min_reads]
		h_corr <- h[n >= min_reads]
		eps_corr <- eps[n >= min_reads]
		n <- n[n >= min_reads]
		# determine if enough loci
		if (length(n) < min_loci){
			return(c(NA, length(n)))
		}

		k <- mapply(max, count1, count2)
		#flip h as necessary
		h_corr[count2 > count1] <- 1/h_corr[count2 > count1]

		#calculate probabilities
		#based on model with error and allelic bias from Gerard et al. 2018
		p_temp <- (0.6666667*(1 - eps_corr) + (0.3333333)*eps_corr)
		prob_trip <- p_temp / (h_corr*(1 - p_temp) + p_temp)
		p_temp <- 0.5 # (0.5*(1 - eps_corr) + (0.5)*eps_corr) simplifies to 0.5
		prob_dip <- p_temp / (h_corr*(1 - p_temp) + p_temp)

		#determine which loci to include using binomial test
		binom_results <- mapply(function(x,y,z){
				return(binom.test(x, y, z, "greater")$p.value)
			}, k, n, prob_trip)
		binom_results <- binom_results > binom_p_value

		h_corr <- h_corr[binom_results]
		eps_corr <- eps_corr[binom_results]
		n <- n[binom_results]
		k <- k[binom_results]
		prob_trip <- prob_trip[binom_results]
		prob_dip <- prob_dip[binom_results]
		# determine if enough loci
		if (length(n) < min_loci){
			return(c(NA, length(n)))
		}

		#calculate log likelihoods
		trip <- (k*log(prob_trip)) + ((n-k)*log(1-prob_trip))
		dip <- (k*log(prob_dip)) + ((n-k)*log(1-prob_dip))
		#sum accros loci
		trip <- sum(trip)
		dip <- sum(dip)

		return(c(trip - dip, length(n)))

	})
	# associate llr's with sample names and return
	return(data.frame(sample_name = rownames(counts),
			 LLR = llr[1,], loci_used=llr[2,], stringsAsFactors = F, row.names = NULL))
}


#setwd("D:/Dropbox/Data analyze/Rdocuments/datas")
library(xlsx)
 library(RColorBrewer)

 fv<-5:3500 #电压频率

q<-c(2.5e-14, 4.5e-13, 9e-13, 3e-12) #不同的流量下

k<-c(0.5,0.6,0.7,0.8) #不同占空比下无电场时间比例，即1-k_i

v<-4.66e-13  #泰勒锥的体积总量

mycolors<-c("red", "blue", "darkgreen", "yellow3")

pchall<-c(21,22,23,24)

######
par(fig=c(0,1,0,1), mar = c(3,3,1,1), oma = c(1,1,1,1),new=FALSE)
plot(fv, (k[1]*q[1]/fv+v), mgp = c(1, 0, 0),tck=0.01,col=mycolors[1], log="x", type="b", xlab = expression(italic(f["v"])(Hz)),
     ylab = expression(italic(V["ne"]+V["m"](m^3))), main="", lwd=2, pch=pchall[1], lty=2,cex.lab=1,cex.axis=1, ylim=c(4.4e-13, 8e-13))

#画出占空比为0.5，流量为1.5nl/min时的弯月面体积，说明最小值是什么

###流量为1.5nl/min时####
for (i in 1:3){
lines(fv,  (k[i+1]*q[1]/fv+v), lwd=1.5, type="b",col="red", pch=pchall[i+1],lty=2,cex=0.6)
}
#画出，流量为最小，占空比从大到小，体积从小到大变化的曲线，其中：颜色均为red，pch的改变代表着占空比的改变

###流量为27nl/min时####
par(fig=c(0,1,0,1))
for (i in 1:4){
lines(fv,  (k[i]*q[2]/fv+v), lwd=1.5, type="b", col="blue", pch=pchall[i] ,lty=2,cex=0.6)
}

###流量为54nl/min时####
for (i in 1:4){
lines(fv,  (k[i]*q[3]/fv+v), lwd=1.5, type="b", col="darkgreen", pch=pchall[i] ,lty=2,cex=0.6)
}

###流量为180nl/min时####
for (i in 1:4){
lines(fv,  (k[i]*q[4]/fv+v), lwd=1.5, type="b", col="yellow3", pch=pchall[i] ,lty=2,cex=0.6)
}

da<-c("kv0.5-Q1.5nlmin", "kv0.4-Q1.5nlmin", "kv0.3-Q1.5nlmin", "kv0.2-Q1.5nlmin", "kv0.5-Q27nlmin", "kv0.4-Q27nlmin", "kv0.3-Q27nlmin", "kv0.2-Q27nlmin","kv0.5-54nlmin", "kv0.4-Q54nlmin", "kv0.3-Q54nlmin", "kv0.2-Q54nlmin","kv0.5-Q180nlmin", "kv0.4-Q180nlmin", "kv0.3-Q180nlmin", "kv0.2-Q180nlmin")

mycolorsss<-c("red","red","red","red","blue","blue","blue","blue","darkgreen","darkgreen","darkgreen","darkgreen","yellow3","yellow3","yellow3","yellow3")

pchss<-c(21,22,23,24,21,22,23,24,21,22,23,24,21,22,23,24)

legend("topright", da, inset=0, col=mycolorsss, pch=pchss,lwd=1.5, lty=2, cex=0.8, bty="n")

abline(v=20, col="red", lwd=2,lty=3)
abline(v=45, col="blue", lwd=2,lty=3)
#abline(v=125, col="darkgreen", lwd=2,lty=3)

#################################################
par(fig=c(0.4, 0.98,0.20,0.98), new=TRUE)

plot(fv, (k[1]*q[1]/fv+v),bty="n", col=mycolors[1], mgp = c(1, 0, 0),tck=0.01,log="x", type="l", xlab = "125Hz ~ 1KHz", ylab ="", lwd=2, lty=2, xlim=c(125,1000), ylim=c(4.66e-13, 5e-13))

#画出占空比为0.5，流量为1.5nl/min时的弯月面体积，说明最小值是什么

###流量为1.5nl/min时####
for (i in 1:3){
lines(fv,  (k[i+1]*q[1]/fv+v), lwd=2, col="red", lty=1)
}
#画出，流量为最小，占空比从大到小，体积从小到大变化的曲线，其中：颜色均为red，pch的改变代表着占空比的改变

###流量为27nl/min时####
for (i in 1:4){
lines(fv,  (k[i]*q[2]/fv+v), lwd=2, col="blue", lty=1)
}

###流量为54nl/min时####
for (i in 1:4){
lines(fv,  (k[i]*q[3]/fv+v), lwd=2,col="darkgreen", lty=1)
}

###流量为180nl/min时####
for (i in 1:4){
lines(fv,  (k[i]*q[4]/fv+v), lwd=2,col="yellow3", lty=1)
}

abline(h=5.126e-13, col="red", lwd=1.5, lty=4)
abline(h=5.592e-13, col="blue", lwd=1.5, lty=4)


## ============================================================================================
##
## predictDiagnosis
##
## ============================================================================================

computePredResMat <- function(predRes, predRes0, followUpTime, followUpTime0) {
  selPeriodStrs <- c("Year 1", "Year 1-2", "Year 3-4", "Year 5-6")
  selPeriodInterval <- matrix(NA, nrow=4, ncol=2)
  selPeriodInterval[1,] <- c(1,365)
  selPeriodInterval[2,] <- c(1,2*365)
  selPeriodInterval[3,] <- c(2*365+1,4*365)
  selPeriodInterval[4,] <- c(4*365+1,6*365)

  resMat <- matrix(NA, nrow=5, ncol=5)
  rownames(resMat) <- c("All years", selPeriodStrs)
  colnames(resMat) <- c("FN", "TP", "FP", "TN", "P-value")

  for (i in 0:length(selPeriodStrs)) {
    fn <- sum(!predRes>0)
    tp <- sum(predRes>0)
    fp <- sum(!predRes0<0)
    tn <- sum(predRes0<0)
    if (i>0) {
      sel <- followUpTime>selPeriodInterval[i,1] & followUpTime<=selPeriodInterval[i,2]
      sel0 <- followUpTime0>selPeriodInterval[i,1] & followUpTime0<=selPeriodInterval[i,2]
      fn <- sum(!predRes[sel]>0)
      tp <- sum(predRes[sel]>0)
      fp <- sum(!predRes0[sel0]<0)
      tn <- sum(predRes0[sel0]<0)
    }

    resMat[i+1,] <-
      c(fn, tp, fp, tn,
        fisher.test(matrix(c(tp, fn, fp, tn), ncol=2, byrow=F),
                    alternative="g")$p.value)
  }

  resMat
}

predictDiagnosis  <- function(dataList, n, nofGenes,  strFollowUpTime, strPlotFracCorr, strResMat,
                              m, m2, selPeriodStr, selPeriodInterval, selPeriodFromWith,
                              hasInsitu=FALSE) {

  ## Predict diagnosis using a leave-one-out approach, n=periodLength
  caseStr <- "Weight"
  caseN <- "N1"

  curDataList <- selectDataset(dataList, caseN, dataList$withSpread)
  data <- curDataList$data
  followUpTime <- curDataList$followUpTime
  weights <- curDataList$weights
  curDataList0 <- selectDataset(dataList, caseN, dataList$withoutSpread)
  data0 <- curDataList0$data
  followUpTime0 <- curDataList0$followUpTime
  weights0 <- curDataList0$weights
  if (hasInsitu) {
    curDataListInsitu <- selectDataset(dataList, caseN, dataList$insitu)
    dataInsitu <- curDataListInsitu$data
    followUpTimeInsitu <- curDataListInsitu$followUpTime
    weightsInsitu <- curDataListInsitu$weights
  }
  selFollowUpTime <- followUpTime0
  notSelFollowUpTime <- followUpTime
  if (selPeriodFromWith) {
    selFollowUpTime <- followUpTime
    notSelFollowUpTime <- followUpTime0
  }
  nofPeriods <- length(selFollowUpTime)-n+1

  ## Select genes for predictor
  ## Find sorting of genes from analyses for "Weights" in predictor
  ## Weights with sign for genes selected for predictor:  Number of genes selected?

  predRes <- matrix(NA, ncol=length(nofGenes), nrow=ncol(data))
  predRes0 <- matrix(NA, ncol=length(nofGenes), nrow=ncol(data0))
  rownames(predRes) <- colnames(data)
  rownames(predRes0)  <- colnames(data0)
  colnames(predRes) <- colnames(predRes0) <- nofGenes
  if (hasInsitu) {
    predResInsitu <- matrix(NA, ncol=length(nofGenes), nrow=ncol(dataInsitu))
    colnames(predResInsitu) <- nofGenes
  }

  for (p in 1:nofPeriods)
    print(c(selFollowUpTime[p+n-1]-selFollowUpTime[p],
            sum(notSelFollowUpTime %in% selFollowUpTime[p]:selFollowUpTime[p+n-1])))

  meanTimeForPeriod <- rep(NA, nofPeriods)
  for (p in 1:nofPeriods)
    meanTimeForPeriod[p] <- (selFollowUpTime[p+n-1]+selFollowUpTime[p])/2

  bestPeriod <- rep(NA, length(followUpTime))
  bestPeriod0 <- rep(NA, length(followUpTime0))
  bestPeriod[followUpTime < mean(meanTimeForPeriod[1:2])] <- 1
  bestPeriod0[followUpTime0 < mean(meanTimeForPeriod[1:2])] <- 1
  bestPeriod[followUpTime > mean(meanTimeForPeriod[(length(meanTimeForPeriod)-1):
                                                   (length(meanTimeForPeriod))])] <- nofPeriods
  bestPeriod0[followUpTime0 > mean(meanTimeForPeriod[(length(meanTimeForPeriod)-1):
                                                     (length(meanTimeForPeriod))])] <- nofPeriods
  if (hasInsitu) {
    bestPeriodInsitu <- rep(NA, length(followUpTimeInsitu))
    bestPeriodInsitu[followUpTimeInsitu < mean(meanTimeForPeriod[1:2])] <- 1
    bestPeriodInsitu[followUpTimeInsitu >
                     mean(meanTimeForPeriod[(length(meanTimeForPeriod)-1):
                                            (length(meanTimeForPeriod))])] <- nofPeriods
  } else {
    bestPeriodInsitu <- c()
  }

  for (p in 2:(nofPeriods-1)) {
    bestPeriod[followUpTime >= mean(meanTimeForPeriod[(p-1):p]) &
               followUpTime <= mean(meanTimeForPeriod[(p):(p+1)])] <- p
    bestPeriod0[followUpTime0 >= mean(meanTimeForPeriod[(p-1):p]) &
                followUpTime0 <= mean(meanTimeForPeriod[(p):(p+1)])] <- p
    if (hasInsitu) {
      bestPeriodInsitu[followUpTimeInsitu >= mean(meanTimeForPeriod[(p-1):p]) &
                       followUpTimeInsitu <= mean(meanTimeForPeriod[(p):(p+1)])] <- p
    }
  }

  for (p in unique(sort(c(bestPeriod, bestPeriod0, bestPeriodInsitu)))) {
    selInd <-  (1:length(followUpTime))[followUpTime>=selFollowUpTime[p] &
                                        followUpTime<=selFollowUpTime[p+n-1]]
    selInd0 <- (1:length(followUpTime0))[followUpTime0>=selFollowUpTime[p] &
                                         followUpTime0<=selFollowUpTime[p+n-1]]

    leaveOut <- which(bestPeriod==p)
    leaveOut0 <- which(bestPeriod0==p)
      if (hasInsitu) {
        leaveOutInsitu <- which(bestPeriodInsitu==p)
      }

    ## Predict for group1
    if (length(leaveOut)>0)
      for (i in leaveOut) {
        curData <- data[, selInd[selInd!=i]]
        curWeights <- weights[, selInd[selInd!=i]]
        curFollowUpTime <- followUpTime[selInd[selInd!=i]]
        curData0 <- data0[, selInd0]
        curWeights0 <- weights0[, selInd0]
        curFollowUpTime0 <- followUpTime0[selInd0]

        mu1 <- computeMean(curData, curWeights)
        mu0 <- computeMean(curData0, curWeights0)
        var1 <- computeVar(curData, curWeights)
        var0 <- computeVar(curData0, curWeights0)

        weight <- as.numeric((mu1-mu0)/sqrt(var1 + var0))
        sortList <- sort.list(abs(weight), decreasing=TRUE)

        for (j in 1:length(nofGenes)) {
          selGenes <- sortList[1:nofGenes[j]]
          predRes[i, j] <- sum(weight[selGenes]*data[selGenes,i])
        }
      }

    ## Predict for group0
    if (length(leaveOut0)>0)
      for (i in leaveOut0) {
        curData <- data[, selInd]
        curWeights <- weights[, selInd]
        curFollowUpTime <- followUpTime[selInd]
        curData0 <- data0[, selInd0[selInd0!=i]]
        curWeights0 <- weights0[, selInd0[selInd0!=i]]
        curFollowUpTime0 <- followUpTime0[selInd0[selInd0!=i]]

        mu1 <- computeMean(curData, curWeights)
        mu0 <- computeMean(curData0, curWeights0)
        var1 <- computeVar(curData, curWeights)
        var0 <- computeVar(curData0, curWeights0)

        weight <- as.numeric((mu1-mu0)/sqrt(var1+var0))
        sortList <- sort.list(abs(weight), decreasing=TRUE)
        for (j in 1:length(nofGenes)) {
          selGenes <- sortList[1:nofGenes[j]]
          predRes0[i, j] <- sum(weight[selGenes]*data0[selGenes,i])
        }
      }

    ## Predict for groupInsitu
    if (hasInsitu) {
      if (length(leaveOutInsitu)>0) {
        curData <- data[, selInd]
        curWeights <- weights[, selInd]
        curFollowUpTime <- followUpTime[selInd]
        curData0 <- data0[, selInd0]
        curWeights0 <- weights0[, selInd0]
        curFollowUpTime0 <- followUpTime0[selInd0]

        mu1 <- computeMean(curData, curWeights)
        mu0 <- computeMean(curData0, curWeights0)
        var1 <- computeVar(curData, curWeights)
        var0 <- computeVar(curData0, curWeights0)

        weight <- as.numeric((mu1-mu0)/sqrt(var1+var0))
        sortList <- sort.list(abs(weight), decreasing=TRUE)

        for (i in leaveOutInsitu) {
          for (j in 1:length(nofGenes)) {
            selGenes <- sortList[1:nofGenes[j]]
            predResInsitu[i, j] <- sum(weight[selGenes]*dataInsitu[selGenes,i])
          }
        }
      }
    }
  }

  for (nGenes in nofGenes) {

    resMat <- computePredResMat(predRes[,paste(nGenes)], predRes0[,paste(nGenes)],
                                followUpTime, followUpTime0)
    write.table(resMat, paste(strResMat, nGenes, ".txt", sep=""), sep="\t")

    ## === Print correctly and wrongly classified and p-value ===
    print(paste("Number of genes selected:", nGenes))
    ##
    fn <- sum(!predRes[,paste(nGenes)]>0)
    tp <- sum(predRes[,paste(nGenes)]>0)
    fp <- sum(!predRes0[,paste(nGenes)]<0)
    tn <- sum(predRes0[,paste(nGenes)]<0)
    print("FN TP FP TN:")
    print(c(fn, tp, fp, tn))
    print("p-value in Fisher test, all years:")
    print(fisher.test(matrix(c(tp, fn, fp, tn), ncol=2, byrow=F), alternative="g")$p.value)
    ##
    sel <- followUpTime>selPeriodInterval[1] & followUpTime<=selPeriodInterval[2]
    sel0 <- followUpTime0>selPeriodInterval[1] & followUpTime0<=selPeriodInterval[2]
    fn <- sum(!predRes[,paste(nGenes)][sel]>0)
    tp <- sum(predRes[,paste(nGenes)][sel]>0)
    fp <- sum(!predRes0[,paste(nGenes)][sel0]<0)
    tn <- sum(predRes0[,paste(nGenes)][sel0]<0)
    print("FN TP FP TN:")
    print(c(fn, tp, fp, tn))
    print(paste("p-value in Fisher test, ", selPeriodStr, ":", sep=""))
    print(fisher.test(matrix(c(tp, fn, fp, tn), ncol=2, byrow=F), alternative="g")$p.value)
    ##
    print("")

    ## === Plot correctly and wrongly classified ===
    plotDataList <- dataList
    plotCorrectPredWithS <- predRes[,paste(nGenes)]>0
    plotCorrectPredWithoutS <- predRes0[,paste(nGenes)]<=0
    ##save(plotDataList, plotCorrectPredWithS, plotCorrectPredWithoutS,
    ##     file=paste(strFollowUpTime, nGenes, ".pdf.R", sep=""))
    plotFollowUpTimesWithPredRes(dataList, predRes[,paste(nGenes)]>0,
                                 predRes0[,paste(nGenes)]<=0,
                                 paste(strFollowUpTime, nGenes, ".pdf", sep=""))

    ## === Plot fraction of correctly classified ===

    pdf(paste(strPlotFracCorr, nGenes, ".pdf", sep=""), height=7, width=15)

    tVecStart <- min(followUpTime):(max(followUpTime)-m2)
    tVecStop <- tVecStart+m2
    tVecMean <- tVecStart+m
    isCorr <- predRes[,paste(nGenes)]>0
    fracCorr <- rep(NA, length(tVecStart))
    for (i in 1:length(tVecStart))
      fracCorr[i] <- mean(isCorr[followUpTime>=tVecStart[i] & followUpTime<=tVecStop[i]])
    keep <- !is.na(fracCorr)
    ##
    plotX <- tVecMean[keep]
    plotY <- runmed(fracCorr[keep],m2)
    plotXlim <- rev(range(dataList$followUpTime))
    ##save(plotX, plotY, plotXlim, file=paste(strPlotFracCorr, nGenes, ".pdf.red.R", sep=""))
    ##
    plot(tVecMean[keep], runmed(fracCorr[keep],m2), xlim=rev(range(dataList$followUpTime)),
         type="l", ylim =c(0,1), xlab="Follow up time (days)", ylab="Fraction correctly classified",
         cex=1.4, cex.axis=1.4, cex.lab=1.4, col=2)

    tVecStart <- min(followUpTime0):(max(followUpTime0)-m2)
    tVecStop <- tVecStart+m2
    tVecMean <- tVecStart+m
    isCorr <- predRes0[,paste(nGenes)]<=0
    fracCorr <- rep(NA, length(tVecStart))
    for (i in 1:length(tVecStart))
      fracCorr[i] <- mean(isCorr[followUpTime0>=tVecStart[i] & followUpTime0<=tVecStop[i]])
    keep <- !is.na(fracCorr)
    ##
    plotX <- tVecMean[keep]
    plotY <- runmed(fracCorr[keep],m2)
    ##save(plotX, plotY, plotXlim, file=paste(strPlotFracCorr, nGenes, ".pdf.black.R", sep=""))
    ##
    lines(tVecMean[keep], runmed(fracCorr[keep], m2),  cex=1.4, cex.axis=1.4, cex.lab=1.4, col=1)

    abline(h=0.5, lty=2)
    for (i in 0:7)
      abline(v=365*i)

    dev.off()
  }
}


#!/usr/bin/env Rscript
#----------------------------------------------------------------------------------------------------------------#
# Filename:
#   ppa_sibgc_v1.r
# Description:
#   R implementation of the Perfect Plasticity Approximation (PPA) with simply biogeochemistry (PPA-SiBGC).
# Version:
#   1.0
# Authors:
#   Adam Erickson,   Washington State University
#   Nikolay Strigul, Washington State University
# Modified:
#   June 30, 2018
# Procedure:
#   (1) Generate constant growth, mortality, and regeneration coefficients from plot data
#   (2) Generate above- and below-ground stoichiometric coefficients from databases
#   (3) Run the Sortie-PPA model:
#     (*) Generate cohorts from tree inventory data
#     (*) Initialize values for allometry, biomass, C, and N from species, type, DBH
#     (a) Soil respiration
#     (b) Regeneratation
#     (c) Sort by height descending
#     (d) Calculate cumulative crown area (CCA)
#     (e) Calculate Z* height and nearest cohort
#     (f) Mortality
#     (g) Growth
#     (h) Allometry
#     (i) Biomass fractions
#     (j) Carbon fractions
#     (k) Nitrogen fractions
#     (l) Save yearly results to CSV
#     (m) Save final results to CSV
#   (4) Compare model results against empirical data
# Notes:
#   Sortie-PPA is based on the assumption that tree canopies are perfectly plastic. This reduces
#   the variance in canopy join heights to zero, creating a single canopy join height known as z*.
#   The approximation allows for model simplification and mathematical tractability. The spatial
#   location of trees is discarded. Growth and mortality are modeled by their mean values for each
#   species and type (adults = above z*; saplings = below z*). Coefficients are used to modify
#   growth rates per the fraction of light received by trees above and below the z* threshold.
#   Aboveground biomass is modeled using equations from Chojnacky, Heath, and Jenkins (2014).
#   Belowground biomass as well as C,N dynamics are modeled using allometry and stoichiometry.
# Examples:
#   Rscript --vanilla ppa_v50.r
#   Rscript --vanilla ppa_v50.r --wd /Users/null/test --verbose
#----------------------------------------------------------------------------------------------------------------#
Version <- "5.0"

# Debugging
options(error=quote({dump.frames(to.file=TRUE); q()}))

# Print banner and pause
Banner <- readLines("sortie_ppa_ansi_shadow.txt")
cat(Banner, sep="\n")

# Print version
message("")
message("Authors: Adam Erickson, Nikolay Strigul")
message(paste("Version:", Version, "\n"))
Sys.sleep(0)

# Remove existing outputs
outputs_files   <- dir("outputs", recursive=FALSE, full.names=TRUE)
outputs_deleted <- file.remove(outputs_files)

# Fetch trailing command line arguments
args <- commandArgs(trailingOnly=TRUE)

# Default verbosity setting
Verbose <- FALSE

# Set working directory
if (length(args) == 0) {
  message(paste0("Working directory: ", getwd()))
} else if (length(args) == 1) {
  Verbose <- args[1] %in% c("--v", "--verbose")
  stopifnot(Verbose)
} else if (length(args) == 2) {
  flag   <- args[1]
  stopifnot(flag %in% c("--wd", "--dir"))
  folder <- args[2]
  if (flag=="--wd" || flag=="--dir") {
    setwd(folder)
    message(paste("Working directory:", getwd()))
  } else {
    message("Flag not recognized.")
  }
} else if (length(args) == 3) {
  flag   <- args[1]
  stopifnot(flag %in% c("--wd", "--dir"))
  folder  <- args[2]
  setwd(folder)
  message(paste("Working directory:", getwd()))
  Verbose <- args[3] %in% c("--v", "--verbose")
  stopifnot(Verbose)
} else {
  stop("Error: Only 0 or 2 arguments may be passed.", call.=FALSE)
}

# Libraries #

# Functions #

# Round to the nearest integer by step
round_int <- function(x, step) {
  return(step * round(x / step))
}

# Bin trees into cohorts by rounding DBH to the nearest cm; check n-trees
# Expects CSV file with species, type, dbh, age (optional)
GenerateCohorts <- function(Trees, interval=1) {
  n_trees <- nrow(Trees)
  Trees$dbh <- round_int(Trees$dbh, interval)
  if("age" %in% tolower(colnames(Trees))) {
    age <- aggregate(Trees$age, by=list(Trees$species, Trees$type, Trees$dbh), FUN=mean)
    colnames(age) <- c("species","type","dbh","age")
    Trees <- subset(Trees, select= -c(age))
    Trees <- merge(Trees, age, by=c("species","type","dbh"))
  }
  cohorts <- data.frame(table(Trees$species, Trees$type, Trees$dbh))
  colnames(cohorts) <- c("species","type","dbh","n_trees")
  cohorts$n_trees <- cohorts$n_trees + 1
  Trees <- merge(Trees, cohorts, by=c("species","type","dbh"))
  Trees <- Trees[!duplicated(Trees[,c("species","type","dbh")]), ]
  Trees <- Trees[Trees$dbh > 0 & !is.na(Trees$n_trees), ]
  Trees$id <- 1:nrow(Trees)
  if ("age" %in% tolower(colnames(Trees))) {
    Trees <- Trees[, c("id","species","type","age","dbh","n_trees")]
  } else {
    Trees <- Trees[, c("id","species","type","dbh","n_trees")]
  }
  message(paste(n_trees, "trees merged to", nrow(Trees), "cohorts containing",
                sum(Trees$n_trees), "trees"))
  return(Trees)
}

# Create biomass, C, and N compartments
Initialize <- function(Trees, ...) {
  # Create columns
  Trees$height              <- NA
  Trees$crown_l             <- NA
  Trees$crown_r             <- NA
  Trees$crown_a             <- NA
  Trees$ba                  <- NA
  Trees$crown_a_cumsum      <- NA
  Trees$biomass_ag          <- NA
  Trees$biomass_stem        <- NA
  Trees$biomass_branch      <- NA
  Trees$biomass_leaf        <- NA
  Trees$biomass_root_coarse <- NA
  Trees$biomass_root_fine   <- NA
  Trees$biomass_soil        <- NA
  Trees$biomass_bg          <- NA
  Trees$biomass_total       <- NA
  Trees$c_ag                <- NA
  Trees$c_bg                <- NA
  Trees$c_total             <- NA
  Trees$anpp                <- NA
  Trees$n_ag                <- NA
  Trees$n_bg                <- NA
  Trees$n_total             <- NA
  Trees$annp                <- NA
  # Update each species and type; vectorized
  for (species in unique(Trees$species)) {
    if (!species %in% AllometryLUT$species) { stop("Species not found in allometry table") }
    s <- Trees$species==species
    for (type in unique(Trees[s,]$type)) {
      st <- Trees$species==species & Trees$type==type
      index <- AllometryLUT$species==species & AllometryLUT$type==type
      allometry <- AllometryLUT[index,]
      Trees[st,]$height  <- 1.35 + (30-1.35) * (1-exp(-(allometry$h_coeff * Trees[st,]$dbh)))
      Trees[st,]$height  <- ifelse(Trees[st,]$height > 30, 30, Trees[st,]$height) # limit height to 30m
      Trees[st,]$type    <- ifelse(Trees[st,]$dbh > 10, "adult", "sapling")
      Trees[st,]$crown_l <- allometry$cd  * Trees[st,]$dbh
      Trees[st,]$crown_r <- allometry$cr1 * Trees[st,]$dbh^allometry$cr2
      Trees[st,]$crown_a <- Trees[st,]$crown_r^2 * pi
      Trees[st,]$ba      <- Trees[st,]$dbh^2 * 0.00007854 # forester's constant for DBH (cm); m2
    }
    # Biomass allocation or partitioning
    if (!species %in% BiomassLUT$species) { stop("Species not found in biomass table") }
    index <- BiomassLUT$species==species
    biomass <- BiomassLUT[index,]
    if (CohortMode) {
      Trees[s,]$biomass_ag <- exp(biomass$b0 + biomass$b1 * log(Trees[s,]$dbh)) * Trees[s,]$n_trees
    } else {
      Trees[s,]$biomass_ag <- exp(biomass$b0 + biomass$b1 * log(Trees[s,]$dbh))
    }
    Trees[s,]$biomass_stem        <- Trees[s,]$biomass_ag * biomass$fraction_stem
    Trees[s,]$biomass_branch      <- Trees[s,]$biomass_ag * biomass$fraction_branch
    Trees[s,]$biomass_leaf        <- Trees[s,]$biomass_ag * biomass$fraction_leaf
    Trees[s,]$biomass_root_coarse <- Trees[s,]$biomass_ag * exp(-1.4485 - 0.03476 * log(Trees[s,]$dbh))
    Trees[s,]$biomass_root_fine   <- Trees[s,]$biomass_ag * exp(-1.8629 - 0.77534 * log(Trees[s,]$dbh))
    Trees[s,]$biomass_soil        <- Trees[s,]$biomass_ag * biomass$fraction_soil
    Trees[s,]$biomass_bg          <- Trees[s,]$biomass_root_coarse + Trees[s,]$biomass_root_fine +
                                     Trees[s,]$biomass_soil
    Trees[s,]$biomass_total       <- Trees[s,]$biomass_ag + Trees[s,]$biomass_bg
    # C fraction
    #index <- CarbonLUT$species==species
    carbon <- CarbonLUT #[index,]
    Trees[s,]$c_ag <- Trees[s,]$biomass_ag *
      ((biomass$fraction_stem   * carbon$fraction_stem)   +
       (biomass$fraction_branch * carbon$fraction_branch) +
       (biomass$fraction_leaf   * carbon$fraction_leaf))
    Trees[s,]$c_bg <- Trees[s,]$biomass_ag *
      ((biomass$fraction_root * carbon$fraction_root) +
       (biomass$fraction_soil * carbon$fraction_soil))
    Trees[s,]$c_total <- Trees[s,]$c_ag + Trees[s,]$c_bg
    Trees[s,]$anpp    <- NA
    # C:N stoichiometry
    if (!species %in% StoichiometryLUT$species) { stop("Species not found in stoichiometry table") }
    index <- StoichiometryLUT$species==species
    stoichiometry <- StoichiometryLUT[index,]
    Trees[s,]$n_ag <- Trees[s,]$c_ag /
      ((biomass$fraction_stem   * stoichiometry$cn_stem)   +
       (biomass$fraction_branch * stoichiometry$cn_branch) +
       (biomass$fraction_leaf   * stoichiometry$cn_leaf))
    Trees[s,]$n_bg <- Trees[s,]$c_bg /
      ((biomass$fraction_root * stoichiometry$cn_root)  +
       (biomass$fraction_soil * stoichiometry$cn_soil))
    Trees[s,]$n_total <- Trees[s,]$n_ag + Trees[s,]$n_bg
    Trees[s,]$annp    <- NA
  }
  return(Trees)
}

# Ensure column names and tree type are lower case
ensure_lowercase <- function(Trees) {
  colnames(Trees) <- tolower(colnames(Trees))
  Trees$type <- tolower(Trees$type)
  return(Trees)
}

# Check if year is a leap year (366 days instead of 365)
leap_year <- function(year) {
  return(ifelse((year %%4 == 0 & year %%100 != 0) | year %%400 == 0, TRUE, FALSE))
}

# Soil respiration, monthly mean; heterotrophic + autotrophic
# g C m-2 day-1; kg C m-2 day-1
# Parameters:
#  Ta = monthly mean temperature (°C)
#  P  = monthly mean precipitation (cm)
# Raich, Potter, Bhagawati, 2002, Interannual variability in global soil respiration, 1980-94, Global Change Biology, 8, pp. 800-12.
# https://onlinelibrary.wiley.com/doi/abs/10.1046/j.1365-2486.2002.00511.x
respiration_soil <- function(Ta, P) {
  if (Ta < -13.3) {
    Rs <- 0
  } else {
    if (Ta > 33.5) { Ta <- 33.5 } # bound the temperature response
    e  <- exp(1)  # Euler's constant
    Q  <- 0.05452 # soil respiration rate change wrt temperature (°C-1)
    F  <- 1.250   # soil respiration rate at 0°C (g C m-2 day-1)
    K  <- 4.259   # hyperbolic respiration-rainfall curve half-saturation constant (mm month-1)
    Rs <- F * e^(Q * Ta) * (P / (K + P))
  }
  return(Rs / 1000)
}

# Simple SOC model
# Mg C ha-1 cm-1; kg C m-2; midpoint of profile depth; Approximates integral in 1 cm steps
# Domke et al. (2017) Toward inventory-based estimates of soil organic carbon in forests of the United States, Ecological Applications, 27(4), pp. 1223–1235.
# https://www.fs.fed.us/nrs/pubs/jrnl/2017/nrs_2017_domke_001.pdf
soc_depth = function(order, depth_cm=100) {
  soc_table = data.frame(
    order     = c("All","Alfisols","Andisols","Aridisols","Entisols","Histosols","Inceptisols",
                  "Mollisols","Spodosols","Ultisols","Vertisols"),
    intercept = c(1.1795,1.1122,1.3837,0.2065,0.9300,1.6227,1.1631,1.0163,1.4262,1.1576,0.5145),
    slope     = c(-0.8228,-0.8330,-0.8425,-0.1300,-0.7207,-1.0109,-0.7331,-0.6214,-0.9801,-0.8867,-0.2427)
  )
  coeffs = as.numeric(soc_table[soc_table$order==order,][,c("intercept","slope")])
  soc    = sapply(seq(1, depth_cm, 1), function(x) 10^(coeffs[1] + coeffs[2] * log10(x)))
  soc    = sum(soc) / 10  # convert to kg m-2 integrated over depth
  return(soc)
}

# Time #
start_time <- proc.time()
loop_times <- c()

# Data #

# Load lookup tables (LUTs) into memory; expects CSV files in lut folder
Configuration    <- read.csv("configuration.csv",     stringsAsFactors=FALSE, nrows=1)
Trees            <- read.csv("trees.csv",             stringsAsFactors=FALSE)
Climate          <- read.csv("climate.csv",           stringsAsFactors=FALSE)
GrowthLUT        <- read.csv("lut/growth.csv",        stringsAsFactors=FALSE)
MortalityLUT     <- read.csv("lut/mortality.csv",     stringsAsFactors=FALSE)
RegenerationLUT  <- read.csv("lut/regeneration.csv",  stringsAsFactors=FALSE)
AllometryLUT     <- read.csv("lut/allometry.csv",     stringsAsFactors=FALSE)
BiomassLUT       <- read.csv("lut/biomass.csv",       stringsAsFactors=FALSE)
StoichiometryLUT <- read.csv("lut/stoichiometry.csv", stringsAsFactors=FALSE)
CarbonLUT        <- read.csv("lut/carbon.csv",        stringsAsFactors=FALSE, nrows=1)

# Model #

# Optional: process in parallel
#nCores <- as.integer(Configuration$n_cores)
#if (nCores > 1) {
#  library(doParallel)
#  cl <- parallel::makeCluster(nCores)
#  doParallel::registerDoParallel(cl)
#}

# Optional: Generate cohorts from initial tree list
CohortMode <- as.logical(Configuration$cohort_mode)
if (CohortMode == TRUE) {
  message("Generating cohorts...")
  Trees <- GenerateCohorts(Trees)
}

# Initialize tree biomass
message("Initializing...")
Trees <- Initialize(Trees)

# Ensure column names and tree type are lower case
Trees <- ensure_lowercase(Trees)

# Number of years to run model; e.g., 2000-2049 (50 years)
StartYear <- as.numeric(Configuration$start_year)
EndYear   <- as.numeric(Configuration$end_year)
Years     <- StartYear:EndYear # 200 years

# Amount of light suppressed cohorts receive
UnderstoryAdult   <- as.numeric(Configuration$understory_adult)   # 0.1
UnderstorySapling <- as.numeric(Configuration$understory_sapling) # 0.7

# id placeholder
id_holder <- nrow(Trees)

# Run the simulation
message("Starting simulation...")
message("=========================================================================")
for (year in Years) {

  loop_start_time <- proc.time()

  if (Verbose) {
    message("=========================================================================")
    message(paste("Year:", year))
    message(paste("n-Trees:", nrow(Trees)))
    message("=========================================================================")
  }

  # Append or update year; vectorized
  Trees$year <- year

  # Increment tree age; vectorized; regeneration yields age 0
  Trees$age <- Trees$age + 1

  # Calculate soil respiration
  if (Verbose) {
    message("Computing soil respiration...")
  }
  climate  <- Climate[Climate$year==year,]
  n_days <- list(
    "1"  = 31,
    "2"  = ifelse(leap_year(year), 29, 28),
    "3"  = 31,
    "4"  = 30,
    "5"  = 31,
    "6"  = 30,
    "7"  = 31,
    "8"  = 31,
    "9"  = 30,
    "10" = 31,
    "11" = 30,
    "12" = 31
  )
  Rs_month <- c()
  for (month in climate$month) {
    month_days <- as.numeric(n_days[as.character(month)])
    month_i    <- climate[climate$month==month,]
    Rs         <- respiration_soil(Ta=month_i$temperature, P=month_i$precipitation)
    Rs         <- Rs * month_days
    Rs_month   <- c(Rs_month, Rs)
  }
  Rs_year        <- sum(Rs_month) # * Configuration$field_area
  respiration_df <- data.frame(year=year, r_soil=Rs_year)

  # Calculate soil organic C and N
  c_so   <- soc_depth(order=Configuration$soil_order, depth_cm=100)
  n_so   <- c_so / mean(StoichiometryLUT$cn_soil, na.rm=TRUE)
  som_df <- data.frame(year=year, c_so=c_so, n_so=n_so)

  # Sort trees by descending height; vectorized
  if (Verbose) {
    message("Sorting...")
  }
  Trees <- Trees[order(Trees$height, decreasing=TRUE), ]

  # Calculate cumulative crown area; vectorized
  if (Verbose) {
    message("Calculating culumative crown area...")
  }
  if (CohortMode) {
    Trees$crown_a_cumsum <- cumsum(Trees$crown_a * Trees$n_trees)
  } else {
    Trees$crown_a_cumsum <- cumsum(Trees$crown_a)
  }

  # Calculate z* and closest cohort; vectorized
  if (Verbose) {
    message("Calculating Z*...")
  }
  index    <- which.min(abs(Trees$crown_a_cumsum - Configuration$field_area))
  zstar_df <- Trees[index,]
  if (Verbose) {
    message(paste("Z* height:", zstar_df$height))
  }

  # Dataframe placeholders
  mortality_df <- data.frame(matrix(ncol=nrow(Trees), nrow=0))
  colnames(mortality_df) <- colnames(Trees)
  regeneration_df <- data.frame(matrix(ncol=nrow(Trees), nrow=0))
  colnames(regeneration_df) <- colnames(Trees)

  # Loop over each species
  for (species in unique(Trees$species)) {

    # Skip species not found in lookup tables
    if (!species %in% GrowthLUT$species) {
      next
    }

    # Species index
    s <- Trees$species==species

    # Regeneration; species
    if (Verbose) {
      message("Applying regeneration...")
    }
    n_replicates <- length(which(s))
    index <- RegenerationLUT$species==species
    n_saplings <- RegenerationLUT[index,]$mean
    # new sapling used in regeneration
    new_sapling <- data.frame(species=species, type="sapling", age=0, dbh=1,
      height=2, crown_r=0.1, crown_l=0.845, crown_a=0.0314, ba=0.00008,
      crown_a_cumsum=NA, biomass_ag=NA, biomass_stem=NA, biomass_branch=NA,
      biomass_leaf=NA, biomass_root_coarse=NA, biomass_root_fine=NA,
      biomass_soil=NA, biomass_bg=NA, biomass_total=NA, c_ag=NA, c_bg=NA,
      c_total=NA, anpp=NA, n_ag=NA, n_bg=NA, n_total=NA, annp=NA, year=year)
    if (CohortMode & n_replicates > 0) {
      new_sapling$id <- id_holder
      new_sapling$n_trees <- n_saplings
      Trees <- rbind(Trees, new_sapling)
      regeneration_df <- rbind(regeneration_df, new_sapling)
      id_holder <- id_holder + 1 #+ n_replicates
    } else if (n_replicates > 0){
      n_trees <- nrow(trees)
      new_saplings <- do.call(rbind, replicate(n_replicates * n_saplings, new_sapling, simplify=FALSE))
      new_saplings$id <- id_holder:(id_holder + (n_replicates * n_saplings) - 1)
      Trees <- rbind(Trees, new_saplings)
      regeneration_df <- rbind(regeneration_df, new_saplings)
      id_holder <- id_holder + (n_replicates * n_saplings)
    }

    # Recalculate species index after regeneration
    s <- Trees$species==species

    # Loop over each type within each species
    for (type in unique(Trees[s,]$type)) {

      # Species and type index
      st <- Trees$species==species & Trees$type==type

      # Mortality; species & type
      if (Verbose) {
        message("Applying mortality...")
      }
      index <- MortalityLUT$species==species & MortalityLUT$type==type
      mortality <- MortalityLUT[index,]
      random_uniform <- runif(1, min=0, max=1)
      if (random_uniform < mortality$probability) {
        kill_fraction <- runif(1, min=0, max=1) # random uniform
        if (CohortMode) {
          kill_n <- round(nrow(Trees[st,]) * kill_fraction)
          if (kill_n > 0) {
            # Kill fraction of cohorts
            kill_index <- sample(which(st), kill_n, replace=FALSE)
            mortality_df <- rbind(mortality_df,  Trees[kill_index,])
            Trees <- Trees[-kill_index,] # kill trees
            # Optional: kill fraction within cohorts and then remove dead cohorts
            #Trees[st,]$n_trees <- Trees[st,]$n_trees - kill_n # kill trees
            #mortality_df <- cbind(data.frame(year=year), Trees[st,])
            #mortality_df$n_trees <- round(mortality_df$n_trees * kill_fraction)
          }
          #dead_cohorts <- Trees$n_trees < 1 | is.na(Trees$n_trees) | is.na(Trees$dbh)
          #if(any(dead_cohorts)) {
          #  Trees <- Trees[-which(dead_cohorts),] # remove dead trees/cohorts
          #  message("Removal")
          #  stopifnot(!anyNA(Trees[st,]$dbh) | !anyNA(Trees[st,]$n_trees)) # "PIAB" "sapling"
          #}
        } else {
          kill_n <- round(nrow(Trees[st,]) * kill_fraction)
          if (kill_n > 0) {
            kill_index <- sample(which(st), kill_n, replace=FALSE)
            mortality_df <- rbind(mortality_df, Trees[kill_index,])
            Trees <- Trees[-kill_index,] # kill trees
          }
        }
      }

      # Recalculate species and type index after mortality
      st <- Trees$species==species & Trees$type==type

      # Skip ahead if species or type is all dead
      if (nrow(Trees[st,]) < 1) {
        next
      }

      # Growth; species & type
      index <- GrowthLUT$species==species & GrowthLUT$type==type
      growth <- GrowthLUT[index,]
      if (type=="adult") {
        Trees[st,]$dbh <- ifelse(Trees[st,]$crown_a_cumsum < Configuration$field_area,
                                 Trees[st,]$dbh + growth$mean,
                                 Trees[st,]$dbh + growth$mean * UnderstoryAdult)
      } else if (type=="sapling") {
        Trees[st,]$dbh <- Trees[st,]$dbh + growth$mean * UnderstorySapling
      } else {
        message("Error: Type not recognized")
      }

      # Allometry; species & type
      if (Verbose) {
        message("Calculating allometry...")
      }
      index <- AllometryLUT$species==species & AllometryLUT$type==type
      allometry <- AllometryLUT[index,]
      Trees[st,]$height  <- 1.35 + (30-1.35) * (1-exp(-(allometry$h_coeff * Trees[st,]$dbh)))
      Trees[st,]$height  <- ifelse(Trees[st,]$height > 30, 30, Trees[st,]$height) # limit height to 30m
      Trees[st,]$type    <- ifelse(Trees[st,]$dbh > 10, "adult", "sapling")
      Trees[st,]$crown_l <- allometry$cd  * Trees[st,]$dbh
      Trees[st,]$crown_r <- allometry$cr1 * Trees[st,]$dbh^allometry$cr2
      Trees[st,]$crown_a <- Trees[st,]$crown_r^2 * pi
      Trees[st,]$ba      <- Trees[st,]$dbh^2 * 0.00007854 # forester's constant for DBH (cm); m2
    } # end type loop

    # Calculate species index after regeneration and mortality
    s <- Trees$species==species

    # Skip ahead if species is all dead
    if (nrow(Trees[s,]) < 1) {
      next
    }

    # Biomass expansion factors and allocation or partitioning; species
    # DBH to AGB and AGB to BGB (Chojnacky, Heath, Jenkins, 2014)
    # To add...? BGB to leaf and steam (Enquist and Niklas, 2002)
    if (Verbose) {
      message("Calculating biomass...")
    }
    index <- BiomassLUT$species==species
    biomass <- BiomassLUT[index,]
    if (CohortMode) {
      Trees[s,]$biomass_ag <- exp(biomass$b0 + biomass$b1 * log(Trees[s,]$dbh)) * Trees[s,]$n_trees
    } else {
      Trees[s,]$biomass_ag <- exp(biomass$b0 + biomass$b1 * log(Trees[s,]$dbh))
    }
    Trees[s,]$biomass_stem        <- Trees[s,]$biomass_ag * biomass$fraction_stem
    Trees[s,]$biomass_branch      <- Trees[s,]$biomass_ag * biomass$fraction_branch
    Trees[s,]$biomass_leaf        <- Trees[s,]$biomass_ag * biomass$fraction_leaf
    Trees[s,]$biomass_root_coarse <- Trees[s,]$biomass_ag * exp(-1.4485 - 0.03476 * log(Trees[s,]$dbh))
    Trees[s,]$biomass_root_fine   <- Trees[s,]$biomass_ag * exp(-1.8629 - 0.77534 * log(Trees[s,]$dbh))
    Trees[s,]$biomass_soil        <- Trees[s,]$biomass_ag * biomass$fraction_soil
    Trees[s,]$biomass_bg          <- Trees[s,]$biomass_root_coarse + Trees[s,]$biomass_root_fine +
                                     Trees[s,]$biomass_soil
    Trees[s,]$biomass_total       <- Trees[s,]$biomass_ag + Trees[s,]$biomass_bg

    # Year naught total C and N for ANPP and ANNP calculations
    c_total_previous <- Trees[s,]$c_total
    n_total_previous <- Trees[s,]$n_total

    # C fraction; species
    if (Verbose) {
      message("Calculating C fraction...")
    }
    #index <- CarbonLUT$species==species
    carbon <- CarbonLUT #[index,]
    Trees[s,]$c_ag <- Trees[s,]$biomass_ag *
      (biomass$fraction_stem   * carbon$fraction_stem) +
      (biomass$fraction_branch * carbon$fraction_branch) +
      (biomass$fraction_leaf   * carbon$fraction_leaf)
    Trees[s,]$c_bg <- Trees[s,]$biomass_ag *
      (biomass$fraction_root * carbon$fraction_root) +
      (biomass$fraction_soil * carbon$fraction_soil)
    Trees[s,]$c_total <- Trees[s,]$c_ag + Trees[s,]$c_bg
    if (year > min(Years)) {
      Trees[s,]$anpp <- Trees[s,]$c_total - c_total_previous
    }
    # C:N stoichiometry; species
    if (Verbose) {
      message("Calculating N fraction...")
    }
    index <- StoichiometryLUT$species==species
    stoichiometry <- StoichiometryLUT[index,]
    Trees[s,]$n_ag <- Trees[s,]$c_ag /
      (biomass$fraction_stem   * stoichiometry$cn_stem)   +
      (biomass$fraction_branch * stoichiometry$cn_branch) +
      (biomass$fraction_leaf   * stoichiometry$cn_leaf)
    Trees[s,]$n_bg <- Trees[s,]$c_bg /
      (biomass$fraction_root * stoichiometry$cn_root) +
      (biomass$fraction_soil * stoichiometry$cn_soil)
    Trees[s,]$n_total <- Trees[s,]$n_ag + Trees[s,]$n_bg
    if (year > min(Years)) {
      Trees[s,]$annp <- Trees[s,]$n_total - n_total_previous
    }
  } # end species loop

  # Fix order of regeneration_df columns
  regeneration_df <- regeneration_df[,colnames(Trees)]

  # Calculate NEE and add to fluxes; NEE calculation based on Equation 1 in:
  #   Clark et al. (2001) Measuring Net Primary Production in Forests: Concepts and Field Methods,
  #   Ecological Applications, 11(2), pp. 356-370.
  # and
  #   Reichstein et al. (2005) On the separation of net ecosystem exchange into assimilation and
  #   ecosystem respiration: review and improved algorithm, Global Change Biology, 11, pp. 1424–1439.
  # Convert C to CO2 in ANPP
  fluxes_df <- data.frame(
    year   = year,
    nee    = (respiration_df$r_soil * Configuration$field_area) - sum(Trees$anpp, na.rm=TRUE),
    r_soil = (respiration_df$r_soil * Configuration$field_area)
  )

  # Save annual tree/cohort results
  write.csv(Trees, file=paste0("outputs/trees_", year, ".csv"), row.names=FALSE,
    fileEncoding="UTF-8")

  # Append results to CSV
  header_boolean <- year == Years[1]

  suppressWarnings(write.table(som_df, file="outputs/som.csv",
    append=TRUE, col.names=header_boolean, row.names=FALSE, sep=",", fileEncoding="UTF-8"))
  suppressWarnings(write.table(fluxes_df, file="outputs/fluxes.csv",
    append=TRUE, col.names=header_boolean, row.names=FALSE, sep=",", fileEncoding="UTF-8"))
  suppressWarnings(write.table(zstar_df, file="outputs/zstar.csv",
    append=TRUE, col.names=header_boolean, row.names=FALSE, sep=",", fileEncoding="UTF-8"))
  suppressWarnings(write.table(regeneration_df, file="outputs/regeneration.csv",
    append=TRUE, col.names=header_boolean, row.names=FALSE, sep=",", fileEncoding="UTF-8"))
  # Mortality is non-deterministic
  if (nrow(mortality_df) > 0 | header_boolean) {
    suppressWarnings(write.table(mortality_df, file="outputs/mortality.csv",
      append=TRUE, col.names=header_boolean, row.names=FALSE, sep=",", fileEncoding="UTF-8"))
  }

  # Calculate loop time
  loop_time <- proc.time() - loop_start_time
  loop_time <- as.numeric(loop_time["elapsed"])
  message(paste(paste0("Year: ", year, ","), "Duration (sec):", round(loop_time, 2)))
  loop_times <- c(loop_times, loop_time)
} # end year loop

# Calculate total time
total_time <- proc.time() - start_time
total_time <- as.numeric(total_time["elapsed"])
message("=========================================================================")
message("Simulation complete")
message(paste("Years:", length(Years)))
message(paste("Duration (sec):", round(total_time, 2)))
message("=========================================================================")

# Export loop times to CSV
loop_times_df <- data.frame(year=Years, time=loop_times)
write.table(loop_times_df, file="outputs/loop_times.csv", col.names=TRUE,
  row.names=FALSE, sep=",", fileEncoding="UTF-8")

# End #


#' Calculate percentage change between two years using Bayesian output
#'
#' Using the data returned from occDetModel/occDetFunc this function models a
#' trend between two years for each iteration of the models. Several options are
#' available for the method used to calculate the trend. This distribution of the results is used to
#' calculate the mean estimate and the 95% credibale intervals.
#'
#' @param bayesOut occDet object as returned from occDetModel or occDetFunc.
#' @param firstYear numeric, the first year over which the change is to be estimated. Defaults to the final year in the dataset
#' @param lastYear numeric, the last year over which the change is to be estimated. Defaults to the first year in the dataset
#' @param change A character string that specifies the type of change to be calculated, the default
#' is annual growth rate.  See details for options.
#' @param region A character string specifying the region name if change is to be determined regional estimates of occupancy.
#' Region names must match those in the model output.
#'
#'
#' @details \code{change} is used to specify which change measure to be calculated.
#' There are four options to choose from: difference, percentdif, growthrate and
#' lineargrowth.
#'
#' \code{difference} calculates the simple difference between the first and last year.
#'
#' \code{percentdif} calculates the percentage difference between the first and last year.
#'
#' \code{growthrate} calculates the annual growth rate across years.
#'
#' \code{lineargrowth} calculates the linear growth rate from a linear model.
#'
#' @return A list giving the mean, median, credible intervals and raw data from the
#' estimations.
#' @examples
#' \dontrun{
#'
#' #' # Create data
#' n <- 15000 #size of dataset
#' nyr <- 20 # number of years in data
#' nSamples <- 100 # set number of dates
#' nSites <- 50 # set number of sites
#'
#' # Create somes dates
#' first <- as.Date(strptime("1980/01/01", "%Y/%m/%d"))
#' last <- as.Date(strptime(paste(1980+(nyr-1),"/12/31", sep=''), "%Y/%m/%d"))
#' dt <- last-first
#' rDates <- first + (runif(nSamples)*dt)
#'
#' # taxa are set as random letters
#' taxa <- sample(letters, size = n, TRUE)
#'
#' # three sites are visited randomly
#' site <- sample(paste('A', 1:nSites, sep=''), size = n, TRUE)
#'
#' # the date of visit is selected at random from those created earlier
#' survey <- sample(rDates, size = n, TRUE)
#'
#' # run the model with these data for one species
#' results <- occDetModel(taxa = taxa,
#'                        site = site,
#'                        survey = survey,
#'                        species_list = c('a','m','g'),
#'                        write_results = FALSE,
#'                        n_iterations = 1000,
#'                        burnin = 10,
#'                        thinning = 2)
#'
#'  # estimate the change for one species
#'  change <- occurrenceChange(firstYear = 1990,
#'                             lastYear = 1999,
#'                             bayesOut = results$a)
#' }
#' @export

occurrenceChange <- function(bayesOut, firstYear=NULL, lastYear=NULL, change = 'growthrate', region = NULL){

  # error checks for years (or set to defaults)
  if(is.null(firstYear))
    firstYear <- bayesOut$min_year
  else
    if(!firstYear %in% bayesOut$min_year:bayesOut$max_year) stop('firstYear must be in the year range of the data')

  if(is.null(lastYear))
    lastYear <- bayesOut$max_year
  else
    if(!lastYear %in% bayesOut$min_year:bayesOut$max_year) stop('lastYear must be in the year range of the data')

  # error checks for change
  if(!class(change) == 'character') stop('Change must be a character string identifying the change metric.  Either: difference, percentdif, growthrate or lineargrowth')
  if(!change %in% c('difference', 'percentdif', 'growthrate', 'lineargrowth')) stop('The change metric must be one of the following: difference, percentdif, growthrate or lineargrowth')

  # error check for region
  if(!is.null(region)){
    if(!class(region) == 'character') stop('region must be a character string identifying the regional estimates that change is to be calculated for.')
    if(!region %in% bayesOut$regions) stop('region must match that used in the model output file, check spelling.')
  }

  # extract the sims list, if there is a region code, use the psi.fs for that region
  if(!is.null(region)){
    reg_code <- paste("psi.fs.r_", region, sep = "")

    occ_it <- bayesOut$BUGSoutput$sims.list
    occ_it <- occ_it[[grep(reg_code, names(occ_it))]]

  }else{
    occ_it <- bayesOut$BUGSoutput$sims.list$psi.fs

  }

  colnames(occ_it) <- bayesOut$min_year:bayesOut$max_year
  years <- firstYear:lastYear

  ## edit values that are 0 or 1 to prevent estimates of inf later on
  #occ_it[occ_it == 0] <- 0.0001
  #occ_it[occ_it == 1] <- 0.9999

  ### loops depend on which change metric has been specified

  if(change == 'lineargrowth'){
      prediction <- function(years, series){

      # cut data
      data_table <- data.frame(occ = series[as.character(years)], year = (years - min(years) + 1))

      # run model
      model <- glm(occ ~ year, data = data_table, family = 'quasibinomial')

      # create predicted values
      predicted <- plogis(predict(model))
      names(predicted) <- years

      # build results
      results <- data.frame(predicted[1], predicted[length(predicted)], row.names = NULL)
      colnames(results) <- as.character(c(min(years), max(years)))
      results$change = (results[,2] - results[,1]) / results[,1]

      return(results)

    }

    res_tab <- do.call(rbind, apply(X = occ_it, MARGIN = 1, years = years, FUN = prediction))

  } # end of loop for linear growth rate

  if(change == 'difference'){
    first <- years[1]
    last <- years[length(years)]
    res_tab <- data.frame(occ_it[, colnames(occ_it) == first],
                          occ_it[, colnames(occ_it) == last],
                          row.names = NULL)
    colnames(res_tab) <- as.character(c(min(years), max(years)))
    res_tab$change = res_tab[,2] - res_tab[,1]
  } # end of loop for simple difference

  if(change == 'percentdif'){
    first <- years[1]
    last <- years[length(years)]
    res_tab <- data.frame(occ_it[, colnames(occ_it) == first],
                          occ_it[, colnames(occ_it) == last],
                          row.names = NULL)

    ## edit 0 in the first year with some small value to prevent Infinite trends
    res_tab[,1][res_tab[,1] == 0] <- 0.0000001

    colnames(res_tab) <- as.character(c(min(years), max(years)))
    res_tab$change = ((res_tab[,2] - res_tab[,1])/res_tab[,1])*100
  } # end of loop for percentage difference

  if(change == 'growthrate'){
    nyr <- length(years)
    first <- years[1]
    last <- years[length(years)]
    res_tab <- data.frame(occ_it[, colnames(occ_it) == first],
                          occ_it[, colnames(occ_it) == last],
                          row.names = NULL)

    ## edit 0 in the first year with some small value to prevent Infinite trends
    res_tab[,1][res_tab[,1] == 0] <- 0.0000001

    colnames(res_tab) <- as.character(c(min(years), max(years)))
    res_tab$change = (((res_tab[,2]/res_tab[,1])^(1/nyr))-1)*100
  } # end of loop for growth rate

  # return the mean, quantiles, and the data
  return(list(mean = mean(res_tab$change),
              median = median(res_tab$change),
              CIs = quantile(res_tab$change, probs = c(0.025, 0.975)),
              data = res_tab))

}


mcmcMH <- function(target, init.theta, proposal.sd = NULL,
                   n.iterations, covmat = NULL,
                   limits=list(lower = NULL, upper = NULL),
                   adapt.size.start = NULL, adapt.size.cooling = 0.99,
                   adapt.shape.start = NULL, adapt.shape.stop = NULL,
                   print.info.every = n.iterations/100,
                   verbose = FALSE, max.scaling.sd = 50) {

  # initialise theta
  theta.current <- init.theta
  theta.propose <- init.theta

  # extract theta of gaussian proposal
  covmat.proposal <- covmat
  lower.proposal <- limits$lower
  upper.proposal <- limits$upper

  # reorder vector and matrix by names, set to default if necessary
  theta.names <- names(init.theta)
  if (!is.null(proposal.sd) && is.null(names(proposal.sd))) {
    names(proposal.sd) <- theta.names
  }

  if (is.null(covmat.proposal)) {
    if (is.null(proposal.sd)) {
      proposal.sd <- init.theta/10
    }
    covmat.proposal <-
      matrix(diag(proposal.sd[theta.names]^2, nrow = length(theta.names)),
             nrow = length(theta.names),
             dimnames = list(theta.names, theta.names))
  } else {
    covmat.proposal <- covmat.proposal[theta.names,theta.names]
  }

  if (is.null(lower.proposal)) {
    lower.proposal <- init.theta
    lower.proposal[] <- -Inf
  } else {
    lower.proposal <- lower.proposal[theta.names]
  }

  if (is.null(upper.proposal)) {
    upper.proposal <- init.theta
    upper.proposal[] <- Inf
  } else {
    upper.proposal <- upper.proposal[theta.names]
  }

  # covmat init
  covmat.proposal.init <- covmat.proposal

  adapting.size <- FALSE # will be set to TRUE once we start
  # adapting the size

  adapting.shape <- 0  # will be set to the iteration at which
  # adaptation starts

  # find estimated theta
  theta.estimated.names <- names(which(diag(covmat.proposal) > 0))

  # evaluate target at theta init
  target.theta.current <- target(theta.current)

  if (!is.null(print.info.every)) {
    message(Sys.time(), ", Init: ", printNamedVector(theta.current[theta.estimated.names]),
            ", target: ", target.theta.current)
  }

  # trace
  trace <- matrix(ncol=length(theta.current)+1, nrow=n.iterations, 0)
  colnames(trace) <- c(theta.estimated.names, "log.density")

  # acceptance rate
  acceptance.rate <- 0

  # scaling factor for covmat size
  scaling.sd  <- 1

  # scaling multiplier
  scaling.multiplier <- 1

  # empirical covariance matrix (0 everywhere initially)
  covmat.empirical <- covmat.proposal
  covmat.empirical[,] <- 0

  # empirical mean vector
  theta.mean <- theta.current

  # if print.info.every is null never print info
  if (is.null(print.info.every)) {
    print.info.every <- n.iterations + 1
  }

  start_iteration_time <- Sys.time()

  for (i.iteration in seq_len(n.iterations)) {

    # adaptive step
    if (!is.null(adapt.size.start) && i.iteration >= adapt.size.start &&
        (is.null(adapt.shape.start) || acceptance.rate*i.iteration < adapt.shape.start)) {
      if (!adapting.size) {
        message("\n---> Start adapting size of covariance matrix")
        adapting.size <- TRUE
      }
      # adapt size of covmat until we get enough accepted jumps
      scaling.multiplier <- exp(adapt.size.cooling^(i.iteration-adapt.size.start) * (acceptance.rate - 0.234))
      scaling.sd <- scaling.sd * scaling.multiplier
      scaling.sd <- min(c(scaling.sd,max.scaling.sd))
      # only scale if it doesn't reduce the covariance matrix to 0
      covmat.proposal.new <- scaling.sd^2*covmat.proposal.init
      if (!(any(diag(covmat.proposal.new)[theta.estimated.names] <
                .Machine$double.eps))) {
        covmat.proposal <- covmat.proposal.new
      }

    } else if (!is.null(adapt.shape.start) &&
               acceptance.rate*i.iteration >= adapt.shape.start &&
               (adapting.shape == 0 || is.null(adapt.shape.stop) ||
                i.iteration < adapting.shape + adapt.shape.stop)) {
      if (!adapting.shape) {
        message("\n---> Start adapting shape of covariance matrix")
        # flush.console()
        adapting.shape <- i.iteration
      }

      ## adapt shape of covmat using optimal scaling factor for multivariate target distributions
      scaling.sd <- 2.38/sqrt(length(theta.estimated.names))

      covmat.proposal <- scaling.sd^2 * covmat.empirical
    } else if (adapting.shape > 0) {
      message("\n---> Stop adapting shape of covariance matrix")
      adapting.shape <- -1
    }

    # print info
    if (i.iteration %% ceiling(print.info.every) == 0) {
      message(Sys.time(), ", Iteration: ",i.iteration,"/", n.iterations,
              ", acceptance rate: ",
              sprintf("%.3f",acceptance.rate), appendLF=FALSE)
      if (!is.null(adapt.size.start) || !is.null(adapt.shape.start)) {
        message(", scaling.sd: ", sprintf("%.3f", scaling.sd),
                ", scaling.multiplier: ", sprintf("%.3f", scaling.multiplier),
                appendLF=FALSE)
      }
      message(", state: ",(printNamedVector(theta.current)))
      message(", logdensity: ", target.theta.current)
    }

    # propose another parameter set
    if (any(diag(covmat.proposal)[theta.estimated.names] <
            .Machine$double.eps)) {
      print(covmat.proposal[theta.estimated.names,theta.estimated.names])
      stop("non-positive definite covmat",call.=FALSE)
    }
    if (length(theta.estimated.names) > 0) {
      theta.propose[theta.estimated.names] <-
        as.vector(rtmvnorm(1,
                           mean =
                             theta.current[theta.estimated.names],
                           sigma =
                             covmat.proposal[theta.estimated.names,theta.estimated.names],
                           lower =
                             lower.proposal[theta.estimated.names],
                           upper = upper.proposal[theta.estimated.names]))
    }

    # evaluate posterior of proposed parameter
    target.theta.propose <- target(theta.propose)
    # if return value is a vector, set log.density and trace

    if (!any(is.finite(target.theta.propose))) { # GK: changed to include "any" as getting error with list
      # if posterior is 0 then do not compute anything else and don't accept
      log.acceptance <- -Inf

    }else{

      # compute Metropolis-Hastings ratio (acceptance probability)
      log.acceptance <- target.theta.propose - target.theta.current
      log.acceptance <- log.acceptance +
        dtmvnorm(x = theta.current[theta.estimated.names],
                 mean =
                   theta.propose[theta.estimated.names],
                 sigma =
                   covmat.proposal[theta.estimated.names,
                                   theta.estimated.names],
                 lower =
                   lower.proposal[theta.estimated.names],
                 upper =
                   upper.proposal[theta.estimated.names],
                 log = TRUE)
      log.acceptance <- log.acceptance -
        dtmvnorm(x = theta.propose[theta.estimated.names],
                 mean = theta.current[theta.estimated.names],
                 sigma =
                   covmat.proposal[theta.estimated.names,
                                   theta.estimated.names],
                 lower =
                   lower.proposal[theta.estimated.names],
                 upper =
                   upper.proposal[theta.estimated.names],
                 log = TRUE)

    }

    if (verbose) {
      message("Propose: ", theta.propose[theta.estimated.names],
              ", target: ", target.theta.propose,
              ", acc prob: ", exp(log.acceptance), ", ",
              appendLF = FALSE)
    }

    if (is.accepted <- (log(runif (1)) < log.acceptance)) {
      # accept proposed parameter set
      theta.current <- theta.propose
      target.theta.current <- target.theta.propose
      if (verbose) {
        message("accepted")
      }
    } else if (verbose) {
      message("rejected")
    }
    trace[i.iteration, ] <- c(theta.current, target.theta.current)

    # update acceptance rate
    if (i.iteration == 1) {
      acceptance.rate <- is.accepted
    } else {
      acceptance.rate <- acceptance.rate +
        (is.accepted - acceptance.rate) / i.iteration
    }

    # update empirical covariance matrix
    if (adapting.shape >= 0) {
      tmp <- updateCovmat(covmat.empirical, theta.mean,
                          theta.current, i.iteration)
      covmat.empirical <- tmp$covmat
      theta.mean <- tmp$theta.mean
    }

  }

  return(list(trace = trace,
              acceptance.rate = acceptance.rate,
              covmat.empirical = covmat.empirical))
}

#'Print named vector
#'
#'Print named vector with format specified by \code{fmt} (2 decimal places by default).
#' @param x named vector
#' @inheritParams base::sprintf
#' @inheritParams base::paste
#' @export
#' @seealso \code{\link[base]{sprintf}}
#' @keywords internal
printNamedVector <- function(x, fmt="%.2f", sep=" | ") {

  paste(paste(names(x),sprintf(fmt,x),sep=" = "),collapse=sep)

}

#' Simulate forward a stochastic model
#'
#' This function uses the function \code{\link[adaptivetau]{ssa.adaptivetau}} to simulate the model and returns the trajectories in a valid format for the class \code{\link{fitmodel}}.
#' @param theta named vector of model parameters.
#' @param init.state named vector of initial state of the model.
#' @param times time sequence for which state of the model is wanted; the first value of times must be the initial time.
#' @inheritParams adaptivetau::ssa.adaptivetau
#' @export
#' @import adaptivetau
#' @return a data.frame of dimension \code{length(times)x(length(init.state)+1)} with column names equal to \code{c("time",names(init.state))}.
simulateModelStochastic <- function(theta,init.state,times,transitions,rateFunc) {

  stoch <- as.data.frame(ssa.adaptivetau(init.state,transitions,rateFunc,theta,tf=diff(range(times))))

  # rescale time as absolute value
  stoch$time <- stoch$time + min(times)

  # interpolate
  traj <- cbind(time=times,apply(stoch[,-1],2,function(col){approx(x=stoch[,1],y=col,xout=times,method="constant")$y}))

  return(as.data.frame(traj))

}

#'Simulate several replicate of the model
#'
#'Simulate several replicate of a fitmodel using its function simulate
#' @param times vector of times at which you want to observe the states of the model.
#' @param n number of replicated simulations.
#' @param observation logical, if \code{TRUE} simulated observation are generated by \code{rTrajObs}.
#' @inheritParams testFitmodel
#' @export
#' @import plyr
#' @return a data.frame of dimension \code{[nxlength(times)]x[length(init.state)+2]} with column names equal to \code{c("replicate","time",names(init.state))}.
simulateModelReplicates <- function(fitmodel,theta, init.state, times, n, observation=FALSE) {

  stopifnot(inherits(fitmodel,"fitmodel"),n>0)

  if(observation && is.null(fitmodel$dPointObs)){
    stop("Can't generate observation as ",sQuote("fitmodel")," doesn't have a ",sQuote("dPointObs")," function.")
  }

  rep <- as.list(1:n)
  names(rep) <- rep

  if (n > 1) {
    progress = "text"
  } else {
    progress = "none"
  }

  traj.rep <- ldply(rep,function(x) {

    if(observation){
      traj <- rTrajObs(fitmodel, theta, init.state, times)
    } else {
      traj <- fitmodel$simulate(theta,init.state,times)
    }

    return(traj)

  },.progress=progress,.id="replicate")

  return(traj.rep)
}

#'Simulate model until extinction
#'
#'Return final state at extinction
#' @param extinct character vetor. Simulations stop when all these state are extinct.
#' @param time.init numeric. Start time of simulation.
#' @param time.step numeric. Time step at which extinction is checked
#' @inheritParams testFitmodel
#' @inheritParams simulateModelReplicates
#' @inheritParams particleFilter
#' @export
#' @import plyr parallel doParallel
simulateFinalStateAtExtinction <- function(fitmodel, theta, init.state, extinct=NULL ,time.init=0, time.step=100, n=100, observation=FALSE, n.cores = 1) {

  stopifnot(inherits(fitmodel,"fitmodel"),n>0)

  if(observation && is.null(fitmodel$dPointObs)){
    stop("Can't generate observation as ",sQuote("fitmodel")," doesn't have a ",sQuote("dPointObs")," function.")
  }

  if(is.null(n.cores)){
    n.cores <- detectCores()
  }

  if(n.cores > 1){
    registerDoParallel(cores=n.cores)
  }

  rep <- as.list(1:n)
  names(rep) <- rep

  if (n > 1 && n.cores==1) {
    progress = "text"
  } else {
    progress = "none"
  }

  times <- c(time.init, time.step)

  final.state.rep <- ldply(rep,function(x) {

    if(observation){
      traj <- rTrajObs(fitmodel, theta, init.state, times)
    } else {
      traj <- fitmodel$simulate(theta,init.state,times)
    }

    current.state <- unlist(traj[nrow(traj),fitmodel$state.names])
    current.time <- last(traj$time)

    while(any(current.state[extinct]>=0.5)){

      times <- times + current.time

      if(observation){
        traj <- rTrajObs(fitmodel, theta, current.state, times)
      } else {
        traj <- fitmodel$simulate(theta, current.state,times)
      }

      current.state <- unlist(traj[nrow(traj),fitmodel$state.names])
      current.time <- last(traj$time)
    }

    return(data.frame(t(c(time=current.time,current.state))))

  },.progress=progress,.id="replicate",.parallel=(n.cores > 1),.paropts=list(.inorder=FALSE))

  return(final.state.rep)
}

#'Update covariance matrix
#'
#'Update covariance matrix using a stable one-pass algorithm. This is much more efficient than using \code{\link{cov}} on the full data.
#' @param covmat covariance matrix at iteration \code{i-1}. Must be numeric, symmetrical and named.
#' @param theta.mean mean vector at iteration \code{i-1}. Must be numeric and named.
#' @param theta vector of new value at iteration \code{i}. Must be numeric and named.
#' @param i current iteration.
#' @references \url{http://en.wikipedia.org/wiki/Algorithms\%5Ffor\%5Fcalculating\%5Fvariance#Covariance}
#' @export
#' @keywords internal
#' @return A list of two elements
#' \itemize{
#' \item \code{covmat} update covariance matrix
#' \item \code{theta.mean} updated mean vector
#' }
updateCovmat <- function(covmat,theta.mean,theta,i) {

  if(is.null(names(theta))){
    stop("Argument ",sQuote("theta")," must be named.",.call=FALSE)
  }
  if(is.null(names(theta.mean))){
    stop("Argument ",sQuote("theta.mean")," must be named.",.call=FALSE)
  }
  if(is.null(rownames(covmat))){
    stop("Argument ",sQuote("covmat")," must have named rows.",.call=FALSE)
  }
  if(is.null(colnames(covmat))){
    stop("Argument ",sQuote("covmat")," must have named columns.",.call=FALSE)
  }

  covmat <- covmat[names(theta),names(theta)]
  theta.mean <- theta.mean[names(theta)]

  residual <- as.vector(theta-theta.mean)
  covmat <- (covmat*(i-1)+(i-1)/i*residual%*%t(residual))/i
  theta.mean <- theta.mean + residual/i

  return(list(covmat=covmat,theta.mean=theta.mean))
}

#'Burn and thin MCMC chain
#'
#'Return a burned and thined trace of the chain.
#' @param trace either a \code{data.frame} or a \code{list} of \code{data.frame} with all variables in column, as outputed by \code{\link{mcmcMH}}. Accept also an \code{mcmc} or \code{mcmc.list} object.
#' @param burn proportion of the chain to burn.
#' @param thin number of samples to discard per sample that is being kept
#' @export
#' @import coda
#' @return an object with the same format as \code{trace} (\code{data.frame} or \code{list} of \code{data.frame} or \code{mcmc} object or \code{mcmc.list} object)
burnAndThin <- function(trace, burn = 0, thin = 0) {

  convert_to_mcmc <- FALSE

  if(class(trace)=="mcmc"){
    convert_to_mcmc <- TRUE
    trace <- as.data.frame(trace)
  } else if(class(trace)=="mcmc.list"){
    convert_to_mcmc <- TRUE
    trace <- as.list(trace)
  }

  if(is.data.frame(trace) || is.matrix(trace)){

    # remove burn
    if (burn > 0) {
      trace <- trace[-(1:burn), ]
    }
    # thin
    trace <- trace[seq(1, nrow(trace), thin + 1), ]

    if(convert_to_mcmc){
      trace <- mcmc(trace)
    }

  } else {

    trace <- lapply(trace, function(x) {

      # remove burn
      if (burn > 0) {
        x <- x[-(1:burn), ]
      }
      # thin
      x <- x[seq(1, nrow(x), thin + 1), ]

      if(convert_to_mcmc){
        x <- mcmc(x)
      }

      return(x)
    })

    if(convert_to_mcmc){
      trace <- mcmc.list(trace)
    }
  }

  return(trace)
}

#'Distance weighted by number of oscillations
#'
#'This positive distance is the mean squared differences between \code{x} and the \code{y}, divided by the square of the number of times the \code{x} oscillates around the \code{y} (see note below for illustration).
#' @param x,y numeric vectors of the same length.
#' @note To illustrate this distance, suppose we observed a time series \code{y = c(1,3,5,7,5,3,1)} and we have two simulated time series \code{x1 = (3,5,7,9,7,5,3)} and \code{x2 = (3,5,3,5,7,5,3)}; \code{x1} is consistently above \code{y} and \code{x2} oscillates around \code{y}. While the squared differences are the same, we obtain \eqn{d(y, x1) = 4} and \eqn{d(y, x2) = 1.3}.
#' @export
distanceOscillation <- function(x, y) {

  # check x and y have same length
  if(length(x)!=length(y)){
    stop(sQuote("x")," and ",sQuote("y")," must be vector of the same length")
  }

  # 1 + number of times x oscillates around y
  n.oscillations <- 1+length(which(diff((x-y)>0)!=0))

  dist <- sum((x-y)^2)/(length(x)*n.oscillations)

  return(dist)
}

#'Export trace in Tracer format
#'
#'Print \code{trace} in a \code{file} that can be read by the software Tracer.
#' @param trace a \code{data.frame} with one column per estimated parameter, as returned by \code{\link{burnAndThin}}
#' @inheritParams utils::write.table
#' @note Tracer is a program for analysing the trace files generated by Bayesian MCMC runs. It can be dowloaded at \url{http://tree.bio.ed.ac.uk/software/tracer}.
#' @export
#' @seealso burnAndThin
#' @keywords internal
export2Tracer <- function(trace, file) {

  if(is.mcmc(trace)){
    trace <- as.data.frame(trace)
  }

  if(!"iteration"%in%names(trace)){
    trace$iteration <- (1:nrow(trace) - 1)
  }

  trace <- trace[c("iteration",setdiff(names(trace),c("iteration","weight")))]
  write.table(trace,file=file,quote=FALSE,row.names=FALSE,sep="\t")

}


#' Function that corrects chronologies for sudden jumps in time
#'
#' Some occurrences in the model results can lead the CumDY function
#' to detect extra year transitions, resulting in sudden jumps in
#' the shell chronology or a start of the chronology at an age
#' beyond 1 year. This function removes these sharp transitions
#' and late onset by adding or subtracting whole years to the age
#' result.
#' @param resultarray Array containing the full results of
#' the optimized growth model
#' @param T_per The period length of one year (in days)
#' @param agecorrection Correct for jumps in age (/code{TRUE}) or
#' only for starting time (/code{FALSE})
#' @param plot Should the results be plotted? (/code{TRUE/FALSE})
#' @return An updated and corrected version of \code{resultarray}
#' @references package dependencies: ggplot2 3.2.1
#' @examples
#' testarray <- array(NA, dim = c(20, 16, 9)) # Create empty array
#' # with correct third dimension
#' windowfill <- seq(10, 100, 10) # Create dummy simulation data
#' # (ages) to copy through the array
#' for(i in 6:length(testarray[1, , 1])){
#'     testarray[, i, 3] <- c(windowfill,
#'         rep(NA, length(testarray[, 1, 3]) - length(windowfill)))
#'     windowfill <- c(NA, windowfill + 31)
#' }
#' testarray2 <- age_corr(testarray, 365, FALSE, FALSE) # Apply function on
#' array
#' @export
age_corr <- function(resultarray,
    T_per = 365,
    plot = TRUE,
    agecorrection = TRUE
    ){
    Age <- Age_corr <- NULL # Predefine variables to circumvent global variable binding error
    # Check on glitches where consecutive windows are placed (almost) 1 year apart.
    # These are repaired by adding one T_per to the cumulative Day values of those windows in
    # resultarray[, , 3]
    mean_window_age <- data.frame(
        1:(length(resultarray[1,,1]) - 5),
        unname(colMeans(resultarray[, 6:length(resultarray[1, , 1]), 3], na.rm = TRUE)))
    colnames(mean_window_age) <- c("window", "Age")

    # Plot mean window ages
    dev.new() # Plot Window age to check for strange jumps in age
    ageplot <- ggplot2::ggplot(mean_window_age, ggplot2::aes(window, Age)) +
        ggplot2::geom_line() +
        ggplot2::geom_point() +
        ggplot2::ggtitle("Plot of average ages of modelling windows") +
        ggplot2::xlab("Window #") +
        ggplot2::scale_y_continuous("Age (days)", seq(0, 365 * ceiling(max(unname(colMeans(
            resultarray[, 6:length(resultarray[1,,1]),3], na.rm = TRUE)),
            na.rm = TRUE) / 365), 365))
    plot(ageplot)

    if(agecorrection == TRUE){
        agecorr <- rep(0, length(mean_window_age[, 2])) # Create vector to store corrections
        # (in days) to the mean ages of modelling windows
        for(i in 1:(length(mean_window_age[,2]) - 1)){ # Loop through all windows
            if(mean_window_age[i + 1, 2] - mean_window_age[i, 2] > T_per / 2){ # If there is a
            # large (> half a year) positive step between consecutive windows...
                # ...subtract one year from the subsequent windows
                agecorr[(i + 1):length(agecorr)] <- agecorr[(i + 1):length(agecorr)] - T_per
            }else if(mean_window_age[i + 1, 2] - mean_window_age[i, 2] < T_per / -2){ # If there is
                # a large (> half a year) negative drop between consecutive windows, add one year
                # from the subsequent windows
                agecorr[(i + 1):length(agecorr)] <- agecorr[(i + 1):length(agecorr)] + T_per
            }
        }

        if(min(mean_window_age$Age + agecorr) > T_per){
            agecorr <- agecorr - 365 # Subtract whole number of years from correction if the
            # smallest value is more than one year old
        }

        mean_window_age$Age_corr <- mean_window_age$Age + agecorr
        mean_window_age$correction <- agecorr

        if(plot == TRUE){ # Plot updated result
            ageplot <- ggplot2::ggplot(mean_window_age, ggplot2::aes(window, Age)) + # Plot Window
            # age to check for strange jumps in age
            ggplot2::geom_line() +
            ggplot2::geom_point() +
            ggplot2::ggtitle("Plot of average ages of modelling windows") +
            ggplot2::xlab("Window #") +
            ggplot2::scale_y_continuous("Age (days)", seq(0, 365 * ceiling(max(unname(colMeans(
                resultarray[, 6:length(resultarray[1,,1]),3], na.rm = TRUE)),
                na.rm = TRUE) / 365), 365)) +
            ggplot2::geom_line(ggplot2::aes(window, Age_corr), col = "red") # Add corrected window
            # age to plot
            plot(ageplot)
        }

        resultarray[, 6:length(resultarray[1, , 1]), 3] <- resultarray[, 6:length(
            resultarray[1, , 1]), 3] + matrix(agecorr, nrow = length(resultarray[, 1, 1]),
            ncol = length(agecorr), byrow = TRUE) # Apply correction on the results of
            # age modelling
    }else{
        resultarray[, 6:length(resultarray[1, , 1]), 3] <- resultarray[, 6:length(
            resultarray[1, , 1]), 3] - floor(min(mean_window_age$Age) / 365) * 365 # Correct age if
            # all windows occur past year one
    }
    return(resultarray)
}