Added 'lim' argument to labbe().

wviechtb · Apr 16, 2024 · 191d2cb · 191d2cb
1 parent 0014f62
commit 191d2cb
Show file tree

Hide file tree

Showing 218 changed files with 297 additions and 248 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: metafor
-Version: 4.7-4
-Date: 2024-04-15
+Version: 4.7-5
+Date: 2024-04-16
 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-4 (2024-04-15)
+# metafor 4.7-5 (2024-04-16)
 
 - made optimizers `Rcgmin` and `Rvmmin` available again via the `optimx` package
 

diff --git a/R/labbe.rma.r b/R/labbe.rma.r
@@ -1,4 +1,4 @@
-labbe.rma <- function(x, xlim, ylim, xlab, ylab,
+labbe.rma <- function(x, xlim, ylim, lim, xlab, ylab,
 add=x$add, to=x$to, transf, targs, pch=21, psize, plim=c(0.5,3.5), col, bg, grid=FALSE, lty, ...) {
 
    mstyle <- .get.mstyle()
@@ -9,7 +9,7 @@ add=x$add, to=x$to, transf, targs, pch=21, psize, plim=c(0.5,3.5), col, bg, grid
       stop(mstyle$stop("L'Abbe plots can only be drawn for models without moderators."))
 
    if (!is.element(x$measure, c("RR","OR","RD","AS","IRR","IRD","IRSD")))
-      stop(mstyle$stop("Argument 'measure' must be set to one of the following: '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'."))
 
    na.act <- getOption("na.action")
    on.exit(options(na.action=na.act), add=TRUE)
@@ -65,6 +65,14 @@ add=x$add, to=x$to, transf, targs, pch=21, psize, plim=c(0.5,3.5), col, bg, grid
       grid <- TRUE
    }
 
+   llim <- ddd$llim
+
+   lplot     <- function(..., addyi, addvi, llim) plot(...)
+   lbox      <- function(..., addyi, addvi, llim) box(...)
+   lsegments <- function(..., addyi, addvi, llim) segments(...)
+   llines    <- function(..., addyi, addvi, llim) lines(...)
+   lpoints   <- function(..., addyi, addvi, llim) points(...)
+
    #########################################################################
 
    ### note: pch, psize, col, and bg (if vectors) must be of the same length as the original dataset
@@ -175,7 +183,7 @@ add=x$add, to=x$to, transf, targs, pch=21, psize, plim=c(0.5,3.5), col, bg, grid
    }
 
    if (length(dat.t$yi)==0L || length(dat.c$yi)==0L)
-      stop(mstyle$stop("No information in object to compute arm-level outcomes."))
+      stop(mstyle$stop("No information in object to compute the arm-level outcomes."))
 
    #########################################################################
 
@@ -218,27 +226,44 @@ add=x$add, to=x$to, transf, targs, pch=21, psize, plim=c(0.5,3.5), col, bg, grid
    max.yi <- max(c(dat.t$yi, dat.c$yi))
    rng.yi <- max.yi - min.yi
 
-   len <- 1000
+   len <- 10000
 
    intrcpt <- x$beta[1]
 
