greaterOrEqual <- function (x, y) {
    precision <- sqrt(.Machine$double.eps)
    (x >= y) | (abs(x - y) <= precision)
}

## getSegments
bh.getSegments <- function(x, f = NULL, cutoff=quantile(abs(x), 0.99), assumeSorted = FALSE, verbose=FALSE){
    if(is.null(f))
        f <- rep(1L, length(x))
    stopifnot(length(x) == length(f))
    stopifnot(length(cutoff) <= 2)
    if(is.character(f))
        f <- as.factor(f)
    if(is.numeric(f))
        f <- as.integer(f)
    stopifnot(is.factor(f) || is.integer(f))
    if(length(cutoff) == 1)
        cutoff <- c(-cutoff, cutoff)
    cutoff <- sort(cutoff)

    reordered <- FALSE
    if(!assumeSorted && is.unsorted(f)) {
	od <- order(f)
	x <- x[od]
	f <- f[od]
	reordered <- TRUE
    }

    if(verbose) message("getSegments: segmenting")
    Indexes <- split(seq(along=x), f)
    direction <- as.integer(greaterOrEqual(x, cutoff[2]))
    direction[x <= cutoff[1]] <- -1L

    ## We now need to convert f into cid
    if(verbose) message("getSegments: splitting")
    segments <- cumsum(c(1, diff(direction) != 0)) +
        cumsum(c(1, diff(f) != 0))
    names(segments) <- NULL

    res <- list(upIndex = split(which(direction>0), segments[direction>0]),
                dnIndex = split(which(direction<0), segments[direction<0]),
                zeroIndex = split(which(direction==0), segments[direction==0]))
    names(res[[1]]) <- NULL
    names(res[[2]]) <- NULL
    names(res[[3]]) <- NULL

    if(reordered) {
        res <- lapply(res, function(sp) lapply(sp, function(xx) od[xx]))
    }
    res
}

## clusterMaker
bh.clusterMaker <- function(chr, pos, assumeSorted = FALSE, maxGap=300){
    nonaIndex <- which(!is.na(chr) & !is.na(pos))
    Indexes <- split(nonaIndex, chr[nonaIndex])
    clusterIDs <- rep(NA, length(chr))
    LAST <- 0
    for(i in seq(along = Indexes)){
        Index <- Indexes[[i]]
        x <- pos[Index]
        if(!assumeSorted){
            Index <- Index[order(x)]
            x <- pos[Index]
        }
        y <- as.numeric(diff(x) > maxGap)
        z <- cumsum(c(1, y))
        clusterIDs[Index] <- z + LAST
        LAST <- max(z) + LAST
    }
    clusterIDs
}

bh.regionFinder <- function(x, chr, pos, cluster=NULL, y=x, summary=mean,
                         ind=seq(along=x),order=TRUE, oneTable=TRUE,
                         maxGap=300, cutoff=quantile(abs(x), 0.99),
                         assumeSorted = FALSE, verbose = TRUE){
    if(any(is.na(x[ind]))){
        warning("NAs found and removed. ind changed.")
        ind <- intersect(which(!is.na(x)),ind)
    }
    if(is.null(cluster))
        cluster <- bh.clusterMaker(chr, pos, maxGap=maxGap, assumeSorted = assumeSorted)
    Indexes <- bh.getSegments(x = x[ind], f = cluster[ind], cutoff = cutoff,
                           assumeSorted = assumeSorted, verbose = verbose)
    clusterN <- table(cluster)[as.character(cluster)]

    res <- vector("list",2)
    for(i in 1:2){
      res[[i]]<-
        data.frame(chr=sapply(Indexes[[i]],function(Index) chr[ind[Index[1]]]),
                   start=sapply(Indexes[[i]],function(Index) min(pos[ind[Index]])),
                   end=sapply(Indexes[[i]], function(Index) max(pos[ind[Index]])),
                   value=sapply(Indexes[[i]],function(Index)summary(y[ind[Index]])),
                   area=sapply(Indexes[[i]],function(Index)abs(sum(y[ind[Index]]))),
                   cluster=sapply(Indexes[[i]],function(Index)cluster[ind[Index]][1]),
                   indexStart=sapply(Indexes[[i]], function(Index) min(ind[Index])),
                   indexEnd = sapply(Indexes[[i]], function(Index) max(ind[Index])),
                   stringsAsFactors=FALSE)

      res[[i]]$L <- res[[i]]$indexEnd - res[[i]]$indexStart+1
      res[[i]]$clusterL <- sapply(Indexes[[i]], function(Index) clusterN[ind[Index]][1])
    }
    names(res) <- c("up","dn")
    if(order & !oneTable){
        if(nrow(res$up)>0) res$up <- res$up[order(-res$up$area),]
        if(nrow(res$dn)>0) res$dn <- res$dn[order(-res$dn$area),]
    }
    if(oneTable){
        res <- rbind(res$up,res$dn)
        if(order & nrow(res)>0) res <- res[order(-res$area),]
    }
    return(res)
}


# Filename: scvm_functions.r
# Purpose:
#   Define functios to be used to fit CV models

# List:
#   save_rgn: save a seed for random number generation
#   restore_rgn: restore a saved seed
#   make_data: make a sample data set which can be used for testing
#   getstart(MOD,S): Calculates Starting Values
#   SIGMAof(theta): Calculated Covariance of Free Parameters
#   vechSIGMA(theta): Returns half-vectorize of SIGMAof(theta)
#   calcDelta(theta,W): Calculates "Delta" for standard errors
#   getDelta(theta,W): Error Checking Wrapper for calcDelta
#   Criterion Functions: Return crit to be minimized given theta
#     fADFcv, fADFcvn, fGLScv, fMLcv
#   plzcon(theta,func): Optimizes Criterion Func to Estimate Pars
#   printRES: Prints results in form set up by plzcon and SEs

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

#Saves current seed (for random number generation)
#ref: http://stackoverflow.com/questions/13997444/
save_rng <- function(savefile=tempfile()) {
  if (exists(".Random.seed"))  {
    oldseed <- get(".Random.seed", .GlobalEnv)
  } else stop("don't know how to save before set.seed() or r*** call")
  oldRNGkind <- RNGkind()
  save("oldseed","oldRNGkind",file=savefile)
  invisible(savefile)
}

#Restores saved seed (for random number generation)
#ref: http://stackoverflow.com/questions/13997444/
restore_rng <- function(savefile) {
  load(savefile)
  do.call("RNGkind",as.list(oldRNGkind))  ## must be first!
  assign(".Random.seed", oldseed, .GlobalEnv)
}

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

#Function to Store Data (Must Match Col Names Below)
storeRES <- function(rMETH,filename="") {
  cat(c(N,REP,
        rMETH$METH,rMETH$conv,rMETH$oalg,rMETH$mini,rMETH$pars,rMETH$SEs),
      file=filename,append=T)
  cat("\n",file=filename,append=T)
}

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

#Defines starting values for parameter estimation based on the specified
#model (MOD)
getstart <- function(MOD,S) {

  #Get selection Variables and Change Format
  MOD$value = as.character(MOD$value)
  sel.na <- (MOD$value == 'X')
  sel.ev <- (MOD$value == 'E')
  MOD$value = suppressWarnings(as.numeric(MOD$value))

  #number of observed variables
  pOBS = nrow(S)
  # ***Assumes variables 1:pOBS are all observed and included in model

  #Select/Identify Paths and Vars
  sel.ip  <- (MOD$code == 1)#paths between dvs
  sel.dp  <- (MOD$code == 2)#paths from an iv
  sel.cov <- (MOD$code == 3)#vars and covs of ivs
  sel.var <- sel.cov & (MOD$to == MOD$from)#vars only

  #Start all NA path coefs at 1.0
  MOD$value[sel.ip] = 1.0
  MOD$value[sel.dp] = 1.0

  #Start all var/covs at 1.0 (update some below)
  MOD$value[sel.cov] = 1.0

  #Change NA covs to 0
  MOD$value[sel.cov & !sel.var] = 0.0

  #Update values for error vars
  listDV = unique(MOD$to[MOD$code != 3])
  sel.dvS = sort(listDV[listDV <= pOBS])
  MOD$value[sel.ev] = (0.9)*diag(S)[sel.dvS]
  # *** Error variances must be listed in order of Observed DVs!

  #Set start values for variance observed IVs
  listIV = unique(MOD$from[MOD$code != 3])
  sel.ivS = sort(listIV[listIV <= pOBS])
  sel.obsiv = sel.cov & sel.cov & (MOD$from <= pOBS)
  MOD$value[sel.obsiv] = diag(S)[sel.ivS]

  MOD
}

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

#Model Covariance of Given free Parameters
SIGMAof <- function(theta) {
  #Combine New Free Values with Fixed Values
  pars = MOD$value
  pars[sel.free] = theta
  #Steps needed for iterations
  B[cbind(MOD$to[sel.dp],MOD$from[sel.dp])]=pars[sel.dp]
  Gam[cbind(MOD$to[sel.ip],ivfrom)] = pars[sel.ip]
  Gam[cbind(MOD$from[sel.ip],ivfrom)] = pars[sel.ip]
  Phi[Cindex] = pars[sel.cov]
  Phi = Phi + t(Phi) - diag(diag(Phi))
  #Get Sigma(pars)
  Binv = solve(diag(rep(1,p))-B)
  GBinvGam = G %*% Binv %*% Gam
  Sigma = GBinvGam %*% Phi %*% t(GBinvGam)
}

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

#Vectorize Sigma
vechSIGMA <- function(theta) {vech(SIGMAof(theta))}

#Calculate standard errors
calcDelta <-function(theta,W) {
  #Tranform W for ML and GLS
  if(dim(W)[1] < pSTAR && dim(W)[1] > 1){
    Dp = D.matrix(pOBS)
    W = (t(Dp) %*% kronecker(W,W) %*% Dp)/2
  }
  #Get Derivatives
  Sdot = jacobian(vechSIGMA,t(theta))
  #Calculate Delta
  Delta = try(solve( t(Sdot) %*% W %*% Sdot),silent=TRUE)
}

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

#Wrapper for calcDelta
#Checks for Convergence
getDelta <- function(rMETH,W) {
  #Check Convergence
  nlmconv = ((rMETH$oalg == 'nlm') && (rMETH$conv <= 2)) #T if nlm converged
  optimconv = ((rMETH$oalg == 'optim') && (rMETH$conv == 0)) #T if optim converged
  #Get Delta if Convergence
  Delta = matrix(0,qFREE,qFREE)
  if(nlmconv || optimconv) {
    CheckDelta = calcDelta(rMETH$pars,W)
    if(typeof(CheckDelta) != "character") {
      Delta = CheckDelta
    }
  }
  Delta
}

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

#Check for convergence and/or effectively singular covariance matrices
compsings <- function(rMETH) {
  #Check Convergence
  nlmconv = ((rMETH$oalg == 1) && (rMETH$conv <= 2)) #T if nlm converged
  optimconv = ((rMETH$oalg == 2) && (rMETH$conv == 0)) #T if optim converged
  SEtrouble = ( sum(!is.finite(rMETH$SEs) != 0) | sum( rMETH$SEs!=0) == 0 )
  if(nlmconv || optimconv) {
    if(SEtrouble == TRUE) {
      rMETH$conv = 6
    }
  }
  rMETH
}

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

#Define Criterion Functions for various estimation procedures

#ADFcv criterion to be minimized
fADFcv <- function(theta) {
  #Get Sigma(pars)
  Sigma = SIGMAof(theta)
  #Minimize This
  diff = vech(PsyHat-Sigma)
  ADFval = t(diff) %*% SHPinv %*% (diff)
}

#ADFcvn criterion to be minimized
fADFcvn <- function(theta) {
  #Get Sigma(pars)
  Sigma = SIGMAof(theta)
  #Minimize This
  diff = vech(PsyHat-Sigma)
  ADFval = t(diff) %*% SHPNinv %*% (diff)
}

#GLScv criterion to be minimized
fGLScv <- function(theta) {
  #Get Sigma(pars)
  Sigma = SIGMAof(theta)
  #Minimize This
  mid = (PsyHat-Sigma) %*% solve(PsyHat)
  GLSval = 0.5 * sum(diag( mid %*% mid ))
}

#MLcv criterion to be minimized
fMLcv <- function(theta) {
  #Get Sigma(pars)
  Sigma = SIGMAof(theta)
  #Minimize This
  mid = (PsyHat-Sigma) %*% solve(Sigma)
  MLval = 0.5 * sum( diag( mid %*% mid ))
}

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

#Apply minimization algorithms to criterion/cost function
plzcon <- function(theta,func) {
  result = new.env()
  #Try NLM:
  resNLM = nlm(func,theta,iterlim = 1000)
  result$oalg = 'nlm'
  result$conv = resNLM$code
  result$mini = resNLM$minimum
  result$pars = resNLM$estimate
  #Check Code
  if(result$conv != 0) {
    resOPTIM = optim(theta,func,method='BFGS',control=list(maxit=1000))
    if(resOPTIM$value < result$mini) {
      result$oalg = 'optim'
      result$conv = resOPTIM$convergence
      result$mini = resOPTIM$value
      result$pars = resOPTIM$par
    }
  }
  result$mini=N*(result$mini)
  result
}

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

#Function to Print Results
printRES <- function(rMETH) {
  if(is.numeric(rMETH) == F) {
    #Estimation Procedure:
    writeLines(paste(rMETH$METH,'\n'))

    #Optimization Method which produced minimum
    writeLines(paste('Optimization Method which Produced Minimum: ',
                rMETH$oalg))
    #Convergence
    writeLines(paste('Convergence Code: ', rMETH$conv, '\n'))

    #Chi-squared Value
    writeLines(paste('Chi-squared (df): ',
                'X^2 = ',rMETH$mini, ' (df=',df,')','\n', sep=''))
    #Parameter Estimates
    writeLines('Parameter Estimates (including fixed): ')
    parlist = MOD$value
    parlist[sel.free] <- rMETH$pars
    print(parlist)
    cat('\n')

    #SEs of ADF Estimates
    writeLines('SEs of Estimates: ')
    print(rMETH$SEs)
  }else {
    writeLines("Still need to code printer for vectorized output.")
  }
}

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

