#written and kindly provided by Roger Mundry
boot.glmm.pred<-function(model.res, excl.warnings=F, nboots=1000, para=F, resol=1000, level=0.95, use=NULL, circ.var.name=NULL, circ.var=NULL, use.u=F,
	n.cores=c("all-1", "all"), save.path=NULL, load.lib=T, lib.loc=.libPaths(), set.all.effects.2.zero=F){
	if(load.lib){library(lme4, lib.loc=lib.loc)}
	n.cores=n.cores[1]
	keepWarnings<-function(expr){
		localWarnings <- list()
		value <- withCallingHandlers(expr,
			warning = function(w) {
				localWarnings[[length(localWarnings)+1]] <<- w
				invokeRestart("muffleWarning")
			}
		)
		list(value=value, warnings=localWarnings)
	}
	##define function extracting all estimated coefficients (fixed and random effects) and also the model summary wrt random effects:
	extract.all<-function(mres){
		##extract random effects model summary:
		vc.mat=as.data.frame(summary(mres)$varcor)##... and prepare/extract variance covariance matrix from the model handed over
		xx=lapply(summary(mres)$varcor, function(x){attr(x, "stddev")})##append residual variance
		##create vector with names of the terms in the model
		xnames=c(names(fixef(mres)), paste(rep(names(xx), unlist(lapply(xx, length))), unlist(lapply(xx, names)), sep="@"))
		if(class(mres)[1]=="lmerMod"){xnames=c(xnames, "Residual")}##append "Residual" to xnames in case of Gaussian model
		if(class(mres)[1]=="lmerMod"){res.sd=vc.mat[vc.mat$grp=="Residual", "sdcor"]}##extract residual sd i case of Gaussian model
		#if(vc.mat$grp[nrow(vc.mat)]=="Residual"){vc.mat=vc.mat[-nrow(vc.mat), ]}##and drop residuals-row from vc.mat in case of Gaussisn model
		##deal with names in vc.mat which aren't exactly the name of the resp. random effect
		r.icpt.names=names(ranef(mres))##extract names of random intercepts...
		not.r.icpt.names=setdiff(vc.mat$grp, r.icpt.names)##... and names of the random effects having random slopes
		not.r.icpt.names=unlist(lapply(strsplit(not.r.icpt.names, split=".", fixed=T), function(x){paste(x[1:(length(x)-1)], collapse=".")}))
		vc.mat$grp[!vc.mat$grp%in%r.icpt.names]=not.r.icpt.names
		if(vc.mat$grp[nrow(vc.mat)]=="Residual"){vc.mat$var1[nrow(vc.mat)]=""}
		xnames=paste(vc.mat$grp, vc.mat$var1, sep="@")
		re.summary=unlist(vc.mat$sdcor)
		names(re.summary)=xnames
		ranef(mres)
		##extract random effects model summary: done
		##extract random effects details:
		re.detail=ranef(mres)
		xnames=paste(
			rep(x=names(re.detail), times=unlist(lapply(re.detail, function(x){nrow(x)*ncol(x)}))),
				unlist(lapply(re.detail, function(x){rep(colnames(x), each=nrow(x))})),
				unlist(lapply(re.detail, function(x){rep(rownames(x), times=ncol(x))})),
				sep="@")
		re.detail=unlist(lapply(re.detail, function(x){
			return(unlist(c(x)))
		}))
		#browser()
		#deal with negative binomial model to extract theta:
		xx=as.character(summary(mres)$call)
		if(any(grepl(x=xx, pattern="negative.binomial"))){
			xx=xx[grepl(x=xx, pattern="negative.binomial")]
			xx=gsub(x=xx, pattern="negative.binomial(theta = ", replacement="", fixed=T)
			xx=gsub(x=xx, pattern=")", replacement="", fixed=T)
			re.detail=c(re.detail, as.numeric(xx))
			xnames=c(xnames, "theta")
		}
		names(re.detail)=xnames
		ns=c(length(fixef(mres)), length(re.summary), length(re.detail))
		names(ns)=c("n.fixef", "n.re.summary", "n.re.detail")
		return(c(fixef(mres), re.summary, re.detail, ns))
	}
	if(excl.warnings){
		boot.fun<-function(x, model.res., keepWarnings., use.u., save.path.){
			xdone=F
			while(!xdone){
				i.res=keepWarnings(bootMer(x=model.res., FUN=extract.all, nsim=1, use.u=use.u.)$t)
				if(length(unlist(i.res$warnings)$message)==0){
					xdone=T
				}
			}
			est.effects=i.res$value
			i.warnings=NULL
			if(length(save.path.)>0){save(file=paste(c(save.path., "/b_", x, ".RData"), collapse=""), list=c("est.effects", "i.warnings"))}
			return(i.res$value)
		}
	}else{
		boot.fun<-function(y, model.res., keepWarnings., use.u., save.path.){
			#keepWarnings.(bootMer(x=model.res., FUN=fixef, nsim=1)$t)
			i.res=keepWarnings(bootMer(x=model.res., FUN=extract.all, nsim=1, use.u=use.u.))
			if(length(save.path.)>0){
				est.effects=i.res$value$t
				i.warnings=i.res$warnings
				save(file=paste(c(save.path., "/b_", y, ".RData"), collapse=""), list=c("est.effects", "i.warnings"))
			}
			return(list(ests=i.res$value$t, warns=unlist(i.res$warnings)))
		}
	}
	if(para){
		on.exit(expr = parLapply(cl=cl, X=1:length(cl), fun=function(x){rm(list=ls())}), add = FALSE)
		on.exit(expr = stopCluster(cl), add = T)
		library(parallel)
		cl <- makeCluster(getOption("cl.cores", detectCores()))
		if(n.cores!="all"){
			if(n.cores=="all-1"){n.cores=length(cl)-1}
			if(n.cores<length(cl)){
				cl=cl[1:n.cores]
			}
		}
		parLapply(cl=cl, 1:length(cl), fun=function(x, .lib.loc=lib.loc){
		  library(lme4, lib.loc=.lib.loc)
		  return(invisible(""))
		})
		all.res=parLapply(cl=cl, X=1:nboots, fun=boot.fun, model.res.=model.res, keepWarnings.=keepWarnings, use.u.=use.u, save.path.=save.path)
	}else{
    all.res=lapply(X=1:nboots, FUN=boot.fun, model.res.=model.res, use.u.=use.u, save.path.=save.path)#, keepWarnings=excl.warnings)
	}
	if(!excl.warnings){
		all.warns=lapply(all.res, function(x){
			xxx=unlist(x$warns)
			if(length(xxx)==0){xxx=""}
			return(xxx)
		})
		all.res=lapply(all.res, function(x){x$ests})
	}else{
		all.warns=NULL
	}
	if(length(use)>0){
		#extract fixed effects terms from the model:
		xcall=as.character(model.res@call)[2]
		model.terms=attr(terms(as.formula(xcall)), "term.labels")
		REs=names(ranef(model.res))
		#for(i in 1:length(REs)){
			model.terms=model.terms[!grepl(x=model.terms, pattern="|", fixed=T)]
		#}
		model=paste(model.terms, collapse="+")
		#build model wrt to the fixed effects:
		model.terms=unique(unlist(strsplit(x=model.terms, split=":", fixed=T)))
		model.terms=model.terms[!grepl(x=model.terms, pattern="I(", fixed=T)]
		model.terms=model.terms[!grepl(x=model.terms, pattern="^2)", fixed=T)]
		#exclude interactions and squared terms from model.terms:
		#create new data to be used to determine fitted values:
		ii.data=model.res@frame

		if(length(circ.var.name)==1){
			set.circ.var.to.zero=sum(circ.var.name%in%use)==0
		}else{
			set.circ.var.to.zero=F
		}

		if(length(use)==0){use=model.terms}
		new.data=vector("list", length(model.terms))
		usel=model.terms%in%use
		#if(length(use)>0)
		for(i in 1:length(model.terms)){
			if(is.factor(ii.data[, model.terms[i]])){
				new.data[[i]]=levels(ii.data[, model.terms[i]])
			}else if(!is.factor(ii.data[, model.terms[i]]) & usel[i] & ifelse(length(circ.var.name)==0, T, !grepl(x=model.terms[i], pattern=circ.var.name))){
				new.data[[i]]=seq(from=min(ii.data[, model.terms[i]]), to=max(ii.data[, model.terms[i]]), length.out=resol)
			}else  if(!is.factor(ii.data[, model.terms[i]]) & ifelse(length(circ.var.name)==0, T, !grepl(x=model.terms[i], pattern=circ.var.name))){
				new.data[[i]]=mean(ii.data[, model.terms[i]])
			}
		}
		names(new.data)=model.terms
		if(length(circ.var.name)==1){
			new.data=new.data[!(model.terms%in%paste(c("sin(", "cos("), circ.var.name, ")", sep=""))]
			if(sum(grepl(pattern=circ.var.name, x=use))>0){
				new.data=c(new.data, list(seq(min(circ.var, na.rm=T), max(circ.var, na.rm=T), length.out=resol)))
				names(new.data)[length(new.data)]=circ.var.name
			}else{
				new.data=c(new.data, list(0))
			}
			model.terms=model.terms[!(model.terms%in%paste(c("sin(", "cos("), circ.var.name, ")", sep=""))]
		}
		xnames=names(new.data)
		#browser()
		new.data=data.frame(expand.grid(new.data))
		names(new.data)=xnames
		#names(new.data)[1:length(model.terms)]=model.terms
		#browser()
		if(length(circ.var.name)==1){
			names(new.data)[ncol(new.data)]=circ.var.name
		}
		#create predictors matrix:
# 		if(length(circ.var.name)>0 & length(intersect(circ.var.name, names(new.data)))>0){
# 			new.data=cbind(new.data, sin(new.data[, circ.var.name]), cos(new.data[, circ.var.name]))
# 			names(new.data)[(ncol(new.data)-1):ncol(new.data)]=paste(c("sin(", "cos("), circ.var.name, ")", sep="")
# 			new.data=new.data[, !names(new.data)==circ.var.name]
# 		}
# 		browser()
		r=runif(nrow(new.data))
		if(set.all.effects.2.zero){
			for(iterm in setdiff(colnames(new.data), c("(Intercept)", use))){
				new.data[, iterm]=0
			}
		}
		m.mat=model.matrix(object=as.formula(paste(c("r", model), collapse="~")), data=new.data)
		if(set.circ.var.to.zero){
			m.mat[,paste(c("sin(", circ.var.name, ")"), collapse="")]=0
			m.mat[,paste(c("cos(", circ.var.name, ")"), collapse="")]=0
		}
		#m.mat=t(m.mat)
		#get the CIs for the fitted values:
		ci=lapply(all.res, function(x){
			#return(apply(m.mat[names(fixef(model.res)), , drop=F]*as.vector(x[, names(fixef(model.res))]), 2, sum))
			return(m.mat[, names(fixef(model.res)), drop=F]%*%as.vector(x[, names(fixef(model.res))]))
		})
		ci=matrix(unlist(ci), ncol=nboots, byrow=F)
		ci=t(apply(ci, 1, quantile, prob=c((1-level)/2, 1-(1-level)/2), na.rm=T))
		colnames(ci)=c("lower.cl", "upper.cl")
		fv=m.mat[, names(fixef(model.res))]%*%fixef(model.res)
		if(class(model.res)[[1]]!="lmerMod"){
			if(model.res@resp$family$family=="binomial"){
				ci=exp(ci)/(1+exp(ci))
				fv=exp(fv)/(1+exp(fv))
			}else if(model.res@resp$family$family=="poisson" | (model.res@resp$family$family=="Gamma" & model.res@resp$family$link=="log") | substr(x=model.res@resp$family$family, start=1, stop=17)=="Negative Binomial"){
				ci=exp(ci)
				fv=exp(fv)
			}
		}
		result=data.frame(new.data, fitted=fv, ci)
	}else{
		result=NULL
	}
	all.boots=matrix(unlist(all.res), nrow=nboots, byrow=T)
	colnames(all.boots)=colnames(all.res[[1]])
	ci.est=apply(all.boots, 2, quantile, prob=c((1-level)/2, 1-(1-level)/2), na.rm=T)
	if(length(fixef(model.res))>1){
		ci.est=data.frame(orig=fixef(model.res), t(ci.est)[1:length(fixef(model.res)), ])
	}else{
		ci.est=data.frame(orig=fixef(model.res), t(t(ci.est)[1:length(fixef(model.res)), ]))
	}
	return(list(ci.predicted=result, ci.estimates=ci.est, all.warns=all.warns, all.boots=all.boots))
}
###########################################################################################################
###########################################################################################################
boot.glmm.pred.list<-function(model.res, excl.warnings=F, nboots=1000, para=F, resol=100, level=0.95, use.list=NULL, circ.var.name=NULL, circ.var=NULL, use.u=F,
	n.cores=c("all-1", "all"), save.path=NULL, load.lib=T, lib.loc=.libPaths(), set.all.effects.2.zero=F){
	if(load.lib){library(lme4, lib.loc=lib.loc)}
	n.cores=n.cores[1]
	keepWarnings<-function(expr){
		localWarnings <- list()
		value <- withCallingHandlers(expr,
			warning = function(w) {
				localWarnings[[length(localWarnings)+1]] <<- w
				invokeRestart("muffleWarning")
			}
		)
		list(value=value, warnings=localWarnings)
	}
	##define function extracting all estimated coefficients (fixed and random effects) and also the model summary wrt random effects:
	extract.all<-function(mres){
		##extract random effects model summary:
		vc.mat=as.data.frame(summary(mres)$varcor)##... and prepare/extract variance covariance matrix from the model handed over
		xx=lapply(summary(mres)$varcor, function(x){attr(x, "stddev")})##append residual variance
		##create vector with names of the terms in the model
		xnames=c(names(fixef(mres)), paste(rep(names(xx), unlist(lapply(xx, length))), unlist(lapply(xx, names)), sep="@"))
		if(class(mres)[1]=="lmerMod"){xnames=c(xnames, "Residual")}##append "Residual" to xnames in case of Gaussian model
		if(class(mres)[1]=="lmerMod"){res.sd=vc.mat[vc.mat$grp=="Residual", "sdcor"]}##extract residual sd i case of Gaussian model
		#if(vc.mat$grp[nrow(vc.mat)]=="Residual"){vc.mat=vc.mat[-nrow(vc.mat), ]}##and drop residuals-row from vc.mat in case of Gaussisn model
		##deal with names in vc.mat which aren't exactly the name of the resp. random effect
		r.icpt.names=names(ranef(mres))##extract names of random intercepts...
		not.r.icpt.names=setdiff(vc.mat$grp, r.icpt.names)##... and names of the random effects having random slopes
		not.r.icpt.names=unlist(lapply(strsplit(not.r.icpt.names, split=".", fixed=T), function(x){paste(x[1:(length(x)-1)], collapse=".")}))
		vc.mat$grp[!vc.mat$grp%in%r.icpt.names]=not.r.icpt.names
		if(vc.mat$grp[nrow(vc.mat)]=="Residual"){vc.mat$var1[nrow(vc.mat)]=""}
		xnames=paste(vc.mat$grp, vc.mat$var1, sep="@")
		re.summary=unlist(vc.mat$sdcor)
		names(re.summary)=xnames
		ranef(mres)
		##extract random effects model summary: done
		##extract random effects details:
		re.detail=ranef(mres)
		xnames=paste(
			rep(x=names(re.detail), times=unlist(lapply(re.detail, function(x){nrow(x)*ncol(x)}))),
				unlist(lapply(re.detail, function(x){rep(colnames(x), each=nrow(x))})),
				unlist(lapply(re.detail, function(x){rep(rownames(x), times=ncol(x))})),
				sep="@")
		re.detail=unlist(lapply(re.detail, function(x){
			return(unlist(c(x)))
		}))
		#browser()
		#deal with negative binomial model to extract theta:
		xx=as.character(summary(mres)$call)
		if(any(grepl(x=xx, pattern="negative.binomial"))){
			xx=xx[grepl(x=xx, pattern="negative.binomial")]
			xx=gsub(x=xx, pattern="negative.binomial(theta = ", replacement="", fixed=T)
			xx=gsub(x=xx, pattern=")", replacement="", fixed=T)
			re.detail=c(re.detail, as.numeric(xx))
			xnames=c(xnames, "theta")
		}
		names(re.detail)=xnames
		ns=c(length(fixef(mres)), length(re.summary), length(re.detail))
		names(ns)=c("n.fixef", "n.re.summary", "n.re.detail")
		return(c(fixef(mres), re.summary, re.detail, ns))
	}
	if(excl.warnings){
		boot.fun<-function(x, model.res., keepWarnings., use.u., save.path.){
			xdone=F
			while(!xdone){
				i.res=keepWarnings(bootMer(x=model.res., FUN=extract.all, nsim=1, use.u=use.u.)$t)
				if(length(unlist(i.res$warnings)$message)==0){
					xdone=T
				}
			}
			est.effects=i.res$value
			i.warnings=NULL
			if(length(save.path.)>0){save(file=paste(c(save.path., "/b_", x, ".RData"), collapse=""), list=c("est.effects", "i.warnings"))}
			return(i.res$value)
		}
	}else{
		boot.fun<-function(y, model.res., keepWarnings., use.u., save.path.){
			#keepWarnings.(bootMer(x=model.res., FUN=fixef, nsim=1)$t)
			i.res=keepWarnings(bootMer(x=model.res., FUN=extract.all, nsim=1, use.u=use.u.))
			if(length(save.path.)>0){
				est.effects=i.res$value$t
				i.warnings=i.res$warnings
				save(file=paste(c(save.path., "/b_", y, ".RData"), collapse=""), list=c("est.effects", "i.warnings"))
			}
			return(list(ests=i.res$value$t, warns=unlist(i.res$warnings)))
		}
	}
	if(para){
		on.exit(expr = parLapply(cl=cl, X=1:length(cl), fun=function(x){rm(list=ls())}), add = FALSE)
		on.exit(expr = stopCluster(cl), add = T)
		library(parallel)
		cl <- makeCluster(getOption("cl.cores", detectCores()))
		if(n.cores!="all"){
			if(n.cores!="all-1"){n.cores=length(cl)-1}
			if(n.cores<length(cl)){
				cl=cl[1:n.cores]
			}
		}
		parLapply(cl=cl, 1:length(cl), fun=function(x, .lib.loc=lib.loc){
		  library(lme4, lib.loc=.lib.loc)
		  return(invisible(""))
		})
		all.res=parLapply(cl=cl, X=1:nboots, fun=boot.fun, model.res.=model.res, keepWarnings.=keepWarnings, use.u.=use.u, save.path.=save.path)
	}else{
    all.res=lapply(X=1:nboots, FUN=boot.fun, model.res.=model.res, use.u.=use.u, save.path.=save.path)#, keepWarnings=excl.warnings)
	}
	if(!excl.warnings){
		all.warns=lapply(all.res, function(x){
			xxx=unlist(x$warns)
			if(length(xxx)==0){xxx=""}
			return(xxx)
		})
		all.res=lapply(all.res, function(x){x$ests})
	}else{
		all.warns=NULL
	}
	if(length(use.list)>0){
		#extract fixed effects terms from the model:
		xcall=as.character(model.res@call)[2]
		model.terms=attr(terms(as.formula(xcall)), "term.labels")
		REs=names(ranef(model.res))
		#for(i in 1:length(REs)){
			model.terms=model.terms[!grepl(x=model.terms, pattern="|", fixed=T)]
		#}
		model=paste(model.terms, collapse="+")
		#build model wrt to the fixed effects:
		model.terms=unique(unlist(strsplit(x=model.terms, split=":", fixed=T)))
		model.terms=model.terms[!grepl(x=model.terms, pattern="I(", fixed=T)]
		model.terms=model.terms[!grepl(x=model.terms, pattern="^2)", fixed=T)]
		#exclude interactions and squared terms from model.terms:
		#create new data to be used to determine fitted values:
		ii.data=model.res@frame
		all.fitted=lapply(use.list, function(use){
			if(length(circ.var.name)==1){
				set.circ.var.to.zero=sum(circ.var.name%in%use)==0
			}else{
				set.circ.var.to.zero=F
			}

			if(length(use)==0){use=model.terms}
			new.data=vector("list", length(model.terms))
			usel=model.terms%in%use
			#if(length(use)>0)
			for(i in 1:length(model.terms)){
				if(is.factor(ii.data[, model.terms[i]])){
					new.data[[i]]=levels(ii.data[, model.terms[i]])
				}else if(!is.factor(ii.data[, model.terms[i]]) & usel[i] & ifelse(length(circ.var.name)==0, T, !grepl(x=model.terms[i], pattern=circ.var.name))){
					new.data[[i]]=seq(from=min(ii.data[, model.terms[i]]), to=max(ii.data[, model.terms[i]]), length.out=resol)
				}else  if(!is.factor(ii.data[, model.terms[i]]) & ifelse(length(circ.var.name)==0, T, !grepl(x=model.terms[i], pattern=circ.var.name))){
					new.data[[i]]=mean(ii.data[, model.terms[i]])
				}
			}
			names(new.data)=model.terms
			if(length(circ.var.name)==1){
				new.data=new.data[!(model.terms%in%paste(c("sin(", "cos("), circ.var.name, ")", sep=""))]
				if(sum(grepl(pattern=circ.var.name, x=use))>0){
					new.data=c(new.data, list(seq(min(circ.var, na.rm=T), max(circ.var, na.rm=T), length.out=resol)))
					names(new.data)[length(new.data)]=circ.var.name
				}else{
					new.data=c(new.data, list(0))
				}
				model.terms=model.terms[!(model.terms%in%paste(c("sin(", "cos("), circ.var.name, ")", sep=""))]
			}
			xnames=names(new.data)
			#browser()
			new.data=data.frame(expand.grid(new.data))
			names(new.data)=xnames
			#names(new.data)[1:length(model.terms)]=model.terms
			#browser()
			if(length(circ.var.name)==1){
				names(new.data)[ncol(new.data)]=circ.var.name
			}
			#create predictors matrix:
	# 		if(length(circ.var.name)>0 & length(intersect(circ.var.name, names(new.data)))>0){
	# 			new.data=cbind(new.data, sin(new.data[, circ.var.name]), cos(new.data[, circ.var.name]))
	# 			names(new.data)[(ncol(new.data)-1):ncol(new.data)]=paste(c("sin(", "cos("), circ.var.name, ")", sep="")
	# 			new.data=new.data[, !names(new.data)==circ.var.name]
	# 		}
	# 		browser()
			r=runif(nrow(new.data))
			if(set.all.effects.2.zero){
				for(iterm in setdiff(colnames(new.data), c("(Intercept)", use))){
					new.data[, iterm]=0
				}
			}
			m.mat=model.matrix(object=as.formula(paste(c("r", model), collapse="~")), data=new.data)
			if(set.circ.var.to.zero){
				m.mat[,paste(c("sin(", circ.var.name, ")"), collapse="")]=0
				m.mat[,paste(c("cos(", circ.var.name, ")"), collapse="")]=0
			}
			#m.mat=t(m.mat)
			#get the CIs for the fitted values:
			ci=lapply(all.res, function(x){
				#return(apply(m.mat[names(fixef(model.res)), , drop=F]*as.vector(x[, names(fixef(model.res))]), 2, sum))
				return(m.mat[, names(fixef(model.res)), drop=F]%*%as.vector(x[, names(fixef(model.res))]))
			})
			ci=matrix(unlist(ci), ncol=nboots, byrow=F)
			ci=t(apply(ci, 1, quantile, prob=c((1-level)/2, 1-(1-level)/2), na.rm=T))
			colnames(ci)=c("lower.cl", "upper.cl")
			fv=m.mat[, names(fixef(model.res))]%*%fixef(model.res)
			if(class(model.res)[[1]]!="lmerMod"){
				if(model.res@resp$family$family=="binomial"){
					ci=exp(ci)/(1+exp(ci))
					fv=exp(fv)/(1+exp(fv))
				}else if(model.res@resp$family$family=="poisson" | substr(x=model.res@resp$family$family, start=1, stop=17)=="Negative Binomial"){
					ci=exp(ci)
					fv=exp(fv)
				}
			}
			return(data.frame(new.data, fitted=fv, ci))
		})
		result=all.fitted
		names(result)=unlist(lapply(use.list, paste, collapse="@"))
	}else{
		result=NULL
	}

	all.boots=matrix(unlist(all.res), nrow=nboots, byrow=T)
	colnames(all.boots)=colnames(all.res[[1]])
	ci.est=apply(all.boots, 2, quantile, prob=c((1-level)/2, 1-(1-level)/2), na.rm=T)
	if(length(fixef(model.res))>1){
		ci.est=data.frame(orig=fixef(model.res), t(ci.est)[1:length(fixef(model.res)), ])
	}else{
		ci.est=data.frame(orig=fixef(model.res), t(t(ci.est)[1:length(fixef(model.res)), ]))
	}
	return(list(ci.predicted=result, ci.estimates=ci.est, all.warns=all.warns, all.boots=all.boots))
}

