#' Runs a transport-reaction model
#' @param ws A [Watershed] object
#' @param initial A vector of initial conditions
#' @param lateral Vector of values of the state variable for lateral input for each pixel
#' @param times The times at which to compute the state variable
#' @param method The integration method to use; default is euler
#' @param dt The size of the time step for integration (euler method only)
#' @param rxn A function giving the time derivative of the reaction component
#' @param rxnParams A list of parameters to pass to `rxn`
#'
#' @details Because the appropriate time step will vary based on the units and the specific
#'    problem, the recommended approach is to first try a single run using lsoda (perhaps on
#'    a small subset), then run euler at varying time steps to find the dt that produces
#'    acceptable results.
#'
#' If used, `rxn` must be a function taking `t` (the current time) and `y`
#'   (the state of the system) as its first few arguments. Other arguments can be added by
#'   name via the `rxnParams` argument.
#' @return A state variable matrix (with one column per time step)
#' @useDynLib WatershedTools
#' @importFrom Rcpp sourceCpp
#' @export
transport <- function(ws, initial, lateral, times, method = c('euler', 'lsoda'), dt = 1,
	rxn = NULL, rxnParams = list()) {
	method <- match.arg(method)
	if(method == "lsoda" && !requireNamespace("deSolve"))
		stop("method = 'lsoda' requires the deSolve package; please install it and try again")
	if(times[1] != 0)
		stop('first time step must be 0')
	if(method == 'euler' && sum(times %% dt) != 0)
		stop('dt must divide evenly into all values in times')
	if(!'discharge' %in% names(ws))
		stop('discharge is required for the transport model')
	if(!'csArea' %in% names(ws)) {
		if(!('width' %in% names(ws)) & !('depth' %in% names(ws))) {
			stop("depth and width, or csArea, are required attributes")
		} else
			ws$data$csArea <- ws$data$width * ws$data$depth
	}
	if(!('adjacency_q' %in% ls(ws)))
		ws$adjacency_q <- Matrix::t(Matrix::t(ws$adjacency) * ws$data$discharge)

	parms <- list(qout = Matrix::colSums(ws[["adjacency_q"]]),
		qin = Matrix::rowSums(ws[["adjacency_q"]]), lateral = lateral,
		csArea = ws[['data']][['csArea']], dx = ws[['data']][["length"]])
	# add discharge for the outlet back in (outlet drains to nowhere)
	parms$qout[which(parms$qout == 0)] <- ws[['data']]$discharge[which(parms$qout == 0)]

	if(method == "euler") {
		parms$adjacencyQ <- ws[["adjacency_q"]]
		state <- transport_euler(initial, parms, times, dt, rxn, rxnParams)
	} else {
		parms$adjacencyQ <- cbind(Matrix::which(ws[["adjacency_q"]] != 0, arr.ind = TRUE),
			ws[["adjacency_q"]][Matrix::which(ws[["adjacency_q"]] != 0)])
		state <- t(deSolve::ode(initial, times = times, func = dCdt_transport, parms = parms,
			rxn = rxn, rxnParams = rxnParams))
		state <- state[2:nrow(state),] # dropping the times row that desolve adds on
	}
	return(state)
}

#' Do euler integration for the transport model
#' @param initial A vector of initial conditions
#' @param parms Integration parameters and data
#' @param times The times at which to compute the state variable
#' @param dt The size of the time step for integration
#' @param rxn A function giving the time derivative of the reaction component
#' @param rxnParams A list of parameters to pass to `rxn`
#' @return A state variable matrix (with one column per time step)
#' @keywords internal
transport_euler <- function(initial, parms, times, dt, rxn = NULL, rxnParams = list()) {
	state <- matrix(NA, ncol=length(times), nrow=length(initial))
	state[,1] <- statet <- initial
	t <- 0
	for(i in 2:ncol(state)) {
		while(t < times[i]) {
			statet <- statet + dt * dCdt_transport_r(t, statet, parms)
			if(!is.null(rxn)) {
				rxnList <- c(list(t = t, y = statet), (rxnParams))
				statet <- statet + dt * do.call(rxn, rxnList)
			}
			t <- t + dt
		}
		state[,i] = statet[,1]
	}
	return(state)
}

#' @name dCdt_transport
#' @aliases dCdt_transport_r
#' @title Compute flux due to transport
#' @param t The time step
#' @param y The state variable
#' @param parms Model parameters and data
#' @param rxn A function giving the time derivative of the reaction component
#' @param rxnParams A list of parameters to pass to `rxn`
#' @details At present, only advective transport is considered
#' @return Flux vector, in units of state variable per unit time, for each spatial unit
#' @keywords internal
dCdt_transport <- function(t, y, parms, rxn = NULL, rxnParams = list()) {
	advection <- dCdt_transport_cpp(t, y, parms$adjacencyQ, parms$qout, parms$qin,
		parms$lateral, parms$csArea, parms$dx)
	if(!is.null(rxn)) {
		rxnList <- c(list(t = t, y = y), (rxnParams))
		reaction <- do.call(rxn, rxnParams)
	} else {
		reaction <- 0
	}

	return(list(advection + reaction))
}

#' @rdname dCdt_transport
#' @keywords internal
dCdt_transport_r <- function(t, y, parms) {
	inputMass <- parms$adjacencyQ %*% y
	totalInputMass <- inputMass + (parms$qout - parms$qin) * parms$lateral;
	totalOutputMass <- parms$qout * y;
	advection <- (-1/parms$csArea) * (totalOutputMass - totalInputMass)/parms$dx;
	return(advection)
}

#' Compute hydraulic geometry from discharge
#' @param discharge A vector of discharge values.
#' @param pars Optional parameters for the scaling relationships; see 'details'
#' @details If given, `pars` should be a named `list` with three elements: `velocity`, `depth`
#' 		and `width`. Each element must be a vector with two elements, the first is the intercept
#' 		and the second the slope. If omitted, values from Raymond et al will be used.
#'
#' For the Raymond et al parameters, discharge should be in units of \eqn{m^3 s^{-1}}.
#' 		All other variables are in meters.
#' @references Raymond, PA et al. 2012. Scaling the gas transfer velocity and hydraulic
#' 		geometry in streams and small rivers. *Limnology and Oceanography: Fluids and
#' 		Environments*. **2**:41-53.
#' @return A data frame with discharge, velocity, depth, and width
#' @export
hydraulic_geometry <- function(discharge, pars) {
	if(missing(pars))
	{
		va <- -1.64
		vb <- 0.285
		da <- -0.895
		db <- 0.294
		wa <- 2.56
		wb <- 0.423
	} else {
		va <- pars$velocity[1]
		vb <- pars$velocity[2]
		da <- pars$depth[1]
		db <- pars$depth[2]
		wa <- pars$width[1]
		wb <- pars$width[2]
	}

	velocity <- exp(va + vb * log(discharge))
	depth <- exp(da + db * log(discharge))
	width <- exp(wa + wb * log(discharge))
	ind <- which(discharge == 0)
	velocity[ind] <- depth[ind] <- width[ind] <- 0
	data.frame(discharge, velocity, depth, width)
}