#Function to Generate Test Data with CV Structure
#   model_file_name
#     - Name of the model file
#   model_dir
#     - Path to directory containing model file and seed file
#       (if restoring)
#   save_data
#     - Set to TRUE to save sample data to csv
#   use_random_seed
#     - Set to TRUE to make or load seed file
#   existing_seed_file
#     - Name of file containing seed to be restored
make_data <- function(model_file_name = 'MOD.dat',
                      model_dir = getwd(),
                      save_data = FALSE,
                      use_random_seed = FALSE,
                      existing_seed_file = NA){
  #Set working directory
  setwd(model_dir)

  ########################
  ##Load and Prep Model ##
  ########################

  #Load MOD file (Must be included in directory with model file)
  MOD <- read.delim(model_file_name)

  #Define Population Factor Structure (PSYID = 1)
  pF1  = 3 #Nodes per factor (pF1=pF2)
  pOBS = 6
  Fcov = 0.3 #Factor Covariance (yields cor(F1,F2)=0.3)
  OffBlocks = matrix(Fcov,pF1,pF1)
  DiagBlocks = matrix(1,pF1,pF1) + diag(pF1)
  PSY = rbind(cbind(DiagBlocks,OffBlocks),cbind(OffBlocks,DiagBlocks))

  #Define Population Mean and Covariance Matrices
  MU = rep(1,pOBS)
  SIGMA = diag(MU) %*% PSY %*% diag(MU)

  #Set sample size
  N =1000
  writeLines(paste('Sample Size: ', N))

  ###################################
  ## Count and Selection Variables ##
  ###################################

  #total number of variables
  p = max(c(MOD$from,MOD$to))
  # ***Assumes no unused variables

  #number of observed variables
  pOBS = nrow(SIGMA)
  # ***Assumes variables 1:pOBS are all observed and included in model

  #Number of unique covariances
  pSTAR = pOBS*(pOBS+1)/2
  writeLines(paste('Number of Unique Covariances: ', pSTAR))

  #Select/Identify Paths and Vars
  sel.ip  <- (MOD$code == 1) #paths from ivs
  sel.dp  <- (MOD$code == 2) #paths between dvs
  sel.cov <- (MOD$code == 3) #vars and covs of ivs

  #Identify and count (strict) IVs
  listIV = unique(MOD$from[sel.ip])
  pIV = length(listIV)
  writeLines(paste('Number of Strictly Independent Variables: ', pIV))
  writeLines('\t *Includes Error Terms')

  #Identify and count (all) DVs
  listDV = unique(MOD$to[MOD$code != 3])
  pDV = length(listDV)
  writeLines(paste('Number of Dependent Variables: ',pDV))

  #Select/Identify Free Parameters
  sel.fixed <- (MOD$index == 0)
  sel.free <- !(sel.fixed)

  #number of parameters
  qTOT = nrow(MOD)
  qFREE = sum(sel.free)
  writeLines(paste('Number of Free Parameters: ', qFREE))
  # *** Assumes no constraints on parameters

  #df for chi-squared
  df = pSTAR - qFREE
  writeLines(paste('Degrees of Freedom: ', df))

  ##############
  ## Set Seed ##
  ##############

  ##Generate/Restore Seed for Random Number Generator
  if(use_random_seed) {
    #If no existing seed file create new
    if(is.na(existing_seed_file)){
      existing_seed_file = paste("RandomSeed_",
                                 format(Sys.time(),"%Y%b%d_%H%M"),
                                 ".Rdata",sep="")
      save_rng(savefile = existing_seed_file)
    }
    #Load Seed
    restore_rng(savefile = existing_seed_file)
  }

  #################
  ## Draw Sample ##
  #################
  Y=mvrnorm(N,MU,SIGMA)
  names(Y) = paste('V',1:ncol(Y),sep='')

  if(save_data == TRUE){
    write.table(Y, paste('cv_sample_data.dat'), sep="\t",row.names=FALSE)
  }

  #Return Sample Data Matrix
  Y
}


cat(paste(c(seq(2, 8, by=2), "who do we appreciate?\n"), collapse=", "))


#' Run a Rasch model from R using Winsteps.
#'
#' This function uses the Winsteps software to analyze data, and then reads the
#'   data back into R without leaving  R interface or interacting with the
#'   Winsteps GUI.
#' @param itms Data frame or matrix of item responses to be analyzed.
#' @param dems Optional data frame or matrix of person identifiers/demographic
#'   fields.
#' @param keep Logical. Should the external files used to conduct the analysis
#'   be stored in the working directory? If TRUE, Winsteps control and data
#'   files will be retained, as well as item and person files in .txt format,
#'   and the .bat file used to process the data.
#' @param ... Additional arguments passed to \code{\link{r2Winsteps}}.
#' @seealso \code{\link{r2Winsteps}} \code{\link{batchWinsteps}}
#'   \code{\link{batch.pfile}} \code{\link{batch.ifile}}
#' @export
#' @return List containing the item and person parameters from the given
#'   analysis.

runWinsteps <- function(itms, dems = NULL, keep = FALSE, ...) {

    if(is.null(dems)) {
    	call <- r2Winsteps(itms, ...)
        dems <- data.frame(rownames = rownames(itms))
    }
    else {
    	call <- r2Winsteps(itms, dems, ...)
    }
    demNames <- names(dems)

    callTitle <- ifelse(!is.null(as.list(call)$title), as.list(call)$title,
        "r2Winsteps")

    # Check for existing files
    pfileName <- paste(callTitle, "Pfile.txt", sep = "")
    ifileName <- paste(callTitle, "Ifile.txt", sep = "")
    sfileName <- paste(callTitle, "Sfile.txt", sep = "")

    if (file.exists(pfileName) == TRUE) {
        invisible(file.remove(pfileName))
        warning("Previously estimated person file removed.")
    }

    if (file.exists(ifileName) == TRUE) {
        invisible(file.remove(ifileName))
        warning("Previously estimated item file removed.")
    }
    if (file.exists(sfileName) == TRUE) {
        invisible(file.remove(sfileName))
        warning("Previously estimated structure file removed.")
    }

    batchWinsteps(callTitle)

    batFile <- paste(callTitle, ".bat", sep = "")

    system(paste("open", batFile))

    pt <- proc.time()
    pc <- as.list(call)$partialCredit
    outFile <- paste0(callTitle, "Out.txt")

    if(length(pc) != 0) {
    	if(pc == TRUE) {
    		repeat {
	        Sys.sleep(0.1)

	        if (file.exists(pfileName) &
	        	file.exists(ifileName) &
	        	file.exists(sfileName)) {
		            pTemp <- readLines(pfileName)
		            iTemp <- readLines(ifileName)
		            sTemp <- readLines(sfileName)
		            split <- strsplit(sTemp[length(sTemp)], " ")[[1]]
	           if(length(pTemp) == (nrow(dems) + 2) &
	           	  length(iTemp) == (ncol(itms) + 2) &
				  na.omit(as.numeric(split))[1] == ncol(itms))
            break
				}
			}
            if(file.exists(outFile)) {
                if(length(readLines(outFile)) > 0 &
                        is.na(readLines(outFile)[27])) {
                stop(paste("Winsteps could not estimate the model. Check ",
                                outFile, "for details."))
                }
            }
    	}
	}
    if(length(pc) == 0) {
    	repeat {
	        Sys.sleep(0.1)

	        if (file.exists(pfileName) & file.exists(ifileName)) {
	            pTemp <- readLines(pfileName)
	            iTemp <- readLines(ifileName)

	        if(length(pTemp) == (nrow(dems) + 2) &
	           	 length(iTemp) == (ncol(itms) + 2) ) {
	        break
		        }
		    }

        if(file.exists(outFile)) {
			if(length(readLines(outFile)) > 0 &
                    is.na(readLines(outFile)[27])) {
				stop(paste("Winsteps could not estimate the model. Check ",
							outFile, "for details."))
				}
			}
		}
	}

    p <- batch.pfile(list(demNames))
    i <- batch.ifile(pat = substr(ifileName, 1, (nchar(ifileName) - 3)))
    if(file.exists(sfileName)) {
        s <- batch.sfile(pat = substr(sfileName, 1, (nchar(sfileName) - 3)))
    }
    if (keep == FALSE) {
        cntrlFile <- paste0(callTitle, "Cntrl.txt")
        dtaFile <- paste0(callTitle, "Dta.txt")
        if(exists("s")) {
            file.remove(c(pfileName, ifileName, sfileName, batFile,
            cntrlFile, dtaFile, outFile))
        }
        else{
            file.remove(c(pfileName, ifileName, batFile,
            cntrlFile, dtaFile, outFile))
        }

    }

    if(exists("s")) {
        return(structure(
                list("ItemParameters" = i,
                     "PersonParameters" = p,
                     "StructureFiles" = s),
            class = "r2Winsteps"))
    }
    else {
        return(structure(
                list("ItemParameters" = i,
                     "PersonParameters" = p),
            class = "r2Winsteps"))
    }

}


#' Network Climate Metrics
#'
#' Climate metrics derived from PRISM 1971-2001 mean monthly and mean annual
#' temperature and precipitation normals in NHDPlusV2 value added attribure
#' extension tables
#'
#' See (\url{http://www.worldclim.org/bioclim}) for more informaton on climate
#' metrics
#'
#' Requires "/VPUAttributeExtension" directory see(\code{\link{net_nhdplus}})
#'
#' @param netdelin output from \code{\link{net_delin}}
#' @param vpu NHDPlusV2 Vector Processing Unit
#' @param nhdplus_path Directory for NHDPlusV2 files (\code{\link{net_nhdplus}})
#'
#' @return \code{data.frame}: \code{$net.id} Unique identifier of network;
#'   \code{$group.comid} Root COMID of network; \code{$vpu} NHDPlusV2 Vector
#'   Processing Unit; \code{$MISSDATAA.x} area of missing temperature data;
#'   \code{$TEMPVC} mean annual temperature (deg C); \code{$seasonality_t}
#'   Coefficient of variation of mean monthly temperatures; \code{$warm_mo}
#'   2-digit warmest month; \code{$warm_mo_t} mean temperature of warmest month;
#'   \code{$cold_mo} 2-digit coldest month; \code{$cold_mo_t} mean temperature
#'   of coldest month; \code{$diff_t} difference between warm and cold monthly
#'   temperatures; \code{$warm_q_t} mean temperature of warmest quarter;
#'   \code{$warm_q} 2-digit warmest quarter; \code{$cold_q_t} mean temperature
#'   of coldest quarter; \code{$cold_q} 2-digit coldest quarter;
#'   \code{MISSDATAA.y} area of missing precipitation data; \code{$PRECIPVC}
#'   cumulative mean annual precipiration (mm); \code{$wet_mo} 2-digit wettest
#'   month; \code{$wet_mo_p} cumulative mean precipitation of wettest month;
#'   \code{$dry_mo} 2-digit driest month; \code{$dry_mo_p} cumulative mean
#'   precipitation of driest month; \code{$seasonality_p} coefficient of
#'   vatiation of mean monthly precipitation; \code{$wet_q_p} cumulaltive mean
#'   precipitation of wettest quarter; \code{$wet_q} 2-digit wettest quarter;
#'   \code{$dry_q_p} cumulaltive mean precipitation of driest quarter;
#'   \code{dry_q} 2-digit driest quarter; \code{$dry_q_t} mean temperature of
#'   driest quarter; \code{$wet_q_t} mean temperature of wettest quarter;
#'   \code{$warm_q_p} cumulaltive mean precipitation of warmest quarter;
#'   \code{$cold_q_p} cumulaltive mean precipitation of coldest quarter
#'
#' @examples
#' # identify NHDPlusV2 COMID
#' a <- net_sample(nhdplus_path = getwd(), vpu = "01", ws_order = 6, n = 5)
#' # delineate stream network
#' b <- net_delin(group_comid = as.character(a[,"COMID"]), nhdplus_path = getwd(), vpu = "01")
#' # derive climate summary
#' c <- net_clim(netdelin = b,vpu = "01", nhdplus_path = getwd())
#'
#' @export

