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


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

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

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

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

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

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

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

###Let's set all simulation parameters:

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

		if (year == start_time) {

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

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

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

		}else{

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

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

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

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

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

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

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

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

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

				}

			}else{ out <- NULL }

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

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

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

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

					colonies <- new.colonies.stack()

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

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

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

				}

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

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

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

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

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

		}

	}

	save.image()
}

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

##Suppress the progress bar
tkdestroy(root)

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

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


#use Rscript --vanilla /datacit/Development/RNAseq_YR/SMAP_fusion/fusionAnalysis_forpaper.r $STAR_FUSION_DIR $SAMPLE
#exemple /datacit/Development/RNAseq_YR/SMAP_fusion/fusionAnalysis_forpaper.r /datacit/Development/RNAseq_YR/SMAP_fusion/ Sample_3

#STAR_FUSION_DIR=commandArgs(trailingOnly=TRUE)[1]
#SAMPLE=commandArgs(trailingOnly=TRUE)[2]

.fuzprocess=function(f,sample){

    y=utils::read.delim(f,sep="\t",header=F,as.is=T,comment.char="",skip=1)
    colnames(y)=gsub("^#","",unlist(strsplit(scan(f,sep='\n',what="character",nlines=1,quiet = T)[1],"\t")))

    suppressWarnings({
        y[,2]=as.integer(	y[,2])
        y[,3]=as.integer(	y[,3])
    })

    y=y[which(!is.na(y[,2])&!is.na(y[,3])),]
    y[,1]=gsub("^#","" 	,y[,1])

    y=y[,which(colSums(is.na(y))<nrow(y) )]
    genes=do.call(rbind,strsplit(y[,1],"--"))
    y = data.frame("LeftGene"=genes[,1],   "RightGene"=genes[,2] ,y,stringsAsFactors=F)

    y$OrgLeftGene = stringr::str_extract(y$LeftBreakpoint,"mmu|hs")
    y$OrgRightGene = stringr::str_extract(y$RightBreakpoint,"mmu|hs")

    y$sample = rep(sample,nrow(y))
    y=unique(y)
    y[order(y[,2],decreasing=T),]
}

.fishersMethod = function(x) stats::pchisq(-2 * sum(log(x)),df=2*length(x),lower=FALSE)
# Function to filter dupplicated fusion (selmaxreads)
.dupFUZ=function(expdat){
    expdat$orderfuz =apply(expdat,1,function(x) paste(as.character(sort(x[c("LeftGene","RightGene")])),collapse="--"))
    expdat$sum=apply(expdat[,c("JunctionReads", "SpanningFrags")],1,sum)
    sym=expdat$orderfuz
    i=order(expdat$sum,decreasing=T)
    oki=i[which(!duplicated(sym[i]))]
    newexpdat=data.frame(expdat[oki,])
    rownames(newexpdat)=sym[oki]
    newexpdat
}

#  utils
.getlast=function(x){return(x[length(x)])}
.cmess=function(...,sep=" "){message(paste(...,sep=sep))}
.cstop=function(...,sep=" "){stop(paste(...,sep=sep))}

#' Title
#'  SMAPfuz
#'
#'
#'
#' @param STAR_FUSION_DIR defines the path to the STAR fusion output directory.
#' @param specieOfInterestPattern defines for which specie the fusion are analysed.
#' usually human for Paitent Derived Xenograft
#'
#' @description This function aims at defining the best thresholds for cimeric transcripts detection.
#' It is based on an estimation of an H0 distribution of parameters of eahc of the detected fusion transcritps by
#' taking into account the impossibility of observing cross-species fusions and therefore using them
#' to define the parameters of H0.
#' As of now, only the number of spanning fragments and of junction reads are used.
#'
#'
#' @return A data frame containing one fusion per line.
#' In addition to the information given by STAR fusion, 4 colums are added :
#' JunctionReads_Pvalue : the p-value of the junction read
#' SpanningFrags_Pvalue : the p-value of the spanning fragments
#' Combined_pvalue : The combined p-value using fishers method
#' Combined_adj.pvalue : The FDR correction of the combined p-value
#'
#' @examples
#' d=system.file( "extdata","Example_StarFusion_OUTPUT", package = "SMAP")
#'
#' fusions=SMAPfuz(STAR_FUSION_DIR=d,"hs")
#' fusions_filtered=fusions[which(fusions$Combined_adj.pvalue < 0.01),]
#' fusions_filtered=fusions[which(fusions$Combined_adj.pvalue < 0.001),]
#'