#' Compute discharge from catchment area
#' @param A vector of catchment area, in \eqn{m^2}
#' @param calib A data.frame with two elements, `A` (catchment area) and `Q` (observed discarge)
#' @details Computes discharge from catchment area as \eqn{\log Q = \log b + m \log A}.
#' 		If a single point in `calib` is included, the relationship will be re-parameterised by
#'  	adjusting the intercept parameter `b` so that the calibration point falls on the line
#' 		(while keeping the slope the same).
#'
#' 		With multiple points, a bayesian regression model is fit with rstanarm. The model uses
#' 		Burgers et al parameters as an informative prior.
#'
#' 		The default parameters used by this function come from Burgers et al (2014).
#' 		For these parameters, catchment area units are expected to be in
#' 		\eqn{m^2}, and discharge will be computed in \eqn{m^3 s^{-1}}.
#' @references Burgers HE et al. 2014. Size relationships of water discharge in rivers: scaling
#' 		of discharge with catchment area, main-stem lengthand precipitation.
#' 		*Hydrological Processes*. **28**:5769-5775.
#' @export
discharge_scaling <- function(A, calib)
{

	# params from Burgers et al 2014; assuming normal distribution on log scale
	logB_mu <- log(6.3e-6)
	logB_sd <- 0.4137399
	m_mu <- 0.78
	m_sd <- 0.03571429

	# convert units to match pars from Burgers et al
	m2perkm2 <- 1000^2
	m3perkm3 <- 1000^3
	secperday <- 60*60*24
	A <- A / m2perkm2 ## now in square kilometers
	calib$A <- calib$A / m2perkm2
	calib$logA <- log(calib$A)
	calib$Q <- (calib$Q / m3perkm3) * secperday # now in cubic kilometers per day
	calib$logQ <- log(calib$Q)

	if(nrow(calib) == 1) {
		logB_mu <- log(calib$Q) - m_mu * log(calib$A)
		Q <- exp(logB_mu + m_mu * log(A))
	} else {
		if(!requireNamespace("rstanarm"))
			stop("This functionality requires the rstanarm package;
				please install it and try again")
		# stan doesn't play nice with data tables
		calib <- as.data.frame(calib)
		# make a dummy intercept to account for how Stan applies informative priors
		calib$b <- 1
		fit <- rstanarm::stan_glm(logQ ~ -1 + b + logA, data = calib,
				prior = rstanarm::normal(c(logB_mu, m_mu), c(logB_sd, m_sd)))
		Q <- exp(predict(fit, newdata = data.frame(b = 1, logA = log(A))))
	}

	# convert to m^3 per second
	Q <- (Q * m3perkm3) / secperday
	return(Q)
}

#' Compute discharge from flow measurements
#'
#'
#' @param depth a vector of depth measurements
#' @param velocity a vector of velocity measurements
#' @param flowID a vector of IDs (e.g., site numbers) corresponding to depth/velocity measurements
#' @param width a vector of stream widths
#' @param widthID a vector of IDs for width measurements to match to flowID
#' @param na.rm should NAs be removed before computation?
#' @import data.table
#' @keywords internal
#'
#' @return A data.table giving discharge by ID
q_from_flow <- function(depth, velocity, flowID = rep(1, length(depth)), width,
		widthID = rep(1, length(width)), na.rm = FALSE) {

	if(length(depth) != length(velocity) | length(depth) != length(flowID))
		stop("depth, velocity, and flowID must have the same length")
	if(length(width) != length(widthID))
		stop("width and widthID must have the same length")

	# require(data.table)
	widthByID <- data.table(id = widthID, width = width)
	widthByID <- widthByID[, .(width = mean(width, na.rm = na.rm)), keyby=id]

	flow <- data.table(id = flowID, velocity = velocity, depth = depth, key = 'id')
	if(any(!complete.cases(flow)) & na.rm) {
		flow <- flow[complete.cases(flow)]
	}

	## need to divide width by the number of measurements
	n <- tapply(flow$id, flow$id, length)
	n <- data.table(id =names(n), n = as.vector(n), key = 'id')
	if(is.numeric(flowID))
		n$id = as.integer(n$id)

	widthByID <- n[widthByID]

	flow <- widthByID[flow]
	flow[, .(Q = sum((width/n)*velocity*depth)), id]
}


#!/usr/bin/env Rscript
library(readr)
require(MESS)

# con <- file("energyPlot.txt")
# sink(con, append=TRUE)
# sink(con, append=TRUE, type="message")

# source("integrateEnergy.r", echo=TRUE, max.deparse.length=10000)

# sink(type="message")

# cat(readLines("energyPlot.txt"), sep="\n")
# testRstudioAUC <- read_delim('1.txt', " ", escape_double = FALSE, col_names = FALSE, trim_ws = TRUE)
# x <- (testRstudioAUC$X1)
# y <- (testRstudioAUC$X2)
# data <- auc(x, y, type='spline')
# write.table(data,quote=FALSE,append=TRUE,row.names=FALSE,col.names=FALSE,sep=" ", "energyPlot.txt")
# for(i in seq(from=2, to=16, by=2)){
            infile <- 'tmpTeslaMeanTimefur.txt'
    # outfile <- paste(i,"-edit.txt",sep="")
    testRstudioAUC <- read_delim(infile, " ", escape_double = FALSE, col_names = FALSE, trim_ws = TRUE)
    testRstudioAUC
    x <- (testRstudioAUC$X2)
    x
    # y <- (testRstudioAUC$X2)
    sd(x)
    # data <- read.table(infile,header=TRUE,sep=",",row.names=NULL)
    # colnames(data)[1] = "time"
    # write.table(data,quote=FALSE,append=TRUE,row.names=FALSE,col.names=FALSE,sep=" ", "energyPlot.txt")
# }
# sink()


## script to develop neural cell type deconvolution algorithm
## uses houseman method with new ref data for purified brain cell populations
## editted original code from minfi to take a matrix rather than RGset - this means data is not preprocessed together.
## this script explores how number of probes influences the result
## uses two testing scenarios:
## 1. ability to predict purified cell type,
## 2. ability to accurately estimate cellular composition of computationally simulated bulk profiles.

classifyCellType<-function(row,thres, names){
	if(max(row) > thres){
		return(names[which(row > thres)])
	} else{
		return(NA)
	}
}

source("FunctionsForBrainCellProportionsPrediction.r")
library(minfi)
library(genefilter)
library(rafalib)
library(RColorBrewer)
source("rmdConfig.bdr")
setwd(dataDir)
load(normData)

pheno$Cell.type<-gsub(" \\+ve", "", pheno$Cell.type) ## need to remove the "+" and "-"
pheno$Cell.type<-gsub(" -ve", "", pheno$Cell.type) ## need to remove the "+" and "-"

## parameters
probeSelect = "any" ## options "both" (select equal number of probes associated with hyper and hypo methylation) or "any" (just select probes based on significance regardless of direction)
cellTypes = c("Double","NeuN", "Sox10", "IRF8")
cellTypes<-sort(cellTypes)

## filter data to selected cellTypes
pheno<-pheno[which(pheno$Cell.type %in% cellTypes),]
celltypenormbeta<-celltypenormbeta[,pheno$Basename]

cellInd<-as.factor(pheno$Cell.type)

### Test 1: split into train and test 75% vs 25%
## compare performance across range of different number of probes
## outcome: correct prediction (classed at > 95% proportion).

nSamples<-round(table(pheno$Cell.type)*0.75)

rangeProbes<-c(seq(5,100, 5),seq(120,1000,20))
nSims<-10
nCorrect<-lapply(1:5, matrix,data = NA, ncol = nSims, nrow = length(rangeProbes))
names(nCorrect)<-c("All", cellTypes)
meanPredCorrect<-lapply(1:5, matrix,data = NA, ncol = nSims, nrow = length(rangeProbes))
names(meanPredCorrect)<-c("All", cellTypes)
nProbes<-matrix(data = NA, ncol = nSims, nrow = length(rangeProbes))

for(j in 1: nSims){
samples.train<-NULL
for(i in 1:length(nSamples)){
	samples.train<-c(samples.train, sample(which(pheno$Cell.type == names(nSamples)[i]),as.numeric(nSamples[i])))
}
samples.test<-c(1:nrow(pheno))[!1:nrow(pheno) %in% samples.train]

betas.train<-celltypenormbeta[,pheno$Basename[samples.train]]
betas.test<-celltypenormbeta[,pheno$Basename[samples.test]]

cellInd.train<-cellInd[samples.train]
cellInd.test<-cellInd[samples.test]

## perform F-test to identify probes with differences between cell types.
## NB only need to do F-test once for each simulation
ffComp <- rowFtests(betas.train, cellInd.train)
prof <- vapply(
        X = splitit(cellInd.train),
        FUN = function(j) rowMeans2(betas.train, cols = j),
        FUN.VALUE = numeric(nrow(betas.train)))
r <- rowRanges(betas.train)
compTable <- cbind(ffComp, prof, r, abs(r[, 1] - r[, 2]))
names(compTable)[1] <- "Fstat"
names(compTable)[c(-2, -1, 0) + ncol(compTable)] <-
        c("low", "high", "range")
tIndexes <- splitit(cellInd.train)
tstatList <- lapply(tIndexes, function(i) {
        x <- rep(0,ncol(betas.train))
        x[i] <- 1
        return(rowttests(betas.train, factor(x)))
})

form <- as.formula(
       sprintf("y ~ %s - 1", paste(levels(cellInd.train), collapse = "+")))
phenoDF <- as.data.frame(model.matrix(~ cellInd.train - 1))
colnames(phenoDF) <- sub("cellInd.train", "", colnames(phenoDF))

## select probes for deconvolution
## look at effect of number of probes
rowNum<-1
for(numProbes in rangeProbes){

	if (probeSelect == "any") {
        probeList <- lapply(tstatList, function(x) {
            y <- x[x[, "p.value"] < 1e-4, ]
            yAny <- y[order(abs(y[, "dm"]), decreasing = TRUE), ]
            c(rownames(yAny)[seq(numProbes * 2)])
        })
    } else {
        probeList <- lapply(tstatList, function(x) {
            y <- x[x[, "p.value"] < 1e-4, ]
            yUp <- y[order(y[, "dm"], decreasing = TRUE), ]
            yDown <- y[order(y[, "dm"], decreasing = FALSE), ]
            c(rownames(yUp)[seq_len(numProbes)],
              rownames(yDown)[seq_len(numProbes)])
        })
    }

	## if insufficient number of probes to select from NAs creep into probeList
	probeList<-lapply(probeList, na.omit)
    trainingProbes <- unique(unlist(probeList))
    p <- betas.train[trainingProbes,]

	# > 2 groups solution
    tmp <- validationCellType(Y = p, pheno = phenoDF, modelFix = form)
    coefEsts <- tmp$coefEsts

	nProbes[rowNum,j]<-length(trainingProbes)

	## generate prediction in test data
	counts <- projectCellType(betas.test[rownames(coefEsts), ], coefEsts)
	predCT<-apply(counts, 1, classifyCellType, 0.9, colnames(counts))
	nCorrect[["All"]][rowNum,j]<-sum(predCT == cellInd.test, na.rm = TRUE)/length(samples.test)
	propCorrectCT<-diag(apply(counts, 1, "[", match(cellInd.test, colnames(counts))))
	meanPredCorrect[["All"]][rowNum,j]<-mean(propCorrectCT, na.rm = TRUE)
	for(each in cellTypes){
		index<-which(cellInd.test == each)
		nCorrect[[each]][rowNum,j]<-sum((predCT == cellInd.test)[index], na.rm = TRUE)/length(index)
		meanPredCorrect[[each]][rowNum,j]<-mean(propCorrectCT[index], na.rm = TRUE)
	}
	rowNum<-rowNum+1
}

}
plotCols<-brewer.pal(length(cellTypes)+1, "Set1")
names(plotCols)<-c("All", cellTypes)
## calculate median and quartiles across simulations

sumStats.1<-lapply(nCorrect, apply, 1, quantile, c(0.25,0.5,0.75))
sumStats.2<-lapply(meanPredCorrect, apply, 1, quantile, c(0.25,0.5,0.75))
pdf("TestCase1SummaryPlots.pdf", width = 8, height = 8)
par(mar = c(4,4,1,1))
par(mfrow = c(2,2))
y_lim<-range(unlist(lapply(sumStats.1, range)))
plot(nProbes[,1], t(sumStats.1[["All"]])[,2], type = "l", ylim = y_lim, xlab = "nProbes", ylab = "Proportion Correct", col = plotCols[1], lwd = 2)
for(each in cellTypes){
	lines(nProbes[,1], t(sumStats.1[[each]])[,2], col = plotCols[each], lwd = 2)
}
#legend("bottomleft", names(plotCols), lty = 1, col = plotCols)

y_lim<-range(unlist(lapply(sumStats.2, range)))
y_lim[1]<-y_lim[1]-diff(y_lim)*0.2
plot(nProbes[,1], t(sumStats.2[["All"]])[,2], type = "l", ylim = y_lim, xlab = "nProbes", ylab = "Mean predicted proportion", col = plotCols[1], lwd = 2)
for(each in cellTypes){
	lines(nProbes[,1], t(sumStats.2[[each]])[,2], col = plotCols[each], lwd = 2)
}
legend("bottomleft", names(plotCols), lty = 1, col = plotCols)

y_lim<-range(unlist(lapply(sumStats.1, range)))
plot(nProbes[,1], t(sumStats.1[["All"]])[,2], type = "l", ylim = y_lim, xlab = "nProbes", ylab = "Proportion Correct", col = plotCols[1], lwd = 2, xlim = c(0,2500))
for(each in cellTypes){
	lines(nProbes[,1], t(sumStats.1[[each]])[,2], col = plotCols[each], lwd = 2)
}
#legend("bottomleft", names(plotCols), lty = 1, col = plotCols)

y_lim<-range(unlist(lapply(sumStats.2, range)))
plot(nProbes[,1], t(sumStats.2[["All"]])[,2], type = "l", ylim = y_lim, xlab = "nProbes", ylab = "Mean predicted proportion", col = plotCols[1], lwd = 2, xlim = c(0,2500))
for(each in cellTypes){
	lines(nProbes[,1], t(sumStats.2[[each]])[,2], col = plotCols[each], lwd = 2)
}
dev.off()

### Test 2: select individuals with all 4 fractions, to compute bulk simulations across full full matrix of possible proportions
## train in remaining samples

nSamp<-table(pheno$Indidivual.ID)
compIDs<-names(nSamp)[which(nSamp == length(cellTypes))]

# create a matrix fo all combinations for three cell types
# keep those that total 1 or less
# add a 4th cell type that makes up the difference to one.
intervals<-seq(0,1,0.05)
propProfile<-expand.grid(rep(list(intervals), 3))
tot<-rowSums(propProfile)
propProfile<-propProfile[which(tot < 1),]
leftOver<-1-rowSums(propProfile)
propProfile<-cbind(propProfile, leftOver)
colnames(propProfile)<-cellTypes

bulkSims<-data.frame(matrix(vector(), 0, 2+(2*length(cellTypes)), dimnames=list(c(), c("ID","NumProbes", paste0("ActualProp", cellTypes),paste0("EstimatedProp", cellTypes)))),stringsAsFactors=F)

for(ID in compIDs){

	pureProfiles<-celltypenormbeta[, which(pheno$Indidivual.ID == ID)]
	colnames(pureProfiles)<-cellInd[which(pheno$Indidivual.ID == ID)]
	pureProfiles<-pureProfiles[,cellTypes]

	## create a matrix of bulk profile weighted by proportions define earlier
	bulkProfiles <- pureProfiles %*% t(propProfile)

	## train model in all other samples
	betas.train<-celltypenormbeta[,which(pheno$Indidivual.ID != ID)]
	cellInd.train<-cellInd[which(pheno$Indidivual.ID != ID)]
	## perform F-test to identify probes with differences between cell types.
	## NB only need to do F-test once for each simulation
	ffComp <- rowFtests(betas.train, cellInd.train)
	prof <- vapply(
			X = splitit(cellInd.train),
			FUN = function(j) rowMeans2(betas.train, cols = j),
			FUN.VALUE = numeric(nrow(betas.train)))
	r <- rowRanges(betas.train)
	compTable <- cbind(ffComp, prof, r, abs(r[, 1] - r[, 2]))
	names(compTable)[1] <- "Fstat"
	names(compTable)[c(-2, -1, 0) + ncol(compTable)] <-
			c("low", "high", "range")
	tIndexes <- splitit(cellInd.train)
	tstatList <- lapply(tIndexes, function(i) {
			x <- rep(0,ncol(betas.train))
			x[i] <- 1
			return(rowttests(betas.train, factor(x)))
	})

	form <- as.formula(
		   sprintf("y ~ %s - 1", paste(levels(cellInd.train), collapse = "+")))
	phenoDF <- as.data.frame(model.matrix(~ cellInd.train - 1))
	colnames(phenoDF) <- sub("cellInd.train", "", colnames(phenoDF))

	## select probes for deconvolution
	## look at effect of number of probes
	rowNum<-1
	for(numProbes in rangeProbes){

		if (probeSelect == "any") {
			probeList <- lapply(tstatList, function(x) {
				y <- x[x[, "p.value"] < 1e-4, ]
				yAny <- y[order(abs(y[, "dm"]), decreasing = TRUE), ]
				c(rownames(yAny)[seq(numProbes * 2)])
			})
		} else {
			probeList <- lapply(tstatList, function(x) {
				y <- x[x[, "p.value"] < 1e-4, ]
				yUp <- y[order(y[, "dm"], decreasing = TRUE), ]
				yDown <- y[order(y[, "dm"], decreasing = FALSE), ]
				c(rownames(yUp)[seq_len(numProbes)],
				  rownames(yDown)[seq_len(numProbes)])
			})
		}

		## if insufficient number of probes to select from NAs creep into probeList
		probeList<-lapply(probeList, na.omit)
		trainingProbes <- unique(unlist(probeList))
		p <- betas.train[trainingProbes,]

		# > 2 groups solution
		tmp <- validationCellType(Y = p, pheno = phenoDF, modelFix = form)
		coefEsts <- tmp$coefEsts

		nProbes[rowNum,j]<-length(trainingProbes)

		## generate prediction in test data
		counts <- projectCellType(bulkProfiles[rownames(coefEsts), ], coefEsts)
		tmp<-cbind(ID, length(trainingProbes), propProfile, counts)
		colnames(tmp)<-c("ID","NumProbes", paste0("ActualProp", cellTypes),paste0("EstimatedProp", cellTypes))
		bulkSims<-rbind(bulkSims,tmp)
	}
}

## need to fix precision error
bulkSims[,grep("ActualProp", colnames(bulkSims))]<-signif(bulkSims[,grep("ActualProp", colnames(bulkSims))],2)

## calculate RMSE
diffTab<-abs(bulkSims[,grep("ActualProp", colnames(bulkSims))] - bulkSims[,grep("EstimatedProp", colnames(bulkSims))])
colnames(diffTab)<-paste0("Diff", cellTypes)
bulkSims<-cbind(bulkSims, diffTab)
plotValues<-aggregate(as.formula(sprintf("cbind(%s) ~ NumProbes", paste(paste0("Diff", cellTypes), collapse = ","))), bulkSims,FUN = "median")

## focus on numProbes ~ 2000
## plot as a function of actual proportion

bulkSims.sub<-bulkSims[which(bulkSims$NumProbes <= 2000 & bulkSims$NumProbes >= 1900),]
medErrorByProp<-list()
for(each in cellTypes){
	medErrorByProp[[each]]<-aggregate(as.formula(sprintf("%s ~ %s", paste0("Diff", each), paste0("ActualProp", each))), bulkSims.sub,FUN = "median")
}

pdf("TestCase2SummaryPlots.pdf", width = 8, height = 8)
par(mar = c(4,4,1,1))
par(mfrow = c(2,1))
y_lim<-range(unlist(lapply(plotValues[,-1], range)))
plot(plotValues[,1], plotValues[,2], type = "n", ylim = y_lim, xlab = "nProbes", ylab = "Median Error")
for(i in 2:5){
	lines(plotValues[,1], plotValues[,i], col = plotCols[i], lwd = 2)
}

y_lim<-c(0, max(unlist(lapply(lapply(medErrorByProp, "[",2), max))))
plot(medErrorByProp[[1]][,1], medErrorByProp[[1]][,2], type = "n", ylim = y_lim, xlab = "Actual Proportion", ylab = "Median Error")
for(each in cellTypes){
	lines(medErrorByProp[[each]][,1], medErrorByProp[[each]][,2], col = plotCols[each], lwd = 2)
}
y_lim[2]<-y_lim[2]+diff(y_lim)*0.2

legend("topleft", names(plotCols), lty = 1, col = plotCols)

dev.off()

save(bulkSims, nCorrect, nProbes, meanPredCorrect, file = "SimulationsNumProbes.rdata")


context("Name collapsing")

test_that("name substitution works",
  expect_equivalent(
    demo_vectors %>% closest_to(~"good")
    ,
    demo_vectors %>% closest_to(demo_vectors[["good"]])
  )
)

test_that("character substitution works",
          expect_equivalent(
            demo_vectors %>% closest_to("good")
            ,
            demo_vectors %>% closest_to(demo_vectors[["good"]])
          )
)

test_that("addition works in substitutions",
          expect_equivalent(
            demo_vectors %>% closest_to(~ "good" + "bad")
            ,
            demo_vectors %>% closest_to(demo_vectors[["good"]] + demo_vectors[["bad"]])
          )
)

test_that("addition provides correct results",
          expect_gt(
            demo_vectors[["good"]] %>% cosineSimilarity(demo_vectors[["good"]] + demo_vectors[["bad"]])
            ,
            .8))

test_that("single-argument negation works",
          expect_equivalent(
            demo_vectors %>% closest_to(~ -("good"-"bad"))
            ,
            demo_vectors %>% closest_to(~ "bad"-"good")

          ))

test_that("closest_to can wrap in function",
          expect_equal(
            {function(x) {closest_to(x,~ "class" + "school")}}(demo_vectors),
            closest_to(demo_vectors,~ "class" + "school")
          )
)

test_that("Name substitution is occurring",
  expect_equivalent(
      cosineSimilarity(demo_vectors,"good"),
      cosineSimilarity(demo_vectors,demo_vectors[["good"]])
    ))

test_that("reference in functional scope is passed along",
          expect_equivalent(
            lapply(c("good"),function(referenced_word)
              {demo_vectors %>% closest_to(demo_vectors[[referenced_word]])})[[1]],
            demo_vectors %>% closest_to("good")
         )
)


segst <- function(wave, seg) {
  srms <- wave$wav@samp.rate / 1000.0
  i <- which(wave$seg$segnam == seg)
  if (length(i) == 1) {
    st = srms * wave$seg$beg[i] / 1000.0
  } else {
    st = 0
  }
  st
}

segnd <- function(wave, seg) {
  srms <- wave$wav@samp.rate / 1000.0
  i <- which(wave$seg$segnam == seg)
  if (length(i) == 1) {
    nd = srms * wave$seg$end[i] / 1000.0
  } else {
    nd = length(wave$wav@left)
  }
  nd
}

segLoc <- function(wave, seg1, seg2=NULL) {
  ib = segst(wave, seg1)
  ie = ifelse(is.null(seg2), segnd(wave, seg1), segnd(wave, seg2))
  return(c(ib,ie))
}


# Copyright (c) 2017 YA-androidapp(https://github.com/YA-androidapp) All rights reserved.

# install.packages('RCurl')
# install.packages('XML')
# install.packages('forecast')
# install.packages('xts')
# install.packages('lubridate')
library(RCurl) # HTML取得
library(XML) # HTMLから表をパース
library(tcltk) # プログレスバー
library(forecast) # 時系列の作図と予測
library(xts) # 時系列
library(lubridate) # 時系列ボックスプロット
library(ggplot2)

# 日経平均株価ヒストリカルデータを取得する
# 1949/5以降のデータを取得可能
# tableurl <- 'https://indexes.nikkei.co.jp/nkave/statistics/dataload?list=daily&year=2017&month=8'
tableurl.1 <- 'https://indexes.nikkei.co.jp/nkave/statistics/dataload?list=daily&year='
tableurl.2 <- '&month='

today <- Sys.Date()
today.year.n <- as.numeric(format(today, '%Y'))
today.year <- as.character(today.year.n)
today.month <- as.character(as.numeric(format(today, '%m')))

# 年月ごとに取得処理を行う
since <- 1949
progressBar <- txtProgressBar(min = 0, max = 12*(today.year.n-since), style = 3)

result <- NULL
for (y in today.year:since) {
  for (m in 12:1) {
    # cat( formatC(y, width=4, flag="0"), '/', formatC(m, width=2, flag="0"))
    setTxtProgressBar(progressBar, (12*(today.year.n-y) + (12 - m)))

    # 将来分のデータは存在しないためスキップ
    diff <- difftime(as.Date(paste(y,m,'1', sep='-')),today, units = 'auto')
    if(diff>0){
      next;
    }

    tableurl <- paste(tableurl.1, y, tableurl.2, m, sep='')

    contents <- getURL(tableurl)
    doc <- htmlParse(contents, encoding = 'UTF-8')
    tabs <- readHTMLTable(doc, stringsAsFactors = F)
    table <- as.data.frame(tabs$`NULL`)
    table$始値 <- as.numeric(sub(",","",table$始値))
    table$高値 <- as.numeric(sub(",","",table$高値))
    table$安値 <- as.numeric(sub(",","",table$安値))
    table$終値 <- as.numeric(sub(",","",table$終値))
    table$日付 <- as.Date(gsub('[.]', '-', table$日付))
    rownames(table) <- gsub('[.]', '-', table$日付)

    if(is.null(result)){
      result <- table
    } else {
      result <- rbind(result, table)
    }

    Sys.sleep(0.5)
  }
}

sort <- order(result$日付)
nk225 <- result[sort,]
head(nk225) # 確認
write.csv(nk225, "./nk225.csv",row.names=T) # CSV出力

# 時系列分析のためにxtsパッケージへ変換する
nk225.xts <- as.xts(read.zoo(nk225))

# 移動平均
tail(rollapply(nk225.xts, 5, mean)) # 5日移動平均

# 月別集計
endpoints <- endpoints(nk225.xts, on='months')
period.apply(nk225.xts, endpoints, function(x) sapply(x, max))
period.apply(nk225.xts, endpoints, function(x) sapply(x, mean))
period.apply(nk225.xts, endpoints, function(x) sapply(x, median))
period.apply(nk225.xts, endpoints, function(x) sapply(x, min))

# 最終日
aggregate(nk225.xts, as.yearmon, last)

# 期別集計
endpoints.6 <- endpoints(nk225.xts, on='months', k=6)
period.apply(nk225.xts, endpoints.6, function(x) sapply(x, max))
period.apply(nk225.xts, endpoints.6, function(x) sapply(x, mean))
period.apply(nk225.xts, endpoints.6, function(x) sapply(x, median))
period.apply(nk225.xts, endpoints.6, function(x) sapply(x, min))

# 欠損値補間

# 最近接値
na.locf(nk225.xts)                   # 前の行で補間
na.locf(nk225.xts, fromLast=T)       # 後の行で補間
t(na.locf(t(nk225.xts)))             # 前の列で補間
t(na.locf(t(nk225.xts), fromLast=T)) # 後の列で補間

# 平均値
na.approx(nk225.xts)                 # 行方向の前後の平均値で補間
t(na.approx(t(nk225.xts)))           # 列方向の前後の平均値で補間

# 行列方向の前後の平均値で補間
( na.approx(nk225.xts) + t(na.approx(t(nk225.xts))) ) / 2

# スプライン補間
na.spline(nk225.xts)

# カルマンフィルタ
na.StructTS(nk225.xts)

# 作図して傾向を捉える
plot(nk225.xts[,4])

nk225.xts.ip <- na.locf(na.approx(nk225.xts), fromLast=T)

acf(nk225.xts.ip[,4]) # 自己相関プロット

plot(decompose(nk225.xts[,4])) # 成分別プロット

# ボックスプロット
nk225.xts.date <- index(nk225.xts)
nk225.df <- nk225 # 複製
nk225.df$close <- nk225.df[,4]
nk225.df$year <- factor(year(nk225.xts.date))
nk225.df$month <- factor(month(nk225.xts.date))
nk225.df$wday <- factor(weekdays(nk225.xts.date, abbreviate=T), levels=c('日', '月', '火', '水', '木', '金', '土'))
p <- ggplot(data=nk225.df, aes(x=wday, y=close)) + facet_grid(month ~ year) + geom_boxplot() + xlab('Weekday') + ylab('Nk225')
print(p)

# 訓練用データと評価用データに分割
nk225.xts.train <- nk225.xts['::2017-03-31']
nk225.xts.eval  <- nk225.xts['2017-04-01::']


read.fit<-function(file){
  #
  # Function to read a basic AD Model Builder fit.
  #
  # Use for instance by:
  #
  #   simple.fit <- read.fit('c:/admb/examples/simple')
  #
  # Then the object 'simple.fit' is a list containing sub-objects
  # 'names', 'est', 'std', 'cor', and 'cov' for all model
  # parameters and sdreport quantities.
  #
  ret<-list()
  parfile<-as.numeric(scan(paste(file,'.par', sep=''),what='', n=16, quiet=TRUE)[c(6,11,16)])
  ret$nopar<-as.integer(parfile[1])
  ret$nlogl<-parfile[2]
  ret$maxgrad<-parfile[3]
  ret$npar<-0   # initial value
  file<-paste(file,'.cor', sep='')
  if (file.exists(file)) if (file.info('op.cor')$size>1) {
    lin<-readLines(file)
    ret$npar<-length(lin)-2
    #ret$logDetHess<-as.numeric(strsplit(lin[1], '=')[[1]][2])
    sublin<-lapply(strsplit(lin[1:ret$npar+2], ' '),function(x)x[x!=''])
    ret$names<-unlist(lapply(sublin,function(x)x[2]))
    ret$est<-as.numeric(unlist(lapply(sublin,function(x)x[3])))
    ret$std<-as.numeric(unlist(lapply(sublin,function(x)x[4])))
    ret$cor<-matrix(NA, ret$npar, ret$npar)
    corvec<-unlist(sapply(1:length(sublin), function(i)sublin[[i]][5:(4+i)]))
    ret$cor[upper.tri(ret$cor, diag=TRUE)]<-as.numeric(corvec)
    ret$cor[lower.tri(ret$cor)] <- t(ret$cor)[lower.tri(ret$cor)]
    ret$cov<-ret$cor*(ret$std%o%ret$std)
  } else { cat("\n no uncertanties\n"); return(ret) }
  dim<-as.numeric(scan('admodel.dep', what='', n=2, quiet=TRUE))
  ret$dep<-matrix(as.numeric(scan('admodel.dep', what='', n=dim[1]*dim[2]+2, quiet=TRUE))[-c(1,2)],
                  byrow=TRUE, nrow=dim[2], ncol=dim[1])
  return(ret)
}

setwd(scenario.dir.optim)

fit<-read.fit('op')

if (file.exists('admodel.dep')) {
  dim<-as.numeric(scan('admodel.dep', what='', n=2, quiet=TRUE))   #the derivatives of dependent variables with respect to the independent variables
  dep<-matrix(as.numeric(scan('admodel.dep', what='', n=dim[1]*dim[2]+2, quiet=TRUE))[-c(1,2)],byrow=T, nrow=dim[2], ncol=dim[1])

  if (fit$npar==0) std.avail<-F else std.avail<-T
  if (!std.avail) {   # no std file available
    fit$npar<-dim[[2]]+dim[[1]]
    nam<-read.table(file='par_exp.out',header=T,sep=' ')
    fit$names<-nam$par
  }
  n.sdvars<-length(unique(fit$names[(fit$nopar+1):fit$npar]))  # number of sd variable types

  dimnames(dep)[[1]]<- c( paste(rep(sp.names[first.VPA:nsp],n.sdvars),fit$names[(fit$nopar+1):fit$npar]))
  dimnames(dep)[[2]]<- paste(sp.names[first.VPA:nsp],'F',sep='_')

  sink('_derivatives.txt')
    print(round(dep,0))
  sink()

  n<-dim[[1]]  # number of VPA species

  if (!std.avail) {   # no std file available
    condensed<-read.table('op_condensed.out',header=TRUE)
    condensed<-droplevels(subset(condensed,Year>=my.first.year & Year<=my.last.year))

    avg_F<-tapply(condensed$Fbar,list(condensed$Species.n),mean)
    #cat("\nAverage F\n"); (round(avg_F,3)); (round(fit$est[1:fit$nopar],3))  # should be the same as above

    avg_SSB<-tapply(condensed$SSB,list(condensed$Species.n),mean)
    #cat("\nAverage SSB\n");(round(avg_SSB,3))

    avg_yield<-tapply(condensed$yield,list(condensed$Species.n),mean)
    #cat("\nAverage yield\n");(round(avg_yield))

    condensed<-droplevels(subset(condensed,Year==my.last.year))

    SSB_ly<-tapply(condensed$SSB,list(condensed$Species.n),sum)
    #cat("\nSSB_ly\n");(round(SSB_ly))

    yield_ly<-tapply(condensed$yield,list(condensed$Species.n),sum)
    #cat("\nyield_ly\n");(round(yield_ly))
  }
  if (std.avail) {
    i<-0; avg_F<-fit$est[(i*n+1):((i+1)*n)]
    i<-1; avg_yield<-fit$est[(i*n+1):((i+1)*n)]
    i<-2; yield_ly<-fit$est[(i*n+1):((i+1)*n)]
    i<-3; avg_SSB<- fit$est[(i*n+1):((i+1)*n)]
    i<-4; SSB_ly<-  fit$est[(i*n+1):((i+1)*n)]
  }

  dep.mean<-matrix(c(rep(avg_yield,n),rep(yield_ly,n),rep(avg_SSB,n),rep(SSB_ly,n)),byrow=T,ncol=n,nrow=4*n)
  rel.change.in.F<-0.10

  dep.relative1<- dep/dep.mean
  dep.relative<- dep/dep.mean *rel.change.in.F*rep(avg_F,each=n*n.sdvars)
  dep.relative.percent<-dep.relative*100
  round(dep.relative.percent,1)

  #make a nice table
  NArow<-avg_F
  NArow[]<-NA
  a<-rbind(avg_F,NArow,avg_yield/1000,NArow,dep.relative.percent[1:n,],NArow,avg_SSB/1000,NArow,dep.relative.percent[(n*2+1):(n*3),])
  dimnames(a)[[2]]<-sp.names[first.VPA:nsp]

  a<-a[,-grep('Sole',dimnames(a)[[2]])]
  a<-a[,-grep('Plaice',dimnames(a)[[2]])]

  a<-a[-grep('Sole',dimnames(a)[[1]]),]
  a<-a[-grep('Plaice',dimnames(a)[[1]]),]

  if (!NS.Key.2014) {ndec<-8;spl<-c("--Cod", "--Whiting","--Haddock","--Saithe","--Herring","--Sandeel","--Norway pout","--Sprat")}
  if (NS.Key.2014) {ndec<-9; spl<-c("--Cod", "--Whiting","--Haddock","--Saithe","--Herring","--Northern sandeel","--Southern sandeel","--Norway pout","--Sprat") }

  dimnames(a)[[1]]<- c( "F at maximum","  ","Average yield (1000 t) at maximum F", "- Change(%) in Yield by species -" ,spl,
                  " ","Average SSB (1000 t) at maximum F", "- Change (%) in SSB by species -" ,spl)

  xtab3(a, caption=paste("Effects of a",round(rel.change.in.F*100),"% increase in F at maximum based on partial derivatives.  ",ifelse(std.avail,' converged','non convergence'),' max grad:',fit$maxgrad), cornername='  ',
           file=file.path('_derivatives.html'), dec=c(2,0,0,0,rep(1,ndec),0,0,0,rep(1,ndec)), width='"100%"',units=' ')

}
setwd(data.path)


library(tidyverse)

irs_data <- read.csv("irs.csv")

Poverty <- irs_data %>%
  group_by(Year, Name) %>%
  mutate(Number_Total_exemptions = as.numeric(gsub(",","", Total.exemptions)),
         Number_Poor_exemptions = as.numeric(gsub(",","", Poor.exemptions))) %>%
  select(Year, Name, Number_Total_exemptions, Number_Poor_exemptions)

top_5_poverty_states <-  Poverty %>%
  filter(Name == "Mississippi" | Name == "Louisiana" | Name == "New Mexico" |
           Name == "Kentucky" | Name == "Arkansas")

chart2 <- ggplot(data = top_5_poverty_states)+
  geom_col(mapping = aes(x = Year, y = Number_Poor_exemptions, fill = Name))+
  labs(title = "Poor Exemptions Indicating Poverty in Top 5 Poorest States ",
       subtitle = "From 1990 - 2018",
       x = "Year",
       y = "# of Poor Exemptions")+
  facet_wrap(~Name)


install.packages('lmtest')
require(lmtest)

condSurvival <- tbl_df(read.table("../processed/conditional_survival_analysis.csv",
                  sep = ",", header = TRUE,
                  stringsAsFactors = FALSE))

write.table(condSurvival %>% select(-n, -km) %>% filter(treatmentType != "total"),
            "../tables/table_BC_conditional_survival.csv", sep = ",", col.names = TRUE,
            row.names = FALSE, quote = FALSE)

linTest <- condSurvival %>% mutate(point.estimate = 1 - point.estimate,
                        X95_conf_low = 1 - X95_conf_low,
                        X95_conf_high = 1 - X95_conf_high) %>%
                            filter(treatmentType != "total")

expfits <- foreach(tt = c("3TC", "PI", "NNRTI", "NRTI"), .combine = "rbind")%do%{

    dat <- linTest %>% filter(treatmentType == tt, Year > 1)  %>% select(Year, point.estimate)
    exp.model <- (lm(log(point.estimate) ~ Year, data= dat))

    timevalues <- seq(1, 10, 0.1)
    Counts.exponential <- exp(predict(exp.model,list(Year=timevalues)))
    fits <- tbl_df(cbind(timevalues, Counts.exponential))
    colnames(fits) <- c("Year", "point.estimate")

    bind_rows(dat %>% mutate(type = "dat"),
              fits %>% mutate(type = "fits")) %>% mutate(treat = tt, r = (summary(exp.model))['r.squared']$r.squared, pval = coef(summary(exp.model))[2, 4])

}

offset <- 0.05
g.a <- condSurvival %>% mutate(point.estimate = 1 - point.estimate,
                        X95_conf_low = 1 - X95_conf_low,
                        X95_conf_high = 1 - X95_conf_high) %>%
                            filter(treatmentType != "total") %>%
    mutate(Year = ifelse(treatmentType == "3TC", Year - 1.5 * offset,
               ifelse(treatmentType == "NNRTI", Year - 0.5 * offset,
               ifelse(treatmentType == "NRTI", Year + 0.5 * offset,
               ifelse(treatmentType == "PI", Year + 1.5 * offset, NA))))) %>%
    ggplot() +
    geom_point(aes(x =  Year, y = point.estimate, col = treatmentType)) +
    geom_segment(aes(x = Year , xend = Year, y = X95_conf_low, yend = X95_conf_high,
                     col = treatmentType, group = treatmentType)) +
    scale_color_manual(values = cols) +
    labs(x = "Year of treatment", y = "Probability of resistance") +
    theme_classic() + theme(legend.position="bottom") +
    theme(legend.title = element_blank()) +
    scale_x_continuous(breaks = seq(0, 10, by = 2), labels = seq(0, 10, by = 2)) +
    geom_path(aes(x = Year, y = point.estimate, col = treat, group = treat),
              data = expfits %>% arrange(Year) %>% filter(type == "fits", Year > 1.9)) +
    geom_path(aes(x = Year, y = point.estimate, col = treat, group = treat),
              data = expfits %>% arrange(Year) %>% filter(type == "fits", Year < 2.1), lty = "dashed") +
                  geom_richtext(aes(x = 10, y = 0.1 - ya,
                            label = paste0("*r2* = ", signif(r, 2)), col = treat), show.legend = FALSE,
data = expfits %>% group_by(treat) %>% slice(n = 1) %>% mutate(ya = 0.0075 * which(treat == unique(expfits$treat))), fill = NA, label.color = NA, hjust = 1)

expfits <- foreach(tt = c("3TC", "PI", "NNRTI", "NRTI"), .combine = "rbind")%do%{

    dat <- linTest %>% filter(treatmentType == tt, Year > 1)  %>% select(Year, point.estimate)
    exp.model <- (lm(log(point.estimate) ~ Year, data= dat))

    tbl_df(coef(summary(exp.model)) ) %>% mutate(Param = c("Intercept", "Year"), r2 = (summary(exp.model))['r.squared']$r.squared, treat = tt)

}

tabToPrint <- expfits %>% mutate(Estimate = ifelse(Param == "Intercept", exp(Estimate), Estimate)) %>%
    select(treat, r2, Param, Estimate, `Std. Error`,  `t value`, `Pr(>|t|)`) %>%
    mutate(Param = ifelse(Param == "Intercept", "a", "b"))

write.table(tabToPrint,
            "../tables/table_BC_exponential_fits.csv", sep = ",", col.names = TRUE,
            row.names = FALSE, quote = FALSE)


setwd("fakepath:\\allstate");
tr_dat<-read.csv("lenc.csv",stringsAsFactors=FALSE,header=TRUE);
ts_dat<-read.csv("lenc_test.csv",stringsAsFactors=FALSE,header=TRUE);

nc<-dim(tr_dat)[2];
nr<-dim(tr_dat)[1];

te_sz<-15000;
tr_set<-tr_dat[1:(nr-te_sz),1:(nc-1)];
tr_y<-tr_dat[1:(nr-te_sz),nc];
t_set<-tail(tr_dat,5000);
te_set<-t_set[,1:(nc-1)];
te_y<-t_set[,nc];

nc_oos<-dim(ts_dat)[2];
nr_oos<-dim(ts_dat)[1];
oos_set<-ts_dat[,1:130];

rssqe<-function(predictions,te_y) { (sum((as.matrix(predictions)-te_y)^2)/length(te_y))^0.5;}
writepred<-function(pred,mname)
 { write.csv(pred,file=paste0(mname,".csv"),row.names=FALSE);}

library(h2o);
set.seed(12345);

h2o.init();
tr_set<-tr_dat[1:(nr-te_sz),1:nc]; # after running setup.r
sampl_set<-tr_set;

tr_set_std<-tr_set;
te_set_std<-te_set;
oos_set_std<-oos_set;

dset.hex<-as.h2o(tr_set);
tset.hex<-as.h2o(te_set);
oos.hex<-as.h2o(oos_set);

ann_pred<-function(model,modelstr)
{ predictions<-h2o.predict(model,tset.hex);
  x<-cbind(as.matrix(predictions),te_y);
  str<-sprintf("ann model %s rms_error: %5.3f",modelstr,rssqe(predictions,te_y));
  print(str);
  predictions<-h2o.predict(model,oos.hex);
  predictions<-as.matrix(predictions);
  writepred(predictions,modelstr);
}

build_ann<-function(nsampl=75000,nhid=66,smetric="AUTO",nfld=10,modlstr)
{ #tr_set2<-tr_dat[sample(nrow(sampl_set),nsampl,replace=TRUE),];
  tr_set2<-tr_dat[sample(nrow(sampl_set),nsampl),];
  dset.hex<-as.h2o(tr_set2);
  ann_Rx<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=nhid,stopping_metric=smetric,nfolds=nfld,seed=12345,standardize=TRUE);
  ann_pred(ann_Rx,modlstr);
}

