##functions providng various diagnostics for evaluating model assumptions and stability and
#for helping with setting an appropriate random slopes structure for (G)LMMs
#written by Roger Mundry, last modified early 2016
ranef.diagn.plot<-function(model.res, QQ=F, col=grey(0.5, alpha=0.75)){
  old.par = par(no.readonly = TRUE)
	if(class(model.res)[[1]]!="glmmTMB"){
		n.plots=sum(unlist(lapply(ranef(model.res), length)))
	}else{
		n.plots=sum(unlist(lapply(ranef(model.res)[["cond"]], ncol)))+sum(unlist(lapply(ranef(model.res)[["zi"]], ncol)))
	}
	x=ifelse(n.plots%%2==1,n.plots+1,n.plots)
	xmat=outer(1:x, 1:(1+x/2), "*")-n.plots
	colnames(xmat)=1:(1+x/2)
	rownames(xmat)=1:x
	xmat=as.data.frame(as.table(xmat))
	xmat=subset(xmat, as.numeric(as.character(xmat$Var1))>=as.numeric(as.character(xmat$Var2)) & xmat$Freq>=0)
	sum.diff=as.numeric(as.character(xmat$Var1))-as.numeric(as.character(xmat$Var2))+xmat$Freq
	xmat=xmat[sum.diff==min(sum.diff),]
	xmat=xmat[which.min(xmat$Freq),]
	par(mfrow=c(xmat$Var2, xmat$Var1))
	par(mar=c(rep(2, 3), 1))
	par(mgp=c(1, 0.5, 0))
	xnames=lapply(ranef(model.res), names)
	xnames=lapply(xnames, gsub, pattern="(Intercept)", replacement="icpt", fixed=T)
	if(class(model.res)[[1]]!="glmmTMB"){
		for(i in 1:length(ranef(model.res))){
			to.plot=ranef(model.res)[[i]]
			for(k in 1:ncol(to.plot)){
				if(QQ){
					qqnorm(to.plot[,k], main="", tcl=-0.25, xlab="", ylab="", pch=19, col=col)
					qqline(to.plot[,k])
				}else{
					hist(to.plot[,k], main="", tcl=-0.25, xlab="", ylab="", col=NA)
				}
				mtext(text=paste(c(names(ranef(model.res)[i]), xnames[[i]][k]), collapse="_"), side=3)
			}
		}
	}else{
		for(i in c("cond", "zi")){
			if(length(ranef(model.res)[[i]])>0){
				for(j in 1:length(ranef(model.res)[[i]])){
					to.plot=ranef(model.res)[[i]][[j]]
					for(k in 1:ncol(to.plot)){
						if(QQ){
							qqnorm(to.plot[,k], main="", tcl=-0.25, xlab="", ylab="", pch=19, col=col)
							qqline(to.plot[,k])
						}else{
							hist(to.plot[,k], main="", tcl=-0.25, xlab="", ylab="", col=NA)
						}
						mtext(text=paste(c(names(ranef(model.res)[i]), names(ranef(model.res)[[i]][j]), colnames(to.plot)[k]), collapse=", "), side=3)
					}
				}
			}
		}
	}
	par(old.par)
}

diagnostics.plot<-function(mod.res, col=grey(level=0.25, alpha=0.5), size.fac=1, weights=NULL){
	if(is.null(weights)){
		if(class(mod.res)[[1]]=="lm" | class(mod.res)[[1]]=="glm"){
			weights=mod.res$model$"(weights)"
			if(is.null(weights)){weights=rep(1, length(residuals(mod.res)))}
		}else if(class(mod.res)[[1]]=="lmerMod"){
			weights=mod.res@resp$weights
		}else{
			weights=rep(1, length(residuals(mod.res)))
		}
	}
	weights=size.fac*weights/max(weights)
  old.par = par(no.readonly = TRUE)
  par(mfrow=c(2, 2))
  par(mar=c(3, 3, 1, 0.5))
  hist(residuals(mod.res), probability=T, xlab="", ylab="", main="", col=NA)
  mtext(text="histogram of residuals", side=3, line=0)
  x=seq(min(residuals(mod.res)), max(residuals(mod.res)), length.out=100)
  lines(x, dnorm(x, mean=0, sd=sd(residuals(mod.res))))
  qqnorm(residuals(mod.res), main="", pch=19, col=col, cex=sqrt(weights))
  qqline(residuals(mod.res))
  mtext(text="qq-plot of residuals", side=3, line=0)
  plot(fitted(mod.res), residuals(mod.res), pch=19, col=col, cex=sqrt(weights))
  abline(h=0, lty=2)
  mtext(text="residuals against fitted values", side=3, line=0)
  par(old.par)
}

lev.thresh<-function(model.res){
	k=length(coefficients(model.res))
	n=length(residuals(model.res))
 return(2*(k+1)/n)
}

overdisp.test<-function(x){
	##last updated Nov 26 2019
	##additions/changes: bugfix for zeroinfl; deals with glmmTMB (beta and nbinom family)
	##function needed for Gamma family:
	gamma.par.transf<-function(mean=NULL, var=NULL, shape=NULL, scale=NULL){
		##parameterizations are
			##shape and scale
			##shape and mean
			##var and mean
		if(is.null(mean) & is.null(var) & !is.null(shape) & !is.null(scale)){
			mean=shape*scale
			var=shape*scale^2
		}else if(is.null(shape) & is.null(scale) & !is.null(mean) & !is.null(var)){
			scale=var/mean
			shape=mean/scale
		}else if(is.null(scale) & is.null(var) & !is.null(shape) & !is.null(mean)){
			scale=mean/shape
			var=shape*scale^2
		}else{
			stop("unsupported parameter combination")
		}
		return(list(shape=as.vector(shape), scale=as.vector(scale),  mean=as.vector(mean), var=as.vector(var)))
	}

  if(class(x)[[1]]!="glmmTMB"){
		pr=residuals(x, type ="pearson")
		sum.dp=sum(pr^2)
	}
  n.model.terms=NULL
  if(class(x)[[1]]=="glmerMod"){
    n.model.terms=length(fixef(x))+nrow(as.data.frame(summary(x)$varcor))
    if(grepl(x=as.character(x@call)[4], pattern="negative.binomial") | grepl(x=as.character(x@call)[4], pattern="Gamma")){n.model.terms=n.model.terms+1}
	}else if(class(x)[[1]]=="glm" | class(x)[[1]]=="negbin"){
    n.model.terms=length(x$coefficients)
    n.model.terms=n.model.terms+length(summary(x)$theta)
  }else if(class(x)[[1]]=="zeroinfl"){
		n.model.terms=sum(unlist(lapply(x$coefficients, length)))
		n.model.terms=n.model.terms+length(summary(x)$theta)
  }else if(class(x)[[1]]=="betareg"){
		n.model.terms=sum(unlist(lapply(x$coefficients, length)))
  }else if(class(x)[[1]]=="glmmTMB"){
		print("caution: support for models of class glmmTMB is experimental and embryonic")
		print("and don't worry if it takes some time")
		#browser()
		#n.model.terms=sum(unlist(lapply(fixef(x), length)))+nrow(extract.ranef.from.glmmTB(x))
		n.model.terms=sum(unlist(lapply(fixef(x), length)))##fixed effects
		n.model.terms=n.model.terms+sum(unlist(lapply(summary(x)$varcor, function(y){
			if(!is.null(y)){
				lapply(y, function(yy){
					xx=dim(attr(yy, "correlation"))
					return((xx[1]^2-xx[1])/2+length(attr(yy, "stddev")))
				})
			}else{
				0
			}
		})))
		if((grepl(x=x$modelInfo$family$family, pattern="nbinom") | x$modelInfo$family$family=="beta") &
			length(attr(terms(x$call$dispformula), "term.labels"))==0){
			#n.model.terms=n.model.terms+1
			##but maybe it needs to be done for negbin??? need to check this
		}
		pr=residuals(x, type ="response")
		if(x$modelInfo$family$family=="poisson"){
			fitted.var = fitted(x)
		}else{
			#model.terms=attr(terms(x$call$dispformula), "term.labels")#attr(terms(x$call$dispformula), "intercept")
			sigma.f=exp(as.vector(model.matrix(object=x$call$dispformula, data=x$frame)[, names(fixef(x)$disp), drop=F]%*%fixef(x)$disp))
			if(x$modelInfo$family$family=="nbinom2"){
				fitted.var = fitted(x)*(1+fitted(x)/sigma.f)#fitted(x) + fitted(x)^2/sigma(x)
			}else if(x$modelInfo$family$family=="nbinom1"){
				fitted.var = fitted(x)*(1+sigma.f)#fitted(x) + fitted(x)/sigma(x)
			}else if(x$modelInfo$family$family=="beta"){
				xfitted=fitted(x)
				shape1 = xfitted * sigma.f
				shape2 = (1 - xfitted) * sigma.f
				#xfitted(1-xfitted)/(1+sigma(x))#according to the glmmTMB help page for sigma
				fitted.var = shape1*shape2/((shape1+shape2)^2*(shape1+shape2+1))
			}else if(x$modelInfo$family$family=="Gamma"){
				#x.disp=exp(as.vector(model.matrix(object=x$call$dispformula, data=x$frame)%*%log(sigma(x))))
				xx=gamma.par.transf(mean=fitted(x), var=NULL, shape=1/sigma.f, scale=NULL)
				fitted.var = xx$var
				#xdf=length(residuals(x))-(length(coef(x))+1)
				#n.model.terms=sum(unlist(lapply(fixef(x), length)))+sum(unlist(lapply(summary(x)$varcor, function(y){length(as.data.frame(y))})))
				xdf=length(residuals(x))-n.model.terms
			}
		}
		#n.model.terms=sum(unlist(lapply(fixef(x), length)))+sum(unlist(lapply(summary(x)$varcor, function(y){length(as.data.frame(y))})))
		#xdf=length(pr)-n.model.terms
		sum.dp=sum((pr/sqrt(fitted.var))^2)
		#if(as.numeric(substr(sessionInfo()[["otherPkgs"]][["glmmTMB"]]$Version, start=1, stop=1))>0){
			#sum.dp=sum(residuals(x, type ="pearson")^2)
		#}
  }
  if(!is.null(n.model.terms)){
		xdf=length(pr)-n.model.terms
		return(data.frame(chisq=sum.dp, df=xdf, P=1-pchisq(sum.dp, xdf), dispersion.parameter=sum.dp/xdf))
	}else{
		print("model isn't of any of the currently supported classes (glm, negbin, zeroinfl, glmerMod, glmmTMB)")
	}
}

