#~~~~~~~~~~~~~~~forecast.table~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Description: Function to create the forecast summary output
#                 table including dead & surviving discards
# Author: HD
# Date:   26/3/2014
#
#  Input parameters:
#
#   wk.dir        - working directory where the input .csv file is stored & where output
#                   file will be created
#
#   fu            - string giving the name of the FU - used to title the output file & also
#                   if north minch allows for different input format
#
#   hist.sum.table - .csv file with the following columns (column names must
#                           be identical):
#                  'year' - up to and including the most recent year of survey data
#                  'mean.wt.landings' - annual individual mean weight in the landings (g)
#                  'mean.wt.discards' - annual individual mean weight in the discards (g)
#                  'dead.discard.rate'- annual discard rate - dead discards as % of
#                     removals (dead discards + landings)
#                  'adjusted.abundance'- bias corrected survey abundance in millions
#                     (if fu=="north minch",function looks for column titled
#                     'adjusted.abundance.VMS').  The last value in this column is used
#                     in the forecast calculations.
#
#   land.wt.yrs, disc.wt.yrs, disc.rt.yrs - sequences of years over which the landings mean wt,
#                   discard mean wt & dead discard rate are averaged (not weighted average)
#
#   hr.rates     - array of harvest rates (%).  Should be named to provide the information in
#                 the basis column of the summary table
#
#   d.surv       - discard survival rate, defaults to 0.25.
#
# Notes:  function does some checks on the rates - are they % or decimal? Output in tonnes,
#         provided inputs are survey in millions & weights in g.  Rounds output to whole
#         tonnes.
#
# 01/05/2015
#  Corrected error with discard rate calculation (when the average of the last 3 years < 1% the
# discard percentage was multiplied by 100. eg Fladen_discard_12-14=0.6% -----> old output was 60%
#

forecast.table.2014<- function(wk.dir, fu, hist.sum.table, land.wt.yrs, disc.wt.yrs, disc.rt.yrs,
                          h.rates, d.surv =0.25)
{

  setwd(wk.dir)
  expl.dat<- read.csv(hist.sum.table)

# Calculate mean weights
  land.mean.wt <-mean(expl.dat$mean.wt.landings[expl.dat$year %in% land.wt.yrs],na.rm=T)
  disc.mean.wt <-mean(expl.dat$mean.wt.discards[expl.dat$year %in% disc.wt.yrs],na.rm=T)

# Dead discard mean rate
  dead.disc.mean.rate <-mean(expl.dat$dead.discard.rate[expl.dat$year %in% disc.rt.yrs])
  if(dead.disc.mean.rate>1){
    dead.disc.mean.rate <-dead.disc.mean.rate/100
  } else{
		dead.disc.mean.rate <-round(dead.disc.mean.rate/100,3)
  }

#
  surv.abundance <-expl.dat$adjusted.abundance[length(expl.dat$adjusted.abundance)]
  if(fu == "north minch"){
    surv.abundance <-expl.dat$adjusted.abundance.VMS[length(expl.dat$adjusted.abundance.VMS)]
  }

#
  if(!is.null(names(h.rates))){
    summary.output <-data.frame(Basis=names(h.rates))
  }else{
    summary.output <-data.frame(Basis=rep("",length(h.rates)))
  }

  summary.output$harvest.rate <-unname(h.rates)
  if(summary.output$harvest.rate[1]>1){
    hrs <-summary.output$harvest.rate/100
  }

  if(d.surv>1){d.surv <-d.surv/100}

  summary.output$landings.tonnes <-round(hrs*surv.abundance*(1-dead.disc.mean.rate)*land.mean.wt)
  summary.output$dead.discards.tonnes <-round(hrs*surv.abundance*dead.disc.mean.rate*disc.mean.wt)
  summary.output$surviving.discards.tonnes <-round(summary.output$dead.discards.tonnes/((1-d.surv)/d.surv))
  summary.output$total.catch.tonnes <-with(summary.output,landings.tonnes+dead.discards.tonnes+
                                                  surviving.discards.tonnes)
  summary.output$dead.removals.tonnes <-with(summary.output,landings.tonnes+dead.discards.tonnes)

  out.sum <-vector("list")
  out.sum$table <-summary.output[,c(1,6,7,3,4,5,2)]
  out.sum$table[,2:6]<-lapply(out.sum$table[,2:6],round,0)
  out.sum$input.txt <-rep("",5)

  out.sum$input.txt[1] <-paste("Bias corrected survey index (",expl.dat$year[length(expl.dat$year)],") = " ,surv.abundance,
               " million",sep="")
  out.sum$input.txt[2] <-paste("Mean weight in landings (",land.wt.yrs[1],"-",land.wt.yrs[length(land.wt.yrs)],") = ",
                         round(land.mean.wt,2)," g",sep="")
  out.sum$input.txt[3] <-paste("Mean weight in discards (",disc.wt.yrs[1],"-",disc.wt.yrs[length(land.wt.yrs)],") = ",
                         round(disc.mean.wt,2)," g",sep="")
  out.sum$input.txt[4] <-paste("Dead discard rate by number (",disc.rt.yrs[1],"-",disc.rt.yrs[length(disc.rt.yrs)],
                         ") = ",round(100*dead.disc.mean.rate,1)," %",sep="" )
  out.sum$input.txt[5] <-paste("Discard survival rate = ",round(d.surv*100,0)," %",sep="")

  write.csv(out.sum$table,paste(fu,"_summary_table.csv",sep=""),row.names=FALSE)
  for (l in 1:length(out.sum$input.txt)){
    cat("\n",out.sum$input.txt[l],file=paste(fu,"_summary_table.csv",sep=""), append=TRUE)
  }

}


#' #This source code is provided under the BSD license and is provided AS IS with no warranty or guarantee of fit for purpose.  See the project's LICENSE.txt for details.
#' #Copyright Thomson Reuters 2013. All rights reserved.
#' @param dates dates for which dividends are needed
#' @param seccodes seccodes for which divs are needed
#' @author Sameena Shah
#' @return matrix
#' @import sqldf
#' @export
get.dividends  <- 	function(dates,seccodes){
	dividends 			<- 	matrix(NA, length(dates),length(seccodes))
	colnames(dividends)	<- 	paste(seccodes)
	rownames(dividends) 	<- 	paste(dates)

	conn <- get.qad.connection()
	query 		<-  	sprintf("SELECT seccode,DivRate,EffectiveDate FROM qai.dbo.DS2DIV D JOIN qai.dbo.DS2CTRYQTINFO I ON D.INFOCODE=I.INFOCODE JOIN qai.dbo.DS2XREF X ON X.CODE=D.DIVTYPECODE AND X.TYPE_=8 join qai.dbo.secmap p on p.vencode=I.infocode and ventype=34 WHERE EffectiveDate between '%s' and SYSDATETIME() order by seccode,EffectiveDate desc",dates[1])
	data			<- 	sqlQuery(conn,query)

	for(i in paste(dates)){
		elig 		<- 	data[as.Date(data[,'EffectiveDate']) > i,]
		if(dim(elig)[1]){
			td		<- 	sqldf("SELECT seccode, SUM(divrate) FROM elig GROUP BY seccode")
			rownames(td)<- 	td[,1]
			seccodes.comm 	<-	intersect(seccodes,rownames(td))
			td.comm	<-	td[paste(seccodes.comm),]
			dividends[paste(i),paste(td.comm[,1])] <- td.comm[,2]
		}
	}

	return(dividends)
}