net_clim<-function(nhdplus_path, vpu, netdelin, Mscale = "N"){
  directory <- grep(paste(vpu, "/NHDPlusAttributes", sep = ""),
                    list.dirs(nhdplus_path, full.names = T),
                    value = T)
  vaa <- grep("PlusFlowlineVAA.dbf",
              list.files(directory[1], full.names = T),
              value = T)
  vaa <- foreign::read.dbf(vaa)
  names(vaa) <- toupper(names(vaa))

  full.net <- netdelin$Network
  full.net <- merge(full.net, vaa[,c("COMID","AREASQKM")],
                    by.x = "net.comid", by.y = "COMID")

  #if M scale is N, set all M values to 1 so no scale
  if(Mscale == "N"){
    full.net[,"M"] <- 1
  }

  clim.dir <- grep(paste(vpu, "/VPUAttributeExtension", sep = ""),
                   list.dirs(nhdplus_path, full.names = T),
                   value = T)
  mappt.files <- grep("CumTotPrecip",
                      list.files(clim.dir[1], full.names = T),
                      value = T)
  mappt.incr.files <- grep("IncrPrecip",
                           list.files(clim.dir[1], full.names = T),
                           value = T)
  matemp.files <- grep("CumTotTemp",
                       list.files(clim.dir[1], full.names = T),
                       value = T)
  matemp.incr.files <- grep("IncrTempM",
                       list.files(clim.dir[1], full.names = T),
                       value = T)

  #read files function
  read_files <- function (file_type){
    map <- read.table(file_type[1], header = T, sep = ",")
    colnames(map) <- toupper(colnames(map))
    colnames(map)[1] <- "COMID"
    #set month of dataframe, pulls off last name in filepath
    month <- unlist(lapply(strsplit(file_type[1], "/"), "[[", lengths(strsplit(file_type[1], "/"))))
    month <- unlist(lapply(strsplit(month,"\\."),"[[", 1))
    month <- substr(month,nchar(month)-1, nchar(month))

    #cbind month to ppt data
    map <- data.frame(map, month = month)
    #merge with fill.net to maintain group comid.
    #Unique values are now set as net.comid.group.comid & month
    map <- merge(full.net, map, by.y = "COMID", by.x = "net.comid")
    #loop over remainder files
    for (j in 2:length(file_type)) {
      month <- unlist(lapply(strsplit(file_type[j],"/"), "[[",lengths(strsplit(file_type[j], "/"))))
      month <- unlist(lapply(strsplit(month,"\\."),"[[", 1))
      month <- substr(month,nchar(month)-1, nchar(month))

      temp <- read.table(file_type[j], header = T, sep = ",")
      colnames(temp) <- toupper(colnames(temp))
      colnames(temp)[1] <- "COMID"
      temp <- data.frame(temp, month = month)
      temp <- merge (full.net,temp, by.y = "COMID", by.x = "net.comid")
      map <- rbind(map, temp)
    }
    return(map)
  }

  map <- read_files(mappt.files)
  matemp <- read_files(matemp.files)
  mapincr <- read_files(mappt.incr.files)
  matempincr <- read_files(matemp.incr.files)

  # temp in NHD given centegrate * 100
  # scale temp data to deg C
  matemp[, "TEMPVC"] <- matemp[, "TEMPVC"] / 100
  matempincr[, "TEMPV"] <- matempincr[, "TEMPV"] / 100
  data.out <- as.data.frame(unique(full.net[,c("net.id", "group.comid", "vpu")]))
  #names(data.out)[1] <- "COMID"

  ##### mean annual temperature
  #CumTotTemp is cumulative down the network
  #consequently, the value at the COMID is the network total
  #cumtemp removes values for each reach in the network (tot already incorporates this)
  #cumtottemp is area weighted average of sub-basins

  #area weighted average is modified my M value
  #if m value = 1 for all comid them result is cumtot value below
  cumtemp.data <- matemp[as.character(matemp[, "net.comid"]) == as.character(matemp[, "group.comid"]), ]
  matempincr$wt <- matempincr$AREASQKM*matempincr$M

  incrtemp.data <- by(matempincr, list(matempincr$net.id, matempincr$month),
          function(x) weighted.mean(x$TEMPV, x$wt))
  #changes "by" class into data.frame
  incrtemp.data <- do.call(rbind, list(incrtemp.data))
  incrtemp.data <- reshape::melt(incrtemp.data)
  names(incrtemp.data) <- c("net.id", "month", "TEMPV")

  cumtemp.data <- merge(incrtemp.data, cumtemp.data, by = c("net.id", "month"))

  # bio1 = annual mean temperature
  MAT <- cumtemp.data[cumtemp.data[,"month"] == "MA", c("net.id", "MISSDATAA", "TEMPV")]
  #assigns field names
  #merges mean annual temp to output file
  data.out <- merge(data.out, MAT, by= "net.id",#by.x = "COMID", by.y = "group.comid",
                    all.x = T)

  #bio 4 - seasonality (do not have max or min temps so skipped bio3 and bio4)
  #aggregate all months other than mean annual temp calculate
  CUMTEMPMM <- cumtemp.data[cumtemp.data[ ,"month"] != "MA", ]

  seasonality_t <- aggregate(CUMTEMPMM[ ,"TEMPV"],
                       by = list(CUMTEMPMM[ ,"net.id"]),
                       sd)
  names(seasonality_t) <- c("net.id", "seasonality_t")
  data.out <- merge(data.out,seasonality_t, by = "net.id", all.x = T)

  # Bio 5 temp of warmest month (NOT BIOCLIM VARIABLE dont have minT)
  warm_mo_t <- aggregate(CUMTEMPMM[ ,"TEMPV"], by = list(CUMTEMPMM[,"net.id"]), max)
  names(warm_mo_t) <- c("net.id", "warm_mo_t")
  #left here undat V and net.id
  warm_mo <- CUMTEMPMM[CUMTEMPMM[,"net.id"] %in% warm_mo_t[,"net.id"] &
                         CUMTEMPMM[,"TEMPV"] %in% warm_mo_t[,"warm_mo_t"],
                           c("net.id", "month")]
  names(warm_mo) <- c("net.id", "warm_mo")
  warm_mo <- merge(warm_mo, warm_mo_t, by = "net.id", all.x = T)
  data.out <- merge(data.out, warm_mo,  by = "net.id", all.x = T)

  #Bio 6 temp of coldest month (NOT BIOCLIM VARIABLE dont have minT)
  cold_mo_t <- aggregate(CUMTEMPMM[ ,"TEMPV"],
                         by=list(CUMTEMPMM[ ,"net.id"]),
                         min)
  names(cold_mo_t)<-c("net.id", "cold_mo_t")
  cold_mo <- CUMTEMPMM[CUMTEMPMM[,"net.id"] %in% cold_mo_t[,"net.id"] &
                            CUMTEMPMM[,"TEMPV"] %in% cold_mo_t[,"cold_mo_t"],
                           c("net.id", "month")]
  names(cold_mo) <- c("net.id", "cold_mo")
  cold_mo <- merge(cold_mo, cold_mo_t, by = "net.id", all.x = T)
  data.out <- merge(data.out, cold_mo, by = "net.id", all.x = T)

  #bioclim 7 - modified temp of warmest mo minus tem of coldest month
  diff_t <- data.out[,"warm_mo_t"] - data.out[,"cold_mo_t"]
  data.out <- data.frame(data.out, diff_t)
  # identify three consecutive months which highest and lowest precip values
  comid.str <- unique(CUMTEMPMM[,"net.id"])
  hot.cold.q<-data.frame(net.id= character(), COMID=character(),
                         warm_q_t = character(),
                         warm_q = character(), cold_q_t = character(),
                         cold_q = character())
  for (i in 1:length(comid.str)) {
    # select from CUMTEMPMM the focal comid
    f <- CUMTEMPMM[CUMTEMPMM[,"net.id"] == comid.str[i], ]
    quarter.mean <- data.frame(q.mean = character(),
                               month = character())
    for (j in 1:length(f[,1])){
      if (j <= 12){
            # if the sum is less than 12
        if (j + 2 <= 12){
              q.mean <- mean(f[c(j, j+1, j+2), "TEMPV"])
              month <- paste(f[j, "month"], f[j+1, "month"], f[j+2, "month"], sep =",")
              quarter.mean <- rbind(quarter.mean, cbind(q.mean, month))
              } else if (j + 2 == 13){
                q.mean <- mean(f[c(j, j + 1, 1), "TEMPV"])
                month <- paste(f[j, "month"], f[j + 1, "month"], f[1, "month"], sep =",")
                quarter.mean <- rbind(quarter.mean, cbind(q.mean, month))
                } else if (j + 2 == 14){
                  q.mean <- mean(f[c(j, 1, 2), "TEMPV"])
                  month <- paste(f[j,"month"],f[1,"month"],f[2,"month"], sep = ",")
                  quarter.mean <- rbind(quarter.mean, cbind(q.mean, month))
                  }
          }
    }

        warm_q_t <- quarter.mean[
          quarter.mean[,"q.mean"] ==
            max(as.numeric(as.character(quarter.mean[,"q.mean"]))),
          c("q.mean","month")]
         names(warm_q_t) <- c("warm_q_t", "warm_q")
         cold_q_t <- quarter.mean[
           quarter.mean[,"q.mean"] ==
             min(as.numeric(as.character(quarter.mean[,1]))),
           c("q.mean", "month")]

         names(cold_q_t) <- c("cold_q_t","cold_q")
         net.id <- as.character(comid.str[i])
         hot.cold.q <- rbind(hot.cold.q,
                             data.frame(net.id, warm_q_t, cold_q_t))
  }

  data.out <- merge(data.out,hot.cold.q, by = "net.id", all.x = T)

  ######mean annaul ppt
  #CumTotPrecip is cumulative down the network
  #consequently, the value at the COMID is the network total
  map[,"PRECIPVC"] <- map[,"PRECIPVC"] / 100
  mapincr[,"PRECIPV"] <- mapincr[,"PRECIPV"] / 100

  cumppt.data <- map[as.character(map[, "net.comid"]) == as.character(map[, "group.comid"]), ]

  incrmap.data <- by(mapincr, list(mapincr$net.id, mapincr$month),
                      function(x) weighted.mean(x$PRECIPV, x$AREASQKM*x$M))

  #changes "by" class into data.frame
  incrmap.data <- do.call(rbind, list(incrmap.data))

  incrmap.data <- reshape::melt(incrmap.data)
  names(incrmap.data) <- c("net.id", "month", "PRECIPV")

  cumppt.data <- merge(incrmap.data, cumppt.data, by = c("net.id", "month"))

  #total mean monthly precipitation (sum of all monthly means) cf with sum.  BIO12
  tot_ppt <- cumppt.data[cumppt.data[,"month"]=="MA", c("net.id" , "MISSDATAA" , "PRECIPV")]

  data.out <- merge(data.out,tot_ppt, by = "net.id", all.x = T)

  #select monthly ppt data
  CUMPPTMM <- cumppt.data[cumppt.data[ ,"month"] != "MA", ]
  #ppt of wettest month bio13
  wet_mo_p <- aggregate(CUMPPTMM[,"PRECIPV"],
                   by = list(CUMPPTMM[,"net.id"]),
                   max)
  names(wet_mo_p) <- c("net.id", "wet_mo_p")
  wet_mo <- CUMPPTMM[CUMPPTMM[,"net.id"] %in% wet_mo_p[,"net.id"]&
                           CUMPPTMM[,"PRECIPV"] %in% wet_mo_p[,"wet_mo_p"],
                            c("net.id", "month")]
  names(wet_mo) <- c("net.id", "wet_mo")
  wet_mo_p <- merge(wet_mo, wet_mo_p, by = "net.id",
                    all.x = T)
  data.out <- merge(data.out, wet_mo_p, by ="net.id", all.x = T)

  #ppt of driest month bio14
  dry_mo_p <- aggregate(CUMPPTMM[,"PRECIPV"],
                   by = list(CUMPPTMM[,"net.id"]),
                   min)
  names(dry_mo_p) <- c("net.id", "dry_mo_p")
  dry_mo <- CUMPPTMM[CUMPPTMM[,"net.id"] %in% dry_mo_p[,"net.id"]&
                       CUMPPTMM[,"PRECIPV"] %in% dry_mo_p[,"dry_mo_p"],
                          c("net.id","month")]
  names(dry_mo) <- c("net.id", "dry_mo")
  dry_mo_p <- merge(dry_mo, dry_mo_p, by = "net.id", all.x = T)
  data.out <- merge(data.out, dry_mo_p, by = "net.id", all.x = T)

  #Precipitaton seasonality - Coeffieient of variation (BIO15)
  seasonality_p <- aggregate(CUMPPTMM[,"PRECIPV"],
                               by = list(net.id = CUMPPTMM[,"net.id"]),
                           function (x) c(stdev = sd(x), mean = mean(x)))
  seasonality_p <- data.frame(net.id = as.character(seasonality_p[,"net.id"]),
                              seasonality_p = as.numeric(seasonality_p[ ,"x"][,"stdev"] /
                                                         seasonality_p[ ,"x"][ ,"mean"]))
  data.out <- merge(data.out, seasonality_p, by = "net.id", all.x = T)

  #Identify dry and wet quarters
  comid.str <- unique(CUMPPTMM[,"net.id"])
  dry.wet.q <- data.frame(net.id = character(), COMID = character(),
                          wet_q_p = numeric(), wet_q = character(), dry_q_p = numeric(),
                          dry_q = character())
  for(i in 1:length(comid.str)){
      f <- CUMPPTMM[CUMPPTMM[,"net.id"] == comid.str[i], ]
      quarter.sum <- data.frame(q.sum = numeric(), month = character())
    #loop over each row in focal comid "f"
    for (j in 1:length(f[,1])){
      if (j <= 12){
        if ( j+2 <= 12){
          q.sum <- sum(f[c(j, j+1, j+2), "PRECIPV"])
          month <- paste(f[j, "month"], f[j+1, "month"], f[j+2, "month"],
                         sep = ",")
          quarter.sum<-rbind(quarter.sum,data.frame(q.sum,month))
          } else if (j+2 == 13){
            q.sum <- sum(f[c(j, j+1, 1), "PRECIPV"])
            month <- paste(f[j, "month"], f[j+1, "month"], f[1, "month"],
                           sep = ",")
            quarter.sum <- rbind(quarter.sum, data.frame(q.sum, month))
            } else if (j+2 == 14){
              q.sum <- sum(f[c(j, 1, 2), "PRECIPV"])
              month<-paste(f[j, "month"], f[1, "month"], f[2, "month"],
                           sep = ",")
              quarter.sum <- rbind(quarter.sum, data.frame(q.sum, month))
        }
      }
    }
      wet_q_p <- quarter.sum[quarter.sum[,1] == max(quarter.sum[,1]), 1]
      wet_q <- quarter.sum[quarter.sum[,1] == max(quarter.sum[,1]), 2]
      dry_q_p <- quarter.sum[quarter.sum[,1] == min(quarter.sum[,1]), 1]
      dry_q <- quarter.sum[quarter.sum[,1] == min(quarter.sum[,1]),2]

      net.id <- as.character(comid.str[i])
      dry.wet.q <- rbind(dry.wet.q, data.frame(net.id, wet_q_p, wet_q, dry_q_p, dry_q))
  }

  data.out <- merge(data.out, dry.wet.q, by = "net.id", all.x = T)

  # quarter sum funtion:
  # mean temp of dry/wet quarter or mean ppt of warm/cold q
  quart_sum <- function(data, quarter, data.out) {
    if (any(names(data) == "TEMPV")){
      s <- "TEMPV"
      } else if (any(names(data) == "PRECIPV")){
        s <- "PRECIPV"
        }
    q <- strsplit(as.character(data.out[ ,quarter]), ",")
    names(q) <- data.out[,"net.id"]
    pt <- data.frame(net.id = character(), x = numeric())

    for (i in names(q)) {
      p <- data[data[,"net.id"] == i,
                c(s, "month")]
      pt <- rbind(pt, data.frame(net.id = i, x = mean(p[p[,"month"] %in% q[i][[1]], s])))
    }
    return(pt)
  }
  # mean temp of dry/wet quarter
  dry_q_t <- quart_sum(CUMTEMPMM, quarter ="dry_q", data.out)
  names(dry_q_t)[2] <-"dry_q_t"
  # mean temp of wet quarter
  wet_q_t <- quart_sum(CUMTEMPMM, "wet_q", data.out)
  names(wet_q_t)[2] <- "wet_q_t"
  # mean ppt of warm q
  warm_q_p <- quart_sum(CUMPPTMM, "warm_q", data.out)
  names(warm_q_p)[2] <- "warm_q_p"
  # mean ppt of cold q
  cold_q_p <- quart_sum(CUMPPTMM, "cold_q", data.out)
  names(cold_q_p)[2] <- "cold_q_p"

  data.out <- Reduce(function(x, y)
    merge(x, y, by = "net.id", all.x = T),
    list(data.out, dry_q_t, wet_q_t, warm_q_p, cold_q_p))

  return(data.out)
str(data.out)
  }


source('source.uvp.r')
source('source.uvp.add.r')
source('source.uvp.plots.r')
source('source.uvp.post.r')
source('source.r')

#### Load the Data, C directory
input.dir = '../UVP Data/All PAR files/'
input.dir.meta = '../UVP Data/All Metadata files/'

raw.files = list.files(input.dir)                     #All years
meta.files = list.files(input.dir.meta)

#Reading in only first metadata file.
meta = as.data.frame(fread(paste0(input.dir.meta, meta.files[1])))

#Combining with the rest.
for (i in 2:length(meta.files)) {
  meta = rbind(meta, as.data.frame(fread(paste0(input.dir.meta, meta.files[i]))))
}

### Load Ancillaries
load('../Other Data/SedTrap.rdata')
load('../Other Data/Thorium.interp.all.rdata')
load('../Other Data/CTD.rdata')
load('../Other Data/FP.rdata')
load('../rstates/Supplemental.rdata')