x<-sample(40:80,20);
x2<-sample(7:13,20,replace=TRUE);
for (i in 1:2)
 { modlstr<-paste0("ann_R4_",x[i],"_",x2[i]);
   ssz<-sample(120000:140000,1);
   print(sprintf("modlstr: %s, nhid: %3d, %3d sampl: %5d",modlstr,x[i],x2[i],ssz));
   build_ann(nsampl=ssz,nhid=c(x[i],x2[i]),smetric="AUTO",nfld=10,modlstr);
 }

library(xgboost);
set.seed(12345);

xgb_pred<-function(model,modelstr)
{ predictions<-predict(model,as.matrix(te_set));
  x<-cbind(as.matrix(predictions),te_y);
  str<-sprintf("*** gbm model %s rms_error: %5.3f",modelstr,rssqe(predictions,te_y));
  print(str);
  predictions<-predict(model,as.matrix(oos_set));
  predictions<-as.matrix(predictions);
  writepred(predictions,modelstr);
}

build_xgb<-function(nsampl=75000,modlstr,nrnd)
 { tr_set2<-tr_dat[sample(nrow(tr_dat),nsampl),];
   tr_x2<-tr_set2[,1:(nc-1)];
   tr_y2<-tr_set2[,nc];
   xgbm<-xgboost(data=as.matrix(tr_x2),label=tr_y2,nrounds=i,eta=0.01,verbose=0);
   #xgbm<-xgboost(data=as.matrix(tr_x2),label=tr_y2,nrounds=i,verbose=0);
   xgb_pred(xgbm,modstr);
 }

