#' @title Parametric bootstraps of confidence intervals of model estimates and potentially fitted values for
#' (G)LMMs fitted with lmer or glmmTMB functions.
#' @description Derive Bootstrapped confidence intervals of model estimates and potentially fitted values for
#' (G)LMMs fitted with lmer or glmmTMB functions and using a parametric bootstrap.
#' @param m fitted model object as obtained from \code{lmer}, \code{glmer}, \code{glmer.nb}, or \code{glmmTMB}.
#' @param data data frame comprising all variables needed to fit the model (only \code{boot.glmmtmb}).
#' @param discard.warnings logical (function \code{boot.lmer}); determines whether bootstraps that failed
#' with an error or issued a warning should be discarded (\code{T}; a 'dangerous' option; see datails) or not (\code{F}; default).
#' @param discard.non.conv logical (function \code{boot.glmmtmb}); determines whether bootstraps that failed
#' with an error should be discarded (\code{T}; a 'dangerous' option; see datails) or not (\code{F}; default).
#' @param nboots number of bootstraps to be conducetd (default: 1000).
#' @param para logical; determines whether bootstraps should be parallellized (\code{T}) or not (\code{F};
#' default; see details).
#' @param n.cores number cores to be used when \code{para=T}. Can be one of "all-1" (the default), "all",
#' or an integer.
#' @param resol resolution with which confidence limits of fitted values for the effects of covariates should be
#' determined (default: 1000; see details).
#' @param level confidence level (default: 0.95).
#' @param use, character vector or list of character vectors indicating the names of the predictors for which
#' confidence intervals of fitted values should be obtained. Defaults to \code{NULL} in which case no
#' confidence intervals of fitted values are returned (see details).
#' @param circ.var.name character; name of a potential circular variable present in the model (only relevant
#' when \code{use} is not left at its default).
#' @param circ.var numeric vector with the values of the circular variable as handed over to the model fitting
#' function.
#' @param use.u logical; determines whether bootstraps should be conditional on the particular levels of the
#' random effects present in the data \code{T} or not (\code{F}; default; see \code{\link{bootMer}} for details).
#' @param save.path path in which results of individual bootstraps should be saved (defaults to \code{NULL} in
#' which case results of individual bootstraps aren't saved).
#' @param load.lib logical determining whether the package needed to conduct the bootstrap should be loaded
#' (\code{T}) or not (\code{F}; default).
#' @param lib.loc path from where the package should be loaded (defaults to \code{.libPaths()}; usually one
#' dosn't need to bother about; see details).
#' @param set.all.effects.2.zero don't know what this is doing (just leave it at its default; \code{F}).
#' @details
#'  Both functions are actually wrappers of the functions \code{bootMer{lme4}} and
#' \code{simulate.glmmTMB{glmmTMB}}, respectively, making their use more convenient, allowing to obtain
#' bootstrapped confidence intervals of fitted values, keep track of warnings issued, and avoid boostraps
#' failing with an error.
#'
#' Note that these functions try to fit many models (at least as many as indicated to the argument
#' \code{n.boots}). As a consequence, it can take a while until they finish. For instance, for a complex GLMM
#' with, e.g., binomial, negative binomial, Poisson, or beta error distribution, it can easily take days
#' for the function to complete, even when it runs parallelized on on, say, 16 or 64 cores.
#'
#' Use parallelisation (i.e., \code{para=T}) on dedicated machines, and I suggest to not use it on laptops to avoid
#' over heating. The default for the number cores (\code{n.cores="all-1"}) keeps some capacity for the OS,
#' allowing to easier have a look at what's going on.
#'
#' Excluding bootstraps which issued a warning or failed with an error (\code{discard.warnings=T} or
#' \code{discard.non.conv=T}, respectively) is pretty 'dangerous' since in case this likely happens many models will
#' tried to be fitted and then discarded. Hence, getting, say, 1,000 bootstraps may take ages...
#'
#' When the argument \code{use} is not left at its default, the function will return confidence intervals
#' of fitted values. When a vector is handed over to \code{use} which includes a single covariate and the model doesn't
#' include any factors, the function will return a data frame with one column for each term in the model with all
#' except the intercept and the particular covariate(s) set to zero, as well as columns with the fitted value
#' ("fitted") and its confidence limits ("lwr", "upr"). The number rows will be equal to \code{resol} whereby the
#' covariate will range from its minimum to its maximum with as many values as \code{resol}, equally spaced.
#' When the vector handed over to \code{use} comprises two or more covariates, confidence intervals of fitted
#' values will be determined for each combination of their values (i.e., all will range from their minimum to
#' their maximum with \code{resol} values and the resulting data frame will have \code{resol}^n rows, with n
#' being the numbe of covariates). When the model
#' comprises factors, these will automatically be included in each vector handed over to use. For instance, if a model
#' comprises the factors 'sex' and 'species' and a covariate 'age' and one runs the function with use="sex", then one
#' will get fitted values with confidence intervals for each combination of sex, species, and age.
#'
#' When a list of vectors is handed over to \code{use} then a data frame ass described in the previous para is generated
#' for each element of the list.
#'
#' When the model comprises a circular variable fitted by including its sine and cosine into the model
#' (Stolwijk et al. 1999) and one wants to get confidence intervals of fitted values, then it is important
#' that the vector with the circular variable (as handed over to the model fitting function is handed over to
#' \code{circ.var} and its name (as present in the model to \code{to circ.var.name}.
#'
#' Caution, the function \code{boot.glmmtmb} is somewhat premature. For instance, it likely fails if the fitted
#' model doesn't contain random effects...
#'
#' @return Returns a list with the following objects:
#' \item{ci.estimates}{bootsrapped confidence intervals of model estimates (together with original estimate). In case of
#' the function \code{boot.lmer} this is a date frame, and in case of the function \code{boot.glmmtmb} this
#' is a named list comprising confidence intervals separately for fixed effects (\code{ci.estimates$fe}) and
#' random effects (\code{ci.estimates$re}).}
#' \item{ci.fitted}{confidence intervals of fitted model with regard to what was handed over to \code{use}. When \code{use} was
#' a single vector it will be a single data frame in case of the function \code{boot.lmer} with one column for
#' each term in the model (with all covariates not present in \code{use} set to zero), the fitted value, and
#' its confidence intervals (columns headed "lwr", and "upr"). In case of the function \code{boot.glmmtmb}, it
#' will be three such data frames, one for each of the conditional, the dispersion, and the zero-inflation model
#' (given these were present in the model). In case one handed over a list to \code{use}, \code{ci.fitted}
#' will be a list with one object as described so far for each entry in the list.}
#'
#' \item{warnings}{list with the warnings issued by the models fitted to the individual bootstraps (only
#' present when \code{boot.lmer} was used).}
#'
#' \item{all.boots}{Data frame with model estimates for each individual bootstrap.}
#'
#' @seealso
#' \code{\link[lme4]{bootMer}}, \code{\link[glmmTMB]{simulate.glmmTMB}}, \code{\link[kyotil]{keepWarnings}} (which I borrowed)
#' @references
#' Stolwijk, AM, Straatman H, & Zielhuis GA. 1999. Studying seasonality by using sine and cosine functions in regression analysis. J Epidemiol Community Health, 53:235–238.
#' @examples
#' ##examples for \code{boot.lmer}
#' \donttest{
#' ##minimal examlpe with 10 boostraps for testing:
#' library(lme4)
#' data(sleepstudy)
#' m = lmer(Reaction ~ Days + (Days | Subject), sleepstudy)
#' boot.m=boot.lmer(m=m, nboots=10)
#' boot.m$ci.estimates
#' #obtain confidence intervals of fitted values (low resolution for testing):
#' boot.m=boot.lmer(m=m, nboots=10, use="Days", resol=10)
#' boot.m$ci.fitted
#' }
#' \donttest{
#' ##with factor in model:
#' data(Orthodont, package="nlme")
#' m=lmer(distance ~ age + Sex + (1|Subject), data=Orthodont)
#' boot.m=boot.lmer(m=m, nboots=10, use="age", resol=10)
#' boot.m$ci.fitted
#' #comprises a range of age values for each of females and males
#' boot.m=boot.lmer(m=m, nboots=10, use="Sex", resol=10)
#' boot.m$ci.fitted
#' ##age is set to zero in the data frame for which confidence intervals of fitted values are determined
#'
#' ##with a list handed over to argument use:
#' boot.m=boot.lmer(m=m, nboots=10, use=list("Sex", "age"), resol=10)
#' names(boot.m$ci.fitted)
#' #comprises two data frames; have a look:
#' boot.m$ci.fitted$Sex
#' boot.m$ci.fitted$age
#' }
#'
#' ##examples for boot.glmmtmb
#' \donttest{
#' library(glmmTMB)
#' m = glmmTMB(count ~ mined + (1|site), zi=~mined, family=poisson, data=Salamanders)
#' boot.m=boot.glmmtmb(m=m, nboots=10, resol=10, data=Salamanders, para=T)
#' boot.m$ci.estimates$fe
#' boot.m$ci.estimates$re
#'
#' ##bootstrap fitted values, too:
#' boot.m=boot.glmmtmb(m=m, nboots=10, resol=10, data=Salamanders, use="mined")
#' names(boot.m$ci.fitted)
#' boot.m$ci.fitted$cond
#' boot.m$ci.fitted$zi
#' boot.m$ci.fitted$disp##null because there is no dispersion part
#'
#' ##bootstrap fitted values for combinations of pedictors and zero-inflated part:
#' m = glmmTMB(count ~ spp + mined + DOP + (1|site), zi=~mined, family=poisson, data=Salamanders)
#' boot.m=boot.glmmtmb(m=m, nboots=10, resol=10, data=Salamanders, use=c("mined", "DOP"))
#' boot.m$ci.estimates$fe
#' head(boot.m$ci.fitted$cond)
#' head(boot.m$ci.fitted$zi)
#' boot.m$ci.fitted$disp##null because there is no dispersion part
#'
#' ##with use being a list:
#' boot.m=boot.glmmtmb(m=m, nboots=10, resol=10, data=Salamanders, use=list("mined", "DOP"))
#' names(boot.m$ci.fitted)
#' boot.m$ci.fitted$mined$cond
#' boot.m$ci.fitted$mined$zi
#' }
#'
#' @rdname boot.lmer
#' @export
boot.lmer<-function(m, discard.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=F, lib.loc=.libPaths(), set.all.effects.2.zero=F){
  if(load.lib){library(lme4, lib.loc=lib.loc)}
  n.cores=n.cores[1]
  if(!is.null(use)){
    if(is.list(use)){use.list=use}else{use.list=list(use)}
  }else{
    use.list=NULL
  }
  #keepWarnings<-function(expr){##from package kyotil
  #  localWarnings <- list()
  #  value <- withCallingHandlers(expr,
	#															 warning = function(w) {
	#															   localWarnings[[length(localWarnings)+1]] <<- w
	#																 #invokeRestart(r="muffleWarnings")
	#															 }
  #  )
  #  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, use.u.=use.u){
    ##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:
    if(use.u.){
			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)))
			}))
			names(re.detail)=xnames
		}else{
			xnames=NULL; re.detail=NULL
		}
    #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="MASS::negative.binomial(theta = ", replacement="", fixed=T)
      theta=as.numeric(gsub(x=xx, pattern=")", replacement="", fixed=T))
      #re.detail=c(re.detail, as.numeric(xx))
      #xnames=c(xnames, "theta")
    }else{
			theta=NULL
		}
    ns=c(length(fixef(mres)), length(re.summary), length(re.detail), length(theta))
    names(ns)=c("n.fixef", "n.re.summary", "n.blups", "n.theta")
    return(c(fixef(mres), re.summary, re.detail, theta=theta, ns))
  }
  if(discard.warnings){
    boot.fun<-function(x, m., keepWarnings., use.u., save.path.){
      xdone=F
      while(!xdone){
        i.res=keepWarnings.(bootMer(x=m., FUN=extract.all, nsim=1, use.u=use.u.)$t)
        if(length(unlist(i.res$warnings))==0){
          xdone=T
        }
      }
      est.effects=i.res
      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(list(ests=i.res$value, warns=i.warnings))
    }
  }else{
    boot.fun<-function(y, m., keepWarnings., use.u., save.path.){
      #keepWarnings.(bootMer(x=m., FUN=fixef, nsim=1)$t)
      i.res=keepWarnings.(bootMer(x=m., FUN=extract.all, nsim=1, use.u=use.u.)$t)
      if(length(save.path.)>0){
        est.effects=i.res$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, warns=unlist(i.res$warnings)))
    }
  }
  #browser()
  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, m.=m, keepWarnings.=keepWarnings, use.u.=use.u, save.path.=save.path)
  }else{
    all.res=lapply(X=1:nboots, FUN=boot.fun, m.=m, keepWarnings.=keepWarnings, use.u.=use.u, save.path.=save.path)
  }
  if(!discard.warnings){
    all.warns=lapply(all.res, function(x){
      xxx=unlist(x$warns)
      if(length(xxx)==0){xxx=""}
      return(xxx)
    })
  }else{
    all.warns=NULL
  }
	all.res=lapply(all.res, function(x){x$ests})
  if(!is.null(use.list)){
    #extract fixed effects terms from the model:
    xcall=as.character(m@call)[2]
    model.terms=attr(terms(as.formula(xcall)), "term.labels")
    REs=names(ranef(m))
    model.terms=model.terms[!grepl(x=model.terms, pattern="|", fixed=T)]
    model=paste(model.terms, collapse="+")
    #build model wrt to the fixed effects:
    #exclude interactions and squared terms from model.terms:
    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)]
    #create new data to be used to determine fitted values:
    ii.data=m@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
      if(length(circ.var.name)==1){
        names(new.data)[ncol(new.data)]=circ.var.name
      }
      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("~", 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
      }
      #get CIs for fitted values:
      ci=lapply(all.res, function(x){
        #return(apply(m.mat[names(fixef(m)), , drop=F]*as.vector(x[, names(fixef(m))]), 2, sum))
        return(as.vector(m.mat[, names(fixef(m)), drop=F]%*%as.vector(x[, names(fixef(m))])))
      })
      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("lwr", "upr")
      fv=m.mat[, names(fixef(m))]%*%fixef(m)
      if(class(m)[[1]]!="lmerMod"){
        if(m@resp$family$family=="binomial"){
          ci=exp(ci)/(1+exp(ci))
          fv=exp(fv)/(1+exp(fv))
        }else if(m@resp$family$family=="poisson" | substr(x=m@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
    if(length(use.list)==1){
			result=as.data.frame(result[[1]])
		}else{
			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(m))>1){
    ci.est=data.frame(orig=fixef(m), t(ci.est)[1:length(fixef(m)), ])
  }else{
    ci.est=data.frame(orig=fixef(m), t(t(ci.est)[1:length(fixef(m)), ]))
  }
  return(list(ci.estimates=ci.est, ci.fitted=result, warnings=all.warns, all.boots=all.boots))
}

#' @rdname boot.lmer
#' @export
boot.glmmtmb<-function(m, data, discard.non.conv=F, nboots=1000, para=F, resol=100, level=0.95,
                       use=NULL, circ.var.name=NULL, circ.var=NULL,
                       n.cores=c("all-1", "all"), save.path=NULL, load.lib=T, lib.loc=.libPaths(), set.all.effects.2.zero=F){
  if(!summary(m)$link%in%c("log", "logit", "identity")){
    stop("link functions other than log, logit, or identity aren't supported yet; please contact Roger")
  }
  if(load.lib){library(lme4, lib.loc=lib.loc)}
  if(!is.null(use)){
    if(is.list(use)){use.list=use}else{use.list=list(use)}
  }else{
    use.list=NULL
  }
  print("doesn't account for circular variables in the zero-inflated model")
  print("haven't tested it yet with a cbind response")
  n.cores=n.cores[1]
  #if(is.null(getCall(m)$control)){
  #  contr=glmmTMBControl()
  #}
  ##does the model comprise any random effects?
  has.RE=any(!unlist(lapply(summary(m)$varcor, is.null)))
  extract.BLUPs.from.glmmTB<-function(m){
    to.do=lapply(c("cond", "zi"), function(x){
      if(length(ranef(m)[[x]])>0){
        lapply(ranef(m)[[x]], function(y){
          return(list(
            what=rep(x, prod(dim(as.matrix(y)))),
            blup=unlist(c(as.matrix(y))),
            level=rep(rownames(y), times=ncol(y)),
            Name=rep(colnames(y), each=nrow(y))
          ))
        })
      }else{
        return(list(list(what=NULL, blup=NULL, level=NULL, Name=NULL)))
      }
    })
    xc=sapply(lapply(to.do[[1]], "[[", "what"), length)
    xz=sapply(lapply(to.do[[2]], "[[", "what"), length)
    res=data.frame(
      what=as.vector(unlist(lapply(to.do, function(x){lapply(x, "[[", "what")}))),
      Grp=c(rep(names(xc), times=xc), rep(names(xz), times=xz)),
      Name=as.vector(unlist(lapply(to.do, function(x){lapply(x, "[[", "Name")}))),
      level=as.vector(unlist(lapply(to.do, function(x){lapply(x, "[[", "level")}))),
      blup=as.vector(unlist(lapply(to.do, function(x){lapply(x, "[[", "blup")})))
    )
    res=res[order(res$what, res$Grp, res$Name, res$level), ]
    return(res)
  }
  extract.all<-function(mres){
    if(has.RE){
			##extract random effects model summary:
			m=extract.ranef.glmmTMB(m=mres)
			##extract random effects, BLUPs:
			BLUPs=extract.BLUPs.from.glmmTB(m=mres)
		}else{
			m=NULL
			BLUPs=NULL
		}
    ##dispersion parameter:
    dp=summary(mres)$sigma
    ##fixed effects
    xx=fixef(mres)
    fe=data.frame(
      what=rep(names(xx), times=sapply(xx, length)),
      term=unlist(lapply(xx, names)),
      est=unlist(xx)
    )
    fe=fe[order(fe$what, fe$term), ]
    return(list(fe=fe, sigma=dp, m=m, BLUPs=BLUPs))
  }
  ##prepare for new calls:
  xcall=as.character(m$call)
  names(xcall)=names(m$call)
  xcall=list(cond.form=xcall["formula"], zi.form=xcall["ziformula"], disp.form=xcall["dispformula"], xfam=xcall["family"])
  if(grepl(xcall[["xfam"]], pattern="(", fixed=T)){
    xfam=xcall[["xfam"]]
    xfam=unlist(strsplit(xfam, split="(", fixed=T))
    xfam[2]=gsub(x=xfam[2], pattern=")", replacement="", fixed=T)
    xfam[2]=gsub(x=xfam[2], pattern="link = ", replacement="", fixed=T)
    xfam[2]=gsub(x=xfam[2], pattern="\"", replacement="", fixed=T)
    if(substr(xcall[["xfam"]], start=1, stop=5)!="Gamma"){
      xcall[["xfam"]]=get(xfam[1])(xfam[2])
    }else{
      if(xfam[2]=="log"){
        xcall[["xfam"]]=Gamma(link="log")
      }else if(xfam[2]=="inverse"){
        xcall[["xfam"]]=Gamma(link="inverse")
      }else if(xfam[2]=="identity"){
        xcall[["xfam"]]=Gamma(link="identity")
      }else{
        stop("Error: family not supported")
				}
    }
  }

  #xweights=try(m$frame[, "(weights)"], silent=T)
  #if(class(xweights)[[1]]=="try-error"){
  #  xweights=rep(1, nrow(m$frame))
  #}
  #data$xweights.X.=xweights
  rv.name=gsub(unlist(strsplit(xcall[["cond.form"]], split="~"))[1], pattern=" ", replacement="", fixed=T)
  ##define function doing the bootstrap:
  boot.fun<-function(x, xcall., data., rv.name., m., discard.non.conv., save.path., extract.all.){
    xdone=F
    while(!xdone){
      done2=F
      while(!done2){
        data.[, rv.name.]=simulate(object=m.)[, 1]
        if(xcall[["xfam"]][["family"]]!="beta" |
           (xcall[["xfam"]][["family"]]=="beta" & min(data.[, rv.name.])>0 & max(data.[, rv.name.])<1)){
          done2=T
        }
      }
      i.res=try(update(m., data=data.), silent=T)
      #return(update(m., data=data.))
      #i.res=try(glmmTMB(formula=as.formula(xcall.[["cond.form"]]), ziformula=as.formula(xcall.[["zi.form"]]), dispformula=as.formula(xcall.[["disp.form"]]),
      #              data=data., control=contr., family=xcall[["xfam"]], weights=xweights.X.), silent=T)
      if(class(i.res)[[1]]!="try-error"){
				if(i.res$sdr$pdHess | !discard.non.conv.){
					xdone=T
				}
			}
    }
		if(class(i.res)[[1]]!="try-error"){
			conv=i.res$sdr$pdHess
			i.res=extract.all.(mres=i.res)
			if(length(save.path.)>0){save(file=paste(c(save.path., "/b_", x, ".RData"), collapse=""), list=c("i.res", "conv"))}
			return(list(boot.res=i.res, conv=conv))
		}else{
			return(NULL)
		}
  }
  ##do bootstrap:
  if(para){
    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]
      }
    }
    clusterExport(cl=cl, varlist="extract.ranef.glmmTMB")
    parLapply(cl=cl, 1:length(cl), fun=function(x, .lib.loc=lib.loc){
      library(glmmTMB, lib.loc=.lib.loc)
      return(invisible(""))
    })
    all.res=parLapply(cl=cl, X=1:nboots, fun=boot.fun, m.=m, xcall.=xcall, data.=data, rv.name.=rv.name,
                      discard.non.conv.=discard.non.conv, save.path.=save.path, extract.all.=extract.all)
  }else{
    all.res=lapply(X=1:nboots, FUN=boot.fun, m.=m, xcall.=xcall, data.=data, rv.name.=rv.name,
                   discard.non.conv.=discard.non.conv, save.path.=save.path, extract.all.=extract.all)
  }

  ##extract results:
  all.res=all.res[!sapply(all.res, is.null)]
  ##convergence:
  all.conv=sapply(all.res, "[[", "conv")
  ##sigma:
  all.sigma=sapply(all.res, function(x){x$boot.res$sigma})
  ##estimates, fixef effects:
  all.fe=lapply(all.res, function(x){x$boot.res$fe$est})
  all.fe=matrix(unlist(all.fe), nrow=length(all.fe), byrow=T)
  colnames(all.fe)=apply(all.res[[1]]$boot.res$fe[, c("what", "term")], 1, paste, collapse="@")
  if(has.RE){
		##estimates, random effects:
		all.re=lapply(all.res, function(x){x$boot.res$m$sdcor})
		all.re=matrix(unlist(all.re), nrow=length(all.re), byrow=T)
		colnames(all.re)=apply(all.res[[1]]$boot.res$m[, c("part", "grp", "var1", "var2")], 1, paste, collapse="@")
		##estimates, BLUPs (well, it doesn't make any sense  to consider them):
		all.BLUPs=lapply(all.res, function(x){x$boot.res$BLUPs$blup})
		all.BLUPs=matrix(unlist(all.BLUPs), nrow=length(all.BLUPs), byrow=T)
		colnames(all.BLUPs)=apply(all.res[[1]]$boot.res$BLUPs[, c("what", "Grp", "Name", "level")], 1, paste, collapse="@")
	}else{
		all.re=NULL
		all.BLUPs=NULL
	}
  ##store results:
  all.ind.boots=list(fe=all.fe, re=all.re, sigma=all.sigma, conv=all.conv)
  ##get confidence intervals and merge them with original values:
  ##fixed effects:
  orig=extract.all(m)
  xx=orig$fe
  xx$comb=apply(xx[, c("what", "term")], 1, paste, collapse="@")
  #xx$comb=paste(rownames(xx), xx$comb, sep="@")
  ci=apply(all.fe, 2, quantile, prob=c((1-level)/2, 1-(1-level)/2), na.rm=T)
  #times=unlist(lapply(summary(m)$coefficients, nrow))
  #comb=paste(rep(c("cond", "zi", "disp")[1:length(times)], times=times), unlist(lapply(summary(m)$coefficients, rownames)), sep="@")
  ci=ci[, match(xx$comb, colnames(ci))]
  #xx=xx[match(comb, xx$comb), ]
  ci.fe=data.frame(orig=xx$est, t(ci))
  ##order according to original:
  ci.fe=ci.fe[paste(rep(c("cond", "zi", "disp"), times=unlist(lapply(fixef(m), length))), unlist(lapply(fixef(m), names)), sep="@"), ]
  ##random effects:
  if(has.RE){
		xx=orig$m
		xx$comb=apply(xx[, c("part", "grp", "var1", "var1")], 1, paste, collapse="@")
		ci=apply(all.re, 2, quantile, prob=c((1-level)/2, 1-(1-level)/2), na.rm=T)
		ci.re=data.frame(orig=xx$sdcor, t(ci))
	}else{
		ci.re=NULL
	}
  ##store results:
  ci.estimates=list(fe=ci.fe, re=ci.re)

  if(length(use.list)>0){
    ci.fitted.cond=NULL
    ci.fitted.zi=NULL
    ci.fitted.disp=NULL
    #extract fixed effects terms from the model:
    model.terms=c(attr(terms(as.formula(xcall[["cond.form"]])), "term.labels"),
                  attr(terms(as.formula(xcall[["zi.form"]])), "term.labels"),
                  attr(terms(as.formula(xcall[["disp.form"]])), "term.labels"))
    #exclude random effects:
    model.terms=model.terms[!grepl(x=model.terms, pattern="|", fixed=T)]
    #exclude random effects, interactions and squared terms from model.terms:
    model.terms=model.terms[!grepl(x=model.terms, pattern="I(", fixed=T)]
    model.terms=model.terms[!grepl(x=model.terms, pattern=":", fixed=T)]
    model.terms=unique(model.terms)

    all.fitted=lapply(use.list, function(use){
      #create new data to be used to determine fitted values:
      if(length(use)==0){use=model.terms}
      new.data=vector("list", length(model.terms))
      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
      }
      usel=model.terms%in%use
      #if(length(use)>0)
      for(i in 1:length(model.terms)){
        if(is.factor(data[, model.terms[i]])){
          new.data[[i]]=levels(data[, model.terms[i]])
        }else if(!is.factor(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(data[, model.terms[i]]), to=max(data[, model.terms[i]]), length.out=resol)
        }else  if(!is.factor(data[, model.terms[i]]) & ifelse(length(circ.var.name)==0, T, !grepl(x=model.terms[i], pattern=circ.var.name))){
          new.data[[i]]=mean(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
      #browser()
      if(length(circ.var.name)==1){
        names(new.data)[ncol(new.data)]=circ.var.name
      }
      if(set.all.effects.2.zero){
        for(iterm in setdiff(colnames(new.data), c("(Intercept)", use))){
          new.data[, iterm]=0
        }
      }
      ##prepare model frame for conditional model for prediction:
      model=attr(terms(as.formula(xcall[["cond.form"]])), "term.labels")
      model=model[!grepl(x=model, pattern="|", fixed=T)]
      if(length(model)==0){model="1"}
      cond.m.mat=model.matrix(object=as.formula(paste(c("~", paste(model, collapse="+")), collapse="")), data=new.data)
      if(set.circ.var.to.zero){
        cond.m.mat[,paste(c("sin(", circ.var.name, ")"), collapse="")]=0
        cond.m.mat[,paste(c("cos(", circ.var.name, ")"), collapse="")]=0
      }
      ##get bootstrapped fitted values for the conditional part:
      ests=all.ind.boots$fe[, substr(colnames(all.ind.boots$fe), start=1, stop=5)=="cond@", drop=F]
      est.names=gsub(colnames(ests), pattern="cond@", replacement="")
      ci.cond=lapply(1:nrow(ests), function(x){
        return(cond.m.mat[, est.names, drop=F]%*%as.vector(ests[x, ]))
      })
      ci.cond=matrix(unlist(ci.cond), ncol=length(all.res), byrow=F)
      ci.cond=t(apply(ci.cond, 1, quantile, prob=c((1-level)/2, 1-(1-level)/2), na.rm=T))
      colnames(ci.cond)=c("lower.cl", "upper.cl")
      ##get fitted value for the conditional part:
      ests=ci.estimates$fe
      ests=ests[substr(rownames(ests), start=1, stop=5)=="cond@", , drop=F]
      est.names=gsub(rownames(ests), pattern="cond@", replacement="")
      fv.cond=cond.m.mat[, est.names, drop=F]%*%ests$orig
      if(summary(m)$link=="log"){
        ci.fitted.cond=data.frame(fitted=exp(fv.cond), exp(ci.cond))
      }else if(summary(m)$link=="logit"){
        ci.fitted.cond=data.frame(fitted=plogis(fv.cond), plogis(ci.cond))
      }else if(summary(m)$link=="identity"){
        ci.fitted.cond=data.frame(fitted=fv.cond, ci.cond)
      }
      ci.fitted.cond=data.frame(new.data, ci.fitted.cond)

      ##prepare model frame for ZI model for prediction:
      if(!is.null(summary(m)$coefficients$zi)){
        model=attr(terms(as.formula(xcall[["zi.form"]])), "term.labels")
        model=model[!grepl(x=model, pattern="|", fixed=T)]
        if(length(model)==0){model="1"}
        zi.m.mat=model.matrix(object=as.formula(paste(c("~", paste(model, collapse="+")), collapse="")), data=new.data)
        ##get bootstrapped fitted values for the conditional part:
        ests=all.ind.boots$fe[, substr(colnames(all.ind.boots$fe), start=1, stop=3)=="zi@", drop=F]
        est.names=gsub(colnames(ests), pattern="zi@", replacement="")
        ci.zi=lapply(1:nrow(ests), function(x){
          return(zi.m.mat[, est.names, drop=F]%*%as.vector(ests[x, ]))
        })
        ci.zi=matrix(unlist(ci.zi), ncol=length(all.res), byrow=F)
        ci.zi=t(apply(ci.zi, 1, quantile, prob=c((1-level)/2, 1-(1-level)/2), na.rm=T))
        colnames(ci.zi)=c("lower.cl", "upper.cl")
        ##get fitted value for the conditional part:
        ests=ci.estimates$fe
        ests=ests[substr(rownames(ests), start=1, stop=3)=="zi@", , drop=F]
        est.names=gsub(rownames(ests), pattern="zi@", replacement="")
        fv.zi=zi.m.mat[, est.names, drop=F]%*%ests$orig
        ci.fitted.zi=data.frame(fitted=plogis(fv.zi), plogis(ci.zi))
        #ci.fitted.zi=ci.fitted*(1-ci.fitted.zi)
        ci.fitted.zi=data.frame(new.data, ci.fitted.zi)
      }

      ##prepare model frame for disp model for prediction:
      if(!is.null(summary(m)$coefficients$disp)){
        model=attr(terms(as.formula(xcall[["disp.form"]])), "term.labels")
        model=model[!grepl(x=model, pattern="|", fixed=T)]
        if(length(model)==0){model="1"}
        disp.m.mat=model.matrix(object=as.formula(paste(c("~", paste(model, collapse="+")), collapse="")), data=new.data)
        ##get bootstrapped fitted values for the conditional part:
        ests=all.ind.boots$fe[, substr(colnames(all.ind.boots$fe), start=1, stop=5)=="disp@", drop=F]
        est.names=gsub(colnames(ests), pattern="disp@", replacement="")
        ci.disp=lapply(1:nrow(ests), function(x){
          return(disp.m.mat[, est.names, drop=F]%*%as.vector(ests[x, ]))
        })
        ci.disp=matrix(unlist(ci.disp), ncol=length(all.res), byrow=F)
        ci.disp=t(apply(ci.disp, 1, quantile, prob=c((1-level)/2, 1-(1-level)/2), na.rm=T))
        colnames(ci.disp)=c("lwr", "upr")
        ##get fitted value for the dispersion part:
        ests=ci.estimates$fe
        ests=ests[substr(rownames(ests), start=1, stop=5)=="disp@", , drop=F]
        est.names=gsub(rownames(ests), pattern="disp@", replacement="")
        fv.disp=disp.m.mat[, est.names, drop=F]%*%ests$orig
        ci.fitted.disp=data.frame(fitted=exp(fv.disp), exp(ci.disp))
        #ci.fitted.disp=ci.fitted*(1-ci.fitted.disp)
        ci.fitted.disp=data.frame(new.data, ci.fitted.disp)
      }
      ci.fitted=list(
        cond=ci.fitted.cond,
        zi=ci.fitted.zi,
        disp=ci.fitted.disp
      )
      return(ci.fitted)
    })
    if(length(use.list)>1){
      names(all.fitted)=unlist(lapply(use.list, paste, collapse="@"))
    }else{
      all.fitted=all.fitted[[1]]
    }
  }else{
    all.fitted=NULL
  }
  return(list(ci.estimates=ci.estimates, ci.fitted=all.fitted, all.boots=all.ind.boots))
}


# Copyright Syncfusion Inc. 2001 - 2016. All rights reserved.
# Use of this code is subject to the terms of our license.
# A copy of the current license can be obtained at any time by e-mailing
# licensing@syncfusion.com. Any infringement will be prosecuted under
# applicable laws.

# If you are not familiar with R you can obtain a quick introduction by downloading
# R Succinctly for free from Syncfusion - http://www.syncfusion.com/resources/techportal/ebooks/rsuccinctly
# R Succinctly is also included with this installation and is available here
# Installed Drive :\Program Files (x86)\Syncfusion\Essential Studio\XX.X.X.XX\Infrastructure\EBooks\R_Succintly.pdf OF R Succinctly
# Uncomment below lines to install necessary packages if not installed already
# install.packages("e1071")
# install.packages("pmml")
# install.packages("gmodels")
# install.packages("ROCR")
# install.packages("caret")

# Load below packages
library(e1071)
library(pmml)
library(gmodels)
library(ROCR)
library(caret)

# Here we directly load the audit dataset installed with the "pmml" package.
data(audit,package="pmml")

# rename column names in audit dataset from pmml package
auditOriginal <- setNames(audit, c("ID", "Age", "Employment", "Education", "Marital", "Occupation", "Income", "Sex", "Deductions", "Hours", "Accounts", "Adjustment", "Adjusted"))

# Omit rows with missing values
auditOriginal <- na.omit(auditOriginal)

# Code below demonstrates loading the same dataset from a CSV file shipped with our installer.
# Please check installed samples (Data) location to set actual working directory
# Uncomment below lines and comment out the code to read data from CSV file.
# setwd("C:/actual_data_location")
# audit<- read.csv("Audit.csv")

# Considering integer variable as factor
auditOriginal$Adjusted <- factor(auditOriginal$Adjusted, ordered = FALSE)

# Randomizing data
audit<-auditOriginal[sample(nrow(auditOriginal)),]

# Divide dataset for training and test
trainData <- audit[1:1487, ]
testData  <- audit[1488:1859, ]

# Set predicted field in formula
formula = formula(Adjusted ~ .)

# Create model for training set using naiveBayes
auditTrainingModel = naiveBayes(formula, trainData, threshold = 0)

# Display the predicted results and create cross table to check on accuracy
# Predict "Adjusted" column for test data set
auditTestPrediction <- predict(auditTrainingModel, testData)
# Display predicted values
auditTestPrediction

# Create cross table to check on accuracy.
CrossTable(auditTestPrediction, testData$Adjusted,
           prop.chisq = FALSE, prop.t = FALSE, prop.r = FALSE,
           dnn = c('predicted', 'actual'))

# Predict the Probabilities for test dataset
auditTestProbabilities = predict(auditTrainingModel, newdata = testData, threshold = 0, type = "raw")

# Generate ROC curve and calculate AUC value to predict the accuracy for Audit test dataset
# To create visualizations - ROC curve with "ROCR" package two vectors of data are needed,
# The first vector must contain the class values - Adjusted column and
# The second vector must contain the estimated probability of the positive class(AuditHighriskProbability)
pred <- prediction(labels = testData$Adjusted, predictions = auditTestProbabilities[,2])

# Using the perf performance object, we can visualize the ROC curve with R's plot() function
perf <- performance(pred, measure = "tpr", x.measure = "fpr")

# Plot the ROC curve for the visualization
plot(perf, main = "ROC curve for Audit Test Dataset", col = "blue", lwd = 3)

# To indicate reference line in the ROC plot
abline(a = 0, b = 1, lwd = 2, lty = 2)

# We can use the ROCR package to calculate the AUC(Area under the ROC Curve)
# To do so, we first need to create another performance object and specify measure = "auc", as shown in the following code:
perf.auc <- performance(pred, measure = "auc")

# perf.auc is an object (specifically known as an S4 object) we need to use a special type of notation to access the values stored within.
# S4 objects hold information in positions known as slots
# The str() function can be used to see all slots for an object
str(perf.auc)

# To access the AUC value, which is stored as a list in the y.values slot, we can use the @ notation along with the unlist() function, which simplifies lists to a vector of numeric values
# Below AUC value is under the "outstanding" category
unlist(perf.auc@y.values)

# View Specificity, Sensitivity and Accuracy information using confusionMatrix function from "caret" package
confusionMatrix(auditTestPrediction,testData$Adjusted, positive = "1")

# PMML generation
saveXML(pmml(auditTrainingModel, predictedField = "Adjusted"), "Audit.pmml")

# The code below  is used for evaluation purpose.
# The model is applied for original audit data set and predicted results are saved in "ROuput.csv"
# "ROuput.csv" file used for comparing the R results with PMML Evaluation engine results

# Applying Naive Bayes model to entire dataset and save the results in a CSV file
classes = predict(auditTrainingModel, newdata = auditOriginal, threshold = 0, type = "class")
probabilities = predict(auditTrainingModel, newdata = auditOriginal, threshold = 0, type = "raw")

# Save predicted value in a data frame
writeOutput = function(classes, probabilities, file)
{
	result = NULL
	if(is.null(probabilities))
  	{
		result = data.frame(classes)
		names(result) = c("Adjusted")
	}
  	else
	{
		result = data.frame(classes, probabilities)
		names(result) = c("Predicted_Adjusted", "AuditLowriskProbability", "AuditHighriskProbability")
	}
	write.csv(result, file, quote=F)
}

# Write the results in a CSV file
writeOutput(classes, probabilities, "ROutput.csv")


library("ggplot2")
library("dplyr")

frameworks = c("freer", "monad-classes", "mtl")

benchmarks <- c("exc","cd","cdr","rt",
                "ras", "rbs",
                "ss","sr","sw","se",
                "rs","rr","rw","re",
                "ws","wr","ww","we",
                "es","er","ew","ee")

params <- expand.grid(benchmark = benchmarks, framework = frameworks, degree = 1)

set_degree <- function(params, benchmark, framework, degree) {
  params$degree[params$benchmark == benchmark & params$framework == framework] <- degree
  params
}

params[] <- set_degree(params, "ras", "mtl", 2)
params[] <- set_degree(params, "ras", "monad-classes", 2)
params[] <- set_degree(params, "rbs", "mtl", 2)
params[] <- set_degree(params, "rbs", "monad-classes", 2)
params[] <- set_degree(params, "rr", "freer", 2)
params[] <- set_degree(params, "rw", "freer", 2)
params[] <- set_degree(params, "wr", "freer", 2)
params[] <- set_degree(params, "ww", "mtl", 2)
params[] <- set_degree(params, "ww", "monad-classes", 2)

plots <- data.frame(benchmark = benchmarks, plot = NA)
fits <- subset(params, select = c(benchmark, framework))

results <- sapply(benchmarks, function(bname) {
  bdata <- read.csv(paste(bname, "csv", sep = "."))
  names(bdata)[2] <- "n"

  p <- ggplot() +
      geom_point(data = bdata, mapping = aes(x = n, y = time, col = framework, shape = framework), size = 5, stroke = 1.5) +
      # scale_shape_discrete(solid = F) +
      scale_shape_manual(values = c(4, 3, 1))

  fits <- sapply(frameworks, function(fw) {
    d <- params$degree[params$benchmark == bname & params$framework == fw]
    fit <- lm(time ~ poly(n, d), bdata, subset = framework == fw)

    predicted <- data.frame(n = seq(min(bdata$n), max(bdata$n), length.out = 100), framework = fw)
    predicted$time <- predict(fit, predicted)
    p <<- p + geom_line(data=predicted, aes(x = n, y = time, col = framework), size = 1)

    fit
  }, simplify = FALSE, USE.NAMES = TRUE)

  linear.fits <- sapply(frameworks, function(fw) {
    lm(time ~ n, bdata, subset = framework == fw)
  }, simplify = FALSE, USE.NAMES = TRUE)

  pdf(paste(bname, "pdf", sep = "."))
  print(p)
  dev.off()

  list(benchmark = bname, plot = p, fits = fits, linear.fits = linear.fits)
}, simplify = FALSE, USE.NAMES = TRUE)

results.final <- expand.grid(benchmark = benchmarks, framework = frameworks)

results.final[c("r2", "coeff", "degree")] <- t(mapply(function(benchmark, framework, degree) {
  fit <- results[[benchmark]]$fits[[framework]]
  r2 <- summary(fit)$r.squared
  coeff <- tail(unname(coef(fit)), n = 1)
  c(r2, coeff, degree)
}, params$benchmark, params$framework, params$degree))

results.final <- results.final[order(results.final$benchmark),]

print(results.final)
print(subset(results.final, r2 < 0.99))

# Export CSV
write.table(results.final, "regression.csv", sep = ",", row.names = F)

# R^2 changes from linear to quadratic
r2.delta <- expand.grid(benchmark = benchmarks, framework = frameworks)
r2.delta[c("linear", "quadr", "delta")] <- t(mapply(function(benchmark, framework) {
  linear <- summary(results[[benchmark]]$linear.fits[[framework]])$r.squared
  quadr <- summary(results[[benchmark]]$fits[[framework]])$r.squared
  delta <- quadr - linear
  c(linear, quadr, delta)
}, r2.delta$benchmark, r2.delta$framework))

print(filter(r2.delta, delta > 0.0001))


# Use Andres bigWig to make a metaplot!
# bedfile: regions we want to get the metaplot around
# bw files: plus and minus signal files (e.g. chipseq, groseq, etc.)
#
# note: here we are doing appropriate normalisation using a spikein (the denominators)
get_rd<-function(datatype,datatime){
    if (datatype=="FP"){
        rds<-list("2min"=35290786/3528924,"5min"=37460495/3740931,"12.5min"=38534246/4854250,"25min"=33348710/5599230,"50min"=29422671/4845825)
    } else if(datatype=="TRP"){
        rds<-list("12.5min"=14299837/696930,"25min"=8798933/805210,"50min"=4463951/558215)
    } else if(datatype=="controls"){
        rds<-list("untreated"=43409559/4341312,"DMSO"=18091023/613884)
    } else if(datatype=="ChIPseq"){
        rds<-list("H3K4me1"=1,"H3K4me3"=1,"H3K27ac"=1)
    }else{
        print("what crazy datatype did you give me?")
        print(datatype)
        quit("no")
    }
    cat(paste("Read depth for",datatype,"and",datatime,"is",rds[datatime],"\n"))
    return(rds[datatime])
}

library(bigWig)
library(ggplot2)
library(grid)
mytheme<-theme(plot.margin=unit(c(2,2,2,2),"cm"),axis.title.x=element_text(vjust=-0.2),axis.title.y=element_text(angle=90,vjust=0.2),plot.title=element_text(size=15,vjust=1.4))+theme_bw()
bw_path<-'/Users/stephanie/ll/data/'

# Parse the input!
args<-commandArgs(TRUE)
bedfilepath<-args[1]

datatype<-args[2]
if(datatype=="ChIPseq"){
    bothstrands<-FALSE
} else{
    bothstrands<-TRUE
}
datatime<-args[3]
read_depth<-as.numeric(get_rd(datatype,datatime))

titleinfo<-args[4]
filename<-paste0(datatype,"_",datatime,"_",titleinfo)

if (file.exists(paste0(filename,".txt"))){
    cat("make_metaplot.r: Metadata already exists! Loading from there. :)\n")
    dl<-read.table(paste0(filename,".txt"),header=T)
} else{
    cat("make_metaplot.r: No metadata found! Creating...\n")
    bw_plus<-paste0(bw_path,datatype,'/V6.5_',datatime,ifelse(datatype=="controls","",datatype),'_Plus.bw')
    bw_minus<-paste0(bw_path,datatype,'/V6.5_',datatime,ifelse(datatype=="controls","",datatype),'_Minus.bw')

    # Constants

    hw<-2000
    stepp<-1

    # Load the data!
    plus<-load.bigWig(bw_plus)
    minus<-load.bigWig(bw_minus)
    bedfile<-read.table(bedfilepath)

    # in the event that bedfile has no strand information, we should be ignoring the second bw argument in either of these...
    cat("make_metaplot.r: plus strand!\n")
    result_plus<-meta.subsample(bedfile,plus,minus,halfWindow=hw,step=stepp)
    r_p<-meta.normalize(result_plus,1/read_depth)
    cat("make_metaplot.r: minus strand!\n")
    result_minus<-meta.subsample(bedfile,minus,plus,halfWindow=hw,step=stepp)
    r_m<-meta.normalize(result_minus,1/read_depth)

    # prepare for plotting
    p<-colMeans(r_p[[1]])
    m<-(-1)*colMeans(r_m[[1]])
    col<-rep(c(TRUE,FALSE),each=length(p))
    lv<-c(p,m)
    uq_p<-rep(r_p[[2]],2)
    uq_m<-rep((-1)*r_m[[2]],2)
    lq_p<-rep(r_p[[3]],2)
    lq_m<-rep((-1)*r_m[[3]],2)
    d<-rep(seq(-length(p)/2,length(p)/2-1))
    dl<-data.frame(d,lv,col,uq_p,uq_m,lq_p,lq_m)
    write.table(dl,row.names=F,col.names=T,quote=F,file=paste0(filename,".txt"))
}

cat("make_metaplot.r: data constructed! Ready to plot.\n")
ggplot(dl,aes(x=d,y=lv,colour=col))+geom_point(cex=0.5,show_guide=FALSE)+mytheme+xlab("Distance to centre (bp)")+ylab("Average normalised GRO-seq signal")+ggtitle(paste0("Metagene plot (",datatype,", ",datatime,", ",titleinfo,")"))+scale_colour_manual(values=c("blue","red"))+geom_ribbon(aes(ymin=lq_p,ymax=uq_p),alpha=0.5,fill="red",colour=NA)+geom_ribbon(aes(ymin=lq_m,ymax=uq_m),alpha=0.5,fill="blue",colour=NA)+geom_abline(intercept=0,slope=0,linetype="dashed")+geom_abline(intercept=0,slope=1,linetype="dashed")+ylim(-0.004,0.007)
cat(paste0("Saving to ",filename,".pdf"),"\n")
ggsave(paste0(filename,".pdf"))


readacmed=function(){

# R Program to read in HIPPO, ORCAS, and ATom MED merge files, massage time variables, add a strat flag, subset, and write to RData object for use by aircraft_filter_mspo_med.r

library('ncdf4')

# specify aircraft data file names
localdatadir='local-data-files'
hippomergefile=paste(localdatadir,'/aircraft-merge-products/HIPPO_medusa_flasks_merge_insitu_20121129.tbl',sep='') # this is the official HIPPO merge product
atommergedir=paste(localdatadir,'/aircraft-merge-products',sep='') # these are version 2.0 (21-08-26)
atommergefiles=c('MER-MED_DC8_ATom-1.nc','MER-MED_DC8_ATom-2.nc','MER-MED_DC8_ATom-3.nc','MER-MED_DC8_ATom-4.nc')  # these files have problems (see below)
orcasmergefile=paste(localdatadir,'/aircraft-merge-products/ORCASall.mergeMED.tbl',sep='') # original release version

# set strat flag cutoffs for use below based upon Jin et al., 2021 (https://doi.org/10.5194/acp-21-217-2021)
stratcoh2o=50
stratcoo3=150
stratcon2o=319

# read in global N2O for detrending aircraft N2O
glbn2ofile=url('ftp://aftp.cmdl.noaa.gov/products/trends/n2o/n2o_annmean_gl.txt')
hlines=61
glbn2o=read.table(glbn2ofile,skip=hlines,header=F,stringsAsFactors=F)
colnames(glbn2o)=c('year','n2o','unc')

# for HIPPO, need to interpolate prof variable from 10-sec merge - load from read_aircraft_10s.r output before reading PFP data below
if(file.exists('HIPPO_10s.RData')){
      load('HIPPO_10s.RData')
} else {
        source('read_aircraft10s.r')
        readac10s()
}
hippomerge10s=hippomerge # 'hippomerge' reused below
hippo10sdt=ISOdatetime(hippomerge$year,hippomerge$mon,hippomerge$day,hippomerge$hour,hippomerge$min,hippomerge$sec,tz='UTC')

## read in HIPPO file, calc strat flag, subset, and output
print('Reading HIPPO file')

# read and add time variables
hippomerge=read.table(hippomergefile,header=T)
hippodt=strptime(paste(hippomerge[,"Year"],hippomerge[,"DOY"]),format='%Y %j',tz='UTC')+hippomerge[,"UTC"] # DOY is day of year of takeoff; UTC is seconds since midnight on day of takeoff
hippomerge$Month=as.POSIXlt(hippodt)$mon+1
hippomerge$Day=as.POSIXlt(hippodt)$mday
hippomerge$Hour=as.POSIXlt(hippodt)$hour
hippomerge$Min=as.POSIXlt(hippodt)$min
hippomerge$Sec=as.POSIXlt(hippodt)$sec

# filter in situ records for overlap
hippomerge$CO2_QCLS[hippomerge$wt.qcls<0.5]=NA
hippomerge$CO2_AO2[hippomerge$wt.ao2<0.5]=NA
hippomerge$CO2_OMS[hippomerge$wt.oms<0.5]=NA

# interpolate prof from 10 sec file
hippomerge$prof=approx(as.POSIXct(hippo10sdt),hippomerge10s$prof,as.POSIXct(hippodt),method='constant',f=0)$y

# add strat flag
hippomerge$strat=rep(0,nrow(hippomerge)) # 0 means trop
h2oref=hippomerge$H2Oppmv_vxl; h2oref[is.na(h2oref)]=hippomerge$H2O_UWV[is.na(h2oref)]
hippomerge$h2oref=h2oref # for output
h2oref[is.na(h2oref)]=0 # if H2O missing treat as if potentially strat
n2oref=hippomerge$N2O_QCLS
n2oref=n2oref-(approx(glbn2o$year+0.5,glbn2o$n2o,hippomerge$Year+hippomerge$DOY/365)$y-glbn2o$n2o[glbn2o$year==2009])
hippomerge$n2oref=n2oref # for output
n2oref[is.na(n2oref)]=400 # if N2O missing do not use for filter
o3ref=hippomerge$O3_ppb; o3ref[is.na(o3ref)]=hippomerge$O3_UO3[is.na(o3ref)]
hippomerge$o3ref=o3ref # for output
o3ref[is.na(o3ref)]=0 # if O3 missing do not use for filter
hippomerge$strat[h2oref<stratcoh2o&(o3ref>stratcoo3|n2oref<stratcon2o|(o3ref==0&n2oref==400))]=1 # if either o3 or n2o criteria are met, or if both are missing, consider strat
hippomerge$strat[h2oref==0&o3ref==0&n2oref==400&hippomerge$GGALT<8000]=0 # if all 3 missing assume < 8 km is trop

# select columns and save
colsel=c('Year','Month','Day','Hour','Min','Sec','H.no','flt','prof','GGLAT','GGLON','GGALT','PSXC','THETA','CO2_MED','CO2_QCLS','CO2_OMS','CO2_AO2','strat','h2oref','n2oref','o3ref')
hippomerge=hippomerge[,is.element(colnames(hippomerge),colsel)]
hippomerge=hippomerge[,match(colsel,names(hippomerge))] # reorder
names(hippomerge)=c('year','mon','day','hour','min','sec','camp','flt','prof','lat','lon','alt','pressure','theta','co2','co2qcls','co2oms','co2ao2','strat','h2oref','n2oref','o3ref') ## 'co2' = CO2_MED
save('hippomerge',file='HIPPO_MED.RData')

## read in ORCAS file, calc strat flag, subset, and output
print('Reading ORCAS file')

# read and add time variables
orcasmerge=read.table(orcasmergefile,header=T)
orcasdt=strptime(paste(orcasmerge[,"Year"],orcasmerge[,"DOY"]),format='%Y %j',tz='UTC')+orcasmerge[,"UTC"] # DOY is day of year of takeoff; UTC is seconds since midnight on day of takeoff
orcasmerge$Month=as.POSIXlt(orcasdt)$mon+1
orcasmerge$Day=as.POSIXlt(orcasdt)$mday
orcasmerge$Hour=as.POSIXlt(orcasdt)$hour
orcasmerge$Min=as.POSIXlt(orcasdt)$min
orcasmerge$Sec=as.POSIXlt(orcasdt)$sec

# filter in situ records for overlap ### add for HIPPO and ATom?
orcasmerge$CO2_NOAA[orcasmerge$wt.CO2_NOAA<0.5]=NA
orcasmerge$CO2_QCLS[orcasmerge$wt.CO2_QCLS<0.5]=NA
orcasmerge$CO2_AO2[orcasmerge$wt.CO2_AO2<0.5]=NA
orcasmerge$CO2.X[orcasmerge$wt.CO2.X<0.5]=NA

# add strat flag
orcasmerge$strat=rep(0,nrow(orcasmerge)) # 0 means trop
h2oref=orcasmerge$VMR_VXL; h2oref[is.na(h2oref)]=orcasmerge$H2O_NOAA[is.na(h2oref)]
orcasmerge$h2oref=h2oref # for output
h2oref[is.na(h2oref)]=0 # if H2O missing treat as if potentially strat
n2oref=orcasmerge$N2O_QCLS
n2oref=n2oref-(approx(glbn2o$year+0.5,glbn2o$n2o,orcasmerge$Year+orcasmerge$DOY/365)$y-glbn2o$n2o[glbn2o$year==2009])
orcasmerge$n2oref=n2oref # for output
n2oref[is.na(n2oref)]=400 # if N2O missing do not use for filter
orcasmerge$strat[h2oref<stratcoh2o&(n2oref<stratcon2o|n2oref==400)]=1 # no O3, if n2o criteria is met or missing, consider strat
orcasmerge$strat[h2oref==0&n2oref==400&orcasmerge$G_ALT<8000]=0 # if both missing assume < 8 km is trop

# select columns and save
colsel=c('Year','Month','Day','Hour','Min','Sec','flt','n.prof','GGLAT','GGLON','GGALT','PSXC','THETA','CO2_MED','CO2.X','CO2_QCLS','CO2_NOAA','CO2_AO2','strat','h2oref','n2oref')
orcasmerge=orcasmerge[,is.element(colnames(orcasmerge),colsel)]
orcasmerge=orcasmerge[,match(colsel,names(orcasmerge))] # reorder
names(orcasmerge)=c('year','mon','day','hour','min','sec','flt','prof','lat','lon','alt','pressure','theta','co2','co2x','co2qcls','co2noaa','co2ao2','strat','h2oref','n2oref') ## 'co2' = CO2_MED
save('orcasmerge',file='ORCAS_MED.RData')

## read in ATom files, calc strat flag, subset, and output
print('Reading ATom files')

# read and add time variables
atomvar=c('time','Flight_Date','DLH-H2O/H2O_ppmv','UCATS-H2O/H2O_UWV','QCLS-CH4-CO-N2O/N2O_QCLS','NOyO3-O3/O3_CL','UCATS-O3/O3_UO3','MMS/G_ALT','RF','prof.no','MMS/P','MMS/POT','MMS/G_LAT','MMS/G_LONG','MMS/G_ALT','MEDUSA/CO2_MED','NOAA-Picarro/CO2_NOAA','QCLS-CO2/CO2_QCLS','AO2/CO2_AO2','NOAA-Picarro/CH4_NOAA','QCLS-CH4-CO-N2O/CH4_QCLS')
atommerge=NULL
for(i in c(1:4)){
	atomnc=nc_open(paste(atommergedir,'/',atommergefiles[i],sep=''))
       	count=length(ncvar_get(atomnc,'time'))
	campdata=NULL
	for(var in atomvar){
		if(i==1&var=='UCATS-H2O/H2O_UWV'){ # no UCATS H2O on ATom-1
			campdata=cbind(campdata,rep(NA,count))
		} else {
			campdata=cbind(campdata,ncvar_get(atomnc,var))
		}
	}
	campdata=cbind(campdata,rep(i,count)) # A.no
       	nc_close(atomnc)
	atommerge=rbind(atommerge,campdata)
}
atommerge=data.frame(atommerge,stringsAsFactors=F)
names(atommerge)=c(gsub('.*/','',atomvar),'A.no')
atommerge$YYYYMMDD=atommerge$Flight_Date
atomdt=as.POSIXlt(ISOdatetime(2016,1,1,0,0,0,tz='UTC')+atommerge$time,tz='UTC')
atommerge$Year=atomdt$year+1900
atommerge$Month=as.POSIXlt(atomdt)$mon+1
atommerge$Day=as.POSIXlt(atomdt)$mday
atommerge$Hour=as.POSIXlt(atomdt)$hour
atommerge$Min=as.POSIXlt(atomdt)$min
atommerge$Sec=as.POSIXlt(atomdt)$sec

# filter in situ records for overlap
atommerge$CO2_NOAA[atommerge$wt.CO2_NOAA<0.5]=NA
atommerge$CO2_QCLS[atommerge$wt.CO2_QCLS<0.5]=NA
atommerge$CO2_AO2[atommerge$wt.CO2_AO2<0.5]=NA

# add strat flag
atommerge$strat=rep(0,nrow(atommerge)) # 0 means trop
h2oref=atommerge$H2O_ppmv; h2oref[is.na(h2oref)]=atommerge$H2O_UWV[is.na(h2oref)]
atommerge$h2oref=h2oref # for output
h2oref[is.na(h2oref)]=0 # if H2O missing treat as if potentially strat
n2oref=atommerge$N2O_QCLS
n2oref=n2oref-(approx(glbn2o$year+0.5,glbn2o$n2o,atommerge$Year+atomdt$yday/365)$y-glbn2o$n2o[glbn2o$year==2009])
atommerge$n2oref=n2oref # for outptut
n2oref[is.na(n2oref)]=400 # if N2O missing do not use for filter
o3ref=atommerge$O3_CL; o3ref[is.na(o3ref)]=atommerge$O3_UO3[is.na(o3ref)]
atommerge$o3ref=o3ref
o3ref[is.na(o3ref)]=0 # if O3 missing do not use for filter
atommerge$strat[h2oref<stratcoh2o&(o3ref>stratcoo3|n2oref<stratcon2o|(o3ref==0&n2oref==400))]=1 # if either o3 or n2o criteria are met, or if both are missing, consider strat
atommerge$strat[h2oref==0&o3ref==0&n2oref==400&atommerge$G_ALT<8000]=0 # if all 3 missing assume < 8 km is trop

# select column and save
colsel=c('Year','Month','Day','Hour','Min','Sec','A.no','RF','prof.no','G_LAT','G_LONG','G_ALT','P','POT','CO2_MED','CO2_NOAA','CO2_QCLS','CO2_AO2','CH4_NOAA','CH4_QCLS','strat','h2oref','n2oref','o3ref')
atommerge=atommerge[,is.element(colnames(atommerge),colsel)]
atommerge=atommerge[,match(colsel,names(atommerge))] # reorder
names(atommerge)=c('year','mon','day','hour','min','sec','camp','flt','prof','lat','lon','alt','pressure','theta','co2','co2noaa','co2qcls','co2ao2','ch4noaa','ch4qcls','strat','h2oref','n2oref','o3ref') ## 'co2' = CO2_MED
save('atommerge',file='ATom_MED.RData')

} # end of readacmed function


setwd("P:/2019 0970 151 000/User Data/Faraz-Export IDAVE folders")
library(tidyverse)

df <- read.csv("./datasets/New/NACRASCIHI_2_dupRemoved.csv")

tabna <- function(x){table(x, useNA = "ifany")}

df<- df %>% select(ID, days_to_lefteddate,triage, female_flag, btany, clidecunitflag,
cacsanetech, cacsit1, cacsitcnt1, cacsitcnt, cacspartition, glscoma,
age_group, rural, dependency_q_da, deprivation_q_da, ethniccon_q_da,
instability_q_da, incquint, prvserv1, admambul, alc_status )

##Not added above are the ICD10 codes and other mutations of them
##Inst type if more information is found should be added
##complaint and consultserv
##ANY TIME BASED variable is not added
str(df)
df$alc_status <- factor(df$alc_status)
df$female_flag <- as.factor(df$female_flag)

df[df$triage == 9, "triage"] <- NA
df$triage <- factor(df$triage)

df$btany[df$btany == ""] <- NA
df$btany <- factor(df$btany)

df$cacsanetech <- factor(df$cacsanetech, levels = c(8, 1, 2, 3, 4))

df$cacsanetech_bin <- ifelse(df$cacsanetech == 8, 0,1) #Anaestethic were used
df$cacsanetech_gen <- ifelse(df$cacsanetech == 1, 1, 0)
df$cacsanetech_oth <- ifelse(df$cacsanetech == 2, 1, 0)
df$cacsanetech_unm <- ifelse(df$cacsanetech == 3, 1, 0)
df$cacsanetech_lcl <- ifelse(df$cacsanetech == 4, 1, 0)

##Technology code
df$cacsit1_grp[df$cacsit1 %in% c(1:5)] <- "Cat_scan"
df$cacsit1_grp[df$cacsit1 == 6] <- "EEG"
df$cacsit1_grp[df$cacsit1 %in% c(7,20,21)] <- "Xray"
df$cacsit1_grp[df$cacsit1 == 8] <- "Mammography"
df$cacsit1_grp[df$cacsit1 %in% c(9:11)] <- "MRI"
df$cacsit1_grp[df$cacsit1 %in% c(12:15)] <- "Nuclear"
df$cacsit1_grp[df$cacsit1 == 16] <- "Stress_test"
df$cacsit1_grp[df$cacsit1 %in% c(17:19)] <- "Ultrasound"

df %>% group_by(cacsit1_grp) %>% summarise( n= n(),
perc = round(n/nrow(df) * 100,digits=2),
alc_perc_grp = mean(as.numeric(alc_status)) * 100) %>%
arrange(desc(alc_perc_grp))

##Based on above results, EEG, Mammo and Stress_test are combind together
##and rest will have their own title

df$cacsit1_grp[df$cacsitcnt == 0] <- "Notapp"
#Grouping some of the least populated categ.
df$cacsit1_grp[df$cacsit1_grp %in% c("EEG",
									 "Mammography",
									 "Stress_test")] <- "Others"
#factor it here!
df$cacsit1_grp <- factor(df$cacsit1_grp)
df$cacsit1_grp <- relevel(df$cacsit1_grp, "Notapp")
tabna(df$cacsit1_grp)

##
df$cacsitcnt1[df$cacsit1_grp == "Notapp"] <- "Notapp"
df$cacsitcnt1 <- factor(df$cacsitcnt1)
df$cacsitcnt1 <- relevel(df$cacsitcnt1, "Notapp")
levels(df$cacsitcnt1) <- c( "Notapp", "Just1","2orMore" )

##cacsitcnt is numerical

##
tabna(df$cacspartition)
df$cacspartition[df$cacspartition == ""] <- NA
df$cacspartition <- factor(df$cacspartition, levels = c("A", "D", "I"))

## Glascow Coma Scale ##
df$glscoma[df$glscoma %in% c(3:8)] <- "Severe"
df$glscoma[df$glscoma %in% c(9:13)] <- "Moderate"
df$glscoma[df$glscoma %in% c(14,15)] <- "Mild"
df$glscoma[df$glscoma %in% c(99)] <- NA
df$glscoma[df$glscoma %>% is.na()] <- "Notapp"
df$glscoma <- as.factor(df$glscoma)
tabna(df$glscoma)
df$glscoma <- relevel(df$glscoma, "Notapp")##changing order to chnage base of odds ratio in LR

df$glscoma_bin <- as.character(df$glscoma)
df$glscoma_bin[! df$glscoma == "Notapp" ] <- "Y"
tabna(df$glscoma_bin)
df$glscoma_bin   <- factor(df$glscoma_bin )

df$glscoma_grp <- as.character(df$glscoma)
df$glscoma_grp[ df$glscoma %in% c("Moderate", "Mild") ] <- "LessSevere"
df$glscoma_grp   <- factor(df$glscoma_grp )
df$glscoma_grp   <- relevel(df$glscoma_grp, "Notapp" )

## age_group, to be determined
df$age_group <- factor(df$age_group, levels = c(levels(df$age_group), "102"))
df[which(df$age_group == "102-110"), "age_group"] <- "102"
df$age_group <- as.numeric(as.character(df$age_group))

#Grouped based on literature or other...
df[which(df$age_group %in% c(65:67)), "age_grp"] <- 1
df[which(df$age_group %in% c(68:73)), "age_grp"] <- 2
df[which(df$age_group %in% c(74:80)), "age_grp"] <- 3
df[which(df$age_group >= 81), "age_grp"] <- 4
df$age_grp <- factor(df$age_grp)
##
df$rural[df$rural == ""]<- NA
df$rural <- factor(df$rural)
df$dependency_q_da <- as.factor(df$dependency_q_da)
df$deprivation_q_da <- as.factor(df$deprivation_q_da)
df$ethniccon_q_da <- as.factor(df$ethniccon_q_da)
df$instability_q_da <- as.factor(df$instability_q_da)
df$incquint <- as.factor(df$incquint)

##ambulance
levels(df$admambul)<- c(levels(df$admambul), "Y")
df[df$admambul %in% c("G", "C", "A"), "admambul"] <- "Y"
df$admambul %>% tabna()
df$admambul <- factor(df$admambul)

# saveRDS(df, "main_features_cln_oldR.rds")

###########Inspect
library(inspectdf)
df %>% inspect_na %>% print(n=30)
df %>% inspect_na %>% show_plot()

#####Correlation

library(corrplot)
dfx <- df %>% select(-alc_status, -ID, -days_to_lefteddate, -prvserv1)
#couldnt be done for factors aka categorical variables
corrplot(dfx, method="circle")

############Select and export
saveRDS(df, "main_features_cln.rds")
df_sel1 <- df %>% select(ID, days_to_lefteddate,
 age_grp, female_flag, rural, dependency_q_da:instability_q_da, incquint, alc_status)

#####TRAINNG MODEL
library(h2o)
h2o.init()

df_sel1 <- df_sel1 %>% drop_na()

df.hex <- as.h2o(df_sel1)

df.split <- h2o.splitFrame(df.hex, ratios = c(0.7), seed = 1234)
train <- df.split[[1]]
test <- df.split[[2]]

pred <- names(df_sel1)[3:10]
target <- c("alc_status")

df.hex_rf <- h2o.randomForest(
training_frame = train,
validation_frame = test,
x = pred,
y = target,
model_id = "rf_demog",
ntrees = 500,
# nfolds = 10,
# fold_assignment = "Stratified",
score_each_iteration = T)

h2o.performance(df.hex_rf)
h2o.performance(df.hex_rf, newdata = test)
h2o.saveModel(df.hex_rf, "./Models/", force=TRUE)

####Adding more features
df_sel <- df %>% select(ID, days_to_lefteddate,
 age_grp, female_flag, rural, dependency_q_da:instability_q_da, incquint,
 triage, btany, clidecunitflag, admambul,alc_status)

df_sel <- df_sel %>% drop_na()

df.hex <- as.h2o(df_sel)

df.split <- h2o.splitFrame(df.hex, ratios = c(0.7), seed = 1234)
train <- df.split[[1]]
test <- df.split[[2]]

pred <- names(df_sel)[3:14]
target <- c("alc_status")

df.hex_rf <- h2o.randomForest(
training_frame = train,
validation_frame = test,
x = pred,
y = target,
model_id = "rf_demog_triage",
ntrees = 500,
# nfolds = 10,
# fold_assignment = "Stratified",
score_each_iteration = T)

h2o.performance(df.hex_rf)
h2o.performance(df.hex_rf, newdata = test)

h2o.saveModel(df.hex_rf, "./Models/", force=TRUE)
#h2o.loadModel("P:\\2019 0970 151 000\\User Data\\Faraz-Export IDAVE folders\\Models\\rf_demog_triage")


source("lib/libraries.r", encoding="UTF-8")

toplogredni_p <- read_csv("podatki/toplogredni.csv",locale=locale(encoding="Windows-1250"), na = c("...","-"))
toplogredni_p[is.na(toplogredni_p)] <- 0

dejavnosti1 <- as.vector(toplogredni_p$`DEJAVNOST`)

toplogredni_po_dejavnosti <- toplogredni_p %>% slice(grep("^[A-Z] ", dejavnosti1))

dejavnosti <- dejavnosti1[grep("^[A-Z] ", dejavnosti1)]

izpust_co2 <- toplogredni_po_dejavnosti %>% select(1,seq(2, 33, 4))
izpust_n2o <- toplogredni_po_dejavnosti %>% select(1,seq(3, 33, 4))
izpust_ch4 <- toplogredni_po_dejavnosti %>% select(1,seq(4, 33, 4))
izpust_sf6 <- toplogredni_po_dejavnosti %>% select(1,seq(5, 33, 4))

izpust_co2[,-1] <- izpust_co2[,-1] * 1000

izpust_co2 <- izpust_co2 %>% rename('2010 CO2 (Mg)'= '2010 CO2 (Gg)',
                                    '2011 CO2 (Mg)'= '2011 CO2 (Gg)',
                                    '2012 CO2 (Mg)'= '2012 CO2 (Gg)',
                                    '2013 CO2 (Mg)'= '2013 CO2 (Gg)',
                                    '2014 CO2 (Mg)'= '2014 CO2 (Gg)',
                                    '2015 CO2 (Mg)'= '2015 CO2 (Gg)',
                                    '2016 CO2 (Mg)'= '2016 CO2 (Gg)',
                                    '2017 CO2 (Mg)'= '2017 CO2 (Gg)')

test <- gather(izpust_co2, 'leto', 'izpust', 2:9)
test$leto <- gsub('CO2\\s.Mg.', ' ', test$leto)

skupni_izpust <- izpust_ch4[-1] + izpust_co2[-1] + izpust_n2o[-1] + izpust_sf6[-1]

colnames(skupni_izpust) <- gsub('CO2', 'Skupno',colnames(izpust_co2[-1]))

skupni_izpust <- skupni_izpust %>% mutate('DEJAVNOSTI'=dejavnosti1[grep("^[A-Z] ", dejavnosti1)])
skupni_izpust <- skupni_izpust[c(9,1,2,3,4,5,6,7,8)]
#as.matrix(skupni_izpust)
#skupni_izpust <- as.data.frame(t(as.matrix(skupni_izpust)))
#colnames(skupni_izpust) <- dejavnosti1[grep("^[A-Z] ", dejavnosti1)]
#skupni_izpust <-skupni_izpust[-1,]
#rownames(skupni_izpust) <- c (1:8)

izpusti <- data.frame(rep(2010,21),dejavnosti,as.vector(skupni_izpust[,2]))
izpusti[22:42,] <- c(rep(2011,21),dejavnosti,as.vector(skupni_izpust[,3]))
izpusti[43:63,] <- c(rep(2012,21),dejavnosti,as.vector(skupni_izpust[,4]))
izpusti[64:84,] <- c(rep(2013,21),dejavnosti,as.vector(skupni_izpust[,5]))
izpusti[85:105,] <- c(rep(2014,21),dejavnosti,as.vector(skupni_izpust[,6]))
izpusti[106:126,] <- c(rep(2015,21),dejavnosti,as.vector(skupni_izpust[,7]))
izpusti[127:147,] <- c(rep(2016,21),dejavnosti,as.vector(skupni_izpust[,8]))
izpusti[148:168,] <- c(rep(2017,21),dejavnosti,as.vector(skupni_izpust[,9]))

colnames(izpusti) <- c('leto', 'dejavnost', 'izpust topogrednih plinov (Mg)')

okoljske_investicije <- read_csv('podatki/okoljske_invest.csv',locale=locale(encoding="Windows-1250"), na=c("z","-"))

okoljske_investicije <- okoljske_investicije %>% rename( '2010,\n (mio EUR)'= `2010 Namen - SKUPAJ`,
                                                        '2011,\n (mio EUR)'= `2011 Namen - SKUPAJ`,
                                                        '2012,\n (mio EUR)'= `2012 Namen - SKUPAJ`,
                                                        '2013,\n (mio EUR)'= `2013 Namen - SKUPAJ`,
                                                        '2014,\n (mio EUR)'= `2014 Namen - SKUPAJ`,
                                                        '2015,\n (mio EUR)'= `2015 Namen - SKUPAJ`,
                                                        '2016,\n (mio EUR)'= `2016 Namen - SKUPAJ`,
                                                        '2017,\n (mio EUR)'= `2017 Namen - SKUPAJ`)

okoljske_investicije[,-1] <- okoljske_investicije[,-1] / 1000

dejavnosti2 <- as.vector(okoljske_investicije$`SKD DEJAVNOST`)

okoljske_investicije_po_dejavnosti <- okoljske_investicije %>% slice(grep("^[A-Z] ", dejavnosti2))

okoljske_investicije_po_dejavnosti[20,] <- c("T Dejavnost gospodinjstev z zaposlenim hišnim osebjem; proizvodnja za lastno rabo
                                            ",NA,NA,NA,NA,NA,NA,NA,NA)
okoljske_investicije_po_dejavnosti[21,] <- c('U Dejavnost eksteritorialnih organizacij in teles'
                                             ,NA,NA,NA,NA,NA,NA,NA,NA)

okoljski_davki <- read_csv('podatki/okolje_davki.csv',locale=locale(encoding="Windows-1250"), na=c("z","-"))
okoljski_davki %>% rename( '2010,\n (mio EUR)'= `2010`,
                            '2011,\n (mio EUR)'= `2011`,
                            '2012,\n (mio EUR)'= `2012`,
                            '2013,\n (mio EUR)'= `2013`,
                            '2014,\n (mio EUR)'= `2014`,
                            '2015,\n (mio EUR)'= `2015`,
                            '2016,\n (mio EUR)'= `2016`,
                            '2017,\n (mio EUR)'= `2017`)

okoljski_davki <- okoljski_davki[c(-1,-23,-24),]

BDP <- read_csv('podatki/bdp.csv',locale=locale(encoding="Windows-1250"), na=c("z","-"))

dejavnosti3 <- as.vector(BDP$`DEJAVNOSTI/TRANSAKCIJE`)

BDP_po_dejavnosti <- BDP %>% slice(grep("^[A-Z] ", dejavnosti3))

invest_regije <- read_csv("podatki/invest_regije.csv", locale=locale(encoding="Windows-1250"), na=c("...","-"))

invest_regije[,-1] <- invest_regije[,-1] / 1000

okoljski_davki <-mutate_each(okoljski_davki, funs(toupper))
BDP_po_dejavnosti <- mutate_each(BDP_po_dejavnosti, funs(toupper))
invest_regije <- mutate_each(invest_regije, funs(toupper))
toplogredni_po_dejavnosti <- mutate_each(toplogredni_po_dejavnosti, funs(toupper))

#______________

regije <- read.csv2(file="podatki/2711801.csv", header=TRUE, fileEncoding="Windows-1250", skip=1, dec= '.')


# Script to prepare SAMexplore data for analyses via theoretical model and Boruta/RandomForest
# Written by Milou Sep

# Packages & data ---------------------------------------------------------
library(dplyr)
library(tidyselect) # for all_of()
# imputed data
readRDS("processed_data/SAMimputed_with.AUC.variables.RDS")->implist # Actual data!
#readRDS("data/simulated.implist.RDS")->implist # simulated data for sharing & code check

# imputation setting
M=10

# # to prepare implist with raw data (for descriptive tables)
# readRDS("processed_data/SAMimputed.andRAW_with.AUC.variables.rds")->implist
# M=M+1

# Variable Selection ------------------------------------------------------

# Collect questionnaire total and subscale scores in vectors
scl.subscales<-c("SCL_SOM_total", "SCL_OC_total", "SCL_IS_total", "SCL_DEP_total", "SCL_ANX_total", "SCL_HOS_total", "SCL_PHOB_total", "SCL_Sleep_total")
jtv.subscales<-c("JTV_PA_total", "JTV_EA_total", "JTV_SA_total", "JTV_PN_total", "JTV_EN_total")
hexaco.subscales <- c("HEXACO_hh.mean", "HEXACO_emo.mean", "HEXACO_extr.mean", "HEXACO_ag.mean", "HEXACO_co.mean", "HEXACO_op.mean")
vtci.subscales <- c( "VTCI_SD_total",  "VTCI_NS_total", "VTCI_CO_total", "VTCI_HA_total",  "VTCI_ST_total",  "VTCI_RD_total", "VTCI_PS_total")

all.t0.total<-c( "SCL_total", "JTV_total", "LSC_event_total", "STAI_T_total" ,
                 #  scl.subscales, jtv.subscales,
                 hexaco.subscales, vtci.subscales)
# Collect demographic variables
demografics<-c("subject",
               "BMI", "age", "Condition",
               "roken", "alcohol", "drugs",
               "psychol", "lich_ziekte",
               "nachtritme_verst")
# collect memory measures
outcomes<-c("fear.memory", "fear.learning", "neutral.memory", "emotional.memory")

# Merge all variables together
varsRF<-c(demografics,all.t0.total,outcomes)

# Select variables above
implist2<-lapply(1:M, function(x){
   # x=1
  implist[[x]]->x.new
  x.new %>% select(all_of(varsRF), grep("AUC", names(.), value = T))-> x.new2
 return(x.new2)
})

# # to save intermediate data (with raw data in implist)
# saveRDS(implist2, "processed_data/implist.withRAW11.RDS")

# z-scores ----------------------------------------------------------------
# All numeric variables are transformed to z-scores and a cumulative stress measure is calculated

# Stress-exposure score:
# This score is based on the cumulative score used by [Kok & Sep etal. 2016](https://www.sciencedirect.com/science/article/pii/S0165032716304530?via%3Dihub)
# and [Vinkers etal. 2014](https://doi.org/10.1002/da.22262):
# "A comprehensive assessment of stressful experiences during life is more informative with respect to an individual's vulnerability for psychopathology than focusing on a single stress domain" (Vinkers et al., 2014).
# Therefore, z-scores of CTQ and LSC-R outcomes were used to calculate a stress exposure score (Vinkers et al., 2014).

# Kok et al. (2016): stress-exposure: Centered variable composed by adding up centered CTQ and LSC-R scores
# Vinkers et al. (2014): "LSC-r scored as `The number of experienced major life events was calculated by summing the positively scored items`." Cumulative score:
# 1. Levels of childhood maltreatment, major life events, and daily hassles were standardized to a z-score
# 2. Each stress domain weighed equally in its contribution to the cumulative stress index
# 3. By definition, the average standardized z-score is 0 for each stress domain. In contrast, this is not the case for the cumulative stress index that is the sum of three independent stress domains.

implist3<-lapply(1:M, function(x){
  # get dataframe
  implist2[[x]]->x.new
  # calculate z-scores
  x.new %>%
    # https://www.r-bloggers.com/r-tutorial-series-centering-variables-and-generating-z-scores-with-the-scale-function/
    mutate_if(is.numeric, ~as.vector(scale(.,center = TRUE, scale = TRUE))) ->x.new2 # solution to lose attributes (from scale)
  # create cumulative stress measure by sum of centered z-scores:
  x.new2$stress_exposure<- x.new2$JTV_total + x.new2$LSC_event_total
  return(x.new2)
})
# implist3[[3]]

# Split experimental conditions -------------------------------------------

# create empty lists, so each imputed dataset can be split in the 3 conditions
imp.nos<-list()
imp.ims<-list()
imp.des<-list()
# The combined dataset is subsequently split in the 3 experimental conditions.
for(i in 1:M){
  # select the imputed dataset
  implist3[[i]]->x.new
  # add imputation index
  # x.new$.imp<-rep(i, nrow(x.new))
  # and split this dataset per condition
  split(x.new, x.new$Condition)->df_splitted
  # add each list element to the imputations lists for each experimental condition
  imp.nos[[i]]<- df_splitted$`No-Stress`
  imp.ims[[i]]<- df_splitted$`Immediate-Stress`
  imp.des[[i]]<- df_splitted$`Delayed-Stress`
}
rm(df_splitted, x.new)

# For Boruta analysis / random forest
# functions to prepare data for the 3 outcomes

prep.emo<-function(data){
  data %>%
    mutate(subject=as.numeric(subject) ) %>% # random forest use a categorical variable with more than 53 categories (= factor subject)
    filter(!is.na(emotional.memory)) %>% # only emotional & neutral contain missing values
    select(-c(neutral.memory, fear.learning, fear.memory, Condition))->df
  return(df)
}

prep.neu<-function(data){
  data %>%
    mutate(subject=as.numeric(subject) ) %>%
    filter(!is.na(neutral.memory)) %>%
    select(-c(emotional.memory, fear.learning, fear.memory, Condition))->df
  return(df)
}

prep.fear.m<-function(data){
    data %>%
    mutate(subject=as.numeric(subject) ) %>%
    filter(!is.na(fear.memory))%>%
    select(-c(emotional.memory, neutral.memory, Condition))->df
 return(df)
}


##################################################################
#### Perform GO enrichment analysis from DESeq2 tables of DEG ####
##################################################################

rm(list=ls())

#####################################
### Load functions and libraries  ###
#####################################
library(readr)
source("load/Load.GO.R")
source("load/GOstats.human.R")
source("load/Ensembl_to_entrez.R")

#######################################
### Analysis for GSE147507 Dataset  ###
#######################################

GSE147507<-'DEA_results/GSE147507_MainDataset'
filenames_GSE147507<-list.dirs(path = 'DEA_results/GSE147507_MainDataset', full.names = FALSE, recursive = FALSE )

for (series in filenames_GSE147507){

  ### Load DESeq2 results  ###
  filename<-paste('DEA_results/GSE147507_MainDataset/',series,'/des_Condition/ControlVsInfected_genes.DESeq2.tsv', sep='')
  DESeq <- read_delim(filename, "\t", escape_double = FALSE, trim_ws = TRUE)

  ### Run GO analysis function ###
  GO.human.list(DESeq$gene_id)

  ### Correct p-values for multitesting and create log2OddsRatio  ###
  out$padj<-p.adjust(out$Pvalue,method = "bonferroni")
  out$log2OddsRatio<-log(out$OddsRatio,base=2)

  ### Write csv file with results ###
  write.csv(out,file=paste("output/GSE147507",series,"_GO.csv",sep=""))
}

#######################################
### Analysis for GSE150316 Dataset  ###
#######################################

GSE150316<-'DEA_results/GSE150316_ValidationDataset/WithoutThreeOutliers'
filenames_GSE150316<-list.dirs(path = 'DEA_results/GSE150316_ValidationDataset/WithoutThreeOutliers', full.names = FALSE, recursive = FALSE )

for (series in filenames_GSE150316){
  ### Load DESeq2 results  ###
  filename<-paste('DEA_results/GSE150316_ValidationDataset/WithoutThreeOutliers/',series,'/des_Case/ControlVs',series,'_genes.DESeq2.tsv', sep='')
  DESeq <- read_delim(filename, "\t", escape_double = FALSE, trim_ws = TRUE)

  ### Validation dataset IDs are not in Ensembl format as the previous dataset  ###
  Ensembl_genes<-subset(ensembl_to_entrez, external_gene_name %in% DESeq$gene_id)

  ### Run GO analysis function ###
  GO.human.list(Ensembl_genes$ensembl_gene_id)

  ### Correct p-values for multitesting and create log2OddsRatio  ###
  out$padj<-p.adjust(out$Pvalue,method = "bonferroni")
  out$log2OddsRatio<-log(out$OddsRatio,base=2)

  ### Write csv file with results ###
  write.csv(out,file=paste("output/GSE150316/",series,"_GO.csv",sep=""))
}


gene <- readLines("current-vs-never-genes.txt")
meth <- read.table("27651444_smoking_current_vs_never_smoking.tsv",sep="\t",header=T)
length(unique(meth$gene))
#[1] 4196
length(unique(gene))
#[1] 670
length(intersect(toupper(gene), toupper(meth$gene)))
#[1] 204
meth[1,]
#      author consortium     pmid       date   trait                                   efo                 analysis   source         outcome
#1 Joehanes R         NA 27651444 2016-10-01 Smoking EFO_0006527, EFO_0005671, EFO_0004318 Current vs never smoking Table S2 DNA methylation
#                      exposure                        covariates outcome_unit exposure_unit                        array                  tissue further_details    n
#1 Current versus never smoking Age, sex, cell composition, batch  Beta values            NA Illumina HumanMethylation450 CD4+ T cells, monocytes              NA 9389
#  n_studies    age  sex         ethnicity        cpg        chrpos chr      pos   gene        type   beta    se       p details
#1        16 Adults Both European, African cg16145216 chr1:42385662   1 42385662 HIVEP3 South shore 0.0298 0.002 6.7e-48       -
#                                   study_id
#1 27651444_smoking_current_vs_never_smoking
meth <- meth[which(meth$p < 1e-7),]
length(unique(meth$gene))
#[1] 1406
length(intersect(toupper(gene), toupper(meth$gene)))
#[1] 81
fisher.test(cbind(c(20000, 1406),c(670, 81)), alternative="greater")
#
#	Fisher's Exact Test for Count Data
#
#data:  cbind(c(20000, 1406), c(670, 81))
#p-value = 1.57e-05
#alternative hypothesis: true odds ratio is greater than 1
#95 percent confidence interval:
# 1.394687      Inf
#sample estimates:
#odds ratio
#  1.719652


###All chromatogram depiction
setwd(codeDrive)

###Require
#chromatoFileTemp
#lengthID
#input.type.name <- "SampleID"
#output.png.name <- "Append_withImageSimilarity.png"
#var.sortID <- sortID

finalRank <- Rank.max
setwd(codeDrive)

for (w2 in 1:lengthID ){

  chromatoFile <- chromatoFileTemp[,w2]

  setwd(codeDrive)
  source("source_basic_chromato_xx1yy1zz1.r")
  cstep <- 100
  cfactor <- 2
  clevels <- seq(0,(1/1000)^(1/cfactor),length.out=cstep )^(cfactor)

  windows(10,5)
  setwd(TempDrive)
  jpeg( paste(input.type.name,w2,".jpg",sep=""),width=1000,height=500 )
  par(mar=c(5,7,1,1))
  filled.contour(xx1,yy1,zz1,xlab="RT1 (min)",ylab="RT2 (sec)", col=red_blue(cstep),levels=clevels[1:cstep] )
  text(RTini*2.2+Masking_left/60,MPeriod*0.85-Masking_top,paste("ID: ",w2,sep=""),cex=10,col="darkgray")

  if (finalRank[w2]==1)
  {col.chosen="red"}
  if (finalRank[w2]==2)
  {col.chosen="yellow"}
  if (finalRank[w2]==3)
  {col.chosen="black"}

  text(RTini*2.4+Masking_left/60,MPeriod*0.65-Masking_top,paste("Rank: ",finalRank[w2],sep=""),cex=10,col=col.chosen)

  dev.off()
  dev.off()
}

###Combine all the chromatogram with rank assignment
library(jpeg)

windows()
par(mar=c(0,0,0,0))
par(mfrow=c(max(ceiling(length(var.sortID)/4),5),4))

setwd(TempDrive)
for (w2 in 1:lengthID ){

  gcxgc.pic <- readJPEG( paste(input.type.name,w2,".jpg",sep="") )

  par(mar=c(0,0,0,0))
  plot( 0,0,xlim=c(0,700),ylim=c(0,512), axes=F,type="n")
  rasterImage(gcxgc.pic, 0, 0, 800, 512)

}

setwd(outputDrive)
dev.copy(device=png,file=output.png.name)
dev.off()
dev.off()


# Functions called in power analysis (Fig 4 in ms)

trait.evolve<-function(tree,num.reps=10,mode.of.evolution="OU",alpha){
  num.taxa<-length(tree$tip.label)
  data.temp<-data.frame(tree$tip.label,rep(1,num.taxa),rep(1,num.taxa))
  #now have to set up something that can multicore nicely different alphas

  ou.sim<-function(alpha,tree=tree,data.temp=data.temp,num.reps=2){
    trait.data.out<-NULL  #a bit hacky but it works
    for (i in 1:num.reps){
      library("OUwie")
      trait.data.out[[i]]<-OUwie.sim(tree,data.temp,alpha=alpha, sigma.sq=0.45, theta0=0, theta=0)
    }
    return(trait.data.out)
  }
  #ou.sim(alpha=1,tree=tree,data.temp=data.temp,num.reps=2) #testing line

  if (mode.of.evolution=="OU"){
    out.mc <- lapply(alpha,tree=tree,FUN=ou.sim,data.temp=data.temp,num.reps=num.reps)
    return(out.mc)
  }
  if (mode.of.evolution=="BM"){
    out.mc.bm<-fastBM(tree,mu=0,sig2=0.45,nsim=num.reps)
    return(out.mc.bm)
  }
}

tree.evolve<-function(tree.choice="sim",pool.size=200){
  #real tree
  if (tree.choice=="real") tree <- tanktree
  #or sim tree
  if (tree.choice=="sim") tree<-pbtree(b=1,n=pool.size,scale=422.6181,extant.only=TRUE) #estimating depth on the big tree takes a long time for some

  if (length(tree$tip.label)>pool.size) {
    big.tree<-tree
    tree<-drop.tip.fixed(big.tree,sample(length(big.tree$tip.label),length(big.tree$tip.label)-pool.size)) #drop tips randomly to get down to a workable   tree
  }

  store.node.labels<-tree$node.label
  tree$node.label<-rep(1,(length(tree$tip.label)-1))
  return(tree)
}

make.picante.format.bm <- function(out.mc.bm = out.mc.bm,ca){
  comm.phy.list <- list()
  if (ca == "filter") species.list <- multi.filter.bm(out.mc.bm)
  if (ca == "neutral") species.list <- multi.neutral.bm(out.mc.bm)
  nspecies <- length(unique(unlist(species.list)))
  m <- matrix(data = 0, ncol = nspecies, nrow = dim(out.mc.bm)[2])
  colnames(m) <- unique(unlist(species.list))
  for (i in 1:length(species.list)){ #hacky!
    m[i, which(colnames(m)%in%species.list[[i]])] <- 1
  }
  return(m)
}

# filtering approaches
filter.derived <- function(species, trait, sr.community = 40) {
  print("habitat filter")
  opt <- max(trait) # NB. max = most derived
  return(species[(order(abs(opt - trait)))[0:sr.community]])
}

neutral.filter <- function(species, trait, sr.community = 40){
  print("neutral")
  return(species[trait %in% sample(trait, sr.community)])
}

multi.filter.bm<-function(out.mc.bm=out.mc.bm){
  comm.list<-list()
  for (i in 1:dim(out.mc.bm)[2]){
    comm.list[[i]]<-filter.derived(row.names(out.mc.bm), out.mc.bm[,i])
  }
  return(comm.list)
}

multi.neutral.bm<-function(out.mc.bm=out.mc.bm){
  comm.list<-list()
  for (i in 1:dim(out.mc.bm)[2]){
    comm.list[[i]]<-neutral.filter(row.names(out.mc.bm), out.mc.bm[,i])
  }
  return(comm.list)
}

## This is a patched version of drop.tip that will keep the nodes in
## the correct order.  Otherwise it is exactly the same as the
## drop.tip in ape version 2.4-1 (right down to the use of dim(x)[1]
## instead of nrow(x)).  See REMOVE/REPLACE/DONE at the end for changes.
drop.tip.fixed <- function(phy, tip, trim.internal = TRUE, subtree =
                             FALSE, root.edge = 0, rooted = is.rooted(phy)) {
  if (!inherits(phy, "phylo"))
    stop("object \"phy\" is not of class \"phylo\"")
  Ntip <- length(phy$tip.label)
  if (is.character(tip))
    tip <- which(phy$tip.label %in% tip)
  if (!rooted && subtree) {
    phy <- root(phy, (1:Ntip)[-tip][1])
    root.edge <- 0
  }
  phy <- reorder(phy)
  NEWROOT <- ROOT <- Ntip + 1
  Nnode <- phy$Nnode
  Nedge <- dim(phy$edge)[1]
  if (subtree) {
    trim.internal <- TRUE
    tr <- reorder(phy, "pruningwise")
    N <- .C("node_depth", as.integer(Ntip), as.integer(Nnode),
            as.integer(tr$edge[, 1]), as.integer(tr$edge[, 2]),
            as.integer(Nedge), double(Ntip + Nnode), DUP = FALSE,
            PACKAGE = "ape")[[6]]
  }
  wbl <- !is.null(phy$edge.length)
  edge1 <- phy$edge[, 1]
  edge2 <- phy$edge[, 2]
  keep <- !logical(Nedge)
  if (is.character(tip))
    tip <- which(phy$tip.label %in% tip)
  if (!rooted && subtree) {
    phy <- root(phy, (1:Ntip)[-tip][1])
    root.edge <- 0
  }
  keep[match(tip, edge2)] <- FALSE
  if (trim.internal) {
    ints <- edge2 > Ntip
    repeat {
      sel <- !(edge2 %in% edge1[keep]) & ints & keep
      if (!sum(sel))
        break
      keep[sel] <- FALSE
    }
    if (subtree) {
      subt <- edge1 %in% edge1[keep] & edge1 %in% edge1[!keep]
      keep[subt] <- TRUE
    }
    if (root.edge && wbl) {
      degree <- tabulate(edge1[keep])
      if (degree[ROOT] == 1) {
        j <- integer(0)
        repeat {
          i <- which(edge1 == NEWROOT & keep)
          j <- c(i, j)
          NEWROOT <- edge2[i]
          degree <- tabulate(edge1[keep])
          if (degree[NEWROOT] > 1)
            break
        }
        keep[j] <- FALSE
        if (length(j) > root.edge)
          j <- 1:root.edge
        NewRootEdge <- sum(phy$edge.length[j])
        if (length(j) < root.edge && !is.null(phy$root.edge))
          NewRootEdge <- NewRootEdge + phy$root.edge
        phy$root.edge <- NewRootEdge
      }
    }
  }
  if (!root.edge)
    phy$root.edge <- NULL
  phy$edge <- phy$edge[keep, ]
  if (wbl)
    phy$edge.length <- phy$edge.length[keep]
  TERMS <- !(phy$edge[, 2] %in% phy$edge[, 1])
  oldNo.ofNewTips <- phy$edge[TERMS, 2]
  n <- length(oldNo.ofNewTips)
  phy$edge[TERMS, 2] <- rank(phy$edge[TERMS, 2])
  if (subtree || !trim.internal) {
    tips.kept <- oldNo.ofNewTips <= Ntip & !(oldNo.ofNewTips %in%
                                               tip)
    new.tip.label <- character(n)
    new.tip.label[tips.kept] <- phy$tip.label[-tip]
    node2tip <- oldNo.ofNewTips[!tips.kept]
    new.tip.label[!tips.kept] <- if (subtree) {
      paste("[", N[node2tip], "_tips]", sep = "")
    }
    else {
      if (is.null(phy$node.label))
        rep("NA", length(node2tip))
      else phy$node.label[node2tip - Ntip]
    }
    if (!is.null(phy$node.label))
      phy$node.label <- phy$node.label[-(node2tip - Ntip)]
    phy$tip.label <- new.tip.label
  }
  else phy$tip.label <- phy$tip.label[-tip]
  if (!is.null(phy$node.label))
    phy$node.label <- phy$node.label[sort(unique(phy$edge[,
                                                          1])) - Ntip]
  phy$Nnode <- dim(phy$edge)[1] - n + 1L

  ## REMOVE:
  ##     newNb <- integer(n + phy$Nnode)
  ##     newNb[NEWROOT] <- n + 1L
  ##     sndcol <- phy$edge[, 2] > n
  ##     phy$edge[sndcol, 2] <- newNb[phy$edge[sndcol, 2]] <- (n +
  ##         2):(n + phy$Nnode)
  ##     phy$edge[, 1] <- newNb[phy$edge[, 1]]
  ## REPLACE:
  i <- phy$edge > n
  phy$edge[i] <- match(phy$edge[i], sort(unique(phy$edge[i]))) + n
  ## DONE:

  storage.mode(phy$edge) <- "integer"
  collapse.singles(phy)
}


# See http://learnr.wordpress.com/2009/04/23/ggplot2-budget-vs-actual-performance/
p <- ggplot(ledger_data, aes(partial_account)) +
            geom_bar(aes(y = actual), width = .75, fill = "grey55") +
            geom_errorbar(aes(ymin = budgeted, ymax = budgeted), size = 1 ) +
            facet_wrap(~ partial_account, ncol = 6, scales = "free") +
            geom_text(aes(y=1, label = paste(round(ledger_data$remaining), " (", round(ledger_data$used), "%)", sep=""),
                      vjust = -0.6, size = 6)) +
            xlab("") +
            ylab(commodity)

suppressMessages(ggsave(file="bar-budget.svg", plot = p, width = 14, height = 2 * (length(ledger_data$account) / 4)))


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

plot_graphs <- function(data_list, fit, fn, NG, inc_vacc, group_names=c("non-B.1.1.7","B.1.1.7")) {
# only including code to plot fit of model to data here
  data <- data_list$data
  subjects <- data_list$subjects
  N <- data_list$N
  posterior <- extract(fit, inc_warmup = FALSE, permuted = TRUE)
  pred_ct_samples <- as.data.frame(posterior$pred_ct)

  pred_ct_mean <- pred_ct_samples %>%
    summarise(across(.cols = everything(),.fns=mean)) %>% t(.)
  pred_ct_0.5 <- pred_ct_samples %>%
    summarise(across(.cols = everything(),~quantile(.x, probs = 0.5))) %>% t(.)
  pred_ct_0.025 <- pred_ct_samples %>%
    summarise(across(.cols = everything(),~quantile(.x, probs = 0.025))) %>% t(.)
  pred_ct_0.975 <- pred_ct_samples %>%
    summarise(across(.cols = everything(),~quantile(.x, probs = 0.975))) %>% t(.)
  pred_id <- rep(1:N, 1, each=42)
  pred_t <- rep(-14:27, N)

  data3 <- data

  x=log(10) # all VL plotted on log10 rather than ln scale

  data3$study_id = subjects$study_id[data3$id]
  data3$data_scale = data_scale[data3$study_id]
  data3$data_offset = data_offset[data3$study_id]
  data3$vl = (data3$data_offset+data3$invCT/data3$data_scale)/x

  data3$B117Status <- as.factor(group_names[data3$B117Status+1])
  data3$B117Status <- factor(data3$B117Status,levels=group_names)

  data4 <- data %>% group_by(id) %>% summarise(B117Status=mean(B117Status),PersonID=mean(PersonID),Symptomatic=mean(Symptomatic))

  B117Status <- rep(data4$B117Status, 1, each=42)
  PersonID <- rep(data4$PersonID, 1, each=42)
  Symptomatic <- rep(data4$Symptomatic, 1, each=42)
  data2 <- as.data.frame(cbind(pred_id,PersonID,Symptomatic,pred_t,B117Status,pred_ct_mean,pred_ct_0.5,pred_ct_0.025,pred_ct_0.975))
  names(data2) <- c("id","PersonID","Symptomatic","t","B117Status","invCT","ct_0.5","ct_0.025","ct_0.975")

  data2$study_id=subjects$study_id[data2$id]
  data2$data_scale=data_scale[data2$study_id]
  data2$data_offset=data_offset[data2$study_id]
  data2$vl = (data2$data_offset+data2$ct_0.5/data2$data_scale)/x
  data2$vl_0.025 = (data2$data_offset+data2$ct_0.025/data2$data_scale)/x
  data2$vl_0.975 = (data2$data_offset+data2$ct_0.975/data2$data_scale)/x

  data2$B117Status <- as.factor(group_names[data2$B117Status+1])
  data2$B117Status <- factor(data2$B117Status,levels=group_names)

  data3$symp[is.na(data3$Symptomatic)]="U"
  data3$symp[data3$Symptomatic==1]="S"
  data3$symp[data3$Symptomatic==0]="A"
  data2$symp[is.na(data2$Symptomatic)]="U"
  data2$symp[data2$Symptomatic==1]="S"
  data2$symp[data2$Symptomatic==0]="A"
  data3$pID2=paste0(data3$PersonID,":",data3$symp)
  data2$pID2=paste0(data2$PersonID,":",data2$symp)

  pl0 <- ggplot(data=data3,aes(x=TestDateIndex,y=vl,colour=B117Status)) +
    labs(colour="Variant") +
    geom_point(colour="black") +
    geom_ribbon(data=data2,aes(x=t,y=vl,ymin=vl_0.025,ymax=vl_0.975, linetype=NA),alpha=0.5,show.legend = FALSE) +
    geom_line(data=data2,aes(x=t,y=vl),size=1) +
    facet_wrap(~pID2) +theme_classic() + theme(legend.position="bottom") +
    scale_x_continuous("Day relative to peak", limits = c(-14,28), breaks = c(-14,0,14)) +
    scale_y_continuous("log10(viral copies/ml)", limits = c(1,10), breaks = seq(2,10,by=2)) +
    theme(panel.grid.major = element_line(colour="lightgrey",linetype="dashed", size = 0.1),
          strip.background = element_blank(),strip.text.x = element_blank())

  ggsave(paste0(fn, "_plot0.pdf"), pl0, width=7, height = 10)
  ggsave(paste0(fn, "_plot0.svg"), pl0, width=7, height = 10)

}