cAIC4/0000755000176200001440000000000014773621532011107 5ustar liggesuserscAIC4/MD50000644000176200001440000000440114773621532011416 0ustar liggesusers26d75c6b068b8aef5b89389e3ad5f0c2 *DESCRIPTION 7c70d8077840721e189231b84d860b24 *NAMESPACE 72fdfa6e182b709eb1467ffaea117175 *R/bcMer.R ab9b63b9f682cbc6159520ecd21033e5 *R/biasCorrectionBernoulli.R 14f8fa0c7440109bee4b0ccf1c7446ba *R/biasCorrectionGaussian.R d3db7769501791811db8b88f8a184cb8 *R/biasCorrectionPoisson.R 41ee280dbd196559b1a93f0c244dfe36 *R/cAIC.R 449cd5531c99cefaf0acbff6b4e18b6e *R/calculateGaussianBc.R 5faacee6a5e322ce0a91eb33bfc26384 *R/cnms2formula.R cd8405a10a2df3ed4efe0813ecb3e1c2 *R/conditionalBootstrap.R 194e2eb5ed2d244a961a94b106d0e887 *R/datasets.R babcdfb3ba91a37e11ad4b135822ee10 *R/deleteZeroComponents.R 040e9ac5ae6f47841df3ff0e13398d20 *R/getModelComponents.R 781a4f4e7f1defca70204cb28de46ed6 *R/getWeights.R 43ec94ece686fb950fcfa8ac25d75b2d *R/getcondLL.R ac61a0cd3c314a766af239ccefa96e5e *R/helperfuns_lme.R 1ced7665be026bdcac51b542fd9954ae *R/helperfuns_stepcAIC.R 66d2111ebb358dd47d1ff6366f0dc5cc *R/methods.R 53cc109f5794bdc3131638ff0cd2b789 *R/modelAvg.R b9e215983f80b98d6a839a2fff5e48e9 *R/predictMA.R ece0220dc11b4d69e61a90f2407d668f *R/stepcAIC.R 6d11d5a21af51153b5c8f329887f3da3 *R/summaryMA.R 5ccb080f0a40b5db62bfcea3988eb0f4 *R/weightOptim.R e359fa076f065894bb21d809ae76947d *build/partial.rdb da1dfda39466d076694af799d95ebc9a *data/Zambia.RData 5cbd836e100488674ffeec6acf25232e *data/guWahbaData.rda 59b65b186a1e9d48b7fc075590723fc2 *inst/CITATION 5ca02868f8a62793e1ac82d3bd46b6b3 *man/Zambia.Rd 1df2b7ff42beb49433bbe17ba814b6f1 *man/anocAIC.Rd 567dd6a9e58de31e1ab93c0f221ad922 *man/cAIC.Rd 96be7a6081541e0cc41e2948e17a43c1 *man/cAIC4-package.Rd 44684e659ad43fde7204861efd61606f *man/deleteZeroComponents.Rd fcdd51f00f6f02315c885a61db230473 *man/family.lme.Rd e2ec8df8f31586cfcdb92799c37ae452 *man/getModelComponents.Rd c8f716c956cd0fb4b913bf6571a00538 *man/getModelComponents.lme.Rd e7bf3dd158caf97a5b5c82cbf4cbda40 *man/getModelComponents.merMod.Rd c9a13437794393484cb3c7410018d534 *man/getWeights.Rd 6fa64465cde6cf2283734e8a6727a89e *man/getcondLL.Rd ae827575eb9bf990a65c9a7487868dcb *man/guWahbaData.Rd 6071b6c586ad8f3ec6b92db93a929a10 *man/modelAvg.Rd d05bfd05e99a802aac36374fd2002cce *man/predictMA.Rd 0db3a9d3d0d41d05a9b1a88630043670 *man/print.cAIC.Rd 379198cfef49a762b90d01b2002cbc81 *man/stepcAIC.Rd 7512573ee142876dba61078612f336ef *man/summaryMA.Rd cAIC4/R/0000755000176200001440000000000014773602310011301 5ustar liggesuserscAIC4/R/cAIC.R0000644000176200001440000002761614773613666012217 0ustar liggesusers#' Conditional Akaike Information for 'lme4' and 'lme' #' #' Estimates the conditional Akaike information for models that were fitted in #' 'lme4' or with 'lme'. Currently all distributions are supported for 'lme4' models, #' based on parametric conditional bootstrap. #' For the Gaussian distribution (from a \code{\link[lme4]{lmer}} or \code{\link[nlme]{lme}} #' call) and the Poisson distribution analytical estimators for the degrees of #' freedom are available, based on Stein type formulas. Also the conditional #' Akaike information for generalized additive models based on a fit via the #' 'gamm4' or \code{\link[mgcv]{gamm}} calls from the 'mgcv' package can be estimated. #' A hands-on tutorial for the package can be found at \url{https://arxiv.org/abs/1803.05664}. #' #' @param object An object of class merMod either fitted by #' \code{\link[lme4]{lmer}} or \code{\link[lme4]{glmer}} of the lme4-package #' or an \code{\link[nlme]{lme}} object fro the nlme-package. #' Also objects returned form a \code{\link[gamm4]{gamm4}} call are possible. #' @param method Either \code{"conditionalBootstrap"} for the estimation of the #' degrees of freedom with the help of conditional Bootstrap or #' \code{"steinian"} for analytical representations based on Stein type #' formulas. The default is \code{NULL}. In this case the method is choosen #' automatically based on the \code{family} argument of the #' \code{(g)lmer}-object. For \code{"gaussian"}, \code{"poisson"} and \code{"binomial"} (in the Bernoulli case, i.e. only two outcomes) this is #' the Steinian type estimator, for all others it is the conditional Bootstrap. #' For models from the nlme package, only \code{\link[nlme]{lme}} objects, i.e., #' with gaussian response are supported. #' @param B Number of Bootstrap replications. The default is \code{NULL}. Then #' B is the minimum of 100 and the length of the response vector. #' @param sigma.penalty An integer value for additional penalization in the analytic #' Gaussian calculation to account for estimated variance components in the residual (co-)variance. #' Per default \code{sigma.penalty} is equal \code{1}, corresponding to a diagonal error #' covariance matrix with only one estimated parameter (sigma). If #' all variance components are known, the value should be set to \code{0}. #' For individual weights (individual variances), this value should be set #' to the number of estimated weights. For \code{\link[nlme]{lme}} objects #' the penalty term is automatically set by extracting the number of estimated #' variance components. #' @param analytic FALSE if the numeric hessian of the (restricted) marginal #' log-likelihood from the lmer optimization procedure should be used. #' Otherwise (default) TRUE, i.e. use a analytical version that has to be #' computed. Only used for the analytical version of Gaussian responses. #' @return A \code{cAIC} object, which is a list consisting of: #' 1. the conditional log likelihood, i.e. the log likelihood with the random #' effects as penalized parameters; 2. the estimated degrees of freedom; #' 3. a list element that is either \code{NULL} #' if no new model was fitted otherwise the new (reduced) model, see details; #' 4. a boolean variable indicating whether a new model was fitted or not; 5. #' the estimator of the conditional Akaike information, i.e. minus twice the #' log likelihood plus twice the degrees of freedom. #' @section WARNINGS : Currently the cAIC can only be estimated for #' \code{family} equal to \code{"gaussian"}, \code{"poisson"} and #' \code{"binomial"}. Neither negative binomial nor gamma distributed responses #' are available. #' Weighted Gaussian models are not yet implemented. #' #' @details #' For \code{method = "steinian"} and an object of class \code{merMod} computed #' the analytic representation of the corrected conditional AIC in Greven and #' Kneib (2010). This is based on a the Stein formula and uses implicit #' differentiation to calculate the derivative of the random effects covariance #' parameters w.r.t. the data. The code is adapted form the one provided in #' the supplementary material of the paper by Greven and Kneib (2010). The #' supplied \code{\link[lme4]{merMod}} model needs to be checked if a random #' effects covariance parameter has an optimum on the boundary, i.e. is zero. #' And if so the model needs to be refitted with the according random effect #' terms omitted. This is also done by the function and the refitted model is #' also returned. Notice that the \code{boundary.tol} argument in #' \code{\link[lme4]{lmerControl}} has an impact on whether a parameter is #' estimated to lie on the boundary of the parameter space. For estimated error #' variance the degrees of freedom are increased by one per default. #' \code{sigma.penalty} can be set manually for \code{\link[lme4]{merMod}} models #' if no (0) or more than one variance component (>1) has been estimated. For #' \code{\link[nlme]{lme}} objects this value is automatically defined. #' #' If the object is of class \code{\link[lme4]{merMod}} and has \code{family = #' "poisson"} there is also an analytic representation of the conditional AIC #' based on the Chen-Stein formula, see for instance Saefken et. al (2014). For #' the calculation the model needs to be refitted for each observed response #' variable minus the number of response variables that are exactly zero. The #' calculation therefore takes longer then for models with Gaussian responses. #' Due to the speed and stability of 'lme4' this is still possible, also for #' larger datasets. #' #' If the model has Bernoulli distributed responses and \code{method = #' "steinian"}, \code{\link{cAIC}} calculates the degrees of freedom based on a #' proposed estimator by Efron (2004). This estimator is asymptotically #' unbiased if the estimated conditional mean is consistent. The calculation #' needs as many model refits as there are data points. #' #' Another more general method for the estimation of the degrees of freedom is #' the conditional bootstrap. This is proposed in Efron (2004). For the B #' boostrap samples the degrees of freedom are estimated by \deqn{\frac{1}{B - #' 1}\sum_{i=1}^n\theta_i(z_i)(z_i-\bar{z}),} where \eqn{\theta_i(z_i)} is the #' i-th element of the estimated natural parameter. #' #' For models with no random effects, i.e. (g)lms, the \code{\link{cAIC}} #' function returns the AIC of the model with scale parameter estimated by REML. #' #' @author Benjamin Saefken, David Ruegamer #' @seealso \code{\link[lme4]{lme4-package}}, \code{\link[lme4]{lmer}}, #' \code{\link[lme4]{glmer}} #' @references #' Saefken, B., Ruegamer, D., Kneib, T. and Greven, S. (2021): #' Conditional Model Selection in Mixed-Effects Models with cAIC4. #' #' #' Saefken, B., Kneib T., van Waveren C.-S. and Greven, S. (2014) A #' unifying approach to the estimation of the conditional Akaike information in #' generalized linear mixed models. Electronic Journal Statistics Vol. 8, #' 201-225. #' #' Greven, S. and Kneib T. (2010) On the behaviour of marginal and conditional #' AIC in linear mixed models. Biometrika 97(4), 773-789. #' #' Efron , B. (2004) The estimation of prediction error. J. Amer. Statist. Ass. #' 99(467), 619-632. #' @keywords regression #' @export #' @import lme4 Matrix methods RLRsim mvtnorm #' @importFrom stats terms.formula na.omit #' @importFrom stats gaussian printCoefmat residuals #' @importFrom utils capture.output #' @importFrom stats family #' @rawNamespace #' if(getRversion() >= "3.3.0") { #' importFrom("stats", sigma) #' } else { #' importFrom("lme4", sigma) #' } #' @examples #' #' ### Three application examples #' b <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy) #' cAIC(b) #' #' b2 <- lmer(Reaction ~ (1 | Days) + (1 | Subject), sleepstudy) #' cAIC(b2) #' #' b2ML <- lmer(Reaction ~ (1 + Days | Subject), sleepstudy, REML = FALSE) #' cAIC(b2ML) #' #' ### Demonstration of boundary case #' \dontrun{ #' set.seed(2017-1-1) #' n <- 50 #' beta <- 2 #' x <- rnorm(n) #' eta <- x*beta #' id <- gl(5,10) #' epsvar <- 1 #' data <- data.frame(x = x, id = id) #' y_wo_bi <- eta + rnorm(n, 0, sd = epsvar) #' #' # use a very small RE variance #' ranvar <- 0.05 #' nrExperiments <- 100 #' #' sim <- sapply(1:nrExperiments, function(j){ #' #' b_i <- scale(rnorm(5, 0, ranvar), scale = FALSE) #' y <- y_wo_bi + model.matrix(~ -1 + id) %*% b_i #' data$y <- y #' #' mixedmod <- lmer(y ~ x + (1 | id), data = data) #' linmod <- lm(y ~ x, data = data) #' #' c(cAIC(mixedmod)$caic, cAIC(linmod)$caic) #' }) #' #' rownames(sim) <- c("mixed model", "linear model") #' #' boxplot(t(sim)) #' #' #' } #' #' #' cAIC <- function(object, method = NULL, B = NULL, sigma.penalty = 1, analytic = TRUE) { if (any(names(object) == "mer")) { object <- object$mer object@optinfo$gamm4 <- TRUE # add indicator for gamm4 } if (any(class(object) %in% "gamm")) { attr(object$lme, "smooth_names") <- get_names(object) # old names attr(object$lme, "is_gamm") <- TRUE # add indicator for mgcv::gamm attr(object$lme, "gam_form") <- formula(object$gam) # for refit object <- object$lme attr(object, "ordered_smooth") <- sort_sterms(object) # names as in gamm4 } if (any(class(object) %in% "lme")) { sigma.penalty <- count_par(object) if (!any(object$dims$ngrps > 1)) stop("No grouping structure specified.") if (is.null(attr(object, "is_gamm"))) attr(object, "is_gamm") <- FALSE } ### START: calculation for GLMs and LMs if (any(class(object) %in% c("glm","lm")) & !("gam" %in% class(object))) { y <- object$y if(is.null(y)) y <- with(eval(object$call$data, environment(formula(object))), eval(formula(object)[[2]])) if(is.null(y)) stop("Please specify the data argument in the initial model call!") # remove NAs y <- na.omit(y) n <- length(y) mu <- predict(object,type="response") p <- object$rank sigma <- ifelse("glm" %in% class(object), sqrt(summary(object)$dispersion), summary(object)$sigma * sqrt((n-p) / n)) switch(family(object)$family, binomial = { cll <- sum(dbinom(x = y, size = length(unique(y)) - 1, prob = mu, log = TRUE)) }, poisson = { cll <- sum(dpois(x = y, lambda = mu, log = TRUE)) }, gaussian = { cll <- sum(dnorm(x = y, mean = mu, sd = sigma, log = TRUE)) }, { cat("For this family no bias correction is currently available \n") cll <- NA }) retobj <- list(loglikelihood = as.numeric(cll), df = object$rank + 1, reducedModel = NA, new = FALSE, caic = -2 * as.numeric(cll) + 2 * (object$rank + 1)) class(retobj) <- c("cAIC") return(retobj) } ### END: calculation for GLMs and LMs if (!inherits(object, c("lmerMod", "glmerMod", "lme"))) { stop("Class of object is not supported.") } if (!inherits(object, "lme") && family(object)$family == "binomial" && length(unique(getME(object, "y"))) > 2) { warning("Method not yet supplied for binomial data with n larger 2. Therefore the conditional parametric bootstrap is returned") method <- "conditionalBootstrap" } dfList <- bcMer(object , method = method, B = B, sigma.penalty = sigma.penalty, analytic = analytic) if (mode(dfList) == "list") { bc <- dfList$bc newModel <- dfList$newModel new <- dfList$new } else { bc <- dfList newModel <- NULL new <- FALSE } if(new) cll <- getcondLL(newModel) else cll <- getcondLL(object) caic <- - 2 * cll + 2 * bc retobj <- list(loglikelihood = cll, df = bc, reducedModel = newModel, new = new, caic = caic) class(retobj) <- c("cAIC") return(retobj) } cAIC4/R/calculateGaussianBc.R0000644000176200001440000000512714773602310015326 0ustar liggesuserscalculateGaussianBc <- function(model, sigma.penalty, analytic) { # A function that calculates the analytic representation of the bias # corrections in linear mixed models, see Greven & Kneib (2010). # # Args: # model = From getAllModelComponents() # sigma.penalty = Number of estimated variance components in the residual error covariance # analytic = FALSE if the numeric hessian of the (restricted) marginal log- # likelihood from the lmer optimization procedure should be used. # Otherwise (default) TRUE, i.e. use a analytical version that # has to be computed. # # Returns: # df = Bias correction (i.e. degrees of freedom) for a linear mixed model. # C <- model$C B <- model$B e <- model$e A <- model$A if(!is.null(model$R)){ RA <- model$R%*%A }else{ RA <- A } tye <- model$tye V0inv <- model$V0inv if(analytic) { WAlist <- lapply(model$Wlist, function(w) { if(!model$isREML) return(w %*% V0inv) else return(w %*% A) }) for (j in 1:length(model$theta)) { Wj <- model$Wlist[[j]] eWje <- model$eWelist[[j]] C[j, ] <- as.vector((e %*% Wj) %*% A - eWje * e/(2 * tye)) for (k in j:length(model$theta)) { Wk <- model$Wlist[[k]] WkAWjA <- sum(t(WAlist[[j]]) * WAlist[[k]]) eWke <- model$eWelist[[k]] if (!model$isREML) { B[j, k] <- B[k, j] <- - tye * WkAWjA/(2 * model$n) - eWje * eWke/(2 * tye) + as.numeric(e %*% Wk %*% (A %*% (Wj %*% e))) } else { B[j, k] <- B[k, j] <- - tye * WkAWjA/(2*(model$n - ncol(model$X))) - eWje * eWke/(2 * tye) + as.numeric(e %*% Wk %*% (A %*% (Wj %*% e))) } } } } else { if (!model$isREML) { np <- model$n } else { np <- model$n - ncol(model$X) } for (j in 1:length(model$theta)) { Wj <- model$Wlist[[j]] eWje <- model$eWelist[[j]] C[j, ] <- 2 * np / tye * as.vector((e %*% Wj) %*% A - eWje * e/tye) } } Lambday <- try(solve(B) %*% C) if(class(Lambday)[1]=="try-error"){ Rchol <- try(chol(B)) L1 <- backsolve(Rchol, C, transpose = TRUE) Lambday <- backsolve(Rchol, L1) } df <- model$n - sum(diag(RA)) for (j in 1:length(model$theta)) { df <- df + sum(Lambday[j,] %*% (RA %*% (model$Wlist[[j]] %*% e))) } if (sigma.penalty) { df <- df + sigma.penalty } return(df) } cAIC4/R/helperfuns_stepcAIC.R0000644000176200001440000007451414773614023015331 0ustar liggesusers####################################################################################### ### allCombn functions ### purpose: allCombn <- function(x,simplify=F) { m <- length(x)-1 unlist(lapply(X=1:m,function(i)combn(x,i,simplify=simplify)),recursive=F) } allCombn2 <- function(x,range,simplify=F) { unlist(lapply(X=2:range,function(i)combn(x,i,simplify=simplify)),recursive=F) } ####################################################################################### ### backwardGam function ### purpose: reduce complexity of gamm4 model backwardGam <- function(intGam, keep) { # intGam result of interpret.gam - call / $gamPart of getComponents-result vars <- intGam$fake.names sTerm <- vars%in%sapply(intGam$smooth.spec,function(x)x$term) nonS <- maybeNonS <- vars[!sTerm] addNonS <- addSlabs <- NULL haveS <- replaceHaveS <- vars[sTerm] # should be at least of length = 1 , # else a (g)lmer should be fitted sLabs <- maybeSlabs <- makeS(intGam) # handle keep if(!is.null(keep)){ keep <- mgcv::interpret.gam(keep) keepVars <- keep$fake.names keepSterm <- keepVars%in%sapply(keep$smooth.spec,function(x)x$term) keepNonS <- keepVars[!keepSterm] keepHaveS <- keepVars[keepSterm] # prevent keepNonS variables to be excluded keepTermNonS <- nonS%in%keepNonS maybeNonS <- nonS[!keepTermNonS] addNonS <- nonS[keepTermNonS] # prevent keepHaveS variables to be excluded keepTermHaveS <- haveS%in%keepHaveS maybeSlabs <- sLabs[!keepTermHaveS] addSlabs <- sLabs[keepTermHaveS] replaceHaveS <- haveS[!keepTermHaveS] } returnList <- NULL # create list for dropping linear term if(length(maybeNonS)>0) returnList <- lapply(combn(maybeNonS,length(maybeNonS)-1,simplify=F), function(x)append(x,c(sLabs,addNonS))) if(length(maybeSlabs)>0){ for(i in 1:length(maybeSlabs)){ temp <- maybeSlabs temp[i] <- replaceHaveS[i] returnList <- append(returnList,list(c(temp,addSlabs,nonS))) } } returnList } ####################################################################################### ### backwardStep function ### purpose: reduce complexity of model backwardStep <- function(cnms, keep, allowCorrelationSel, allowNoIntercept) { if( (sum(sapply(cnms,length))==1# & !isGam ) ){ if(!is.null(keep)){ retList <- vector("list",1) retList[[1]] <- cnms return(retList) }else{ return(NA) } } cnms2 <- rep(cnms,sapply(cnms,length)) listCnms <- split(cnms2,names(cnms2)) if(!is.null(keep)){ keep <- interpret.random(keep) for(i in 1:length(listCnms)){ if(names(listCnms)[i]%in%names(keep)){ temp <- listCnms[[names(listCnms)[i]]] indRem <- unlist(temp)!=unlist(keep) listCnms[[names(listCnms)[i]]] <- temp[indRem] } } } newCnms <- lapply(listCnms,function(d){ if(length(d)<=1){ # if(names(d)%in%names(keep)){ # keep[names(d)] # }else{ list(NA) # } }else{ for(i in 1:length(d)){ d[[i]] <- d[[i]][-i] } # if(names(d)%in%names(keep)){ # append(d,keep[names(d)]) # }else{ d # } } }) if(!is.null(keep)){ for(n in names(keep)){ if(is.na(newCnms[[n]])){ newCnms[[n]] <- keep[n] }else{ newCnms[[n]] <- append(newCnms[[n]],keep[n]) } } } newCnms <- unlist(newCnms,recursive=FALSE) # problematic: variables with dots in name... names(newCnms) <- gsub("\\..*","",names(newCnms)) listOfAllCombs <- vector("list",length(newCnms)) for(i in 1:length(newCnms)){ accessREi <- names(newCnms)[i] listOfAllCombs[[i]] <- append(cnms[names(cnms)!=accessREi],newCnms[i]) } notempty <- sapply(listOfAllCombs, function(x) length(x[[1]])>0) listOfAllCombs <- listOfAllCombs[notempty] newCnms <- newCnms[notempty] listOfAllCombs <- suppressWarnings(split(unlist(listOfAllCombs,recursive=FALSE), rep(1:length(newCnms),each=length(cnms)))) listOfAllCombs <- lapply(listOfAllCombs,checkREs) listOfAllCombs <- listOfAllCombs[sapply(listOfAllCombs,function(r)!is.null(r))] listOfAllCombs <- lapply(listOfAllCombs,function(t)t[order(names(t))]) listOfAllCombs <- listOfAllCombs[!(duplicated(listOfAllCombs) & duplicated(lapply(listOfAllCombs,names)))] # listOfAllCombs <- listOfAllCombs[ # which(sapply(listOfAllCombs,function(l) # !is.logical(all.equal(l[order(names(l))], # cnms[order(names(cnms))])) # )) # ] if(!allowCorrelationSel) listOfAllCombs <- removeUncor(listOfAllCombs) if(!allowNoIntercept) listOfAllCombs <- removeNoInt(listOfAllCombs) return(listOfAllCombs) } ####################################################################################### ### calculateAllCAICs function ### purpose: computes cAIC for all given models calculateAllCAICs <- function(newSetup, # gamPos, modelInit, numCores, data, calcNonOptimMod, nrmods, ...) { # if(is.null(newSetup$sPart)) isGam <- FALSE formulaList <- lapply(newSetup,function(x)makeFormula(x,modelInit)) ### create all possible models ### listOfModels <- mclapply(formulaList, function(f) makeUpdate(modelInit=modelInit, setup=f, data=data), mc.cores=numCores) ####################################################################### ################### calculate alle the cAICs ########################## ####################################################################### listOfCAICs <- mclapply(listOfModels,function(m){ # if(any(class(m)%in%c("glm","lm"))){ # # ll <- getGLMll(m) # bc <- attr(logLik(m),"df") # caic <- -2*ll + 2*bc # c(ll,bc,caic) # # }else{ if(length(class(m))==1 && inherits(m,"list")){ # m is a gamm4 object tryCatch(cAIC(m,...)[c("loglikelihood","df","caic", "new")], error = function(e){ ret <- c(NA,NA,NA,NA) attr(ret, "message") <- e return(ret) }) }else{ if(!calcNonOptimMod){ errCode <- m@optinfo$conv$lme4$code if(!is.null(errCode)) return(c(NA,NA,NA)) } tryCatch(cAIC(m,...)[c("loglikelihood","df","caic","new")], error = function(e){ ret <- c(NA,NA,NA) attr(ret, "message") <- e return(ret) }) } # } }, mc.cores=numCores) if(all(sapply(listOfCAICs, function(x) is.na(sum(unlist(x)))))) { listOfCAICs$message <- attr(listOfCAICs[[1]],"message") return(listOfCAICs) } # if(all(sapply(listOfCAICs, is.list)) # all(sapply(listOfCAICs, function(x) !is.null(x$message)))) # return(listOfCAICs) else listOfCAICs <- lapply(listOfCAICs,unlist) ####################################################################### ################ list all the cAICs and models ######################## ####################################################################### aicTab <- as.data.frame(as.matrix(do.call("rbind",listOfCAICs))) colnames(aicTab) <- c("cll","df","caic","refit") aicTab$models <- sapply(formulaList, makePrint, initial=FALSE) aicTab <- as.data.frame(aicTab[,c("models","cll","df","caic","refit")]) minInd <- order(aicTab$caic, decreasing = FALSE) bestMod <- NA if(length(minInd)!=0){ bestMod <- listOfModels[minInd[1:(min(nrmods,length(minInd)))]] attr(bestMod, "caic") <- sort(aicTab$caic, decreasing = FALSE)[ 1:(min(nrmods,length(minInd)))] } return(list(aicTab=aicTab, bestMod=bestMod) ) } ####################################################################################### ### checkHierarchicalOrder function ### purpose: checks the correct hierarchical order checkHierarchicalOrder <- function(listIn) { listIn <- listIn[order(sapply(listIn,length),decreasing=T)] notAllowed <- list() lenMax <- length(listIn[[1]]) lenMin <- length(listIn[[length(listIn)]]) i = 1 while(i < length(listIn)){ lenI <- length(listIn[[i]]) if( lenMax>1 & lenI>lenMin ){ notAllowed <- allCombn(listIn[[i]]) listIn <- listIn[!listIn%in%notAllowed] } i = i + 1 } return(listIn) } ####################################################################################### ### checkREs function ### purpose: checks for NULL- or NA-REs, then for duplicates and calls the check ### for hierarchical order checkREs <- function(reList) { # first check: NULL-REs / NA-REs reList <- reList[sapply(reList,function(x)!is.null(x))] reList <- reList[sapply(reList,function(x)any(!is.na(x)))] nam <- unique(names(reList)) checkedList <- list() for(i in 1:length(nam)){ namL <- reList[names(reList)==nam[i]] namL <- lapply(namL,sort) # second check: duplicated REs namL <- namL[!duplicated(namL)] # third check: hierarchical order if(length(namL)>1) namL <- checkHierarchicalOrder(namL) checkedList <- append(checkedList,namL) } return(checkedList) } ####################################################################################### ### nester function ### purpose: does the nesting of random effects # # # nester <- function(namesGroups, intDep) # { # # countColons <- function(strings) sapply(regmatches(strings, gregexpr(":", strings)), length) # # # namesGroups <- unique(unlist(sapply(listOfRanefCombs,names))) # nrOfColons <- countColons(namesGroups) # newGroups <- namesGroups[nrOfColons1){ # # combsGroups <- sapply(allCombn2(newGroups,intDep),paste0,collapse=":") # combsGroups <- combsGroups[countColons(combsGroups)<=intDep-1] # namesGroups <- append(namesGroups,combsGroups) # # } # # return(namesGroups) # # } ####################################################################################### ### allNestSubs function ### purpose: create all grouping variables from nested expression allNestSubs <- function(x) { unlist(sapply( findbars( as.formula( paste0("~ (1 | ", x, ")"))), function(y) deparse(y[[3]]) ) ) } ####################################################################################### ### cnmsConverter function ### purpose: converts cnms to formula-like string cnmsConverter <- function(cnms) { charForm <- character(length(cnms)) if(all(sapply(cnms,function(x) all(is.na(x)))) | all(sapply(cnms,is.null))) return(NULL) for(i in 1:length(cnms)){ if ("(Intercept)"%in%cnms[[i]]) { cnms[[i]][which(cnms[[i]]=="(Intercept)")] <- "1" }else{ cnms[[i]] <- append(cnms[[i]],"0") } charForm[i] <- paste("(", paste(cnms[[i]], collapse = " + "), " | ", names(cnms)[i], ")", sep = "") } charForm } ####################################################################################### ### forwardGam function ### purpose: does the forward step for gamm4 models forwardGam <- function(intGam, fixEfCandidates=NULL, bsType="ps", keep) { vars <- intGam$fake.names sTerm <- vars%in%sapply(intGam$smooth.spec,function(x)x$term) nonS <- vars[!sTerm] haveS <- vars[sTerm] # should be at least of length 1 , else a (g)lmer should be fitted sLabs <- makeS(intGam) keepNonS <- vars[!(vars %in% fixEfCandidates) & !(vars %in% haveS)] newX <- fixEfCandidates[which(!fixEfCandidates %in% vars)] if(!is.null(keep)){ keep <- mgcv::interpret.gam(keep) keepVars <- keep$fake.names keepSterm <- keepVars%in%sapply(keep$smooth.spec,function(x)x$term) keepNonS <- keepVars[!keepSterm] } nonS <- nonS[!nonS%in%keepNonS] # drop the keepNonS from nonS # to prevent s-making if(length(nonS)==0) nonS <- NULL returnListS <- vector("list",length=length(nonS)+length(newX)) for(i in 1:length(returnListS)){ if(i <= length(newX)){ returnListS[[i]] <- c(keepNonS,sLabs,nonS,newX[i]) }else{ returnListS[[i]] <- c(keepNonS,sLabs,nonS[-(i-length(newX))], paste0("s(",nonS[i-length(newX)], ",bs=",deparse(bsType),")")) } } returnListS } ####################################################################################### ### forwardStep function ### purpose: does the forward step forwardStep <- function(cnms, slopeCandidates, groupCandidates, nrOfCombs, allowUseAcross, allowCorrelationSel ) { if(allowUseAcross) allSlopes <- unique(c(unlist(cnms), slopeCandidates), "(Intercept)") else allSlopes <- c(slopeCandidates,"(Intercept)") allGroups <- unique( c(names(cnms), groupCandidates) ) allSlopeCombs <- list() for(i in 1:nrOfCombs){ if(i<=length(allSlopes)){ allSlopeCombs <- append(allSlopeCombs,combn(allSlopes,m=i,simplify=FALSE)) } } allSlopeCombs <- allSlopeCombs[sapply(allSlopeCombs,function(x)!any(duplicated(x)))] reList <- rep(allSlopeCombs,each=length(allGroups)) names(reList) <- rep(allGroups,length(allSlopeCombs)) allCombs <- lapply(X=1:length(reList),function(i)append(cnms,reList[i])) allCombs <- lapply(allCombs,checkREs) if(!allowCorrelationSel) allCombs <- allCombs[ sapply(allCombs,function(x) length(unique(names(x))) == length(x))] allCombs <- allCombs[!duplicated(allCombs)] allCombs <- allCombs[!(sapply(allCombs,function(x)all.equal(x,lapply(cnms,sort)))=="TRUE")] if(length(allCombs)==0) return(NULL) allCombs <- allCombs[sapply(allCombs,function(r)!is.null(r))] allCombs <- lapply(allCombs,function(t)t[order(names(t))]) allCombs <- allCombs[!(duplicated(allCombs) & duplicated(lapply(allCombs,names)))] # also allow for correlation parameter to be selected? if(!allowCorrelationSel) allCombs <- removeUncor(allCombs) # only allow for REs, which are one variable larger than the current one allCombs <- allCombs[!sapply(allCombs, function(r){ any(sapply(1:length(r), function(i){ if(!names(r)[i] %in% names(cnms)){ length(r[[i]]) > 1 }else{ length(r[[i]]) > length(cnms[[names(r)[i]]]) + 1 } })) })] if(length(allCombs)==0) return(NULL) return(#list(randomPart= allCombs#, sPart=...) ) } ####################################################################################### ### removeUncor function ### purpose: removes random effects with uncorrelated intercept and slope removeUncor <- function(res) { # keep <- sapply(res, function(re){ # # length(re) == 1 | # (all(unlist(sapply(re, function(x) # any(grepl("(Intercept)", x, fixed=T)))))) # # }) drop <- sapply(res, function(re){ reL <- split(re, names(re)) dropPerName <- sapply(reL, function(rel) { if(length(rel) > 1){ ints <- sapply(rel, function(x) any(grepl("(Intercept)", x, fixed=T))) noints <- sapply(rel, function(x) any(!grepl("(Intercept)", x, fixed=T))) return(ints & noints) }else return(FALSE) }) any(dropPerName) }) # res <- res[keep] # check for several random intercepts with different slopes # drop <- sapply(res, function(re){ # # reL <- split(re, names(re)) # dropPerName <- sapply(reL, function(rel) # { # if(length(rel) > 1){ # ints <- sapply(rel, function(x) any(grepl("(Intercept)", x, fixed=T))) # }else FALSE # }) # any(dropPerName) # # }) return(res[!drop]) } ### removeNoInt function ### purpose: removes random effects with no random intercept removeNoInt <- function(res) { # check if any of the results is an intercept hasInt = function(x) any(grepl("(Intercept)",x,fixed=TRUE)) for(i in 1:length(res)){ namresi = names(res[[i]]) for(j in 1:length(namresi)){ resForThisGroup <- unlist(res[[i]][namresi[j]]) # remove RE without intercept if(!hasInt(resForThisGroup)) res[[i]] <- res[[i]][-j] } } res <- res[sapply(res, length)>0] return(res) } ####################################################################################### ### getComponents function ### purpose: extracts important components of [g]lmerMod and 'gamm4' objects getComponents <- function(object) { isGam <- is.list(object) & length(object)==2 & all(c("mer","gam") %in% names(object)) gamPart <- NULL random <- NULL if(isGam){ nrOfSmooths <- length(object$gam$smooth) # cutp <- length(object$mer@cnms)-nrOfSmooths random <- object$mer@cnms[!object$mer@cnms%in%sapply(object$gam$smooth,function(x)x$label)] # ,cutp) if(length(random)==0) random=NULL gamPart <- mgcv::interpret.gam(object$gam$formula) }else if(inherits(object, c("lmerMod", "glmerMod"))){ random <- object@cnms }#else if(any(class(object)%in%c("lm","glm"))){ #} return(list(random=random, gamPart=gamPart ) ) } ####################################################################################### ### getGLMll function ### purpose: # getGLMll <- function(object) # { # # y <- object$y # if(is.null(y)) y <- eval(object$call$data, environment(formula(object)))[all.vars(formula(object))[1]][[1]] # if(is.null(y)) stop("Please specify the data argument in the initial model call!") # # mu <- predict(object,type="response") # sigma <- ifelse("glm"%in%class(object),sqrt(summary(object)$dispersion),summary(object)$sigma) # # switch(family(object)$family, binomial = { # cll <- sum(dbinom(x = y, size = length(unique(y)), prob = mu, log = TRUE)) # }, poisson = { # cll <- sum(dpois(x = y, lambda = mu, log = TRUE)) # }, gaussian = { # cll <- sum(dnorm(x = y, mean = mu, sd = sigma, log = TRUE)) # }, { # cat("For this family no bias correction is currently available \n") # cll <- NA # }) # return(cll) # # # } ####################################################################################### ### keeps functions ### purpose: # sepKeeps <- function(comps, keep = keep) # { # # keepRE <- keep$random # keepS <- keep$fixed # # if(!is.null(keepS)) keepS <- mgcv::interpret.gam(keepS) # if(!is.null(keepRE)) keepRE <- interpret.random(keepRE) # # randomNK <- excludeRE(comps, keepRE) # gamPartNK <- excludeS(comps, keepS) # # return(list(random = random, # gamPart = gamPart)) # # } # # addKeeps <- function(keep, newComps) # { # # random <- lapply(newComps$random, function(x) append(x, keep$random)) # gamPart <- lapply(newComps$gamPart, function(x) append(x, keep$gamPart)) # # return(list(random=random, # gamPart=gamPart)) # # } ####################################################################################### ### interpret_random function ### purpose: interpret.random <- function(frla) { bars <- findbars(frla[[length(frla)]]) names(bars) <- unlist(lapply(bars, function(x) deparse(x[[3]]))) lapply(bars, function(b){ hasInt <- attr(terms(as.formula(paste0("~",deparse(subbars(b))))),"intercept")==1 v <- ifelse(hasInt, "(Intercept)", "0") v <- append(v,all.vars(as.formula(paste0("~",deparse(b[[2]]))))) return(v) }) } ####################################################################################### ### makeBackward function ### purpose: makeBackward <- function(comps, keep, allowCorrelationSel, allowNoIntercept) { # comps list created by getComponents returnListRE <- returnListS <- NULL returnListRE <- if(!is.null(comps$random)) backwardStep(comps$random, keep=keep$random, allowCorrelationSel=allowCorrelationSel, allowNoIntercept=allowNoIntercept) returnListS <- if(!is.null(comps$gamPart) && comps$gamPart$fake.formula[[3]]!=1) backwardGam(comps$gamPart, keep=keep$fixed) return(list(gamPart=returnListS, random=returnListRE)) } ####################################################################################### ### makeFormula function ### purpose: makeFormula <- function(setup, modelInit) { # setup list ($random,$gamPart) created by makeBackward / makeForward # modelInit initial model # get config isGam <- !is.null(setup$gamPart) & length(setup$gamPart)>0 wasGam <- is.list(modelInit) & length(modelInit)==2 & all(c("mer","gam") %in% names(modelInit)) random <- gamPart <- reFormula <- rhs <- NULL ### create random part if(!is.null(setup$random) && all(!is.na(setup$random))){ charForm <- cnmsConverter(setup$random) reFormula <- paste(charForm, collapse = " + ") } ### create gamPart / lhs / rhs if(isGam){ rhs <- paste(setup$gamPart, collapse = " + ") }else{ if(wasGam){ rhs <- "1" }else{ # (g)lmer / (g)lm if(nobars(formula(modelInit)) == formula(modelInit)[[2]]){ nobarsF <- NULL }else{ if(any(class(modelInit)%in%c("lm","glm"))){ nobarsF <- labels(terms(formula(modelInit))) }else{ nobarsF <- attr(terms.formula(nobars(formula(modelInit)), data = modelInit@frame), "term.labels") } } rhs <- c(nobarsF, reFormula) } } # if there are no covariates, set rhs to "1" if(is.null(rhs) | length(rhs)==0) rhs <- "1" # extract response lhs <- ifelse(wasGam, formula(modelInit$gam)[[2]], formula(modelInit)[[2]]) # specify the parts random and gamPart if(isGam | wasGam){ random <- reFormula gamPart <- reformulate(rhs, lhs) }else{ random <- reformulate(rhs, lhs) } return(list(random=random, gamPart=gamPart) ) } ####################################################################################### ### makeForward function ### purpose: makeForward <- function(comps, slopeCandidates, groupCandidates, nrOfCombs, allowUseAcross, fixEfCandidates, bsType, keep, allowCorrelationSel) { returnListRE <- returnListS <- NULL # ellipsis <- as.list(substitute(list(...))) if(is.null(comps$random) & is.null(comps$gamPart)){ gr <- rep("(Intercept)",length(groupCandidates)) names(gr) <- groupCandidates returnListRE <- if(!is.null(groupCandidates)) lapply(split(gr, 1:length(gr)),as.list) returnListS <- if(!is.null(fixEfCandidates)) lapply(as.list(fixEfCandidates),as.list) }else{ returnListS <- if(!is.null(comps$gamPart) | !is.null(fixEfCandidates)) forwardGam(comps$gamPart, fixEfCandidates=fixEfCandidates, bsType=bsType, keep=keep$fixed) returnListRE <- if(!is.null(slopeCandidates) | !is.null(groupCandidates) | length(comps$random)>1 | allowUseAcross) forwardStep(cnms=comps$random, slopeCandidates, groupCandidates, nrOfCombs, allowUseAcross, allowCorrelationSel) } return(list(gamPart=returnListS, random=returnListRE)) } ####################################################################################### ### makePrint function ### purpose: makePrint <- function(comps, initial=TRUE) { if(initial){ isLMER <- FALSE if(inherits(comps, c("lmerMod", "glmerMod"))){ f <- nobars(formula(comps)) f <- if(is.name(f)){ 1 }else{ f[[length(f)]] } isLMER <- TRUE } if("lm" %in% class(comps)){ pr <- paste0("~ ", #attr(comps$terms, "intercept"), " + ", paste(attr(comps$terms, "term.labels"), collapse = " + ")) }else{ comps <- mergeChanges(getComponents(comps), NULL) if(isLMER) comps$gamPart <- all.vars(f) gp <- c( comps$gamPart, cnmsConverter(comps$random) ) if(is.null(gp) | length(gp)==0) gp <- "1" pr <- paste0("~ ", paste(gp, collapse = " + ") ) } }else{ gp <- NULL gp <- if(!is.null(comps$gamPart)) as.character(Reduce(paste,deparse(comps$gamPart))) parts <- c(gp,comps$random) # print(parts) pr <- paste(parts,collapse=" + ") pr <- as.character(Reduce(paste,deparse(as.formula(pr)[-2]))) # too complicated } return(pr) } ####################################################################################### ### makeS function ### purpose: makeS <- function(intGam) { sapply(intGam$smooth.spec, function(x) paste0("s(", x$term, ",bs=", deparse(paste0(substring(attr(x,"class"), 1, 2))), ")") ) } ####################################################################################### ### makeUpdate function ### purpose: makeUpdate <- function(modelInit, setup, data) { willBeGam <- !is.null(setup$gamPart) & grepl("s\\(",Reduce(paste,deparse(setup$gamPart))) # probably not the best way to check... hasBars <- ifelse(!is.character(setup$random), !is.null(findbars(setup$random)), !is.null(findbars(as.formula(paste0("~",setup$random)))) ) isGlm <- any(class(modelInit)%in%c("glm","lm")) isGam <- is.list(modelInit) & length(modelInit)==2 & all(c("mer","gam") %in% names(modelInit)) # make a decision which method should be used for fitting if(!willBeGam & isGlm & hasBars){ fm <- ifelse(isGam, family(modelInit$mer)$family, family(modelInit)$family) mod <- if(fm=="gaussian"){ lmer(setup$random, data = data) }else{ glmer(setup$random, data = data, family = fm) } }else if(!willBeGam & !isGlm & hasBars & !isGam){ form <- setup$random if(!is.null(setup$gamPart)) form <- paste0(paste(format(setup$gamPart), collapse=""), " + ", setup$random) mod <- update(modelInit, formula = form) }else if(!willBeGam & !hasBars & !isGam){ fm <- ifelse(isGam, family(modelInit$mer)$family, family(modelInit)$family) mod <- eval(parse(text=paste0("glm(",paste(format(setup$random), collapse=""), ", family = ", fm, ", data = ", attr(data, "orgname"),")")), envir = environment(modelInit)) }else if(!willBeGam & !hasBars & isGam){ fm <- ifelse(isGam, family(modelInit$mer)$family, family(modelInit)$family) if(length(modelInit$gam$smooth)==0) { # actually a Glm this_data <- data }else{ this_data <- attr(data, "orgname") } mod <- eval(parse(text=paste0("glm(",paste(format(setup$gamPart), collapse=""), ", family = ", fm, ", data = ", "this_data",")"))) }else{ # willBeGam r <- if(!is.null(setup$random)){ as.formula(paste("~",setup$random)) }else{ NULL } mod <- gamm4::gamm4(setup$gamPart, data = data, family = family(modelInit$mer), random = r) } return(mod) } ####################################################################################### ### mergeChanges function ### purpose: mergeChanges <- function(initialParts, listParts) { ### initial part orgS <- orgRE <- NULL if(!is.null(initialParts$gamPart)){ vars <- initialParts$gamPart$fake.names sTerm <- vars%in%sapply(initialParts$gamPart$smooth.spec,function(x)x$term) nonS <- vars[!sTerm] haveS <- vars[sTerm] # should be at least of lenght = 1 , else a (g)lmer should be fitted sLabs <- makeS(initialParts$gamPart) orgS <- append(sLabs,nonS) } if(!is.null(initialParts$random)) orgRE <- initialParts$random if(is.null(listParts$gamPart) & is.null(listParts$random)) return(list(random=orgRE,gamPart=orgS)) newRE <- lapply(listParts$random,function(r)list(random=r,gamPart=orgS)) newS <- lapply(listParts$gamPart,function(s)list(random=orgRE,gamPart=s)) resList <- append(newRE,newS) ### drop those models with the exact same configuration as the initial model resList <- resList[!sapply(resList,function(r) is.logical(all.equal(r, list(random=orgRE,gamPart=orgS))))] return(resList) } ####################################################################################### ### duplicatedMers function ### purpose: get the duplicated merMod models in a list of models duplicatedMers <- function(listModels) { duplicated(sapply(listModels, function(x){ if(class(x)[1]=="list") as.character(Reduce(paste,deparse(formula(x$mer)))) else as.character(Reduce(paste,deparse(formula(x)))) })) } cAIC4/R/biasCorrectionBernoulli.R0000644000176200001440000000421114773602310016244 0ustar liggesusersbiasCorrectionBernoulli <- function(object){ # A function that calculates the bias correction for the estimation of the Kullback-Leibler distance # # Args: # object = gam object with family=binomial # # Returns: # bc = Bias correction for Binomial gam # zeroLessModel <- deleteZeroComponents(object) if (inherits(zeroLessModel, "glm")) { return(zeroLessModel$rank) } signCor <- - 2 * zeroLessModel@resp$y + 1 muHat <- zeroLessModel@resp$mu workingEta <- numeric(length(muHat)) for(i in 1:length(muHat)){ workingData <- zeroLessModel@resp$y workingData[i] <- 1 - workingData[i] workingModel <- refit(zeroLessModel, newresp = workingData) workingEta[i] <- log(workingModel@resp$mu[i] / (1 - workingModel@resp$mu[i])) - log(muHat[i] / (1 - muHat[i])) } bc <- sum(muHat * (1 - muHat) * signCor * workingEta) if (identical(object, zeroLessModel)) { newModel <- NULL new <- FALSE } else { newModel <- zeroLessModel new <- TRUE } return(list(bc = bc, newModel = newModel, new = new)) } # #biasCorrectionBernoulli <- function(object) { # # A function that calculates the bias correction for a generalized linear # # mixed models with binary(!) data similar to the centralized Steinian method # # in Efron (2004). # # # # Args: # # object = Object of class lmerMod or glmerMod. Obtained by lmer() or # # glmer(). Needs binary data. # # # # Returns: # # BC = (Asymptotic) bias correction (i.e. degrees of freedom) for a # # (generalized) linear mixed model with binary response. # # # y <- object@resp$y # signCor <- - 2 * y + 1 ## Signum correction Eta(0)-Eta(1) vs Eta(1)-Eta(0) # mu <- object@resp$mu # eta <- qlogis(mu) # workingMatrix <- matrix(rep(y, length(y)), ncol = length(y)) # diag(workingMatrix) <- 1 - diag(workingMatrix) # workingEta <- diag(apply(workingMatrix, 2, function(x) qlogis(refit(object, newresp = x)@resp$mu) - eta)) # return(sum(mu * (1 - mu) * signCor * workingEta)) #} # cAIC4/R/cnms2formula.R0000644000176200001440000000161014773602310014032 0ustar liggesuserscnms2formula <- function(cnms) { # A function that builds a random effects formula from the ?component names?, # a list that can be extracted from an lmerMod object by .@cnms or # getME(., "cnms"). # # Args: # cnms = List from an lmerMod object by .@cnms or getME(., "cnms"). # # Returns: # reFormula = random effects part of a lmerMod formula # len <- unlist(lapply(cnms, length)) cnms <- cnms[which(len != 0)] charForm <- character(length(cnms)) for(i in 1:length(cnms)) { if (cnms[[i]][1] == "(Intercept)") { cnms[[i]][1] <- "1" } else { tpv <- cnms[[i]] cnms[[i]] <- append("",tpv) cnms[[i]][1] <- "-1" } charForm[i] <- paste("(", paste(cnms[[i]], collapse = " + "), " | ",names(cnms)[i], ")", sep = "") } reFormula <- paste(charForm, collapse = " + ") return(reFormula) } cAIC4/R/getcondLL.R0000644000176200001440000000364714773602310013311 0ustar liggesusers#' Function to calculate the conditional log-likelihood #' #' @param object An object of class \code{merMod} either fitted by #' \code{\link[lme4]{lmer}} or \code{\link[lme4]{glmer}} of the 'lme4' package. #' #' @return conditional log-likelihood value #' @importFrom stats weights #' @export getcondLL <- function(object) UseMethod("getcondLL") #' @return \code{NULL} #' #' @rdname getcondLL #' @importFrom nlme getResponse #' @export getcondLL.lme <- function(object) { stopifnot(family(object)$family == "gaussian") y <- as.vector(getResponse(object)) y_hat <- predict(object) # re at their predicted values R <- as.matrix(get_R(object)) sum(mvtnorm::dmvnorm(x = y, mean = y_hat, sigma = R, log = TRUE)) } #' @return \code{NULL} #' #' @rdname getcondLL #' @export getcondLL.merMod <- function(object) { # A function that calls the bias correction functions. # # Args: # object = Object of class lmerMod or glmerMod. Obtained by lmer() or glmer() # # Returns: # cll = The conditional log-likelihood. # # check for weights w <- weights(object) if(sum(w)!=length(w)){ if(family(object)$family != "gaussian") warning("Weights for family != gaussian not implemented yet.") } switch(family(object)$family, binomial = { cll <- sum(dbinom(x = getME(object, "y"), size = length(unique(getME(object, "y"))) - 1, prob = getME(object, "mu"), log = TRUE)) }, poisson = { cll <- sum(dpois(x = getME(object, "y"), lambda = getME(object, "mu"), log = TRUE)) }, gaussian = { cll <- sum(dnorm(x = getME(object, "y"), mean = getME(object, "mu"), sd = sigma(object) / sqrt(w), log = TRUE)) }, { cat("For this family no bias correction is currently available \n") cll <- NA } ) return(cll) } cAIC4/R/methods.R0000644000176200001440000000433614773602310013075 0ustar liggesusers#' Print method for cAIC #' @method print cAIC #' @param x a cAIC object #' @param digits number of digits to print #' @param ... further arguments passed to #' generic print function (not in use). #' @export print.cAIC <- function(x, ..., digits = 2){ prdf <- data.frame( a = c("Conditional log-likelihood: ", "Degrees of freedom: ", "Conditional Akaike information criterion: "), b = round(unlist(x[c("loglikelihood", "df", "caic")]), digits = digits)) colnames(prdf) <- c() if(x$new){ cat("The original model was refitted due to zero variance components.\n") cat("Refitted model: ", Reduce(paste, deparse(formula(x$reducedModel))), "\n") } print(prdf, row.names = FALSE) invisible(prdf) } #' Comparison of several lmer objects via cAIC #' #' Takes one or more \code{lmer}-objects and produces a table #' to the console. #' #' @param object a fitted \code{lme4}-object #' @param ... additional objects of the same type #' @param digits number of digits to print #' #' @seealso \code{\link{cAIC}} for the model fit. #' #' @return a table comparing the cAIC relevant information of all models #' #' @export anocAIC <- function(object, ..., digits = 2) { # get list of models objs <- c(object, list(...)) # check correct input if(any(sapply(objs, function(x) !inherits(x, "merMod")))) stop("anocAIC can only deal with objects of class lmerMod or glmerMod") # calculate cAICs cAICs <- lapply(objs, cAIC) # extract formulas frms <- sapply(objs, function(x) Reduce(paste, deparse(formula(x)))) # replace formulas, where the model was refitted refit <- sapply(cAICs, "[[", "new") if(any(refit)) frms[which(refit)] <- sapply(cAICs[which(refit)], function(x) Reduce(paste, deparse(formula(x$reducedModel)))) # create returning data.frame ret <- as.data.frame(do.call("rbind", lapply(cAICs, function(x) round(unlist(x[c("loglikelihood", "df", "caic", "new")]), digits = digits)))) ret[,4] <- as.logical(ret[,4]) rownames(ret) <- make.unique(frms, sep = " % duplicate #") colnames(ret) <- c("cll", "df", "cAIC", "Refit") # print and return print(ret) invisible(ret) } cAIC4/R/getWeights.R0000644000176200001440000001117014773602310013536 0ustar liggesusers#' Optimize weights for model averaging. #' #'Function to determine optimal weights for model averaging based on a proposal #'by Zhang et al. ( 2014) to derive a weight choice criterion based on the #'conditional Akaike Information Criterion as proposed by Greven and Kneib #'(2010). The underlying optimization is a customized version of the #'Augmented Lagrangian Method. #' #' @param models An list object containing all considered candidate models fitted by #' \code{\link[lme4]{lmer}} of the lme4-package or of class #' \code{\link[nlme]{lme}}. #' @return An object containing a vector of optimized weights, #' value of the minimized target function and the duration of the optimization #' process. #' #' @section WARNINGS : #' No weight-determination is currently possible for models called via \code{gamm4}. #' @author Benjamin Saefken & Rene-Marcel Kruse #' @seealso \code{\link[lme4]{lme4-package}}, \code{\link[lme4]{lmer}}, #' \code{\link[lme4]{getME}} #' @references Greven, S. and Kneib T. (2010) On the behaviour of marginal and #' conditional AIC in linear mixed models. Biometrika 97(4), 773-789. #' @references Zhang, X., Zou, G., & Liang, H. (2014). Model averaging and #' weight choice in linear mixed-effects models. Biometrika, 101(1), 205-218. #' @references Nocedal, J., & Wright, S. (2006). Numerical optimization. #' Springer Science & Business Media. #' @rdname getWeights #' @export getWeights #' @examples data(Orthodont, package = "nlme") #' models <- list( #' model1 <- lmer(formula = distance ~ age + Sex + (1 | Subject) + age:Sex, #' data = Orthodont), #' model2 <- lmer(formula = distance ~ age + Sex + (1 | Subject), #' data = Orthodont), #' model3 <- lmer(formula = distance ~ age + (1 | Subject), #' data = Orthodont), #' model4 <- lmer(formula = distance ~ Sex + (1 | Subject), #' data = Orthodont)) #' #' foo <- getWeights(models = models) #' foo #' #' getWeights <- function(models) { m <- models .envi <- environment() # Creation of the variables required for the optimization of weights # TODO: Suppress anocAIC's automatic output invisible(capture.output(modelcAIC <- anocAIC(m))) df <- modelcAIC[[2]] tempm <- m[[which.max(modelcAIC$df)]] seDF <- getME(tempm, "sigma") varDF <- seDF * seDF y <- getME(m[[1]], "y") mu <- list() # TODO: that needs to be made more effective ... for(i in 1:length(m)){ mu[[i]] <- getME(m[[i]], "mu") } mu <- t(matrix(unlist(mu), nrow = length(m), byrow = TRUE)) weights <- rep(1/length(m), times = length(m)) fun <- find_weights <- function(w){(t(y - matrix(mu %*% w))%*%(y - matrix(mu %*% w))) + 2 * varDF * (w %*% df)} eqfun <- equal <-function(w){sum(w)} equB <- 1 lowb <- rep(0, times = length(m)) uppb <- rep(1, times = length(m)) nw <- length(weights) funv <- find_weights(weights) eqv <- (sum(weights)-equB) rho <- 0 maxit <- 400 minit <- 800 delta <- (1.0e-7) tol <- (1.0e-8) # Start of optimization: j <- jh <- funv lambda <- c(0) constraint <- eqv p <- c(weights) hess <- diag(nw) mue <- nw .iters <- 0 targets <- c(funv, eqv) tic <- Sys.time() while( .iters < maxit ){ .iters <- .iters + 1 scaler <- c( targets[ 1 ], rep(1, 1) * max( abs(targets[ 2:(1 + 1) ]) ) ) scaler <- c(scaler, rep( 1, length.out = length(p) ) ) scaler <- apply( matrix(scaler, ncol = 1), 1, FUN = function( x ) min( max( abs(x), tol ), 1/tol ) ) res <- .weightOptim(weights = p, lm = lambda, targets = targets, hess = hess, lambda = mue, scaler = scaler, .envi = .envi) p <- res$p lambda <- res$y hess <- res$hess mue <- res$lambda temp <- p funv <- find_weights(temp) eqv <- (sum(temp)-equB) targets <- c(funv, eqv) # Change of the target function through optimization tt <- (j - targets[ 1 ]) / max(targets[ 1 ], 1) j <- targets[ 1 ] constraint <- targets[ 2 ] if( abs(constraint) < 10 * tol ) { rho <- 0 mue <- min(mue, tol) } if( c( tol + tt ) <= 0 ) { lambda <- 0 hess <- diag( diag ( hess ) ) } if( sqrt(sum( (c(tt, eqv))^2 )) <= tol ) { maxit <- .iters } } toc <- Sys.time() - tic ans <- list("weights" = p, "functionvalue" = j, "duration" = toc) return( ans ) } cAIC4/R/conditionalBootstrap.R0000644000176200001440000000162014773602310015624 0ustar liggesusersconditionalBootstrap <- function(object, BootStrRep) { # A function that calculates the bias correction for a (generalized) linear # mixed models by the methods in Efron (2004). # # Args: # object = Object of class lmerMod or glmerMod. Obtained by lmer() or # glmer(). # BootStrRep = Number of bootstrap replications. # # Returns: # bootBC = Bias correction (i.e. degrees of freedom) for a (generalized) # linear mixed model. # dataMatrix <- simulate(object, nsim = BootStrRep, use.u = TRUE) workingEta <- sapply(dataMatrix, function(x){ predict(refit(object, newresp = x)) }) if(is.factor(dataMatrix[[1]])) dataMatrix <- sapply(dataMatrix, as.numeric) - 1 dataMatrix <- dataMatrix - rowMeans(dataMatrix) bootBC <- sum(workingEta * dataMatrix) / ((BootStrRep - 1) * sigma(object)^2) return(bootBC) } cAIC4/R/biasCorrectionPoisson.R0000644000176200001440000000244414773602310015751 0ustar liggesusersbiasCorrectionPoisson <- function(object) { # A function that calculates the bias correction for a generalized linear # mixed models with Poisson data, see Lian (2012) & Saefken et al. (2014). # # Args: # object = Object of class lmerMod or glmerMod. Obtained by glmer(). With # family = "poisson". # Returns: # BC = Bias correction (i.e. degrees of freedom) for a (generalized) # linear mixed model with Poisson response. # zeroLessModel <- deleteZeroComponents(object) if (inherits(zeroLessModel, "glm")) { return(zeroLessModel$rank) } y <- zeroLessModel@resp$y ind <- which(y != 0) workingMatrix <- matrix(rep(y, length(y)), ncol = length(y)) diag(workingMatrix) <- diag(workingMatrix) - 1 workingMatrix <- workingMatrix[, ind] workingEta <- diag(apply(workingMatrix, 2, function(x) refit(zeroLessModel, newresp = x)@resp$eta)[ind,]) bc <- sum(y[ind] * (zeroLessModel@resp$eta[ind] - workingEta)) if (identical(object, zeroLessModel)) { newModel <- NULL new <- FALSE } else { newModel <- zeroLessModel new <- TRUE } return(list(bc = bc, newModel = newModel, new = new)) } cAIC4/R/getModelComponents.R0000644000176200001440000001330614773611132015237 0ustar liggesusers#' Generic getModelComponents method #' #' @export #' @param m model object #' @param analytic logical #' #' @return Model components #' #' getModelComponents <- function(m, analytic) UseMethod("getModelComponents") #' getModelComponents for lme objects #' #' @exportS3Method getModelComponents lme #' #' @param m lme object #' @param analytic logical #' #' @return Model components #' #' getModelComponents.lme <- function(m, analytic = TRUE) { model <- list() model$df <- NULL X <- model.matrix(formula(m),m$data) n <- nrow(X) Z <- as.matrix(get_Z(m)) theta <- get_theta(m) Lambdat <- get_LambdaT(m)$LambdaT D <- get_LambdaT(m)$D Lambda <- t(Lambdat) model$Wlist <- list() model$eWelist <- list() # L <- get_L(m) sig2 <- sigma(m)^2 R <- get_R(m) / sig2 # definition according to derivation of bc with weights # w <- sig2 / diag(get_R(m)) Rinv <- solve(R) model$R <- R Zt <- t(Z) #Dinv <- solve(get_LambdaT(m)$D) V0inv <- solve(Matrix(Z %*% D %*% Zt + get_R(m))/sig2) RX <- get_RX(m) A <- V0inv - crossprod(crossprod(X %*% solve(RX), V0inv)) y <- as.vector(getResponse(m)) e <- residuals(m) ## prepare list of derivative matrices W_j ind <- get_Lind(m) len <- rep(0, length(Lambda@x)) for (s in 1:length(theta)) { # model$Wlist <- lapply(theta, function(s){ LambdaS <- Lambda LambdaSt <- Lambdat LambdaS@x <- LambdaSt@x <- len LambdaS@x[which(ind == s)] <- LambdaSt@x[which(ind == s)] <- 1 diagonal <- diag(LambdaS) diag(LambdaS) <- diag(LambdaSt) <- 0 Ds <- LambdaS + LambdaSt diag(Ds) <- diagonal model$Wlist[[s]] <- tcrossprod(Z %*% Ds, Z) model$eWelist[[s]] <- as.numeric(e %*% model$Wlist[[s]] %*% e) # model$Wlist[[s]] <- model$Wlist[[s]]/norm(model$Wlist[[s]], type = "F") } ## Write everything into a return list model$X <- X model$n <- n model$theta <- theta model$Z <- Z model$Lambda <- Lambda model$Lambdat <- Lambdat model$V0inv <- V0inv model$A <- A if (analytic) { model$B <- matrix(0, length(theta), length(theta)) } else { stop("Numerical Hessian not calculated in nlme::lme objects!") # model$B <- m@optinfo$derivs$Hessian } model$C <- matrix(0, length(theta), n) model$y <- y model$e <- e model$tye <- as.numeric(crossprod(y, e)) model$isREML <- m$method == "REML" return(model) } #' getModelComponents for merMods #' #' @exportS3Method getModelComponents merMod #' #' @param m merMod object #' @param analytic logical #' getModelComponents.merMod <- function(m, analytic) { # A function that calculates all components needed to calculate the bias # correction as in Greven & Kneib (2010) # # Args: # m = Object of class lmerMod. Obtained by lmer() # analytic = FALSE if the numeric hessian of the (restricted) marginal log- # likelihood from the lmer optimization procedure should be used. # Otherwise (default) TRUE, i.e. use a analytical version that # has to be computed. # # Returns: # model = List of components needed to calculate the bias correction # model <- list() model$df <- NULL X <- getME(m, "X") n <- nrow(X) Z <- getME(m, "Z") theta <- getME(m, "theta") Lambda <- getME(m, "Lambda") Lambdat <- getME(m, "Lambdat") model$Wlist <- list() model$eWelist <- list() L <- getME(m, "L") w <- weights(m) if(any(w!=1)){ model$R <- diag(1/w) Rinv <- diag(w) D0inv <- solve(tcrossprod(Lambda)) V0inv <- Rinv - crossprod(Rinv,Z) %*% solve(D0inv + t(Z)%*%Rinv%*%Z) %*% crossprod(Z,Rinv) }else{ I_v0inv <- Matrix(0, n, n, sparse = TRUE) diag(I_v0inv) <- 1 V0inv <- I_v0inv - crossprod(solve(L, system = "L") %*% solve(L, Lambdat, system = "P") %*% t(Z)) } # P <- diag(rep(1, n)) - X %*% chol2inv(getME(m, "RX")) %*% crossprod(X, V0inv) ## pre calculate matrices for faster computation # A <- crossprod(P, V0inv) A <- V0inv - crossprod(crossprod(X %*% solve(getME(m, "RX")), V0inv)) y <- getME(m, "y") e <- y - getME(m, "mu") ## prepare list of derivative matrices W_j ind <- getME(m, "Lind") len <- rep(0, length(Lambda@x)) for(s in 1:length(theta)) { # model$Wlist <- lapply(theta, function(s){ LambdaS <- Lambda LambdaSt <- Lambdat LambdaS@x <- LambdaSt@x <- len LambdaS@x[which(ind == s)] <- LambdaSt@x[which(ind == s)] <- 1 diagonal <- diag(LambdaS) diag(LambdaS) <- diag(LambdaSt) <- 0 Ds <- LambdaS + LambdaSt diag(Ds) <- diagonal model$Wlist[[s]] <- tcrossprod(Z %*% Ds, Z) model$eWelist[[s]] <- as.numeric(e %*% model$Wlist[[s]] %*% e) # model$Wlist[[s]] <- model$Wlist[[s]]/norm(model$Wlist[[s]], type = "F") } ## Write everything into a return list model$X <- X model$n <- n model$theta <- theta model$Z <- Z model$Lambda <- Lambda model$Lambdat <- Lambdat model$V0inv <- V0inv model$A <- A if(analytic) { model$B <- matrix(0, length(theta), length(theta)) } else { model$B <- m@optinfo$derivs$Hessian } model$C <- matrix(0, length(theta), n) model$y <- y model$e <- e model$tye <- as.numeric(crossprod(y, e)) model$isREML <- isREML(m) return(model) } cAIC4/R/bcMer.R0000644000176200001440000000410514773607435012471 0ustar liggesusersbcMer <- function(object, method = NULL, B = NULL, sigma.penalty = 1, analytic = TRUE) { # A function that calls the bias correction functions. # # Args: # object = Object of class lmerMod or glmerMod. Obtained by lmer() or glmer() # or of class lme # method = How the bias correction should be evaluated. If NULL than method # is chosen by family, i.e. analytical if family is Poisson or # Gaussian and with parametric bootstrap for other. Method may also # be specified before, either "steinian" or "conditionalBootstrap". # "steinian" only available for Gaussian, Poisson and Bernoulli. # B = Number of Bootstrap replications. Default is NULL then it is # chosen as maximum of the number of observations and 100. # # Returns: # bc = Bias correction for a mixed model. # if (is.null(method) | inherits(object, "lme")) { switch(family(object)$family, binomial = { bc <- biasCorrectionBernoulli(object) }, poisson = { bc <- biasCorrectionPoisson(object) }, gaussian = { bc <- biasCorrectionGaussian(object, sigma.penalty, analytic) }, { cat("For this family no bias correction is currently available \n") bc <- NA } ) } else { if(method == "steinian") { switch(family(object)$family, binomial = { bc <- biasCorrectionBernoulli(object) }, poisson = { bc <- biasCorrectionPoisson(object) }, gaussian = { bc <- biasCorrectionGaussian(object, sigma.penalty, analytic) }, { cat("For this family no bias correction is currently available \n") bc <- NA } ) } if(method == "conditionalBootstrap") { if (is.null(B)) { B <- max(length(getME(object, "y")), 100) } bc <- conditionalBootstrap(object, B) } } return(bc) } cAIC4/R/helperfuns_lme.R0000644000176200001440000003004714773614674014460 0ustar liggesusers#' family function for lme objects to have a generic function #' @exportS3Method family lme #' @param object lme object #' @param ... unused #' @return returns a Gaussian distribution #' family.lme <- function(object, ...) gaussian() sort_sterms <- function(m) { ## takes an nlme::lme object, orders and renames the smooth parts of the ## lme$data part as they are ordered in gamm4() # gamm() sorts the s()-terms as they appear in the model formula. # gamm4() respects ordering of s()-terms by, first, the s()-term with the # highest k comes first, in case of equal k, the s()-term are ordered as they # appear in the model formula with the latter terms in the model formula # appearing former in the columns of Z. Disregarding the order would lead to # false matrix multiplication. # only the names attribute is left after sorting sterm_index <- grep("^Xr", names(m$data)) if(length(sterm_index) == 0) return(NULL) old_names <- names(m$data)[sterm_index] smooth_names <- attr(m, "smooth_names") names(m$data)[sterm_index] <- paste0("s.", smooth_names) knots_p_sterm <- sapply(m$data[sterm_index], ncol) # append old ordering to names for tracking later on names(knots_p_sterm) <- paste(names(knots_p_sterm), 1:length(knots_p_sterm), sep = ".." ) # if two single smooth terms have equal k uknots <- unique(knots_p_sterm) how_often_unique <- sapply(uknots, function(x) sum(knots_p_sterm %in% x)) knots_p_sterm <- sort(knots_p_sterm, decreasing = TRUE) if (length(uknots) == 1) knots_p_sterm <- rev(knots_p_sterm) if (any(how_often_unique > 1)) { # if multiple smooth terms have equal k g <- uknots[how_often_unique > 1] for (ind in g) { index <- which(ind == knots_p_sterm) names(knots_p_sterm)[index] <- rev(names(knots_p_sterm)[index]) } } n_knots <- names(knots_p_sterm) new_order <- as.numeric(substr(n_knots, nchar(n_knots), nchar(n_knots))) names(knots_p_sterm) <- substr(n_knots, 1, nchar(n_knots) - 3) attr(knots_p_sterm, "old_names") <- old_names[new_order] knots_p_sterm } get_names <- function(x) { # extracts the names of the smooth parts of an mgcv::gamm object and returns # them as they appear in the lme$data part of the original gamm$object. The # order of the terms is crucial later on owing to the different ordering of # smooth terms in gamm and gamm4. See sort_sterms for details. unlist(sapply(x$gam$smooth, function(x) { if (is.list(x[[1]])) { return(paste0(x$label, collapse = "_")) } # interaction te() x$label # regular s() })) } get_ST <- function(m) { # extracts from a fitted nlme::lme object and returns a list equivalent to # what is returned by getME(mer, "ST") theta <- get_theta(m) cnms <- attr(m$modelStruct$reStruct[[1]], "Dimnames")[1] # equivalent to lme4 cnms <- c(cnms, attr(m, "smooth_names")) # relevant for mgcv::gamm cnms <- cor_re(m, cnms) # if random itcpt and slope are dependent cnms changes no_re <- lengths(cnms) vec2mlist(theta, no_re) } # split vector at position and return a list with the splitted elements split_at <- function(x, pos) unname(split(x, cumsum(seq_along(x) %in% pos))) # vec2mlist, get_clen, vec2STlist and sdiag are functions taken from the lme4 # package vec2mlist <- function(v, n = NULL, symm = FALSE) { n <- get_clen(v, n) s <- split(v, rep.int(seq_along(n), n * (n + 1) / 2)) m <- mapply(function(x, n0) { m0 <- diag(nrow = n0) m0[lower.tri(m0, diag = TRUE)] <- x if (symm) { m0[upper.tri(m0)] <- t(m0)[upper.tri(m0)] } m0 }, s, n, SIMPLIFY = FALSE) m } get_clen <- function(v, n = NULL) { if (is.null(n)) { if (is.null(n <- attr(v, "clen"))) { n <- (sqrt(8 * length(v) + 1) - 1) / 2 } } n } vec2STlist <- function(v, n = NULL) { ch <- vec2mlist(v, n, FALSE) lapply(ch, function(L) { ST <- L %*% sdiag(1 / sdiag(L)) diag(ST) <- diag(L) ST }) } sdiag <- function(x) { if (length(x) == 1) { matrix(x, 1, 1) } else { diag(x) } } cor_re <- function(m, cnms) { # splits the first entry of cnms into two parts if random itcpt and slope # were modelled dependently and returns the splitted version if so if (!is_dep(m) & lengths(cnms[1]) == 2) { # uncorrelated re have different cnms dim than correlated ones rev(c(split_at(cnms[[1]], 2), cnms[-1])) } else { cnms } } get_D <- function(m) { # extracts getME(mer, "Lambda) %*% getME(mer, "Lambdat") first as in lme4 # and then returns the vCov of the random effects (D) in the order as they # are returned in lme4 (D = getME(mer, "Lambda) %*% getME(mer, "Lambdat") * # sigma(mer) ^ 2). This needs special treatment with repect to the smooth # terms which appear in different order inside the reStruct list and need to # ordered first. D_lt <- lapply(m$modelStruct$reStruct, as.matrix) n <- m$dims$ngrps[1] no_knots <- sum(attr(m, "ordered_smooth")) # in case of smooth terms if (length(D_lt) > 1) { D_lt_2 <- D_lt re_formula <- lapply(m$modelStruct$reStruct[-1], function(x) formula(x)) re_formula <- sapply(re_formula, function(x) as.character(x[[2]][[2]])) ordered_n <- attr(attr(m,"ordered_smooth"),"old_names") D_lt_2 <- D_lt_2[names(re_formula[match(ordered_n,re_formula)])] } D_lt <- lapply(1:n, function(x) D_lt[[1]]) # substitute for rep() with matrix D_lt <- bdiag(D_lt) # in case of independent random effects if (!is_dep(m) & m$dims$qvec[1] == 2) { D_lt <- diag(D_lt) fir <- D_lt[seq(1,length(D_lt),2)] sec <- D_lt[seq(1,length(D_lt),2) + 1] D_lt <- Matrix(diag(c(fir,sec))) if (!no_knots == 0) D_lt <- Matrix(diag(c(sec,fir))) } if (exists("D_lt_2")) return(bdiag(c(D_lt,bdiag(D_lt_2))) * sigma(m)^2) D_lt * sigma(m)^2 } get_theta <- function(m) { # extracts equivalent to getME(mer,"theta") from a nlme::lme. For now, only # random intercept (+ slope, correlated and uncorrelated) can be handled. re_vcov <- nlme::VarCorr(m) sigma <- sigma(m) rnames <- rownames(re_vcov) idx1 <- grep("(Intercept)", rnames) idx2 <- grep("Residual", rnames) var_re_itcpt <- as.numeric(re_vcov[idx1, "Variance"]) theta_1 <- matrix(sqrt(var_re_itcpt) / sigma) # more than a random intercept if (idx2 - idx1 > 1) { var_re_slope <- as.numeric(re_vcov[idx1 + 1, "Variance"]) D <- matrix(c(var_re_itcpt, 0L, 0L, var_re_slope), ncol = 2, byrow = TRUE) theta_1 <- sqrt(diag(D)) / sigma if (is_dep(m)) { cov_re <- as.numeric(re_vcov[idx1 + 1, "Corr"]) * sqrt(var_re_itcpt * var_re_slope) D[2:3] <- cov_re theta_1 <- base::chol(D) / sigma theta_1 <- theta_1[upper.tri(theta_1, diag = TRUE)] } } if (!attr(m, "is_gamm") | length(grep("^g.", rnames)) == 0) { return(theta_1) } spline_var <- as.numeric(re_vcov[grep("^g.", rnames) + 1, 1]) names(spline_var) <- attr(m, "smooth_names") # gamm order # these terms have gamm4 order ordered_sterms <- names(attr(m, "ordered_smooth")) ordered_sterms <- substr(ordered_sterms, 3, nchar(ordered_sterms)) # terms are now ordered in line with columns of getME(mer,"Z") spline_var <- spline_var[ordered_sterms] # has gamm4 order theta_2 <- sqrt(spline_var) / sigma c(theta_1, theta_2) } count_par <- function(m, sigma.estimated = TRUE) { # takes a fitted nlme::lme and returns the number of # estimated paramters that were used to specify the residual matrix of a mixed # model. Per default, the residual variance is assumed unknown and thus # estimated. var_str <- as.vector(m$modelStruct[["varStruct"]]) cor_str <- as.vector(m$modelStruct[["corStruct"]]) length(var_str) + length(cor_str) + sigma.estimated } is_dep <- function(m) "Corr" %in% colnames(nlme::VarCorr(m)) get_Z <- function(m) { ## extracts equivalent to getME(mer,"Z") from a nlme::lme object. # the spline part of RLRsim::extract.lmeDesign$Z is not convenient for usage # since the ordering of the columns is not arbitrary and not in line with # getME(mer,"Z") Z_try <- RLRsim::extract.lmeDesign(m)$Z no_knots <- sum(attr(m, "ordered_smooth")) # get (true) random effect part from Z matrix random_part <- Z_try[, (no_knots + 1):ncol(Z_try)] if (!is_dep(m) & m$dims$qvec[1] == 2) { col <- seq(1,ncol(random_part),2) fir <- random_part[,col, drop = FALSE] sec <- random_part[,col + 1, drop = FALSE] random_part <- cbind(fir,sec) if (!no_knots == 0) random_part <- cbind(sec, fir) } # get the spline part of Z order it according to getME(mer,"Z") spline_part <- m$data[attr(attr(m, "ordered_smooth"), "old_names")] Matrix(as.matrix(cbind(random_part, spline_part))) } get_LambdaT <- function(m) { # extracts equivalent to getME(mer,"Lambdat") from a nlme::lme object. D <- get_D(m) # relative covariance (divide by residual variance) rel_vcov <- D / (sigma(m)^2) # may consider Cholesky() instead: Cholesky(chol_prep, LDL = FALSE, Imult=1) list(LambdaT = Matrix(base::chol(rel_vcov)), D = D) } get_L <- function(m) { # extracts equivalent to getME(mer,"L") from a nlme::lme object # weights <- weights(m) # if(length(weights) == 0) weights <- rep(1,nrow(m$data)) # sqrtW <- Diagonal(x = sqrt(as.numeric(weights))) # ZtW <- Zt %*% sqrtW Zt <- t(get_Z(m)) R <- get_R(m)/(sigma(m)^2) ZtW <- Zt %*% chol(R) Lambdat <- get_LambdaT(m) as( Cholesky(tcrossprod(Lambdat %*% ZtW), LDL = FALSE, Imult = 1), "sparseMatrix" ) } get_RX <- function(m) { # extracts equivalent to getME(mer,"RX") from a nlme::lme object chol(solve(m$varFix)) * sigma(m) } get_Lind <- function(m) { # extracts equivalent to getME(mer,"RX") from a nlme::lme object no_re <- m$dims$qvec[[1]] + (is_dep(m)) l_re <- no_re <= 2 n_groups <- m$dims$ngrps[[1]] knots_p_sterm <- attr(m, "ordered_smooth") i_g <- attr(m, "is_gamm") if ((!i_g & l_re) | (i_g & is.null(knots_p_sterm) & l_re)) { return(rep(1:no_re, each = n_groups)) } if (!i_g | (i_g & is.null(knots_p_sterm))) { return(rep(1:no_re, n_groups)) } term <- 1:length(knots_p_sterm) + no_re vemp <- vector("list", length(term)) for (ind in seq_len(length(term))) { vemp[[ind]] <- rep(term[ind],knots_p_sterm[ind]) } if (l_re) { return(c(rep(1:no_re, each = n_groups), unlist(vemp))) } c(rep(1:no_re, n_groups), unlist(vemp)) } get_R <- function(m) { # returns the cond. VCov of a mixed model fitted with nlme::lme as a block - # diag matrix. In the case of homoscedastic error variance the main diagonal # contains sigma(m)^2. For now, a nested mixed model can not be handled. # some gamms contain a pesudo nesting structure (s-terms) which needs # to be exlcuded nlev_col <- sapply(m$groups, nlevels) if (ncol(m$groups) > 1) m$groups <- m$groups[, nlev_col > 1, drop = FALSE] n <- m$dims$ngrps[1] vcov_list <- sapply(1:n, function(x) nlme::getVarCov(m, type = "conditional", x )) Matrix::bdiag(vcov_list) } get_D_RLRSim <- function(m) { # extracts getME(mer, "Lambda) %*% getME(mer, "Lambdat") first as in lme4 # and then returns the vCov of the random effects (D) in the order as they # are returned in lme4 (D = getME(mer, "Lambda) %*% getME(mer, "Lambdat") * # sigma(mer) ^ 2). This needs special treatment with repect to the smooth # terms which appear in different order inside the reStruct list and need to # ordered first. res <- RLRsim::extract.lmeDesign(m) D <- res$Vr * res$sigmasq # inverse order of splines and re coefs # find vcov coef that belong to splines and those who belong to true re spline_index <- grep("^g", names(m$coefficients$random)) no_knots <- length(unlist(m$coefficients$random[spline_index])) last_index <- nrow(D) if (length(spline_index) != 0) { # seperate parts spline_vcov <- D[1:no_knots, 1:no_knots] random_vcov <- D[(no_knots + 1):last_index, (no_knots + 1):last_index] # build D matrix as in gamm4() by just reordering D from RLRsim D <- matrix(0L, nrow = nrow(res$Vr), ncol = ncol(res$Vr)) # prepare D[1:(last_index - no_knots), 1:(last_index - no_knots)] <- random_vcov D[(last_index - no_knots + 1):last_index, (last_index - no_knots + 1): last_index] <- spline_vcov } D } cAIC4/R/modelAvg.R0000644000176200001440000000604114773602310013163 0ustar liggesusers#' Model Averaging for Linear Mixed Models #' #' Function to perform model averaging for linear mixed models based #' on the weight selection criterion as proposed by Zhang et al. (2014). #' #' @param models A list object containing all considered candidate models fitted by #' \code{\link[lme4]{lmer}} of the lme4-package or of class #' \code{\link[nlme]{lme}}. #' @param opt logical. If TRUE (the default) the model averaging approach based #' on Zhang et al. is applied. If FALSE the underlying weights are calculated #' as smoothed weights as proposed by Buckland et al. (1997). #' @return An object containing the function calls of the underlying candidate models, #' the values of the model averaged fixed effects, the values of the model averaged random effects, #' the results of the weight optimization process, as well as a list of the candidate models themselves. #' @author Benjamin Saefken & Rene-Marcel Kruse #' @seealso \code{\link[lme4]{lme4-package}}, \code{\link[lme4]{lmer}} #' @references Greven, S. and Kneib T. (2010) On the behaviour of marginal and #' conditional AIC in linear mixed models. Biometrika 97(4), 773-789. #' @references Zhang, X., Zou, G., & Liang, H. (2014). Model averaging and #' weight choice in linear mixed-effects models. Biometrika, 101(1), 205-218. #' @rdname modelAvg #' @export modelAvg #' @examples #' data(Orthodont, package = "nlme") #' models <- list( #' model1 <- lmer(formula = distance ~ age + Sex + (1 | Subject) + age:Sex, #' data = Orthodont), #' model2 <- lmer(formula = distance ~ age + Sex + (1 | Subject), #' data = Orthodont), #' model3 <- lmer(formula = distance ~ age + (1 | Subject), #' data = Orthodont), #' model4 <- lmer(formula = distance ~ Sex + (1 | Subject), #' data = Orthodont)) #' foo <- modelAvg(models = models) #' foo #' #' modelAvg <- function(models, opt = TRUE){ call <- match.call() if (opt == TRUE) { tempres <- getWeights(models) } else { invisible(capture.output(tempres <-anocAIC(models))) tempres$delta<- tempres$cAIC - min(tempres$cAIC) tempres$weights <- exp(-tempres$delta / 2) / sum(exp(-tempres$delta / 2)) } # calculation model averaged coefficients betas <- list() for (i in 1:length(models)) { betas[[i]] <- getME(models[[i]], "fixef") } avg.betas <- list() for (i in 1:length(models)) { avg.betas[[i]] <- betas[[i]]*tempres$weights[i] } sum.avg.betas <- tapply((unlist(avg.betas)), names(unlist(avg.betas)), FUN = sum) # random effects rand <- list() for (i in 1:length(models)) { rand[[i]] <- ranef(models[[i]]) } avg.rand <- list() for (i in 1:length(models)) { dummy <- unlist(rand[[i]]) avg.rand[[i]] <- dummy*tempres$weight[i] } sum.avg.rand <- tapply((unlist(avg.rand)), names(unlist(avg.rand)), FUN = sum) res <- list(call = call, fixeff = sum.avg.betas, raneff = sum.avg.rand, optimresults = tempres, candidatmodels = models) } cAIC4/R/datasets.R0000644000176200001440000000205114773602310013232 0ustar liggesusers#' Data from Gu and Wahba (1991) #' #' @name guWahbaData #' @description Data from Gu and Wahba (1991) which is used for demonstrative purposes to exemplarily fit #' a generalized additive mixed model. #' @docType data #' @references Gu and Wahba (1991) Minimizing GCV/GML scores with multiple smoothing parameters #' via the Newton method. SIAM J. Sci. Statist. Comput. 12:383-398 #' @keywords data NULL #' Subset of the Zambia data set on childhood malnutrition #' #' @name Zambia #' @description Data analyzed by Kandala et al. (2001) which is used for demonstrative purposes to #' estimate linear mixed and additive models using a stepwise procedure on the basis of the cAIC. #' The full data set is #' available at \url{https://www.uni-goettingen.de/de/551625.html}. #' @docType data #' @references Kandala, N. B., Lang, S., Klasen, S., Fahrmeir, L. (2001): #' Semiparametric Analysis of the Socio-Demographic and Spatial #' Determinants of Undernutrition in Two African Countries. #' Research in Official Statistics, 1, 81-100. #' @keywords data NULLcAIC4/R/weightOptim.R0000644000176200001440000002100014773602310013715 0ustar liggesusers.weightOptim = function(weights, lm, targets, hess, lambda, scaler, .envi) { m <- get("m", envir = .envi) y <- get("y", envir = .envi) mue <- get("mu", envir = .envi) varDF <- get("varDF", envir = .envi) find_weights <- get("find_weights", envir = .envi) lowb <- get("lowb", envir = .envi) uppb <- get("uppb", envir = .envi) equB <- get("equB", envir = .envi) rho <- 0 maxit <- 800 delta <- (1.0e-7) tol <- (1.0e-8) numw <- length(m) ind <- 1 l <- c(0,0,0) p0 <- weights ab <- cbind(lowb,uppb) st <- numeric() ptt <- matrix() sc <- numeric() # scale the cost, the equality constraints, the inequality constraints, # the parameters (inequality parameters AND actual parameters), targets <- targets / scaler[ 1:2 ] p0 <- p0 / scaler[ 3:(numw + 2) ] mm <- numw ab <- ab / cbind(scaler[ 3:(mm + 2) ], scaler[ 3:(mm + 2) ]) # scale the lagrange multipliers and the Hessian lm <- scaler[2] * lm / scaler[ 1 ] hess <- hess * (scaler[ 3:(numw + 2) ] %*% t(scaler[ 3:(numw + 2)]) ) / scaler[ 1 ] j <- targets[ 1 ] a <- matrix(0, nrow = 1, ncol = numw) g <- rep(0, times = length(m)) p <- p0 [ 1:numw ] constraint <- targets[ 2 ] # gradient: for( i in 1:numw ) { p0[ i ] <- p0[ i ] + delta tmpv <- p0[ 1:numw ] * scaler[ 3:(numw + 2) ] funv <- find_weights(tmpv) eqv <- (sum(tmpv) - equB) targets <- c(funv, eqv) / scaler[ 1:2] g[ i ] <- (targets[ 1 ] - j) / delta a[ , i ]<- (targets[ 2 ] - constraint) / delta p0[ i ] <- p0[ i ] - delta } b <- a %*% p0 - constraint ind <- -1 l[1] <- tol - max(abs(constraint)) if( l[ 1 ] <= 0 ) { ind <- 1 p0[ numw + 1 ] <- 1 a <- cbind(a, -constraint) cx <- cbind(matrix(0, nrow = 1, ncol = numw), 1) dx <- rep(1, times = length(m)+1) go <- 1 minit <- 0 while( go >= tol ) { minit <- minit + 1 gap <- cbind(p0[ 1:mm ] - ab[ , 1 ], ab[ , 2 ] - p0[ 1:mm ] ) gap <- t( apply( gap, 1, FUN=function( x ) sort(x) ) ) dx[ 1:mm ] <- gap[ , 1 ] dx[ numw + 1 ] <- p0[ numw + 1 ] y <- try( qr.solve( t( a %*% diag( as.numeric(dx) , length(dx), length(dx) ) ), dx * t(cx) ), silent = TRUE) if(inherits(y, "try-error")){ p <- p0 * scaler[ 3:(numw + 2) ] y <- 0 hess <- scaler[ 1 ] * hess / (scaler[ 3:(numw + 2) ] %*% t(scaler[ 3:(numw + 2) ]) ) ans <- list(p = p, y = y, hess = hess, lambda = lambda) return(ans) } v <- dx * ( dx *(t(cx) - t(a) %*% y) ) if( v[ numw + 1 ] > 0 ) { z <- p0[ numw + 1 ] / v[ numw + 1 ] for( i in 1:mm ) { if( v[ i ] < 0 ) { z <- min(z, -(ab[ i, 2 ] - p0[ i ]) / v[ i ]) } else if( v[ i ] > 0 ) { z <- min( z, (p0[ i ] - ab[ i , 1 ]) / v[ i ]) } } if( z >= p0[ numw + 1 ] / v[ numw + 1 ] ) { p0 <- p0 - z * v } else { p0 <- p0 - 0.9 * z * v } go <- p0[ numw + 1 ] if( minit >= 10 ) { go <- 0 } } else { go <- 0 minit <- 10 } } a <- matrix(a[ , 1:numw ], ncol = numw) b <- a %*% p0[ 1:numw ] } p <- p0 [ 1:numw ] y <- 0 if( ind > 0 ) { tmpv <- p[ 1:numw ] * scaler[ 3:(numw + 2) ] funv <- find_weights(tmpv) eqv <- (sum(tmpv) - equB) targets <- c(funv, eqv) / scaler[ 1:2 ] } j <- targets[ 1 ] targets[ 2 ] <- targets[ 2 ] - a %*% p + b j <- targets[ 1 ] - t(lm) %*% matrix(targets[ 2 ], ncol=1) + rho * targets[ 2 ]^2 minit <- 0 while( minit < maxit ) { minit <- minit + 1 if( ind > 0 ) { for( i in 1:numw ) { p[ i ] <- p[ i ] + delta tmpv <- p[ 1:numw ] * scaler[ 3:(numw + 2) ] funv <- find_weights(tmpv) eqv <- (sum(tmpv) - equB) targetsm <- c(funv, eqv) / scaler[ 1:2 ] targetsm[ 2 ] <- targetsm[ 2 ] - a %*% p + b targetsm <- targetsm[ 1 ] - t(lm) %*% targetsm[ 2 ] + rho * targetsm[ 2 ]^2 g[ i ] <- (targetsm - j) / delta p[ i ] <- p[ i ] - delta } } if( minit > 1 ) { yg <- g - yg sx <- p - sx sc[ 1 ] <- t(sx) %*% hess %*% sx sc[ 2 ] <- t(sx) %*% yg if( (sc[ 1 ] * sc[ 2 ]) > 0 ) { sx <- hess %*% sx hess <- hess - ( sx %*% t(sx) ) / sc[ 1 ] + ( yg %*% t(yg) ) / sc[ 2 ] } } dx <- matrix(rep(0.1, times = numw), nrow = numw, ncol = 1) gap <- cbind(p[ 1:mm ] - ab[ , 1 ], ab[ , 2 ] - p[ 1:mm ]) gap <- t( apply( gap, 1, FUN = function( x ) sort(x) ) ) gap <- gap[ , 1 ] + sqrt(.Machine$double.eps) * rep(1, times = mm) dx[ 1:mm, 1 ] <- rep(1, times = mm) / gap go <- -1 lambda <- lambda / 10 while( go <= 0 ) { cz <- try(chol( hess + lambda * diag( as.numeric(dx * dx), length(dx), length(dx) ) ), silent = TRUE) if(inherits(cz, "try-error")){ p <- p * scaler[ 3:(numw + 2) ] y <- 0 hess <- scaler[ 1 ] * hess / (scaler[ 3:(numw + 2) ] %*% t(scaler[ 3:(numw + 2) ]) ) ans <- list(p = p, y = y, hess = hess, lambda = lambda) return(ans) } cz <- try(solve(cz), silent = TRUE) if(inherits(cz, "try-error")){ p <- p * scaler[ 3:(numw + 2) ] y <- 0 hess <- scaler[ 1 ] * hess / (scaler[ 3:(numw + 2) ] %*% t(scaler[ 3:(numw + 2) ]) ) ans <- list(p = p, y = y, hess = hess, lambda = lambda) return(ans) } yg <- t(cz) %*% g y <- try( qr.solve(t(cz) %*% t(a), yg), silent = TRUE ) if(inherits(y, "try-error")){ p <- p * scaler[ 3:(numw + 2) ] y <- 0 hess <- scaler[ 1 ] * hess / (scaler[ 3:(numw + 2) ] %*% t(scaler[ 3:(numw + 2) ]) ) ans <- list(p = p, y = y, hess = hess, lambda = lambda) return(ans) } u <- -cz %*% (yg - ( t(cz) %*% t(a) ) %*% y) p0 <- u[ 1:numw ] + p go <- min( c(p0[ 1:mm ] - ab[ , 1 ], ab[ , 2 ] - p0[ 1:mm ]) ) lambda <- 3 * lambda } l[ 1 ] <- 0 targets1 <- targets targets2 <- targets1 st[ 1 ] <- j st[ 2 ] <- j ptt <- cbind(p, p) l[ 3 ] <- 1.0 ptt <- cbind(ptt, p0) tmpv <- ptt[ 1:numw, 3 ] * scaler[ 3:(numw + 2) ] funv <- find_weights(tmpv) eqv <- (sum(tmpv) - equB) targets3 <- c(funv, eqv) / scaler[ 1:2 ] st[ 3 ] <- targets3[ 1 ] targets3[ 2 ] <- targets3[ 2 ] - a %*% ptt[ , 3 ] + b st[ 3 ] <- targets3[ 1 ] - t(lm) %*% targets3[ 2 ] + rho * targets3[ 2 ] ^ 2 go <- 1 while( go > tol ) { l[ 2 ] <- (l[ 1 ] + l[ 3 ]) / 2 ptt[ , 2 ] <- (1 - l[ 2 ]) * p + l[ 2 ] * p0 tmpv <- ptt[ 1:numw, 2 ] * scaler[ 3:(numw + 2) ] funv <- find_weights(tmpv) eqv <- (sum(tmpv) - equB) targets2 <- c(funv, eqv) / scaler[ 1:2 ] st[ 2 ] <- targets2[ 1 ] targets2[ 2 ] <- targets2[ 2 ] - a %*% ptt[ , 2 ] + b st[ 2 ] <- targets2[ 1 ] - t(lm) %*% targets2[ 2 ] + rho * targets2[ 2 ] ^ 2 targetsm <- max(st) if( targetsm < j ) { targetsn <- min(st) go <- tol * (targetsm - targetsn) / (j - targetsm) } # Conditions: con1 <- st[ 2 ] >= st[ 1 ] con2 <- st[ 1 ] <= st[ 3 ] && st[ 2 ] < st[ 1 ] con3 <- st[ 2 ] < st[ 1 ] && st[ 1 ] > st[ 3 ] if( con1 ) { st[ 3 ] <- st[ 2 ] targets3 <- targets2 l[ 3 ] <- l[ 2 ] ptt[ , 3 ] <- ptt[ , 2 ] } if( con2 ) { st[ 3 ] <- st[ 2 ] targets3 <- targets2 l[ 3 ] <- l[ 2 ] ptt[ , 3 ] <- ptt[ , 2 ] } if( con3 ) { st[ 1 ] <- st[ 2 ] targets1 <- targets2 l[ 1 ] <- l[ 2 ] ptt[ , 1 ] <- ptt[ , 2 ] } if( go >= tol ) { go <- l[ 3 ] - l[ 1 ] } } sx <- p yg <- g ind <- 1 targetsn <- min(st) if( j <= targetsn ) { maxit <- minit } reduce <- (j - targetsn) / ( 1 + abs(j) ) if( reduce < tol ) { maxit <- minit } con1 <- st[ 1 ] < st[ 2 ] con2 <- st[ 3 ] < st[ 2 ] && st[ 1 ] >= st[ 2 ] con3 <- st[ 1 ] >= st[ 2 ] && st[ 3 ] >= st[ 2 ] if( con1 ) { j <- st[ 1 ] p <- ptt[ , 1 ] targets <- targets1 } if( con2 ) { j <- st [ 3 ] p <- ptt[ , 3 ] targets <- targets3 } if( con3 ) { j <- st[ 2 ] p <- ptt[ , 2 ] targets <- targets2 } } p <- p * scaler[ 3:(numw + 2) ] y <- scaler[ 1 ] * y / scaler[ 2 ] hess <- scaler[ 1 ] * hess / (scaler[ 3:(numw + 2) ] %*% t(scaler[ 3:(numw + 2) ]) ) ans <- list(p = p, y = y, hess = hess, lambda = lambda) return( ans ) } cAIC4/R/stepcAIC.R0000644000176200001440000006064214773602310013067 0ustar liggesusers#' Function to stepwise select the (generalized) linear mixed model #' fitted via (g)lmer() or (generalized) additive (mixed) model #' fitted via gamm4() with the smallest cAIC. #' #' #' The step function searches the space of possible models in a greedy manner, #' where the direction of the search is specified by the argument #' direction. If direction = "forward" / = "backward", #' the function adds / exludes random effects until the cAIC can't be improved further. #' In the case of forward-selection, either a new grouping structure, new #' slopes for the random effects or new covariates modeled nonparameterically #' must be supplied to the function call. #' If direction = "both", the greedy search is alternating between forward #' and backward steps, where the direction is changed after each step #' #'@param object object returned by \code{[lme4]{lmer}}, \code{[lme4]{glmer}} or #'\code{[gamm4]{gamm4}} #'@param numberOfSavedModels integer defining how many additional models to be saved #'during the step procedure. If \code{1} (DEFAULT), only the best model is returned. #'Any number \code{k} greater \code{1} will return the \code{k} best models. #'If \code{0}, all models will be returned (not recommended for larger applications). #'@param groupCandidates character vector containing names of possible grouping variables for #'new random effects. Group nesting must be specified manually, i.e. by #'listing up the string of the groups in the manner of lme4. For example #'\code{groupCandidates = c("a", "b", "a/b")}. #'@param slopeCandidates character vector containing names of possible new random effects #'@param fixEfCandidates character vector containing names of possible (non-)linear fixed effects #'in the GAMM; NULL for the (g)lmer-use case #'@param direction character vector indicating the direction ("both","backward","forward") #'@param numberOfPermissibleSlopes how much slopes are permissible for one grouping variable #'@param trace logical; should information be printed during the execution of stepcAIC? #'@param steps maximum number of steps to be considered #'@param keep list($fixed,$random) of formulae; which splines / fixed (fixed) or #'random effects (random) to be kept during selection; specified terms must be #'included in the original model #'@param numCores the number of cores to be used in calculations; #'parallelization is done by using \code{parallel::mclapply} #'@param data data.frame supplying the data used in \code{object}. \code{data} must also include #'variables, which are considered for forward updates. #'@param returnResult logical; whether to return the result (best model and corresponding cAIC) #'@param calcNonOptimMod logical; if FALSE, models which failed to converge are not considered #'for cAIC calculation #'@param bsType type of splines to be used in forward gamm4 steps #'@param allowUseAcross allow slopes to be used in other grouping variables #'@param allowCorrelationSel logical; FALSE does not allow correlations of random effects #'to be (de-)selected (default) #'@param allowNoIntercept logical; FALSE does not allow random effects without random intercept #'@param digits number of digits used in printing the results #'@param printValues what values of \code{c("cll", "df", "caic", "refit")} #'to print in the table of comparisons #'@param ... further options for cAIC call #'@section Details: #' #' Note that the method can not handle mixed models with uncorrelated random effects and does NOT #' reduce models to such, i.e., the model with \code{(1 + s | g)} is either reduced to #' \code{(1 | g)} or \code{(0 + s | g)} but not to \code{(1 + s || g)}. #' @return if \code{returnResult} is \code{TRUE}, a list with the best model \code{finalModel}, #' \code{additionalModels} if \code{numberOfSavedModels} was specified and #' the corresponding cAIC \code{bestCAIC} is returned. #' #' Note that if \code{trace} is set to \code{FALSE} and \code{returnResult} #' is also \code{FALSE}, the function call may not be meaningful #' @author David Ruegamer #' @export #' @import parallel #' @importFrom stats as.formula dbinom dnorm dpois family #' formula glm lm model.frame model.matrix #' predict reformulate simulate terms #' @importFrom utils combn #' @importFrom stats4 logLik #' @examples #' #' (fm3 <- lmer(strength ~ 1 + (1|sample) + (1|batch), Pastes)) #' #' fm3_step <- stepcAIC(fm3, direction = "backward", trace = TRUE, data = Pastes) #' #' fm3_min <- lm(strength ~ 1, data=Pastes) #' #' fm3_min_step <- stepcAIC(fm3_min, groupCandidates = c("batch", "sample"), #' direction="forward", data=Pastes, trace=TRUE) #' fm3_min_step <- stepcAIC(fm3_min, groupCandidates = c("batch", "sample"), #' direction="both", data=Pastes, trace=TRUE) #' # try using a nested group effect which is actually not nested -> warning #' fm3_min_step <- stepcAIC(fm3_min, groupCandidates = c("batch", "sample", "batch/sample"), #' direction="both", data=Pastes, trace=TRUE) #' #' Pastes$time <- 1:dim(Pastes)[1] #' fm3_slope <- lmer(data=Pastes, strength ~ 1 + (1 + time | cask)) #' #' fm3_slope_step <- stepcAIC(fm3_slope,direction="backward", trace=TRUE, data=Pastes) #' #' #' #' fm3_min <- lm(strength ~ 1, data=Pastes) #' #' fm3_min_step <- stepcAIC(fm3_min,groupCandidates=c("batch","sample"), #' direction="forward", data=Pastes,trace=TRUE) #' #' #' #' fm3_inta <- lmer(strength ~ 1 + (1|sample:batch), data=Pastes) #' #' fm3_inta_step <- stepcAIC(fm3_inta,groupCandidates=c("batch","sample"), #' direction="forward", data=Pastes,trace=TRUE) #' #' fm3_min_step2 <- stepcAIC(fm3_min,groupCandidates=c("cask","batch","sample"), #' direction="forward", data=Pastes,trace=TRUE) #' #' fm3_min_step3 <- stepcAIC(fm3_min,groupCandidates=c("cask","batch","sample"), #' direction="both", data=Pastes,trace=TRUE) #' #' \dontrun{ #' fm3_inta_step2 <- stepcAIC(fm3_inta,direction="backward", #' data=Pastes,trace=TRUE) #' } #' #' ##### create own example #' #' #' na <- 20 #' nb <- 25 #' n <- 400 #' a <- sample(1:na,400,replace=TRUE) #' b <- factor(sample(1:nb,400,replace=TRUE)) #' x <- runif(n) #' y <- 2 + 3 * x + a*.02 + rnorm(n) * .4 #' a <- factor(a) #' c <- interaction(a,b) #' y <- y + as.numeric(as.character(c))*5 #' df <- data.frame(y=y,x=x,a=a,b=b,c=c) #' #' smallMod <- lm(y ~ x) #' #' \dontrun{ #' # throw error #' stepcAIC(smallMod, groupCandidates=c("a","b","c"), data=df, trace=TRUE, returnResult=FALSE) #' #' smallMod <- lm(y ~ x, data=df) #' #' # throw error #' stepcAIC(smallMod, groupCandidates=c("a","b","c"), data=df, trace=TRUE, returnResult=FALSE) #' #' # get it all right #' mod <- stepcAIC(smallMod, groupCandidates=c("a","b","c"), #' data=df, trace=TRUE, #' direction="forward", returnResult=TRUE) #' #' # make some more steps... #' stepcAIC(smallMod, groupCandidates=c("a","b","c"), data=df, trace=TRUE, #' direction="both", returnResult=FALSE) #' #' mod1 <- lmer(y ~ x + (1|a), data=df) #' #' stepcAIC(mod1, groupCandidates=c("b","c"), data=df, trace=TRUE, direction="forward") #' stepcAIC(mod1, groupCandidates=c("b","c"), data=df, trace=TRUE, direction="both") #' #' #' #' mod2 <- lmer(y ~ x + (1|a) + (1|c), data=df) #' #' stepcAIC(mod2, data=df, trace=TRUE, direction="backward") #' #' mod3 <- lmer(y ~ x + (1|a) + (1|a:b), data=df) #' #' stepcAIC(mod3, data=df, trace=TRUE, direction="backward") #' #' } #' stepcAIC <- function(object, numberOfSavedModels = 1, groupCandidates = NULL, slopeCandidates = NULL, fixEfCandidates = NULL, numberOfPermissibleSlopes = 2, allowUseAcross = FALSE, allowCorrelationSel = FALSE, allowNoIntercept = FALSE, direction = "backward", trace = FALSE, steps = 50, keep = NULL, numCores = 1, data = NULL, returnResult = TRUE, calcNonOptimMod = TRUE, bsType = "tp", digits = 2, printValues = "caic", ...) { ####################################################################### ########################## pre-processing ############################# ####################################################################### if(!is.null(data)){ data <- get(deparse(substitute(data)), envir = parent.frame()) if(inherits(object, c("lmerMod", "glmerMod"))) attr(data, "orgname") <- as.character(object@call[["data"]]) else attr(data, "orgname") <- as.character(object$call[["data"]]) }else if(inherits(object, c("lmerMod", "glmerMod"))){ data <- get(deparse(object@call[["data"]]), envir = parent.frame()) attr(data, "orgname") <- as.character(object@call[["data"]]) }else{ stop("argument data must be supplied!") } possible_predictors <- colnames(data) ### build nesting in groupCandidates nestCands <- groupCandidates[grep("/", groupCandidates)] nestCands <- nestCands[!nestCands %in% possible_predictors] for(nc in nestCands){ # check if really nested ncc <- trimws(strsplit(nc, "/")[[1]]) if(!isNested(data[,ncc[1]], data[,ncc[2]])){ warning(paste0("Dropping incorrect nesting group ", nc, " from groupCandidates.")) }else{ groupCandidates <- unique( c(groupCandidates, allNestSubs(nc)) ) } groupCandidates <- setdiff(groupCandidates, nc) } # intaCands <- groupCandidates[grep(":", groupCandidates)] # if(length(intaCands) > 0) intaCands <- intaCands[!intaCands %in% possible_predictors] # for(ic in intaCands){ # sepIc <- trimws(strsplit(ic, ":")[[1]]) # if(cor(sapply(data[,sepIc], as.numeric))==1) # stop(paste0("Interaction of ", sepIc, " not meaningful.")) # } existsNonS <- FALSE ### check if gamm4-call if(is.list(object) & length(object)==2 & all(c("mer","gam") %in% names(object))){ if(allowUseAcross | !is.null(slopeCandidates)) stop("allowUseAcross and slopeCandidates are not permissible for gamm4-objects!") ig <- mgcv::interpret.gam(object$gam$formula) existsNonS <- length(ig$smooth.spec) get cAIC of input model if(inherits(object, c("lmerMod", "glmerMod")) | "mer"%in%names(object)){ timeBefore <- Sys.time() cAICofMod <- tryCatch(cAIC(object,...), error = function(e){ cat("\n\nThe cAIC of the initial model can not be calculated. Continue Anyway?") readline("If so, type 'y': ") }) if(!is.numeric(cAICofMod$caic) && cAICofMod=="y"){ cAICofMod <- Inf }else if(!is.numeric(cAICofMod$caic) && cAICofMod!="y") return(NULL) refit <- cAICofMod$new # if(refit==1 & inherits(object, c("lmerMod", "glmerMod"))) # object <- cAICofMod$reducedModel cAICofMod <- cAICofMod$caic timeForCalc <- Sys.time() - timeBefore }else if(any(class(object)%in%c("lm","glm"))){ # ll <- getGLMll(object) # bc <- attr(logLik(object),"df") cAICofMod <- cAIC(object)$caic #-2*ll + 2*bc if(direction=="backward") stop("A simple (generalized) linear model can't be reduced!") }else{ stop("Class of object is not known") } # check if call is inherently consistent if(!( direction=="backward" | ( direction %in% c("forward","both") & ( !is.null(groupCandidates) | !is.null(slopeCandidates) | !is.null(fixEfCandidates) ) ) | ( direction %in% c("forward","both") & is.null(groupCandidates) & is.null(slopeCandidates) & is.null(fixEfCandidates) & ( allowUseAcross | existsNonS ) ) )) stop("Can not make forward steps without knowledge of additional random effect covariates.") if( direction=="backward" & !( is.null(groupCandidates) & is.null(slopeCandidates) & is.null(fixEfCandidates) ) ) warning("Ignoring variables in group-/slopeCandidates or fixEfCandidates for backward steps.") ####################################################################### ########################## (end) ############################# ####################################################################### ####################################################################### ####################### iteratively fitting ########################### ####################################################################### # indicator to break while loop stepsOver <- FALSE # indicator for direction=="both" dirWasBoth <- ifelse( direction=="both", TRUE, FALSE ) # indicator for improvement in direction=="both" - step improvementInBoth <- TRUE # indicator for check if step procedure didnt yield better # results compared to the previous step equalToLastStep <- FALSE # change direction to either forward or backward direction <- ifelse( direction%in%c("both","forward"),"forward","backward" ) # get the initial number of steps stepsInit <- steps ################################################################### ####################### iterative part ############################ ################################################################### if(trace){ cat("Starting stepwise procedure...") cat("\n_____________________________________________\n") cat("_____________________________________________\n") } # try to improve the model as long as stepsOver==FALSE while(!stepsOver){ # get all components needed for stepping procedure comps <- getComponents(object) newSetup <- if(direction=="forward"){ makeForward(comps=comps, slopeCandidates=slopeCandidates, groupCandidates=groupCandidates, fixEfCandidates=fixEfCandidates, nrOfCombs=numberOfPermissibleSlopes, allowUseAcross=allowUseAcross, allowCorrelationSel=allowCorrelationSel, bsType=bsType, keep=keep) }else{ makeBackward(comps=comps, keep=keep, allowCorrelationSel=allowCorrelationSel, allowNoIntercept=allowNoIntercept) } if(all(sapply(newSetup, is.null)) & direction=="forward") { if(trace){ cat("\nBest model: ", makePrint(object), "\ncAIC:", cAICofMod, "\n_____________________________________________\n") # cat("\nModel can not be further extended.") if(refit==1) cat("\nBest model should be refitted due to zero variance components.\n") } return(list(finalModel=object, additionalModels=NULL, bestCAIC=cAICofMod) ) } ########################### printing ############################## if(trace) { cat("\nStep ",stepsInit-steps+1," (",direction,"): cAIC=", format(round(cAICofMod, 4)), "\n", "Best model so far:\n", makePrint(object), "\n", sep = "") utils::flush.console() } ################################################################### steps = steps - 1 if(trace) cat("New Candidates:\n\n") newSetup <- mergeChanges(initialParts=comps, listParts=newSetup) ### ( print ) ### if(trace & !is.null(newSetup)) cat("Calculating cAIC for", length(newSetup), "model(s) ...\n") ############# ### calculate all other models and cAICs tempRes <- if(!is.null(newSetup)){ calculateAllCAICs(newSetup=newSetup, modelInit=object, numCores=numCores, data=data, calcNonOptimMod=calcNonOptimMod, nrmods=numberOfSavedModels, ...) } ############## if(is.list(tempRes) & !is.null(tempRes$message)){ # gamm4 with error warning(paste0("There are zero variance components.\n", tempRes$message)) if(returnResult){ return(list(finalModel=object, additionalModels=additionalModels, bestCAIC=cAICofMod) ) }else{ return(invisible(NULL)) } } ### get performance aicTab <- as.data.frame(tempRes$aicTab) ### ( print ) ### if (trace) { cat("\n") print(aicTab[with(aicTab,order(-caic)), c("models",printValues)], row.names = FALSE, digits = digits) cat("\n_____________________________________________\n") cat("_____________________________________________\n") utils::flush.console() } caicsres <- attr(tempRes$bestMod, "caic") bestModel <- tempRes$bestMod[[which.min(caicsres)]] if(numberOfSavedModels > 1 & length(tempRes$bestMod) > 0){ additionalModels <- c(additionalModels, tempRes$bestMod) # check for duplicates among models duplicates <- duplicatedMers(additionalModels) # remove duplicates additionalModels <- additionalModels[!duplicates] additionalCaics <- c(additionalCaics, caicsres)[!duplicates] bestCaics <- order(additionalCaics, decreasing = FALSE)[ 1:min(numberOfSavedModels, length(additionalCaics)) ] additionalModels <- additionalModels[bestCaics] additionalCaics <- additionalCaics[bestCaics] } indexMinCAIC <- which.min(aicTab$caic) minCAIC <- ifelse(length(indexMinCAIC)==0, Inf, aicTab$caic[indexMinCAIC]) if(minCAIC < cAICofMod) refit <- tempRes$aicTab[indexMinCAIC,"refit"] keepList <- list(random=interpret.random(keep$random),gamPart=NULL) if(!is.null(keep$fixed)) keepList$gamPart <- mgcv::interpret.gam(keep$fixed) ############################################################################### ############################################################################### ############################# - decision part - ############################### ############################################################################### ############################################################################### if( minCAIC==Inf ){ if(dirWasBoth){ direction <- ifelse( direction=="forward", "backward", "forward" ) improvementInBoth <- FALSE }else{ stepsOver <- TRUE bestModel <- object minCAIC <- cAICofMod } }else if( ( minCAIC <= cAICofMod & !dirWasBoth & direction=="backward" & any(class(bestModel)%in%c("glm","lm")) ) # if backward step procedure reached (g)lm | ( minCAIC <= cAICofMod & !dirWasBoth & direction=="backward" & is.logical(all.equal(newSetup[[which.min(aicTab$caic)]],keepList)) ) # if backward step procedure reached minimal model defined by keep statement | ( minCAIC <= cAICofMod & all( is.na(newSetup) ) ) # if there is a new better model, which is a (g)lm # stop stepping and return bestModel / bestCAIC ){ stepsOver <- TRUE }else if( minCAIC <= cAICofMod & all(!is.na(newSetup) & !equalToLastStep ) ){ if( minCAIC == cAICofMod ) equalToLastStep <- TRUE # if there is a new better model and the new model is not a (g)lm # update the best model if( steps==0 | length(newSetup)==1 ) stepsOver <- TRUE else{ cAICofMod <- minCAIC object <- bestModel improvementInBoth <- TRUE # set TRUE as performance improved # (only relevant for direction=="both") if(dirWasBoth) direction <- ifelse( direction=="forward", "backward", "forward" ) } }else if( minCAIC <= cAICofMod & equalToLastStep & improvementInBoth ){ # there is another best model cAICofMod <- minCAIC object <- bestModel improvementInBoth <- FALSE if(dirWasBoth) direction <- ifelse( direction=="forward", "backward", "forward" ) }else if( minCAIC > cAICofMod & ( steps==0 | length(newSetup)==1 ) & !dirWasBoth ){ # if there is no better model, but all the required steps were done or # there is no more combination of random effects to check or the # "both"-stepping was not successful in the previous turn, stop # stepping and return the current model or previous model stepsOver <- TRUE minCAIC <- cAICofMod bestModel <- object }else if( minCAIC >= cAICofMod & dirWasBoth & improvementInBoth ){ # if there is no new better model, but direction was "both" and # the step before the last step was a successfully forward / backward step direction <- ifelse( direction=="forward", "backward", "forward" ) improvementInBoth <- FALSE # set to FALSE to prevent unnecessary steps if the current model is the best model }else{ # in case when the procedure did all steps / no more random effects are available # but the last step did not yield better performance or the last step had an equal cAIC stepsOver <- TRUE if(refit==0) bestModel <- object minCAIC <- cAICofMod } } # while end ############################################################################### ############################ return result ################################### ############################################################################### if(minCAIC==Inf){ if(trace) cat("\nNo best model found.") }else{ if(trace) cat("\nBest model:\n", makePrint(bestModel),",\n", "cAIC:", minCAIC, "\n_____________________________________________\n") #if(refit==1) cat("\nBest model should be refitted due to zero variance components.\n") } if(returnResult){ if(!is.null(additionalModels)){ additionalModels <- additionalModels[-1] attr(additionalModels, "cAICs") <- additionalCaics[-1] } return(list(finalModel=bestModel, additionalModels=additionalModels, bestCAIC=minCAIC) ) }else{ return(invisible(NULL)) } } cAIC4/R/biasCorrectionGaussian.R0000644000176200001440000000217614773602310016073 0ustar liggesusersbiasCorrectionGaussian <- function(m, sigma.penalty, analytic) { # A function that calls the bias correction functions. # # Args: # mer = Object of class lmerMod or lme # sigma.penalty = Number of estimated variance components in the residual error covariance # analytic = FALSE if the numeric hessian of the (restricted) marginal log- # likelihood from the lmer optimization procedure should be used. # Otherwise (default) TRUE, i.e. use a analytical version that # has to be computed. # # Returns: # bc = Bias correction for a mixed model. # zeroLessModel <- deleteZeroComponents(m) if (inherits(zeroLessModel, "lm")) { return(zeroLessModel$rank + sigma.penalty) } model <- getModelComponents(zeroLessModel, analytic) if (identical(m, zeroLessModel)) { bc <- calculateGaussianBc(model, sigma.penalty, analytic) newModel <- NULL new <- FALSE } else { bc <- calculateGaussianBc(model, sigma.penalty, analytic) newModel <- zeroLessModel new <- TRUE } return(list(bc = bc, newModel = newModel, new = new)) } cAIC4/R/predictMA.R0000644000176200001440000000324314773602310013276 0ustar liggesusers#' Prediction of model averaged linear mixed models #' #' Function to perform prediction for model averaged linear mixed models based #' on the weight selection criterion as proposed by Zhang et al.(2014) #' #' @param object A object created by the model averaging function. #' @param new.data Object that contains the data on which the prediction #' is to be based on. #' @return An object that contains predictions calculated based on the given #' dataset and the assumed underlying model average. #' @author Benjamin Saefken & Rene-Marcel Kruse #' @seealso \code{\link[lme4]{lme4-package}}, \code{\link[lme4]{lmer}} #' @references Greven, S. and Kneib T. (2010) On the behaviour of marginal and #' conditional AIC in linear mixed models. Biometrika 97(4), 773-789. #' @rdname predictMA #' @export predictMA #' @examples #' data(Orthodont, package = "nlme") #' models <- list( #' model1 <- lmer(formula = distance ~ age + Sex + (1 | Subject) + age:Sex, #' data = Orthodont), #' model2 <- lmer(formula = distance ~ age + Sex + (1 | Subject), #' data = Orthodont), #' model3 <- lmer(formula = distance ~ age + (1 | Subject), #' data = Orthodont), #' model4 <- lmer(formula = distance ~ Sex + (1 | Subject), #' data = Orthodont)) #' foo <- modelAvg(models = models) #' predictMA(foo, new.data = Orthodont) #' #' predictMA <- function(object, new.data){ z <- object c <- z$candidatmodels w <- z$optimresults$weights pmodels <- sapply(z$candidatmodels, predict, newdata = new.data) MApredict <- w%*%t(sapply(c, predict, newdata = new.data)) res <- list(prediction = MApredict, weights = w) return(res) } cAIC4/R/summaryMA.R0000644000176200001440000000355314773602310013345 0ustar liggesusers#' Summary of model averaged linear mixed models #' #' summaryMA is a function used to produce result summaries of the model #' averaging approach. #' #' @param object A object created by the model averaging function. #' @param randeff logical. Indicator whether the model averaged random effects should also be part of the output. The default setting is FALSE. #' @return Outputs a summary of the model averaged random and fixed effects, as well as the calculated weights of the individual candidate models. #' @author Benjamin Saefken & Rene-Marcel Kruse #' @seealso \code{\link[lme4]{lme4-package}}, \code{\link[lme4]{lmer}} #' @references Greven, S. and Kneib T. (2010) On the behaviour of marginal and #' conditional AIC in linear mixed models. Biometrika 97(4), 773-789. #' @rdname summaryMA #' @export summaryMA #' @examples #' data(Orthodont, package = "nlme") #' models <- list( #' model1 <- lmer(formula = distance ~ age + Sex + (1 | Subject) + age:Sex, #' data = Orthodont), #' model2 <- lmer(formula = distance ~ age + Sex + (1 | Subject), #' data = Orthodont), #' model3 <- lmer(formula = distance ~ age + (1 | Subject), #' data = Orthodont), #' model4 <- lmer(formula = distance ~ Sex + (1 | Subject), #' data = Orthodont)) #' foo <- modelAvg(models = models) #' summaryMA(foo) #' #' summaryMA <- function(object, randeff = FALSE){ z <- object c <- z$call f <- z$fixeff r <- data.frame("group-specific" = z$raneff) o <- z$optimresults m <- z$candidatmodels cat("\nCall:\n", paste(deparse(c), sep="\n", collapse = "\n"), "\n\n", sep = "") cat("\nModel Averaged Fixed Effects:\n") print(f) if (randeff == TRUE) { cat("\nModel Averaged Fixed Effects:\n") printCoefmat(r) } cat("\nWeights for underlying Candidate Models:\n") print(round(o$weights, digits = 6)) } cAIC4/R/deleteZeroComponents.R0000644000176200001440000001563614773603117015615 0ustar liggesusers#' Delete random effect terms with zero variance #' #' Is used in the \code{\link{cAIC}} function if \code{method = "steinian"} and #' \code{family = "gaussian"}. The function deletes all random effects terms #' from the call if corresponding variance parameter is estimated to zero and #' updates the model in \code{\link[lme4]{merMod}}. #' #' For \code{\link[lme4]{merMod}} class models: #' Uses the \code{cnms} slot of \code{m} and the relative covariance factors to #' rewrite the random effects part of the formula, reduced by those parameters #' that have an optimum on the boundary. This is necessary to obtain the true #' conditional corrected Akaike information. For the theoretical justification #' see Greven and Kneib (2010). The reduced model formula is then updated. The #' function deleteZeroComponents is then called iteratively to check if in the #' updated model there are relative covariance factors parameters on the #' boundary. #' #' For \code{\link[nlme]{lme}} class models: #' ... #' #' @param m An object of class \code{\link[lme4]{merMod}} fitted by #' \code{\link[lme4]{lmer}} of the lme4-package or of class #' \code{\link[nlme]{lme}}. #' @return An updated object of class \code{\link[lme4]{merMod}} #' or of class \code{\link[nlme]{lme}}. #' @section WARNINGS : For models called via \code{gamm4} or \code{gamm} #' no automated update is available. #' Instead a warning with terms to omit from the model is returned. #' @author Benjamin Saefken, David Ruegamer, Philipp Baumann #' @seealso \code{\link[lme4]{lme4-package}}, \code{\link[lme4]{lmer}}, #' \code{\link[lme4]{getME}} #' @references Greven, S. and Kneib T. (2010) On the behaviour of marginal and #' conditional AIC in linear mixed models. Biometrika 97(4), 773-789. #' @keywords regression #' @rdname deleteZeroComponents #' @examples #' #' ## Currently no data with variance equal to zero... #' b <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy) #' #' deleteZeroComponents(b) #' @importFrom mgcv gamm #' @importFrom nlme pdDiag #' @export deleteZeroComponents <- function(m) UseMethod("deleteZeroComponents") #' @return \code{NULL} #' #' @rdname deleteZeroComponents #' @export deleteZeroComponents.lme <- function(m) { theta <- get_theta(m) thetazero <- which(theta == 0) if (is.null(names(theta))) { true_re <- rep(T, length(theta)) } else { true_re <- names(theta) == "" } if (length(thetazero) == 0) { return(m) } varBlockMatrices <- get_ST(m) re_name <- m$modelStruct$reStruct[1] cnms <- attr(m$modelStruct$reStruct[[1]], "Dimnames")[1] cnms <- cor_re(m, cnms) smooth_names <- attr(m, "smooth_names") cnms <- c(cnms, smooth_names) for (i in 1:length(varBlockMatrices)) { cnms[[i]] <- cnms[[i]][which(diag(varBlockMatrices[[i]]) != 0)] } # modify random argument for refit no_re <- sum(true_re) left_bar <- deparse(attr(re_name[[1]], "formula")[[2]]) right_bar <- names(re_name) is_indpt <- "pdDiag" %in% class(re_name[[1]]) r_effect <- formula(re_name) if (no_re == 3) { if (theta[2] == 0) { r_effect <- list() r_effect[[right_bar]] <- pdDiag(as.formula(paste("~", left_bar))) } if (theta[1] == 0 & theta[2] == 0) { r_effect <- list() r_effect[[right_bar]] <- as.formula(paste("~ -1 + ", left_bar, "|", right_bar)) } if (theta[2] == 0 & theta[3] == 0) { r_effect <- list() r_effect[[right_bar]] <- as.formula(paste("~ 1", "|", right_bar)) } } if (is_indpt) { if (theta[1] == 0) { r_effect <- list() r_effect[[right_bar]] <- as.formula(paste("~ -1 + ", left_bar, "|", right_bar)) } if (theta[2] == 0) { r_effect <- list() r_effect[[right_bar]] <- as.formula(paste("~ 1", "|", right_bar)) } } if (no_re == 1 & theta[1] == 0) cat("No random effect variance.") if (!attr(m, "is_gamm")) { new_lme <- update(m, formula(m), random = r_effect, evaluate = TRUE) attr(new_lme, "is_gamm") <- FALSE return(deleteZeroComponents(new_lme)) } g_m <- gamm(attr(m, "gam_form"), random = r_effect, data = m$data) attr(g_m$lme, "smooth_names") <- get_names(g_m) # old names attr(g_m$lme, "is_gamm") <- TRUE # add indicator for mgcv::gamm attr(g_m$lme, "gam_form") <- formula(g_m$gam) # for refit g_m <- g_m$lme attr(g_m, "ordered_smooth") <- sort_sterms(g_m) # names as in gamm4 return(deleteZeroComponents(g_m)) } #' @return \code{NULL} #' #' @rdname deleteZeroComponents #' @export deleteZeroComponents.merMod <- function(m) { # A function that deletes all random effects terms if corresponding variance # parameter is estimated to zero. # # Args: # m = Object of class lmerMod. Obtained by lmer() # # Returns: # m/newMod = A model without zero estimated variance component # theta <- getME(m, "theta") thetazero <- which(theta == 0) if (length(thetazero) == 0) { # every thing's fine return(m) } if (length(theta) == length(thetazero)) { # only lm left warning("Model has no random effects variance components larger than zero.") return(lm(nobars(formula(m)), model.frame(m))) } varBlockMatrices <- getME(m, "ST") cnms <- m@cnms if(exists("gamm4", m@optinfo)) { # for gamm4 what to exclude from the model for(i in 1:length(varBlockMatrices)){ if(any(diag(varBlockMatrices[[i]]) == 0)) { termWithZero <- cnms[[i]][which(diag(varBlockMatrices[[i]]) == 0)] cat("The term", ifelse(termWithZero=="(Intercept)", names(cnms)[[i]], termWithZero[[1]]), "has zero variance components. \n") } } stop("After removing the terms with zero variance components and refitting the model cAIC can be called again.", call. = FALSE) } # if(is.null(m@optinfo$conv$lme4$code) || # m@optinfo$conv$lme4$code == -1) { for(i in 1:length(varBlockMatrices)){ cnms[[i]] <- cnms[[i]][which(diag(varBlockMatrices[[i]]) != 0)] } # } else { # in case of convergence failures # nc <- vapply(cnms, length, 1L) # thl <- split(theta, rep.int(seq_along(nc), (nc * (nc + 1))/2)) # for (i in 1:length(nc)) { # ranVars <- thl[[i]][1:nc[i]] # cnms[[i]] <- cnms[[i]][which(ranVars != 0)] # } # } reFormula <- cnms2formula(cnms) if(suppressWarnings(nobars(formula(m)) == formula(m)[[2]])) { # if there are no fixed effects rhs <- reFormula } else { rhs <- c(attr(terms(nobars(formula(m))), "term.labels"), reFormula) } lhs <- formula(m)[[2]] # left hand side of the formula newFormula <- reformulate(rhs, lhs) # merge both sides newMod <- update(m, formula. = newFormula, evaluate = TRUE) return(deleteZeroComponents(newMod)) } cAIC4/data/0000755000176200001440000000000014773602310012011 5ustar liggesuserscAIC4/data/Zambia.RData0000644000176200001440000002731214773602310014136 0ustar liggesusers|U~Mn`9 J CQ#2A FLkfUEQT (kb$Gr坲st۷o; {}V;zN`ߠiZFVA4-S Ͼh5%Wд-,D7?U~KۢK빛{w:նvq|?Z{x_޼ގЀҼG\ٮsޗ>z}J?{wCϚq}ϘݳOո9=%k53e tW~?2}8{p^u׬w~vx'4p7vOt.}m}U:}mm;`܏v)yMwLrOsvFcݏ7_Y3_6Mf/s i;'^5rʓTɾgtwY3s޺}so~v;=p->w+]]x—?=Bح^mݓ:+޶5je,{~cs^*Nw]'Qy.=6Îw\uC=x7=_^hߧ7xˣKsx݋\7۹i6>op}Њy}ɔӧi[෭<dRxLϝus.7gކ^.smlyY+7~iYmʏ|7=rsSǁ_\ wSvz#e*<0^YSk(\P2wruk+mW|j s;.l]9=s(ܽfWN}~7wO|~ r,[?Ɍ7[wg'y g-.~caG\س:>-4);~ 5MV/w`>q=?>ߛ}˼==m7t)rg*E}j.o6ʝ-#y楷S+XyLgYEZt܍yl;\Ow_KXwקs+\tw-'?l*^V4:Y3>)rw^V?k:6UF{7^{lo|s.RĞk_:ﻉsܝ 6|p?ue\y/fw?z߹ykgum1;~jև5?ȼrws]uwpv.?wMW\wWww|ٹo㬛M.5֭=5T?9[>6{Հя{od}p%ۢU1޾}]뻳ݿe~gs;/9i?םuMogxV믭haw-n})qiԛ_p=wp}a﫷xȸi^(E>+z4-}့G_;֧ym{fMQWftl qcgZ/݈u慇r7L5×p{wRvP_^e-/(/簎1.#b_%Hg&_4@8ninC Xvnr۩70oK5{'}|9oohz5OMvJ{}Sv]tYM{w:x|-UCGSƏCvq겚'nTor1Joujp=\9v ڇ<)w΍\OoOk-~昳c{_6f>]%޾t_3^e/j9J^wY_ӟo0Yݲ'j+5y[/*C;]~]4Q]= [o /Y#mh:_ glOx|tt_ri)~B?;q}*Ue\2EP "Zວ_hW~xܓ|0|qaCWY'7Z7x};{ʮv1EEvO{t{^[gGo[sޡ>S ؇{/ݥZ}ubo> {~ϧoxp-w}~U xz;_5iHj?}/Ÿxqd4蜮ޏPQ 7qEmnypeєMSYU*mV {yge =VqCn[{°/r7tXE*O9cѓ{ѥ'Z?2o{g⁹޻L^oY>ZսW7g'[+ƒ\wa͇w#Upoܗ=o>=K?-_j5Ww~xBi{` M|\3?Ey|~_RUSj r?tƏcMڨ]}G GVp.u`F޺Kc=iu~2W}߿P_oӳr(\bnk/~߹ Ol^Q'(}>bQgi({>t!O[Go=w{/C{NW;5P{Ҫ񬚙/y~9/W:Ǻ}I0#x Ua&z0 gɟ3]WM[MK #^Hk'#sn4i<\jypSGxŘVq a|0+Uio.Y1SuU=0j)rm?R/R5UM+Uay%K={qj(|kfVRGswQ/C替fՒ(/y1ODV|yNlMW#X~g8Zkܕ)5I1k'ƀrWL>S%[K|״d-K|EW k{ ^5zZ~Ɯ9#xתk?nVDǿgsFd&ηF>>6 1_|b?U=IK.95G}{1#Y#<[ @~>uv' Gzc5ѪA 먙cc<׷pVC Я,:dL mݯۉZպ`,Ƒ4A-0|96}G}FMM qPx680FȽMG-s}N臏5T 1Wgp}\aNYx^ǵ|)빈:Uٸcdcw&'%kNZg3Ԫy!Ǩ_Ua 8cX٨C]W"ז"^>Uc8n|♚{KG>}9{ClB6=Ԧ&s=eӁa̫qØ?皨_L c"f1㜠U3*,n^5ժ0P 5VMK; W\<53i:=@jE}r*;"v7C'b̓pq"Wrz\zQùz<תt7Fl^ydD~Y@sp{Qḅ#U#<8cꗍZ-Ǽwa=ϧbØ3sʗ }OLOҶ~.R}^W&,I\/L<>9>8'|Y<7y< Ms?x|lIx (~2~>8WyD`^%j^ k OS|>!}Z2/΃c%3{ܧc2?R=yY:pq,ySW|C?J|WN\zO]Pwֿ&ϻ<)2~u.nz`}޹Ψ×1_oq▎8?xN_K%7`r:]sk02/ xt*b ΣKn?ZQg>d$SIOuc򼎀jQIW nȳ~񼹟߇|Kf&{)3 ?~c%-y_W}08)eW?8S.?T}x><WxeM|܇Rx<^ q2:ߞG'D^Qgt|;<{j7V&Ƶ}cyM>Q.ǃq'&;~o:pf'/GW3/vuEn <#Q7(mu#Ze$d#]$8wB1;N~7nIfS|EMg|ȷ`_;>b?1# }2mB/ tLcA?&x\^sp o_& ݍىz;P'ۀ.. 13eC_ٛ/ {eWgsŘ8ݯJ:1,uq_ ~:&> ΃G1Nh }$p~aY?NJ2/6&<#'1_cv":x<CW;cvGYgYǔa<ipC] ^x]1ԍQNg-u |!?}-B]L^պ1ԛ+C:<;Ku=ŃmuG̓^~Mh21ybW1Jw'dE^ XGQ(ga1WmK3Q&֩"'a4",bBt:_uq~c_^gd]:`-ºڑXwOs>n.c}K16_1' x3~Xt^\?}eVz ~^> b~C7 5pٳ~c'uY'P"7wOgZ=6%1? /")ϞM `sXwmoOwƍźѹ.q~[Nu&:pŸz9:G_3>gcooֱڅjzޟW08_zkE/ *8mA K1ԯ#AwD?c ^:r _'}Mˀ>aB^&t}J~+ 3묟>:<9ʺ7s f0Q'-w)9N3:aOcOq R/>uw"=OA3^]x\٬#c_uHՕ?t6#[O_58~e2u?וߛg<.~c=xvBؗs~Q;§c03X'zuDG82홼.tb'xiNKEbY1eٿa9b^=w?mʝoۿNG?X|PACYٴ">l>pRe0.PzuOU;޴=D'{w+ ay&v66XKk_/ߴRL}.ᄥ-#{679Y7~ ;7yVb韶~ź}5+#蛿,.>^k{Rf_wز{ퟴ>'b(iwag&ǵwi[,8ű!cǖ8űuKtKtKtKt    b"VLĊX1+&bDbUEU8*uql86ű%mq\K`#*؈ lD6QFT`#*؈ lD6QFT`#*؈ lD6QFT`#*؈ lD6QFT`#*؈Jl")b")b")b")b"%bY"%bY"%bY"%bY"%b"-b"-b"-b"-bUt/]Kt/]Kt/]Kt/]Kt/]Kt/]Kt/]Kt/]Kt/]Kt/]Kt/]Kt/]Kt/]Kt/]84 CC84 CC84 CC84 CC84 CC84 CC84 CC84 CC84 CC84 CC84 CC8~Db_1ѯWL+&~Db_1ѯWL+&~DLyS`7MyS`7MyS54E MQCS54E MQCS54E MQCS54E MQCSД584MCS84MCS84BMCS)zh =4ba)oba)oba)oba)obaXXXXTŲ,/K,/K,/K,/K,/K,/K,/Kk%K)XS,XbMĚb5k%l .[˖%l .[˖%l .[˖%l .[˖%l .-ph -ph -a l-a l-e~٢_-e~٢_-e~٢_-e~٢_-e~ B{m^[h-k B{m^[h-k B{m^[h-k B{yG`wyG`wyGh#u:B{^Gh#~9_#~9_#u:B{^Gh#ueGp\veGp\v/Gr/Gr/Gr/Gr/Gr/Gr/G]"/pMPܞi#y% , ״pMkė0H'X6/B9%wMWʹ Yh?dO 8-/D7>"[F[5d2,LVHV Id4^x/[d.Yd2+dg]BVFv% kɨ4iCo&(49M|Ӧ&[Gl7CdG_:,ݯ5 kIVDFy(Ȯ&7dTtN%dcL8٫d3fQ!C}Hꖾl=fR)ό,<_dPQ/3N kMF͠3dȨ]( qd]Av `[h4 _ɦ=OF=x6!}}A!Au@l'=ß >0ُښdN$/nd}(LsUdTLw&:spFQ3)̇Ȩ֙ON3${rΤ3%+30IBFen#>Q (d3zQNY#fQ(,!E5ˢ&#dQm>!K2Cv52k6K6a);٩d=(F6%R2`v :zMϦx4d4lK6a){&a(=pMuϦ6r94\N{2qNG2t%bPw#V;Ȩ9Qdɨ9o~s9}JFsYAFus$#s)\#jKsȨT\Ad4R2g.?KΥr!{K8%Ҝs;+6Q_sQ.~.?Q]rŸS!#QU8 = P~3( p!Y_2] |##n##<(q'@xPo2@|oėRoȈ3[V/e4+@ nIo R]AZ` 29Hz 8H5AuH Ayd4 'HxQT a0H 42}4/H= NF {AZ3}yd $ 'Ud q"^I\Q߂A[GΣѼHOyMhy_@zV@+MFP/ CԋZC H (~oԏʳj_pa- +' H Qaևzկ`F!%DBP]2ZBm!W։i\jLgԟ0VdT0$L8 S„0Aԟ0'Lč0%Lu SM¤a0KaG3L\S=407<&iia҂0a(L~t!L| ZI¤ acEH"\p!G[Vx>BkKq BF(!G?y"ϒQ?"\#O#4կqZw _cAIC4/data/guWahbaData.rda0000644000176200001440000006013314773602310014654 0ustar liggesusers_M -%*`ŽE"XHb)ݝϱ{=?~u/qvggfggvgg7bBEEECEKCCECK# ?TtTj{₥~ ' **ZJ&gPxЙ3OD\ն&| (9u݋3 Nlٶ/DOhEp1 %/2y RX|s@IC=rfttИf9q-=.rOGלފ}2GJu/"JW}AfcHPpt5mZ> Aڑ.nhc UϨUZ!>cwa#(x9mP~R+`{Zr7w~vPIisCNHe[tCiNفTMU,: On\'ڕƣKAѰ-d9a QSĆC eeְa=@bWFR"Wώק*V^(yFRg&@>pyHk:/tybj ^VjC 3 O<|q{-&v4k}`( |L| άdҶ΍ x(ǧdcj|? b3@tƑf/5Jc@41FP ?1_*AGH*?/i ,̱ > ; 5ӹQ2_~/fNz5gW &3s[n[|@枰?sM]|wD;J N}c\AYݠ27O9*Z|:U(ETI/I:/rZCc?WTx A~@fݝN sȊ:Iy siS,/_? ;&T?0O}N Xiq+5k .A.r.;z0b`G@A *lMo%Fi58)y-ilp߿xV;|@A/?too=HWv$]hޭ%Jj!Z X0;Qd\~oY9Iz(m&7yˁt]bO# zv!D4~hMaɋZAulˍ_@n1[q,;@cm2}{Xli/J7^jTaUؒS@ZIih x۾6  *`(ȷϻ2W*-2-'?i;6zE wmc.z7ӑm.}~~OP٧6*םmAy(Sq`OtC'(U]+ޓ?<2S;@)7p0R{7V7JAZ1Pۅ o%[.ћ О2Mu/CS`ewn #k\? (;pH- اvV_lEzkpk6 {0xlw&y2Mtke חa=uօWFB% }e0rх68Hwһw[wHIЕ"^gHjz ӝst? ݁ /I%6N{ r&38/Y4RV 7ly#ȕ{>5ǟ2jƀM/9*@Xo^jsä9< +lQ,v N/ )˱ j9"{ Iȕ|X΅@є;{@uR<6tYEϹ rTn-ptx$3sT&Ѫn6:V 2vԕ耬煝\(i63uU>7 sK$Ń}̨dR$lyÜX.H8iqs -jE6( Off~كekM2!U݅~ J]oL9J>lz^?eybHЕnOZKƆz@KaP4vl*Yg$@^Et 0|n!ZHxyJN}[Q5H_<䙢T>jKY vӤ1Zp(*ZV&G|d.UMUx 7_A!GB@gњ'ȻO>|~d AXeڅiP I6iw^6 toyXÛuw\Z5zy^['mkWhZ1(wc[IJ.q) w4*eNm~J^-S"fvxrH}}eub.pSjAf<0P r?1 ;D@N*dgL&tA.X²cxM$g~78g'c`: Z6qeZk7QpV ыEx"U=dOS 'LgXqrp;9Vg AFMTmsw7xSLL!w TTho&wun7_C)Yxi1fI bc&eC} #억x|[0+tET|.Kx組~L߮Nvx{C6L_1.>i}&y1}i1 ǞSnS.;bd~VM <~TQ>(̇gW7 w`uiW7wn O#0'veFXΈ$;ߠqrIKϞ̿, S?y|_1+!)ױ̷h%5,Uks<ԉ#:7쑇ޭosH ̧+k' X:pH*< _٣aaCLzO+7/بc#t|E[+}÷xڍw]*'v}iᇏzl.<̿'^4zً#/M!gڙx5Y$~thc}؞BW0%=ga̿)xC%N<>O/WmzWa<7TMcQ̯{a#q[C!Fd=ٮIb9ȝ#Q-ƋV&Iu;7bbOαI0ߡl}[b}J]'nou<#4nON5sAomu k=CiQ匈zztUoBGSHn+F/%_W4Y>x|BS7 L?S?[^cdA/'rSNǰU4Mx2eCte=_E kx^1rfsg垍IaOٌ5̮Da~B1$#c%;p[Pױa~l?bb3 knL(_#LWdsf>w>3Ne/ Ktu|]&n=]+̕eZ=I֣n #|uG^Zx\ä/̿cipìs(ƫ=H^S pL/Ŀc<|DZ^޸ug0޾m ϥUl<7~ӟ{ Qd>O񸾻^u81yw M sHQ,s"+1OР?dQ{E&m öKğzb]\X';1^m+ߋodޛL܊rBubawc9/M0]"5x˩ӌ5nur^>x̋qba"iPuڇԫt1lT]ȹUdDE}#&4U;v?I`AAC֥;n~%L{:}܉akAeϏ# oe OֽiCXz =;a y3r#JSx]]7_9Ux|O6k#U21['\r5|aDOs1n QGAReF Tw#W"]s?Dέa)31I^L9*<_\OyxZCw?fqQqW׷k )ϟMȑw}s&~k7y| 3#0W'1*57qçcu&=.G&?9(ÿ7>Oc΂6`?:n~ qm)C;1wY'Fv[J>xH u \ِy1~VGW MhH2֯V"j;9;~ͧvif#ui#S%@p5BKky}ۉ bMgkO[2{-'x|oLW=BKTZ|[J8:1D;!J\K>@㸅V:x|RnaZCHH"bYL|5g}c=b;N8OXwv1մ{6}XNx/S*7ۣZ6-b<4R?eL'kF ~q?ib|TBz8a]o<#;%d Nq؇׊$1"D1$~}=CjI|_H|M;܋kYn`}$^\rF  !ZS3H'wT~լ$zMC_]v^FnWnny!ump 7ckro|HƑal̯e;7׵3F{j +Ⱦ6X|уo5+u~ /`T2 $Iؽ%qyKB#?߉uWp1LΧO>7);j-Ē{]ۓ~rȕ[}hH>UM=4ԸdӕKgubo)$(? hf3bMƛ1GvYQu y^|1*Fdg}3C_>%?NlEx\Ɨy0ng=#|0D]9Z2ij/1o"?KFKw}"l}$'H~91R[~6D,d6`7zXd5n_ɧ0mw%u?G1߬܇dvxFLr+Ğ t }$?xNq;D]13+OsrTcぱ$ ]̷6y{Њ)|6죍>mlNDP9 Ww~Fy~sqs S/urYI}vk-+0b˺K32}-6b kd6R%~+mzC8[j4z}UqJ]!q5בԳp{YM$9|D5揑АLk˭ k_!7I&3jK Ƚ='^0c=hwsç 9ڈۛ7IJ62xy0J}Qg8N"RkԇȻh8W=ue3Z296}4]@)]ռI|E^"VK֧w"9ջhU0^hv݇sc<'җNKϪׯ=VhC5CtLÒ-s}xc;adܥɻISL[H~Od]>Q(,ei%>_\#O{__M!/,glw[LoB}c>]AE{<.>'dUs5| RC뻅]&*+b]>r,9ǜgv)8b߹ZHi8 Er|*%12 N5,/U֫pOB>.DϯBΝ2Z9'}mmz ޝ\r打{L䝫Ӏn$P:INnERO+_7t~jauL6*+_Yd$"bw$?Ul+&xkvDb^R}x!@gu00Xne k~blN+|J:Y' ̷M=^]pU'40@N0{b*o<+F<ͅXO=$*oOm$& ?_<[6;W񺗴uF6JtK߂1KST>abRxX:a1<*Ɉ4<^krFyz}?[hh:_׎o17G<Ȼ^!Cg~l>°W @Ys?9>y 4HӐN ?4%~c딘pP}eH:xfٷF*R7UESS>(OOۨ%yP*7ѫa=R76rf &OIc*dvl|י";[!$icktG>q7o#{G5ix6'g]afBλ,1jq-:&~&3*$w} "O}"笃W3imJι?ßԧx\ɻW7ud~仛όx^UM"؏J_2<=Ecֽ_1LgwcUXpD S/u*w˼=FUyhp%lK3^'WWowEw"& u))ZH}gxUː%y\{\L䭑^ُ]"]epݏ8_NR|Jp{Vj"nKjoB^qwy6bOW_Ű!F<~8_Xw5116jN. ࿁巖ӐzCc8`lOj.|$&@,oXܒԗS[0dRquيt=B={KclFA [CKַ4+8J;;+v;ylA[]"u\OZnYŊY5Ɛ},ַv?!ٜ߭[L\t׈~yR_QV@w./Ebϗɪ$n~/w!됳Ŀ3=E2uJ(q_N=y?sC0z\)d˴_kIsb~ac>uw"#ԑYGƘܑ䫣M;1ܛeȼv:dB!C7 ^ 8e<1;GX~QXf%+q/ y-?)Ero- $D1$~"|*]n'~;)tENS%d#C{v׫aXH2v7^ ɻt3kQ\$7o#r_I+܆rCwOq`Q^c[;PTw.2Ƚ(M3rUi`ԇ3&ɽc( in؄G&yKF=o]] 0ӲGs<>(&q=\+=T'Dߵ=rٌI>UިYO{c/<A#|#H?_&wH SAC}@c.仾b#M6V K1 ; A~X߄ZW;|mfH:I{hNݘ=.':=v cH~p,.%ߏtn_ ^]u|=}{!;9+1cA2ߞN=04?{Arg2s3+[\&;C_N9r7 'ay'6(¸r.Pzѯ{zbi  |y0S{/Y9" L_mRwЮ!;]C7`tdO&AiN1k)[n _5o {pH$:U#ias!sPl|u8+hA.5ef:4y};~ʖ/^M\2 Z PxyP B)3̾lrpDy ~)b{߈>Qhm 72dlGό.M5vuGjnVL"^-H;(sW\R:A!~ e~;yu/#WkblA7H^}ed {$HWsƙ}DzA}r H5\ wrLgo2h?8_D3#wyL6Ʀf쟌so?A%ܿ"%%f MgN6H5xnyxv7UPw;Ⱦ?bCP)-__rzg ĀP X-, }o80 C {@͢χ O4< ܺZ*{6Gs1b*pM|[ Y. -N J:v 7;CJYb+OO]erA҅c_@S}; [6h: 2ܧwG RS~+T㘗F.0hgT՟"ǁ[ 2frAM}36ؚ_7+^jeA1Vȭ.fUطGΝu@'"ݫ8^> N:Lv q_R<ž39gYWa ^Oeۿ3y† =mCׂY?ucqO?fjF&E=?ZQ=>@+q__ix76T`;^BCR] u(`d=A28O(:؞o.Q 8S"Q}Ln z۶]h5Vd|US% MsS$y *N bU 2NbȚ2=>KP}n@2Wv.;|?aYJ~πo  FsMZ4W8@d`Kj:CCdnP_Ck@bǩ@C ٩2lOsd g,A'o([r!n9f.;78I(+~w.l:7};j/L嶽[3i1`A>Q} + (~5yjT[߯~X>s>7?Aۯخ:8 ߋo\N q@CMa6vRUe*Dƣ3t}VE(j (}?˧y4,^1Qr h%bl4ʢݶ)15?`NPO|lN/a&oY/ٿ'0M-_;nb AZ~lCKظ+=΀+`Se\|j}qxһ.u6{VOڇ@Ku:oj;=\fGzو`ک\YEۙlr:?@&_;eH>֥*u8Ł@ΧY ݷSK\fFda2g9Hh,{kN஧+}i~}#|diqq9Jf}\he\IZ&E4yaZ"AE΃kmJvwZ7H.NqB4Nխ&=-j*oaLEk:SrЊ#hA4*P"oj5k -cY[`E=/ Gm4 Zr&bM̀ |W頂h· hOU[) OLFNDV+hIW$jۆ J߷LZ{MG7{^@sJ|3ѫod,^vh奬ïJ(Kč#x`5Ů/E޽ CcnCn2k~ꝶ)IWj,Ak{ 7҅yѯggn%ۃr*SKTSѼ{z,n-9LU+qXAudrzyU8o3wh'15ȉo=>&|d;6_瘒 ei=]њCγ KO.X@c@hFS/hL,v .:-3wxX֥4,hyK4<4[R|K,[TE?D F$7Ck߆-_9nC3Wf~NWݵk}"Z>~zG5OW4R*nCsx>E==Nh;R !=ZWՒs MCkc4th|I`Z5&}]Euת иȒ1#ZNO¼-nSaBW fh7E^LؿwRh=6VrDۏ|ذ-xe xn&=hޣ#Tsݩn CnD_L)z;l֤ɟs!pecfz5.IfCoD?wYޝI&fZмbEyoU.=C%ꤿӡ]~Ѐpf3nWPgn|uA}eӉX~y2FXMM7joey3S7ڧs"hd&4yIz'ukߕ_޽DA4qh-m%hyʸROC7Z:d=J]j G?hq+3-zdn&Z fy](!'GM~+,jۊZs&[PAjVu{Qn4o8%Zxuf),`G#^v./of_F|Z~ZcWu* /G/t{,Xi5OUhvv T6..h„_X =^j{ Fka#v #b8rcX;Z1w`z9ZRb1.s-hYiKoEQGSЀ׉ՙ/&H)|Qf^@: +oQD]F/>Pֺ^?p]f_}OEZ-_~{ٿEy(d7!h]-%_˱i}hJ7J/Vwڠn7>QuJhU:r %7*Wf^}TFwB_ԣY~Tsr^:bK AkGt >lPפCcKhإ,v!4yS>}u;ZƍzΤY))&0N\؃/0g3GssWF8 C,_d!/B_| xΕ~,E+g3kk+ZoQPLC'\qM h]?Π7'(q>v/K;POY)]r pEoaMaht<0}{x/&g}nW ]@D7hzۻs \}v@mOOMh`<槮tf]݁q aONgL?;Қ>~=.W^J|֛1P3_K&}=$z=#JשYи7oF4yS-w(j33-eIQ]z͕}.s,0vQM1kyj]G+$RY87Z~BX r3|~@9Iϡh-A+ߘ;.ʯcEh4֯:4!wN=.Opm;A rlݛy`d%V[<Ӹ^`˿]-:@Uj-`e">4&}߀kXJDgZ}fnzn!/E+Oe߱]$.[Y@Iv9kѤ>kjRjͿA @HTge޾jht(?Ь sk|Yd :) LfS`c1"n]j2B_P RYR9hQYS2_ؠtT̀IL`'nvZk~zN9 NǢ A`_ TB" 3-^)]X8ltKlVpg MJ:rQ0\ЌG dM39tL@_45aۍ]ہOZ>^ne]M/CJE8O0sVn?+WA*. Zg^l z#*4>jpw̮iȍM jrxusߓZo3"ӄ禾Vhk8Yk Xβٰb`w}q2~D<Ձh e^2@{qԷs9+P=>r.j9(|=dR hMwntz&clY{{.PٲPE_l a{Ӊu./o6 lS0l+<]{I 0W4q} 4gi>Y/%rZ>#L'5f|$V|4?r}0K @r%/f{7$?kw.3h84:>o=u otвM5fZD!ہD,P8 9~1~&/4t3q~ h/숖b7!I4t;ZhJx B<Ȳd-*rвft 5#О{Wi>mCSn&R*_aRh:xD$X{f&$>D*niL g/ ΁SnUY`yYs9e?Rz솙Z[b_|-Mܑ.tIF tHk@"zOKEtRw>/9;+.@IY*`0~?4qyZN'&^_RḤG̀];@Uk`Z)~+ϿZt}'Ch \QwLYVG6}6oP[]3 쉦z[KmXXԶo(<0p ؗUjxx TGy,Ơ72㧐%TWi=UNE3} 9P~a=^]'{=컖ri$H- /O RB3=cи1޻W E-^ ^uZd^gh_Sn@ş/N>xG_xF~)gU}cXi ,6~L z@H]2OI/.5m ʢY)ۏ[1R'4zd0щq)Ӌ)(=)cxnlfG+<}(3'v>--tE Eu[BsyˀqWgթtJl+++t_W5VQ+1 n%LUy5D5<aMǫtAe(sd89)@XDIwF kPAT4I9)P |Z'úǶeQ<>3 St|+,K IjO' l>Oـi`48ذ+r`~r m't:Ç9Ax7@5D9ul4tAc-5yFGPu"(ÿH0jx|"l@*Ix4PGO=-s[9 1 %Niz*KBܧVC:*s#?nKiODž w%CXzó"AW{]&=ե b"fk U}}y_y0E&GoĆ=GV`], voj9>- /ՊA8,1Id^>52 9tbAE7.0Zy1GJ: f:ۿ6RF.QU 7rɞ.}PcxqHU_B*^LS6j >|-uuE(fOg^~rxj\/`VF`O)oA_{X!_5FGb\DsjZЖs|Nsأ絪vtA߭>f U-?+'@".Mw=p'cZO@O鞹8uahiO`mJ{ XC?y jZYi75qE;= d=Ci/@т}/u H۩R3 oc<;g3h u3,_N(M7T2o8# ʺ^ޡ^Atm=;<#+^i^C?0V!QBsW?=B˷WQwOBy}\JJs†cLԅFQ`,RԔz)RA;PF bd)z M(euѰFԇjOJCC*o%ij\!掔%kE68ǘ]5B zٴ.!0YN^Cgw7DUf]* cT홗՟W(纑M6Zvg?hxm%Gu~:rMnIt⦃ *5 R[XM)]S;dx^ k)ïKQ)e G)wVf o$o;IF,`f ڒhmy)PJmM7 RNo揠Ҿ]g^\qx3n{s܎C7u[ԝ½M.*leACbނArx p(<G=No8ߚX~bY:V?d֤|"M p]A{ľpC_[׵ c Uhs#0ny$͹m@J{A`SI~oW4b VUԙcn#HISϺ۠a>˚[#7ܵKGwy@%5k1n{Mx\B/N|4!}_šY11_za:yT덼d 4o:t~J0ͭvooa--@jRPQ D݉ƭX@nuỼ!C0h tY>ZI1s'K$@rߖv4qp{6CEQL+w(QG_<}ޭK4& ~i:Wj ϴ%{/P3&ODvEnJ D ڍZ/ߊIވ2Eqs੎U|qX jiyA9DOɕS% ]Zn%?fY V <'wiIY=Gzg7*GɷKN=V{ÔTԪMG {uߗ rJ\QV:!wBQqMmW{ ZQU-(4xVUOYʾNˆf.6n"?s& "yl-kgdR ݃{˞IC??u[]qV?m?m?wlo 6j/׮_a7Vdqz弅Fk _V[ e~cAIC4/NAMESPACE0000644000176200001440000000251114773614701012325 0ustar liggesusers# Generated by roxygen2: do not edit by hand if(getRversion() >= "3.3.0") { importFrom("stats", sigma) } else { importFrom("lme4", sigma) } S3method(deleteZeroComponents,lme) S3method(deleteZeroComponents,merMod) S3method(family,lme) S3method(getModelComponents,lme) S3method(getModelComponents,merMod) S3method(getcondLL,lme) S3method(getcondLL,merMod) S3method(print,cAIC) export(anocAIC) export(cAIC) export(deleteZeroComponents) export(getModelComponents) export(getWeights) export(getcondLL) export(modelAvg) export(predictMA) export(stepcAIC) export(summaryMA) import(Matrix) import(RLRsim) import(lme4) import(methods) import(mvtnorm) import(parallel) importFrom(mgcv,gamm) importFrom(nlme,getResponse) importFrom(nlme,pdDiag) importFrom(stats,as.formula) importFrom(stats,dbinom) importFrom(stats,dnorm) importFrom(stats,dpois) importFrom(stats,family) importFrom(stats,formula) importFrom(stats,gaussian) importFrom(stats,glm) importFrom(stats,lm) importFrom(stats,model.frame) importFrom(stats,model.matrix) importFrom(stats,na.omit) importFrom(stats,predict) importFrom(stats,printCoefmat) importFrom(stats,reformulate) importFrom(stats,residuals) importFrom(stats,simulate) importFrom(stats,terms) importFrom(stats,terms.formula) importFrom(stats,weights) importFrom(stats4,logLik) importFrom(utils,capture.output) importFrom(utils,combn) cAIC4/inst/0000755000176200001440000000000014773602310012055 5ustar liggesuserscAIC4/inst/CITATION0000644000176200001440000000177714773602310013226 0ustar liggesusersbibentry(bibtype = "Article", title = "Conditional Model Selection in Mixed-Effects Models with {cAIC4}", author = c(person(given = "Benjamin", family = "S\\\"afken", email = "bsaefke@uni-goettingen.de"), person(given = "David", family = "R\\\"ugamer", email = "david.ruegamer@stat.uni-muenchen.de"), person(given = "Thomas", family = "Kneib", email = "tkneib@uni-goettingen.de"), person(given = "Sonja", family = "Greven", email = "sonja.greven@stat.uni-muenchen.de")), journal = "Journal of Statistical Software", year = "2021", volume = "99", number = "8", pages = "1--30", doi = "10.18637/jss.v099.i08", header = "To cite cAIC4 in publications use:" ) cAIC4/build/0000755000176200001440000000000014773614754012216 5ustar liggesuserscAIC4/build/partial.rdb0000644000176200001440000001152214773614754014344 0ustar liggesusers]{Wƶ7G ͓4I;'az@6bhգӮ46*zH2 I~8]ΖFHl Z+bOgC{7L7ߓU'zK.όP:.ljXUrK/K᜶%[B+yeWCw ѻ*FЌW(Kߺ!~Eq(01dSQj0ub^owG78XQ.…ώK5l%0v6Ȏ/+abmBٲWZT2G*,+RpYбQ4_RBUBO|i?Bq Ұp\#dVqI!_q XIh ovcظQvqef3 fK%!aTl(' T?Qv$ ZH1;1-gTHH#Ci%1LA3%N%Ŕwk"42K_>}@W8ʎ6);]mJyf"v]s짖2M{*yo{f/--q3_Hdԇ4wK+-*vo`XPqq cy4QMkhem1D Rzd!†4E]qC}ԝ[8FG}tueYh9~gq)kز֠y$ Fހb[X8U5l2TU m;{iʼYqѪRmvGL[D*TUA,:(HW%G*";H7QKoUgeSԹY)<_eO#J(w)>uqZ3xA#: SsJ3"DunˡlB&}b Qvvf8(T/=*jż:x9Vŵٍ)ܝ{f1I}t؋CD,oI;F:ecŧ8ORX]ﬖ6w7^!XYj7nN{2N/e:9$I'ի74{u0{ьWZT~жtԒc'ȶ'%tft2qK.0ё Yg*>INM)1AX,Z&hmCR8)BZצOl0lUCm/R4װ7273OR78W4bS)h%!2lQ~.?JIG_WҵN:L:(mRzA󷔄/AȍA~|4ś"rR%q7 I15ȋIoe"Jq&V a_$.q9:'6,u,h^))MxD6 OcL<ͣM{Z5U&vR?q3zt'QUd'~ c/׺Sm78oucw}h55U[ޝo ;UNFT?ab6qKFit왦 5XnE:X]Æ <*Ŀ^i^Io`HgHgLW)xZN* ==hX̳y$$̺}HrdƜ3Ɨ;suDqږrاɸ`o=Om~)W󹝼h}Aq~ VaQU@2@c:j=X: Az Gn2(@_a h,PeYЎCQPȲ~0cU4x^ ;K.n7Dj!IJL+ͣ:͏צBo W,cLW CugVOֹ =o+@w5erQGlL2 }i5pٺ>z K_IB}rִDmqmXL>eGf"2~_l3i!F'Yz21Kh/]lZ5#/K''8wXN`"%1z%(&Ob4n Gb&kp̙6P}/G;ںl{\Svt(2zsc%h /( \([#f;u06!%%^:9ۧ0,4f˭/^kh#y&eYugҦYi-M}L;!Gx0 XL1GR265\p:S2Yb1(,pCi}2|*1B#TQuz- # s\˸4 #'I!7 ٰMfp_mfbP[nqː䏈DŽ\yg,3Ib([Fd Vcar,w@b[j.3MMfHA˛p3*φu걪2JCv8`\ >6n83nd4>H`_ k$1)[)Ćm'$X9.Y$?ۉTݹ/f Jb:BD.0PLoH:v$ꖖ x )u6BhhUTYw@cH*ւ# ࣂ̷ܐTRjG_R*/:Pñc3 Q[uX7(9h{h8ơi_銎-mM)6ocaJ#@s_xu7HCG[4NruE$e"ڬ[q7 rYc2+xu%CuǰG.H錹KO;m;%FqAa#}h5[ CH.Lj>)ӆ*1/헏re#EE]cPȃ[BU?ez*nL C1Q*HZze?F(:/c֥4 D3aF=+M?jh{kgiJ~4\Bݶ HSB MGޟ_=UpZDlY+EPr9G*,+R`TGN$DF]jz*,_Dl%`pRv(.*9󄥟4-zՉ%%o8>K>^ >|x%g.1Ke썲PgdQ)cMP'P̪a>B I;Ǯ,_i!= EDNN;\IP;I2*x&ji;COwyBΗrja>oZRz+ ^anf"&F6$n *>n&ps67iJB˭o)[%TZ- u 'C?ωujic{wcU2hc0/ ,P`M٘:EgR"_RL5ܹcmie(s g,c 8$7!Q)!L K+{@p1{GF!FT9YFg Cwf`(h?zwdGcAIC4/man/0000755000176200001440000000000014773610660011662 5ustar liggesuserscAIC4/man/getModelComponents.Rd0000644000176200001440000000057014773610750015761 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getModelComponents.R \name{getModelComponents} \alias{getModelComponents} \title{Generic getModelComponents method} \usage{ getModelComponents(m, analytic) } \arguments{ \item{m}{model object} \item{analytic}{logical} } \value{ Model components } \description{ Generic getModelComponents method } cAIC4/man/print.cAIC.Rd0000644000176200001440000000062314773602310014035 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/methods.R \name{print.cAIC} \alias{print.cAIC} \title{Print method for cAIC} \usage{ \method{print}{cAIC}(x, ..., digits = 2) } \arguments{ \item{x}{a cAIC object} \item{...}{further arguments passed to generic print function (not in use).} \item{digits}{number of digits to print} } \description{ Print method for cAIC } cAIC4/man/Zambia.Rd0000644000176200001440000000133614773602310013350 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/datasets.R \docType{data} \name{Zambia} \alias{Zambia} \title{Subset of the Zambia data set on childhood malnutrition} \description{ Data analyzed by Kandala et al. (2001) which is used for demonstrative purposes to estimate linear mixed and additive models using a stepwise procedure on the basis of the cAIC. The full data set is available at \url{https://www.uni-goettingen.de/de/551625.html}. } \references{ Kandala, N. B., Lang, S., Klasen, S., Fahrmeir, L. (2001): Semiparametric Analysis of the Socio-Demographic and Spatial Determinants of Undernutrition in Two African Countries. Research in Official Statistics, 1, 81-100. } \keyword{data} cAIC4/man/getModelComponents.lme.Rd0000644000176200001440000000062514773611241016532 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getModelComponents.R \name{getModelComponents.lme} \alias{getModelComponents.lme} \title{getModelComponents for lme objects} \usage{ \method{getModelComponents}{lme}(m, analytic = TRUE) } \arguments{ \item{m}{lme object} \item{analytic}{logical} } \value{ Model components } \description{ getModelComponents for lme objects } cAIC4/man/getcondLL.Rd0000644000176200001440000000116014773602310014013 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getcondLL.R \name{getcondLL} \alias{getcondLL} \alias{getcondLL.lme} \alias{getcondLL.merMod} \title{Function to calculate the conditional log-likelihood} \usage{ getcondLL(object) \method{getcondLL}{lme}(object) \method{getcondLL}{merMod}(object) } \arguments{ \item{object}{An object of class \code{merMod} either fitted by \code{\link[lme4]{lmer}} or \code{\link[lme4]{glmer}} of the 'lme4' package.} } \value{ conditional log-likelihood value \code{NULL} \code{NULL} } \description{ Function to calculate the conditional log-likelihood } cAIC4/man/modelAvg.Rd0000644000176200001440000000363314773607716013724 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/modelAvg.R \name{modelAvg} \alias{modelAvg} \title{Model Averaging for Linear Mixed Models} \usage{ modelAvg(models, opt = TRUE) } \arguments{ \item{models}{A list object containing all considered candidate models fitted by \code{\link[lme4]{lmer}} of the lme4-package or of class \code{\link[nlme]{lme}}.} \item{opt}{logical. If TRUE (the default) the model averaging approach based on Zhang et al. is applied. If FALSE the underlying weights are calculated as smoothed weights as proposed by Buckland et al. (1997).} } \value{ An object containing the function calls of the underlying candidate models, the values of the model averaged fixed effects, the values of the model averaged random effects, the results of the weight optimization process, as well as a list of the candidate models themselves. } \description{ Function to perform model averaging for linear mixed models based on the weight selection criterion as proposed by Zhang et al. (2014). } \examples{ data(Orthodont, package = "nlme") models <- list( model1 <- lmer(formula = distance ~ age + Sex + (1 | Subject) + age:Sex, data = Orthodont), model2 <- lmer(formula = distance ~ age + Sex + (1 | Subject), data = Orthodont), model3 <- lmer(formula = distance ~ age + (1 | Subject), data = Orthodont), model4 <- lmer(formula = distance ~ Sex + (1 | Subject), data = Orthodont)) foo <- modelAvg(models = models) foo } \references{ Greven, S. and Kneib T. (2010) On the behaviour of marginal and conditional AIC in linear mixed models. Biometrika 97(4), 773-789. Zhang, X., Zou, G., & Liang, H. (2014). Model averaging and weight choice in linear mixed-effects models. Biometrika, 101(1), 205-218. } \seealso{ \code{\link[lme4]{lme4-package}}, \code{\link[lme4]{lmer}} } \author{ Benjamin Saefken & Rene-Marcel Kruse } cAIC4/man/guWahbaData.Rd0000644000176200001440000000076414773602310014321 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/datasets.R \docType{data} \name{guWahbaData} \alias{guWahbaData} \title{Data from Gu and Wahba (1991)} \description{ Data from Gu and Wahba (1991) which is used for demonstrative purposes to exemplarily fit a generalized additive mixed model. } \references{ Gu and Wahba (1991) Minimizing GCV/GML scores with multiple smoothing parameters via the Newton method. SIAM J. Sci. Statist. Comput. 12:383-398 } \keyword{data} cAIC4/man/getModelComponents.merMod.Rd0000644000176200001440000000056714773610660017211 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getModelComponents.R \name{getModelComponents.merMod} \alias{getModelComponents.merMod} \title{getModelComponents for merMods} \usage{ \method{getModelComponents}{merMod}(m, analytic) } \arguments{ \item{m}{merMod object} \item{analytic}{logical} } \description{ getModelComponents for merMods } cAIC4/man/deleteZeroComponents.Rd0000644000176200001440000000433314773607716016334 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deleteZeroComponents.R \name{deleteZeroComponents} \alias{deleteZeroComponents} \alias{deleteZeroComponents.lme} \alias{deleteZeroComponents.merMod} \title{Delete random effect terms with zero variance} \usage{ deleteZeroComponents(m) \method{deleteZeroComponents}{lme}(m) \method{deleteZeroComponents}{merMod}(m) } \arguments{ \item{m}{An object of class \code{\link[lme4]{merMod}} fitted by \code{\link[lme4]{lmer}} of the lme4-package or of class \code{\link[nlme]{lme}}.} } \value{ An updated object of class \code{\link[lme4]{merMod}} or of class \code{\link[nlme]{lme}}. \code{NULL} \code{NULL} } \description{ Is used in the \code{\link{cAIC}} function if \code{method = "steinian"} and \code{family = "gaussian"}. The function deletes all random effects terms from the call if corresponding variance parameter is estimated to zero and updates the model in \code{\link[lme4]{merMod}}. } \details{ For \code{\link[lme4]{merMod}} class models: Uses the \code{cnms} slot of \code{m} and the relative covariance factors to rewrite the random effects part of the formula, reduced by those parameters that have an optimum on the boundary. This is necessary to obtain the true conditional corrected Akaike information. For the theoretical justification see Greven and Kneib (2010). The reduced model formula is then updated. The function deleteZeroComponents is then called iteratively to check if in the updated model there are relative covariance factors parameters on the boundary. For \code{\link[nlme]{lme}} class models: ... } \section{WARNINGS }{ For models called via \code{gamm4} or \code{gamm} no automated update is available. Instead a warning with terms to omit from the model is returned. } \examples{ ## Currently no data with variance equal to zero... b <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy) deleteZeroComponents(b) } \references{ Greven, S. and Kneib T. (2010) On the behaviour of marginal and conditional AIC in linear mixed models. Biometrika 97(4), 773-789. } \seealso{ \code{\link[lme4]{lme4-package}}, \code{\link[lme4]{lmer}}, \code{\link[lme4]{getME}} } \author{ Benjamin Saefken, David Ruegamer, Philipp Baumann } \keyword{regression} cAIC4/man/stepcAIC.Rd0000644000176200001440000001642714773602310013607 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/stepcAIC.R \name{stepcAIC} \alias{stepcAIC} \title{Function to stepwise select the (generalized) linear mixed model fitted via (g)lmer() or (generalized) additive (mixed) model fitted via gamm4() with the smallest cAIC.} \usage{ stepcAIC( object, numberOfSavedModels = 1, groupCandidates = NULL, slopeCandidates = NULL, fixEfCandidates = NULL, numberOfPermissibleSlopes = 2, allowUseAcross = FALSE, allowCorrelationSel = FALSE, allowNoIntercept = FALSE, direction = "backward", trace = FALSE, steps = 50, keep = NULL, numCores = 1, data = NULL, returnResult = TRUE, calcNonOptimMod = TRUE, bsType = "tp", digits = 2, printValues = "caic", ... ) } \arguments{ \item{object}{object returned by \code{[lme4]{lmer}}, \code{[lme4]{glmer}} or \code{[gamm4]{gamm4}}} \item{numberOfSavedModels}{integer defining how many additional models to be saved during the step procedure. If \code{1} (DEFAULT), only the best model is returned. Any number \code{k} greater \code{1} will return the \code{k} best models. If \code{0}, all models will be returned (not recommended for larger applications).} \item{groupCandidates}{character vector containing names of possible grouping variables for new random effects. Group nesting must be specified manually, i.e. by listing up the string of the groups in the manner of lme4. For example \code{groupCandidates = c("a", "b", "a/b")}.} \item{slopeCandidates}{character vector containing names of possible new random effects} \item{fixEfCandidates}{character vector containing names of possible (non-)linear fixed effects in the GAMM; NULL for the (g)lmer-use case} \item{numberOfPermissibleSlopes}{how much slopes are permissible for one grouping variable} \item{allowUseAcross}{allow slopes to be used in other grouping variables} \item{allowCorrelationSel}{logical; FALSE does not allow correlations of random effects to be (de-)selected (default)} \item{allowNoIntercept}{logical; FALSE does not allow random effects without random intercept} \item{direction}{character vector indicating the direction ("both","backward","forward")} \item{trace}{logical; should information be printed during the execution of stepcAIC?} \item{steps}{maximum number of steps to be considered} \item{keep}{list($fixed,$random) of formulae; which splines / fixed (fixed) or random effects (random) to be kept during selection; specified terms must be included in the original model} \item{numCores}{the number of cores to be used in calculations; parallelization is done by using \code{parallel::mclapply}} \item{data}{data.frame supplying the data used in \code{object}. \code{data} must also include variables, which are considered for forward updates.} \item{returnResult}{logical; whether to return the result (best model and corresponding cAIC)} \item{calcNonOptimMod}{logical; if FALSE, models which failed to converge are not considered for cAIC calculation} \item{bsType}{type of splines to be used in forward gamm4 steps} \item{digits}{number of digits used in printing the results} \item{printValues}{what values of \code{c("cll", "df", "caic", "refit")} to print in the table of comparisons} \item{...}{further options for cAIC call} } \value{ if \code{returnResult} is \code{TRUE}, a list with the best model \code{finalModel}, \code{additionalModels} if \code{numberOfSavedModels} was specified and the corresponding cAIC \code{bestCAIC} is returned. Note that if \code{trace} is set to \code{FALSE} and \code{returnResult} is also \code{FALSE}, the function call may not be meaningful } \description{ The step function searches the space of possible models in a greedy manner, where the direction of the search is specified by the argument direction. If direction = "forward" / = "backward", the function adds / exludes random effects until the cAIC can't be improved further. In the case of forward-selection, either a new grouping structure, new slopes for the random effects or new covariates modeled nonparameterically must be supplied to the function call. If direction = "both", the greedy search is alternating between forward and backward steps, where the direction is changed after each step } \section{Details}{ Note that the method can not handle mixed models with uncorrelated random effects and does NOT reduce models to such, i.e., the model with \code{(1 + s | g)} is either reduced to \code{(1 | g)} or \code{(0 + s | g)} but not to \code{(1 + s || g)}. } \examples{ (fm3 <- lmer(strength ~ 1 + (1|sample) + (1|batch), Pastes)) fm3_step <- stepcAIC(fm3, direction = "backward", trace = TRUE, data = Pastes) fm3_min <- lm(strength ~ 1, data=Pastes) fm3_min_step <- stepcAIC(fm3_min, groupCandidates = c("batch", "sample"), direction="forward", data=Pastes, trace=TRUE) fm3_min_step <- stepcAIC(fm3_min, groupCandidates = c("batch", "sample"), direction="both", data=Pastes, trace=TRUE) # try using a nested group effect which is actually not nested -> warning fm3_min_step <- stepcAIC(fm3_min, groupCandidates = c("batch", "sample", "batch/sample"), direction="both", data=Pastes, trace=TRUE) Pastes$time <- 1:dim(Pastes)[1] fm3_slope <- lmer(data=Pastes, strength ~ 1 + (1 + time | cask)) fm3_slope_step <- stepcAIC(fm3_slope,direction="backward", trace=TRUE, data=Pastes) fm3_min <- lm(strength ~ 1, data=Pastes) fm3_min_step <- stepcAIC(fm3_min,groupCandidates=c("batch","sample"), direction="forward", data=Pastes,trace=TRUE) fm3_inta <- lmer(strength ~ 1 + (1|sample:batch), data=Pastes) fm3_inta_step <- stepcAIC(fm3_inta,groupCandidates=c("batch","sample"), direction="forward", data=Pastes,trace=TRUE) fm3_min_step2 <- stepcAIC(fm3_min,groupCandidates=c("cask","batch","sample"), direction="forward", data=Pastes,trace=TRUE) fm3_min_step3 <- stepcAIC(fm3_min,groupCandidates=c("cask","batch","sample"), direction="both", data=Pastes,trace=TRUE) \dontrun{ fm3_inta_step2 <- stepcAIC(fm3_inta,direction="backward", data=Pastes,trace=TRUE) } ##### create own example na <- 20 nb <- 25 n <- 400 a <- sample(1:na,400,replace=TRUE) b <- factor(sample(1:nb,400,replace=TRUE)) x <- runif(n) y <- 2 + 3 * x + a*.02 + rnorm(n) * .4 a <- factor(a) c <- interaction(a,b) y <- y + as.numeric(as.character(c))*5 df <- data.frame(y=y,x=x,a=a,b=b,c=c) smallMod <- lm(y ~ x) \dontrun{ # throw error stepcAIC(smallMod, groupCandidates=c("a","b","c"), data=df, trace=TRUE, returnResult=FALSE) smallMod <- lm(y ~ x, data=df) # throw error stepcAIC(smallMod, groupCandidates=c("a","b","c"), data=df, trace=TRUE, returnResult=FALSE) # get it all right mod <- stepcAIC(smallMod, groupCandidates=c("a","b","c"), data=df, trace=TRUE, direction="forward", returnResult=TRUE) # make some more steps... stepcAIC(smallMod, groupCandidates=c("a","b","c"), data=df, trace=TRUE, direction="both", returnResult=FALSE) mod1 <- lmer(y ~ x + (1|a), data=df) stepcAIC(mod1, groupCandidates=c("b","c"), data=df, trace=TRUE, direction="forward") stepcAIC(mod1, groupCandidates=c("b","c"), data=df, trace=TRUE, direction="both") mod2 <- lmer(y ~ x + (1|a) + (1|c), data=df) stepcAIC(mod2, data=df, trace=TRUE, direction="backward") mod3 <- lmer(y ~ x + (1|a) + (1|a:b), data=df) stepcAIC(mod3, data=df, trace=TRUE, direction="backward") } } \author{ David Ruegamer } cAIC4/man/summaryMA.Rd0000644000176200001440000000271214773607716014076 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summaryMA.R \name{summaryMA} \alias{summaryMA} \title{Summary of model averaged linear mixed models} \usage{ summaryMA(object, randeff = FALSE) } \arguments{ \item{object}{A object created by the model averaging function.} \item{randeff}{logical. Indicator whether the model averaged random effects should also be part of the output. The default setting is FALSE.} } \value{ Outputs a summary of the model averaged random and fixed effects, as well as the calculated weights of the individual candidate models. } \description{ summaryMA is a function used to produce result summaries of the model averaging approach. } \examples{ data(Orthodont, package = "nlme") models <- list( model1 <- lmer(formula = distance ~ age + Sex + (1 | Subject) + age:Sex, data = Orthodont), model2 <- lmer(formula = distance ~ age + Sex + (1 | Subject), data = Orthodont), model3 <- lmer(formula = distance ~ age + (1 | Subject), data = Orthodont), model4 <- lmer(formula = distance ~ Sex + (1 | Subject), data = Orthodont)) foo <- modelAvg(models = models) summaryMA(foo) } \references{ Greven, S. and Kneib T. (2010) On the behaviour of marginal and conditional AIC in linear mixed models. Biometrika 97(4), 773-789. } \seealso{ \code{\link[lme4]{lme4-package}}, \code{\link[lme4]{lmer}} } \author{ Benjamin Saefken & Rene-Marcel Kruse } cAIC4/man/cAIC.Rd0000644000176200001440000001770614773607716012733 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cAIC.R \name{cAIC} \alias{cAIC} \title{Conditional Akaike Information for 'lme4' and 'lme'} \usage{ cAIC(object, method = NULL, B = NULL, sigma.penalty = 1, analytic = TRUE) } \arguments{ \item{object}{An object of class merMod either fitted by \code{\link[lme4]{lmer}} or \code{\link[lme4]{glmer}} of the lme4-package or an \code{\link[nlme]{lme}} object fro the nlme-package. Also objects returned form a \code{\link[gamm4]{gamm4}} call are possible.} \item{method}{Either \code{"conditionalBootstrap"} for the estimation of the degrees of freedom with the help of conditional Bootstrap or \code{"steinian"} for analytical representations based on Stein type formulas. The default is \code{NULL}. In this case the method is choosen automatically based on the \code{family} argument of the \code{(g)lmer}-object. For \code{"gaussian"}, \code{"poisson"} and \code{"binomial"} (in the Bernoulli case, i.e. only two outcomes) this is the Steinian type estimator, for all others it is the conditional Bootstrap. For models from the nlme package, only \code{\link[nlme]{lme}} objects, i.e., with gaussian response are supported.} \item{B}{Number of Bootstrap replications. The default is \code{NULL}. Then B is the minimum of 100 and the length of the response vector.} \item{sigma.penalty}{An integer value for additional penalization in the analytic Gaussian calculation to account for estimated variance components in the residual (co-)variance. Per default \code{sigma.penalty} is equal \code{1}, corresponding to a diagonal error covariance matrix with only one estimated parameter (sigma). If all variance components are known, the value should be set to \code{0}. For individual weights (individual variances), this value should be set to the number of estimated weights. For \code{\link[nlme]{lme}} objects the penalty term is automatically set by extracting the number of estimated variance components.} \item{analytic}{FALSE if the numeric hessian of the (restricted) marginal log-likelihood from the lmer optimization procedure should be used. Otherwise (default) TRUE, i.e. use a analytical version that has to be computed. Only used for the analytical version of Gaussian responses.} } \value{ A \code{cAIC} object, which is a list consisting of: 1. the conditional log likelihood, i.e. the log likelihood with the random effects as penalized parameters; 2. the estimated degrees of freedom; 3. a list element that is either \code{NULL} if no new model was fitted otherwise the new (reduced) model, see details; 4. a boolean variable indicating whether a new model was fitted or not; 5. the estimator of the conditional Akaike information, i.e. minus twice the log likelihood plus twice the degrees of freedom. } \description{ Estimates the conditional Akaike information for models that were fitted in 'lme4' or with 'lme'. Currently all distributions are supported for 'lme4' models, based on parametric conditional bootstrap. For the Gaussian distribution (from a \code{\link[lme4]{lmer}} or \code{\link[nlme]{lme}} call) and the Poisson distribution analytical estimators for the degrees of freedom are available, based on Stein type formulas. Also the conditional Akaike information for generalized additive models based on a fit via the 'gamm4' or \code{\link[mgcv]{gamm}} calls from the 'mgcv' package can be estimated. A hands-on tutorial for the package can be found at \url{https://arxiv.org/abs/1803.05664}. } \details{ For \code{method = "steinian"} and an object of class \code{merMod} computed the analytic representation of the corrected conditional AIC in Greven and Kneib (2010). This is based on a the Stein formula and uses implicit differentiation to calculate the derivative of the random effects covariance parameters w.r.t. the data. The code is adapted form the one provided in the supplementary material of the paper by Greven and Kneib (2010). The supplied \code{\link[lme4]{merMod}} model needs to be checked if a random effects covariance parameter has an optimum on the boundary, i.e. is zero. And if so the model needs to be refitted with the according random effect terms omitted. This is also done by the function and the refitted model is also returned. Notice that the \code{boundary.tol} argument in \code{\link[lme4]{lmerControl}} has an impact on whether a parameter is estimated to lie on the boundary of the parameter space. For estimated error variance the degrees of freedom are increased by one per default. \code{sigma.penalty} can be set manually for \code{\link[lme4]{merMod}} models if no (0) or more than one variance component (>1) has been estimated. For \code{\link[nlme]{lme}} objects this value is automatically defined. If the object is of class \code{\link[lme4]{merMod}} and has \code{family = "poisson"} there is also an analytic representation of the conditional AIC based on the Chen-Stein formula, see for instance Saefken et. al (2014). For the calculation the model needs to be refitted for each observed response variable minus the number of response variables that are exactly zero. The calculation therefore takes longer then for models with Gaussian responses. Due to the speed and stability of 'lme4' this is still possible, also for larger datasets. If the model has Bernoulli distributed responses and \code{method = "steinian"}, \code{\link{cAIC}} calculates the degrees of freedom based on a proposed estimator by Efron (2004). This estimator is asymptotically unbiased if the estimated conditional mean is consistent. The calculation needs as many model refits as there are data points. Another more general method for the estimation of the degrees of freedom is the conditional bootstrap. This is proposed in Efron (2004). For the B boostrap samples the degrees of freedom are estimated by \deqn{\frac{1}{B - 1}\sum_{i=1}^n\theta_i(z_i)(z_i-\bar{z}),} where \eqn{\theta_i(z_i)} is the i-th element of the estimated natural parameter. For models with no random effects, i.e. (g)lms, the \code{\link{cAIC}} function returns the AIC of the model with scale parameter estimated by REML. } \section{WARNINGS }{ Currently the cAIC can only be estimated for \code{family} equal to \code{"gaussian"}, \code{"poisson"} and \code{"binomial"}. Neither negative binomial nor gamma distributed responses are available. Weighted Gaussian models are not yet implemented. } \examples{ ### Three application examples b <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy) cAIC(b) b2 <- lmer(Reaction ~ (1 | Days) + (1 | Subject), sleepstudy) cAIC(b2) b2ML <- lmer(Reaction ~ (1 + Days | Subject), sleepstudy, REML = FALSE) cAIC(b2ML) ### Demonstration of boundary case \dontrun{ set.seed(2017-1-1) n <- 50 beta <- 2 x <- rnorm(n) eta <- x*beta id <- gl(5,10) epsvar <- 1 data <- data.frame(x = x, id = id) y_wo_bi <- eta + rnorm(n, 0, sd = epsvar) # use a very small RE variance ranvar <- 0.05 nrExperiments <- 100 sim <- sapply(1:nrExperiments, function(j){ b_i <- scale(rnorm(5, 0, ranvar), scale = FALSE) y <- y_wo_bi + model.matrix(~ -1 + id) \%*\% b_i data$y <- y mixedmod <- lmer(y ~ x + (1 | id), data = data) linmod <- lm(y ~ x, data = data) c(cAIC(mixedmod)$caic, cAIC(linmod)$caic) }) rownames(sim) <- c("mixed model", "linear model") boxplot(t(sim)) } } \references{ Saefken, B., Ruegamer, D., Kneib, T. and Greven, S. (2021): Conditional Model Selection in Mixed-Effects Models with cAIC4. Saefken, B., Kneib T., van Waveren C.-S. and Greven, S. (2014) A unifying approach to the estimation of the conditional Akaike information in generalized linear mixed models. Electronic Journal Statistics Vol. 8, 201-225. Greven, S. and Kneib T. (2010) On the behaviour of marginal and conditional AIC in linear mixed models. Biometrika 97(4), 773-789. Efron , B. (2004) The estimation of prediction error. J. Amer. Statist. Ass. 99(467), 619-632. } \seealso{ \code{\link[lme4]{lme4-package}}, \code{\link[lme4]{lmer}}, \code{\link[lme4]{glmer}} } \author{ Benjamin Saefken, David Ruegamer } \keyword{regression} cAIC4/man/getWeights.Rd0000644000176200001440000000373314773607716014301 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getWeights.R \name{getWeights} \alias{getWeights} \title{Optimize weights for model averaging.} \usage{ getWeights(models) } \arguments{ \item{models}{An list object containing all considered candidate models fitted by \code{\link[lme4]{lmer}} of the lme4-package or of class \code{\link[nlme]{lme}}.} } \value{ An object containing a vector of optimized weights, value of the minimized target function and the duration of the optimization process. } \description{ Function to determine optimal weights for model averaging based on a proposal by Zhang et al. ( 2014) to derive a weight choice criterion based on the conditional Akaike Information Criterion as proposed by Greven and Kneib (2010). The underlying optimization is a customized version of the Augmented Lagrangian Method. } \section{WARNINGS }{ No weight-determination is currently possible for models called via \code{gamm4}. } \examples{ data(Orthodont, package = "nlme") models <- list( model1 <- lmer(formula = distance ~ age + Sex + (1 | Subject) + age:Sex, data = Orthodont), model2 <- lmer(formula = distance ~ age + Sex + (1 | Subject), data = Orthodont), model3 <- lmer(formula = distance ~ age + (1 | Subject), data = Orthodont), model4 <- lmer(formula = distance ~ Sex + (1 | Subject), data = Orthodont)) foo <- getWeights(models = models) foo } \references{ Greven, S. and Kneib T. (2010) On the behaviour of marginal and conditional AIC in linear mixed models. Biometrika 97(4), 773-789. Zhang, X., Zou, G., & Liang, H. (2014). Model averaging and weight choice in linear mixed-effects models. Biometrika, 101(1), 205-218. Nocedal, J., & Wright, S. (2006). Numerical optimization. Springer Science & Business Media. } \seealso{ \code{\link[lme4]{lme4-package}}, \code{\link[lme4]{lmer}}, \code{\link[lme4]{getME}} } \author{ Benjamin Saefken & Rene-Marcel Kruse } cAIC4/man/anocAIC.Rd0000644000176200001440000000110014773602310013367 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/methods.R \name{anocAIC} \alias{anocAIC} \title{Comparison of several lmer objects via cAIC} \usage{ anocAIC(object, ..., digits = 2) } \arguments{ \item{object}{a fitted \code{lme4}-object} \item{...}{additional objects of the same type} \item{digits}{number of digits to print} } \value{ a table comparing the cAIC relevant information of all models } \description{ Takes one or more \code{lmer}-objects and produces a table to the console. } \seealso{ \code{\link{cAIC}} for the model fit. } cAIC4/man/cAIC4-package.Rd0000644000176200001440000000164114773602310014360 0ustar liggesusers\name{cAIC4-package} \alias{cAIC4-package} \alias{cAIC4} \docType{package} \title{ \packageTitle{cAIC4} } \description{ \packageDescription{cAIC4} } \details{ The DESCRIPTION file: \packageDESCRIPTION{cAIC4} \packageIndices{cAIC4} } \author{ \packageAuthor{cAIC4} Maintainer: \packageMaintainer{cAIC4} } \references{ Saefken, B., Kneib T., van Waveren C.-S. and Greven, S. (2014) A unifying approach to the estimation of the conditional Akaike information in generalized linear mixed models. Electronic Journal Statistics Vol. 8, 201-225. Greven, S. and Kneib T. (2010) On the behaviour of marginal and conditional AIC in linear mixed models. Biometrika 97(4), 773-789. Efron , B. (2004) The estimation of prediction error. J. Amer. Statist. Ass. 99(467), 619-632. } \keyword{ package } \seealso{ \code{\link[lme4:lme4-package]{lme4}} } \examples{ b <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy) cAIC(b) } cAIC4/man/predictMA.Rd0000644000176200001440000000271314773607716014034 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/predictMA.R \name{predictMA} \alias{predictMA} \title{Prediction of model averaged linear mixed models} \usage{ predictMA(object, new.data) } \arguments{ \item{object}{A object created by the model averaging function.} \item{new.data}{Object that contains the data on which the prediction is to be based on.} } \value{ An object that contains predictions calculated based on the given dataset and the assumed underlying model average. } \description{ Function to perform prediction for model averaged linear mixed models based on the weight selection criterion as proposed by Zhang et al.(2014) } \examples{ data(Orthodont, package = "nlme") models <- list( model1 <- lmer(formula = distance ~ age + Sex + (1 | Subject) + age:Sex, data = Orthodont), model2 <- lmer(formula = distance ~ age + Sex + (1 | Subject), data = Orthodont), model3 <- lmer(formula = distance ~ age + (1 | Subject), data = Orthodont), model4 <- lmer(formula = distance ~ Sex + (1 | Subject), data = Orthodont)) foo <- modelAvg(models = models) predictMA(foo, new.data = Orthodont) } \references{ Greven, S. and Kneib T. (2010) On the behaviour of marginal and conditional AIC in linear mixed models. Biometrika 97(4), 773-789. } \seealso{ \code{\link[lme4]{lme4-package}}, \code{\link[lme4]{lmer}} } \author{ Benjamin Saefken & Rene-Marcel Kruse } cAIC4/man/family.lme.Rd0000644000176200001440000000064414773614677014226 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/helperfuns_lme.R \name{family.lme} \alias{family.lme} \title{family function for lme objects to have a generic function} \usage{ \method{family}{lme}(object, ...) } \arguments{ \item{object}{lme object} \item{...}{unused} } \value{ returns a Gaussian distribution } \description{ family function for lme objects to have a generic function } cAIC4/DESCRIPTION0000644000176200001440000000250414773621532012616 0ustar liggesusersPackage: cAIC4 Type: Package Title: Conditional Akaike Information Criterion for 'lme4' and 'nlme' Version: 1.1 Date: 2025-04-04 Authors@R: c(person(given = "Benjamin", family = "Saefken", role = "aut"), person(given = "David", family = "Ruegamer", role = c("aut", "cre"), email = "david.ruegamer@gmail.com"), person(given = "Philipp", family = "Baumann", role = "aut"), person(given = "Rene-Marcel", family = "Kruse", role = "aut"), person(given = "Sonja", family = "Greven", role = "aut"), person(given = "Thomas", family = "Kneib", role = "aut")) Depends: lme4(>= 1.1-6), methods, Matrix, stats4, nlme Imports: RLRsim, mgcv, mvtnorm Suggests: gamm4 Description: Provides functions for the estimation of the conditional Akaike information in generalized mixed-effect models fitted with (g)lmer() from 'lme4', lme() from 'nlme' and gamm() from 'mgcv'. For a manual on how to use 'cAIC4', see Saefken et al. (2021) . License: GPL (>= 2) Packaged: 2025-04-03 23:29:48 UTC; david NeedsCompilation: no Date/Publication: 2025-04-04 00:10:02 UTC RoxygenNote: 7.3.2 Encoding: UTF-8 Author: Benjamin Saefken [aut], David Ruegamer [aut, cre], Philipp Baumann [aut], Rene-Marcel Kruse [aut], Sonja Greven [aut], Thomas Kneib [aut] Maintainer: David Ruegamer Repository: CRAN