#' Marginal and conditional r-squared for merMod objects
#'
#' This method extracts the variance for fixed and random effects, residuals,
#' and the fixed effects for the null model (in the case of Poisson family),
#' and calls \code{\link{.rsquared.glmm}}
#'
#' @param mdl an merMod model (usually fit using \code{\link{lme4::lmer}},
#' \code{\link{lme4::glmer}}, \code{\link{lmerTest::lmer}},
#' \code{\link{blme::blmer}}, \code{\link{blme::bglmer}}, etc)
#' @export
r.squared.merMod <- function(mdl){
# Get variance of fixed effects by multiplying coefficients by design matrix
VarF <- var(as.vector(lme4::fixef(mdl) %*% t(mdl@pp$X)))
# Get variance of random effects by extracting variance components
# Omit random effects at the observation level, variance is factored in later
VarRand <- sum(
sapply(
VarCorr(mdl)[!sapply(unique(unlist(strsplit(names(ranef(mdl)),":|/"))), function(l) length(unique(mdl@frame[,l])) == nrow(mdl@frame))],
function(Sigma) {
X <- model.matrix(mdl)
Z <- X[,rownames(Sigma)]
sum(diag(Z %*% Sigma %*% t(Z)))/nrow(X) } ) )
# Get the dispersion variance
VarDisp <- unlist(VarCorr(mdl)[sapply(unique(unlist(strsplit(names(ranef(mdl)),":|/"))), function(l) length(unique(mdl@frame[,l])) == nrow(mdl@frame))])
if(is.null(VarDisp)) VarDisp = 0 else VarDisp = VarDisp
if(inherits(mdl, "lmerMod")){
# Get residual variance
VarResid <- attr(lme4::VarCorr(mdl), "sc")^2
# Get ML model AIC
mdl.aic <- AIC(update(mdl, REML=F))
# Model family for lmer is gaussian
family <- "gaussian"
# Model link for lmer is identity
link <- "identity"
}
else if(inherits(mdl, "glmerMod")){
# Get the model summary
mdl.summ <- summary(mdl)
# Get the model's family, link and AIC
family <- mdl.summ$family
link <- mdl.summ$link
mdl.aic <- AIC(mdl)
# Pseudo-r-squared for poisson also requires the fixed effects of the null model
if(family=="poisson") {
# Get random effects names to generate null model
rand.formula <- reformulate(sapply(findbars(formula(mdl)),
function(x) paste0("(", deparse(x), ")")),
response=".")
# Generate null model (intercept and random effects only, no fixed effects)
null.mdl <- update(mdl, rand.formula)
# Get the fixed effects of the null model
null.fixef <- as.numeric(lme4::fixef(null.mdl))
}
}
# Call the internal function to do the pseudo r-squared calculations
.rsquared.glmm(VarF, VarRand, VarResid, VarDisp, family = family, link = link,
mdl.aic = mdl.aic,
mdl.class = class(mdl),
null.fixef = null.fixef)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.