fe.re.tab<-function(fe.model, re, other.vars=NULL, data, treat.covs.as.factors=c(NA, F, T)){
	print("please read the documentation in the beginning of the script")
	#function helping in determinining which random slopes are needed
	#last updated: 2018, June 6
	#latest updates:
		#major revision of how interactions are treated; reveals in the summary
			#for combinations factors whether the number of observations is >1 (seperately for each level of the random effect)
			#for combination of covariates whether the number of unique combinations per level of random effect is >2
			#for combinations of factors and covariates whether the number unique values per covariate is larger than 2 (when treated as covariate)
				#or larger than 1 (when treated as a factor), separately for each commbination of levels of fixed and random effects factors
		#treat.covs.as.factors can be NA in which case covariates aretreates as such and as factors
			#this is the default now
		#output gives information about which fixed effects are covariates and factors aso for interactions
			#and also how covariates were treated
	#input/arguments:
		#data: a dataframe with all relevant variables (including the response)
		#fe.model: character; the model wrt the fixed effect (including the response); e.g., "r~f1*c*f2"
		#re: character; either a vector with the names of the random effects (e.g., c("re1", "re2")) or a random intercepts expression (e.g., "(1|re1)+(1|re2)")
		#other.vars: character, optional; a vector with the names of variables which are to be kept in the data considered and returned
		#treat.covs.as.factors: logical, when set to TRUE covariates will be treated like factors (see value/summary for details)
	#value: list with the following entries:
		#detailed: list with cross-tabulations ffor each combination of (main) fixed and random effect
		#summary: list tables...
			#telling for each combination of (main) fixed and random effect...
				#the number of levels of the random effect with a given number of unique values of the fixed effect (in case of a covariate)
				#the number of levels of the random effect with a given number of levels of the fixed effect for which at least two cases do exist (in case of a factor)
			#telling for each combination of interaction and random effect...
				#the combination of the above two informations, i.e., the number of individuals with a given number of unique values of the covariate
					#and a given number of factor levels for which at least two cases exist
		#data: data frame containing all relevant variables (i.e., response, fixed and random effects as well as those indicated in other.vars (e.g., offset terms)
			#also includes columns for dummy variables coding the levels (except the reference level) of all factors
		#pot.terms: length one vector comprising the model wrt the random slopes (for all combinations of fixed and random effects, i.e., most likely some will need to be omitted)
			#note that this comprises only the random slopes but not the correlations between random slopes and intercepts not the random intercept itself
		#pot.terms.with.corr: length one vector comprising the model wrt the random slopes (for all combinations of fixed and random effects, i.e., most likely some will need to be omitted)
			#note that this comprises the random slopes and intercepts  and also all correlations among them
	treat.covs.as.factors=treat.covs.as.factors[1]
	if(sum(grepl(x=re, pattern="", fixed=T))>0 & length(re)==1){#if random effects are handed over as formula
		re=gsub(x=re, pattern="(1|", replacement="", fixed=T)
		re=gsub(x=re, pattern=")", replacement="", fixed=T)
		re=gsub(x=re, pattern=" ", replacement="", fixed=T)
		re=unlist(strsplit(re, split="+", fixed=T))
	}
	fe.model=gsub(x=fe.model, pattern=" ", replacement="", fixed=T)#remove spaces
	model.terms=attr(terms(as.formula(fe.model)), "term.labels")#get individual terms from fixed effects model
	fe.me=model.terms[!grepl(x=model.terms, pattern=":", fixed=T)]#remove interactions
	fe.me=fe.me[!grepl(x=fe.me, pattern="^", fixed=T)]#remove squares terms
	resp=unlist(strsplit(fe.model, split="~", fixed=T))[1]#determine response
	if(substr(resp, start=1, stop=6)=="cbind("){
		resp=gsub(x=resp, pattern="cbind(", replacement="", fixed=T)
		resp=gsub(x=resp, pattern=")", replacement="", fixed=T)
		resp=gsub(x=resp, pattern=" ", replacement="", fixed=T)
		resp=unlist(strsplit(resp, split=",", fixed=T))
	}
	xx=setdiff(c(resp, fe.me, re, other.vars), names(data))
	if(length(xx)>0){
		stop(paste(c("error: preditor(s) missing in the data is/are ", paste(xx, collapse=", ")), collapse=""))
	}
	data=droplevels(as.data.frame(na.omit(data[, c(resp, fe.me, re, other.vars)])))#keep complete data wrt all relevant variables
	model.terms=model.terms[!grepl(x=model.terms, pattern="^", fixed=T)]#remove squares terms
	modes=rep(NA, length(model.terms))#initialize vector storing whether PVs are factors or not
	effect=c(rep("main", length(fe.me)), rep("int", length(model.terms)-length(fe.me)))#create vector telling for each model term whether it is a main effect of not
	for(i in 1:ncol(data)){#for all columns in data
		if(is.character(data[, i])){data[, i]=as.factor(data[, i])}#turn character column into factor
		modes[i]=class(data[, i])#and determine its class
	}
	names(modes)=names(data)#name 'm
	to.do=data.frame(expand.grid(re=re, fe=fe.me))#create data frame with one column for each combination of fixed main and random effect
	to.do$re=as.character(to.do$re)#reformat to character (for later addressing by name)
	to.do$fe=as.character(to.do$fe)#reformat to character (for later addressing by name)
	res.detailed=lapply(1:nrow(to.do), function(xrow){#create detailed results by lapply-ing over the rows of to.do
		table(data[,to.do$re[xrow]], data[,to.do$fe[xrow]])#cross tabulate the respective fixed and random effect
	})
	names(res.detailed)=paste(to.do$fe, to.do$re, sep="_within_")#name it
	modes=modes[as.character(to.do$fe)]
	modes=gsub(x=modes, pattern="integer", replacement="numeric")
	to.do$modes.cons=modes
	to.do$modes=modes
	if(is.na(treat.covs.as.factors) & any(to.do[, "modes.cons"]=="numeric")){
		xx=to.do[to.do[, "modes.cons"]=="numeric", ]
		xx["modes.cons"]="factor"
		to.do=rbind(to.do, xx)
		to.do=to.do[order(to.do[, "re"], to.do[, "fe"]), ]
	}else if(!is.na(treat.covs.as.factors) & treat.covs.as.factors){
		to.do$modes.cons="factor"
	}
	to.do=to.do[order(to.do$fe), ]
	res.summary=lapply(1:nrow(to.do), function(xrow){#begin with creating summary results by lapply-ing over the rows of to.do
		#browser()
		xwhat=paste(to.do[xrow, c("fe", "re")], collapse="_within_")
		if(to.do$modes.cons[xrow]!="factor"){#if fixed effect is not a factor
			ires=table(apply(res.detailed[[xwhat]]>0, 1, sum))#determine number of levels of the random effect per number of unique cases of the fixed effect
		}else{#if fixed effect is a factor
			ires=table(apply(res.detailed[[xwhat]]>1, 1, sum))#determine number of levels of the random effect per number of unique cases of the fixed effect with at least two observations
		}
		ires=c(ires, tot=nrow(res.detailed[[xwhat]]))
	})
	xx=to.do[, "modes.cons"]
	xx[xx=="numeric"]="covariate"
	xx[xx=="integer"]="covariate"
	xx[to.do[, "modes.cons"]!=to.do[, "modes"]]="covariate as factor"
	xx=paste("(", xx, ")", sep="")
	names(res.summary)=paste(paste(to.do$fe, to.do$re, sep="_within_"), xx, sep=" ")#name it
	#append 'factor' or 'covariate' to the names:
	#names(res.summary)[modes[to.do$fe]=="factor"]=paste(names(res.summary)[modes[to.do$fe]=="factor"], "(factor)", sep=" ")
	#names(res.summary)[!modes[to.do$fe]=="factor"]=paste(names(res.summary)[!modes[to.do$fe]=="factor"], "(covariate)", sep=" ")
	to.do=data.frame(expand.grid(re=re, int=setdiff(model.terms, fe.me)))#create data frame with one row for each combination of interaction and random effect
	if(nrow(to.do)>0){
		#add two columns denoting original mode:
		to.do$mode=unlist(lapply(strsplit(as.character(to.do$int), split=":", fixed=T), function(x){
			paste(modes[x], collapse=":")
		}))
		to.do$mode.cons=to.do$mode
		if(is.na(treat.covs.as.factors)){#if is.na(treat.covs.as.factors)
			xx=to.do[grepl(x=to.do$mode, pattern="numeric"), ]#add rows duplicating interactions involving covariates (to treat them as covariate and factor
			xx$mode.cons=gsub(x=xx$mode.cons, pattern="numeric", replacement="factor")
			to.do=rbind(to.do, xx)
			to.do=to.do[order(to.do$re, to.do$int), ]
		}else if(treat.covs.as.factors){#if treat.covs.as.factors
			to.do$mode.cons=gsub(x=to.do$mode.cons, pattern="numeric", replacement="factor")#change mode to be considered
		}
		to.do[, "int"]=as.character(to.do[, "int"])#reformat to character (for later addressing by name)
		to.do[, "re"]=as.character(to.do[, "re"])#reformat to character (for later addressing by name)
		##this needs to be rewritten!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		to.add=lapply(1:nrow(to.do), function(xrow){#treat combinations of fixed and random effect by lapply-ing over the rows of to.do
			#browser()
			iterms=unlist(strsplit(to.do[xrow, "int"], split=":", fixed=T))#determine main effects involved in the interaction...
			imodes=unlist(strsplit(to.do[xrow, "mode.cons"], split=":", fixed=T))#... and their classes
			imodes.orig=unlist(strsplit(to.do[xrow, "mode"], split=":", fixed=T))#... and their classes
			if(all(imodes.orig=="factor")){
				comb.fac=lapply(iterms[imodes=="factor"], function(x){paste(x, data[, x], sep="")})
				comb.fac=matrix(unlist(comb.fac), ncol=length(comb.fac), byrow=F)
				comb.fac=apply(comb.fac, 1, paste, collapse="__")
				ires=table(data[,to.do$re[xrow]], comb.fac)
				class(ires)="matrix"
				ires.summary=aggregate(1:nrow(ires), data.frame(ires>1), length)
				xx=as.matrix(ires.summary[, -ncol(ires.summary)])
				xx[xx]=">1"
				xx[xx!=">1"]="!>1"
				ires.summary=data.frame(xx, freq=ires.summary$x)
				ires=list(detailed=ires, summary=ires.summary)
			}else if(any(imodes.orig=="factor")){
				comb.fac=lapply(iterms[imodes.orig=="factor"], function(x){paste(x, data[, x], sep="")})
				comb.fac=matrix(unlist(comb.fac), ncol=length(comb.fac), byrow=F)
				comb.fac=apply(comb.fac, 1, paste, collapse="__")
				covs=lapply(iterms[imodes.orig=="numeric"], function(x){data[, x]})
				if(all(imodes=="factor")){
					ires=lapply(covs, function(x){
						x=tapply(x, list(data[, to.do[xrow, "re"]], comb.fac), function(x){
							sum(table(x)>1)
						})
						x[is.na(x)]=0
						return(x)
					})
				}else{
					ires=lapply(covs, function(x){
						x=tapply(x, list(data[, to.do[xrow, "re"]], comb.fac), function(x){
							length(unique(x))
						})
						x[is.na(x)]=0
						return(x)
					})
				}
				xx=matrix(unlist(lapply(ires, c)), ncol=length(ires), byrow=F)
				xx=apply(xx, 1, paste, collapse="/")
				xx=matrix(xx, ncol=ncol(ires[[1]]), byrow=F)
				colnames(xx)=colnames(ires[[1]])
				rownames(xx)=rownames(ires[[1]])
				ires.detailed=xx
				if(all(imodes=="factor")){
					xx=matrix(unlist(lapply(ires, c))>=2, ncol=length(ires), byrow=F)
					xx[xx]=">1"
					xx[xx!=">1"]="!>1"
				}else{
					xx=matrix(unlist(lapply(ires, c))>=3, ncol=length(ires), byrow=F)
					xx[xx]=">2"
					xx[xx!=">2"]="!>2"
				}
				xx=apply(xx, 1, paste, collapse="/")
				xx=matrix(xx, ncol=ncol(ires[[1]]), byrow=F)
				colnames(xx)=colnames(ires[[1]])
				rownames(xx)=rownames(ires[[1]])
				ires.summary=aggregate(1:nrow(xx), data.frame(xx), length)
				colnames(ires.summary)[ncol(ires.summary)]="freq"
				ires=list(detailed=ires.detailed, summary=ires.summary)
			}else{
				xx=lapply(iterms, function(x){
					apply(res.detailed[[paste(c(x, to.do[xrow, "re"]), collapse="_within_")]]>0, 1, sum)
				})
				yy=matrix(unlist(xx), ncol=length(xx), byrow=F)
				colnames(yy)=iterms
				rownames(yy)=names(xx[[1]])
				ires=yy
				ires.summary=aggregate(1:nrow(ires), data.frame(ires), length)
				colnames(ires.summary)=c(colnames(ires), "freq")#[ncol(ires.summary)]
				ires=list(detailed=ires, summary=ires.summary)
				#browser()
			}
			return(ires)
		})
		xx=paste(to.do$int, to.do$re, sep="_within_")#gsub(x=paste(to.do$int, to.do$re, sep="_within_"), pattern=":", replacement="_", fixed=T)#name it
		mode.mat=to.do[, "mode"]
		mode.mat=gsub(x=mode.mat, pattern="numeric", replacement="COV")
		mode.mat=gsub(x=mode.mat, pattern="factor", replacement="FAC")
		mode.mat=strsplit(mode.mat, split=":", fixed=T)#), nrow=nrow(to.do), byrow=T)
		mode.cons.mat=to.do[, "mode.cons"]
		mode.cons.mat=gsub(x=mode.cons.mat, pattern="numeric", replacement="COV")
		mode.cons.mat=gsub(x=mode.cons.mat, pattern="factor", replacement="FAC")
		mode.cons.mat=strsplit(mode.cons.mat, split=":", fixed=T)#), nrow=nrow(to.do), byrow=T)
		for(i in 1:length(mode.mat)){
			mode.mat[[i]][mode.mat[[i]]!=mode.cons.mat[[i]]]="COVasFAC"
		}
		#mode.mat[mode.mat=="numeric"]="COV"
		#mode.mat[mode.mat=="factor"]="FAC"
		#mode.mat[mode.mat!=mode.cons.mat]="COVasFAC"
		xx=paste(xx, paste("(", unlist(lapply(mode.mat, paste, collapse=":")), ")", sep=""), sep=" ")
		to.add.2=lapply(to.add, "[[", "summary")
		names(to.add.2)=xx
		res.summary=c(res.summary, to.add.2)#and append to.add to res.summary
		to.add.2=lapply(to.add, "[[", "detailed")
		names(to.add.2)=xx
		res.detailed=c(res.detailed, to.add.2)
	}
	#add columns with the dummy coded factor levels to data:
	to.code=fe.me[modes[fe.me]=="factor"]#determine factors among the fixed effects:
	if(length(to.code)>0){
		coded=lapply(to.code, function(xc){#for each factor
			lapply(levels(data[, xc])[-1], function(xl){#for all levels except the reference level
				as.numeric(data[, xc]==xl)#code it
			})
		})
		coded=matrix(unlist(coded), nrow=nrow(data), byrow=F)#reformat to matrix
		xnames=unlist(lapply(to.code, function(xc){#determine column names to be given to the matrix...
			paste(xc, levels(data[, xc])[-1], sep=".")
		}))
		colnames(coded)=xnames#... and use 'm
		data=data.frame(data, coded)#and append 'm to data
	}else{
		xnames=""
	}
	#now the model expression wrt random slopes; first no correllations between random slopes and intercepts:
	pot.terms=c(xnames, fe.me[modes[fe.me]!="factor"])#create vector with names of dummy variables and names of fixed main effects not being factors
	pot.terms=outer(pot.terms, re, Vectorize(function(x, y){#create matrix with separate model term for each combination of fixed and random effect
		paste(c("(0+", x, "|", y, ")"), collapse="")
	}))
	pot.terms=paste(c(t(pot.terms)), collapse="+")#put them all in a single entry
	#now the random slopes part of the model including random intercepts and slopes and their correlation:
	pot.terms.with.corr=paste(c(xnames, fe.me[modes[fe.me]!="factor"]), collapse="+")#get all fixed effects terms together...
	pot.terms.with.corr=paste(paste("(1+", pot.terms.with.corr, "|", re, ")", sep=""), collapse="+")#... and paste random effects, brackets and all that
		#(and everything in a single entry)
	return(list(detailed=res.detailed, summary=res.summary, data=data, pot.terms=pot.terms, pot.terms.with.corr=pot.terms.with.corr))
}

