Better handling of outlist='minimal'.

DESCRIPTION

@@ -1,10 +1,10 @@
 Package: metafor
-Version: 4.7-31
-Date: 2024-09-11
+Version: 4.7-32
+Date: 2024-09-15
 Title: Meta-Analysis Package for R
 Authors@R: person(given = "Wolfgang", family = "Viechtbauer", role = c("aut","cre"), email = "wvb@metafor-project.org", comment = c(ORCID = "0000-0003-3463-4063"))
 Depends: R (>= 4.0.0), methods, Matrix, metadat, numDeriv
-Imports: stats, utils, graphics, grDevices, nlme, mathjaxr, pbapply
+Imports: stats, utils, graphics, grDevices, nlme, mathjaxr, pbapply, digest
 Suggests: lme4, pracma, minqa, nloptr, dfoptim, ucminf, lbfgsb3c, subplex, BB, Rsolnp, alabama, optimParallel, optimx, CompQuadForm, mvtnorm, BiasedUrn, Epi, survival, GLMMadaptive, glmmTMB, car, multcomp, gsl, sp, ape, boot, clubSandwich, crayon, R.rsp, testthat, rmarkdown, wildmeta, emmeans, estmeansd, metaBLUE, rstudioapi, glmulti, MuMIn, mice, Amelia
 Description: A comprehensive collection of functions for conducting meta-analyses in R. The package includes functions to calculate various effect sizes or outcome measures, fit equal-, fixed-, random-, and mixed-effects models to such data, carry out moderator and meta-regression analyses, and create various types of meta-analytical plots (e.g., forest, funnel, radial, L'Abbe, Baujat, bubble, and GOSH plots). For meta-analyses of binomial and person-time data, the package also provides functions that implement specialized methods, including the Mantel-Haenszel method, Peto's method, and a variety of suitable generalized linear (mixed-effects) models (i.e., mixed-effects logistic and Poisson regression models). Finally, the package provides functionality for fitting meta-analytic multivariate/multilevel models that account for non-independent sampling errors and/or true effects (e.g., due to the inclusion of multiple treatment studies, multiple endpoints, or other forms of clustering). Network meta-analyses and meta-analyses accounting for known correlation structures (e.g., due to phylogenetic relatedness) can also be conducted. An introduction to the package can be found in Viechtbauer (2010) <doi:10.18637/jss.v036.i03>.
 License: GPL (>=2)

NAMESPACE

@@ -11,6 +11,7 @@ export(ranef)
 import(mathjaxr)
 import(metadat)
 import(numDeriv)
+import(digest)
 
 S3method("[", list.rma)
 S3method("$<-", list.rma)

NEWS.md

@@ -1,4 +1,4 @@
-# metafor 4.7-31 (2024-09-11)
+# metafor 4.7-32 (2024-09-15)
 
 - some general changes to the various `forest()` functions: argument `header` is now `TRUE` by default, the y-axis is now created with `yaxs="i"`, and the y-axis limits have been tweaked slightly in accordance
 
@@ -44,6 +44,8 @@
 
 - some tweaks were made to `vcalc()` to speed up the calculations (by James Pustejovsky)
 
+- better handling of `outlist="minimal"`
+
 - added more tests
 
 # metafor 4.6-0 (2024-03-28)

R/AIC.rma.r

@@ -39,9 +39,9 @@ AIC.rma <- function(object, ..., k=2, correct=FALSE) {
 
       ### check that all models were fitted to the same data
 
-      yis <- lapply(list(object, ...), function(x) as.vector(x$yi))
+      chksums <- sapply(list(object, ...), function(x) x$chksumyi)
 
-      if (!all(sapply(yis[-1], function(x) identical(x, yis[[1]]))))
+      if (any(chksums[1] != chksums))
          warning(mstyle$warning("Models not all fitted to the same data."), call.=FALSE)
 
    }

R/BIC.rma.r

@@ -34,9 +34,9 @@ BIC.rma <- function(object, ...) {
 
       ### check that all models were fitted to the same data
 
-      yis <- lapply(list(object, ...), function(x) as.vector(x$yi))
+      chksums <- sapply(list(object, ...), function(x) x$chksumyi)
 
-      if (!all(sapply(yis[-1], function(x) identical(x, yis[[1]]))))
+      if (any(chksums[1] != chksums))
          warning(mstyle$warning("Models not all fitted to the same data."), call.=FALSE)
 
    }

R/anova.rma.r

@@ -527,21 +527,21 @@ anova.rma <- function(object, object2, btt, X, att, Z, rhs, adjust, digits, refi
       ###       isTRUE(all.equal()) because conversion to non-sparse can introduce some negligible discrepancies
 
       if (inherits(object, "rma.uni")) {
-         if (!(identical(as.vector(model.f$yi), as.vector(model.r$yi)) && isTRUE(all.equal(as.vector(model.f$vi), as.vector(model.r$vi)))))
+         if (!identical(model.f$chksumyi, model.r$chksumyi) || !identical(model.f$chksumvi, model.r$chksumvi))
             stop(mstyle$stop("The observed outcomes and/or sampling variances are not equal in the full and reduced model."))
       }
 
       if (is.null(df)) {
 
          if (inherits(object, "rma.mv")) {
-            if (!(identical(as.vector(model.f$yi), as.vector(model.r$yi)) && isTRUE(all.equal(as.matrix(model.f$V), as.matrix(model.r$V)))))
+            if (!identical(model.f$chksumyi, model.r$chksumyi) || !identical(model.f$chksumV, model.r$chksumV))
                stop(mstyle$stop("The observed outcomes and/or sampling variances/covariances are not equal in the full and reduced model."))
          }
 
       } else {
 
          if (inherits(object, "rma.mv")) {
-            if (!(identical(as.vector(model.f$yi), as.vector(model.r$yi))))
+            if (!(identical(model.f$chksumyi, model.r$chksumyi)))
                stop(mstyle$stop("The observed outcomes are not equal in the full and reduced model."))
          }
 
@@ -569,7 +569,7 @@ anova.rma <- function(object, object2, btt, X, att, Z, rhs, adjust, digits, refi
 
       ### for LRTs based on REML estimation, check if fixed effects differ
 
-      if (test == "LRT" && model.f$method == "REML" && (!identical(model.f$X, model.r$X))) {
+      if (test == "LRT" && model.f$method == "REML" && !identical(model.f$chksumX, model.r$chksumX)) {
          if (refit) {
             #message(mstyle$message("Refitting models with ML (instead of REML) estimation ..."))
             if (inherits(model.f, "rma.uni") && model.f$model == "rma.uni") {

R/baujat.rma.r

@@ -13,6 +13,9 @@ baujat.rma <- function(x, xlim, ylim, xlab, ylab, cex, symbol="ids", grid=TRUE,
    if (x$k == 1L)
       stop(mstyle$stop("Stopped because k = 1."))
 
+   if (is.null(x$X.f))
+      stop(mstyle$stop("Information needed to construct the plot is not available in the model object."))
+
    .start.plot()
 
    ### grid argument can either be a logical or a color

R/blup.rma.uni.r

@@ -9,6 +9,9 @@ blup.rma.uni <- function(x, level, digits, transf, targs, ...) {
    if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass")))
       stop(mstyle$stop("Unknown 'na.action' specified under options()."))
 
+   if (is.null(x$X.f) || is.null(x$yi.f))
+      stop(mstyle$stop("Information needed to compute the BLUPs is not available in the model object."))
+
    if (missing(level))
       level <- x$level
 

R/confint.rma.uni.r

@@ -18,12 +18,12 @@ confint.rma.uni <- function(object, parm, level, fixed=FALSE, random=TRUE, type,
 
    x <- object
 
-   k <- x$k
-   p <- x$p
+   k  <- x$k
+   p  <- x$p
    yi <- x$yi
    vi <- x$vi
-   X <- x$X
-   Y <- cbind(yi)
+   X  <- x$X
+   Y  <- cbind(yi)
    weights <- x$weights
 
    if (missing(level))

R/fitstats.rma.r

@@ -47,8 +47,9 @@ fitstats.rma <- function(object, ..., REML) {
 
       ### check that all models were fitted to the same data
 
-      yis <- lapply(list(object, ...), function(x) as.vector(x$yi))
-      if (!all(sapply(yis[-1], function(x) identical(x, yis[[1]]))))
+      chksums <- sapply(list(object, ...), function(x) x$chksumyi)
+
+      if (any(chksums[1] != chksums))
          warning(mstyle$warning("Models not all fitted to the same data."), call.=FALSE)
 
    }

R/fitted.rma.r

@@ -9,6 +9,9 @@ fitted.rma <- function(object, ...) {
    if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass")))
       stop(mstyle$stop("Unknown 'na.action' specified under options()."))
 
+   if (is.null(object$X.f))
+      stop(mstyle$stop("Information needed to compute the fitted values is not available in the model object."))
+
    ### note: fitted values can be calculated for all studies including those that
    ### have NA on yi/vi (and with "na.pass" these will be provided); but if there
    ### is an NA in the X's, then the fitted value will also be NA

R/forest.rma.r

@@ -18,6 +18,9 @@ lty, fonts, cex, cex.lab, cex.axis, ...) {
    if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass")))
       stop(mstyle$stop("Unknown 'na.action' specified under options()."))
 
+   if (is.null(x$yi.f) || is.null(x$vi.f) || is.null(x$X.f))
+      stop(mstyle$stop("Information needed to construct the plot is not available in the model object."))
+
    if (missing(transf))
       transf <- FALSE
 

R/funnel.rma.r

@@ -13,6 +13,9 @@ label=FALSE, offset=0.4, legend=FALSE, ...) {
    na.act <- getOption("na.action")
    on.exit(options(na.action=na.act), add=TRUE)
 
+   if (is.null(x$yi) || is.null(x$vi))
+      stop(mstyle$stop("Information needed to construct the plot is not available in the model object."))
+
    yaxis <- match.arg(yaxis, c("sei", "vi", "seinv", "vinv", "ni", "ninv", "sqrtni", "sqrtninv", "lni", "wi"))
    type  <- match.arg(type,  c("rstandard", "rstudent"))
 

R/gosh.rma.r

@@ -9,6 +9,9 @@ gosh.rma <- function(x, subsets, progbar=TRUE, parallel="no", ncpus=1, cl, ...)
    if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass")))
       stop(mstyle$stop("Unknown 'na.action' specified under options()."))
 
+   if (is.null(x$yi) || is.null(x$vi))
+      stop(mstyle$stop("Information needed to construct the plot is not available in the model object."))
+
    if (x$k == 1L)
       stop(mstyle$stop("Stopped because k = 1."))
 

R/hatvalues.rma.mv.r

@@ -9,6 +9,9 @@ hatvalues.rma.mv <- function(model, type="diagonal", ...) {
    if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass")))
       stop(mstyle$stop("Unknown 'na.action' specified under options()."))
 
+   if (is.null(model$M) || is.null(model$X))
+      stop(mstyle$stop("Information needed to compute the hat values is not available in the model object."))
+
    type <- match.arg(type, c("diagonal", "matrix"))
 
    #########################################################################

R/hatvalues.rma.uni.r

@@ -9,6 +9,9 @@ hatvalues.rma.uni <- function(model, type="diagonal", ...) {
    if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass")))
       stop(mstyle$stop("Unknown 'na.action' specified under options()."))
 
+   if (is.null(model$vi) || is.null(model$X))
+      stop(mstyle$stop("Information needed to compute the hat values is not available in the model object."))
+
    type <- match.arg(type, c("diagonal", "matrix"))
 
    #########################################################################

R/hc.rma.uni.r

@@ -9,6 +9,9 @@ hc.rma.uni <- function(object, digits, transf, targs, control, ...) {
    if (!x$int.only)
       stop(mstyle$stop("Method only applicable to models without moderators."))
 
+   if (is.null(x$yi) || is.null(x$vi))
+      stop(mstyle$stop("Information needed is not available in the model object."))
+
    if (missing(digits)) {
       digits <- .get.digits(xdigits=x$digits, dmiss=TRUE)
    } else {

R/influence.rma.uni.r

@@ -10,6 +10,9 @@ influence.rma.uni <- function(model, digits, progbar=FALSE, ...) {
    if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass")))
       stop(mstyle$stop("Unknown 'na.action' specified under options()."))
 
+   if (is.null(model$yi) || is.null(model$vi))
+      stop(mstyle$stop("Information needed is not available in the model object."))
+
    x <- model
 
    if (x$k == 1L)

R/labbe.rma.r

@@ -12,6 +12,9 @@ add=x$add, to=x$to, transf, targs, pch=21, psize, plim=c(0.5,3.5), col, bg, lty,
    if (!is.element(x$measure, c("RR","OR","RD","AS","IRR","IRD","IRSD")))
       stop(mstyle$stop("Argument 'measure' must have been set to one of the following: 'RR','OR','RD','AS','IRR','IRD','IRSD'."))
 
+   if (is.null(x$outdat.f))
+      stop(mstyle$stop("Information needed to construct the plot is not available in the model object."))
+
    na.act <- getOption("na.action")
    on.exit(options(na.action=na.act), add=TRUE)
 

R/leave1out.rma.mh.r

@@ -15,6 +15,9 @@ leave1out.rma.mh <- function(x, digits, transf, targs, progbar=FALSE, ...) {
    if (x$k == 1L)
       stop(mstyle$stop("Stopped because k = 1."))
 
+   if (is.null(x$outdat.f))
+      stop(mstyle$stop("Information needed to carry out a leave-one-out analysis is not available in the model object."))
+
    if (missing(digits)) {
       digits <- .get.digits(xdigits=x$digits, dmiss=TRUE)
    } else {

R/leave1out.rma.peto.r

@@ -15,6 +15,9 @@ leave1out.rma.peto <- function(x, digits, transf, targs, progbar=FALSE, ...) {
    if (x$k == 1L)
       stop(mstyle$stop("Stopped because k = 1."))
 
+   if (is.null(x$outdat.f))
+      stop(mstyle$stop("Information needed to carry out a leave-one-out analysis is not available in the model object."))
+
    if (missing(digits)) {
       digits <- .get.digits(xdigits=x$digits, dmiss=TRUE)
    } else {

R/leave1out.rma.uni.r

@@ -15,6 +15,9 @@ leave1out.rma.uni <- function(x, digits, transf, targs, progbar=FALSE, ...) {
    if (x$k == 1L)
       stop(mstyle$stop("Stopped because k = 1."))
 
+   if (is.null(x$yi.f) || is.null(x$vi.f))
+      stop(mstyle$stop("Information needed to carry out a leave-one-out analysis is not available in the model object."))
+
    if (missing(digits)) {
       digits <- .get.digits(xdigits=x$digits, dmiss=TRUE)
    } else {

R/misc.func.hidden.mv.r

@@ -988,6 +988,8 @@
    if (nearpd)
       M <- as.matrix(nearPD(M)$mat)
 
+   ### compute W = M^-1 via Cholesky decomposition
+
    if (verbose > 1) {
       W <- try(chol2inv(chol(M)), silent=FALSE)
    } else {
@@ -1016,8 +1018,7 @@
          U <- try(suppressWarnings(chol(W)), silent=TRUE)
       }
 
-      ### Y ~ N(Xbeta, M), so UY ~ N(UXbeta, UMU) where UMU = I
-      ### return(U %*% M %*% U)
+      ### Y ~ N(Xbeta, M), so UY ~ N(UXbeta, UMU') where UMU' = I
 
       if (inherits(U, "try-error")) {
 
@@ -1031,13 +1032,22 @@
 
          if (!dofit || is.null(A)) {
 
-            sX   <- U %*% X
-            sY   <- U %*% Y
-            beta <- solve(crossprod(sX), crossprod(sX, sY))
-            beta <- ifelse(is.na(beta.arg), beta, beta.arg)
-            RSS  <- sum(as.vector(sY - sX %*% beta)^2)
-            if (dofit)
-               vb <- matrix(solve(crossprod(sX)), nrow=pX, ncol=pX)
+            if (FALSE) {
+               sX   <- U %*% X
+               sY   <- U %*% Y
+               beta <- solve(crossprod(sX), crossprod(sX, sY))
+               beta <- ifelse(is.na(beta.arg), beta, beta.arg)
+               RSS  <- sum(as.vector(sY - sX %*% beta)^2)
+               if (dofit)
+                  vb <- matrix(solve(crossprod(sX)), nrow=pX, ncol=pX)
+            } else {
+               stXWX <- chol2inv(chol(as.matrix(t(X) %*% W %*% X)))
+               beta  <- matrix(stXWX %*% crossprod(X,W) %*% Y, ncol=1)
+               beta  <- ifelse(is.na(beta.arg), beta, beta.arg)
+               RSS   <- as.vector(t(Y - X %*% beta) %*% W %*% (Y - X %*% beta))
+               if (dofit)
+                  vb <- stXWX
+            }
 
          } else {
 
@@ -1097,7 +1107,6 @@
          iteration <- .getfromenv("iteration", default=NULL)
 
          if (!is.null(iteration)) {
-            #cat(mstyle$verbose(paste0("Iteration ", iteration, "\t")))
             cat(mstyle$verbose(paste0("Iteration ", formatC(iteration, width=5, flag="-", format="f", digits=0), " ")))
             try(assign("iteration", iteration+1, envir=.metafor), silent=TRUE)
          }

R/misc.func.hidden.r

@@ -316,6 +316,9 @@
 
 .level <- function(level, allow.vector=FALSE, argname="level", stopon100=FALSE) {
 
+   if (is.null(level))
+      return(NULL)
+
    mstyle <- .get.mstyle()
 
    if (any(level > 100) || any(level < 0))

R/misc.func.hidden.uni.r

@@ -1,9 +1,9 @@
 ############################################################################
 
-### function to calculate:
+### function to calculate
 ### solve(t(X) %*% W %*% X) = .invcalc(X=X, W=W, k=k)
 ### solve(t(X) %*% X)       = .invcalc(X=X, W=diag(k), k=k)
-### without taking the actual inverse
+### via QR decomposition
 
 .invcalc <- function(X, W, k) {
 

R/permutest.rma.ls.r

@@ -10,6 +10,9 @@ permutest.rma.ls <- function(x, exact=FALSE, iter=1000, btt=x$btt, att=x$att, pr
       digits <- .get.digits(digits=digits, xdigits=x$digits, dmiss=FALSE)
    }
 
+   if (is.null(x$yi) || is.null(x$vi))
+      stop(mstyle$stop("Information needed to carry out permutation test is not available in the model object."))
+
    ddd <- list(...)
 
    .chkdots(ddd, c("tol", "time", "seed", "verbose", "permci", "skip.beta", "skip.alpha", "fixed"))

R/permutest.rma.uni.r

@@ -10,6 +10,9 @@ permutest.rma.uni <- function(x, exact=FALSE, iter=1000, btt=x$btt, permci=FALSE
       digits <- .get.digits(digits=digits, xdigits=x$digits, dmiss=FALSE)
    }
 
+   if (is.null(x$yi) || is.null(x$vi))
+      stop(mstyle$stop("Information needed to carry out permutation test is not available in the model object."))
+
    ddd <- list(...)
 
    .chkdots(ddd, c("tol", "time", "seed", "verbose", "fixed"))

R/predict.rma.r

@@ -239,6 +239,9 @@ level, adjust=FALSE, digits, transf, targs, vcov=FALSE, ...) {
 
    }
 
+   if (is.null(X.new))
+      stop(mstyle$stop("Matrix 'X.new' is NULL."))
+
    #return(list(k.new=k.new, tau2=x$tau2, gamma2=x$gamma2, tau2.levels=tau2.levels, gamma2.levels=gamma2.levels))
 
    #########################################################################

R/profile.rma.ls.r

@@ -7,6 +7,9 @@ profile.rma.ls <- function(fitted, alpha,
 
    x <- fitted
 
+   if (is.null(x$yi) || is.null(x$vi))
+      stop(mstyle$stop("Information needed for profiling is not available in the model object."))
+
    if (x$optbeta)
       stop(mstyle$stop("Profiling not yet implemented for models fitted with 'optbeta=TRUE'."))
 

R/profile.rma.mv.r

@@ -7,6 +7,9 @@ profile.rma.mv <- function(fitted, sigma2, tau2, rho, gamma2, phi,
 
    x <- fitted
 
+   if (is.null(x$yi) || is.null(x$V))
+      stop(mstyle$stop("Information needed for profiling is not available in the model object."))
+
    if (anyNA(steps))
       stop(mstyle$stop("No missing values allowed in 'steps' argument."))