#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)
}


# color compensation / multi-channel deconvolution

# function: get cross-over constant matrix k
get_k <- function(
    db_conn, # MySQL database connection
    dcv_exp_info, # deconvolution experiment ids, i.e. the data in these experiments are for constructing deconvolution matrix. a named vector (by channel) where each element is the experiment id using the target dye of each channel
    well_proc='dim3' # options: 'mean', 'dim3'.
    ) {

    dei_names <- names(dcv_exp_info)
    channel_names <- dei_names[2:length(dei_names)]
    channels <- sapply(channel_names, function(channel_name) strsplit(channel_name, '_')[[1]][2])
    num_channels <- length(channels)
    names(channel_names) <- channels

    dcv_list <- get_full_calib_data(db_conn, dcv_exp_info)

    water_data <- dcv_list[['water']]
    well_nums <- colnames(water_data)
    num_wells <- length(well_nums)

    k_list_bydy <- lapply(channel_names, function(channel_name) dcv_list[[channel_name]] - water_data)
    names(k_list_bydy) <- channels

    dye_names <- paste('dye_', channels)

    k_inv_array <- array(
        0,
        dim=c(num_channels, num_channels, num_wells),
        dimnames=list(channels, dye_names, well_nums)
    )

    k_singular <- ''

    if (well_proc == 'mean') {
        k <- as.matrix(do.call(cbind, lapply(channels, function(channel) {
            k_data_1dye <- rowMeans(k_list_bydy[[channel]])
            k_data_1dye / sum(k_data_1dye)
        })))
        colnames(k) <- dye_names
        k_inv <- tryCatch(solve(k), error=err_e)
        if ('error' %in% class(k_inv)) {
            k_singular <- c('Well mean K matrix is singular. ')
        } else {
            for (well_num in well_nums) {
                k_inv_array[,,well_num] <- k_inv
            }
        }

    } else if (well_proc == 'dim3') {
        k <- k_inv_array
        k_singular_vec <- c()
        for (well_num in well_nums) {
            k_mtx <- as.matrix(do.call(cbind, lapply(channels, function(channel) {
                k_data_1dye <- k_list_bydy[[channel]][,well_num]
                k_data_1dye / sum(k_data_1dye)
            })))
            k[,,well_num] <- k_mtx
            k_inv <- tryCatch(solve(k_mtx), error=err_e)
            if ('error' %in% class(k_inv)) {
                k_singular_vec <- c(k_singular_vec, well_num)
            } else {
                k_inv_array[,,well_num] <- k_inv
            }
        }
        if (length(k_singular_vec) > 0) {
            k_singular <- sprintf(
                'Well-specific K matrix is singular for the following well(s): %s. ',
                paste(k_singular_vec, collapse=', ')
            )
        }
    }

    return(list('k'=k, 'k_inv_array'=k_inv_array, 'k_singular'=k_singular))
    }

# multi-channel deconvolution
deconv <- function(
    array2dcv, # dim1 must be channel, dim3 must be well; dim2 is cycle for amplification and temperature point for melting curve
    db_conn,
    calib_info
    ) {

    a2d_dim1 <- dim(array2dcv)[1]
    a2d_dim2 <- dim(array2dcv)[2]
    a2d_dim3 <- dim(array2dcv)[3]
    a2d_dimnames <- dimnames(array2dcv)

    # if data only has 1 cycle (amplification) or 1 temperature point (melt curve)
    if (is.na(a2d_dim3)) array2dcv <- array(c(array2dcv),
                                            dim=c(a2d_dim1, 1, a2d_dim2),
                                            dimnames=list(a2d_dimnames[[1]], '1', a2d_dimnames[[2]]))

    if (class(calib_info) == "numeric" ||
        sum(duplicated(sapply(calib_info, function(calib_ele) calib_ele[['step_id']]))) > 0
    ) {
        k_list_temp <- k_list
    } else {
        k_list_temp <- get_k(db_conn, calib_info, 'dim3')
    }

    k_inv_array = k_list_temp[['k_inv_array']]

    dcvd_by_dim2_well <- lapply(1:a2d_dim2,
        function(dim2_i) do.call(cbind, lapply(1:a2d_dim3,
            function(well_i) k_inv_array[,,well_i] %*% array2dcv[,dim2_i,well_i]))) # dim2 is cycle_num for amp and temperature for melt curve

    dcvd_array <- array(NA, dim(array2dcv))
    for (dim2_i in 1:dim(array2dcv)[2]) dcvd_array[,dim2_i,] <- dcvd_by_dim2_well[[dim2_i]]
    dimnames(dcvd_array) <- dimnames(array2dcv)

    # scale by channel to adjust for different fluorescence excitation strengths among dyes
    for (channel in dimnames(dcvd_array)[1]) {
        dcvd_array[channel,,] <- dcvd_array[channel,,] * scaling_factors_deconv[channel] }

    return(list('dcvd_array'=dcvd_array, 'k_list_temp'=k_list_temp))
    }


# Model prediction Accuracy calculating function.
#The accuracy calculation function work based on +- one log bacterial count of predicted values from the actual values.

# x = is predicted values using the trained model
# y = is the actual test data
Percentage<-function(x, y){
  SVMLM_TVC<-c()
  for ( i in 1:length(x)){
    if((x[i])<=((y[i])+1) & x[i]>=((y[i])-1)){
      G<-i
      SVMLM_TVC<-c(SVMLM_TVC, G)

    }
    else{

    }

  }
  percentage_SVMLM_TVC<- length(SVMLM_TVC)/length(y)*100
}


# ruth's unifrac method

library(phangorn)
library(ape)
library(zCompositions)

gm_mean = function(x, na.rm=TRUE){
  exp(mean(log(x), na.rm=na.rm) )
}

# gm_vector = function(node_count, other_counts, geometric_mean) {
#   gm_vec <- array(0,length(node_count))
#   # a count of -1 means that the OTU has been amalgamated to other OTUs in the node_count
#   zero_means <- list()
#   counter = 1
#   for (i in 1:length(node_count)) {
#   # CHECK IF THIS IS CORRECT - indexing for other_counts
#     gm_vec[i] <- gm_mean(c(node_count[i],other_counts[i,][which(other_counts[i,]!=-1)]))
#     if (gm_vec[i] == 0) {
#       gm_vec[i] = geometric_mean[i]
#     }
#   }
#   return(gm_vec)
# }

gm_from_props = function(rownum, colnums) {
  otuPropsPerNode.adjustedZeros <- get("otuPropsPerNode.adjustedZeros",envir = .GlobalEnv)
  return(log2(otuPropsPerNode.adjustedZeros[rownum,colnums[1]]) - mean(log2(otuPropsPerNode.adjustedZeros[rownum,colnums])))
}

make_otu_props_positive = function() {
  otuPropsPerNode <- get("otuPropsPerNode",envir = .GlobalEnv)
  otuPropsPerNode.adjustedZeros <- get("otuPropsPerNode.adjustedZeros",envir = .GlobalEnv)
  otuPropsPerNode <- abs(otuPropsPerNode)
  otuPropsPerNode.adjustedZeros <- abs(otuPropsPerNode.adjustedZeros)
  assign("otuPropsPerNode", otuPropsPerNode, envir = .GlobalEnv)
  assign("otuPropsPerNode.adjustedZeros", otuPropsPerNode.adjustedZeros, envir = .GlobalEnv)
}