write.fe.re.summary2file<-function(x, file){
	c.tab<-function(x, incl.fst=F, incl.rownames=T){
		res=format(as.matrix(x))
		res=gsub(x=res, pattern=" ", replacement="", fixed=T)
		res=rbind(colnames(res), res)
		rownames(res)=NULL
		colnames(res)=NULL
		res[is.na(res)]="NA"
		n.char.range=apply(res, 2, function(x){range(nchar(x))})
		#res[, 1]=unlist(lapply(res[, 1], function(x){paste(c(x, rep(" ", n.char.range[2, 1]-nchar(x))), collapse="")}))
		res=matrix(unlist(lapply(1:ncol(res), function(x){
			unlist(lapply(res[, x], function(y){paste(c(rep(" ", n.char.range[2, x]-nchar(y)), y), collapse="")}))
		})), nrow=nrow(res), byrow=F)
		res=apply(res, 1, paste, collapse=paste(rep(" ", 1), collapse=""))
		return(res)
	}

	append=F
	for(i in 1:length(x)){
		write.table(x=names(x[i]), file=file, row.names=F, col.names=F, sep="\t", quote=F, append=append)
		append=T
		xx=x[[i]]
		if(is.null(dim(xx))){
			xx=cbind(names(xx), xx)
			colnames(xx)=NULL
			xx=c.tab(xx)
		}else{
			rownames(xx)=NULL
			xx=c.tab(x=xx)
		}
		xx=matrix(xx, ncol=1)
		write.table(x=xx, file=file, row.names=F, col.names=F, sep="\t", quote=F, append=append)
		write.table(x="", file=file, row.names=F, col.names=F, sep="\t", quote=F, append=append)
	}
}

m.stab.plot<-function(est, lower=NULL, upper=NULL, xnames=NULL, col="black", center.at.null=F, reset.par=T, pch=18, xlim=NULL){
	#version from Aug 12 2018
	#function to plot model stability or CIs (not really supposed to be nice, but to give a quick overview/rapid diagnostic)
	#input:
		#either a three columns data frame or matrix (with rownames) handed over to argument est (first column needs to comprise the original estimate)
		#or several vectors handed over as follows:
			#est: numeric; estimated coefficients of the model
			#lower: numeric; lower limits of the estimates (either from model stability of from bootstrap)
			#upper: numeric; upper limits of the estimates (either from model stability of from bootstrap)
			#xnames: character; names to be depicted besides the error bars
		#col: character; name of the color with which data should be depicted
	if(ncol(est)==3){
		lower=est[, 2]
		upper=est[, 3]
		xnames=rownames(est)
		est=est[, 1]
		x.at=est
	}
	if(is.null(xlim)){
		xlim=range(c(0, lower, upper))
	}
  old.par = par(no.readonly = TRUE)
	par(mar=c(3, 0.5, 0.5, 0.5), mgp=c(1, 0.4, 0), tcl=-0.2)
	plot(x=est, y=1:length(est), pch=pch, xlab="estimate", ylab="", yaxt="n", xlim=xlim, type="n", ylim=c(1, length(est)+1))
	abline(v=0, lty=3)
	if(center.at.null){
		x.at=rep(0, length(est))
		text(labels=xnames, x=x.at, y=(1:length(est))+0.3, cex=0.8)
	}else{
		xx=range(est)#c(lower, upper))
		for(i in 1:length(est)){
			text(labels=xnames[i], x=x.at[i], y=i+0.3, cex=0.8, adj=c((est[i]-min(xx))/diff(xx), 0))#pos=c(2, 4)[1+as.numeric(est<0)])
		}
	}
	points(x=est, y=1:length(est), pch=pch, col=col)
	segments(x0=lower, x1=upper, y0=1:length(est), y1=1:length(est), col=col)
	if(reset.par){par(old.par)}
}

fe.re.tab.old<-function(fe.model, re, other.vars=NULL, data, treat.covs.as.factors=F){
	#function helping in determinining which random slopes are needed
	#last updated: 2015, Nov 25
	#input/arguments:
		#data: a dataframe with all relevant variables (including the response)
		#fe.model: character; the model wrt the fixed effect (including the response); e.g., "r~f1*c*f2"
		#re: character; either a vector with the names of the random effects (e.g., c("re1", "re2")) or a random intercepts expression (e.g., "(1|re1)+(1|re2)")
		#other.vars: character, optional; a vector with the names of variables which are to be kept in the data considered and returned
		#treat.covs.as.factors: logical, when set to TRUE covariates will be treated like factors (see value/summary for details)
	#value: list with the following entries:
		#detailed: list with cross-tabulations ffor each combination of (main) fixed and random effect
		#summary: list tables...
			#telling for each combination of (main) fixed and random effect...
				#the number of levels of the random effect with a given number of unique values of the fixed effect (in case of a covariate)
				#the number of levels of the random effect with a given number of levels of the fixed effect for which at least two cases do exist (in case of a factor)
			#telling for each combination of interaction and random effect...
				#the combination of the above two informations, i.e., the number of individuals with a given number of unique values of the covariate
					#and a given number of factor levels for which at least two cases exist
		#data: data frame containing all relevant variables (i.e., response, fixed and random effects as well as those indicated in other.vars (e.g., offset terms)
			#also includes columns for dummy variables coding the levels (except the reference level) of all factors
		#pot.terms: length one vector comprising the model wrt the random slopes (for all combinations of fixed and random effects, i.e., most likely some will need to be omitted)
			#note that this comprises only the random slopes but not the correlations between random slopes and intercepts not the random intercept itself
		#pot.terms.with.corr: length one vector comprising the model wrt the random slopes (for all combinations of fixed and random effects, i.e., most likely some will need to be omitted)
			#note that this comprises the random slopes and intercepts  and also all correlations among them
	if(sum(grepl(x=re, pattern="", fixed=T))>0 & length(re)==1){#if random effects are handed over as formula
		re=gsub(x=re, pattern="(1|", replacement="", fixed=T)
		re=gsub(x=re, pattern=")", replacement="", fixed=T)
		re=gsub(x=re, pattern=" ", replacement="", fixed=T)
		re=unlist(strsplit(re, split="+", fixed=T))
	}
	fe.model=gsub(x=fe.model, pattern=" ", replacement="", fixed=T)#remove spaces
	model.terms=attr(terms(as.formula(fe.model)), "term.labels")#get individual terms from fixed effects model
	fe.me=model.terms[!grepl(x=model.terms, pattern=":", fixed=T)]#remove interactions
	fe.me=fe.me[!grepl(x=fe.me, pattern="^", fixed=T)]#remove squares terms
	resp=unlist(strsplit(fe.model, split="~", fixed=T))[1]#determine response
	if(substr(resp, start=1, stop=6)=="cbind("){
		resp=gsub(x=resp, pattern="cbind(", replacement="", fixed=T)
		resp=gsub(x=resp, pattern=")", replacement="", fixed=T)
		resp=gsub(x=resp, pattern=" ", replacement="", fixed=T)
		resp=unlist(strsplit(resp, split=",", fixed=T))
	}
	xx=setdiff(c(resp, fe.me, re, other.vars), names(data))
	if(length(xx)>0){
		stop(paste(c("error: preditor(s) missing in the data is/are ", paste(xx, collapse=", ")), collapse=""))
	}
	data=droplevels(as.data.frame(na.omit(data[, c(resp, fe.me, re, other.vars)])))#keep complete data wrt all relevant variables
	model.terms=model.terms[!grepl(x=model.terms, pattern="^", fixed=T)]#remove squares terms
	modes=rep(NA, length(model.terms))#initialize vector storing whether PVs are factors or not
	effect=c(rep("main", length(fe.me)), rep("int", length(model.terms)-length(fe.me)))#create vector telling for each model term whether it is a main effect of not
	for(i in 1:ncol(data)){#for all columns in data
		if(is.character(data[, i])){data[, i]=as.factor(data[, i])}#turn character column into factor
		modes[i]=class(data[, i])#and determine its class
	}
	names(modes)=names(data)#name 'm
	to.do=data.frame(expand.grid(re=re, fe=fe.me))#create data frame with one column for each combination of fixed main and random effect
	to.do$re=as.character(to.do$re)#reformat to character (for later addressing by name)
	to.do$fe=as.character(to.do$fe)#reformat to character (for later addressing by name)
	res.detailed=lapply(1:nrow(to.do), function(xrow){#create detailed results by lapply-ing over the rows of to.do
			table(data[,to.do$re[xrow]], data[,to.do$fe[xrow]])#cross tabulate the respective fixed and random effect
	})
	names(res.detailed)=paste(to.do$fe, to.do$re, sep="_within_")#name it
	res.summary=lapply(1:nrow(to.do), function(xrow){#begin with creating summary results by lapply-ing over the rows of to.do
		if(modes[to.do[xrow, "fe"]]!="factor" & !treat.covs.as.factors){#if fixed effect is not a factor
			ires=table(apply(res.detailed[[xrow]]>0, 1, sum))#determine number of levels of the random effect per number of unique cases of the fixed effect
		}else{#if fixed effect is a factor
			ires=table(apply(res.detailed[[xrow]]>1, 1, sum))#determine number of levels of the random effect per number of unique cases of the fixed effect with at least two observations
		}
		ires=c(ires, tot=nrow(res.detailed[[xrow]]))
	})
	names(res.summary)=paste(to.do$fe, to.do$re, sep="_within_")#name it
	#append 'factor' or 'covariate' to the names:
	names(res.summary)[modes[to.do$fe]=="factor"]=paste(names(res.summary)[modes[to.do$fe]=="factor"], "(factor)", sep=" ")
	names(res.summary)[!modes[to.do$fe]=="factor"]=paste(names(res.summary)[!modes[to.do$fe]=="factor"], "(covariate)", sep=" ")
	to.do=data.frame(expand.grid(re=re, int=setdiff(model.terms, fe.me)))#create data frame with one row for each combination of interaction and random effect
	if(nrow(to.do)>0){
		to.do[, "int"]=as.character(to.do[, "int"])#reformat to character (for later addressing by name)
		to.do[, "re"]=as.character(to.do[, "re"])#reformat to character (for later addressing by name)
		to.add=lapply(1:nrow(to.do), function(xrow){#treat combinations of fixed and random effect by lapply-ing over the rows of to.do
			iterms=unlist(strsplit(to.do[xrow, "int"], split=":", fixed=T))#determine main effects involved in the interaction...
			imodes=modes[iterms]#... and their classes
			all.tabs=lapply(1:length(iterms), function(yrow){#for each term
				#if its not a factor, determine determine the number of unique cases of the fixed effect per level of the random effect
				#otherwise, determine per level of thee random effect the number of levels of the fixed effect with at least two observations
				apply(res.detailed[[paste(c(iterms[yrow], to.do[xrow, "re"]), collapse="_within_")]]>ifelse(imodes[iterms[yrow]]=="factor" | treat.covs.as.factors, 1, 0), 1, sum)
			})
			all.tabs=matrix(unlist(all.tabs), ncol=length(all.tabs), byrow=F)#reformat to matrix (one row per level of the random effect, one column per term)
			all.tabs=aggregate(1:nrow(all.tabs), c(data.frame(all.tabs)), length)#summarize it ((wrt the number of levels of the random effec per combination of values)
			colnames(all.tabs)=c(iterms, paste(c("n", to.do[xrow, "re"]), collapse="."))#name it
			return(all.tabs)
		})
		names(to.add)=gsub(x=paste(to.do$int, to.do$re, sep="_within_"), pattern=":", replacement="_", fixed=T)#name it
		res.summary=c(res.summary, to.add)#and append to.add to res.summary
	}
	#add columns with the dummy coded factor levels to data:
	to.code=fe.me[modes[fe.me]=="factor"]#determine factors among the fixed effects:
	if(length(to.code)>0){
		coded=lapply(to.code, function(xc){#for each factor
			lapply(levels(data[, xc])[-1], function(xl){#for all levels except the reference level
				as.numeric(data[, xc]==xl)#code it
			})
		})
		coded=matrix(unlist(coded), nrow=nrow(data), byrow=F)#reformat to matrix
		xnames=unlist(lapply(to.code, function(xc){#determine column names to be given to the matrix...
			paste(xc, levels(data[, xc])[-1], sep=".")
		}))
		colnames(coded)=xnames#... and use 'm
		data=data.frame(data, coded)#and append 'm to data
	}else{
		xnames=""
	}
	#now the model expression wrt random slopes; first no correllations between random slopes and intercepts:
	pot.terms=c(xnames, fe.me[modes[fe.me]!="factor"])#create vector with names of dummy variables and names of fixed main effects not being factors
	pot.terms=outer(pot.terms, re, Vectorize(function(x, y){#create matrix with separate model term for each combination of fixed and random effect
		paste(c("(0+", x, "|", y, ")"), collapse="")
	}))
	pot.terms=paste(c(t(pot.terms)), collapse="+")#put them all in a single entry
	#now the random slopes part of the model including random intercepts and slopes and their correlation:
	pot.terms.with.corr=paste(c(xnames, fe.me[modes[fe.me]!="factor"]), collapse="+")#get all fixed effects terms together...
	pot.terms.with.corr=paste(paste("(1+", pot.terms.with.corr, "|", re, ")", sep=""), collapse="+")#... and paste random effects, brackets and all that
		#(and everything in a single entry)
	return(list(detailed=res.detailed, summary=res.summary, data=data, pot.terms=pot.terms, pot.terms.with.corr=pot.terms.with.corr))
}


