Added internal .expand1() function.

wviechtb · May 6, 2024 · f7c5474 · f7c5474
1 parent c2d0efd
commit f7c5474
Show file tree

Hide file tree

Showing 155 changed files with 258 additions and 378 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: metafor
-Version: 4.7-10
-Date: 2024-04-29
+Version: 4.7-11
+Date: 2024-05-06
 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-10 (2024-04-29)
+# metafor 4.7-11 (2024-05-06)
 
 - `rma.mv()` now counts the number of levels of a random effect more appropriately; this may trigger more often the check whether the number of levels is equal to 1, in which case the corresponding variance component is automatically fixed to 0; this check can be omitted with `control=list(check.k.gtr.1=FALSE)`
 

diff --git a/R/addpoly.default.r b/R/addpoly.default.r
@@ -93,8 +93,7 @@ transf, atransf, targs, efac, col, border, lty, fonts, cex, constarea=FALSE, ...
    if (is.null(mlab)) {
       mlab <- rep("", k)
    } else {
-      if (length(mlab) == 1L)
-         mlab <- rep(mlab, k)
+      mlab <- .expand1(mlab, k)
       if (length(mlab) != k)
          stop(mstyle$stop(paste0("Length of the 'mlab' argument (", length(mlab), ") does not correspond to the number of polygons to be plotted (", k, ").")))
    }
@@ -127,8 +126,7 @@ transf, atransf, targs, efac, col, border, lty, fonts, cex, constarea=FALSE, ...
    if (is.null(fonts)) {
       fonts <- rep(par("family"), 2L)
    } else {
-      if (length(fonts) == 1L)
-         fonts <- rep(fonts, 2L)
+      fonts <- .expand1(fonts, 2L)
    }
 
    if (is.null(names(fonts)))
@@ -334,8 +332,7 @@ transf, atransf, targs, efac, col, border, lty, fonts, cex, constarea=FALSE, ...
       if (is.null(width)) {
          width <- apply(annotext, 2, function(x) max(nchar(x)))
       } else {
-         if (length(width) == 1L)
-            width <- rep(width, ncol(annotext))
+         width <- .expand1(width, ncol(annotext))
       }
 
       for (j in seq_len(ncol(annotext))) {
@@ -354,14 +351,9 @@ transf, atransf, targs, efac, col, border, lty, fonts, cex, constarea=FALSE, ...
 
    }
 