get_children = function(root) {
  unifrac.tree <- get("unifrac.tree",envir=.GlobalEnv)
  children <- unifrac.tree$edge[which(unifrac.tree$edge[,1]==root),2]
  return(children)
}

get_subtree = function() {
  otuPropsPerNode.adjustedZeros <- get("otuPropsPerNode.adjustedZeros",envir = .GlobalEnv)
  return(colnames(otuPropsPerNode.adjustedZeros)[which(otuPropsPerNode.adjustedZeros[1,] < 0)])
}

build_weights = function(root) {
  # make all weight values positive
  make_otu_props_positive()
  # if root is leaf, then weight has already been calculated and we can skip this
  if (root > length(unifrac.tree$tip.label)) {

    children <- get_children(root)

    # construct values for left child
    build_weights(children[1])
    leftChildSubtree <- get_subtree()

    # construct values for right child
    build_weights(children[2])
    rightChildSubtree <- get_subtree()

    otuPropsPerNode <- get("otuPropsPerNode",envir = .GlobalEnv)
    otuPropsPerNode.adjustedZeros <- get("otuPropsPerNode.adjustedZeros",envir = .GlobalEnv)
    weightsPerNode <- get("weightsPerNode",envir = .GlobalEnv)
    unifrac.tree <- get("unifrac.tree",envir=.GlobalEnv)
    unifrac.treeLeaves <- get("unifrac.treeLeaves",envir=.GlobalEnv)

    # the negative values in leftChildProportions are for all the nodes in the subtree of the left child
    # the negative values in rightChildProportions are for all the nodes in the subtree of the right child

    leafColumns <- colnames(otuPropsPerNode)[which(colnames(otuPropsPerNode) %in% unifrac.treeLeaves)]

    # make both left and right child subtrees negative
    otuPropsPerNode[,leftChildSubtree] <- (-1)*abs(otuPropsPerNode[,leftChildSubtree])
    otuPropsPerNode.adjustedZeros[,leftChildSubtree] <- (-1)*abs(otuPropsPerNode.adjustedZeros[,leftChildSubtree])

    # get columns for use in weight calculation (leaves not in right or left subtree plus root)
    columnsForWeightCalculation <- leafColumns
    columnsForWeightCalculation <- columnsForWeightCalculation[which(!(columnsForWeightCalculation %in% leftChildSubtree))]
    columnsForWeightCalculation <- columnsForWeightCalculation[which(!(columnsForWeightCalculation %in% rightChildSubtree))]
    columnsForWeightCalculation <- c(root, columnsForWeightCalculation)

    # calculate proportion of current node
    otuPropsPerNode[,root] <- abs(otuPropsPerNode[,children[1]]) + abs(otuPropsPerNode[,children[2]])
    otuPropsPerNode.adjustedZeros[,root] <- abs(otuPropsPerNode.adjustedZeros[,children[1]]) + abs(otuPropsPerNode.adjustedZeros[,children[2]])
    assign("otuPropsPerNode", otuPropsPerNode, envir = .GlobalEnv)
    assign("otuPropsPerNode.adjustedZeros", otuPropsPerNode.adjustedZeros, envir = .GlobalEnv)

    # calculate weight of current node
    weightsPerNode[,root] <- sapply(c(1:nrow(otuPropsPerNode.adjustedZeros)),function(x) { gm_from_props(x, columnsForWeightCalculation)})
  }
  # make root node values negative
  otuPropsPerNode[,root] <- (-1)*abs(otuPropsPerNode[,root])
  otuPropsPerNode.adjustedZeros[,root] <- (-1)*abs(otuPropsPerNode.adjustedZeros[,root])

  assign("otuPropsPerNode", otuPropsPerNode, envir = .GlobalEnv)
  assign("otuPropsPerNode.adjustedZeros", otuPropsPerNode.adjustedZeros, envir = .GlobalEnv)
  assign("weightsPerNode", weightsPerNode, envir = .GlobalEnv)
}

calculateDistanceMatrix <- function(weights, method, otuTable, verbose, pruneTree, normalize) {
  unifrac.tree <- get("unifrac.tree",envir=.GlobalEnv)
  otuPropsPerNode <- get("otuPropsPerNode",envir=.GlobalEnv)

  nSamples <- nrow(otuTable)
  distanceMatrix <- matrix(NA,nrow=nSamples,ncol=nSamples)
  rownames(distanceMatrix) <- rownames(otuTable)
  colnames(distanceMatrix) <- rownames(otuTable)

  branchLengths <- unifrac.tree$edge.length

  weightColnames <- as.numeric(colnames(weights))

  weights <- weights[,match(unifrac.tree$edge[,2], weightColnames)]

	for (i in 1:nSamples) {
		for (j in i:nSamples) {

				if (method == "weighted" || method == "information" || method == "ratio" || method == "ratio_no_log") {
					# the formula is sum of (proportional branch lengths * | proportional abundance for sample A - proportional abundance for sample B| )
					if (pruneTree==TRUE){
						includeBranchLengths <- which( (otuPropsPerNode[i,] > 0) | (otuPropsPerNode[j,] > 0) )
						if (normalize==TRUE && (method != "ratio" || method != "ratio_no_log")) {
							distance <- sum( branchLengths[includeBranchLengths] * abs(weights[i,includeBranchLengths] - weights[j,includeBranchLengths]) )/sum( branchLengths[includeBranchLengths]* (weights[i,includeBranchLengths] + weights[j,includeBranchLengths]) )
						}
						else {
							distance <- sum( branchLengths[includeBranchLengths] * abs(weights[i,includeBranchLengths] - weights[j,includeBranchLengths]) )/sum( branchLengths[includeBranchLengths])
						}
					}
					else {
						distance <- sum( branchLengths * abs(weights[i,] - weights[j,]) )/sum(branchLengths)
						if (normalize==TRUE) {
							distance <- sum( branchLengths * abs(weights[i,] - weights[j,]) )/sum(branchLengths * (weights[i,] + weights[j,]))
						}
					}

				}
			else {
				if (method!="unweighted") {
					warning(paste("Invalid method",method,", using unweighted Unifrac instead"))
				}
				# the formula is sum of (branch lengths * (1 if one sample has counts and not the other, 0 otherwise) )
				#	i call the (1 if one sample has counts and not the other, 0 otherwise) xorBranchLength
				xorBranchLength <- as.numeric(xor( weights[i,] > 0, weights[j,] > 0))
				if (pruneTree==TRUE) {
					includeBranchLengths <- which( (weights[i,] > 0) | (weights[j,] > 0) )
					distance <- sum( branchLengths[includeBranchLengths] *  xorBranchLength[includeBranchLengths])/sum(branchLengths[includeBranchLengths])
				}
				else {
					distance <- sum( branchLengths *  xorBranchLength)/sum(branchLengths)
				}

			}
			distanceMatrix[i,j] <- distance
			distanceMatrix[j,i] <- distance

		}
	}

	if(verbose) {	print("done")	}

	return(distanceMatrix)

}