###############################################################
# oml4spark_function_create_balanced_input.r
#
# Function to create a Balanced Dataset based on Input
# Dataset and formula.
#
# Input can be HDFS ID, HIVE, IMPALA, Spark DF or R dataframe
#
# It allows for a range to be choosen
# for the TARGET proportion so that if one thinks the
# proportion is within that range, then the returned Spark DF
# is the original input
#
# Usage: createBalancedInput( input_bal ,
#                             formula_bal ,
#                             feedback = FALSE ,
#                             rangeForNoProcess = c(0.45,0.55)
#                           )
#
#
# Copyright (c) 2020 Oracle Corporation
# The Universal Permissive License (UPL), Version 1.0
#
# https://oss.oracle.com/licenses/upl/
#
###############################################################

#######################################
### GENERATE A BALANCED SAMPLE
### FROM ANY INPUT
### HDFS ID, SPARK, HIVE, R Dataframe
#######################################

createBalancedInput <- function(input_bal, formula_bal, reduceToFormula=FALSE,
                                feedback = FALSE, rangeForNoProcess = c(0.45,0.55),
                                sampleSize = 0) {
  # Extract the Target variable from the formula
  targetFromFormula <- strsplit(deparse(formula_bal), " ")[[1]][1]
  # If the Target has an "as.factor", remove it for processing
  if (startsWith(targetFromFormula,"as.factor("))
  { targetFromFormula <- regmatches(targetFromFormula,
                                    gregexpr("(?<=\\().+?(?=\\))",
                                             targetFromFormula,
                                             perl = T))[[1]]
  }
  # If the user wants to run a full verbose mode, store the info
  if (grepl(feedback, "FULL", fixed = TRUE))
  {verbose_user <- TRUE
  } else {verbose_user <- FALSE}

  # Find the ideal number of Partitions to use when creating the Spark DF
  # To Maximize Spark parallel utilization
  sparkXinst <- as.numeric(spark.property('spark.executor.instances'))
  sparkXcores <- as.numeric(spark.property('spark.executor.cores'))
  ideal_partitions <- sparkXinst*sparkXcores

  # Push the INPUT DATA to Spark (if it's not already)
  # In Case it is a Spark DF already we don't do anything
  if (!((spark.connected()) && (class(input_bal)[1]=="jobjRef"))) {
    # Check if the input if a DFS ID (HDFS)
    if (is.hdfs.id(input_bal)) {
      if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) print('Input is HDFS...processing')
      dat_df <- orch.df.fromCSV(input_bal,
                                minPartitions = ideal_partitions,
                                verbose = FALSE ) # Convert the input HDFS to Spark DF
    } else
      # Check if the input is HIVE and load it into Spark DF
      if ( ore.is.connected(type='HIVE') && (is.ore.frame(input_bal)) ) {
        if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) print('Input is HIVE Table...processing')
        dat_df <- ORCHcore:::.ora.getHiveDF(table=input_bal@sqlTable)
      } else
        # Check if the input is IMPALA
        if ( ore.is.connected(type='IMPALA') && (is.ore.frame(input_bal)) ) {
          if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) print('Input is IMPALA Table...processing')
          dat_df <- ORCHcore:::.ora.getHiveDF(table=input_bal@sqlTable)
        } else
          # For R Dataframe it is a two-step process for now
          if (is.data.frame(input_bal)){
            if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) print('Input is R Dataframe...processing')
            dat_hdfs <- hdfs.put(input_bal)
            dat_df <- orch.df.fromCSV(dat_hdfs,
                                      minPartitions = ideal_partitions,
                                      verbose = FALSE ) # Convert the input HDFS to Spark DF
          }
  } else
    # If it's already a Spark DF then just point to it
  { if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) print('Input is already Spark DF')
    dat_df <- input_bal}

  # Persist the Spark DF for added performance
  orch.df.persist(dat_df, storageLevel = "MEMORY_ONLY", verbose = verbose_user)

  # Extract Original terms from formula to reduce the original Dataset (if indicated)
  formulaTerms <- terms(x=formula_bal, data=orch.df.collect(dat_df$limit(1L)))

  # Extract Var names from formula
  tempVars <- gsub(".*~","",Reduce(paste, deparse(formulaTerms)))
  tempVars <- gsub(" ", "", tempVars)
  tempVars <- gsub("-1","", tempVars)

  # Final list
  finalVarList <- strsplit( tempVars , "+", fixed = TRUE)[[1]]
  # In case the user added "as.factor()" to the variables
  removeAsFactor <- function(x) {
    if (startsWith(x,"as.factor(")) {
      regmatches(x, gregexpr("(?<=\\().+?(?=\\))", x, perl = T))[[1]]
    } else x
  }
  finalVarList <- unlist(lapply(finalVarList,removeAsFactor))

  if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) {
    print('List of Variables from Formula that are going to be in the output Spark DataFrame:')
    print(c(targetFromFormula,finalVarList))
  }

  if (reduceToFormula==TRUE) {
    # Select only the columns used by the formula plus the target
    dat_df <- dat_df$selectExpr(append(targetFromFormula,finalVarList))
    # Persist the Reduced Spark DF for added performance
    orch.df.persist(dat_df, storageLevel = "MEMORY_ONLY", verbose = verbose_user)
  }

  # Prepare to create a SQL View with random name for the Spark DF
  op <- options(digits.secs = 6)
  time <- as.character(Sys.time())
  options(op)
  tempViewName <- paste0("tmp_view_",
                         paste(regmatches(time,
                                          gregexpr('\\(?[0-9]+',
                                                   time))[[1]],
                               collapse = ''),
                         collapse = " ")
  orch.df.createView(dat_df , tempViewName)

  # Capture the proportion of Target=1 in order to balance the Data into 50/50
  targetInfo <- orch.df.collect(orch.df.sql(paste0("select ",targetFromFormula,
                                                   " as target, count(*) as num_rows from ",
                                                   tempViewName," group by ",targetFromFormula,
                                                   " order by ",targetFromFormula)))
  proportionTarget <- targetInfo[2,2]/sum(targetInfo$num_rows)
  # Not needed, maybe future use:  names(proportionTarget) <- c(as.character(targetInfo[2,1]),as.character(targetInfo[1,1]))

  # Only need to Sample from Target = 0 if the proportion is outside of the Range given by the user.
  # Default is 0.45 to 0.55, so if the proportion is already close enough to 0.5 we should not waste time sampling
  if (findInterval(proportionTarget, rangeForNoProcess)) {
    if (grepl(feedback, "FULL|TRUE", fixed = TRUE))
      cat(paste0('\nTarget proportion in Input Data already within range ',
                 paste0(rangeForNoProcess, collapse = ' <-> '),' . No change done. \nTarget proportion is : ',
                 format(proportionTarget,digits=6), '\nNum Rows is : ',format(sum(targetInfo$num_rows),big.mark=',')))
    balanced <- dat_df
  } else {
    cat(paste0('\nTarget proportion is outside the range ',paste0(rangeForNoProcess, collapse = ' <-> '),
               ' . Processing...\nTarget proportion is : ', format(proportionTarget,digits=6)))
    # Select all Target = 1 records and put them into a Spark DF "input_1"
    input_1 <- dat_df$filter(c(paste0(targetFromFormula," == '",targetInfo$target[which.min(targetInfo$num_rows)],"'")))
    target_1_count <- targetInfo[2,2] # or input_1$count()
    if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) cat(paste0('\nTarget = ',targetInfo[2,1],' count : ',
                                                               format(target_1_count,big.mark = ",")))

    # Select a sample of Target = 0 records and put them into a Spark DF "input_0"
    input_0 <- dat_df$filter(c(paste0(targetFromFormula," == '",targetInfo$target[which.max(targetInfo$num_rows)],"'")))
    if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) cat(paste0('\nTarget = ',targetInfo[1,1],' count : ',
                                                               format(targetInfo[1,2],big.mark = ","))) # or input_0$count()

    # Prepare the settings needed for the Sampling function of Spark on Data Frames "$sample"
    samp_rate <- min(1,targetInfo[2,2]/targetInfo[1,2])
    seed_long <- .jlong(12345L)
    # Runs the sample of Target = 0 records a little bigger (with an offset) to avoid limitations
    # by Spark DF "$sample" function sometimes sampling smaller than desired samples
    offset <- 10*(1/target_1_count)
    if ((samp_rate+offset)>=1) {offset <- 1 - samp_rate -0.01}
    sample_0 <- input_0$sample(FALSE,samp_rate+offset,seed_long)

    # Trims the sample of Target = 0 records to the ideal size (same as te target = 1) using the function "$limit"
    input_0_samp <- sample_0$limit(as.integer(target_1_count))
    if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) cat(paste0('\nSampled Target = ',
                                                               targetInfo[1,1],' count : ',
                                                               format(input_0_samp$count(),big.mark = ",")))

    # Use the function "$union" from Spark Data Frame to join both Target and non-Target portions
    balanced <- input_1$union(input_0_samp)

    if (sampleSize >0) {
      newSampRate <- (sampleSize/balanced$count())
      if (newSampRate < 1) {
        if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) cat(paste0('\nSampling final balanced count from ',
                                                                   format(balanced$count(),big.mark = ","),' down to ',
                                                                   format(sampleSize,big.mark = ","),' records'))
        sample_final <- balanced$sample(FALSE,newSampRate+offset,seed_long)
        balanced <- sample_final$limit(as.integer(sampleSize))
        orch.df.unpersist(sample_final)
      } else {
        if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) cat(paste0('\nSampling requested of ',
                                                                   format(sampleSize,big.mark = ","),
                                                                   ' is larger than final balanced count and was ignored.'
        ))
      }
    }

    orch.df.unpersist(dat_df)
    orch.df.unpersist(input_1)
    orch.df.unpersist(input_0)
    orch.df.unpersist(input_0_samp)
    orch.df.persist(balanced, storageLevel = 'MEMORY_ONLY', verbose = FALSE)
    if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) cat(paste0('\nBalanced Final count : ',
                                                               format(balanced$count(),big.mark = ","),
                                                               '\n'))
  }
  return(balanced)
}


##
#  Copyright (c) 2011 LabKey Corporation
#
#  Licensed under the Apache License, Version 2.0: http://www.apache.org/licenses/LICENSE-2.0
##

# This R script will calculate and store kinship coefficients (aka. relatedness) for all animals in the colony.  This is a large, sparse matrix.
# The matrix is converted into a very long 3-column dataframe (animal1, animal2, coefficient).  This dataframe is compared to the data
# already present in the system.  The minimal number of inserts/updates/deletes are then performed.  This script is designed
# to run as a daily cron job.  If it runs frequently enough, the number of updates should remain small.  If more than 5000 inserts need to be performed,
# the script will output a TSV file to /usr/local/labkey/kinship/.  This file can be manually imported into LabKey.  The threshold of 5000 is probably
# too conservative, but large imports using the HTTP API can be problematic.

# When the script runs it outputs the log to /usr/local/labkey/kinship/kinshipOut.txt.  This file is monitored by monit and an alert will be through
# if the timestamp does not change once per day.  This monitors whether the script is running, but does not directly monitor for errors.
# Monit also monitors checksum changes on the TSV output file.  If this file changes, an alert email will be triggered, in which case someone
# should import this file into the DB.

#options(echo=TRUE);
library(kinship)
library(Rlabkey)

library(Matrix)

#print('Labkey.data:')
#str(labkey.data);
#remove(labkey.data)

#NOTE: to run directly in R instead of through labkey, uncomment this:
labkey.url.base = "https://ehr.primate.wisc.edu/"

#this section queries labkey to obtain the pedigree data
#you could replace it with a command that loads from TSV if you like
allPed <- labkey.selectRows(
    baseUrl=labkey.url.base,
    folderPath="/WNPRC/EHR",
    schemaName="study",
    queryName="Pedigree",
    colSelect=c('Id', 'Dam','Sire', 'Gender'),
    showHidden = TRUE,
    colNameOpt = 'fieldname',  #rname
    #showHidden = FALSE
)
colnames(allPed)<-c('Id', 'Dam', 'Sire', 'Gender')

is.na(allPed$Id)<-which(allPed$Id=="")
is.na(allPed$Dam)<-which(allPed$Dam=="")
is.na(allPed$Sire)<-which(allPed$Sire=="")
is.na(allPed$Gender)<-which(allPed$Gender=="")
#print("All ped2");
#str(allPed)
#allPedfile=read.delim("demographics_2011-07-01.txt",header=TRUE,na.strings="")
#allPedfile=allPedfile[,1:4]
#str(allPed[(is.na(allPed$Dam))&(!is.na(allPed$Sire)),])
#str(allPed[(!is.na(allPed$Dam))&(is.na(allPed$Sire)),])

##### These code are commented out after checking data
# duplicatedId=allPed$Id[duplicated(allPed$Id)]
# allPed[allPed$Id%in%duplicatedId,]# Check for duplication: passed
# Id.Dam=unique(allPed$Dam)
# allPed[(allPed$Id%in%Id.Dam)&(allPed$Gender!=2),]#Check for Dam that is not female
# Id.Sire=unique(allPed$Sire)
# allPed[(allPed$Id%in%Id.Sire)&(allPed$Gender!=1),]#Check for Sire that is not male:1 not passed