###########################################################################################################
###########################################################################################################
boot.glmm<-function(model.res, excl.warnings=F, nboots=1000, para=F, use.u=F, n.cores=c("all-1", "all"), save.path=NULL){
	n.cores=n.cores[1]
	keepWarnings<-function(expr) {
		localWarnings <- list()
		value <- withCallingHandlers(expr,
			warning = function(w) {
				localWarnings[[length(localWarnings)+1]] <<- w
				invokeRestart("muffleWarning")
			}
		)
		list(value=value, warnings=localWarnings)
	}
	if(excl.warnings){
		boot.fun<-function(x, model.res., keepWarnings., use.u., save.path.){
			xdone=F
			while(!xdone){
				i.res=keepWarnings.(bootMer(x=model.res., FUN=fixef, nsim=1, use.u=use.u.)$t)
				if(length(unlist(i.res$warnings)$message)==0){
					xdone=T
				}
			}
			if(length(save.path.)>0){
				i.res=i.res$value
				save(file=paste(c(save.path., "/b_", x, ".RData"), collapse=""), list="i.res")
			}
			return(i.res$value)
		}
	}else{
		boot.fun<-function(x, model.res., keepWarnings., use.u., save.path.){
			i.res=bootMer(x=model.res, FUN=fixef, nsim=1, use.u=use.u.)$t
			if(length(save.path.)>0){
				save(file=paste(c(save.path., "/b_", x, ".RData"), collapse=""), list="i.res")
			}
			return(i.res)
		}
	}
	if(para){
		require(parallel)
    cl <- makeCluster(getOption("cl.cores", detectCores()))
		if(n.cores!="all"){
			if(n.cores!="all-1"){n.cores=length(cl)-1}
			if(n.cores<length(cl)){
				cl=cl[1:n.cores]
			}
		}
    parLapply(cl=cl, 1:length(cl), fun=function(x){
      library(lme4)
      return(invisible(""))
    })
    all.coeffs=parLapply(cl=cl, X=1:nboots, fun=boot.fun, model.res.=model.res, keepWarnings.=keepWarnings, use.u=use.u, save.path.=save.path)
    parLapply(cl=cl, X=1:length(cl), fun=function(x){rm(list=ls())})
    stopCluster(cl)
	}else{
    all.coeffs=lapply(X=1:nboots, FUN=boot.fun, model.res.=model.res, keepWarnings.=keepWarnings, use.u=use.u, save.path.=save.path)
	}
	ci=matrix(unlist(all.coeffs), nrow=length(all.coeffs), byrow=T)
	colnames(ci)=names(fixef(model.res))
	ci=apply(ci, 2, quantile, prob=c(0.025, 0.975), na.rm=T)
	ci=data.frame(orig=fixef(model.res), t(ci))
	return(ci)
}