for (i in seq(2808,2900))
 { for (j in seq(1,3))
   {
    rstr<-round(runif(1,100000,999999));
    modstr<-paste0("xgbm#_R4_",i,"_",rstr);
    print(modstr);
    build_xgb(120000,modstr,i);
   }
 }

### try_20161127
for (i in seq(2773,2900))
 {  rstr<-round(runif(1,100000,999999));
    modstr<-paste0("xgbm#_R5_",i,"_",rstr);
    print(modstr);
    build_xgb(173318,modstr,i);
 }


> options(expressions=10000)
> mapply(A, 0:10, 1, -1, -1, 1, 0)
 [1]   1   0  -2   0   1   0   1  -1 -10 -30 -67


library(ggplot2)
library(scales)
library(ggpubr)
library(bayesplot)
library(matrixStats)
library(cowplot)

plot_covars <- function(filename){

  load(paste0("nature/results/", filename,'-stanfit.Rdata'))
  out <- rstan::extract(fit)
  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(data1,data2[1:5,])
  colQuantiles(data.matrix(first.intervention),probs=c(.025,.975))

  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_blank(
      mapping = NULL, data = NULL,
      show.legend = FALSE, inherit.aes = FALSE)
  }
  args_outer <- list(mapping = aes_(x = ~ll, xend = ~hh, y = ~parameter,
                                    yend = ~parameter))
  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"

  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]])
  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 = "",
                        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("nature/figures/covars-alpha-reduction", filename,".png"),
         p,height=4,width=8)
}