grid = expand.grid(A = seq(10, 18, by = 1), b = seq(1.5, 4.5, by = 0.5), score = 0, r2 = 0)
grid = expand.grid(A = seq(12.2, 13.8, by = 0.15), b = seq(1.4, 1.6, by = 0.025), score = 0, R2 = 0)
verbose = FALSE

for (i in 1:nrow(grid)) {
  print(paste('Grid entry ', i, ' (', Sys.time(), ')  ::   A = ', grid$A[i], '  B = ', grid$b[i]))

  k = 3
  ##Looping through all the files for a given year
  cruises = run.all.data(raw.files, A = grid$A[i], b = grid$b[i], dz = 5, ctd = ctd, verbose = FALSE, k = k)

  if (verbose) {
    print('Raw data loaded.')
  }

  cruises = check.casts(cruises, TRUE)
  cruises = add.spectra.model(cruises)
  cruises = add.export.fp(cruises, fp)

  if (verbose) {
    print('Casts checked.')
  }

  st.comp = build.st.comparison(cruises, average = TRUE)
  #fp.comp = build.fp.comparison(cruises, average = TRUE)
  #fp.st.comp = build.fp.st.comparison(cruises, average = TRUE)

  if (verbose) {
    print('Comparison Generated.')
  }

  #Plot cycle averaged
  png(filename = paste0("../Images/Grid/New Small (11) -", i,".png"))

  plot(st.comp$ST, st.comp$Total, pch=16, xlim=c(0,600), ylim=c(0,600), xaxs='i', yaxs='i',
       ylab = 'UVP Flux', xlab = 'ST Flux', main = paste0('A = ', cruises[[1]]$params$A, '     B = ', cruises[[1]]$params$b))
  add.one.to.one()
  add.error.bars(st.comp$ST, st.comp$ST.sd, st.comp$Total, st.comp$Total.sd)

  model = bootstrap(st.comp$ST, st.comp$ST.sd, st.comp$Total, st.comp$Total.sd, n = 1000)
  add.boot.conf(model, trendline = TRUE)

  score = sum((log(st.comp$Total) - log(st.comp$ST))^2) ## Guidi's Score

  #score = sum(((st.comp$Total-st.comp$ST)/st.comp$ST.sd)^2, na.rm = TRUE)
  r2 = 1 - sum((st.comp$Total - st.comp$ST * median(model$m) + median(model$b))^2) /
    sum((st.comp$Total - mean(st.comp$Total, na.rm = TRUE))^2)

  grid$score[i] = score
  grid$r2[i] = r2

  text(50, 575, paste0('m = ', floor(median(model$m)*100)/100))
  text(50, 545, paste0('b = ', floor(median(model$b)*100)/100))
  text(50, 515, paste0('S = ', floor(score)))
  text(50, 490, paste0('R2 = ', floor(r2*100)/100))

  dev.off()

  png('../Images/Full Grid Search Status.png')

  plot(grid$A, grid$b, col = make.seq.pal(grid$score, n = 16, min = 0, max = 30, rev = TRUE, pal = 'ocean.ice'), pch=15, cex=1.2,
       xlim = c(7.3, 20), ylim = c(1, 4.8), xlab = 'A', ylab = 'b', main = 'Misfit')
  points(grid$A, grid$b, pch = 0, cex = 1.2, col = 'grey')
  text(grid$A, grid$b, c(1:nrow(grid)), cex= 0.3)

  ## Colorbar
  add.colorbar(0, 30, 9, 1.7, 9, 3.7, pal = 'ocean.ice', rev = TRUE, n = 16)

  ## Reference values
  points(12.1, 3.81, cex=2, pch = 16)
  points(grid$A[which.min(grid$score)], grid$b[which.min(grid$score)], pch=2, cex=3)

  dev.off()
}

#### Summary Figure

pdf('../Images/Full Grid Search Example.pdf')

plot(grid$A, grid$b, col = make.seq.pal(grid$score, n = 16, min = 10, max = 50, rev = TRUE), pch=15, cex=1.2,
     xlim = c(12, 14), ylim = c(1.4, 1.8), xlab = 'A', ylab = 'b', main = 'Misfit')
points(grid$A, grid$b, pch = 0, cex = 1.2, col = 'grey')
add.colorbar(0, 300, 9, 1.7, 9, 3.7, pal = 'YlOrRd', rev = TRUE, n = 16)
points(12.1, 3.81, cex=2, pch = 16)
points(grid$A[which.min(grid$score)], grid$b[which.min(grid$score)], pch=2, cex=3)
text(grid$A, grid$b, c(1:nrow(grid)), cex= 0.3)

plot(grid$A, grid$b, col = make.seq.pal(grid$r2, n = 16, min = 0, max = 1, rev = TRUE), pch=15, cex=1.2,
     xlim = c(7.3, 20), ylim = c(1, 4.8), xlab = 'A', ylab = 'b', main = 'R2')
points(grid$A, grid$b, pch = 0, cex = 1.2, col = 'grey')
add.colorbar(0, 1, 9, 1.7, 9, 3.7, pal = 'YlOrRd', rev = TRUE, n = 16)
points(12.1, 3.81, cex=2, pch = 16)
points(grid$A[which.min(grid$score)], grid$b[which.min(grid$score)], pch=2, cex=3)
points(grid$A[which.max(grid$r2)], grid$b[which.max(grid$r2)], pch=2, cex=3)
text(grid$A, grid$b, c(1:nrow(grid)), cex= 0.3)

dev.off()


library(zoo)
library(tidyverse)
library(haven)
library(lubridate)

#datO <- read_sav('data/CINICS altogether no HbA1C.sav')
#dat <- datO
dat <- read_sav('data/CINICS altogether no HbA1C.sav')
for(i in which(sapply(dat,is.character))) dat[[i]][dat[[i]]==''] <- NA

naclass <- function(cls){
  x <- NA
  class(x) <- cls
  x
}
naForCls <- sapply(unique(sapply(dat,class)),naclass,simplify=FALSE)

dat <-
  dat%>%filter(!is.na(Date))%>%
  mutate_at(c('cig3c','anxlevel'),as.numeric)

recodeHavenLabelled <- function(x){
  if(!inherits(x,"haven_labelled" )) return(x)
  names(attr(x,'labels'))[match(x,attr(x,'labels'))]
}

### what subject characteristics are stable?
## stable <- dat%>%group_by(StudyId)%>%mutate(nobs=n())%>%filter(nobs>1)%>%
##  summarize_at(vars(BirthYear,ends_with('_R'),Site),n_distinct,na.rm=TRUE)

## lapply(stable[,-1],table)

## create stable covariate dataset, one line per subject
covs <-
  dat%>%
  group_by(StudyId)%>%
  mutate_if(~inherits(.,'haven_labelled'),recodeHavenLabelled)%>%
  mutate(BirthYear=as.numeric(BirthYear))%>%
  summarize_at(
    vars(BirthYear:Race_R,Site),
    ~ if(all(is.na(.))) .[1] else unique(na.omit(.))[1]
  )%>%
  mutate(
    Site=ifelse(is.na(Site),"NA",Site),
    gender=ifelse(is.na(PresentSex_R),birthSex_R,PresentSex_R)
    )

## for variables that change over time, we want one row per subject/date:
dat <- dat%>%
  select(!!c('StudyId',setdiff(names(dat),names(covs)),'BirthYear'))%>%
  group_by(StudyId,Date)%>%
  summarize_all(~ ifelse(all(is.na(.)),.[1],unique(na.omit(.))[1]))%>%
  mutate(age=lubridate::year(Date)-BirthYear)%>%
  ungroup()%>%
  select(-BirthYear)

## ndate <- dat%>%group_by(StudyId)%>%summarize(ndate=n_distinct(Date))

## dateSep <- dat%>%group_by(StudyId)%>%arrange(Date)%>%mutate(ndate=n(),dateGap=Date-lag(Date))%>%
##   summarize(ndate=ndate[1],
##     minGap=ifelse(ndate==1,-1,min(dateGap,na.rm=TRUE)),
##     maxGap=ifelse(ndate==1,-1,max(dateGap,na.rm=TRUE)))

## plotSep <- dateSep%>%filter(ndate>1)%>%gather(minMax,gap,minGap,maxGap)

## ggplot(plotSep%>%filter(gap<50),aes(gap))+geom_histogram(bins=100)+facet_wrap(~minMax)

## quantile(dateSep$minGap[dateSep$minGap>0],seq(0,1,.05))

### numeric variables that are almost always (>90%) equal to 0 -> dichotomous
dat <- dat%>%
    mutate_if(
        function(x) is.numeric(x)&mean(x==0,na.rm=TRUE)>0.9,
        function(x) ifelse(x>0,1,0)
    )

### combine hard drugs
dat <- mutate(dat,anyHard=ifelse(OPI_SUM>0|COC_SUM>0|AMPH_SUM>0,1,0))

alc <- read_csv('data/PRO_AlcoholAudit.csv')

alc <- alc%>%
  mutate(
    alcCat=ifelse(alcriskhi=='',NA,
      ifelse(alcrisklo=='not at risk',1,
      ifelse(alcriskhi=='not at risk',2,3))),
    StudyId=as.numeric(StudyId)
  )%>%
  select(StudyId,Date,alcCat)%>%
  filter(StudyId%in%dat$StudyId)

dat <- full_join(dat,alc)

adhere <- read_csv('data/PRO_Adherence.csv')%>%
  mutate(
    adhere=ifelse(selfrt=='',NA,
      ifelse(selfrt=='Very poor'|selfrt=='Poor',1,
      ifelse(selfrt=='Fair',2,
      ifelse(selfrt=='Good',3,
      ifelse(selfrt=='Very good',4,5))))),
    StudyId=as.numeric(StudyId))%>%
  select(StudyId,Date,adhere)%>%
  filter(StudyId%in%dat$StudyId)

dat <- full_join(dat,adhere)

diagnosis <- read_csv('data/Diagnosis.csv')%>%
  group_by(StudyId)%>%
  summarize(diab=ifelse(any(DxCategory=='Diabetes: Type 2'|DxCategory=='Diabetes: Type unspecified'),1,0))%>%
  mutate(StudyId=as.numeric(StudyId))

dat <- left_join(dat,diagnosis)

cd4 <- read_csv('data/Lab.csv')%>%
  filter(TestName=='CD4 cell absolute')%>%
  transmute(
    Date=date(ResultDate),
    cd4=as.numeric(Result),
    StudyId=as.numeric(StudyId))%>%
  filter(!is.na(cd4),cd4<100000,StudyId%in%dat$StudyId)
## one cd4 count is almost 1M which is not possible and skews everything

### some duplicate dates for some reason:
# ns <- cd4%>%group_by(StudyId)%>%summarize(nrec=n(),ndate=n_distinct(Date))
# sum(ns$nrec-ns$ndate)
# [1] 369
cd4 <- cd4%>%group_by(StudyId,Date)%>%summarize(cd4=round(mean(cd4,na.rm=TRUE)))

dat <- full_join(dat,cd4)

ns <- dat%>%group_by(StudyId)%>%summarize(nrec=n(),ndate=n_distinct(Date))
mean(ns$nrec==ns$ndate)

## merge covs back in
dat <- full_join(dat,covs,by='StudyId')%>%
    mutate(age=lubridate::year(Date)-BirthYear)

save(dat,file='data/cleanedData.RData')


## Functions for exploring and plotting results from Imperial model
#
# Richard T. Gray
#
# This script when sourced loads various functions for extracting and
# producing results. Based on the code used in plot-3-panel.r and
# plot-forecast.r. Attempt to make it more succinct and based on my
# preferences.

library(ggplot2)
library(tidyr)
library(dplyr)
library(rstan)
library(data.table)
library(lubridate)
library(gdata)
library(EnvStats)
library(matrixStats)
library(scales)
library(gridExtra)
library(ggpubr)
library(cowplot)
library(bayesplot)
# library(svglite)

source("utils/geom-stepribbon.r")

# Fitting results ------------------------
StanResults <- function(countries,JOBID,out,resultsDir) {
  filename <- paste0('base-',JOBID)
  mu = (as.matrix(out$mu))
  colnames(mu) = countries
  g = (mcmc_intervals(mu,prob = .9))
  ggsave(paste0(resultsDir, filename, "-mu.png"),g,width=4,height=6)
  # ggsave(sprintf("results/%s-mu.png",filename),g,width=4,height=6)
  tmp = lapply(1:length(countries), function(i) (out$Rt_adj[,stan_data$N[i],i]))
  Rt_adj = do.call(cbind,tmp)
  colnames(Rt_adj) = countries
  g = (mcmc_intervals(Rt_adj,prob = .9))
  ggsave(paste0(resultsDir, filename, "-final-rt.png"),g,width=4,height=6)
  # ggsave(sprintf("results/%s-final-rt.png",filename),g,width=4,height=6)
  return(list("mu" = mu, "Rt_adj" = Rt_adj))
}

## Impact no NPIs -predictions if R0 stays at original value
resultsR0 <- function(stanData, stanOut) {
  stanruns <- nrow(stanOut$mu)

  infections <- array(rep(0, stanruns*stanData$N2*stanData$M),
    c(stanruns, stanData$N2, stanData$M))
  cummInfects <- infections
  deaths <- infections
  y <- stanOut$prediction[,1,]

  for (ii in 1:stanData$M) {
    population <- rep(stanData$pop[ii], stanruns)
    infections[,1,ii] <- y[,ii]
    for (jj in 2:stanData$N0){
      cummInfects[,jj,ii] <- cummInfects[,jj-1,ii] + y[,ii];
      infections[,jj,ii] <- y[,ii]
    }

    for (jj in (stanData$N0+1):stanData$N2) {
      convolution0 <- rep(0, stanruns)
      for(kk in 1:(jj-1)) {
        convolution0 <- convolution0 + infections[,kk,ii] *
          stanData$SI[jj-kk];
      }
      infections[,jj,ii] =  ((population[ii]-cummInfects[,jj-1,ii]) /
          population[ii]) * stanOut$mu[,ii] * convolution0;

      cummInfects[,jj,ii] = cummInfects[,jj-1,ii] + infections[,jj,ii];

    }

    deaths[,1,ii] = 1e-15 * infections[,1,ii];
    for (jj in 2:stanData$N2){
      for(kk in 1:(jj-1)){
        deaths[,jj,ii] <- deaths[,jj,ii] + infections[,kk,ii] *
          stanData$f[jj-kk,ii] * stanOut$ifr_noise[,ii]
      }
    }
  }

  return(list("infections" = infections, "deaths" = deaths))
}