SMAPfuz = function(STAR_FUSION_DIR,specieOfInterestPattern="hs"){

    finalfusionFiles="fusion.fusion_candidates.final.abridged"
    unfiltfusionFiles="fusion.fusion_candidates.preliminary.filt_info.abridged"

    sample =  .getlast(strsplit(STAR_FUSION_DIR,"/")[[1]])
    finaldatafile=grep(finalfusionFiles,list.files(STAR_FUSION_DIR),value=T)
    unfiltdatafile=grep(unfiltfusionFiles,list.files(STAR_FUSION_DIR),value=T)

    if(length(finaldatafile)==0 | length(unfiltdatafile)==0 ){
        .cstop("No STAR FUSION files found in the given directory: ",STAR_FUSION_DIR)
    }

    FilteredFuz=.dupFUZ(.fuzprocess(file.path(STAR_FUSION_DIR,finaldatafile),sample))
    UnfiltFuz=.dupFUZ(.fuzprocess(file.path(STAR_FUSION_DIR,unfiltdatafile),sample))

    # HO distribution
    valuecols=c("JunctionReads", "SpanningFrags")
    leftgeneOrgCol="OrgLeftGene"
    rightgeneOrgCol="OrgRightGene"

    humanfuze=FilteredFuz[which(FilteredFuz[,rightgeneOrgCol]==specieOfInterestPattern & FilteredFuz[,leftgeneOrgCol]==specieOfInterestPattern),]

    reads_junc = UnfiltFuz[which(UnfiltFuz[,rightgeneOrgCol] != UnfiltFuz[,leftgeneOrgCol]),valuecols[1]]
    frag_span = UnfiltFuz[which(UnfiltFuz[,rightgeneOrgCol] != UnfiltFuz[,leftgeneOrgCol]),valuecols[2]]
    nb0junc = sum(reads_junc>0)
    nb0span = sum(frag_span>0)
    #print(nb0junc)
    #print(nb0span)

    if(nb0junc<4 & nb0span<4) .cstop("Too few reads support the interspecies-Fusion for H0 calculation")

    if(nb0junc> 2 & nb0span<4){
        print("H0 on junction reads only")
        nulld1=MASS::fitdistr(UnfiltFuz[which(UnfiltFuz[,rightgeneOrgCol] != UnfiltFuz[,leftgeneOrgCol]),valuecols[1]],"negative binomial")$estimate
        humanfuze[[paste(valuecols[1],"_","Pvalue",sep="")]] = 1-stats::pnbinom(humanfuze[[valuecols[1]]],size=nulld1["size"],mu=nulld1["mu"])
        humanfuze[[paste(valuecols[1],"_","adj.pvalue",sep="")]]=stats::p.adjust( humanfuze[[paste(valuecols[1],"_","Pvalue",sep="")]],method="fdr")
        return(humanfuze)
    }
    if(nb0junc>2 & nb0span>2){
        print("H0 on junction reads and Spanning Fragments")
        nulld1=MASS::fitdistr (UnfiltFuz[which(UnfiltFuz[,rightgeneOrgCol] != UnfiltFuz[,leftgeneOrgCol]),valuecols[1]],"negative binomial")$estimate
        nulld2=MASS::fitdistr (UnfiltFuz[which(UnfiltFuz[,rightgeneOrgCol] != UnfiltFuz[,leftgeneOrgCol]),valuecols[2]],"negative binomial")$estimate
        logx=unique(floor(2^(seq(0,10,by=0.1))))
        x=log2(logx+1)
        xd1 <- stats::dnbinom(logx, mu =nulld1["mu"], size = nulld1["size"])
        xd2 <- stats::dnbinom(logx, mu = nulld2["mu"], size = nulld2["size"])
        humanfuze[[paste(valuecols[1],"_","Pvalue",sep="")]] = 1-stats::pnbinom(humanfuze[[valuecols[1]]],size=nulld1["size"],mu=nulld1["mu"])
        humanfuze[[paste(valuecols[2],"_","Pvalue",sep="")]]=1-stats::pnbinom(humanfuze[[valuecols[2]]],size=nulld2["size"],mu=nulld2["mu"])
        humanfuze$Combined_pvalue=apply(humanfuze[,c(paste(valuecols[1],"_","Pvalue",sep=""),paste(valuecols[2],"_","Pvalue",sep=""))],1,.fishersMethod)
        humanfuze$Combined_adj.pvalue=stats::p.adjust(humanfuze$Combined_pvalue,method="fdr")
        X=humanfuze
        X$decisionPvals=cut(X$Combined_adj.pvalue,breaks=c(0,0.001,0.01,0.05,0.1,1),include.lowest=T)
        FPvals=cbind(UnfiltFuz[which(UnfiltFuz[,rightgeneOrgCol] != UnfiltFuz[,leftgeneOrgCol]),valuecols[1]],
        UnfiltFuz[which(UnfiltFuz[,rightgeneOrgCol] != UnfiltFuz[,leftgeneOrgCol]),valuecols[2]])
        colnames(FPvals)=valuecols
        xmax=ceiling(log2(1+max(UnfiltFuz[,valuecols[1]])))
        logx=unique(floor(2^(seq(0,xmax,by=0.1))))
        xd1 <- stats::dnbinom(logx, mu =nulld1["mu"], size = nulld1["size"])
        xx=log2(logx+1)
        ymax=ceiling(log2(1+max(UnfiltFuz[,valuecols[2]])))
        logy=unique(floor(2^(seq(0,ymax,by=0.1))))
        xd2 <- stats::dnbinom(logy, mu = nulld2["mu"], size = nulld2["size"])
        xy=log2(logy+1)
        #pdf(paste(STAR_FUSION_DIR,"/", SAMPLE,"/SMAPFusions_fusionsAnalysis_filternDecisionThreshPval.pdf", sep=""))

        par(fig=c(0,0.8,0,0.75),mar=c(5.1,4.1,1,1))
        smoothScatter(log2(FPvals+1),transformation = function(x) x^.2,xlim=c(0,ymax),ylim=c(0,xmax) )
        points(log2(X[,valuecols]+1),col=rev(c("black","purple","red","orange","green"))[as.integer(X$decisionPvals)],pch=16)
        legend("topright",paste(c(">0.1","<0.1","<0.05","<0.01","<0.001"),"(fdr)"),col=c("black","purple","red","orange","green"),pch=16, cex=0.9)
        par(fig=c(0.8,1,0,0.75),new=T,mar=c(5.1,1,4.1,1))
        barplot(xd1,xx,type="l",axes=T,bty="l",horiz=T,xlab="Prob. distribution")
        par(fig=c(0,0.8,0.75,1),new=T,mar=c(1,4.1,3,1))
        barplot(xd2,xy,type="l",axes=T,bty="l",main="Parametric p-values (negative binomial)",ylab="Prob. distribution")
        #dev.off()

    }

    # isfilt=unlist(lapply(1:nrow(humanfuze),function(i){
    #  thisfuz=humanfuze[i,]
    #  js=which(filtfuz$X.fusion_name == thisfuz$X.fusion_name &
    #             filtfuz$sample == thisfuz$sample &filtfuz$LeftBreakpoint == thisfuz$LeftBreakpoint
    #           &filtfuz$RightBreakpoint == thisfuz$RightBreakpoint&filtfuz$Splice_type == thisfuz$Splice_type )
    #  length(js)
    #}))
    # humanfuze$PassStarFusion =isfilt>0
    return(humanfuze)

}