#=============Function======================================
pr.OHLC<- function(0, h, l, cl) {

	  #combine quotes matrix. Quotes pre-reversing
	  price <- cbind(Open = rev(o), High = rev(h), Low = rev(l), Close = rev(cl));
	  Med <- (price[, 2] + price[, 3)/2;
	  CO <- price[,4] - price[, 1];
	  #add the matrix Med and CO
	  price<- cbind(price, Med, CO);

}

In <- function(p = 16) {

   require(TTR)
   require(dplyr)
   require(magrittr)

   adx <- ADX(price, n=p) %>% as.data.frame %>%
   mutate(., oscDX = DIp - DIn) %>%
   transmutate(., DX, ADX, oscDX) %>%
   as.matrix()
   ar <- aroon(price[,c('High', 'Low')], n=p) %>%
   extract(,3)
   atr <- ATR(price, n=p, maType = "EMA") %>%
   extract(, 1:2)
   cci <- CCI(price[ ,2:4], n=p)
   chv <- chaikinVolatility(price[ ,2:4], n=p)
   cmo <- CMO(price[ ,'Med'], n=p)
   macd <- MACD(price[ ,'Med'], 12, 26, 9) %>%
   as.data.frame() %>%
   mutate(., vsig = signal %>%
   	     diff %>% c(NA, .) %>% multiply_by((10)) %>%

   transmute(., sign = signal, vsig) %>%
	     as.matrix()
   rsi <- RSI(price[, 'Med'], n=p)
   stoh <- stoch(price[, 2:4], nFastK = p,
   	   	 nFastD = 3, nSlowD = 3,
		 maType = "EMA") %>%
		 as.data.frame() %>%
		 mutate(., oscK = fastK - fastD) %>%
		 transmute(., slowD, oscK) %>%
		 as.matrix()
    smi <- SMI(price[ ,2:4],n = p, nFast = 2,
             nSlow = 25, nSig = 9)
    kst <- KST(price[ ,4])%>% as.data.frame() %>%
				mutate(., oscKST = kst - signal) %>%
				select(.,oscKST) %>% as.matrix()
  In <- cbind(adx, ar, atr, cci, chv, cmo, macd,
              rsi, stoh, smi, kst)
  return(In)

}

ZZ <- function(pr = price, ch = ch , mode="m") {
  require(TTR)
  require(magrittr)
  if (ch > 1) ch <- ch/(10 ^ (Dig - 1))
  if (mode == "m") {pr <- pr[ ,'Med']}
  if (mode == "hl") {pr <- pr[ ,c("High", "Low")]}
  if (mode == "cl") {pr <- pr[ ,c("Close")]}
  zz <- ZigZag(pr, change = ch, percent = F,
               retrace = F, lastExtreme = T)
  n <- 1:length(zz)
  dz <- zz %>% diff %>% c(., NA)
  sig <- sign(dz)
  for (i in n) { if (is.na(zz[i])) zz[i] = zz[i - 1]}
  return(cbind(zz, sig))
}

form.data <- function( n = 16, z = 37, len = 500) {
	require(magrittr)
	x <- In( p =n)
	out <- ZZ(ch = z, mode = "m")
	data <- cbind(x, y = out[, 2]) %>%
	as.data.frame %>% head(., (nrow(x)-len))%>%
	na.omit😂
	data$y <- as.factor(data$y)
	return(data)
}

cleaning <- function(n = 16, z= 25, cut = 0.9 ){
	data <- form.data(n,z)
	descCor <- cor(data[ ,-ncol(data)])
	#summary(descCor[upper.tri(descCor)])
	highCor <- caret::findCorrelation(descCor, cutoff = cut)
	data <- data[ , -highCor]
	return(data)
}

prepareBest <- function(n, z, cut, norm, meth) {
	require(randomUniformForest)
	data.f <<- cleaning(n = n, z=z, cut =cut)
	idx <- rminer::holdout(y = data.f$y)
	x.train <- data.f[idx$tr, -ncol(data.f)]
	x.test <-  data.f[idx$ts, -ncol(data.f)]
  	y.train <- data.f[idx$tr, ncol(data.f)]
  	y.test <- data.f[idx$ts, ncol(data.f)]
 	if(norm){
    prep <- caret::preProcess(x = x.train, method = meth)
    #c("center", "scale","spatialSign"), "range"
    x.train <- predict(prep, x.train)
    x.test <- predict(prep, x.test)

}

ruf <- randomUniformForest(X = x.train,
						   Y = y.train,
						   xtest = x.test,
						   ytest = y.test,
						   mtry = 1, ntree = 300,
						   threads = 2,
						   nodesize = 1

)
imp.ruf <- importance(ruf, Xtest = x.test)
best <- imp.ruf$localVariableImportance$classVariableImportance %>%
head(., 10) %>% rownames()
return(best)
}

prepareTrain <- function(x , y,
                         rati, mod = "stratified",
                         balance = F,
                         norm, meth)
{
  require(magrittr)
  require(dplyr)
  t <- rminer::holdout(y = y, ratio = rati,
                       mode = mod)
  train <- cbind(x[t$tr, ], y = y[t$tr])
  if(balance){
    train <- caret::upSample(x = train[ ,best],
                             y = train$y,
                             list = F)%>% tbl_df
    train <- cbind(train[ ,best], select(train, y = Class))
  }
  test <- cbind(x[t$ts, ], y = y[t$ts])
  if (norm) {
    prepr <<- caret::preProcess(train[ ,best], method = meth)
    train = predict(prepr, train[ ,best])%>% cbind(., y = train$y)
    test =  predict(prepr, test[ ,best] %>% cbind(., y = test$y))
  }
  DT <- list(train = train,
             test = test)
  return(DT)
}

#----PreTraining---------------------------------------

pretrainDBN <- function(L, Bs, dS, nE, nCD, InM = 0.5, FinM = 0.9) {
	require(darch)
	#create object DArch
	dbn <- newDArch(layers = L, batchSize = Bs, logLevel = 5)
	#set initial moment
	setInitialMomentum(dbn) <- InM
	#set final moment
	setFinalMomentum(dbn) <- FinM
	#set time of switching moments from initial to final
	setMomentumSwitch(dbn) <- round(0.8 * nE)
	dbn <- preTrainDArch(dbn, dataSet = dS,
							numEpoch = nE,
							numCD = nCD,
							trainOutputLayer = T)

	return(dbn)

}

fineMod <- function(variant=1, dbnin, dS,
					hd = 0.5, id = 0.2,
                    act = c(2,1), nE = 10)
{
  setDropoutOneMaskPerEpoch(dbnin) <- FALSE
  setDropoutHiddenLayers(dbnin) <- hd
  setDropoutInputLayer(dbnin) <- id
  layers <<- getLayers(dbnin)
  stopifnot(length(layers)==length(act))
  if(variant < 0 || variant >2) {variant = 1}
  for(i in 1:length(layers)){
    fun <- actFun %>% extract2(act[i])
    layers[[i]][[2]] <- fun
  }
  setLayers(dbnin) <- layers
  if(variant == 1 || variant == 2){ # backpropagation
    if(variant == 2){# rpropagation
      #setDropoutHiddenLayers(dbnin) <- 0.0
      setFineTuneFunction(dbnin) <- rpropagation
    }
    mod = fineTuneDArch(darch = dbnin,
                        dataSet = dS,
                        numEpochs = nE,
                        bootstrap = T)
    return(mod)
  }
}

prepareTest<- function(n, z, norm, len =501)
{
	x <- In(p = n) %>% na.omit %>% extract( ,best) %>%
	tail(., len)
	CO <- price[, "CO"] %>% tail(., len)
	if (norm) {
		x <- predict(prepr, x)
	}
	dt <- cbind(x=x, CO= CO) %>% as.data.frame()
	return(dt)
}

testAcc <- function(obj, typ = "bin") {
	require(fTrading)
	x <- DT.test[, best]
	CO <- DT.test$CO
	out <- predict(obj, newdata = x, type = typ)
	if(soft) {out <- max.col(out) - 1} else {out %<>% as.vector()}
	acc <- length(y.ts[y.ts == out])/length(y.ts) %>%
	round(., digits = 4)
	return(list(Acc = acc, y.ts = y.ts, y = out))
}


 setClass("shapefile",representation(
	 dir="character",
	 layer="character",
	 proj_from="character",
	 proj_to="character"),
	 prototype=list(
		 proj_from="NA",
		 proj_to="NA"))

 setGeneric("polygonConvert",function(obj){
	 cat(class(obj)," is not available\n")})

setMethod("polygonConvert", signature(obj="shapefile"),
	function(obj){
		cat("read polygons:\n----\n")
		shape_file<-readOGR(obj@dir,obj@layer)
		if(obj@proj_from!="NA")
			projection(shape_file)<-obj@proj_from
		if(obj@proj_to!="NA"){
			cat("transform polygons projection:\n----\n")
			shape_file<-spTransform(shape_file,CRS(obj@proj_to))
		}

		dataframe<-fortify(shape_file)
		return(dataframe)
	})

 setGeneric("addLines",function(obj,gg,...){
	 cat(class(obj)," is not available\n")})

 setMethod("addLines", signature(obj="shapefile"),
	function(obj,gg,...){
		cat("add polygons\n====\n")
		dataframe<-polygonConvert(obj)
		g2<-gg+geom_path(data=dataframe,aes(long,lat,group=group),...)
		return(g2)

	})

 setGeneric("addPoly",function(obj,gg,...){
	 cat(class(obj)," is not available\n")})

 setMethod("addPoly", signature(obj="shapefile"),
	function(obj,gg,...){
		cat("add polygons\n====\n")
		dataframe<-polygonConvert(obj)
		g2<-gg+geom_polygon(data=dataframe,aes(long,lat,group=group),...)
		return(g2)

	})

getShpAttrib<-function(obj,slot=c("labpt","area"),att){
	if(!inherits(obj,"shapefile"))
		stop("obj has to be shapefile class.\n")
	shape_file<-readOGR(obj@dir,obj@layer)
	slots<-slotNames(shape_file@polygons[[1]])
	if(length(intersect(slots,slot))!=length(slot))
		stop("shape file does not contain all selected slots\n")

	sv<-list()
	for(i in 1:length(shape_file@polygons)){
		for(j in 1:length(slot)){
			sv[[slot[j]]]<-rbind(sv[[slot[j]]],slot(shape_file@polygons[[i]],slot[j]))

		}

	}
	for(i in att)
	sv[[i]]<-shape_file[[i]]

	return(as.data.frame(sv))
}


res  = 3

version="v2.4"
AR     = TRUE
draw   = FALSE
ndraws = 10
nknots = 120
one_time=FALSE
lambda_fixed = TRUE
bchron = FALSE

# stat model flags
decomp     = TRUE
bt         = TRUE
mpp        = TRUE
save_plots = TRUE

bacon = TRUE
# draw  = TRUE
add_varves = TRUE
constrain  = FALSE
# how far to extrapolate past last geochron anchor
nbeyond = 5000

age_model  = 'bacon'

suff_dat = '12taxa_mid_comp_ALL_v0.3'

run_pl_Ka_Kgamma = list(suff_fit  = 'cal_pl_Ka_Kgamma_EPs_ALL_v0.4c1',
                        suff_dat  = suff_dat,
                        kernel    = 'pl',
                        one_a     = FALSE,
                        one_b     = TRUE,
                        one_gamma = FALSE,
                        EPs       = TRUE)

runs = list(run_pl_Ka_Kgamma)

# for (run in runs){
  # for (res in grids){
#     if (draw){
#       for (dr in 1:ndraws){
#         source('r/pred_build_data.r')
#       }
#     }
  # }
# }

if (draw){
  for (dr in 1:ndraws){
    source('r/pred_build_data.r')
  }
} else {
  dr = 1
  source('r/pred_build_data.r')
}


library(ggplot2)
library(plyr)

dmaData = read.table("dmaReport.dat", header=TRUE, sep="\t")
dmaData$DMAsFactor =  as.factor(dmaData$DMAs)
dmaData$DATAKB =  dmaData$DATA / 1000

dmaValid = dmaData[dmaData$TIME>0, ]

#qplot(DATA, BW, data=dmaValid, color=DMAs, shape=, size=, alpha=, geom=, method=, formula=, facets=, xlim=, ylim= xlab=, ylab=, main=, sub=)
g = qplot(DATAKB, BW, data=dmaValid, color=DMAsFactor, xlab="Data Moved [KB]", ylab="BW [MB/s]")

g = g + theme_bw()
g = g + geom_point()
g = g + scale_x_continuous(trans = 'log10')
#g = g + stat_smooth(se=FALSE)
g = g + stat_summary(fun.y=mean, geom="line")
g = g + scale_colour_brewer(palette="Set1", labels=c("ARM", "1 DMA", "2 DMA", "3 DMA", "4 DMA"), name="")

ggsave("./dmaReport.pdf")

summarized = ddply(dmaValid,TYPE~DMAsFactor~DATA,summarise,mean=mean(BW))

summarized


##########
data =read.table("C:/Users/ADMIN/Desktop/imputation/bulk/FPKM.txt",header=T,row.names=1,sep="\t")
data <-data[rowSums(data) > 0,]
gen <-matrix(unlist(strsplit(rownames(data),"\\.")),2)[1,]
infer <-as.matrix(read.table("C:/Users/ADMIN/Desktop/imputation/bulk/fitter.GRCh38.93.gtf"))
infer <-infer[,c(1,6)]
gene <-NULL
for(i in 1:length(gen)){
index <-which(infer[,1]==gen[i])
gene <-c(gene,infer[index,2])
}
rs <-rowSums(data)
kid <- sapply(unique(gene),function(sid) {
            tmp <- which(gene==sid)
            if (length(tmp)==1) {
                  tmp
            } else {
                  tmp[which.max(rs[tmp])]
            }
      })

data <-data[kid,]
rownames(data) <-gene[kid]
data <- data[!grepl('^MT-',row.names(data)),]
saveRDS(data,"C:/Users/ADMIN/Desktop/imputation/bulk/FPKM_gene1.rds")

###########293T
bulk <-readRDS("/home/wucheng/imputation/bulk/FPKM_gene1.rds")
bulk <-log2(bulk+1)
pbmc.data = readloom("/home/yuanhao/github_repositories/DISC/reproducibility/data/293T/imputation/raw_mc_10_mce_1.loom")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
gene <-intersect(rownames(scData),rownames(bulk))
aa <-rowMeans(bulk[gene,][,1:2])
bb <-rowMeans(scData[gene,])
library(ggplot2)
df <- data.frame(x = bb, y = aa)
library(psych)
coorda <-corr.test(aa,bb,method="spearman")
Raw <-coorda$r

pbmc.data = readloom("/home/yuanhao/DISC_imputation_result/293T/result/imputation.loom")
raw = readloom("/home/yuanhao/github_repositories/DISC/reproducibility/data/293T/imputation/raw_mc_10_mce_1.loom")
pbmc.data <-pbmc.data[rownames(raw),]
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
DISC <-coorda$r

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/293T/imputation/raw_DCA_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
DCA <-coorda$r

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/293T/imputation/raw_scScope_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
scScope <-coorda$r

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/293T/imputation/raw_VIPER_gene_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
VIPER <-coorda$r

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/293T/imputation/raw_scVI_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
scVI <-coorda$r

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/293T/imputation/raw_deepImpute_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
deepImpute <-coorda$r

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/293T/imputation/raw_scImpute_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
scImpute <-coorda$r

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/293T/imputation/raw_MAGIC_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
MAGIC <-coorda$r

T293 <-c(Raw,DISC,DCA,scScope,VIPER,scVI,deepImpute,scImpute,MAGIC)

###########JURKAT
bulk <-readRDS("/home/wucheng/imputation/bulk/FPKM_gene1.rds")
bulk <-log2(bulk+1)
pbmc.data = readloom("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT/imputation/raw_mc_10_mce_1.loom")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
gene <-intersect(rownames(scData),rownames(bulk))
aa <-rowMeans(bulk[gene,][,3:4])
bb <-rowMeans(scData[gene,])
library(ggplot2)
df <- data.frame(x = bb, y = aa)
library(psych)
coorda <-corr.test(aa,bb,method="spearman")
Raw <-coorda$r
#pdf(file="/home/wucheng/imputation/bulk/pcc_293T_Raw.pdf",width=6,height=4)
#p <-ggplot(data = df, mapping = aes(x = x, y = y)) + geom_point(size = 1)+ labs(x="pseudobulk", y = "Log2(FPKM+1)")
#p <-p +theme_classic()+theme(axis.text.x = element_text(size = 12,angle = 0, hjust = 1, vjust = 1),axis.text.y = element_text(size = 12,angle = 0, hjust = 1, vjust = 1))
#p +annotate("text", label = paste0('R==',coorda$r), parse = TRUE, x = 4, y = 6,size =6 )
#dev.off()

pbmc.data = readloom("/home/yuanhao/DISC_imputation_result/JURKAT/result/imputation.loom")
raw = readloom("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT/imputation/raw_mc_10_mce_1.loom")
pbmc.data <-pbmc.data[rownames(raw),]
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
DISC <-coorda$r

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT/imputation/raw_DCA_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
DCA <-coorda$r

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT/imputation/raw_scScope_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
scScope <-coorda$r

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT/imputation/raw_VIPER_gene_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
VIPER <-coorda$r

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT/imputation/raw_scVI_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
scVI <-coorda$r

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT/imputation/raw_deepImpute_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
deepImpute <-coorda$r

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT/imputation/raw_scImpute_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
scImpute <-coorda$r

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT/imputation/raw_MAGIC_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
scData <-as.matrix(pbmc[["RNA"]]@data)
bb <-rowMeans(scData[gene,])
coorda <-corr.test(aa,bb,method="spearman")
MAGIC <-coorda$r

JURKAT <-c(Raw,DISC,DCA,scScope,VIPER,scVI,deepImpute,scImpute,MAGIC)
data <-rbind(T293,JURKAT)
rownames(data) <-c("293T","JURKAT")
colnames(data) <-c("Raw","DISC","DCA","scScope","VIPER","scVI","deepImpute","scImpute","MAGIC")
saveRDS(data,"/home/wucheng/imputation/bulk/sc_bulk_scc.rds")

######plot
library(ggplot2)
library(reshape2)
#data <-readRDS("C:/Users/ADMIN/Desktop/imputation/DEG/sc_bulk_scc.rds")
data <-readRDS("/home/wucheng/imputation/bulk/sc_bulk_scc.rds")
df <-melt(data)
levels <-c("Raw","DISC","scImpute","VIPER","MAGIC","DCA","deepImpute","scScope","scVI")
ggplot(df, aes(x=factor(Var2,levels=levels), y=value,fill = Var1))+
geom_bar(position = "dodge",stat = "identity",width = 0.5)+
ylim(0,1)+theme_classic()+theme(axis.text.x = element_text(size = 12,angle = 45, hjust = 1, vjust = 1, face = "bold"))+theme(axis.text.y = element_text(size = 12, hjust = 1, vjust = 1, face = "bold"))

##############
bulk <-readRDS("/home/wucheng/imputation/bulk/FPKM_gene1.rds")
bulk <-log2(bulk+1)
bulk = cbind(rowMeans(bulk[,1:2]),rowMeans(bulk[,3:4]))
colnames(bulk) = c('293T','JURKAT')
pbmc.data = readloom("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT_293T/imputation/raw_mc_10_mce_1.loom")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
sexpr <-as.matrix(pbmc[["RNA"]]@data)
cl = sub('_.*','',colnames(sexpr))
intgene = intersect(rownames(bulk),rownames(sexpr))
bulk = bulk[intgene,]
sexpr = sexpr[intgene,]
imp1 = sexpr[, which(cl=='293T')]
imp2 = sexpr[, which(cl=='JURKAT')]
aa <-rowMeans(imp1)-rowMeans(imp2)
bb <-bulk[,1]-bulk[,2]
library(ggplot2)
df <- data.frame(x = aa, y = bb)
library(psych)
coorda <-cor(aa,bb,method="spearman")
Raw <-coorda
#pdf(file="/home/wucheng/imputation/bulk/pcc_293T_JURKAT.pdf",width=6,height=4)
#p <-ggplot(data = df, mapping = aes(x = x, y = y)) + geom_point(size = 1)+ labs( x="pseudobulk", y = "Log2(FPKM+1)")
#p <-p +theme_classic()+theme(axis.text.x = element_text(size = 12,angle = 0, hjust = 1, vjust = 1),axis.text.y = element_text(size = 12,angle = 0, hjust = 1, vjust = 1))
#p +annotate("text", label =paste0('R==',coorda), parse = TRUE, x = 2, y = 0,size =6 )
#dev.off()

pbmc.data = readloom("/home/yuanhao/DISC_imputation_result/JURKAT_293T/result/imputation.loom")
raw = readloom("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT_293T/imputation/raw_mc_10_mce_1.loom")
pbmc.data <-pbmc.data[rownames(raw),]
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
sexpr <-as.matrix(pbmc[["RNA"]]@data)
sexpr = sexpr[intgene,]
imp1 = sexpr[, which(cl=='293T')]
imp2 = sexpr[, which(cl=='JURKAT')]
aa <-rowMeans(imp1)-rowMeans(imp2)
df <- data.frame(x = aa, y = bb)
coorda <-cor(aa,bb,method="spearman")
DISC <-coorda

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT_293T/imputation/raw_MAGIC_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
sexpr <-as.matrix(pbmc[["RNA"]]@data)
sexpr = sexpr[intgene,]
imp1 = sexpr[, which(cl=='293T')]
imp2 = sexpr[, which(cl=='JURKAT')]
aa <-rowMeans(imp1)-rowMeans(imp2)
df <- data.frame(x = aa, y = bb)
coorda <-cor(aa,bb,method="spearman")
MAGIC <-coorda

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT_293T/imputation/raw_DCA_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
sexpr <-as.matrix(pbmc[["RNA"]]@data)
sexpr = sexpr[intgene,]
imp1 = sexpr[, which(cl=='293T')]
imp2 = sexpr[, which(cl=='JURKAT')]
aa <-rowMeans(imp1)-rowMeans(imp2)
df <- data.frame(x = aa, y = bb)
coorda <-cor(aa,bb,method="spearman")
DCA <-coorda

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT_293T/imputation/raw_scVI_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
sexpr <-as.matrix(pbmc[["RNA"]]@data)
sexpr = sexpr[intgene,]
imp1 = sexpr[, which(cl=='293T')]
imp2 = sexpr[, which(cl=='JURKAT')]
aa <-rowMeans(imp1)-rowMeans(imp2)
df <- data.frame(x = aa, y = bb)
coorda <-cor(aa,bb,method="spearman")
scVI <-coorda

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT_293T/imputation/raw_scScope_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
sexpr <-as.matrix(pbmc[["RNA"]]@data)
sexpr = sexpr[intgene,]
imp1 = sexpr[, which(cl=='293T')]
imp2 = sexpr[, which(cl=='JURKAT')]
aa <-rowMeans(imp1)-rowMeans(imp2)
df <- data.frame(x = aa, y = bb)
coorda <-cor(aa,bb,method="spearman")
scScope <-coorda

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT_293T/imputation/raw_scImpute_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
sexpr <-as.matrix(pbmc[["RNA"]]@data)
sexpr = sexpr[intgene,]
imp1 = sexpr[, which(cl=='293T')]
imp2 = sexpr[, which(cl=='JURKAT')]
aa <-rowMeans(imp1)-rowMeans(imp2)
df <- data.frame(x = aa, y = bb)
coorda <-cor(aa,bb,method="spearman")
scImpute <-coorda

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT_293T/imputation/raw_deepImpute_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
sexpr <-as.matrix(pbmc[["RNA"]]@data)
sexpr = sexpr[intgene,]
imp1 = sexpr[, which(cl=='293T')]
imp2 = sexpr[, which(cl=='JURKAT')]
aa <-rowMeans(imp1)-rowMeans(imp2)
df <- data.frame(x = aa, y = bb)
coorda <-cor(aa,bb,method="spearman")
deepImpute <-coorda

pbmc.data = readh5("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT_293T/imputation/raw_VIPER_gene_mc_10_mce_1.hdf5")
pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
sexpr <-as.matrix(pbmc[["RNA"]]@data)
sexpr = sexpr[intgene,]
imp1 = sexpr[, which(cl=='293T')]
imp2 = sexpr[, which(cl=='JURKAT')]
aa <-rowMeans(imp1)-rowMeans(imp2)
df <- data.frame(x = aa, y = bb)
coorda <-cor(aa,bb,method="spearman")
VIPER <-coorda

dif_bulk <-c(Raw,DISC,DCA,scScope,VIPER,scVI,deepImpute,scImpute,MAGIC)
saveRDS(dif_bulk,"/home/wucheng/imputation/bulk/sc_dif_bulk_scc.rds")

#value <-readRDS("C:/Users/ADMIN/Desktop/imputation/DEG/sc_dif_bulk_scc.rds")
value <-readRDS("/home/wucheng/imputation/bulk/sc_dif_bulk_scc.rds")
method <-c("Raw","DISC","DCA","scScope","VIPER","scVI","deepImpute","scImpute","MAGIC")
df <-data.frame(method,value)
levels <-c("Raw","DISC","scImpute","VIPER","MAGIC","DCA","deepImpute","scScope","scVI")
ggplot(df, aes(x=factor(method,levels=levels), y=value))+
geom_bar(stat = "identity",width=0.4) +
ylim(0,0.65)+theme_classic()+theme(axis.text.x = element_text(size = 12,angle = 45, hjust = 1, vjust = 1, face = "bold"))+theme(axis.text.y = element_text(size = 12, hjust = 1, vjust = 1, face = "bold"))

#####(cell-cell VS bulk)-dif
#bulk <-readRDS("/home/wucheng/imputation/bulk/FPKM_gene.rds")
#bulk <-log2(bulk+1)
#pbmc.data = readloom("/home/yuanhao/github_repositories/DISC/reproducibility/data/293T/imputation/raw_mc_10_mce_1.loom")
#pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
#pbmc
#pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
#scData <-as.matrix(pbmc[["RNA"]]@data)
#gene <-intersect(rownames(scData),rownames(bulk))
#aa <-rowMeans(bulk[gene,][,1:2])
#bb <-scData[gene,]
#scc <-NULL
#for(i in 1:ncol(bb)){
#coorda <-corr.test(aa,bb[,i],method="spearman")
#scc <-c(scc,coorda$r)
#}

#bulk <-readRDS("/home/wucheng/imputation/bulk/FPKM_gene.rds")
#bulk <-log2(bulk+1)
#bulk = cbind(rowMeans(bulk[,1:2]),rowMeans(bulk[,3:4]))
#colnames(bulk) = c('293T','JURKAT')
#pbmc.data = readloom("/home/yuanhao/github_repositories/DISC/reproducibility/data/JURKAT_293T/imputation/raw_mc_10_mce_1.loom")
#pbmc <- CreateSeuratObject(counts = as.data.frame(pbmc.data))
#pbmc
#pbmc <- NormalizeData(pbmc, normalization.method = "LogNormalize", scale.factor = 10000)
#sexpr <-as.matrix(pbmc[["RNA"]]@data)
#sexpr <-cbind(sexpr[,1001:1100],sexpr[,4001:4100])
#cl = sub('_.*','',colnames(sexpr))
#intgene = intersect(rownames(bulk),rownames(sexpr))
#bulk = bulk[intgene,]
#sexpr = sexpr[intgene,]
#get_scCellType_bulkCellType_cor <- function(ct1, ct2, bulkDiff){
  imp1 = sexpr[, which(cl==ct1)]
  imp2 = sexpr[, which(cl==ct2)]
  corvec = NULL
  corvec <- sapply(1:ncol(imp1),function(i) {
    sapply(1:ncol(imp2), function(j) {
      cor((imp1[,i] - imp2[,j]), bulkDiff,method='spearman')
    })
  })
  as.vector(corvec)
#}
#cn = NULL
#v = sapply(1:(ncol(bulk)-1), function(i){
#  sapply((i+1):ncol(bulk), function(j){
#    cn = c(cn,print(paste0(colnames(bulk)[i],'_',colnames(bulk)[j])))
#    get_scCellType_bulkCellType_cor(ct1=colnames(bulk)[i], ct2=colnames(bulk)[j], bulkDiff = bulk[,colnames(bulk)[i]]-bulk[,colnames(bulk)[j]])
#  })
#})
#colnames(v) = cn
#saveRDS(v,'/home/wucheng/imputation/bulk/sc_sc/raw1.rds')

reproducibility/Data Structure Recovery Evaluation/raw_scripts/sc_bulk_scc.r


##VERSION 7 SWITCHES TO A GAMMA DISTRIBUTION FOR BETWEEN SEASON VARIABILITY
#Version 7A switches to autoregressive noise, where the observation noise slider controls innovations
#and season shock adds additional variations every 12 months

##TO ESTIMATE AR and noise components from real data: ar.test<- ar(test, aic = TRUE, order.max = 1)

#Clear workspace to get rid of old junk
rm(list=ls(all=TRUE))
library(shiny)
library(RColorBrewer)
library(lme4)
# Define server logic required to draw a histogram

shinyServer(function(input, output, clientData, session) {

###################PART OF THE PROGRAM THAT RERUNS WHEN SLIDERS CHANGE
output$ui.pct.decline<- renderUI({
    if (is.null(input$setting))
      return()

 ###BASE INPUT IN THIS VERSION ON THE SID DATA FROM COLORADO FOR 0-1 year OLD CHILDREN

    # Depending on input$input_type, we'll generate a different
    # UI component and send it to the client.
    switch(input$setting,
      "IPD (any serotype)" =
 	  sliderInput("pct.decline.yr",
                  "True vaccine-associated change (%/year):",
                  min = -60,
                  max = 10,
                  value = -30.15),
	"Pneumococcal pneumonia (any serotype)"=
	   sliderInput("pct.decline.yr",
                  "True vaccine-associated change (%/year):",
                  min = -60,
                  max = 10,
                  value = -13.3),
	"All cause pneumonia"=
	   sliderInput("pct.decline.yr",
                  "True vaccine-associated change (%/year):",
                  min = -60,
                  max = 10,
                  value = 0.13)
			#actual value for this is 0.13
		)
	})

output$ui.season.amp<- renderUI({
  if (is.null(input$setting)  )
      return()

    # Depending on input$input_type, we'll generate a different
    # UI component and send it to the client.
    switch(input$setting,
	"IPD (any serotype)" =
       sliderInput("season.amp",
                  "Strength of seasonality:",
                  min = 0,
                  max = 1,
                  value = 0.54),
		"Pneumococcal pneumonia (any serotype)"=
	  sliderInput("season.amp",
                  "Strength of seasonality:",
                  min = 0,
                  max = 1,
                  value = 0.91),
	"All cause pneumonia"=
	 sliderInput("season.amp",
                  "Strength of seasonality:",
                  min = 0,
                  max = 1,
                  value = 0.86)
	)
})

output$ui.n.cases<- renderUI({
      if (is.null(input$setting))
      return()

    # Depending on input$input_type, we'll generate a different
    # UI component and send it to the client.
    switch(input$setting,
	"IPD (any serotype)" =
	 sliderInput("mean.cases.n",
                  "Average number of cases per week:",
                  min = 1.0,
                  max = 500,
                  value = exp(1.12)),
	"Pneumococcal pneumonia (any serotype)"=
 sliderInput("mean.cases.n",
                  "Average number of cases per week:",
                  min = 1.0,
                  max = 500,
                  value = exp(0.93) ),
	"All cause pneumonia"=
 sliderInput("mean.cases.n",
                  "Average number of cases per week:",
                  min = 1.0,
                  max = 500,
                  value = exp(4.64)	)
	)
	})

output$ui.rand.noise<- renderUI({
      if (is.null(input$setting))
      return()

    # Depending on input$input_type, we'll generate a different
    # UI component and send it to the client.
    switch(input$setting,
	"IPD (any serotype)" =
 sliderInput("observation.noise",
                  "Amount of random variation in data:",
                  min = 1e-6,
                  max = 0.4,
                  value = 0.33),
	"Pneumococcal pneumonia (any serotype)"=
 sliderInput("observation.noise",
                  "Amount of random variation in data:",
                  min = 1e-6,
                  max = 0.4,
                  value = 0.25),
	"All cause pneumonia"=
 sliderInput("observation.noise",
                  "Amount of random variation in data:",
                  min = 1e-6,
                  max = 0.4,
                  value = 0.23)
	)
	})

##########################
#######################
output$distPlot <- renderPlot({
	if (is.null(input$pct.decline.yr)){
	return()}

	n.year.post.PCV <- 		input$years.post.pcv.data      #how many years post-pcv data?
	n.year.pre.PCV  <-		input$years.pre.pcv.data     #how many years pre-PCV data?
	n.years.fill <-           	n.year.pre.PCV + n.year.post.PCV
	year.introduce.vax.fill.vec<- n.years.fill -n.year.post.PCV  #What year is vaccine introduced?
	irr.yr.vax                 <-  1+(input$pct.decline.yr/100)
	irr.sec.trend.yr			<- 1 + (input$secular.trend.yr/100)
	vax.change.coeff.fill.vec <-   irr.yr.vax #What is the IRR per year?
	std.dev.year.fill.vec <-       input$year.noise #Variation between years
	mean.cases.vec<-               input$mean.cases.n  #What is the intercept (cases/month)?
	obs.noise.fill.vec <-          input$observation.noise #How much random noise (note there is also poisson observation noise added to the data separately?

	n.reps<-input$sim.n

	coeffs.end<- matrix(ncol=1, nrow=n.reps) #Create empty data frame

	#CHECKBOXES
 	if (input$model.season) include.seasonality <- 1 else include.seasonality <- 0
	if (input$model.secular.trend) include.secular.trend <-1 else include.secular.trend <-0

	sim.function <-function(n.years.fill2,year.introduce.vax.fill, vax.change.coeff.fill,mean.cases, obs.noise.fill)
		{

			#monthly data for 10 years
			n.years<- n.years.fill2

			#Year vaccine introduced
			year.introduce.vax <-year.introduce.vax.fill

			#coeff for vaccine change per month is ln(IRR)/12, so a 10%/year decline is ln(0.9)/12, 30%/year would be ln ln(0.7)/12  try 0.8
			vax.change.coeff=log(vax.change.coeff.fill)/12

			#Standard deviation in mean between years...try 0.2
			#std.dev.year<-std.dev.year.fill

			#Observation noise...
			obs.noise=0.3

			#Vector of monthly values
			t <- 1:(12*10)

			#Seasonal variation
			season.component <-  1 * cos(2*3.14159*t/12+3.14159)

			#Year to year variation in mean levels, centered at mean with a certain stddev
			year.index=1:10
			#year.noise <- rgamma(n.years, shape=std.dev.year, scale = 0.15)
			#year.noise.tab<-cbind.data.frame(year.noise, year.index)

			#merge in yearly noise with seasonal variations
			d <- cbind.data.frame(t,season.component)
			d$year <-ceiling(t/12)

			d2<-d
			#d2<-merge(d,year.noise.tab, by.x="year", by.y="year.index")

			#Random observation-level noise
			d2$obs.noise <-rnorm(nrow(d2),mean=0, obs.noise)

			year.introduce.vax=7
			#vaccine introduced in year x and can be either a change in mean or changslope
			change.month<-(year.introduce.vax*12+1)
			#print(change.month)
			d2$meanchng<-0
			d2$meanchng[(year.introduce.vax*12+1):(nrow(d2)) ]  <-1

			d2$changslope<-d2$t -(year.introduce.vax*12)
			d2$changslope[ d2$changslope<0 ]<- 0

			include.seasonality=1
			d2$sin12.model <-include.seasonality*sin(2*3.14159*d2$t/12)
			d2$cos12.model <-include.seasonality*cos(2*3.14159*d2$t/12)

			include.secular.trend=1
			secular.trend.model <-t*include.secular.trend

			#GENERATE THE SIMULATED TIME SERIES
			irr.sec.trend.yr<-1
			vax.change.coeff<- -0.8
			mean.cases=10
			d2$exp.case.mean.no.int<-exp( season.component + log(irr.sec.trend.yr)/12*t +  d2$obs.noise + d2$changslope*vax.change.coeff)
     			beta0 <- log(mean.cases) - mean(log(d2$exp.case.mean.no.int)) #calculate intercept as function of mena cases and model components
			d2$exp.case.mean.no.int <- exp(beta0)* d2$exp.case.mean.no.int #full model with intercept
			d2$exp.case <-rpois(length(t),d2$exp.case.mean)  #The observed number of cases is drawn from some true mean
			d2$TID <-as.factor(t)

			plot.df<-cbind.data.frame(	d2$t,d2$exp.case)

			#FIT MODEL
			glmm1 <-glmer(exp.case ~  secular.trend.model + sin12.model +  cos12.model + changslope + (1|TID )  , data=d2, family = poisson, nAGQ = 0, control = glmerControl(check.rankX = "stop.deficient"), silent = TRUE)
			summary.glmm1<-summary(glmm1)

 coef.cp2 <- as.data.frame(summary.glmm1$coefficients)["changslope",1]
			coef.cp<-coef(glmm1)["changslope"]
			list.results<-list(summary.glmm1,coef.cp,plot.df)
			return(list.results)
		}

		irr.end<-NA
		est.pct.change.vax <-NA
		est.vax.change.irr <-NA

		sim.data <-data.frame(simn=numeric(),exp.case=numeric() )
		for (i in 1:n.reps){
			func<-sim.function(n.years.fill2=n.years.fill, year.introduce.vax.fill=year.introduce.vax.fill.vec,
			vax.change.coeff.fill=vax.change.coeff.fill.vec,
			mean.cases=mean.cases.vec, obs.noise.fill=obs.noise.fill.vec)
			est.vax.change.irr<-exp(12*as.numeric(as.character(func[2])))
			irr.end[i] <-est.vax.change.irr  ##GIVES CHANGE PER YEAR POSTVAX

			sim.dataout<-cbind(i,unlist(func[[3]][1]),unlist(func[[3]][2]) )
			sim.data<-rbind(sim.data,sim.dataout)
					}

			est.pct.change.vax=100*(irr.end-1)
			quant.pct<- as.character(round(quantile(est.pct.change.vax,  probs = c(2.5, 50,97.5)/100),1))
			ci.vector<-paste("95%CI:", quant.pct[1], "," , quant.pct[3], sep='')
			median.vector<-paste("Median:", quant.pct[2],sept="")
			mean.vector<-paste("Mean:", mean(est.pct.change.vax),sept="")
			std.dev.vector <- paste("Standard Deviation:", round(sqrt(var(est.pct.change.vax)),digits=2)  )

m <- rbind(c(2,2, 1,3))
layout(m)
par(mar = c(3, 3, 2, 1))
par(xaxs="i",  yaxs="i") # OPTION ENSURES X AND Y AXES MEET AT 0,0
	names(sim.data)<-c("i","month", "cases")
	# draw the histogram with the specified number of bins
	d <- density(est.pct.change.vax) # returns the density data
	plot(d, bty="l",xlim=c(-90, 100), main="", lwd=2, col="red")
	#hist(est.pct.change.vax, bty="l",xlim=c(-90, 100), main="", lwd=2, col="red") # plots the results
	abline(v=0,lty="dotted",col="darkgray")
	abline(v=input$pct.decline.yr,lty="dashed",col="darkblue")
	text(input$pct.decline.yr,0.0,"Actual change (%)",srt=270, adj=c(1.0,1.00), cex=1.5 , col="darkgray")

	title(main="Estimates of % change from different simulations", cex.main=1.5)

	#Draw the time series
	color.vector=brewer.pal(n.reps ,"Blues")
	interaction.plot(sim.data$month,sim.data$i, sim.data$cases, axes=FALSE, bty="l",col=color.vector,ylab="Cases", xlab="time(months)", legend=FALSE, main="",ylim=c(0,max(sim.data$cases)) )
	axis(side=1, at=c(1,12,24,36,48,60,72,84,96,108,120,132,144) ,col="darkgray" )
		ymaxval<- max(sim.data$cases)
	yticks<- round(c( 0, ymaxval*0.1,  ymaxval*0.2,  ymaxval*0.3, ymaxval*0.4,  ymaxval*0.5,  ymaxval*0.6,  ymaxval*0.7,  ymaxval*0.8,  ymaxval*0.9,  ymaxval*1.0, ymaxval*1.1))
	axis(side=2, at=yticks ,col="darkgray" )
	title(main="", xlab="time(months)" , ylab="Cases", xpd=NA)

	plot(1:10, 1:10,col="white", axes=FALSE)
	text(2,10, median.vector , cex=3,adj=c(0, 0.5), xpd=NA  ) #Adds the median of the density plot
	#text(2,9, mean.vector , cex=3,adj=c(0, 0.5), xpd=NA  ) #Adds the median of the density plot
	text(2,9, ci.vector , cex=3,adj=c(0, 0.5), xpd=NA ) #Adds the median of the density plot
	text(2,8, std.dev.vector , cex=3,adj=c(0, 0.5), xpd=NA ) #Adds the median of the density plot

	  })
})


# Cette fonction transforme un raster avec des couches donnant pour des temps donnés
# en un raster layer qui donne les temps pour un seuil donné
# le seuil doit être donc atteint sur les couches (ou cela renverra NA)

isorenorme <- function(isoraster, facteur)
{
  isoraster/facteur
}

isAraster <- function(x)
{
  return((class(x)[1]=="RasterLayer" || class(x)[1]=="RasterBrick" || class(x)[1]=="RasterStack"))
}

#' Transforme des isochrones en temps d'accès
#'
#' Cette fonction transforme un raster avec des couches donnant pour des temps donnés des opportunités atteintes
# en un raster layer qui donne les temps pour un seuil d'opportunité donné
# le seuil doit être donc atteint sur les couches (ou cela renverra NA)
#'
#' @param isoraster le raster en entrée
#' @param seuils les seuils pour la sortie
#'
#' @return un raster avec autant de couches que d'éléments dans seuils
#' @export
#'
#'
iso2time <- function(isoraster, seuils=median(raster::cellStats(isoraster, median)))
{
  checkmate::assert(checkmate::checkMultiClass(isoraster, c("RasterLayer", "RasterBrick", "RasterStack")))
  seuils <- unique(seuils)
  isotimes <- names(isoraster) %>%
    stringr::str_extract("[:digit:]+") %>%
    as.numeric()
  mm <- raster::as.matrix(isoraster)
  ncol <- ncol(mm)
  nrow <- nrow(mm)
  rr <- purrr::map(seuils, ~ {
    cc_moins <- max.col(mm<=.x, ties.method = "last")
    cc_plus <- max.col(mm>=.x, ties.method = "first")
    nnas <- !is.na(cc_moins)
    i_nnas <- which(nnas)
    ind_moins <- i_nnas +(cc_moins[nnas]-1)*nrow
    y_moins <- mm[ind_moins]
    y_plus <- mm[i_nnas +(cc_plus[nnas]-1)*nrow]
    out <- c(NA)
    length(out) <- nrow
    out[nnas] <- (.x-y_moins)/(y_plus-y_moins)*(isotimes[cc_plus[nnas]]-isotimes[cc_moins[nnas]])+isotimes[cc_moins[nnas]]
    out[nnas] [y_moins>=y_plus] <- NA
    res <- raster::raster(isoraster)
    raster::values(res) <- out
    res
  })
  rr <- raster::brick(rr)
  names(rr) <- stringr::str_c(
    "to",
    ofce::uf2si2(seuils, rounding=FALSE, unit="multi")
  )
  rr
}

iso2time_dt <- function(isodt, seuils=median(cellStats(isodt, median)), exclude=1)
{
  checkmate::assert(checkmate::checkMultiClass(isodt, c("data.table", "data.frame", "tibble")))
  isotimes <- names(isodt[,-(exclude),  with=FALSE]) %>%
    stringr::str_extract("[:digit:]+") %>%
    as.numeric()
  mm <- isodt[,-(exclude), with=FALSE] %>%
    as.matrix()
  ncol <- ncol(mm)
  nrow <- nrow(mm)
  rr <- purrr::map(seuils, ~ {
    cc_moins <- max.col(mm<=.x, ties.method = "last")
    cc_plus <- max.col(mm>=.x, ties.method = "first")
    nnas <- !is.na(cc_moins)
    i_nnas <- which(nnas)
    ind_moins <- i_nnas +(cc_moins[nnas]-1)*nrow
    y_moins <- mm[ind_moins]
    y_plus <- mm[i_nnas +(cc_plus[nnas]-1)*nrow]
    out <- c(NA)
    length(out) <- nrow
    out[nnas] <- (.x-y_moins)/(y_plus-y_moins)*(isotimes[cc_plus[nnas]]-isotimes[cc_moins[nnas]])+isotimes[cc_moins[nnas]]
    out[nnas] [y_moins>=y_plus] <- NA
    out
  })
  names(rr) <- stringr::str_c("to",
                              uf2si2(seuils, rounding=FALSE, unit="multi"))
  setDT(rr)
  cbind(isodt[,(exclude),  with=FALSE], rr)
}


sqldf('select user_id,count(*) c from d1_a group by user_id order by c desc limit 10')

sqldf('select hotel_cluster,count(*) c from d1_a where user_id=1156294 group by hotel_cluster order by c desc limit 10')

sqldf('select hotel_cluster,count(*) c from d1_a where srch_adults_cnt>3 and srch_children_cnt>1 group by hotel_cluster order by c desc limit 10')

sqldf('select hotel_cluster,count(*) c from d1_a where srch_adults_cnt>3 and srch_rm_cnt>1 and srch_destination_id=8253 group by hotel_cluster order by c desc limit 100')

#no match
331829

#strong match
195876


if ( list.i <= 1 ){
	windows(width=10,height=5)

	par(mar=c(5,7,1,11))
	plot(NA,xlim=range(xx1),ylim=range(yy1),frame=FALSE,axes=F,xaxs="i",yaxs="i",ylab="",xlab="")
	.filled.contour(x=xx1, y=yy1, z=zz1,levels=clevels,col=red_blue(cstep))

	par(new=T,mar=c(5,7,1,11),xaxs="i", yaxs="i", las=1,mgp=c(2.0, 1, 0))
	contour(xx1,yy1,matrix(0,nrow(zz1),ncol(zz1)),xlab="GC1 (min)",ylab="GC2 (sec)", yaxs="i",col.lab="blue",col.axis="blue")

	####Log Kow
	par(new=T,mar=c(5,7,1,11),xaxs="i", yaxs="i", las=1,mgp=c(3, 1, 0))
	contour(xx1,yy1,logKo_w.contour, yaxs="i",ylab=paste("Log Ko_w"),axes=FALSE,col=rgb(0,0,0,1),lwd=1.2,levels=seq(-30,30,1),labcex = 1.1)

	####Log Kaw
	par(new=T,mar=c(5,7,1,11),xaxs="i", yaxs="i", las=1)
	contour(xx1,yy1,logKa_w.contour,xaxs="i", yaxs="i",axes=FALSE,col=rgb(0.6,0.6,0.6,1),lwd=1.2,levels=seq(-30,30,1),labcex = 1.1 )
	axis(4, yaxt ="n")
	mtext("Log Ka_w", side = 4, line = 3, las=3,col=rgb(0.6,0.6,0.6,1) )

	####Log Koa
	par(new=T, mar=c(5,7,1,11) )
	contour(xx1,yy1,logKo_a.contour,,xaxs="i", yaxs="i",axes=FALSE,col=rgb(1,0.5,0.5,1),lwd=1.2,levels=seq(-30,30,1),labcex = 1.1)
	axis(1, xaxt ="n")
	mtext("Log Koa", side = 1, line = 3, las=1,col=rgb(1,0.5,0.5,1))

}

###Obtain click point(s)
setwd(codeDrive)
source("source_point_choose.r")

RT1.memo <- point1$x
RT2.memo <- point1$y
suppressWarnings( rm( point1, RT1.click, RT2.click ) )

RT1.memo.list <- rep(RT1.memo, length(prop.me.list.all))
RT2.memo.list <- rep(RT2.memo, length(prop.me.list.all))
RT_for_estim <- cbind( RT1.memo.list, RT2.memo.list)
estim.result <- round(cbind( t(prop.lower), t(prop.me.list.all), t(prop.upper) ),digits=3)
estim.table <- cbind( estim.result, RT_for_estim )

setwd(outputDrive)
write.csv( estim.table, paste("ID",list.i, "RT1_", RT1.memo, "RT2_", RT2.memo,".csv", sep="") )

if ( list.i <= 1 ){
	lower.estim.table <- estim.table[,1]
	med.estim.table <- estim.table[,2]
	upper.estim.table <- estim.table[,3]
} else {
	lower.estim.table <- rbind(lower.estim.table, estim.table[,1])
	med.estim.table <- rbind(med.estim.table, estim.table[,2])
	upper.estim.table <- rbind(upper.estim.table, estim.table[,3])
}

if ( list.i == nrow(Analyze_RTlist) ) {
	lower.estim.table <- cbind(Analyze_RTlist$Retention.I..min., Analyze_RTlist$Retention.II..sec., lower.estim.table )
	med.estim.table <- cbind(Analyze_RTlist$Retention.I..min., Analyze_RTlist$Retention.II..sec., med.estim.table )
	upper.estim.table <- cbind(Analyze_RTlist$Retention.I..min., Analyze_RTlist$Retention.II..sec., upper.estim.table )

	colnames(lower.estim.table) <- colnames(med.estim.table) <- colnames(upper.estim.table) <- c("RT1 (min)","RT2 (sec)", rownames(estim.table) )

}


library(zoo)
library(sf)
library(hydromad)
library(rgeos)
library(tidyverse)

catchments=readLines(textConnection("SC #114
SC #106
SC #113
SC #107
SC #112
SC #108
SC #109
SC #157
SC #110
SC #111
SC #105
SC #161
SC #104
SC #103
"))

setwd("E:/cloudStor/source/projects/MW_BASE_RC8_411_4712/")
subc=read_sf("876a3af3-9508-4f42-802b-cf410c72404e.shp")
cat_dem = raster("1.flt")

st_crs(subc)<-"+proj=aea +lat_1=-18 +lat_2=-36 +lat_0=0 +lon_0=132 +x_0=0 +y_0=0 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs "
subc3<-st_transform(subc,"+proj=longlat +datum=WGS84 +no_defs ")

# With functional unit
x2=read_sf("91cf75b6-ce76-4d41-891f-2f1a2fe7c127.shp")
x2=subset(x2,IntSCs %in% catchments)
plot(x2[,"IntFUs"])
#st_area(x2) %>% sum

st_crs(x2)<-"+proj=aea +lat_1=-18 +lat_2=-36 +lat_0=0 +lon_0=132 +x_0=0 +y_0=0 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs "
x2<-st_transform(x2,"+proj=longlat +datum=WGS84 +no_defs ")
write_sf(x2,"mw_LU.shp")
# Up to here for Qian


# Do this for multiple folders.  So i am going to select.list ll the folders
#in my current directory that hass all my experiments listed.
main.dir<-"E:/DRG Profiling/Short Protocols"
setwd(main.dir)
exp.dir<-select.list(list.dirs(), multiple=T)

rd.names<-c(
"RD.161011.50.f.p1",
"RD.161011.50.f.p2"
)

for(i in 1:length(rd.names)){
setwd(exp.dir[i])

# read in cell data.  This is a big data frame, but we only need a
# few collumns for now.
c.dat<-read.delim("celldatacells_filtered.txt", header=T, sep="\t")

#These are the collumns needed for analysis
c.dat.names<-c(
"ObjectNumber",
"AreaShape_Area",
"AreaShape_Center_X",
"AreaShape_Center_Y",
"AreaShape_FormFactor",
"AreaShape_Perimeter",
"Intensity_MeanIntensity_CGRP",
"Intensity_MeanIntensity_IB4_1",
"Intensity_MeanIntensity_DNA_2",
"Location_Center_X",
"Location_Center_Y")

c.dat<-c.dat[,c.dat.names]

# i like to rename the collumns for my procpharm
names(c.dat)<-c(
"id",
"area",
"center.x.simplified",
"center.y.simplified",
"circularity",
"perimeter",
"mean.gfp",
"mean.tritc",
"mean.dapi",
"center.x",
"center.y")

# Now read in video Data
# this takes a long time and needs to be optimzed outside of R
require(data.table)
f2.img<-fread("video_dataROI.txt")
f2.img<-read.delim("video_dataROI.txt", se)
f2.img2<-f2.img[-drop.rows]
#cell names
cell.names<-unique(f2.img[,"ObjectNumber"])
#table of frames per cell

row.names(f2.img)<-NULL

cell.names<-unique(f2.img[,"ObjectNumber"])

x.tab<-table(f2.img[,"ObjectNumber"])

x.row<-max(x.tab)

t.340<-xtabs(Intensity_MeanIntensity_f2_340~ImageNumber+ObjectNumber, f2.img)
t.380<-xtabs(Intensity_MeanIntensity_f2_380~ImageNumber+ObjectNumber, f2.img)

t.dat<-t.340/t.380

time.info<-read.delim("time.info.txt", sep="\t", fileEncoding="UCS-2LE")
if(length(which(is.na(time.info[3]), arr.ind=T)[,1])>=1){
	time.info<-time.info[-which(is.na(time.info[3]), arr.ind=T)[,1],]
}else{time.info<-time.info}#remove any nas
time.min<-round(time.info["Time..s."]/60, digits=3)

# Create row.names
cell.names<-paste("X.",c.dat$id,sep="")
c.dat[,"id"]<-cell.names
row.names(c.dat)<-cell.names
t.dat <- as.data.frame(t.dat)

t.dat["Time"]<-time.min
t.dat<- t.dat[unique(row.names(t.dat)),]#incase of duplicated rownames

names(t.dat) <- c("Time",cell.names)
t.340["Time"]<-time.min
t.340<-as.data.frame(t.340)
row.names(t.340)<-time.min

t.380["Time"]<-time.min
t.380<-as.data.frame(t.380)
row.names(t.380)<-time.min

## Proof my dataframes are already sorting in the correct way.
#first create a dataframe from the video file x and y location data
#t.loc.x<-matrix(f2.img[,"Location_Center_X"],byrow=FALSE, nrow=max(cell.names))[,1]
#t.loc.y<-matrix(f2.img[,"Location_Center_Y"],byrow=FALSE, nrow=max(cell.names))[,1]
#t.loc<-cbind(t.loc.x, t.loc.y)
#t.loc<-round(t.loc, digits=3) #Then round dataframe to three digits

## Create datatrame from c.dat(c created above)
#c.xy<-c.dat[,c("center.x", "center.y")]
#c.xy<-round(c.xy, digits=3) # also round to three digits
#setdiff(t.loc[,2], c.xy[,2]) #There should be no difference between the two data frames

#setequal(t.loc[,1], c.xy[,1])#There should be no difference between the two data frame
#setequal(t.loc[,2], c.xy[,2])#There should be no difference between the two data frame

#example
#a<-seq(from=1,to=10,by=10)
#b<-seq(from=1,to=10,by=10)

############ wr1 import
wrdef<-"wr1.csv"
if(!is.null(wrdef))
	{
		wr <- ReadResponseWindowFile(wrdef)
		Wr<-length(wr[,1])#complete and revise this section
		if(length(colnames(wr))<2){w.dat<-WrMultiplex(t.dat,wr,n=Wr)}
		else{w.dat <- MakeWr(t.dat,wr)}
		}

# Initial Data processing
tmp.rd <- list(t.dat=t.dat,w.dat=w.dat,c.dat=c.dat)
levs<-setdiff(unique(as.character(w.dat[,2])),"")
snr.lim=4;hab.lim=.05;sm=3;ws=30;blc="SNIP"
pcp <- ProcConstPharm(tmp.rd,sm,ws,blc)
scp <- ScoreConstPharm(tmp.rd,pcp$blc,pcp$snr,pcp$der,snr.lim,hab.lim,sm)
bin <- bScore(pcp$blc,pcp$snr,snr.lim,hab.lim,levs,tmp.rd$w.dat[,"wr1"])
bin <- bin[,levs]
bin["drop"] <- 0 #maybe try to generate some drop criteria from the scp file.
bin<-pf.function(bin,levs)

# Add images
require(png)
img.gtd<-png::readPNG("gfp.tritc.dapi.png")
img.g<-png::readPNG("gfp.png")
img.t<-png::readPNG("tritc.png")
img.b<-png::readPNG("bf.png")
img.bl<-png::readPNG("bf.lab.png")
img.r<-png::readPNG("roi.img.png")
img.f<-png::readPNG("fura2.png")

tmp.rd <- list(t.dat=t.dat,t.340=t.340, t.380=t.380,w.dat=w.dat,c.dat=c.dat, bin=bin, scp=scp, snr=pcp$snr, blc=pcp$blc, der=pcp$der,
img.gtd=img.gtd, img.g=img.g, img.t=img.t, img.b=img.b,img.bl=img.bl,img.r=img.r, img.f=img.f)

## Check for duplicated rows
if(length(which(duplicated(row.names(t.dat))))>=1){
dup<-which(duplicated(row.names(t.dat)))
paste(dup)
t.dat<-t.dat[-dup,]
w.dat<-w.dat[-dup,]
}

rd.name<-rd.names[i]
f.name <- paste(rd.name,".Rdata",sep="")
assign(rd.name,tmp.rd)
save(list=rd.name,file=f.name)

setwd(main.dir)
rm(f2.img)
}


#Contact map score (CMScore)
#Script to find matched presence in two matrices/arrays
#Initial purpose for comparing cross-linked protein data to contact maps
#CMS=contact map score
# '#print' are used for troubleshooting various steps of the script

cms.example=function(distancerange,exampleinput) {
	if(is.numeric(distancerange)==FALSE){
		return("Error: Contact map distances must be numeric.")
	}else if(is.character(exampleinput)==FALSE){
		return("Error: Protein input must be character, add quote marks around protein name/accession.")
	}else{
		#libraries
			#library(Matrix)
			#library(zoo)
			#library(Rpdb)
			#library(lattice)
			#library(latticeExtra)
			#library(tcltk)
		#Nullify
		pdbfile.initial=NULL
		pdbfile=NULL
		xatoms=NULL
		xmolecule=NULL
		xchaina=NULL
		xalpha=NULL
		aamin=NULL
		xlstart=NULL
		xlend=NULL
		xdistmatrix=NULL
		distcon=NULL
		colfunc1=NULL
		colfunc2=NULL
		hmcols=NULL
		xlcontactfile=NULL
		uniprotsitetable=NULL
		upaccs1=NULL
		upaccs2=NULL
		upinputselect1=NULL
		upinputselect2=NULL
		reciprocalust=NULL
		crosslinkmap=NULL
		upaccs1=NULL
		upaccs2=NULL
		xlcontactfile=NULL
		uniprotsitetable=NULL
		upinputselect1=NULL
		upinputselect2=NULL
		reciprocalust=NULL
		crosslinktable=NULL
		crosslinkmap=NULL
		sort.clt=NULL
		cms.crosslinkmap=NULL
		cms.matrix.input=NULL
		cms.matrix=NULL
		cmscore.table=NULL

		recname=chainid=elename=NULL

		#data
		#data(cmdata)
		#data(xlmapdata)

		#import pdb from example file
		pdbfile.initial=paste("p.",exampleinput,sep="")
		pdbfile=get(pdbfile.initial)

		cmscore.table.initial=unlist(
			lapply(distancerange,function(cadistance){

			###
			###Making PDB matrix
			##
			##if pdb file imported, find contacts within x angstroms and plot them to data matrix
			#first identify atoms
			xatoms=pdbfile$atoms

			#as.data.frame important for maintaining values in eleid and resid columns
			xmolecule=subset(as.data.frame(xatoms),recname=="ATOM")

			yes.pdb=c('oxa23','tbpa','ppib')
			no.pdb=c('ab57.2983','ppib.decoy')

			#then identify alpha-carbons in chain A
			if(any(exampleinput==yes.pdb)==TRUE) {
				xchaina=subset(xmolecule,chainid=="A")
				xalpha=subset(xchaina,elename=="CA")
			}else if(any(exampleinput==no.pdb)==TRUE){
				xalpha=subset(xmolecule,elename=="CA")
			}else {
			return("No example files with that name.")
			}

			aamin=1
			xlstart=min(xalpha[c("resid")])
			xlend=max(xalpha[c("resid")])

			#create matrix including any crystal structure offset in amino acid sequence
			xfill=as.data.frame(c(1:xlend))
			colnames(xfill)=c('resid')
			xalphafilled.initial=merge(xfill,xalpha,all=TRUE)
			xalphafilled=xalphafilled.initial[1:xlend,]

			#determine distance between alpha carbons (this will create the matrix of interactions)
			xdistmatrix=as.matrix(dist(xalphafilled[c("x1","x2","x3")]))
			xdistmax=max(as.matrix(dist(xalpha[c("x1","x2","x3")])))
			if(cadistance>max(xdistmax)){
				cadistance=max(xdistmax)
			}else{
				cadistance=cadistance
			}
			xdistmatadj=xdistmatrix[xdistmatrix>cadistance]=50

			cms.xdm=xdistmatrix
			cms.pdb.distmatadj=cms.xdm[cms.xdm<cadistance]=1

			###
			###
			###
			###Make matrix for XL data from example data
			###
			###

			crosslinktable=get(gsub('.decoy',"",exampleinput))
			crosslinkmap=as.matrix(crosslinktable[c(3,4)])

			#Make Xl matrix for ContactMapScore(CMS)
			sort.clt=crosslinktable[order(crosslinktable$mod_pos1,crosslinktable$mod_pos2),]
			cms.crosslinkmap=as.matrix(sort.clt[c(3,4)])
			cms.matrix.initial=as.data.frame(cms.crosslinkmap)
			#remove crosslinks greater than xlend
			cms.matrix.namaker=cms.matrix.initial[cms.matrix.initial>xlend]=NA
			cms.matrix.short=na.omit(cms.matrix.initial)
			#fill to max residue in pdb file
			cms.matrix.input=rbind(cms.matrix.short,c(xlend,xlend))

			cms.matrix=Matrix(0,nrow=nrow(cms.xdm),ncol=ncol(cms.xdm))
			cms.matrix[cbind(cms.matrix.short$mod_pos1,cms.matrix.short$mod_pos2)]=1
			cms.matrix=as.matrix(cms.matrix)

			#
			###
			###
			###
			#Comparing the two matrices
			###
			###
			###
			#

			#change row and column names in both matrices to match each other
			rownames(cms.xdm)=colnames(cms.xdm)=rownames(cms.matrix)=colnames(cms.matrix)=c(1:xlend)

			#find matrix sum
			matrix.matcher=cms.xdm==cms.matrix
			matrix.matcher=matrix.matcher+0
			matrix.overlap=sum(matrix.matcher,na.rm=TRUE)

			cms.crosslink.sum=sum(cms.matrix)

			cms.xdm.sum.input=cms.xdm
			cms.xdm.sum.middle=cms.xdm.sum.input[cms.xdm.sum.input!=1]=0
			cms.xdm.sum=sum(cms.xdm.sum.input,na.rm=TRUE)

			cms.middle=cms.crosslink.sum/matrix.overlap
			#Lower scores are better, 0 is perfect overlap!
			cms.final=cms.middle-1

			return(cms.final)
		}
		)
		)
		#create plot and add CMScore as text to plot, users can save this as a metafile to get necessary information;
		if(is.infinite(max(cmscore.table.initial))) {
			cmscore.table.maxfind=cmscore.table.initial
			cmscore.table.maxfind[is.infinite(cmscore.table.maxfind)]=0
			max.cmscore.adj=max(cmscore.table.maxfind)
			cmscore.table.final=cmscore.table.initial
			cmscore.table.final[is.infinite(cmscore.table.final)]=max.cmscore.adj
		} else {
			cmscore.table.final=cmscore.table.initial
		}
	#Plot the residual scores and CMScore
		cmscore.table.final=cbind(c(min(distancerange):max(distancerange)),cmscore.table.final)
		plot(
			cmscore.table.final,type='o',
			xlab="Distance Constraint used to Generate Contact Map (Angstroms)",
			ylab="Residual Score",
			xlim=c(min(distancerange),max(distancerange)),
			main=paste("CMScore =",round(sum(cmscore.table.final[,2]),digits=5))
		)
		question.save.plot = winDialog(type = c("yesno"),"Do you want to save the CMScore table?")
		if(question.save.plot=="YES") {
			write.table(cmscore.table.final,file = paste(exampleinput,"CMScoreTable",format(Sys.time(),"%Y%m%d%H%M%S"),".txt", sep=""), sep="\t",row.names=F)
			print("NICE PLOT!")
		} else {
			print("NICE PLOT!")
		}
	}
}

#cmsexample(0:40,'ppib')


library(lubridate)
library(modelr)
library(broom)
library(tidyverse)
library(visdat)
library(mlr3verse)

source("./read-mobility.r")

forecast_googleMob<-function(codeToName){
  # read data

  # google
  google_data <- read_google_mobility(codeToName=codeToName, regression=TRUE)
  il <- as.data.frame("Illinois")
  colnames(il) <- "sub_region_1"
  google_data <- left_join(google_data, il, by = c("sub_region_1"))

  # new foursquare data
  new_foursquare = read_csv("../modelInput/mobility/visit-data/visitdata-grouped.csv")
  new_foursquare$categoryname=as.factor(new_foursquare$categoryname)

  # c("Airport" ,  "Arts & Entertainment"        "Banks"
  # [5] "Beach"                       "Big Box Stores"              "Bus"                         "Colleges & Universities"
  # [9] "Convenience Store"           "Discount Stores"             "Drug Store"                  "Events"
  # [13] "Fast Food Restaurants"       "Fitness Center"              "Food"                        "Gas Stations"
  # [17] "Government"                  "Grocery"                     "Gun Shops"                   "Hardware Stores"
  # [21] "Hotel"                       "Light Rail Stations"         "Medical"                     "Metro Stations"
  # [25] "Nightlife Spots"             "Office"                      "Outdoors & Recreation"       "Professional & Other Places"
  # [29] "Residences"                  "School"                      "Shops & Services"            "Skiing"
  # [33] "Spiritual Center"            "Sports"                      "Travel & Transport"

  sfsq <- new_foursquare %>%
          filter(categoryname!="Skiing",demo=="All") %>%
          select(c(-demo,-county,-p50Duration)) # revisit p50

  # notice: visit data is only by state, not by county -> this is okay
  # just apply the same state-level signal to every county
  # just need to generate a functional table at this point
  google_cleaned <- google_data %>%
          select(date,state=sub_region_1,retail.recreation,grocery.pharmacy,parks,transitstations,workplace,residential) %>%
          filter(state!="")

  print("google last obs:")
  print(tail(google_cleaned$date, 1))
  print("visitdata last obs:")
  print(tail(sfsq$date, 1))

  mobility_data <- left_join(sfsq,google_cleaned, by = c("state" = "state", "date" = "date"))

  #mobility_data <- mobility_data %>% #  filter(!(state %in% c("Alaska", "District of Columbia", "Hawaii")))
  mobility_data <- mobility_data %>%
          pivot_wider(names_from = categoryname , values_from = c(avgDuration,visits))
  mobility_data$state <- as.factor(mobility_data$state)
  names(mobility_data)<- make.names(names(mobility_data),unique = TRUE)

  # check fit on last week
  last_google = ymd((mobility_data %>% filter(!is.na(retail.recreation)) %>% summarise(last(date)))[[1,1]])
  train_stop = last_google-6

  # foursquare broken then # should be fine
  mobility_data = mobility_data %>% filter(date!=ymd("2020-04-19"))

  # need to remove date for mlr
  mobility_data = mobility_data %>% arrange(date)
  mobility_data$id = c(1:nrow(mobility_data))

  train_end_id = (mobility_data %>% filter(date==train_stop) %>% summarise(last(id)))[[1,1]]
  google_end_id = (mobility_data %>% filter(date==last_google) %>% summarise(last(id)))[[1,1]]
  dates = mobility_data$date
  mobility_data = mobility_data %>% select(c(-date,-categoryid))

  # revisit imputation
  mobility_data=mobility_data %>% fill(names(mobility_data),.direction = 'updown')

  # convert single-item list cols to numeric
  tmp <- sapply(mobility_data, class)
  mobility_data[tmp == "list"] <- sapply(mobility_data[tmp == "list"], function(l) l[1])

  # retail.recreation
  task = TaskRegr$new(id = "retail.recreation", backend = as.data.frame(mobility_data %>%
          select(c(-"grocery.pharmacy",-"parks",-"transitstations",-"workplace",-"residential"))), target = "retail.recreation")
  learner = lrn("regr.ranger")
  train_set = c(1:train_end_id)
  test_set = c((train_end_id+1):google_end_id)
  learner$train(task, row_ids = train_set)
  prediction = learner$predict(task, row_ids = test_set)
  abs(prediction$truth-prediction$response)
  df_lastweek = data.frame(id=prediction$row_ids,retail.recreation=(abs(prediction$truth-prediction$response)))
  train_set = c(1:google_end_id)
  test_set = setdiff(seq_len(task$nrow), train_set)
  learner$train(task, row_ids = train_set)
  prediction = learner$predict(task, row_ids = test_set)
  mobility_data[test_set,"retail.recreation"] = prediction$response

  # grocery.pharmacy
  task = TaskRegr$new(id = "grocery.pharmacy", backend = as.data.frame(mobility_data %>%
                                                                          select(c(-"retail.recreation",-"parks",-"transitstations",-"workplace",-"residential"))),
                      target ="grocery.pharmacy")
  learner=lrn("regr.ranger")
  train_set = c(1:train_end_id)
  test_set = c((train_end_id+1):google_end_id)
  learner$train(task, row_ids = train_set)
  prediction = learner$predict(task, row_ids = test_set)
  abs(prediction$truth-prediction$response)
  df_lastweek=cbind(df_lastweek,data.frame(grocery.pharmacy=(abs(prediction$truth-prediction$response)) ))
  train_set = c(1:google_end_id)
  test_set = setdiff(seq_len(task$nrow), train_set)
  learner$train(task, row_ids = train_set)
  prediction = learner$predict(task, row_ids = test_set)
  mobility_data[test_set,"grocery.pharmacy"]=prediction$response

  # parks
  task = TaskRegr$new(id = "parks", backend = as.data.frame(mobility_data %>%
                                                              select(c(-"retail.recreation",-"grocery.pharmacy",-"transitstations",-"workplace",-"residential"))),
                      target ="parks")
  learner=lrn("regr.ranger")
  train_set = c(1:train_end_id)
  test_set = c((train_end_id+1):google_end_id)
  learner$train(task, row_ids = train_set)
  prediction = learner$predict(task, row_ids = test_set)
  abs(prediction$truth-prediction$response)
  df_lastweek=cbind(df_lastweek,data.frame(parks=(abs(prediction$truth-prediction$response)) ))
  train_set = c(1:google_end_id)
  test_set = setdiff(seq_len(task$nrow), train_set)
  learner$train(task, row_ids = train_set)
  prediction = learner$predict(task, row_ids = test_set)
  mobility_data[test_set,"parks"]=prediction$response

  # transitstations
  task = TaskRegr$new(id = "transitstations", backend = as.data.frame(mobility_data %>%
                                                                        select(c(-"retail.recreation",-"grocery.pharmacy",-"parks",-"workplace",-"residential"))),
                      target ="transitstations")
  learner=lrn("regr.ranger")
  train_set = c(1:train_end_id)
  test_set = c((train_end_id+1):google_end_id)
  learner$train(task, row_ids = train_set)
  prediction = learner$predict(task, row_ids = test_set)
  abs(prediction$truth-prediction$response)
  df_lastweek=cbind(df_lastweek,data.frame(transitstations=(abs(prediction$truth-prediction$response)) ))
  train_set = c(1:google_end_id)
  test_set = setdiff(seq_len(task$nrow), train_set)
  learner$train(task, row_ids = train_set)
  prediction = learner$predict(task, row_ids = test_set)

  mobility_data[test_set,"transitstations"]=prediction$response

  # workplace
  task = TaskRegr$new(id = "workplace", backend = as.data.frame(mobility_data %>%
                                                                  select(c(-"retail.recreation",-"grocery.pharmacy",-"parks",-"transitstations",-"residential"))),
                      target ="workplace")
  learner=lrn("regr.ranger")
  train_set = c(1:train_end_id)
  test_set = c((train_end_id+1):google_end_id)
  learner$train(task, row_ids = train_set)
  prediction = learner$predict(task, row_ids = test_set)
  abs(prediction$truth-prediction$response)
  df_lastweek=cbind(df_lastweek,data.frame(workplace=(abs(prediction$truth-prediction$response)) ))
  train_set = c(1:google_end_id)
  test_set = setdiff(seq_len(task$nrow), train_set)
  learner$train(task, row_ids = train_set)
  prediction = learner$predict(task, row_ids = test_set)
  mobility_data[test_set,"workplace"]=prediction$response

  # residential
  task = TaskRegr$new(id = "residential", backend = as.data.frame(mobility_data %>%
                                                                  select(c(-"retail.recreation",-"grocery.pharmacy",-"parks",-"transitstations",-"workplace"))),
                      target ="residential")
  learner=lrn("regr.ranger")
  train_set = c(1:train_end_id)
  test_set = c((train_end_id+1):google_end_id)
  learner$train(task, row_ids = train_set)
  prediction = learner$predict(task, row_ids = test_set)
  abs(prediction$truth-prediction$response)
  df_lastweek=cbind(df_lastweek,data.frame(residential=(abs(prediction$truth-prediction$response)) ))
  train_set = c(1:google_end_id)
  test_set = setdiff(seq_len(task$nrow), train_set)
  learner$train(task, row_ids = train_set)
  prediction = learner$predict(task, row_ids = test_set)
  mobility_data[test_set,"residential"]=prediction$response

  mobility_data$date=dates

  # error analysis
  df_raw_error=copy(df_lastweek)
  print("Error last week")
  print(df_raw_error %>% summarise(retail.recreation=mean(retail.recreation),
                            grocery.pharmacy=mean(grocery.pharmacy),
                            parks=mean(parks),transitstations=mean(transitstations),
                            workplace=mean(workplace),residential=mean(residential)
                            ))
  df_lastweek=df_lastweek %>% pivot_longer(  c("retail.recreation","grocery.pharmacy","parks","transitstations","workplace","residential")
,names_to = "cat",values_to = "error")

  return(mobility_data)
}

# case-mortality table
d <- read.csv("../modelInput/ILCaseAndMortalityV1.csv", stringsAsFactors = FALSE)
d$countryterritoryCode <- sapply(d$countryterritoryCode, as.character)
d$countryterritoryCode <- sub("840", "", d$countryterritoryCode)
codeToName <- unique(data.frame("countyCode" = d$countryterritoryCode, "countyName" = d$countriesAndTerritories))

f <- forecast_googleMob(codeToName=codeToName)
google_forecast <- f %>% select(state,retail.recreation,grocery.pharmacy,parks,transitstations,workplace,residential,date)
write.csv(google_forecast, "../modelInput/mobility/google-mobility-forecast.csv", row.names = FALSE)


#--------------------------------------------------------------------------------
# Name:         IBM_MonteCarlo.r
# Purpose:      MonteCarlo Simulation. Stand-alone script.
# Author:       Francesco Tonini
# Email: 	    f_tonini@hotmail.com
# Created:      11/10/2011
# Copyright:    (c) 2011 by Francesco Tonini
# License:    	GNU General Public License (GPL)
# Software:     Tested successfully using R-2.14.0 64-bit version(http://www.r-project.org/)
#-----------------------------------------------------------------------------------------

##Define the main working directory
##Make sure to specify the appropriate path using either / or \\ to specify the path
mainDir <- '~/Desktop/Temp'

##Let's set the working directory
setwd(file.path(mainDir))

#Path to folders in which you want to save all your vector & raster files
workdir_Raster <- 'Raster'

##Create a physical copy of the subdirectory folder(s) where you save your output
##If the directory already exists it gives a warning, BUT we can suppress it using showWarnings = FALSE
dir.create(file.path(mainDir, workdir_Raster), showWarnings = FALSE)

##Use an external source file w/ all modules (functions) used within this script.
##Use FULL PATH if source file is not in the same folder w/ this script
source('myfunctionsMC.R')

##Load all required libraries
print('Loading required libraries...')
load.packages()

###Let's set all simulation parameters:

##Number of Monte Carlo runs
cat('\nHow many MonteCarlo simulation runs?\n')
NRuns <- scan(n=1)

##First Year of Simulation (input from terminal console)
cat('\nWhat is the first year of simulation?\n')
start_time <- scan(n=1)

##Last Year of Simulation (input from terminal console)
cat('\nWhat Is The Last Year Of Simulation?\n')
end_time <- scan(n=1)
while(end_time < start_time) {
	tkmessageBox(title = "Warning", message = 'The last year of simulation cannot be inferior to the first year!...Please type again'
				, icon = "warning", type = "ok")
	end_time <- scan(n=1)
}

##Set the age at which colonies start producing first swarmers
cat('\nAt what age do colonies generate the first swarmers?\n')
ColAge_swarmers <- scan(n=1)

##Set the maximum life expectancy for a colony (input from terminal console)
cat('\nWhat is the maximum life expectancy of a colony (in years)?\n')
MaxAge <- scan(n=1)

##Apply a radius representing the max attraction distance btw Males & Females
cat('\nType max attraction distance between males & females (in meters)?\n')
radius <- scan(n=1)
while(radius == 0) {
	tkmessageBox(title = "Warning", message = 'The attraction distance must be > 0!...Please type again'
				, icon = "warning", type = "ok")
	radius <- scan(n=1)
}

##Read background non-suitable habitat layer
habitat_block <- read.NSHabitat()

##Read the Input File w/ Starting Points (colonies)
##By default it assigns a random age to all input colonies
starting_colonies <- read.file(random.age = 'random')

##Check habitat suitability and remove colonies falling within non-suitable habitat
starting_colonies <- habitat.survival(starting_colonies)

##Define a Simulation Extent
extent <- simulation.extent()

##Check for max density of source colonies, based on the user input
##This module returns a list (to access list elements use $ sign)
cat('\nType the maximum colony density in colonies per hectare (1ha = 100 sq. meters)\n')
maxdensity <- scan(n=1)
lst <- max.density.source()

##lst is a list with outputs returned by the max.density.source() module
starting_colonies <- lst$starting_colonies
maxdensity <- lst$maxdensity

##Create a database to store occupied areas over time & across all MC simulation runs
area.dataset <- as.data.frame(matrix(0,ncol=1,nrow=NRuns))
colnames(area.dataset) <- start_time
rownames(area.dataset) <- paste('Run',seq(NRuns),sep='')

##If we only have ONE source of invasion, define an empty vector in which we will store the
##mean Eucl. dist. of all existing colonies from it, at each time step
if (nrow(starting_colonies) == 1) {
	avgdistSource <- as.data.frame(matrix(0,ncol=1,nrow=NRuns))
	colnames(avgdistSource) <- start_time
	rownames(avgdistSource) <- paste('Run',seq(NRuns),sep='')
}

##Create a Tk window element as a container
root <- tktoplevel()
tktitle(root) <- 'MonteCarlo Simulation'

##Define the label of the first progress bar
l1 <- tk2label(root)
##Define the length of the first progress bar
pb1 <- tk2progress(root, length = 300)
##Configure the first progress bar's max value (min is always = 0)
##Max will be the number of MC simulation runs - 1 (since index starts at 0)
tkconfigure(pb1, value=0, maximum = NRuns-1)

##Define the label of the second progress bar
l2 <- tk2label(root)
##Define the length of the second progress bar
pb2 <- tk2progress(root, length = 300)
##Configure the second progress bar's max value (min is always = 0)
##Max will be the number of subdivisions - 1 (since index starts at 0)
tkconfigure(pb2, value=0, maximum = 2)

##Pack all labels and progress bars inside the Tk container
tkpack(l1)
tkpack(pb1)
tkpack(l2)
tkpack(pb2)

##Refresh the Tk window
tcl('update')

##LOOP for each MC simulation run
for (run in seq(NRuns)){

	##Configure the MC Runs progress bar by updating its label and current value
	tkconfigure(l1, text = paste('Run', run))
    tkconfigure(pb1, value = run - 1)

	##Let's now create an object called colonies (we do not delete starting_colonies because it can still be used)
	colonies <- starting_colonies

	##LOOP for each year of simulation
	for (year in seq(start_time,end_time)){

		tkconfigure(l2, text = paste('Year',year))
        tkconfigure(pb2, value = 0)
		tcl('update')

		if (year == start_time) {

			##Estimate the approx. area covered by current colonies in Km^2
			##If writeRas=TRUE a raster file (.img or as defined in source file) is produced
			Tot_area <- raster.save(colonies,year,writeRas=TRUE)
			area.dataset[run,year-start_time+1] <- Tot_area
			colnames(area.dataset)[year-start_time+1] <- year

			##Remove objects not needed from the memory
			rm(Tot_area)

			##Update progress bar (move progress segment to the end of the bar)
			tkconfigure(pb2, value = 2)
			tcl('update')

		}else{

			##Increase Age and Timecount by 1
			colonies <- age.increase()

			##Only keep current colonies (remove the past year)
			colonies <- colonies[which(colonies$Timecount == year),]

			##Colonies older than MaxAge die (i.e. removed from dataset)
			if (length(which(colonies$Age > MaxAge)) > 0) colonies = colonies[-which(colonies$Age > MaxAge),]

			##Generate offspring for each existing colony
			##Change the scenario to 'pessimistic' if colonies generate more individuals at a younger age
			##(other scenarios can be defined within the script 'myfunctionsMC.R' and can be manually changed)
			if (any(colonies$Age >= ColAge_swarmers)) {

				out <- offspring.generate(survival_prob = 0.01, male_prob = 0.5, scenario = 'optimistic', dist.mean = 200)
				pop <- out$pop
				flag <- out$flag

				##flag = 1 if ONE or MORE individuals crossed the simulation boundaries
				##If flag is not NULL print a warning on screen, EXIT (break) the loop and move to the next MC simulation run
				if (!is.null(flag)) {

					cat('\n')
					cat('WARNING: ONE OR MORE INDIVIDUALS LAY OUTSIDE THE SIMULATION EXTENT!!\n')
					cat(paste('The Current & All Following Simulation Runs Will Be Terminated Before Year: ',year,'\n',sep=''))
					cat('\n')
					maxyear <- year - 1

					##Overwrite end_time with a value corresponding to the current year - 1
					##so that in the next MC run the simulation will stop at the same year
					##This is done to be able to compare across MC runs for same years
					end_time <- maxyear

					##EXIT the inner loop and go to the next MC simulation run
					break

				}

			}else{ out <- NULL }

			##Configure the progress bar by updating its value
			##(the green bar will move 1 segment forward)
			tkconfigure(pb2, value = 1)
			tcl('update')

			##Only if there are AT LEAST two swarmers check for Male-Female within a 'radius' buffer
			if (!is.null(out)){

				##Check for Male-Female within a 'radius' buffer
				new_colonies <- new.colonies.create()

				##Store new colonies in the main colony dataset
				if (nrow(new_colonies) > 0) {

					colonies <- new.colonies.stack()

					##Check habitat suitability of current colonies
					colonies <- habitat.survival(colonies)

					##Uncomment one of the following modules when having only ONE source of invasion
					##and you are interested in keeping ONLY colonies laying on the fringe:
					##colonies <- convex.hull(colonies)

					##If there are no colonies left exit the LOOP, set the new end_time to the current year
					##and EXIT the LOOP
					if (nrow(colonies) == 0) {
						print(paste('No colonies survived at year', year))
						Tot_area <- raster.save(colonies,year,writeRas=TRUE)
						area.dataset[run,year-start_time+1] <- Tot_area
						colnames(area.dataset)[year-start_time+1] <- year
						maxyear <- year
						end_time <- maxyear
						##EXIT the inner loop and go to the next MC simulation run
						break
					}

				}

				##Remove objects not needed from the memory
				rm(list=c('pop', 'new_colonies'))
			}

			##Configure the progress bar by updating its value
			##(the green bar will move 1 segment forward)
			tkconfigure(pb2, value = 2)
			tcl('update')

			##Estimate the approx. area covered by current colonies in Km^2
			##If writeRas=TRUE a raster file (.img or as defined in source file) is produced
			Tot_area <- raster.save(colonies,year,writeRas=TRUE)
			area.dataset[run,year-start_time+1] <- Tot_area
			colnames(area.dataset)[year-start_time+1] <- year

			##If we are starting with ONE source of invasion, calculate the mean Eucl. dist. of all colonies
			##from the source
			if (nrow(starting_colonies) == 1) {
				avgdistSource[run,year-start_time+1] <- dist.source(colonies)
				colnames(avgdistSource)[year-start_time+1] <- year
			}

			##Remove objects not needed from the memory
			rm(Tot_area)

		}

	}

	save.image()
}

#Final message of simulation is over
tkmessageBox(title = "Message", message = 'The simulation is over!', icon = "info", type = "ok")

##Suppress the progress bar
tkdestroy(root)

##Print on screen a summary of statistics across all MC runs
summary.stats()

##Ask whether the user wants to compute and save an 'occupancy envelope' or not
envelope.raster()


    offset.time = function (x, ny=1) { # take data from previous year-class and year (i.e., previous data from the same cohort)
      dx = dim(x)
      if (!is.null(dx) ) {
        n.ageclass = dim(x)[1]
        n.years = dim(x)[2]
        i.years = c(1:n.years)
        i.y.offset = i.years - ny
        i.y.offset = i.y.offset[ i.y.offset >= 1 ]
        i.ageclass = c(1:n.ageclass)
        i.ac.offset = i.ageclass - ny
        i.ac.offset = i.ac.offset[ i.ac.offset >= 1 ]
        y = x * NA # initialise
        y[ (ny+1):n.ageclass, (ny+1):n.years] = x[i.ac.offset, i.y.offset]
      } else {
        n.ageclass = length(x)
        i.ageclass = c(1:n.ageclass)
        i.ac.offset = i.ageclass - ny
        i.ac.offset = i.ac.offset[ i.ac.offset >= 1 ]
        y = x * NA # initialise
        y[ (ny+1):n.ageclass ] = x[i.ac.offset]
      }

      return(y)
    }


# Title: tickerFns.r
# Objective: central script with most common ticker functions
# Created by: NR
# Additional editors:

# Those originally written for retrieveAnalyzeAlert.r

benchmark <- function(tickers, from, to){
  getSymbols(tickers, from = "2017-10-01", to = end, src='yahoo')
  # getSymbols(tickers, from = "2017-10-01", to = end, src='google', return.class="data.frame")

  # Consolodate ticker data to facilitate easier analysis:
  summ <- NULL
  for (i in tickers) {
    tmp <- get(i)
    tmp <- as.data.frame(tmp)
    names(tmp) <- gsub(names(tmp),pattern="^.+\\.(.*)",replacement="\\1")
    tmp$ticker <- i
    tmp$date <- as.POSIXct(rownames(tmp))
    summ <- rbind(summ,tmp)
    rm(tmp)
  }

  # Get historical baselines:
  # smfn <- function(dat, response, aggvar, smfn) {
  #   tmp01 <- with(dat,aggregate(x=list()))
  # }

  hdat <- read.csv(file='collect.csv',header=T)
  hdat$Trade.Time <- as.POSIXct(hdat$Trade.Time)
  hdat$day <- as.POSIXct(strptime(hdat$Trade.Time, format="%F"))
  hsumm01 <- with(hdat,aggregate(x=list(sd.daily=Last),by=list(day=day,ticker=ticker),FUN=function(x) sd(x,na.rm=T)))
  hsumm11 <- with(hsumm01,aggregate(x=list(med.daily.sd=sd.daily),by=list(ticker=ticker),FUN=median))
  # hsumm12 <- with(hsumm01,aggregate(x=list(q25.daily.sd=sd.daily),by=list(ticker=ticker),FUN=function(x) quantile(x,probs=.25)))
  # hsumm13 <- with(hsumm01,aggregate(x=list(q75.daily.sd=sd.daily),by=list(ticker=ticker),FUN=function(x) quantile(x,probs=.75)))

  hsumm02 <- with(hdat,aggregate(x=list(mn.daily=Last),by=list(day=day,ticker=ticker),FUN=function(x) mean(x,na.rm=T)))
  hsumm21 <- with(hsumm02, aggregate(x=list(med.mn.daily=mn.daily),by=list(ticker=ticker),FUN=median))
  # hsumm22 <- with(hsumm02,aggregate(x=list(q25.daily.mn=mn.daily),by=list(ticker=ticker),FUN=function(x) quantile(x,probs=.25)))
  # hsumm23 <- with(hsumm02,aggregate(x=list(q75.daily.mn=mn.daily),by=list(ticker=ticker),FUN=function(x) quantile(x,probs=.75)))

  hsumm <- merge(hsumm11,hsumm21,by='ticker',all=T)
  hsumm$cvhat <- with(hsumm,med.daily.sd/med.mn.daily)
  # hsumm <- merge(hsumm,hsumm12,by='ticker',all=T)
  # hsumm <- merge(hsumm,hsumm13,by='ticker',all=T)
  # hsumm <- merge(hsumm,hsumm22,by='ticker',all=T)
  # hsumm <- merge(hsumm,hsumm23,by='ticker',all=T)
  # hsumm$skewRatio <- with(hsumm, (q75.daily.mn-med.mn.daily)/(med.mn.daily-q25.daily.mn)) # do not use this, calculate each day, then take the median!
  return(list(baseline=hsumm))
  }

openStatus <- function(pos){
  pos$pre.closed <- with(pos,ifelse(type=='sell',-1,NA))
  pos$pre.closed <- with(pos,ifelse(type=='acquire',1,pre.closed))
  closed <- with(pos,aggregate(x=list(pre.closed=count*pre.closed),by=list(basis.id=basis.id),FUN=sum))
  closed$closed <- with(closed,ifelse(pre.closed==0,1,0))
  pos <- merge(pos,closed[,c('basis.id','closed')],by='basis.id',all.x=T)
  pos <- pos[,-which(names(pos)=='pre.closed')]
  return(pos)
}

identify <- function(tickers, baseline, position, tactAcqFn, tactTurnFn, sThreshold=1){
  eval.obj <-
    getQuote(tickers,
      what=yahooQF(c("Open", "Trade Time", "Last Trade (Price Only)","Volume"))
    )
  eval.obj$ticker <- rownames(eval.obj)
  # browser()
  eval.acq <- merge(eval.obj,baseline,by='ticker',all.x=T)
  eval.turn <- merge(position, eval.obj, by.x='position', by.y='ticker', all.x=T)
  eval.turn <- merge(eval.turn,baseline, by.x='position', by.y='ticker', all.x=T)

  # eval.acq <- openStatus(eval.acq)
  eval.turn <- openStatus(eval.turn)
  # Identify candidates for purchase
  evaluated.acq <- tactAcqFn(eval.acq)
  evaluated.turn <- tactTurnFn(eval.turn,sThreshold=sThreshold)
  return(list(flagged.acq=evaluated.acq, flagged.turn=evaluated.turn))
}

proposeAcq <- function(position, eval, block.size, rpt=F) {
  liquid <- with(position,sum(cash.transaction))
  position <- openStatus(position)
  # browser()
  # Calculate target purchase size should a given ticker be chosen
  eval$count <- with(eval,ifelse(flag_buy,yes=floor(block.size/Last),no=0))
  # Simulate a 'buy'
  for(i in unique(na.omit(eval$ticker))) { # Please add a control to prevent second purchase in existing stake!
    tmp <- eval[which(eval$ticker==i),]
    if(tmp$flag_buy) {
      tmp.timestamp <- as.character(Sys.time())
      tmp.id <- max(position$id)+1
      proposed <- data.frame(timestamp=tmp.timestamp, id=tmp.id, position=tmp$ticker, count=tmp$count, basis.id=paste(strftime(tmp.timestamp,format="%F"),tmp.id,sep="_"), type='acquire', price=tmp$Last, cash.transaction=with(tmp,-count*Last))
      if(proposed$cash.transaction+liquid<0) break()
      if(!rpt & (proposed$position %in% position$position[which(position$closed==0)])) break()
      # browser()
      rt <- c('timestamp','id','position','count','basis.id','type','price','cash.transaction')
      position <- rbind(position[,rt],proposed[,rt])
    }
    liquid <- with(position,sum(cash.transaction))
    cat('\nLiquid:  ', liquid,'\n\n')
  }
  if('closed' %in% names(position)) position <- position[,-which(names(position)=='closed')]
  return(position)
}

proposeTurn <- function(position, flagged, block.size){
  position <- openStatus(position)
  for(i in unique(na.omit(flagged$position))) { # Please add a control to prevent second purchase in existing stake!
     # browser()
    tmp <- flagged[which(flagged$position==i & flagged$id==max(flagged$id[which(flagged$position==i)])),]
    tmp2 <- position[which(position$position==i & position$id==max(position$id[which(position$position==i)])),]
    if(tmp$flag_sell & (0 %in% position$closed[which(position$position==i)])) {
      tmp.timestamp <- as.character(Sys.time())
      tmp.id <- max(position$id)+1
      tmp.basis.id <- tmp$basis.id
      proposed <- data.frame(timestamp=tmp.timestamp, id=tmp.id, position=tmp$position, count=tmp2$count, basis.id=tmp.basis.id,  type='sell', price=tmp$Last, cash.transaction=with(tmp,count*Last))
      rt <- c('timestamp','id','position','count','basis.id','type','price','cash.transaction')
      position <- rbind(position[,rt],proposed[,rt])
    }
  }
  if('closed' %in% names(position)) position <- position[,-which(names(position)=='closed')]
  return(position)
}


# modified 3-29-10: Qunhua Li
# add 2 columns in the output of "-overlapped-peaks.txt": local.idr and IDR

# 01-20-2010 Qunhua Li
#
# This program performs consistency analysis for a pair of peak calling outputs
# It takes narrowPeak or broadPeak formats.
#
# usage: Rscript batch-consistency-analysis2.r peakfile1 peakfile2 half.width outfile.prefix overlap.ratio  is.broadpeak sig.value
#
# peakfile1 and peakfile2 : the output from peak callers in narrowPeak or broadPeak format
# half.width: -1 if using the reported peak width,
#             a numerical value to truncate the peaks to
# outfile.prefix: prefix of output file
# overlap.ratio: a value between 0 and 1. It controls how much overlaps two peaks need to have to be called as calling the same region. It is the ratio of overlap / short peak of the two. When setting at 0, it means as long as overlapped width >=1bp, two peaks are deemed as calling the same region.
# is.broadpeak: a logical value. If broadpeak is used, set as T; if narrowpeak is used, set as F
# sig.value: type of significant values, "q.value", "p.value" or "signal.value" (default, i.e. fold of enrichment)

args <- commandArgs(trailingOnly=T)

# consistency between peakfile1 and peakfile2
#input1.dir <- args[1]
#input2.dir <- args[2] # directories of the two input files
peakfile1 <- args[1]
peakfile2 <- args[2]

if(as.numeric(args[3])==-1){ # enter -1 when using the reported length
  half.width <- NULL
}else{
  half.width <- as.numeric(args[3])
}

output.prefix <- args[4]
overlap.ratio <- args[5]

if(args[6] == "T"){
  is.broadpeak <- T
}else{
  is.broadpeak <- F
}

sig.value <- args[7]

#dir1 <- "~/ENCODE/anshul/data/"
#dir2 <- dir1
#peakfile1 <- "../data/SPP.YaleRep1Gm12878Cfos.VS.Gm12878Input.PointPeak.narrowPeak"
#peakfile2 <- "../data/SPP.YaleRep3Gm12878Cfos.VS.Gm12878Input.PointPeak.narrowPeak"
#half.width <- NULL
#overlap.ratio <- 0.1
#sig.value <- "signal.value"

source("functions-all-clayton-12-13.r")

# read the length of the chromosomes, which will be used to concatenate chr's
chr.file <- "genome_table.txt"

chr.size <- read.table(chr.file)

sink(paste(output.prefix, "-Rout.txt", sep=""))

############# process the data
cat("is.broadpeak", is.broadpeak, "\n")
# process data, summit: the representation of the location of summit
rep1 <- process.narrowpeak(paste(peakfile1, sep=""), chr.size, half.width=half.width, summit="offset", broadpeak=is.broadpeak)
rep2 <- process.narrowpeak(paste(peakfile2, sep=""), chr.size, half.width=half.width, summit="offset", broadpeak=is.broadpeak)

cat(paste("read", peakfile1, ": ", nrow(rep1$data.ori), "peaks\n", nrow(rep1$data.cleaned), "peaks are left after cleaning\n", peakfile2, ": ", nrow(rep2$data.ori), "peaks\n", nrow(rep2$data.cleaned), " peaks are left after cleaning"))

if(args[3]==-1){
  cat(paste("half.width=", "reported", "\n"))
}else{
  cat(paste("half.width=", half.width, "\n"))
}
cat(paste("significant measure=", sig.value, "\n"))

# compute correspondence profile (URI)
uri.output <- compute.pair.uri(rep1$data.cleaned, rep2$data.cleaned, sig.value1=sig.value, sig.value2=sig.value, overlap.ratio=overlap.ratio)

#uri.output <- compute.pair.uri(rep1$data.cleaned, rep2$data.cleaned)

cat(paste("URI is done\n"))

# save output
save(uri.output, file=paste(output.prefix, "-uri.sav", sep=""))
cat(paste("URI is saved at: ", output.prefix, "-uri.sav \n", sep=""))

# EM procedure for inference
em.output <- fit.em(uri.output$data12.enrich, fix.rho2=T)

#em.output <- fit.2copula.em(uri.output$data12.enrich, fix.rho2=T, "gaussian")

cat(paste("EM is done\n\n"))

save(em.output, file=paste(output.prefix, "-em.sav", sep=""))
cat(paste("EM is saved at: ", output.prefix, "-em.sav \n", sep=""))

# write em output into a file

cat(paste("EM estimation for the following files\n", peakfile1, "\n", peakfile2, "\n", sep=""))

print(em.output$em.fit$para)

# add on 3-29-10
# output both local idr and IDR
idr.local <- 1-em.output$em.fit$e.z
IDR <- c()
o <- order(idr.local)
IDR[o] <- cumsum(idr.local[o])/c(1:length(o))

write.out.data <- data.frame(chr1=em.output$data.pruned$sample1[, "chr"],
                    start1=em.output$data.pruned$sample1[, "start.ori"],
                    stop1=em.output$data.pruned$sample1[, "stop.ori"],
                    sig.value1=em.output$data.pruned$sample1[, "sig.value"],
                    chr2=em.output$data.pruned$sample2[, "chr"],
                    start2=em.output$data.pruned$sample2[, "start.ori"],
                    stop2=em.output$data.pruned$sample2[, "stop.ori"],
                    sig.value2=em.output$data.pruned$sample2[, "sig.value"],
                    idr.local=1-em.output$em.fit$e.z, IDR=IDR)

write.table(write.out.data, file=paste(output.prefix, "-overlapped-peaks.txt", sep=""))
cat(paste("Write overlapped peaks and local idr to: ", output.prefix, "-overlapped-peaks.txt\n", sep=""))

# number of peaks passing IDR range (0.01-0.25)
IDR.cutoff <- seq(0.01, 0.25, by=0.01)
idr.o <- order(write.out.data$idr.local)
idr.ordered <- write.out.data$idr.local[idr.o]
IDR.sum <- cumsum(idr.ordered)/c(1:length(idr.ordered))

IDR.count <- c()
n.cutoff <- length(IDR.cutoff)
for(i in 1:n.cutoff){
  IDR.count[i] <- sum(IDR.sum <= IDR.cutoff[i])
}

# write the number of peaks passing various IDR range into a file
idr.cut <- data.frame(peakfile1, peakfile2, IDR.cutoff=IDR.cutoff, IDR.count=IDR.count)
write.table(idr.cut, file=paste(output.prefix,"-npeaks-aboveIDR.txt", sep=""), append=T, quote=F, row.names=F, col.names=F)
cat(paste("Write number of peaks above IDR cutoff [0.01, 0.25]: ","npeaks-aboveIDR.txt\n", sep=""))

mar.mean <- get.mar.mean(em.output$em.fit)

cat(paste("Marginal mean of two components:\n"))
print(mar.mean)

sink()


makeUmapClusters	<- function( seuratObj, umapDim, myResolution){

# this snipper runs Seurat tool FindClusters in the UMAP image space and identify control cluster types by
# control cells or marker genes

require("Seurat")
source("R/getClusterTypes.r")

#pcaDim			<- 6
seuratObj 		<- FindClusters( seuratObj, reduction.type = 'umap',
					dims.use = 1:umapDim,
					k.param = 15, print.output = FALSE, force.recalc = TRUE, save.SNN = TRUE,
					resolution = myResolution)

clTypes 		<- getClusterTypes(seuratObj)
levels(seuratObj@ident) <- names(clTypes)
seuratObj		<- StashIdent( seuratObj, save.name = paste0( umapDim, "D_UMAP_res_", myResolution))
return(seuratObj)

}