# Examine the probabilities of null model producing results as extreme as our observations
# run after wfs_nullmodel_function.r and wfs_nullmodel_combine.r/wfs_nullmodel_lowp_rerun.r
# Script looks at the output
require(data.table)
require(ggplot2)
require(RColorBrewer)

#####################
## Functions
#####################

# takes p-values and returns a color
# uses colout for p<thresh, otherwise a colorbrewer palette
# alternates color by chromosome
lgcolsramp <- function(x, lg = 1, thresh = 0.05){
  if(lg == 1) rmp <- colorRamp(brewer.pal(11, 'BrBG')[5:1])
  if(lg == 2) rmp <- colorRamp(brewer.pal(11, 'BrBG')[7:11])
  if(!(lg %in% c(1,2))) error('lg must be 1 or 2')
  out <- rep(colout, length(x))
  out[x <= thresh] <- colout
  rgbs <- rmp(-log10(x[x > thresh])/-log10(thresh))
  out[x > thresh] <- rgb(rgbs[,1], rgbs[,2], rgbs[,3], maxColorValue = 256)
  return(out)
}

# draw a vertical colorbar at xposmin to xposmax, from yposmin to yposmax
# cols in hex, x are values to go with each col
color.bar <- function(cols, x, axis = TRUE, cex = 1, nticks=11,
                      xposmin, xposmax, yposmin, yposmax, title = '', titley = yposmax) {
  scale = (length(cols)-1)/(yposmax - yposmin)

  for (i in 1:(length(cols)-1)) {
    y = (i-1)/scale + yposmin
    rect(xposmin,y,xposmax,y+1/scale, col=cols[i], border=NA)
  }

  if(axis){
    line(c(xposmax, xposmax), c(yposmin, yposmax))
    line(c(xposmax, xposmax + (xposmax-xposmin)/2), c(yposmin, yposmin))
    line(c(xposmax, xposmax + (xposmax-xposmin)/2), c(yposmax, yposmax))
    at = seq(yposmin, yposmax, length.out = nticks)
    labs <- signif(x[round(seq(1, length(x), length.out = nticks))], 2)
    text(rep(xposmax + (xposmax-xposmin)/2, nticks), y = at, labels = labs, adj = 0, cex = cex)
  }

  text(xposmin, titley, title, adj = 0.5, cex = cex)
}

##########
## Prep
##########

# 1907-2011-2014
fst <- fread('analysis/gatk.lof07-11-14.weir.fst', header=TRUE)
dat <- readRDS(file=paste('analysis/wfs_nullmodel_pos&pvals_07-11-14.rds', sep='')) # has p-values
nrow(dat)
dat <- merge(fst, dat[, .(CHROM, POS, p)], by = c('CHROM', 'POS'))
nrow(dat)

# Canada
fstCan <- fread('analysis/gatk.can.weir.fst', header=TRUE)
datCan <- readRDS(file=paste('analysis/wfs_nullmodel_pos&pvals_Can.rds', sep='')) # has p-values
nrow(datCan)
datCan <- merge(fstCan, datCan[, .(CHROM, POS, p)], by = c('CHROM', 'POS'))
nrow(datCan)

# trim to unlinked nodam2 loci
unlCan <- fread('analysis/ld.unlinked.Can.gatk.nodam.csv.gz')
datCan <- merge(datCan, unlCan, by = c('CHROM', 'POS'))

unlLof <- fread('analysis/ld.unlinked.Lof.gatk.nodam.csv.gz')
dat <- merge(dat, unlLof, by = c('CHROM', 'POS'))

# only consider Lof loci for which 2011-2014 are more similar than to 1907
freqLof07 <- fread('data_31_01_20/Lof_07_freq.mafs.gz')
freqLof11 <- fread('data_31_01_20/Lof_11_freq.mafs.gz')
freqLof14 <- fread('data_31_01_20/Lof_14_freq.mafs.gz')

nrow(dat)
dat <- merge(dat, freqLof07[, .(CHROM = chromo, POS = position, freq07 = knownEM)], by = c('CHROM', 'POS'))
dat <- merge(dat, freqLof11[, .(CHROM = chromo, POS = position, freq11 = knownEM)], by = c('CHROM', 'POS'))
dat <- merge(dat, freqLof14[, .(CHROM = chromo, POS = position, freq14 = knownEM)], by = c('CHROM', 'POS'))
nrow(dat)
dat[, sum(p < 0.05)]
dat[, sum(p < 0.005)]

dat <- dat[abs(freq11 - freq14) < abs(freq14 - freq07) & abs(freq11 - freq14) < abs(freq11 - freq07), ]
nrow(dat)
dat[, sum(p < 0.05)]
dat[, sum(p < 0.005)]

dat[, c('freq07', 'freq11', 'freq14') := NULL]

# combine
dat[, pop := 'Lof']
datCan[, pop := 'Can']
dat <- rbind(dat, datCan)

# remove unplaced
dat <- dat[CHROM != 'Unplaced', ]

# add genome position
chrmax <- fread('data/lg_length.csv')
chrmax[, start := c(0,cumsum(chrmax$len)[1:(nrow(chrmax)-1)])]

dat <- merge(dat, chrmax[, .(CHROM = chr, start)], by = c('CHROM'))
dat[, POSgen := POS + start]
dat[,start := NULL]

# calculate FDR
dat[, p.adj := p.adjust(p), by = pop]

# write out
write.csv(dat[, .(CHROM, POS, pop, p, p.adj)], file = gzfile('analysis/wfs_nullmodel_padj.csv.gz'), row.names = FALSE)

##################
## basic analysis
##################
dat[,min(p, na.rm=TRUE), by = pop]
dat[,min(p.adj, na.rm=TRUE), by = pop]

# lowest FDR-correct p-values
dat[pop == 'Can' & p.adj < 0.21, .(CHROM, POS, WEIR_AND_COCKERHAM_FST, nloci, p, p.adj)]
dat[pop == 'Lof' & p.adj < 0.14, .(CHROM, POS, WEIR_AND_COCKERHAM_FST, nloci, p, p.adj)]

#####################
## plots
#####################
colout <- '#b2182b' # red, part of RdGy colorbrewer, for outlier loci

# add a vector for color by LG
lgs <- dat[, sort(unique(CHROM))]
dat[,lgcol := lgcolsramp(p.adj, lg = 1, thresh = 0.1)]
dat[CHROM %in% lgs[seq(2, length(lgs),by=2)], lgcol := lgcolsramp(p.adj, lg = 2, thresh = 0.1)]

# order
setorder(dat, pop, -p.adj)

# histogram of p-values
# png(width=5, height=4, filename='figures/wfs_nullmodel_hist_pvals.png', units='in', res=300)
ggplot(dat, aes(p, group = pop)) +
  geom_histogram() +
  facet_grid(~pop)

	dev.off()

# histogram of FDR-adjusted p-values
# png(width=5, height=4, filename='figures/wfs_nullmodel_hist_padjvals.png', units='in', res=300)
	ggplot(dat, aes(p.adj, group = pop)) +
	  geom_histogram() +
	  facet_grid(~pop)

	dev.off()

# Per locus FST vs. genome position, colored by -log10(p)
# for plotting a colorbar
cbar <- data.frame(logx = seq(0, 1.30103, length.out=50))
cbar$x <- 10^(-cbar$logx)
cbar$col1 <- lgcolsramp(cbar$x, lg = 1, thresh = 0.1)
cbar$col2 <- lgcolsramp(cbar$x, lg = 2, thresh = 0.1)

png(filename = paste0('figures/wfs_nullmodel_fst_vs_position_by_p.png'), width = 20, height = 12, units = "in", res = 150)
par(mfrow = c(2,1))
dat[pop == 'Can' & !is.na(WEIR_AND_COCKERHAM_FST), plot(POSgen/1e6, WEIR_AND_COCKERHAM_FST, xlab = 'Position (Mb)', ylab = "FST",
                       main = 'Canada', col = lgcol, cex = 0.5)]

dat[pop == 'Lof' & !is.na(WEIR_AND_COCKERHAM_FST), plot(POSgen/1e6, WEIR_AND_COCKERHAM_FST, xlab = 'Position (Mb)', ylab = "FST",
                                                        main = 'Lof', col = lgcol, cex = 0.5)]

color.bar(cbar$col1, cbar$x, axis = FALSE, xposmin =640, xposmax = 645,
          yposmin = 0.2, yposmax = 0.5)
color.bar(cbar$col2, cbar$x, cex = 0.5, axis = TRUE, nticks = 5,
          xposmin =645, xposmax = 650, yposmin = 0.2, yposmax = 0.5, title = 'FDR p-value', titley = 0.55)

dev.off()


stom<-Read.stomach.data()

a<-aggregate(list(Pred.avail=stom$Prey.avail.part),
              list(Year=stom$Year,Quarter=stom$Quarter,Predator=stom$Predator,Predator.length.class=stom$Predator.length.class),sum)
stom<-merge(stom,a)
stom$stomcon.hat.part<-stom$Prey.avail.part/stom$Pred.avail
stom$Residual.part<-stom$stom.input-stom$stomcon.hat.part
stom<-transform(stom,year.range=ifelse(Year<=1981,'1977-81','1982-93'),year=paste("Y",Year,sep=''))

write.csv(stom, file = file.path(data.path,'ASCII_stom_data.csv'),row.names = FALSE)
stomAll<-stom  # all stomach input irrespectiv of actually use
stom<-subset(stom,stom.used.all==1)  # used stomachs specified for input

tr<-trellis.par.get( "background")
# old value  tr$col="#909090"
tr$col="white"
trellis.par.set("background", tr)

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

####################################
# observation by predator-prey size ratio
## prog size 1b

cleanup()
nox<-2; noy<-2;
newplot(dev,nox,noy);
i<-0

stom3<-subset(stom,  (Size.model==1 | Size.model==11) &  Prey.no>0 & Predator %in% c('H. porpoise','Grey seal'))

stom3<-subset(stom,  (Size.model==1 | Size.model==11) &  Prey.no>0 )

# just checking
a<-aggregate(list(stom=stom3$stomcon,stom.input=stom3$stom.input,stom.hat=stom3$stomcon.hat,stom.hat.part=stom3$stomcon.hat.part),
             list(Year=stom3$Year,Quarter=stom3$Quarter,Predator=stom3$Predator,Pred_l=stom3$Predator.length),sum)

# use the individual data points (not the liklihood data) when size mode is 11
stom3[stom3$Size.model==11,]$stomcon<-    stom3[stom3$Size.model==11,]$stom.input
stom3[stom3$Size.model==11,]$stomcon.hat<-stom3[stom3$Size.model==11,]$stomcon.hat.part

# to get rit of "Other"
write.csv(stom3, file = file.path(data.path,'junk.csv'),row.names = FALSE)
stom3<-read.csv(file = file.path(data.path,'junk.csv'))

# start with a high fac for calc of mean and var
fac<-50
a<-aggregate(list(stom=stom3$stomcon*5000,stom.hat=stom3$stomcon.hat*5000)
             ,list(Predator=stom3$Predator,PredPrey=trunc(log(stom3$Predator.size/stom3$Prey.size)*fac)/fac),sum)

# by(a,list(a$Predator),function(x) weighted.mean(x$PredPrey, x$stom))

bb<-data.frame(size=rep(a$PredPrey,trunc(a$stom)),Predator=rep(a$Predator,trunc(a$stom)))
k1<-aggregate(list(mean=bb$size),list(Predator=bb$Predator),mean)
k2<-aggregate(list(var=bb$size),list(Predator=bb$Predator),var)
stat<-merge(k1,k2)

bb<-data.frame(size=rep(a$PredPrey,trunc(a$stom.hat)),Predator=rep(a$Predator,trunc(a$stom.hat)))
k1<-aggregate(list(mean.hat=bb$size),list(Predator=bb$Predator),mean)
k2<-aggregate(list(var.hat=bb$size),list(Predator=bb$Predator),var)
stat.hat<-merge(k1,k2)

stat<-merge(stat,stat.hat)
stat

# decrease fac for a  nice plot
fac<-2
a<-aggregate(list(stom=stom3$stomcon, stomNo=stom3$stomcon/stom3$Prey.weight,stom.hat=stom3$stomcon.hat),list(Predator=stom3$Predator,
                                      PredPrey=trunc(log(stom3$Predator.size/stom3$Prey.size)*fac)/fac),sum)
b<-aggregate(list(sumstom=a$stom, sumstomNo=a$stomNo, sumstom.hat=a$stom.hat),list(Predator=a$Predator),sum)
a<-merge(a,b)
a<-merge(a,stat)
a$stom<-a$stom/a$sumstom
a$stomNo<-a$stomNo/a$sumstomNo
a$stom.hat<-a$stom.hat/a$sumstom.hat

## observed
a$headt<-paste(a$Predator,", mean=",formatC(a$mean,digits=2,format='f')," var=",formatC(a$var,digits=2,format='f'),sep='')

cleanup()
trellis.device(device = "windows",
               color = T, width=9, height=17,pointsize = 12,
               new = TRUE, retain = FALSE)
cleanup()
trellis.device(device = "windows",
               color = T, width=18, height=22,pointsize = 12,
               new = TRUE, retain = FALSE)

 barchart(stom~as.factor(PredPrey)|headt, data=a,
    groups = Predator, stack = TRUE,      # this line is not needed, but it gives a nicer offset on the Y-axis
    xlab='log(predator weight/prey weight)',ylab='Proportion',
    strip = strip.custom( bg='white'),par.strip.text=list(cex=0.6, lines=2),
    scales = list(x = list(rot = 90, cex=0.5), y= list(alternating = 1,cex=0.5)),
    layout = c(3,4) ,col='grey')

b1<-a
b1$type<-paste(a$headt,'\nObserved',sep='');

## predicted
a$headt<-paste(a$Predator," mean=",formatC(a$mean.hat,digits=2,format='f')," var=",formatC(a$var.hat,digits=2,format='f'),sep='')