#' Epigenome-wide association study
#'
#' Test association with each CpG site.
#'
#' @param beta Methylation levels matrix, one row per CpG site, one column per sample.
#' @param variable Independent variable vector.
#' @param covariates Covariates data frame to include in regression model,
#' one row per sample, one column per covariate (Default: NULL).
#' @param batch Batch vector to be included as a random effect (Default: NULL).
#' @param weights Non-negative observation weights.
#' Can be a numeric matrix of individual weights of same dimension as \code{beta},
#' or a numeric vector of weights with length \code{ncol(beta)},
#' or a numeric vector of weights with length \code{nrow(beta)}.
#' @param cell.counts Proportion of cell counts for one cell type in cases
#' where the samples are mainly composed of two cell types (e.g. saliva) (Default: NULL).
#' @param isva Apply Independent Surrogate Variable Analysis (ISVA) to the
#' methylation levels and include the resulting variables as covariates in a
#' regression model (Default: TRUE).
#' @param sva Apply Surrogate Variable Analysis (SVA) to the
#' methylation levels and covariates and include
#' the resulting variables as covariates in a regression model (Default: TRUE).
#' @param n.sv Number of surrogate variables to calculate (Default: NULL).
#' @param winsorize.pct Apply all regression models to methylation levels
#' winsorized to the given level. Set to NA to avoid winsorizing (Default: 0.05).
#' @param robust Test associations with the 'robust' option when \code{\link{limma::eBayes}}
#' is called (Default: TRUE).
#' @param rlm Test assocaitions with the 'robust' option when \code{\link{limma:lmFit}}
#' is called (Default: FALSE).
#' @param outlier.iqr.factor For each CpG site, prior to fitting regression models,
#' set methylation levels less than
#' \code{Q1 - outlier.iqr.factor * IQR} or more than
#' \code{Q3 + outlier.iqr.factor * IQR} to NA. Here IQR is the inter-quartile
#' range of the methylation levels at the CpG site, i.e. Q3-Q1.
#' Set to NA to skip this step (Default: NA).
#' @param most.variable Apply (Independent) Surrogate Variable Analysis to the
#' given most variable CpG sites (Default: 50000).
#' @param featureset Name from \code{\link{meffil.list.featuresets}()}  (Default: NA).
#' @param verbose Set to TRUE if status updates to be printed (Default: FALSE).
#'
#' @export
meffil.ewas <- function(beta, variable,
                        covariates=NULL, batch=NULL, weights=NULL,
                        cell.counts=NULL,
                        isva=T, sva=T, ## cate?
                        n.sv=NULL,
                        isva0=F,isva1=F, ## deprecated
                        winsorize.pct=0.05,
                        robust=TRUE,
                        rlm=FALSE,
                        outlier.iqr.factor=NA, ## typical value = 3
                        most.variable=min(nrow(beta), 50000),
                        featureset=NA,
                        random.seed=20161123,
                        verbose=F) {

    if (isva0 || isva1)
        stop("isva0 and isva1 are deprecated and superceded by isva and sva")

    if (is.na(featureset))
        featureset <- guess.featureset(rownames(beta))
    features <- meffil.get.features(featureset)

    stopifnot(length(rownames(beta)) > 0 && all(rownames(beta) %in% features$name))
    stopifnot(ncol(beta) == length(variable))
    stopifnot(is.null(covariates) || is.data.frame(covariates) && nrow(covariates) == ncol(beta))
    stopifnot(is.null(batch) || length(batch) == ncol(beta))
    stopifnot(is.null(weights)
              || is.numeric(weights) && (is.matrix(weights) && nrow(weights) == nrow(beta) && ncol(weights) == ncol(beta)
                                         || is.vector(weights) && length(weights) == nrow(beta)
                                         || is.vector(weights) && length(weights) == ncol(beta)))
    stopifnot(most.variable > 1 && most.variable <= nrow(beta))
    stopifnot(!is.numeric(winsorize.pct) || winsorize.pct > 0 && winsorize.pct < 0.5)

    original.variable <- variable
    original.covariates <- covariates
    if (is.character(variable))
        variable <- as.factor(variable)

    stopifnot(!is.factor(variable) || is.ordered(variable) || length(levels(variable)) == 2)

    msg("Simplifying any categorical variables.", verbose=verbose)
    variable <- simplify.variable(variable)
    if (!is.null(covariates))
        covariates <- do.call(cbind, lapply(covariates, simplify.variable))

    sample.idx <- which(!is.na(variable))
    if (!is.null(covariates))
        sample.idx <- intersect(sample.idx, which(apply(!is.na(covariates), 1, all)))

    msg("Removing", ncol(beta) - length(sample.idx), "missing case(s).", verbose=verbose)

    if (is.matrix(weights))
        weights <- weights[,sample.idx]
    if (is.vector(weights) && length(weights) == ncol(beta))
        weights <- weights[sample.idx]

    beta <- beta[,sample.idx]
    variable <- variable[sample.idx]

    if (!is.null(covariates))
        covariates <- covariates[sample.idx,,drop=F]

    if (!is.null(batch))
        batch <- batch[sample.idx]

    if (!is.null(cell.counts))
        cell.counts <- cell.counts[sample.idx]

    if (!is.null(covariates)) {
        pos.var.idx <- which(apply(covariates, 2, var, na.rm=T) > 0)
        msg("Removing", ncol(covariates) - length(pos.var.idx), "covariates with no variance.",
            verbose=verbose)
        covariates <- covariates[,pos.var.idx, drop=F]
    }

    covariate.sets <- list(none=NULL)
    if (!is.null(covariates))
        covariate.sets$all <- covariates

    if (is.numeric(winsorize.pct))  {
        msg(winsorize.pct, "- winsorizing the beta matrix.", verbose=verbose)
        beta <- winsorize(beta, pct=winsorize.pct)
    }

    too.hi <- too.lo <- NULL
    if (is.numeric(outlier.iqr.factor)) {
        q <- rowQuantiles(beta, probs = c(0.25, 0.75), na.rm = T)
        iqr <- q[,2] - q[,1]
        too.hi <- which(beta > q[,2] + outlier.iqr.factor * iqr, arr.ind=T)
        too.lo <- which(beta < q[,1] - outlier.iqr.factor * iqr, arr.ind=T)
        if (nrow(too.hi) > 0) beta[too.hi] <- NA
        if (nrow(too.lo) > 0) beta[too.lo] <- NA
    }

    if (isva || sva) {
        beta.sva <- beta

        autosomal.sites <- meffil.get.autosomal.sites(featureset)
        autosomal.sites <- intersect(autosomal.sites, rownames(beta.sva))
        if (length(autosomal.sites) < most.variable) {
          warning("Probes from the sex chromosomes will be used to calculate surrogate variables.")
        } else {
          beta.sva <- beta.sva[autosomal.sites,]
        }
        var.idx <- order(rowVars(beta.sva, na.rm=T), decreasing=T)[1:most.variable]
        beta.sva <- impute.matrix(beta.sva[var.idx,,drop=F])

        if (!is.null(covariates)) {
            cov.frame <- model.frame(~., data.frame(covariates, stringsAsFactors=F), na.action=na.pass)
            mod0 <- model.matrix(~., cov.frame)
        }
        else
            mod0 <- matrix(1, ncol=1, nrow=length(variable))
        mod <- cbind(mod0, variable)

        if (isva) {
            msg("ISVA.", verbose=verbose)
            set.seed(random.seed)
            isva.ret <- isva(beta.sva, mod, ncomp=n.sv, verbose=verbose)
            if (!is.null(covariates))
                covariate.sets$isva <- data.frame(covariates, isva.ret$isv, stringsAsFactors=F)
            else
                covariate.sets$isva <- as.data.frame(isva.ret$isv)
            cat("\n")
        }

        if (sva) {
            msg("SVA.", verbose=verbose)
            set.seed(random.seed)
            sva.ret <- sva(beta.sva, mod=mod, mod0=mod0, n.sv=n.sv)
            if (!is.null(covariates))
                covariate.sets$sva <- data.frame(covariates, sva.ret$sv, stringsAsFactors=F)
            else
                covariate.sets$sva <- as.data.frame(sva.ret$sv)
            cat("\n")
        }
    }

    analyses <- sapply(names(covariate.sets), function(name) {
        msg("EWAS for covariate set", name, verbose=verbose)
        covariates <- covariate.sets[[name]]
        ewas(variable,
             beta=beta,
             covariates=covariates,
             batch=batch,
             weights=weights,
             cell.counts=cell.counts,
             winsorize.pct=winsorize.pct,
             robust=robust,
             rlm=rlm)
    }, simplify=F)

    p.values <- sapply(analyses, function(analysis) analysis$table$p.value)
    coefficients <- sapply(analyses, function(analysis) analysis$table$coefficient)
    rownames(p.values) <- rownames(coefficients) <- rownames(analyses[[1]]$table)

    for (name in names(analyses)) {
        idx <- match(rownames(analyses[[name]]$table), features$name)
        analyses[[name]]$table$chromosome <- features$chromosome[idx]
        analyses[[name]]$table$position <- features$position[idx]
    }

    list(class="ewas",
         version=packageVersion("meffil"),
         samples=sample.idx,
         variable=original.variable[sample.idx],
         covariates=original.covariates[sample.idx,,drop=F],
         winsorize.pct=winsorize.pct,
         robust=robust,
         rlm=rlm,
         outlier.iqr.factor=outlier.iqr.factor,
         most.variable=most.variable,
         p.value=p.values,
         coefficient=coefficients,
         analyses=analyses,
         random.seed=random.seed,
         too.hi=too.hi,
         too.lo=too.lo)
}