# Sort out covariates ----------------------------------------------------
TidyCovariates <- function(ncountries, covariates) {
  names_covariates = c('Schools + Universities','Self-isolating if ill',
    'Public events', 'Lockdown', 'Social distancing encouraged')
  covariates <- covariates %>%
    filter((Type %in% names_covariates))
  covariates <- covariates[,c(1,2,4)]
  covariates <- spread(covariates, Type, Date.effective)
  names(covariates) <- c('Country','lockdown', 'public_events',
    'schools_universities','self_isolating_if_ill',
    'social_distancing_encouraged')
  covariates <- covariates[c('Country','schools_universities',
    'self_isolating_if_ill', 'public_events', 'lockdown',
    'social_distancing_encouraged')]
  covariates$schools_universities <- as.Date(covariates$schools_universities,
    format = "%d.%m.%Y")
  covariates$lockdown <- as.Date(covariates$lockdown, format = "%d.%m.%Y")
  covariates$public_events <- as.Date(covariates$public_events,
    format = "%d.%m.%Y")
  covariates$self_isolating_if_ill <- as.Date(covariates$self_isolating_if_ill,
    format = "%d.%m.%Y")
  covariates$social_distancing_encouraged <- as.Date(covariates$social_distancing_encouraged, format = "%d.%m.%Y")

  return(covariates)

}

CountryCovariates <- function(country, covariates,rt_ui) {

  covariates_country <- covariates[which(covariates$Country == country), 2:6]
  covariates_country_long <- gather(covariates_country[], key = "key",
    value = "value")
  covariates_country_long$x <- rep(NULL, length(covariates_country_long$key))
  un_dates <- unique(covariates_country_long$value)

  for (k in 1:length(un_dates)){
    idxs <- which(covariates_country_long$value == un_dates[k])
    max_val <- round(max(rt_ui)) + 0.3
    for (j in idxs){
      covariates_country_long$x[j] <- max_val
      max_val <- max_val - 0.3
    }
  }

  covariates_country_long$value <- as_date(covariates_country_long$value)
  covariates_country_long$country <- rep(country,
    length(covariates_country_long$value))

  return(covariates_country_long)
}

# Country estimates  ------------------------------------------------------
CountryOutputs <- function(index,country,dates,reported_cases,
  deaths_by_country,prediction,estimated.deaths,rt) {

  N <- length(dates)
  predicted_cases <- colMeans(prediction[,1:N,index])
  predicted_cases_li <- colQuantiles(prediction[,1:N,index], probs=.025)
  predicted_cases_ui <- colQuantiles(prediction[,1:N,index], probs=.975)
  predicted_cases_li2 <- colQuantiles(prediction[,1:N,index], probs=.25)
  predicted_cases_ui2 <- colQuantiles(prediction[,1:N,index], probs=.75)

  cum_predicted_cases <- rowCumsums(prediction[,1:N,index])

  estimated_deaths <- colMeans(estimated.deaths[,1:N,index])
  estimated_deaths_li <- colQuantiles(estimated.deaths[,1:N,index],
    probs=.025)
  estimated_deaths_ui <- colQuantiles(estimated.deaths[,1:N,index],
    probs=.975)
  estimated_deaths_li2 <- colQuantiles(estimated.deaths[,1:N,index],
    probs=.25)
  estimated_deaths_ui2 <- colQuantiles(estimated.deaths[,1:N,index],
    probs=.75)

  cum_predicted_deaths <- rowCumsums(estimated.deaths[,1:N,index])

  rt <- colMeans(out$Rt[,1:N,index])
  rt_li <- colQuantiles(out$Rt[,1:N,index],probs=.025)
  rt_ui <- colQuantiles(out$Rt[,1:N,index],probs=.975)
  rt_li2 <- colQuantiles(out$Rt[,1:N,index],probs=.25)
  rt_ui2 <- colQuantiles(out$Rt[,1:N,index],probs=.75)

  data_country <- data.frame("time" = as_date(as.character(dates)),
    "country" = rep(country, length(dates)),
    "reported_cases" = reported_cases[[index]],
    "reported_cases_c" = cumsum(reported_cases[[index]]),

    "predicted_cases_c" = colMeans(cum_predicted_cases),
    "predicted_min_c" = colQuantiles(cum_predicted_cases, probs=.025),
    "predicted_max_c" = colQuantiles(cum_predicted_cases, probs=.975),
    "predicted_cases" = predicted_cases,
    "predicted_min" = predicted_cases_li,
    "predicted_max" = predicted_cases_ui,
    "predicted_min2" = predicted_cases_li2,
    "predicted_max2" = predicted_cases_ui2,
    "deaths" = deaths_by_country[[index]],
    "deaths_c" = cumsum(deaths_by_country[[index]]),
    "estimated_deaths_c" =  colMeans(cum_predicted_deaths),
    "death_min_c" = colQuantiles(cum_predicted_deaths, probs=.025),
    "death_max_c"= colQuantiles(cum_predicted_deaths, probs=.975),

    "estimated_deaths" = estimated_deaths,
    "death_min" = estimated_deaths_li,
    "death_max"= estimated_deaths_ui,
    "death_min2" = estimated_deaths_li2,
    "death_max2"= estimated_deaths_ui2,
    "rt" = rt,
    "rt_min" = rt_li,
    "rt_max" = rt_ui,
    "rt_min2" = rt_li2,
    "rt_max2" = rt_ui2)

  return(data_country)

}

CountryForecast <- function(index,country,dates,forecast,prediction,
  estimated.deaths) {
  N <- length(dates)
  N2 <- N + forecast

  predicted_cases_forecast <- colMeans(prediction[,1:N2,index])[N:N2]
  predicted_cases_li_forecast <- colQuantiles(prediction[,1:N2,index],
    probs=.025)[N:N2]
  predicted_cases_ui_forecast <- colQuantiles(prediction[,1:N2,index],
    probs=.975)[N:N2]

  estimated_deaths_forecast <- colMeans(estimated.deaths[,1:N2,index])[N:N2]
  estimated_deaths_li_forecast <- colQuantiles(estimated.deaths[,1:N2,index],
    probs=.025)[N:N2]
  estimated_deaths_ui_forecast <- colQuantiles(estimated.deaths[,1:N2,index],
    probs=.975)[N:N2]

  times <- as_date(as.character(dates))
  times_forecast <- times[length(times)] + 0:forecast
  data_country_forecast <- data.frame("time" = times_forecast,
    "country" = rep(country, forecast+1),
    "predicted_cases_forecast" = predicted_cases_forecast,
    "predicted_min_forecast" = predicted_cases_li_forecast,
    "predicted_max_forecast"= predicted_cases_ui_forecast,
    "estimated_deaths_forecast" = estimated_deaths_forecast,
    "death_min_forecast" = estimated_deaths_li_forecast,
    "death_max_forecast"= estimated_deaths_ui_forecast)

  return(data_country_forecast)

}

CountryForecastR0 <- function(index,country,dates,forecast,predictionR0) {

  N <- length(dates)
  N2 <- N + forecast

  predicted_cases <- colMeans(predictionR0$infections[,1:N2,index])
  predicted_cases_li <- colQuantiles(predictionR0$infections[,1:N2,index],
    probs=.025)
  predicted_cases_ui <- colQuantiles(predictionR0$infections[,1:N2,index],
    probs=.975)
  predicted_cases_li2 <- colQuantiles(predictionR0$infections[,1:N2,index],
    probs=.25)
  predicted_cases_ui2 <- colQuantiles(predictionR0$infections[,1:N2,index],
    probs=.75)

  cum_predicted_cases <- rowCumsums(predictionR0$infections[,1:N2,index])

  estimated_deaths <- colMeans(predictionR0$deaths[,1:N2,index])
  estimated_deaths_li <- colQuantiles(predictionR0$deaths[,1:N2,index],
    probs=.025)
  estimated_deaths_ui <- colQuantiles(predictionR0$deaths[,1:N2,index],
    probs=.975)
  estimated_deaths_li2 <- colQuantiles(predictionR0$deaths[,1:N2,index],
    probs=.25)
  estimated_deaths_ui2 <- colQuantiles(predictionR0$deaths[,1:N2,index],
    probs=.75)

  cum_predicted_deaths <- rowCumsums(predictionR0$deaths[,1:N2,index])

  times <- as_date(as.character(dates))
  times_forecast <- c(times, times[length(times)] + 1:forecast)
  data_country_R0 <- data.frame("time" = times_forecast,
    "country" = rep(country, length(times_forecast)),
    "predicted_cases_c" = colMeans(cum_predicted_cases),
    "predicted_min_c" = colQuantiles(cum_predicted_cases, probs=.025),
    "predicted_max_c" = colQuantiles(cum_predicted_cases, probs=.975),
    "predicted_cases" = predicted_cases,
    "predicted_min" = predicted_cases_li,
    "predicted_max" = predicted_cases_ui,
    "predicted_min2" = predicted_cases_li2,
    "predicted_max2" = predicted_cases_ui2,
    "estimated_deaths_c" =  colMeans(cum_predicted_deaths),
    "death_min_c" = colQuantiles(cum_predicted_deaths, probs=.025),
    "death_max_c"= colQuantiles(cum_predicted_deaths, probs=.975),
    "estimated_deaths" = estimated_deaths,
    "death_min" = estimated_deaths_li,
    "death_max"= estimated_deaths_ui,
    "death_min2" = estimated_deaths_li2,
    "death_max2"= estimated_deaths_ui2)

  return(data_country_R0)

}

# Plotting functions ------------------------------------------------------

make_plots <- function(data_country, covariates_country_long,
  filename2, figuresDir, country){

  data_cases_95 <- data.frame(data_country$time, data_country$predicted_min,
    data_country$predicted_max)
  names(data_cases_95) <- c("time", "cases_min", "cases_max")
  data_cases_95$key <- rep("nintyfive", length(data_cases_95$time))
  data_cases_50 <- data.frame(data_country$time, data_country$predicted_min2,
    data_country$predicted_max2)
  names(data_cases_50) <- c("time", "cases_min", "cases_max")
  data_cases_50$key <- rep("fifty", length(data_cases_50$time))
  data_cases <- rbind(data_cases_95, data_cases_50)
  levels(data_cases$key) <- c("ninetyfive", "fifty")

  p1 <- ggplot(data_country) +
    geom_bar(data = data_country, aes(x = time, y = reported_cases),
      fill = "coral4", stat='identity', alpha=0.5) +
    geom_ribbon(data = data_cases, aes(x = time, ymin = cases_min,
      ymax = cases_max, fill = key)) +
    geom_line(data = data_country, aes(x = time, y = predicted_cases),
      col = "blue4") +
    xlab("") +
    ylab("Daily number of infections") +
    scale_x_date(date_breaks = "weeks", labels = date_format("%e %b")) +
    scale_fill_manual(name = "", labels = c("50%", "95%"),
      values = c(alpha("deepskyblue4", 0.55),
        alpha("deepskyblue4", 0.45))) +
    theme_pubr() +
    theme(axis.text.x = element_text(angle = 45, hjust = 1),
      legend.position = "None") +
    guides(fill=guide_legend(ncol=1))

  data_deaths_95 <- data.frame(data_country$time, data_country$death_min,
    data_country$death_max)
  names(data_deaths_95) <- c("time", "death_min", "death_max")
  data_deaths_95$key <- rep("nintyfive", length(data_deaths_95$time))
  data_deaths_50 <- data.frame(data_country$time, data_country$death_min2,
    data_country$death_max2)
  names(data_deaths_50) <- c("time", "death_min", "death_max")
  data_deaths_50$key <- rep("fifty", length(data_deaths_50$time))
  data_deaths <- rbind(data_deaths_95, data_deaths_50)
  levels(data_deaths$key) <- c("ninetyfive", "fifty")

  p2 <-   ggplot(data_country, aes(x = time)) +
    geom_bar(data = data_country, aes(y = deaths, fill = "reported"),
      fill = "coral4", stat='identity', alpha=0.5) +
    geom_ribbon(
      data = data_deaths,
      aes(ymin = death_min, ymax = death_max, fill = key)) +
    geom_line(data = data_country, aes(x = time, y = estimated_deaths),
      col = "blue4") +
    xlab("") +
    ylab("Daily number of deaths") +
    scale_x_date(date_breaks = "weeks", labels = date_format("%e %b")) +
    scale_fill_manual(name = "", labels = c("50%", "95%"),
      values = c(alpha("deepskyblue4", 0.55),
        alpha("deepskyblue4", 0.45))) +
    theme_pubr() +
    theme(axis.text.x = element_text(angle = 45, hjust = 1),
      legend.position = "None") +
    guides(fill=guide_legend(ncol=1))

  plot_labels <- c("Complete lockdown",
    "Public events banned",
    "School closure",
    "Self isolation",
    "Social distancing")

  # Plotting interventions
  data_rt_95 <- data.frame(data_country$time,
    data_country$rt_min, data_country$rt_max)
  names(data_rt_95) <- c("time", "rt_min", "rt_max")
  data_rt_95$key <- rep("nintyfive", length(data_rt_95$time))
  data_rt_50 <- data.frame(data_country$time, data_country$rt_min2,
    data_country$rt_max2)
  names(data_rt_50) <- c("time", "rt_min", "rt_max")
  data_rt_50$key <- rep("fifty", length(data_rt_50$time))
  data_rt <- rbind(data_rt_95, data_rt_50)
  levels(data_rt$key) <- c("ninetyfive", "fifth")

  p3 <- ggplot(data_country) +
    geom_stepribbon(data = data_rt, aes(x = time, ymin = rt_min,
      ymax = rt_max, group = key, fill = key)) +
    geom_hline(yintercept = 1, color = 'black', size = 0.1) +
    geom_segment(data = covariates_country_long,
      aes(x = value, y = 0, xend = value, yend = max(x)),
      linetype = "dashed", colour = "grey", alpha = 0.75) +
    geom_point(data = covariates_country_long, aes(x = value,
      y = x,
      group = key,
      shape = key,
      col = key), size = 2) +
    xlab("") +
    ylab(expression(R[t])) +
    scale_fill_manual(name = "", labels = c("50%", "95%"),
      values = c(alpha("seagreen", 0.75), alpha("seagreen", 0.5))) +
    scale_shape_manual(name = "Interventions", labels = plot_labels,
      values = c(21, 22, 23, 24, 25, 12)) +
    scale_colour_discrete(name = "Interventions", labels = plot_labels) +
    scale_x_date(date_breaks = "weeks", labels = date_format("%e %b"),
      limits = c(data_country$time[1],
        data_country$time[length(data_country$time)])) +
    theme_pubr() +
    theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
    theme(legend.position="right")

  top_row <- plot_grid(p1, p2, labels = c("A", "B"))
  p <- plot_grid(top_row, p3, labels = c("", "C"), ncol = 1)
  # p <- plot_grid(p1, p2, p3, ncol = 3, rel_widths = c(1, 1, 2))
  ggsave(filename = paste0(figuresDir, country, "_three_panel_",
    filename2, ".png"), p, width = 7, height = 7)
}