#valid methods are unweighted, weighted, information, and ratio. Any other method will result in a warning and the unweighted analysis
#pruneTree option prunes the tree for each comparison to exclude branch lenxgths not present in both samples
#normalize divides the value at each node by sum of weights to guarantee output between 0 and 1 (breaks the triangle inequality)

#otuTable must have samples as rows, OTUs as columns
#tree must be phylo tree object from ape package (can use read.tree method to read in a newick tree to this format)

getDistanceMatrix <- function(otuTable,tree,method="weighted",verbose=FALSE,pruneTree=FALSE,normalize=TRUE)  {

	if (length(which(is.na(otuTable))) > 0) {
		stop("OTU count table has NA")
	}

	if (!is.rooted(tree)) {
		tree <- midpoint(tree)
		if(verbose) { print("Rooting tree by midpoint") }
	}

	if (attributes(tree)$order!="postorder") {
		tree <- reorder(tree,order="postorder")
		if (verbose) { print("Reordering tree as postorder for distance calculation algorithm") }
	}

  #make globally available copy of tree
  assign("unifrac.tree", tree, envir = .GlobalEnv)
  unifrac.tree <- get("unifrac.tree", envir = .GlobalEnv)

  #make globally available copy of leaves
  assign("unifrac.treeLeaves", c(1:length(tree$tip.label)), envir = .GlobalEnv)
  unifrac.treeLeaves <- get("unifrac.treeLeaves", envir = .GlobalEnv)

	# get proportions
	readsPerSample <- apply(otuTable,1,sum)
	otu.prop <- otuTable/readsPerSample
	otu.prop <- as.matrix(otu.prop)
	rownames(otu.prop) <- rownames(otuTable)
	colnames(otu.prop) <- colnames(otuTable)
	if(verbose) {	print("calculated proportional abundance")	}

	# add priors to zeros based on bayesian approach
	otuTable.adjustedZeros <- cmultRepl(otuTable, method="CZM", output="counts")
  # make any negative numbers as close to zero as possible - this is probably due to a precision error.
  otuTable.adjustedZeros <- apply(otuTable.adjustedZeros,2,function(x) { x[which(x < 0)] <- .Machine$double.eps; return(x) })
  readsPerSample <- apply(otuTable.adjustedZeros,1,sum)
  otu.prop.adjustedZeros <- otuTable.adjustedZeros/readsPerSample
  otu.prop.adjustedZeros <- as.matrix(otu.prop.adjustedZeros)
	rownames(otu.prop.adjustedZeros) <- rownames(otuTable)
	colnames(otu.prop.adjustedZeros) <- colnames(otuTable)

	##get cumulative proportional abundance for the nodes (nodes are ordered same as in the phylo tree representation)

  otuPropsPerNode <- matrix(NA, ncol=length(tree$edge.length)+1, nrow=length(rownames(otuTable)))
  otuPropsPerNode.adjustedZeros <- matrix(NA, ncol=length(tree$edge.length)+1, nrow=length(rownames(otuTable)))
  weightsPerNode <- matrix(NA, ncol=length(tree$edge.length)+1, nrow=length(rownames(otuTable)))

	#each row is a sample
  rownames(otuPropsPerNode) <- rownames(otuTable)
  rownames(otuPropsPerNode.adjustedZeros) <- rownames(otuTable)
  rownames(weightsPerNode) <- rownames(otuTable)
  #each column is a node in the tree
  colnames(otuPropsPerNode) <- c(1:(length(tree$edge.length)+1))
  colnames(otuPropsPerNode.adjustedZeros) <- c(1:(length(tree$edge.length)+1))
  colnames(weightsPerNode) <- c(1:(length(tree$edge.length)+1))

  leafNodes <- c(1:length(tree$tip.label))
  leafOrder <- match(tree$tip.label,colnames(otu.prop))

  otuPropsPerNode[,leafNodes] <- otu.prop[,leafOrder]
  otuPropsPerNode.adjustedZeros[,leafNodes] <- otu.prop.adjustedZeros[,leafOrder]
  weightsPerNode[,leafNodes] <- log2(otu.prop.adjustedZeros[,leafOrder])
  weightsPerNode[,leafNodes] <- t(apply(weightsPerNode[,leafNodes],1,function(x) { return(x - mean(x))}))

  # the tree is in postorder, so the last edges belong to the root
  root <- tree$edge[nrow(tree$edge),1]

  if(verbose) {	print("calculating weights...")	}

  assign("otuPropsPerNode", otuPropsPerNode, envir = .GlobalEnv)
  assign("otuPropsPerNode.adjustedZeros", otuPropsPerNode.adjustedZeros, envir = .GlobalEnv)
  assign("weightsPerNode", weightsPerNode, envir = .GlobalEnv)

  build_weights(root)

  otuPropsPerNode <- get("otuPropsPerNode",envir = .GlobalEnv)
  otuPropsPerNode.adjustedZeros <- get("otuPropsPerNode.adjustedZeros",envir = .GlobalEnv)
  weightsPerNode <- get("weightsPerNode",envir = .GlobalEnv)

  # build_weights makes everything negative, make everything positive again
  otuPropsPerNode[,c(1:ncol(otuPropsPerNode))] <- abs(otuPropsPerNode[,c(1:ncol(otuPropsPerNode))])
  otuPropsPerNode.adjustedZeros[,c(1:ncol(otuPropsPerNode.adjustedZeros))] <- abs(otuPropsPerNode.adjustedZeros[,c(1:ncol(otuPropsPerNode.adjustedZeros))])

  assign("otuPropsPerNode", otuPropsPerNode, envir = .GlobalEnv)
  assign("otuPropsPerNode.adjustedZeros", otuPropsPerNode.adjustedZeros, envir = .GlobalEnv)
  assign("weightsPerNode", weightsPerNode, envir = .GlobalEnv)

  if(verbose) {	print("calculating pairwise distances...")	}

  #convert table according to weight
  if (method == "all") {
    returnList <- list()
    # unweighted
    print("calculating unweighted distance matrix")
    weights <- otuPropsPerNode
    returnList[["unweighted"]] <- calculateDistanceMatrix(weights, "unweighted", otuTable, verbose, pruneTree, normalize)
    # weighted
    print("calculating weighted distance matrix")
    weights <- otuPropsPerNode
    returnList[["weighted"]] <- calculateDistanceMatrix(weights, "weighted", otuTable, verbose, pruneTree, normalize)
    # information
    print("calculating information distance matrix")
    weights <- otuPropsPerNode.adjustedZeros*log2(otuPropsPerNode.adjustedZeros)
    returnList[["information"]] <- calculateDistanceMatrix(weights, "information", otuTable, verbose, pruneTree, normalize)
    # ratio
    print("calculating ratio distance matrix")
    weights <- weightsPerNode
    returnList[["ratio"]] <- calculateDistanceMatrix(weights, "ratio", otuTable, verbose, pruneTree, normalize)
    # ratio no log
    print("calculating no log ratio distance matrix")
    weights <- weightsPerNode
    weights <- 2^weights
    returnList[["ratio_no_log"]] <- calculateDistanceMatrix(weights, "ratio_no_log", otuTable, verbose, pruneTree, normalize)
    return(returnList)
  } else if (method=="information") {
    weights <- otuPropsPerNode.adjustedZeros*log2(otuPropsPerNode.adjustedZeros)
    return(calculateDistanceMatrix(weights, method, otuTable, verbose, pruneTree, normalize))
  } else if (method == "ratio_no_log") {
    weights <- weightsPerNode
    weights <- 2^weights
    return(calculateDistanceMatrix(weights, method, otuTable, verbose, pruneTree, normalize))
  } else if (method == "ratio") {
    weights <- weightsPerNode
    return(calculateDistanceMatrix(weights, method, otuTable, verbose, pruneTree, normalize))
  }
  else {
    weights <- otuPropsPerNode
    return(calculateDistanceMatrix(weights, method, otuTable, verbose, pruneTree, normalize))
  }
}