is.ewas.object <- function(object)
    is.list(object) && "class" %in% names(object) && object$class == "ewas"

# Test associations between \code{variable} and each row of \code{beta}
# while adjusting for \code{covariates} (fixed effects) and \code{batch} (random effect).
# If \code{cell.counts} is not \code{NULL}, then it is assumed that
# the methylation data is derived from samples with two cell types.
# \code{cell.counts} should then be a vector of numbers
# between 0 and 1 of length equal to \code{variable} corresponding
# to the proportions of cell of a selected cell type in each sample.
# The regression model is then modified in order to identify
# associations specifically in the selected cell type (PMID: 24000956).
ewas <- function(variable, beta, covariates=NULL, batch=NULL, weights=NULL, cell.counts=NULL, winsorize.pct=0.05,
                 robust=TRUE, rlm=FALSE, verbose=F) {
    stopifnot(all(!is.na(variable)))
    stopifnot(length(variable) == ncol(beta))
    stopifnot(is.null(covariates) || nrow(covariates) == ncol(beta))
    stopifnot(is.null(batch) || length(batch) == ncol(beta))
    stopifnot(is.null(cell.counts)
              || length(cell.counts) == ncol(beta)
              && all(cell.counts >= 0 & cell.counts <= 1))

    method <- "ls"
    if (rlm) method <- "robust"

    if (is.null(covariates))
        design <- data.frame(intercept=1, variable=variable)
    else
        design <- data.frame(intercept=1, variable=variable, covariates)
    rownames(design) <- colnames(beta)

    if (!is.null(cell.counts)) {
        ## Irizarray method: Measuring cell-type specific differential methylation
        ##      in human brain tissue
        ## Mi is methylation level for sample i
        ## Xi is the value of the variable of interest for sample i
        ## pi is the proportion of the target cell type for sample i
        ## thus: Mi ~ target cell methylation * pi + other cell methylation * (1-pi)
        ## and target cell methylation = base target methylation + effect of Xi value
        ## and other cell methylation = base other methylation + effect of Xi value
        ## thus:
        ## Mi = (T + U Xi)pi + (O + P Xi)(1-pi) + e
        ##    = C + A Xi pi + B Xi (1-pi) + e
        design <- design[,-which(colnames(design) == "intercept")]

        design <- cbind(design * cell.counts,
                        typeB=design * (1-cell.counts))
    }

    msg("Linear regression with limma::lmFit", verbose=verbose)
    fit <- NULL
    batch.cor <- NULL
    if (!is.null(batch)) {
        msg("Adjusting for batch effect", verbose=verbose)
        corfit <- duplicateCorrelation(beta, design, block=batch, ndups=1)
        batch.cor <- corfit$consensus
        msg("Linear regression with batch as random effect", verbose=verbose)
        tryCatch(fit <- lmFit(beta, design, method=method, block=batch, cor=batch.cor, weights=weights),
                 error=function(e) {
                     print(e)
                     msg("lmFit failed with random effect batch variable, omitting", verbose=verbose)
                 })
    }
    if (is.null(fit)) {
        msg("Linear regression with only fixed effects", verbose=verbose)
        batch <- NULL
        fit <- lmFit(beta, design, method=method, weights=weights)
    }

    msg("Empirical Bayes", verbose=verbose)
    if (is.numeric(winsorize.pct) && robust) {
      fit.ebayes <- eBayes(fit, robust=T, winsor.tail.p=c(winsorize.pct, winsorize.pct))
    } else {
      fit.ebayes <- eBayes(fit, robust=robust)
    }

    alpha <- 0.975
    std.error <- (sqrt(fit.ebayes$s2.post) * fit.ebayes$stdev.unscaled[,"variable"])
    margin.error <- (std.error * qt(alpha, df=fit.ebayes$df.total))
    n <- rowSums(!is.na(beta))

    list(design=design,
         batch=batch,
         batch.cor=batch.cor,
         cell.counts=cell.counts,
         table=data.frame(p.value=fit.ebayes$p.value[,"variable"],
             fdr=p.adjust(fit.ebayes$p.value[,"variable"], "fdr"),
             p.holm=p.adjust(fit.ebayes$p.value[,"variable"], "holm"),
             t.statistic=fit.ebayes$t[,"variable"],
             coefficient=fit.ebayes$coefficient[,"variable"],
             coefficient.ci.high=fit.ebayes$coefficient[,"variable"] + margin.error,
             coefficient.ci.low=fit.ebayes$coefficient[,"variable"] - margin.error,
             coefficient.se=std.error,
             n=n))
}