#this function adds missing parents to the pedigree
#it is similar to add.Inds from kinship; however, we retain gender
`addMissing` <-
function(ped)
  {
    if(ncol(ped)<4)stop("pedigree should have at least 4 columns")
    head <- names(ped)

    nsires <- match(ped[,3],ped[,1])# [Quoc] change ped,2 to ped,3
    nsires <- as.character(unique(ped[is.na(nsires),3]))
    nsires <- nsires[!is.na(nsires)]
    if(length(nsires)){
        ped <- rbind(ped, data.frame(Id=nsires, Dam=rep(NA, length(nsires)), Sire=rep(NA, length(nsires)), Gender=rep(1, length(nsires))));
    }

    ndams <- match(ped[,2],ped[,1])# [Quoc] change ped,3 to ped,2
    ndams <- as.character(unique(ped[is.na(ndams),2]))
    ndams <- ndams[!is.na(ndams)];

    if(length(ndams)){
        ped <- rbind(ped,data.frame(Id=ndams, Dam=rep(NA, length(ndams)), Sire=rep(NA, length(ndams)), Gender=rep(2, length(ndams))));
    }

    names(ped) <- head
    return(ped)
  }

#str(allPed)
allPed <- addMissing(allPed)
#print("All ped 3");
#str(allPed)
#[Quoc: new code to collapse sparse matrix]
#[makefamid separate the giant dataset to unrelated families]
#[It resizes the biggest matrix from 12000^2 to 8200^2 thus reduces the memory used by half ]
fami=makefamid(id=allPed$Id,father.id=allPed$Sire,mother.id=allPed$Dam)
famid=unique(fami)
famid=famid[famid!=0]
newRecords=NULL
for (fam.no in famid){
  familytemp=allPed[fami==fam.no,]
  temp.kin=kinship(familytemp$Id,familytemp$Sire,familytemp$Dam)
  sparse.kin=as(temp.kin,"dsTMatrix") #change kinship matrix to symmetric triplet sparse matrix
  #[Quoc this more efficient than do it manually, sparse matrix is S4 object from library Matrix]
  temp.tri=data.frame(Id=colnames(temp.kin)[sparse.kin@i+1],Id2=colnames(temp.kin)[sparse.kin@j+1],coefficient=sparse.kin@x,stringsAsFactors=FALSE)
  newRecords=rbind(newRecords,temp.tri)
  #str(newRecords)
}

# [Quoc: Untouched code frome here]
#these keys are created in order to subset this dataframe
#it is possible a more efficient approach could be used
newRecords$key1 <- paste(newRecords$Id, newRecords$Id2, sep=":")
newRecords$key2 <- paste(newRecords$key1, newRecords$coefficient, sep=":")

#we set date=now() as a timestamp
#the purpose of this is so we have a record when we save to the DB of when this was calculated.
newRecords$date <- c(date())
newRecords$date <- as.character(newRecords$date)

#in the next sections we will compare the newly created dataframe to the data already in the DB
#the first time this script is run, the DB will be blank
#on subsequent runs, we perform these steps to minimize the amount of add/deletes against this data

#find old records first by querying labkey
#this can be replaced with a TSV load for testing if needed
oldRecords <- labkey.selectRows(
    baseUrl=labkey.url.base,
    folderPath="/WNPRC/EHR",
    schemaName="ehr",
    queryName="kinship",
    colSelect=c('rowid', 'Id', 'Id2', 'coefficient'),
    showHidden = TRUE,
    #stringsAsFactors = FALSE,
    colNameOpt = 'fieldname'  #rname
)
colnames(oldRecords)<-c('rowid', 'Id', 'Id2', 'coefficient');

print("New Records")
str(newRecords);

#these keys are created in order to subset this dataframe
#it is possible a more efficient approach could be used
oldRecords$key1 <- paste(oldRecords$Id, oldRecords$Id2, sep=":")
oldRecords$key2 <- paste(oldRecords$key1, oldRecords$coefficient, sep=":")

print("Old Records")
str(oldRecords);

#first we find any cases where an Id existing in oldRecords, but not newRecords.  These need to be deleted
IdxToDelete <- setdiff(oldRecords$key1, newRecords$key1);
toDelete <- oldRecords[match(IdxToDelete, oldRecords$key1),]
print('Total To Delete: ')
length(toDelete$Id)

if(length(toDelete$Id)){
    toDelete <- data.frame(rowid=toDelete$rowid)
    del <- labkey.deleteRows(
        baseUrl=labkey.url.base,
        folderPath="/WNPRC/EHR",
        schemaName="ehr",
        queryName="kinship",
        toDelete=toDelete
    );
}
remove(IdxToDelete)
remove(toDelete)

#next we find any cases where an Id/Id2 pair exists in both oldRecords and newRecords, but the coefficient is different.
#These need to be updated

SharedIdPairs <- intersect(oldRecords$key1, newRecords$key1);
coefficient1 <- oldRecords[match(SharedIdPairs, oldRecords$key1),]
coefficient2 <- newRecords[match(SharedIdPairs, newRecords$key1),]

#find records where the old coefficient does not equal the new one:
toGet <- (!is.na(coefficient1$coefficient) & is.na(coefficient2$coefficient)) | (is.na(coefficient1$coefficient) & !is.na(coefficient2$coefficient)) | (!is.na(coefficient1$coefficient) & !is.na(coefficient2$coefficient) & coefficient1$coefficient != coefficient2$coefficient)
toUpdate <- coefficient1[toGet,];
toUpdate$coefficient <- coefficient2$coefficient[toGet];

print('Total To Update: ')
length(toUpdate$Id)

if(length(toUpdate$Id)){
    update <- labkey.updateRows(
        baseUrl=labkey.url.base,
        folderPath="/WNPRC/EHR",
        schemaName="ehr",
        queryName="kinship",
        toUpdate=toUpdate
    );
}

#next we find any cases where an Id/Id2 pair exists in newRecords, but not oldRecords.
#These need to be inserted

IdxToInsert <- setdiff(newRecords$key1, oldRecords$key1);
toInsert <- newRecords[match(IdxToInsert, newRecords$key1),]
print("Total To Insert:");
length(toInsert$Id)

if(length(toInsert$Id) > 5000){
     toInsert$container = c('29e3860b-02b5-102d-b524-493dbd27b599');
     toInsert <- subset(toInsert, select = -c(key1,key2,date) )

     write.table(toInsert, file = "/usr/local/labkey/kinship/kinship.tsv", quote = FALSE, sep = "\t");
     print("NOTE: There are too many rows to import using the API.")
     print("A TSV file has been written to /usr/local/labkey/kinship.tsv")
     print("It can be imported here: https://ehr.primate.wisc.edu/query/WNPRC/EHR/import.view?schemaName=ehr&query.queryName=kinship")
     stop()
     #toInsert <- toInsert[1:500,];
     #length(toInsert$Id);
}

if(length(toInsert$Id) <= 5000){
    if(length(toInsert$Id)){
        ins <- labkey.insertRows(
            baseUrl=labkey.url.base,
            folderPath="/WNPRC/EHR",
            schemaName="ehr",
            queryName="kinship",
            toInsert=toInsert
        );
    }
    remove(IdxToInsert)
    remove(toInsert)
}


#' precision_matrix_match.r
#' takes a a dataframe of x values, and a dataframe of precision
#' Renames columns of precision matrix to match x_mu matrix, so long as some of x label is in precision label (mat to mat_SD)
#' Add columns to precision matrix for x_mu columns not present, sets precision to 10000 (v high).
#' makes sure columns of x_mu and x_precision are in the same order.
#'
#' @param a x_mu matrix as a dataframe with column names.
#' @param b x_precision matrix as a dataframe with column names.
#'
#' @return returns precision matrix as dataframe with columns added for x_mu columns not already in it.
#' @export
#'
#' @examples
#' a <- data.frame(rnorm(100),rnorm(100),rnorm(100))
#' b <- data.frame(rnorm(100),rnorm(100))
#' colnames(a) <- c('intercept','mat','map')
#' colnames(b) <- c('mat_sd','map_sd')
#' precision_matrix_match(a,b)
#'
precision_matrix_match <- function(a,b){
  #gotta drop any data.table formatting if present.
  #if supplied as matrices need to be dataframes.
  a <- as.data.frame(a)
  b <- as.data.frame(b)

  #rename columns to match x_mu
  for(i in 1:ncol(a)){
    position <- grep(colnames(a)[i], colnames(b))
    if(length(position) > 0){
      position <- position[1]
      colnames(b)[position] <- colnames(a)[i]
    }
  }

  #add columns for x values not present in precision matrix.
  #give these columns a sd value of 0.01, which corresponds to a precision of 10000
  to_add <- colnames(a)[!(colnames(a) %in% colnames(b))]
  new.precision <- matrix(ncol = length(to_add), nrow = nrow(b))
  new.precision[,] <- 0.0001
  colnames(new.precision) <- to_add
  b <- cbind(b,new.precision)
  #order the precision matrix columns to match x_mu matrix.
  b <- b[,colnames(a)]
  b <- as.data.frame(b)
  colnames(b) <- colnames(a)

  #return new precision matrix.
  return(b)

} ##end function.


#!/usr/bin/env Rscript

#' @author Noah Ollikainen, Charlotte A Lai, Peter Chovanec

# This program plots SPRITE clusters as a barplot, with each bar corresponding
# to the read-coverage over a chromosome. If passed only a single clusters
# file, this program will plot absolute coverage
if(!require(ggplot2)){
  install.packages("ggplot2", repos='http://cran.us.r-project.org')
  library(ggplot2)
}
if(!require(optparse)){
  install.packages("optparse", repos='http://cran.us.r-project.org')
  library(optparse)
}

refs <- c("chr1", "chr2", "chr3", "chr4", "chr5", "chr6", "chr7", "chr8",
          "chr9", "chr10", "chr11", "chr12", "chr13", "chr14", "chr15",
          "chr16", "chr17", "chr18", "chr19", "chrX")

parseArgs <- function() {

    option_list <- list(
        make_option(c("-i", "--input"),
                    action = "store",
                    dest = "input",
                    metavar = "FILE",
                    type = "character",
                    help = "blah"),

        make_option(c("-n", "--normalize"),
                    action = "store",
                    dest = "normalize",
                    metavar = "FILE",
                    type = "character",
                    default = NULL,
                    help = "blah"),

        make_option(c("-o", "--output"),
                    action = "store",
                    dest = "output",
                    metavar = "FILE",
                    type = "character",
                    help = "blah")
      )

      args <- parse_args(OptionParser(option_list = option_list))

      if (!file.exists(args$input)) {
          stop(paste0("Cannot open file ", args$input, "!"))
      }

      if (!is.null(args$normalize) && !file.exists(args$normalize)) {
          stop(paste0("Cannot open file ", args$normalize, "!"))
      }

      args
}

processFile <- function(input) {
    hash <- new.env()
    sapply(refs, function(x) hash[[x]] <- 0)

    tryCatch({
        con <- file(input, open = "r")
        while (length(oneLine <- readLines(con, n = 1, warn = FALSE)) > 0) {
            fields <- unlist(strsplit(oneLine, "\t"))[-1]
            for (i in 1:length(fields)) {
                chrom <- getChrom(fields[i])
                count <- hash[[chrom]]
                if (!is.null(count)) {
                    hash[[chrom]] <- count + 1
                }
            }
        }
    }, finally = {
    close(con)
    })

    hash
}

plotHash <- function(hash, output) {
    chroms <- names(hash)
    df <- data.frame(matrix(ncol = 2, nrow = length(chroms)))
    colnames(df) <- c("chromosome", "count")
    for (i in 1:length(chroms)) {
        df[i, ] <- c(chroms[i], hash[[chroms[i]]])
    }

    df$chromosome <- factor(df$chromosome, levels = refs)

    p <- ggplot(df, aes(x = chromosome, y = as.numeric(count)))
    p <- p + geom_bar(stat = "identity")
    p <- p + theme(axis.text.x = element_text(angle = 45, hjust = 1))
    p <- p + ylab("coverage (absolute)")

    ggsave(paste0(output, ".pdf"), plot = p)
    ggsave(paste0(output, ".eps"), plot = p)
}

plotHashes <- function(numHash, denomHash, output) {
    chroms <- names(numHash)
    df <- data.frame(matrix(ncol = 3, nrow = length(chroms)))
    colnames(df) <- c("chromosome", "num", "denom")
    for (i in 1:length(chroms)) {
        df[i, ] <- c(chroms[i], numHash[[chroms[i]]], denomHash[[chroms[i]]])
    }

    df$num <- as.numeric(df$num)
    df$denom <- as.numeric(df$denom)
    df$num.frac <- df$num / sum(df$num)
    df$denom.frac <- df$denom / sum(df$denom)
    df$oe <- df$num.frac / df$denom.frac

    df$chromosome <- factor(df$chromosome, levels = refs)

    p <- ggplot(df, aes(x = chromosome, y = oe))
    p <- p + geom_bar(stat = "identity")
    p <- p + theme(axis.text.x = element_text(angle = 45, hjust = 1))
    p <- p + ylab("O/E")

    ggsave(paste0(output, ".pdf"), plot = p)
    ggsave(paste0(output, ".eps"), plot = p)
}

getChrom <- function(s) unlist(strsplit(s, ":"))[1]