make_single_plot <- function(data_country, data_country_forecast, filename,
  figuresDir, country, logy = TRUE, ymax = 100000){

  # data_deaths <- data_country %>%
  #   select(time, deaths, estimated_deaths) %>%
  #   gather("key" = key, "value" = value, -time)
  #
  # data_deaths_forecast <- data_country_forecast %>%
  #   select(time, estimated_deaths_forecast) %>%
  #   gather("key" = key, "value" = value, -time)
  #
  # # Force less than 1 case to zero
  # data_deaths$value[data_deaths$value < 1] <- NA
  # data_deaths_forecast$value[data_deaths_forecast$value < 1] <- NA
  # data_deaths_all <- rbind(data_deaths, data_deaths_forecast)

  p <- ggplot(data_country) +
    geom_bar(data = data_country, aes(x = time, y = deaths),
      fill = "coral4", stat='identity', alpha=0.5) +
    geom_line(data = data_country, aes(x = time, y = estimated_deaths),
      col = "deepskyblue4") +
    geom_line(data = data_country_forecast,
      aes(x = time, y = estimated_deaths_forecast),
      col = "black", alpha = 0.5) +
    geom_ribbon(data = data_country, aes(x = time,
      ymin = death_min,
      ymax = death_max),
      fill="deepskyblue4", alpha=0.3) +
    geom_ribbon(data = data_country_forecast,
      aes(x = time,
        ymin = death_min_forecast,
        ymax = death_max_forecast),
      fill = "black", alpha=0.35) +
    geom_vline(xintercept = data_country$time[length(data_country$time)],
      col = "black", linetype = "dashed", alpha = 0.5) +
    xlab("Date") +
    ylab("Daily number of deaths\n") +
    scale_x_date(date_breaks = "weeks", labels = date_format("%e %b")) +
    theme_pubr(base_family="sans") +
    theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
    guides(fill=guide_legend(ncol=1, reverse = TRUE)) +
    annotate(geom="text", x=data_country$time[length(data_country$time)]+11,
      y=10000, label="",
      color="black")
  if (logy) {
    p <- p + scale_y_continuous(trans='log10', labels=comma) +
      coord_cartesian(ylim = c(1, ymax), expand = FALSE)
  } else {
    p <- p + scale_y_continuous(labels=comma) +
      coord_cartesian(ylim = c(0, ymax), expand = TRUE)
  }
  print(p)

  ggsave(file= paste0(figuresDir, country, "_forecast_", filename, ".png"),
    p, width = 7, height = 3.5)
}

make_comparison_plot <- function(data_country, data_country_forecast,
  data_country_R0, indicator, filename2, figuresDir, country, logy = TRUE,
  ymax = 10e6, include_cases = TRUE) {

  # Remove first zero entry
  data_country_R0[1,2:ncol(data_country_R0)] <-
    data_country_R0[2,2:ncol(data_country_R0)]

  fileTag <- paste0("_", indicator)

  p <- ggplot(data_country)

  if (indicator == "infections") {
    p <- p + geom_ribbon(data = data_country,
      aes(x = time, ymin = predicted_min, ymax = predicted_max),
      fill = "deepskyblue4", alpha=0.35) +
      geom_line(data = data_country, aes(x = time, y = predicted_cases),
        col = "deepskyblue4") +
      geom_ribbon(data = data_country_forecast, aes(x = time,
        ymin = predicted_min_forecast, ymax = predicted_max_forecast),
        fill = "deepskyblue4", alpha=0.35) +
      geom_line(data = data_country_forecast, aes(x = time,
        y = predicted_cases_forecast), col = "deepskyblue4") +
      geom_ribbon(data = data_country_R0, aes(x = time,
        ymin = predicted_min, ymax = predicted_max),
        fill = "black", alpha=0.35) +
      geom_line(data = data_country_R0, aes(x = time,
        y = predicted_cases), col = "black") +
      ylab("Daily number of infectons\n(millions)")
  } else {
    # Deaths
    p <- p +
      geom_ribbon(data = data_country,
        aes(x = time, ymin = death_min, ymax = death_max),
        fill = "deepskyblue4", alpha=0.35) +
      geom_line(data = data_country,
        aes(x = time, y = estimated_deaths),
        col = "deepskyblue4") +
      geom_ribbon(data = data_country_forecast,
        aes(x = time, ymin = death_min_forecast, ymax = death_max_forecast),
        fill = "deepskyblue4", alpha=0.35) +
      geom_line(data = data_country_forecast,
        aes(x = time, y = estimated_deaths_forecast),
        col = "deepskyblue4") +
      geom_ribbon(data = data_country_R0,
        aes(x = time, ymin = death_min, ymax = death_max),
        fill = "black", alpha=0.35) +
      geom_line(data = data_country_R0,
        aes(x = time, y = estimated_deaths), col = "black") +
      ylab("Daily number of deaths\n")
  }

  p <- p +  geom_vline(xintercept =
      data_country$time[length(data_country$time)],
    col = "black", linetype = "dashed", alpha = 0.5) +
    xlab("Date") +
    scale_x_date(date_breaks = "weeks", labels = date_format("%e %b")) +
    theme_pubr(base_family="sans") +
    theme(axis.text.x = element_text(angle = 45, hjust = 1))
  if (include_cases) {
    if (indicator == "infections") {
      p <- p + geom_bar(data = data_country, aes(x = time,
        y = reported_cases),
        fill = "coral4", stat='identity', alpha=0.5)
    } else {
      p <- p + geom_bar(data = data_country, aes(x = time,
        y = deaths),
        fill = "coral4", stat='identity', alpha=0.5)
    }
  }

  if (logy) {
    p <- p + scale_y_continuous(trans='log10', labels = comma_format(
      accuracy = 1)) +
      coord_cartesian(ylim = c(1, ymax), expand = FALSE)
    fileTag <- paste0(fileTag, "_R0_log_")
  } else {
    p <- p + scale_y_continuous(labels = unit_format(unit = "M",
      scale = 1e-6, accuracy = 0.1)) +
      # scale_y_continuous(labels = unit_format(unit = "M", scale = 1e+6))
      coord_cartesian(ylim = c(0, ymax), expand = TRUE)
    fileTag <- paste0(fileTag, "_R0_linear_")
  }

  print(p)

  ggsave(file= paste0(figuresDir, country, fileTag, filename, ".png"),
    p, width = 5, height = 3.5)
}

plot_covariate_effects <- function(resultsDir, out) {

  alpha = data.frame(as.matrix(out$alpha))
  plot_labels <- c("School Closure",
    "Self Isolation",
    "Public Events",
    "First Intervention",
    "Lockdown", 'Social distancing')
  colnames(alpha) = plot_labels
  first.intervention = alpha[,c(1,2,3,5,6)] + alpha[,4]
  data1 = mcmc_intervals_data(first.intervention,prob=.95,
    transformation=function(x) 1-exp(-x),point_est="mean")
  data1$type = "First Intervention"

  data2 = mcmc_intervals_data(alpha[,c(1,2,3,5,6)],  prob = .95,
    transformation=function(x) 1-exp(-x),point_est="mean")
  data2$type = "Later Intervention"
  # data = rbind(rbind(data2[6,],data1),data2[1:5,])
  data = rbind(data1,data2[1:5,])
  colQuantiles(data.matrix(first.intervention),probs=c(.025,.975))

  #data$type[1] = "First Intervention"

  levels(data$parameter) = gsub("t(", "", levels(data$parameter), fixed=TRUE)
  levels(data$parameter) = gsub(")", "", levels(data$parameter), fixed=TRUE)
  data$parameter = (as.character(data$parameter))

  no_point_est <- all(data$point_est == "none")
  x_lim <- range(c(data$ll, data$hh))
  x_range <- diff(x_lim)
  x_lim[1] <- x_lim[1] - 0.05 * x_range
  x_lim[2] <- x_lim[2] + 0.05 * x_range
  layer_vertical_line <- if (0 > x_lim[1] && 0 < x_lim[2]) {
    vline_0(color = "gray90", size = 0.5)
  } else {
    geom_ignore()
  }
  args_outer <- list(mapping = aes_(x = ~ll, xend = ~hh, y = ~parameter,
    yend = ~parameter)) #, color = bayesplot::get_color("mid"))
  args_inner <- list(mapping = aes_(x = ~l, xend = ~h, y = ~parameter,
    yend = ~parameter), size = 2, show.legend = FALSE)
  args_point <- list(mapping = aes_(x = ~m, y = ~parameter),
    data = data, size = 4, shape = 21)

  args_point$color <- "blue" #get_color("dark_highlight")

  point_func <- geom_point
  layer_outer <- do.call(geom_segment, args_outer)
  layer_inner <- do.call(geom_segment, args_inner)
  layer_point <- do.call(point_func, args_point)

  data$parameter = factor(as.character(data$parameter),
    levels=plot_labels[order(plot_labels)[6:1]])
  # data = data[order(-data$m),]
  p = ggplot(data) +theme_pubr() +
    geom_point(aes(x=m,y=parameter,colour=type),
      position = position_dodge(-.5)) +
    geom_linerange(aes(xmin=ll,xmax=hh,y=parameter,colour=type),
      position = position_dodge(-.5)) +
    scale_x_continuous(breaks=seq(0,1,.25),
      labels = c("0%\n(no effect on transmissibility)",
        "25%","50%","75%","100%\n(ends transmissibility)"),
      expand=c(0.005,0.005),expression(paste("Relative % reduction in  ",
        R[t])))  +
    scale_colour_manual(name = "", #labels = c("50%", "95%"),
      values = c(("coral4"), ("seagreen"))) +

    geom_vline(xintercept=1,colour="darkgray") +
    scale_y_discrete("Governmental intervention\n") +
    #geom_vline(xintercept=0,colour="darkgray") +
    theme(plot.margin = margin(0, 2, 0, .5, "cm"))

  #+ guides(fill=guide_legend(nrow=2))
  p

  ggsave(filename = paste0(resultsDir , "covars-alpha-reduction.png"),
    p,height=4,width=8)

}


# MicroRNA数据分析（GEO GSE66805 GSE95405&TCGA-LIHC）

library(RColorBrewer)
library(pheatmap) # 加载包
library(ggplot2) # 加载包
library(ggrepel) # 加载包
library(eulerr)

# 热图生成（数据GSE66805 GSE95405）
data2<-read.csv('70-high.csv',header = TRUE, sep = ",", quote = "\"",dec = ".", fill = TRUE, comment.char = "", )
rownames(data2)<-data2[,1]
data2<-data2[,-1]
p1<-pheatmap(data2, scale = "column",color = colorRampPalette(c("navy", "white", "firebrick3"))(50),fontfamily= "Times New Roman",angle_col = 0)

#火山图
P<-ggplot(
  #设置数据
  diffall,
  aes(x = log2FC,
      y = -log10(FDR),
      colour=change)) +
  geom_point(alpha=0.4, size=3.5) +
  scale_color_manual(values=c("#4393C3", "#d2dae2","#D6604D"))+

  # 辅助线
  geom_vline(xintercept=c(-1,1),lty=4,col="black",lwd=0.8) +
  geom_hline(yintercept = -log10(cut_off_FDR),lty=4,col="black",lwd=0.8) +

  # 坐标轴
  labs(x="log2(fold change)",
       y="-log10 (FDR)")+
  theme_bw()+

  # 图例
  theme(plot.title = element_text(hjust = 0.5),
        legend.position="right",
        legend.title = element_blank()
  )

diffall$label=ifelse(diffall$FDR < cut_off_FDR & diffall$log2FC >= 1.827,
                     rownames(diffall),'')
