├── DESCRIPTION ├── NAMESPACE ├── R ├── JSS.R ├── communityPLMM.R ├── pirls.R ├── pls.R └── templateApproach.R ├── README.md ├── man ├── Zsection.Rd ├── blockLambdat.Rd ├── lmer.fit.Rd ├── lmerCorr.fit.Rd ├── mkLambdat.Rd ├── mkLind.Rd ├── mkRanefRepresentation.Rd ├── mkRanefStructures.Rd ├── mkRanefStructuresCorr.Rd ├── mkTemplate.Rd ├── mkTemplates.Rd ├── mkTheta.Rd ├── mkZt.Rd ├── mkZtSection.Rd ├── pirls.Rd ├── pls.Rd ├── plsJSS.Rd ├── plsform.Rd └── rLmer.Rd └── tests ├── Contraception.R ├── cbpp.R ├── pirls.R ├── pls.R └── sleep.R /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: lme4pureR 2 | Type: Package 3 | Title: lme4 in pure R 4 | Version: 0.1-0 5 | Date: 2013-08-28 6 | Author: Steve Walker, Doug Bates 7 | Maintainer: Steve Walker 8 | Description: The penalized least squares (PLS) and penalized iteratively 9 | reweighted least squares (PIRLS) algorithms from lme4, but written entirely 10 | in pure R. The purpose is to clarify how PLS and PIRLS work without having 11 | to read through C++ code, and as a sandbox for trying out modified versions 12 | of PLS and PIRLS. 13 | Depends: 14 | Matrix 15 | Suggests: 16 | minqa, 17 | mlmRev 18 | Imports: 19 | lme4 20 | License: GPL-2 21 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | export(Zsection) 2 | export(blockLambdat) 3 | export(lmer.fit) 4 | export(lmerCorr.fit) 5 | export(mkLambdat) 6 | export(mkLind) 7 | export(mkRanefRepresentation) 8 | export(mkRanefStructures) 9 | export(mkRanefStructuresCorr) 10 | export(mkTemplate) 11 | export(mkTemplates) 12 | export(mkTheta) 13 | export(mkZt) 14 | export(mkZtSection) 15 | export(pirls) 16 | export(pls) 17 | export(plsJSS) 18 | export(plsform) 19 | export(rLmer) 20 | importFrom(Matrix,Cholesky) 21 | importFrom(Matrix,Diagonal) 22 | importFrom(Matrix,bdiag) 23 | importFrom(Matrix,rBind) 24 | importFrom(Matrix,sparse.model.matrix) 25 | importFrom(lme4,findbars) 26 | importFrom(lme4,nobars) 27 | importFrom(lme4,subbars) 28 | importMethodsFrom(Matrix,"%*%") 29 | importMethodsFrom(Matrix,crossprod) 30 | importMethodsFrom(Matrix,determinant) 31 | importMethodsFrom(Matrix,diag) 32 | importMethodsFrom(Matrix,solve) 33 | importMethodsFrom(Matrix,t) 34 | importMethodsFrom(Matrix,tcrossprod) 35 | importMethodsFrom(Matrix,update) 36 | -------------------------------------------------------------------------------- /R/JSS.R: -------------------------------------------------------------------------------- 1 | ##' Linear mixed model deviance function as it 2 | ##' appears in the pseudocode of the JSS article 3 | ##' 4 | ##' A pure \code{R} implementation of the 5 | ##' penalized least squares (PLS) approach for computing 6 | ##' linear mixed model deviances. The purpose 7 | ##' is to clarify how PLS works without having 8 | ##' to read through C++ code, and as a sandbox for 9 | ##' trying out modifications to PLS. 10 | ##' 11 | ##' @param X fixed effects model matrix 12 | ##' @param y response 13 | ##' @param Zt transpose of the sparse model matrix for the random effects 14 | ##' @param Lambdat upper triangular sparse Cholesky factor of the 15 | ##' relative covariance matrix of the random effects 16 | ##' @param mapping a function that takes a value of \code{theta} and produces 17 | ##' the non-zero elements of \code{Lambdat}. The structure of \code{Lambdat} 18 | ##' cannot change, only the numerical values 19 | ##' @param weights prior weights 20 | ##' @param offset offset 21 | ##' @param REML calculate REML deviance? 22 | ##' @param ... additional arguments 23 | ##' @keywords models 24 | ##' 25 | ##' @return a function that evaluates the deviance or REML criterion 26 | ##' @export 27 | plsJSS <- function(X, y, Zt, Lambdat, mapping, weights, 28 | offset = numeric(n), REML = TRUE, ...) 29 | { 30 | stopifnot(is.matrix(X)) # is.matrix(Zt), is.matrix(Lambdat)) 31 | n <- length(y); p <- ncol(X); q <- nrow(Zt) 32 | stopifnot(nrow(X) == n, ncol(Zt) == n, 33 | nrow(Lambdat) == q, ncol(Lambdat) == q) 34 | # calculate weighted products 35 | sqrtW <- if (missing(weights)) Diagonal(n=n) else Diagonal(x=sqrt(as.numeric(weights))) 36 | WX <- sqrtW %*% X 37 | Wy <- sqrtW %*% y 38 | ZtW <- Zt %*% sqrtW 39 | XtWX <- crossprod(WX) 40 | XtWy <- crossprod(WX, Wy) 41 | ZtWX <- ZtW %*% WX 42 | ZtWy <- ZtW %*% Wy 43 | rm(WX,Wy) 44 | local({ # mutable values stored in local environment 45 | b <- numeric(q) # conditional mode of random effects 46 | beta <- numeric(p) # conditional estimate of fixed-effects 47 | cu <- numeric(q) # intermediate solution 48 | RXtRX <- XtWX # down-dated XtWX 49 | L <- Cholesky(tcrossprod(Lambdat %*% ZtW), LDL = FALSE, Imult=1) 50 | Lambdat <- Lambdat # stored here b/c x slot will be updated 51 | mu <- numeric(n) # conditional mean of response 52 | RZX <- matrix(0,nrow=q,ncol=p) # intermediate matrix in solution 53 | u <- numeric(q) # conditional mode of spherical random effects 54 | degFree <- as.numeric(n) # degrees of freedom (depends on REML) 55 | if(REML) degFree <- degFree - as.numeric(p) 56 | function(theta) { 57 | 58 | ################################################## 59 | # Step I: update covariance parameters 60 | ################################################## 61 | # update relative covariance factor 62 | # by placing the new values of theta 63 | # in the appropriate positions 64 | Lambdat@x[] <<- mapping(theta) 65 | # update random-effects 66 | # Cholesky factor (eqn. 18) 67 | L <<- update(L, Lambdat %*% ZtW, mult = 1) 68 | 69 | ################################################## 70 | # Step II: solve normal equations 71 | ################################################## 72 | # solve eqn. 48 73 | cu[] <<- as.vector(solve(L, solve(L, Lambdat %*% ZtWy, 74 | system="P"), system="L")) 75 | # solve eqn. 49 76 | RZX[] <<- as.vector(solve(L, solve(L, Lambdat %*% ZtWX, 77 | system="P"), system="L")) 78 | # downdate XtWX and form 79 | # Cholesky factor (eqn. 50) 80 | RXtRX <<- as(XtWX - crossprod(RZX), "dpoMatrix") 81 | # conditional estimate of 82 | # fixed-effects coefficients 83 | # (solve eqn. 51) 84 | beta[] <<- as.vector(solve(RXtRX, XtWy - crossprod(RZX, cu))) 85 | # conditional mode of the 86 | # spherical random-effects 87 | # coefficients (eqn. 52) 88 | u[] <<- as.vector(solve(L, solve(L, cu - RZX %*% beta, 89 | system = "Lt"), system="Pt")) 90 | # update conditional model of 91 | # the non-spherical 92 | # random-effects coefficients 93 | # (eqn. 11) 94 | b[] <<- as.vector(crossprod(Lambdat,u)) 95 | 96 | 97 | ################################################## 98 | # Step III: update linear predictor and residuals 99 | ################################################## 100 | # update linear predictor 101 | # (eqn. 13) 102 | mu[] <<- as.vector(crossprod(Zt,b) + X %*% beta + offset) 103 | # weighted residuals (eqn. 15) 104 | wtres <- sqrtW*(y-mu) 105 | 106 | 107 | 108 | ################################################## 109 | # Step IV: compute profiled deviance 110 | ################################################## 111 | # penalized, weighted residual 112 | # sum-of-squares (eqn. 14) 113 | pwrss <- sum(wtres^2) + sum(u^2) 114 | # log determinant (depends on 115 | # whether REML or ML is used) 116 | logDet <- 2*determinant(L, logarithm = TRUE)$modulus 117 | if (REML) logDet <- logDet + determinant(RXtRX, 118 | logarithm = TRUE)$modulus 119 | attributes(logDet) <- NULL 120 | # profiled deviance or REML 121 | # criterion (eqns. 34, 41) 122 | profDev <- logDet + degFree*(1 + log(2*pi*pwrss) - log(degFree)) 123 | return(profDev) 124 | } 125 | }) 126 | } 127 | -------------------------------------------------------------------------------- /R/communityPLMM.R: -------------------------------------------------------------------------------- 1 | ##' Phylogenetic Generalized Linear Mixed Model for Community Data 2 | ##' 3 | ##' This function performs Generalized Linear Mixed Models for binary 4 | ##' and continuous phylogenetic data, estimating regression 5 | ##' coefficients with approximate standard errors. It is a modeled 6 | ##' after \code{lmer} but is more general by allowing correlation 7 | ##' structure within random effects; these correlations can be 8 | ##' phylogenetic among species, or any other correlation structure, 9 | ##' such as geographical correlations among sites. It is, however, 10 | ##' much more specific than \code{lmer} in that it can only analyze a 11 | ##' subset of the types of model designed handled by \code{lmer}. It 12 | ##' is also much slower than \code{lmer} and requires users to specify 13 | ##' correlation structures as covariance matrices. 14 | ##' \code{communityPGLMM} can analyze models in Ives and Helmus 15 | ##' (2011). It can also analyze bipartite phylogenetic data, such as 16 | ##' that analyzed in Rafferty and Ives (2011), by giving sites 17 | ##' phylogenetic correlations. 18 | ##' 19 | ##' @param formula a two-sided linear formula object describing the 20 | ##' fixed-effects of the model; for example, \code{Y ~ X}. 21 | ##' @param data data frame containing the variables named in formula. The 22 | ##' data frame should have long format with factors specifying species 23 | ##' and sites. \code{communityPGLMM} will reorder rows of the data 24 | ##' frame so that species are nested within sites. 25 | ##' @param family either \code{gaussian} for a Linear Mixed Model, or 26 | ##' \code{binomial} for binary dependent data. 27 | ##' @param sp a factor variable that identifies species 28 | ##' @param site a factor variable that identifies sites 29 | ##' @param random.effects a list that contains, for non-nested random 30 | ##' effects, lists of triplets of the form \code{list(X, group = 31 | ##' group, covar = V)}. This is modeled after the \code{lmer} formula 32 | ##' syntax \code{(X | group)} where \code{X} is a variable and group 33 | ##' is a grouping factor. Note that group should be either your sp or 34 | ##' site variable specified in sp and site. The additional term 35 | ##' \code{V} is a covariance matrix of rank equal to the number of 36 | ##' levels of group that specifies the covariances among groups in the 37 | ##' random effect \code{X}. For nested variable random effects, 38 | ##' random.effects contains lists of quadruplets of the form 39 | ##' \code{list(X, group1 = group1, covar = V, group2 = group2)} where 40 | ##' \code{group1} is nested within \code{group2}. 41 | ##' @param REML whether REML or ML is used for model fitting. For the 42 | ##' generalized linear mixed model for binary data, these don't have 43 | ##' standard interpretations, and there is no log likelihood function 44 | ##' that can be used in likelihood ratio tests. 45 | ##' @param s2.init an array of initial estimates of \code{s2} for each 46 | ##' random effect that scales the variance. If s2.init is not provided 47 | ##' for \code{family="gaussian"}, these are estimated using in a 48 | ##' clunky way using \code{lm} assuming no phylogenetic signal. A 49 | ##' better approach is to run \code{lmer} and use the output random 50 | ##' effects for \code{s2.init}. If \code{s2.init} is not provided for 51 | ##' \code{family="binomial"}, these are set to 0.25. 52 | ##' @param B.init initial estimates of B, a matrix containing 53 | ##' regression coefficients in the model for the fixed effects. This 54 | ##' matrix must have dim(B.init)=c(p+1,1), where p is the number of 55 | ##' predictor (independent) variables; the first element of B 56 | ##' corresponds to the intercept, and the remaining elements 57 | ##' correspond in order to the predictor (independent) variables in 58 | ##' the formula. If B.init is not provided, these are estimated using 59 | ##' in a clunky way using lm() or glm() assuming no phylogenetic 60 | ##' signal. A better approach is to run lmer() and use the output 61 | ##' fixed effects for B.init. 62 | ##' @param reltol a control parameter dictating the relative tolerance 63 | ##' for convergence in the optimization; see optim(). 64 | ##' @param maxit a control parameter dictating the maximum number of 65 | ##' iterations in the optimization; see optim(). 66 | ##' @param reltol.pgl a control parameter dictating the tolerance for 67 | ##' convergence in the PQL estimates of the mean components of the 68 | ##' binomial GLMM. 69 | ##' @param maxit.pgl a control parameter dictating the maximum number 70 | ##' of iterations in the PQL estimates of the mean components of the 71 | ##' binomial GLMM. 72 | ##' @param verbose if TRUE, the model deviance and running estimates 73 | ##' of s2 and B are plotted each iteration during optimization. 74 | ##' 75 | ##' @details For linear mixed models (family = "gaussian"), the 76 | ##' function estimates parameters for the model of the form FIXME 77 | communityPGLMM <- function(formula, data = list(), family = "gaussian", 78 | sp = NULL, site = NULL, random.effects = list(), REML = 79 | TRUE, s2.init = NULL, B.init = NULL, reltol = 10^-6, maxit = 500, 80 | tol.pql = 10^-6, maxit.pql = 200, verbose = FALSE) { 81 | 82 | if (family == "gaussian") 83 | z <- communityPGLMM.gaussian(formula = formula, data = data, sp = sp, 84 | site = site, random.effects = random.effects, 85 | REML = REML, s2.init = s2.init, B.init = B.init, 86 | reltol = reltol, maxit = maxit, verbose = verbose) 87 | if (family == "binomial") { 88 | s2.init <- 0.25 89 | z <- communityPGLMM.binary(formula = formula, data = data, sp = sp, site = site, 90 | random.effects = random.effects, REML = REML, 91 | s2.init = s2.init, B.init = B.init, reltol = reltol, 92 | maxit = maxit, tol.pql = tol.pql, 93 | maxit.pql = maxit.pql, verbose = verbose) 94 | } 95 | if (!is.element(family, c("gaussian", "binomial"))) 96 | cat("\nSorry, but only binomial (binary) and gaussian options exist at this time") 97 | return(z) 98 | } 99 | 100 | ###################################################### 101 | ###################################################### 102 | # communityPLMM.gaussian 103 | ###################################################### 104 | ###################################################### 105 | communityPGLMM.gaussian <- function(formula, data = list(), family = "gaussian", 106 | sp = NULL, site = NULL, random.effects = list(), 107 | REML = TRUE, s2.init = NULL, B.init = NULL, 108 | reltol = 10^-8, maxit = 500, verbose = FALSE) { 109 | 110 | # Begin pglmm.LL 111 | plmm.LL <- function(par, X, Y, Zt, St, nestedsp = NULL, nestedsite = NULL, REML, verbose) { 112 | n <- dim(X)[1] 113 | p <- dim(X)[2] 114 | 115 | if (!is.null(St)) { 116 | q.nonNested <- dim(St)[1] 117 | sr <- Re(par[1:q.nonNested]) 118 | iC <- sr[1] * St[1, ] 119 | if (length(sr) > 1) 120 | for (i in 2:q.nonNested) { 121 | iC <- iC + sr[i] * St[i, ] 122 | } 123 | iC <- as(diag(iC), "dsCMatrix") 124 | Ut <- iC %*% Zt 125 | U <- t(Ut) 126 | } else { 127 | q.nonNested <- 0 128 | sr <- NULL 129 | } 130 | if (is.null(nestedsp[[1]])) { 131 | q.Nested <- 0 132 | } else { 133 | q.Nested <- length(nestedsp) 134 | } 135 | 136 | if (q.Nested == 0) { 137 | sn <- NULL 138 | } else { 139 | sn <- Re(par[(q.nonNested + 1):(q.nonNested + q.Nested)]) 140 | } 141 | 142 | if (q.Nested == 0) { 143 | iA <- as(diag(n), "dsCMatrix") 144 | Ishort <- as(diag(nrow(Ut)), "dsCMatrix") 145 | Ut.iA.U <- Ut %*% U 146 | # Woodbury identity 147 | iV <- iA - U %*% solve(Ishort + Ut.iA.U) %*% Ut 148 | } else { 149 | A <- as(diag(n), "dsCMatrix") 150 | for (j in 1:q.Nested) { 151 | A <- A + sn[j]^2 * kronecker(nestedsite[[j]], nestedsp[[j]]) 152 | } 153 | iA <- solve(A) 154 | if (q.nonNested > 0) { 155 | Ishort <- as(diag(nrow(Ut)), "dsCMatrix") 156 | Ut.iA.U <- Ut %*% iA %*% U 157 | iV <- iA - iA %*% U %*% solve(Ishort + Ut.iA.U) %*% Ut %*% iA 158 | } else { 159 | iV <- iA 160 | } 161 | } 162 | 163 | denom <- t(X) %*% iV %*% X 164 | num <- t(X) %*% iV %*% Y 165 | B <- solve(denom, num) 166 | B <- as.matrix(B) 167 | H <- Y - X %*% B 168 | 169 | if (q.Nested == 0) { 170 | # Sylvester identity 171 | logdetV <- determinant(Ishort + Ut.iA.U)$modulus[1] 172 | if (is.infinite(logdetV)) 173 | logdetV <- 2 * sum(log(diag(chol(Ishort + Ut.iA.U)))) 174 | } else { 175 | logdetV <- -determinant(iV)$modulus[1] 176 | if (is.infinite(logdetV)) 177 | logdetV <- -2 * sum(log(diag(chol(iV, pivot = T)))) 178 | if (is.infinite(logdetV)) 179 | return(10^10) 180 | } 181 | 182 | 183 | if (REML == TRUE) { 184 | # concentrated REML likelihood function 185 | s2.conc <- t(H) %*% iV %*% H/(n - p) 186 | LL <- 0.5 * ((n - p) * log(s2.conc) + logdetV + (n - p) + log(det(t(X) %*% iV %*% X))) 187 | } else { 188 | # concentrated ML likelihood function 189 | s2.conc <- t(H) %*% iV %*% H/n 190 | LL <- 0.5 * (n * log(s2.conc) + logdetV + n) 191 | } 192 | 193 | if (verbose == T) 194 | show(c(as.numeric(LL), par)) 195 | return(as.numeric(LL)) 196 | } 197 | # End plmm.LL 198 | 199 | # Main program 200 | if (is.null(sp) | is.null(site)) 201 | stop("Categorical variables for 'sp' and 'site' must be specified") 202 | nspp <- nlevels(sp) 203 | nsite <- nlevels(site) 204 | 205 | # order data first by site, second by species 206 | sp.order <- order(sp) 207 | data <- data[sp.order, ] 208 | sp <- sp[sp.order] 209 | site <- site[sp.order] 210 | 211 | site.order <- order(site) 212 | data <- data[site.order, ] 213 | sp <- sp[site.order] 214 | site <- site[site.order] 215 | 216 | mf <- model.frame(formula = formula, data = data) 217 | X <- model.matrix(attr(mf, "terms"), data = mf) 218 | Y <- model.response(mf) 219 | 220 | re <- random.effects 221 | q <- length(re) 222 | 223 | Ztt <- list(NULL) 224 | St.lengths <- array(0, q) 225 | nestedsp <- list(NULL) 226 | nestedsite <- list(NULL) 227 | ii <- 0 228 | jj <- 0 229 | 230 | for (i in 1:q) { 231 | re.i <- re[[i]] 232 | # non-nested terms 233 | if (length(re.i) == 3) { 234 | if (setequal(levels(re.i[[2]]), levels(sp)) && all(re.i[[2]] == sp)) { 235 | Zt.i <- kronecker(matrix(1, nrow = 1, ncol = nsite), chol(re.i[[3]])) 236 | if (length(re.i[[1]]) > 1) { 237 | Zt.i <- Zt.i * kronecker(t(re.i[[1]]), matrix(1, nrow = nspp, ncol = 1)) 238 | } 239 | ii <- ii + 1 240 | Ztt[[ii]] <- Zt.i 241 | St.lengths[ii] <- nspp 242 | } 243 | if (setequal(levels(re.i[[2]]), levels(site)) && all(re.i[[2]] == site)) { 244 | Zt.i <- kronecker(chol(re.i[[3]]), matrix(re.i[[1]], nrow = 1, ncol = nspp)) 245 | if (length(re.i[[1]]) > 1) { 246 | Zt.i <- Zt.i * kronecker(t(re.i[[1]]), matrix(1, nrow = nspp, ncol = 1)) 247 | } 248 | ii <- ii + 1 249 | Ztt[[ii]] <- Zt.i 250 | St.lengths[ii] <- nsite 251 | } 252 | } 253 | 254 | # nested terms 255 | if (length(re.i) == 4) { 256 | if (setequal(levels(re.i[[2]]), levels(sp)) && all(re.i[[2]] == sp)) { 257 | if (length(re.i[[1]]) > 1) 258 | stop("Nested terms can only be for intercepts") 259 | nestedsp.j <- re.i[[3]] 260 | nestedsite.j <- diag(nsite) 261 | } 262 | if (setequal(levels(re.i[[2]]), levels(site)) && all(re.i[[2]] == site)) { 263 | if (length(re.i[[1]]) > 1) 264 | stop("Nested terms can only be for intercepts") 265 | nestedsp.j <- diag(nspp) 266 | nestedsite.j <- re.i[[3]] 267 | } 268 | jj <- jj + 1 269 | nestedsp[[jj]] <- nestedsp.j 270 | nestedsite[[jj]] <- nestedsite.j 271 | } 272 | } 273 | q.nonNested <- ii 274 | q.Nested <- jj 275 | 276 | if (q.nonNested > 0) { 277 | St <- matrix(0, nrow = q.nonNested, ncol = sum(St.lengths)) 278 | Zt <- matrix(0, nrow = sum(St.lengths), ncol = nspp * nsite) 279 | count <- 1 280 | for (i in 1:q.nonNested) { 281 | St[i, count:(count + St.lengths[i] - 1)] <- matrix(1, nrow = 1, ncol = St.lengths[i]) 282 | Zt[count:(count + St.lengths[i] - 1), ] <- Ztt[[i]] 283 | count <- count + St.lengths[i] 284 | } 285 | Zt <- as(Zt, "dgTMatrix") 286 | St <- as(St, "dgTMatrix") 287 | } else { 288 | Zt <- NULL 289 | St <- NULL 290 | } 291 | 292 | p <- ncol(X) 293 | n <- nrow(X) 294 | 295 | # Compute initial estimates 296 | # assuming no phylogeny if not 297 | # provided 298 | if (!is.null(B.init) & length(B.init) != p) { 299 | warning("B.init not correct length, so computed B.init using glm()") 300 | } 301 | if ((is.null(B.init) | (!is.null(B.init) & length(B.init) != p)) & !is.null(s2.init)) { 302 | B.init <- t(matrix(lm(formula = formula, data = data)$coefficients, ncol = p)) 303 | } 304 | if (!is.null(B.init) & is.null(s2.init)) { 305 | s2.init <- var(lm(formula = formula, data = data)$residuals)/q 306 | } 307 | if ((is.null(B.init) | (!is.null(B.init) & length(B.init) != p)) & is.null(s2.init)) { 308 | B.init <- t(matrix(lm(formula = formula, data = data)$coefficients, ncol = p)) 309 | s2.init <- var(lm(formula = formula, data = data)$residuals)/q 310 | } 311 | B <- B.init 312 | s <- as.vector(array(s2.init^0.5, dim = c(1, q))) 313 | 314 | if (q > 1) { 315 | opt <- optim(fn = plmm.LL, par = s, X = X, Y = Y, Zt = Zt, St = St, 316 | nestedsp = nestedsp, nestedsite = nestedsite, 317 | REML = REML, verbose = verbose, method = "Nelder-Mead", 318 | control = list(maxit = maxit, reltol = reltol)) 319 | } else { 320 | opt <- optim(fn = plmm.LL, par = s, X = X, Y = Y, Zt = Zt, St = St, 321 | nestedsp = nestedsp, nestedsite = nestedsite, 322 | REML = REML, verbose = verbose, method = "L-BFGS-B", 323 | control = list(maxit = maxit)) 324 | 325 | } 326 | # Extract parameters 327 | par <- abs(Re(opt$par)) 328 | LL <- opt$value 329 | if (!is.null(St)) { 330 | q.nonNested <- dim(St)[1] 331 | sr <- Re(par[1:q.nonNested]) 332 | iC <- sr[1] * St[1, ] 333 | if (length(sr) > 1) 334 | for (i in 2:q.nonNested) { 335 | iC <- iC + sr[i] * St[i, ] 336 | } 337 | iC <- as(diag(iC), "dsCMatrix") 338 | Ut <- iC %*% Zt 339 | U <- t(Ut) 340 | } else { 341 | q.nonNested <- 0 342 | sr <- NULL 343 | } 344 | if (is.null(nestedsp[[1]])) { 345 | q.Nested <- 0 346 | } else { 347 | q.Nested <- length(nestedsp) 348 | } 349 | if (q.Nested == 0) { 350 | sn <- NULL 351 | } else { 352 | sn <- Re(par[(q.nonNested + 1):(q.nonNested + q.Nested)]) 353 | } 354 | if (q.Nested == 0) { 355 | iA <- as(diag(n), "dsCMatrix") 356 | Ishort <- as(diag(nrow(Ut)), "dsCMatrix") 357 | Ut.iA.U <- Ut %*% U 358 | # Woodbury identity 359 | iV <- iA - U %*% solve(Ishort + Ut.iA.U) %*% Ut 360 | } else { 361 | A <- as(diag(n), "dsCMatrix") 362 | for (j in 1:q.Nested) { 363 | A <- A + sn[j]^2 * kronecker(nestedsite[[j]], nestedsp[[j]]) 364 | } 365 | iA <- solve(A) 366 | if (q.nonNested > 0) { 367 | Ishort <- as(diag(nrow(Ut)), "dsCMatrix") 368 | Ut.iA.U <- Ut %*% iA %*% U 369 | iV <- iA - iA %*% U %*% solve(Ishort + Ut.iA.U) %*% Ut %*% iA 370 | } else { 371 | iV <- iA 372 | } 373 | } 374 | 375 | denom <- t(X) %*% iV %*% X 376 | num <- t(X) %*% iV %*% Y 377 | B <- solve(denom, num) 378 | B <- as.matrix(B) 379 | H <- Y - X %*% B 380 | 381 | if (q.Nested == 0) { 382 | # Sylvester identity 383 | logdetV <- determinant(Ishort + Ut.iA.U)$modulus[1] 384 | if (is.infinite(logdetV)) { 385 | logdetV <- 2 * sum(log(diag(chol(Ishort + Ut.iA.U)))) 386 | } 387 | } else { 388 | logdetV <- -determinant(iV)$modulus[1] 389 | if (is.infinite(logdetV)) { 390 | logdetV <- -2 * sum(log(diag(chol(iV, pivot = T)))) 391 | } 392 | if (is.infinite(logdetV)) { 393 | return(10^10) 394 | } 395 | } 396 | 397 | if (REML == TRUE) { 398 | s2resid <- as.numeric(t(H) %*% iV %*% H/(n - p)) 399 | } else { 400 | s2resid <- as.numeric(t(H) %*% iV %*% H/n) 401 | } 402 | 403 | s2r <- s2resid * sr^2 404 | s2n <- s2resid * sn^2 405 | ss <- c(sr, sn, s2resid^0.5) 406 | 407 | iV <- iV/s2resid 408 | 409 | B.cov <- solve(t(X) %*% iV %*% X) 410 | B.se <- as.matrix(diag(B.cov))^0.5 411 | B.zscore <- B/B.se 412 | B.pvalue <- 2 * pnorm(abs(B/B.se), lower.tail = FALSE) 413 | 414 | if (REML == TRUE) { 415 | logLik <- -0.5 * (n - p) * log(2 * pi) + 0.5 * log(det(t(X) %*% X)) - LL 416 | } else { 417 | logLik <- -0.5 * n * log(2 * pi) - LL 418 | } 419 | k <- p + q + 1 420 | AIC <- -2 * logLik + 2 * k 421 | BIC <- -2 * logLik + k * (log(n) - log(pi)) 422 | 423 | results <- list(formula = formula, data = data, family = family, 424 | random.effects = random.effects, B = B, 425 | B.se = B.se, B.cov = B.cov, B.zscore = B.zscore, 426 | B.pvalue = B.pvalue, ss = ss, s2r = s2r, s2n = s2n, 427 | s2resid = s2resid, logLik = logLik, AIC = AIC, BIC = BIC, 428 | REML = REML, s2.init = s2.init, B.init = B.init, 429 | Y = Y, X = X, H = H, iV = iV, mu = NULL, nestedsp = nestedsp, 430 | nestedsite = nestedsite, sp = sp, site = site, 431 | Zt = Zt, St = St, convcode = opt$convergence, 432 | niter = opt$counts) 433 | 434 | class(results) <- "communityPGLMM" 435 | results 436 | } 437 | 438 | ###################################################### 439 | ###################################################### 440 | # communityPGLMM.binary 441 | ###################################################### 442 | ###################################################### 443 | communityPGLMM.binary <- function(formula, data = list(), family = "binomial", 444 | sp = NULL, site = NULL, random.effects = list(), 445 | REML = TRUE, s2.init = 0.25, B.init = NULL, 446 | reltol = 10^-5, maxit = 40, tol.pql = 10^-6, 447 | maxit.pql = 200, verbose = FALSE) { 448 | 449 | plmm.binary.V <- function(par, Zt, St, mu, nestedsp = NULL, nestedsite = NULL) { 450 | 451 | if (!is.null(St)) { 452 | q.nonNested <- dim(St)[1] 453 | sr <- Re(par[1:q.nonNested]) 454 | iC <- sr[1] * St[1, ] 455 | if (length(sr) > 1) 456 | for (i in 2:q.nonNested) { 457 | iC <- iC + sr[i] * St[i, ] 458 | } 459 | iC <- as(diag(iC), "dsCMatrix") 460 | Ut <- iC %*% Zt 461 | U <- t(Ut) 462 | } else { 463 | q.nonNested <- 0 464 | sr <- NULL 465 | } 466 | if (is.null(nestedsp[[1]])) { 467 | q.Nested <- 0 468 | } else { 469 | q.Nested <- length(nestedsp) 470 | } 471 | 472 | if (q.Nested == 0) { 473 | sn <- NULL 474 | } else { 475 | sn <- Re(par[(q.nonNested + 1):(q.nonNested + q.Nested)]) 476 | } 477 | 478 | iW <- diag(as.vector((mu * (1 - mu))^-1)) 479 | if (q.Nested == 0) { 480 | A <- iW 481 | } else { 482 | A <- iW 483 | for (j in 1:q.Nested) { 484 | A <- A + sn[j]^2 * kronecker(nestedsite[[j]], nestedsp[[j]]) 485 | } 486 | } 487 | if (q.nonNested > 0) { 488 | V <- A + U %*% Ut 489 | } else { 490 | V <- A 491 | } 492 | return(V) 493 | } 494 | # End plmm.binary.V 495 | 496 | plmm.binary.iV <- function(par, Zt, St, mu, nestedsp = NULL, nestedsite = NULL) { 497 | 498 | if (!is.null(St)) { 499 | q.nonNested <- dim(St)[1] 500 | sr <- Re(par[1:q.nonNested]) 501 | iC <- sr[1] * St[1, ] 502 | if (length(sr) > 1) { 503 | for (i in 2:q.nonNested) { 504 | iC <- iC + sr[i] * St[i, ] 505 | } 506 | } 507 | iC <- as(diag(iC), "dsCMatrix") 508 | Ut <- iC %*% Zt 509 | U <- t(Ut) 510 | } else { 511 | q.nonNested <- 0 512 | sr <- NULL 513 | } 514 | if (is.null(nestedsp[[1]])) { 515 | q.Nested <- 0 516 | } else { 517 | q.Nested <- length(nestedsp) 518 | } 519 | 520 | if (q.Nested == 0) { 521 | sn <- NULL 522 | } else { 523 | sn <- Re(par[(q.nonNested + 1):(q.nonNested + q.Nested)]) 524 | } 525 | 526 | if (q.Nested == 0) { 527 | iA <- diag(as.vector((mu * (1 - mu)))) 528 | Ishort <- as(diag(nrow(Ut)), "dsCMatrix") 529 | Ut.iA.U <- Ut %*% iA %*% U 530 | # Woodbury identity 531 | iV <- iA - iA %*% U %*% solve(Ishort + Ut.iA.U) %*% Ut %*% iA 532 | } else { 533 | A <- diag(as.vector((mu * (1 - mu))^-1)) 534 | for (j in 1:q.Nested) { 535 | A <- A + sn[j]^2 * kronecker(nestedsite[[j]], nestedsp[[j]]) 536 | } 537 | iA <- solve(A) 538 | if (q.nonNested > 0) { 539 | Ishort <- as(diag(nrow(Ut)), "dsCMatrix") 540 | Ut.iA.U <- Ut %*% iA %*% U 541 | iV <- iA - iA %*% U %*% solve(Ishort + Ut.iA.U) %*% Ut %*% iA 542 | } else { 543 | iV <- iA 544 | } 545 | } 546 | return(iV) 547 | } 548 | # End plmm.binary.iV 549 | 550 | plmm.binary.logdetV <- function(par, Zt, St, mu, nestedsp = NULL, nestedsite = NULL) { 551 | n <- dim(X)[1] 552 | p <- dim(X)[2] 553 | 554 | if (!is.null(St)) { 555 | q.nonNested <- dim(St)[1] 556 | sr <- Re(par[1:q.nonNested]) 557 | iC <- sr[1] * St[1, ] 558 | if (length(sr) > 1) 559 | for (i in 2:q.nonNested) { 560 | iC <- iC + sr[i] * St[i, ] 561 | } 562 | iC <- as(diag(iC), "dsCMatrix") 563 | Ut <- iC %*% Zt 564 | U <- t(Ut) 565 | } else { 566 | q.nonNested <- 0 567 | sr <- NULL 568 | } 569 | if (is.null(nestedsp[[1]])) { 570 | q.Nested <- 0 571 | } else { 572 | q.Nested <- length(nestedsp) 573 | } 574 | 575 | if (q.Nested == 0) { 576 | sn <- NULL 577 | } else { 578 | sn <- Re(par[(q.nonNested + 1):(q.nonNested + q.Nested)]) 579 | } 580 | 581 | if (q.Nested == 0) { 582 | iA <- diag(as.vector((mu * (1 - mu)))) 583 | Ishort <- as(diag(nrow(Ut)), "dsCMatrix") 584 | Ut.iA.U <- Ut %*% iA %*% U 585 | logdetV <- determinant(Ishort + Ut.iA.U)$modulus[1] - determinant(iA)$modulus[1] 586 | if (is.infinite(logdetV)) 587 | logdetV <- 2 * sum(log(diag(chol(Ishort + Ut.iA.U)))) - determinant(iA)$modulus[1] 588 | } else { 589 | A <- diag(as.vector((mu * (1 - mu))^-1)) 590 | for (j in 1:q.Nested) { 591 | A <- A + sn[j]^2 * kronecker(nestedsite[[j]], nestedsp[[j]]) 592 | } 593 | iA <- solve(A) 594 | if (q.nonNested > 0) { 595 | Ishort <- as(diag(nrow(Ut)), "dsCMatrix") 596 | Ut.iA.U <- Ut %*% iA %*% U 597 | iV <- iA - iA %*% U %*% solve(Ishort + Ut.iA.U) %*% Ut %*% iA 598 | } else { 599 | iV <- iA 600 | } 601 | logdetV <- -determinant(iV)$modulus[1] 602 | if (is.infinite(logdetV)) 603 | logdetV <- -2 * sum(log(diag(chol(iV, pivot = T)))) 604 | if (is.infinite(logdetV)) 605 | return(list(iV = NULL, logdetV = NULL)) 606 | } 607 | 608 | return(logdetV) 609 | } 610 | # End plmm.binary.logdetV 611 | 612 | # Begin pglmm.binary.LL 613 | plmm.binary.LL <- function(par, H, X, Zt, St, mu, nestedsp = NULL, nestedsite = NULL, 614 | REML = TRUE, verbose = FALSE) { 615 | par <- abs(par) 616 | n <- dim(H)[1] 617 | p <- dim(H)[2] 618 | 619 | iV <- plmm.binary.iV(par = par, Zt = Zt, St = St, mu = mu, 620 | nestedsp = nestedsp, nestedsite = nestedsite) 621 | logdetV <- plmm.binary.logdetV(par = par, Zt = Zt, St = St, mu = mu, 622 | nestedsp = nestedsp, nestedsite = nestedsite) 623 | if (REML == TRUE) { 624 | # REML likelihood function 625 | LL <- 0.5 * (logdetV + t(H) %*% iV %*% H + log(det(t(X) %*% iV %*% X))) 626 | } else { 627 | # ML likelihood function 628 | LL <- 0.5 * (logdetV + t(H) %*% iV %*% H) 629 | } 630 | if (verbose == T) 631 | show(c(as.numeric(LL), par)) 632 | 633 | return(as.numeric(LL)) 634 | } 635 | # End plmm.binary.LL 636 | 637 | 638 | # Begin main program 639 | if (is.null(sp) | is.null(site)) 640 | stop("Categorical variables for 'sp' and 'site' must be specified") 641 | nspp <- nlevels(sp) 642 | nsite <- nlevels(site) 643 | 644 | # order data first by site, second by species 645 | sp.order <- order(sp) 646 | data <- data[sp.order, ] 647 | sp <- sp[sp.order] 648 | site <- site[sp.order] 649 | 650 | site.order <- order(site) 651 | data <- data[site.order, ] 652 | sp <- sp[site.order] 653 | site <- site[site.order] 654 | 655 | mf <- model.frame(formula = formula, data = data) 656 | X <- model.matrix(attr(mf, "terms"), data = mf) 657 | Y <- model.response(mf) 658 | 659 | re <- random.effects 660 | q <- length(re) 661 | 662 | Ztt <- list(NULL) 663 | St.lengths <- array(0, q) 664 | nestedsp <- list(NULL) 665 | nestedsite <- list(NULL) 666 | ii <- 0 667 | jj <- 0 668 | 669 | for (i in 1:q) { 670 | re.i <- re[[i]] 671 | # non-nested terms 672 | if (length(re.i) == 3) { 673 | if (setequal(levels(re.i[[2]]), levels(sp)) && all(re.i[[2]] == sp)) { 674 | Zt.i <- kronecker(matrix(1, nrow = 1, ncol = nsite), chol(re.i[[3]])) 675 | if (length(re.i[[1]]) > 1) { 676 | Zt.i <- Zt.i * kronecker(t(re.i[[1]]), matrix(1, nrow = nspp, ncol = 1)) 677 | } 678 | ii <- ii + 1 679 | Ztt[[ii]] <- Zt.i 680 | St.lengths[ii] <- nspp 681 | } 682 | if (setequal(levels(re.i[[2]]), levels(site)) && all(re.i[[2]] == site)) { 683 | Zt.i <- kronecker(chol(re.i[[3]]), matrix(re.i[[1]], nrow = 1, ncol = nspp)) 684 | if (length(re.i[[1]]) > 1) { 685 | Zt.i <- Zt.i * kronecker(t(re.i[[1]]), matrix(1, nrow = nspp, ncol = 1)) 686 | } 687 | ii <- ii + 1 688 | Ztt[[ii]] <- Zt.i 689 | St.lengths[ii] <- nsite 690 | } 691 | } 692 | 693 | # nested terms 694 | if (length(re.i) == 4) { 695 | if (setequal(levels(re.i[[2]]), levels(sp)) && all(re.i[[2]] == sp)) { 696 | if (length(re.i[[1]]) > 1) 697 | stop("Nested terms can only be for intercepts") 698 | nestedsp.j <- re.i[[3]] 699 | nestedsite.j <- diag(nsite) 700 | } 701 | if (setequal(levels(re.i[[2]]), levels(site)) && all(re.i[[2]] == site)) { 702 | if (length(re.i[[1]]) > 1) 703 | stop("Nested terms can only be for intercepts") 704 | nestedsp.j <- diag(nspp) 705 | nestedsite.j <- re.i[[3]] 706 | } 707 | jj <- jj + 1 708 | nestedsp[[jj]] <- nestedsp.j 709 | nestedsite[[jj]] <- nestedsite.j 710 | } 711 | } 712 | q.nonNested <- ii 713 | q.Nested <- jj 714 | 715 | if (q.nonNested > 0) { 716 | St <- matrix(0, nrow = q.nonNested, ncol = sum(St.lengths)) 717 | Zt <- matrix(0, nrow = sum(St.lengths), ncol = nspp * nsite) 718 | count <- 1 719 | for (i in 1:q.nonNested) { 720 | St[i, count:(count + St.lengths[i] - 1)] <- matrix(1, nrow = 1, ncol = St.lengths[i]) 721 | Zt[count:(count + St.lengths[i] - 1), ] <- Ztt[[i]] 722 | count <- count + St.lengths[i] 723 | } 724 | Zt <- as(Zt, "dgTMatrix") 725 | St <- as(St, "dgTMatrix") 726 | } else { 727 | Zt <- NULL 728 | St <- NULL 729 | } 730 | 731 | p <- ncol(X) 732 | n <- nrow(X) 733 | 734 | # Compute initial estimates 735 | # assuming no phylogeny if not 736 | # provided 737 | if (!is.null(B.init) & length(B.init) != p) { 738 | warning("B.init not correct length, so computed B.init using glm()") 739 | } 740 | if ((is.null(B.init) | (!is.null(B.init) & length(B.init) != p))) { 741 | B.init <- t(matrix(glm(formula = formula, data = data, 742 | family = binomial)$coefficients, ncol = p)) 743 | } else { 744 | B.init <- matrix(B.init, ncol = 1) 745 | } 746 | B <- B.init 747 | ss <- as.vector(array(s2.init^0.5, dim = c(1, q))) 748 | 749 | b <- matrix(0, nrow = n) 750 | beta <- rbind(B, b) 751 | mu <- exp(X %*% B)/(1 + exp(X %*% B)) 752 | XX <- cbind(X, diag(1, nrow = n, ncol = n)) 753 | 754 | est.ss <- ss 755 | est.B <- B 756 | oldest.ss <- 10^6 757 | oldest.B <- matrix(10^6, nrow = length(est.B)) 758 | 759 | iteration <- 0 760 | exitflag <- 0 761 | rcondflag <- 0 762 | while (((t(est.ss - oldest.ss) %*% (est.ss - oldest.ss) > tol.pql^2) | 763 | (t(est.B - oldest.B) %*% (est.B - oldest.B) > tol.pql^2)) & 764 | (iteration <= maxit.pql)) { 765 | 766 | iteration <- iteration + 1 767 | oldest.ss <- est.ss 768 | oldest.B <- est.B 769 | 770 | est.B.m <- B 771 | oldest.B.m <- matrix(10^6, nrow = length(est.B)) 772 | 773 | # mean component 774 | while ((t(est.B.m - oldest.B.m) %*% (est.B.m - oldest.B.m) > tol.pql^2) & 775 | (iteration <= maxit.pql)) { 776 | 777 | oldest.B.m <- est.B.m 778 | 779 | iV <- plmm.binary.iV(par = ss, Zt = Zt, St = St, mu = mu, 780 | nestedsp = nestedsp, nestedsite = nestedsite) 781 | 782 | Z <- X %*% B + b + (Y - mu)/(mu * (1 - mu)) 783 | denom <- t(X) %*% iV %*% X 784 | num <- t(X) %*% iV %*% Z 785 | B <- solve(denom, num) 786 | B <- as.matrix(B) 787 | 788 | V <- plmm.binary.V(par = ss, Zt = Zt, St = St, mu = mu, 789 | nestedsp = nestedsp, nestedsite = nestedsite) 790 | iW <- diag(as.vector((mu * (1 - mu))^-1)) 791 | C <- V - iW 792 | b <- C %*% iV %*% (Z - X %*% B) 793 | beta <- rbind(B, matrix(b)) 794 | mu <- exp(XX %*% beta)/(1 + exp(XX %*% beta)) 795 | 796 | est.B.m <- B 797 | if (verbose == TRUE) 798 | show(c(iteration, B)) 799 | } 800 | 801 | # variance component 802 | Z <- X %*% B + b + (Y - mu)/(mu * (1 - mu)) 803 | H <- Z - X %*% B 804 | if (q > 1) { 805 | opt <- optim(fn = plmm.binary.LL, par = ss, H = H, X = X, Zt = Zt, 806 | St = St, mu = mu, nestedsp = nestedsp, 807 | nestedsite = nestedsite, REML = REML, verbose = verbose, 808 | method = "Nelder-Mead", 809 | control = list(maxit = maxit, reltol = reltol)) 810 | } else { 811 | opt <- optim(fn = plmm.binary.LL, par = ss, H = H, X = X, Zt = Zt, 812 | St = St, mu = mu, nestedsp = nestedsp, nestedsite = nestedsite, 813 | REML = REML, verbose = verbose, method = "L-BFGS-B", 814 | control = list(maxit = maxit)) 815 | } 816 | ss <- abs(opt$par) 817 | LL <- opt$value 818 | 819 | est.ss <- ss 820 | est.B <- B 821 | } 822 | 823 | # Extract parameters 824 | if (q.nonNested > 0) { 825 | sr <- ss[1:q.nonNested] 826 | } else { 827 | sr <- NULL 828 | } 829 | if (q.Nested > 0) { 830 | sn <- ss[(q.nonNested + 1):(q.nonNested + q.Nested)] 831 | } else { 832 | sn <- NULL 833 | } 834 | 835 | s2r <- sr^2 836 | s2n <- sn^2 837 | 838 | B.cov <- solve(t(X) %*% iV %*% X) 839 | B.se <- as.matrix(diag(B.cov))^0.5 840 | B.zscore <- B/B.se 841 | B.pvalue <- 2 * pnorm(abs(B/B.se), lower.tail = FALSE) 842 | 843 | results <- list(formula = formula, data = data, family = family, 844 | random.effects = random.effects, B = B, 845 | B.se = B.se, B.cov = B.cov, B.zscore = B.zscore, 846 | B.pvalue = B.pvalue, ss = ss, s2r = s2r, s2n = s2n, 847 | s2resid = NULL, logLik = NULL, AIC = NULL, BIC = NULL, 848 | REML = REML, s2.init = s2.init, B.init = B.init, 849 | Y = Y, X = X, H = H, iV = iV, mu = mu, nestedsp = nestedsp, 850 | nestedsite = nestedsite, sp = sp, site = site, 851 | Zt = Zt, St = St, convcode = opt$convergence, niter = opt$counts) 852 | class(results) <- "communityPGLMM" 853 | results 854 | return(results) 855 | } 856 | 857 | ###################################################### 858 | ###################################################### 859 | # communityPGLMM.binary.LRT 860 | ###################################################### 861 | ###################################################### 862 | communityPGLMM.binary.LRT <- function(x, re.number = 0, ...) { 863 | 864 | plmm.binary.iV <- function(par, Zt, St, mu, nestedsp = NULL, nestedsite = NULL) { 865 | 866 | if (!is.null(St)) { 867 | q.nonNested <- dim(St)[1] 868 | sr <- Re(par[1:q.nonNested]) 869 | iC <- sr[1] * St[1, ] 870 | if (length(sr) > 1) 871 | for (i in 2:q.nonNested) { 872 | iC <- iC + sr[i] * St[i, ] 873 | } 874 | iC <- as(diag(iC), "dsCMatrix") 875 | Ut <- iC %*% Zt 876 | U <- t(Ut) 877 | } else { 878 | q.nonNested <- 0 879 | sr <- NULL 880 | } 881 | if (is.null(nestedsp[[1]])) { 882 | q.Nested <- 0 883 | } else { 884 | q.Nested <- length(nestedsp) 885 | } 886 | 887 | if (q.Nested == 0) { 888 | sn <- NULL 889 | } else { 890 | sn <- Re(par[(q.nonNested + 1):(q.nonNested + q.Nested)]) 891 | } 892 | 893 | if (q.Nested == 0) { 894 | iA <- diag(as.vector((mu * (1 - mu)))) 895 | Ishort <- as(diag(nrow(Ut)), "dsCMatrix") 896 | Ut.iA.U <- Ut %*% iA %*% U 897 | # Woodbury identity 898 | iV <- iA - iA %*% U %*% solve(Ishort + Ut.iA.U) %*% Ut %*% iA 899 | } else { 900 | A <- diag(as.vector((mu * (1 - mu))^-1)) 901 | for (j in 1:q.Nested) { 902 | A <- A + sn[j]^2 * kronecker(nestedsite[[j]], nestedsp[[j]]) 903 | } 904 | iA <- solve(A) 905 | if (q.nonNested > 0) { 906 | Ishort <- as(diag(nrow(Ut)), "dsCMatrix") 907 | Ut.iA.U <- Ut %*% iA %*% U 908 | iV <- iA - iA %*% U %*% solve(Ishort + Ut.iA.U) %*% Ut %*% iA 909 | } else { 910 | iV <- iA 911 | } 912 | } 913 | return(iV) 914 | } 915 | # End plmm.binary.iV 916 | 917 | plmm.binary.logdetV <- function(par, Zt, St, mu, nestedsp = NULL, nestedsite = NULL) { 918 | n <- dim(X)[1] 919 | p <- dim(X)[2] 920 | 921 | if (!is.null(St)) { 922 | q.nonNested <- dim(St)[1] 923 | sr <- Re(par[1:q.nonNested]) 924 | iC <- sr[1] * St[1, ] 925 | if (length(sr) > 1) 926 | for (i in 2:q.nonNested) { 927 | iC <- iC + sr[i] * St[i, ] 928 | } 929 | iC <- as(diag(iC), "dsCMatrix") 930 | Ut <- iC %*% Zt 931 | U <- t(Ut) 932 | } else { 933 | q.nonNested <- 0 934 | sr <- NULL 935 | } 936 | if (is.null(nestedsp[[1]])) { 937 | q.Nested <- 0 938 | } else { 939 | q.Nested <- length(nestedsp) 940 | } 941 | 942 | if (q.Nested == 0) { 943 | sn <- NULL 944 | } else { 945 | sn <- Re(par[(q.nonNested + 1):(q.nonNested + q.Nested)]) 946 | } 947 | 948 | if (q.Nested == 0) { 949 | iA <- diag(as.vector((mu * (1 - mu)))) 950 | Ishort <- as(diag(nrow(Ut)), "dsCMatrix") 951 | Ut.iA.U <- Ut %*% iA %*% U 952 | logdetV <- determinant(Ishort + Ut.iA.U)$modulus[1] - determinant(iA)$modulus[1] 953 | if (is.infinite(logdetV)) 954 | logdetV <- 2 * sum(log(diag(chol(Ishort + Ut.iA.U)))) - determinant(iA)$modulus[1] 955 | } else { 956 | A <- diag(as.vector((mu * (1 - mu))^-1)) 957 | for (j in 1:q.Nested) { 958 | A <- A + sn[j]^2 * kronecker(nestedsite[[j]], nestedsp[[j]]) 959 | } 960 | iA <- solve(A) 961 | if (q.nonNested > 0) { 962 | Ishort <- as(diag(nrow(Ut)), "dsCMatrix") 963 | Ut.iA.U <- Ut %*% iA %*% U 964 | iV <- iA - iA %*% U %*% solve(Ishort + Ut.iA.U) %*% Ut %*% iA 965 | } else { 966 | iV <- iA 967 | } 968 | logdetV <- -determinant(iV)$modulus[1] 969 | if (is.infinite(logdetV)) 970 | logdetV <- -2 * sum(log(diag(chol(iV, pivot = T)))) 971 | if (is.infinite(logdetV)) 972 | return(list(iV = NULL, logdetV = NULL)) 973 | } 974 | 975 | return(logdetV) 976 | } 977 | # End plmm.binary.logdetV 978 | 979 | # Begin pglmm.binary.LL 980 | plmm.binary.LL <- function(par, H, X, Zt, St, mu, nestedsp = NULL, 981 | nestedsite = NULL, REML = TRUE, verbose = FALSE) { 982 | par <- abs(par) 983 | n <- dim(H)[1] 984 | p <- dim(H)[2] 985 | 986 | iV <- plmm.binary.iV(par = par, Zt = Zt, St = St, mu = mu, 987 | nestedsp = nestedsp, nestedsite = nestedsite) 988 | logdetV <- plmm.binary.logdetV(par = par, Zt = Zt, St = St, mu = mu, 989 | nestedsp = nestedsp, nestedsite = nestedsite) 990 | if (REML == TRUE) { 991 | # REML likelihood function 992 | LL <- 0.5 * (logdetV + t(H) %*% iV %*% H + log(det(t(X) %*% iV %*% X))) 993 | } else { 994 | # ML likelihood function 995 | s2.conc <- t(H) %*% iV %*% H/(n - p) 996 | LL <- 0.5 * (logdetV + t(H) %*% iV %*% H) 997 | } 998 | if (verbose == T) 999 | show(c(as.numeric(LL), par)) 1000 | 1001 | return(as.numeric(LL)) 1002 | } 1003 | # End plmm.binary.LL 1004 | 1005 | 1006 | # Begin main program 1007 | 1008 | n <- dim(x$X)[1] 1009 | p <- dim(x$X)[2] 1010 | par <- x$ss 1011 | par[re.number] <- 0 1012 | df <- length(re.number) 1013 | 1014 | LL <- plmm.binary.LL(par = x$ss, H = x$H, X = x$X, Zt = x$Zt, St = x$St, 1015 | mu = x$mu, nestedsp = x$nestedsp, 1016 | nestedsite = x$nestedsite, REML = x$REML) 1017 | if (x$REML == TRUE) { 1018 | logLik <- -0.5 * (n - p - 1) * log(2 * pi) + 0.5 * log(det(t(x$X) %*% x$X)) - LL 1019 | } else { 1020 | logLik <- -0.5 * n * log(2 * pi) - LL 1021 | } 1022 | 1023 | LL0 <- plmm.binary.LL(par = par, H = x$H, X = x$X, Zt = x$Zt, St = x$St, 1024 | mu = x$mu, nestedsp = x$nestedsp, 1025 | nestedsite = x$nestedsite, REML = x$REML) 1026 | if (x$REML == TRUE) { 1027 | logLik0 <- -0.5 * (n - p - 1) * log(2 * pi) + 0.5 * log(det(t(x$X) %*% x$X)) - LL0 1028 | } else { 1029 | logLik0 <- -0.5 * n * log(2 * pi) - LL0 1030 | } 1031 | 1032 | P.H0.s2 <- pchisq(2 * (logLik - logLik0), df = df, lower.tail = F)/2 1033 | return(list(LR = logLik - logLik0, df = df, Pr = P.H0.s2)) 1034 | } 1035 | 1036 | ###################################################### 1037 | ###################################################### 1038 | # communityPGLMM.matrix.structure 1039 | ###################################################### 1040 | ###################################################### 1041 | communityPGLMM.matrix.structure <- function(formula, data = list(), family = "binomial", 1042 | sp = NULL, site = NULL, random.effects = list(), 1043 | ss = 1) { 1044 | 1045 | plmm.binary.V.test <- function(par, Zt, St, X, nestedsp = NULL, nestedsite = NULL) { 1046 | n <- nrow(X) 1047 | 1048 | if (!is.null(St)) { 1049 | q.nonNested <- dim(St)[1] 1050 | sr <- Re(par[1:q.nonNested]) 1051 | iC <- sr[1] * St[1, ] 1052 | if (length(sr) > 1) 1053 | for (i in 2:q.nonNested) { 1054 | iC <- iC + sr[i] * St[i, ] 1055 | } 1056 | iC <- as(diag(iC), "dsCMatrix") 1057 | Ut <- iC %*% Zt 1058 | U <- t(Ut) 1059 | } else { 1060 | q.nonNested <- 0 1061 | sr <- NULL 1062 | } 1063 | if (is.null(nestedsp[[1]])) { 1064 | q.Nested <- 0 1065 | } else { 1066 | q.Nested <- length(nestedsp) 1067 | } 1068 | 1069 | if (q.Nested == 0) { 1070 | sn <- NULL 1071 | } else { 1072 | sn <- Re(par[(q.nonNested + 1):(q.nonNested + q.Nested)]) 1073 | } 1074 | 1075 | iW <- 0 * diag(n) 1076 | if (q.Nested == 0) { 1077 | A <- iW 1078 | } else { 1079 | A <- iW 1080 | for (j in 1:q.Nested) { 1081 | A <- A + sn[j]^2 * kronecker(nestedsite[[j]], nestedsp[[j]]) 1082 | } 1083 | } 1084 | if (q.nonNested > 0) { 1085 | V <- A + U %*% Ut 1086 | } else { 1087 | V <- A 1088 | } 1089 | return(V) 1090 | } 1091 | # End plmm.binary.V 1092 | 1093 | 1094 | # Begin main program 1095 | if (is.null(sp) | is.null(site)) 1096 | stop("Categorical variables for 'sp' and 'site' must be specified") 1097 | nspp <- nlevels(sp) 1098 | nsite <- nlevels(site) 1099 | 1100 | # order data first by site, 1101 | # second by species 1102 | sp.order <- order(sp) 1103 | data <- data[sp.order, ] 1104 | sp <- sp[sp.order] 1105 | site <- site[sp.order] 1106 | 1107 | site.order <- order(site) 1108 | data <- data[site.order, ] 1109 | sp <- sp[site.order] 1110 | site <- site[site.order] 1111 | 1112 | mf <- model.frame(formula = formula, data = data) 1113 | X <- model.matrix(attr(mf, "terms"), data = mf) 1114 | Y <- model.response(mf) 1115 | 1116 | re <- random.effects 1117 | q <- length(re) 1118 | 1119 | Ztt <- list(NULL) 1120 | St.lengths <- array(0, q) 1121 | nestedsp <- list(NULL) 1122 | nestedsite <- list(NULL) 1123 | ii <- 0 1124 | jj <- 0 1125 | 1126 | for (i in 1:q) { 1127 | re.i <- re[[i]] 1128 | # non-nested terms 1129 | if (length(re.i) == 3) { 1130 | if (setequal(levels(re.i[[2]]), levels(sp)) && all(re.i[[2]] == sp)) { 1131 | Zt.i <- kronecker(matrix(1, nrow = 1, ncol = nsite), chol(re.i[[3]])) 1132 | if (length(re.i[[1]]) > 1) { 1133 | Zt.i <- Zt.i * kronecker(t(re.i[[1]]), matrix(1, nrow = nspp, ncol = 1)) 1134 | } 1135 | ii <- ii + 1 1136 | Ztt[[ii]] <- Zt.i 1137 | St.lengths[ii] <- nspp 1138 | } 1139 | if (setequal(levels(re.i[[2]]), levels(site)) && all(re.i[[2]] == site)) { 1140 | Zt.i <- kronecker(chol(re.i[[3]]), matrix(re.i[[1]], nrow = 1, ncol = nspp)) 1141 | if (length(re.i[[1]]) > 1) { 1142 | Zt.i <- Zt.i * kronecker(t(re.i[[1]]), matrix(1, nrow = nspp, ncol = 1)) 1143 | } 1144 | ii <- ii + 1 1145 | Ztt[[ii]] <- Zt.i 1146 | St.lengths[ii] <- nsite 1147 | } 1148 | } 1149 | 1150 | # nested terms 1151 | if (length(re.i) == 4) { 1152 | if (setequal(levels(re.i[[2]]), levels(sp)) && all(re.i[[2]] == sp)) { 1153 | if (length(re.i[[1]]) > 1) 1154 | stop("Nested terms can only be for intercepts") 1155 | nestedsp.j <- re.i[[3]] 1156 | nestedsite.j <- diag(nsite) 1157 | } 1158 | if (setequal(levels(re.i[[2]]), levels(site)) && all(re.i[[2]] == site)) { 1159 | if (length(re.i[[1]]) > 1) 1160 | stop("Nested terms can only be for intercepts") 1161 | nestedsp.j <- diag(nspp) 1162 | nestedsite.j <- re.i[[3]] 1163 | } 1164 | jj <- jj + 1 1165 | nestedsp[[jj]] <- nestedsp.j 1166 | nestedsite[[jj]] <- nestedsite.j 1167 | } 1168 | } 1169 | q.nonNested <- ii 1170 | q.Nested <- jj 1171 | 1172 | if (q.nonNested > 0) { 1173 | St <- matrix(0, nrow = q.nonNested, ncol = sum(St.lengths)) 1174 | Zt <- matrix(0, nrow = sum(St.lengths), ncol = nspp * nsite) 1175 | count <- 1 1176 | for (i in 1:q.nonNested) { 1177 | St[i, count:(count + St.lengths[i] - 1)] <- matrix(1, nrow = 1, ncol = St.lengths[i]) 1178 | Zt[count:(count + St.lengths[i] - 1), ] <- Ztt[[i]] 1179 | count <- count + St.lengths[i] 1180 | } 1181 | Zt <- as(Zt, "dgTMatrix") 1182 | St <- as(St, "dgTMatrix") 1183 | } else { 1184 | Zt <- NULL 1185 | St <- NULL 1186 | } 1187 | 1188 | V <- plmm.binary.V.test(par = array(ss, c(1, q)), Zt = Zt, St = St, X = X, 1189 | nestedsp = nestedsp, nestedsite = nestedsite) 1190 | return(V) 1191 | } 1192 | 1193 | 1194 | ###################################################### 1195 | ###################################################### 1196 | # summary.communityPGLMM 1197 | ###################################################### 1198 | ###################################################### 1199 | summary.communityPGLMM <- function(x, digits = max(3, getOption("digits") - 3), ...) { 1200 | if (x$family == "gaussian") { 1201 | if (x$REML == TRUE) 1202 | cat("Linear mixed model fit by restricted maximum likelihood") 1203 | else cat("Linear mixed model fit by maximum likelihood") 1204 | } 1205 | if (x$family == "binomial") { 1206 | if (x$REML == TRUE) 1207 | cat("Generalized linear mixed model for binary data fit by restricted maximum likelihood") 1208 | else cat("Generalized linear mixed model for binary data fit by maximum likelihood") 1209 | } 1210 | 1211 | cat("\n\nCall:") 1212 | print(x$formula) 1213 | cat("\n") 1214 | 1215 | if (x$family == "gaussian") { 1216 | 1217 | logLik = x$logLik 1218 | AIC = x$AIC 1219 | BIC = x$BIC 1220 | 1221 | names(logLik) = "logLik" 1222 | names(AIC) = "AIC" 1223 | names(BIC) = "BIC" 1224 | print(c(logLik, AIC, BIC), digits = digits) 1225 | } 1226 | cat("\nRandom effects:\n") 1227 | w <- data.frame(Variance = matrix(c(x$s2r, x$s2n, x$s2resid), ncol = 1), 1228 | Std.Dev = matrix(c(x$s2r^0.5, x$s2n^0.5, x$s2resid^0.5), ncol = 1)) 1229 | 1230 | re.names <- NULL 1231 | if (length(x$s2r) > 0) 1232 | for (i in 1:length(x$s2r)) re.names <- c(re.names, paste("non-nested ", i, sep = "")) 1233 | 1234 | if (length(x$s2n) > 0) 1235 | for (i in 1:length(x$s2n)) re.names <- c(re.names, paste("nested ", i, sep = "")) 1236 | 1237 | if (x$family == "gaussian") 1238 | re.names <- c(re.names, "residual") 1239 | 1240 | row.names(w) <- re.names 1241 | print(w, digits = digits) 1242 | 1243 | cat("\nFixed effects:\n") 1244 | coef <- data.frame(Value = x$B, Std.Error = x$B.se, Zscore = x$B.zscore, Pvalue = x$B.pvalue) 1245 | printCoefmat(coef, P.values = TRUE, has.Pvalue = TRUE) 1246 | cat("\n") 1247 | } 1248 | 1249 | print.communityPGLMM <- function(x, digits = max(3, getOption("digits") - 3), ...) { 1250 | summary.communityPGLMM(x, digits = digits) 1251 | } 1252 | 1253 | ###################################################### 1254 | ###################################################### 1255 | # plot.communityPGLMM 1256 | ###################################################### 1257 | ###################################################### 1258 | plot.communityPGLMM <- function(x, digits = max(3, getOption("digits") - 3), ...) { 1259 | if (!require(plotrix)) { 1260 | stop("The 'plotrix' package is required to plot images from this function") 1261 | } 1262 | 1263 | W <- data.frame(Y = x$Y, sp = x$sp, site = x$site) 1264 | Y <- reshape(W, v.names = "Y", idvar = "sp", timevar = "site", direction = "wide") 1265 | Y <- Y[, 2:dim(Y)[2]] 1266 | 1267 | par(mfrow = c(1, 1), las = 1, mar = c(4, 4, 2, 2) - 0.1) 1268 | 1269 | color2D.matplot(Y, ylab = "species", xlab = "sites", main = "Observed values") 1270 | } 1271 | 1272 | 1273 | ###################################################### 1274 | ###################################################### 1275 | # communityPGLMM.predicted.values 1276 | ###################################################### 1277 | ###################################################### 1278 | communityPGLMM.predicted.values <- function(x, show.plot = TRUE, ...) { 1279 | 1280 | if (x$family == "gaussian") { 1281 | V <- solve(x$iV) 1282 | h <- matrix(0, nrow = length(x$Y), ncol = 1) 1283 | for (i in 1:length(x$Y)) { 1284 | h[i] <- as.numeric(V[i, -i] %*% solve(V[-i, -i]) %*% matrix(x$H[-i])) 1285 | } 1286 | predicted.values <- h 1287 | } 1288 | 1289 | if (x$family == "binomial") { 1290 | h <- x$H + x$X %*% x$B 1291 | predicted.values <- as.numeric(h) 1292 | } 1293 | 1294 | if (show.plot == TRUE) { 1295 | if (!require(plotrix)) { 1296 | stop("The 'plotrix' package is required to plot images from this function") 1297 | } 1298 | 1299 | W <- data.frame(Y = predicted.values, sp = x$sp, site = x$site) 1300 | Y <- reshape(W, v.names = "Y", idvar = "sp", timevar = "site", direction = "wide") 1301 | Y <- Y[, 2:dim(Y)[2]] 1302 | par(mfrow = c(1, 1), las = 1, mar = c(4, 4, 2, 2) - 0.1) 1303 | 1304 | color2D.matplot(Y, ylab = "species", xlab = "sites", main = "Predicted values") 1305 | } 1306 | return(predicted.values) 1307 | } 1308 | -------------------------------------------------------------------------------- /R/pirls.R: -------------------------------------------------------------------------------- 1 | ##' Create an approximate deviance evaluation function for GLMMs using Laplace 2 | ##' Must use the flexLambda branch of lme4 3 | ##' 4 | ##' A pure \code{R} implementation of the 5 | ##' penalized iteratively reweighted least squares (PIRLS) 6 | ##' algorithm for computing generalized linear mixed model 7 | ##' deviances. The purpose is to clarify how 8 | ##' PIRLS works without having to read through C++ code, 9 | ##' and as a sandbox for trying out modified versions of 10 | ##' PIRLS. 11 | ##' 12 | ##' @param glmod output of \code{glFormula} 13 | ##' @param y response 14 | ##' @param eta linear predictor 15 | ##' @param family a \code{glm} family object 16 | ##' @param weights prior weights 17 | ##' @param offset offset 18 | ##' @param tol convergence tolerance 19 | ##' @param npirls maximum number of iterations 20 | ##' @param nAGQ either 0 (PIRLS for \code{u} and \code{beta}) or 1 (\code{u} only). 21 | ##' currently no quadature is available 22 | ##' @param verbose verbose 23 | ##' 24 | ##' @details \code{pirls1} is a convenience function for optimizing \code{pirls} 25 | ##' under \code{nAGQ = 1}. In particular, it wraps \code{theta} and \code{beta} 26 | ##' into a single argument \code{thetabeta}. 27 | ##' 28 | ##' @return A function for evaluating the GLMM Laplace approximated deviance 29 | ##' @export 30 | pirls <- function(X,y,Zt,Lambdat,thfun,theta, 31 | weights,offset=numeric(n), 32 | eta=numeric(n),family=binomial, 33 | tol = 10^-6, npirls = 30,nstephalf = 10,nAGQ = 1,verbose=0L, 34 | ...){ 35 | # FIXME: bad default starting value for eta 36 | 37 | n <- nrow(X); p <- ncol(X); q <- nrow(Zt) 38 | stopifnot(nrow(X) == n, ncol(Zt) == n, 39 | nrow(Lambdat) == q, ncol(Lambdat) == q, is.function(thfun)) 40 | 41 | if (is.function(family)) family <- family() # ensure family is a list 42 | 43 | local({ 44 | nth <- length(theta) 45 | betaind <- -seq_len(nth) # indices to drop 1:nth 46 | linkinv <- family$linkinv 47 | variance <- family$variance 48 | muEta <- family$mu.eta 49 | aic <- family$aic 50 | sqDevResid <- family$dev.resid 51 | mu <- linkinv(eta) 52 | beta <- numeric(p) 53 | u <- numeric(q) 54 | L <- Cholesky(tcrossprod(Lambdat %*% Zt), perm=FALSE, LDL=FALSE, Imult=1) 55 | if (nAGQ > 0L) { 56 | # create function for conducting PIRLS 57 | function(thetabeta) { 58 | # initialize 59 | Lambdat@x[] <<- thfun(thetabeta[-betaind]) 60 | LtZt <- Lambdat %*% Zt 61 | beta[] <<- thetabeta[betaind] 62 | offb <- offset + X %*% beta 63 | updatemu <- function(uu) { 64 | eta[] <<- offb + as.vector(crossprod(LtZt, uu)) 65 | mu[] <<- linkinv(eta) 66 | sum(sqDevResid(y, mu, weights)) + sum(uu^2) 67 | } 68 | u[] <<- numeric(q) 69 | olducden <- updatemu(u) 70 | cvgd <- FALSE 71 | for(i in 1:npirls){ 72 | # update w and muEta 73 | Whalf <- Diagonal(x = sqrt(weights / variance(mu))) 74 | # update weighted design matrix 75 | LtZtMWhalf <- LtZt %*% (Diagonal(x = muEta(eta)) %*% Whalf) 76 | # update Cholesky decomposition 77 | L <- update(L, LtZtMWhalf, 1) 78 | # alternative (more explicit but slower) 79 | # Cholesky update 80 | # L <- Cholesky(tcrossprod(LtZtMWhalf), perm=FALSE, LDL=FALSE, Imult=1) 81 | # update weighted residuals 82 | wtres <- Whalf %*% (y - mu) 83 | # solve for the increment 84 | delu <- as.vector(solve(L, LtZtMWhalf %*% wtres - u)) 85 | if (verbose > 0L) { 86 | cat(sprintf("inc: %12.4g", delu[1])) 87 | nprint <- min(5, length(delu)) 88 | for (j in 2:nprint) cat(sprintf(" %12.4g", delu[j])) 89 | cat("\n") 90 | } 91 | # update mu and eta and calculate 92 | # new unscaled conditional log density 93 | ucden <- updatemu(u + delu) 94 | if (verbose > 1L) { 95 | cat(sprintf("%6.4f: %10.3f\n", 1, ucden)) 96 | } 97 | 98 | if(abs((olducden - ucden) / ucden) < tol){ 99 | cvgd <- TRUE 100 | break 101 | } 102 | # step-halving 103 | if(ucden > olducden){ 104 | for(j in 1:nstephalf){ 105 | ucden <- updatemu(u + (delu <- delu/2)) 106 | if (verbose > 1L) { 107 | cat(sprintf("%6.4f: %10.3f\n", 1/2^j, ucden)) 108 | } 109 | if(ucden <= olducden) break 110 | } 111 | if(ucden > olducden) stop("Step-halving failed") 112 | } 113 | # set old unscaled conditional log density 114 | # to the new value 115 | olducden <- ucden 116 | # update the conditional modes (take a step) 117 | u[] <<- u + delu 118 | } 119 | if(!cvgd) stop("PIRLS failed to converge") 120 | 121 | # create Laplace approx to -2log(L) 122 | ldL2 <- 2*determinant(L, logarithm = TRUE)$modulus 123 | attributes(ldL2) <- NULL 124 | # FIXME: allow for quadrature approximations too 125 | Lm2ll <- aic(y,rep.int(1,n),mu,weights,NULL) + sum(u^2) + ldL2 #+ (q/2)*log(2*pi) 126 | 127 | if (verbose > 0L) { 128 | cat(sprintf("%10.3f: %12.4g", Lm2ll, thetabeta[1])) 129 | for (j in 2:length(thetabeta)) cat(sprintf(" %12.4g", thetabeta[j])) 130 | cat("\n") 131 | } 132 | 133 | Lm2ll 134 | } 135 | } else stop("code for nAGQ == 0 needs to be added") 136 | }) 137 | } 138 | -------------------------------------------------------------------------------- /R/pls.R: -------------------------------------------------------------------------------- 1 | ##' @importMethodsFrom Matrix t %*% crossprod diag tcrossprod solve determinant update 2 | ##' @importFrom Matrix bdiag rBind Diagonal Cholesky sparse.model.matrix 3 | ##' @importFrom lme4 findbars nobars subbars 4 | NULL 5 | 6 | 7 | ##' Fit a mixed effects from raw matrices, vectors and grouping factors 8 | ##' 9 | ##' The only output from this function is the result of an optimization 10 | ##' over the covariance parameters. 11 | ##' 12 | ##' @param y response vector 13 | ##' @param mmFE model matrix for the fixed effects 14 | ##' @param mmRE template model matrix for the random effects 15 | ##' (or optionally a list of such matrices) 16 | ##' @param grp grouping factor for the random effects 17 | ##' (or optionally a list of such factors) 18 | ##' @param weights weights 19 | ##' @param offset offset 20 | ##' @param REML should restricted maximum likelihood be used? 21 | ##' 22 | ##' @export 23 | ##' 24 | ##' @examples 25 | ##' library(lme4pureR) 26 | ##' library(lme4) 27 | ##' library(minqa) 28 | ##' set.seed(1) 29 | ##' n <- 1000 30 | ##' x <- rnorm(n) 31 | ##' z <- rnorm(n) 32 | ##' X <- cbind(1, x) 33 | ##' ZZ <- cbind(1, z) 34 | ##' grp <- gl(n/5,5) 35 | ##' RE <- mkRanefStructures(list(grp), list(ZZ)) 36 | ##' Z <- t(RE$Zt) 37 | ##' y <- as.numeric(X%*%rnorm(ncol(X)) + Z%*%rnorm(ncol(Z)) + rnorm(n)) 38 | ##' m <- lmer.fit(y,X,ZZ,grp) 39 | ##' m$par 40 | ##' Lambdat <- RE$Lambdat 41 | ##' Lambdat@x <- m$par[RE$Lind] 42 | ##' cov2cor(crossprod(Lambdat)[1:2,1:2]) 43 | ##' lmer(y ~ x + (z|grp)) 44 | lmer.fit <- function(y, mmFE, mmRE, grp, 45 | weights, offset = numeric(n), 46 | REML = TRUE){ 47 | if(missing(weights)) weights <- rep(1,length(y)) 48 | initRE <- mkRanefStructures(grp, mmRE) 49 | devfun <- with(initRE, { 50 | pls(mmFE,y,Zt,Lambdat, 51 | thfun = function(theta) theta[Lind], 52 | weights = weights, offset = offset, 53 | REML = REML)}) 54 | with(initRE, { 55 | bobyqa(initRE$theta, devfun, 56 | lower = lower, upper = upper)}) 57 | } 58 | 59 | ##' lmer.fit function for the single correlation template model 60 | ##' 61 | ##' @param y response vector 62 | ##' @param mmFE model matrix for the fixed effects 63 | ##' @param corr template correlation matrix for the single scalar random effect 64 | ##' @param grp grouping factor for the random effect (levels correspond 65 | ##' to \code{dimnames} of \code{corr} 66 | ##' @param weights weights 67 | ##' @param offset offset 68 | ##' @param REML should restricted maximum likelihood be used? 69 | ##' 70 | ##' @export 71 | ##' @examples 72 | ##' library(lme4pureR) 73 | ##' library(lme4) 74 | ##' library(minqa) 75 | ##' library(subscript) 76 | ##' library(rmv) 77 | ##' set.seed(1) 78 | ##' n <- 100 79 | ##' x <- rnorm(n) 80 | ##' X <- cbind(1, x) 81 | ##' grp <- gl(n/5,5) 82 | ##' ugrps <- unique(grp) 83 | ##' q <- length(ugrps) 84 | ##' corr <- rcov(q+1,q) 85 | ##' dimnames(corr) <- rep(list(as.character(ugrps)), 2) 86 | ##' b <- as.numeric(rmv(1,corr) %*% as(grp, "sparseMatrix")) 87 | ##' y <- as.numeric(X%*%rnorm(ncol(X)) + b + rnorm(n)) 88 | ##' 89 | ##' m <- lmerCorr.fit(y, X, corr, grp) 90 | ##' m$par 91 | lmerCorr.fit <- function(y, mmFE, corr, grp, 92 | weights, offset = numeric(n), 93 | REML = TRUE){ 94 | if(missing(weights)) weights <- rep(1,length(y)) 95 | initRE <- mkRanefStructuresCorr(corr, grp, length(y)) 96 | devfun <- with(initRE, { 97 | pls(mmFE,y,Zt,Lambdat,thfun=thfun, 98 | weights = weights, offset = offset, 99 | REML = REML)}) 100 | with(initRE, { 101 | bobyqa(initRE$theta, devfun, 102 | lower = lower, upper = upper)}) 103 | 104 | } 105 | 106 | 107 | ##' Create linear mixed model deviance function 108 | ##' 109 | ##' A pure \code{R} implementation of the 110 | ##' penalized least squares (PLS) approach for computing 111 | ##' linear mixed model deviances. The purpose 112 | ##' is to clarify how PLS works without having 113 | ##' to read through C++ code, and as a sandbox for 114 | ##' trying out modifications to PLS. 115 | ##' 116 | ##' @param X fixed effects model matrix 117 | ##' @param y response 118 | ##' @param Zt transpose of the sparse model matrix for the random effects 119 | ##' @param Lambdat upper triangular sparse Cholesky factor of the 120 | ##' relative covariance matrix of the random effects 121 | ##' @param thfun a function that takes a value of \code{theta} and produces 122 | ##' the non-zero elements of \code{Lambdat}. The structure of \code{Lambdat} 123 | ##' cannot change, only the numerical values 124 | ##' @param weights prior weights 125 | ##' @param offset offset 126 | ##' @param REML calculate REML deviance? 127 | ##' @param ... additional arguments 128 | ##' @keywords models 129 | ##' 130 | ##' @return a function that evaluates the deviance or REML criterion 131 | ##' @export 132 | pls <- function(X,y,Zt,Lambdat,thfun,weights, 133 | offset = numeric(n),REML = TRUE,...) 134 | { 135 | # SW: how to test for sparse matrices, without specifying the specific class? 136 | stopifnot(is.matrix(X)) # is.matrix(Zt), is.matrix(Lambdat)) 137 | n <- length(y); p <- ncol(X); q <- nrow(Zt) 138 | stopifnot(nrow(X) == n, ncol(Zt) == n, 139 | nrow(Lambdat) == q, ncol(Lambdat) == q, is.function(thfun)) 140 | # calculate weighted products 141 | Whalf <- if (missing(weights)) Diagonal(n=n) else Diagonal(x=sqrt(as.numeric(weights))) 142 | WX <- Whalf %*% X 143 | Wy <- Whalf %*% y 144 | ZtW <- Zt %*% Whalf 145 | XtWX <- crossprod(WX) 146 | XtWy <- crossprod(WX, Wy) 147 | ZtWX <- ZtW %*% WX 148 | ZtWy <- ZtW %*% Wy 149 | rm(WX,Wy) 150 | local({ # mutable values stored in local environment 151 | b <- numeric(q) # conditional mode of random effects 152 | beta <- numeric(p) # conditional estimate of fixed-effects 153 | cu <- numeric(q) # intermediate solution 154 | DD <- XtWX # down-dated XtWX 155 | L <- Cholesky(tcrossprod(Lambdat %*% ZtW), LDL = FALSE, Imult=1) 156 | Lambdat <- Lambdat # stored here b/c x slot will be updated 157 | mu <- numeric(n) # conditional mean of response 158 | RZX <- matrix(0,nrow=q,ncol=p) # intermediate matrix in solution 159 | u <- numeric(q) # conditional mode of spherical random effects 160 | function(theta) { 161 | Lambdat@x[] <<- thfun(theta) 162 | L <<- update(L, Lambdat %*% ZtW, mult = 1) 163 | # solve eqn. 30 164 | cu[] <<- as.vector(solve(L, solve(L, Lambdat %*% ZtWy, system="P"), 165 | system="L")) 166 | # solve eqn. 31 167 | RZX[] <<- as.vector(solve(L, solve(L, Lambdat %*% ZtWX, system="P"), 168 | system="L")) 169 | ## downdate XtWX and form Cholesky factor (eqn. 32) 170 | DD <<- as(XtWX - crossprod(RZX), "dpoMatrix") 171 | ## conditional estimate of fixed-effects coefficients (solve eqn. 33) 172 | beta[] <<- as.vector(solve(DD, XtWy - crossprod(RZX, cu))) 173 | ## conditional mode of the spherical random-effects coefficients (eqn. 34) 174 | u[] <<- as.vector(solve(L, solve(L, cu - RZX %*% beta, system = "Lt"), 175 | system="Pt")) 176 | b[] <<- as.vector(crossprod(Lambdat,u)) 177 | # conditional mean of the response 178 | mu[] <<- as.vector(crossprod(Zt,b) + X %*% beta + offset) 179 | wtres <- Whalf*(y-mu) # weighted residuals 180 | pwrss <- sum(wtres^2) + sum(u^2) # penalized, weighted residual sum-of-squares 181 | fn <- as.numeric(length(mu)) 182 | ld <- 2*determinant(L,logarithm=TRUE)$modulus # log determinant 183 | if (REML) { 184 | ld <- ld + determinant(DD,logarithm=TRUE)$modulus 185 | fn <- fn - length(beta) 186 | } 187 | attributes(ld) <- NULL 188 | # profiled deviance or REML criterion 189 | ld + fn*(1 + log(2*pi*pwrss) - log(fn)) 190 | #ld + fn*(1 + log(2*pi*pwrss)) 191 | } 192 | }) 193 | } 194 | 195 | ##' Create the structure of a linear mixed model from formula/data specification 196 | ##' 197 | ##' A pure \code{R} implementation of the 198 | ##' penalized least squares (PLS) approach to evaluation of the deviance or the 199 | ##' REML criterion for linear mixed-effects models. 200 | ##' 201 | ##' @param formula a two-sided model formula with random-effects terms 202 | ##' and, optionally, fixed-effects terms. 203 | ##' @param data a data frame in which to evaluate the variables from \code{form} 204 | ##' @param REML calculate REML deviance? 205 | ##' @param weights prior weights 206 | ##' @param offset offset 207 | ##' @param sparseX should X, the model matrix for the fixed-effects coefficients be sparse? 208 | ##' @param ... additional arguments 209 | ##' @keywords models 210 | ##' 211 | ##' @return a \code{list} with: 212 | ##' \itemize{ 213 | ##' \item \code{X} Fixed effects model matrix 214 | ##' \item \code{y} Observed response vector 215 | ##' \item \code{fr} Model frame 216 | ##' \item \code{call} Matched call 217 | ##' \item \code{REML} Logical indicating REML or not 218 | ##' \item \code{weights} Prior weights or \code{NULL} 219 | ##' \item \code{offset} Prior offset term or \code{NULL} 220 | ##' \item \code{Zt} Transposed random effects model matrix 221 | ##' \item \code{Lambdat} Transposed relative covariance factor 222 | ##' \item \code{theta} Vector of covariance parameters 223 | ##' \item \code{lower} Vector of lower bounds for \code{theta} 224 | ##' \item \code{upper} Vector of upper bounds for \code{theta} 225 | ##' \item \code{thfun} A function that maps \code{theta} into the structural non-zero 226 | ##' elements of \code{Lambdat}, which are stored in \code{slot(Lambdat, 'x')} 227 | ##' } 228 | ##' @export 229 | ##' @examples 230 | ##' form <- Reaction ~ Days + (Days|Subject) 231 | ##' data(sleepstudy, package="lme4") 232 | ##' ll <- plsform(form, sleepstudy, REML=FALSE) 233 | ##' names(ll) 234 | plsform <- function(formula, data, REML=TRUE, weights, offset, sparseX = FALSE, family = gaussian, ...) { 235 | stopifnot(inherits(formula, "formula"), length(formula) == 3L, 236 | length(rr <- findbars(formula[[3]])) > 0L) 237 | mc <- match.call() 238 | fr <- eval(mkMFCall(mc, formula), parent.frame()) # evaluate the model frame 239 | fr1 <- eval(mkMFCall(mc, formula, TRUE), parent.frame()) # evaluate the model frame sans bars 240 | trms <- attr(fr, "terms") <- attr(fr1, "terms") 241 | rho <- initializeResp(fr, REML=REML, family=family) # FIXME: make use of etastart and mustart 242 | c(list(X = if (sparseX) sparse.model.matrix(trms,fr) else model.matrix(trms,fr), 243 | y = rho$y, 244 | fr = fr, call = mc, 245 | REML = as.logical(REML)[1]), 246 | #if (is.null(wts <- model.weights(fr))) wts else list(weights=wts), 247 | #if (is.null(off <- model.offset(fr))) off else list(offset=off), 248 | list(weights = rho$weights), list(offset = rho$offset), 249 | mkRanefRepresentation(lapply(rr, function(t) as.factor(eval(t[[3]], fr))), 250 | lapply(rr, function(t) 251 | model.matrix(eval(substitute( ~ foo, list(foo = t[[2]]))), fr)))) 252 | } 253 | 254 | initializeResp <- function(fr, REML, family){ 255 | # taken mostly from mkRespMod 256 | if(!inherits(family,"character")) family <- as.function(family) 257 | if(!inherits(family,"family")) family <- family() 258 | y <- model.response(fr) 259 | ### Why consider there here? They are handled in plsform. 260 | # offset <- model.offset(fr) 261 | # weights <- model.weights(fr) 262 | n <- nrow(fr) 263 | etastart_update <- model.extract(fr, "etastart") 264 | if(length(dim(y)) == 1) { 265 | ## avoid problems with 1D arrays, but keep names 266 | nm <- rownames(y) 267 | dim(y) <- NULL 268 | if(!is.null(nm)) names(y) <- nm 269 | } 270 | ### I really wish that the glm families in R were cleaned up. All of 271 | ### this is such an ugly hack, just to handle one special case for the binomial 272 | rho <- new.env() 273 | rho$y <- if (is.null(y)) numeric(0) else y 274 | if (!is.null(REML)) rho$REML <- REML 275 | rho$etastart <- fr$etastart 276 | rho$mustart <- fr$mustart 277 | if (!is.null(offset <- model.offset(fr))) { 278 | if (length(offset) == 1L) offset <- rep.int(offset, n) 279 | stopifnot(length(offset) == n) 280 | rho$offset <- unname(offset) 281 | } else rho$offset <- rep.int(0, n) 282 | if (!is.null(weights <- model.weights(fr))) { 283 | stopifnot(length(weights) == n, all(weights >= 0)) 284 | rho$weights <- unname(weights) 285 | } else rho$weights <- rep.int(1, n) 286 | stopifnot(inherits(family, "family")) 287 | rho$nobs <- n 288 | eval(family$initialize, rho) 289 | family$initialize <- NULL # remove clutter from str output 290 | rho 291 | } 292 | 293 | ## Create the call to model.frame from the matched call with the 294 | ## appropriate substitutions and eliminations 295 | mkMFCall <- function(mc, form, nobars=FALSE) { 296 | m <- match(c("data", "subset", "weights", "na.action", "offset"), names(mc), 0) 297 | mc <- mc[c(1, m)] # retain only a subset of the arguments 298 | mc$drop.unused.levels <- TRUE # ensure unused levels of factors are dropped 299 | mc[[1]] <- quote(model.frame) # change the call to model.frame 300 | form[[3]] <- if (nobars) { 301 | if(is.null(nb <- nobars(form[[3]]))) 1 else nb 302 | } else subbars(form[[3]]) 303 | mc$formula <- form 304 | mc 305 | } 306 | 307 | ##' Create a section of a transposed random effects model matrix 308 | ##' 309 | ##' @param grp Grouping factor for a particular random effects term. 310 | ##' @param mm Dense model matrix for a particular random effects term. 311 | ##' @return Section of a random effects model matrix corresponding to a 312 | ##' particular term. 313 | ##' @export 314 | ##' @examples 315 | ##' ## consider a term (x | g) with: 316 | ##' ## number of observations, n = 6 317 | ##' ## number of levels, nl = 3 318 | ##' ## number of columns ('predictors'), nc = 2 319 | ##' (X <- cbind("(Intercept)"=1,x=1:6)) # an intercept in the first column and 1:6 predictor in the other 320 | ##' (g <- as.factor(letters[rep(1:3,2)])) # grouping factor 321 | ##' nrow(X) # n = 6 322 | ##' nrow(X) == length(g) # and consistent n between X and g 323 | ##' ncol(X) # nc = 2 324 | ##' nlevels(g) # nl = 3 325 | ##' Zsection(g, X) 326 | Zsection <- function(grp,mm) { 327 | Jt <- as(as.factor(grp), Class="sparseMatrix") 328 | KhatriRao(Jt,t(mm)) 329 | } 330 | ## Zsection <- function(grp,mm) { 331 | ## # Jt is a sparse matrix of indicators to groups. 332 | ## # this is an interesting feature of coercing a 333 | ## # factor to a sparseMatrix. 334 | ## Jt <- as(as.factor(grp), Class="sparseMatrix") 335 | ## # if mm has one column, multiply zt by a diagonal 336 | ## # matrix. 337 | ## if ((m <- ncol(mm)) == 1L) return(Jt %*% Diagonal(x=mm)) 338 | ## # if mm has more than one column, carry on. 339 | ## # figure out how to rearrange the order of the 340 | ## # rows by calculating row indices (rinds) 341 | ## # eg: if m = 2, nrow(Jt) = 10, we want the order: 342 | ## # 1,11,2,12,3,13,...,20 343 | ## rinds <- as.vector(matrix(seq_len(m*nrow(Jt)), nrow=m, byrow=TRUE)) 344 | ## # rBind products of Jt and a diagonal matrix 345 | ## # for each column, then rearrange rows. 346 | ## do.call(rBind,lapply(seq_len(m), function(j) Jt %*% Diagonal(x=mm[,j])))[rinds,] 347 | ## } 348 | 349 | 350 | ## Create the diagonal block on Lambdat for a random-effects term with 351 | ## nc columns and nl levels. The value is a list with the starting 352 | ## value of theta for the block, the lower bounds, the block of 353 | ## Lambdat and the function that updates the block given the section 354 | ## of theta for this block. 355 | 356 | ##' Create digonal block on transposed relative covariance factor 357 | ##' 358 | ##' Each random-effects term is represented by diagonal block on 359 | ##' the transposed relative covariance factor. \code{blockLambdat} 360 | ##' creates such a block, and returns related information along 361 | ##' with it. 362 | ##' 363 | ##' @param nl Number of levels in a grouping factor for a particular 364 | ##' random effects term (the number of levels in the \code{grp} argument 365 | ##' in \code{\link{Zsection}}). 366 | ##' @param nc Number of columns in a dense model matrix for a particular 367 | ##' random effects term (the number of columns in the \code{mm} argument 368 | ##' in \code{\link{Zsection}}). 369 | ##' @return A \code{list} with: 370 | ##' \itemize{ 371 | ##' \item the block 372 | ##' \item ititial values of theta for the block 373 | ##' \item lower bounds on these initial theta values 374 | ##' \item a function that updates the block given the section 375 | ##' of theta for this block 376 | ##' } 377 | ##' @export 378 | ##' @examples 379 | ##' (l <- blockLambdat(2, 3)) 380 | ##' within(l, slot(Lambdat, 'x') <- updateLambdatx(as.numeric(10:12))) 381 | blockLambdat <- function(nl, nc) { 382 | if (nc == 1L) 383 | return(list(theta = 1, 384 | lower = 0, 385 | Lambdat = Diagonal(x = rep(1, nl)), 386 | updateLambdatx=local({nl <- nl;function(theta) rep.int(theta[1],nl)}))) 387 | 388 | # generate row (i) and column (j) indices 389 | # of the upper triangular template matrix 390 | i <- sequence(nc); j <- rep(1:nc,1:nc) 391 | # generate theta: 392 | # 1) 1's along the diagonal (i.e. when i==j) 393 | # 2) 0's above the diagonal (i.e. when i!=j) 394 | theta <- 1*(i==j) 395 | # create the template with the triplet: (i,j,theta) 396 | template <- sparseMatrix(i=i,j=j,x=theta) 397 | # put the blocks together 398 | LambdaBlock <- .bdiag(rep(list(template),nl)) 399 | 400 | list(theta=theta, 401 | lower=ifelse(theta,0,-Inf), 402 | Lambdat=Lambdat, 403 | updateLambdatx = local({ 404 | Lind <- rep(seq_along(i),nl) 405 | function(theta) theta[Lind] 406 | }) 407 | ) 408 | } 409 | 410 | blockLambdat <- function(nl, nc) { 411 | if (nc == 1L) 412 | return(list(theta = 1, 413 | lower = 0, 414 | Lambdat = Diagonal(x = rep(1, nl)), 415 | updateLambdatx=local({nl <- nl;function(theta) rep.int(theta[1],nl)}))) 416 | # create template matrix 417 | m <- diag(nrow=nc, ncol=nc) 418 | # identify its upper triangular elements 419 | ut <- upper.tri(m, diag=TRUE) 420 | # the initial theta values are these upper 421 | # triangular elements 422 | theta <- m[ut] 423 | # put the indices of theta in the upper 424 | # triangle of the template 425 | m[ut] <- seq_along(theta) 426 | # repeat the template (once for each level) 427 | # to create a sparse block diagonal matrix 428 | Lambdat <- do.call(bdiag, rep(list(m), nl)) 429 | # store the indices mapping theta to the 430 | # structural non-zeros of lambdat 431 | Lind <- Lambdat@x 432 | # save the initial theta values in their 433 | # appropriate locations in Lambdat 434 | Lambdat@x <- theta[Lind] 435 | 436 | list(theta=theta, 437 | lower=ifelse(theta,0,-Inf), 438 | Lambdat=Lambdat, 439 | updateLambdatx = local({ 440 | Lind <- Lind 441 | function(theta) theta[Lind] 442 | }) 443 | ) 444 | } 445 | 446 | 447 | 448 | 449 | ##' Make random effects representation 450 | ##' 451 | ##' Create all of the elements required to specify the random-effects 452 | ##' structure of a mixed effects model. 453 | ##' 454 | ##' @param grps List of factor vectors of length n indicating groups. Each 455 | ##' element corresponds to a random effects term. 456 | ##' @param mms List of model matrices. Each 457 | ##' element corresponds to a random effects term. 458 | ##' @details 459 | ##' The basic idea of this function is to call \code{\link{Zsection}} and 460 | ##' \code{\link{blockLambdat}} once for each random effects term (ie. 461 | ##' each list element in \code{grps} and \code{mms}). The results of 462 | ##' \code{\link{Zsection}} for each term are \code{rBind}ed together. 463 | ##' The results of \code{\link{blockLambdat}} are \code{bdiag}ed 464 | ##' together, unless all terms have only a single column ('predictor') 465 | ##' in which case a diagonal matrix is created directly. 466 | ##' 467 | ##' @return A \code{list} with: 468 | ##' \itemize{ 469 | ##' \item \code{Lambdat} Transformed relative covariance factor 470 | ##' \item \code{Zt} Transformed random effects model matrix 471 | ##' \item \code{theta} Vector of covariance parameters 472 | ##' \item \code{lower} Vector of lower bounds on the covariance parameters 473 | ##' \item \code{upper} Vector of upper bounds on the covariance parameters 474 | ##' \item \code{thfun} A function that maps \code{theta} onto the non-zero 475 | ##' elements of \code{Lambdat} 476 | ##' } 477 | ##' @export 478 | mkRanefRepresentation <- function(grps, mms) { 479 | # compute transposed random effects model 480 | # matrix, Zt (Class="dgCMatrix"), by 481 | # rBinding the sections for each term. 482 | ll <- list(Zt = do.call(rBind, mapply(Zsection, grps, mms))) 483 | # number of levels in each grouping factor 484 | nl <- sapply(grps, function(g) length(levels(g))) 485 | # number of columns in each model matrix 486 | nc <- sapply(mms, ncol) 487 | # for scalar models use a diagonal Lambdat 488 | # (Class="ddiMatrix") and a simpler thfun. 489 | if (all(nc == 1L)) { 490 | nth <- length(nc) 491 | ll$lower <- numeric(nth) 492 | ll$theta <- rep.int(1, nth) 493 | ll$upper <- rep.int(Inf, nth) 494 | ll$Lambdat <- Diagonal(x= rep.int(1, sum(nl))) 495 | ll$thfun <- local({ 496 | nlvs <- nl 497 | function(theta) rep.int(theta,nlvs)}) 498 | # for vector models bdiag the lambdat 499 | # blocks together (Class="dgCMatrix") 500 | } else { 501 | zz <- mapply(blockLambdat, nl, nc, SIMPLIFY=FALSE) 502 | ll$Lambdat <- do.call(bdiag, lapply(zz, "[[", "Lambdat")) 503 | th <- lapply(zz, "[[", "theta") 504 | ll$theta <- unlist(th) 505 | ll$lower <- sapply(zz, "[[", "lower") 506 | ll$upper <- rep.int(Inf, length(ll$theta)) 507 | ll$thfun <- local({ 508 | splits <- rep.int(seq_along(th), sapply(th, length)) 509 | thfunlist <- lapply(zz,"[[","updateLambdatx") 510 | function (theta) 511 | unlist(mapply(do.call,thfunlist,lapply(split(theta,splits),list))) 512 | }) 513 | } 514 | ll 515 | } 516 | -------------------------------------------------------------------------------- /R/templateApproach.R: -------------------------------------------------------------------------------- 1 | ##' Random lmer-type model simulation 2 | ##' @export 3 | rLmer <- function(grp, mmRE, mmFE) message("not yet written") 4 | 5 | 6 | ##' Make random effects structures 7 | ##' 8 | ##' @param grp List of grouping factors (one for each term) 9 | ##' @param mm List of model matrices (one for each term) 10 | ##' @export 11 | mkRanefStructures <- function(grp, mm){ 12 | # checking things are OK 13 | if(!is.list(grp)) grp <- list(grp) 14 | if(!is.list(mm)) mm <- list(mm) 15 | grp <- lapply(grp, as.factor) 16 | 17 | 18 | nl <- sapply(grp, nlevels) # number of grouping factor levels per term 19 | nc <- sapply(mm, ncol) # number of model matrix columns per term 20 | templates <- mkTemplates(nc) # templates for relative covariance factor 21 | theta <- mkTheta(templates) 22 | 23 | list( Zt = mkZt(grp, mm), 24 | Lambdat = mkLambdat(templates, nl), 25 | Lind = mkLind(nl, nc), 26 | theta = theta, 27 | lower = ifelse(theta, 0, -Inf), # lower and 28 | upper = rep(Inf, length(theta)) # upper bounds on theta parameters 29 | ) 30 | } 31 | 32 | 33 | ##' Create a section of a transposed random effects model matrix 34 | ##' 35 | ##' @param grp Grouping factor for a particular random effects term. 36 | ##' @param mm Dense model matrix for a particular random effects term. 37 | ##' @return Section of a random effects design matrix corresponding to a 38 | ##' particular term. 39 | ##' @export 40 | ##' @examples 41 | ##' ## consider a term (x | g) with: 42 | ##' ## number of observations, n = 6 43 | ##' ## number of levels, nl = 3 44 | ##' ## number of columns ('predictors'), nc = 2 45 | ##' (X <- cbind("(Intercept)"=1,x=1:6)) # an intercept in the first column 46 | ##' # and 1:6 predictor in the other 47 | ##' (g <- as.factor(letters[rep(1:3,2)])) # grouping factor 48 | ##' nrow(X) # n = 6 49 | ##' nrow(X) == length(g) # and consistent n between X and g 50 | ##' ncol(X) # nc = 2 51 | ##' nlevels(g) # nl = 3 52 | ##' Zsection(g, X) 53 | mkZtSection <- function(grp,mm) { 54 | Jt <- as(as.factor(grp), Class="sparseMatrix") 55 | KhatriRao(Jt,t(mm)) 56 | } 57 | 58 | ##' Make transposed random-effects model matrix 59 | ##' @export 60 | mkZt <- function(grp,mm){ 61 | ZtSections <- mapply(mkZtSection, grp, mm, SIMPLIFY=FALSE) 62 | do.call(rBind, ZtSections) 63 | } 64 | 65 | ##' Make a single template for a relative covariance factor 66 | ##' 67 | ##' @param nc Number of columns in a dense model matrix for a particular 68 | ##' random effects term 69 | ##' @export 70 | ##' @examples 71 | ##' mkTemplate(5) 72 | mkTemplate <- function(nc){ 73 | # generate row (i) and column (j) indices 74 | # of the upper triangular template matrix 75 | i <- sequence(1:nc); j <- rep(1:nc,1:nc) 76 | # initialize theta: 77 | # 1) 1's along the diagonal (i.e. when i==j) 78 | # 2) 0's above the diagonal (i.e. when i!=j) 79 | theta <- 1*(i==j) 80 | # return the template using triplet (i,j,theta) 81 | sparseMatrix(i=i,j=j,x=theta) 82 | } 83 | 84 | ##' Make list of templates for relative covariance factor 85 | ##' @export 86 | mkTemplates <- function(nc) lapply(nc, mkTemplate) 87 | 88 | ##' Make vector of indices giving the mapping from theta to Lambdat 89 | ##' @export 90 | mkLind <- function(nl, nc){ 91 | # number of thetas per term (i.e. number 92 | # of elements in the upper triangle of 93 | # each of the template matrices) 94 | nTheta <- choose(nc+1, 2) 95 | # Lind per template 96 | templateLind <- lapply(nTheta, seq_len) 97 | # 0-based pointers to where each term 98 | # begins in theta 99 | offsetTheta <- c(0,cumsum(nTheta[-length(nTheta)])) 100 | # add offsets (i.e. pointers) 101 | templateLindWithOffset <- mapply("+", templateLind, offsetTheta) 102 | # repeat template-specific Lind vectors 103 | # once for each term and return Lind 104 | unlist(rep(templateLindWithOffset, nl)) 105 | } 106 | 107 | ##' Make initial relative covariance factor from list of templates 108 | ##' @export 109 | mkLambdat <- function(templates, nl){ 110 | # repeat templates once for each level 111 | templateList <- rep(templates, nl) 112 | # return Lambdat by putting blocks 113 | # together along the diagonal 114 | .bdiag(templateList) 115 | } 116 | 117 | ##' Make initial theta from list of templates 118 | ##' @export 119 | mkTheta <- function(templates){ 120 | thetas <- lapply(templates, slot, "x") 121 | unlist(thetas) 122 | } 123 | 124 | 125 | 126 | 127 | ##' Make random effects structures for the single correlation template model 128 | ##' 129 | ##' @param corr a correlation matrix template 130 | ##' @param grp a grouping factor vector 131 | ##' @param n sample size 132 | ##' @export 133 | mkRanefStructuresCorr <- function(corr, grp, n){ 134 | # create indicator matrix and order it 135 | # to be consistent with the order of corr 136 | Jt <- as(as.factor(grp), Class="sparseMatrix") 137 | Jt <- Jt[dimnames(corr)[[1]],] 138 | 139 | # create Zt 140 | Zt <- KhatriRao(Jt, t(rep(1,n))) 141 | 142 | # create Lambdat 143 | Lambdat <- as(t(chol(corr)), Class="sparseMatrix") 144 | 145 | # create mapping from theta to 146 | # the non-zero components of 147 | # Lambdat 148 | thfun <- local({ 149 | template <- Lambdat 150 | function(theta) theta * template@x}) 151 | 152 | list( Zt = Zt, 153 | Lambdat = Lambdat, 154 | thfun = thfun, 155 | theta = 1, 156 | lower = 0, # lower and 157 | upper = Inf) # upper bounds on theta parameters 158 | } 159 | 160 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | lme4pureR 2 | ========= 3 | 4 | The penalized least squares (PLS) and penalized iteratively 5 | reweighted least squares (PIRLS) algorithms from lme4, but written entirely 6 | in pure R. The purposes of this package are: 7 | 8 | 1. clarify how PLS and PIRLS work without having to read through C++ code, 9 | 10 | 2. as a sandbox for trying out modified versions of PLS and PIRLS, 11 | 12 | 3. as a companion to manuscripts describing the lmer and glmer functions. 13 | 14 | Note: Currently, this branch of lme4pureR depends on the flexLambda branch of lme4. 15 | -------------------------------------------------------------------------------- /man/Zsection.Rd: -------------------------------------------------------------------------------- 1 | \name{Zsection} 2 | \alias{Zsection} 3 | \title{Create a section of a transposed random effects model matrix} 4 | \usage{ 5 | Zsection(grp, mm) 6 | } 7 | \arguments{ 8 | \item{grp}{Grouping factor for a particular random 9 | effects term.} 10 | 11 | \item{mm}{Dense model matrix for a particular random 12 | effects term.} 13 | } 14 | \value{ 15 | Section of a random effects model matrix corresponding to a 16 | particular term. 17 | } 18 | \description{ 19 | Create a section of a transposed random effects model 20 | matrix 21 | } 22 | \examples{ 23 | ## consider a term (x | g) with: 24 | ## number of observations, n = 6 25 | ## number of levels, nl = 3 26 | ## number of columns ('predictors'), nc = 2 27 | (X <- cbind("(Intercept)"=1,x=1:6)) # an intercept in the first column and 1:6 predictor in the other 28 | (g <- as.factor(letters[rep(1:3,2)])) # grouping factor 29 | nrow(X) # n = 6 30 | nrow(X) == length(g) # and consistent n between X and g 31 | ncol(X) # nc = 2 32 | nlevels(g) # nl = 3 33 | Zsection(g, X) 34 | } 35 | 36 | -------------------------------------------------------------------------------- /man/blockLambdat.Rd: -------------------------------------------------------------------------------- 1 | \name{blockLambdat} 2 | \alias{blockLambdat} 3 | \title{Create digonal block on transposed relative covariance factor} 4 | \usage{ 5 | blockLambdat(nl, nc) 6 | } 7 | \arguments{ 8 | \item{nl}{Number of levels in a grouping factor for a 9 | particular random effects term (the number of levels in 10 | the \code{grp} argument in \code{\link{Zsection}}).} 11 | 12 | \item{nc}{Number of columns in a dense model matrix for a 13 | particular random effects term (the number of columns in 14 | the \code{mm} argument in \code{\link{Zsection}}).} 15 | } 16 | \value{ 17 | A \code{list} with: \itemize{ \item the block \item ititial 18 | values of theta for the block \item lower bounds on these 19 | initial theta values \item a function that updates the 20 | block given the section of theta for this block } 21 | } 22 | \description{ 23 | Each random-effects term is represented by diagonal block 24 | on the transposed relative covariance factor. 25 | \code{blockLambdat} creates such a block, and returns 26 | related information along with it. 27 | } 28 | \examples{ 29 | (l <- blockLambdat(2, 3)) 30 | within(l, slot(Lambdat, 'x') <- updateLambdatx(as.numeric(10:12))) 31 | } 32 | 33 | -------------------------------------------------------------------------------- /man/lmer.fit.Rd: -------------------------------------------------------------------------------- 1 | \name{lmer.fit} 2 | \alias{lmer.fit} 3 | \title{Fit a mixed effects from raw matrices, vectors and grouping factors} 4 | \usage{ 5 | lmer.fit(y, mmFE, mmRE, grp, weights, offset = numeric(n), REML = TRUE) 6 | } 7 | \arguments{ 8 | \item{y}{response vector} 9 | 10 | \item{mmFE}{model matrix for the fixed effects} 11 | 12 | \item{mmRE}{template model matrix for the random effects 13 | (or optionally a list of such matrices)} 14 | 15 | \item{grp}{grouping factor for the random effects (or 16 | optionally a list of such factors)} 17 | 18 | \item{weights}{weights} 19 | 20 | \item{offset}{offset} 21 | 22 | \item{REML}{should restricted maximum likelihood be 23 | used?} 24 | } 25 | \description{ 26 | The only output from this function is the result of an 27 | optimization over the covariance parameters. 28 | } 29 | \examples{ 30 | library(lme4pureR) 31 | library(lme4) 32 | library(minqa) 33 | set.seed(1) 34 | n <- 1000 35 | x <- rnorm(n) 36 | z <- rnorm(n) 37 | X <- cbind(1, x) 38 | ZZ <- cbind(1, z) 39 | grp <- gl(n/5,5) 40 | RE <- mkRanefStructures(list(grp), list(ZZ)) 41 | Z <- t(RE$Zt) 42 | y <- as.numeric(X\%*\%rnorm(ncol(X)) + Z\%*\%rnorm(ncol(Z)) + rnorm(n)) 43 | m <- lmer.fit(y,X,ZZ,grp) 44 | m$par 45 | Lambdat <- RE$Lambdat 46 | Lambdat 47 | } 48 | 49 | -------------------------------------------------------------------------------- /man/lmerCorr.fit.Rd: -------------------------------------------------------------------------------- 1 | \name{lmerCorr.fit} 2 | \alias{lmerCorr.fit} 3 | \title{lmer.fit function for the single correlation template model} 4 | \usage{ 5 | lmerCorr.fit(y, mmFE, corr, grp, weights, offset = numeric(n), REML = TRUE) 6 | } 7 | \arguments{ 8 | \item{y}{response vector} 9 | 10 | \item{mmFE}{model matrix for the fixed effects} 11 | 12 | \item{corr}{template correlation matrix for the single 13 | scalar random effect} 14 | 15 | \item{grp}{grouping factor for the random effect (levels 16 | correspond to \code{dimnames} of \code{corr}} 17 | 18 | \item{weights}{weights} 19 | 20 | \item{offset}{offset} 21 | 22 | \item{REML}{should restricted maximum likelihood be 23 | used?} 24 | } 25 | \description{ 26 | lmer.fit function for the single correlation template model 27 | } 28 | \examples{ 29 | library(lme4pureR) 30 | library(lme4) 31 | library(minqa) 32 | library(subscript) 33 | library(rmv) 34 | set.seed(1) 35 | n <- 100 36 | x <- rnorm(n) 37 | X <- cbind(1, x) 38 | grp <- gl(n/5,5) 39 | ugrps <- unique(grp) 40 | q <- length(ugrps) 41 | corr <- rcov(q+1,q) 42 | dimnames(corr) <- rep(list(as.character(ugrps)), 2) 43 | b <- as.numeric(rmv(1,corr) \%*\% as(grp, "sparseMatrix")) 44 | y <- as.numeric(X\%*\%rnorm(ncol(X)) + b + rnorm(n)) 45 | 46 | m <- lmerCorr.fit(y, X, corr, grp) 47 | m$par 48 | } 49 | 50 | -------------------------------------------------------------------------------- /man/mkLambdat.Rd: -------------------------------------------------------------------------------- 1 | \name{mkLambdat} 2 | \alias{mkLambdat} 3 | \title{Make initial relative covariance factor from list of templates} 4 | \usage{ 5 | mkLambdat(templates, nl) 6 | } 7 | \description{ 8 | Make initial relative covariance factor from list of 9 | templates 10 | } 11 | 12 | -------------------------------------------------------------------------------- /man/mkLind.Rd: -------------------------------------------------------------------------------- 1 | \name{mkLind} 2 | \alias{mkLind} 3 | \title{Make vector of indices giving the mapping from theta to Lambdat} 4 | \usage{ 5 | mkLind(nl, nc) 6 | } 7 | \description{ 8 | Make vector of indices giving the mapping from theta to 9 | Lambdat 10 | } 11 | 12 | -------------------------------------------------------------------------------- /man/mkRanefRepresentation.Rd: -------------------------------------------------------------------------------- 1 | \name{mkRanefRepresentation} 2 | \alias{mkRanefRepresentation} 3 | \title{Make random effects representation} 4 | \usage{ 5 | mkRanefRepresentation(grps, mms) 6 | } 7 | \arguments{ 8 | \item{grps}{List of factor vectors of length n indicating 9 | groups. Each element corresponds to a random effects 10 | term.} 11 | 12 | \item{mms}{List of model matrices. Each element 13 | corresponds to a random effects term.} 14 | } 15 | \value{ 16 | A \code{list} with: \itemize{ \item \code{Lambdat} 17 | Transformed relative covariance factor \item \code{Zt} 18 | Transformed random effects model matrix \item \code{theta} 19 | Vector of covariance parameters \item \code{lower} Vector 20 | of lower bounds on the covariance parameters \item 21 | \code{upper} Vector of upper bounds on the covariance 22 | parameters \item \code{thfun} A function that maps 23 | \code{theta} onto the non-zero elements of \code{Lambdat} } 24 | } 25 | \description{ 26 | Create all of the elements required to specify the 27 | random-effects structure of a mixed effects model. 28 | } 29 | \details{ 30 | The basic idea of this function is to call 31 | \code{\link{Zsection}} and \code{\link{blockLambdat}} once 32 | for each random effects term (ie. each list element in 33 | \code{grps} and \code{mms}). The results of 34 | \code{\link{Zsection}} for each term are \code{rBind}ed 35 | together. The results of \code{\link{blockLambdat}} are 36 | \code{bdiag}ed together, unless all terms have only a 37 | single column ('predictor') in which case a diagonal matrix 38 | is created directly. 39 | } 40 | 41 | -------------------------------------------------------------------------------- /man/mkRanefStructures.Rd: -------------------------------------------------------------------------------- 1 | \name{mkRanefStructures} 2 | \alias{mkRanefStructures} 3 | \title{Make random effects structures} 4 | \usage{ 5 | mkRanefStructures(grp, mm) 6 | } 7 | \arguments{ 8 | \item{grp}{List of grouping factors (one for each term)} 9 | 10 | \item{mm}{List of model matrices (one for each term)} 11 | } 12 | \description{ 13 | Make random effects structures 14 | } 15 | 16 | -------------------------------------------------------------------------------- /man/mkRanefStructuresCorr.Rd: -------------------------------------------------------------------------------- 1 | \name{mkRanefStructuresCorr} 2 | \alias{mkRanefStructuresCorr} 3 | \title{Make random effects structures for the single correlation template model} 4 | \usage{ 5 | mkRanefStructuresCorr(corr, grp, n) 6 | } 7 | \description{ 8 | Make random effects structures for the single correlation 9 | template model 10 | } 11 | 12 | -------------------------------------------------------------------------------- /man/mkTemplate.Rd: -------------------------------------------------------------------------------- 1 | \name{mkTemplate} 2 | \alias{mkTemplate} 3 | \title{Make a single template for a relative covariance factor} 4 | \usage{ 5 | mkTemplate(nc) 6 | } 7 | \arguments{ 8 | \item{nc}{Number of columns in a dense model matrix for a 9 | particular random effects term} 10 | } 11 | \description{ 12 | Make a single template for a relative covariance factor 13 | } 14 | \examples{ 15 | mkTemplate(5) 16 | } 17 | 18 | -------------------------------------------------------------------------------- /man/mkTemplates.Rd: -------------------------------------------------------------------------------- 1 | \name{mkTemplates} 2 | \alias{mkTemplates} 3 | \title{Make list of templates for relative covariance factor} 4 | \usage{ 5 | mkTemplates(nc) 6 | } 7 | \description{ 8 | Make list of templates for relative covariance factor 9 | } 10 | 11 | -------------------------------------------------------------------------------- /man/mkTheta.Rd: -------------------------------------------------------------------------------- 1 | \name{mkTheta} 2 | \alias{mkTheta} 3 | \title{Make initial theta from list of templates} 4 | \usage{ 5 | mkTheta(templates) 6 | } 7 | \description{ 8 | Make initial theta from list of templates 9 | } 10 | 11 | -------------------------------------------------------------------------------- /man/mkZt.Rd: -------------------------------------------------------------------------------- 1 | \name{mkZt} 2 | \alias{mkZt} 3 | \title{Make transposed random-effects model matrix} 4 | \usage{ 5 | mkZt(grp, mm) 6 | } 7 | \description{ 8 | Make transposed random-effects model matrix 9 | } 10 | 11 | -------------------------------------------------------------------------------- /man/mkZtSection.Rd: -------------------------------------------------------------------------------- 1 | \name{mkZtSection} 2 | \alias{mkZtSection} 3 | \title{Create a section of a transposed random effects model matrix} 4 | \usage{ 5 | mkZtSection(grp, mm) 6 | } 7 | \arguments{ 8 | \item{grp}{Grouping factor for a particular random 9 | effects term.} 10 | 11 | \item{mm}{Dense model matrix for a particular random 12 | effects term.} 13 | } 14 | \value{ 15 | Section of a random effects design matrix corresponding to 16 | a particular term. 17 | } 18 | \description{ 19 | Create a section of a transposed random effects model 20 | matrix 21 | } 22 | \examples{ 23 | ## consider a term (x | g) with: 24 | ## number of observations, n = 6 25 | ## number of levels, nl = 3 26 | ## number of columns ('predictors'), nc = 2 27 | (X <- cbind("(Intercept)"=1,x=1:6)) # an intercept in the first column 28 | # and 1:6 predictor in the other 29 | (g <- as.factor(letters[rep(1:3,2)])) # grouping factor 30 | nrow(X) # n = 6 31 | nrow(X) == length(g) # and consistent n between X and g 32 | ncol(X) # nc = 2 33 | nlevels(g) # nl = 3 34 | Zsection(g, X) 35 | } 36 | 37 | -------------------------------------------------------------------------------- /man/pirls.Rd: -------------------------------------------------------------------------------- 1 | \name{pirls} 2 | \alias{pirls} 3 | \title{Create an approximate deviance evaluation function for GLMMs using Laplace 4 | Must use the flexLambda branch of lme4} 5 | \usage{ 6 | pirls(X, y, Zt, Lambdat, thfun, theta, weights, offset = numeric(n), 7 | eta = numeric(n), family = binomial, tol = 10^-6, npirls = 30, 8 | nstephalf = 10, nAGQ = 1, verbose = 0L, ...) 9 | } 10 | \arguments{ 11 | \item{glmod}{output of \code{glFormula}} 12 | 13 | \item{y}{response} 14 | 15 | \item{eta}{linear predictor} 16 | 17 | \item{family}{a \code{glm} family object} 18 | 19 | \item{weights}{prior weights} 20 | 21 | \item{offset}{offset} 22 | 23 | \item{tol}{convergence tolerance} 24 | 25 | \item{npirls}{maximum number of iterations} 26 | 27 | \item{nAGQ}{either 0 (PIRLS for \code{u} and \code{beta}) 28 | or 1 (\code{u} only). currently no quadature is 29 | available} 30 | 31 | \item{verbose}{verbose} 32 | } 33 | \value{ 34 | A function for evaluating the GLMM Laplace approximated 35 | deviance 36 | } 37 | \description{ 38 | A pure \code{R} implementation of the penalized iteratively 39 | reweighted least squares (PIRLS) algorithm for computing 40 | generalized linear mixed model deviances. The purpose is to 41 | clarify how PIRLS works without having to read through C++ 42 | code, and as a sandbox for trying out modified versions of 43 | PIRLS. 44 | } 45 | \details{ 46 | \code{pirls1} is a convenience function for optimizing 47 | \code{pirls} under \code{nAGQ = 1}. In particular, it wraps 48 | \code{theta} and \code{beta} into a single argument 49 | \code{thetabeta}. 50 | } 51 | 52 | -------------------------------------------------------------------------------- /man/pls.Rd: -------------------------------------------------------------------------------- 1 | \name{pls} 2 | \alias{pls} 3 | \title{Create linear mixed model deviance function} 4 | \usage{ 5 | pls(X, y, Zt, Lambdat, thfun, weights, offset = numeric(n), REML = TRUE, 6 | ...) 7 | } 8 | \arguments{ 9 | \item{X}{fixed effects model matrix} 10 | 11 | \item{y}{response} 12 | 13 | \item{Zt}{transpose of the sparse model matrix for the 14 | random effects} 15 | 16 | \item{Lambdat}{upper triangular sparse Cholesky factor of 17 | the relative covariance matrix of the random effects} 18 | 19 | \item{thfun}{a function that takes a value of 20 | \code{theta} and produces the non-zero elements of 21 | \code{Lambdat}. The structure of \code{Lambdat} cannot 22 | change, only the numerical values} 23 | 24 | \item{weights}{prior weights} 25 | 26 | \item{offset}{offset} 27 | 28 | \item{REML}{calculate REML deviance?} 29 | 30 | \item{...}{additional arguments} 31 | } 32 | \value{ 33 | a function that evaluates the deviance or REML criterion 34 | } 35 | \description{ 36 | A pure \code{R} implementation of the penalized least 37 | squares (PLS) approach for computing linear mixed model 38 | deviances. The purpose is to clarify how PLS works without 39 | having to read through C++ code, and as a sandbox for 40 | trying out modifications to PLS. 41 | } 42 | \keyword{models} 43 | 44 | -------------------------------------------------------------------------------- /man/plsJSS.Rd: -------------------------------------------------------------------------------- 1 | \name{plsJSS} 2 | \alias{plsJSS} 3 | \title{Linear mixed model deviance function as it 4 | appears in the pseudocode of the JSS article} 5 | \usage{ 6 | plsJSS(X, y, Zt, Lambdat, mapping, weights, offset = numeric(n), 7 | REML = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{X}{fixed effects model matrix} 11 | 12 | \item{y}{response} 13 | 14 | \item{Zt}{transpose of the sparse model matrix for the 15 | random effects} 16 | 17 | \item{Lambdat}{upper triangular sparse Cholesky factor of 18 | the relative covariance matrix of the random effects} 19 | 20 | \item{mapping}{a function that takes a value of 21 | \code{theta} and produces the non-zero elements of 22 | \code{Lambdat}. The structure of \code{Lambdat} cannot 23 | change, only the numerical values} 24 | 25 | \item{weights}{prior weights} 26 | 27 | \item{offset}{offset} 28 | 29 | \item{REML}{calculate REML deviance?} 30 | 31 | \item{...}{additional arguments} 32 | } 33 | \value{ 34 | a function that evaluates the deviance or REML criterion 35 | } 36 | \description{ 37 | A pure \code{R} implementation of the penalized least 38 | squares (PLS) approach for computing linear mixed model 39 | deviances. The purpose is to clarify how PLS works without 40 | having to read through C++ code, and as a sandbox for 41 | trying out modifications to PLS. 42 | } 43 | \keyword{models} 44 | 45 | -------------------------------------------------------------------------------- /man/plsform.Rd: -------------------------------------------------------------------------------- 1 | \name{plsform} 2 | \alias{plsform} 3 | \title{Create the structure of a linear mixed model from formula/data specification} 4 | \usage{ 5 | plsform(formula, data, REML = TRUE, weights, offset, sparseX = FALSE, 6 | family = gaussian, ...) 7 | } 8 | \arguments{ 9 | \item{formula}{a two-sided model formula with 10 | random-effects terms and, optionally, fixed-effects 11 | terms.} 12 | 13 | \item{data}{a data frame in which to evaluate the 14 | variables from \code{form}} 15 | 16 | \item{REML}{calculate REML deviance?} 17 | 18 | \item{weights}{prior weights} 19 | 20 | \item{offset}{offset} 21 | 22 | \item{sparseX}{should X, the model matrix for the 23 | fixed-effects coefficients be sparse?} 24 | 25 | \item{...}{additional arguments} 26 | } 27 | \value{ 28 | a \code{list} with: \itemize{ \item \code{X} Fixed effects 29 | model matrix \item \code{y} Observed response vector \item 30 | \code{fr} Model frame \item \code{call} Matched call \item 31 | \code{REML} Logical indicating REML or not \item 32 | \code{weights} Prior weights or \code{NULL} \item 33 | \code{offset} Prior offset term or \code{NULL} \item 34 | \code{Zt} Transposed random effects model matrix \item 35 | \code{Lambdat} Transposed relative covariance factor \item 36 | \code{theta} Vector of covariance parameters \item 37 | \code{lower} Vector of lower bounds for \code{theta} \item 38 | \code{upper} Vector of upper bounds for \code{theta} \item 39 | \code{thfun} A function that maps \code{theta} into the 40 | structural non-zero elements of \code{Lambdat}, which are 41 | stored in \code{slot(Lambdat, 'x')} } 42 | } 43 | \description{ 44 | A pure \code{R} implementation of the penalized least 45 | squares (PLS) approach to evaluation of the deviance or the 46 | REML criterion for linear mixed-effects models. 47 | } 48 | \examples{ 49 | form <- Reaction ~ Days + (Days|Subject) 50 | data(sleepstudy, package="lme4") 51 | ll <- plsform(form, sleepstudy, REML=FALSE) 52 | names(ll) 53 | } 54 | \keyword{models} 55 | 56 | -------------------------------------------------------------------------------- /man/rLmer.Rd: -------------------------------------------------------------------------------- 1 | \name{rLmer} 2 | \alias{rLmer} 3 | \title{Random lmer-type model simulation} 4 | \usage{ 5 | rLmer(grp, mmRE, mmFE) 6 | } 7 | \description{ 8 | Random lmer-type model simulation 9 | } 10 | 11 | -------------------------------------------------------------------------------- /tests/Contraception.R: -------------------------------------------------------------------------------- 1 | options(show.signif.stars = FALSE) 2 | library(lme4) 3 | library(mlmRev) 4 | library(lme4pureR) 5 | Contraception <- within(Contraception, ch <- factor(as.numeric(as.integer(livch)>1L))) 6 | form <- use ~ age + I(age^2) + ch + urban + (1|district) 7 | gm0 <- glm(nobars(form), binomial, Contraception) 8 | print(summary(gm0), corr=FALSE) 9 | ## Call: glm(formula = nobars(form), family = binomial, data = Contraception) 10 | 11 | ## Deviance Residuals: 12 | ## Min 1Q Median 3Q Max 13 | ## -1.454 -1.037 -0.668 1.238 1.979 14 | 15 | ## Coefficients: 16 | ## Estimate Std. Error z value Pr(>|z|) 17 | ## (Intercept) -0.942935 0.149730 -6.30 3.0e-10 18 | ## age 0.004967 0.007589 0.65 0.51 19 | ## I(age^2) -0.004328 0.000692 -6.26 4.0e-10 20 | ## ch1 0.806217 0.142262 5.67 1.5e-08 21 | ## urbanY 0.766362 0.105946 7.23 4.7e-13 22 | 23 | ## (Dispersion parameter for binomial family taken to be 1) 24 | 25 | ## Null deviance: 2590.9 on 1933 degrees of freedom 26 | ## Residual deviance: 2417.9 on 1929 degrees of freedom 27 | ## AIC: 2428 28 | 29 | ## Number of Fisher Scoring iterations: 4 30 | 31 | dput(deviance(gm0)) # 2417.86412239273 32 | logLik(gm0) # -1208.93206119637 33 | beta0 <- coef(gm0) 34 | 35 | # gm1 <- glmer(form, Contraception, binomial, nAGQ=1L) 36 | ## Generalized linear mixed model fit by maximum likelihood ['summary.merMod'] 37 | ## Family: binomial ( logit ) 38 | ## Formula: use ~ age + I(age^2) + ch + urban + (1 | district) 39 | ## Data: Contraception 40 | 41 | ## AIC BIC logLik deviance 42 | ## 2385.19 2418.59 -1186.59 2373.19 43 | 44 | ## Random effects: 45 | ## Groups Name Variance Std.Dev. 46 | ## district (Intercept) 0.225 0.474 47 | ## Number of obs: 1934, groups: district, 60 48 | 49 | ## Fixed effects: 50 | ## Estimate Std. Error z value Pr(>|z|) 51 | ## (Intercept) -1.006374 0.167892 -5.99 2.0e-09 52 | ## age 0.006256 0.007840 0.80 0.42 53 | ## I(age^2) -0.004635 0.000716 -6.47 9.7e-11 54 | ## ch1 0.860382 0.147353 5.84 5.3e-09 55 | ## urbanY 0.692922 0.119668 5.79 7.0e-09 56 | 57 | glmod <- glFormula(form, Contraception, binomial) 58 | #devf <- pirls(glmod, gm0$y, gm0$linear.predictor) 59 | devf <- pirls(glmod$X,gm0$y,glmod$reTrms$Zt,glmod$reTrms$Lambdat, 60 | glmod$reTrms$thfun,glmod$reTrms$theta, 61 | weights = weights(gm0), 62 | family=binomial) 63 | devf(c(1,beta0)) 64 | beta1 <- c(-1.00637368953914, 0.00625611018864605, -0.00463527887823825, 0.860382098849009, 0.692921941313297) 65 | theta1 <- 0.473985228740739 66 | devf(c(theta1,beta1)) 67 | # deviance(gm1) # 2373.18581907321 68 | # head(getME(gm1,"u")) # c(-1.56655252109295, -0.0451095377205166, 69 | # 0.453409972754753, 0.35265189198274, 0.252723822217955, -0.504481434155787) 70 | # head(getME(gm1, "mu")) # c(0.16025103705494, 0.225473461055359, 71 | # 0.451107632834752, 0.383912222123962, 0.119942471057264, 0.148334820475519) 72 | 73 | form1 <- use ~ age + I(age^2) + ch + urban + (1|district) + (1|district:urban) 74 | 75 | ## > print(summary(gm2 <- glmer(form1,Contraception,binomial)), corr=FALSE) 76 | ## Generalized linear mixed model fit by maximum likelihood ['summary.merMod'] 77 | ## Family: binomial ( logit ) 78 | ## Formula: use ~ age + I(age^2) + ch + urban + (1 | district) + (1 | district:urban) 79 | ## Data: Contraception 80 | 81 | ## AIC BIC logLik deviance 82 | ## 2375.88 2414.85 -1180.94 2361.88 83 | 84 | ## Random effects: 85 | ## Groups Name Variance Std.Dev. 86 | ## district:urban (Intercept) 0.31863 0.5645 87 | ## district (Intercept) 0.00715 0.0845 88 | ## Number of obs: 1934, groups: district:urban, 102; district, 60 89 | 90 | ## Fixed effects: 91 | ## Estimate Std. Error z value Pr(>|z|) 92 | ## (Intercept) -1.032745 0.175593 -5.88 4.1e-09 93 | ## age 0.005876 0.007935 0.74 0.46 94 | ## I(age^2) -0.004537 0.000724 -6.26 3.8e-10 95 | ## ch1 0.872691 0.149028 5.86 4.7e-09 96 | ## urbanY 0.764670 0.169725 4.51 6.6e-06 97 | 98 | beta2 <- c(-1.03274535458238, 0.00587602227525672, -0.0045372320199417, 99 | 0.872690858261632, 0.764670407439094) 100 | theta2 <- c(0.564472021994911, 0.0845334785825269) 101 | 102 | ## dput(head(unname(getME(gm2,"u")))) 103 | ## c(-1.60622219325897, -0.981855964992823, -0.0339024704692014, 104 | ## 0.505250674118111, -0.428344594466731, 1.10122436874433) 105 | 106 | ## dput(head(unname(getME(gm2,"mu")))) 107 | ## c(0.195157958203462, 0.26347290296241, 0.504168959587931, 0.436350391068322, 108 | ## 0.145679693412778, 0.178092903689705) 109 | 110 | form2 <- use ~ age + I(age^2) + ch + urban + (1 | district:urban) 111 | 112 | ## print(summary(gm3 <- glmer(form2,Contraception,binomial)), corr=FALSE) 113 | ## Generalized linear mixed model fit by maximum likelihood ['summary.merMod'] 114 | ## Family: binomial ( logit ) 115 | ## Formula: use ~ age + I(age^2) + ch + urban + (1 | district:urban) 116 | ## Data: Contraception 117 | 118 | ## AIC BIC logLik deviance 119 | ## 2373.88 2407.29 -1180.94 2361.88 120 | 121 | ## Random effects: 122 | ## Groups Name Variance Std.Dev. 123 | ## district:urban (Intercept) 0.327 0.572 124 | ## Number of obs: 1934, groups: district:urban, 102 125 | 126 | ## Fixed effects: 127 | ## Estimate Std. Error z value Pr(>|z|) 128 | ## (Intercept) -1.032829 0.175651 -5.88 4.1e-09 129 | ## age 0.005862 0.007935 0.74 0.46 130 | ## I(age^2) -0.004535 0.000724 -6.26 3.9e-10 131 | ## ch1 0.872716 0.149034 5.86 4.7e-09 132 | ## urbanY 0.766667 0.170601 4.49 7.0e-06 133 | 134 | beta3 <- c(-1.03282920682185, 0.00586163322902896, -0.00453480196155543, 135 | 0.872715839072072, 0.766667032721774) 136 | theta3 <- 0.571568547571509 137 | 138 | ## dput(head(unname(getME(gm3,"mu")))) 139 | ## c(0.195804532044805, 0.264187372529822, 0.505051933870551, 0.43723605274129, 140 | ## 0.146198921135808, 0.178681337173397) 141 | 142 | ## dput(head(unname(getME(gm3,"u")))) 143 | ## c(-1.63882047908625, -1.02416872093547, -0.0343530888451908, 144 | ## 0.510937117406129, -0.419566092717808, 1.10846888333543) 145 | -------------------------------------------------------------------------------- /tests/cbpp.R: -------------------------------------------------------------------------------- 1 | library(lme4) 2 | library(minqa) 3 | library(lme4pureR) 4 | 5 | # model structure 6 | form <- cbind(incidence, size - incidence) ~ period + (1 | herd) 7 | glmod <- glFormula(form, cbpp, binomial) 8 | do.call(mkGlmerDevfun, glmod) 9 | data(cbpp, package = 'lme4') 10 | ll <- plsform(form, data = cbpp, family = binomial) 11 | devf <- do.call(pirls, c(ll, list(family=binomial))) 12 | devf(c(1,0,0,0,0)) 13 | (opt <- bobyqa(c(1,0,0,0,0), devf)) 14 | 15 | # get initial values 16 | gm1 <- glm(nobars(form), binomial, cbpp) 17 | weights <- weights(gm1) 18 | beta0 <- coef(gm1) 19 | ratios <- gm1$y 20 | eta <- gm1$linear.predictors 21 | 22 | # create deviance function with `lme4pureR` 23 | #devf <- pirls(glmod, ratios, binomial(), weights=weights, eta=eta, nAGQ=1) 24 | devf <- pirls(glmod$X,ratios,glmod$reTrms$Zt,glmod$reTrms$Lambdat, 25 | glmod$reTrms$thfun,glmod$reTrms$theta, 26 | weights=weights,eta=eta,family=binomial) 27 | 28 | # run `bobyqa` 29 | bobyqa(c(1,beta0), devf, lower=c(0,rep.int(-Inf,length(beta0))))$par 30 | -------------------------------------------------------------------------------- /tests/pirls.R: -------------------------------------------------------------------------------- 1 | library(lme4pureR) 2 | library(minqa) 3 | glmerReproduce <- FALSE 4 | tol <- 1e-3 5 | 6 | form <- cbind(incidence, size - incidence) ~ period + (1 | herd) 7 | data(cbpp, package = 'lme4') 8 | ll <- plsform(form, data = cbpp, family = binomial) 9 | devf <- do.call(pirls, c(ll, list(family=binomial))) 10 | rho <- environment(devf) 11 | opt <- minqa:::bobyqa(c(ll$theta, rho$beta), devf) 12 | if(glmerReproduce){ 13 | mML <- lme4::glmer(form, data = cbpp, family = binomial) 14 | par <- unname(c(lme4::getME(mML, "theta"), getME(mML, "beta"))) 15 | fval <- deviance(mML) 16 | } else{ 17 | par <- c(0.6420622, -1.3983429, -0.9919250, -1.1282162, -1.5797454) 18 | fval <- 184.0531 19 | } 20 | all.equal(par, opt$par, tolerance = tol) 21 | all.equal(fval, opt$fval, tolerance = tol) 22 | 23 | options(show.signif.stars = FALSE) 24 | form <- use ~ age + I(age^2) + ch + urban + (1|district) 25 | data(Contraception, package = 'mlmRev') 26 | Contraception <- within(Contraception, ch <- factor(as.numeric(as.integer(livch)>1L))) 27 | glm0 <- glm(lme4:::nobars(form),binomial,Contraception) 28 | ll <- plsform(form, data = Contraception, family = binomial) 29 | devf <- do.call(pirls, c(ll, list(family=binomial,eta=glm0$linear.predictor, tol=1e-6))) 30 | rho <- environment(devf) 31 | 32 | if(FALSE){ # FIXME: why step-halving problem? 33 | opt <- minqa:::bobyqa(c(ll$theta, rho$beta), devf) 34 | opt <- minqa:::bobyqa(c(ll$theta, coef(glm0)), devf) 35 | opt <- minqa:::bobyqa(opt$par, devf) 36 | } 37 | 38 | form <- use ~ age + I(age^2) + ch + urban + (1|district) 39 | data(Contraception, package = 'mlmRev') 40 | Contraception <- within(Contraception, ch <- factor(as.numeric(as.integer(livch)>1L))) 41 | glm0 <- glm(lme4:::nobars(form),binomial,Contraception) 42 | ll <- plsform(form, data = Contraception, family = binomial) 43 | devf <- do.call(pirls, c(ll, list(family=binomial,eta=glm0$linear.predictor, tol=1e-6))) 44 | 45 | #body(devf)[8] <- parse("olducden <- updatemu(u); print(ucden); print(olducden)") 46 | #body(devf)[7:9] <- parse(text = "olducden <- updatemu(u); print(ucden); print(olducden)") 47 | paropt <- c(0.474010082, -1.006445615, 0.006255540, -0.004635385, 0.860439478, 0.692959336) 48 | devf(paropt) 49 | if(FALSE) opt <- minqa:::bobyqa(paropt, devf) # FIXME: step-halving again 50 | devf(paropt) 51 | 52 | library(lme4) 53 | glmer0 <- glmer(form, data = Contraception, family = binomial, nAGQ = 0) 54 | ll <- plsform(form, data = Contraception, family = binomial) 55 | devf <- do.call(pirls, c(ll, list(family=binomial,eta=qlogis(getME(glmer0, 'mu')), verbose=2L))) 56 | if(FALSE) opt <- minqa:::bobyqa(c(glmer0@theta,glmer0@beta), devf) #FIXME 57 | 58 | 59 | 60 | glmer0 <- glmer(form, data = Contraception, family = binomial, nAGQ = 0) 61 | ll <- plsform(form, data = Contraception, family = binomial) 62 | devf <- do.call(pirls, c(ll, list(family=binomial,eta=qlogis(getME(glmer0, 'mu')), tol=1e-6))) 63 | if(FALSE) opt <- minqa:::bobyqa(c(glmer0@theta,glmer0@beta), devf) # FIXME 64 | 65 | gmod <- glFormula(form, data = Contraception, family = binomial, nAGQ = 1) 66 | devf <- do.call(mkGlmerDevfun, gmod) 67 | devf <- updateGlmerDevfun(devf, gmod$reTrms) 68 | optimizeGlmer(devf, stage=2)$par 69 | 70 | form1 <- use ~ age + I(age^2) + ch + urban + (1|district) + (1|district:urban) 71 | 72 | ## > print(summary(gm2 <- glmer(form1,Contraception,binomial)), corr=FALSE) 73 | ## Generalized linear mixed model fit by maximum likelihood ['summary.merMod'] 74 | ## Family: binomial ( logit ) 75 | ## Formula: use ~ age + I(age^2) + ch + urban + (1 | district) + (1 | district:urban) 76 | ## Data: Contraception 77 | 78 | ## AIC BIC logLik deviance 79 | ## 2375.88 2414.85 -1180.94 2361.88 80 | 81 | ## Random effects: 82 | ## Groups Name Variance Std.Dev. 83 | ## district:urban (Intercept) 0.31863 0.5645 84 | ## district (Intercept) 0.00715 0.0845 85 | ## Number of obs: 1934, groups: district:urban, 102; district, 60 86 | 87 | ## Fixed effects: 88 | ## Estimate Std. Error z value Pr(>|z|) 89 | ## (Intercept) -1.032745 0.175593 -5.88 4.1e-09 90 | ## age 0.005876 0.007935 0.74 0.46 91 | ## I(age^2) -0.004537 0.000724 -6.26 3.8e-10 92 | ## ch1 0.872691 0.149028 5.86 4.7e-09 93 | ## urbanY 0.764670 0.169725 4.51 6.6e-06 94 | 95 | beta2 <- c(-1.03274535458238, 0.00587602227525672, -0.0045372320199417, 96 | 0.872690858261632, 0.764670407439094) 97 | theta2 <- c(0.564472021994911, 0.0845334785825269) 98 | 99 | ## dput(head(unname(getME(gm2,"u")))) 100 | ## c(-1.60622219325897, -0.981855964992823, -0.0339024704692014, 101 | ## 0.505250674118111, -0.428344594466731, 1.10122436874433) 102 | 103 | ## dput(head(unname(getME(gm2,"mu")))) 104 | ## c(0.195157958203462, 0.26347290296241, 0.504168959587931, 0.436350391068322, 105 | ## 0.145679693412778, 0.178092903689705) 106 | 107 | form2 <- use ~ age + I(age^2) + ch + urban + (1 | district:urban) 108 | 109 | ## print(summary(gm3 <- glmer(form2,Contraception,binomial)), corr=FALSE) 110 | ## Generalized linear mixed model fit by maximum likelihood ['summary.merMod'] 111 | ## Family: binomial ( logit ) 112 | ## Formula: use ~ age + I(age^2) + ch + urban + (1 | district:urban) 113 | ## Data: Contraception 114 | 115 | ## AIC BIC logLik deviance 116 | ## 2373.88 2407.29 -1180.94 2361.88 117 | 118 | ## Random effects: 119 | ## Groups Name Variance Std.Dev. 120 | ## district:urban (Intercept) 0.327 0.572 121 | ## Number of obs: 1934, groups: district:urban, 102 122 | 123 | ## Fixed effects: 124 | ## Estimate Std. Error z value Pr(>|z|) 125 | ## (Intercept) -1.032829 0.175651 -5.88 4.1e-09 126 | ## age 0.005862 0.007935 0.74 0.46 127 | ## I(age^2) -0.004535 0.000724 -6.26 3.9e-10 128 | ## ch1 0.872716 0.149034 5.86 4.7e-09 129 | ## urbanY 0.766667 0.170601 4.49 7.0e-06 130 | 131 | beta3 <- c(-1.03282920682185, 0.00586163322902896, -0.00453480196155543, 132 | 0.872715839072072, 0.766667032721774) 133 | theta3 <- 0.571568547571509 134 | 135 | ## dput(head(unname(getME(gm3,"mu")))) 136 | ## c(0.195804532044805, 0.264187372529822, 0.505051933870551, 0.43723605274129, 137 | ## 0.146198921135808, 0.178681337173397) 138 | 139 | ## dput(head(unname(getME(gm3,"u")))) 140 | ## c(-1.63882047908625, -1.02416872093547, -0.0343530888451908, 141 | ## 0.510937117406129, -0.419566092717808, 1.10846888333543) 142 | -------------------------------------------------------------------------------- /tests/pls.R: -------------------------------------------------------------------------------- 1 | library(lme4pureR) 2 | library(minqa) 3 | lmerReproduce <- FALSE 4 | tol <- 1e-3 5 | 6 | # sleepstudy 7 | form <- Reaction ~ Days + (Days|Subject) 8 | data(sleepstudy, package="lme4") 9 | ll <- plsform(form, data = sleepstudy, REML=FALSE) 10 | devf <- do.call(pls, ll) 11 | opt <- minqa::bobyqa(ll$theta, devf, ll$lower, ll$upper)[c("par","fval")] 12 | if(lmerReproduce){ 13 | mML <- lme4::lmer(form, sleepstudy, REML=FALSE) 14 | par <- unname(lme4::getME(mML, "theta")) 15 | fval <- deviance(mML) 16 | } else{ 17 | par <- c(0.92922239, 0.01816504, 0.22264528) 18 | fval <- 1751.939 19 | } 20 | all.equal(par, opt$par, tolerance = tol) 21 | all.equal(fval, opt$fval, tolerance = tol) 22 | 23 | 24 | # Pastes 25 | form <- strength ~ (1|sample) + (1|batch) 26 | data(Pastes, package="lme4") 27 | ll <- plsform(form, data = Pastes, REML=FALSE) 28 | devf <- do.call(pls, ll) 29 | opt <- minqa::bobyqa(ll$theta, devf, ll$lower, ll$upper)[c("par","fval")] 30 | if(lmerReproduce){ 31 | mML <- lme4::lmer(form, Pastes, REML=FALSE) 32 | par <- unname(lme4::getME(mML, "theta")) 33 | fval <- deviance(mML) 34 | } else{ 35 | par <- c(3.526904, 1.329914) 36 | fval <- 247.9945 37 | } 38 | all.equal(par, opt$par, tolerance = tol) 39 | all.equal(fval, opt$fval, tolerance = tol) 40 | 41 | # Dyestuff 42 | form <- Yield ~ 1|Batch 43 | data(Dyestuff,package="lme4") 44 | ll <- plsform(form, data = Dyestuff, REML=FALSE) 45 | devf <- do.call(pls, ll) 46 | opt <- minqa::bobyqa(ll$theta, devf, ll$lower, ll$upper)[c("par","fval")] 47 | if(lmerReproduce){ 48 | mML <- lme4::lmer(form, Dyestuff, REML=FALSE) 49 | par <- unname(lme4::getME(mML, "theta")) 50 | fval <- deviance(mML) 51 | } else{ 52 | par <- 0.7525807 53 | fval <- 327.3271 54 | } 55 | all.equal(par, opt$par, tolerance = tol) 56 | all.equal(fval, opt$fval, tolerance = tol) 57 | -------------------------------------------------------------------------------- /tests/sleep.R: -------------------------------------------------------------------------------- 1 | library(lme4pureR) 2 | 3 | ## only *one* of these two ? 4 | library(nloptwrap) 5 | library(minqa) 6 | 7 | ## library(lme4) 8 | data(sleepstudy, package="lme4") 9 | lmod <- lme4::lFormula(Reaction ~ Days + (Days|Subject), sleepstudy) 10 | 11 | devf <- pls(lmod,sleepstudy$Reaction) 12 | bobyqa(c(1, 0, 1), devf, lower=c(0,-Inf,0))[c("par","value")] 13 | mML <- lme4::lmer(Reaction ~ Days + (Days|Subject), 14 | sleepstudy, REML = FALSE) 15 | lme4::getME(mML, "theta") 16 | lme4::deviance(mML) 17 | --------------------------------------------------------------------------------