#!/usr/bin/Rscript

# attempt to load a library implementing the Bradley-Terry model for inferring rankings based on
# comparisons; if it doesn't load, try to install it through R's in-language package management;
# otherwise, abort and warn the user
# https://www.jstatsoft.org/v48/i09/

# Add the repo to the R search path
options(repos = list(CRAN="http://cran.rstudio.com/"))

loaded <- library(BradleyTerry2, quietly=TRUE, logical.return=TRUE)
if (!loaded) { write("warning: R library 'BradleyTerry2' unavailable; attempting to install locally...", stderr())
              install.packages("BradleyTerry2")
              loadedAfterInstall <- library(BradleyTerry2, quietly=TRUE, logical.return=TRUE)
              if(!loadedAfterInstall) { write("error: 'BradleyTerry2' unavailable and cannot be installed. Aborting.", stderr()); quit() }
}
# similarly, but for the library to parse command line arguments:
loaded <- library(argparser, quietly=TRUE, logical.return=TRUE)
if (!loaded) { write("warning: R library 'argparser' unavailable; attempting to install locally...", stderr())
              install.packages("argparser")
              loadedAfterInstall <- library(argparser, quietly=TRUE, logical.return=TRUE)
              if(!loadedAfterInstall) { write("error: 'argparser' unavailable and cannot be installed. Aborting.", stderr()); quit() }
}
p <- arg_parser("sort a list using comparative rankings under the Bradley-Terry statistical model; see https://www.gwern.net/Resorter", name="resorter")
p <- add_argument(p, "--input", short="-i",
                  "input file: a CSV file of items to sort: one per line, with up to two columns. (eg both 'Akira\\n' and 'Akira, 10\\n' are valid).", type="character")