#加注释
P+ggrepel::geom_label_repel(
  aes(label=label),diffall
)
ggsave("mir-21.pdf",width = 22, height = 20, units = c("cm"))
```
![volcano_map](volcano_map.png)

#生存曲线
#先从数据库里找到符合各项参数要求的数据
query <- GDCquery(project = "TCGA-LIHC",
                  legacy = FALSE,
                  experimental.strategy = "RNA-Seq",
                  data.category = "Transcriptome Profiling",
                  data.type = "Gene Expression Quantification",
                  data.type = "miRNA Expression Quantification"
                  workflow.type = "HTSeq - Counts")

#再使用命令GDCdownload(）下载
GDCdownload(query)
                  data<-read.table("miRNA_HiSeq_gene",header = TRUE, sep = "\t", quote = "\"",dec = ".", fill = TRUE, comment.char = "", )
rownames(data)<-data[,1]
data<-data[,-1]

metadata<-read.table("nationwidechildrens.org_clinical_follow_up_v4.0_nte_lihc.txt",header = TRUE, sep = "\t", quote = "\"",dec = ".", fill = TRUE, comment.char = "", )

metadata<-metadata[-1,]

data1<-data1ro
data1<-data[c('MIMAT0000076','MIMAT0007891','MIMAT0027658'),]

data2<-read.table("TCGA-LIHC.mirna.tsv",header = TRUE, sep = "\t", quote = "\"",dec = ".", fill = TRUE, comment.char = "", )
metadata2<-read.table("TCGA-LIHC.survival.tsv",header = TRUE, sep = "\t", quote = "\"",dec = ".", fill = TRUE, comment.char = "", )
rownames(data2)<-data2[,1]
data2<-data2[,-1]
GENE=t(data2[which(row.names(data2)=="hsa-mir-21"),])
med=17.3

GENE=data.frame(GENE)
GENE[GENE$hsa.mir.21>med,"level"]<-"High"
GENE[GENE$hsa.mir.21<=med,"level"]<-"Low"

t=metadata2

T=data.frame(gsub("-",".",t$sample),t)

colnames(T)[1]="SampleID"

T=T[,-2]
Clinical=T

gene_clinical=data.frame(Clinical[match(rownames(GENE),Clinical$SampleID),],GENE)

gene_clinical$level<- ifelse ((gene_clinical$level =="High"), 1,2)

GC=gene_clinical
GC$OS.time<-GC$OS.time/365
GC=GC[which(GC$OS.time<7),]
GC=GC[which(GC$OS==1),]

fit.surv <-Surv(GC$OS.time,GC$OS)
km<-survfit(fit.surv~1,data = GC)
km_2<- survfit(fit.surv~level,data=GC)
ggsurvplot(km_2, main = "Survival curve",
           pval=TRUE  #添加P值
)
Med=median(GENE$hsa.mir.21)
mean=mean(GENE$hsa.mir.21)
ggsurvplot (km_2)

ggsurvplot (km)


subroutine lo0(x,y,w,n,d,p,nvmax,span,degree,match,nef,dof,s,var,
		beta,iv,liv,lv,v,iwork,work)
integer n,d,p,nvmax,degree,match(*),nef,liv,lv,iv(liv),iwork(*)
double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),v(lv),work(*)
double precision beta(p+1)
#work should be nef*(p+d+8) + 2*p + n +8
integer qrank
	call lo1(x,y,w,n,d,p,nvmax,span,degree,match,nef,0,dof,s,var,beta,
#	xin,win,sqwin,sqwini,
	work(1),work(nef*d+1),work(nef*(d+1)+2),work(nef*(d+2)+2),
#	xqr,qrank,qpivot,qraux,
	work(nef*(d+3)+2),qrank,iwork(1),work(nef*(p+d+4)+3+p),
	iv,liv,lv,v,
	work(nef*(p+d+4)+4+2*p) )
return
end

subroutine lo1(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,beta,
	xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux,
	iv,liv,lv,v,
	work)
integer n,d,p,nvmax,degree,match(*),nef,nit,qrank,qpivot(p+1)
integer iv(liv),liv,lv
double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),beta(p+1),
	xin(nef,d),win(nef+1),sqwin(nef),sqwini(nef),xqr(nef,p+1),
	qraux(p+1),v(lv),
	work(*)
#work should have size n +4*(nef+1)
call lo2(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,beta,
	xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux,
	iv,liv,lv,v,
	work(1),work(nef+2),work(2*nef+3),work(3*nef+4))
return
end

subroutine lo2(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,beta,
	xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux,
	iv,liv,lv,v,
	levout,sout,yin,work)
integer n,d,p,nvmax,degree,match(*),nef,nit,qrank,qpivot(p+1)
integer iv(liv),liv,lv
double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),beta(p+1),
	xin(nef,d),win(nef+1),sqwin(nef),sqwini(nef),xqr(nef,p+1),
	qraux(p+1),v(lv),
	levout(nef+1), sout(nef+1),yin(nef+1),work(*)
#work should be length n
double precision junk, onedm7
integer job, info
logical setLf, ifvar
job=110;info=1
ifvar=.true.
onedm7=1d-7
if(nit<=1){
	call pck(n,nef,match,w,win)
	do i=1,nef{
		if(win(i)>0d0){
			sqwin(i)=dsqrt(win(i))
			sqwini(i)=1d0/sqwin(i)
		}
		else{
			sqwin(i)=1d-5
			sqwini(i)=1d5
			}
		}
	do i=1,n{
		k=match(i)
		if(k<=nef){
			do j=1,d
				xin(k,j)=x(i,j)
			for(j=d+1;j<=p;j=j+1)
				xqr(k,j+1)=x(i,j)

			}
		}
	do i=1,nef{
		xqr(i,1)=sqwin(i)
		do j=1,d
			xqr(i,j+1)=xin(i,j)*sqwin(i)
		for(j=d+2;j<=p+1;j=j+1)
				xqr(i,j)=xqr(i,j)*sqwin(i)
		}
	for(j=1;j<=p+1;j=j+1)
		qpivot(j)=j
	call dqrdca(xqr,nef,nef,p+1,qraux,qpivot,work,qrank,onedm7)
	setLf = (nit==1)
	call lowesd(106,iv,liv,lv,v,d,nef,span,degree,nvmax,setLf)
	v(2)=span/5d0
	}
do i=1,n
	work(i)=y(i)*w(i)
call pck(n,nef,match,work,yin)
	do i=1,nef
		yin(i)=yin(i)*sqwini(i)*sqwini(i)

if(nit<=1)call lowesb(xin,yin,win,levout,ifvar,iv,liv,lv,v)
	else call lowesr(yin,iv,liv,lv,v)
call lowese(iv,liv,lv,v,nef,xin,sout)

#now remove the parametric piece
do i=1,nef
	sout(i)=sout(i)*sqwin(i)
call dqrsl(xqr,nef,nef,qrank,qraux,sout,work(1),work(1),beta,
		sout,work(1),job,info)
#####dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info)
do i=1,nef
	sout(i)=sout(i)*sqwini(i)

#now clean up

if(nit<=1){
#get rid of the parametric component of the leverage
	job=10000
	for(j=1;j<=p+1;j=j+1){
		do i=1,nef
			work(i)=0d0
		work(j)=1d0
		call dqrsl(xqr,nef,nef,qrank,qraux,work,var,junk,junk,
			junk,junk,job,info)
		do i=1,nef
			levout(i)=levout(i) - var(i)**2
		}
	dof=0d0
	do i=1,nef {
		if(win(i)>0d0) {
			levout(i)=levout(i)/win(i)
			}
		else {levout(i)=0d0}
		}
	do i=1,nef {dof=dof+levout(i)*win(i)}
	call unpck(n,nef,match,levout,var)
	for(j=1;j<=p+1;j=j+1){work(j)=beta(j)}
	for(j=1;j<=p+1;j=j+1){beta(qpivot(j))=work(j)}
	}
call unpck(n,nef,match,sout,s)
return
end
subroutine pck(n,p,match,x,xbar)
integer match(n),p,n
double precision x(n),xbar(n)
	do i=1,p
		xbar(i)=0d0
	do i=1,n
		xbar(match(i))=xbar(match(i))+x(i)
return
end

subroutine suff(n,p,match,x,y,w,xbar,ybar,wbar,work)
integer match(n),p,n
double precision x(n),xbar(n),y(n),ybar(n),w(n),wbar(n),work(n)
call pck(n,p,match,w,wbar)
do i=1,n
	xbar(match(i))=x(i)
do i=1,n
	work(i)=y(i)*w(i)
call pck(n,p,match,work,ybar)
	do i=1,p{
		if(wbar(i)>0d0)
			ybar(i)=ybar(i)/wbar(i)
		else ybar(i)=0d0

	}
return
end
subroutine unpck(n,p,match,xbar,x)
integer match(n),p,n
double precision x(n),xbar(p+1)
if(p<n)xbar(p+1)=0d0
do i = 1,n
	x(i)=xbar(match(i))
return
end
double precision function dwrss(n,y,eta,w)
integer n
double precision y(n),w(n),wtot,wsum,work,eta(n)
wsum=0d0
wtot=0d0
do i = 1,n{
	work=y(i)-eta(i)
	wsum=wsum+w(i)*work*work
	wtot=wtot+w(i)
}
if (wtot > 0d0) {dwrss=wsum/wtot} else {dwrss=0d0}
return
end


#################################
# Guide to bLSmodelR Version 4+
#################################

# I am very sorry for the underdocumented help pages in bLSmodelR.
# I hope this guide will bring some better insight into the bLSmodelR...
# The current version of bLSmodelR to use with this guide is version 4.3-0 (2020-06-12)

library(bLSmodelR)

####################################
#~~~~~~~I. Setting up a Run:~~~~~~~#
####################################

#******
# I. What input is needed?
#******

	#******
	# I.M. What input is mandatory?

	#******
	# I.M.0: Have a look at the main model function *runbLS*:
		# ?runbLS
		# to run bLSmodelR a list of data.frames defining the model input is needed
		# ?genInputList
		# The argument 'ModelInput' in *runbLS* contains 2 mandatory entries:
		# $Interval 	-> I.M.1
		# $Sensors 		-> I.M.2
		#
		# and 3 optional entry:
		# $Sources 		-> I.O.1
		# $Model 		-> I.O.2
		# $Tolerances 	-> I.O.3
	#******

	#******
	# I.M.1: $Interval:
		# ?genInterval
		print(Interval <- genInterval())
		str(Interval)
		# contains all information about the individual intervals that will be calculated
		# i.e. necessary turbulence and windprofile parameters incl. wind direction
		# Sensors and Sources that will be included in the calculation of the interval can be defined as well
		# if arguments 'SensorNames' and/or 'SourceNames' are not provided, all available Sensors/Sources will be included
		# when gathering the model input with the function *genInputList* (c.f. example below IntervalDemo).
		# example 1: 'Sensor1' will be calculated in first interval, 'Sensor2' in second
		print(Interval1 <- genInterval(SensorNames = c("Sensor1","Sensor2")))
		# example 2: 'Sensor1' and 'Sensor2' will be calculated in the same interval
		print(Interval2 <- genInterval(SensorNames = "Sensor1,Sensor2"))
		### 'MaxFetch' argument
		# argument 'MaxFetch' can be provided as negative number. If done so, the maximum distance between the specific
		# Sources and the Sensors will be calculated based on the wind direction during the model run
		# and the absolute value of the 'MaxFetch' argument will be added on top of this distance in order to define the MaxFetch
		# values (i.e. the maximum distance upwind of the Sensor) for each interval (see example in ?genInterval)
		print(Interval3 <- genInterval(MaxFetch = -50))
		####
		# an option to construct the Interval data.frame by hand is given as well (using argument 'Data').
		# This comes most of the time handier and additionally allows for more information changing on an interval basis (e.g. start/end times etc.),
		# which is passed to the output. Columns that should be recognized as Interval arguments should be named according to the
		# corresponding arguments, i.e names(as.list(args(genInterval)))[2:14]
		IntervalData <- cbind(Interval3,Numeric=c(1.2,3.1),Characters=letters[1:2],Factors=factor(letters[1:2]),POSXct=as.POSIXct(1:2,origin=Sys.time()),stringsAsFactors=FALSE)
		print(IntervalDemo <- genInterval(Data=IntervalData))
		str(IntervalDemo)
	#******

	#******
	# I.M.2: $Sensors:
		# ?genSensors
		# genSensors accepts either lists or data.frames as argument input
		# these lists/data.frames need specific named entries (mandatory are
		# entries x, y, and z; optional is entry name - the name of the sensor):
		# Point Sensors need 3 entries (x,y,z)
		# PathSensors need one of these entries (x,y,z) with length >1 and can
		# have two additional arguments:
		# 	- entry 'd' refines the way to interpolate the path sensor by multiple point sensors:
		# 		-> d = Distance between point sensors in m
		#		- entry 'id' defines 'sub-groups' of a sensor, such that multiple sensors at different
		#			locations can be treated as one sensor
		# providing no argument to genSensors results in an error
		# genSensors()
		print(Sensors <- genSensors(PointSensor=list(x=0,y=0,z=1.2)))
		str(Sensors)
		# other example:
		print(Sensors1 <- genSensors(data.frame(name=paste0("Sensor",1:3),x=10,y=0,z=c(0.5,1.2,2.05))))
		# defining Path Sensors:
		print(Sensors2 <- genSensors(
			LineSensor1=list(x=c(0,20),y=0,z=1.2),
			LineSensor2=list(x=c(-10,20),y=10,z=c(2,2.2),d=0.5),
			PathSensor1=list(x=c(0, 10, 10),y=c(15,25,30),z=1.2),
			PathSensor2=list(x=c(2, 2, 10, 10, 20),y=c(0, 15,5,10, 5),z=1.2,id=c(1,1,2,2,2))
		))
		plot(Sensors2[Sensors2$"Sensor Name" == "PathSensor2",])
		# joining Sensors:
		head(join(Sensors1,Sensors2))

		# Now define the two Sensors included in IntervalDemo for further use:
		print(SensorsDemo <- genSensors(Sensor1=list(x=10,y=0,z=1.2),Sensor2=list(x=20,y=0,z=2.05)))
	#******

	#******
	# Gathering ModelInput:
		# ?genInputList
		# Given these 2 list entries, bLSmodelR could be run to pre-calculate TD catalogs - but only, if TDonly==TRUE:
		# *genInputList* will set TDonly==TRUE with a warning
		# Default values for Model Parameters and Tolerances (see I.O.2 and I.O.3 below) will be used
		InputWithoutSource <- genInputList(IntervalDemo,SensorsDemo)
		print(InputWithoutSource)
		# Since no sensors were defined explicitly in the Interval data.frame, all existing sensors were added to each interval.
	#******

	#******
	# I.O. Optional model input:
	#******
	# I.O.1: $Sources:
		# Sources are treated as homogeneously emitting source ares, defined by polygons.
		# ?genSources
		print(Sources <- genSources(list(x=rnorm(10),y=rnorm(10))))
		str(Sources)
		# generating sources is done in a somewhat inconvenient way...
		# source areas are either defined by:
		# 1) a list of named lists, where the names of the list entries correspond to the source area names.
		# 2) arguments providing lists or data.frames, where the argument names correspond to the source are names.
		# There are two optional polygon "Classes" to help building source areas:
		# circle 'Class'="c":
		print(Circle <- genSources(SourceCirc=list(Class="c",M=c(10,50),R=10)))
		# rectangle 'Class'="r":
		print(Rect <- genSources(SourceRect=list(Class="r",x1=0,x2=10,y1=0,y2=20)))
		# Otherwise source polygons are defined by a list with vectors x and y:
		print(Poly <- genSources(SourcePoly=list(
			x=c(seq(-10,10,1),seq(9.5,-9.5,-0.5))-20,
			y=c(rep(0,21),seq(h <- sqrt(20^2-10^2)/20,h*20,h),seq(19*h,h,-h))+30
			)))
		# or equivalently by supplying a data.frame:
		print(Poly <- genSources(SourcePoly=data.frame(
			x=c(seq(-10,10,1),seq(9.5,-9.5,-0.5))-20,
			y=c(rep(0,21),seq(h <- sqrt(20^2-10^2)/20,h*20,h),seq(19*h,h,-h))+30
			)))
		# Multiple entries with equal names are treated as one source.
		# One can provide them as one list argument with named list entries
		print(MultiPoly <- genSources(list(
			SourceRects=list(Class="r",x1=10,x2=20,y1=5,y2=25),
			SourceRects=list(Class="r",x1=-10,x2=-20,y1=5,y2=25),
			SourceRects=list(Class="r",x1=-10,x2=10,y1=-10,y2=0),
			OtherSource=list(Class="r",x1=-5,x2=5,y1=20,y2=30)
			)))
		# or, equivalently, as multiple (possibly named) arguments:
		print(MultiPoly <- genSources(
			SourceRects=list(Class="r",x1=10,x2=20,y1=5,y2=25),
			SourceRects=list(Class="r",x1=-10,x2=-20,y1=5,y2=25),
			SourceRects=list(Class="r",x1=-10,x2=10,y1=-10,y2=0),
			OtherSource=list(Class="r",x1=-5,x2=5,y1=20,y2=30)
			))
		# join all previous in one for demo:
		print(SourcesDemo <- join(
			Circle,
			Rect,
			Poly,
			MultiPoly
			))
		head(SourcesDemo)

	#******

	#******
	# I.O.2: $Model:
		# ?genModel
		print(Model <- genModel())
		str(Model)
		# kv:			von Karman constant
		# A:			Scaling Factor (see Flesch et al., 2004)
		# alpha:		fraction of "tau_L" to define timestep (see Flesch et al., 2004)
		# wTDcutoff:	lower limit of touchdown velocities (TD velocities below the cutoff will be set to the cutoff value)
		# TDwrite:		Writing (i.e. permanently saving) touchdown catalogs?
		# overwriteTD:	Overwrite existing (identical) touchdown catalogs?
		# TDread:		Reading previously saved touchdown catalogs?
		# TDonly:		Calculate touchdown catalogs only?
		# ncores:		Number of cores to use. 'ncores' <= 0 == "use all detected cores" as given by the
		#				default call of *parallel::detectCores* (although this is not recommended
		#				-> see: ?parallel::detectCores)
		#
		#  For demo: do not save TD catalogs:
		print(ModelDemo <- genModel(TDwrite=FALSE))
	#******

	#******
	# I.O.3: $Tolerances:
		# ?genTolerances
		print(Tol <- genTolerances())
		str(Tol)
		# only used for choosing appropriate touchdown catalogs, if TDread is "TRUE".
		# Tol.Zero prohibits using tolerances when choosing TD cataolgs,
		# i.e. only exactly matching catalogs will be used:
		print(genTolerances(Tol.Zero=TRUE))
	#******

	#******
	# Gathering ModelInput:
		# Generate ModelInput for demo:
		print(demoInput <- genInputList(IntervalDemo,SensorsDemo,SourcesDemo,ModelDemo,Tol))
		# If you use default values (as here Tolerances), you don't need to supply them:
		identicalDemoInput <- genInputList(IntervalDemo,SensorsDemo,SourcesDemo,ModelDemo)
		identical(demoInput,identicalDemoInput)
	#******

#******
# II. Have a look at your set up
#******

	#******
		siteMap(demoInput,polygon.args = list(col = rainbow(5,s=0.3)),
			sources.text.args = list(col = rainbow(5,v=0.5)))
		# or equivalently:
		plot(demoInput,polygon.args = list(col = rainbow(5,s=0.3)),
			sources.text.args = list(col = rainbow(5,v=0.5)))
		args(siteMap)
		# additional possible calls (arguments order doesn't matter):
		par(mfrow=c(2,2))
		plot(SourcesDemo,SensorsDemo,main="plot(SourcesDemo,SensorsDemo)")
		plot(SensorsDemo,SourcesDemo,main="plot(SensorsDemo,SourcesDemo)")
		plot(SensorsDemo,main="plot(SensorsDemo)")
		plot(SourcesDemo,main="plot(SourcesDemo)")
		# make a somewhat nicer looking plot :-)
		nicerMap <- function(...){}
		body(nicerMap) <- expression({plot(demoInput
			,polygon.args=list(col=rainbow(5,s=0.3))
			,points.args=list(pch=4,cex=1,col=c("darkgreen","darkred"),lwd=2)
			,sensors.text.args=list(pos=4)
			,sources.text.args=list(col = rainbow(5,v=0.5))
			,...)})
		nicerMap()
		# add a scale bar:
		bnicerMap <- body(nicerMap)
		bnicerMap[3] <- expression(addScaleBar())
		body(nicerMap) <- bnicerMap
		nicerMap()
		bnicerMap[3] <- expression(addScaleBar(pos=4))
		body(nicerMap) <- bnicerMap
		nicerMap()
		# wind direction from NW would be best:
		bnicerMap[4] <- expression(addWindrose(WD=315,pos=1))
		body(nicerMap) <- bnicerMap
		nicerMap()
	#******

#******
# III. Run the model
#******

	#******
	# ?runbLS
		# define a temporary catalog path. Even if you don't save the TD catalogs at the end,
		# temporary TD catalogs will be stored there and later removed.
		# Make sure to have enough space available there. The following example will only require
		# around 2 MB for the temporary TD catalogs.
		Cat.Path <- getwd()

		# set Interval WD to 315 deg N for demo:
		demoInput$Interval[,"WD [deg N]"] <- 315

		# run the model
		args(runbLS)
		# results as data.table:
		DemoOutput_DataTable <- runbLS(demoInput,Cat.Path=Cat.Path)
		# temporary TD catalogs will be used as long as they're not removed (i.e. actively removed
		# by a call to cleanTemporary(), or by exiting the R session (where cleanTemporary() will be called before exiting))
		# results as data.frame
		DemoOutput <- runbLS(demoInput,Cat.Path=Cat.Path,asDT=FALSE)
		#
		DemoOutput
		head(DemoOutput,1)
		names(attributes(DemoOutput))
		# initially attached columns:
		DemoOutput[,39:42]
		str(DemoOutput[,39:42])
		# change from data.frame to data.table:
		setDT(DemoOutput)
		DemoOutput
		# and back to data.frame:
		setDF(DemoOutput)
		DemoOutput
		# switch column names to simple:
		DemoOutput <- switchNames(DemoOutput)
		DemoOutput
		# change back to data.table with more 'informative' column names:
		switchNames(setDT(DemoOutput),FALSE)
		DemoOutput
		# switch names back:
		switchNames(DemoOutput)

		# switch the heights of sensors (in a somewhat unconventional way). One catalog needs to be calculated
		# due to the new, longer Fetch required. This could have been omitted by setting a large enough MaxFetch value.
		demoInput2 <- demoInput
		demoInput2$Sensors <- genSensors(data.frame(name=c("S1.High","S2.Low"),x=(1:2)*10,y=0,z=c(2.05,1.2)))
		demoInput2$Interval[,"Sensor Names (sep = \",\")"] <- c("S1.High","S2.Low")
		DemoOutput2 <- runbLS(demoInput2,Cat.Path=Cat.Path)
		DemoOutput2[,.(Sensor,Source,SensorHeight,CE)]
		DemoOutput[,.(Sensor,Source,SensorHeight,CE)]

		# extract Sensor1 and sort C/E in decreasing order (have a look at data.table::setorder for increasing/decreasing ordering -> i.e. -/+ for decreasing/increasing column ordering):
		S1Output <- extractResult(DemoOutput,sortArgs = list("Sensor"="Sensor1",-"CE"),dropAttr=FALSE)
		S1Output[]
		names(attributes(S1Output))
		# otherwise, if dropAttr=TRUE (default), model specific attributes are dropped:
		S1Results <- extractResult(DemoOutput,sortArgs = list("Sensor"="Sensor1",-"CE"))
		S1Results[]
		names(attributes(S1Results))
		#
		# extract Sources c("SourceRect","SourceRects") and drop all columns but c("Sensor","Source","C/E","C/E SE"):
		OutShort <- extractResult(DemoOutput,sortArgs = list("Source"=c("SourceRect","SourceRects")),keep=c("Sensor","Source","CE","CE_se"))
		OutShort
		#
		# get catalog: (somewhat inconvenient... will be improved someday)
		# row 1:
		CatInfo <- getCatalogs(DemoOutput,1)
		Catalog <- readCatalog(CatInfo[,Catalog])
		Catalog
		par(mfrow=c(1,1))
		plot(Catalog, col = "#00000011", pch = 20)

		# Visualize footprint (quite a number of arguments, sorry for that!):
		args(plotFootprint)
		par(mfrow=c(2,2))
		# Plot C-Footprint of Sensor 1:
		nicerMap(main="C-FP as modelled")
		plotFootprint(DemoOutput,"Sensor1",1,add=TRUE,addSource=FALSE,showSensor=FALSE,lpos="topright",showPerc=TRUE,alpha=0.5)
		# Plot 'despiked' C-Footprint of Sensor 1:
		nicerMap(main="C-FP (use.avg = TRUE)")
		plotFootprint(DemoOutput,"Sensor1",1,use.avg=TRUE,add=TRUE,addSource=FALSE,showSensor=FALSE,lpos="topright",showPerc=TRUE,alpha=0.5)
		# Plot 'despiked' C-Footprint of Sensor 1 using symmetry property due to horizontal homogeneity of turbulence:
		nicerMap(main="C-FP (use.avg = TRUE, use.sym = TRUE)")
		plotFootprint(DemoOutput,"Sensor1",1,use.avg=TRUE,use.sym=TRUE,add=TRUE,addSource=FALSE,showSensor=FALSE,lpos="topright",showPerc=TRUE,alpha=0.5)

		# Plot w'C'-Footprint:
		x11(width=10,height=5)
		par(mfrow=c(1,2))
		nicerMap(main="w'C'-FP")
		plotFootprint(DemoOutput,"Sensor1",1,type="wCE",use.avg=TRUE,add=TRUE,addSource=FALSE,showSensor=FALSE,lpos="topright",showPerc=TRUE)
		# Plot C-Footprint of Sensor 1 and Sensor 2:
		nicerMap(main="C-FP of both Sensors (units: CE s/m)")
		plotFootprint(DemoOutput,"Sensor1",1,add=TRUE,use.avg=TRUE,use.sym=TRUE,addSource=FALSE,showSensor=FALSE,lpos="topright",alpha=0.5,breaks = function(x) exp(seq(log(1E-4),log(0.027),length.out=4)),sigNums=2)
		plotFootprint(DemoOutput,"Sensor2",2,add=TRUE,use.avg=TRUE,use.sym=TRUE,addSource=FALSE,showSensor=FALSE,lpos=NA,alpha=0.3,breaks = function(x) exp(seq(log(1E-4),log(0.027),length.out=4)))

	#******

#******
# IV. Deposition post-processing
#******
		# Run the deposition post-processing function: deposition
		args(deposition)
		# vDep must be given as m/s. It is defined as the 'surface' deposition velocity ath height d + z0 (the "bLS model surface").
		# post-process results with a 'rather high' deposition velocity of 3 cm/s:
		RunDep <- deposition(DemoOutput,0.03,Sensor="Sensor1",Source="SourceRects")
		RunDep
		RunDep[,.(CE,CE_Dep,"Reduction of CE by deposition (in %)"=(CE - CE_Dep)/CE*100)]

		# spatially inhomogeneous deposition velocity
		# this is still experimental and input format may change in future updates...
		vDepAreas <- join(Circle,Rect,MultiPoly)
		vDepList <- list(
			SourceRects = 0
			,SourceRect = 0.03
			,OtherSource = 0.01
			)
		plot(join(Poly,vDepAreas),SensorsDemo,polygon.args = list(col = rainbow(5,s=0.3)),sources.text.args = list(
			labels = paste0("vDep = ",c("0 (emitting area)","0.002 (same as default,\n because it is not defined in \"vDepList\")","0.03","0","0.01"))
			,col = rainbow(5,v=0.5)))
		text(0,35,"vDep = 0.002 (all non-defined areas)",cex=0.5,font=2)
		RunDep2 <- deposition(DemoOutput,0.002,Sensor="Sensor1",Source="SourcePoly",vDepSpatial = list(vDepList,vDepAreas))
		RunDep2[,.(CE,CE_Dep,"Reduction of CE by deposition (in %)"=(CE - CE_Dep)/CE*100)]

#******
# V. Parallelism
#******
		# A very! simple attempt to parallelize parts of the model calculation has been implemented using the package snow (and snowfall)
		# It is possible to either:
		# a) provide the number of cores (argument: ncores) to build a SOCKET type structure or
		DemoOutput_Parallel <- runbLS(demoInput,Cat.Path=Cat.Path,ncores=2)
		# b) to have a network already running before calling runbLS (if so, keep in mind, that the TD catalog must be available to all nodes!!!)
		sfInit(TRUE,2)
		DemoOutput_Parallel2 <- runbLS(demoInput,Cat.Path=Cat.Path);sfStop()


# GetLong100_456Data.r
source("../common/DataUtil.r")
library(ggplot2)
source("../common/PlotUtil.r")

# P A R A M S
sPlotFile <- "long100_456.png"
fnGroupBy <- function(dfIn) {group_by(dfIn, copies, lifem
                                    , serverdefaultlife
                                    , shockfreq, shockspan, shockimpact
                                    , shockmaxlife
                                    )}
fnSubset <- function(dfIn)  {subset(dfIn,  lifem<=1000)}
want.varnames <- c("copies","lifem","lost","docstotal","serverdefaultlife"
                ,"shockfreq","shockimpact","shockspan","shockmaxlife"
                ,"auditfrequency","audittype","auditsegments"
                ,"deadserversactive","deadserversall")
fnNarrow <- function(dfIn)  {dfIn[want.varnames]}
sTitleLine <-   (   ""
                %+% "Can a collection survive long-term with enough copies "
                %+% "and annual auditing?\n "
                %+% "100-year document survival based on "
                %+% "number of copies and disk error rates"
                %+% " "
                %+% "\n"
                %+% "\n(Copies=4,5,6, annual total auditing, sample size=21)"
                )
if (exists("sLegendLabel")) {rm(sLegendLabel)}
sLegendLabel <- "Number of\n  Audited\n   Copies"
if (exists("lLegendItemLabels")) {rm(lLegendItemLabels)}
lLegendItemLabels <- c("4 ", "5 ", "6 ")
sXLabel <- ("Storage sector (1MB) half-life (megahours) "
            %+% "            (longer half-life = lower error rate =====>)")
sYLabel <- ("permanent document loss rate (%)")
# ************ Also change summarize function and axis values
#               and ggplot(color=...).

# G E T   D A T A
# Get the data into the right form for these plots.
alldat.df <- fndfGetGiantDataRaw("")
newdat <- alldat.df %>% fnGroupBy() %>%
# Fix  s u m m a r i z e  here.
summarize(losspct=round(midmean(lost/docstotal)*100.0, 2), n=n()) %>%
fnSubset()
trows <- newdat

# P L O T   D A T A
# Fix  c o l o r  and  a x e s  here.
gp <- ggplot(data=trows
            , aes(x=lifem,y=safe(losspct)
            , color=factor(copies))
            )
gp <- gp + labs(color=sLegendLabel)

gp <- fnPlotLogScales(gp, x="YES", y="YES"
#                , xbreaks=c(50,67,75,80,90,100)
                , xbreaks=c(2,5,10,100,1000)
                , ybreaks=c(0.01,0.10,1.00,10,100)
                )
#gp <- gp + scale_x_reverse(breaks=c(50,67,75,80,90,100))
gp <- gp + geom_line(
                  size=3
                , show.legend=TRUE
                )
gp <- gp + geom_point(data=trows
                , size=6
                , show.legend=TRUE
                , color="black"
                )

gp <- gp + theme(legend.position=c(0.7,0.85))
gp <- gp + theme(legend.background=element_rect(fill="lightgray",
                                  size=0.5, linetype="solid"))
gp <- gp + theme(legend.key.size=unit(0.3, "in"))
gp <- gp + theme(legend.key.width=unit(0.6, "in"))
gp <- gp + theme(legend.text=element_text(size=16))
gp <- gp + theme(legend.title=element_text(size=14))
gp <- gp + scale_color_discrete(labels=lLegendItemLabels)

gp <- fnPlotTitles(gp
            , titleline=sTitleLine
            , xlabel=sXLabel
            , ylabel=sYLabel
        )
# Label the percentage lines out on the right side.
xlabelposition <- log10(800)
gp <- fnPlotPercentLine(gp, xloc=xlabelposition)
gp <- fnPlotMilleLine(gp, xloc=xlabelposition)
gp <- fnPlotSubMilleLine(gp, xloc=xlabelposition)

plot(gp)
fnPlotMakeFile(gp, sPlotFile)

# Unwind any remaining sink()s to close output files.
while (sink.number() > 0) {sink()}