-   if (x$measure == "RD")
-      c.vals <- seq(ifelse(intrcpt>0, 0, -intrcpt), ifelse(intrcpt>0, 1-intrcpt, 1), length.out=len)
-   if (x$measure == "RR")
-      c.vals <- seq(min.yi-rng.yi, ifelse(intrcpt>0, 0-intrcpt, 0), length.out=len)
-   if (x$measure == "OR")
-      c.vals <- seq(min.yi-rng.yi, max.yi+rng.yi, length.out=len)
-   if (x$measure == "AS")
-      c.vals <- seq(ifelse(intrcpt>0, 0, -intrcpt), ifelse(intrcpt>0, asin(sqrt(1))-intrcpt, asin(sqrt(1))), length.out=len)
-   if (x$measure == "IRR")
-      c.vals <- seq(min.yi-rng.yi, ifelse(intrcpt>0, 0-intrcpt, 0), length.out=len)
-   if (x$measure == "IRD")
-      c.vals <- seq(ifelse(intrcpt>0, 0, -intrcpt), ifelse(intrcpt>0, 1-intrcpt, 1), length.out=len)
-   if (x$measure == "IRSD")
-      c.vals <- seq(ifelse(intrcpt>0, 0, -intrcpt), ifelse(intrcpt>0, 1-intrcpt, 1), length.out=len)
+   if (is.null(llim)) {
+
+      if (x$measure == "RD")
+         c.vals <- seq(ifelse(intrcpt>0, 0, -intrcpt), ifelse(intrcpt>0, 1-intrcpt, 1), length.out=len)
+      if (x$measure == "RR")
+         c.vals <- seq(min.yi-rng.yi, ifelse(intrcpt>0, -intrcpt, 0), length.out=len)
+      if (x$measure == "OR")
+         c.vals <- seq(min.yi-rng.yi, max.yi+rng.yi, length.out=len)
+      if (x$measure == "AS")
+         c.vals <- seq(ifelse(intrcpt>0, 0, -intrcpt), ifelse(intrcpt>0, asin(sqrt(1))-intrcpt, asin(sqrt(1))), length.out=len)
+      if (x$measure == "IRR")
+         c.vals <- seq(min.yi-rng.yi, ifelse(intrcpt>0, -intrcpt, 0), length.out=len)
+      if (x$measure == "IRD")
+         c.vals <- seq(ifelse(intrcpt>0, 0, -intrcpt), ifelse(intrcpt>0, 1-intrcpt, 1), length.out=len)
+      if (x$measure == "IRSD")
+         c.vals <- seq(ifelse(intrcpt>0, 0, -intrcpt), ifelse(intrcpt>0, 1-intrcpt, 1), length.out=len)
+
+   } else {
+
+      if (length(llim) != 2L)
+         stop(mstyle$stop("Argument 'llim' must be of length 2."))
+
+      c.vals <- seq(llim[1], llim[2], length.out=len)
+
+   }
 
    t.vals <- intrcpt + 1*c.vals
 
+   if (!is.null(llim)) {
+      sel.c  <- c.vals >= llim[1] & c.vals <= llim[2]
+      sel.ct <- t.vals >= llim[1] & c.vals >= llim[1] & t.vals <= llim[2] & c.vals <= llim[2]
+      c.vals <- c.vals[sel.c]
+   }
+
    if (is.function(transf)) {
       if (is.null(targs)) {
          dat.t$yi <- sapply(dat.t$yi, transf)
@@ -253,14 +278,25 @@ add=x$add, to=x$to, transf, targs, pch=21, psize, plim=c(0.5,3.5), col, bg, grid
       }
    }
 
+   #print(round(cbind(c.vals, t.vals), 3))
+
    min.yi <- min(c(dat.t$yi, dat.c$yi))
    max.yi <- max(c(dat.t$yi, dat.c$yi))
 
-   if (missing(xlim))
-      xlim <- c(min.yi, max.yi)
+   if (missing(lim)) {
 
-   if (missing(ylim))
-      ylim <- c(min.yi, max.yi)
+      if (missing(xlim))
+         xlim <- c(min.yi, max.yi)
+
+      if (missing(ylim))
+         ylim <- c(min.yi, max.yi)
+
+   } else {
+
+      xlim <- lim
+      ylim <- lim
+
+   }
 
    ### order points by psize
 
@@ -287,23 +323,32 @@ add=x$add, to=x$to, transf, targs, pch=21, psize, plim=c(0.5,3.5), col, bg, grid
       ylab <- paste(ylab, "(Group 2)")
    }
 
-   plot(NA, NA, xlim=xlim, ylim=ylim, xlab=xlab, ylab=ylab, ...)
+   lplot(NA, NA, xlim=xlim, ylim=ylim, xlab=xlab, ylab=ylab, ...)
 
    ### add grid (and redraw box)
 
    if (.isTRUE(grid)) {
       grid(col=gridcol)
-      box(...)
+      lbox(...)
    }
 
-   ### add diagonal and estimated effects lines
+   ### add diagonal reference line
+
+   #abline(a=0, b=1, lty=lty[1], ...)
+   lsegments(min(c.vals), min(c.vals), max(c.vals), max(c.vals), lty=lty[1], ...)
+
+   ### add estimated effects line
+
+   if (!is.null(llim)) {
+      c.vals <- c.vals[sel.ct]
+      t.vals <- t.vals[sel.ct]
+   }
 