trellis.device(device = "windows",
               color = T, width=18, height=22,pointsize = 12,
               new = TRUE, retain = FALSE)

  barchart(stom.hat~as.factor(PredPrey)|headt, data=a,
    groups = Predator, stack = TRUE,      # this line is not needed, but it gives a nicer offset on the Y-axis
    xlab='log(predator weight/prey weight)',ylab='Proportion',
    strip = strip.custom( bg='white'),par.strip.text=list(cex=0.6, lines=2),
    scales = list(x = list(rot = 90, cex=0.5), y= list(alternating = 1,cex=0.5)),
    layout = c(3,4) ,col='grey')

b2<-a

b2$type<-paste(a$headt,'\nPredicted',sep='');

# both on the same plot
b2$stom<-b2$stom.hat
aa<-rbind(b1,b2)

trellis.device(device = "windows",
               color = T, width=17, height=17,pointsize = 12,
               new = TRUE, retain = FALSE)

 barchart(stom~as.factor(PredPrey)|type, data=aa,
     groups = Predator, stack = TRUE,      # this line is not needed, but it gives a nicer offset on the Y-axis

    xlab='log(predator weight/prey weight)',ylab='Proportion',
    strip = strip.custom( bg='white'),par.strip.text=list(cex=1, lines=2),
    scales = list(x = list(rot = 45, cex=1), y= list(alternating = 1,cex=1)),
    layout = c(2, 3) ,col='grey')

#####################
# same as above, but with contributions from prey species

fac<-2
a<-aggregate(list(stom=stom3$stomcon, stomNo=stom3$stomcon/stom3$Prey.weight,stom.hat=stom3$stomcon.hat),list(Predator=stom3$Predator,
                                      Prey=stom3$Prey,
                                      PredPrey=trunc(log(stom3$Predator.size/stom3$Prey.size)*fac)/fac),sum)
b<-aggregate(list(sumstom=a$stom, sumstomNo=a$stomNo, sumstom.hat=a$stom.hat),list(Predator=a$Predator),sum)
a<-merge(a,b)
a<-merge(a,stat)
a$stom<-a$stom/a$sumstom
a$stomNo<-a$stomNo/a$sumstomNo
a$stom.hat<-a$stom.hat/a$sumstom.hat

## observed
a$headt<-paste(a$Predator,", mean=",formatC(a$mean,digits=2,format='f')," var=",formatC(a$var,digits=2,format='f'),sep='')

#cleanup()
trellis.device(device = "windows",
               color = T, width=17, height=17,pointsize = 12,
               new = TRUE, retain = FALSE )

b<- tapply(stom3$stomcon,list(stom3$Prey),sum)
dim(b)

col<-1:dim(b)
lab<-dimnames(b)[[1]]

 barchart(stom~as.factor(PredPrey)|headt, data=a,
 groups = Prey, stack = TRUE,  col=1:dim(b),
    xlab='log(predator weight/prey weight)',ylab='Proportion',
    strip = strip.custom( bg='white'),par.strip.text=list(cex=0.75, lines=2),
    key = list(text = list(label = lab,col=1), rectangles = TRUE, space = "right", col=1:dim(b)),
    scales = list(x = list(rot = 45, cex=1), y= list(alternating = 1,cex=1)),
    layout = c(2, 2) )

b1<-a
b1$type<-paste(a$headt,'\nObserved',sep='');

## predicted
a$headt<-paste(a$Predator," mean=",formatC(a$mean.hat,digits=2,format='f')," var=",formatC(a$var.hat,digits=2,format='f'),sep='')
trellis.device(device = "windows",
               color = T, width=17, height=17,pointsize = 12,
               new = TRUE, retain = FALSE )

 barchart(stom.hat~as.factor(PredPrey)|headt, data=a,
 groups = Prey, stack = TRUE,  col=1:dim(b),
    xlab='log(predator weight/prey weight)',ylab='Proportion',
    strip = strip.custom( bg='white'),par.strip.text=list(cex=0.75, lines=2),
    key = list(text = list(label = lab,col=1), rectangles = TRUE, space = "right", col=1:dim(b)),
    scales = list(x = list(rot = 45, cex=1), y= list(alternating = 1,cex=1)),
    layout = c(2, 2) )

b2<-a

b2$type<-paste(a$headt,'\nPredicted',sep='');

# both on the same plot
b2$stom<-b2$stom.hat
aa<-rbind(b1,b2)

trellis.device(device = "windows",
               color = T, width=17, height=17,pointsize = 12,
               new = TRUE, retain = FALSE)

 barchart(stom~as.factor(PredPrey)|type, data=aa,
     groups = Prey, stack = TRUE,  col=1:7,    # this line is not needed, but it gives a nicer offset on the Y-axis
    xlab='log(predator weight/prey weight)',ylab='Proportion',
    strip = strip.custom( bg='white'),par.strip.text=list(cex=0.75, lines=2),
    key = list(text = list(label = lab,col=1), rectangles = TRUE, space = "right", col=1:7),
    scales = list(x = list(rot = 45, cex=1), y= list(alternating = 1,cex=1)),
    layout = c(2, 3) )


#' Calculate GC3 value of a codon sequence
#'
#' Outputs an array of numbers, representing the proportion of codons with G/C bases in the third position
#'
#' @param x a list of KZsqns objects.
#' @return a number array of GC3s.
#'
#' @examples
#' data('CodonTable0')
#' x = vector('list', 5) # Creating an empty list of length 5
#' for(i in 1:5){
#'   x[[i]] = CodonTable0[sample(1:64, 10*i, TRUE),1]
#'   attr(x[[i]], 'class') = 'KZsqns'
#' }
#'
#' cat(gc3(x))
#' @export

gc3 <- function(x){
  if(!is.list(x)){
    cat("Just one perhap very long sequence?\n")
    x = list(x)
  }
  ans = matrix(0, length(x), 1)
  colnames(ans) <- 'GC3'
  rownames(ans) <- paste0('s_', 1:length(x))
  temp = n3_freq(x)
  ans[,1] = rowSums(temp[,c('G3', 'C3'), drop=F])
  return(ans)
}


fn.flow = file.path(PROJECT_DIR, "data", "CHI", "flow", "bp_flow_data.txt")
flow = fread(fn.flow) %>% tibble::column_to_rownames("Sample") %>%
  data.matrix()

flow.poB = flow[,-(1:5)] / flow[,"B_cells"] * 100

flow.info = sub("^\\d+: (.+)\\.fcs","\\1",rownames(flow.poB)) %>%
            gsub("pre ","-",.) %>% data.frame(sample=.) %>%
            separate(sample, c("subject","time"), sep="_", remove = F) %>%
            mutate(time = as.integer(time)) %>%
            mutate(time.point = paste0(ifelse(time<0,"pre","day"),abs(time))) %>%
            mutate(sample = paste(subject, time.point, sep="_"))

rownames(flow.poB) = flow.info$sample

fn.flag = file.path(PROJECT_DIR, "data", "CHI", "flow", "bp_flow_sample_flagged.txt")
flow.flag = fread(fn.flag)

flow.info = flow.info %>% left_join(flow.flag, by="sample")

fn.flow.poB = file.path(PROJECT_DIR, "generated_data", "CHI", "flow_percent_of_B.txt")
fn.flow.si = file.path(PROJECT_DIR, "generated_data", "CHI", "flow_sample_info.txt")

flow.poB %>% as.data.frame() %>% tibble::rownames_to_column("sample") %>%
  fwrite(fn.flow.poB, sep="\t", quote=T)

fwrite(flow.info, fn.flow.si, sep="\t", quote=T)


library(ggplot2)
library(ggthemes)

source('colors.r')

# pdf('../pdfs/peak_pos_histogram.pdf',width=7.46,height=4.1983)

data = read.csv(file='../cleaned_data.csv', sep=',', header = TRUE)

reset <- par(mar=rep(0,4))

plot <- ggplot(data, aes(x=peak_pos)) +
        geom_histogram(data = data, aes(x=peak_pos), color='white', fill = '#fcde05', binwidth = 1) +
        theme_wsj(color='white') +
        # coord_flip() +
        scale_y_continuous(breaks = seq(0, 900, by = 200)) +
        scale_x_continuous(breaks = seq(0, 100, by = 10)) +
        guides(alpha = FALSE) +
        theme(plot.margin=grid::unit(c(0,0,0,0), 'mm'))

par(reset)
print(plot)
par(reset)
# dev.off()


library(scales)
library(ggplot2)
library(gridExtra)
library(data.table)
library(RColorBrewer)

args <- commandArgs(trailingOnly = TRUE)

file1 <- args[1]
file2 <- args[2]
file3 <- args[3]
call <- args[4]
date1 <- args[5]
date2 <- args[6]

# file1 <- 'wsprspots-2016-04-SWLJO20.csv'
# file2 <- 'wsprspots-2016-04-PI4THT.csv'
# file3 <- 'wsprspots-2016-04-snr-diff-SWLJO20.png'
# call <- 'SWLJO20'
# date1 <- '2016-04-01'
# date2 <- '2016-12-31'

colNames <- c('id', 'epoch', 'rcall',
  'rgrid', 'snr', 'freq', 'call',
  'grid', 'power', 'drift', 'distance',
  'azimuth', 'band', 'version', 'code')
colClasses <- c('numeric', 'numeric', 'character',
  'character', 'numeric', 'numeric', 'character',
  'character', 'numeric', 'numeric', 'numeric',
  'numeric', 'numeric', 'character', 'numeric')

spots1 <- as.data.table(read.table(file1, header = F, sep = ',', col.names = colNames, colClasses = colClasses))
spots2 <- as.data.table(read.table(file2, header = F, sep = ',', col.names = colNames, colClasses = colClasses))

spots1[, time := as.POSIXct(epoch, origin = '1970-01-01')]
spots2[, time := as.POSIXct(epoch, origin = '1970-01-01')]

freqs <- c(0, 1, 3, 5, 7, 10, 14, 18, 21, 24, 28, 50)
bands <- c('MF', '160m', '80m', '60m', '40m', '30m', '20m', '17m', '15m', '12m', '10m', '6m')

proc1 <- function(x){
  x[
    ,
    list(
      diff = mean(as.numeric(snr.x) - as.numeric(snr.y))
    ),
    list(
      mday = mday(time),
      band
    )
  ]
}

spots <- merge(spots1, spots2, by = c('time', 'band', 'call'))

diff <- proc1(spots)
# diff[, time := as.POSIXct(paste0('2016/04/', mday, ' ', hour, ':00:00'))]
diff[, time := as.POSIXct(paste0('2016/04/', mday, ' 12:00:00'))]

subset <- diff[time >= as.POSIXct(paste0(date1, ' 00:00:00')) & time <= as.POSIXct(paste0(date2, ' 23:59:59'))]

p <- lapply(2:7, function(i)
  ggplot(data = subset[band == freqs[i]], aes(x = time, y = diff)) +
    geom_point() +
    scale_x_datetime(breaks = date_breaks('1 day'), minor_breaks = date_breaks('1 hour')) +
    theme(axis.text.x = element_text(angle = 45)) +
    labs(title = bands[i]) + labs(x = '', y = 'average SNR difference') +
    theme(legend.position = 'none') + coord_cartesian(ylim = c(-20.0, 10.0))
)

png(file3, width = 1200, height = 600, res = 90)
grid.arrange(arrangeGrob(grobs = p, nrow = 2))
dev.off()


library(Seurat)
library(CHETAH)

options_table<-read.table(parSampleFile1, sep="\t", header=F, stringsAsFactors = F)
myoptions<-split(options_table$V1, options_table$V2)

species=myoptions$species
prefix=myoptions$prefix

#load reference
load(parFile2)

finalList<-readRDS(parFile1)
obj<-finalList$obj

#keep umap only
obj@reductions$pca=NULL
obj@reductions$tsne=NULL

prefix=paste0(outFile, ".CHETAH")

obj.sce = as.SingleCellExperiment(obj)
obj.sce<-CHETAHclassifier(input=obj.sce, ref_cells = reference)

ct=data.frame(cell=c(1:length(colnames(obj.sce))), "seurat_cluster"=obj$seurat_clusters, "celltype_CHETAH"=obj.sce$celltype_CHETAH)
row.names(ct)<-colnames(obj)
write.csv(ct, paste0(prefix,".csv"))
saveRDS(obj.sce, file=paste0(prefix, ".rds"))

png(paste0(prefix, ".png"), width=6000, height=2500, res=300)
g<-PlotCHETAH(obj.sce)
print(g)
dev.off()


pdf_file<-"pdf/histograms_overlay.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11,height=7)

source("scripts/inc_datadesign_dbconnect.r")
par(omi=c(0.75,0.2,0.75,0.2),mai=c(0.25,1.25,0.25,0.25),family="Lato Light",las=1)

# Import data and prepare chart

sql<-"select * from v_women_men"
myDataset<-dbGetQuery(con,sql)
attach(myDataset)
myCol1<-rgb(191,239,255,180,maxColorValue=255)
myCol2<-rgb(255,0,210,80,maxColorValue=255)
brandenburg<-subset(myDataset,bundesland == 'Brandenburg')

# Create chart