EGU.plot.timeseries <- function(){

source('../code/moving.quantile.classification.R')
source('../code/normalize.R')

# read data
understory <- read.table('birch.understory-2007-tseries.txt')
birch <- read.table('birch-2007-tseries.txt')
beech <- read.table('beech-2007-tseries.txt')
s.maple <- read.table('sugar.maple-2007-tseries.txt')
red.maple <- read.table('red.maple-2007-tseries.txt')
sky <- read.table('sky-2007-tseries.txt')
conif <-read.table('conif-2007-tseries.txt')

# smooth using moving quantile
beech <- na.omit(moving.quantile(beech))
birch <- na.omit(moving.quantile(birch))
s.maple <- na.omit(moving.quantile(s.maple))
red.maple <- na.omit(moving.quantile(red.maple))
understory <- na.omit(moving.quantile(understory))
sky <- na.omit(moving.quantile(sky))
conif <- na.omit(moving.quantile(conif))

# plot everything

plot(beech[,1],beech[,2],
xaxt='n',
yaxt='n',
xlab='DOY (2007)',
ylab='ExG',
type='n',
cex.lab=1.2,
ylim=c(0.32,0.45)
)

lines(sky[,1],sky[,2],lwd=1.5,pch=6,lty=6,type='b',col='grey75')
lines(beech[,1],beech[,2],lwd=1.5,pch=1,lty=1,type='b',col='orange')
#lines(birch[,1],birch[,2],lwd=1.5,pch=2,lty=2,type='b',col='yellow')
lines(red.maple[,1],red.maple[,2],lwd=1.5,pch=3,lty=3,type='b',col='red')
#lines(s.maple[,1],s.maple[,2],lwd=1.5,pch=4,lty=4,type='b')
lines(understory[,1],understory[,2],lwd=1.5,pch=5,lty=5,type='b')
lines(conif[,1],conif[,2],pch=7,lty=7,type='b',col='lightgreen')

legend('topright',legend=c('birch/understory','beech','red maple','sky','coniferous'),lty=c(5,1,3,6,7),pch=c(5,1,3,6,7),col=c('black','orange','red','grey75','lightgreen'),cex=1.2,bty='n')

legend('topleft',legend=c('ExG = 2G - R - B'),cex=1.2,bty='n')

axis(1,label=T,lwd=1.5,cex.axis=1.5)
axis(2,label=T,lwd=1.5,cex.axis=1.5)
box(lwd=1.5)
}
EGU.plot.timeseries()


##########################################
## HELPER FUNCTIONS
##########################################
# DATA MUNGING FUNCTIONS
GrabData <- function(x, from = '20130225', to = '20181228'){
  # Retrieves historical price data from stooq.com.
  # Args:
  #   x: Stock symbol. Lowercase string.
  #   from: First date in the series. String in the format of %YYYY%MM%DD.
  #   to: Last date in the series. String in the format of %YYYY%MM%DD.
  # Returns: A dataframe with Date, Open, High, Low, Close, and Volume columns
  return(read.csv(sprintf('https://stooq.com/q/d/l/?s=%s.us&d1=%s&d2=%s&i=d',
                          x, from, to)))
}
Frame2Xts <- function(x){
  # Convert dataframe pulled from stooq to xts object
  # Args:
  #   x: datafame object from stooq.com
  # Returns: xts equivalent of original data frame
  x$Date <- as.Date(x$Date)
  x.xts <- xts(x, order.by = x$Date)
  storage.mode(x.xts) <- "numeric"
  x.xts$Date <- NULL
  x.xts
}
# ANALYSIS HELPER FUNCTIONS
KellyCriterion <- function(p.hat, p.given){
  # Proportion bets based on disparity between given odds and true odds
  # Args:
  #   p0 = estimated probabilty of event occuring
  #   p1 = given probability
  # Returns: Fraction of bankroll to be wagered on a particular bet
  out <- list(1/p.given, ((p.hat*(1/p.given))-(1-p.hat))*p.given)
  names(out) <- c('odds','bet')
  out
}
PLag4 <- function(x){
  # Calculate and store daily returns, whether return was positive or negative,
  # calulate lagged returns up to 4 lags, return new xts object
  # Args:
  #   x: an xts object with 'Close' column
  # Returns: xts object with daily returns, up to 4 lags,
  # and dummy for whether return was positive or negative
  x$Return <- ((x$Close/lag(x$Close, 1)) - 1 )
  x$PosR <- ifelse(x$Return > 0.0, 1, 0)
  x$NegR <- ifelse(x$Return < 0.0, 1, 0)
  x$LR1 <- lag(x$Return, 1)
  x$LR2 <- lag(x$Return, 2)
  x$LR3 <- lag(x$Return, 3)
  x$LR4 <- lag(x$Return, 4)
  x
}
TTSplit <- function(x, p = 0.7){
  # Splits data set in training and testing sets. Produce index of split.point
  # Args:
  #   x: xts object
  #   p: proprtion of entries to be used in test data set
  # Returns: train data (xts), test data (xts), split.point (integer)
  nm <- c('train.data', 'test.data', 'split.point')
  split.point <- floor(nrow(x)*p)
  train.data <- x[(1:split.point),]
  test.data <- x[(split.point+1):nrow(x),]
  out <- list(train.data, test.data, split.point)
  names(out) <- nm
  out
}
LiveTestSplit <- function(x, start, stop){
  # Reduces data sets to index from start to stop
  # Args:
  #   x: xts object
  #   start: string providing start date in the format MM/DD/YY
  #   stop: string providing stop date in the format MM/DD/YY
  # Returns: xts object indexed from start to stop date
  dates <- c(start,stop)
  dates <- as.Date(dates, '%m/%d/%y')
  formated.date <- sprintf("%s/%s", dates[1], dates[2])
  x[formated.date]
}
LogitEval2 <- function(model, data, cut.point = 0.5){
  # Feed in logistic regression model, model factors, and data to be tested on
  # Args:
  #   model: logistic regresion model object
  #   data: data series for the model to be tested on
  # Returns: Accuracy, Confusion Matrix
  # CONFUSION MATRIX ---------------
  pred <- predict(model, data, type = "response")
  pred <- ifelse(pred > cut.point, 1, 0)
  m.confusion <- table(Predicted = pred,
                       Actual = data[, c(strsplit(as.character(model$formula), ' ')[[1]][1])])
  accuracy <- as.numeric(sum(diag(m.confusion))/sum(m.confusion))
  # OUTPUT -----------------------
  out <- list(accuracy, m.confusion)
  names(out) <- c("accuracy", "m.confusion")
  out
}
#TODO(dkanu): Add documentations and comment
LogitPred <- function(model, data, tol = 0.5, action = 'long'){
  pred_prob <- predict(model, newdata = data, type = 'response')
  if(action == 'long'){decision <- ifelse(pred_prob > tol, 1, 0)}
  if(action == 'short'){decision <- ifesle(pred_prob < tol, 1, 0)}
  out <- list(action, pred_prob[[1]], decision[[1]])
  names(out) <- c('type', 'pred_prob', 'decision')
  out
}
#TODO(dkanu): Add documentations and comment
SvmPred <- function(model, data, action = 'long'){
  pred_prob <- predict(model, newdata = data)
  if(action == 'long'){decision <- ifelse(pred_prob == 1, 1, 0)}
  if(action == 'short'){decision <- ifelse(pred_prob == 0, 1, 0)}
  out <- list(action, decision)
  names(out) <- c('type', 'classification')
  out
}
SvmEval2 <- function(model, data){
  # Feed in logistic regression model, model factors, and data to be tested on
  # Args:
  #   model: logistic regresion model object
  #   data: data series for the model to be tested on
  # Returns: Accuracy, Confusion Matrix
  # CONFUSION MATRIX ---------------
  pred <- predict(model, data)
  m.confusion <- table(Predicted = pred,
                       Actual = data[, gsub('as.factor, ', '',
                                            toString(get(toString(model$call$formula))[[2]])
                                            )
                                     ]
                       )
  accuracy <- as.numeric(sum(diag(m.confusion))/sum(m.confusion))
  # OUTPUT -----------------------
  out <- list(accuracy, m.confusion)
  names(out) <- c("accuracy", "m.confusion")
  out
}


# Wind Manipulation
# 2016-05-05 Ismail SEZEN
# sezenismail@gmail.com

#' rwind: A package for processing wind and related data.
#'
#' The rwind package provides four categories of important functions:
#' \code{\link{deg2comp}}, \code{\link{hd2uv}}, \code{\link{uv2hd}}
#' and \code{\link{rotax}}.
#'
#' @section rwind functions:
#' The rwind functions ...
#'
#' @docType package
#' @name rwind
NULL

index_array <- function(x, dim, value, drop = T) {
  indices <- rep(list(bquote()), length(dim(x)))
  indices[[dim]] <- value
  call <- as.call(c(
    list(as.name("["), quote(x)),
    indices,
    list(drop = drop)))
  eval(call)
}

windhelper_get_args <- function(...) {
  l <- list(...); x <- NULL
  if (length(l) == 1) {
    if (is.array(l[[1]])) x <- l[[1]]
    if (is.data.frame(l[[1]])) x <- as.matrix(l[[1]])
  }
  if (is.null(x)) x <- do.call(c, l)
  if (is.vector(x) && (length(x) %% 2) == 0)
    x <- array(x, dim = c(length(x) / 2, 2))
  return(x)
}

#' Wind direction to compass direction
#'
#' \code{deg2comp} converts horizontal wind speed and direction to uv
#' components of wind.
#'
#' @param x A numeric vector of wind directions in degrees.
#' @return Wind directions converted to compass directions
#'
#' @author Ismail SEZEN, \email{sezenismail@@gmail.com}
#'
#' @examples
#' deg2comp(runif(100, 0, 360))
#' x <- array(runif(1000, 0, 360), dim = c(10, 10, 10))
#' deg2comp(x)
#'
#' @export
deg2comp <- function(x, bins = c("N", "NNE", "NE", "ENE",
                                 "E", "ESE", "SE", "SSE",
                                 "S", "SSW", "SW", "WSW",
                                 "W", "WNW", "NW", "NNW")) {
  x[x == 0] <- 360
  x <- round((x * length(bins) / 360) + .5)
  x[1:length(x)] <- bins[x]
  return(x)
}

#' uv to horizontal speed & direction
#'
#' Convert uv components of wind to horizontal wind speed and direction.
#'
#' @param ... The names of the objects to be converted
#' @param deg Should the resulting wind directions are degree or radian?
#' @param reverse should be added 180 degree (or pi) to the wind directions?
#' @param drop Should be deleted the dimensions of an array which
#'        have only one level?
#' @return Speed and direction of the wind
#'
#' @author Ismail SEZEN, \email{sezenismail@@gmail.com}
#'
#' @examples
#' uv2hd(1, 1)
#' uv2hd(c(1, 1))
#' x <- array(runif(100, -5, 5), dim = c(100, 100, 2))
#' uv2hd(x)
#'
#' @export
uv2hd <- function(..., deg = T, reverse = T, drop = T) {
  x <- windhelper_get_args(...)
  comp_loc <- which(dim(x) == 2, arr.ind = T) # find uv dim order
  if (length(comp_loc) == 0)
    stop("x does not have a dim = 2 represents u and v")
  dx <- dim(x); ldx <- length(dx)
  r <- aperm(x, c(comp_loc, (1:ldx)[-comp_loc])) # get uv dim to start

  num_pi <- if (deg) 180 else pi
  add_pi <- if (reverse) num_pi else 0
  u <- index_array(r, 1, 1)
  v <- index_array(r, 1, 2)
  h <- sqrt(colSums(r ^ 2))
  d <- ((atan2(u / h, v / h) * num_pi / pi) + add_pi)
  if (deg) d <- d  %% 360
  r <- array(c(h, d), dim = dx)

  r[is.nan(r)] <- 0
  dmn <- dimnames(x)
  if (is.null(dmn)) {
    dimnames(r)[[comp_loc]] <- c("h", "d")
  } else {
    dimnames(r) <- dmn
  }
  if (drop) r <- drop(r)
  return(r)
}

#' Horizontal wind speed & direction to uv
#'
#' Convert horizontal wind speed and direction to uv components of wind.
#'
#' @param ... The names of the objects to be converted
#' @param deg Should the resulting wind directions are degree or radian?
#' @param drop Should be deleted the dimensions of an array which
#'        have only one level?
#' @return uv components of the wind
#'
#' @author Ismail SEZEN, \email{sezenismail@@gmail.com}
#'
#' @examples
#' hd2uv(5, 30)
#' hd2uv(c(5, 30))
#' x <- matrix(c(runif(100, -5, 5), round(runif(100, 0, 360), 2)), ncol = 2,
#'             dimnames = list(NULL, c("h","d")))
#' hd2uv(x)
#'
#' @export
hd2uv <- function(..., deg = T, drop = T) {
  x <- windhelper_get_args(...)
  comp_loc <- which(dim(x) == 2, arr.ind = T) # find uv dim order
  if (length(comp_loc) == 0)
    stop("x does not have a dim = 2 represents h and d")
  dx <- dim(x); ldx <- length(dx)
  r <- aperm(x, c(comp_loc, (1:ldx)[-comp_loc])) # get uv dim to start

  num_pi <- if (deg) 180 else pi
  h <- index_array(r, 1, 1)
  d <- index_array(r, 1, 2)
  d <- (d - num_pi) / num_pi
  u <- h * sinpi(d)
  v <- h * cospi(d)
  r <- array(c(u, v), dim = dx)

  r[is.nan(r)] <- 0
  dmn <- dimnames(x)
  if (is.null(dmn)) {
    dimnames(r)[[comp_loc]] <- c("u", "v")
  } else {
    dimnames(r) <- dmn
  }
  if (drop) r <- drop(r)
  return(r)
}

