From a65b442f247710a492a139a118881919e1ecefa2 Mon Sep 17 00:00:00 2001 From: Wolfgang Viechtbauer Date: Tue, 19 Nov 2024 12:59:21 +0100 Subject: [PATCH] Make integral transformation functions vectorized again. --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- R/transf.r | 52 ++++++++++++++++++++++++++++++++-------------------- R/zzz.r | 2 +- README.md | 2 +- 5 files changed, 37 insertions(+), 25 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 36ca5b09..88800895 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: metafor -Version: 4.7-49 -Date: 2024-11-11 +Version: 4.7-50 +Date: 2024-11-19 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 diff --git a/NEWS.md b/NEWS.md index c0ffb59b..5766537e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# metafor 4.7-49 (2024-11-11) +# metafor 4.7-50 (2024-11-19) - 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/transf.r b/R/transf.r index 69b63eff..085ac408 100644 --- a/R/transf.r +++ b/R/transf.r @@ -38,9 +38,6 @@ transf.ztor <- function(xi) transf.ztor.int <- function(xi, targs=NULL) { - if (is.na(xi)) - return(NA_real_) - targs <- .chktargsint(targs) if (is.null(targs$lower)) @@ -51,8 +48,14 @@ transf.ztor.int <- function(xi, targs=NULL) { toint <- function(zval, xi, tau2) tanh(zval) * dnorm(zval, mean=xi, sd=sqrt(tau2)) - cfunc <- function(xi, tau2, lower, upper) - integrate(toint, lower=lower, upper=upper, xi=xi, tau2=tau2)$value + cfunc <- function(xi, tau2, lower, upper) { + out <- try(integrate(toint, lower=lower, upper=upper, xi=xi, tau2=tau2), silent=TRUE) + if (inherits(out, "try-error")) { + return(NA_real_) + } else { + return(out$value) + } + } if (targs$tau2 == 0) { zi <- transf.ztor(xi) @@ -77,9 +80,6 @@ transf.ztor2 <- function(xi) transf.exp.int <- function(xi, targs=NULL) { - if (is.na(xi)) - return(NA_real_) - targs <- .chktargsint(targs) if (is.null(targs$lower)) @@ -90,8 +90,14 @@ transf.exp.int <- function(xi, targs=NULL) { toint <- function(zval, xi, tau2) exp(zval) * dnorm(zval, mean=xi, sd=sqrt(tau2)) - cfunc <- function(xi, tau2, lower, upper) - integrate(toint, lower=lower, upper=upper, xi=xi, tau2=tau2)$value + cfunc <- function(xi, tau2, lower, upper) { + out <- try(integrate(toint, lower=lower, upper=upper, xi=xi, tau2=tau2), silent=TRUE) + if (inherits(out, "try-error")) { + return(NA_real_) + } else { + return(out$value) + } + } if (targs$tau2 == 0) { zi <- exp(xi) @@ -113,9 +119,6 @@ transf.ilogit <- function(xi) transf.ilogit.int <- function(xi, targs=NULL) { - if (is.na(xi)) - return(NA_real_) - targs <- .chktargsint(targs) if (is.null(targs$lower)) @@ -126,8 +129,14 @@ transf.ilogit.int <- function(xi, targs=NULL) { toint <- function(zval, xi, tau2) plogis(zval) * dnorm(zval, mean=xi, sd=sqrt(tau2)) - cfunc <- function(xi, tau2, lower, upper) - integrate(toint, lower=lower, upper=upper, xi=xi, tau2=tau2)$value + cfunc <- function(xi, tau2, lower, upper) { + out <- try(integrate(toint, lower=lower, upper=upper, xi=xi, tau2=tau2), silent=TRUE) + if (inherits(out, "try-error")) { + return(NA_real_) + } else { + return(out$value) + } + } if (targs$tau2 == 0) { zi <- transf.ilogit(xi) @@ -153,9 +162,6 @@ transf.iarcsin <- function(xi) { # transf.iarcsin.int <- function(xi, targs=NULL) { # -# if (is.na(xi)) -# return(NA_real_) -# # targs <- .chktargsint(targs) # # if (is.null(targs$lower)) @@ -166,8 +172,14 @@ transf.iarcsin <- function(xi) { # toint <- function(zval, xi, tau2) # transf.iarcsin(zval) * dnorm(zval, mean=xi, sd=sqrt(tau2)) # -# cfunc <- function(xi, tau2, lower, upper) -# integrate(toint, lower=lower, upper=upper, xi=xi, tau2=tau2)$value +# cfunc <- function(xi, tau2, lower, upper) { +# out <- try(integrate(toint, lower=lower, upper=upper, xi=xi, tau2=tau2), silent=TRUE) +# if (inherits(out, "try-error")) { +# return(NA_real_) +# } else { +# return(out$value) +# } +# } # # if (targs$tau2 == 0) { # zi <- transf.iarcsin(xi) diff --git a/R/zzz.r b/R/zzz.r index 7e80e3c8..d312a05a 100644 --- a/R/zzz.r +++ b/R/zzz.r @@ -1,6 +1,6 @@ .onAttach <- function(libname, pkgname) { - ver <- "4.7-49" + ver <- "4.7-50" 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 index 23eee6d9..2a705a01 100644 --- 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--49-brightgreen.svg)](https://www.metafor-project.org/doku.php/installation#development_version) +[![devel Version](https://img.shields.io/badge/devel-4.7--50-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)