#' Outlier adjustment estimation
#'
#' How much of the heterogeneity due to the outlier can be explained by alternative pathways?
#'
#' @param tryxscan Output from \code{tryx.scan}
#' @param id_remove List of IDs to exclude from the adjustment analysis. It is possible that in the outlier search a candidate trait will come up which is essentially just a surrogate for the outcome trait (e.g. if you are analysing coronary heart disease as the outcome then a variable related to heart disease medication might come up as a candidate trait). Adjusting for a trait which is essentially the same as the outcome will erroneously nullify the result, so visually inspect the candidate trait list and remove those that are inappropriate.
#'
#' @export
#' @return data frame of adjusted effect estimates and heterogeneity stats
tryx.adjustment <- function(tryxscan, id_remove=NULL)
{
	# for each outlier find the candidate MR analyses
	# if only exposure then ignore
	# if only outcome then re-estimate the snp-outcome association
	# if exposure and outcome then re-estimate the snp-exposure and snp-outcome association
	# outlier
	# candidate
	# what
	# old.beta.exposure
	# adj.beta.exposure
	# old.beta.outcome
	# adj.beta.outcome
	# candidate.beta.outcome
	# candidate.se.outcome
	# candidate.beta.exposure
	# candidate.se.exposure
	# old.deviation
	# new.deviation

	if(!any(tryxscan$search$sig))
	{
		return(tibble())
	}

	l <- list()
	sig <- subset(tryxscan$search, sig & !id.outcome %in% id_remove)
	sige <- subset(tryxscan$candidate_exposure_mr, sig & !id.exposure %in% id_remove)
	sigo <- subset(tryxscan$candidate_outcome_mr, sig & !id.exposure %in% id_remove)

	dat <- tryxscan$dat
	dat$qi <- cochrans_q(dat$beta.outcome / dat$beta.exposure, dat$se.outcome / abs(dat$beta.exposure))
	dat$Q <- sum(dat$qi)
	for(i in 1:nrow(sig))
	{
		a <- subset(dat, SNP == sig$SNP[i], select=c(SNP, beta.exposure, beta.outcome, se.exposure, se.outcome, qi, Q))
		if(sig$id.outcome[i] %in% sigo$id.exposure)
		{
			a$candidate <- sig$outcome[i]
			a$i <- i
			if(sig$id.outcome[i] %in% sige$id.exposure) {
				message("x<-p->y:  ", a$SNP, "\t- ", sig$outcome[i])
				a$what <- "p->x; p->y"
				a$candidate.beta.exposure <- sige$b[sige$id.exposure == sig$id.outcome[i]]
				a$candidate.se.exposure <- sige$se[sige$id.exposure == sig$id.outcome[i]]
				a$candidate.beta.outcome <- sigo$b[sigo$id.exposure == sig$id.outcome[i]]
				a$candidate.se.outcome <- sigo$se[sigo$id.exposure == sig$id.outcome[i]]
				b <- bootstrap_path(a$beta.exposure, a$se.exposure, sig$beta.outcome[i], sig$se.outcome[i], sige$b[sige$id.exposure == sig$id.outcome[i]], sige$se[sige$id.exposure == sig$id.outcome[i]])
				a$adj.beta.exposure <- b[1]
				a$adj.se.exposure <- b[2]
				b <- bootstrap_path(a$beta.outcome, a$se.outcome, sig$beta.outcome[i], sig$se.outcome[i], sigo$b[sigo$id.exposure == sig$id.outcome[i]], sigo$se[sigo$id.exposure == sig$id.outcome[i]])
				a$adj.beta.outcome <- b[1]
				a$adj.se.outcome <- b[2]
			} else {
				message("   p->y:  ", a$SNP, "\t- ", sig$outcome[i])
				a$what <- "p->y"
				a$candidate.beta.exposure <- NA
				a$candidate.se.exposure <- NA
				a$candidate.beta.outcome <- sigo$b[sigo$id.exposure == sig$id.outcome[i]]
				a$candidate.se.outcome <- sigo$se[sigo$id.exposure == sig$id.outcome[i]]
				b <- bootstrap_path(a$beta.outcome, a$se.outcome, sig$beta.outcome[i], sig$se.outcome[i], sigo$b[sigo$id.exposure == sig$id.outcome[i]], sigo$se[sigo$id.exposure == sig$id.outcome[i]])
				a$adj.beta.exposure <- a$beta.exposure
				a$adj.se.exposure <- a$se.exposure
				a$adj.beta.outcome <- b[1]
				a$adj.se.outcome <- b[2]
			}
			temp <- dat
			temp$beta.exposure[temp$SNP == a$SNP] <- a$adj.beta.exposure
			temp$se.exposure[temp$SNP == a$SNP] <- a$adj.se.exposure
			temp$beta.outcome[temp$SNP == a$SNP] <- a$adj.beta.outcome
			temp$se.outcome[temp$SNP == a$SNP] <- a$adj.se.outcome
			temp$qi <- cochrans_q(temp$beta.outcome / temp$beta.exposure, temp$se.outcome / abs(temp$beta.exposure))
			a$adj.qi <- temp$qi[temp$SNP == a$SNP]
			a$adj.Q <- sum(temp$qi)

			l[[i]] <- a
		}

	}
	l <- bind_rows(l)
	l$d <- (l$adj.qi / l$adj.Q) / (l$qi / l$Q)
	return(l)
}