-   if (length(col) == 1L)
-      col <- rep(col, k)
-
-   if (length(border) == 1L)
-      border <- rep(border, k)
-
-   if (length(lcol) == 1L)
-      lcol <- rep(lcol, k)
+   col    <- .expand1(col, k)
+   border <- .expand1(border, k)
+   lcol   <- .expand1(lcol, k)
 
    if (isTRUE(constarea)) {
       areas <- (ci.ub - ci.lb) * (height/100)*cex*efac[1]

diff --git a/R/aggregate.escalc.r b/R/aggregate.escalc.r
@@ -12,8 +12,7 @@ aggregate.escalc <- function(x, cluster, time, obs, V, struct="CS", rho, phi,
    if (missing(cluster))
       stop(mstyle$stop("Must specify 'cluster' variable."))
 
-   if (length(na.rm) == 1L)
-      na.rm <- c(na.rm, na.rm)
+   na.rm <- .expand1(na.rm, 2L)
 
    k <- nrow(x)
 
@@ -102,8 +101,7 @@ aggregate.escalc <- function(x, cluster, time, obs, V, struct="CS", rho, phi,
          if (missing(rho))
             stop(mstyle$stop("Must specify 'rho' for this var-cov structure."))
 
-         if (length(rho) == 1L)
-            rho <- rep(rho, n)
+         rho <- .expand1(rho, n)
 
          if (length(rho) != n)
             stop(mstyle$stop(paste0("Length of 'rho' (", length(rho), ") does not match the number of clusters (", n, ").")))
@@ -118,8 +116,7 @@ aggregate.escalc <- function(x, cluster, time, obs, V, struct="CS", rho, phi,
          if (missing(phi))
             stop(mstyle$stop("Must specify 'phi' for this var-cov structure."))
 
-         if (length(phi) == 1L)
-            phi <- rep(phi, n)
+         phi <- .expand1(phi, n)
 
          if (length(phi) != n)
             stop(mstyle$stop(paste0("Length of 'phi' (", length(phi), ") does not match the number of clusters (", n, ").")))
@@ -195,8 +192,7 @@ aggregate.escalc <- function(x, cluster, time, obs, V, struct="CS", rho, phi,
 
       if (.is.vector(V)) {
 
-         if (length(V) == 1L)
-            V <- rep(V, k)
+         V <- .expand1(V, k)
 
          if (length(V) != k)
             stop(mstyle$stop(paste0("Length of 'V' (", length(V), ") does not match length of data frame (", k, ").")))

diff --git a/R/anova.rma.r b/R/anova.rma.r
@@ -69,8 +69,7 @@ anova.rma <- function(object, object2, btt, X, att, Z, rhs, digits, refit=FALSE,
             if (missing(rhs)) {
                rhs <- rep(0, m)
             } else {
-               if (length(rhs) == 1L)
-                  rhs <- rep(rhs, m)
+               rhs <- .expand1(rhs, m)
                if (length(rhs) != m)
                   stop(mstyle$stop(paste0("Length of 'rhs' (", length(rhs), ") does not match the number of coefficients tested (", m, ").")))
             }
@@ -118,8 +117,7 @@ anova.rma <- function(object, object2, btt, X, att, Z, rhs, digits, refit=FALSE,
             if (missing(rhs)) {
                rhs <- rep(0, m)
             } else {
-               if (length(rhs) == 1L)
-                  rhs <- rep(rhs, m)
+               rhs <- .expand1(rhs, m)
                if (length(rhs) != m)
                   stop(mstyle$stop(paste0("Length of 'rhs' (", length(rhs), ") does not match the number of coefficients tested (", m, ").")))
             }
@@ -193,8 +191,7 @@ anova.rma <- function(object, object2, btt, X, att, Z, rhs, digits, refit=FALSE,
             if (missing(rhs)) {
                rhs <- rep(0, m)
             } else {
-               if (length(rhs) == 1L)
-                  rhs <- rep(rhs, m)
+               rhs <- .expand1(rhs, m)
                if (length(rhs) != m)
                   stop(mstyle$stop(paste0("Length of 'rhs' (", length(rhs), ") does not match the number of linear combinations (", m, ").")))
             }
@@ -345,8 +342,7 @@ anova.rma <- function(object, object2, btt, X, att, Z, rhs, digits, refit=FALSE,
                if (missing(rhs)) {
                   rhs <- rep(0, m)
                } else {
-                  if (length(rhs) == 1L)
-                     rhs <- rep(rhs, m)
+                  rhs <- .expand1(rhs, m)
                   if (length(rhs) != m)
                      stop(mstyle$stop(paste0("Length of 'rhs' (", length(rhs), ") does not match the number of linear combinations (", m, ").")))
                }

diff --git a/R/baujat.rma.r b/R/baujat.rma.r
@@ -133,8 +133,7 @@ baujat.rma <- function(x, xlim, ylim, xlab, ylab, cex, symbol="ids", grid=TRUE,
 
    if (is.numeric(symbol)) {
 
-      if (length(symbol) == 1L)
-         symbol <- rep(symbol, x$k.all)
+      symbol <- .expand1(symbol, x$k.all)
 
       if (length(symbol) != x$k.all)
          stop(mstyle$stop(paste0("Length of the 'symbol' argument (", length(symbol), ") does not correspond to the size of the original dataset (", x$k.all, ").")))

diff --git a/R/blup.rma.uni.r b/R/blup.rma.uni.r
@@ -45,8 +45,7 @@ blup.rma.uni <- function(x, level, digits, transf, targs, ...) {
    ### see Appendix in: Raudenbush, S. W., & Bryk, A. S. (1985). Empirical
    ### Bayes meta-analysis. Journal of Educational Statistics, 10(2), 75-98
 
-   if (length(x$tau2.f) == 1L)
-      x$tau2.f <- rep(x$tau2.f, length(x$yi.f))
+   x$tau2.f <- .expand1(x$tau2.f, length(x$yi.f))
 
    li <- ifelse(is.infinite(x$tau2.f), 1, x$tau2.f / (x$tau2.f + x$vi.f))
 

diff --git a/R/confint.rma.ls.r b/R/confint.rma.ls.r
@@ -165,13 +165,11 @@ confint.rma.ls <- function(object, parm, level, fixed=FALSE, alpha, digits, tran
       }
 
       if (!is.null(x$control$alpha.min)) {
-         if (length(x$control$alpha.min) == 1L)
-            x$control$alpha.min <- rep(x$control$alpha.min, x$q)
+         x$control$alpha.min <- .expand1(x$control$alpha.min, x$q)
          con$vc.min <- max(con$vc.min, x$control$alpha.min[alpha])
       }
       if (!is.null(x$control$alpha.max)) {
-         if (length(x$control$alpha.max) == 1L)
-            x$control$alpha.max <- rep(x$control$alpha.max, x$q)
+         x$control$alpha.max <- .expand1(x$control$alpha.max, x$q)
          con$vc.max <- min(con$vc.max, x$control$alpha.max[alpha])
       }
 

diff --git a/R/conv.2x2.r b/R/conv.2x2.r
@@ -70,8 +70,7 @@ conv.2x2 <- function(ori, ri, x2i, ni, n1i, n2i, correct=TRUE, data, include,
 
    ### handle correct argument
 
-   if (length(correct) == 1L)
-      correct <- rep(correct, k)
+   correct <- .expand1(correct, k)
 
    if (length(correct) != k)
       stop(mstyle$stop(paste0("Length of 'correct' argument (", length(correct), ") does not match length of data (", k, ").")))

diff --git a/R/conv.delta.r b/R/conv.delta.r
@@ -139,8 +139,7 @@ conv.delta <- function(yi, vi, ni, data, include, transf, var.names, append=TRUE
 
    for (i in seq_along(dotargs)) {
       dotarglist[[i]] <- .getx(dotargs[i], mf=mf, data=x, checknumeric=TRUE)
-      if (length(dotarglist[[i]]) == 1L)
-         dotarglist[[i]] <- rep(dotarglist[[i]], k)
+      dotarglist[[i]] <- .expand1(dotarglist[[i]], k)
       names(dotarglist)[i] <- dotargs[i]
    }
 

diff --git a/R/conv.fivenum.r b/R/conv.fivenum.r
@@ -87,8 +87,7 @@ conv.fivenum <- function(min, q1, median, q3, max, n, data, include,
 
    ### handle dist argument
 
-   if (length(dist) == 1L)
-      dist <- rep(dist, k)
+   dist <- .expand1(dist, k)
 
    if (length(dist) != k)
       stop(mstyle$stop(paste0("Length of 'dist' argument (", length(dist), ") does not match length of data (", k, ").")))
@@ -132,8 +131,7 @@ conv.fivenum <- function(min, q1, median, q3, max, n, data, include,
 
    method <- tolower(method)
 
-   if (length(method) == 1L)
-      method <- c(method, method)
+   method <- .expand1(method, 2L)
 
    method1.options <- c("default", "luo/wan/shi", "qe", "bc", "mln", "blue", "hozo2005", "wan2014", "bland2015", "luo2016", "walter2007")
    method2.options <- c("default", "luo/wan/shi", "qe", "bc", "mln", "blue", "hozo2005", "wan2014", "bland2015", "shi2020", "walter2007")
@@ -184,7 +182,7 @@ conv.fivenum <- function(min, q1, median, q3, max, n, data, include,
    tval  <- rep(NA_real_, k)
    crit  <- rep(NA_real_, k)
    sig   <- rep(NA,       k)
-   dists <- rep("norm", k)
+   dists <- rep("norm",   k)
 
    for (i in seq_len(k)) {
 

diff --git a/R/conv.wald.r b/R/conv.wald.r
@@ -145,8 +145,7 @@ conv.wald <- function(out, ci.lb, ci.ub, zval, pval, n, data, include,
 
    ### if level is a single value, expand to the appropriate length
 
-   if (length(level) == 1L)
-      level <- rep(level, k)
+   level <- .expand1(level, k)
 
    if (length(level) != k)
       stop(mstyle$stop(paste0("Length of the 'level' argument (", length(level), ") does not correspond to the size of the dataset (", k, ").")))

diff --git a/R/dfround.r b/R/dfround.r
@@ -12,11 +12,8 @@ dfround <- function(x, digits, drop0=TRUE) {
    if (missing(digits))
       digits <- 0
 
-   if (length(digits) == 1L)
-      digits <- rep(digits, p)
-
-   if (length(drop0) == 1L)
-      drop0 <- rep(drop0, p)
+   digits <- .expand1(digits, p)
+   drop0  <- .expand1(drop0, p)
 
    if (p != length(digits))
       stop(mstyle$stop(paste0("Number of columns in 'x' (", p, ") does not match length of 'digits' (", length(digits), ").")))