R/print.meta.R
In guido-s/meta: General Package for Meta-Analysis
Defines functions
cilayout
print.meta
Documented in
cilayout
print.meta
#' Print meta-analysis results
#'
#' @description
#' Print method for objects of class \code{meta}.
#'
#' R function cilayout can be utilised to change the layout to print
#' confidence intervals (both in printout from print.meta and
#' print.summary.meta function as well as in forest plots). The
#' default layout is "[lower; upper]". Another popular layout is
#' "(lower - upper)" which is used throughout an R session by using R
#' command \code{cilayout("(", " - ")}.
#'
#' Argument \code{pscale} can be used to rescale single proportions or
#' risk differences, e.g. \code{pscale = 1000} means that proportions
#' are expressed as events per 1000 observations. This is useful in
#' situations with (very) low event probabilities.
#'
#' Argument \code{irscale} can be used to rescale single rates or rate
#' differences, e.g. \code{irscale = 1000} means that rates are
#' expressed as events per 1000 time units, e.g. person-years. This is
#' useful in situations with (very) low rates. Argument \code{irunit}
#' can be used to specify the time unit used in individual studies
#' (default: "person-years"). This information is printed in summaries
#' and forest plots if argument \code{irscale} is not equal to 1.
#'
#' @aliases print.meta cilayout
#'
#' @param x An object of class \code{meta}.
#' @param common A logical indicating whether results for common
#' effect meta-analysis should be printed.
#' @param random A logical indicating whether results for random
#' effects meta-analysis should be printed.
#' @param prediction A logical indicating whether a prediction
#' interval should be printed.
#' @param overall A logical indicating whether overall summaries
#' should be reported. This argument is useful in a meta-analysis
#' with subgroups if overall results should not be reported.
#' @param overall.hetstat A logical value indicating whether to print
#' heterogeneity measures for overall treatment comparisons. This
#' argument is useful in a meta-analysis with subgroups if
#' heterogeneity statistics should only be printed on subgroup
#' level.
#' @param test.subgroup A logical value indicating whether to print
#' results of test for subgroup differences.
#' @param test.subgroup.common A logical value indicating whether to
#' print results of test for subgroup differences (based on common
#' effect model).
#' @param test.subgroup.random A logical value indicating whether to
#' print results of test for subgroup differences (based on random
#' effects model).
#' @param prediction.subgroup A single logical or logical vector
#' indicating whether / which prediction intervals should be printed
#' for subgroups.
#' @param backtransf A logical indicating whether printed results
#' should be back transformed. If \code{backtransf=TRUE}, results
#' for \code{sm="OR"} are printed as odds ratios rather than log
#' odds ratios and results for \code{sm="ZCOR"} are printed as
#' correlations rather than Fisher's z transformed correlations, for
#' example.
#' @param pscale A numeric giving scaling factor for printing of
#' single event probabilities or risk differences, i.e. if argument
#' \code{sm} is equal to \code{"PLOGIT"}, \code{"PLN"},
#' \code{"PRAW"}, \code{"PAS"}, \code{"PFT"}, or \code{"RD"}.
#' @param irscale A numeric defining a scaling factor for printing of
#' single incidence rates or incidence rate differences, i.e. if
#' argument \code{sm} is equal to \code{"IR"}, \code{"IRLN"},
#' \code{"IRS"}, \code{"IRFT"}, or \code{"IRD"}.
#' @param irunit A character specifying the time unit used to
#' calculate rates, e.g. person-years.
#' @param subgroup.name A character string with a name for the
#' grouping variable.
#' @param print.subgroup.name A logical indicating whether the name of
#' the grouping variable should be printed in front of the group
#' labels.
#' @param sep.subgroup A character string defining the separator
#' between label and levels of grouping variable.
#' @param nchar.subgroup A numeric specifying the number of characters
#' to print from subgroup labels.
#' @param sort.overall An optional vector used to sort meta-analysis
#' results.
#' @param sort.tau An optional vector used to sort estimators of the
#' between-study heterogeneity variance.
#' @param sort.het An optional vector used to sort heterogeneity
#' statistics.
#' @param sort.Q An optional vector used to sort test of
#' heterogeneity.
#' @param header A logical indicating whether information on title of
#' meta-analysis, comparison and outcome should be printed at the
#' beginning of the printout.
#' @param print.CMH A logical indicating whether result of the
#' Cochran-Mantel-Haenszel test for overall effect should be
#' printed.
#' @param digits Minimal number of significant digits, see
#' \code{print.default}.
#' @param digits.stat Minimal number of significant digits for z- or
#' t-value of test for overall effect, see \code{print.default}.
#' @param digits.pval Minimal number of significant digits for p-value
#' of overall treatment effect, see \code{print.default}.
#' @param digits.pval.Q Minimal number of significant digits for
#' p-value of heterogeneity test, see \code{print.default}.
#' @param digits.Q Minimal number of significant digits for
#' heterogeneity statistic Q, see \code{print.default}.
#' @param digits.tau2 Minimal number of significant digits for
#' between-study variance \eqn{\tau^2}, see \code{print.default}.
#' @param digits.tau Minimal number of significant digits for
#' \eqn{\tau}, the square root of the between-study variance
#' \eqn{\tau^2}.
#' @param digits.H Minimal number of significant digits for H
#' statistic, see \code{print.default}.
#' @param digits.I2 Minimal number of significant digits for I-squared
#' and Rb statistic, see \code{print.default}.
#' @param scientific.pval A logical specifying whether p-values should
#' be printed in scientific notation, e.g., 1.2345e-01 instead of
#' 0.12345.
#' @param big.mark A character used as thousands separator.
#' @param zero.pval A logical specifying whether p-values should be
#' printed with a leading zero.
#' @param JAMA.pval A logical specifying whether p-values for test of
#' overall effect should be printed according to JAMA reporting
#' standards.
#' @param digits.df Minimal number of significant digits for degrees
#' of freedom.
#' @param print.tau2 A logical specifying whether between-study
#' variance \eqn{\tau^2} should be printed.
#' @param print.tau2.ci A logical value indicating whether to print
#' the confidence interval of \eqn{\tau^2}.
#' @param print.tau A logical specifying whether \eqn{\tau}, the
#' square root of the between-study variance \eqn{\tau^2}, should be
#' printed.
#' @param print.tau.ci A logical value indicating whether to print the
#' confidence interval of \eqn{\tau}.
#' @param print.I2 A logical specifying whether heterogeneity
#' statistic I\eqn{^2} should be printed.
#' @param print.H A logical specifying whether heterogeneity statistic
#' H should be printed.
#' @param print.Rb A logical specifying whether heterogeneity
#' statistic R\eqn{_b} should be printed.
#' @param text.tau2 Text printed to identify between-study variance
#' \eqn{\tau^2}.
#' @param text.tau Text printed to identify \eqn{\tau}, the square
#' root of the between-study variance \eqn{\tau^2}.
#' @param text.I2 Text printed to identify heterogeneity statistic
#' I\eqn{^2}.
#' @param text.Rb Text printed to identify heterogeneity statistic
#' R\eqn{_b}.
#' @param print.Q A logical value indicating whether to print the
#' results of the test of heterogeneity.
#' @param details.methods A logical specifying whether details on
#' statistical methods should be printed.
#' @param warn.backtransf Deprecated argument (ignored).
#' @param func.backtransf A function used to back-transform results.
#' @param bracket A character with bracket symbol to print lower
#' confidence interval: "[", "(", "\{", "".
#' @param separator A character string with information on separator
#' between lower and upper confidence interval.
#' @param lower.blank A logical indicating whether blanks between left
#' bracket and lower confidence limit should be printed.
#' @param upper.blank A logical indicating whether blanks between
#' separator and upper confidence limit should be printed.
#' @param warn.deprecated A logical indicating whether warnings should
#' be printed if deprecated arguments are used.
#' @param \dots Additional arguments (passed on to \code{prmatrix}).
#'
#' @rdname print.meta
#' @method print meta
#' @export
print.meta <- function(x,
common = x$common,
random = x$random,
prediction = x$prediction,
overall = x$overall,
overall.hetstat = x$overall.hetstat,
##
test.subgroup = x$test.subgroup,
test.subgroup.common = test.subgroup & common,
test.subgroup.random = test.subgroup & random,
prediction.subgroup = x$prediction.subgroup,
##
backtransf = x$backtransf,
pscale = x$pscale,
irscale = x$irscale,
irunit = x$irunit,
##
subgroup.name = x$subgroup.name,
print.subgroup.name = x$print.subgroup.name,
sep.subgroup = x$sep.subgroup,
nchar.subgroup = 35,
##
sort.overall = NULL,
sort.tau = NULL,
sort.het = NULL,
sort.Q = NULL,
##
header = TRUE,
print.CMH = x$print.CMH,
##
digits = gs("digits"),
digits.stat = gs("digits.stat"),
digits.pval = max(gs("digits.pval"), 2),
digits.pval.Q = max(gs("digits.pval.Q"), 2),
digits.Q = gs("digits.Q"),
digits.tau2 = gs("digits.tau2"),
digits.tau = gs("digits.tau"),
digits.H = gs("digits.H"),
digits.I2 = gs("digits.I2"),
##
scientific.pval = gs("scientific.pval"),
big.mark = gs("big.mark"),
zero.pval = gs("zero.pval"),
JAMA.pval = gs("JAMA.pval"),
##
digits.df = gs("digits.df"),
##
print.tau2 = gs("print.tau2"),
print.tau2.ci = gs("print.tau2.ci"),
print.tau = gs("print.tau"),
print.tau.ci = gs("print.tau.ci"),
##
print.I2 = gs("print.I2"),
print.H = gs("print.H"),
print.Rb = gs("print.Rb"),
##
text.tau2 = gs("text.tau2"),
text.tau = gs("text.tau"),
text.I2 = gs("text.I2"),
text.Rb = gs("text.Rb"),
##
print.Q = gs("print.Q"),
##
details.methods = gs("details"),
##
warn.backtransf = FALSE,
func.backtransf = x$func.backtransf,
warn.deprecated = gs("warn.deprecated"),
...) {
##
##
## (1) Check for meta object
##
##
chkclass(x, "meta")
x <- updateversion(x)
##
if (inherits(x, "metacum") | inherits(x, "metainf"))
return(invisible(NULL))
##
is.metabind <- inherits(x, "metabind")
is.netpairwise <- inherits(x, "netpairwise")
##
by <- !is.null(x$subgroup)
##
if (by)
n.by <- length(x$subgroup.levels)
##
method.random.ci <- replaceNULL(x$method.random.ci, "")
method.predict <- replaceNULL(x$method.predict, "")
##
if (is.function(func.backtransf))
fbt <- deparse(substitute(func.backtransf))
else
fbt <- func.backtransf
##
abt <- x$args.backtransf
##
##
## (2) Check and set other arguments
##
##
sfsp <- sys.frame(sys.parent())
mc <- match.call()
##
chknumeric(digits, min = 0, length = 1)
chknumeric(digits.tau2, min = 0, length = 1)
chknumeric(digits.tau, min = 0, length = 1)
chknumeric(digits.stat, min = 0, length = 1)
chknumeric(digits.pval, min = 1, length = 1)
chknumeric(digits.pval.Q, min = 1, length = 1)
chknumeric(digits.Q, min = 0, length = 1)
chknumeric(digits.H, min = 0, length = 1)
chknumeric(digits.I2, min = 0, length = 1)
chklogical(scientific.pval)
chklogical(zero.pval)
chklogical(JAMA.pval)
##
chklogical(print.tau2)
chklogical(print.tau2.ci)
chklogical(print.tau)
chklogical(print.tau.ci)
##
chklogical(print.I2)
chklogical(print.H)
chklogical(print.Rb)
chkchar(text.tau2, length = 1)
chkchar(text.tau, length = 1)
chkchar(text.I2, length = 1)
chkchar(text.Rb, length = 1)
chklogical(print.Q)
##
chklogical(warn.deprecated)
##
missing.pscale <- missing(pscale)
if (!is.null(pscale))
chknumeric(pscale, length = 1)
else
pscale <- 1
##
missing.irscale <- missing(irscale)
if (!is.null(irscale))
chknumeric(irscale, length = 1)
else
irscale <- 1
if (!is.null(irunit) && !is.na(irunit))
chkchar(irunit)
##
chklogical(common)
chklogical(random)
chklogical(prediction)
overall <- replaceNULL(overall, TRUE)
chklogical(overall)
overall.hetstat <- replaceNULL(overall.hetstat, TRUE)
chklogical(overall.hetstat)
test.subgroup <- replaceNULL(test.subgroup, TRUE)
if (is.na(test.subgroup))
test.subgroup <- FALSE
chklogical(test.subgroup)
test.subgroup.common <- replaceNULL(test.subgroup.common, test.subgroup)
chklogical(test.subgroup.common)
test.subgroup.random <- replaceNULL(test.subgroup.random, test.subgroup)
chklogical(test.subgroup.random)
##
missing.prediction.subgroup <- missing(prediction.subgroup)
##
if (by) {
x$lower.predict.w <- list2mat(x$lower.predict.w)
x$upper.predict.w <- list2mat(x$upper.predict.w)
x$df.predict.w <- list2mat(x$df.predict.w)
##
if (!missing.prediction.subgroup)
prediction.subgroup <- catch("prediction.subgroup", mc, x, sfsp)
##
prediction.subgroup <- replaceNULL(prediction.subgroup, FALSE)
##
if (length(prediction.subgroup) == 1) {
if (is.matrix(x$lower.predict.w)) {
prediction.subgroup.logical <-
prediction.subgroup &
apply(x$lower.predict.w, 1, notallNA) &
apply(x$upper.predict.w, 1, notallNA)
}
else {
prediction.subgroup.logical <-
prediction.subgroup &
notallNA(x$lower.predict.w) &
notallNA(x$upper.predict.w)
##
prediction.subgroup.logical <-
rep(prediction.subgroup.logical, n.by)
}
}
else {
chklength(prediction.subgroup, n.by,
text = paste("Length of argument 'prediction.subgroup' must be",
"equal to 1 or number of subgroups."))
prediction.subgroup.logical <- prediction.subgroup
}
##
if (length(prediction.subgroup.logical) == 0)
prediction.subgroup.logical <- FALSE
##
chklogical(prediction.subgroup.logical[1])
##
if (missing.prediction.subgroup) {
if (any(method.predict %in% c("", "S")))
prediction.w <- prediction.subgroup.logical
else
prediction.w <- prediction.subgroup.logical & !is.na(x$df.predict.w)
}
else
prediction.w <- prediction.subgroup.logical
##
prediction.w[is.na(prediction.w)] <- FALSE
prediction.w <- any(prediction.w) & !is.metabind
}
else
prediction.w <- FALSE
##
if (!is.null(print.CMH))
chklogical(print.CMH)
##
sort.tau <- catch("sort.tau", mc, x, sfsp)
if (is.list(sort.tau))
sort.tau <- unlist(sort.tau)
##
sort.het <- catch("sort.het", mc, x, sfsp)
if (is.list(sort.het))
sort.het <- unlist(sort.het)
##
sort.Q <- catch("sort.Q", mc, x, sfsp)
if (is.list(sort.Q))
sort.Q <- unlist(sort.Q)
##
chklogical(header)
##
chklogical(details.methods)
##
## Check for deprecated arguments in '...'
##
args <- list(...)
##
missing.common <- missing(common)
common <- deprecated(common, missing.common, args, "comb.fixed",
warn.deprecated)
common <- deprecated(common, missing.common, args, "fixed",
warn.deprecated)
chklogical(common)
##
random <- deprecated(random, missing(random), args, "comb.random", FALSE)
chklogical(random)
##
subgroup.name <-
deprecated(subgroup.name, missing(subgroup.name), args, "bylab", FALSE)
##
print.subgroup.name <-
deprecated(print.subgroup.name, missing(print.subgroup.name),
args, "print.byvar", FALSE)
##
sep.subgroup <-
deprecated(sep.subgroup, missing(sep.subgroup), args, "byseparator",
FALSE)
##
nchar.subgroup <-
deprecated(nchar.subgroup, missing(nchar.subgroup), args, "nchar.subgroup",
warn.deprecated)
chknumeric(nchar.subgroup, min = 1, length = 1)
##
backtransf <-
deprecated(backtransf, missing(backtransf), args, "logscale",
warn.deprecated)
if (is_untransformed(x$sm))
backtransf <- TRUE
chklogical(backtransf)
##
## Additional settings
##
if (!backtransf & pscale != 1 & !is_untransformed(x$sm)) {
if (!missing.pscale)
warning("Argument 'pscale' set to 1 as argument 'backtransf' is FALSE.")
pscale <- 1
}
if (!backtransf & irscale != 1 & !is_untransformed(x$sm)) {
if (!missing.irscale)
warning("Argument 'irscale' set to 1 as argument 'backtransf' is FALSE.")
irscale <- 1
}
##
if (by) {
chklogical(print.subgroup.name)
chkchar(sep.subgroup)
}
else {
if (!missing.prediction.subgroup)
warning("Argument 'prediction.subgroup' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
}
##
##
## (3) Some additional settings
##
##
k.all <- replaceNULL(x$k.all, length(x$TE))
k <- x$k
k.study <- replaceNULL(x$k.study, k)
sm <- x$sm
##
bip <- inherits(x, c("metabin", "metainc", "metaprop", "metarate"))
metabin <- inherits(x, "metabin")
metaprop <- inherits(x, "metaprop")
metarate <- inherits(x, "metarate")
##
null.effect <- x$null.effect
null.given <- !is.null(null.effect) && !is.na(null.effect)
##
if (null.given & !backtransf) {
##
if (sm %in% c("PFT", "PAS"))
null.effect <- asin(sqrt(null.effect))
else if (is_log_effect(sm))
null.effect <- log(null.effect)
else if (sm == c("PLOGIT"))
null.effect <- log(null.effect / (1 - null.effect))
else if (sm %in% c("IRS", "IRFT"))
null.effect <- sqrt(null.effect)
else if (sm == "ZCOR")
null.effect <- 0.5 * log((1 + null.effect) / (1 - null.effect))
}
##
x$null.effect <- null.effect
##
if (is.null(prediction) || is.na(prediction))
prediction <- FALSE
#
sm.lab <- smlab(sm, backtransf, pscale, irscale)
#
if (length(x$tau.common) == 0)
x$tau.common <- FALSE
##
if (length(x$tau.common) == 0)
x$tau.common <- FALSE
##
if (by)
subgroup.levels <-
ifelse(nchar(x$subgroup.levels) > nchar.subgroup,
paste0(substring(x$subgroup.levels, 1, nchar.subgroup - 4),
" ..."),
x$subgroup.levels)
##
if (is.null(x$text.common))
text.common <- gs("text.common")
else
text.common <- x$text.common
##
if (is.null(x$text.random))
text.random <- gs("text.random")
else
text.random <- x$text.random
##
if (is.null(x$text.predict))
text.predict <- gs("text.predict")
else
text.predict <- x$text.predict
##
if (any(substring(text.common, 1, 5) %in% c("Fixed", "Commo"))) {
text.common.br <- gsub("Fixed", "fixed", text.common)
text.common.br <- gsub("Common", "common", text.common.br)
text.common.br <- gsub("Effect", "effect", text.common.br)
}
else
text.common.br <- text.common
##
if (any(substring(text.random, 1, 5) %in% c("Rando"))) {
text.random.br <- gsub("Random", "random", text.random)
text.random.br <- gsub("Effect", "effect", text.random.br)
}
else
text.random.br <- text.random
##
ci.lab <- paste0(round(100 * x$level.ma, 1), "%-CI")
##
details <- NULL
##
##
## (4) Set and backtransform results of meta-analysis
##
##
TE.common <- x$TE.common
lowTE.common <- x$lower.common
uppTE.common <- x$upper.common
pTE.common <- x$pval.common
sTE.common <- x$statistic.common
##
TE.random <- x$TE.random
lowTE.random <- x$lower.random
uppTE.random <- x$upper.random
if (length(TE.random) == 1 &&
length(TE.random) != length(lowTE.random))
TE.random <- rep_len(TE.random, length(lowTE.random))
##
lowTE.predict <- x$lower.predict
uppTE.predict <- x$upper.predict
##
Q <- unlist(x$Q)
df.Q <- replaceNULL(unlist(x$df.Q), k - 1)
pval.Q <- replaceNULL(unlist(x$pval.Q), pvalQ(Q, df.Q))
##
if (!is.null(x$Q.CMH)) {
Q.CMH <- unlist(x$Q.CMH)
df.Q.CMH <- replaceNULL(unlist(x$df.Q.CMH), 1)
pval.Q.CMH <- replaceNULL(unlist(x$pval.Q.CMH), pvalQ(Q.CMH, df.Q.CMH))
}
##
if (by) {
k.w <- x$k.w
##
TE.common.w <- list2mat(x$TE.common.w)
lowTE.common.w <- list2mat(x$lower.common.w)
uppTE.common.w <- list2mat(x$upper.common.w)
pval.common.w <- list2mat(x$pval.common.w)
##
lowTE.random.w <- list2mat(x$lower.random.w)
TE.random.w <- list2mat(x$TE.random.w, lowTE.random.w)
##
uppTE.random.w <- list2mat(x$upper.random.w)
pval.random.w <- list2mat(x$pval.random.w)
##
if (!is.matrix(TE.random.w) & is.matrix(lowTE.random.w)) {
TE.random.w <-
matrix(TE.random.w,
nrow = nrow(lowTE.random.w),
ncol = ncol(lowTE.random.w))
rownames(TE.random.w) <- rownames(lowTE.random.w)
colnames(TE.random.w) <- colnames(lowTE.random.w)
}
##
lowTE.predict.w <- x$lower.predict.w
uppTE.predict.w <- x$upper.predict.w
##
harmonic.mean.w <- x$n.harmonic.mean.w
##
Q.b.common <- unlist(x$Q.b.common)
names(Q.b.common) <- colnames(lowTE.common.w)
Q.w.common <- x$Q.w.common
##
Q.b.random <- unlist(x$Q.b.random)
Q.w.random <- x$Q.w.random
##
Q.w <- x$Q.w
##
df.Q.w <- replaceNULL(x$df.Q.w, sum((k.w - 1)[!is.na(x$Q.w)]))
df.Q.b <- replaceNULL(x$df.Q.b, (k - 1) - sum((k.w - 1)[!is.na(x$Q.w)]))
df.Q.b.common <- replaceNULL(x$df.Q.b.common, df.Q.b)
df.Q.b.random <- replaceNULL(x$df.Q.b.random, df.Q.b)
##
pval.Q.b.common <-
replaceNULL(x$pval.Q.b.common, pvalQ(Q.b.common, df.Q.b.common))
pval.Q.w.common <-
replaceNULL(x$pval.Q.w.common, pvalQ(Q.w.common, df.Q.w))
##
pval.Q.b.random <-
unlist(replaceNULL(x$pval.Q.b.random, pvalQ(Q.b.random, df.Q.b.random)))
pval.Q.w.random <-
unlist(replaceNULL(x$pval.Q.w.random, pvalQ(Q.w.random, df.Q.w)))
}
##
if (backtransf) {
if (sm == "IRFT") {
if (is.metabind)
harmonic.mean <- x$t.harmonic.mean.ma
else
harmonic.mean <- 1 / mean(1 / x$time)
}
else {
if (is.metabind)
harmonic.mean <- x$n.harmonic.mean.ma
else
harmonic.mean <- 1 / mean(1 / x$n)
}
##
TE.common <-
backtransf(TE.common, sm, harmonic.mean, harmonic.mean, fbt, abt)
lowTE.common <-
backtransf(lowTE.common, sm, harmonic.mean, harmonic.mean, fbt, abt)
uppTE.common <-
backtransf(uppTE.common, sm, harmonic.mean, harmonic.mean, fbt, abt)
##
TE.random <-
backtransf(TE.random, sm, harmonic.mean, harmonic.mean, fbt, abt)
lowTE.random <-
backtransf(lowTE.random, sm, harmonic.mean, harmonic.mean, fbt, abt)
uppTE.random <-
backtransf(uppTE.random, sm, harmonic.mean, harmonic.mean, fbt, abt)
##
lowTE.predict <-
backtransf(lowTE.predict, sm, harmonic.mean, harmonic.mean, fbt, abt)
uppTE.predict <-
backtransf(uppTE.predict, sm, harmonic.mean, harmonic.mean, fbt, abt)
##
if (by) {
TE.common.w <-
backtransf(TE.common.w, sm, harmonic.mean.w, harmonic.mean.w,
fbt, abt)
lowTE.common.w <-
backtransf(lowTE.common.w, sm, harmonic.mean.w, harmonic.mean.w,
fbt, abt)
uppTE.common.w <-
backtransf(uppTE.common.w, sm, harmonic.mean.w, harmonic.mean.w)
##
TE.random.w <-
backtransf(TE.random.w, sm, harmonic.mean.w, harmonic.mean.w, fbt, abt)
lowTE.random.w <-
backtransf(lowTE.random.w, sm, harmonic.mean.w, harmonic.mean.w,
fbt, abt)
uppTE.random.w <-
backtransf(uppTE.random.w, sm, harmonic.mean.w, harmonic.mean.w,
fbt, abt)
##
if (prediction.w) {
lowTE.predict.w <-
backtransf(lowTE.predict.w, sm, harmonic.mean.w, harmonic.mean.w,
fbt, abt)
uppTE.predict.w <-
backtransf(uppTE.predict.w, sm, harmonic.mean.w, harmonic.mean.w,
fbt, abt)
}
}
}
##
## Apply argument 'pscale' to proportions / risk differences and
## 'irscale' to rates / incidence rate differences
##
if (pscale != 1 || irscale != 1) {
if (pscale != 1 && irscale != 1)
stop("Provide either arguments 'pscale' or 'irscale' but not ",
"both arguments.",
call. = FALSE)
if (pscale != 1)
scale <- pscale
else
scale <- irscale
##
TE.common <- scale * TE.common
lowTE.common <- scale * lowTE.common
uppTE.common <- scale * uppTE.common
##
TE.random <- scale * TE.random
lowTE.random <- scale * lowTE.random
uppTE.random <- scale * uppTE.random
##
lowTE.predict <- scale * lowTE.predict
uppTE.predict <- scale * uppTE.predict
##
if (by) {
TE.common.w <- scale * TE.common.w
lowTE.common.w <- scale * lowTE.common.w
uppTE.common.w <- scale * uppTE.common.w
##
TE.random.w <- scale * TE.random.w
lowTE.random.w <- scale * lowTE.random.w
uppTE.random.w <- scale * uppTE.random.w
##
if (prediction.w) {
lowTE.predict.w <- scale * lowTE.predict.w
uppTE.predict.w <- scale * uppTE.predict.w
}
}
}
##
## Switch lower and upper limit for VE if results have been
## backtransformed
##
if (backtransf & sm == "VE") {
tmp.l <- lowTE.common
lowTE.common <- uppTE.common
uppTE.common <- tmp.l
##
tmp.l <- lowTE.random
lowTE.random <- uppTE.random
uppTE.random <- tmp.l
##
tmp.l <- lowTE.predict
lowTE.predict <- uppTE.predict
uppTE.predict <- tmp.l
##
if (by) {
tmp.l <- lowTE.common.w
lowTE.common.w <- uppTE.common.w
uppTE.common.w <- tmp.l
##
tmp.l <- lowTE.random.w
lowTE.random.w <- uppTE.random.w
uppTE.random.w <- tmp.l
##
if (prediction.w) {
tmp.l <- lowTE.predict.w
lowTE.predict.w <- uppTE.predict.w
uppTE.predict.w <- tmp.l
}
}
}
##
## Round and round ...
##
TE.common <- round(TE.common, digits)
lowTE.common <- round(lowTE.common, digits)
uppTE.common <- round(uppTE.common, digits)
sTE.common <- round(sTE.common, digits.stat)
##
TE.random <- round(TE.random, digits)
lowTE.random <- round(lowTE.random, digits)
uppTE.random <- round(uppTE.random, digits)
pTE.random <- x$pval.random
sTE.random <- round(x$statistic.random, digits.stat)
##
lowTE.predict <- round(lowTE.predict, digits)
uppTE.predict <- round(uppTE.predict, digits)
##
if (by) {
TE.common.w <- round(TE.common.w, digits)
lowTE.common.w <- round(lowTE.common.w, digits)
uppTE.common.w <- round(uppTE.common.w, digits)
##
TE.random.w <- round(TE.random.w, digits)
lowTE.random.w <- round(lowTE.random.w, digits)
uppTE.random.w <- round(uppTE.random.w, digits)
##
if (prediction.w) {
lowTE.predict.w <- round(lowTE.predict.w, digits)
uppTE.predict.w <- round(uppTE.predict.w, digits)
}
##
if (print.I2)
I2.w <- round(100 * x$I2.w, digits.I2)
else
I2.w <- NA
##
if (print.Rb)
Rb.w <- round(100 * x$Rb.w, digits.I2)
else
Rb.w <- NA
}
##
if (print.H) {
H <- round(unlist(x$H), digits.H)
lowH <- round(unlist(x$lower.H), digits.H)
uppH <- round(unlist(x$upper.H), digits.H)
if (all(!is.na(lowH) & !is.na(uppH)) && all(lowH == uppH)) {
lowH <- NA
uppH <- NA
}
}
else {
H <- lowH <- uppH <- NULL
}
##
if (print.I2) {
I2 <- round(100 * unlist(x$I2), digits.I2)
lowI2 <- round(100 * unlist(x$lower.I2), digits.I2)
uppI2 <- round(100 * unlist(x$upper.I2), digits.I2)
##
if (is.null(names(Q)))
Q4I2 <- Q
else
Q4I2 <- Q[!grepl("LRT", names(Q))]
##
print.I2.ci <-
ifelse(((Q4I2 > max(k, na.rm = TRUE) & max(k, na.rm = TRUE) >= 2) |
(Q4I2 <= max(k, na.rm = TRUE) & max(k, na.rm = TRUE) > 2)) &
!(is.na(lowI2) | is.na(uppI2)), TRUE, FALSE)
##
print.I2.ci[is.na(print.I2.ci)] <- FALSE
print.I2.ci <- print.I2.ci & !(lowI2 == uppI2)
print.I2.ci <- any(print.I2.ci)
}
else {
I2 <- lowI2 <- uppI2 <- NULL
print.I2.ci <- FALSE
}
##
if (print.Rb) {
Rb <- round(100 * unlist(x$Rb), digits.I2)
lowRb <- round(100 * unlist(x$lower.Rb), digits.I2)
uppRb <- round(100 * unlist(x$upper.Rb), digits.I2)
##
if (all(!is.na(lowRb) & !is.na(uppRb)) && all(lowRb == uppRb)) {
lowRb <- rep(NA, length(Rb))
uppRb <- rep(NA, length(Rb))
}
}
else {
Rb <- lowRb <- uppRb <- NULL
print.Rb.ci <- FALSE
}
##
method <- x$method
method.random <- x$method.random
##
three.level <- if (is.null(x$three.level)) FALSE else any(x$three.level)
is.glmm <- any(method == "GLMM") | any(method.random == "GLMM")
##
sel.n <- inherits(x, c("metacor", "metaprop", "metamean", "metarate"))
##
sel.ev <- inherits(x, c("metaprop", "metarate"))
##
##
## (5) Print result for meta-analysis
##
##
is.metamiss <- inherits(x, "metamiss")
if (header) {
if (is.metamiss)
cat("Sensitivity analysis for missing binary data\n")
##
crtitle(x)
}
##
if (all(is.na(k.all))) {
## Do nothing
return(invisible(NULL))
}
else if (all(k.all == 1)) {
##
## Print results for a single study
##
if (!(metaprop | metarate) | (overall & (common | random)) |
overall.hetstat | by)
method <- ifelse(method == "Peto", method, "")
##
if (!is.metabind) {
if (is.metamiss)
cat("\n")
else if (sel.n)
catobsev(if (is.null(x$exclude)) x$n else x$n[!x$exclude],
type = "n")
else
catobsev(if (is.null(x$exclude)) x$n.e else x$n.e[!x$exclude],
if (is.null(x$exclude)) x$n.c else x$n.c[!x$exclude],
type = "n")
##
if (sel.ev)
catobsev(if (is.null(x$exclude)) x$event else x$event[!x$exclude],
type = "e", addrow = TRUE)
else if (!is.metamiss)
catobsev(if (is.null(x$exclude)) x$event.e else x$event.e[!x$exclude],
if (is.null(x$exclude)) x$event.c else x$event.c[!x$exclude],
type = "e", addrow = TRUE)
}
##
res <- cbind(formatN(TE.common, digits, "NA",
big.mark = big.mark),
formatCI(formatN(lowTE.common, digits, "NA",
big.mark = big.mark),
formatN(uppTE.common, digits, "NA",
big.mark = big.mark)),
if (null.given)
formatN(sTE.common, digits.stat, big.mark = big.mark),
if (null.given)
formatPT(pTE.common, digits = digits.pval,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
dimnames(res) <- list(x$studlab,
c(sm.lab, ci.lab,
if (null.given) "z",
if (null.given) "p-value"))
prmatrix(res, quote = FALSE, right = TRUE, ...)
##
## Print information on meta-analysis method:
##
x$pscale <- pscale
x$irscale <- irscale
x$irunit <- irunit
##
if (details.methods)
details <-
catmeth(x,
common, random, prediction, overall, overall.hetstat,
x$func.transf, backtransf, fbt,
big.mark, digits, digits.tau, text.tau, text.tau2,
print.tau2 = FALSE)
}
else {
##
##
## Print results for meta-analysis with more than one study
##
##
if (header & is.metamiss)
cat("\n")
##
if (all(!is.na(k))) {
if (overall & (common | random | prediction)) {
if (!inherits(x, "trimfill")) {
if (any(method == "MH") &&
(inherits(x, c("metabin", "metainc")) &
common & sm %in% c("RD", "IRD") &
(!is.null(x$k.MH) && any(k != x$k.MH, na.rm = TRUE))))
cat(paste0("Number of studies: k.MH = ",
cond(x$k.MH, digits = 0),
" (", text.common.br[1], "), k = ",
format(cond(k, digits = 0),
big.mark = big.mark),
" (", text.random.br[1], ")\n",
collapse = ""))
else {
if (any(k.study != k, na.rm = TRUE)) {
cat(paste0("Number of studies: n = ",
format(cond(x$k.study, digits = 0),
big.mark = big.mark), "\n",
collapse = ""))
cat(paste0("Number of estimates: k = ",
format(cond(k, digits = 0),
big.mark = big.mark), "\n",
collapse = ""))
}
else
cat(paste0("Number of studies: k = ",
format(cond(k, digits = 0),
big.mark = big.mark), "\n",
collapse = ""))
}
}
else
cat(paste0("Number of studies: k = ",
format(cond(k, digits = 0),
big.mark = big.mark),
" (with ",
format(cond(x$k0, digits = 0),
big.mark = big.mark),
" added studies)\n",
collapse = ""))
##
if (!is.metabind) {
if (is.metamiss)
cat("\n")
else if (sel.n)
catobsev(if (is.null(x$exclude)) x$n else x$n[!x$exclude],
type = "n")
else
catobsev(if (is.null(x$exclude)) x$n.e else x$n.e[!x$exclude],
if (is.null(x$exclude)) x$n.c else x$n.c[!x$exclude],
type = "n")
##
if (sel.ev)
catobsev(if (is.null(x$exclude)) x$event else x$event[!x$exclude],
type = "e", addrow = TRUE)
else if (!is.metamiss)
catobsev(if (is.null(x$exclude)) x$event.e
else x$event.e[!x$exclude],
if (is.null(x$exclude)) x$event.c
else x$event.c[!x$exclude],
type = "e", addrow = TRUE)
}
##
res <- cbind(formatN(c(if (common) TE.common,
if (random) TE.random,
if (prediction)
rep(NA, length(lowTE.predict))),
digits, "NA",
big.mark = big.mark),
formatCI(formatN(c(if (common) lowTE.common,
if (random) lowTE.random,
if (prediction) lowTE.predict),
digits, "NA", big.mark = big.mark),
formatN(c(if (common) uppTE.common,
if (random) uppTE.random,
if (prediction) uppTE.predict),
digits, "NA", big.mark = big.mark)),
if (null.given)
formatN(c(if (common) sTE.common,
if (random) sTE.random,
if (prediction)
rep(NA, length(lowTE.predict))),
digits = digits.stat, big.mark = big.mark),
if (null.given)
formatPT(c(if (common) pTE.common,
if (random) pTE.random,
if (prediction)
rep(NA, length(lowTE.predict))),
digits = digits.pval,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
if (prediction) {
seq <- (nrow(res) - length(lowTE.predict) + 1):nrow(res)
res[seq, 1] <- ""
if (null.given)
res[seq, 3:4] <- ""
}
##
if (any(method.random.ci %in% c("HK", "KR"))) {
if (common & random)
zlab <- "z|t"
else if (common & !random)
zlab <- "z"
else if (!common & random)
zlab <- "t"
}
else
zlab <- "z"
##
if (prediction)
if (x$level.ma == x$level.predict)
lab.predict <- text.predict
else
lab.predict <-
paste0(text.predict,
" (", round(100 * x$level.predict, 1), "%-PI)")
##
dimnames(res) <- list(c(if (common) text.common,
if (random) text.random,
if (prediction) lab.predict),
c(sm.lab, ci.lab,
if (null.given) zlab,
if (null.given) "p-value"))
##
sort.overall <- setsort(sort.overall, nrow(res), "overall results")
##
prmatrix(res[sort.overall, , drop = FALSE],
quote = FALSE, right = TRUE, ...)
##
if (metabin && print.CMH) {
Qdata <- cbind(formatN(round(Q.CMH, digits.Q), digits.Q, "NA",
big.mark = big.mark),
df.Q.CMH,
formatPT(pval.Q.CMH,
digits = digits.pval.Q,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
dimnames(Qdata) <- list("", c("Q", "d.f.", "p-value"))
##
cat("\nCochran-Mantel-Haenszel (CMH) test for overall effect: \n")
prmatrix(Qdata, quote = FALSE, right = TRUE, ...)
}
}
else {
if (any(k.study != k)) {
cat(paste0("Number of studies: ",
if (is.netpairwise) "k" else "n", " = ",
format(cond(x$k.study, digits = 0),
big.mark = big.mark), "\n"))
cat(paste0("Number of ",
if (is.netpairwise)
"pairwise comparisons: m = " else "estimates: k = ",
format(cond(k, digits = 0),
big.mark = big.mark), "\n"))
}
else
cat(paste0("Number of studies: k = ",
format(cond(k, digits = 0),
big.mark = big.mark), "\n"))
##
if (!is.metabind) {
if (is.metamiss)
cat("\n")
else if (sel.n)
catobsev(if (is.null(x$exclude)) x$n else x$n[!x$exclude],
type = "n")
else
catobsev(if (is.null(x$exclude)) x$n.e else x$n.e[!x$exclude],
if (is.null(x$exclude)) x$n.c else x$n.c[!x$exclude],
type = "n")
##
if (sel.ev)
catobsev(if (is.null(x$exclude)) x$event else x$event[!x$exclude],
type = "e")
else if (!is.metamiss)
catobsev(if (is.null(x$exclude)) x$event.e else x$event.e[!x$exclude],
if (is.null(x$exclude)) x$event.c else x$event.c[!x$exclude],
type = "e")
}
}
}
##
## Print information on heterogeneity
##
if (overall.hetstat) {
cat("\nQuantifying heterogeneity:")
if (sum(c(print.tau2, print.tau, print.I2, print.H, print.Rb)) > 1)
cat("\n")
else
cat("")
##
print.tau2.ci <-
print.tau2.ci & !all(is.na(x$lower.tau2) & is.na(x$upper.tau2))
if (print.tau2.ci &&
(all(x$lower.tau2 == 0) & all(x$upper.tau2 == 0)))
print.tau2.ci <- FALSE
##
print.tau.ci <-
print.tau.ci & !all(is.na(x$lower.tau) & is.na(x$upper.tau))
if (print.tau.ci &&
(all(x$lower.tau == 0) & all(x$upper.tau == 0)))
print.tau.ci <- FALSE
##
cathet(k,
x$method.tau, x$detail.tau,
x$tau2, x$lower.tau2, x$upper.tau2,
print.tau2, print.tau2.ci, text.tau2, digits.tau2,
x$tau, x$lower.tau, x$upper.tau,
print.tau, print.tau.ci, text.tau, digits.tau,
x$sign.lower.tau, x$sign.upper.tau,
I2, lowI2, uppI2,
print.I2, print.I2.ci, text.I2, digits.I2,
H, lowH, uppH,
print.H, digits.H,
Rb, lowRb, uppRb,
print.Rb, text.Rb,
big.mark,
sort.tau, sort.het)
##
## Print information on residual heterogeneity
##
if (by & !is.metabind) {
##
Q.resid <- x$Q.w.common
k.resid <- x$df.Q.w + 1
##
if (print.H) {
H.resid <- round(replaceNULL(x$H.resid), digits.H)
lowH.resid <- round(replaceNULL(x$lower.H.resid), digits.H)
uppH.resid <- round(replaceNULL(x$upper.H.resid), digits.H)
}
if (print.I2) {
I2.resid <- round(100 * replaceNULL(x$I2.resid), digits.I2)
lowI2.resid <- round(100 * replaceNULL(x$lower.I2.resid), digits.I2)
uppI2.resid <- round(100 * replaceNULL(x$upper.I2.resid), digits.I2)
print.I2.ci <-
((replaceNULL(Q.resid) > replaceNULL(k.resid) &
replaceNULL(k.resid) >= 2) |
(replaceNULL(Q.resid) <= replaceNULL(k.resid) &
replaceNULL(k.resid) > 2)) &
!(is.na(replaceNULL(lowI2.resid)) |
is.na(replaceNULL(uppI2.resid)))
##
print.I2.ci <- unique(print.I2.ci)
if (is.na(print.I2.ci))
print.I2.ci <- FALSE
}
##
if (!is.na(replaceNULL(I2.resid))) {
cat("\nQuantifying residual heterogeneity:")
if (sum(c(print.tau2, print.tau, print.I2, print.H, print.Rb)) > 1)
cat("\n")
else
cat("")
##
cathet(k.resid,
x$method.tau, x$detail.tau,
x$tau2.resid, x$lower.tau2.resid, x$upper.tau2.resid,
x$tau.common, print.tau2.ci, text.tau2, digits.tau2,
x$tau.resid, x$lower.tau.resid, x$upper.tau.resid,
x$tau.common, print.tau.ci, text.tau, digits.tau,
"", "",
I2.resid, lowI2.resid, uppI2.resid,
print.I2, print.I2.ci, text.I2, digits.I2,
H.resid, lowH.resid, uppH.resid,
print.H, digits.H,
NA, NA, NA,
FALSE, "",
big.mark)
}
}
##
## Test of heterogeneity
##
if (print.Q & (common | random)) {
if (any(k > 1, na.rm = TRUE)) {
##
Qdat <- qdat(Q, df.Q, pval.Q, x$hetlabel, text.common)
##
sort.Q <- setsort(sort.Q, nrow(Qdat), "tests of heterogeneity")
##
Qdata <- cbind(formatN(round(Qdat$Q, digits.Q), digits.Q, "NA",
big.mark = big.mark),
format(Qdat$df.Q, big.mark = big.mark),
formatPT(Qdat$pval.Q,
digits = digits.pval.Q,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
dimnames(Qdata) <- list(Qdat$names, c("Q", "d.f.", "p-value"))
##
Qdata <- Qdata[sort.Q, , drop = FALSE]
##
cat("\nTest of heterogeneity:\n")
prmatrix(Qdata, quote = FALSE, right = TRUE, ...)
}
}
}
else {
print.tau2 <- FALSE
print.tau2.ci <- FALSE
print.tau <- FALSE
print.tau.ci <- FALSE
}
##
## Print information for subgroup analysis
##
if (by) {
if (is.metabind)
anaunit <- "meta-analyses"
else if (is.netpairwise)
anaunit <- "pairwise comparisons"
else
anaunit <- "subgroups"
##
if (common) {
##
## Subgroup analysis based on common effect model
##
if (is.vector(TE.common.w)) {
nam <- names(TE.common.w)
TE.common.w <- matrix(TE.common.w, ncol = 1)
lowTE.common.w <- matrix(lowTE.common.w, ncol = 1)
uppTE.common.w <- matrix(uppTE.common.w, ncol = 1)
##
if (!is.null(nam))
rownames(TE.common.w) <- rownames(lowTE.common.w) <-
rownames(uppTE.common.w) <- nam
}
##
n.common <- ncol(TE.common.w)
##
if (!is.list(df.Q.b.common))
df.Q.b.common <- list(df.Q.b.common)
##
df.Q.b.common <- do.call("c", df.Q.b.common)
##
for (i in seq_len(n.common)) {
Tdata <- cbind(format(k.w, big.mark = big.mark),
formatN(TE.common.w[, i], digits, "NA",
big.mark = big.mark),
formatCI(formatN(lowTE.common.w[, i], digits, "NA",
big.mark = big.mark),
formatN(uppTE.common.w[, i], digits, "NA",
big.mark = big.mark)),
formatN(round(Q.w, digits.Q), digits.Q,
big.mark = big.mark),
if (print.I2)
ifelse(is.na(I2.w),
"--",
paste0(formatN(I2.w, digits.I2), "%")),
if (print.Rb)
ifelse(is.na(Rb.w),
"--",
paste0(formatN(Rb.w, digits.I2), "%")),
if (!random & !is.list(x$tau.w))
ifelse(k.w == 1 & !x$tau.common, "--",
formatPT(x$tau.w^2,
digits = digits.tau2,
big.mark = big.mark,
noblanks = TRUE)),
if (!random & !is.list(x$tau.w))
ifelse(k.w == 1 & !x$tau.common, "--",
formatPT(x$tau.w,
digits = digits.tau,
big.mark = big.mark,
noblanks = TRUE))
)
##
bylab.txt <- bylabel(subgroup.name, subgroup.levels,
print.subgroup.name, sep.subgroup,
big.mark = big.mark)
##
dimnames(Tdata) <- list(bylab.txt,
c(if (is.netpairwise)
" m" else " k",
sm.lab, ci.lab,
"Q",
if (print.I2) text.I2,
if (print.Rb) text.Rb,
if (!random) text.tau2,
if (!random) text.tau)
)
##
if (is.metabind & !is.null(x$common.meta))
Tdata <- Tdata[x$common.meta, , drop = FALSE]
##
cat(paste0("\nResults for ", anaunit,
paste0(" (", text.common.br[i], "):\n")))
##
prmatrix(Tdata, quote = FALSE, right = TRUE, ...)
##
df.i <- df.Q.b.common[[i]]
##
if (length(df.i) > 1) {
dfs.b.i <-
rmSpace(paste(formatN(unlist(df.i), digits = 0,
big.mark = big.mark),
collapse = ", "), end = TRUE)
Q.lab <- "F"
}
else {
dfs.b.i <- formatN(df.i, digits = 0, big.mark = big.mark)
Q.lab <- "Q"
}
##
if (test.subgroup.common & !is.metabind) {
cat(paste0("\nTest for subgroup differences (",
text.common.br[i], "):\n"))
if (any(method == "MH") | all(is.na(Q.w.common))) {
Qdata <- cbind(formatN(round(Q.b.common[i], digits.Q),
digits.Q, "NA", big.mark = big.mark),
formatN(dfs.b.i, digits = 0,
big.mark = big.mark),
formatPT(pval.Q.b.common[i],
digits = digits.pval.Q,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
dimnames(Qdata) <- list("Between groups",
c(Q.lab, "d.f.", "p-value"))
prmatrix(Qdata, quote = FALSE, right = TRUE, ...)
}
else {
Qs <- c(Q.b.common[i], Q.w.common[i])
dfs <- c(dfs.b.i,
formatN(df.Q.w, digits = 0, big.mark = big.mark))
if (is.glmm & Q.lab == "F")
Q.lab <- "F/Q"
##
pvals <- c(pval.Q.b.common[i], pval.Q.w.common[i])
##
Qdata <- cbind(formatN(round(Qs, digits.Q), digits.Q, "NA",
big.mark = big.mark),
dfs,
formatPT(pvals,
digits = digits.pval.Q,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
dimnames(Qdata) <- list(c("Between groups", "Within groups"),
c(Q.lab, "d.f.", "p-value"))
prmatrix(Qdata, quote = FALSE, right = TRUE, ...)
}
}
}
}
##
if (random) {
##
## Subgroup analysis based on random effects model
##
if (is.vector(TE.random.w)) {
nam <- names(TE.random.w)
TE.random.w <- matrix(TE.random.w, ncol = 1)
lowTE.random.w <- matrix(lowTE.random.w, ncol = 1)
uppTE.random.w <- matrix(uppTE.random.w, ncol = 1)
##
if (!is.null(nam))
rownames(TE.random.w) <- rownames(lowTE.random.w) <-
rownames(uppTE.random.w) <- nam
}
##
n.random <- ncol(TE.random.w)
##
if (!is.list(x$tau.w))
x$tau.w <- list(x$tau.w)
##
if (!is.list(df.Q.b.random))
df.Q.b.random <- list(df.Q.b.random)
##
df.Q.b.random <- do.call("c", df.Q.b.random)
##
for (i in seq_len(n.random)) {
tau.i <- length(x$tau.w) >= i
##
Tdata <- cbind(format(k.w, big.mark = big.mark),
formatN(TE.random.w[, i], digits, "NA",
big.mark = big.mark),
formatCI(formatN(lowTE.random.w[, i], digits, "NA",
big.mark = big.mark),
formatN(uppTE.random.w[, i], digits, "NA",
big.mark = big.mark)),
if (i == 1 | tau.i)
ifelse(k.w == 1 & !x$tau.common, "--",
formatPT(x$tau.w[[i]]^2,
digits = digits.tau2,
big.mark = big.mark,
noblanks = TRUE)),
if (i == 1 | tau.i)
ifelse(k.w == 1 & !x$tau.common, "--",
formatPT(x$tau.w[[i]],
digits = digits.tau,
big.mark = big.mark,
noblanks = TRUE)),
if (i == 1 & !common)
formatN(round(Q.w, digits.Q), digits.Q,
big.mark = big.mark),
if (i == 1 & !common & print.I2)
ifelse(is.na(I2.w),
"--",
paste0(formatN(I2.w, digits.I2), "%")),
if (i == 1 & !common & print.Rb)
ifelse(is.na(Rb.w),
"--",
paste0(formatN(Rb.w, digits.I2,
big.mark = big.mark), "%"))
)
##
bylab.txt <- bylabel(subgroup.name, subgroup.levels,
print.subgroup.name, sep.subgroup,
big.mark = big.mark)
##
dimnames(Tdata) <- list(bylab.txt,
c(if (is.netpairwise)
" m" else " k",
sm.lab, ci.lab,
if (i == 1 | tau.i) text.tau2,
if (i == 1 | tau.i) text.tau,
if (i == 1 & !common) "Q",
if (i == 1 & !common & print.I2) text.I2,
if (i == 1 & !common & print.Rb) text.Rb)
)
##
if (is.metabind & !is.null(x$random.meta))
Tdata <- Tdata[x$random.meta, , drop = FALSE]
##
cat(paste0("\nResults for ", anaunit,
paste0(" (", text.random.br[i], "):\n")))
##
prmatrix(Tdata, quote = FALSE, right = TRUE, ...)
##
df.i <- df.Q.b.random[[i]]
##
if (length(df.i) > 1) {
dfs.b.i <-
rmSpace(paste(formatN(df.i, digits = 0,
big.mark = big.mark),
collapse = ", "), end = TRUE)
Q.lab <- "F"
}
else {
dfs.b.i <- formatN(df.i, digits = 0, big.mark = big.mark)
Q.lab <- "Q"
}
##
if (test.subgroup.random & !is.na(Q.b.random[i]) & !is.metabind) {
cat(paste0("\nTest for subgroup differences (",
text.random.br[i],
"):\n"))
if (all(is.na(Q.w.random))) {
Qdata <- cbind(formatN(round(Q.b.random[i], digits.Q),
digits.Q, "NA", big.mark = big.mark),
formatN(dfs.b.i, digits = 0,
big.mark = big.mark),
formatPT(pval.Q.b.random[i],
digits = digits.pval.Q,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
dimnames(Qdata) <- list("Between groups",
c(Q.lab, "d.f.", "p-value"))
}
else {
Qs <- c(Q.b.random[i], Q.w.random[i])
dfs <- c(dfs.b.i,
formatN(df.Q.w, digits = 0, big.mark = big.mark))
Q.lab <-
ifelse((three.level | is.glmm) && Q.lab == "F", "F/Q", Q.lab)
##
pvals <- c(pval.Q.b.random[i], pval.Q.w.random[i])
##
Qdata <- cbind(formatN(round(Qs, digits.Q), digits.Q, "NA",
big.mark = big.mark),
dfs,
formatPT(pvals,
digits = digits.pval.Q,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
dimnames(Qdata) <- list(c("Between groups", "Within groups"),
c(Q.lab, "d.f.", "p-value"))
}
prmatrix(Qdata, quote = FALSE, right = TRUE, ...)
}
}
}
##
if (prediction.w) {
##
## Prediction intervals for subgroups
##
if (is.vector(lowTE.predict.w)) {
nam <- names(lowTE.predict.w)
lowTE.predict.w <- matrix(lowTE.predict.w, ncol = 1)
uppTE.predict.w <- matrix(uppTE.predict.w, ncol = 1)
##
rownames(lowTE.predict.w) <- rownames(uppTE.predict.w) <- nam
}
##
for (i in seq_len(ncol(lowTE.predict.w))) {
Pdata <- cbind(formatCI(formatN(lowTE.predict.w[, i], digits, "NA",
big.mark = big.mark),
formatN(uppTE.predict.w[, i], digits, "NA",
big.mark = big.mark)))
##
bylab.txt <-
bylabel(subgroup.name, subgroup.levels,
print.subgroup.name, sep.subgroup,
big.mark = big.mark)
lab.predict <- paste0(round(100 * x$level.predict, 1), "%-PI")
dimnames(Pdata) <- list(bylab.txt, lab.predict)
##
Pdata <- Pdata[prediction.subgroup.logical, , drop = FALSE]
##
cat(paste0("\n", text.predict[i], " for subgroups:\n"))
prmatrix(Pdata, quote = FALSE, right = TRUE, ...)
}
}
}
##
## Print information on meta-analysis method:
##
x$pscale <- pscale
x$irscale <- irscale
x$irunit <- irunit
##
if (details.methods &
(common | random | prediction | overall.hetstat | by))
details <-
catmeth(x,
common, random, prediction, overall, overall.hetstat,
x$func.transf, backtransf, fbt,
big.mark, digits, digits.tau, text.tau, text.tau2,
print.tau2, print.tau2.ci,
print.tau, print.tau.ci,
print.df = overall)
}
invisible(details)
}
#' @rdname print.meta
#' @export cilayout
cilayout <- function(bracket = gs("CIbracket"),
separator = gs("CIseparator"),
lower.blank = gs("CIlower.blank"),
upper.blank = gs("CIupper.blank")) {
chkchar(bracket, length = 1)
chkchar(separator, length = 1)
##
bracket <- setchar(bracket, c("[", "(", "{", ""))
##
chklogical(lower.blank)
chklogical(upper.blank)
setOption("CIbracket", bracket)
setOption("CIseparator", separator)
setOption("CIlower.blank", lower.blank)
setOption("CIupper.blank", upper.blank)
invisible(NULL)
}
guido-s/meta documentation built on April 18, 2024, 7:11 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions cilayout print.meta
Documented in cilayout print.meta
#' Print meta-analysis results
#'
#' @description
#' Print method for objects of class \code{meta}.
#'
#' R function cilayout can be utilised to change the layout to print
#' confidence intervals (both in printout from print.meta and
#' print.summary.meta function as well as in forest plots). The
#' default layout is "[lower; upper]". Another popular layout is
#' "(lower - upper)" which is used throughout an R session by using R
#' command \code{cilayout("(", " - ")}.
#'
#' Argument \code{pscale} can be used to rescale single proportions or
#' risk differences, e.g. \code{pscale = 1000} means that proportions
#' are expressed as events per 1000 observations. This is useful in
#' situations with (very) low event probabilities.
#'
#' Argument \code{irscale} can be used to rescale single rates or rate
#' differences, e.g. \code{irscale = 1000} means that rates are
#' expressed as events per 1000 time units, e.g. person-years. This is
#' useful in situations with (very) low rates. Argument \code{irunit}
#' can be used to specify the time unit used in individual studies
#' (default: "person-years"). This information is printed in summaries
#' and forest plots if argument \code{irscale} is not equal to 1.
#'
#' @aliases print.meta cilayout
#'
#' @param x An object of class \code{meta}.
#' @param common A logical indicating whether results for common
#' effect meta-analysis should be printed.
#' @param random A logical indicating whether results for random
#' effects meta-analysis should be printed.
#' @param prediction A logical indicating whether a prediction
#' interval should be printed.
#' @param overall A logical indicating whether overall summaries
#' should be reported. This argument is useful in a meta-analysis
#' with subgroups if overall results should not be reported.
#' @param overall.hetstat A logical value indicating whether to print
#' heterogeneity measures for overall treatment comparisons. This
#' argument is useful in a meta-analysis with subgroups if
#' heterogeneity statistics should only be printed on subgroup
#' level.
#' @param test.subgroup A logical value indicating whether to print
#' results of test for subgroup differences.
#' @param test.subgroup.common A logical value indicating whether to
#' print results of test for subgroup differences (based on common
#' effect model).
#' @param test.subgroup.random A logical value indicating whether to
#' print results of test for subgroup differences (based on random
#' effects model).
#' @param prediction.subgroup A single logical or logical vector
#' indicating whether / which prediction intervals should be printed
#' for subgroups.
#' @param backtransf A logical indicating whether printed results
#' should be back transformed. If \code{backtransf=TRUE}, results
#' for \code{sm="OR"} are printed as odds ratios rather than log
#' odds ratios and results for \code{sm="ZCOR"} are printed as
#' correlations rather than Fisher's z transformed correlations, for
#' example.
#' @param pscale A numeric giving scaling factor for printing of
#' single event probabilities or risk differences, i.e. if argument
#' \code{sm} is equal to \code{"PLOGIT"}, \code{"PLN"},
#' \code{"PRAW"}, \code{"PAS"}, \code{"PFT"}, or \code{"RD"}.
#' @param irscale A numeric defining a scaling factor for printing of
#' single incidence rates or incidence rate differences, i.e. if
#' argument \code{sm} is equal to \code{"IR"}, \code{"IRLN"},
#' \code{"IRS"}, \code{"IRFT"}, or \code{"IRD"}.
#' @param irunit A character specifying the time unit used to
#' calculate rates, e.g. person-years.
#' @param subgroup.name A character string with a name for the
#' grouping variable.
#' @param print.subgroup.name A logical indicating whether the name of
#' the grouping variable should be printed in front of the group
#' labels.
#' @param sep.subgroup A character string defining the separator
#' between label and levels of grouping variable.
#' @param nchar.subgroup A numeric specifying the number of characters
#' to print from subgroup labels.
#' @param sort.overall An optional vector used to sort meta-analysis
#' results.
#' @param sort.tau An optional vector used to sort estimators of the
#' between-study heterogeneity variance.
#' @param sort.het An optional vector used to sort heterogeneity
#' statistics.
#' @param sort.Q An optional vector used to sort test of
#' heterogeneity.
#' @param header A logical indicating whether information on title of
#' meta-analysis, comparison and outcome should be printed at the
#' beginning of the printout.
#' @param print.CMH A logical indicating whether result of the
#' Cochran-Mantel-Haenszel test for overall effect should be
#' printed.
#' @param digits Minimal number of significant digits, see
#' \code{print.default}.
#' @param digits.stat Minimal number of significant digits for z- or
#' t-value of test for overall effect, see \code{print.default}.
#' @param digits.pval Minimal number of significant digits for p-value
#' of overall treatment effect, see \code{print.default}.
#' @param digits.pval.Q Minimal number of significant digits for
#' p-value of heterogeneity test, see \code{print.default}.
#' @param digits.Q Minimal number of significant digits for
#' heterogeneity statistic Q, see \code{print.default}.
#' @param digits.tau2 Minimal number of significant digits for
#' between-study variance \eqn{\tau^2}, see \code{print.default}.
#' @param digits.tau Minimal number of significant digits for
#' \eqn{\tau}, the square root of the between-study variance
#' \eqn{\tau^2}.
#' @param digits.H Minimal number of significant digits for H
#' statistic, see \code{print.default}.
#' @param digits.I2 Minimal number of significant digits for I-squared
#' and Rb statistic, see \code{print.default}.
#' @param scientific.pval A logical specifying whether p-values should
#' be printed in scientific notation, e.g., 1.2345e-01 instead of
#' 0.12345.
#' @param big.mark A character used as thousands separator.
#' @param zero.pval A logical specifying whether p-values should be
#' printed with a leading zero.
#' @param JAMA.pval A logical specifying whether p-values for test of
#' overall effect should be printed according to JAMA reporting
#' standards.
#' @param digits.df Minimal number of significant digits for degrees
#' of freedom.
#' @param print.tau2 A logical specifying whether between-study
#' variance \eqn{\tau^2} should be printed.
#' @param print.tau2.ci A logical value indicating whether to print
#' the confidence interval of \eqn{\tau^2}.
#' @param print.tau A logical specifying whether \eqn{\tau}, the
#' square root of the between-study variance \eqn{\tau^2}, should be
#' printed.
#' @param print.tau.ci A logical value indicating whether to print the
#' confidence interval of \eqn{\tau}.
#' @param print.I2 A logical specifying whether heterogeneity
#' statistic I\eqn{^2} should be printed.
#' @param print.H A logical specifying whether heterogeneity statistic
#' H should be printed.
#' @param print.Rb A logical specifying whether heterogeneity
#' statistic R\eqn{_b} should be printed.
#' @param text.tau2 Text printed to identify between-study variance
#' \eqn{\tau^2}.
#' @param text.tau Text printed to identify \eqn{\tau}, the square
#' root of the between-study variance \eqn{\tau^2}.
#' @param text.I2 Text printed to identify heterogeneity statistic
#' I\eqn{^2}.
#' @param text.Rb Text printed to identify heterogeneity statistic
#' R\eqn{_b}.
#' @param print.Q A logical value indicating whether to print the
#' results of the test of heterogeneity.
#' @param details.methods A logical specifying whether details on
#' statistical methods should be printed.
#' @param warn.backtransf Deprecated argument (ignored).
#' @param func.backtransf A function used to back-transform results.
#' @param bracket A character with bracket symbol to print lower
#' confidence interval: "[", "(", "\{", "".
#' @param separator A character string with information on separator
#' between lower and upper confidence interval.
#' @param lower.blank A logical indicating whether blanks between left
#' bracket and lower confidence limit should be printed.
#' @param upper.blank A logical indicating whether blanks between
#' separator and upper confidence limit should be printed.
#' @param warn.deprecated A logical indicating whether warnings should
#' be printed if deprecated arguments are used.
#' @param \dots Additional arguments (passed on to \code{prmatrix}).
#'
#' @rdname print.meta
#' @method print meta
#' @export
print.meta <- function(x,
common = x$common,
random = x$random,
prediction = x$prediction,
overall = x$overall,
overall.hetstat = x$overall.hetstat,
##
test.subgroup = x$test.subgroup,
test.subgroup.common = test.subgroup & common,
test.subgroup.random = test.subgroup & random,
prediction.subgroup = x$prediction.subgroup,
##
backtransf = x$backtransf,
pscale = x$pscale,
irscale = x$irscale,
irunit = x$irunit,
##
subgroup.name = x$subgroup.name,
print.subgroup.name = x$print.subgroup.name,
sep.subgroup = x$sep.subgroup,
nchar.subgroup = 35,
##
sort.overall = NULL,
sort.tau = NULL,
sort.het = NULL,
sort.Q = NULL,
##
header = TRUE,
print.CMH = x$print.CMH,
##
digits = gs("digits"),
digits.stat = gs("digits.stat"),
digits.pval = max(gs("digits.pval"), 2),
digits.pval.Q = max(gs("digits.pval.Q"), 2),
digits.Q = gs("digits.Q"),
digits.tau2 = gs("digits.tau2"),
digits.tau = gs("digits.tau"),
digits.H = gs("digits.H"),
digits.I2 = gs("digits.I2"),
##
scientific.pval = gs("scientific.pval"),
big.mark = gs("big.mark"),
zero.pval = gs("zero.pval"),
JAMA.pval = gs("JAMA.pval"),
##
digits.df = gs("digits.df"),
##
print.tau2 = gs("print.tau2"),
print.tau2.ci = gs("print.tau2.ci"),
print.tau = gs("print.tau"),
print.tau.ci = gs("print.tau.ci"),
##
print.I2 = gs("print.I2"),
print.H = gs("print.H"),
print.Rb = gs("print.Rb"),
##
text.tau2 = gs("text.tau2"),
text.tau = gs("text.tau"),
text.I2 = gs("text.I2"),
text.Rb = gs("text.Rb"),
##
print.Q = gs("print.Q"),
##
details.methods = gs("details"),
##
warn.backtransf = FALSE,
func.backtransf = x$func.backtransf,
warn.deprecated = gs("warn.deprecated"),
...) {
##
##
## (1) Check for meta object
##
##
chkclass(x, "meta")
x <- updateversion(x)
##
if (inherits(x, "metacum") | inherits(x, "metainf"))
return(invisible(NULL))
##
is.metabind <- inherits(x, "metabind")
is.netpairwise <- inherits(x, "netpairwise")
##
by <- !is.null(x$subgroup)
##
if (by)
n.by <- length(x$subgroup.levels)
##
method.random.ci <- replaceNULL(x$method.random.ci, "")
method.predict <- replaceNULL(x$method.predict, "")
##
if (is.function(func.backtransf))
fbt <- deparse(substitute(func.backtransf))
else
fbt <- func.backtransf
##
abt <- x$args.backtransf
##
##
## (2) Check and set other arguments
##
##
sfsp <- sys.frame(sys.parent())
mc <- match.call()
##
chknumeric(digits, min = 0, length = 1)
chknumeric(digits.tau2, min = 0, length = 1)
chknumeric(digits.tau, min = 0, length = 1)
chknumeric(digits.stat, min = 0, length = 1)
chknumeric(digits.pval, min = 1, length = 1)
chknumeric(digits.pval.Q, min = 1, length = 1)
chknumeric(digits.Q, min = 0, length = 1)
chknumeric(digits.H, min = 0, length = 1)
chknumeric(digits.I2, min = 0, length = 1)
chklogical(scientific.pval)
chklogical(zero.pval)
chklogical(JAMA.pval)
##
chklogical(print.tau2)
chklogical(print.tau2.ci)
chklogical(print.tau)
chklogical(print.tau.ci)
##
chklogical(print.I2)
chklogical(print.H)
chklogical(print.Rb)
chkchar(text.tau2, length = 1)
chkchar(text.tau, length = 1)
chkchar(text.I2, length = 1)
chkchar(text.Rb, length = 1)
chklogical(print.Q)
##
chklogical(warn.deprecated)
##
missing.pscale <- missing(pscale)
if (!is.null(pscale))
chknumeric(pscale, length = 1)
else
pscale <- 1
##
missing.irscale <- missing(irscale)
if (!is.null(irscale))
chknumeric(irscale, length = 1)
else
irscale <- 1
if (!is.null(irunit) && !is.na(irunit))
chkchar(irunit)
##
chklogical(common)
chklogical(random)
chklogical(prediction)
overall <- replaceNULL(overall, TRUE)
chklogical(overall)
overall.hetstat <- replaceNULL(overall.hetstat, TRUE)
chklogical(overall.hetstat)
test.subgroup <- replaceNULL(test.subgroup, TRUE)
if (is.na(test.subgroup))
test.subgroup <- FALSE
chklogical(test.subgroup)
test.subgroup.common <- replaceNULL(test.subgroup.common, test.subgroup)
chklogical(test.subgroup.common)
test.subgroup.random <- replaceNULL(test.subgroup.random, test.subgroup)
chklogical(test.subgroup.random)
##
missing.prediction.subgroup <- missing(prediction.subgroup)
##
if (by) {
x$lower.predict.w <- list2mat(x$lower.predict.w)
x$upper.predict.w <- list2mat(x$upper.predict.w)
x$df.predict.w <- list2mat(x$df.predict.w)
##
if (!missing.prediction.subgroup)
prediction.subgroup <- catch("prediction.subgroup", mc, x, sfsp)
##
prediction.subgroup <- replaceNULL(prediction.subgroup, FALSE)
##
if (length(prediction.subgroup) == 1) {
if (is.matrix(x$lower.predict.w)) {
prediction.subgroup.logical <-
prediction.subgroup &
apply(x$lower.predict.w, 1, notallNA) &
apply(x$upper.predict.w, 1, notallNA)
}
else {
prediction.subgroup.logical <-
prediction.subgroup &
notallNA(x$lower.predict.w) &
notallNA(x$upper.predict.w)
##
prediction.subgroup.logical <-
rep(prediction.subgroup.logical, n.by)
}
}
else {
chklength(prediction.subgroup, n.by,
text = paste("Length of argument 'prediction.subgroup' must be",
"equal to 1 or number of subgroups."))
prediction.subgroup.logical <- prediction.subgroup
}
##
if (length(prediction.subgroup.logical) == 0)
prediction.subgroup.logical <- FALSE
##
chklogical(prediction.subgroup.logical[1])
##
if (missing.prediction.subgroup) {
if (any(method.predict %in% c("", "S")))
prediction.w <- prediction.subgroup.logical
else
prediction.w <- prediction.subgroup.logical & !is.na(x$df.predict.w)
}
else
prediction.w <- prediction.subgroup.logical
##
prediction.w[is.na(prediction.w)] <- FALSE
prediction.w <- any(prediction.w) & !is.metabind
}
else
prediction.w <- FALSE
##
if (!is.null(print.CMH))
chklogical(print.CMH)
##
sort.tau <- catch("sort.tau", mc, x, sfsp)
if (is.list(sort.tau))
sort.tau <- unlist(sort.tau)
##
sort.het <- catch("sort.het", mc, x, sfsp)
if (is.list(sort.het))
sort.het <- unlist(sort.het)
##
sort.Q <- catch("sort.Q", mc, x, sfsp)
if (is.list(sort.Q))
sort.Q <- unlist(sort.Q)
##
chklogical(header)
##
chklogical(details.methods)
##
## Check for deprecated arguments in '...'
##
args <- list(...)
##
missing.common <- missing(common)
common <- deprecated(common, missing.common, args, "comb.fixed",
warn.deprecated)
common <- deprecated(common, missing.common, args, "fixed",
warn.deprecated)
chklogical(common)
##
random <- deprecated(random, missing(random), args, "comb.random", FALSE)
chklogical(random)
##
subgroup.name <-
deprecated(subgroup.name, missing(subgroup.name), args, "bylab", FALSE)
##
print.subgroup.name <-
deprecated(print.subgroup.name, missing(print.subgroup.name),
args, "print.byvar", FALSE)
##
sep.subgroup <-
deprecated(sep.subgroup, missing(sep.subgroup), args, "byseparator",
FALSE)
##
nchar.subgroup <-
deprecated(nchar.subgroup, missing(nchar.subgroup), args, "nchar.subgroup",
warn.deprecated)
chknumeric(nchar.subgroup, min = 1, length = 1)
##
backtransf <-
deprecated(backtransf, missing(backtransf), args, "logscale",
warn.deprecated)
if (is_untransformed(x$sm))
backtransf <- TRUE
chklogical(backtransf)
##
## Additional settings
##
if (!backtransf & pscale != 1 & !is_untransformed(x$sm)) {
if (!missing.pscale)
warning("Argument 'pscale' set to 1 as argument 'backtransf' is FALSE.")
pscale <- 1
}
if (!backtransf & irscale != 1 & !is_untransformed(x$sm)) {
if (!missing.irscale)
warning("Argument 'irscale' set to 1 as argument 'backtransf' is FALSE.")
irscale <- 1
}
##
if (by) {
chklogical(print.subgroup.name)
chkchar(sep.subgroup)
}
else {
if (!missing.prediction.subgroup)
warning("Argument 'prediction.subgroup' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
}
##
##
## (3) Some additional settings
##
##
k.all <- replaceNULL(x$k.all, length(x$TE))
k <- x$k
k.study <- replaceNULL(x$k.study, k)
sm <- x$sm
##
bip <- inherits(x, c("metabin", "metainc", "metaprop", "metarate"))
metabin <- inherits(x, "metabin")
metaprop <- inherits(x, "metaprop")
metarate <- inherits(x, "metarate")
##
null.effect <- x$null.effect
null.given <- !is.null(null.effect) && !is.na(null.effect)
##
if (null.given & !backtransf) {
##
if (sm %in% c("PFT", "PAS"))
null.effect <- asin(sqrt(null.effect))
else if (is_log_effect(sm))
null.effect <- log(null.effect)
else if (sm == c("PLOGIT"))
null.effect <- log(null.effect / (1 - null.effect))
else if (sm %in% c("IRS", "IRFT"))
null.effect <- sqrt(null.effect)
else if (sm == "ZCOR")
null.effect <- 0.5 * log((1 + null.effect) / (1 - null.effect))
}
##
x$null.effect <- null.effect
##
if (is.null(prediction) || is.na(prediction))
prediction <- FALSE
#
sm.lab <- smlab(sm, backtransf, pscale, irscale)
#
if (length(x$tau.common) == 0)
x$tau.common <- FALSE
##
if (length(x$tau.common) == 0)
x$tau.common <- FALSE
##
if (by)
subgroup.levels <-
ifelse(nchar(x$subgroup.levels) > nchar.subgroup,
paste0(substring(x$subgroup.levels, 1, nchar.subgroup - 4),
" ..."),
x$subgroup.levels)
##
if (is.null(x$text.common))
text.common <- gs("text.common")
else
text.common <- x$text.common
##
if (is.null(x$text.random))
text.random <- gs("text.random")
else
text.random <- x$text.random
##
if (is.null(x$text.predict))
text.predict <- gs("text.predict")
else
text.predict <- x$text.predict
##
if (any(substring(text.common, 1, 5) %in% c("Fixed", "Commo"))) {
text.common.br <- gsub("Fixed", "fixed", text.common)
text.common.br <- gsub("Common", "common", text.common.br)
text.common.br <- gsub("Effect", "effect", text.common.br)
}
else
text.common.br <- text.common
##
if (any(substring(text.random, 1, 5) %in% c("Rando"))) {
text.random.br <- gsub("Random", "random", text.random)
text.random.br <- gsub("Effect", "effect", text.random.br)
}
else
text.random.br <- text.random
##
ci.lab <- paste0(round(100 * x$level.ma, 1), "%-CI")
##
details <- NULL
##
##
## (4) Set and backtransform results of meta-analysis
##
##
TE.common <- x$TE.common
lowTE.common <- x$lower.common
uppTE.common <- x$upper.common
pTE.common <- x$pval.common
sTE.common <- x$statistic.common
##
TE.random <- x$TE.random
lowTE.random <- x$lower.random
uppTE.random <- x$upper.random
if (length(TE.random) == 1 &&
length(TE.random) != length(lowTE.random))
TE.random <- rep_len(TE.random, length(lowTE.random))
##
lowTE.predict <- x$lower.predict
uppTE.predict <- x$upper.predict
##
Q <- unlist(x$Q)
df.Q <- replaceNULL(unlist(x$df.Q), k - 1)
pval.Q <- replaceNULL(unlist(x$pval.Q), pvalQ(Q, df.Q))
##
if (!is.null(x$Q.CMH)) {
Q.CMH <- unlist(x$Q.CMH)
df.Q.CMH <- replaceNULL(unlist(x$df.Q.CMH), 1)
pval.Q.CMH <- replaceNULL(unlist(x$pval.Q.CMH), pvalQ(Q.CMH, df.Q.CMH))
}
##
if (by) {
k.w <- x$k.w
##
TE.common.w <- list2mat(x$TE.common.w)
lowTE.common.w <- list2mat(x$lower.common.w)
uppTE.common.w <- list2mat(x$upper.common.w)
pval.common.w <- list2mat(x$pval.common.w)
##
lowTE.random.w <- list2mat(x$lower.random.w)
TE.random.w <- list2mat(x$TE.random.w, lowTE.random.w)
##
uppTE.random.w <- list2mat(x$upper.random.w)
pval.random.w <- list2mat(x$pval.random.w)
##
if (!is.matrix(TE.random.w) & is.matrix(lowTE.random.w)) {
TE.random.w <-
matrix(TE.random.w,
nrow = nrow(lowTE.random.w),
ncol = ncol(lowTE.random.w))
rownames(TE.random.w) <- rownames(lowTE.random.w)
colnames(TE.random.w) <- colnames(lowTE.random.w)
}
##
lowTE.predict.w <- x$lower.predict.w
uppTE.predict.w <- x$upper.predict.w
##
harmonic.mean.w <- x$n.harmonic.mean.w
##
Q.b.common <- unlist(x$Q.b.common)
names(Q.b.common) <- colnames(lowTE.common.w)
Q.w.common <- x$Q.w.common
##
Q.b.random <- unlist(x$Q.b.random)
Q.w.random <- x$Q.w.random
##
Q.w <- x$Q.w
##
df.Q.w <- replaceNULL(x$df.Q.w, sum((k.w - 1)[!is.na(x$Q.w)]))
df.Q.b <- replaceNULL(x$df.Q.b, (k - 1) - sum((k.w - 1)[!is.na(x$Q.w)]))
df.Q.b.common <- replaceNULL(x$df.Q.b.common, df.Q.b)
df.Q.b.random <- replaceNULL(x$df.Q.b.random, df.Q.b)
##
pval.Q.b.common <-
replaceNULL(x$pval.Q.b.common, pvalQ(Q.b.common, df.Q.b.common))
pval.Q.w.common <-
replaceNULL(x$pval.Q.w.common, pvalQ(Q.w.common, df.Q.w))
##
pval.Q.b.random <-
unlist(replaceNULL(x$pval.Q.b.random, pvalQ(Q.b.random, df.Q.b.random)))
pval.Q.w.random <-
unlist(replaceNULL(x$pval.Q.w.random, pvalQ(Q.w.random, df.Q.w)))
}
##
if (backtransf) {
if (sm == "IRFT") {
if (is.metabind)
harmonic.mean <- x$t.harmonic.mean.ma
else
harmonic.mean <- 1 / mean(1 / x$time)
}
else {
if (is.metabind)
harmonic.mean <- x$n.harmonic.mean.ma
else
harmonic.mean <- 1 / mean(1 / x$n)
}
##
TE.common <-
backtransf(TE.common, sm, harmonic.mean, harmonic.mean, fbt, abt)
lowTE.common <-
backtransf(lowTE.common, sm, harmonic.mean, harmonic.mean, fbt, abt)
uppTE.common <-
backtransf(uppTE.common, sm, harmonic.mean, harmonic.mean, fbt, abt)
##
TE.random <-
backtransf(TE.random, sm, harmonic.mean, harmonic.mean, fbt, abt)
lowTE.random <-
backtransf(lowTE.random, sm, harmonic.mean, harmonic.mean, fbt, abt)
uppTE.random <-
backtransf(uppTE.random, sm, harmonic.mean, harmonic.mean, fbt, abt)
##
lowTE.predict <-
backtransf(lowTE.predict, sm, harmonic.mean, harmonic.mean, fbt, abt)
uppTE.predict <-
backtransf(uppTE.predict, sm, harmonic.mean, harmonic.mean, fbt, abt)
##
if (by) {
TE.common.w <-
backtransf(TE.common.w, sm, harmonic.mean.w, harmonic.mean.w,
fbt, abt)
lowTE.common.w <-
backtransf(lowTE.common.w, sm, harmonic.mean.w, harmonic.mean.w,
fbt, abt)
uppTE.common.w <-
backtransf(uppTE.common.w, sm, harmonic.mean.w, harmonic.mean.w)
##
TE.random.w <-
backtransf(TE.random.w, sm, harmonic.mean.w, harmonic.mean.w, fbt, abt)
lowTE.random.w <-
backtransf(lowTE.random.w, sm, harmonic.mean.w, harmonic.mean.w,
fbt, abt)
uppTE.random.w <-
backtransf(uppTE.random.w, sm, harmonic.mean.w, harmonic.mean.w,
fbt, abt)
##
if (prediction.w) {
lowTE.predict.w <-
backtransf(lowTE.predict.w, sm, harmonic.mean.w, harmonic.mean.w,
fbt, abt)
uppTE.predict.w <-
backtransf(uppTE.predict.w, sm, harmonic.mean.w, harmonic.mean.w,
fbt, abt)
}
}
}
##
## Apply argument 'pscale' to proportions / risk differences and
## 'irscale' to rates / incidence rate differences
##
if (pscale != 1 || irscale != 1) {
if (pscale != 1 && irscale != 1)
stop("Provide either arguments 'pscale' or 'irscale' but not ",
"both arguments.",
call. = FALSE)
if (pscale != 1)
scale <- pscale
else
scale <- irscale
##
TE.common <- scale * TE.common
lowTE.common <- scale * lowTE.common
uppTE.common <- scale * uppTE.common
##
TE.random <- scale * TE.random
lowTE.random <- scale * lowTE.random
uppTE.random <- scale * uppTE.random
##
lowTE.predict <- scale * lowTE.predict
uppTE.predict <- scale * uppTE.predict
##
if (by) {
TE.common.w <- scale * TE.common.w
lowTE.common.w <- scale * lowTE.common.w
uppTE.common.w <- scale * uppTE.common.w
##
TE.random.w <- scale * TE.random.w
lowTE.random.w <- scale * lowTE.random.w
uppTE.random.w <- scale * uppTE.random.w
##
if (prediction.w) {
lowTE.predict.w <- scale * lowTE.predict.w
uppTE.predict.w <- scale * uppTE.predict.w
}
}
}
##
## Switch lower and upper limit for VE if results have been
## backtransformed
##
if (backtransf & sm == "VE") {
tmp.l <- lowTE.common
lowTE.common <- uppTE.common
uppTE.common <- tmp.l
##
tmp.l <- lowTE.random
lowTE.random <- uppTE.random
uppTE.random <- tmp.l
##
tmp.l <- lowTE.predict
lowTE.predict <- uppTE.predict
uppTE.predict <- tmp.l
##
if (by) {
tmp.l <- lowTE.common.w
lowTE.common.w <- uppTE.common.w
uppTE.common.w <- tmp.l
##
tmp.l <- lowTE.random.w
lowTE.random.w <- uppTE.random.w
uppTE.random.w <- tmp.l
##
if (prediction.w) {
tmp.l <- lowTE.predict.w
lowTE.predict.w <- uppTE.predict.w
uppTE.predict.w <- tmp.l
}
}
}
##
## Round and round ...
##
TE.common <- round(TE.common, digits)
lowTE.common <- round(lowTE.common, digits)
uppTE.common <- round(uppTE.common, digits)
sTE.common <- round(sTE.common, digits.stat)
##
TE.random <- round(TE.random, digits)
lowTE.random <- round(lowTE.random, digits)
uppTE.random <- round(uppTE.random, digits)
pTE.random <- x$pval.random
sTE.random <- round(x$statistic.random, digits.stat)
##
lowTE.predict <- round(lowTE.predict, digits)
uppTE.predict <- round(uppTE.predict, digits)
##
if (by) {
TE.common.w <- round(TE.common.w, digits)
lowTE.common.w <- round(lowTE.common.w, digits)
uppTE.common.w <- round(uppTE.common.w, digits)
##
TE.random.w <- round(TE.random.w, digits)
lowTE.random.w <- round(lowTE.random.w, digits)
uppTE.random.w <- round(uppTE.random.w, digits)
##
if (prediction.w) {
lowTE.predict.w <- round(lowTE.predict.w, digits)
uppTE.predict.w <- round(uppTE.predict.w, digits)
}
##
if (print.I2)
I2.w <- round(100 * x$I2.w, digits.I2)
else
I2.w <- NA
##
if (print.Rb)
Rb.w <- round(100 * x$Rb.w, digits.I2)
else
Rb.w <- NA
}
##
if (print.H) {
H <- round(unlist(x$H), digits.H)
lowH <- round(unlist(x$lower.H), digits.H)
uppH <- round(unlist(x$upper.H), digits.H)
if (all(!is.na(lowH) & !is.na(uppH)) && all(lowH == uppH)) {
lowH <- NA
uppH <- NA
}
}
else {
H <- lowH <- uppH <- NULL
}
##
if (print.I2) {
I2 <- round(100 * unlist(x$I2), digits.I2)
lowI2 <- round(100 * unlist(x$lower.I2), digits.I2)
uppI2 <- round(100 * unlist(x$upper.I2), digits.I2)
##
if (is.null(names(Q)))
Q4I2 <- Q
else
Q4I2 <- Q[!grepl("LRT", names(Q))]
##
print.I2.ci <-
ifelse(((Q4I2 > max(k, na.rm = TRUE) & max(k, na.rm = TRUE) >= 2) |
(Q4I2 <= max(k, na.rm = TRUE) & max(k, na.rm = TRUE) > 2)) &
!(is.na(lowI2) | is.na(uppI2)), TRUE, FALSE)
##
print.I2.ci[is.na(print.I2.ci)] <- FALSE
print.I2.ci <- print.I2.ci & !(lowI2 == uppI2)
print.I2.ci <- any(print.I2.ci)
}
else {
I2 <- lowI2 <- uppI2 <- NULL
print.I2.ci <- FALSE
}
##
if (print.Rb) {
Rb <- round(100 * unlist(x$Rb), digits.I2)
lowRb <- round(100 * unlist(x$lower.Rb), digits.I2)
uppRb <- round(100 * unlist(x$upper.Rb), digits.I2)
##
if (all(!is.na(lowRb) & !is.na(uppRb)) && all(lowRb == uppRb)) {
lowRb <- rep(NA, length(Rb))
uppRb <- rep(NA, length(Rb))
}
}
else {
Rb <- lowRb <- uppRb <- NULL
print.Rb.ci <- FALSE
}
##
method <- x$method
method.random <- x$method.random
##
three.level <- if (is.null(x$three.level)) FALSE else any(x$three.level)
is.glmm <- any(method == "GLMM") | any(method.random == "GLMM")
##
sel.n <- inherits(x, c("metacor", "metaprop", "metamean", "metarate"))
##
sel.ev <- inherits(x, c("metaprop", "metarate"))
##
##
## (5) Print result for meta-analysis
##
##
is.metamiss <- inherits(x, "metamiss")
if (header) {
if (is.metamiss)
cat("Sensitivity analysis for missing binary data\n")
##
crtitle(x)
}
##
if (all(is.na(k.all))) {
## Do nothing
return(invisible(NULL))
}
else if (all(k.all == 1)) {
##
## Print results for a single study
##
if (!(metaprop | metarate) | (overall & (common | random)) |
overall.hetstat | by)
method <- ifelse(method == "Peto", method, "")
##
if (!is.metabind) {
if (is.metamiss)
cat("\n")
else if (sel.n)
catobsev(if (is.null(x$exclude)) x$n else x$n[!x$exclude],
type = "n")
else
catobsev(if (is.null(x$exclude)) x$n.e else x$n.e[!x$exclude],
if (is.null(x$exclude)) x$n.c else x$n.c[!x$exclude],
type = "n")
##
if (sel.ev)
catobsev(if (is.null(x$exclude)) x$event else x$event[!x$exclude],
type = "e", addrow = TRUE)
else if (!is.metamiss)
catobsev(if (is.null(x$exclude)) x$event.e else x$event.e[!x$exclude],
if (is.null(x$exclude)) x$event.c else x$event.c[!x$exclude],
type = "e", addrow = TRUE)
}
##
res <- cbind(formatN(TE.common, digits, "NA",
big.mark = big.mark),
formatCI(formatN(lowTE.common, digits, "NA",
big.mark = big.mark),
formatN(uppTE.common, digits, "NA",
big.mark = big.mark)),
if (null.given)
formatN(sTE.common, digits.stat, big.mark = big.mark),
if (null.given)
formatPT(pTE.common, digits = digits.pval,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
dimnames(res) <- list(x$studlab,
c(sm.lab, ci.lab,
if (null.given) "z",
if (null.given) "p-value"))
prmatrix(res, quote = FALSE, right = TRUE, ...)
##
## Print information on meta-analysis method:
##
x$pscale <- pscale
x$irscale <- irscale
x$irunit <- irunit
##
if (details.methods)
details <-
catmeth(x,
common, random, prediction, overall, overall.hetstat,
x$func.transf, backtransf, fbt,
big.mark, digits, digits.tau, text.tau, text.tau2,
print.tau2 = FALSE)
}
else {
##
##
## Print results for meta-analysis with more than one study
##
##
if (header & is.metamiss)
cat("\n")
##
if (all(!is.na(k))) {
if (overall & (common | random | prediction)) {
if (!inherits(x, "trimfill")) {
if (any(method == "MH") &&
(inherits(x, c("metabin", "metainc")) &
common & sm %in% c("RD", "IRD") &
(!is.null(x$k.MH) && any(k != x$k.MH, na.rm = TRUE))))
cat(paste0("Number of studies: k.MH = ",
cond(x$k.MH, digits = 0),
" (", text.common.br[1], "), k = ",
format(cond(k, digits = 0),
big.mark = big.mark),
" (", text.random.br[1], ")\n",
collapse = ""))
else {
if (any(k.study != k, na.rm = TRUE)) {
cat(paste0("Number of studies: n = ",
format(cond(x$k.study, digits = 0),
big.mark = big.mark), "\n",
collapse = ""))
cat(paste0("Number of estimates: k = ",
format(cond(k, digits = 0),
big.mark = big.mark), "\n",
collapse = ""))
}
else
cat(paste0("Number of studies: k = ",
format(cond(k, digits = 0),
big.mark = big.mark), "\n",
collapse = ""))
}
}
else
cat(paste0("Number of studies: k = ",
format(cond(k, digits = 0),
big.mark = big.mark),
" (with ",
format(cond(x$k0, digits = 0),
big.mark = big.mark),
" added studies)\n",
collapse = ""))
##
if (!is.metabind) {
if (is.metamiss)
cat("\n")
else if (sel.n)
catobsev(if (is.null(x$exclude)) x$n else x$n[!x$exclude],
type = "n")
else
catobsev(if (is.null(x$exclude)) x$n.e else x$n.e[!x$exclude],
if (is.null(x$exclude)) x$n.c else x$n.c[!x$exclude],
type = "n")
##
if (sel.ev)
catobsev(if (is.null(x$exclude)) x$event else x$event[!x$exclude],
type = "e", addrow = TRUE)
else if (!is.metamiss)
catobsev(if (is.null(x$exclude)) x$event.e
else x$event.e[!x$exclude],
if (is.null(x$exclude)) x$event.c
else x$event.c[!x$exclude],
type = "e", addrow = TRUE)
}
##
res <- cbind(formatN(c(if (common) TE.common,
if (random) TE.random,
if (prediction)
rep(NA, length(lowTE.predict))),
digits, "NA",
big.mark = big.mark),
formatCI(formatN(c(if (common) lowTE.common,
if (random) lowTE.random,
if (prediction) lowTE.predict),
digits, "NA", big.mark = big.mark),
formatN(c(if (common) uppTE.common,
if (random) uppTE.random,
if (prediction) uppTE.predict),
digits, "NA", big.mark = big.mark)),
if (null.given)
formatN(c(if (common) sTE.common,
if (random) sTE.random,
if (prediction)
rep(NA, length(lowTE.predict))),
digits = digits.stat, big.mark = big.mark),
if (null.given)
formatPT(c(if (common) pTE.common,
if (random) pTE.random,
if (prediction)
rep(NA, length(lowTE.predict))),
digits = digits.pval,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
if (prediction) {
seq <- (nrow(res) - length(lowTE.predict) + 1):nrow(res)
res[seq, 1] <- ""
if (null.given)
res[seq, 3:4] <- ""
}
##
if (any(method.random.ci %in% c("HK", "KR"))) {
if (common & random)
zlab <- "z|t"
else if (common & !random)
zlab <- "z"
else if (!common & random)
zlab <- "t"
}
else
zlab <- "z"
##
if (prediction)
if (x$level.ma == x$level.predict)
lab.predict <- text.predict
else
lab.predict <-
paste0(text.predict,
" (", round(100 * x$level.predict, 1), "%-PI)")
##
dimnames(res) <- list(c(if (common) text.common,
if (random) text.random,
if (prediction) lab.predict),
c(sm.lab, ci.lab,
if (null.given) zlab,
if (null.given) "p-value"))
##
sort.overall <- setsort(sort.overall, nrow(res), "overall results")
##
prmatrix(res[sort.overall, , drop = FALSE],
quote = FALSE, right = TRUE, ...)
##
if (metabin && print.CMH) {
Qdata <- cbind(formatN(round(Q.CMH, digits.Q), digits.Q, "NA",
big.mark = big.mark),
df.Q.CMH,
formatPT(pval.Q.CMH,
digits = digits.pval.Q,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
dimnames(Qdata) <- list("", c("Q", "d.f.", "p-value"))
##
cat("\nCochran-Mantel-Haenszel (CMH) test for overall effect: \n")
prmatrix(Qdata, quote = FALSE, right = TRUE, ...)
}
}
else {
if (any(k.study != k)) {
cat(paste0("Number of studies: ",
if (is.netpairwise) "k" else "n", " = ",
format(cond(x$k.study, digits = 0),
big.mark = big.mark), "\n"))
cat(paste0("Number of ",
if (is.netpairwise)
"pairwise comparisons: m = " else "estimates: k = ",
format(cond(k, digits = 0),
big.mark = big.mark), "\n"))
}
else
cat(paste0("Number of studies: k = ",
format(cond(k, digits = 0),
big.mark = big.mark), "\n"))
##
if (!is.metabind) {
if (is.metamiss)
cat("\n")
else if (sel.n)
catobsev(if (is.null(x$exclude)) x$n else x$n[!x$exclude],
type = "n")
else
catobsev(if (is.null(x$exclude)) x$n.e else x$n.e[!x$exclude],
if (is.null(x$exclude)) x$n.c else x$n.c[!x$exclude],
type = "n")
##
if (sel.ev)
catobsev(if (is.null(x$exclude)) x$event else x$event[!x$exclude],
type = "e")
else if (!is.metamiss)
catobsev(if (is.null(x$exclude)) x$event.e else x$event.e[!x$exclude],
if (is.null(x$exclude)) x$event.c else x$event.c[!x$exclude],
type = "e")
}
}
}
##
## Print information on heterogeneity
##
if (overall.hetstat) {
cat("\nQuantifying heterogeneity:")
if (sum(c(print.tau2, print.tau, print.I2, print.H, print.Rb)) > 1)
cat("\n")
else
cat("")
##
print.tau2.ci <-
print.tau2.ci & !all(is.na(x$lower.tau2) & is.na(x$upper.tau2))
if (print.tau2.ci &&
(all(x$lower.tau2 == 0) & all(x$upper.tau2 == 0)))
print.tau2.ci <- FALSE
##
print.tau.ci <-
print.tau.ci & !all(is.na(x$lower.tau) & is.na(x$upper.tau))
if (print.tau.ci &&
(all(x$lower.tau == 0) & all(x$upper.tau == 0)))
print.tau.ci <- FALSE
##
cathet(k,
x$method.tau, x$detail.tau,
x$tau2, x$lower.tau2, x$upper.tau2,
print.tau2, print.tau2.ci, text.tau2, digits.tau2,
x$tau, x$lower.tau, x$upper.tau,
print.tau, print.tau.ci, text.tau, digits.tau,
x$sign.lower.tau, x$sign.upper.tau,
I2, lowI2, uppI2,
print.I2, print.I2.ci, text.I2, digits.I2,
H, lowH, uppH,
print.H, digits.H,
Rb, lowRb, uppRb,
print.Rb, text.Rb,
big.mark,
sort.tau, sort.het)
##
## Print information on residual heterogeneity
##
if (by & !is.metabind) {
##
Q.resid <- x$Q.w.common
k.resid <- x$df.Q.w + 1
##
if (print.H) {
H.resid <- round(replaceNULL(x$H.resid), digits.H)
lowH.resid <- round(replaceNULL(x$lower.H.resid), digits.H)
uppH.resid <- round(replaceNULL(x$upper.H.resid), digits.H)
}
if (print.I2) {
I2.resid <- round(100 * replaceNULL(x$I2.resid), digits.I2)
lowI2.resid <- round(100 * replaceNULL(x$lower.I2.resid), digits.I2)
uppI2.resid <- round(100 * replaceNULL(x$upper.I2.resid), digits.I2)
print.I2.ci <-
((replaceNULL(Q.resid) > replaceNULL(k.resid) &
replaceNULL(k.resid) >= 2) |
(replaceNULL(Q.resid) <= replaceNULL(k.resid) &
replaceNULL(k.resid) > 2)) &
!(is.na(replaceNULL(lowI2.resid)) |
is.na(replaceNULL(uppI2.resid)))
##
print.I2.ci <- unique(print.I2.ci)
if (is.na(print.I2.ci))
print.I2.ci <- FALSE
}
##
if (!is.na(replaceNULL(I2.resid))) {
cat("\nQuantifying residual heterogeneity:")
if (sum(c(print.tau2, print.tau, print.I2, print.H, print.Rb)) > 1)
cat("\n")
else
cat("")
##
cathet(k.resid,
x$method.tau, x$detail.tau,
x$tau2.resid, x$lower.tau2.resid, x$upper.tau2.resid,
x$tau.common, print.tau2.ci, text.tau2, digits.tau2,
x$tau.resid, x$lower.tau.resid, x$upper.tau.resid,
x$tau.common, print.tau.ci, text.tau, digits.tau,
"", "",
I2.resid, lowI2.resid, uppI2.resid,
print.I2, print.I2.ci, text.I2, digits.I2,
H.resid, lowH.resid, uppH.resid,
print.H, digits.H,
NA, NA, NA,
FALSE, "",
big.mark)
}
}
##
## Test of heterogeneity
##
if (print.Q & (common | random)) {
if (any(k > 1, na.rm = TRUE)) {
##
Qdat <- qdat(Q, df.Q, pval.Q, x$hetlabel, text.common)
##
sort.Q <- setsort(sort.Q, nrow(Qdat), "tests of heterogeneity")
##
Qdata <- cbind(formatN(round(Qdat$Q, digits.Q), digits.Q, "NA",
big.mark = big.mark),
format(Qdat$df.Q, big.mark = big.mark),
formatPT(Qdat$pval.Q,
digits = digits.pval.Q,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
dimnames(Qdata) <- list(Qdat$names, c("Q", "d.f.", "p-value"))
##
Qdata <- Qdata[sort.Q, , drop = FALSE]
##
cat("\nTest of heterogeneity:\n")
prmatrix(Qdata, quote = FALSE, right = TRUE, ...)
}
}
}
else {
print.tau2 <- FALSE
print.tau2.ci <- FALSE
print.tau <- FALSE
print.tau.ci <- FALSE
}
##
## Print information for subgroup analysis
##
if (by) {
if (is.metabind)
anaunit <- "meta-analyses"
else if (is.netpairwise)
anaunit <- "pairwise comparisons"
else
anaunit <- "subgroups"
##
if (common) {
##
## Subgroup analysis based on common effect model
##
if (is.vector(TE.common.w)) {
nam <- names(TE.common.w)
TE.common.w <- matrix(TE.common.w, ncol = 1)
lowTE.common.w <- matrix(lowTE.common.w, ncol = 1)
uppTE.common.w <- matrix(uppTE.common.w, ncol = 1)
##
if (!is.null(nam))
rownames(TE.common.w) <- rownames(lowTE.common.w) <-
rownames(uppTE.common.w) <- nam
}
##
n.common <- ncol(TE.common.w)
##
if (!is.list(df.Q.b.common))
df.Q.b.common <- list(df.Q.b.common)
##
df.Q.b.common <- do.call("c", df.Q.b.common)
##
for (i in seq_len(n.common)) {
Tdata <- cbind(format(k.w, big.mark = big.mark),
formatN(TE.common.w[, i], digits, "NA",
big.mark = big.mark),
formatCI(formatN(lowTE.common.w[, i], digits, "NA",
big.mark = big.mark),
formatN(uppTE.common.w[, i], digits, "NA",
big.mark = big.mark)),
formatN(round(Q.w, digits.Q), digits.Q,
big.mark = big.mark),
if (print.I2)
ifelse(is.na(I2.w),
"--",
paste0(formatN(I2.w, digits.I2), "%")),
if (print.Rb)
ifelse(is.na(Rb.w),
"--",
paste0(formatN(Rb.w, digits.I2), "%")),
if (!random & !is.list(x$tau.w))
ifelse(k.w == 1 & !x$tau.common, "--",
formatPT(x$tau.w^2,
digits = digits.tau2,
big.mark = big.mark,
noblanks = TRUE)),
if (!random & !is.list(x$tau.w))
ifelse(k.w == 1 & !x$tau.common, "--",
formatPT(x$tau.w,
digits = digits.tau,
big.mark = big.mark,
noblanks = TRUE))
)
##
bylab.txt <- bylabel(subgroup.name, subgroup.levels,
print.subgroup.name, sep.subgroup,
big.mark = big.mark)
##
dimnames(Tdata) <- list(bylab.txt,
c(if (is.netpairwise)
" m" else " k",
sm.lab, ci.lab,
"Q",
if (print.I2) text.I2,
if (print.Rb) text.Rb,
if (!random) text.tau2,
if (!random) text.tau)
)
##
if (is.metabind & !is.null(x$common.meta))
Tdata <- Tdata[x$common.meta, , drop = FALSE]
##
cat(paste0("\nResults for ", anaunit,
paste0(" (", text.common.br[i], "):\n")))
##
prmatrix(Tdata, quote = FALSE, right = TRUE, ...)
##
df.i <- df.Q.b.common[[i]]
##
if (length(df.i) > 1) {
dfs.b.i <-
rmSpace(paste(formatN(unlist(df.i), digits = 0,
big.mark = big.mark),
collapse = ", "), end = TRUE)
Q.lab <- "F"
}
else {
dfs.b.i <- formatN(df.i, digits = 0, big.mark = big.mark)
Q.lab <- "Q"
}
##
if (test.subgroup.common & !is.metabind) {
cat(paste0("\nTest for subgroup differences (",
text.common.br[i], "):\n"))
if (any(method == "MH") | all(is.na(Q.w.common))) {
Qdata <- cbind(formatN(round(Q.b.common[i], digits.Q),
digits.Q, "NA", big.mark = big.mark),
formatN(dfs.b.i, digits = 0,
big.mark = big.mark),
formatPT(pval.Q.b.common[i],
digits = digits.pval.Q,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
dimnames(Qdata) <- list("Between groups",
c(Q.lab, "d.f.", "p-value"))
prmatrix(Qdata, quote = FALSE, right = TRUE, ...)
}
else {
Qs <- c(Q.b.common[i], Q.w.common[i])
dfs <- c(dfs.b.i,
formatN(df.Q.w, digits = 0, big.mark = big.mark))
if (is.glmm & Q.lab == "F")
Q.lab <- "F/Q"
##
pvals <- c(pval.Q.b.common[i], pval.Q.w.common[i])
##
Qdata <- cbind(formatN(round(Qs, digits.Q), digits.Q, "NA",
big.mark = big.mark),
dfs,
formatPT(pvals,
digits = digits.pval.Q,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
dimnames(Qdata) <- list(c("Between groups", "Within groups"),
c(Q.lab, "d.f.", "p-value"))
prmatrix(Qdata, quote = FALSE, right = TRUE, ...)
}
}
}
}
##
if (random) {
##
## Subgroup analysis based on random effects model
##
if (is.vector(TE.random.w)) {
nam <- names(TE.random.w)
TE.random.w <- matrix(TE.random.w, ncol = 1)
lowTE.random.w <- matrix(lowTE.random.w, ncol = 1)
uppTE.random.w <- matrix(uppTE.random.w, ncol = 1)
##
if (!is.null(nam))
rownames(TE.random.w) <- rownames(lowTE.random.w) <-
rownames(uppTE.random.w) <- nam
}
##
n.random <- ncol(TE.random.w)
##
if (!is.list(x$tau.w))
x$tau.w <- list(x$tau.w)
##
if (!is.list(df.Q.b.random))
df.Q.b.random <- list(df.Q.b.random)
##
df.Q.b.random <- do.call("c", df.Q.b.random)
##
for (i in seq_len(n.random)) {
tau.i <- length(x$tau.w) >= i
##
Tdata <- cbind(format(k.w, big.mark = big.mark),
formatN(TE.random.w[, i], digits, "NA",
big.mark = big.mark),
formatCI(formatN(lowTE.random.w[, i], digits, "NA",
big.mark = big.mark),
formatN(uppTE.random.w[, i], digits, "NA",
big.mark = big.mark)),
if (i == 1 | tau.i)
ifelse(k.w == 1 & !x$tau.common, "--",
formatPT(x$tau.w[[i]]^2,
digits = digits.tau2,
big.mark = big.mark,
noblanks = TRUE)),
if (i == 1 | tau.i)
ifelse(k.w == 1 & !x$tau.common, "--",
formatPT(x$tau.w[[i]],
digits = digits.tau,
big.mark = big.mark,
noblanks = TRUE)),
if (i == 1 & !common)
formatN(round(Q.w, digits.Q), digits.Q,
big.mark = big.mark),
if (i == 1 & !common & print.I2)
ifelse(is.na(I2.w),
"--",
paste0(formatN(I2.w, digits.I2), "%")),
if (i == 1 & !common & print.Rb)
ifelse(is.na(Rb.w),
"--",
paste0(formatN(Rb.w, digits.I2,
big.mark = big.mark), "%"))
)
##
bylab.txt <- bylabel(subgroup.name, subgroup.levels,
print.subgroup.name, sep.subgroup,
big.mark = big.mark)
##
dimnames(Tdata) <- list(bylab.txt,
c(if (is.netpairwise)
" m" else " k",
sm.lab, ci.lab,
if (i == 1 | tau.i) text.tau2,
if (i == 1 | tau.i) text.tau,
if (i == 1 & !common) "Q",
if (i == 1 & !common & print.I2) text.I2,
if (i == 1 & !common & print.Rb) text.Rb)
)
##
if (is.metabind & !is.null(x$random.meta))
Tdata <- Tdata[x$random.meta, , drop = FALSE]
##
cat(paste0("\nResults for ", anaunit,
paste0(" (", text.random.br[i], "):\n")))
##
prmatrix(Tdata, quote = FALSE, right = TRUE, ...)
##
df.i <- df.Q.b.random[[i]]
##
if (length(df.i) > 1) {
dfs.b.i <-
rmSpace(paste(formatN(df.i, digits = 0,
big.mark = big.mark),
collapse = ", "), end = TRUE)
Q.lab <- "F"
}
else {
dfs.b.i <- formatN(df.i, digits = 0, big.mark = big.mark)
Q.lab <- "Q"
}
##
if (test.subgroup.random & !is.na(Q.b.random[i]) & !is.metabind) {
cat(paste0("\nTest for subgroup differences (",
text.random.br[i],
"):\n"))
if (all(is.na(Q.w.random))) {
Qdata <- cbind(formatN(round(Q.b.random[i], digits.Q),
digits.Q, "NA", big.mark = big.mark),
formatN(dfs.b.i, digits = 0,
big.mark = big.mark),
formatPT(pval.Q.b.random[i],
digits = digits.pval.Q,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
dimnames(Qdata) <- list("Between groups",
c(Q.lab, "d.f.", "p-value"))
}
else {
Qs <- c(Q.b.random[i], Q.w.random[i])
dfs <- c(dfs.b.i,
formatN(df.Q.w, digits = 0, big.mark = big.mark))
Q.lab <-
ifelse((three.level | is.glmm) && Q.lab == "F", "F/Q", Q.lab)
##
pvals <- c(pval.Q.b.random[i], pval.Q.w.random[i])
##
Qdata <- cbind(formatN(round(Qs, digits.Q), digits.Q, "NA",
big.mark = big.mark),
dfs,
formatPT(pvals,
digits = digits.pval.Q,
scientific = scientific.pval,
zero = zero.pval, JAMA = JAMA.pval))
dimnames(Qdata) <- list(c("Between groups", "Within groups"),
c(Q.lab, "d.f.", "p-value"))
}
prmatrix(Qdata, quote = FALSE, right = TRUE, ...)
}
}
}
##
if (prediction.w) {
##
## Prediction intervals for subgroups
##
if (is.vector(lowTE.predict.w)) {
nam <- names(lowTE.predict.w)
lowTE.predict.w <- matrix(lowTE.predict.w, ncol = 1)
uppTE.predict.w <- matrix(uppTE.predict.w, ncol = 1)
##
rownames(lowTE.predict.w) <- rownames(uppTE.predict.w) <- nam
}
##
for (i in seq_len(ncol(lowTE.predict.w))) {
Pdata <- cbind(formatCI(formatN(lowTE.predict.w[, i], digits, "NA",
big.mark = big.mark),
formatN(uppTE.predict.w[, i], digits, "NA",
big.mark = big.mark)))
##
bylab.txt <-
bylabel(subgroup.name, subgroup.levels,
print.subgroup.name, sep.subgroup,
big.mark = big.mark)
lab.predict <- paste0(round(100 * x$level.predict, 1), "%-PI")
dimnames(Pdata) <- list(bylab.txt, lab.predict)
##
Pdata <- Pdata[prediction.subgroup.logical, , drop = FALSE]
##
cat(paste0("\n", text.predict[i], " for subgroups:\n"))
prmatrix(Pdata, quote = FALSE, right = TRUE, ...)
}
}
}
##
## Print information on meta-analysis method:
##
x$pscale <- pscale
x$irscale <- irscale
x$irunit <- irunit
##
if (details.methods &
(common | random | prediction | overall.hetstat | by))
details <-
catmeth(x,
common, random, prediction, overall, overall.hetstat,
x$func.transf, backtransf, fbt,
big.mark, digits, digits.tau, text.tau, text.tau2,
print.tau2, print.tau2.ci,
print.tau, print.tau.ci,
print.df = overall)
}
invisible(details)
}
#' @rdname print.meta
#' @export cilayout
cilayout <- function(bracket = gs("CIbracket"),
separator = gs("CIseparator"),
lower.blank = gs("CIlower.blank"),
upper.blank = gs("CIupper.blank")) {
chkchar(bracket, length = 1)
chkchar(separator, length = 1)
##
bracket <- setchar(bracket, c("[", "(", "{", ""))
##
chklogical(lower.blank)
chklogical(upper.blank)
setOption("CIbracket", bracket)
setOption("CIseparator", separator)
setOption("CIlower.blank", lower.blank)
setOption("CIupper.blank", upper.blank)
invisible(NULL)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.