Added code injection hooks to various functions for JASP.

wviechtb · Dec 2, 2024 · 0cd002a · 0cd002a
1 parent d0c00ed
commit 0cd002a
Show file tree

Hide file tree

Showing 155 changed files with 521 additions and 253 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: metafor
-Version: 4.7-56
-Date: 2024-11-24
+Version: 4.7-57
+Date: 2024-12-02
 Title: Meta-Analysis Package for R
 Authors@R: person(given = "Wolfgang", family = "Viechtbauer", role = c("aut","cre"), email = "[email protected]", comment = c(ORCID = "0000-0003-3463-4063"))
 Depends: R (>= 4.0.0), methods, Matrix, metadat, numDeriv

diff --git a/NEWS.md b/NEWS.md
@@ -1,4 +1,4 @@
-# metafor 4.7-56 (2024-11-24)
+# metafor 4.7-57 (2024-12-02)
 
 - 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
 

diff --git a/R/baujat.rma.r b/R/baujat.rma.r
@@ -28,6 +28,16 @@ baujat.rma <- function(x, xlim, ylim, xlab, ylab, cex, symbol="ids", grid=TRUE,
       grid <- TRUE
    }
 
+   ddd <- list(...)
+
+   lplot   <- function(..., code1, code2) plot(...)
+   lbox    <- function(..., code1, code2) box(...)
+   lpoints <- function(..., code1, code2) points(...)
+   ltext   <- function(..., code1, code2) text(...)
+
+   if (!is.null(ddd[["code1"]]))
+      eval(expr = parse(text = ddd[["code1"]]))
+
    #########################################################################
 
    ### set up vectors to store results in