tryx.adjustment.mv <- function(tryxscan, lasso=TRUE, id_remove=NULL, proxies=FALSE)
{
	# for each outlier find the candidate MR analyses
	# if only exposure then ignore
	# if only outcome then re-estimate the snp-outcome association
	# if exposure and outcome then re-estimate the snp-exposure and snp-outcome association
	# outlier
	# candidate
	# what
	# old.beta.exposure
	# adj.beta.exposure
	# old.beta.outcome
	# adj.beta.outcome
	# candidate.beta.outcome
	# candidate.se.outcome
	# candidate.beta.exposure
	# candidate.se.exposure
	# old.deviation
	# new.deviation

	if(!any(tryxscan$search$sig))
	{
		return(tibble())
	}

	l <- list()
	sig <- subset(tryxscan$search, sig & !id.outcome %in% id_remove)
	sige <- subset(tryxscan$candidate_exposure_mr, sig & !id.exposure %in% id_remove)
	sigo <- subset(tryxscan$candidate_outcome_mr, sig & !id.exposure %in% id_remove)

	id.exposure <- tryxscan$dat$id.exposure[1]
	id.outcome <- tryxscan$dat$id.outcome[1]

#	for each outlier SNP find its effects on

	sigo1 <- subset(sig, id.outcome %in% sigo$id.exposure) %>% group_by(SNP) %>% mutate(snpcount=n()) %>% arrange(desc(snpcount), SNP)
	snplist <- unique(sigo1$SNP)
	mvo <- list()
	dat <- tryxscan$dat
	dat$qi <- cochrans_q(dat$beta.outcome / dat$beta.exposure, dat$se.outcome / abs(dat$beta.exposure))
	dat$Q <- sum(dat$qi)
	dat$orig.beta.outcome <- dat$beta.outcome
	dat$orig.se.outcome <- dat$se.outcome
	dat$orig.qi <- dat$qi
	dat$outlier <- FALSE
	dat$outlier[dat$SNP %in% tryxscan$outliers] <- TRUE
	for(i in 1:length(snplist))
	{
		message("Estimating joint effects of the following trait(s) associated with ", snplist[i])
		temp <- subset(sigo1, SNP %in% snplist[i])
		candidates <- unique(temp$outcome)
		message(paste(candidates, collapse="\n"))
		if(lasso & length(candidates) == 1)
		{
			message("Only one candidate trait for SNP ", snplist[i], " so performing standard MVMR instead of LASSO")
		}
		mvexp <- suppressMessages(mv_extract_exposures(c(id.exposure, unique(temp$id.outcome)), find_proxies=proxies))
		mvout <- suppressMessages(extract_outcome_data(mvexp$SNP, id.outcome))
		mvdat <- suppressMessages(mv_harmonise_data(mvexp, mvout))
		if(lasso & length(candidates) > 1)
		{
			message("Performing shrinkage")
			b <- glmnet::cv.glmnet(x=mvdat$exposure_beta, y=mvdat$outcome_beta, weight=1/mvdat$outcome_se^2, intercept=0)
			c <- coef(b, s = "lambda.min")
			keeplist <- unique(c(rownames(c)[!c[,1] == 0], tryxscan$dat$id.exposure[1]))
			message("After shrinkage keeping:")
			message(paste(keeplist, collapse="\n"))
			mvexp2 <- subset(mvexp, id.exposure %in% keeplist)
			remsnp <- group_by(mvexp2, SNP) %>% summarise(mp = min(pval.exposure)) %>% filter(mp > 5e-8) %$% as.character(SNP)
			mvexp2 <- subset(mvexp2, !SNP %in% remsnp)
			mvout2 <- subset(mvout, SNP %in% mvexp2$SNP)
			mvdat2 <- suppressMessages(mv_harmonise_data(mvexp2, mvout2))
			mvo[[i]] <- mv_multiple(mvdat2)$result
		} else {
			mvo[[i]] <- mv_multiple(mvdat)$result
		}
		mvo[[i]] <- subset(mvo[[i]], !exposure %in% tryxscan$dat$exposure[1])
		temp2 <- with(temp, tibble(SNP=SNP, exposure=outcome, snpeff=beta.outcome, snpeff.se=se.outcome, snpeff.pval=pval.outcome))
		mvo[[i]] <- merge(mvo[[i]], temp2, by="exposure")
		boo <- with(subset(dat, SNP == snplist[i]),
			bootstrap_path(
				beta.outcome,
				se.outcome,
				mvo[[i]]$snpeff,
				mvo[[i]]$snpeff.se,
				mvo[[i]]$b,
				mvo[[i]]$se
			))
		dat$beta.outcome[dat$SNP == snplist[i]] <- boo[1]
		dat$se.outcome[dat$SNP == snplist[i]] <- boo[2]
	}
	mvo <- bind_rows(mvo)

	dat$qi[dat$mr_keep] <- cochrans_q(dat$beta.outcome[dat$mr_keep] / dat$beta.exposure[dat$mr_keep], dat$se.outcome[dat$mr_keep] / abs(dat$beta.exposure[dat$mr_keep]))
	return(list(mvo=mvo, dat=dat))
}