p <- add_argument(p, "--output", "output file: a file to write the final results to. Default: printing to stdout.")
p <- add_argument(p, "--verbose", "whether to print out intermediate statistics", flag=TRUE)
p <- add_argument(p, "--queries", short="-n", default=NA,
                  "Maximum number of questions to ask the user; defaults to N*log(N) comparisons. If already rated, 𝒪(n) is a good max, but the more items and more levels in the scale and more accuracy desired, the more comparisons are needed.")
p <- add_argument(p, "--levels", short="-l", default=5, "The highest level; rated items will be discretized into 1-l levels, so l=5 means items are bucketed into 5 levels: [1,2,3,4,5], etc")
p <- add_argument(p, "--quantiles", short="-q", "What fraction to allocate to each level; space-separated; overrides `--levels`. This allows making one level of ratings narrower (and more precise) than the others, at their expense; for example, one could make 3-star ratings rarer with quantiles like `--quantiles '0 0.25 0.8 1'`. Default: uniform distribution (1--5 → '0.0 0.2 0.4 0.6 0.8 1.0').")
p <- add_argument(p, "--no-scale", flag=TRUE, "Do not discretize/bucket the final estimated latent ratings into 1-l levels/ratings; print out inferred latent scores.")
p <- add_argument(p, "--progress", flag=TRUE, "Print out mean standard error of items")
argv <- parse_args(p)

# read in the data from either the specified file or stdin:
if(!is.na(argv$input)) { ranking <- read.csv(file=argv$input, stringsAsFactors=TRUE, header=FALSE); } else {
    ranking <- read.csv(file=file('stdin'), stringsAsFactors=TRUE, header=FALSE); }

# turns out noisy sorting is fairly doable in 𝒪(n * log(n)), so do that plus 1 to round up:
if (is.na(argv$queries)) { n <- nrow(ranking)
                           argv$queries <- round(n * log(n) + 1) }

# if user did not specify a second column of initial ratings, then put in a default of '1':
if(ncol(ranking)==1) { ranking$Rating <- 1; }
colnames(ranking) <- c("Media", "Rating")
# A set of ratings like 'foo,1\nbar,2' is not comparisons, though. We *could* throw out everything except the 'Media' column
# but we would like to accelerate the interactive querying process by exploiting the valuable data the user has given us.
# So we 'seed' the comparison dataset based on input data: higher rating means +1, lower means −1, same rating == tie (0.5 to both)
comparisons <- NULL
for (i in 1:(nrow(ranking)-1)) {
 rating1 <- ranking[i,]$Rating
 media1 <- ranking[i,]$Media
 rating2 <- ranking[i+1,]$Rating
 media2 <- ranking[i+1,]$Media
 if (rating1 == rating2)
  {
     comparisons <- rbind(comparisons, data.frame("Media.1"=media1, "Media.2"=media2, "win1"=0.5, "win2"=0.5))
  } else { if (rating1 > rating2)
           {
            comparisons <- rbind(comparisons, data.frame("Media.1"=media1, "Media.2"=media2, "win1"=1, "win2"=0))
            } else {
              comparisons <- rbind(comparisons, data.frame("Media.1"=media1, "Media.2"=media2, "win1"=0, "win2"=1))
                   } } }
# the use of '0.5' is recommended by the BT2 paper, despite causing quasi-spurious warnings:
# > In several of the data examples (e.g., `?CEMS`, `?springall`, `?sound.fields`), ties are handled by the crude but
# > simple device of adding half of a 'win' to the tally for each player involved; in each of the examples where this
# > has been done it is found that the result is similar, after a simple re-scaling, to the more sophisticated
# > analyses that have appeared in the literature. Note that this device when used with `BTm` typically gives rise to
# > warnings produced by the back-end glm function, about non-integer 'binomial' counts; such warnings are of no
# > consequence and can be safely ignored. It is likely that a future version of `BradleyTerry2` will have a more
# > general method for handling ties.
suppressWarnings(priorRankings <- BTm(cbind(win1, win2), Media.1, Media.2, data = comparisons))

if(argv$verbose) {
  print("higher=better:")
  print(summary(priorRankings))
  print(sort(BTabilities(priorRankings)[,1]))
}