hist(brandenburg$wm,col=myCol1,xlim=c(0.9,1.2),border=F,main='',xlab="Ratio",ylab="Number of Counties",axes=F)
axis(1,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
axis(2,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
rp<-subset(myDataset,bundesland == 'Rheinland-Pfalz')
hist(rp$wm,col=myCol2,xlim=c(0.9,1.2),border=F,add=T,main='')
legend("right",c("Brandenburg","Rhineland-Palatinate"),border=F,pch=15,col=c(myCol1,myCol2),bty="n",cex=1.25,xpd=T,ncol=1)

# Titling

mtext("Distribution of Women-Men-Ratio",3,line=1.8,adj=0,family="Lato Black",cex=1.5,outer=T)
mtext("Brandenburg and Rhineland-Palatinate",3,line=-0.2,adj=0,font=3,cex=1.2,outer=T)
mtext("Source: Bundeswahlleiter",1,line=2,adj=1.0,font=3,cex=1.2,outer=T)
dev.off()


#-h-  outnum			  381  local   12/01/80  15:54:32
# outnum - output decimal number
   include  defs

   subroutine outnum (n)
   integer n

   character chars (MAXCHARS)

   integer i, m

   m = iabs (n)
   i = 0
   repeat {
      i = i + 1
      chars (i) = mod (m, 10) + DIG0
      m = m / 10
      } until (m == 0 | i >= MAXCHARS)
   if (n < 0)
      call outch (MINUS)
   for ( ; i > 0; i = i - 1)
      call outch (chars (i))
   return
   end


#' Categorizing Computation as CPU or RAM Bound
#'
#' This attmpts to declare a computation as compute or memory bound.  Some
#' simplifying assumptions are made.  See the details section for more
#' information.
#'
#' To make our determination, we measure the total number of floating point
#' instructions and the total number of L2 cache accesses.  If the number of
#' floating point instructions is greater, then we say the computation is
#' compute bound, and otherwise we say the computation is memory bound.
#'
#' @param expr
#' A valid R expression to be profiled.
#' @param gcFirst
#' logical; determines if garbage collection should be called
#' before profiling.
#' @param burnin
#' logical; determines if the function should first be evaluated
#' with an empty expression.
#'
#' @return
#' The results of the requested PAPI events are returned, in a named
#' list, with values stored in double precision.
#'
#' @keywords programming
#'
#' @examples
#' \dontrun{
#' library(pbdPAPI)
#'
#' system.idle(1+1, events="float")
#' }
#'
#' @export
system.cpuormem <- function(expr, gcFirst=TRUE, burnin=TRUE)
{
  if (missing(expr))
    expr <- NULL

  events <- c("PAPI_FP_INS", "PAPI_L2_TCA")
  papi.avail.lookup(events=events)

  ret <- system.event(expr=expr, events=events, gcFirst=gcFirst)

  if (ret[[1L]] >= ret[[2L]])
    ret <- c(ret, "compute bound")
  else
    ret <- c(ret, "memory bound")

  names(ret)[3L] <- "Program Characterization"

  return( ret )
}


library("testthat");
#install.packages("testthat")

source("../testCatMultiple.r");
source("../replaceNaN.r")

# categorical multiple phenotype with two arrays
pheno_0_0 <- c(1,2,-1,NA,1,2,-1,NA);
pheno_0_1 <- c(NA,-1,NA,NA,NA,-1,NA,NA)

other_0_0 <- c(1,1,1,1,NA,NA,-1,-1)

data = cbind.data.frame(pheno_0_0,pheno_0_1,other_0_0)
colnames(data)[1] <- "pheno_0_0"
colnames(data)[2] <- "pheno_0_1"
colnames(data)[3] <- "xother_0_0"

####
# include ALL - pheno with NK values aren't included as -ve examples
idxNA = restrictSample2('test1',data[,1:2], "ALL", 1)
expect_equal(sort(idxNA), c(2,3,6,7))

# here examples 2 and 6 aren't included because they correspond to the -ve class
idxNA = restrictSample2('test1',data[,1:2], "ALL", 2)
expect_equal(sort(idxNA), c(3,7))

####
# include NO_NAN
idxNA = restrictSample2('test1',data[,1:2], "NO_NAN", 1)
cat("\n")
expect_equal(sort(idxNA), c(2,3,4,6,7,8))

# here examples 2 and 6	aren't included	because	they correspond	to the -ve class
idxNA = restrictSample2('test1',data[,1:2], "NO_NAN", 2)
cat("\n")
expect_equal(sort(idxNA), c(3,4,7,8))

####
# include only those with (non missing) value for other field
idxNA = restrictSample2('test1',data[,1:2], "other", 1)
cat("\n")
expect_equal(sort(idxNA), c(2,3,5,6,7,8))

#
idxNA = restrictSample2('test1',data[,1:2], "other", 2)
cat("\n")
expect_equal(sort(idxNA), c(3,5,6,7,8))

## if cat mult is not numeric then can't have missing values
pheno_0_0 <- c("A","B","C",NA,"A","B","C",NA);
pheno_0_1 <- c(NA,"C",NA,NA,NA,"C",NA,NA)
other_0_0 <- c("A","A","A","A",NA,NA,"C","C")
data = cbind.data.frame(pheno_0_0,pheno_0_1,other_0_0)
colnames(data)[1] <- "pheno_0_0"
colnames(data)[2] <- "pheno_0_1"
colnames(data)[3] <- "xother_0_0"

idxNA = restrictSample2('test1',data[,1:2], "ALL", "A")
expect_equal(idxNA, NULL)

idxNA = restrictSample2('test1',data[,1:2], "NO_NAN", "A")
expect_equal(sort(idxNA), c(4,8))

idxNA = restrictSample2('test1',data[,1:2], "other", "A")
expect_equal(sort(idxNA), c(5,6))


\name{comb_name}
\alias{comb_name}
\title{
Names of the Combination sets
}
\description{
Names of the Combination sets
}
\usage{
comb_name(m)
}
\arguments{

  \item{m}{A combination matrix returned by \code{\link{make_comb_mat}}.}

}
\details{
The name of the combination sets are formatted as a string
of binary bits. E.g. for three sets of "a", "b", "c", the combination
set with name "101" corresponds to select set a, not select set b
and select set c. The definition of "select" depends on the value of
\code{mode} from \code{\link{make_comb_mat}}.
}
\value{
A vector of names of the combination sets.
}
\examples{
set.seed(123)
lt = list(a = sample(letters, 10),
          b = sample(letters, 15),
          c = sample(letters, 20))
m = make_comb_mat(lt)
comb_name(m)
}


library(data.table)
library(ggplot2)
library(colorspace)

source('../../../functions.r')
source('../../../labs.r')

spplist <- fread('../../acap-species-list.csv')

MAX_RISKRATIO <- 10

## * Summary table

riskratios <- fread('../../generated/risk-ratios-summary.csv')

setorder(riskratios, -rr_p_ov_1, -rr_med)

riskratios <- riskratios[, .(cname = upper1st(cname),
               pst_mean = format(round(pst_mean, 1), big.mark = ' '), pst_ci,
               apf_mean = format(round(apf_mean, 1), big.mark = ' '), apf_ci,
               rr_med = round(rr_med, 2), rr_ci,
               rr_p_ov_1 = round(rr_p_ov_1, 2))]

fwrite(riskratios, '../assets/risk-ratios-summary.csv')

## * Violin plot

risksamples <- readRDS('../../generated/risk-ratios.rds')

get_dens <- function(x) {
    d <- density(x, from = quantile(x, 0.025), to = pmin(quantile(x, 0.975), MAX_RISKRATIO))
    return(data.table(x = as.numeric(d$x), y = as.numeric(d$y)))
}

dens <- risksamples[, get_dens(riskratio), .(cname, species_code)]
dens[, y := y / max(y), .(cname)]

dd <- dens[, rbind(.SD, .SD[.N:1, .(x = x, y = -y)], .SD[1]), .(cname, species_code)]

dd[spplist, spgroup := labs[i.vulgroup], on = c('species_code' = 'code.sra')]

stats <- risksamples[, .(rr_med = median(riskratio), p_rr_ov = mean(riskratio > 1)), .(cname, species_code)]

## ** Order taxa
spp <- stats[order(-p_rr_ov, -rr_med), cname]
dd[, lab := factor(as.character(cname), levels = spp)]

## ** Median line
dd[stats, med := i.rr_med, on = c('cname')]
med_lims <- dd[, .SD[which.min(abs(med - x))], .(cname, species_code, spgroup)]

outname <- '../assets/plot-risk-ratios.png'

g <- ggplot(dd, aes(x=x, y=y, fill=spgroup)) +
    geom_polygon(alpha = 0.6) +
    geom_segment(data = med_lims, aes(x = med, xend = med, y = y, yend = -y, colour=spgroup)) +
    scale_fill_discrete_qualitative(palette = "Harmonic", name = NULL) +
    scale_colour_discrete_qualitative(palette = "Harmonic", name = NULL) +
    scale_x_continuous(expand = c(0,0), limits = c(0, 1.02*MAX_RISKRATIO)) +
    facet_wrap(~ lab, scales = 'free_y', ncol = 1, strip.position = 'left') +
    labs(x = 'Risk ratio', y = NULL) +
    theme_minimal() +
    theme(panel.grid.major.y = element_blank(),
          panel.grid.minor.y = element_blank(),
          axis.text.y = element_blank(),
          axis.ticks.y = element_blank(),
          strip.text.y =element_text(angle=180, hjust = 1),
          legend.position = c(0.8, 0.2),
          legend.background = element_rect(fill='#EEEEEE', colour=NA),
          legend.margin = margin(0,2,2,2, 'mm'),
          panel.spacing.y=unit(0, 'mm'))

ggsave(outname, g, width = 8, height = 6)

cat('Plot saved as `', outname, '`\n')


#!/usr/bin/env Rscript

require(plyr)
require(ggplot2)
require(pracma)
require(grid)

argv <- commandArgs(trailingOnly = TRUE)

prefix <- gsub("\\s","", argv[1])
print(prefix)
truthset <- argv[2]
print(truthset)
results <- argv[3]
print(results)
xmin <- as.numeric(argv[4])
xmax <- as.numeric(argv[5])
ymin <- as.numeric(argv[6])
ymax <- as.numeric(argv[7])

roc <- read.delim(results)

bests <- ddply(roc, .(set), function(x) { data.frame(best_snps=with(x, min(false_negative_snps + false_positive_snps)), best_snp_threshold=min(subset(x, (false_negative_snps + false_positive_snps) == with(x, min(false_negative_snps + false_positive_snps)))$threshold ), best_indels=with(x, min(false_negative_indels + false_positive_indels)), best_indel_threshold=min(subset(x, (false_negative_indels + false_positive_indels) == with(x, min(false_negative_indels + false_positive_indels)))$threshold )) })

write.table(bests, paste(prefix, ".bests.tsv", sep=""), row.names=FALSE, quote=FALSE, sep="\t")

#abs(trapz(c(1, roc$complexfpr), c(1, roc$complextpr)))

true_snps <- with(subset(roc, set==truthset), max(num_snps))
true_indels <- with(subset(roc, set==truthset), max(num_indels))

# get ROC AUC
auc <- ddply(roc, .(set),
      function(x) {
        data.frame(
                   snp_auc=ifelse(true_snps>0,
                     with(x,
                          abs(trapz(c(1,
                                      false_positive_snps/(false_positive_snps+ max(false_negative_snps + num_snps - false_positive_snps))),
                                    c(max(1- false_negative_snps/true_snps),
                                      1- false_negative_snps/true_snps)))),
                     0),
                   indel_auc=ifelse(true_indels>0,
                     with(x,
                          abs(trapz(c(1,
                                      false_positive_indels/(false_positive_indels+ max(false_negative_indels + num_indels - false_positive_indels))),
                                    c(max(1- false_negative_indels/true_indels),
                                      1- false_negative_indels/true_indels)))),
                     0)
                   )
      }
      )

write.table(auc, paste(prefix, ".auc.tsv", sep=""), row.names=FALSE, quote=FALSE, sep="\t")

rocsnps <- ddply(roc, .(set),
      function(x) {
        data.frame(
                   FPR=
                     with(x,
                          c(1,
                            false_positive_snps/(false_positive_snps+ max(false_negative_snps + num_snps - false_positive_snps)))),
                   TPR=
                      with(x,
                          c(max(1- false_negative_snps/true_snps),
                            1- false_negative_snps/true_snps)),
                   type=as.factor("snps")
                   )
          }
      )

rocindels <- ddply(roc, .(set),
      function(x) {
        data.frame(
                   FPR=
                     with(x,
                          c(1,
                            false_positive_indels/(false_positive_indels+ max(false_negative_indels + num_indels - false_positive_indels)))),
                   TPR=
                      with(x,
                          c(max(1- false_negative_indels/true_indels),
                            1- false_negative_indels/true_indels)),
                   type=as.factor("indels")
                   )
          }
      )

if (FALSE) {
if (true_snps>0) {
  ggplot(subset(roc, set != truthset),
         aes(false_positive_snps/(false_positive_snps+with(subset(roc, set==set), max(false_negative_snps + num_snps - false_positive_snps))),
             1- false_negative_snps/with(subset(roc, set==set), max(false_negative_snps + num_snps - false_positive_snps)),
             group=set,
             color=set)) + scale_x_continuous("false positive rate") + scale_y_continuous("true positive rate") + geom_path() + theme_bw()
            + coord_cartesian(xlim=c(xmin,xmax), ylim=c(ymin,ymax))
  ggsave(paste(prefix, ".snps.png", sep=""), height=6, width=9)
}

if (true_indels>0) {
  ggplot(subset(roc, set != truthset),
         aes(false_positive_indels/(false_positive_indels+with(subset(roc, set==set), max(false_negative_indels + num_indels - false_positive_indels))),
             1- false_negative_indels/with(subset(roc, set==set), max(false_negative_indels + num_indels - false_positive_indels)),
             group=set,
             color=set)) + scale_x_continuous("false positive rate") + scale_y_continuous("true positive rate") + geom_path() + theme_bw()
            + coord_cartesian(xlim=c(xmin,xmax), ylim=c(ymin,ymax))
  ggsave(paste(prefix, ".indels.png", sep=""), height=6, width=9)
}
}

# new versions
if (true_snps>0) {
  ggplot(subset(rocsnps, set != truthset),
         aes(FPR,
             TPR,
             group=set,
             color=set)) + scale_x_continuous("false positive rate") + scale_y_continuous("true positive rate") + geom_path() + theme_bw() + coord_cartesian(xlim=c(xmin,xmax), ylim=c(ymin,ymax))
  ggsave(paste(prefix, ".snps.png", sep=""), height=6, width=9)
}

if (true_indels>0) {
  ggplot(subset(rocindels, set != truthset),
         aes(FPR,
             TPR,
             group=set,
             color=set)) + scale_x_continuous("false positive rate") + scale_y_continuous("true positive rate") + geom_path() + theme_bw() + coord_cartesian(xlim=c(xmin,xmax), ylim=c(ymin,ymax))
  ggsave(paste(prefix, ".indels.png", sep=""), height=6, width=9)
}

if (true_indels>0 && true_snps>0) {

(
  ggplot(subset(rbind(rocsnps,rocindels), set != truthset),
         aes(FPR,
             TPR,
             group=set,
             color=set))
    + scale_x_continuous("false positive rate")
    + scale_y_continuous("true positive rate")
    + geom_path()
    + theme_bw()
    + coord_cartesian(xlim=c(xmin,xmax), ylim=c(ymin,ymax))
    + facet_grid(type ~ .)
    + theme(panel.margin = unit(1, "lines"))
)
  ggsave(paste(prefix, ".both.png", sep=""), height=5, width=5)

}


## options for fringe analysis routines, wavefront fitting and wavefront display

psfit_options <- function(colors=topo.colors(256), refine=TRUE, puw_alg = "qual", fringescale=1,
                    wt=NULL, bgsub=TRUE,
                    maxiter=20, ptol=1.e-4, trace=1, nzcs = 2,
                    zc0=6:7,
                    satarget=c(0,0), astig.bath=c(0,0),
                    maxorder=14, uselm=FALSE, isoseq=FALSE, sgs=1,
                    nthreads=parallel::detectCores()/2,
                    plots=TRUE, crop=FALSE) {
  list(colors=colors, refine=refine, puw_alg=puw_alg, fringescale=fringescale,
       wt=wt, bgsub=bgsub,
       maxiter=maxiter, ptol=ptol, trace=trace, nzcs=nzcs,
       zc0=zc0, satarget=satarget, astig.bath=astig.bath,
       maxorder=maxorder, uselm=uselm, isoseq=isoseq, sgs=sgs,
       nthreads=nthreads,
       plots=plots, crop=crop)
}

psifit <- function(images, phases, cp=NULL, satarget=NULL, psialg ="ls", options=psfit_options()) {
  dims <- dim(images)
  nr <- dims[1]
  nc <- dims[2]
  nf <- dims[3]
  im.mat <- matrix(images, ncol=nf)
  if (!is.null(satarget)) {
    options$satarget <- satarget
  }
  refine <- options$refine
  if (length(phases) < nf) {
    phases <- wrap((0:(nf-1)) * phases[1])
  }
  if (!is.null(cp)) {
    prt <- pupil.rhotheta(nr, nc, cp)
    mask <- as.vector(prt$rho)
    im.mat <- im.mat[!is.na(mask),]
    refine <- FALSE
  } else {
    mask <- numeric(nr*nc)
  }
  switch(psialg,
    ls = {
      if (is.null(options$wt)) {
        wt <- rep(1, nf)
      } else {
        wt <- options$wt
      };
      psfit <- lspsiC(im.mat, phases, wt);
      extras <- NULL
    },
    aia = {
      if (is.null(options$ptol)) {
        ptol <- 0.001
      } else {
        ptol <- options$ptol
      };
      if (is.null(options$maxiter)) {
        maxiter <- 20
      } else {
        maxiter <- options$maxiter
      };
      if (is.null(options$trace)) {
        trace <- 1
      } else {
        trace <- options$trace
      };
      psfit <- aiapsiC(im.mat, phases, ptol, maxiter, trace);
      phases <- psfit$phases;
    },
    pc1 = {
       if (is.null(options$bgsub)) {
        bgsub <- TRUE
      } else {
        bgsub <- options$bgsub
      };
      group_diag <- "v";
      psfit <- pcapsi(im.mat, bgsub, group_diag);
      phases <- psfit$phases
    },
    pc2 = {
       if (is.null(options$bgsub)) {
        bgsub <- TRUE
      } else {
        bgsub <- options$bgsub
      };
      group_diag <- "u";
      psfit <- pcapsi(im.mat, bgsub, group_diag);
      phases <- psfit$phases
    },
    gpc = ,
    gpcthentilt = {
      if (is.null(options$ptol)) {
        ptol <- 0.001
      } else {
        ptol <- options$ptol
      };
      if (is.null(options$maxiter)) {
        maxiter <- 20
      } else {
        maxiter <- options$maxiter
      };
      if (is.null(options$trace)) {
        trace <- 1
      } else {
        trace <- options$trace
      };
      psfit <- gpcapsiC(im.mat, ptol, maxiter, trace);
      phases <- psfit$phases
    },
    tilt = {
      if (is.null(cp)) stop("This algorithm must have measured interferogram outline");
      if (is.null(options$ptol)) {
        ptol <- 0.001
      } else {
        ptol <- options$ptol
      };
      if (is.null(options$maxiter)) {
        maxiter <- 20
      } else {
        maxiter <- options$maxiter
      };
      if (is.null(options$trace)) {
        trace <- 1
      } else {
        trace <- options$trace
      };
      if (is.null(options$nzcs)) {
        nzcs <- 2
      } else {
        nzcs <- min(options$nzcs, 8)
      };
      rho <- prt$rho;
      theta <- prt$theta;
      rho <- rho[!is.na(rho)];
      theta <- theta[!is.na(theta)];
      coords <- zpmC(rho, theta, maxorder=4);
      coords <- coords[, 2:(nzcs+1)]
      psfit <- tiltpsiC(im.mat, phases, coords,
                       maxiter=maxiter, ptol=ptol, trace=trace);
      phases <- psfit$phases;
    },
    { ## if no match to ls
      if (is.null(options$wt)) {
        wt <- rep(1, nf)
      } else {
        wt <- options$wt
      };
      psfit <- lspsiC(im.mat, phases, wt);
      extras <- NULL
    }
  )
  phi <- matrix(NA, nr, nc)
  mod <- matrix(0, nr, nc)
  phi[!is.na(mask)] <- psfit$phi
  mod[!is.na(mask)] <- psfit$mod
  if (is.null(cp)) {
    phi <- matrix(psfit$phi, ncol=nc)
    mod <- matrix(psfit$mod, ncol=nc)
    cp <- circle.pars(mod, plot=options$plots)
    prt <- pupil.rhotheta(nr, nc, cp)
  }
  if (refine || psialg=="gpcthentilt") {
    mask <- as.vector(prt$rho)
    im.mat <- matrix(images, ncol=nf)
    im.mat <- im.mat[!is.na(mask),]
    switch(psialg,
      ls = {
        mask <- numeric(nr*nc)
      },
      aia = {
        psfit <- aiapsiC(im.mat, phases, ptol, maxiter, trace);
        phases <- psfit$phases;
      },
      pc1 = {
        psfit <- pcapsi(im.mat, bgsub, group_diag);
        phases <- psfit$phases
      },
      pc2 = {
        psfit <- pcapsi(im.mat, bgsub, group_diag);
        phases <- psfit$phases
      },
      gpc = {
        psfit <- gpcapsiC(im.mat, ptol, maxiter, trace);
        phases <- psfit$phases
      },
      gpcthentilt = ,
      tilt = {
        if (is.null(options$ptol)) {
          ptol <- 0.001
        } else {
          ptol <- options$ptol
        };
        if (is.null(options$maxiter)) {
          maxiter <- 20
        } else {
          maxiter <- options$maxiter
        };
        if (is.null(options$trace)) {
          trace <- 1
        } else {
          trace <- options$trace
        };
        if (is.null(options$nzcs)) {
          nzcs <- 2
        } else {
          nzcs <- min(options$nzcs, 8)
        };
        rho <- prt$rho;
        theta <- prt$theta;
        rho <- rho[!is.na(rho)];
        theta <- theta[!is.na(theta)];
        coords <- zpmC(rho, theta, maxorder=4);
        coords <- coords[, 2:(nzcs+1)]
        psfit <- tiltpsiC(im.mat, phases, coords,
                          maxiter=maxiter, ptol=ptol, trace=trace);
        phases <- psfit$phases;
      }
    )
    phi <- matrix(NA, nr, nc)
    mod <- matrix(0, nr, nc)
    phi[!is.na(mask)] <- psfit$phi
    mod[!is.na(mask)] <- psfit$mod
  }
  phi[is.na(prt$rho)] <- NA
  class(phi) <- "pupil"
  cp.orig <- cp
  if (options$crop) {
    phi <- crop(phi, cp)
    mod <- crop(mod, cp)$im
    cp <- phi$cp
    phi <- phi$im
    nr <- nrow(phi)
    nc <- ncol(phi)
  }
  wf.raw <- switch(options$puw_alg,
                qual = qpuw(phi, mod),
                brcut = brcutpuw(phi),
                lp = lppuw::netflowpuw(phi, mod)
  )
  wf.raw <- options$fringescale * wf.raw
  class(wf.raw) <- "pupil"
  wfnets <- wf_net(wf.raw, cp, options)
  if(length(psfit) > 3) extras <- psfit[4:length(psfit)]
  outs <- list(phi=phi, mod=mod, phases=wrap(as.vector(phases)),
       cp=cp, cp.orig=cp.orig,
       wf.net=wfnets$wf.net, wf.smooth=wfnets$wf.smooth,wf.residual=wfnets$wf.residual,
       fit=wfnets$fit, zcoef.net=wfnets$zcoef.net, extras=extras)
  class(outs) <- append(class(outs), "wf_fitted")
  outs
}


#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatBindot <- ggproto("StatBindot", Stat,
  required_aes = "x",
  non_missing_aes = "weight",
  default_aes = aes(y = after_stat(count)),

  setup_params = function(data, params) {
    if (is.null(params$binwidth)) {
      cli::cli_inform("Bin width defaults to 1/30 of the range of the data. Pick better value with {.arg binwidth}.")
    }
    params
  },

  compute_layer = function(self, data, params, layout) {
    data <- remove_missing(data, params$na.rm, name = snake_class(self))
    ggproto_parent(Stat, self)$compute_layer(data, params, layout)
  },

  compute_panel = function(self, data, scales, na.rm = FALSE, binwidth = NULL,
                           binaxis = "x", method = "dotdensity",
                           binpositions = "bygroup", origin = NULL,
                           width = 0.9, drop = FALSE,
                           right = TRUE) {

    # If using dotdensity and binning over all, we need to find the bin centers
    # for all data before it's split into groups.
    if (method == "dotdensity" && binpositions == "all") {
      if (binaxis == "x") {
        newdata <- densitybin(x = data$x, weight = data$weight, binwidth = binwidth,
                      method = method)

        data    <- data[order(data$x), ]
        newdata <- newdata[order(newdata$x), ]

      } else if (binaxis == "y") {
        newdata <- densitybin(x = data$y, weight = data$weight, binwidth = binwidth,
                    method = method)

        data    <- data[order(data$y), ]
        newdata <- newdata[order(newdata$x), ]
      }

      data$bin       <- newdata$bin
      data$binwidth  <- newdata$binwidth
      data$weight    <- newdata$weight
      data$bincenter <- newdata$bincenter

    }

    ggproto_parent(Stat, self)$compute_panel(data, scales, binwidth = binwidth,
      binaxis = binaxis, method = method, binpositions = binpositions,
      origin = origin, width = width, drop = drop,
      right = right)
  },

  compute_group = function(self, data, scales, binwidth = NULL, binaxis = "x",
                           method = "dotdensity", binpositions = "bygroup",
                           origin = NULL, width = 0.9, drop = FALSE,
                           right = TRUE) {
    # Check that weights are whole numbers (for dots, weights must be whole)
    if (!is.null(data$weight) && !(is_integerish(data$weight) && all(data$weight >= 0))) {
      cli::cli_abort("Weights must be nonnegative integers.")
    }

    if (binaxis == "x") {
      range   <- scales$x$dimension()
      values  <- data$x
    } else if (binaxis == "y") {
      range  <- scales$y$dimension()
      values <- data$y
      # The middle of each group, on the stack axis
      midline <- mean(range(data$x))
    }

    if (method == "histodot") {
      closed <- if (right) "right" else "left"
      if (!is.null(binwidth)) {
        bins <- bin_breaks_width(range, binwidth, boundary = origin, closed = closed)
      } else {
        bins <- bin_breaks_bins(range, 30, boundary = origin, closed = closed)
      }

      data <- bin_vector(values, bins, weight = data$weight, pad = FALSE)

      # Change "width" column to "binwidth" for consistency
      names(data)[names(data) == "width"] <- "binwidth"
      names(data)[names(data) == "x"]     <- "bincenter"

    } else if (method == "dotdensity") {

      # If bin centers are found by group instead of by all, find the bin centers
      # (If binpositions=="all", then we'll already have bin centers.)
      if (binpositions == "bygroup")
        data <- densitybin(x = values, weight = data$weight, binwidth = binwidth,
                  method = method, range = range)

      # Collapse each bin and get a count
      data <- dapply(data, "bincenter", function(x) {
        new_data_frame(list(
          binwidth = .subset2(x, "binwidth")[1],
          count = sum(.subset2(x, "weight"))
        ))
      })

      if (sum(data$count, na.rm = TRUE) != 0) {
        data$count[is.na(data$count)] <- 0
        data$ncount <- data$count / max(abs(data$count), na.rm = TRUE)
        if (drop) data <- subset(data, count > 0)
      }
    }

    if (binaxis == "x") {
      names(data)[names(data) == "bincenter"] <- "x"
      # For x binning, the width of the geoms is same as the width of the bin
      data$width <- data$binwidth
    } else if (binaxis == "y") {
      names(data)[names(data) == "bincenter"] <- "y"
      # For y binning, set the x midline. This is needed for continuous x axis
      data$x <- midline
    }
    return(data)
  }
)

# This does density binning, but does not collapse each bin with a count.
# It returns a data frame with the original data (x), weights, bin #, and the bin centers.
densitybin <- function(x, weight = NULL, binwidth = NULL, method = method, range = NULL) {

    if (length(stats::na.omit(x)) == 0) return(new_data_frame())
    if (is.null(weight))  weight <- rep(1, length(x))
    weight[is.na(weight)] <- 0

    if (is.null(range))    range <- range(x, na.rm = TRUE, finite = TRUE)
    if (is.null(binwidth)) binwidth <- diff(range) / 30

    # Sort weight and x, by x
    weight <- weight[order(x)]
    x      <- x[order(x)]

    cbin    <- 0                      # Current bin ID
    bin     <- rep.int(NA, length(x)) # The bin ID for each observation
    binend  <- -Inf                   # End position of current bin (scan left to right)

    # Scan list and put dots in bins
    for (i in 1:length(x)) {
        # If past end of bin, start a new bin at this point
        if (x[i] >= binend) {
            binend <- x[i] + binwidth
            cbin <- cbin + 1
        }

        bin[i] <- cbin
    }

    results <- new_data_frame(list(
      x = x,
      bin = bin,
      binwidth = binwidth,
      weight = weight
    ), n = length(x))
    results <- dapply(results, "bin", function(df) {
                    df$bincenter = (min(df$x) + max(df$x)) / 2
                    return(df)
                  })

    return(results)
}


library(readxl)
library(ComplexHeatmap)
library(circlize)

# Flow data ---------------------------------------------------------------

fn.flow = "data/Pregnancy_flow_cytometry.xlsx"
df.flow = read_xlsx(fn.flow, sheet = "frequencies") %>%
  dplyr::rename(Visit = TimePoint)
info.flow = df.flow[,1:2] %>%
  mutate(sample = paste(Subject, Visit, sep="_"))
dat.flow = df.flow[,-(1:2)] %>%
  data.matrix()
rownames(dat.flow) = info.flow$sample
ids = colnames(dat.flow)[-1]
ids = round(as.numeric(ids), digits = 1) %>% as.character()
colnames(dat.flow)[-1] = ids
colnames(df.flow)[-(1:3)] = ids

ann.flow = read_xlsx(fn.flow, sheet = "all gates") %>%
  dplyr::select(ID = `Pop Code`, Name = `Subset name`)
ia = match(colnames(dat.flow), ann.flow$ID)
ann.flow = ann.flow[ia,]
ann.flow[is.na(ann.flow$ID),] = c("LYM","Lymphocytes")

dir.create("data_generated", showWarnings = F)
save(info.flow, dat.flow, ann.flow, file="data_generated/Pregnancy_flow_cytometry.RData")

# Compare cell population frequencies between visits ----------------------

fc31 = c()
fc41 = c()
fc43 = c()
wt31 = list()
wt41 = list()
wt43 = list()
for (ci in colnames(dat.flow)) {
  fc31[ci] = mean(dat.flow[info.flow$Visit==3,ci], na.rm=T) / mean(dat.flow[info.flow$Visit==1,ci], na.rm=T)
  fc41[ci] = mean(dat.flow[info.flow$Visit==4,ci], na.rm=T) / mean(dat.flow[info.flow$Visit==1,ci], na.rm=T)
  fc43[ci] = mean(dat.flow[info.flow$Visit==4,ci], na.rm=T) / mean(dat.flow[info.flow$Visit==3,ci], na.rm=T)
  wt31[[ci]] = wilcox.test(dat.flow[info.flow$Visit==1,ci], dat.flow[info.flow$Visit==3,ci], paired=T, exact = F)
  wt41[[ci]] = wilcox.test(dat.flow[info.flow$Visit==1 & info.flow$Subject!=8,ci], dat.flow[info.flow$Visit==4,ci], paired=T, exact = F)
  wt43[[ci]] = wilcox.test(dat.flow[info.flow$Visit==3 & info.flow$Subject!=8,ci], dat.flow[info.flow$Visit==4,ci], paired=T, exact = F)
}

wt31.p = map_dbl(wt31, function(x) x$p.value)
wt31.padj = p.adjust(wt31.p, method = "BH")
i.31 = names(wt31)[wt31.padj < 0.05]

wt41.p = map_dbl(wt41, function(x) x$p.value)
wt41.padj = p.adjust(wt41.p, method = "BH")
i.41 = names(wt41)[wt41.padj < 0.05]

wt43.p = map_dbl(wt43, function(x) x$p.value)
wt43.padj = p.adjust(wt43.p, method = "BH")
i.43 = names(wt43)[wt43.padj < 0.05]

i.flow = unique(c(i.31, i.41, i.43))
i.flow = i.flow[order(as.numeric(i.flow), na.last = T)]

# save test results to file

F.df.all = data.frame(ID = colnames(dat.flow), FC.3.v.1 = fc31, FC.4.v.3 = fc43, FC.4.v.1 = fc41,
                  wP.3.v.1 = wt31.p, wP.4.v.3 = wt43.p, wP.4.v.1 = wt41.p,
                  wQ.3.v.1 = wt31.padj, wQ.4.v.3 = wt43.padj, wQ.4.v.1 = wt41.padj)
F.df.all = left_join(F.df.all, ann.flow, by="ID")
fwrite(F.df.all, "results/flow_visits_comparison_all.txt", sep="\t")

F.df = F.df.all[match(i.flow, F.df.all$ID),]
fwrite(F.df, "results/flow_visits_comparison.txt", sep="\t")

F.df.V31 = data.frame(ID = colnames(dat.flow), FC = fc31, wP = wt31.p, wQ = wt31.padj) %>%
  dplyr::filter(wQ <= 0.05) %>%
  arrange(wP)
fwrite(F.df.V31, "results/flow_visits.3.v.1_comparison.txt", sep="\t")

# combine the data and filter by fold change

DF = data.frame(ID = i.flow, V31 = fc31[i.flow], V43 = fc43[i.flow], V41 = fc41[i.flow])
X = DF %>% inner_join(ann.flow, by="ID") %>%
  mutate(Name = glue::glue("{Name} [{ID}]")) %>%
  dplyr::select(-ID) %>%
  tibble::column_to_rownames("Name") %>%
  data.matrix()

X.log2 = log2(X)
X.max = apply(X.log2, 1, function(x)max(abs(x),na.rm=T))
fc.th = 1.2
i.sel = X.max > log2(fc.th)
iord = order(X.max[i.sel], decreasing = T)
XX = X.log2[i.sel, ]#[i.ord,]
range(XX)

P.df = data.frame(ID = i.flow, V31 = wt31.padj[i.flow], V43 = wt43.padj[i.flow], V41 = wt41.padj[i.flow])
P = P.df %>% inner_join(ann.flow %>% dplyr::select(ID, Name), by="ID") %>%
  mutate(Name = glue::glue("{Name} [{ID}]")) %>%
  tibble::column_to_rownames("Name") %>%
  dplyr::select(-ID) %>%
  data.matrix()
PP = P[i.sel, ]

# additional annotation of selected gates (with BH-adjusted Wilcoxon p-value < 0.05 and FC > 1.2)

ann.flow.selected = read_xlsx(fn.flow, sheet = "selected gates") %>%
  mutate(Name2 = glue::glue("{Name} [{ID}]"))
ro = match(ann.flow.selected$ID, i.flow[i.sel])
split.vec = ann.flow.selected$group %>% fct_inorder()

# prepare data for heatmap

max.val = max(abs(X.log2))
fnt.sz = 12

colnames(XX) = c("V3 / V1", "V4 / V3", "V4 / V1")
XX = XX[ro,]
PP = PP[ro,]

rownames(XX) = ann.flow.selected$Name2
hm = Heatmap(XX, name = "Fold Change, log2", cluster_columns = F, cluster_rows = F,
             split = split.vec,
             gap = unit(2,"mm"),
        row_names_max_width = max_text_width( rownames(XX), gp = gpar(fontsize = 12) ),
        column_names_side = "top",
        col = colorRamp2(c(-1.4,0,1.4), c("blue", "white", "red")),
        cell_fun = function(j, i, x, y, width, height, fill) {
          if(PP[i, j] < 0.001) {
            grid.text("***", x, y, gp = gpar(fontsize = fnt.sz))
          } else if(PP[i, j] < 0.01) {
            grid.text("**", x, y, gp = gpar(fontsize = fnt.sz))
          } else if(PP[i, j] < 0.05) {
            grid.text("*", x, y, gp = gpar(fontsize = fnt.sz))
          }
        },
        heatmap_legend_param = list(color_bar = "continuous",
                                    legend_width = unit(3,"cm"),
                                    legend_direction = "horizontal"))

fn.hm = glue::glue("figures/Flow_FC_heatmap_fc.th.{fc.th}")
png(paste0(fn.hm, ".png"), w=450, h=700)
draw(hm, heatmap_legend_side = "bottom")
dev.off()
pdf(paste0(fn.hm, ".pdf"), w=6, h=10)
draw(hm, heatmap_legend_side = "bottom")
dev.off()

# plot individual samples -------------------------------------------------

pop.use = i.flow[i.sel]
pop.name = paste(ann.flow.selected$subset, ann.flow.selected$ID, sep=", population ")[match(pop.use, ann.flow.selected$ID)]
DF2 = df.flow %>%
  dplyr::select(Subject, Visit, one_of(pop.use)) %>%
  gather("ID","freq", -Subject, -Visit) %>%
  arrange(Visit, Subject) %>%
  mutate(Sample = paste(Subject, Visit, sep="_") %>% fct_inorder()) %>%
  mutate(Subject = fct_inorder(as.character(Subject))) %>%
  mutate(ID = factor(ID, levels = pop.use)) %>%
  group_by(ID, Subject) %>%
  mutate(FC = freq / freq[Visit==1]) %>%
  ungroup()

dir.create("figures/flow_profiles", showWarnings = F)

for(k in seq_along(pop.use)) {
  cat(pop.use[k]," ")
  ggplot(DF2 %>% dplyr::filter(ID==pop.use[k]), aes(Visit, FC, group=Subject, col=Subject)) +
    geom_path(show.legend = F) +
    geom_hline(yintercept = 1, col="black") +
    # scale_y_continuous(trans = "log2") +
    xlab("Study visit") +
    ylab("Fold change in percent\nof parent population") +
    ggtitle(pop.name[k]) +
    theme_bw()
  ggsave(glue::glue("figures/flow_profiles/flow_profile_{pop.use[k]}.png"), w=4,h=3)
}


#THIS SCRIPT GENERATES THE PLOT FOR THE DIAGONAL K=1 IN THE CONFIGURATION TOTAL_TRIPLE_IN_WINDOW/EW PLOTTING THE FOUR BASELINES IN THE SAME FIGURE IN 4 DIFFERENT PLOTS
#IT USES LOG SCALING

log_plot_dash <- function(x,y,sdx,sdy, col, pch){

  lx <- log(x)
  ly <- log(y)

  par(new=TRUE)
  points(x = lx, y = ly, col=col, type = "p", pch=pch)
  arrows(lx, log(y-sdy),lx,log(y+sdy),, length=0.05, angle=90, code=3, col="grey55")
  arrows(log(x), ly,log(x+sdx),ly, length=0.05, angle=90, code=3, col="gray55")
  if(log(sdx)<x){
    arrows(log(sdx), ly,log(x),ly, length=0.05, angle=90, code=3, col="red")
  }else{
    arrows(log(sdx), ly,log(x),ly, length=0.05, angle=90, code=3, col="red")
  }
}

log_dashboard<- function(a,b,c,d,e, ss = c(FALSE, FALSE, FALSE, FALSE, FALSE)){
  options("scipen"=5)
  exp <- paste(lat_report_rhodf$STREAM[a], substr(lat_report_rhodf$REASONING[a], 0, 6))

  xlim <- c(min(lat_report_rhodf$Mean.SS), max(lat_report_rhodf$Mean.SS))
  ylim <- c(sort(mem_report_rhodf$A..Mean.SS)[1], sort(mem_report_rhodf$A..Mean.SS, decreasing = TRUE)[1])

  myxlim <- c(0.01, log(xlim[2]))
  myylim <- c(log(ylim[1])-1, log(ylim[2])+10)

  getOption("scipen")
  opt <- options("scipen" = 20)
  getOption("scipen")
  options(opt)

  plot(seq(min(xlim[1], ylim[1]),max(xlim[2], ylim[2]),0.001),seq(min(xlim[1], ylim[1]),max(xlim[2], ylim[2]),0.001), log="xy",  type = "n", ylab = "Memory", xlab = "Latency", xlim=myxlim, ylim=myylim)

  abline( h = seq(min(xlim[1], ylim[1]),max(xlim[2], ylim[2]),0.01), lty = 3, col = colors()[ 440 ] )
  abline( v = seq(min(xlim[1], ylim[1]),max(xlim[2], ylim[2]),0.01), lty = 3, col = colors()[ 440 ] )

  z<-a
  if(ss[1]){
    pch <- 0
  }else{
    pch <- 15
  }
  pch_legend <- pch
  log_plot_dash(lat_report_rhodf$Mean.SS[z], mem_report_rhodf$A..Mean.SS[z], lat_report_rhodf$Dev.StdSS[z],mem_report_rhodf$A.Dev.Std.SS[z], "red", pch)

  z<-b
  if(ss[2]){
    pch <- 1
  }else{
    pch <- 16
  }
  pch_legend <- c(pch_legend,pch)
  log_plot_dash(lat_report_rhodf$Mean.SS[z], mem_report_rhodf$A..Mean.SS[z], lat_report_rhodf$Dev.StdSS[z], mem_report_rhodf$A.Dev.Std.SS[z], "blue", pch)

  z<-c
  if(ss[3]){
    pch <- 2
  }else{
    pch <- 17
  }
  pch_legend <- c(pch_legend,pch)
  log_plot_dash(lat_report_rhodf$Mean.SS[z], mem_report_rhodf$A..Mean.SS[z], lat_report_rhodf$Dev.StdSS[z], mem_report_rhodf$A.Dev.Std.SS[z], "black", pch)

  z <- d
  if(ss[4]){
    pch <- 5
  }else{
    pch <- 18
  }
  pch_legend <- c(pch_legend,pch)
  log_plot_dash(lat_report_rhodf$Mean.SS[z], mem_report_rhodf$A..Mean.SS[z], lat_report_rhodf$Dev.StdSS[z], mem_report_rhodf$A.Dev.Std.SS[z], "chartreuse4", pch)

  z <-e
  if(ss[5]){
    pch <- 4
  }else{
    pch <- 8
  }
  pch_legend <- c(pch_legend,pch)
  log_plot_dash(lat_report_rhodf$Mean.SS[z], mem_report_rhodf$A..Mean.SS[z], lat_report_rhodf$Dev.StdSS[z], mem_report_rhodf$A.Dev.Std.SS[z], "purple", pch)

  legend(0.10, 10,pch=pch_legend,bg = "white",bty="o", legend=c(
    paste( "K", lat_report_rhodf$K[a], "EW", lat_report_rhodf$EW[a], lat_report_rhodf$REASONING[a], lat_report_rhodf$STREAM[a]),
    paste( "K", lat_report_rhodf$K[b], "EW", lat_report_rhodf$EW[b], lat_report_rhodf$REASONING[a], lat_report_rhodf$STREAM[b]),
    paste( "K", lat_report_rhodf$K[c], "EW", lat_report_rhodf$EW[c], lat_report_rhodf$REASONING[a], lat_report_rhodf$STREAM[c]),
    paste( "K", lat_report_rhodf$K[d], "EW", lat_report_rhodf$EW[d], lat_report_rhodf$REASONING[a], lat_report_rhodf$STREAM[d]),
    paste( "K", lat_report_rhodf$K[e], "EW", lat_report_rhodf$EW[e], lat_report_rhodf$REASONING[a], lat_report_rhodf$STREAM[e])), cex=1 ,y.intersp=1, col=c("red","blue","black","chartreuse4", "purple"))
  title(exp, paste("ENs",  lat_report_rhodf$EN[a], lat_report_rhodf$EN[b], lat_report_rhodf$EN[c], lat_report_rhodf$EN[d], lat_report_rhodf$EN[e]))

}

options(scipen =4)
png("DASHBOARD K=1 EW=X LOG DIAGONAL.png", 1000, 1000)

mem_report_rhodf <- mem_report_rhodf[with(mem_report_rhodf, order(K)),]
lat_report_rhodf <- lat_report_rhodf[with(lat_report_rhodf, order(K)),]

a <- 1
b <- a+1
c <- b+1
d <- c+1
split.screen(c(2,1))
split.screen(c(1,2), screen=1)

#INC GRAPH
screen(3)
log_dashboard(a,a+4,a+8,a+12,a+16, c(FALSE, TRUE, FALSE, FALSE, TRUE))
#INC STMT
screen(4)
log_dashboard(b,b+4,b+8,b+12,b+16, c(FALSE, TRUE, FALSE, FALSE, TRUE))
split.screen(c(1,2), screen=2)

#NAIVE GRAPH
screen(5)
log_dashboard(c,c+4,c+8,c+12,c+16, c(TRUE, TRUE, FALSE, FALSE, TRUE))
screen(6)
#NAIVE STMT
log_dashboard(d,d+4,d+8,d+12,d+16, c(FALSE, TRUE, FALSE, FALSE, TRUE))

dev.off()


\name{dend_xy}
\alias{dend_xy}
\title{
Coordinates of the Dendrogram
}
\description{
Coordinates of the Dendrogram
}
\usage{
dend_xy(dend)
}
\arguments{

  \item{dend}{a \code{\link{dendrogram}} object.}

}
\details{
\code{dend} will be processed by \code{\link{adjust_dend_by_x}} if it is processed yet.
}
\value{
A list of leave positions (\code{x}) and dendrogram height (\code{y}).
}
\examples{
m = matrix(rnorm(100), 10)
dend1 = as.dendrogram(hclust(dist(m)))
dend_xy(dend1)

dend1 = adjust_dend_by_x(dend1, sort(runif(10)))
dend_xy(dend1)

dend1 = adjust_dend_by_x(dend1, unit(1:10, "cm"))
dend_xy(dend1)
}


# Copyright © 2013-2015 Université catholique de Louvain, Belgium - UCL
# All rights reserved.
#
# This file is part of the precall package.
#
# The precall package has been developed by Adrien Dessy [Machine Learning
# Group (MLG) - Institute of Information and Communication Technologies,
# Electronics and Applied Mathematics (ICTEAM)] for the Université catholique de
# Louvain (UCL). The precall package enables to plot precision-recall curves and
# to compute the Area Under Precision-Recall curves.
#
# The precall package is distributed under the terms of the MIT License (MIT).
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is furnished
# to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

context("Area under the curve")

test_that("AUPR == 1", {
  scores = seq_len(5)
  labels0 = c(T,T,T,F,F)

  expect_equal(aupr(labels0, scores), 1)

  scores  = c(3, 1, 2, 0)
  labels1 = c(F, F ,F ,T)
  labels2 = c(F, T ,F ,T)
  labels3 = c(F, T ,F ,T)
  labels4 = c(F, T ,T ,T)
  labels5 = c(T, T ,T ,T)

  testthat::expect_equal(aupr(labels1, scores), 1)
  testthat::expect_equal(aupr(labels2, scores), 1)
  testthat::expect_equal(aupr(labels3, scores), 1)
  testthat::expect_equal(aupr(labels4, scores), 1)
  testthat::expect_equal(aupr(labels5, scores), 1)
})

test_that("AUPR == 0", {
  scores1 = c(-1, 5, 2, 6, -3)
  scores2 = c(-4, 3, 0, 6, -1)
  labels  = rep(F,5)

  testthat::expect_equal(aupr(labels, scores1), 0)
  testthat::expect_equal(aupr(labels, scores2), 0)
  testthat::expect_equal(aupr(labels, cbind(scores1,scores2)), c(scores1=0, scores2=0))
  testthat::expect_equal(aupr(labels, cbind(a=scores1,b=scores2)), c(a=0, b=0))
})

test_that("0 < AUPR < 1", {

  scores = c(1,1)
  testthat::expect_equal(aupr(c(T,F), scores), 0.5)
  testthat::expect_equal(aupr(c(F,T), scores), 0.5)

  testthat::expect_equal(aupr(c(T,T,F,F), c(2,1,2,1)), 0.5)
  testthat::expect_equal(aupr(c(F, T), c(0,1)), 1 - log(2))
  testthat::expect_equal(aupr(c(T, F, T), c(0,1,2)), 1 - log(3/2)/2 )
  testthat::expect_equal(aupr(c(T, F, T), c(0,1,1)), 0.75 + log(3)/8 )

  scores = cbind(s1=c(0,1,2), s2=c(0,1,1))
  labels = c(T, F, T)
  aupr_res = c(s1=1 - log(3/2)/2, s2=0.75 + log(3)/8)
  testthat::expect_equal(aupr(labels, scores), aupr_res)
})


# _setup.r
# Run analysis
# 20201207

library(arm)
library(arsenal)
library(broom)
library(car)
library(conflicted)
library(feather)
library(here)
library(janitor)
library(parsedate)
library(readxl)
library(skimr)
library(tidyverse)

options(width=300)

conflict_prefer('filter', 'dplyr')
conflict_prefer('recode', 'dplyr')
conflict_prefer('select', 'dplyr')
conflict_prefer('parse_date', 'parsedate')

RAW_FILE <- 'DATA_FILE.xlsx'
RAW_PATH <- here('data','raw')
INTERMEDIATES_PATH <- here('data','intermediates')
RECODED_PATH <- here('data','recoded')

source(here('r', '1_import.r'))
message('Import step complete.')
source(here('r', '2_preprocess.r'))
message('\nPreprocess step complete.')
source(here('r', '3_generate_tables.r'))
message('\nGenerated tables.')
source(here('r', '4_fit_models.r'))
message('\nFit models.')


# Saharan Dust Transport Research
# 2016-05-04 Ismail SEZEN
# sezenismail@gmail.com

source("code/correlation.r")
source("code/filehelper.r")

calcor <- function(files = stop("'file' must be specified"), log = T) {
  pm <- read_pm10()
  file_prefix <- "pm_"
  if (log) {
    pm <- log10(pm)
    file_prefix <- paste0("log_", file_prefix)
  }
  dir_out <- "data/cor"
  dir.create(dir_out, showWarnings = F)
  nof <- length(files)
  i <- 1
  for (f in files) {
    fwe <- basename(tools::file_path_sans_ext(f))
    save_to <- file.path(dir_out, paste0("cor_", file_prefix, fwe, ".rds"))
    if (!file.exists(save_to)) {
      cat("Calculation started at", as.character(now()), "\n")
      cat("(", i, "/", nof, ") ", basename(save_to), "\n", sep = "")
      w <- readRDS(f)
      st <- system.time(data <- cor2(w, pm, alfa = seq(0, 360, 1)))[3]
      cat("[Elapsed :", st, "sec]\n")
      attr(data, "filename") <- f
      saveRDS(data, file = save_to)
    } else {
      cat("(", i, "/", nof, ") ", save_to, " is exist.\n", sep = "")
    }
    i <- i + 1
  }
}

files <- paste0(c("r2-pres-00-uv", "r2-pres-06-uv",
                  "r2-pres-12-uv", "r2-pres-18-uv",
                  "r2-pres-daily-uv",
                  "r2-surf-00-uv", "r2-surf-06-uv",
                  "r2-surf-12-uv", "r2-surf-18-uv",
                  "r2-surf-daily-uv",
                  "r2-pres-00-hgt", "r2-pres-06-hgt",
                  "r2-pres-12-hgt", "r2-pres-18-hgt",
                  "r2-pres-daily-hgt",
                  "r2-surf-00-mslp", "r2-surf-06-mslp",
                  "r2-surf-12-mslp", "r2-surf-18-mslp",
                  "r2-surf-daily-mslp",
                  "r2-pres-00-omega", "r2-pres-06-omega",
                  "r2-pres-12-omega", "r2-pres-18-omega",
                  "r2-pres-daily-omega"), ".rds")
files <- file.path("data/rds", files)
calcor(files, log = T)
calcor(files, log = F)


df <- read.delim ("sample/chip1/chip1_divided_input1_around_peak1_halfwid1000winsize25step10.txt")

png("sample/chip1/chip1_divided_input1_around_peak1_halfwid1000winsize25step10.png")
plot (df$relative_pos, df$smt_mean, col="blue", ylim=c(1,13), main="Enrichment of chip1 around peak1", ylab="Enrichment of chip1", xlab="Distance from peak1 (bp)", type="l", lwd=2)
lines (df$relative_pos, df$CI95.00percent_U, col="blue", lty=2)
lines (df$relative_pos, df$CI95.00percent_L, col="blue", lty=2)
dev.off()


  ggplot(df, aes(x = EV_Diff, y = rt)) +
         geom_smooth(method="lm", alpha = .25, size = 1.5) +
         labs(title = "Expected Value Difference Predicts Decision Reaction Time",
              subtitle = "As expected value differences increase, reaction time decreases.",
              x = "Difference in Expected Value",
              y ="Reaction time (in seconds)",
              caption = "p > 0.05: N.S. \np < 0.05: * \np < 0.01: ** \np < 0.001: ***") +
         coord_cartesian(ylim=c(0, 2)) +
         theme_classic() +
         theme(plot.title = element_text(face="bold", size=13, hjust = 0.5)) +
         theme(plot.subtitle = element_text(face = "italic", size = 10, hjust = 0.5)) +
         theme(plot.caption = element_text(face = "italic", size = 8, hjust = 0.0)) +
         theme(axis.title = element_text(size = 12)) +
         theme(axis.text.x = element_text(size = 14, color = "Black")) +
         theme(axis.text.y = element_text(size = 14, color = "Black"))
rm(m1)


\name{hc_rect-dispatch}
\alias{hc_rect}
\title{
Method dispatch page for hc_rect
}
\description{
Method dispatch page for \code{hc_rect}.
}
\section{Dispatch}{
\code{hc_rect} can be dispatched on following classes:

\itemize{
\item \code{\link{hc_rect,HilbertCurve-method}}, \code{\link{HilbertCurve-class}} class method
\item \code{\link{hc_rect,GenomicHilbertCurve-method}}, \code{\link{GenomicHilbertCurve-class}} class method
}
}
\examples{
# no example
NULL

}


source("R/functions/get_score.r")

fn.si = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_sample_info_2_sle_lowDA.txt")
info = fread(fn.si, data.table=F)

fn.ge = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_ge_matrix_gene_sle_lowDA.txt")
dat = fread(fn.ge, data.table = F) %>%
  tibble::remove_rownames() %>% tibble::column_to_rownames("gene") %>%
  data.matrix()

fn.sig = file.path(PROJECT_DIR, "generated_data", "signatures", "CD38_ge_sig.txt")
cd38.genes = fread(fn.sig, header = F) %>% unlist(use.names=F)

gi = toupper(rownames(dat)) %in% toupper(cd38.genes)
sum(gi)

df.cd38.score = cbind(
                  dplyr::select(info, SUBJECT, VISIT, CUMULATIVE_TIME, SAMPLE_NAME),
                  data.frame(CD38_score=get_score(dat[gi,]))
                )

fn.sig = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_lowDA_cd38_ge_sig_score.txt")
fwrite(df.cd38.score, fn.sig, sep="\t", quote=F)

df.cd38.score.subj = df.cd38.score %>%
  dplyr::select(SUBJECT, CD38_score) %>%
  mutate(SUBJECT = factor(SUBJECT,
                          levels=unique(SUBJECT[order(as.numeric(sub("SLE-","",SUBJECT)))]))) %>%
  group_by(SUBJECT) %>%
  dplyr::summarise(CD38_score_mean=mean(CD38_score, na.rm=T)) %>%
  ungroup()

fn.sig.subj = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_lowDA_cd38_ge_sig_score_subjects.txt")
fwrite(df.cd38.score.subj, fn.sig.subj, sep="\t", quote=F)