#' Analyse tryx results
#'
#' This returns various heterogeneity statistics, IVW estimates for raw,
#' adjusted and outlier removed datasets, and summary of peripheral
#' traits detected etc.
#'
#' @param tryxscan Output from \code{tryx.scan}
#' @param plot Whether to plot or not. Default is TRUE
#' @param id_remove List of IDs to exclude from the adjustment analysis. It is possible that in the outlier search a candidate trait will come up which is essentially just a surrogate for the outcome trait (e.g. if you are analysing coronary heart disease as the outcome then a variable related to heart disease medication might come up as a candidate trait). Adjusting for a trait which is essentially the same as the outcome will erroneously nullify the result, so visually inspect the candidate trait list and remove those that are inappropriate.
#' @param duplicate_outliers_method Sometimes more than one trait will associate with a particular outlier. TRUE = only keep the trait that has the biggest influence on heterogeneity
#'
#' @export
#' @return List of
#' - adj_full: data frame of SNP adjustments for all candidate traits
#' - adj: The results from adj_full selected to adjust the exposure-outcome model
#' - Q: Heterogeneity stats
#' - estimates: Adjusted and unadjested exposure-outcome effects
#' - plot: Radial plot showing the comparison of different methods and the changes in SNP effects ater adjustment
tryx.analyse <- function(tryxscan, plot=TRUE, id_remove=NULL, filter_duplicate_outliers=TRUE)
{

	analysis <- list()
	adj_full <- tryx.adjustment(tryxscan, id_remove)
	if(nrow(adj_full) == 0)
	{
		return(NULL)
	}
	analysis$adj_full <- adj_full
	if(filter_duplicate_outliers)
	{
		adj <- adj_full %>% arrange(d) %>% filter(!duplicated(SNP))
	} else {
		adj <- adj_full
	}
	analysis$adj <- adj

	# Detection
	# if("simulation" %in% names(tryxscan))
	# {
	# 	detection <- list()
	# 	detection$nu1_correct <- sum(adj$SNP %in% 1:tryxscan$simulation$nu1 & adj$what != "p->y")
	# 	detection$nu1_incorrect <- sum(adj$SNP %in% 1:tryxscan$simulation$nu1 & adj$what == "p->y")
	# 	detection$nu2_correct <- sum(adj$SNP %in% (1:tryxscan$simulation$nu2 + tryxscan$simulation$nu1) & adj$what == "p->y")
	# 	detection$nu2_incorrect <- sum(adj$SNP %in% (1:tryxscan$simulation$nu2 + tryxscan$simulation$nu1) & adj$what != "p->y")
	# 	detection$no_outlier_flag <- tryxscan$simulation$no_outlier_flag
	# 	analysis$detection <- detection
	# }

	cpg <- require(ggrepel)
	if(!cpg)
	{
		stop("Please install the ggrepel package\ninstall.packages('ggrepel')")
	}

	dat <- subset(tryxscan$dat, mr_keep, select=c(SNP, beta.exposure, beta.outcome, se.exposure, se.outcome))
	dat$ratio <- dat$beta.outcome / dat$beta.exposure
	dat$weights <- sqrt(dat$beta.exposure^2 / dat$se.outcome^2)
	dat$ratiow <- dat$ratio * dat$weights
	dat$what <- "Unadjusted"
	dat$candidate <- "NA"
	dat$qi <- cochrans_q(dat$beta.outcome / dat$beta.exposure, dat$se.outcome / abs(dat$beta.exposure))

	analysis$Q$full_Q <- adj$Q[1]
	analysis$Q$num_reduced <- sum(adj$adj.qi < adj$qi)
	analysis$Q$mean_d <- mean(adj$d)

	temp <- subset(adj, select=c(SNP, adj.beta.exposure, adj.beta.outcome, adj.se.exposure, adj.se.outcome, candidate))
	temp$qi <- cochrans_q(temp$adj.beta.outcome / temp$adj.beta.exposure, temp$adj.se.outcome / abs(temp$adj.beta.exposure))
	ind <- grepl("\\|", temp$candidate)
	if(any(ind))
	{
		temp$candidate[ind] <- sapply(strsplit(temp$candidate[ind], split=" \\|"), function(x) x[[1]])
	}
	names(temp) <- gsub("adj.", "", names(temp))
	temp$what <- "Adjusted"
	temp$weights <- sqrt(temp$beta.exposure^2 / temp$se.outcome^2)
	temp$ratio <- temp$beta.outcome / temp$beta.exposure
	temp$ratiow <- temp$ratio * temp$weights

	dat_adj <- rbind(temp, dat) %>% filter(!duplicated(SNP))
	dat_adj$qi <- cochrans_q(dat_adj$beta.outcome / dat_adj$beta.exposure, dat_adj$se.outcome / abs(dat_adj$beta.exposure))
	analysis$Q$adj_Q <- sum(dat_adj$qi)

	dat_rem <- subset(dat, !SNP %in% temp$SNP)
	dat_rem2 <- subset(dat, !SNP %in% tryxscan$outliers)
	# adjust everything that's possible remove remaining outliers
	dat_rem3 <- rbind(temp, dat_rem2) %>% filter(!duplicated(SNP))

	estimates <- tibble()

	# Raw IVW
	tt <- dat
	mod <- summary(lm(ratiow ~ -1 + weights, data=tt))
	estimates <- bind_rows(estimates,
		tibble(
			est="Raw",
			b=coefficients(mod)[1,1],
			se = coefficients(mod)[1,2],
			pval=coefficients(mod)[1,4],
			nsnp = nrow(tt),
			Q = sum(tt$qi),
			int = 0
		)
	)

	# Outliers removed (all)
	tt <- subset(dat, !SNP %in% tryxscan$outliers)
	mod <- try(summary(lm(ratiow ~ -1 + weights, data=tt)))
	if(class(mod) != "try-error")
	{
		estimates <- bind_rows(estimates,
			tibble(
				est="Outliers removed (all)",
				b=coefficients(mod)[1,1],
				se = coefficients(mod)[1,2],
				pval=coefficients(mod)[1,4],
				nsnp = nrow(tt),
				Q = sum(tt$qi),
				int = 0
			)
		)
	}

	# Outliers removed (candidates)
	tt <- subset(dat, !SNP %in% temp$SNP)
	mod <- try(summary(lm(ratiow ~ -1 + weights, data=tt)))
	if(class(mod) != "try-error")
	{
		estimates <- bind_rows(estimates,
			tibble(
				est="Outliers removed (candidates)",
				b=coefficients(mod)[1,1],
				se = coefficients(mod)[1,2],
				pval=coefficients(mod)[1,4],
				nsnp = nrow(tt),
				Q = sum(tt$qi),
				int = 0
			)
		)
	}

	# Outliers adjusted
	tt <- rbind(temp, dat) %>% filter(!duplicated(SNP))
	tt$qi <- cochrans_q(tt$beta.outcome / tt$beta.exposure, tt$se.outcome / abs(tt$beta.exposure))
	analysis$Q$adj_Q <- sum(tt$qi)
	mod <- try(summary(lm(ratiow ~ -1 + weights, data=tt)))
	if(class(mod) != "try-error")
	{
		estimates <- bind_rows(estimates,
			tibble(
				est="Outliers adjusted",
				b=coefficients(mod)[1,1],
				se = coefficients(mod)[1,2],
				pval=coefficients(mod)[1,4],
				nsnp = nrow(tt),
				Q = sum(tt$qi),
				int = 0
			)
		)
	}

	if("mvres" %in% names(tryxscan))
	{
		estimates <- bind_rows(estimates,
			tibble(
				est="Multivariable MR",
				b=tryxscan$mvres$result$b[1],
				se = tryxscan$mvres$result$se[1],
				pval = tryxscan$mvres$result$pval[1],
				nsnp = tryxscan$mvres$result$nsnp[1],
				Q = NA,
				int = 0
			)
		)
	}

	if("true_outliers" %in% names(tryxscan))
	{
		tt <- subset(dat, !SNP %in% tryxscan$true_outliers)
		mod <- try(summary(lm(ratiow ~ -1 + weights, data=tt)))
		if(class(mod) != "try-error")
		{
			estimates <- bind_rows(estimates,
				tibble(
					est=c("Oracle"),
					b=c(coefficients(mod)[1,1]),
					se=c(coefficients(mod)[1,2]),
					pval=c(coefficients(mod)[1,4]),
					nsnp=c(nrow(tt)),
					Q = c(sum(tt$qi)),
					int=0
				)
			)
		}
	}

	estimates <- bind_rows(estimates)
	estimates$Isq <- pmax(0, (estimates$Q - estimates$nsnp - 1) / estimates$Q)

	analysis$estimates <- estimates

	# est3 <- summary(lm(ratiow ~ -1 + weights, data=dat_adj))
	# est4 <- try(summary(lm(ratiow ~ -1 + weights, data=dat_rem2)))
	# est5 <- try(summary(lm(ratiow ~ -1 + weights, data=dat_rem3)))
	# if(class(est4) == "try-error")
	# {
	# 	est4 <- list(coefficients = matrix(NA, 2,4))
	# }

	# estimates <- data.frame(
	# 	est=c("Raw", "Outliers removed (candidates)", "Outliers removed (all)", "Outliers adjusted", "Mixed", "Multivariable MR"),
	# 	b=c(coefficients(est2)[1,1], coefficients(est1)[1,1], coefficients(est4)[1,1], coefficients(est3)[1,1], coefficients(est5)[1,1], tryxscan$mvres$result$b[1]),
	# 	se=c(coefficients(est2)[1,2], coefficients(est1)[1,2], coefficients(est4)[1,2], coefficients(est3)[1,2], coefficients(est5)[1,2], tryxscan$mvres$result$se[1]),
	# 	pval=c(coefficients(est2)[1,4], coefficients(est1)[1,4], coefficients(est4)[1,4], coefficients(est3)[1,4], coefficients(est5)[1,4], tryxscan$mvres$result$pval[1]),
	# 	nsnp=c(nrow(dat), nrow(dat_rem), nrow(dat_rem2), nrow(dat_adj), nrow(dat_rem3), tryxscan$mvres$result$nsnp[1]),
	# 	Q = c(sum(dat$qi), sum(dat_rem$qi), sum(dat_rem2$qi), sum(dat_adj$qi), sum(dat_rem3$qi), NA),
	# 	int=0
	# )
	# estimates$Isq <- pmax(0, (estimates$Q - estimates$nsnp - 1) / estimates$Q)

	# estimates$Isq <- pmax(0, (estimates$Q - estimates$nsnp - 1) / estimates$Q)

	# analysis$estimates <- estimates

	if(plot)
	{
		temp2 <- merge(dat, temp, by="SNP")
		labs <- rbind(
			data.frame(label=temp2$SNP, x=temp2$weights.x, y=temp2$weights.x * temp2$ratio.x),
			data.frame(label=temp$candidate, x=temp$weights, y=temp$weights * temp$ratio)
		)
		p <- ggplot(rbind(dat, temp), aes(y=ratiow, x=weights)) +
		geom_abline(data=estimates, aes(slope=b, intercept=0, colour=est)) +
		geom_label_repel(data=labs, aes(x=x, y=y, label=label), size=2, segment.color = "grey10") +
		geom_point() +
		geom_segment(data=temp2, colour="grey50", aes(x=weights.x, xend=weights.y, y=ratiow.x, yend=ratiow.y), arrow = arrow(length = unit(0.02, "npc"))) +
		labs(colour="") +
		xlim(c(0, max(dat$weights))) +
		ylim(c(min(0, dat$ratiow, temp$ratiow), max(dat$ratiow, temp$ratiow))) +
		scale_colour_brewer(type="qual")
		analysis$plot <- p
	}
	return(analysis)
}