set.seed(2015-09-10)
cat("Comparison commands: 1=yes, 2=tied, 3=second is better, p=print estimates, s=skip, q=quit\n")
for (i in 1:argv$queries) {

 # with the current data, calculate and extract the new estimates:
 suppressWarnings(updatedRankings <- BTm(cbind(win1, win2), Media.1, Media.2, br=TRUE, data = comparisons))
 coefficients <- BTabilities(updatedRankings)
 # sort by latent variable 'ability':
 coefficients <- coefficients[order(coefficients[,1]),]

 if(argv$verbose) { print(i); print(coefficients); }

 # select two media to compare: pick the media with the highest standard error and the media above or below it with the highest standard error:
 # which is a heuristic for the most informative pairwise comparison. BT2 appears to get caught in some sort of a fixed point with greedy selection,
 # so every few rounds pick a random starting point:
 media1N <- if (i %% 3 == 0) { which.max(coefficients[,2]) } else { sample.int(nrow(coefficients), 1) }
 media2N <- if (media1N == nrow(coefficients)) { nrow(coefficients)-1; } else { # if at the top & 1st place, must compare to 2nd place
   if (media1N == 1) { 2; } else { # if at the bottom/last place, must compare to 2nd-to-last
    # if neither at bottom nor top, then there are two choices, above & below, and we want the one with highest SE; if equal, arbitrarily choose the better:
    if ( (coefficients[,2][media1N+1]) > (coefficients[,2][media1N-1])  ) { media1N+1 } else { media1N-1 } } }

 targets <- row.names(coefficients)
 media1 <- targets[media1N]
 media2 <- targets[media2N]

 if (argv$`progress`) { cat(paste0("Mean stderr: ", round(mean(coefficients[,2]))), " | "); }
 cat(paste0("Is '", as.character(media1), "' greater than '", as.character(media2), "'? "))
 rating <- scan("stdin", character(), n=1, quiet=TRUE)

 switch(rating,
        "1" = { comparisons <- rbind(comparisons, data.frame("Media.1"=media1, "Media.2"=media2, "win1"=1, "win2"=0)) },
        "3" = { comparisons <- rbind(comparisons, data.frame("Media.1"=media1, "Media.2"=media2, "win1"=0, "win2"=1)) },
        "2" = { comparisons <- rbind(comparisons, data.frame("Media.1"=media1, "Media.2"=media2, "win1"=0.5, "win2"=0.5))},
        "p" = { estimates <- data.frame(Media=row.names(coefficients), Estimate=coefficients[,1], SE=coefficients[,2]);
                print(comparisons)
                print(warnings())
                print(summary(updatedRankings))
                print(estimates[order(estimates$Estimate),], row.names=FALSE) },
        "s" = {},
        "q" = { break; }
        )
}

# results of all the questioning:
if(argv$verbose) { print(comparisons); }

suppressWarnings(updatedRankings <- BTm(cbind(win1, win2), Media.1, Media.2, ~ Media, id = "Media", data = comparisons))
coefficients <- BTabilities(updatedRankings)
if(argv$verbose) { print(rownames(coefficients)[which.max(coefficients[2,])]);
                 print(summary(updatedRankings))
                 print(sort(coefficients[,1])) }

ranking2 <- as.data.frame(BTabilities(updatedRankings))
ranking2$Media <- rownames(ranking2)
rownames(ranking2) <- NULL

if(!(argv$`no_scale`)) {

    # if the user specified a bunch of buckets using `--quantiles`, parse it and use it,
    # otherwise, take `--levels` and make a uniform distribution
    quantiles <- if (!is.na(argv$quantiles)) { (sapply(strsplit(argv$quantiles, " "), as.numeric))[,1]; } else {
      seq(0, 1, length.out=(argv$levels+1)); }
    ranking2$Quantile <- with(ranking2, cut(ability,
                                    breaks=quantile(ability, probs=quantiles),
                                    labels=1:(length(quantiles)-1),
                                    include.lowest=TRUE))
    df <- subset(ranking2[order(ranking2$Quantile, decreasing=TRUE),], select=c("Media", "Quantile"));
    if (!is.na(argv$output)) { write.csv(df, file=argv$output, row.names=FALSE) } else { print(df); }
} else { # return just the latent continuous scores:
         df <- data.frame(Media=rownames(coefficients), Estimate=coefficients[,1]);
         if (!is.na(argv$output)) { write.csv(df[order(df$Estimate, decreasing=TRUE),], file=argv$output, row.names=FALSE); } else {
             print(finalReport); }
       }

cat("\nResorting complete")


#setwd("D:/Dropbox/Data analyze/Rdocuments/datas")
library(xlsx)
 library(RColorBrewer)

 #读取数据
#k1<-read.xlsx("t_for.xls", sheetName = "0.2", header = TRUE)
#k2<-read.xlsx("t_for.xls", sheetName = "0.3", header = TRUE)
#k3<-read.xlsx("t_for.xls", sheetName = "0.4", header = TRUE)
#k4<-read.xlsx("t_for.xls", sheetName = "0.5", header = TRUE)
fv<-5:3500

q<-c(2.5e-14, 4.5e-13, 9e-13, 3e-12) #不同的流量下

k<-c(0.8,0.7,0.6,0.5) #不同占空比下无电场时间比例，即1-k_i

v<-4.66e-13  #泰勒锥的体积总量

#jpeg(file="figure2.jpg")