-   abline(a=0, b=1, lty=lty[1], ...)
-   lines(c.vals, t.vals, lty=lty[2], ...)
+   llines(c.vals, t.vals, lty=lty[2], ...)
 
    ### add points
 
-   points(x=dat.c$yi.o, y=dat.t$yi.o, cex=psize.o, pch=pch.o, col=col.o, bg=bg.o, ...)
+   lpoints(x=dat.c$yi.o, y=dat.t$yi.o, cex=psize.o, pch=pch.o, col=col.o, bg=bg.o, ...)
 
    #########################################################################
 

diff --git a/R/zzz.r b/R/zzz.r
@@ -1,6 +1,6 @@
 .onAttach <- function(libname, pkgname) {
 
-   ver <- "4.7-4"
+   ver <- "4.7-5"
 
    loadmsg <- paste0("\nLoading the 'metafor' package (version ", ver, "). For an\nintroduction to the package please type: help(metafor)\n")
 

diff --git a/README.md b/README.md
@@ -5,7 +5,7 @@ metafor: A Meta-Analysis Package for R
 [![R build status](https://github.com/wviechtb/metafor/workflows/R-CMD-check/badge.svg)](https://github.com/wviechtb/metafor/actions)
 [![Code Coverage](https://codecov.io/gh/wviechtb/metafor/branch/master/graph/badge.svg)](https://app.codecov.io/gh/wviechtb/metafor)
 [![CRAN Version](https://www.r-pkg.org/badges/version/metafor)](https://cran.r-project.org/package=metafor)
-[![devel Version](https://img.shields.io/badge/devel-4.7--4-brightgreen.svg)](https://www.metafor-project.org/doku.php/installation#development_version)
+[![devel Version](https://img.shields.io/badge/devel-4.7--5-brightgreen.svg)](https://www.metafor-project.org/doku.php/installation#development_version)
 [![Monthly Downloads](https://cranlogs.r-pkg.org/badges/metafor)](https://cranlogs.r-pkg.org/badges/metafor)
 [![Total Downloads](https://cranlogs.r-pkg.org/badges/grand-total/metafor)](https://cranlogs.r-pkg.org/badges/grand-total/metafor)
 

diff --git a/docs/404.html b/docs/404.html
diff --git a/docs/ISSUE_TEMPLATE.html b/docs/ISSUE_TEMPLATE.html
diff --git a/docs/articles/index.html b/docs/articles/index.html
diff --git a/docs/articles/pkgdown/diagram.html b/docs/articles/pkgdown/diagram.html
diff --git a/docs/authors.html b/docs/authors.html
diff --git a/docs/index.html b/docs/index.html
diff --git a/docs/news/index.html b/docs/news/index.html
diff --git a/docs/pkgdown.yml b/docs/pkgdown.yml
@@ -3,7 +3,7 @@ pkgdown: 2.0.8
 pkgdown_sha: ~
 articles:
   diagram: pkgdown/diagram.html
-last_built: 2024-04-15T20:10Z
+last_built: 2024-04-16T20:32Z
 urls:
   reference: https://wviechtb.github.io/metafor/reference
   article: https://wviechtb.github.io/metafor/articles

diff --git a/docs/reference/addpoly.default.html b/docs/reference/addpoly.default.html
diff --git a/docs/reference/addpoly.html b/docs/reference/addpoly.html
diff --git a/docs/reference/addpoly.predict.rma.html b/docs/reference/addpoly.predict.rma.html
diff --git a/docs/reference/addpoly.rma.html b/docs/reference/addpoly.rma.html
diff --git a/docs/reference/aggregate.escalc.html b/docs/reference/aggregate.escalc.html
diff --git a/docs/reference/anova.rma.html b/docs/reference/anova.rma.html
diff --git a/docs/reference/baujat.html b/docs/reference/baujat.html
diff --git a/docs/reference/bldiag.html b/docs/reference/bldiag.html
diff --git a/docs/reference/blsplit.html b/docs/reference/blsplit.html
diff --git a/docs/reference/blup.html b/docs/reference/blup.html
diff --git a/docs/reference/coef.permutest.rma.uni.html b/docs/reference/coef.permutest.rma.uni.html
diff --git a/docs/reference/coef.rma.html b/docs/reference/coef.rma.html