#' Analyse tryx results
#'
#' This returns various heterogeneity statistics, IVW estimates for raw,
#' adjusted and outlier removed datasets, and summary of peripheral
#' traits detected etc.
#'
#' @param tryxscan Output from \code{tryx.scan}
#' @param plot Whether to plot or not. Default is TRUE
#' @param filter_duplicate_outliers Whether to only allow each putative outlier to be adjusted by a single trait (in order of largest divergence). Default is TRUE.
#'
#' @export
#' @return List of
#' - adj_full: data frame of SNP adjustments for all candidate traits
#' - adj: The results from adj_full selected to adjust the exposure-outcome model
#' - Q: Heterogeneity stats
#' - estimates: Adjusted and unadjested exposure-outcome effects
#' - plot: Radial plot showing the comparison of different methods and the changes in SNP effects ater adjustment

#' Adjust and analyse the tryx results
#'
#' Similar to tryx.analyse, but when there are multiple traits associated with a single variant then we use a LASSO-based multivariable approach
#'
#' @param tryxscan Output from \code{tryx.scan}
#' @param lasso Whether to shrink the estimates of each trait within SNP. Default=TRUE.
#' @param plot Whether to plot or not. Default is TRUE
#' @param id_remove List of IDs to exclude from the adjustment analysis. It is possible that in the outlier search a candidate trait will come up which is essentially just a surrogate for the outcome trait (e.g. if you are analysing coronary heart disease as the outcome then a variable related to heart disease medication might come up as a candidate trait). Adjusting for a trait which is essentially the same as the outcome will erroneously nullify the result, so visually inspect the candidate trait list and remove those that are inappropriate.
#' @param proxies Look for proxies in the MVMR methods. Default = FALSE.
#'
#' @export
#' @return List of
#' - adj_full: data frame of SNP adjustments for all candidate traits
#' - adj: The results from adj_full selected to adjust the exposure-outcome model
#' - Q: Heterogeneity stats
#' - estimates: Adjusted and unadjested exposure-outcome effects
#' - plot: Radial plot showing the comparison of different methods and the changes in SNP effects ater adjustment
tryx.analyse.mv <- function(tryxscan, lasso=TRUE, plot=TRUE, id_remove=NULL, proxies=FALSE)
{
	adj <- tryx.adjustment.mv(tryxscan, lasso=lasso, id_remove=id_remove, proxies=proxies)
	dat <- subset(adj$dat, mr_keep)
	dat$orig.ratio <- dat$orig.beta.outcome / dat$beta.exposure
	dat$orig.weights <- sqrt(dat$beta.exposure^2 / dat$orig.se.outcome^2)
	dat$orig.ratiow <- dat$orig.ratio * dat$orig.weights
	dat$ratio <- dat$beta.outcome / dat$beta.exposure
	dat$weights <- sqrt(dat$beta.exposure^2 / dat$se.outcome^2)
	dat$ratiow <- dat$ratio * dat$weights

	est_raw <- summary(lm(orig.ratiow ~ -1 + orig.weights, data=dat))
	est_adj <- summary(lm(ratiow ~ -1 + weights, data=dat))
	est_out1 <- summary(lm(orig.ratiow ~ -1 + orig.weights, data=subset(dat, !SNP %in% tryxscan$outliers)))
	est_out2 <- summary(lm(orig.ratiow ~ -1 + orig.weights, data=subset(dat, !SNP %in% adj$mvo$SNP)))

	estimates <- data.frame(
		est=c("Raw", "Outliers removed (all)", "Outliers removed (candidates)", "Outliers adjusted"),
		b=c(coefficients(est_raw)[1,1], coefficients(est_out2)[1,1], coefficients(est_out1)[1,1], coefficients(est_adj)[1,1]),
		se=c(coefficients(est_raw)[1,2], coefficients(est_out2)[1,2], coefficients(est_out1)[1,2], coefficients(est_adj)[1,2]),
		pval=c(coefficients(est_raw)[1,4], coefficients(est_out2)[1,4], coefficients(est_out1)[1,4], coefficients(est_adj)[1,4]),
		nsnp=c(nrow(dat), nrow(subset(dat, !SNP %in% tryxscan$outliers)), nrow(subset(dat, !SNP %in% adj$mvo$SNP)), nrow(dat)),
		Q = c(sum(dat$orig.qi), sum(subset(dat, !SNP %in% tryxscan$outliers)$qi), sum(subset(dat, !SNP %in% adj$mvo$SNP)$qi), sum(dat$qi)),
		int=0
	)
	estimates$Isq <- pmax(0, (estimates$Q - estimates$nsnp - 1) / estimates$Q)

	analysis <- list(
		estimates=estimates,
		mvo=adj$mvo,
		dat=adj$dat
	)

	if(plot)
	{
		dato <- subset(dat, SNP %in% tryxscan$outliers)
		datadj <- subset(dat, SNP %in% adj$mvo$SNP)
		datadj$x <- datadj$orig.weights
		datadj$xend <- datadj$weights
		datadj$y <- datadj$orig.ratiow
		datadj$yend <- datadj$ratiow

		mvog <- tidyr::separate(adj$mvo, exposure, sep="\\|", c("exposure", "temp", "id"))
		mvog$exposure <- gsub(" $", "", mvog$exposure)
		mvog <- group_by(mvog, SNP) %>% summarise(label = paste(exposure, collapse="\n"))
		datadj <- merge(datadj, mvog, by="SNP")

		labs <- rbind(
			tibble(label=dato$SNP, x=dato$orig.weights, y=dato$orig.ratiow, col="grey50"),
			tibble(label=datadj$label, x=datadj$weights, y=datadj$ratiow, col="grey100")
		)

		p <- ggplot(dat, aes(y=orig.ratiow, x=orig.weights)) +
		geom_abline(data=estimates, aes(slope=b, intercept=0, linetype=est)) +
		geom_label_repel(data=labs, aes(label=label, x=x, y=y, colour=col), size=2, segment.color = "grey50", show.legend = FALSE) +
		geom_point(data=dato, size=4) +
		# geom_label_repel(data=labs, aes(label=label, x=weights, y=ratiow), size=2, segment.color = "grey50") +
		geom_point(data=datadj, aes(x=weights, y=ratiow)) +
		geom_point(aes(colour=SNP %in% dato$SNP), show.legend=FALSE) +
		geom_segment(data=datadj, colour="grey50", aes(x=x, xend=xend, y=y, yend=yend), arrow = arrow(length = unit(0.01, "npc"))) +
		labs(colour=NULL, linetype="Estimate", x="w", y="beta * w")
		# xlim(c(0, max(dat$weights))) +
		# ylim(c(min(0, dat$ratiow, temp$ratiow), max(dat$ratiow, temp$ratiow)))
		analysis$plot <- p
	}
	return(analysis)

}