#' Rotate coordinate axis for uv wind components
#'
#' Rotates coordinate axes for uv components of the wind. uv values will be
#' re-calculated based on new axis. For instance, rotating axis 30 degrees
#' in clockwise means new and old positive y-directions will have 30 degrees
#'  between them.
#'
#'
#' @param ... The names of the objects to be converted.
#' @param alfa Rotation angle in degrees or radians.
#' @param deg TRUE if alfa is degree.
#' @param right TRUE if rotation is in clockwise.
#' @param drop Should be deleted the dimensions of an array which have
#'        only one level?
#' @return Rotated uv components
#'
#' @author Ismail SEZEN, \email{sezenismail@@gmail.com}
#'
#' @examples
#' rotax(1, 1)
#' rotax(1, 1, alfa = 120)
#' x <- array(runif(100, -5, 5), dim = c(100, 100, 2))
#' rotax(x)
#'
#' @export
rotax <- function(..., alfa = 45, deg = T, right = T, drop = T) {
  x <- windhelper_get_args(...)
  comp_loc <- which(dim(x) == 2, arr.ind = T) # find uv dim order
  if (length(comp_loc) == 0)
    stop("x does not have a dim = 2 represents u and v")

  u <- index_array(x, comp_loc, 1)
  v <- index_array(x, comp_loc, 2)
  a <- if (deg) alfa / 180 else alfa / pi
  c <- cospi(a); s <- sinpi(a)
  if (right) {
    un <- u * c - v * s
    vn <- u * s + v * c
  } else {
    un <- u * c + v * s
    vn <- v * c - u * s
  }
  dm <- dim(x); dn <- dimnames(x)
  x <- array(c(un, vn), dim = dm)
  dimnames(x) <- dn
  if (drop) x <- drop(x)
  return(x)
}


png(file="temp/Rbar02.png", bg="white", width=780, height=560)

x.value <- c(135, 99, 94,33,2,0)
x.name <-c("待问","浦东","品管","石膏代型","蜡型包埋","CAPTEK蜡型")

x1.value <- sort(x.value,decreasing = TRUE)
x2 <- x1.value
i <- 1
t <- 0
for( x in x1.value)
{
	t <- t + 100*x/363
	x2[i] <- t
	i <- i+1
}
##lines();
##x1.name <- x.name
##xp <- c(32,60,8,21,74,4,65,7,1,71,33,29,4,5,8,30,8,14,13,5,43,3,0,17,-1)

barplot(x1.value,ylim=c(0,max(x1.value)),offset = 0,col=rainbow(18),
names=c("Process", "NGMES BUG","Infrastr...","Turn Table","Operation","Interface"),
)

par(new=TRUE)
plot(x2, ann=FALSE, type="n", ylim=c(0,100),offset = 0,axes = FALSE)

axis(4, c(0,20,40,60,80,100), lwd = 1)
box()

abline(h = 100*0.8, col = gray(0.9))
lines(x2, col = "blue", lty = 1, type="o")
##points(x1, pch = 1)

##text(x1.value, labels=(x1.name))
title(main = "排列图", xlab = "--", col.main = "blue", col.lab = gray(0.8), cex.main = 1.2, cex.lab = 1, font.main = 4, font.lab = 3)

##legend("topright", c("WIP", "标准产能",), col = c(3,4), text.col = "green4", lty = c(2, 1), pch = c(4,1), merge = TRUE, bg = 'gray90')

dev.off()
# 114,74, 148, 570 / 155 127  188, 570
  y1 <- 74+ x1.value ##array(rep(seq(1,by=floor(w/k), to=w),k),c(k,k))
  y2 <- 74+ y1 + 10 ##floor(w/k) - 1
  x1 <- t(y1)
  x2 <- t(y2)
  val <- 1:25


#' Remove points from a scatter plot where density is really high
#' @param x x-coordinates vector
#' @param y y-coordinates vector
#' @param resolution number of partitions for the x and y-dimensions.
#' @param max.per.cell maximum number of points per x-y partition.
#' @return index into the points that omits points from x-y partitions
#' so that each has at most \code{max.per.cell} points.
scatter.thinning <- function(x,y,resolution=100,max.per.cell=100) {
    x.cell <- floor((resolution-1)*(x - min(x,na.rm=T))/diff(range(x,na.rm=T))) + 1
    y.cell <- floor((resolution-1)*(y - min(y,na.rm=T))/diff(range(y,na.rm=T))) + 1
    z.cell <- x.cell * resolution + y.cell
    frequency.table <- table(z.cell)
    frequency <- rep(0,max(z.cell, na.rm=T))
    frequency[as.integer(names(frequency.table))] <- frequency.table
    f.cell <- frequency[z.cell]

    big.cells <- length(which(frequency > max.per.cell))
    sort(c(which(f.cell <= max.per.cell),
           sample(which(f.cell > max.per.cell),
                  size=big.cells * max.per.cell, replace=F)),
         decreasing=F)
}

#' Manhattan plot
#'
#' @param object Output from the \code{\link{dmrff}()}, \code{\link{dmrff.meta}()}
#' or \code{\link{dmrff.cohort}} functions.
#' @param title Title for the plot (Default: "Manhattan plot").
#' @return \code{\link{ggplot}} object showing the Manhattan plot.
#' @export
dmrff.manhattan.plot <- function(object, chr, pos, title="Manhattan plot") {
    stopifnot(class(object) == "data.frame")
    stopifnot(all(c("chr","start","end","p.value","n") %in% colnames(object)))
    chr <- as.character(chr)
    stopifnot(all(object[["chr"]] %in% chr))
    stopifnot(length(chr) == length(pos))
    object$loc <- paste(as.character(object$chr), object$start)
    loc <- paste(chr,pos)
    stopifnot(all(object$loc %in% loc))

    chromosomes <- unique(chr)
    chromosomes <- chromosomes[order(as.integer(sub("chr","",tolower(chromosomes))))]

    stats <- data.frame(chr=factor(as.character(chr), levels=chromosomes),
                        pos=pos,
                        chr.colour=0)
    stats$loc <- loc
    stats$chr.colour[stats$chromosome %in% chromosomes[seq(1,length(chromosomes),2)]] <- 1
    object$p.value[which(object$p.value < .Machine$double.xmin)] <- .Machine$double.xmin
    object$logp <- -log(object$p.value,10) * sign(object$estimate)
    object$pos <- object$start
    stats$stat <- 0
    stats$stat[match(object$loc, stats$loc)] <- object$logp

    stats <- stats[order(stats$stat, decreasing=T),]

    chr.lengths <- sapply(chromosomes, function(chr) max(stats$pos[which(stats$chr == chr)]))
    chr.lengths <- as.numeric(chr.lengths)
    chr.starts <- c(1,cumsum(chr.lengths)+1)
    names(chr.starts) <- c(chromosomes, "NA")
    stats$global <- stats$pos + chr.starts[stats$chr] - 1

    stats <- stats[which(abs(stats$stat) > -log(0.05,10)),]

    selection.idx <- scatter.thinning(stats$global, stats$stat,
                                      resolution=100, max.per.cell=100)
    stats <- stats[selection.idx,]

    ret <- (ggplot(stats, aes(x=pos, y=stat)) +
            geom_point(aes(colour=chr.colour)) +
            facet_grid(. ~ chr, space="free_x", scales="free_x") +
            theme(strip.text.x = element_text(angle = 90)) +
            guides(colour=FALSE) +
            labs(x="Position",
                 y=bquote(-log[10]("p-value") * sign(beta))) +
            theme(axis.text.x = element_blank(), axis.ticks.x = element_blank()) +
            ggtitle(title))

    if (any(object$p.adjust < 1)) {
        sig.threshold <- 0.05/max(object$p.adjust/object$p.value, na.rm=T)
        ret <- (ret +
                geom_hline(yintercept=log(sig.threshold,10), colour="red") +
                geom_hline(yintercept=-log(sig.threshold,10), colour="red"))
    }

    ret
}


get_deltas_dt <- function(seed_0, dataset){
        merged_activation_trajectory <- merge(seed_0, dataset, by=c("muscle", "task_index"))
        #split by muscle so we can get a_{i+1} - a_{i}
        each_muscle <- split(merged_activation_trajectory, merged_activation_trajectory$muscle)
        diffsets <- lapply(each_muscle, function(sa){
                seed_activations <- sa$activation.x[1:6]
                other_traj_activations <- sa$activation.y[2:7]
                the_diffs <- other_traj_activations - seed_activations
                return(the_diffs)
            }) %>% dcrb

        add_trailing_0 <- function(v) c(v,0)
        abs_per_txn <- apply(diffsets,2, function(v) max(abs(v))) %>% add_trailing_0 %>% as.numeric
        res <- data.table(max_abs_dot = abs_per_txn, transition_index=task_transition_idx())
        return(res)
}
task_transition_idx <- function() {c("t0_t1",
                            "t1_t2",
                            "t2_t3",
                            "t3_t4",
                            "t4_t5",
                            "t5_t6", "end_padding")}

run_step_speed_distributions_plot <- function(spatiotemporal_evaluations){
    library(data.table)
    points <- rbindlist(spatiotemporal_evaluations)
    velocities <- as.numeric(points$velocity_limit)
    sorted_speed_levels <- sort(unique(velocities), decreasing=TRUE)
    points[,velocity_limit:= factor(points$velocity_limit, levels=sorted_speed_levels)]
    points_with_dot <- points[,.( task_index, activation, transition_index=task_transition_idx(), dot = as.numeric(c(diff(activation),0))), by=.(muscle_trajectory, muscle, velocity_limit)]

    # within a given muscle trajectory, describe the norm of the transition from moment to moment
    within <- points_with_dot[transition_index!="end_padding",.(max_abs_dot = max(abs(dot))), by=.(muscle_trajectory,velocity_limit,transition_index)]

    #across analyses from the seed trajectory (a view from the 'transect', which is the predefined trajectory of the first har point sampled)
    seed_0 <- points[velocity_limit==1.0 & muscle_trajectory==1, .(muscle,task_index,activation)]
    message('computing deltas dataframe')
    across <- points[muscle_trajectory!=1, get_deltas_dt(seed_0, .SD), by=.(velocity_limit, muscle_trajectory)]
    setcolorder(across, colnames(within))
    across[,source:="across"]
    within[,source:="within"]
    within_and_across_within <- rbindlist(list(within, across))

    p4 <- ggplot(within_and_across_within[transition_index!="end_padding"], aes(max_abs_dot, fill=as.factor(source), group=as.factor(source)))
    p4 <- p4 + geom_histogram(aes(y=..ncount..),bins=100, alpha=0.7,position="identity")
    p4 <- p4 + facet_grid(velocity_limit~transition_index, scales = "free", space="free")
    p4 <- p4 + theme_classic() + xlab("maximum absolute delta observed within a given transition, \n where all operations are performed from id=1 (red) within each single activation trajectory and \n id=2(blue) across, with a single seed point across all of the other trajectories.")
    p4 <- p4 + ylab("number of transitions") + theme_bw()
    p4 <- p4 + labs(caption = "degenerate case is where the velocity constraint is set to 1. \n Rows as you go down are increasingly stringent velocity constraints, \n down to 0.05, indicating no change can be greater than 5% activation change per 50ms transition.")
    p4 <- p4 + ggtitle("Max(abs(a_i+1 - a_i)) maximum value that still meets lipschitz constraints")

    ggsave("redirection_figures/within_vs_across_transition_distributions.pdf", p4, height=20)
    message('done with redirection_figures/within_vs_across_transition_distributions.pdf')
 }