@@ -54,6 +64,9 @@ baujat.rma <- function(x, xlim, ylim, xlab, ylab, cex, symbol="ids", grid=TRUE,
       if (progbar)
          pbapply::setpb(pbar, i)
 
+      if (!is.null(ddd[["code2"]]))
+         eval(expr = parse(text = ddd[["code2"]]))
+
       if (!x$not.na[i])
          next
 
@@ -125,13 +138,13 @@ baujat.rma <- function(x, xlim, ylim, xlab, ylab, cex, symbol="ids", grid=TRUE,
 
    ### draw empty plot
 
-   plot(NA, xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim, ...)
+   lplot(NA, xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim, ...)
 
    ### add grid (and redraw box)
 
    if (.isTRUE(grid)) {
       grid(col=gridcol)
-      box(...)
+      lbox(...)
    }
 
    if (is.numeric(symbol)) {
@@ -143,15 +156,15 @@ baujat.rma <- function(x, xlim, ylim, xlab, ylab, cex, symbol="ids", grid=TRUE,
 
       symbol <- .getsubset(symbol, x$subset)
 
-      points(x=xhati, y=yhati, cex=cex, pch=symbol, ...)
+      lpoints(x=xhati, y=yhati, cex=cex, pch=symbol, ...)
 
    }
 
    if (is.character(symbol) && symbol=="ids")
-      text(xhati, yhati, x$ids, cex=cex, ...)
+      ltext(xhati, yhati, x$ids, cex=cex, ...)
 
    if (is.character(symbol) && symbol=="slab")
-      text(xhati, yhati, x$slab, cex=cex, ...)
+      ltext(xhati, yhati, x$slab, cex=cex, ...)
 
    #########################################################################
 

diff --git a/R/blup.rma.uni.r b/R/blup.rma.uni.r
@@ -40,6 +40,13 @@ blup.rma.uni <- function(x, level, digits, transf, targs, ...) {
    if (!is.null(x$weights) || !x$weighted)
       stop(mstyle$stop("Extraction of random effects not available for models with non-standard weights."))
 
+   ddd <- list(...)
+
+   .chkdots(ddd, c("code1", "code2"))
+
+   if (!is.null(ddd[["code1"]]))
+      eval(expr = parse(text = ddd[["code1"]]))
+
    #########################################################################
 
    pred  <- rep(NA_real_, x$k.f)
@@ -53,13 +60,20 @@ blup.rma.uni <- function(x, level, digits, transf, targs, ...) {
    li <- ifelse(is.infinite(x$tau2.f), 1, x$tau2.f / (x$tau2.f + x$vi.f))
 
    for (i in seq_len(x$k.f)[x$not.na]) { # note: skipping NA cases
+
+      if (!is.null(ddd[["code2"]]))
+         eval(expr = parse(text = ddd[["code2"]]))
+
       Xi <- matrix(x$X.f[i,], nrow=1)
+
       pred[i]  <- li[i] * x$yi.f[i] + (1 - li[i])   * Xi %*% x$beta
+
       if (li[i] == 1) {
          vpred[i] <- li[i] * x$vi.f[i]
       } else {
          vpred[i] <- li[i] * x$vi.f[i] + (1 - li[i])^2 * Xi %*% tcrossprod(x$vb,Xi)
       }
+
    }
 
    se <- sqrt(vpred)

diff --git a/R/confint.rma.ls.r b/R/confint.rma.ls.r
@@ -32,7 +32,7 @@ confint.rma.ls <- function(object, parm, level, fixed=FALSE, alpha, digits, tran
 
    ddd <- list(...)
 
-   .chkdots(ddd, c("time", "xlim", "extint"))
+   .chkdots(ddd, c("time", "xlim", "extint", "code1", "code2"))
 
    level <- .level(level, stopon100=.isTRUE(ddd$extint))
 
@@ -66,12 +66,17 @@ confint.rma.ls <- function(object, parm, level, fixed=FALSE, alpha, digits, tran
       if (comps == 0)
          stop(mstyle$stop("No components for which a CI can be obtained."))
 
+      if (!is.null(ddd[["code1"]]))
+         eval(expr = parse(text = ddd[["code1"]]))
+
       res.all <- list()
       j <- 0
 
       if (any(!x$alpha.fix)) {
          for (pos in seq_len(x$alphas)[!x$alpha.fix]) {
             j <- j + 1
+            if (!is.null(ddd[["code2"]]))
+               eval(expr = parse(text = ddd[["code2"]]))
             cl.vc <- cl
             cl.vc$alpha <- pos
             cl.vc$time <- FALSE

diff --git a/R/confint.rma.mv.r b/R/confint.rma.mv.r
@@ -32,7 +32,7 @@ confint.rma.mv <- function(object, parm, level, fixed=FALSE, sigma2, tau2, rho,
 
    ddd <- list(...)
 
-   .chkdots(ddd, c("time", "xlim", "extint"))
+   .chkdots(ddd, c("time", "xlim", "extint", "code1", "code2"))
 
    level <- .level(level, stopon100=.isTRUE(ddd$extint))
 
@@ -65,12 +65,17 @@ confint.rma.mv <- function(object, parm, level, fixed=FALSE, sigma2, tau2, rho,
       if (comps == 0)
          stop(mstyle$stop("No components for which a CI can be obtained."))
 
+      if (!is.null(ddd[["code1"]]))
+         eval(expr = parse(text = ddd[["code1"]]))
+
       res.all <- list()
       j <- 0
 
       if (x$withS && any(!x$vc.fix$sigma2)) {
          for (pos in seq_len(x$sigma2s)[!x$vc.fix$sigma2]) {
             j <- j + 1
+            if (!is.null(ddd[["code2"]]))
+               eval(expr = parse(text = ddd[["code2"]]))
             cl.vc <- cl
             cl.vc$sigma2 <- pos
             cl.vc$time <- FALSE
@@ -86,6 +91,8 @@ confint.rma.mv <- function(object, parm, level, fixed=FALSE, sigma2, tau2, rho,
          if (any(!x$vc.fix$tau2)) {
             for (pos in seq_len(x$tau2s)[!x$vc.fix$tau2]) {
                j <- j + 1
+               if (!is.null(ddd[["code2"]]))
+                  eval(expr = parse(text = ddd[["code2"]]))
                cl.vc <- cl
                cl.vc$tau2 <- pos
                cl.vc$time <- FALSE
@@ -99,6 +106,8 @@ confint.rma.mv <- function(object, parm, level, fixed=FALSE, sigma2, tau2, rho,
          if (any(!x$vc.fix$rho)) {
             for (pos in seq_len(x$rhos)[!x$vc.fix$rho]) {
                j <- j + 1
+               if (!is.null(ddd[["code2"]]))
+                  eval(expr = parse(text = ddd[["code2"]]))
                cl.vc <- cl
                cl.vc$rho <- pos
                cl.vc$time <- FALSE
@@ -115,6 +124,8 @@ confint.rma.mv <- function(object, parm, level, fixed=FALSE, sigma2, tau2, rho,
          if (any(!x$vc.fix$gamma2)) {
             for (pos in seq_len(x$gamma2s)[!x$vc.fix$gamma2]) {
                j <- j + 1
+               if (!is.null(ddd[["code2"]]))
+                  eval(expr = parse(text = ddd[["code2"]]))
                cl.vc <- cl
                cl.vc$gamma2 <- pos
                cl.vc$time <- FALSE
@@ -128,6 +139,8 @@ confint.rma.mv <- function(object, parm, level, fixed=FALSE, sigma2, tau2, rho,
          if (any(!x$vc.fix$phi)) {
             for (pos in seq_len(x$phis)[!x$vc.fix$phi]) {
                j <- j + 1
+               if (!is.null(ddd[["code2"]]))
+                  eval(expr = parse(text = ddd[["code2"]]))
                cl.vc <- cl
                cl.vc$phi <- pos
                cl.vc$time <- FALSE

diff --git a/R/confint.rma.uni.selmodel.r b/R/confint.rma.uni.selmodel.r
@@ -43,7 +43,7 @@ confint.rma.uni.selmodel <- function(object, parm, level, fixed=FALSE, tau2, del
 
    ddd <- list(...)
 
-   .chkdots(ddd, c("time", "xlim", "extint"))
+   .chkdots(ddd, c("time", "xlim", "extint", "code1", "code2"))
 
    level <- .level(level, stopon100=.isTRUE(ddd$extint))
 
@@ -74,11 +74,16 @@ confint.rma.uni.selmodel <- function(object, parm, level, fixed=FALSE, tau2, del
       if (comps == 0)
          stop(mstyle$stop("No components for which a CI can be obtained."))
 
+      if (!is.null(ddd[["code1"]]))
+         eval(expr = parse(text = ddd[["code1"]]))
+
       res.all <- list()
       j <- 0
 
       if (!is.element(x$method, c("FE","EE","CE")) && !x$tau2.fix) {
          j <- j + 1
+         if (!is.null(ddd[["code2"]]))
+            eval(expr = parse(text = ddd[["code2"]]))
          cl.vc <- cl
          cl.vc$tau2 <- 1
          cl.vc$time <- FALSE
@@ -92,6 +97,8 @@ confint.rma.uni.selmodel <- function(object, parm, level, fixed=FALSE, tau2, del
       if (any(!x$delta.fix)) {
          for (pos in seq_len(x$deltas)[!x$delta.fix]) {
             j <- j + 1
+            if (!is.null(ddd[["code2"]]))
+               eval(expr = parse(text = ddd[["code2"]]))
             cl.vc <- cl
             cl.vc$delta <- pos
             cl.vc$time <- FALSE

diff --git a/R/cooks.distance.rma.mv.r b/R/cooks.distance.rma.mv.r
@@ -58,7 +58,7 @@ cooks.distance.rma.mv <- function(model, progbar=FALSE, cluster, reestimate=TRUE
 
    ddd <- list(...)
 
-   .chkdots(ddd, c("btt", "time", "LB"))
+   .chkdots(ddd, c("btt", "time", "LB", "code1", "code2"))
 
    btt <- .set.btt(ddd$btt, x$p, int.incl=FALSE, Xnames=colnames(x$X))
    m <- length(btt)
@@ -96,31 +96,34 @@ cooks.distance.rma.mv <- function(model, progbar=FALSE, cluster, reestimate=TRUE
    ids <- unique(cluster)
    n <- length(ids)
 
+   if (!is.null(ddd[["code1"]]))
+      eval(expr = parse(text = ddd[["code1"]]))
+
    #########################################################################
 
    ### calculate inverse of variance-covariance matrix under the full model
 
    svb <- chol2inv(chol(x$vb[btt,btt,drop=FALSE]))
 
    if (parallel == "no")
-      res <- pbapply::pblapply(seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt)
+      res <- pbapply::pblapply(seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt, code2=ddd$code2)
 
    if (parallel == "multicore")
-      res <- pbapply::pblapply(seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt, cl=ncpus)
-      #res <- parallel::mclapply(seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt, mc.cores=ncpus)
+      res <- pbapply::pblapply(seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt, code2=ddd$code2, cl=ncpus)
+      #res <- parallel::mclapply(seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt, code2=ddd$code2, mc.cores=ncpus)
 
    if (parallel == "snow") {
       if (is.null(cl)) {
          cl <- parallel::makePSOCKcluster(ncpus)
          on.exit(parallel::stopCluster(cl), add=TRUE)
       }
       if (.isTRUE(ddd$LB)) {
-         res <- parallel::parLapplyLB(cl, seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt)
-         #res <- parallel::clusterApplyLB(cl, seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt)
+         res <- parallel::parLapplyLB(cl, seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt, code2=ddd$code2)
+         #res <- parallel::clusterApplyLB(cl, seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt, code2=ddd$code2)
       } else {
-         res <- pbapply::pblapply(seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt, cl=cl)
-         #res <- parallel::parLapply(cl, seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt)
-         #res <- parallel::clusterApply(cl, seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt)
+         res <- pbapply::pblapply(seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt, code2=ddd$code2, cl=cl)
+         #res <- parallel::parLapply(cl, seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt, code2=ddd$code2)
+         #res <- parallel::clusterApply(cl, seq_len(n), .cooks.distance.rma.mv, obj=x, parallel=parallel, svb=svb, cluster=cluster, ids=ids, reestimate=reestimate, btt=btt, code2=ddd$code2)
       }
    }
 

diff --git a/R/cumul.rma.mh.r b/R/cumul.rma.mh.r
@@ -26,7 +26,7 @@ cumul.rma.mh <- function(x, order, digits, transf, targs, collapse=FALSE, progba
 
    ddd <- list(...)
 
-   .chkdots(ddd, c("time", "decreasing"))
+   .chkdots(ddd, c("time", "decreasing", "code1", "code2"))
 
    if (.isTRUE(ddd$time))
       time.start <- proc.time()
@@ -91,6 +91,9 @@ cumul.rma.mh <- function(x, order, digits, transf, targs, collapse=FALSE, progba
 
    k.o <- length(uorvar)
 
+   if (!is.null(ddd[["code1"]]))
+      eval(expr = parse(text = ddd[["code1"]]))
+
    k     <- rep(NA_integer_, k.o)
    beta  <- rep(NA_real_, k.o)
    se    <- rep(NA_real_, k.o)
@@ -116,6 +119,9 @@ cumul.rma.mh <- function(x, order, digits, transf, targs, collapse=FALSE, progba
       if (progbar)
          pbapply::setpb(pbar, i)
 
+      if (!is.null(ddd[["code2"]]))
+         eval(expr = parse(text = ddd[["code2"]]))
+
       if (collapse) {
 
          if (all(!not.na[is.element(orvar, uorvar[i])])) {

diff --git a/R/cumul.rma.peto.r b/R/cumul.rma.peto.r
@@ -26,7 +26,7 @@ cumul.rma.peto <- function(x, order, digits, transf, targs, collapse=FALSE, prog
 
    ddd <- list(...)
 
-   .chkdots(ddd, c("time", "decreasing"))
+   .chkdots(ddd, c("time", "decreasing", "code1", "code2"))
 
    if (.isTRUE(ddd$time))
       time.start <- proc.time()
@@ -87,6 +87,9 @@ cumul.rma.peto <- function(x, order, digits, transf, targs, collapse=FALSE, prog
 
    k.o <- length(uorvar)
 
+   if (!is.null(ddd[["code1"]]))
+      eval(expr = parse(text = ddd[["code1"]]))
+
    k     <- rep(NA_integer_, k.o)
    beta  <- rep(NA_real_, k.o)
    se    <- rep(NA_real_, k.o)
@@ -112,6 +115,9 @@ cumul.rma.peto <- function(x, order, digits, transf, targs, collapse=FALSE, prog
       if (progbar)
          pbapply::setpb(pbar, i)
 
+      if (!is.null(ddd[["code2"]]))
+         eval(expr = parse(text = ddd[["code2"]]))
+
       if (collapse) {
 
          if (all(!not.na[is.element(orvar, uorvar[i])])) {

diff --git a/R/cumul.rma.uni.r b/R/cumul.rma.uni.r
@@ -34,7 +34,7 @@ cumul.rma.uni <- function(x, order, digits, transf, targs, collapse=FALSE, progb
 
    ddd <- list(...)
 
-   .chkdots(ddd, c("time", "decreasing"))
+   .chkdots(ddd, c("time", "decreasing", "code1", "code2"))
 
    if (.isTRUE(ddd$time))
       time.start <- proc.time()
@@ -92,6 +92,9 @@ cumul.rma.uni <- function(x, order, digits, transf, targs, collapse=FALSE, progb
 
    k.o <- length(uorvar)
 
+   if (!is.null(ddd[["code1"]]))
+      eval(expr = parse(text = ddd[["code1"]]))
+
    k     <- rep(NA_integer_, k.o)
    beta  <- rep(NA_real_, k.o)
    se    <- rep(NA_real_, k.o)
@@ -118,6 +121,9 @@ cumul.rma.uni <- function(x, order, digits, transf, targs, collapse=FALSE, progb
       if (progbar)
          pbapply::setpb(pbar, i)
 
+      if (!is.null(ddd[["code2"]]))
+         eval(expr = parse(text = ddd[["code2"]]))
+
       if (collapse) {
 
          if (all(!not.na[is.element(orvar, uorvar[i])])) {