#' Cochran's Q statistic
#'
#' @param b vector of effecti
#' @param se vector of standard errors
#'
#' @return q values
#'
#' @export
cochrans_q <- function(b, se)
{
	xw <- sum(b / se^2) / sum(1/se^2)
	qi <- (1/se^2) * (b - xw)^2
	return(qi)
}

bootstrap_path1 <- function(gx, gx.se, gp, gp.se, px, px.se, nboot=1000)
{
	res <- rnorm(nboot, gx, gx.se) - rnorm(nboot, gp, gp.se) * rnorm(nboot, px, px.se)
	pe <- gx - gp * px
	return(c(pe, sd(res)))
}

bootstrap_path <- function(gx, gx.se, gp, gp.se, px, px.se, nboot=1000)
{
	nalt <- length(gp)
	altpath <- tibble(
		p = rnorm(nboot * nalt, gp, gp.se) * rnorm(nboot * nalt, px, px.se),
		b = rep(1:nboot, each=nalt)
	)
	altpath <- group_by(altpath, b) %>%
		summarise(p = sum(p))
	res <- rnorm(nboot, gx, gx.se) - altpath$p
	pe <- gx - sum(gp * px)
	return(c(pe, sd(res)))
}

radialmr <- function(dat, outlier=NULL)
{
	library(ggplot2)
	beta.exposure <- dat$beta.exposure
	beta.outcome <- dat$beta.outcome
	se.outcome <- dat$se.outcome
	w <- sqrt(beta.exposure^2 / se.outcome^2)
	ratio <- beta.outcome / beta.exposure
	ratiow <- ratio*w
	dat <- data.frame(w=w, ratio=ratio, ratiow=ratiow)
	if(is.null(outlier))
	{
		dat2 <- dat
	} else {
		dat2 <- dat[-c(outlier), ]
	}
	mod <- lm(ratiow ~ -1 + w, dat2)$coefficients[1]
	ggplot(dat, aes(x=w, y=ratiow)) +
	geom_point() +
	geom_abline(slope=mod, intercept=0)
}


# /* !/usr/bin/Rscript */

#' ## Data munging
#' Pre-process and explore datasets in preparation for feature creation.
#'
#'

#'
survival

#'
Survival (0 = No; 1 = Yes)

#'
pclass

#'
Passenger Class (1 = 1st; 2 = 2nd; 3 = 3rd)

#'
name

#'
Name (Title-Firstnames-Surname)

#'
sex

#'
Sex (Male/Female)
#'
age

#'
Age (in years, float)
#'
sibsp

#'
Number of Siblings/Spouses aboard

#'
parch

#'
Number of Parents/Children aboard

#'
ticket

#'
Ticket Number (alphanumeric)

#'
fare

#'
Passenger Fare (in US$)

#'
cabin

#'
Cabin (alphanumeric)

#'
embarked

#'
Port of Embarkation (C=Cherbourg; Q=Queenstown; S=Southampton)

#'

#'
#' #### Family Relation Details
#' With respect to the family relation variables (i.e. *Sibsp* and
#' *Parch*) some relations were ignored. The following are the
#' definitions used for sibsp and parch (aboard Titanic):
#' - Sibling: Brother, Sister, Stepbrother, or Stepsister of Passenger
#' - Spouse: Husband or Wife of Passenger (Mistresses and Fiances
#'   ignored)
#' - Parent: Mother or Father of Passenger
#' - Child: Son, Daughter, Stepson, or Stepdaughter of Passenger
#'
#' Other family relatives excluded from this study include cousins,
#' nephews/nieces, aunts/uncles, and in-laws. Some children travelled
#' only with a nanny, therefore `parch=0` for them. As well, some
#' travelled with very close friends or neighbors in a village, however,
#' the definitions do not support such relations.

# /*
writeLines("\n-------------")
writeLines("Combining datasets, cleaning & imputing for exploration")
# */

#' ### Combine raw datasets
#' The data provided by Kaggle is pre-split into "Training" and "Test" sets,
#' the former possessing the "ground truth" (or real outcome), the latter
#' requiring prediction.
#'
#' In order to obtain the clearest possible picture of the date, as well as
#' clean, impute missing data, and create new features, it is necessary to
#' combine the two sets into one. The two sets will be re-created based on
#' record ID before the modelling phase of the analysis.
#'
#' First a `Survived` column is added to the "Test" set (since it was missing
#' and is required to match the columns in the "Training" set), and then the
#' two combined:
test$Survived <- NA
combi <- rbind(raw, test)

#' ### Inspection
#' First assert the viability of creating a predictor for the response
#' variable by examining the proportions of each level. Prevailing wisdom
#' holds that if any proportion < 15% (0.15) then it might be classifed
#' "rare", in which case it is much more difficult to model.
prop.table(table(combi$Survived))

#' Next use str to obtain a quick overview of the combined dataset dimensions
#' and features (auto-created onRead).
str(combi)

#' Looks like *Name* and *Cabin* should be of type `character`, not `factor`:
combi$Name <- as.character(combi$Name)
combi$Cabin <- as.character(combi$Cabin)

#' Determine missing values:
#' - is.na tests for any missing vals
#' - missmap in Amelia package visualizes this
sum(is.na(combi))

missmap(combi,
  main="Titanic Training Data - Missings Map",
  col=c("yellow", "black"),
  legend=FALSE
)

#' *Age*, *Cabin*, *Fare* and *Embarkation* have missing data points. Impute
#' *Embarkation* data using most common value. The others require the
#' creation of new synthetic features for optimal imputation.
summary(combi$Embarked)
combi$Embarked[which(combi$Embarked == "")] <- "S"

#' Before engineering new features, convert and re-level `numeric` classes to
#' factors, and rename *Survived* => *Fate* (as "Survived" is one of the
#' levels). This aids understanding of confusion matrices, visualizations,
#' and summary output.
combi$Class <- as.factor(combi$Pclass)
levels(combi$Class) <- c("Upper", "Middle", "Lower")
combi$Fate <- as.factor(combi$Survived)
levels(combi$Fate) <- c("Perished", "Survived")

# /*
writeLines("\n-------------")
writeLines("Munging DONE")
# */