runplots <- function(spatiotemporal_evaluations){
    # boxplots figure
    library(data.table)
    points <- rbindlist(spatiotemporal_evaluations)
    points <- data.table(points)
    velocities <- as.numeric(points$velocity_limit)
    sorted_speed_levels <- sort(unique(velocities), decreasing=TRUE)
    # as we decrease the max abs velocity from 1 towards 0, the difficulty increases.
    points$velocity_limit <- factor(velocities, levels=sorted_speed_levels)
    points <- data.table(points)
    library(data.table)
    variance_p <- ggplot(points[,var(activation),by=.(muscle,task_index,velocity_limit)],
        aes(task_index,V1,col=velocity_limit,group=velocity_limit))
    variance_p <- variance_p + geom_path(size=1.5) + facet_grid(~factor(muscle, levels=c("FDP" ,"FDS" ,"EIP" ,"EDC" ,"LUM" ,"DI" , "PI"))) + theme_classic()
    variance_p <- variance_p + xlab("Time") + ylab("Variance of the FAS")
    ggsave("redirection_figures/variance_per_task_per_vel.pdf",variance_p)

    boxplots_plot <- ggplot(points,aes(task_index,activation,fill=velocity_limit, group=task_index)) + geom_boxplot(outlier.shape=19,outlier.size=0.2) + facet_grid(velocity_limit~factor(muscle, levels=c("FDP" ,"FDS" ,"EIP" ,"EDC" ,"LUM" ,"DI" , "PI"))) + theme_classic() + xlab("Time") + ylab("Muscle Activation")
    ggsave("redirection_figures/boxplots_by_vel.pdf", boxplots_plot, width=10)

    distributions_per_task_per_muscle_per_st <- ggplot(points,aes(y=activation, col=velocity_limit)) + geom_histogram(bins=50) + facet_grid(velocity_limit~muscle+task_index, scales="free", space="free") + theme_classic()
    ggsave("redirection_figures/distributions_per_task_per_muscle_per_st.pdf", distributions_per_task_per_muscle_per_st)

    diffs <- points[,max(abs(diff(activation))),by=.(muscle_trajectory, muscle,velocity_limit)]
    diffs$velocity_limit <- factor(diffs$velocity_limit,levels=sorted_speed_levels)
    speed_dists <- ggplot(diffs, aes(V1, col=velocity_limit)) + geom_histogram(bins=100) + facet_grid(velocity_limit~factor(muscle, levels=c("FDP" ,"FDS" ,"EIP" ,"EDC" ,"LUM" ,"DI" , "PI")), scales="free_y") + theme_classic()
    ggsave("redirection_figures/speed_distributions_by_vel_const.pdf", speed_dists)

    dotdot <- points[,abs(diff(diff(activation))),by=.(muscle_trajectory, muscle,velocity_limit)]
    dotdot$velocity_limit <- factor(dotdot$velocity_limit,levels=sorted_speed_levels)
    dot_dot_p <- ggplot(dotdot, aes(V1, col=velocity_limit)) + geom_histogram(bins=100) + facet_grid(velocity_limit~factor(muscle, levels=c("FDP" ,"FDS" ,"EIP" ,"EDC" ,"LUM" ,"DI" , "PI")), scales="free_y") + theme_classic()
    ggsave("redirection_figures/dot_dot_dist.pdf", dot_dot_p)

    summ_stats <- diffs[,.(min=min(V1),median=median(V1),mean=mean(V1),max=max(V1)), by=.(muscle,velocity_limit)]
    setorder(summ_stats,"muscle", "velocity_limit")
    summ_stats$velocity_limit <- factor(summ_stats$velocity_limit,levels=sorted_speed_levels)
    summary_stats_p <- ggplot(melt(summ_stats, id.vars=c("muscle","velocity_limit")), aes(velocity_limit, value, group=muscle, col=factor(muscle, levels=c("FDP" ,"FDS" ,"EIP" ,"EDC" ,"LUM" ,"DI" , "PI")))) + geom_path() + facet_grid(~variable) + theme_classic()
    browser()
    pp2 <- ggplot(diffs,aes(velocity_limit, y=V1,fill=velocity_limit)) + geom_boxplot(outlier.size=0.2) + facet_grid(~factor(muscle, levels=c("FDP" ,"FDS" ,"EIP" ,"EDC" ,"LUM" ,"DI" , "PI"))) + theme_classic()
    pp2 <- pp2 + ylab("Trajectory speeds recorded")
    ggsave("redirection_figures/per_muscle_changes_in_fas_by_vel_constraint.pdf", pp2, width=8)
}


library(zoo)

# Load the CSV Data (containing time, ping, download/upload)
dat <- read.table("speedtest.csv", sep="\t", header=T)

# Order the data by date
temp <- zoo(x = dat, order.by = dat[,1])

# Create the rolling mean value with w=10 for the down-/upload
ma <- rollmean(temp, k=10, align="right")

# Plot the data
#plot(temp, screens=1, type="l", lwd=c(1,1),col=c("red2", "blue"), xlab="", ylab="MBit/s",
#     main="UPC internet speed")
#legend('topright', names(temp),lty=1, col=c(red2", "blue"))

# Calculate the Downtime Percentage
# Calculate the mean, lowest, highest ping/down-/upload


#' Performs scaling of functional or phylogenetic structure of simulated community.
#'
#' @param com A list, returned by evolve_com.
#' @param grain_size A number, size of community data matrix.
#' @param use_tr If True, uses trait distances, else uses phylogenetic distances.
#' @param abundance_weighted Boolean, indicates, if abundances should be weighted.
#' @param scaling_iter A number of iterations.
#' @param be_verbose Boolean, returns messages during the execution.
#'
#' @return A list, result of scaling.
#' @export
#'
#' @examples
#' com_scaling(com, grain_size = 8, use_tr = T, abundance_weighted = T, scaling_iter = 100, be_verbose = T)

com_scaling <- function(com, grain_size = 8, use_tr = T, abundance_weighted = T, scaling_iter = 100, be_verbose = T){

  phylo <- com$phylo
  com <- com[-16]

  cda <- make_cda(com$id, grain_size)
  if (use_tr){
    dist <- as.matrix(dist(com$niche))
  } else {
    dist <- cophenetic(phylo)
  }

  if (be_verbose){
    print('Perfoming scaling.')
    print(system.time(resG <- scaling_grain(com$id, dist, abundance_weighted, scaling_iter)))
    print(system.time(resP <- scaling_pool(cda, dist, abundance_weighted, scaling_iter)))
    print(system.time(resC <- scaling_coherent(cda, dist, abundance_weighted, scaling_iter)))
  } else {
    resG <- scaling_grain(com$id, dist, abundance_weighted, scaling_iter)
    resP <- scaling_pool(cda, dist, abundance_weighted, scaling_iter)
    resC <- scaling_coherent(cda, dist, abundance_weighted, scaling_iter)
  }

  res <- list(resG = numeric(), resP = numeric(), resC = numeric())

  res$resG <- data.frame(r = resG[, 1], ses = resG[, 2])
  res$resP <- data.frame(r = 1:max(resP[, 1]), ses = tapply(resP[, 5], resP[, 1], mean, na.rm = T))
  res$resC <- data.frame(r = 0:max(resC[, 1]), ses = tapply(resC[, 5], resC[, 1], mean, na.rm = T))

  return(res)

}


require(ggplot2)

df <- read.csv("results/data.csv", header=TRUE, sep=",")

p <- ggplot(
        data        = df,
        position    = "dodge",
        aes(
            x   = reorder(name, -median),
            y   = median,
            fill = accuracy)) +
    geom_bar(
        stat        = "identity",
        color       = "black",
        position    = "dodge") +
    geom_text(aes(
                x       = reorder(name, -median),
                y       = median + 0.3 * sign(median),
                label   = format(df$median, digits=2)),
                hjust   = -0.13,
                size    = 3) +
    coord_flip() +
    scale_fill_gradient(
        low     = "tomato1",
        high    = "dodgerblue",
        guide   = guide_legend(
                    title           = "Accuracy (%)",
                    title.position  = "right",
                    title.hjust     = 0.5,
                    title.theme     = element_text(
                                        size = 10,
                                        angle = -90),
                    label.position  = "left",
                    label.hjust     = -5)) +
    labs(
        title       = "Speed comparison of various porgramming languages",
        subtitle    = "Method: calculating π through the Leibniz formula x times",
        caption     = "https://github.com/ducla5/speed-comparison",
        x           = "Languages",
        y           = "Median time (ms)") +
    theme(
        plot.title          = element_text(hjust = 0.5),
        plot.subtitle       = element_text(hjust = 0.5),
        plot.caption        = element_text(hjust = 1.18),
        panel.background    = element_blank(),
        panel.grid.minor    = element_blank(),
        axis.ticks          = element_blank(),
        axis.line           = element_line(colour=NA))

ggsave("results/plot.png", width=10, height = 7)


## This script uses the output of the QC.r & methylationDerivedVariables.r scripts to perform the primary analysis of a genome-wide analysis to identify dna methylation sites associated with ASD status.
## Filepaths and sample IDs have been removed for security reasons, therfore it serves as a guide to the analysis

uniqueAnno<-function(row){
if(row != ""){
	return(paste(unique(unlist(strsplit(row, "\\;"))), collapse = ";"))
	} else {
	return(row)
	}
	}

library(qqman)

setwd("")
load("QCed_Data.rda")

crosshyb<-read.csv("CrossHybridisingProbesPriceORWeksberg.csv", row.names = 1)
probes<-read.csv("SNPsinProbesAnno.csv", row.names = 1)

## remove cross hybridising probes
remove<-match(crosshyb[,1], rownames(betas))
remove<-remove[which(is.na(remove) != TRUE)]
betas<-betas[-remove,]
## remove SNP probes
probes<-probes[row.names(betas),]
betas<-betas[which(probes$Weksburg_CommonSNP_Af_within10bpSBE == "" | probes$Illumina_CommonSNP_Af_within10bpSBE == ""),]
betas<-betas[-grep("rs", rownames(betas)),]

## load cellular composition variables
counts<-read.csv("Analysis/HousemanEstimatedCellCounts.csv", stringsAsFactors = FALSE, row.names = 1)
counts<-counts[match(colnames(betas) ,rownames(counts)),]

### alternatively use smokingScores
scores<-read.csv("Analysis/QC/SmokingScores.csv", stringsAsFactors = FALSE, row.names = 1)
scores<-scores[match(colnames(betas), scores$Basename),]

pheno<-read.csv("", stringsAsFactors = FALSE)
### needs reformating
pheno.cont<-pheno[,c(22,18,grep("cont", colnames(pheno)))]
pheno.case<-pheno[,c(21,18,grep("case", colnames(pheno)))]
pheno.cont<-cbind(pheno.cont, "Con")
pheno.case<-cbind(pheno.case, "Case")
colnames(pheno.cont)<-gsub("_cont", "", colnames(pheno.cont))
colnames(pheno.case)<-gsub("_case", "", colnames(pheno.case))
colnames(pheno.cont)[1]<-"participiant_id"
colnames(pheno.case)[1]<-"participiant_id"
colnames(pheno.cont)[13]<-"CasCon"
colnames(pheno.case)[13]<-"CasCon"
pheno<-rbind(pheno.cont,pheno.case)
pheno$participiant_id<-gsub("MMXII_iPSYCH_", "", pheno$participiant_id)
pheno<-pheno[(match(sampleSheet$Sample_Name, pheno$participiant_id)),]

birthMonth<-unlist(strsplit(pheno$fdato, "/"))[seq(from = 2, by = 3, to = 3*nrow(pheno))]
birthMonth<-factor(birthMonth)
birthYear<-unlist(strsplit(pheno$fdato, "/"))[seq(from = 3, by = 3, to = 3*nrow(pheno))]
birthYear<-factor(birthYear)

res<-matrix(data = NA, nrow = nrow(betas), ncol = 3)
colnames(res)<-c("P-value", "MeanDiff", "SE")
for(i in 1:nrow(betas)){

	model<-lm(betas[i,] ~ as.factor(sampleSheet$CaCo) + as.factor(sampleSheet$gender.x.chr) + as.factor(sampleSheet$Sentrix_ID) + counts[,1] + counts[,2] + counts[,3] + counts[,4] + counts[,5] + counts[,6] + scores$scores_combined_A + birthMonth + birthYear + as.factor(pheno$geo5) + pheno$gest_week)
	res[i,]<-summary(model)$coefficients["as.factor(sampleSheet$CaCo)Ctrl", c(4,1,2)]
}

### as effects are increases in controls, multiple by -1
res[,2]<-res[,2]*-1

library(IlluminaHumanMethylation450kanno.ilmn12.hg19)
data(IlluminaHumanMethylation450kanno.ilmn12.hg19)
probeAnnot<-as.data.frame(IlluminaHumanMethylation450kanno.ilmn12.hg19@data$Locations)
probeAnnot<-probeAnnot[rownames(betas),]
res<-cbind(res, probeAnnot)
probeAnnot<-as.data.frame(IlluminaHumanMethylation450kanno.ilmn12.hg19@data$Other)
probeAnnot<-probeAnnot[rownames(betas),]
res<-cbind(res, probeAnnot)

res<-res[order(res[,1]),]

write.csv(res, "Analysis/CaseControl_Sex_Batch_HousemanCellComp_SmokingScore_BY_BM_GA_Urbanicity.csv")

pdf("Analysis/TopProbes_AUT_EWAS_HousemanCellComp_GA_Urbanicity.pdf", height = 6, width = 12)
par(mfrow = c(2,5))
par(mar = c(4.5,4.5,5,0.2))
for(i in 1:10){
	model<-lm(betas[rownames(res)[i],] ~ as.factor(sampleSheet$CaCo) + as.factor(sampleSheet$gender.x.chr) + as.factor(sampleSheet$Sentrix_ID) + counts[,1] + counts[,2] + counts[,3] + counts[,4] + counts[,5] + counts[,6] + scores$scores_combined_A + birthMonth + birthYear + as.factor(pheno$geo5) + pheno$gest_week)
	data.points<-(residuals(model)+coef(model)[2]*c(0,1)[as.factor(sampleSheet$CaCo)] + coef(model)[1])*100
	boxplot(data.points ~ as.factor(sampleSheet$CaCo), ylab = "DNA methylation (%)", main = paste(rownames(res)[i], "\n", uniqueAnno(res$UCSC_RefGene_Name[i]), sep = ""), col = c(rgb(1,0,0,0.25), rgb(0,1,0,0.25)), cex.axis = 1.5, cex.lab = 1.5, cex.main = 1.5)
	title(main = paste("p = ", signif(res[i,"P.value"],3), sep = ""), line = 0, adj = 1)
}
dev.off()

res.all<-res.all[which(res.all$chr != "Y")]
res.all$chr<-gsub("chr", "", res.all$chr)
res.all$chr[which(res.all$chr == "X")]<-23
res.all$chr<-as.numeric(res.all$chr)
par(mar = c(5,5,2,1))
manhattan(res.all, p = "P.value", chr = "chr", bp = "pos", suggestiveline = -log10(5e-5), genomewideline = -log10(1e-7))