par(mfrow=c(2,2), mar=c(4,2,2,2), oma=c(2,4,2,2))

mycolors<-c("red", "blue", "darkgreen", "yellow3")

c1<- 0.2 * 4.66e-13 #弯月面体积，用以标识体积增量占泰勒锥体积的大小
#c2<- 0.1 * 4.66e-13
#c3<- 0.05 * 4.66e-13
#c4<-0.4 * 4.66e-13
#c5<- 0.6 * 4.66e-13
c<-4.66e-13  #泰勒锥体积

#####占空比为0.2时######
plot(fv, (k[1]*q[1]/fv+v), col=mycolors[1], log="x", type="l", xlab = expression(log(italic(f["v"])) (Hz)), ylab = expression(italic(volume["increase"](m^3))), main="k=0.2", lwd=2.5, ylim=c(4e-13, 10e-13))#y轴的边界，在不同的占空比k下应该相差不大，最大应该是V_m的2倍，即10e-13左右

for (i in 1:3){
lines(fv,  (k[1]*q[i+1]/fv+v), lwd=2.5, col=mycolors[i+1] )
}
title("k=0.2")
legend("topright", c("1.5nl/min","27nl/min","54nl/min","180nl/min"), inset=0.02, col=mycolors, lwd=2.5, lty=1, cex=1.1, bty="n")

abline(h=c, col="red", lty=2, lwd=2)
abline(h=1.2*c, col="blue", lty=2, lwd=2)
abline(h=1.5*c, col="darkgreen",lty=2, lwd=2)

#text(50, 2.5e-14, "5% V_M,red", col="blue", cex=1.2, font=2)
#text(50, 4e-14, "10% V_M,blue", col="blue", cex=1.2, font=2)

#####占空比k=0.3######
plot(fv, (k[2]*q[1]/fv+v), col=mycolors[1], log="x", type="l", xlab = expression(log(italic(f["v"])) (Hz)), ylab = expression(italic(volume["increase"](m^3))), main="k=0.3", lwd=2.5, ylim=c(4e-13, 10e-13))

for (i in 1:3){
lines(fv,  (k[2]*q[i+1]/fv+v), lwd=2.5, col=mycolors[i+1] )
}
title("k=0.3")
legend("topright",  c("1.5nl/min","27nl/min","54nl/min","180nl/min"), inset=0.02, col=mycolors, lwd=2.5, lty=1, cex=1.1, bty="n")

abline(h=c, col="red", lty=2, lwd=2)
abline(h=1.2*c, col="blue", lty=2, lwd=2)
abline(h=1.5*c, col="darkgreen",lty=2, lwd=2)

#text(50, 1.8e-13, "20% V_M,green", col="blue", cex=1.2, font=2)
#text(50, 1.2e-13, "10% V_M,blue", col="blue", cex=1.2, font=2)
#text(50, 0.75e-14, "5% V_M,red", col="blue", cex=1.2, font=2)

#####占空比k=0.4######
plot(fv, (k[3]*q[1]/fv+v), col=mycolors[1], log="x", type="l", xlab = expression(log(italic(f["v"])) (Hz)), ylab = expression(italic(volume["increase"](m^3))), main="k=0.4", lwd=2.5 , ylim=c(4e-13, 10e-13))

for (i in 1:3){
lines(fv,  (k[3]*q[i+1]/fv+v), lwd=2.5, col=mycolors[i+1] )
}
title("k=0.4")
legend("topright",  c("1.5nl/min","27nl/min","54nl/min","180nl/min"), inset=0.02, col=mycolors, lwd=2.5, lty=1, cex=1.1, bty="n")

abline(h=c, col="red", lty=2, lwd=2)
abline(h=1.2*c, col="blue", lty=2, lwd=2)
abline(h=1.5*c, col="darkgreen",lty=2, lwd=2)

#text(50, 5e-13, "20% V_M, green", col="blue", cex=1.2, font=2)
#text(50, 4e-13, "10% V_M, blue", col="blue", cex=1.2, font=2)
#text(50, 3e-13, "5% V_M, red", col="blue", cex=1.2, font=2)

#####占空比k=0.5######
plot(fv, (k[4]*q[1]/fv+v), col=mycolors[1], log="x", type="l", xlab = expression(log(italic(f["v"])) (Hz)), ylab = expression(italic(volume["increase"](m^3))), main="k=0.5", lwd=2.5 , ylim=c(4e-13, 10e-13))

for (i in 1:3){
lines(fv, (k[4]*q[i+1]/fv+v), lwd=2.5, col=mycolors[i+1] )
}
title("k=0.5")
legend("topright",  c("1.5nl/min","27nl/min","54nl/min","180nl/min"), inset=0.02, col=mycolors, lwd=2.5, lty=1, cex=1.1, bty="n")

abline(h=c, col="red", lty=2, lwd=2)
abline(h=1.2*c, col="blue", lty=2, lwd=2)
abline(h=1.5*c, col="darkgreen",lty=2, lwd=2)

#text(50, 1.6e-12, "60% V_M,yellow", col="blue", cex=1.2, font=2)
#text(50, 1.2e-12, "50% V_M,green", col="blue", cex=1.2, font=2)
#text(50, 0.8e-12, "20% V_M, blue", col="blue", cex=1.2, font=2)
#text(50, 0.5e-12, "5% V_M, red", col="blue", cex=1.2, font=2)

#dev.off()