main <- function() {
    args <- parseArgs()
    hash <- processFile(args$input)
    if (is.null(args$normalize)) {
        plotHash(hash, args$output)
    } else {
        hash2 <- processFile(args$normalize)
        plotHashes(hash, hash2, args$output)
    }
}

main()


# author: Cheng Min
# date: 2020-01-30

"Creates eda plots and tables for the un-pre-processed and pre-processed training data of the online shoppers intetion data from UCI website (https://archive.ics.uci.edu/ml/datasets/Online+Shoppers+Purchasing+Intention+Dataset).
Saves the plots as png files and save the tables as .csv files

Usage: src/eda.r --input_dir=<input_dir> --out_dir=<out_dir>

Options:
--input_dir=<input_dir>    Path to training data (filename should not be included)
--out_dir=<out_dir> Path to directory where the plots and tables should be saved
" -> doc

library(data.table, quietly = TRUE)
library(tidyverse, quietly = TRUE)
library(plotly, quietly = TRUE)
library(cowplot, quietly = TRUE)
library(scales, quietly = TRUE)
library(pheatmap, quietly = TRUE)
library(testthat, quietly = TRUE)
library(docopt)

opt <- docopt(doc)

main <- function(input_dir, out_dir) {

  # Read the training data without pre-processing
  mydata <- suppressMessages(read_csv(paste0(input_dir, "/training_for_eda.csv")))
  setDT(mydata)

  # Define the numerical and categorical features
  num_vars_1 <- c("Administrative", "Informational", "ProductRelated")
  num_vars_2 <- c("Administrative_Duration", "Informational_Duration", "ProductRelated_Duration",
                  "BounceRates", "ExitRates",
                  "PageValues", "ProductRelated")

  num_vars_2_units <- c("sec", "sec", "sec",
                  "percent", "percent",
                  "dollars", "Count")
  units <- tibble(num_vars = num_vars_2, num_vars_2_units=num_vars_2_units)

  target <- "Revenue"
  cat_vars <- setdiff(names(mydata), c(num_vars_1, num_vars_2, target))

  # Create a table for quantile distribution and save it in a .csv file
  quantile_dist <- sapply(num_vars_2, FUN=function(x) {
    print(paste("Mean of", x, "is", round(mydata[, mean(get(x))], digits=3),
                "and standard deviation is", round(mydata[, sd(get(x))], digits=3)))
    mydata[, round(quantile(get(x), probs=seq(0,1,0.05)), digits=3)]
  })

  quantile_dist <- as_tibble(quantile_dist)

  quantile_dist$probs <-  seq(0,1,0.05)

  quantile_dist <- quantile_dist %>%
    select(probs, num_vars_2)
  write_csv(quantile_dist, paste0(out_dir, "/quantile_dist.csv"))

  # Save percentage of rows for categories of categorical variables in a .rds file
  cat_vars_expo <- sapply(c(cat_vars, target), FUN=function(x) {
    round(mydata[, table(get(x))]/nrow(mydata), digits=3)*100
  })

  saveRDS(cat_vars_expo, paste0(out_dir, "/cat_vars_expo.rds"))

  # Save the distribution plot for numerical variables
  temp <- mydata %>%
    select(num_vars_2, Revenue) %>%
    gather("num_vars", "values", -Revenue) %>%
    mutate(values = values+0.001)

  temp <- left_join(temp, units)
  temp <- temp %>% mutate(num_vars = paste(num_vars, num_vars_2_units, sep=", "))

  num_vars_dist_plot <- temp %>%
    ggplot(aes(y=values, x=Revenue)) +
    geom_violin(mapping = aes(fill = Revenue),  show.legend = FALSE) +
    scale_y_log10(labels = scales::comma) +
    facet_wrap(~num_vars, scales = "free", nrow = 3) +
    labs(
      title = "Distributions of the numerical variables",
      x = "",
      y = "Log Scaled Value"
    ) +
    theme_bw()

  ggsave(paste0(out_dir, "/img/num_vars_dist_plot.png"), num_vars_dist_plot)

  # Save the distribution plot for categorical variables
  my_level <- c(seq(0,0.8,0.2),seq(1,20),c("Feb", "Mar", "May", "June", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec", "Returning_Visitor", "New_Visitor", "Other", "FALSE", "TRUE"))

  cat_vars_dist_plot <- mydata %>%
    select(cat_vars, Revenue) %>%
    gather("num_vars", "values", -Revenue) %>%
    group_by(Revenue, values, num_vars) %>%
    summarise(n = n()) %>%
    group_by(Revenue, num_vars) %>%
    mutate(freq = n / sum(n),
           values = factor(values, levels = my_level)) %>%
    ggplot(aes(x=values, y=freq, fill=Revenue)) +
    geom_col(position = "dodge")+
    scale_y_continuous(labels = scales::percent) +
    facet_wrap(~num_vars, scales  ="free", nrow = 4) +
    labs(
      title = "Distributions of the categorical variables",
      x = "Categorical variables",
      y = "Frequency"
    ) +
    theme_bw()

  ggsave(paste0(out_dir, "/img/cat_vars_dist_plot.png"), cat_vars_dist_plot, width = 22, height = 15, units = "cm")

  # Plot the correlation after pre-process and save the plot
  X_train <- read_csv(paste0(input_dir, "/X_train.csv"))
  y_train <- read_csv(paste0(input_dir, "/y_train.csv"))

  training <- cbind(X_train, y_train)

  corr_mat <- training %>%
    select(num_vars_1, num_vars_2, Revenue) %>%
    cor()

  corr_mat[lower.tri(corr_mat)] <- NA

  melt_corr_mat <- melt(corr_mat, na.rm=TRUE)
  melt_corr_mat <- melt_corr_mat %>% filter(Var1!=Var2)

  corr_plot <- melt_corr_mat %>%
    ggplot(aes(Var2, Var1, fill = value))+
    geom_tile(color = "white")+
    scale_fill_gradient(low = "#56B1F7", high = "#132B43", name="Pearson\nCorrelation") +
    labs(x="", y="")+
    ggtitle("Correlation between target and numerical variables")+
    theme_minimal()+
    theme(axis.text.x = element_text(angle = 45, vjust = 1, size = 12, hjust = 1), axis.text.y = element_text(size = 12))+
    coord_fixed()

  ggsave(paste0(out_dir, "/img/corr_plot.png"), corr_plot)
}

test_inputs <- function(input, output){
  test_that("The path to training data is wrong!", {
    expect_true(dir.exists(input))
  })

  test_that("The path to store the results is wrong!", {
    expect_true(dir.exists(output))
  })

  test_that("The file needed does not exist! You may need to run fetch_data.py and pre_process.py first.", {
    expect_true(file.exists(paste0(input, "/training_for_eda.csv")))
  })
}

test_inputs(opt[["--input_dir"]], opt[["--out_dir"]])

main(opt[["--input_dir"]], opt[["--out_dir"]])


#!/usr/bin/env Rscript
# Time line plots
# plot two identical timeline plots counts vs. counts to see relative growth
# scott hendrickson
# @drskippy
#
library(ggplot2)
##############
# Args are infile, outfile, title, time_period_string
args <- commandArgs(trailingOnly = TRUE)
if (length(args) != 3) {
    print(args)
    stop("Error! 3 arguments required (infile1[.csv], infile2[.csv], outfile[.csv], title). Don't include the csv.")
}
##############
Y1 = read.delim(paste(sep="", "./examples/", args[1], ".csv"), sep=",", header=TRUE)
colnames(Y1) <- c("time","ts","count")
Y1$date <- as.POSIXct(Y1$time, format="%Y-%m-%dT%H:%M:%S")
Y1$series <- as.factor(args[1])
##############
Y2 = read.delim(paste(sep="", "./examples/", args[2], ".csv"), sep=",", header=TRUE)
colnames(Y2) <- c("time","ts","count")
Y2$date <- as.POSIXct(Y2$time, format="%Y-%m-%dT%H:%M:%S")
Y2$series <- as.factor(args[2])
##############
Y <- Y1
Y$count2 <- Y2$count
##############
png(filename = paste(sep="", args[3], ".png"), width = 550, height = 550, units = 'px')
    ggplot(data=Y) +
	geom_point(aes(count, count2), size=1, color="red") +
	stat_smooth(aes(count, count2), method="lm", color="blue") +
	geom_abline(intercept=0, slope=1, size=1, color="green") +
    labs(title = args[3]) +
    xlab(args[1]) +
    ylab(paste(args[2])) +
    theme(legend.position = 'none', text = element_text(size=20))
dev.off()
##############
Y$count <- (Y$count - min(Y$count))/(max(Y$count) - min(Y$count))
Y$count2 <- (Y$count2 - min(Y$count2))/(max(Y$count2) - min(Y$count2))
png(filename = paste(sep="", args[3], "_norm.png"), width = 550, height = 550, units = 'px')
    ggplot(data=Y) +
	geom_point(aes(count, count2), size=1, color="red") +
	stat_smooth(aes(count, count2), method="lm", size=1, color="blue") +
	geom_abline(intercept=0, slope=1, size=1, color="green") +
    labs(title = args[3]) +
    xlab(args[1]) +
    ylab(paste(args[2])) +
    theme(legend.position = 'none', text = element_text(size=20))
dev.off()
##############


#### MAIN FUNCTION 3.

#' @title
#' Plot a Z-score heatmap with events overlaid.
#'
#' @description
#' Plot a heatmap of z-scores, masking the z-scores at insignificant p-values. Rows in the heatmap correspond to clusters, and columns in the heatmap correspond to time intervals. Overlaid on this heatmap are events, where the increasing events are shown in red, and the decreasing events are shown in blue.
#'
#' @param list_concTpSummary Z-scores and p-values extracted from tukey-constrasts of consecutive time intervals for each cluster. Obtained by running the \code{summaryGetZP} function.
#' @param mat_events A matrix containing the event information generated by running the \code{calcEvents} function.
#' @param significanceTh P-value cutoff of the Tukey contrasts.
#'
#'
#'
#' @return Displays a plot and returns a matrix, with z-scores masked (NA) according to the signficance threshold specified. The plot also displays events calculated for the centroids.
#'
#' @importFrom methods is
#' @importFrom gplots heatmap.2
#' @importFrom grDevices colorRampPalette
#' @importFrom graphics segments
#' @importFrom shape Arrows
#'
#' @seealso \code{\link{summaryGetZP}}, \code{\link{calcEvents}}, \code{\link{plotZP}}
#'
#' @export
plotZP_withEvents <- function(list_concTpSummary, mat_events, significanceTh=0.05){

	stopifnot(is(list_concTpSummary, "summary.clusterChange"), is(mat_events, "matrix"), (significanceTh >0 && significanceTh <= 1))

	segs <- calcSegsOfCentroids(mat_events) # need to add to global, for graphics::segments to find.
	assign("segs", segs, envir=.GlobalEnv)
	theSignifs <- list_concTpSummary[[2]] < significanceTh

	matToPlot <- list_concTpSummary[[1]]

	rwb <- grDevices::colorRampPalette(colors = c("blue", "#cfcfcf", "red"))(n=299)

	if (!all(theSignifs)){
		zscore_largest <- ceiling(max(c(abs(min(matToPlot)), abs(max(matToPlot)))))
		theBreaks <- seq(-zscore_largest, zscore_largest, length.out=299)

		zscore_largest_noSignif <- max(c(abs(max(matToPlot[!theSignifs])), abs(min(matToPlot[!theSignifs]))))
		idx_forGray50 <- theBreaks <= zscore_largest_noSignif & theBreaks >= -zscore_largest_noSignif

		rwb[idx_forGray50] <- "#cfcfcf"

		matToPlot[!theSignifs] <- NA
	}

	titleTxt = paste("Significant changes\n(z-values of intervals,\n with significance p \u003C", significanceTh, ")", sep="")
	# print(titleTxt)

	idx_up = segs[[5]] == "#8B0000"
	assign("idx_up", idx_up, envir=.GlobalEnv)
	idx_down = segs[[5]] == "#00008B"
	assign("idx_down", idx_down, envir=.GlobalEnv)

	gplots::heatmap.2(matToPlot, main=titleTxt, xlab="Time interval", ylab="Cluster", Rowv=FALSE, Colv=FALSE, dendrogram="none", col=rwb, na.color="#cfcfcf", tracecol=NA, density.info="none", sepcolor="#cfcfcf", sepwidth=c(0.001, 0.001), colsep=0:ncol(matToPlot), rowsep=0:nrow(matToPlot), srtCol=45, add.expr=c(shape::Arrows(x0=segs[[1]][idx_up], x1=segs[[1]][idx_up], y0=segs[[2]][idx_up]-0.1,  y1=segs[[2]][idx_up]+0.5, arr.type="triangle", arr.length=0.2, arr.width=0.2, col="#8B0000", arr.adj=0, segment=FALSE), shape::Arrows(x0=segs[[1]][idx_down], x1=segs[[1]][idx_down], y0=segs[[2]][idx_down]+2,  y1=segs[[2]][idx_down]+0.5, arr.type="triangle", arr.length=0.2, arr.width=0.2, col="#00008B", arr.adj=0, segment=FALSE), graphics::segments(x0=segs[[1]], y0=segs[[2]]+0.3, x1=segs[[1]], y1=segs[[4]]-0.3, col=segs[[5]], lwd=3, lend=2)), cexCol=0.8)

	return (matToPlot)
}

addToMatrix <- function(theMat, clusNum, x_50, y_50, direction){
	theMat <- rbind(theMat, c(clusNum, x_50, y_50, direction))
	return (theMat)
}

calcSegsOfCentroids <- function(mat_fiftyPoints){

	totalNumCluster <- max(mat_fiftyPoints[,cols_matFifty$col_clus]) + 0.5
	y_val = totalNumCluster

	x <- c(); y <- c(); x1 <- c(); y1 <- c(); colors <- c();

	for (rowNum in 1:nrow(mat_fiftyPoints)){
		x[rowNum] <- mat_fiftyPoints[rowNum, cols_matFifty$col_x] - 0.5
		x1[rowNum] <- mat_fiftyPoints[rowNum, cols_matFifty$col_x] - 0.5
		y[rowNum] <- ((totalNumCluster - (mat_fiftyPoints[rowNum, cols_matFifty$col_clus])) * 1)
		y1[rowNum] <- ((totalNumCluster - (mat_fiftyPoints[rowNum, cols_matFifty$col_clus] - 1)) * 1)

		if (mat_fiftyPoints[rowNum, cols_matFifty$col_dir] == 1){
			colors[rowNum] <- "#8B0000"
		}
		else{
			colors[rowNum] <- "#00008B"
		}
	}

	return(list(x, y, x1, y1, colors))
}

getMidX <- function(x1, y1, x2, y2, y_50){
	m <- (y2 - y1)/(x2 - x1)
	x_50 <- x1 + ((y_50 - y1)/m)
	return (x_50)
}

#### MAIN FUNCTION 2.

#' @title
#' Calculate events for the cluster centroids.
#'
#'
#' @param timeRegions A list containing the time regions information.
#' @param clusters A vector with same length as number of profiles. The cluster labels are assumed to be numbers, starting from 1.
#' @param Tc A matrix containing time course data (from this centroids are computed, if not provided below).
#' @param centroids A matrix containing centroids. If no matrix is provided, the centroid are then compuated, and are a simple average of all the profiles within each cluster. Alternatively, for example, centroids from FCM clustering can be provided where profiles are weighted by the membership score.
#' @param phosEventTh Value between 0 and 1, to define the threshold at which a phosphorylation (or increasing) event occurs. Here, a threshold of 0 corresponds to the minimum value within an interval. (Such an event is designated as 1).
#' @param dephosEventTh Value between 0 and 1, to define the threshold at which a dephosphorylation (or decreasing) event occurs. A threshold of 0 corresponds to the maximum value within an interval. (Such an event is designated as -1).
#'
#'
#'
#' @return A matrix containing the details of the calculated events for the cluster centroids (event window information is appended to the matrix).
#'
#' @importFrom methods is
#'
#' @seealso \code{\link{getTimeRegionsWithMaximalChange}} to generate \code{timeRegions}.
#'
#' @export
calcEvents <- function(timeRegions, clusters, Tc=NA, centroids=NA, phosEventTh=0.5, dephosEventTh=0.5){

	stopifnot(is(timeRegions, "list"), (length(clusters) == nrow(Tc)), (phosEventTh >= 0 && phosEventTh <= 1), (dephosEventTh >= 0 && dephosEventTh <= 1), ( (!is.na(centroids)) || (is.na(centroids) && !is.na(Tc))) )

	mat_fiftyPoints <- matrix(ncol=length(Col_events), data=NA) # see Col_events

	if (is.na(centroids)){
		centroids = calcAvgOfClusProf(Tc, clusters)
	}

	# centroids = calcAvgOfClusProf()
	for (clusNum in 1:max(clusters)){
		if (nrow(timeRegions[[clusNum]]) > 0){
			for (i in 1:nrow(timeRegions[[clusNum]])){
				startTp = as.integer(min(timeRegions[[clusNum]][i, cols_timeReg$tpStart], timeRegions[[clusNum]][i, cols_timeReg$tpEnd]))
				endTp = as.integer(max(timeRegions[[clusNum]][i, cols_timeReg$tpStart], timeRegions[[clusNum]][i, cols_timeReg$tpEnd]))

				# print(paste("StartTp: ", startTp, endTp, timeRegions[[clusNum]][i, cols_timeReg$tpStart], timeRegions[[clusNum]][i, cols_timeReg$tpEnd]))

				crossPt <- calcCrossing_v3(centroids[clusNum, startTp:endTp], timeRegions[[clusNum]][i, cols_timeReg$dir], (startTp -1), phosEventTh, dephosEventTh)

				# if (crossPt[1] == -1){
					# print(clustered$center[clusNum, startTp:endTp])
				# }
				mat_fiftyPoints <- addToMatrixWithRegionInfo(mat_fiftyPoints, clusNum, crossPt[1], crossPt[2], timeRegions[[clusNum]][i, cols_timeReg$dir], startTp, endTp)
			}
		}
	}

	mat_fiftyPoints <- mat_fiftyPoints[-1,,drop=FALSE]

	# print(mat_fiftyPoints)
	mat_fiftyPoints <- mat_fiftyPoints[order(mat_fiftyPoints[,Col_events$clus],mat_fiftyPoints[,Col_events$x]),] # order by cluster, then time; else issue in downstream function (as only subsequent events are checked over there)

	colnames(mat_fiftyPoints) <- c("Cluster", "Time", "Th. abundance", "Direction", "Start interval", "End interval", "Order", "CombinedDatasetNum")

	return (mat_fiftyPoints)
}

addToMatrixWithRegionInfo <- function(theMat, clusNum, x_50, y_50, direction, tpStart, tpEnd){
	theRow <- c(clusNum, x_50, y_50, direction, tpStart, tpEnd, NA, NA)
	theMat <- rbind(theMat, theRow)
	rownames(theMat)[nrow(theMat)] <- ''
	return (theMat)
}

calcCrossing_v3 <- function(region, dir, offset, phosTh, dephosTh){

	x_50 <- -1 # initial time
	y_50 <- -1 # initial th_point

	y_max <- max(region)
	y_min <- min(region)

	if (dir == 1){
		y_10Percent <- (y_max - y_min) * phosTh
		y_50 <- y_min + y_10Percent
	}
	else{
		y_10Percent <- (y_max - y_min) * (1- dephosTh)
		y_50 <- y_min + y_10Percent
	}

	e = 0.0001 # due to calculation some round error when threshold is 0.
	# find intervals and store
	for (j in 2:length(region)){

		if (dir == 1 && ( (y_50 >= region[j-1] && y_50 <= region[j]) || abs(y_50 - region[j-1]) < e  || abs(y_50 - region[j]) < e )){
			# 50 is crossed here in phos direction
			x_50 <- getMidX((offset+j-1), region[j-1], offset+j, region[j], y_50)
			# mat_fiftyPoints <- addToMatrix(mat_fiftyPoints, clusNum, x_50, y_50, 1)
		}
		else if (dir == -1 && ( (y_50 <= region[j-1] && y_50 >=region[j]) || abs(y_50 - region[j-1]) < e  || abs(y_50 - region[j]) < e ) ){
			# 50 is crossed here in dephos direction
			# getMidX()
			x_50 <- getMidX((offset+j-1), region[j-1], offset+j, region[j], y_50)
			# mat_fiftyPoints <- addToMatrix(mat_fiftyPoints, clusNum, x_50, y_50, -1)

		}
	}

	return (c(x_50, y_50))
}

#' @title
#' A summary, providing percentage of profiles with missing events in each cluster.
#'
#' @description
#' Summary of clusters: providing information regarding the percentage of profiles which do not contain events within the identified time regions.
#'
#' @param Tc A matrix containing time course data.
#' @param clusters A vector with same length as number of profiles. The cluster labels are assumed to be numbers, starting from 1.
#' @param mat_events A matrix containing the event information generated by running the \code{calcEvents} function.
#' @param phosEventTh Value between 0 and 1, to define the threshold at which a phosphorylation (or increasing) event occurs. Here, a threshold of 0 corresponds to the minimum value within an interval. (Such an event is designated as 1).
#' @param dephosEventTh Value between 0 and 1, to define the threshold at which a dephosphorylation (or decreasing) event occurs. A threshold of 0 corresponds to the maximum value within an interval. (Such an event is designated as -1).
#'
#'
#'
#' @return A matrix providing the number of profiles missing events (1 events per row) for each cluster.
#'
#' @importFrom methods is
#'
#' @seealso \code{\link{getTimeRegionsWithMaximalChange}}, \code{\link[e1071]{cmeans}}.
#'
#' @export
missingStats <- function(Tc, clusters, mat_events, phosEventTh, dephosEventTh){

	stopifnot(is(Tc, "matrix"), (length(clusters) == nrow(Tc)), is(mat_events, "matrix"), (phosEventTh >= 0 && phosEventTh <= 1), (dephosEventTh >= 0 && dephosEventTh <= 1))

	list_matrices <- splitIntoSubMatrices(Tc, clusters)

	list_distributions <- getDistOfAllEvents_v2(mat_events, list_matrices, phosEventTh, dephosEventTh)

	list_distributions
	mat_missingStats <- matrix(ncol=7) #cluster, time, th.abun., dir, numNa, numTotal, percentNa

	for (eventNum in 1:length(list_distributions)){

		numNa <-length(which(is.na(list_distributions[[eventNum]][,cols_matFifty$col_x])))

		numTotal <- nrow(list_distributions[[eventNum]])

		percentNa <- (numNa * 100) / numTotal

		mat_missingStats <- rbind(mat_missingStats, c(mat_events[eventNum, cols_matFifty_v2$clus:cols_matFifty_v2$dir], numNa, numTotal, percentNa))

		# print(paste(eventNum, numNa, numTotal, percentNa, sep=" "))
	}

	colnames(mat_missingStats) <- c("Cluster", "Time", "Th. abun.", "Dir.", "Num. NA", "Num. total", "Percent NA")

	mat_missingStats <- mat_missingStats[-1,,drop=FALSE]
	return(mat_missingStats)
}

#### MAIN FUNCTION 1.

#' @title
#' Calculate time regions
#'
#' @description
#' Utilize the Tukey significantly constrasting intervals, and determine time regions. Time regions are intervals such that:
#' 1. the z-score is maximal
#' 2. if a region consists of any sub-intervals, they too have the same sign
#' 3. intervals are non-overlapping.
#'
#'
#' @param glmTukeyForEachClus A list (with same length as number of clusters) containing the GLM post-hoc Tukey contrasts for all time points. Obtained by running the \code{calcClusterChng} function.
#' @param numTps Total number of time points in the data.
#' @param signifTh P-value cutoff of the Tukey contrasts.
#' @param phosZscoreTh  A z-score value filter to remove phosphorylation (or increasing) events, such that all events with a z-score <= phosZscoreTh are removed.
#' @param dephosZscoreTh A z-score value filter to remove dephosphorylation (or decreasing) events, such that all events with a z-score >= dephosZscoreTh are removed.
#'
#' @return A List of matrices, one for each cluster, containing the time regions information. The columns in each matrix are cluster, zscore, start time point, end time point, and direction.
#'
#' @importFrom methods is
#'
#' @seealso \code{\link{calcClusterChng}}, \code{\link{missingStats}}
#'
#' @export
getTimeRegionsWithMaximalChange <- function(glmTukeyForEachClus, numTps, signifTh=0.05, phosZscoreTh=0, dephosZscoreTh=0){

	# Add checks
	stopifnot(is(glmTukeyForEachClus, "clusterChange"), numTps > 0, (signifTh > 0 && signifTh <= 1), phosZscoreTh >= 0, dephosZscoreTh <= 0)

	list_timeRegNoOvrlp <- list()

	for (i in 1:length(glmTukeyForEachClus)){ # for each cluster

		# convert z-scores to matrix (by time * time)
		combined <- convertToMatAndAddNAs(glmTukeyForEachClus[[i]], numTps, signifTh)

		# Convert regions to 0 which cannot statisfy zscoreTh.
		combined <- filterByZscore(combined, phosZscoreTh, dephosZscoreTh)

		# print(combined)
		# find time regions
		timeRegions <- findMonotonicRegions(combined, i)

		if (nrow(timeRegions) == 0){ # no time regions here.
			# print('yes recognized, can skip')
			list_timeRegNoOvrlp[[i]] <- timeRegions
		}
		else{
			timeRegions_noOverlaps<- removeAnyOverlaps(timeRegions)
			list_timeRegNoOvrlp[[i]] <- timeRegions_noOverlaps
		}

	}

	return(list_timeRegNoOvrlp)
}

filterByZscore <- function(combined, phosZscoreTh, dephosZscoreTh){
	# combined_local <- combined

	for (rowNum in 1:nrow(combined)){
		for (colNum in 1:ncol(combined)){

			if (!is.na(combined[rowNum, colNum]) && combined[rowNum, colNum] > 0 && combined[rowNum, colNum] < phosZscoreTh){
				combined[rowNum, colNum] <- 0

			}

			if (!is.na(combined[rowNum, colNum]) && combined[rowNum, colNum] < 0 && combined[rowNum, colNum] > dephosZscoreTh){

				combined[rowNum, colNum] <- 0

			}
		}
	}

	return (combined)
}

isAnyOverlap <- function(noOverlaps, currTp1, currTp2){

	if (nrow(noOverlaps) == 0){
		return (FALSE)
	}

	for (i in 1: nrow(noOverlaps)) {
		if (noOverlaps[i,cols_timeReg$tpStart] > min(c(currTp1,currTp2)) && noOverlaps[i,cols_timeReg$tpStart]  < max(c(currTp1, currTp2))) {
			return (TRUE)
		}
		if ((noOverlaps[i,cols_timeReg$tpEnd]  > min(c(currTp1,currTp2)) && noOverlaps[i,cols_timeReg$tpEnd]  <  max(c(currTp1, currTp2))) || (noOverlaps[i,cols_timeReg$tpEnd]  > currTp1 && noOverlaps[i,cols_timeReg$tpEnd]  < currTp2)){
			return (TRUE)
		}
		if (currTp1 > min(c(noOverlaps[i,cols_timeReg$tpStart],noOverlaps[i,cols_timeReg$tpEnd]))  && currTp2 < max(c(noOverlaps[i,cols_timeReg$tpStart], noOverlaps[i,cols_timeReg$tpEnd]) )) {
			return (TRUE)
		}
		if (currTp2 > min(c(noOverlaps[i,cols_timeReg$tpStart],noOverlaps[i,cols_timeReg$tpEnd]))  && currTp2 < max(c(noOverlaps[i,cols_timeReg$tpStart], noOverlaps[i,cols_timeReg$tpEnd]) ) ){
			return (TRUE)
		}
	}

	return (FALSE)
}

removeAnyOverlaps <- function(timeRegions){

	noOverlaps_phos <- matrix(ncol=5)
	noOverlaps_dephos <- matrix(ncol=5)
	isFirstAdded_phos <- FALSE
	isFirstAdded_dephos <- FALSE
	for (i in 1:nrow(timeRegions)){
		if (nrow(timeRegions) == 0){
			break;
		}
		if ( any(timeRegions[,cols_timeReg$zScore] > 0)){
			maxIdx <- which.max(timeRegions[,cols_timeReg$zScore])
			if (isFirstAdded_phos == FALSE){
				noOverlaps_phos <- rbind(noOverlaps_phos, timeRegions[maxIdx,])
				isFirstAdded_phos = TRUE
				noOverlaps_phos <- noOverlaps_phos[-1,,drop=FALSE ]
				# print(timeRegions)
			}
			else{
				if (isAnyOverlap(noOverlaps_phos, timeRegions[maxIdx,cols_timeReg$tpStart], timeRegions[maxIdx,cols_timeReg$tpEnd]) == FALSE){
					noOverlaps_phos <- rbind(noOverlaps_phos, timeRegions[maxIdx,])
				}
			}
			timeRegions <- timeRegions[-maxIdx,,drop=F]
		}

		if (nrow(timeRegions) > 0 && any(timeRegions[,cols_timeReg$zScore] < 0)){
			minIdx <- which.min(timeRegions[,cols_timeReg$zScore])
			if (isFirstAdded_dephos == FALSE){
				noOverlaps_dephos <- rbind(noOverlaps_dephos, timeRegions[minIdx,])
				isFirstAdded_dephos = TRUE
				noOverlaps_dephos <- noOverlaps_dephos[-1,,drop=FALSE]
			}
			else{
				if (isAnyOverlap(noOverlaps_dephos, timeRegions[minIdx,cols_timeReg$tpStart], timeRegions[minIdx,cols_timeReg$tpEnd]) == FALSE){
					noOverlaps_dephos <- as.matrix(rbind(noOverlaps_dephos, timeRegions[minIdx,]))
				}
			}
			timeRegions <- timeRegions[-minIdx,,drop=FALSE]
		}
	}

	if (is.na(noOverlaps_phos[1,1] )){
		return (noOverlaps_dephos)
	}
	if (is.na(noOverlaps_dephos[1,1])){
		return (noOverlaps_phos)
	}

	overlaps <- rbind(noOverlaps_phos, noOverlaps_dephos)

	return (overlaps)

}

addToTimeRegionsMat <- function(timeRegions, cluster, zScore, tpStart, tpEnd, direction){
	# dir = -1
	# if (zScore > 0){
	#	dir = 1
	# }
	tpStart = tpStart + 1
	# startReg = min(tpStart, tpEnd)
	# endReg = max(tpStart, tpEnd)

	timeRegions <- rbind(timeRegions, c(cluster, zScore, tpStart, tpEnd, direction))

	return(timeRegions)
}

########################### AUX
findMonotonicRegions <- function(combined, cluster){
	timeRegions <- matrix(ncol=5) # cluster, z-score, tpStart, tpEnd, direction, z-score

	direction = 0
	currMaxMin = 0
	rowStart = 0
	colStart = 0
	rowEnd = 0
	colEnd = 0

	# trial 3
	rowNum =1
	while (rowNum <= nrow(combined)){
		colNum = 1
		isBreak = FALSE
		while (colNum <= rowNum){
			if (combined[rowNum, colNum] > 0 && direction != 1) {
				# save any prev value ...
				if (currMaxMin < 0){
					timeRegions <- addToTimeRegionsMat(timeRegions, cluster, combined[rowEnd, colEnd], rowEnd, colEnd, direction)

					# print("Set 1: ")
					# print(paste(cluster, rowStart, colStart, rowEnd+1, colEnd, combined[rowEnd, colEnd], direction))
				}
				# new one encountered in + dir.
				direction = 1
				currMaxMin = combined[rowNum, colNum]
				rowStart = rowNum; rowEnd = rowNum; colStart = colNum; colEnd = colNum;

			}
			else if (combined[rowNum, colNum] > 0 && direction == 1 ){
				# encountered in same direction

				if (combined[rowNum, colNum] > currMaxMin){
					currMaxMin = combined[rowNum, colNum]
					rowEnd = rowNum; colEnd = colNum;
				}
			}

			if (combined[rowNum, colNum] < 0 && direction != -1) {
				# save any prev value ...
				if (currMaxMin > 0){
					# print(paste(rowStart, colStart, rowEnd+1, colEnd, combined[rowEnd, colEnd]))
					timeRegions <- addToTimeRegionsMat(timeRegions, cluster, combined[rowEnd, colEnd], rowEnd, colEnd, direction)

					# print("Set 2: ")
					# print(paste(cluster, rowStart, colStart, rowEnd+1, colEnd, combined[rowEnd, colEnd], direction))
				}
				# new one encountered in + dir.
				direction = -1
				currMaxMin = combined[rowNum, colNum]
				rowStart = rowNum; rowEnd = rowNum; colStart = colNum; colEnd = colNum;
				#print("here! ")
				#print(combined[rowNum, colNum])
			}
			else if (combined[rowNum, colNum] < 0 && direction == -1 ){
				# encountered in same direction
				if (combined[rowNum, colNum] < currMaxMin){
					currMaxMin = combined[rowNum, colNum]
					rowEnd = rowNum; colEnd = colNum;
				}
			}

			colNum = colNum + 1
		}

		rowNum = rowNum + 1

	}

	if ( rowEnd > 0 && colEnd > 0 && rowEnd <= nrow(combined) && colEnd <= ncol(combined) && combined[rowEnd, colEnd] != 0) {
		timeRegions <- addToTimeRegionsMat(timeRegions, cluster, combined[rowEnd, colEnd], rowEnd, colEnd, direction)

		# print(paste(rowStart, colStart, rowEnd+1, colEnd, combined[rowEnd, colEnd]))
	}

	timeRegions <- timeRegions[-1,, drop=FALSE]
	return (timeRegions)
}

convertToMatAndAddNAs <- function(glmTukeyForAClus, numTps, signifTh){
	mat_zscore <- matrix(nrow=(numTps-1), ncol=(numTps-1))
	mat_pvalue <- matrix(nrow=(numTps-1), ncol=(numTps-1))
	combined <- matrix(nrow=(numTps-1), ncol=(numTps-1)) # the row ranges from (2, 9), the col ranges from (1,8)

	for (val1 in seq(1, numTps)){
		if ((val1+1) <= numTps){
	#		for (val2 in seq((val1+1), (numTps))){
			for (val2 in seq((val1+1), numTps)) {

				name = paste(val2, "-", (val1))
				# print(name)

				idx = which(names(glmTukeyForAClus$test$tstat) == name )
				# print(paste(idx , name))
				# print(glmTukeyForAClus$test$tstat[idx])
		# 		print(glmTukeyForAClus$contrasts[idx,]$z.ratio)

				mat_zscore[val2-1, val1] <- as.numeric(glmTukeyForAClus$test$tstat[idx]) # * -1

				# idx = which(names(zscores) == name)

				mat_pvalue[val2-1, val1] <- glmTukeyForAClus$test$pvalues[[idx]]

				if(as.numeric(mat_pvalue[val2-1, val1]) < signifTh){
					combined[val2-1, val1] <- mat_zscore[val2-1, val1]
				}
				else{
					combined[val2-1, val1] <- 0
				}
				# print(name)
				# print(idx)

			}
		}
	}

	return (combined)
}


#
#  convert original Aglink .gdx files into a more appropriate format
#
#  output: MTO20XX.gdx file, to be read by scripts/convert_to_gdx.gms
#

# set library path on local computer
.libPaths( c(.libPaths(), "c:/Users/Public/R/libraries_x64_64"))

library(dplyr)
library(gdxrrw)
library(tidyverse)
igdx("c:/Program Files (x86)/GAMS/win64/28.2/")

setwd("c:/Users/Public/jrc_bl")

agri19 <- rgdx.param("data/result_EUNMerge_PostM.gdx", "p_dbvar")

agri19 <- as_tibble(agri19)

colnames(agri19) <- c("countries", "commodities", "attributes", "aglinkYears", "value")

agri19 <- agri19 %>% select(countries, attributes, commodities, aglinkYears, value)

# filter out undefined data points (Undf alredy in the input .gdx)
agri19 <- agri19 %>% filter(!is.na(value))

# write to .gdx
#--------------

DATAOUT <- as.data.frame(agri19)

DATAOUT$aglinkYears <- factor(DATAOUT$aglinkYears)
attr(DATAOUT, "symName") <- "DATAOUT"
attr(DATAOUT, "ts")      <- "output cube from Aglink"

# prepare GAMS sets
x <- agri19 %>% group_by(countries) %>% summarise(value = sum(value))
countries <- x$countries
countries <- as.data.frame(countries)
attr(countries, "symName") <- "countries"
attr(countries, "ts")      <- "countries in the output cube from Aglink"

x <- agri19 %>% group_by(attributes) %>% summarise(value = sum(value))
attributes <- x$attributes
attributes <- as.data.frame(attributes)
attr(attributes, "symName") <- "attributes"
attr(attributes, "ts")      <- "attributes in the output cube from Aglink"

x <- agri19 %>% group_by(commodities) %>% summarise(value = sum(value))
commodities <- x$commodities
commodities <- as.data.frame(commodities)
attr(commodities, "symName") <- "commodities"
attr(commodities, "ts")      <- "commodities in the output cube from Aglink"

x <- agri19 %>% group_by(aglinkYears) %>% summarise(value = sum(value))
aglinkYears <- x$aglinkYears
aglinkYears <- as.data.frame(aglinkYears)
attr(aglinkYears, "symName") <- "aglinkYears"
attr(aglinkYears, "ts")      <- "aglinkYears in the output cube from Aglink"

# 'tuple' will hold the combinations of (countries, attributes, commodities) with data
x <- agri19 %>% group_by(countries, attributes, commodities) %>% summarise(value = sum(value))
tuple <- x %>% select(-value)
tuple <- as.data.frame(tuple)
attr(tuple, "symName") <- "tuple"
attr(tuple, "ts")      <- "tuples in the output cube from Aglink"

rm(x)

wgdx.lst("data/MTO_2019.gdx", list(DATAOUT, commodities, attributes, aglinkYears, countries, tuple))


rm(list = ls())

library(readnet)
library(dplyr)

edgelist <- readxl::read_excel("playground/kayla/GROW_Edgelist clean for George.xlsx")
dat      <- readr::read_tsv("playground/kayla/GROW Attribute Data for George.csv")
ids2work <- readxl::read_excel("playground/kayla/GROW_Edgelist clean for George.xlsx", "NetMembersN400")

# Catched an error:
# Error: Missing ids in `data`. There are 610 observations in `data` and 613
# identified ids. The observations that are missing in `data` are: '812398',
# '812660', '831086'.

# The same error shows up when I run it filtering the data:
#
#  Error: Missing ids in `data`. There are 394 observations in `data` and 397
# identified ids. The observations that are missing in `data` are: '812398',
# '812660', '831086'. So
#
# So I'll just drop it!

dids <- unique(dat$study_id)
edgelist <- filter(edgelist, (Sender %in% dids) & (Receiver %in% dids))

ans <- edgelist_to_adjmat_w_attributes(
  edgelist         = edgelist,
  data             = dat,
  data.idvar       = "study_id",
  edgelist.timevar = "wave",
  ids.to.keep      = ids2work$study_id
  )


timestamp()

args=(commandArgs(TRUE))
idirBase = args[1]
label = args[2]
ofile = args[3]
strand = args[4]
probabilityFile = args[5]

# idirBase = "products/_06_seesawFitting_bin_5k"
# label = "chr6:94050766-94283009"
# ofile = ""

thPval = 1e-5
thProbability = 0.95

ifiles =  list.files(idirBase,
                      sprintf("%s.res.txt.gz", label),
                      recursive=TRUE, full.names=TRUE)

pvalfiles = list.files(idirBase,
                       sprintf("%s.pval.txt", label),
                       recursive=TRUE, full.names=TRUE)

path_rdata = sprintf("%s.rda", ofile)

source("scripts/r14_replot_fitting_bin_5k_coloringByPvalue/base_prepare.r", echo = TRUE)
source("scripts/r14_replot_fitting_bin_5k_coloringByPvalue/base.r", echo = TRUE)

sessionInfo()
timestamp()