library(SignatureEstimation)
mut=read.delim('MUTCOUNTIN',sep=',',header=FALSE,check.names=FALSE) #C:\\Users\\tuf78332\\Desktop\\mutational-signature\\PhyloSig\\Example\\E.csv
colnames(mut) <- c('Type','Count')
Pro=mut$Count/sum(mut$Count)
mut0=cbind(mut,Pro)
row.names(mut0)=mut0$Type
signaturesCOSMIC=read.delim('SIGIN',sep=',')  #C:\\Users\\tuf78332\\Desktop\\mutational-signature\\PhyloSig\\PhyloSig1\\cosmicSig.csv
row.names(signaturesCOSMIC)=signaturesCOSMIC$X
drops <- c("X")
signaturesCOSMIC=signaturesCOSMIC[ , !(names(signaturesCOSMIC) %in% drops)]
order = match(row.names(mut0), row.names(signaturesCOSMIC))
signaturesCOSMIC=signaturesCOSMIC[,c('SIGLS')]
cancer_signatures = signaturesCOSMIC[order,]
cancer_signatures=data.matrix(cancer_signatures, rownames.force = NA)
mut1=data.frame(mut0$Pro)
QP=decomposeQP(mut1, cancer_signatures)
write.table(QP,'Expo.out')


# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

#' Calculate Kinship matrix by VanRaden method
#'
#' Build date: Dec 12, 2016
#' Last update: Dec 12, 2019
#'
#' @param M Genotype, m * n, m is marker size, n is population size
#' @param priority speed or memory
#' @param cpu the number of cpu
#' @param verbose whether to print detail.
#'
#' @return K, n * n matrix
#' @export
#'
#' @examples
#' genoPath <- system.file("extdata", "06_mvp-impute", "mvp.imp.geno.desc", package = "rMVP")
#' genotype <- attach.big.matrix(genoPath)
#' print(dim(genotype))
#'
#' K <- MVP.K.VanRaden(genotype)
#'
MVP.K.VanRaden <-
function(
    M,
    priority=c("speed", "memory"),
    cpu=1,
    verbose=TRUE
){
    # R.ver <- Sys.info()[['sysname']]
    # wind <- R.ver == 'Windows'
    # linux <- R.ver == 'Linux'
    # mac <- (!linux) & (!wind)
    r.open <- eval(parse(text = "!inherits(try(Revo.version,silent=TRUE),'try-error')"))

    # if(r.open && mac){
    #     Sys.setenv("VECLIB_MAXIMUM_THREADS" = "1")
    # }

    if (!is.big.matrix(M)) stop("Format of Genotype Data must be big.matrix")
    if(hasNA(M@address))   stop("NA is not allowed in genotype, use 'MVP.Data.impute' to impute.")

    # logging.log("Relationship matrix mode in", priority[1], "\n", verbose = verbose)
    # if(is.null(dim(M))) M <- t(as.matrix(M))
    switch(
        match.arg(priority),
        "speed" = {
            # if (!is.matrix(M)) M <- as.matrix(M)
            # n <- ncol(M)
            # m <- nrow(M)
            # Pi <- 0.5 * rowMeans(M)
            # logging.log("Scale the genotype matrix", "\n", verbose = verbose)
            # M <- M - 2 * Pi
            # SUM <- sum(Pi * (1 - Pi))
            # logging.log("Computing Z'Z", "\n", verbose = verbose)

            K <- try(kin_cal_s(M@address, threads = cpu, verbose = verbose, mkl = r.open), silent=TRUE)

            if(inherits(K,"try-error")){
                logging.log("Out of memory, please set parameter (..., priority='memory') and try again.", "\n", verbose = verbose)
                stop(K[[1]])
            }
        },

        "memory" = {
            K <- kin_cal_m(M@address, threads=cpu, verbose = verbose)
            # n <- ncol(M)
            # m <- nrow(M)
            # bac <- paste0("Z", memo, ".temp.bin")
            # des <- paste0("Z", memo, ".temp.desc")
            # if (file.exists(bac)) file.remove(bac)
            # if (file.exists(des)) file.remove(des)
            # #options(bigmemory.typecast.warning=FALSE)
            # Z <- big.matrix(
            #     nrow = m,
            #     ncol = n,
            #     type = "double",
            #     backingfile = bac,
            #     descriptorfile = des,
            #     init = 0.1
            # )
            # Pi <- NULL
            # estimate.memory <- function(dat, integer=FALSE, raw=FALSE){
            #     cells.per.gb <- 2^27  # size of double() resulting in ~1GB of memory use by R 2.15
            #     dimz <- dat
            #     if(length(dimz) == 1) { dimz[2] <- 1 }
            #     if(length(dimz)>1 & length(dimz)<11 & is.numeric(dimz)) {
            #         total.size <- as.double(1)
            #         for(cc in 1:length(dimz)) { total.size <- as.double(total.size * as.double(dimz[cc])) }
            #         memory.estimate <- as.double(as.double(total.size)/cells.per.gb)
            #         memory.estimate <- memory.estimate
            #         if(integer) { memory.estimate <- memory.estimate/2 } else { if(raw) { memory.estimate <- memory.estimate/8 } }
            #         return(memory.estimate)
            #     } else {
            #         # guessing this is a vector
            #         if(!is.list(dimz) & is.vector(dimz)) {
            #             LL <- length(dimz)
            #             return(estimate.memory(LL, integer=integer, raw=raw))
            #         } else {
            #             warning("tried to estimate memory for object which is neither a vector, pair of dimension sizes or a dataframe/matrix")
            #         }
            #     }
            # }
            # if((Sys.info()[['sysname']]) == 'Windows'){
            #     max.gb <- memory.limit()/1000
            # }else{
            #     max.gb <- Inf
            # }
            # maxLines.gb <- estimate.memory(c(maxLine, n))
            # if(maxLines.gb > max.gb) stop("Memory limited! Please reset the 'maxLine'")
            # loop.index <- seq(0, m, maxLine)[-1]
            # if(max(loop.index) < m) loop.index <- c(loop.index, m)
            # loop.len <- length(loop.index)
            # print("Z assignment...")
            # for(cc in 1:loop.len){
            #     if(loop.len == 1){
            #         c1 <- 1
            #     }else{
            #         c1 <- ifelse(cc == loop.len, (loop.index[cc-1]) + 1, loop.index[cc]-maxLine + 1)
            #     }
            #     c2 <- loop.index[cc]
            #     means <-rowMeans(M[c1:c2, 1:n])
            #     if(!is.null(weight)){
            #         Z[c1:c2, 1:n] <- (M[c1:c2, 1:n]-means) * sqrt(weight[c1:c2])
            #     }else{
            #         Z[c1:c2, 1:n] <- M[c1:c2, 1:n]-means
            #     }
            #     Pi <- c(Pi, 0.5 * means);gc()
            # }
            # print("Assignment DONE!")
            # if(is.null(SUM)){
            #     SUM <- sum(Pi * (1-Pi))
            # }
            # fl.suc <- flush(Z)
            # if(!fl.suc){ stop("flush failed\n") }
            # RR <- describe(Z); rm(list=c("Z", "Pi", "means")); gc()
            # Z <- attach.big.matrix(RR)
            # print("Computing Z'Z in big.matrix...")
            # K <- 0.5 * big.crossprod(Z)/SUM
            # rm(Z)
            # gc()
            # unlink(c(paste0("Z", memo, ".temp.bin"), paste0("Z", memo, ".temp.desc")), recursive = TRUE)
        }
    )
    #print("K Preparation is Done!")
    logging.log("Deriving relationship matrix successfully", "\n", verbose = verbose); gc()
    return(K)
}#end of MVP.k.VanRaden function


#  James Rekow

densDiffMultiPlot = function(M = 80, N = 20, iStrength = 1, univ = 1, sigmaMax = 0.1,
                             thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4, tStep = 10 ^ (-2),
                             intTime = 1, interSmplMult = 0.01, lambda = 10 ^ (-1),
                             conGraph = NULL, graphType = "gnp", meanDegree = 4,
                             synthM = floor(M / 4), numSynthChrt = 10, numSample = 100,
                             maxIters = 100){

  #  ARGS: conGraph - supplied connectivity graph
  #        graphMethod - method to use to create conGraph if one is not supplied
  #        graphArgs - arguments to pass to the graphMethod
  #        synthM - number of samples in each synthetic cohort
  #        numSynthChrt - number of synthetic cohorts (there will be this many of both the
  #                       interacting and non-interacting cohorts)
  #
  #  RETURNS: a figure containing 9 plots. Each plot is the difference between the 2D density
  #           of the aggregate OD NS points of the interacting synthetic cohorts and the
  #           non-interacting synthetic cohorts. Each plot uses a different base cohort.
  #
  #  NOTE: Steps in construction of each density difference plot: first, a base cohort is created
  #        with synthM interacting samples and M - synthM non-interacting samples. Next, conGraph
  #        is created (if not supplied). Then the edge list of conGraph is used to determine which
  #        pairs of samples can interact during the intra-cohort interaction step. conGraph should
  #        have no loops or multiple edges. The samples in the base cohort are then integrated and
  #        interacted as usual (using the edge list from con graph to determine possible interactions).
  #        Next, numSynthChrt interacting synthetic cohorts are created. Each one is created by
  #        randomly selecting synthM interacting samples from the base cohort. For each synthetic
  #        cohort the points in the NS region of the OD plane are selected and stored in a data
  #        frame along with the points from all of the other interacting synthetic cohorts. The same
  #        is done for the non-interacting synthetic cohorts. Then the 2D density of the aggregate
  #        OD NS points (the collection of points from all of the synthetic cohorts) is computed
  #        for the interacting and non-interacting aggregates. The density of the non-interacting
  #        aggregate is subtracted from the density of the interacting aggregate, and this density
  #        difference is plotted. Regions where the density difference is negative (non-interacting
  #        aggregate has a higher density than interacting aggregate) are colored blue, and regions
  #        where the density difference is positive (interacting aggregate has a higher density than
  #        non-interacting aggregate) are colored red.

  #  import libraries
  library(gridExtra)
  library(grid)
  library(snow)
  library(parallel)

  #  function used to produce the ggplot object for one density difference plot
  producePlot = function(x = NULL){
    source("conChrtDensDiffPlotObj.r")
    return(
      conChrtDensDiffPlotObj(M = M, N = N, iStrength = iStrength, univ = univ, sigmaMax = sigmaMax,
                             thresholdMult = thresholdMult, maxSteps = maxSteps, tStep = tStep,
                             intTime = intTime, interSmplMult = interSmplMult, lambda = lambda,
                             conGraph = conGraph, graphType = graphType, meanDegree = meanDegree,
                             synthM = synthM, numSynthChrt = numSynthChrt, numSample = numSample,
                             maxIters = maxIters)
    ) #  end return
  } #  end producePlot function

  #  preallocate list to store plot objects
  pList = vector("list", 9)

  #  create 9 plot objects, printing the number created so far
  for(ii in 1:9){

    pList[[ii]] = producePlot()
    print(ii)

  } #  end for loop

  # #  make clusters to compute in parallel
  # cl = makeCluster(8, type = "SOCK")
  #
  # #  export function to each cluster
  # clusterExport(cl = cl, list = list("producePlot", "conGraph"), envir = environment())
  #
  # #  produce an aggregate doc for non-interacting and interacting synthetic cohorts
  # pList = parLapply(cl, as.list(1:9), producePlot)
  #
  # #  remove the clusters and close connections
  # stopCluster(cl)

  ##  create text for graph arguments
  graphArgsText = NULL

  if(is.null(conGraph)){
    graphArgsText = paste("graphType = ", graphType, "meanDegree = ", meanDegree)
  } # end if

  if(!is.null(conGraph)){
    graphArgsText = "conGraph: custom"
  } #  end if

  #  create title object
  main = textGrob(paste("Aggregate Synthetic Cohort Density Differences \n M = ", M, "N = ", N,
                        "synthM = ", synthM, "numSynthChrt = ", numSynthChrt, graphArgsText))

  #  create a new graphical device
  dev.new()

  #  arrange the 9 plots in a 3 x 3 grid, add title, and plot them
  grid.arrange(pList[[1]], pList[[2]], pList[[3]], pList[[4]], pList[[5]], pList[[6]], pList[[7]],
               pList[[8]], pList[[9]], nrow = 3, ncol = 3, top = main)

} #  end densDiffMultiPlot function


### Category mapping format
getGO <- function(de.genes=res2foldpadj$id){
  library(goseq)
  ### length data
  txdb <- loadDb("~/Documents/BDproj/cache/Bd192.sqlite")
  txsByGene <- transcriptsBy(txdb,"gene")
  lengthData <- median(width(txsByGene))
  assayed.genes <- names(eByg)

  gene.vector <- as.integer(assayed.genes %in% de.genes)
  names(gene.vector) <- assayed.genes

  ## GO file
  gos <- read.delim("~/DBcenter/BD_v1.0/annot_v1.2/brachy_V1.2_GOs_fromSIMAP.txt", header=FALSE)
  names(gos) <- c("txid", "GOterm", "function", "N")
  gosin <- nrow(gos)
  ## txid to geneid
  info <- read.delim("~/DBcenter/BD_v1.0/annot_v1.2/Bdistachyon_192_annotation_info.txt", header=F)
  names(info)[2:3] <- c("geneid", "txid")
  gos <- merge(info[,2:3], gos, by="txid" )
  message(sprintf("Input go terms/found geneid [ %s | %s ]", gosin, nrow(gos)))

  #Fitting the Probability Weighting Function (PWF)
  pwf <- nullp(gene.vector, bias.data=lengthData, plot.fit=TRUE)
  go <- goseq(pwf, gene2cat=gos[, 2:3], method="Wallenius")

  return(go)
}
#######