Nothing
R/forest.R
In meta: General Package for Meta-Analysis
Defines functions
forest.meta
Documented in
forest.meta
#' Forest plot to display the result of a meta-analysis
#'
#' @description
#' Draws a forest plot in the active graphics window (using grid
#' graphics system).
#'
#' @aliases forest forest.meta
#'
#' @param x An object of class \code{meta}.
#' @param sortvar An optional vector used to sort the individual
#' studies (must be of same length as \code{x$TE}).
#' @param studlab A logical indicating whether study labels should be
#' printed in the graph. A vector with study labels can also be
#' provided (must be of same length as \code{x$TE} then).
#' @param layout A character string specifying the layout of the
#' forest plot (see Details).
#' @param common A logical indicating whether common effect estimate
#' should be plotted.
#' @param random A logical indicating whether random effects estimate
#' should be plotted.
#' @param overall A logical indicating whether overall summaries
#' should be plotted. This argument is useful in a meta-analysis
#' with subgroups if summaries should only be plotted on group
#' level.
#' @param text.common A character string used in the plot to label the
#' pooled common effect estimate.
#' @param text.random A character string used in the plot to label the
#' pooled random effects estimate.
#' @param lty.common Line type (pooled common effect estimate).
#' @param lty.random Line type (pooled random effects estimate).
#' @param col.common Line colour (pooled common effect estimate).
#' @param col.random Line colour (pooled random effects estimate).
#' @param text.w.common A character string used to label weights of
#' common effect model.
#' @param text.w.random A character string used to label weights of
#' random effects model.
#' @param prediction A logical indicating whether a prediction
#' interval should be printed.
#' @param text.predict A character string used in the plot to label
#' the prediction interval.
#' @param subgroup A single logical or logical vector indicating
#' whether / which subgroup results should be shown in forest
#' plot. This argument is useful in a meta-analysis with subgroups
#' if summaries should not be plotted for (some) subgroups.
#' @param subgroup.hetstat A single logical or logical vector
#' indicating whether / which information on heterogeneity in
#' subgroups should be shown in forest plot. This argument is useful
#' in a meta-analysis with subgroups if heterogeneity statistics
#' should not be printed for (some) subgroups.
#' @param print.subgroup.labels A logical indicating whether subgroup
#' label should be printed.
#' @param subgroup.name A character string with a label 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 text.common.w A character string to label the pooled common
#' effect estimate within subgroups, or a character vector of same
#' length as number of subgroups with corresponging labels.
#' @param text.random.w A character string to label the pooled random
#' effect estimate within subgroups, or a character vector of same
#' length as number of subgroups with corresponging labels.
#' @param text.predict.w A character string to label the prediction
#' interval within subgroups, or a character vector of same length
#' as number of subgroups with corresponging labels.
#' @param sort.subgroup A logical indicating whether groups should be
#' ordered alphabetically.
#' @param pooled.totals A logical indicating whether total number of
#' observations should be given in the figure.
#' @param pooled.events A logical indicating whether total number of
#' events should be given in the figure.
#' @param pooled.times A logical indicating whether total person time
#' at risk should be given in the figure.
#' @param study.results A logical indicating whether results for
#' individual studies should be shown in the figure (useful to only
#' plot subgroup results).
#' @param xlab A label for the x-axis.
#' @param xlab.pos A numeric specifying the center of the label on the
#' x-axis.
#' @param smlab A label for the summary measure (printed at top of
#' figure).
#' @param smlab.pos A numeric specifying the center of the label for
#' the summary measure.
#' @param xlim The x limits (min,max) of the plot, or the character
#' string "symmetric" to produce symmetric forest plots.
#' @param allstudies A logical indicating whether studies with
#' inestimable treatment effects should be included in the forest
#' plot.
#' @param weight.study A character string indicating weighting used to
#' determine size of squares or diamonds (argument
#' \code{type.study}) to plot individual study results. One of
#' missing, \code{"same"}, \code{"common"}, or \code{"random"}, can
#' be abbreviated. Plot symbols have the same size for all studies
#' or represent study weights from common effect or random effects
#' model.
#' @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 ref A numerical giving the reference value to be plotted as
#' a line in the forest plot. No reference line is plotted if
#' argument \code{ref} is equal to \code{NA}.
#' @param lower.equi A numerical giving the lower limit of equivalence
#' to be plotted as a line in the forest plot. Or a vector to
#' provide several limits, e.g., for large, moderate and small
#' effects. No line is plotted if argument \code{lower.equi} is
#' equal to \code{NA}.
#' @param upper.equi A numerical giving the upper limit of equivalence
#' to be plotted as a line in the forest plot. Or a vector to
#' provide several limits, e.g., for small, moderate and large
#' effects. No line is plotted if argument \code{upper.equi} is
#' equal to \code{NA}.
#' @param lty.equi Line type (limits of equivalence).
#' @param col.equi Line colour (limits of equivalence).
#' @param fill.equi Colour(s) for area between limits of equivalence
#' or more general limits.
#' @param fill.lower.equi Colour of area between lower limit(s) and
#' reference value. Can be equal to the number of lower limits or
#' the number of limits plus 1 (in this case the the region between
#' minimum and smallest limit is also filled).
#' @param fill.upper.equi Colour of area between reference value and
#' upper limit(s). Can be equal to the number of upper limits or the
#' number of limits plus 1 (in this case the region between largest
#' limit and maximum is also filled).
#' @param leftcols A character vector specifying (additional) columns
#' to be printed on the left side of the forest plot or a logical
#' value (see Details).
#' @param rightcols A character vector specifying (additional) columns
#' to be printed on the right side of the forest plot or a logical
#' value (see Details).
#' @param leftlabs A character vector specifying labels for
#' (additional) columns on left side of the forest plot (see
#' Details).
#' @param rightlabs A character vector specifying labels for
#' (additional) columns on right side of the forest plot (see
#' Details).
#' @param label.e Label to be used for experimental group in table
#' heading.
#' @param label.c Label to be used for control group in table heading.
#' @param label.e.attach A character specifying the column name where
#' label \code{label.e} should be attached to in table heading.
#' @param label.c.attach A character specifying the column name where
#' label \code{label.c} should be attached to in table heading.
#' @param label.left Graph label on left side of forest plot.
#' @param label.right Graph label on right side of forest plot.
#' @param bottom.lr A logical indicating whether labels on right and
#' left side should be printed at bottom or top of forest plot.
#' @param lab.NA A character string to label missing values.
#' @param lab.NA.effect A character string to label missing values in
#' individual treatment estimates and confidence intervals.
#' @param lab.NA.weight A character string to label missing weights.
#' @param lwd The line width, see \code{\link{par}}.
#' @param at The points at which tick-marks are to be drawn, see
#' \code{grid.xaxis}.
#' @param label A logical value indicating whether to draw the labels
#' on the tick marks, or an expression or character vector which
#' specify the labels to use. See \code{\link{grid.xaxis}}.
#' @param type.study A character string or vector specifying how to
#' plot treatment effects and confidence intervals for individual
#' studies (see Details).
#' @param type.common A character string specifying how to plot
#' treatment effect and confidence interval for common effect
#' meta-analysis (see Details).
#' @param type.random A character string specifying how to plot
#' treatment effect and confidence interval for random effects
#' meta-analysis (see Details).
#' @param type.subgroup A character string specifying how to plot
#' treatment effect and confidence interval for subgroup results
#' (see Details).
#' @param type.subgroup.common A character string specifying how to
#' plot treatment effect and confidence interval for subgroup
#' results (common effect model).
#' @param type.subgroup.random A character string specifying how to
#' plot treatment effect and confidence interval for subgroup
#' results (random effects model).
#' @param col.study The colour for individual study results and
#' confidence limits.
#' @param col.inside The colour for individual study results and
#' confidence limits if confidence limits are completely within
#' squares.
#' @param col.inside.common The colour for result of common effect
#' meta-analysis if confidence limit lies completely within square.
#' @param col.inside.random The colour for result of random effects
#' meta-analysis if confidence limit lies completely within square.
#' @param col.square The colour for squares reflecting study's weight
#' in the meta-analysis.
#' @param col.square.lines The colour for the outer lines of squares
#' reflecting study's weight in the meta-analysis.
#' @param col.diamond The colour of diamonds representing the results
#' for common effect and random effects models.
#' @param col.diamond.common The colour of diamonds for common effect
#' estimates.
#' @param col.diamond.random The colour of diamonds for random effects
#' estimates.
#' @param col.diamond.lines The colour of the outer lines of diamonds
#' representing the results for common effect and random effects
#' models.
#' @param col.diamond.lines.common The colour of the outer lines of
#' diamond for common effect estimate.
#' @param col.diamond.lines.random The colour of the outer lines of
#' diamond for random effects estimate.
#' @param col.predict Background colour of prediction interval.
#' @param col.predict.lines Colour of outer lines of prediction
#' interval.
#' @param col.subgroup The colour to print information on subgroups.
#' @param col.label.right The colour for label on right side of null
#' effect.
#' @param col.label.left The colour for label on left side of null
#' effect.
#' @param hetstat Either a logical value indicating whether to print
#' results for heterogeneity measures at all or a character string
#' (see Details).
#' @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 hetlab Label printed in front of results for heterogeneity
#' measures.
#' @param resid.hetstat A logical value indicating whether to print
#' measures of residual heterogeneity in a meta-analysis with
#' subgroups.
#' @param resid.hetlab Label printed in front of results for residual
#' heterogeneity measures.
#' @param print.I2 A logical value indicating whether to print the
#' value of the I-squared statistic.
#' @param print.I2.ci A logical value indicating whether to print the
#' confidence interval of the I-squared statistic.
#' @param print.tau2 A logical value indicating whether to print the
#' value of the between-study variance \eqn{\tau^2}.
#' @param print.tau2.ci A logical value indicating whether to print
#' the confidence interval of \eqn{\tau^2}.
#' @param print.tau A logical value indicating whether to print
#' \eqn{\tau}, the square root of the between-study variance
#' \eqn{\tau^2}.
#' @param print.tau.ci A logical value indicating whether to print the
#' confidence interval of \eqn{\tau}.
#' @param print.Q A logical value indicating whether to print the
#' value of the heterogeneity statistic Q.
#' @param print.pval.Q A logical value indicating whether to print the
#' p-value of the heterogeneity statistic Q.
#' @param print.Rb A logical value indicating whether to print the
#' value of the I-squared statistic.
#' @param print.Rb.ci A logical value indicating whether to print the
#' confidence interval of the I-squared statistic.
#' @param text.subgroup.nohet A logical value or character string
#' which is printed to indicate subgroups with less than two studies
#' contributing to meta-analysis (and thus without
#' heterogeneity). If FALSE, heterogeneity statistics are printed
#' (with NAs).
#' @param LRT A logical value indicating whether to report
#' Likelihood-Ratio or Wald-type test of heterogeneity for
#' generalized linear mixed models.
#' @param test.overall A logical value indicating whether to print
#' results of test for overall effect.
#' @param test.overall.common A logical value indicating whether to
#' print results of test for overall effect (common effect model).
#' @param test.overall.random A logical value indicating whether to
#' print results of test for overall effect (random effects model).
#' @param label.test.overall.common Label printed in front of results
#' of test for overall effect (common effect model).
#' @param label.test.overall.random Label printed in front of results
#' of test for overall effect (random effects model).
#' @param print.stat A logical value indicating whether z- or t-value
#' for test of treatment effect should be printed.
#' @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 (common effect
#' model).
#' @param test.subgroup.random A logical value indicating whether to
#' print results of test for subgroup differences (random effects
#' model).
#' @param prediction.subgroup A single logical or logical vector
#' indicating whether / which prediction intervals should be printed
#' for subgroups.
#' @param print.Q.subgroup A logical value indicating whether to print
#' the value of the heterogeneity statistic Q (test for subgroup
#' differences).
#' @param label.test.subgroup.common Label printed in front of results
#' of test for subgroup differences (common effect model).
#' @param label.test.subgroup.random Label printed in front of results
#' of test for subgroup differences (random effects model).
#' @param test.effect.subgroup A single logical or logical vector
#' indicating whether / which tests for effect in subgroups should
#' be printed.
#' @param test.effect.subgroup.common A single logical or logical
#' vector indicating whether / which tests for effect in subgroups
#' should be printed (common effect model).
#' @param test.effect.subgroup.random A single logical or logical
#' vector indicating whether / which tests for effect in subgroups
#' should be printed (random effects model).
#' @param label.test.effect.subgroup.common Label printed in front of
#' results of test for effect in subgroups (common effect model).
#' @param label.test.effect.subgroup.random Label printed in front of
#' results of test for effect in subgroups (random effects model).
#' @param text.addline1 Text for first additional line (below
#' meta-analysis results).
#' @param text.addline2 Text for second additional line (below
#' meta-analysis results).
#' @param header.line A logical value indicating whether to print a
#' header line or a character string ("both", "below", "").
#' @param fontsize The size of text (in points), see
#' \code{\link{gpar}}.
#' @param fontfamily The font family, see \code{\link{gpar}}.
#' @param fs.heading The size of text for column headings, see
#' \code{\link{gpar}}.
#' @param fs.common The size of text for results of common effect
#' model, see \code{\link{gpar}}.
#' @param fs.random The size of text for results of random effects
#' model, see \code{\link{gpar}}.
#' @param fs.predict The size of text for results of prediction
#' interval, see \code{\link{gpar}}.
#' @param fs.common.labels The size of text for label of common effect
#' model, see \code{\link{gpar}}.
#' @param fs.random.labels The size of text for label of random
#' effects model, see \code{\link{gpar}}.
#' @param fs.predict.labels The size of text for label of prediction
#' interval, see \code{\link{gpar}}.
#' @param fs.study The size of text for results of individual studies,
#' see \code{\link{gpar}}.
#' @param fs.study.labels The size of text for labels of individual
#' studies, see \code{\link{gpar}}.
#' @param fs.hetstat The size of text for heterogeneity measures, see
#' \code{\link{gpar}}.
#' @param fs.test.overall The size of text of test for overall effect,
#' see \code{\link{gpar}}.
#' @param fs.test.subgroup The size of text of test of subgroup
#' differences, see \code{\link{gpar}}.
#' @param fs.test.effect.subgroup The size of text of test of effect
#' in subgroups, see \code{\link{gpar}}.
#' @param fs.addline The size of text for additional lines, see
#' \code{\link{gpar}}.
#' @param fs.axis The size of text on x-axis, see \code{\link{gpar}}.
#' @param fs.smlab The size of text of label for summary measure, see
#' \code{\link{gpar}}.
#' @param fs.xlab The size of text of label on x-axis, see
#' \code{\link{gpar}}.
#' @param fs.lr The size of text of label on left and right side of
#' forest plot, see \code{\link{gpar}}.
#' @param ff.heading The fontface for column headings, see
#' \code{\link{gpar}}.
#' @param ff.common The fontface of text for results of common effect
#' model, see \code{\link{gpar}}.
#' @param ff.random The fontface of text for results of random effects
#' model, see \code{\link{gpar}}.
#' @param ff.predict The fontface of text for results of prediction
#' interval, see \code{\link{gpar}}.
#' @param ff.common.labels The fontface of text for label of common
#' effect model, see \code{\link{gpar}}.
#' @param ff.random.labels The fontface of text for label of random
#' effects model, see \code{\link{gpar}}.
#' @param ff.predict.labels The fontface of text for label of
#' prediction interval, see \code{\link{gpar}}.
#' @param ff.study The fontface of text for results of individual
#' studies, see \code{\link{gpar}}.
#' @param ff.study.labels The fontface of text for labels of
#' individual studies, see \code{\link{gpar}}.
#' @param ff.hetstat The fontface of text for heterogeneity measures,
#' see \code{\link{gpar}}.
#' @param ff.test.overall The fontface of text of test for overall
#' effect, see \code{\link{gpar}}.
#' @param ff.test.subgroup The fontface of text for test of subgroup
#' differences, see \code{\link{gpar}}.
#' @param ff.test.effect.subgroup The fontface of text for test of
#' effect in subgroups, see \code{\link{gpar}}.
#' @param ff.addline The fontface of text for additional lines, see
#' \code{\link{gpar}}.
#' @param ff.axis The fontface of text on x-axis, see
#' \code{\link{gpar}}.
#' @param ff.smlab The fontface of text of label for summary measure,
#' see \code{\link{gpar}}.
#' @param ff.xlab The fontface of text of label on x-axis, see
#' \code{\link{gpar}}.
#' @param ff.lr The fontface of text of label on left and right side
#' of forest plot, see \code{\link{gpar}}.
#' @param squaresize A numeric used to increase or decrease the size
#' of squares in the forest plot.
#' @param plotwidth Either a character string, e.g., "8cm", "60mm", or
#' "3inch", or a \code{\link[grid]{unit}} object specifying width of
#' the forest plot.
#' @param colgap Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between columns
#' printed on left and right side of forest plot.
#' @param colgap.left Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between columns
#' printed on left side of forest plot.
#' @param colgap.right Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between columns
#' printed on right side of forest plot.
#' @param colgap.studlab Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between column
#' with study labels and subsequent column.
#' @param colgap.forest Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between column
#' adjacent to forest plot and the forest plot.
#' @param colgap.forest.left Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between column on
#' the left side of forest plot and the forest plot.
#' @param colgap.forest.right Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between column on
#' the right side of forest plot and the forest plot.
#' @param calcwidth.pooled A logical indicating whether text for
#' common effect and random effects model should be considered to
#' calculate width of the column with study labels.
#' @param calcwidth.common A logical indicating whether text given in
#' arguments \code{text.common} and \code{text.common.w} should be
#' considered to calculate width of the column with study labels.
#' @param calcwidth.random A logical indicating whether text given in
#' arguments \code{text.random} and \code{text.random.w} should be
#' considered to calculate width of the column with study labels.
#' @param calcwidth.predict A logical indicating whether text given in
#' argument \code{text.predict} and \code{text.predict.w} should be
#' considered to calculate width of the column with study labels.
#' @param calcwidth.hetstat A logical indicating whether text for
#' heterogeneity statistics should be considered to calculate width
#' of the column with study labels.
#' @param calcwidth.tests A logical indicating whether text for tests
#' of overall effect or subgroup differences should be considered to
#' calculate width of the column with study labels.
#' @param calcwidth.subgroup A logical indicating whether text with
#' subgroup labels should be considered to calculate width of the
#' column with study labels.
#' @param calcwidth.addline A logical indicating whether text for
#' additional lines should be considered to calculate width of the
#' column with study labels.
#' @param just Justification of text in all columns but columns with
#' study labels and additional variables (possible values: "left",
#' "right", "center").
#' @param just.studlab Justification of text for study labels
#' (possible values: "left", "right", "center").
#' @param just.addcols Justification of text for additional columns
#' (possible values: "left", "right", "center").
#' @param just.addcols.left Justification of text for additional
#' columns on left side of forest plot (possible values: "left",
#' "right", "center"). Can be of same length as number of additional
#' columns on left side of forest plot.
#' @param just.addcols.right Justification of text for additional
#' columns on right side of forest plot (possible values: "left",
#' "right", "center"). Can be of same length as number of additional
#' columns on right side of forest plot.
#' @param spacing A numeric determining line spacing in a forest plot.
#' @param addrow A logical value indicating whether an empty row is
#' printed above study results.
#' @param addrow.overall A logical value indicating whether an empty
#' row is printed above overall meta-analysis results.
#' @param addrow.subgroups A logical value indicating whether an empty
#' row is printed between results for subgroups.
#' @param addrows.below.overall A numeric value indicating how many
#' empty rows are printed between meta-analysis results and
#' heterogeneity statistics and test results.
#' @param new A logical value indicating whether a new figure should
#' be printed in an existing graphics window.
#' @param backtransf A logical indicating whether results should be
#' back transformed in forest plots. If \code{backtransf = TRUE},
#' results for \code{sm = "OR"} are presented as odds ratios rather
#' than log odds ratios and results for \code{sm = "ZCOR"} are
#' presented as correlations rather than Fisher's z transformed
#' correlations, for example.
#' @param digits Minimal number of significant digits for treatment
#' effects, see \code{print.default}.
#' @param digits.se Minimal number of significant digits for standard
#' errors, see \code{print.default}.
#' @param digits.stat Minimal number of significant digits for z- or
#' t-statistic for test of overall effect, see \code{print.default}.
#' @param digits.tau2 Minimal number of significant digits for
#' between-study variance, see \code{print.default}.
#' @param digits.tau Minimal number of significant digits for square
#' root of between-study variance, 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.I2 Minimal number of significant digits for I-squared
#' statistic, see \code{print.default}.
#' @param digits.weight Minimal number of significant digits for
#' weights, see \code{print.default}.
#' @param digits.mean Minimal number of significant digits for means;
#' only applies to \code{\link{metacont}} objects.
#' @param digits.sd Minimal number of significant digits for standard
#' deviations; only applies to \code{\link{metacont}} objects.
#' @param digits.cor Minimal number of significant digits for
#' correlations; only applies to \code{\link{metacor}} objects.
#' @param digits.time Minimal number of significant digits for times;
#' only applies to \code{\link{metainc}} and \code{\link{metarate}}
#' objects.
#' @param digits.TE Minimal number of significant digits for list
#' element 'TE'.
#' @param digits.addcols A vector or scalar with minimal number of
#' significant digits for additional columns.
#' @param digits.addcols.left A vector or scalar with minimal number
#' of significant digits for additional columns on left side of
#' forest plot.
#' @param digits.addcols.right A vector or scalar with minimal number
#' of significant digits for additional columns on right side of
#' forest plot.
#' @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 warn.deprecated A logical indicating whether warnings should
#' be printed if deprecated arguments are used.
#' @param \dots Additional graphical arguments.
#'
#' @details
#' A forest plot, also called confidence interval plot, is drawn in
#' the active graphics window. The forest functions in R package
#' \bold{meta} are based on the grid graphics system. In order to
#' print the forest plot, resize the graphics window and either use
#' \code{\link{dev.copy2eps}} or \code{\link{dev.copy2pdf}}. Another
#' possibility is to create a file using \code{\link{pdf}},
#' \code{\link{png}}, or \code{\link{svg}} and to specify the width and
#' height of the graphic (see Examples).
#'
#' \subsection{Default layout for studies and pooled effects}{
#'
#' By default, treatment estimates and confidence intervals are
#' plotted in the following way:
#' \itemize{
#' \item For an individual study, a square with treatment estimate in
#' the center and confidence interval as line extending either side
#' of the square (\code{type.study = "square"})
#' \item For meta-analysis results, a diamond with treatment estimate
#' in the center and right and left side corresponding to lower and
#' upper confidence limits (\code{type.common = "diamond"},
#' \code{type.random = "diamond"}, and \code{type.subgroup = "diamond"})
#' }
#'
#' In a forest plot, size of the squares typically reflects the precision of
#' individual treatment estimates based either on the common effect
#' (\code{weight.study = "common"}) or random effects meta-analysis
#' (\code{weight.study = "random"}). Information from meta-analysis object
#' \code{x} is utilised if argument \code{weight.study} is missing. Weights
#' from the common effect model are used if argument \code{x$common} is
#' \code{TRUE}; weights from the random effects model are used if argument
#' \code{x$random} is \code{TRUE} and \code{x$common} is \code{FALSE}.
#' The same square sizes are used if \code{weight.study = "same"}.
#'
#' A prediction interval for treatment effect of a new study (Higgins
#' et al., 2009) is given in the forest plot if arguments
#' \code{prediction} and \code{random} are \code{TRUE}. For
#' graphical presentation of prediction intervals the approach by
#' Guddat et al. (2012) is used.
#' }
#'
#' \subsection{Columns printed on left side of forest plot}{
#'
#' Argument \code{leftcols} can be used to specify columns which are
#' printed on the left side of the forest plot. By default, i.e. if
#' argument \code{leftcols} is \code{NULL} and \code{layout = "meta"},
#' and depending on the class of the meta-analysis object (which is
#' defined by the R function used to generate the object) a different
#' set of \emph{\bold{columns}} is printed \emph{\bold{on the left
#' side of the forest plot}}:
#' \tabular{ll}{
#' \bold{Function} \tab \bold{Value of argument leftcols} \cr
#' \code{\link{metabin}} \tab \code{c("studlab", "event.e", "n.e",
#' "event.c", "n.c")} \cr
#' \code{\link{metacont}} \tab \code{c("studlab", "n.e", "mean.e",
#' "sd.e", "n.c", "mean.c", "sd.c")} \cr
#' \code{\link{metacor}} \tab \code{c("studlab", "n")} \cr
#' \code{\link{metagen}} \tab \code{c("studlab", "TE", "seTE")} \cr
#' \code{\link{metainc}} \tab \code{c("studlab", "event.e", "time.e",
#' "event.c", "time.c")} \cr
#' \code{\link{metamean}} \tab \code{c("studlab", "n", "mean", "sd")}
#' \cr
#' \code{\link{metaprop}} \tab \code{c("studlab", "event", "n")} \cr
#' \code{\link{metarate}} \tab \code{c("studlab", "event", "time", "n")}
#' \cr
#' \code{\link{metacum}} \tab \code{"studlab"} \cr
#' \code{\link{metainf}} \tab \code{"studlab"}
#' }
#'
#' For three-level models, the cluster variable is printed next to the
#' study labels (value \code{"cluster"} in argument \code{leftcols}).
#'
#' By default, study labels and labels for pooled estimates and
#' heterogeneity statistics will be printed in the first column on the
#' left side of the forest plot. The character string \code{"studlab"}
#' is used to identify study labels as this is the name of the list
#' element of a meta-analysis object.
#'
#' If the character string \code{"studlab"} is not provided in
#' \code{leftcols} and \code{rightcols}, the first \emph{additional}
#' variable specified by the user is used as study labels (and labels
#' for pooled estimates are printed in this column). Additional
#' variables are any variables not mentioned in the section on
#' predefined column names below. For example, \code{leftcols =
#' "studlab"} and \code{leftcols = "study"} would result in the same
#' forest plot if the variable \code{"study"} was used in the command
#' to conduct the meta-analysis. If no additional variable is provided
#' by the user, no study labels will be printed.
#' }
#'
#' \subsection{Overlapping information on left side of forest plot}{
#'
#' Depending on the number of columns printed on the left side of the
#' forest plot, information on heterogeneity measures or statistical
#' tests (see below) can be overlapping with the x-axis. Argument
#' \code{addrows.below.overall} can be used to specify the number of
#' empty rows that are printed between meta-analysis results and
#' information on heterogeneity measures and statistical tests. By
#' default, no additional rows are added to the forest plot. If
#' \code{addrows.below.overall = NULL}, the function tries to add a
#' sufficient number of empty rows to prevent overlapping
#' text. Another possibility is to manually increase the space between
#' the columns on the left side (argument \code{colgap.left}) or
#' between the columns on the left side and the forest plot (argument
#' \code{colgap.forest.left}).
#' }
#'
#' \subsection{Columns printed on right side of forest plot}{
#'
#' Argument \code{rightcols} can be used to
#' specify columns which are printed on the right side of the
#' forest plot. If argument \code{rightcols} is
#' \code{FALSE}, no columns will be printed on the right side. By
#' default, i.e. if argument \code{rightcols} is
#' \code{NULL} and \code{layout = "meta"}, the following
#' \emph{\bold{columns}} will be printed \emph{\bold{on the right side
#' of the forest plot}}:
#' \tabular{ll}{
#' \bold{Meta-analysis results} \tab \bold{Value of argument
#' rightcols} \cr
#' No summary \tab \code{c("effect", "ci")} \cr
#' Only common effect model \tab \code{c("effect", "ci", "w.common")}
#' \cr
#' Only random effects model \tab \code{c("effect", "ci", "w.random")}
#' \cr
#' Both models \tab \code{c("effect", "ci", "w.common", "w.random")}
#' }
#'
#' By default, estimated treatment effect and corresponding confidence
#' interval will be printed. Depending on arguments \code{common} and
#' \code{random}, weights of the common effect and/or random effects
#' model will be given too.
#'
#' For an object of class \code{\link{metacum}} or
#' \code{\link{metainf}} the following columns will be printed:
#' \code{c("effect", "ci", "pval", "tau2", "tau", "I2")}. This
#' information corresponds to the printout with
#' \code{\link{print.meta}}.
#' }
#'
#' \subsection{Predefined column names}{
#'
#' The arguments \code{leftlabs} and \code{rightlabs} can be used to
#' specify column headings which are printed on left or right side of
#' the forest plot. For certain columns predefined labels exist which
#' are used by default, i.e., if arguments \code{leftlabs} and
#' \code{rightlabs} are \code{NULL}:
#' \tabular{rcccccc}{
#' Column: \tab \code{studlab} \tab \code{TE} \tab \code{seTE} \tab
#' \code{cluster} \tab \code{n.e} \tab \code{n.c} \cr
#' Label: \tab "Study" \tab "TE" \tab "seTE" \tab "Cluster" \tab
#' "Total" \tab "Total" \cr
#' \cr
#' Column: \tab \code{n} \tab \code{event.e} \tab \code{event.c} \tab
#' \code{event} \tab \code{mean.e} \tab \code{mean.c} \cr
#' Label: \tab "Total" \tab "Events" \tab "Events" \tab "Events" \tab
#' "Mean" \tab "Mean" \cr
#' \cr
#' Column: \tab \code{sd.e} \tab \code{sd.c} \tab \code{time.e}
#' \tab \code{time.c} \tab \code{effect} \tab \cr
#' Label: \tab "SD" \tab "SD" \tab "Time" \tab "Time" \tab
#' \code{x$sm} \tab \cr
#' \cr
#' Column: \tab \code{ci} \tab \code{effect.ci} \tab
#' \code{w.common} \tab \code{w.random} \tab \tab \cr
#' Label: \tab \code{x$level}"\%-CI" \tab \emph{effect+ci} \tab
#' "W(common)" \tab "W(random)" \tab \tab
#' }
#'
#' For other columns, the column name will be used as a label if no
#' column label is defined. It is possible to only provide labels for
#' new columns (see Examples). Otherwise the length of \code{leftlabs}
#' and \code{rightlabs} must be the same as the number of printed
#' columns. The value \code{NA} can be used to specify columns which
#' should use default labels (see Examples).
#'
#'
#' In pairwise meta-analysis comparing two groups (i.e.,
#' \code{\link{metabin}}, \code{\link{metacont}},
#' \code{\link{metainc}}, and \code{\link{metagen}} depending on the
#' outcome), arguments \code{label.e} and \code{label.c} are used to
#' label columns belonging to the two treatment groups. By default,
#' labels defined in the meta-analysis object are used. The columns
#' where treatment labels are attached can be changed using arguments
#' \code{label.e.attach} and \code{label.c.attach}.
#' }
#'
#' \subsection{Information on heterogeneity and statistical tests}{
#'
#' Argument \code{hetstat} can be a character string to specify where
#' to print heterogeneity information:
#' \itemize{
#' \item row with results for common effect model (\code{hetstat =
#' "common"}),
#' \item row with results for random effects model (\code{hetstat =
#' "random"}).
#' }
#'
#' Otherwise, information on heterogeneity measures is printed below
#' the meta-analysis results if argument \code{overall.hetstat = TRUE}
#' (default). The heterogeneity measures to print can be specified
#' (see list of arguments following \code{overall.hetstat}).
#'
#' In addition, the following arguments can be used to print results
#' for various statistical tests:
#' \tabular{ll}{
#' \bold{Argument} \tab \bold{Statistical test} \cr
#' \code{test.overall.common} \tab Test for overall effect (common
#' effect model) \cr
#' \code{test.overall.random} \tab Test for overall effect (random
#' effects model) \cr
#' \code{test.effect.subgroup.common} \tab Test for effect in subgroup
#' (CE model) \cr
#' \code{test.effect.subgroup.random} \tab Test for effect in subgroup
#' (RE model) \cr
#' \code{test.subgroup.common} \tab Test for subgroup differences (CE
#' model) \cr
#' \code{test.subgroup.random} \tab Test for subgroup differences (RE
#' model)
#' }
#'
#' By default, these arguments are \code{FALSE} with exception of
#' tests for subgroup differences which are \code{TRUE}. R function
#' \code{\link{settings.meta}} can be used to change this default for
#' the entire R session. For example, use the following command to
#' always print results of tests for an overall effect:
#' \code{settings.meta(test.overall = TRUE)}.
#' }
#'
#' \subsection{Flexible printing of subgroup results}{
#'
#' Argument \code{subgroup} determines whether summary results are
#' printed for subgroups. A logical vector of length equal to the
#' number of subgroups can be provided to determine which subgroup
#' summaries are printed. By default, only subgroup results based on
#' at least two studies are printed which is identical to use argument
#' \code{subgroup = k.w > 1}. The order of the logical vector
#' corresponds to the order of subgroups in list element 'subgroup.levels' of a
#' meta-analysis object. Argument \code{subgroup = k.w >= 1} can be
#' used to show results for all subgroups (including those with a
#' single study).
#'
#' The following arguments can be used in a similar way:
#'
#' \itemize{
#' \item \code{subgroup.hetstat} (heterogeneity statistic in
#' subgroups),
#' \item \code{prediction.subgroup} (prediction interval in
#' subgroups),
#' \item \code{test.effect.subgroup} (test for effect in subgroups),
#' \item \code{test.effect.subgroup.common} (test for effect in
#' subgroups, common effect model),
#' \item \code{test.effect.subgroup.random} (test for effect in
#' subgroups, random effects model).
#' }
#' }
#'
#' \subsection{Additional general settings}{
#'
#' Arguments \code{text.common}, \code{text.random}, and
#' \code{text.predict} can be used to change the label to identify
#' overall results (common effect and random effects model as well as
#' prediction interval). By default the following text is printed:
#' \itemize{
#' \item "Common effect model" (argument \code{text.common})
#' \item "Random effects model" (\code{text.random})
#' \item "Prediction interval" (\code{text.predict})
#' }
#'
#' If confidence interval levels are different for individual studies,
#' meta-analysis, and prediction interval (arguments \code{level},
#' \code{level.ma}, \code{level.predict} in meta-analysis functions,
#' e.g., \code{\link{metabin}}), additional information is printed,
#' e.g., " (99\%-CI)" for a 99\% confidence interval in the
#' meta-analysis.
#'
#' 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.
#' }
#'
#' \subsection{Forest plots in RevMan5 layout}{
#'
#' If argument \code{layout = "RevMan5"} (and arguments \code{leftcols} and
#' \code{rightcols} are \code{NULL}), the layout for forest plots used for
#' Cochrane reviews (which are generated with Review Manager 5,
#' \url{https://training.cochrane.org/online-learning/core-software/revman})
#' is reproduced:
#' \enumerate{
#' \item All columns are printed on the left side of the forest plot
#' (see arguments \code{leftcols} and \code{rightcols})
#' \item Tests for overall effect and subgroup differences are printed
#' (\code{test.overall}, \code{test.effect.subgroup},
#' \code{test.subgroup})
#' \item Diamonds representing meta-analysis results are printed in
#' black (\code{diamond.common}, \code{diamond.random})
#' \item Colour of squares depends on the meta-analysis object
#' (\code{col.square}, \code{col.square.lines})
#' \item Information on effect measure and meta-analysis method is
#' printed above the forest plot (\code{smlab})
#' \item Label "Study or Subgroup" is printed for meta-analysis with
#' subgroups (\code{leftlabs})
#' }
#' }
#'
#' \subsection{Forest plots in JAMA layout}{
#'
#' If argument \code{layout = "JAMA"} (and arguments \code{leftcols} and
#' \code{rightcols} are \code{NULL}), instructions for authors of the
#' \emph{Journal of the American Medical Association}, see
#' \url{https://jamanetwork.com/journals/jama/pages/instructions-for-authors/},
#' are taken into account:
#' \enumerate{
#' \item Graph labels on right and left side are printed in bold font
#' at top of forest plot (see arguments \code{bottom.lr} and
#' \code{ff.lr})
#' \item Information on effect measure and level of confidence
#' interval is printed at bottom of forest plot (\code{xlab})
#' \item Tests for overall effect are printed (\code{test.overall})
#' \item Diamonds representing meta-analysis results are printed in
#' lightblue (\code{diamond.common}, \code{diamond.random})
#' \item Squares representing individual study results are printed in
#' darkblue (\code{col.square}, \code{col.square.lines})
#' \item Between-study variance \eqn{\tau^2} is not printed
#' \item Empty rows are omitted (\code{addrow}, \code{addrow.overall},
#' \code{addrow.subgroups})
#' \item Label "Source" is printed instead of "Study" (\code{leftlabs})
#' \item P-values are printed without leading zeros (\code{zero.pval})
#' \item P-values are rounded to three digits (for 0.001 < p \eqn{\le}
#' 0.01) or two digits (p > 0.01) (\code{JAMA.pval})
#' }
#' Study labels according to JAMA guidelines can be generated using
#' \code{\link{labels.meta}}.
#' }
#'
#' \subsection{Forest plots showing results of subgroups}{
#'
#' The following changes are conducted if argument
#' \code{layout = "subgroup"} (and arguments \code{leftcols} and
#' \code{rightcols} are \code{NULL}) and a subgroup analysis was
#' conducted:
#' \enumerate{
#' \item Individual study results are omitted (see argument
#' \code{study.results})
#' \item Total number of observations is not printed
#' (\code{pooled.totals})
#' \item Label "Subgroup" is printed instead of "Study"
#' (\code{leftlabs})
#' }
#' }
#'
#' @author Guido Schwarzer \email{guido.schwarzer@@uniklinik-freiburg.de}
#'
#' @seealso \code{\link{metabin}}, \code{\link{metacont}},
#' \code{\link{metagen}}, \code{\link{forest.metabind}},
#' \code{\link{settings.meta}}, \code{\link{labels.meta}}
#'
#' @references
#' Guddat C, Grouven U, Bender R, Skipka G (2012):
#' A note on the graphical presentation of prediction intervals in
#' random-effects meta-analyses.
#' \emph{Systematic Reviews},
#' \bold{1}, 34
#'
#' Higgins JPT, Thompson SG, Spiegelhalter DJ (2009):
#' A re-evaluation of random-effects meta-analysis.
#' \emph{Journal of the Royal Statistical Society: Series A},
#' \bold{172}, 137-59
#'
#' @keywords hplot
#'
#' @examples
#' data(Olkin1995)
#' m1 <- metabin(ev.exp, n.exp, ev.cont, n.cont,
#' data = Olkin1995, subset = c(41, 47, 51, 59),
#' sm = "RR", method = "I",
#' studlab = paste(author, year))
#'
#'
#' \dontrun{
#' # Do standard (symmetric) forest plot
#' #
#' forest(m1)
#' }
#'
#' # Layout of forest plot similar to Review Manager 5
#' #
#' # Furthermore, add labels on both sides of forest plot and
#' # prediction interval
#' #
#' forest(m1, layout = "RevMan5", common = FALSE,
#' label.right = "Favours control", col.label.right = "red",
#' label.left = "Favours experimental", col.label.left = "green",
#' prediction = TRUE)
#'
#'
#' \dontrun{
#' # Create a PDF file forest-m1.pdf with the forest plot
#' #
#' pdf("forest-m1.pdf", width = 10, height = 3)
#' forest(m1)
#' dev.off()
#'
#' # Define equivalence limits: 0.75 and 1 / 0.75
#' #
#' forest(m1, layout = "RevMan5", common = FALSE,
#' lower.equi = 0.75, upper.equi = 1 / 0.75, fill.equi = "lightgray")
#'
#' # Fill areas with beneficial and detrimental effects
#' #
#' forest(m1, layout = "RevMan5", common = FALSE,
#' lower.equi = 0.75, upper.equi = 1 / 0.75,
#' fill.lower.equi = c("green", "lightgray"),
#' fill.upper.equi = c("lightgray", "red"))
#'
#' # Define thresholds for small, moderate and large effects
#' # and use hcl.colors() to define colours to fill areas
#' #
#' thresholds <- c(0.25, 0.5, 0.75)
#' n.cols <- length(thresholds) + 1
#' forest(m1, layout = "RevMan5", common = FALSE,
#' label.right = "Undesirable effect",
#' label.left = "Desirable effect",
#' lty.equi = 3, col.equi = "darkgray",
#' lower.equi = thresholds, upper.equi = 1 / rev(thresholds),
#' fill.lower.equi =
#' hcl.colors(n.cols, palette = "Blues 2", alpha = 0.6),
#' fill.upper.equi =
#' hcl.colors(n.cols, palette = "Oranges", alpha = 0.6, rev = TRUE))
#'
#' # Conduct subgroup meta-analysis
#' #
#' m2 <- update(m1,
#' subgroup = ifelse(year < 1987, "Before 1987", "1987 and later"),
#' print.subgroup.name = FALSE)
#'
#' # Show summary results for subgroups with at least two studies
#' #
#' forest(m2, sortvar = -TE, random = FALSE)
#'
#' # Show results for all subgroups
#' #
#' forest(m2, sortvar = -TE, random = FALSE, subgroup = k.w >= 1)
#'
#' # Forest plot specifying argument xlim
#' #
#' forest(m1, xlim = c(0.01, 10))
#'
#' # Print results of test for overall effect
#' #
#' forest(m1, test.overall.common = TRUE, test.overall.random = TRUE)
#'
#' # Forest plot with 'classic' layout used in R package meta,
#' # version < 1.6-0
#' #
#' forest(m1, col.square = "black", hetstat = FALSE)
#'
#' # Change set of columns printed on left side of forest plot
#' # (resulting in overlapping text)
#' #
#' forest(m1, random = FALSE, leftcols = "studlab")
#'
#' # Use argument 'calcwidth.hetstat' to consider text for heterogeneity
#' # measures in width of column with study labels
#' #
#' forest(m1, random = FALSE, leftcols = "studlab",
#' calcwidth.hetstat = TRUE)
#'
#' # Use argument 'addrows.below.overall' to manually add two empty
#' # rows
#' #
#' forest(m1, random = FALSE, leftcols = "studlab", addrows = 2)
#'
#' # Do not print columns on right side of forest plot
#' #
#' forest(m1, rightcols = FALSE)
#'
#' # Change study label to "Author"
#' #
#' forest(m1, random = FALSE, leftlabs = c("Author", NA, NA, NA, NA))
#'
#' # Just give effect estimate and 95% confidence interval on right
#' # side of forest plot (in one column)
#' #
#' forest(m1, rightcols = c("effect.ci"))
#'
#' # Just give effect estimate and 95% confidence interval on right
#' # side of forest plot
#' #
#' forest(m1, rightcols = c("effect", "ci"))
#'
#' # 1. Change order of columns on left side
#' # 2. Attach labels to columns 'event.e' and 'event.c' instead of
#' # columns 'n.e' and 'n.c'
#' #
#' forest(m1,
#' leftcols = c("studlab", "n.e", "event.e", "n.c", "event.c"),
#' label.e.attach = "event.e", label.c.attach = "event.c")
#'
#' # Specify column labels only for variables 'year' and 'author'
#' # (and define digits for additional variables)
#' #
#' forest(m1,
#' leftcols = c("studlab", "event.e", "n.e", "event.c", "n.c", "author", "year"),
#' leftlabs = c("Author", "Year of Publ"))
#'
#' # Center text in all columns
#' #
#' forest(m1,
#' leftcols = c("studlab", "event.e", "n.e", "event.c", "n.c",
#' "author", "year"),
#' leftlabs = c("Author", "Year of Publ"), hetstat = FALSE,
#' just = "center", just.addcols = "center", just.studlab = "center")
#'
#' # Same result
#' #
#' forest(m1,
#' leftcols = c("studlab", "event.e", "n.e", "event.c", "n.c",
#' "author", "year"),
#' leftlabs = c("Author", "Year of Publ"), hetstat = FALSE,
#' just = "c", just.addcols = "c", just.studlab = "c")
#'
#' # Change some fontsizes and fontfaces
#' #
#' forest(m1,
#' fs.study = 10, ff.study = "italic",
#' fs.study.label = 11, ff.study.label = "bold",
#' fs.axis = 5, ff.axis = "italic",
#' ff.smlab = "bold.italic",
#' ff.common = "plain", ff.hetstat = "plain")
#'
#' # Change some colours
#' #
#' forest(m1,
#' col.diamond = "green", col.diamond.lines = "red",
#' col.study = c("green", "blue", "red", "orange"),
#' col.square = "pink", col.square.lines = "black")
#'
#' # Sort by weight in common effect model
#' #
#' forest(m1, sortvar = w.common, random = FALSE)
#'
#' # Sort by decreasing weight in common effect model
#' #
#' forest(m1, sortvar = -w.common, random = FALSE)
#'
#' # Sort by size of treatment effect
#' #
#' forest(m1, sortvar = TE, random = FALSE)
#'
#' # Sort by size of treatment effect
#' #
#' forest(m1, sortvar = -TE, random = FALSE)
#'
#' # Sort by decreasing year of publication
#' #
#' forest(m1, sortvar = -year, random = FALSE)
#'
#' # Print results of test for subgroup differences (random effects
#' # model)
#' #
#' forest(m2, sortvar = -TE, common = FALSE)
#'
#' # Print only subgroup results
#' #
#' forest(m2, layout = "subgroup")
#'
#' # Print only subgroup results (and consider text for tests of
#' # subgroup differences in width of subgroup column)
#' #
#' forest(m2, layout = "subgroup", calcwidth.tests = TRUE)
#'
#' # Print only subgroup results (and consider text for heterogeneity
#' # in width of subgroup column)
#' #
#' forest(m2, layout = "subgroup", calcwidth.hetstat = TRUE)
#' }
#'
#' @method forest meta
#' @export
#' @export forest.meta
forest.meta <- function(x,
sortvar,
studlab = TRUE,
##
layout = gs("layout"),
##
common = x$common,
random = x$random,
overall = x$overall,
text.common = x$text.common,
text.random = x$text.random,
lty.common = gs("lty.common"),
lty.random = gs("lty.random"),
col.common = gs("col.common"),
col.random = gs("col.random"),
text.w.common = x$text.w.common,
text.w.random = x$text.w.random,
##
prediction = x$prediction,
text.predict = x$text.predict,
##
subgroup = TRUE,
subgroup.hetstat =
subgroup & (is.character(hetstat) || hetstat),
print.subgroup.labels = TRUE,
##
subgroup.name = x$subgroup.name,
print.subgroup.name = x$print.subgroup.name,
sep.subgroup = x$sep.subgroup,
text.common.w = text.common,
text.random.w = text.random,
text.predict.w = text.predict,
sort.subgroup = gs("sort.subgroup"),
##
pooled.totals = common | random,
pooled.events = gs("pooled.events"),
pooled.times = gs("pooled.times"),
##
study.results = gs("study.results"),
##
xlab = "", xlab.pos,
smlab = NULL, smlab.pos, xlim = "symmetric",
##
allstudies = TRUE,
weight.study = NULL,
pscale = x$pscale,
irscale = x$irscale, irunit = x$irunit,
##
ref,
##
lower.equi = gs("lower.equi"),
upper.equi = gs("upper.equi"),
lty.equi = gs("lty.equi"),
col.equi = gs("col.equi"),
fill.equi = gs("fill.equi"),
fill.lower.equi = fill.equi,
fill.upper.equi = rev(fill.equi),
##
leftcols = NULL, rightcols = NULL,
leftlabs = NULL, rightlabs = NULL,
##
label.e = x$label.e,
label.c = x$label.c,
##
label.e.attach = NULL,
label.c.attach = NULL,
##
label.right = x$label.right,
label.left = x$label.left,
bottom.lr = gs("bottom.lr"),
##
lab.NA = gs("lab.NA"),
lab.NA.effect = gs("lab.NA.effect"),
lab.NA.weight = gs("lab.NA.weight"),
##
lwd = gs("lwd"),
##
at = NULL,
label = TRUE,
##
type.study = gs("type.study"),
type.common = gs("type.common"),
type.random = type.common,
type.subgroup =
ifelse(study.results, "diamond", "square"),
type.subgroup.common = type.subgroup,
type.subgroup.random = type.subgroup,
##
col.study = gs("col.study"),
col.square = gs("col.square"),
col.square.lines = col.square,
##
col.inside = gs("col.inside"),
col.inside.common = col.inside,
col.inside.random = col.inside,
##
col.diamond = gs("col.diamond"),
col.diamond.common = col.diamond,
col.diamond.random = col.diamond,
col.diamond.lines = gs("col.diamond.lines"),
col.diamond.lines.common = col.diamond.lines,
col.diamond.lines.random = col.diamond.lines,
##
col.predict = gs("col.predict"),
col.predict.lines = gs("col.predict.lines"),
##
col.subgroup = gs("col.subgroup"),
##
col.label.right = gs("col.label.right"),
col.label.left = gs("col.label.left"),
##
hetstat = common | random | overall.hetstat,
overall.hetstat = x$overall.hetstat,
hetlab = gs("hetlab"),
resid.hetstat = gs("resid.hetstat"),
resid.hetlab = gs("resid.hetlab"),
##
print.I2 = gs("forest.I2"),
print.I2.ci = gs("forest.I2.ci"),
print.tau2 = gs("forest.tau2"),
print.tau2.ci = gs("forest.tau2.ci"),
print.tau = gs("forest.tau"),
print.tau.ci = gs("forest.tau.ci"),
print.Q = gs("forest.Q"),
print.pval.Q = gs("forest.pval.Q"),
print.Rb = gs("forest.Rb"),
print.Rb.ci = gs("forest.Rb.ci"),
text.subgroup.nohet = gs("text.subgroup.nohet"),
##
LRT = gs("LRT"),
##
test.overall = gs("test.overall"),
test.overall.common = common & overall & test.overall,
test.overall.random =
random & overall & test.overall,
label.test.overall.common,
label.test.overall.random,
##
print.stat = gs("forest.stat"),
##
test.subgroup = x$test.subgroup,
test.subgroup.common = test.subgroup & common,
test.subgroup.random = test.subgroup & random,
prediction.subgroup = x$prediction.subgroup,
print.Q.subgroup = gs("forest.Q.subgroup"),
label.test.subgroup.common,
label.test.subgroup.random,
##
test.effect.subgroup = gs("test.effect.subgroup"),
test.effect.subgroup.common,
test.effect.subgroup.random,
label.test.effect.subgroup.common,
label.test.effect.subgroup.random,
##
text.addline1,
text.addline2,
##
header.line,
##
fontsize = gs("fontsize"),
fontfamily = gs("fontfamily"),
fs.heading = fontsize,
fs.common = gs("fs.common"),
fs.random = gs("fs.random"),
fs.predict = gs("fs.predict"),
fs.common.labels = gs("fs.common.labels"),
fs.random.labels = gs("fs.random.labels"),
fs.predict.labels = gs("fs.predict.labels"),
fs.study = fontsize,
fs.study.labels = fs.study,
fs.hetstat = gs("fs.hetstat"),
fs.test.overall = gs("fs.test.overall"),
fs.test.subgroup = gs("fs.test.subgroup"),
fs.test.effect.subgroup = gs("fs.test.effect.subgroup"),
fs.addline = gs("fs.addline"),
fs.axis = fontsize,
fs.smlab = fontsize,
fs.xlab = fontsize,
fs.lr = fontsize,
##
ff.heading = "bold",
ff.common = gs("ff.common"),
ff.random = gs("ff.random"),
ff.predict = gs("ff.predict"),
ff.common.labels = gs("ff.common.labels"),
ff.random.labels = gs("ff.random.labels"),
ff.predict.labels = gs("ff.predict.labels"),
ff.study = "plain",
ff.study.labels = ff.study,
ff.hetstat = gs("ff.hetstat"),
ff.test.overall = gs("ff.test.overall"),
ff.test.subgroup = gs("ff.test.subgroup"),
ff.test.effect.subgroup = gs("ff.test.effect.subgroup"),
ff.addline = gs("ff.addline"),
ff.axis = gs("ff.axis"),
ff.smlab = gs("ff.smlab"),
ff.xlab = gs("ff.xlab"),
ff.lr = gs("ff.lr"),
##
squaresize = 0.8 / spacing,
##
plotwidth = if (layout == "JAMA") "8cm" else "6cm",
colgap = gs("colgap"),
colgap.left = colgap,
colgap.right = colgap,
colgap.studlab = colgap.left,
colgap.forest = colgap,
colgap.forest.left = colgap.forest,
colgap.forest.right = colgap.forest,
##
calcwidth.pooled =
(common | random) &
(overall | !is.null(x$subgroup)),
calcwidth.common = calcwidth.pooled,
calcwidth.random = calcwidth.pooled,
calcwidth.predict = gs("calcwidth.predict"),
calcwidth.hetstat = gs("calcwidth.hetstat"),
calcwidth.tests = gs("calcwidth.tests"),
calcwidth.subgroup = gs("calcwidth.subgroup"),
calcwidth.addline = gs("calcwidth.addline"),
##
just = if (layout == "JAMA") "left" else "right",
just.studlab = gs("just.studlab"),
just.addcols = gs("just.addcols"),
just.addcols.left = just.addcols,
just.addcols.right = just.addcols,
##
spacing = gs("spacing"),
addrow = gs("addrow"),
addrow.overall = gs("addrow.overall"),
addrow.subgroups = gs("addrow.subgroups"),
addrows.below.overall = gs("addrows.below.overall"),
##
new = TRUE,
##
backtransf = x$backtransf,
digits = gs("digits.forest"),
digits.se = gs("digits.se"),
digits.stat = gs("digits.stat"),
digits.pval = max(gs("digits.pval") - 2, 2),
digits.pval.Q = max(gs("digits.pval.Q") - 2, 2),
digits.Q = gs("digits.Q"),
digits.tau2 = gs("digits.tau2"),
digits.tau = gs("digits.tau"),
digits.I2 = max(gs("digits.I2") - 1, 0),
digits.weight = gs("digits.weight"),
##
digits.mean = digits,
digits.sd = digits.se,
digits.cor = digits,
digits.time = digits,
##
digits.TE = gs("digits.TE.forest"),
##
digits.addcols = digits,
digits.addcols.right = digits.addcols,
digits.addcols.left = digits.addcols,
##
scientific.pval = gs("scientific.pval"),
big.mark = gs("big.mark"),
zero.pval =
if (layout == "JAMA") FALSE else gs("zero.pval"),
JAMA.pval =
if (layout == "JAMA") TRUE else gs("JAMA.pval"),
##
warn.deprecated = gs("warn.deprecated"),
...) {
##
##
## (1) Check for meta object and upgrade older meta objects
##
##
chkclass(x, "meta")
x.name <- deparse(substitute(x))
x <- updateversion(x)
##
K.all <- length(x$TE)
##
sm <- x$sm
##
metabin <- inherits(x, "metabin")
metacont <- inherits(x, "metacont")
metacor <- inherits(x, "metacor")
metagen <- inherits(x, "metagen")
metainc <- inherits(x, "metainc")
metamean <- inherits(x, "metamean")
metaprop <- inherits(x, "metaprop")
metarate <- inherits(x, "metarate")
metabind <- inherits(x, "is.metabind")
##
metainf.metacum <- inherits(x, "metainf") | inherits(x, "metacum")
##
meta <- !metabind &&
(metabin | metacont | metacor | metagen | metainc | metamean |
metaprop | metarate | metainf.metacum)
##
ftr <- x$func.transf
atr <- x$args.transf
fbt <- x$func.backtransf
abt <- x$args.backtransf
##
##
## (2) Extract data on subgroup analysis
##
##
by <- !is.null(x$subgroup)
##
if (by) {
n.by <- length(x$subgroup.levels)
##
TE.common.w <- collapsemat(x$TE.common.w)
statistic.common.w <- collapsemat(x$statistic.common.w)
pval.common.w <- collapsemat(x$pval.common.w)
lower.common.w <- collapsemat(x$lower.common.w)
upper.common.w <- collapsemat(x$upper.common.w)
##
if (!is.matrix(x$TE.random.w) & is.matrix(x$seTE.random.w)) {
TE.random.w <-
collapsemat(matrix(x$TE.random.w,
nrow = nrow(x$seTE.random.w),
ncol = ncol(x$seTE.random.w),
dimnames = list(rownames(x$seTE.random.w),
colnames(x$seTE.random.w))))
}
else
TE.random.w <- collapsemat(x$TE.random.w)
##
lower.random.w <- collapsemat(x$lower.random.w)
upper.random.w <- collapsemat(x$upper.random.w)
statistic.random.w <- collapsemat(x$statistic.random.w)
pval.random.w <- collapsemat(x$pval.random.w)
##
lower.predict.w <- collapsemat(x$lower.predict.w)
upper.predict.w <- collapsemat(x$upper.predict.w)
}
else
n.by <- 0
##
##
## (3) Determine columns on left and right side of forest plot
##
##
missing.leftcols <- missing(leftcols)
missing.rightcols <- missing(rightcols)
##
layout <- setchar(layout, c("meta", "RevMan5", "JAMA", "subgroup"))
if (layout == "subgroup" & is.null(x$subgroup)) {
warning("Argument 'layout' set to \"meta\" (default) as ",
"no subgroup analysis was conducted.")
layout <- "meta"
}
missing.type.subgroup.common <- missing(type.subgroup.common)
if (layout == "subgroup") {
if (missing(type.subgroup))
type.subgroup <- "square"
if (missing.type.subgroup.common)
type.subgroup.common <- "square"
if (missing(type.subgroup.random))
type.subgroup.random <- "square"
##
if (missing(pooled.totals))
pooled.totals <- FALSE
}
revman5 <- layout == "RevMan5"
jama <- layout == "JAMA"
revman5.jama <- revman5 | jama
##
lsel <- TRUE
if (is.logical(leftcols)) {
if (!leftcols)
lsel <- FALSE
##
leftcols <- NULL
}
##
rsel <- !(is.logical(rightcols) && length(rightcols) == 1 && !rightcols)
if (revman5.jama)
rsel <- FALSE
##
if (!rsel)
rightcols <- NULL
##
## Check for duplicate columns
##
if (length(c(rightcols, leftcols)) > 0 &&
any(duplicated(c(rightcols, leftcols))))
stop("Duplicate entries in 'leftcols' and 'rightcols'.")
##
colnames <- c("studlab",
"TE", "seTE",
"cluster",
"n.e", "n.c",
"event.e", "event.c",
"mean.e", "mean.c",
"sd.e", "sd.c",
"cor",
"time.e", "time.c",
"effect", "ci",
"effect.ci",
"w.fixed", "w.common", "w.random",
"pval")
##
if (metainf.metacum)
colnames <- c(colnames, "tau2", "tau", "I2")
##
## If any of the following list elements is NULL, these 'special'
## variable names are searched for in original data set (i.e., list
## element x$data)
##
colnames.notNULL <- colnames
colnames.notNULL <- removeNULL(x, colnames.notNULL, "cluster")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "n.e")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "n.c")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "event.e")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "event.c")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "mean.e")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "mean.c")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "sd.e")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "sd.c")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "cor")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "time.e")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "time.c")
##
## Identify and process columns in addition to columns
## defined above in variable 'colnames'
##
colnames.new <-
c(leftcols, rightcols)[!c(leftcols, rightcols) %in% colnames.notNULL]
##
newcols <- length(colnames.new) > 0
##
withstudlab <-
(lsel & missing(leftcols)) |
(lsel & !missing(leftcols) & "studlab" %in% leftcols) |
(rsel & !missing(rightcols) & "studlab" %in% rightcols)
##
if (!withstudlab || newcols) {
dataset2 <- as.data.frame(x)
##
if (!is.null(x$data))
dataset1 <- x$data
else if (!is.null(x$x$data))
dataset1 <- x$x$data
else
dataset1 <- dataset2
##
if (!is.null(x$subset))
dataset1 <- dataset1[x$subset, ]
##
if (!withstudlab && newcols) {
##
## Check whether first additional variable is part of
## meta-object
##
firstvar <- colnames.new[1]
colnames.new <- colnames.new[-1]
newcols <- length(colnames.new) > 0
##
if (length(dataset1[[firstvar]]) == 0 &
length(dataset2[[firstvar]]) == 0)
stop("Variable '", firstvar, "' not available in '",
x.name, "'.",
call. = FALSE)
else {
if (length(dataset1[[firstvar]]) != 0)
studlab.new <- dataset1[[firstvar]]
else if (length(dataset2[[firstvar]]) != 0)
studlab.new <- dataset2[[firstvar]]
##
if (metainf.metacum)
studlab.new <- c(studlab.new, "", rev(x$studlab)[1])
##
if (length(x$studlab) != length(studlab.new))
stop("Variable '", firstvar, "' has different length ",
"than list element '", x.name, "' with study labels.",
call. = FALSE)
##
x$studlab <- studlab.new
switch.l <- leftcols == firstvar
switch.r <- rightcols == firstvar
if (any(switch.l))
leftcols[switch.l] <- "studlab"
if (any(switch.r))
rightcols[switch.r] <- "studlab"
##
}
}
}
##
if (newcols) {
##
## Determine labels for new columns
## 1. Use column name as label if no label is given
## 2. Otherwise use specified labels
##
rightcols.new <- rightcols[!rightcols %in% colnames.notNULL]
leftcols.new <- leftcols[!leftcols %in% colnames.notNULL]
}
##
##
## (3) Check other arguments
##
##
sfsp <- sys.frame(sys.parent())
mc <- match.call()
##
error <-
try(sortvar <- catch("sortvar", mc, x, sfsp),
silent = TRUE)
if (inherits(error, "try-error")) {
sortvar <- catch("sortvar", mc, x$data, sfsp)
if (isCol(x$data, ".subset"))
sortvar <- sortvar[x$data$.subset]
}
##
if (!is.null(sortvar) & metainf.metacum)
warning("Argument 'sortvar' ignored for objects ",
"created with metacum() or metainf().")
sort <- !is.null(sortvar) & !metainf.metacum
if (sort && (length(sortvar) != K.all))
stop("Number of studies in object 'x' and argument 'sortvar' ",
"have different length.")
if (!sort)
sortvar <- 1:K.all
##
missing.subgroup <- missing(subgroup)
missing.subgroup.hetstat <- missing(subgroup.hetstat)
missing.prediction.subgroup <- missing(prediction.subgroup)
##
if (!by) {
if (!missing.subgroup)
warning("Argument 'subgroup' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
if (!missing.subgroup.hetstat)
warning("Argument 'subgroup.hetstat' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
if (!missing.prediction.subgroup)
warning("Argument 'prediction.subgroup' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
if (!missing(test.effect.subgroup))
warning("Argument 'test.effect.subgroup' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
if (!missing(test.effect.subgroup.common))
warning("Argument 'test.effect.subgroup.common' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
if (!missing(test.effect.subgroup.random))
warning("Argument 'test.effect.subgroup.random' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
}
##
missing.studlab <- missing(studlab)
if (!missing.studlab) {
error <-
try(studlab <- catch("studlab", mc, x, sfsp),
silent = TRUE)
if (inherits(error, "try-error")) {
studlab <- catch("studlab", mc, x$data, NULL)
if (isCol(x$data, ".subset"))
studlab <- studlab[x$data$.subset]
}
}
##
slab <- TRUE
if (length(studlab) == 1 & is.logical(studlab)) {
if (studlab == FALSE) {
studlab <- rep("", K.all)
slab <- FALSE
}
else studlab <- x$studlab
}
##
if (missing.studlab && K.all == 1 && studlab == "")
studlab <- "1"
##
if (length(studlab) != (K.all - 2 * (metainf.metacum & !missing.studlab)))
stop("Number of studies in object 'x' and argument 'studlab' have ",
"different length.")
##
## Additional arguments in '...'
##
args <- list(...)
## Check whether first argument is a list. In this case only use
## this list as input.
if (length(args) > 0 && is.list(args[[1]]))
args <- args[[1]]
##
common <- deprecated(common, missing(common), args, "fixed",
warn.deprecated)
chklogical(common)
chklogical(random)
overall <- replaceNULL(overall, common | random)
chklogical(overall)
##
lty.common <- deprecated(lty.common, missing(lty.common), args, "lty.fixed",
warn.deprecated)
if (!is.null(lty.common))
chknumeric(lty.common, length = 1)
if (!is.null(lty.random))
chknumeric(lty.random, length = 1)
col.common <- deprecated(col.common, missing(col.common), args, "col.fixed",
warn.deprecated)
chkcolor(col.common, length = 1)
chkcolor(col.random, length = 1)
chklogical(prediction)
##
chklogical(print.subgroup.labels)
if (!is.null(print.subgroup.name))
chklogical(print.subgroup.name)
if (!is.null(sep.subgroup))
chkchar(sep.subgroup)
##
sort.subgroup <- deprecated(sort.subgroup, missing(sort.subgroup),
args, "bysort", warn.deprecated)
chklogical(sort.subgroup)
##
chklogical(pooled.totals)
chklogical(pooled.events)
chklogical(pooled.times)
chklogical(study.results)
## chknumeric(xlab.pos) ??
## chknumeric(smlab.pos) ??
chklogical(allstudies)
##
chklogical(backtransf)
##
if (!is.null(pscale))
chknumeric(pscale, length = 1)
else
pscale <- 1
if (!is.null(irscale))
chknumeric(irscale, length = 1)
else
irscale <- 1
if (!is.null(irunit) && !is.na(irunit))
chkchar(irunit)
##
missing.ref <- missing(ref)
## Use logarithmic x-axis?
## (for back-transformed relative effect measures)
log.xaxis <-
backtransf & (is_relative_effect(sm) | (!is.null(fbt) && fbt == "exp"))
##
if (missing.ref) {
if (is_prop(sm) | is_rate(sm) | is_mean(sm))
ref <- NA
else if (log.xaxis)
ref <- 1
else
ref <- 0
##
}
else
chknumeric(ref, length = 1)
##
chknumeric(lower.equi)
chknumeric(upper.equi)
##
if (all(is.na(lower.equi)))
max.lower.equi <- NA
else {
max.lower.equi <- max(lower.equi, na.rm = TRUE)
##
if (!is.na(ref) && any(lower.equi[!is.na(lower.equi)] > ref))
stop("All values provided for argument 'lower.equi' must be ",
"smaller than reference value of ", ref, ".",
call. = FALSE)
}
##
if (all(is.na(upper.equi)))
min.upper.equi <- NA
else {
min.upper.equi <- min(upper.equi, na.rm = TRUE)
##
if (!is.na(ref) && any(upper.equi[!is.na(upper.equi)] < ref))
stop("All values provided for argument 'upper.equi' must be ",
"larger than reference value of ", ref, ".",
call. = FALSE)
}
##
if (!is.na(max.lower.equi) && !is.na(min.upper.equi) &&
max.lower.equi > min.upper.equi)
stop("Value", if (length(lower.equi) > 1) "s " else " ",
"of 'lower.equi' must be smaller than 'upper.equi'.",
call. = FALSE)
##
if (any(lower.equi != sort(lower.equi), na.rm = TRUE))
stop("Values of 'lower.equi' must be increasing.",
call. = FALSE)
##
if (any(upper.equi != sort(upper.equi), na.rm = TRUE))
stop("Values of 'upper.equi' must be increasing.",
call. = FALSE)
##
if (!is.na(max.lower.equi))
if (length(fill.lower.equi) == 1 & sum(!is.na(lower.equi)) > 1)
fill.lower.equi <- rep(fill.lower.equi, sum(!is.na(lower.equi)))
else if (all(length(fill.lower.equi) != sum(!is.na(lower.equi)) + 0:1))
stop("Number of fill colours must be equal to the number of values ",
"for 'lower.equi' or +1.",
call. = FALSE)
##
if (!is.na(min.upper.equi))
if (length(fill.upper.equi) == 1 & sum(!is.na(upper.equi)) > 1)
fill.upper.equi <- rep(fill.upper.equi, sum(!is.na(upper.equi)))
else if (all(length(fill.upper.equi) != sum(!is.na(upper.equi)) + 0:1))
stop("Number of fill colours must be equal to the number of values ",
"for 'upper.equi' or +1.",
call. = FALSE)
##
chknumeric(lty.equi)
chkcolor(col.equi)
##
type.study <- setchar(type.study, c("square", "diamond", "predict"))
type.common <- setchar(type.common, c("square", "diamond", "predict"))
type.random <- setchar(type.random, c("square", "diamond", "predict"))
type.subgroup <- setchar(type.subgroup, c("square", "diamond", "predict"))
type.subgroup.common <- setchar(type.subgroup.common,
c("square", "diamond", "predict"))
type.subgroup.random <- setchar(type.subgroup.random,
c("square", "diamond", "predict"))
##
chklogical(bottom.lr)
chkchar(lab.NA)
if (is.null(lab.NA.effect))
if (metainf.metacum)
lab.NA.effect <- lab.NA
else
lab.NA.effect <- ""
chkchar(lab.NA.effect)
chkchar(lab.NA.weight)
if (!is.null(at))
chknumeric(at)
chkcolor(col.diamond)
chkcolor(col.diamond.random)
chkcolor(col.predict)
chkcolor(col.predict.lines)
##
col.subgroup <- deprecated(col.subgroup, missing(col.subgroup), args,
"col.by", warn.deprecated)
##
missing.hetstat <- missing(hetstat)
missing.overall.hetstat <- missing(overall.hetstat)
##
overall.hetstat <- replaceNULL(overall.hetstat, TRUE)
chklogical(overall.hetstat)
##
if (is.null(print.I2))
if (is.character(hetstat) || hetstat || overall.hetstat)
print.I2 <- TRUE
else
print.I2 <- FALSE
else
chklogical(print.I2)
##
chklogical(print.I2.ci)
##
if (is.null(print.tau2))
if (is.character(hetstat) || hetstat || overall.hetstat)
print.tau2 <- TRUE
else
print.tau2 <- FALSE
else
chklogical(print.tau2)
##
chklogical(print.tau2.ci)
chklogical(print.tau)
chklogical(print.tau.ci)
print.tau2.tau <- print.tau2 | print.tau
if (print.tau2 & print.tau)
print.tau2 <- FALSE
if (print.tau2.ci & print.tau.ci)
print.tau2.ci <- FALSE
##
chklogical(print.Q)
##
if (is.null(print.pval.Q))
if (is.character(hetstat) || hetstat || overall.hetstat)
print.pval.Q <- TRUE
else
print.pval.Q <- FALSE
else
chklogical(print.pval.Q)
##
chklogical(print.Rb)
chklogical(print.Rb.ci)
if (!is.logical(text.subgroup.nohet))
chkchar(text.subgroup.nohet)
else if (text.subgroup.nohet)
text.subgroup.nohet <- "not applicable"
##
hetstat.pooled <- ""
if (is.character(hetstat)) {
hetstat <- setchar(hetstat, c("common", "random", "study", "fixed"))
hetstat[hetstat == "fixed"] <- "common"
hetstat.pooled <- hetstat
if (!metabind & hetstat.pooled == "study") {
warning("Argument 'hetstat = \"study\"' ",
"only considered for 'metabind' objects.")
hetstat <- print.I2 | print.tau2.tau | print.Q | print.pval.Q | print.Rb
}
}
else
chklogical(hetstat)
##
if (hetstat.pooled == "common") {
common <- TRUE
overall <- TRUE
}
if (hetstat.pooled == "random") {
if (length(x$TE.random) == 1) {
random <- TRUE
overall <- TRUE
}
else
hetstat.pooled <- ""
}
##
if (missing.overall.hetstat) {
if (!missing.hetstat)
if (is.character(hetstat))
overall.hetstat <- FALSE
else
overall.hetstat <- hetstat
}
else
chklogical(overall.hetstat)
##
chklogical(LRT)
if (LRT & all(x$method != "GLMM")) {
warning("Likelihood-Ratio test of heterogeneity only ",
"available for generalized linear mixed models.")
LRT <- FALSE
}
##
chkchar(hetlab)
if (!is.null(resid.hetstat))
chklogical(resid.hetstat)
else {
if (overall && (is.character(hetstat) || hetstat) && !LRT &&
!is.null(x$tau.common) && x$tau.common)
resid.hetstat <- TRUE
else
resid.hetstat <- FALSE
}
chkchar(resid.hetlab)
##
test.overall.common <-
deprecated(test.overall.common, missing(test.overall.common),
args, "test.overall.fixed",
warn.deprecated)
chklogical(test.overall.common)
chklogical(test.overall.random)
##
test.subgroup <- replaceNULL(test.subgroup, TRUE)
chklogical(test.subgroup)
test.subgroup.common <-
deprecated(test.subgroup.common, missing(test.subgroup.common),
args, "test.subgroup.fixed",
warn.deprecated)
chklogical(test.subgroup.common)
chklogical(test.subgroup.random)
##
chklogical(print.Q.subgroup)
##
if (missing(header.line)) {
if (is.character(gs("header.line")))
header.line <- gs("header.line")
else
header.line <- gs("header.line") |
(layout %in% c("JAMA", "RevMan5"))
}
##
if (is.character(header.line)) {
header.line.pos <- setchar(header.line, c("below", "both", ""))
header.line <- header.line.pos != ""
}
else {
chklogical(header.line)
if (header.line)
header.line.pos <- "below"
else
header.line.pos <- ""
}
##
chknumeric(fontsize, length = 1)
chknumeric(fs.heading, length = 1)
##
missing.fs.common <- missing(fs.common)
missing.fs.fixed <- is.na(argid(names(args), "fs.fixed"))
if (!missing.fs.fixed) {
fs.common <-
deprecated(fs.common, missing.fs.common, args, "fs.fixed",
warn.deprecated)
missing.fs.common <- FALSE
}
if (!missing.fs.common)
chknumeric(fs.common, length = 1)
##
if (!is.null(fs.random))
chknumeric(fs.random, length = 1)
if (!is.null(fs.predict))
chknumeric(fs.predict, length = 1)
##
missing.fs.common.labels <- missing(fs.common.labels)
missing.fs.fixed.labels <- is.na(argid(names(args), "fs.fixed.labels"))
if (!missing.fs.fixed.labels) {
fs.common.labels <-
deprecated(fs.common.labels, missing.fs.common.labels,
args, "fs.fixed.labels",
warn.deprecated)
missing.fs.common.labels <- FALSE
}
if (!missing.fs.common.labels)
chknumeric(fs.common.labels, length = 1)
##
if (!is.null(fs.random.labels))
chknumeric(fs.random.labels, length = 1)
if (!is.null(fs.predict.labels))
chknumeric(fs.predict.labels, length = 1)
if (!is.null(fs.study))
chknumeric(fs.study, length = 1)
if (!is.null(fs.study.labels))
chknumeric(fs.study.labels, length = 1)
if (!is.null(fs.hetstat))
chknumeric(fs.hetstat, length = 1)
if (!is.null(fs.test.overall))
chknumeric(fs.test.overall, length = 1)
if (!is.null(fs.test.subgroup))
chknumeric(fs.test.subgroup, length = 1)
if (!is.null(fs.test.effect.subgroup))
chknumeric(fs.test.effect.subgroup, length = 1)
if (!is.null(fs.addline))
chknumeric(fs.addline, length = 1)
chknumeric(fs.axis, length = 1)
chknumeric(fs.smlab, length = 1)
chknumeric(fs.xlab, length = 1)
chknumeric(fs.lr, length = 1)
##
missing.ff.common <- missing(ff.common)
missing.ff.fixed <- is.na(argid(names(args), "ff.fixed"))
if (!missing.ff.fixed) {
ff.common <-
deprecated(ff.common, missing.ff.common, args, "ff.fixed",
warn.deprecated)
missing.ff.common <- FALSE
}
##
missing.ff.common.labels <- missing(ff.common.labels)
missing.ff.fixed.labels <- is.na(argid(names(args), "ff.fixed.labels"))
if (!missing.ff.fixed.labels) {
ff.common.labels <-
deprecated(ff.common.labels, missing.ff.common.labels,
args, "ff.fixed.labels",
warn.deprecated)
missing.ff.common.labels <- FALSE
}
##
chknumeric(squaresize, length = 1)
chklogical(calcwidth.pooled)
calcwidth.common <-
deprecated(calcwidth.common, missing(calcwidth.common),
args, "calcwidth.fixed",
warn.deprecated)
chklogical(calcwidth.common)
chklogical(calcwidth.random)
chklogical(calcwidth.predict)
chklogical(calcwidth.hetstat)
chklogical(calcwidth.tests)
chklogical(calcwidth.subgroup)
chklogical(calcwidth.addline)
just.cols <- setchar(just, c("right", "center", "left"))
just.studlab <- setchar(just.studlab, c("right", "center", "left"))
just.addcols <- setchar(just.addcols, c("right", "center", "left"))
just.addcols.left <- setchar(just.addcols.left, c("right", "center", "left"))
just.addcols.right <-
setchar(just.addcols.right, c("right", "center", "left"))
##
chknumeric(spacing, length = 1)
##
missing.text.addline1 <- missing(text.addline1)
if (!missing.text.addline1) {
chkchar(text.addline1)
if (text.addline1 == "")
missing.text.addline1 <- TRUE
}
else
text.addline1 <- ""
missing.text.addline2 <- missing(text.addline2)
if (!missing.text.addline2) {
chkchar(text.addline2)
if (text.addline2 == "")
missing.text.addline2 <- TRUE
}
else
text.addline2 <- ""
##
## Check and set additional empty rows in forest plot
##
if (!is.null(addrow))
chklogical(addrow)
else
addrow <- !jama
if (!is.null(addrow.overall)) {
chklogical(addrow.overall)
if (!(overall & (common | random | prediction)))
addrow.overall <- FALSE
}
else
addrow.overall <- !jama & overall & (common | random | prediction)
if (!is.null(addrow.subgroups))
chklogical(addrow.subgroups)
else
addrow.subgroups <- !jama
##
chknumeric(digits, min = 0, length = 1)
chknumeric(digits.tau2, 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.I2, min = 0, length = 1)
chknumeric(digits.se, min = 0, length = 1)
if (!missing(digits.mean))
chknumeric(digits.mean, min = 0, length = 1)
if (!missing(digits.sd))
chknumeric(digits.sd, min = 0, length = 1)
if (!missing(digits.cor))
chknumeric(digits.cor, min = 0, length = 1)
missing.digits.time <- missing(digits.time)
if (!missing.digits.time)
chknumeric(digits.time, min = 0, length = 1)
missing.digits.TE <- missing(digits.TE)
if (!missing.digits.TE)
chknumeric(digits.TE, min = 0, length = 1)
missing.addcols.left <-
missing(digits.addcols) & missing(digits.addcols.left)
missing.addcols.right <-
missing(digits.addcols) & missing(digits.addcols.right)
if (!missing(digits.addcols))
chknumeric(digits.addcols, min = 0)
if (!missing(digits.addcols.right))
chknumeric(digits.addcols.right, min = 0)
if (!missing(digits.addcols.left))
chknumeric(digits.addcols.left, min = 0)
chklogical(scientific.pval)
chklogical(zero.pval)
chklogical(JAMA.pval)
##
## Check for deprecated arguments in '...'
##
weight.study <-
deprecated(weight.study, missing(weight.study), args, "weight",
warn.deprecated)
if (missing(weight.study) || is.null(weight.study))
weight.study <- ifelse(random & !common, "random", "common")
weight.study <- setchar(weight.study, c("same", "common", "random", "fixed"))
weight.study[weight.study == "fixed"] <- "common"
##
digits.stat <-
deprecated(digits.stat, missing(digits.stat), args, "digits.zval",
warn.deprecated)
chknumeric(digits.stat, min = 0, length = 1)
##
print.stat <-
deprecated(print.stat, missing(print.stat), args, "print.zval",
warn.deprecated)
chklogical(print.stat)
##
label <- deprecated(label, missing(label), args, "labels",
warn.deprecated)
##
label.e <- deprecated(label.e, missing(label.e), args, "lab.e",
warn.deprecated)
label.c <- deprecated(label.c, missing(label.c), args, "lab.c",
warn.deprecated)
##
label.e.attach <- deprecated(label.e.attach, missing(label.e.attach),
args, "lab.e.attach.to.col",
warn.deprecated)
label.c.attach <- deprecated(label.c.attach, missing(label.c.attach),
args, "lab.c.attach.to.col",
warn.deprecated)
##
col.inside <-
deprecated(col.inside, missing(col.inside), args, "col.i.inside.square",
warn.deprecated)
chkcolor(col.inside)
chkcolor(col.inside.common)
chkcolor(col.inside.random)
##
if (!is.na(argid(names(args), "col.diamond.lines.fixed"))) {
col.diamond.lines.common <-
deprecated(col.diamond.lines.common, missing(col.diamond.lines.common),
args, "col.diamond.lines.fixed",
warn.deprecated)
}
else if (!is.na(argid(names(args), "col.diamond.fixed.lines"))) {
col.diamond.lines.common <-
deprecated(col.diamond.lines.common, missing(col.diamond.lines.common),
args, "col.diamond.fixed.lines",
warn.deprecated)
}
chkcolor(col.diamond.lines)
chkcolor(col.diamond.lines.common)
##
col.diamond.lines.random <-
deprecated(col.diamond.lines.random, missing(col.diamond.lines.random),
args, "col.diamond.random.lines",
warn.deprecated)
chkcolor(col.diamond.lines.random)
##
## Additional assignments
##
if (jama) {
if (missing.ff.common)
ff.common <- "plain"
if (missing(ff.random))
ff.random <- ff.common
if (missing(ff.predict))
ff.predict <- ff.common
if (missing.ff.common.labels)
ff.common.labels <- ff.common
if (missing(ff.random.labels))
ff.random.labels <- ff.random
if (missing(ff.predict.labels))
ff.predict.labels <- ff.predict
##
if (missing.fs.common)
fs.common <- fontsize
if (missing(fs.random))
fs.random <- fs.common
if (missing(fs.predict))
fs.predict <- fs.common
if (missing.fs.common.labels)
fs.common.labels <- fs.common
if (missing(fs.random.labels))
fs.random.labels <- fs.random
if (missing(fs.predict.labels))
fs.predict.labels <- fs.predict
}
else {
if (missing.ff.common)
ff.common <- "bold"
if (missing(ff.random))
ff.random <- ff.common
if (missing(ff.predict))
ff.predict <- ff.common
if (missing.ff.common.labels)
ff.common.labels <- ff.common
if (missing(ff.random.labels))
ff.random.labels <- ff.random
if (missing(ff.predict.labels))
ff.predict.labels <- ff.predict
##
if (missing.fs.common)
fs.common <- fontsize
if (missing(fs.random))
fs.random <- fs.common
if (missing(fs.predict))
fs.predict <- fs.common
if (missing.fs.common.labels)
fs.common.labels <- fs.common
if (missing(fs.random.labels))
fs.random.labels <- fs.random
if (missing(fs.predict.labels))
fs.predict.labels <- fs.predict
}
hetseparator <- " = "
##
if (revman5) {
if (missing(ff.hetstat))
ff.hetstat <- "plain"
if (missing(ff.test.overall))
ff.test.overall <- ff.hetstat
if (missing(ff.test.subgroup))
ff.test.subgroup <- ff.hetstat
if (missing(ff.test.effect.subgroup))
ff.test.effect.subgroup <- ff.hetstat
if (missing(ff.addline))
ff.addline <- ff.hetstat
##
if (missing(fs.hetstat))
fs.hetstat <- fontsize - 1
if (missing(fs.test.overall))
fs.test.overall <- fs.hetstat
if (missing(fs.test.subgroup))
fs.test.subgroup <- fs.hetstat
if (missing(fs.test.effect.subgroup))
fs.test.effect.subgroup <- fs.hetstat
if (missing(fs.addline))
fs.addline <- fs.hetstat
}
else if (jama) {
if (missing(ff.hetstat))
ff.hetstat <- "plain"
if (missing(ff.test.overall))
ff.test.overall <- ff.hetstat
if (missing(ff.test.subgroup))
ff.test.subgroup <- ff.hetstat
if (missing(ff.test.effect.subgroup))
ff.test.effect.subgroup <- ff.hetstat
if (missing(ff.addline))
ff.addline <- ff.hetstat
##
if (missing(fs.hetstat))
fs.hetstat <- fontsize - 1
if (missing(fs.test.overall))
fs.test.overall <- fs.hetstat
if (missing(fs.test.subgroup))
fs.test.subgroup <- fs.hetstat
if (missing(fs.test.effect.subgroup))
fs.test.effect.subgroup <- fs.hetstat
if (missing(fs.addline))
fs.addline <- fs.hetstat
}
else {
if (missing(ff.hetstat))
ff.hetstat <- "plain"
if (missing(ff.test.overall))
ff.test.overall <- ff.hetstat
if (missing(ff.test.subgroup))
ff.test.subgroup <- ff.hetstat
if (missing(ff.test.effect.subgroup))
ff.test.effect.subgroup <- ff.hetstat
if (missing(ff.addline))
ff.addline <- ff.hetstat
##
if (missing(fs.hetstat))
fs.hetstat <- fontsize - 1
if (missing(fs.test.overall))
fs.test.overall <- fs.hetstat
if (missing(fs.test.subgroup))
fs.test.subgroup <- fs.hetstat
if (missing(fs.test.effect.subgroup))
fs.test.effect.subgroup <- fs.hetstat
if (missing(fs.addline))
fs.addline <- fs.hetstat
}
##
##
## (4) Check length of variables
##
##
fun <- "forest.meta"
##
if (length(col.study) == 1)
col.study <- rep(col.study, K.all)
else
chklength(col.study, K.all, fun)
##
if (length(col.inside) == 1)
col.inside <- rep(col.inside, K.all)
else
chklength(col.inside, K.all, fun)
##
miss.col.square <- missing(col.square)
miss.col.square.lines <- missing(col.square.lines)
if (length(col.square) == 1)
col.square <- rep(col.square, K.all)
else
chklength(col.square, K.all, fun)
##
if (length(col.square.lines) == 1)
col.square.lines <- rep(col.square.lines, K.all)
else
chklength(col.square.lines, K.all, fun)
##
##
## (5) Some assignments and additional checks
##
##
n.com <- max(length(x$TE.common), 1)
n.ran <- max(length(x$seTE.random), 1)
n.prd <- max(length(x$lower.predict), 1)
##
prediction <- prediction &
any(!is.na(x$lower.predict) & !is.na(x$upper.predict))
##
if (by) {
if (!missing.subgroup & !metabind)
subgroup <- catch("subgroup", mc, x, sfsp)
##
if (length(subgroup) == 1)
subgroup.logical <- rep(subgroup, n.by) &
(x$k.w > 1 | layout == "subgroup")
else {
chklength(subgroup, n.by,
text = paste("Length of argument 'subgroup' must be",
"equal to 1 or number of subgroups."))
subgroup.logical <- subgroup
}
chklogical(subgroup[1])
##
if (!missing.subgroup.hetstat & !metabind)
subgroup.hetstat <- catch("subgroup.hetstat", mc, x, sfsp)
##
if (length(subgroup.hetstat) == 1 & is.character(subgroup.hetstat))
subgroup.hetstat.logical <- rep(TRUE, n.by)
else if (length(subgroup.hetstat) == 1) {
chklogical(subgroup.hetstat)
subgroup.hetstat.logical <- subgroup.hetstat &
(x$k.w > 1 | layout == "subgroup")
}
else {
chklength(subgroup.hetstat, n.by,
text = paste("Length of argument 'subgroup.hetstat' must be",
"equal to 1 or number of subgroups."))
chklogical(subgroup.hetstat[1])
subgroup.hetstat.logical <- subgroup.hetstat
}
##
if (!missing.prediction.subgroup & !metabind)
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
}
chklogical(prediction.subgroup[1])
##
if (!missing(test.effect.subgroup)) {
test.effect.subgroup <-
catch("test.effect.subgroup", mc, x, sfsp)
test.effect.subgroup <- replaceNULL(test.effect.subgroup, FALSE)
##
if (length(test.effect.subgroup) == 1) {
chklogical(test.effect.subgroup)
##
test.effect.subgroup.logical <-
rep(test.effect.subgroup, n.by) &
(x$k.w > 1 | layout == "subgroup")
}
else {
chklength(test.effect.subgroup, n.by,
text = paste("Length of argument 'test.effect.subgroup'",
"must be equal to 1 or number of subgroups."))
chklogical(test.effect.subgroup[1])
test.effect.subgroup.logical <- test.effect.subgroup
}
}
else
test.effect.subgroup.logical <- rep(test.effect.subgroup, n.by)
##
if (missing(test.effect.subgroup.common))
test.effect.subgroup.common.logical <-
common & test.effect.subgroup.logical
else {
test.effect.subgroup.common <-
catch("test.effect.subgroup.common", mc, x, sfsp)
test.effect.subgroup.common <-
replaceNULL(test.effect.subgroup.common, FALSE)
##
if (length(test.effect.subgroup.common) == 1) {
chklogical(test.effect.subgroup.common)
##
test.effect.subgroup.common.logical <-
rep(test.effect.subgroup.common, n.by) &
(x$k.w > 1 | layout == "subgroup")
}
else {
chklength(test.effect.subgroup.common, n.by,
text = paste("Length of argument",
"'test.effect.subgroup.common'",
"must be equal to 1 or number of subgroups."))
chklogical(test.effect.subgroup.common[1])
test.effect.subgroup.common.logical <- test.effect.subgroup.common
}
}
##
if (missing(test.effect.subgroup.random))
test.effect.subgroup.random.logical <-
random & test.effect.subgroup.logical
else {
test.effect.subgroup.random <-
catch("test.effect.subgroup.random", mc, x, sfsp)
test.effect.subgroup.random <-
replaceNULL(test.effect.subgroup.random, FALSE)
##
if (length(test.effect.subgroup.random) == 1) {
chklogical(test.effect.subgroup.random)
##
test.effect.subgroup.random.logical <-
rep(test.effect.subgroup.random, n.by) &
(x$k.w > 1 | layout == "subgroup")
}
else {
chklength(test.effect.subgroup.random, n.by,
text = paste("Length of argument",
"'test.effect.subgroup.random'",
"must be equal to 1 or number of subgroups."))
chklogical(test.effect.subgroup.random[1])
test.effect.subgroup.random.logical <- test.effect.subgroup.random
}
}
}
##
level <- x$level
level.ma <- x$level.ma
level.predict <- x$level.predict
##
if (is.null(label.right))
label.right <- ""
if (is.null(label.left))
label.left <- ""
##
subgroup <- x$subgroup
##
three.level <- !is.null(x$three.level) && any(x$three.level)
##
if (!by) {
common.random <- common & random
##
test.subgroup.common <- FALSE
test.subgroup.random <- FALSE
}
else
common.random <-
any(common | test.subgroup.common | test.effect.subgroup.common.logical) &
any(random | test.subgroup.random | test.effect.subgroup.random.logical)
##
if (layout == "subgroup") {
if (!missing(study.results) & study.results)
warning("Argument 'study.results' set to FALSE as ",
"argument 'layout' is \"subgroup\".")
study.results <- FALSE
}
##
missing.text.common <- missing(text.common)
missing.text.fixed <- is.na(argid(names(args), "text.fixed"))
if (!missing.text.fixed) {
text.common <-
deprecated(text.common, missing.text.common, args, "text.fixed",
warn.deprecated)
missing.text.common <- FALSE
}
##
if (missing.text.common | is.null(text.common)) {
if (is.null(text.common) || length(text.common) == 1) {
if (study.results & (x$level != x$level.ma | revman5)) {
if (revman5.jama)
text.common <- paste0("Total (",
if (common.random)
paste0(gs("text.w.common"), " effect, "),
round(x$level.ma * 100), "% CI)")
else if (!is.null(text.common))
text.common <- paste0(text.common, " (",
round(x$level.ma * 100), "%-CI)")
else
text.common <- paste0(gs("text.common"), " (",
round(x$level.ma * 100), "%-CI)")
}
else {
if (revman5.jama) {
text.common <- "Total"
if (common.random)
text.common <- paste0(text.common, " (", gs("text.w.common"),
" effect)")
}
else if (is.null(text.common))
text.common <- gs("text.common")
}
}
}
##
missing.text.random <- missing(text.random)
if (missing.text.random | is.null(text.random)) {
if (is.null(text.random) || length(text.random) == 1) {
if (study.results & (x$level != x$level.ma | revman5)) {
if (revman5.jama) {
text.random <- paste0("Total (",
if (common.random)
paste0(gs("text.w.random"), " effect, "))
if (length(x$lower.random) > 1) {
meth.r <- gsub("classic", "", x$method.random.ci)
text.random <-
paste0(text.random, meth.r,
ifelse(meth.r == "HK" & x$adhoc.hakn.ci != "",
paste0("-",
toupper(substring(x$adhoc.hakn.ci, 1, 2))),
""),
ifelse(meth.r != "", ", ", ""))
}
text.random <- paste0(text.random,
round(x$level.ma * 100), "% CI)")
}
else if (!is.null(text.random))
text.random <- paste0(text.random, " (",
round(x$level.ma * 100), "%-CI)")
else
text.random <- paste0(gs("text.random"), " (",
round(x$level.ma * 100), "%-CI)")
}
else {
if (revman5.jama) {
text.random <- "Total"
if (common.random || length(x$lower.random) > 1) {
text.random <- paste0(text.random, " (", gs("text.w.random"),
" effect")
if (length(x$lower.random) > 1) {
meth.r <- gsub("classic", "", x$method.random.ci)
text.random <-
paste0(text.random,
ifelse(meth.r != "", ", ", ""),
meth.r,
ifelse(meth.r == "HK" & x$adhoc.hakn.ci != "",
paste0("-",
toupper(substring(x$adhoc.hakn.ci, 1, 2))),
""))
}
text.random <- paste0(text.random, ")")
}
}
else if (is.null(text.random)) {
text.random <- gs("text.random")
if (length(x$lower.random) > 1) {
meth.r <- gsub("classic", "", x$method.random.ci)
text.random <-
paste0(text.random,
ifelse(meth.r != "", "(", ""),
meth.r,
ifelse(meth.r == "HK" & x$adhoc.hakn.ci != "",
paste0("-",
toupper(substring(x$adhoc.hakn.ci, 1, 2))),
""),
ifelse(meth.r != "", ")", ""))
}
}
}
}
}
##
if (length(text.random) == 1 & n.ran > 1)
text.random <- rep(text.random, n.ran)
##
missing.text.predict <- missing(text.predict)
if (missing.text.predict | is.null(text.predict)) {
if (is.null(text.predict))
text.predict <- rep("Prediction interval", n.prd)
if (!(length(x$level.predict) == 0) &&
(study.results & (x$level != x$level.predict |
x$level.ma != x$level.predict)))
text.predict <- paste0(text.predict, " (",
round(x$level.predict * 100), "%-PI)")
}
##
if (metainf.metacum) {
overall.hetstat <- FALSE
test.overall.common <- FALSE
test.overall.random <- FALSE
resid.hetstat <- FALSE
test.subgroup.common <- FALSE
test.subgroup.random <- FALSE
##
hetstat <- FALSE
prediction <- FALSE
}
##
if (is.null(x$null.effect) || is.na(x$null.effect)) {
test.overall.common <- FALSE
test.overall.random <- FALSE
}
##
if (!overall) {
if (test.overall)
test.overall <- FALSE
if (test.overall.common)
test.overall.common <- FALSE
if (test.overall.random)
test.overall.random <- FALSE
}
##
## Add space for heterogeneity statistics (if needed)
##
if (is.null(addrows.below.overall)) {
addrows.below.overall <- 0
##
if (layout == "JAMA")
addrows.below.overall <- 3
else if (layout == "meta" & (metacor | metagen) &
missing.leftcols &
(overall.hetstat | test.overall.common |
test.overall.random) &
!(calcwidth.hetstat | calcwidth.tests))
addrows.below.overall <- 2
else if (layout %in% c("meta", "subgroup") &
(test.subgroup.common & test.subgroup.random) &
!calcwidth.tests) {
addrows.below.overall <- 1
##
if (layout == "meta")
addrows.below.overall <-
addrows.below.overall +
as.numeric((label.left != "" | label.right != "")) +
as.numeric(xlab != "")
}
}
##
chknumeric(addrows.below.overall, min = 0, length = 1, integer = TRUE)
##
notmiss.xlim <- !missing(xlim)
##
if (just.studlab == "left")
xpos.s <- 0
else if (just.studlab == "center")
xpos.s <- 0.5
else if (just.studlab == "right")
xpos.s <- 1
##
if (just.cols == "left")
xpos.c <- 0
else if (just.cols == "center")
xpos.c <- 0.5
else if (just.cols == "right")
xpos.c <- 1
##
if (log.xaxis) {
ref <- log(ref)
lower.equi <- log(lower.equi)
upper.equi <- log(upper.equi)
}
##
if (!backtransf & !missing(pscale) & pscale != 1 & !is_untransformed(sm)) {
warning("Argument 'pscale' set to 1 as argument 'backtransf' is FALSE.")
pscale <- 1
}
##
if (!backtransf & pscale != 1)
pscale <- 1
##
if (!backtransf & !missing(irscale) & irscale != 1 & !is_untransformed(sm)) {
warning("Argument 'irscale' set to 1 as argument 'backtransf' is FALSE.")
irscale <- 1
}
##
if (!backtransf & irscale != 1)
irscale <- 1
##
if (is.null(xlab))
xlab <- xlab(sm, backtransf, newline = revman5.jama, revman5 = revman5,
big.mark = big.mark)
##
smlab.null <- is.null(smlab)
if (smlab.null)
if (is_rate(sm))
smlab <- xlab(sm, backtransf, irscale = irscale, irunit = irunit,
newline = !revman5.jama, revman5 = revman5,
big.mark = big.mark)
else
smlab <- xlab(sm, backtransf, pscale = pscale,
newline = !revman5.jama, revman5 = revman5,
big.mark = big.mark)
##
print.label <- (label.left != "" | label.right != "") & !is.na(ref)
if (print.label & !bottom.lr) {
if (!smlab.null)
warning("Argument 'smlab' ignored as argument 'bottom.lr' is FALSE.")
smlab <- ""
}
##
if (!by)
addrow.subgroups <- FALSE
##
if (resid.hetstat &&
(!by || (by && is.null(x$tau.common) || !x$tau.common))) {
if (!missing(resid.hetstat))
warning("Information on residual heterogeneity only added to ",
"forest plot of meta-analysis with subgroups ",
"assuming common estimator for between-study heterogeneity ",
"(argument 'tau.common = TRUE' in meta-analysis functions)",
call. = FALSE)
resid.hetstat <- FALSE
}
##
plotwidth <- setunit(plotwidth)
colgap <- setunit(colgap)
colgap.left <- setunit(colgap.left)
colgap.right <- setunit(colgap.right)
colgap.studlab <- setunit(colgap.studlab)
colgap.forest <- setunit(colgap.forest)
colgap.forest.left <- setunit(colgap.forest.left)
colgap.forest.right <- setunit(colgap.forest.right)
##
missing.label.test.overall.common <- missing(label.test.overall.common)
missing.label.test.overall.fixed <-
is.na(argid(names(args), "label.test.overall.fixed"))
if (!missing.label.test.overall.fixed) {
label.test.overall.common <-
deprecated(label.test.overall.common, missing.label.test.overall.common,
args, "label.test.overall.fixed",
warn.deprecated)
missing.label.test.overall.common <- FALSE
}
if (missing.label.test.overall.common)
label.test.overall.common <-
paste0("Test for overall effect",
if (common.random)
paste0(" (", gs("text.w.common"), " effect)"),
": ")
if (missing(label.test.overall.random))
label.test.overall.random <-
paste0("Test for overall effect",
if (common.random)
paste0(" (", gs("text.w.random"), " effects)"),
": ")
##
missing.label.test.subgroup.common <- missing(label.test.subgroup.common)
missing.label.test.subgroup.fixed <-
is.na(argid(names(args), "label.test.subgroup.fixed"))
if (!missing.label.test.subgroup.fixed) {
label.test.subgroup.common <-
deprecated(label.test.subgroup.common,
missing.label.test.subgroup.common,
args, "label.test.subgroup.fixed",
warn.deprecated)
missing.label.test.subgroup.common <- FALSE
}
if (missing.label.test.subgroup.common)
label.test.subgroup.common <-
paste0("Test for subgroup differences",
if (common.random)
paste0(" (", gs("text.w.common"), " effect)"),
": ")
if (missing(label.test.subgroup.random))
label.test.subgroup.random <-
paste0("Test for subgroup differences",
if (common.random)
paste0(" (", gs("text.w.random"), " effects)"),
": ")
##
missing.label.test.effect.subgroup.common <-
missing(label.test.effect.subgroup.common)
missing.label.test.effect.subgroup.fixed <-
is.na(argid(names(args), "label.test.effect.subgroup.fixed"))
if (!missing.label.test.effect.subgroup.fixed) {
label.test.effect.subgroup.common <-
deprecated(label.test.effect.subgroup.common,
missing.label.test.effect.subgroup.common,
args, "label.test.effect.subgroup.fixed",
warn.deprecated)
missing.label.test.effect.subgroup.common <- FALSE
}
if (missing.label.test.effect.subgroup.common)
label.test.effect.subgroup.common <-
paste0(if (revman5.jama)
"Test for overall effect"
else
"Test for effect in subgroup",
if (common.random)
paste0(" (", gs("text.w.common"), " effect)"),
": ")
if (missing(label.test.effect.subgroup.random))
label.test.effect.subgroup.random <-
paste0(if (revman5.jama)
"Test for overall effect"
else
"Test for effect in subgroup",
if (common.random)
paste0(" (", gs("text.w.random"), " effects)"),
": ")
##
fs.head <- fs.heading
ff.head <- ff.heading
##
just.c <- just.cols
just.s <- just.studlab
##
##
## (6) Labels for columns on left and right side of forest plot
##
##
sm.lab <- sm
##
if (backtransf) {
if (sm == "ZCOR")
sm.lab <- "COR"
else if (is_prop(sm)) {
if (pscale == 1)
sm.lab <- "Proportion"
else
sm.lab <- "Events"
}
else if (is_rate(sm)) {
if (irscale == 1)
sm.lab <- "Rate"
else
sm.lab <- "Events"
}
else if (sm == "proportion")
sm.lab <- "Proportion"
else if (sm == "MLN")
sm.lab <- "Mean"
}
else if (is_relative_effect(sm) | (!is.null(fbt) && fbt == "exp"))
sm.lab <- paste0("log", sm)
##
sel.studlab <- pmatch(layout, c("meta", "RevMan5", "JAMA", "subgroup"))
lab.studlab <- c("Study", "Study", "Source", "Subgroup")[sel.studlab]
if (revman5 & by)
lab.studlab <- c("Study or\nSubgroup")
##
if (revman5.jama)
cisep <- " "
else
cisep <- "-"
##
if (study.results)
ci.lab <- paste0(100 * level, "%", cisep, "CI")
else
ci.lab <- paste0(100 * level.ma, "%", cisep, "CI")
##
missing.col.diamond.common <- missing(col.diamond.common)
missing.col.diamond.fixed <- is.na(argid(names(args), "col.diamond.fixed"))
if (!missing.col.diamond.fixed) {
col.diamond.common <-
deprecated(col.diamond.common, missing.col.diamond.common,
args, "col.diamond.fixed",
warn.deprecated)
missing.col.diamond.common <- FALSE
}
chkcolor(col.diamond.common)
##
if (jama) {
if (missing(ff.lr))
ff.lr <- "bold"
if (xlab == "")
xlab <- paste0(sm.lab, " (", ci.lab, ")")
if (miss.col.square)
col.square <- rep("darkblue", K.all)
if (miss.col.square.lines)
col.square.lines <- rep("darkblue", K.all)
if (missing.col.diamond.common)
col.diamond.common <- "lightblue"
if (missing(col.diamond.random))
col.diamond.random <- "lightblue"
##
smlab <- ""
bottom.lr <- FALSE
}
else {
if (revman5) {
if (miss.col.square) {
if (metacont | metamean)
col.square <- rep("green", K.all)
else if (metabin)
col.square <- rep("blue", K.all)
else
col.square <- rep("red", K.all)
}
if (miss.col.square.lines) {
if (metacont | metamean)
col.square.lines <- rep("green", K.all)
else if (metabin)
col.square.lines <- rep("darkblue", K.all)
else
col.square.lines <- rep("red", K.all)
}
if (missing.col.diamond.common)
col.diamond.common <- "black"
if (missing(col.diamond.random))
col.diamond.random <- "black"
##
sel.method <- pmatch(x$method, c("Inverse", "MH", "Peto", "GLMM"))
lab.method <- c("IV", "MH", "Peto", "GLMM")[sel.method]
##
if (common.random)
lab.model <- "Fixed + Random, "
else if (common)
lab.model <- "Fixed, "
else if (random)
lab.model <- "Random, "
else
lab.model <- ""
##
if (smlab.null)
smlab <- paste0(smlab, "\n", lab.method[1], ", ", lab.model, ci.lab)
}
}
##
if (jama | gs("CIbracket") == "(")
ci.lab.bracket <- paste0("(", ci.lab, ")")
else if (gs("CIbracket") == "[")
ci.lab.bracket <- paste0("[", ci.lab, "]")
else if (gs("CIbracket") == "{")
ci.lab.bracket <- paste0("{", ci.lab, "}")
else if (gs("CIbracket") == "")
ci.lab.bracket <- ci.lab
##
if (!common.random) {
text.w.common <- "Weight"
text.w.random <- "Weight"
}
else {
text.w.common <-
deprecated(text.w.common, missing(text.w.common), args, "text.w.fixed",
warn.deprecated)
##
if (is.null(text.w.common))
text.w.common <- paste0("Weight\n(", gs("text.w.common"), ")")
else
text.w.common <- paste0("Weight\n(", text.w.common, ")")
##
if (is.null(text.w.random))
text.w.random <- paste0("Weight\n(", gs("text.w.random"), ")")
else
text.w.random <- paste0("Weight\n(", text.w.random, ")")
}
##
lab.TE <- sm
##
if (log.xaxis | sm == "VE")
lab.TE <- paste0("log", sm)
else if (!log.xaxis & !is.null(ftr)) {
lab.TE <-
paste0(ftr, "(", sm,
if (!is.null(atr) && length(names(atr)) >= 1)
paste0(", ",
paste0(names(atr), "=", paste(atr), collapse = ", ")),
")")
}
else if (sm == "")
lab.TE <- "TE"
##
labnames <- c(lab.studlab,
lab.TE,
if (revman5) "SE" else paste0("SE(", lab.TE, ")"),
"Cluster",
"Total", "Total", "Events", "Events",
"Mean", "Mean", "SD", "SD",
"Cor",
"Time", "Time",
sm.lab,
ci.lab,
if (revman5 & smlab.null)
smlab
else
paste(sm.lab, ci.lab.bracket),
text.w.common,
text.w.common,
text.w.random,
"P-value")
##
if (metainf.metacum)
labnames <- c(labnames, "Tau2", "Tau", "I2")
##
if (newcols) {
##
if (length(rightcols.new) > 0) {
if (missing(rightlabs)) {
rightlabs.new <- rightcols.new
##
if ((metacor | metaprop | metamean | metarate) &
any(rightcols.new == "n"))
rightlabs.new[rightlabs.new == "n"] <- "Total"
##
if (metamean & any(rightcols.new == "mean"))
rightlabs.new[rightlabs.new == "mean"] <- "Mean"
##
if (metamean & any(rightcols.new == "sd"))
rightlabs.new[rightlabs.new == "sd"] <- "SD"
##
if (metarate & any(rightcols.new == "time"))
rightlabs.new[rightlabs.new == "time"] <- "Time"
##
if (any(rightcols.new == "pval"))
rightlabs.new[rightlabs.new == "pval"] <- "P-value"
##
if (any(rightcols.new == "tau2"))
rightlabs.new[rightlabs.new == "tau2"] <- "Tau2"
##
if (any(rightcols.new == "tau"))
rightlabs.new[rightlabs.new == "tau"] <- "Tau"
##
if (any(rightcols.new == "I2"))
rightlabs.new[rightlabs.new == "I2"] <- "I2"
##
if (three.level & any(rightcols.new == "cluster"))
rightlabs.new[rightlabs.new == "cluster"] <- "Cluster"
}
else {
if (length(rightcols.new) == length(rightlabs))
rightlabs.new <- rightlabs
else if (length(rightcols.new) > length(rightlabs))
stop("Too few labels defined for argument 'rightcols'.")
else {
rightlabs.new <- rightcols.new
##
for (i in seq_along(rightcols.new)) {
match1.i <- match(rightcols.new[i], rightcols)
if (!is.na(rightlabs[match1.i]))
rightlabs.new[i] <- rightlabs[match1.i]
else {
match2.i <- match(rightcols.new[i], colnames)
if (!is.na(match2.i))
rightlabs.new[i] <- labnames[match2.i]
else if (rightcols.new[i] == "pval")
rightlabs.new[i] <- "P-value"
else if (rightcols.new[i] == "tau2")
rightlabs.new[i] <- "Tau2"
else if (rightcols.new[i] == "tau")
rightlabs.new[i] <- "Tau"
else if (rightcols.new[i] == "I2")
rightlabs.new[i] <- "I2"
}
}
}
}
}
##
if (length(leftcols.new) > 0) {
if (missing(leftlabs)) {
leftlabs.new <- leftcols.new
##
if ((metacor | metaprop | metamean | metarate) &
any(leftcols.new == "n"))
leftlabs.new[leftlabs.new == "n"] <- "Total"
##
if (metamean & any(leftcols.new == "mean"))
leftlabs.new[leftlabs.new == "mean"] <- "Mean"
##
if (metamean & any(leftcols.new == "sd"))
leftlabs.new[leftlabs.new == "sd"] <- "SD"
##
if (metarate & any(leftcols.new == "time"))
leftlabs.new[leftlabs.new == "time"] <- "Time"
##
if (any(leftcols.new == "pval"))
leftlabs.new[leftlabs.new == "pval"] <- "P-value"
##
if (any(leftcols.new == "tau2"))
leftlabs.new[leftlabs.new == "tau2"] <- "Tau2"
##
if (any(leftcols.new == "tau"))
leftlabs.new[leftlabs.new == "tau"] <- "Tau"
##
if (any(leftcols.new == "I2"))
leftlabs.new[leftlabs.new == "I2"] <- "I2"
##
if (three.level & any(leftcols.new == "cluster"))
leftlabs.new[leftlabs.new == "cluster"] <- "Cluster"
}
else {
if (length(leftcols.new) == length(leftlabs))
leftlabs.new <- leftlabs
else if (length(leftcols.new) > length(leftlabs))
stop("Too few labels defined for argument 'leftcols'.")
else {
leftlabs.new <- leftcols.new
##
for (i in seq_along(leftcols.new)) {
match1.i <- match(leftcols.new[i], leftcols)
if (!is.na(leftlabs[match1.i]))
leftlabs.new[i] <- leftlabs[match1.i]
else {
match2.i <- match(leftcols.new[i], colnames)
if (!is.na(match2.i))
leftlabs.new[i] <- labnames[match2.i]
else if (leftcols.new[i] == "pval")
leftlabs.new[i] <- "P-value"
else if (leftcols.new[i] == "tau2")
leftlabs.new[i] <- "Tau2"
else if (leftcols.new[i] == "tau")
leftlabs.new[i] <- "Tau"
else if (leftcols.new[i] == "I2")
leftlabs.new[i] <- "I2"
}
}
}
}
}
}
##
## Default set of columns if argument leftcols and / or
## rightcols not specified
##
if (is.null(leftcols) && lsel) {
##
leftcols <- "studlab"
##
if (three.level)
leftcols <- c(leftcols, "cluster")
##
if (jama) {
leftcols <- c(leftcols, "effect.ci")
}
else {
if (metabin) {
if (study.results)
leftcols <- c(leftcols,
"event.e", "n.e",
"event.c", "n.c")
else {
leftcols <- c(leftcols,
if (pooled.events) "event.e",
if (pooled.totals) "n.e",
if (pooled.events) "event.c",
if (pooled.totals) "n.c")
if (pooled.events & !pooled.totals) {
if (is.null(label.e.attach))
label.e.attach <- "event.e"
if (is.null(label.c.attach))
label.c.attach <- "event.c"
}
}
}
##
if (metacont) {
if (study.results) {
if (revman5)
leftcols <- c(leftcols,
"mean.e", "sd.e", "n.e",
"mean.c", "sd.c", "n.c")
else
leftcols <- c(leftcols,
"n.e", "mean.e", "sd.e",
"n.c", "mean.c", "sd.c")
}
else if (pooled.totals) {
leftcols <- c(leftcols, "n.e", "n.c")
if (is.null(label.e.attach))
label.e.attach <- "n.e"
if (is.null(label.c.attach))
label.c.attach <- "n.c"
}
}
##
if (metagen & study.results) {
leftcols <- c(leftcols,
"TE", "seTE")
if (!is.null(x$n.e)) {
leftcols <- c(leftcols, "n.e")
if (is.null(label.e.attach))
label.e.attach <- "n.e"
}
if (!is.null(x$n.c)) {
leftcols <- c(leftcols, "n.c")
if (is.null(label.c.attach))
label.c.attach <- "n.c"
}
}
##
if (metamean) {
if (study.results) {
if (revman5)
leftcols <- c(leftcols,
"mean.e", "sd.e", "n.e")
else
leftcols <- c(leftcols,
"n.e", "mean.e", "sd.e")
}
else if (pooled.totals) {
leftcols <- c(leftcols, "n.e")
if (is.null(label.e.attach))
label.e.attach <- "n.e"
}
}
##
if (metaprop) {
if (study.results)
leftcols <- c(leftcols, "event.e", "n.e")
else {
leftcols <- c(leftcols,
if (pooled.events) "event.e",
if (pooled.totals) "n.e")
if (pooled.events & !pooled.totals) {
if (is.null(label.e.attach))
label.e.attach <- "event.e"
}
}
}
##
if (metarate) {
if (study.results)
leftcols <- c(leftcols,
"event.e", "time.e",
if (!is.null(x$n)) "n.e")
else {
leftcols <- c(leftcols,
if (pooled.events) "event.e",
if (pooled.times) "time.e")
if (pooled.events & !pooled.times) {
if (is.null(label.e.attach))
label.e.attach <- "event.e"
}
}
}
##
if (metacor) {
if (study.results | pooled.totals)
leftcols <- c(leftcols,
"n.e")
}
##
if (metainc) {
if (study.results)
leftcols <- c(leftcols,
"event.e", "time.e",
"event.c", "time.c")
else {
leftcols <- c(leftcols,
if (pooled.events) "event.e",
if (pooled.times) "time.e",
if (pooled.events) "event.c",
if (pooled.times) "time.c")
if (pooled.events & !pooled.times) {
if (is.null(label.e.attach))
label.e.attach <- "event.e"
if (is.null(label.c.attach))
label.c.attach <- "event.c"
}
}
}
}
##
## Add columns for RevMan 5 layout
##
if (revman5) {
##
if (!metainf.metacum & overall & study.results & !any(x$method == "GLMM")) {
if (common)
leftcols <- c(leftcols, "w.common")
if (random)
leftcols <- c(leftcols, "w.random")
}
##
leftcols <- c(leftcols, "effect.ci")
}
}
##
leftcols[leftcols == "w.fixed"] <- "w.common"
leftcols <- unique(leftcols)
##
if (is.null(rightcols) && rsel) {
rightcols <- c("effect", "ci")
##
if (!metainf.metacum & overall & study.results & !any(x$method == "GLMM")) {
if (common)
rightcols <- c(rightcols, "w.common")
if (random)
rightcols <- c(rightcols, "w.random")
}
##
if (metainf.metacum)
rightcols <- c(rightcols, "pval", "tau2", "tau", "I2")
}
##
rightcols[rightcols == "w.fixed"] <- "w.common"
rightcols <- unique(rightcols)
##
if (any(leftcols == "w.common") & any(rightcols == "w.common"))
leftcols <- leftcols[!leftcols == "w.common"]
##
##
## (6) Select data for forest plot
##
##
if (metacor) {
x$n.e <- x$n
}
##
if (metamean) {
x$n.e <- x$n
x$mean.e <- x$mean
x$sd.e <- x$sd
##
if (!is.null(rightcols)) {
if (any(rightcols == "n"))
rightcols[rightcols == "n"] <- "n.e"
if (any(rightcols == "mean"))
rightcols[rightcols == "mean"] <- "mean.e"
if (any(rightcols == "sd"))
rightcols[rightcols == "sd"] <- "sd.e"
}
##
if (!is.null(leftcols)) {
if (any(leftcols == "n"))
leftcols[leftcols == "n"] <- "n.e"
if (any(leftcols == "mean"))
leftcols[leftcols == "mean"] <- "mean.e"
if (any(leftcols == "sd"))
leftcols[leftcols == "sd"] <- "sd.e"
}
}
##
if (metaprop) {
x$event.e <- x$event
x$n.e <- x$n
##
if (!is.null(rightcols)) {
if (any(rightcols == "n"))
rightcols[rightcols == "n"] <- "n.e"
if (any(rightcols == "event"))
rightcols[rightcols == "event"] <- "event.e"
}
##
if (!is.null(leftcols)) {
if (any(leftcols == "n"))
leftcols[leftcols == "n"] <- "n.e"
if (any(leftcols == "event"))
leftcols[leftcols == "event"] <- "event.e"
}
}
##
if (metarate) {
x$event.e <- x$event
x$time.e <- x$time
x$n.e <- x$n
##
if (!is.null(rightcols)) {
if (any(rightcols == "time"))
rightcols[rightcols == "time"] <- "time.e"
if (any(rightcols == "event"))
rightcols[rightcols == "event"] <- "event.e"
if (any(rightcols == "n"))
rightcols[rightcols == "n"] <- "n.e"
}
##
if (!is.null(leftcols)) {
if (any(leftcols == "time"))
leftcols[leftcols == "time"] <- "time.e"
if (any(leftcols == "event"))
leftcols[leftcols == "event"] <- "event.e"
if (any(leftcols == "n"))
leftcols[leftcols == "n"] <- "n.e"
}
}
##
if (metainf.metacum) {
##
x$TE.common <- rev(x$TE)[1]
x$seTE.common <- rev(x$seTE)[1]
x$lower.common <- rev(x$lower)[1]
x$upper.common <- rev(x$upper)[1]
##
x$TE.random <- rev(x$TE)[1]
x$seTE.random <- rev(x$seTE)[1]
x$lower.random <- rev(x$lower)[1]
x$upper.random <- rev(x$upper)[1]
##
x$n.harmonic.mean.ma <- rev(x$n.harmonic.mean)[1]
x$t.harmonic.mean.ma <- rev(x$t.harmonic.mean)[1]
##
x$w.all <- rev(x$w)[1]
##
x$TE <- rev(rev(x$TE)[-(1:2)])
x$seTE <- rev(rev(x$seTE)[-(1:2)])
x$studlab <- rev(rev(x$studlab)[-(1:2)])
##
x$lower <- rev(rev(x$lower)[-(1:2)])
x$upper <- rev(rev(x$upper)[-(1:2)])
##
x$w.common <- rev(rev(x$w)[-(1:2)])
x$w.random <- rev(rev(x$w)[-(1:2)])
##
x$n.harmonic.mean <- rev(rev(x$n.harmonic.mean)[-(1:2)])
x$t.harmonic.mean <- rev(rev(x$t.harmonic.mean)[-(1:2)])
##
x$pval.common <- x$pval.random <- rev(x$pval)[1]
x$tau2.overall <- rev(x$tau2)[1]
x$tau.overall <- rev(x$tau)[1]
x$I2.overall <- rev(x$I2)[1]
##
x$pval <- rev(rev(x$pval)[-(1:2)])
x$tau2 <- rev(rev(x$tau2)[-(1:2)])
x$tau <- rev(rev(x$tau)[-(1:2)])
x$I2 <- rev(rev(x$I2)[-(1:2)])
##
if (overall & x$pooled == "common") {
common <- TRUE
random <- FALSE
if (weight.study != "same")
weight.study <- "common"
}
else if (overall & x$pooled == "random") {
common <- FALSE
random <- TRUE
if (weight.study != "same")
weight.study <- "random"
}
}
## Total number of studies to plot (*not* number of studies combined)
k.all <- length(x$TE)
##
if (allstudies)
n.stud <- k.all # all studies
else
n.stud <- sum(!is.na(x$TE)) # number of studies with treatment estimates
##
if (length(type.study) == 1)
type.study <- rep(type.study, k.all)
else if (length(type.study) != k.all)
stop("Argument 'type.study' must be a single character or of ",
"same length as number of studies.")
##
if (!by)
subgroup <- rep(1, k.all)
##
if (by & anyNA(subgroup))
stop("Missing values in 'subgroup'")
##
if (allstudies)
sel <- rep(TRUE, k.all)
else
sel <- !is.na(x$TE)
##
x$n.e <- x$n.e[sel]
x$n.c <- x$n.c[sel]
##
x$event.e <- x$event.e[sel]
x$event.c <- x$event.c[sel]
##
x$mean.e <- x$mean.e[sel]
x$mean.c <- x$mean.c[sel]
##
x$sd.e <- x$sd.e[sel]
x$sd.c <- x$sd.c[sel]
##
x$cor <- x$cor[sel]
##
x$time.e <- x$time.e[sel]
x$time.c <- x$time.c[sel]
##
x$TE <- x$TE[sel]
x$seTE <- x$seTE[sel]
##
x$lower <- x$lower[sel]
x$upper <- x$upper[sel]
##
if (is.matrix(x$w.common))
x$w.common <- x$w.common[sel, , drop = FALSE]
else
x$w.common <- x$w.common[sel]
##
if (is.matrix(x$w.random))
x$w.random <- x$w.random[sel, , drop = FALSE]
else
x$w.random <- x$w.random[sel]
##
studlab <- studlab[sel]
type.study <- type.study[sel]
##
x$n.harmonic.mean <- x$n.harmonic.mean[sel]
x$t.harmonic.mean <- x$t.harmonic.mean[sel]
##
x$pval <- x$pval[sel]
##
x$cluster <- x$cluster[sel]
##
if (metainf.metacum) {
x$tau2 <- x$tau2[sel]
x$tau <- x$tau[sel]
x$I2 <- x$I2[sel]
}
##
subgroup <- subgroup[sel]
sortvar <- sortvar[sel]
##
col.study <- col.study[sel]
col.square <- col.square[sel]
col.square.lines <- col.square.lines[sel]
##
col.inside <- col.inside[sel]
##
null.exclude <- is.null(x$exclude)
if (!null.exclude)
exclude <- x$exclude[sel]
##
if (sort | by) {
if (sort.subgroup)
subgroup.levels <- sort(x$subgroup.levels)
else
subgroup.levels <- x$subgroup.levels
##
subgroup.factor <- factor(subgroup, levels = subgroup.levels)
o <- order(subgroup.factor, sortvar)
##
x$cluster <- x$cluster[o]
##
x$n.e <- x$n.e[o]
x$n.c <- x$n.c[o]
##
x$event.e <- x$event.e[o]
x$event.c <- x$event.c[o]
##
x$mean.e <- x$mean.e[o]
x$mean.c <- x$mean.c[o]
##
x$sd.e <- x$sd.e[o]
x$sd.c <- x$sd.c[o]
##
x$cor <- x$cor[o]
##
x$time.e <- x$time.e[o]
x$time.c <- x$time.c[o]
##
x$TE <- x$TE[o]
x$seTE <- x$seTE[o]
##
x$lower <- x$lower[o]
x$upper <- x$upper[o]
##
if (is.matrix(x$w.common))
x$w.common <- x$w.common[o, , drop = FALSE]
else
x$w.common <- x$w.common[o]
##
if (is.matrix(x$w.random))
x$w.random <- x$w.random[o, , drop = FALSE]
else
x$w.random <- x$w.random[o]
##
studlab <- studlab[o]
type.study <- type.study[o]
##
x$n.harmonic.mean <- x$n.harmonic.mean[o]
x$t.harmonic.mean <- x$t.harmonic.mean[o]
##
x$pval <- x$pval[o]
##
if (metainf.metacum) {
x$tau2 <- x$tau2[o]
x$tau <- x$tau[o]
x$I2 <- x$I2[o]
}
##
subgroup <- subgroup[o]
sortvar <- sortvar[o]
##
col.study <- col.study[o]
col.square <- col.square[o]
col.square.lines <- col.square.lines[o]
##
col.inside <- col.inside[o]
##
if (!null.exclude)
exclude <- exclude[o]
##
if (newcols) {
dataset1 <- dataset1[o, ]
dataset2 <- dataset2[o, ]
}
}
##
if (metainf.metacum) {
TE <- x$TE
seTE <- x$seTE
lowTE <- x$lower
uppTE <- x$upper
##
TE.common <- x$TE.common
lowTE.common <- x$lower.common
uppTE.common <- x$upper.common
##
TE.random <- x$TE.random
lowTE.random <- x$lower.random
uppTE.random <- x$upper.random
##
lowTE.predict <- NA
uppTE.predict <- NA
##
Q <- NA
df.Q <- NA
pval.Q <- NA
I2 <- NA
tau2 <- NA
lower.tau2 <- NA
upper.tau2 <- NA
tau <- NA
lower.tau <- NA
upper.tau <- NA
sign.lower.tau <- ""
sign.upper.tau <- ""
lowI2 <- NA
uppI2 <- NA
Rb <- NA
lowRb <- NA
uppRb <- NA
##
Q.b.common <- NA
Q.b.random <- NA
df.Q.b <- NA
df.Q.b.common <- NA
df.Q.b.random <- NA
pval.Q.b.common <- NA
pval.Q.b.random <- NA
}
else {
TE <- x$TE
seTE <- x$seTE
lowTE <- x$lower
uppTE <- x$upper
##
if ((metaprop | metarate) & !backtransf) {
ciTE <- ci(TE, seTE, level = level)
lowTE <- ciTE$lower
uppTE <- ciTE$upper
}
##
TE.common <- x$TE.common
lowTE.common <- x$lower.common
uppTE.common <- x$upper.common
##
TE.random <- x$TE.random
lowTE.random <- x$lower.random
uppTE.random <- x$upper.random
if (n.ran > 1 && length(TE.random) == 1)
TE.random <- rep(TE.random, n.ran)
##
lowTE.predict <- x$lower.predict
uppTE.predict <- x$upper.predict
##
if (LRT)
Q <- x$Q.LRT
else
Q <- unlist(x$Q)
##
df.Q <- unlist(x$df.Q)
pval.Q <- replaceNULL(unlist(x$pval.Q), pvalQ(Q, df.Q))
##
## Keep the first heterogeneity statistics
##
if (length(Q) > 1) {
Q <- Q[1]
df.Q <- df.Q[1]
pval.Q <- pval.Q[1]
}
##
tau2 <- x$tau2
lower.tau2 <- x$lower.tau2
upper.tau2 <- x$upper.tau2
##
if (is.null(tau2)) {
tau2 <- x$tau^2
lower.tau2 <- upper.tau2 <- NA
}
##
if (length(tau2) > 1) {
if (three.level) {
tau2 <- sum(tau2)
lower.tau2 <- NA
upper.tau2 <- NA
}
else {
tau2 <- tau2[1]
lower.tau2 <- lower.tau2[1]
upper.tau2 <- upper.tau2[1]
}
}
##
tau <- x$tau
lower.tau <- x$lower.tau
upper.tau <- x$upper.tau
##
if (length(tau) > 1) {
if (three.level) {
tau <- sqrt(sum(tau^2))
lower.tau2 <- NA
upper.tau2 <- NA
}
else {
tau <- tau[1]
lower.tau <- lower.tau[1]
upper.tau <- upper.tau[1]
}
}
##
sign.lower.tau <- x$sign.lower.tau
sign.upper.tau <- x$sign.lower.tau
##
if (is.null(lower.tau)) {
lower.tau <- upper.tau <- NA
sign.lower.tau <- sign.upper.tau <- ""
}
##
I2 <- unlist(x$I2)
lowI2 <- unlist(x$lower.I2)
uppI2 <- unlist(x$upper.I2)
##
if (length(I2) > 1) {
I2 <- I2[1]
lowI2 <- lowI2[1]
uppI2 <- uppI2[1]
}
##
Rb <- unlist(x$Rb)
lowRb <- unlist(x$lower.Rb)
uppRb <- unlist(x$upper.Rb)
##
if (length(Rb) > 1) {
Rb <- Rb[1]
lowRb <- lowRb[1]
uppRb <- uppRb[1]
}
##
if (by) {
df.Q.b <- x$df.Q.b
df.Q.b.random <- replaceNULL(x$df.Q.b.random, df.Q.b)
##
Q.b.common <- x$Q.b.common
df.Q.b.common <- replaceNULL(x$df.Q.b.common, df.Q.b)
pval.Q.b.common <-
replaceNULL(x$pval.Q.b.common, pvalQ(Q.b.common, df.Q.b.common))
## Only consider test for subgroup differences for first random
## effects meta-analysis method
Q.b.random <- x$Q.b.random[1]
if (is.list(df.Q.b.random))
df.Q.b.random <- df.Q.b.random[[1]]
##
if (length(df.Q.b.random) == 1)
pval.Q.b.random <-
replaceNULL(x$pval.Q.b.random[1], pvalQ(Q.b.random, df.Q.b.random))
else if (length(df.Q.b.random) == 2)
pval.Q.b.random <-
replaceNULL(x$pval.Q.b.random[1],
pf(Q.b.random, df.Q.b.random[1], df.Q.b.random[2],
lower.tail = FALSE))
else
pval.Q.b.random <- x$pval.Q.b.random
##
Q.resid <- x$Q.resid
df.Q.resid <- x$df.Q.resid
pval.Q.resid <- x$pval.Q.resid
##
tau2.resid <- x$tau2.resid
lower.tau2.resid <- x$lower.tau2.resid
upper.tau2.resid <- x$upper.tau2.resid
if (is.null(tau2.resid)) {
tau2.resid <- x$tau.resid^2
lower.tau2.resid <- upper.tau2.resid <- NA
}
tau.resid <- x$tau.resid
lower.tau.resid <- x$lower.tau.resid
upper.tau.resid <- x$upper.tau.resid
sign.lower.tau.resid <- x$sign.lower.tau.resid
sign.upper.tau.resid <- x$sign.lower.tau.resid
if (is.null(lower.tau.resid)) {
lower.tau.resid <- upper.tau.resid <- NA
sign.lower.tau.resid <- sign.upper.tau.resid <- ""
}
##
I2.resid <- x$I2.resid
lowI2.resid <- x$lower.I2.resid
uppI2.resid <- x$upper.I2.resid
}
else {
Q.b.common <- NA
Q.b.random <- NA
df.Q.b <- NA
df.Q.b.common <- NA
df.Q.b.random <- NA
}
}
##
hetstat.overall <- ""
##
if (overall.hetstat || is.character(hetstat)) {
##
hetstat.I2 <-
paste0(hetseparator,
formatN(100 * I2, digits.I2, "NA"), "%",
if (print.I2.ci && !(is.na(lowI2) | is.na(uppI2)))
pasteCI(100 * lowI2, 100 * uppI2,
digits.I2, big.mark,
text.NA = lab.NA, unit = "%"))
##
hetstat.tau2 <-
paste0(formatPT(tau2, digits = digits.tau2, big.mark = big.mark,
lab = TRUE, labval = "", lab.NA = "NA"),
if (print.tau2.ci && !(is.na(lower.tau2) | is.na(upper.tau2)))
pasteCI(lower.tau2, upper.tau2, digits.tau2, big.mark,
sign.lower.tau, sign.upper.tau, lab.NA))
##
hetstat.tau <-
paste0(formatPT(tau, digits = digits.tau, big.mark = big.mark,
lab = TRUE, labval = "", lab.NA = "NA"),
if (print.tau.ci && !(is.na(lower.tau) | is.na(upper.tau)))
pasteCI(lower.tau, upper.tau, digits.tau, big.mark,
sign.lower.tau, sign.upper.tau, lab.NA))
##
hetstat.Q <-
paste0(hetseparator,
formatN(Q, digits.Q, "NA", big.mark = big.mark),
if (revman5) ", df",
if (revman5) hetseparator,
if (revman5) df.Q)
##
hetstat.pval.Q <-
formatPT(pval.Q,
lab = TRUE, labval = "",
digits = digits.pval.Q,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA")
##
if (print.Rb)
hetstat.Rb <-
paste0(hetseparator,
formatN(100 * Rb, digits.I2, "NA", big.mark = big.mark),
"%",
if (print.Rb.ci && !(is.na(lowRb) | is.na(uppRb)))
pasteCI(100 * lowRb, 100 * uppRb,
digits.I2, big.mark,
text.NA = lab.NA, unit = "%"))
##
## Remove superfluous spaces
##
while(grepl(" ", hetstat.I2))
hetstat.I2 <- gsub(" ", " ", hetstat.I2)
while(grepl(" ", hetstat.tau2))
hetstat.tau2 <- gsub(" ", " ", hetstat.tau2)
while(grepl(" ", hetstat.Q))
hetstat.Q <- gsub(" ", " ", hetstat.Q)
while(grepl(" ", hetstat.pval.Q))
hetstat.pval.Q <- gsub(" ", " ", hetstat.pval.Q)
if (print.Rb)
while(grepl(" ", hetstat.Rb))
hetstat.Rb <- gsub(" ", " ", hetstat.Rb)
##
if (revman5)
hetstat.overall <- substitute(paste(hl,
"Tau"^2, ht, "; ",
"Chi"^2, hq,
" (",
P, hp,
"); ",
I^2, hi),
list(hl = hetlab,
hi = hetstat.I2,
ht = hetstat.tau2,
hq = hetstat.Q,
hp = hetstat.pval.Q))
else if (jama)
hetstat.overall <- substitute(paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi
),
list(hl = hetlab,
hi = hetstat.I2,
hq = hetstat.Q,
hp = hetstat.pval.Q,
df = df.Q))
else {
##
## One
##
if (print.I2 & !print.tau2.tau & !print.Q & !print.pval.Q & !print.Rb)
hetstat.overall <-
substitute(paste(hl, italic(I)^2, hi),
list(hl = hetlab, hi = hetstat.I2))
else if (!print.I2 & print.tau2.tau & !print.Q & !print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.overall <- substitute(paste(hl, tau^2, ht),
list(hl = hetlab, ht = hetstat.tau2))
else
hetstat.overall <- substitute(paste(hl, tau, ht),
list(hl = hetlab, ht = hetstat.tau))
else if (!print.I2 & !print.tau2.tau & print.Q & !print.pval.Q &
!print.Rb)
hetstat.overall <-
substitute(paste(hl, chi[df]^2, hq),
list(hl = hetlab, df = df.Q, hq = hetstat.Q))
else if (!print.I2 & !print.tau2.tau & !print.Q & print.pval.Q &
!print.Rb)
hetstat.overall <-
substitute(paste(hl, italic(p), hp),
list(hl = hetlab, hp = hetstat.pval.Q))
else if (!print.I2 & !print.tau2.tau & !print.Q & !print.pval.Q &
print.Rb)
hetstat.overall <-
substitute(paste(hl, italic(R)[italic(b)], hb),
list(hl = hetlab, hb = hetstat.Rb))
##
## Two
##
else if (print.I2 & print.tau2.tau & !print.Q & !print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl, italic(I)^2, hi,
", ",
tau^2, ht),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau2))
else
hetstat.overall <-
substitute(paste(hl, italic(I)^2, hi,
", ",
tau, ht),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau))
else if (print.I2 & !print.tau2.tau & print.Q & !print.pval.Q & !print.Rb)
hetstat.overall <-
substitute(paste(hl, italic(I)^2, hi,
", ",
chi[df]^2, hq),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, hq = hetstat.Q))
else if (print.I2 & !print.tau2.tau & !print.Q & print.pval.Q & !print.Rb)
hetstat.overall <-
substitute(paste(hl, italic(I)^2, hi,
", ",
italic(p), hp),
list(hl = hetlab,
hi = hetstat.I2, hp = hetstat.pval.Q))
else if (print.I2 & !print.tau2.tau & !print.Q & !print.pval.Q & print.Rb)
hetstat.overall <-
substitute(paste(hl, italic(I)^2, hi,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2, hb = hetstat.Rb))
else if (!print.I2 & print.tau2.tau & print.Q & !print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl, tau^2, ht,
", ",
chi[df]^2, hq),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau2, hq = hetstat.Q))
else
hetstat.overall <-
substitute(paste(hl, tau, ht,
", ",
chi[df]^2, hq),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau, hq = hetstat.Q))
else if (!print.I2 & print.tau2.tau & !print.Q & print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl, tau^2, ht,
", ",
italic(p), hp),
list(hl = hetlab,
ht = hetstat.tau2, hp = hetstat.pval.Q))
else
hetstat.overall <-
substitute(paste(hl, tau, ht,
", ",
italic(p), hp),
list(hl = hetlab,
ht = hetstat.tau, hp = hetstat.pval.Q))
else if (!print.I2 & print.tau2.tau & !print.Q & !print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl, tau^2, ht,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau2, hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl, tau, ht,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau, hb = hetstat.Rb))
else if (!print.I2 & !print.tau2.tau & print.Q & print.pval.Q & !print.Rb)
hetstat.overall <-
substitute(paste(hl, chi[df]^2, hq,
" (",
italic(p), hp, ")"),
list(hl = hetlab, df = df.Q,
hq = hetstat.Q, hp = hetstat.pval.Q))
else if (!print.I2 & !print.tau2.tau & print.Q & !print.pval.Q & print.Rb)
hetstat.overall <-
substitute(paste(hl, chi[df]^2, hq,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hq = hetstat.Q, hb = hetstat.Rb))
else if (!print.I2 & !print.tau2.tau & !print.Q & print.pval.Q & print.Rb)
hetstat.overall <-
substitute(paste(hl, italic(p), hp,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hp = hetstat.pval.Q, hb = hetstat.Rb))
##
## Three
##
else if (print.I2 & print.tau2.tau & print.Q & !print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau2,
hq = hetstat.Q))
else
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau,
hq = hetstat.Q))
else if (print.I2 & print.tau2.tau & !print.Q & print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(p), hp),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau2,
hp = hetstat.pval.Q))
else
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(p), hp),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau,
hp = hetstat.pval.Q))
else if (print.I2 & !print.tau2.tau & print.Q & print.pval.Q & !print.Rb)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2,
hq = hetstat.Q, hp = hetstat.pval.Q))
else if (!print.I2 & print.tau2.tau & print.Q & print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau2,
hq = hetstat.Q, hp = hetstat.pval.Q))
else
hetstat.overall <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau,
hq = hetstat.Q, hp = hetstat.pval.Q))
else if (print.I2 & print.tau2.tau & !print.Q & !print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau2,
hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau,
hb = hetstat.Rb))
else if (print.I2 & !print.tau2.tau & print.Q & !print.pval.Q & print.Rb)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2,
hq = hetstat.Q,
hb = hetstat.Rb))
else if (!print.I2 & print.tau2.tau & print.Q & !print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau2,
hq = hetstat.Q,
hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau,
hq = hetstat.Q,
hb = hetstat.Rb))
else if (print.I2 & !print.tau2.tau & !print.Q & print.pval.Q & print.Rb)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2, hp = hetstat.pval.Q,
hb = hetstat.Rb))
else if (!print.I2 & print.tau2.tau & !print.Q & print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
tau^2, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau2,
hp = hetstat.pval.Q,
hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl,
tau, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau,
hp = hetstat.pval.Q,
hb = hetstat.Rb))
else if (!print.I2 & !print.tau2.tau & print.Q & print.pval.Q & print.Rb)
hetstat.overall <-
substitute(paste(hl,
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hq = hetstat.Q, hp = hetstat.pval.Q,
hb = hetstat.Rb))
##
## Four
##
if (print.I2 & print.tau2.tau & print.Q & print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau2,
hq = hetstat.Q, hp = hetstat.pval.Q))
else
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau,
hq = hetstat.Q, hp = hetstat.pval.Q))
else if (print.I2 & print.tau2.tau & print.Q & !print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau2,
hq = hetstat.Q, hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau,
hq = hetstat.Q, hb = hetstat.Rb))
else if (print.I2 & print.tau2.tau & !print.Q & print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau2,
hp = hetstat.pval.Q, hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau,
hp = hetstat.pval.Q, hb = hetstat.Rb))
else if (print.I2 & !print.tau2.tau & print.Q & print.pval.Q & print.Rb)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2,
hq = hetstat.Q, hp = hetstat.pval.Q,
hb = hetstat.Rb))
else if (!print.I2 & print.tau2.tau & print.Q & print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau2,
hq = hetstat.Q, hp = hetstat.pval.Q,
hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau,
hq = hetstat.Q, hp = hetstat.pval.Q,
hb = hetstat.Rb))
##
## Five
##
else if (print.I2 & print.tau2.tau & print.Q & print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau2,
hq = hetstat.Q, hp = hetstat.pval.Q,
hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau,
hq = hetstat.Q, hp = hetstat.pval.Q,
hb = hetstat.Rb))
}
}
##
## Line with residual heterogeneity
##
hetstat.resid <- ""
##
if (by && (length(tau2.resid) == 0 || is.na(tau2.resid)))
print.tau2.tau.resid <- FALSE
else
print.tau2.tau.resid <- print.tau2.tau
##
if (resid.hetstat) {
##
hetstat.I2.resid <-
paste0(hetseparator,
formatN(100 * I2.resid, digits.I2, "NA"), "%",
if (print.I2.ci && !(is.na(lowI2.resid) | is.na(uppI2.resid)))
pasteCI(100 * lowI2.resid, 100 * uppI2.resid,
digits.I2, big.mark,
text.NA = lab.NA, unit = "%"))
##
hetstat.tau2.resid <-
paste0(formatPT(tau2.resid, digits = digits.tau2, big.mark = big.mark,
lab = TRUE, labval = "", lab.NA = "NA"),
if (print.tau2.ci &&
!(is.na(lower.tau2.resid) | is.na(upper.tau2.resid)))
pasteCI(lower.tau2.resid, upper.tau2.resid, digits.tau2,
big.mark,
sign.lower.tau.resid, sign.upper.tau.resid, lab.NA))
hetstat.tau.resid <-
paste0(formatPT(tau.resid, digits = digits.tau, big.mark = big.mark,
lab = TRUE, labval = "", lab.NA = "NA"),
if (print.tau.ci &&
!(is.na(lower.tau.resid) | is.na(upper.tau.resid)))
pasteCI(lower.tau.resid, upper.tau.resid, digits.tau,
big.mark,
sign.lower.tau.resid, sign.upper.tau.resid, lab.NA))
##
hetstat.Q.resid <-
paste0(hetseparator,
formatN(Q.resid, digits.Q, "NA", big.mark = big.mark),
if (revman5) ", df",
if (revman5) hetseparator,
if (revman5) df.Q.resid)
##
hetstat.pval.Q.resid <-
formatPT(pval.Q.resid,
lab = TRUE, labval = "",
digits = digits.pval.Q,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA")
##
hetstat.Rb.resid <- ""
print.Rb.resid <- FALSE
##
## Remove superfluous spaces
##
while(grepl(" ", hetstat.I2.resid))
hetstat.I2.resid <- gsub(" ", " ", hetstat.I2.resid)
while(grepl(" ", hetstat.tau2.resid))
hetstat.tau2.resid <- gsub(" ", " ", hetstat.tau2.resid)
while(grepl(" ", hetstat.tau.resid))
hetstat.tau.resid <- gsub(" ", " ", hetstat.tau.resid)
while(grepl(" ", hetstat.Q.resid))
hetstat.Q.resid <- gsub(" ", " ", hetstat.Q.resid)
while(grepl(" ", hetstat.pval.Q.resid))
hetstat.pval.Q.resid <- gsub(" ", " ", hetstat.pval.Q.resid)
while(grepl(" ", hetstat.Rb.resid))
hetstat.Rb.resid <- gsub(" ", " ", hetstat.Rb.resid)
##
if (revman5)
hetstat.resid <- substitute(paste(hl,
"Tau"^2, ht, "; ",
"Chi"^2, hq,
" (",
P, hp,
"); ",
I^2, hi),
list(hl = resid.hetlab,
hi = hetstat.I2.resid,
ht = hetstat.tau2.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid))
else if (jama)
hetstat.resid <- substitute(paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi
),
list(hl = resid.hetlab,
hi = hetstat.I2.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
df = df.Q.resid))
else {
##
## One
##
if (print.I2 & !print.tau2.tau.resid & !print.Q & !print.pval.Q &
!print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, italic(I)^2, hi),
list(hl = resid.hetlab, hi = hetstat.I2.resid))
else if (!print.I2 & print.tau2.tau.resid & !print.Q & !print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl, tau^2, ht),
list(hl = resid.hetlab, ht = hetstat.tau2.resid))
else
hetstat.resid <-
substitute(paste(hl, tau, ht),
list(hl = resid.hetlab, ht = hetstat.tau.resid))
else if (!print.I2 & !print.tau2.tau.resid & print.Q & !print.pval.Q &
!print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, chi[df]^2, hq),
list(hl = resid.hetlab, df = df.Q.resid, hq = hetstat.Q.resid))
else if (!print.I2 & !print.tau2.tau.resid & !print.Q & print.pval.Q &
!print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, italic(p), hp),
list(hl = resid.hetlab, hp = hetstat.pval.Q.resid))
else if (!print.I2 & !print.tau2.tau.resid & !print.Q & !print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, italic(R)[italic(b)], hb),
list(hl = resid.hetlab, hb = hetstat.Rb.resid))
##
## Two
##
else if (print.I2 & print.tau2.tau.resid & !print.Q & !print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl, italic(I)^2, hi,
", ",
tau^2, ht),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid))
else
hetstat.resid <-
substitute(paste(hl, italic(I)^2, hi,
", ",
tau, ht),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau.resid))
else if (print.I2 & !print.tau2.tau.resid & print.Q & !print.pval.Q &
!print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, italic(I)^2, hi,
", ",
chi[df]^2, hq),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, hq = hetstat.Q.resid))
else if (print.I2 & !print.tau2.tau.resid & !print.Q & print.pval.Q &
!print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, italic(I)^2, hi,
", ",
italic(p), hp),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, hp = hetstat.pval.Q.resid))
else if (print.I2 & !print.tau2.tau.resid & !print.Q & !print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, italic(I)^2, hi,
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, hb = hetstat.Rb.resid))
else if (!print.I2 & print.tau2.tau.resid & print.Q & !print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl, tau^2, ht,
", ",
chi[df]^2, hq),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau2.resid, hq = hetstat.Q.resid))
else
hetstat.resid <-
substitute(paste(hl, tau, ht,
", ",
chi[df]^2, hq),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau.resid, hq = hetstat.Q.resid))
else if (!print.I2 & print.tau2.tau.resid & !print.Q & print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl, tau^2, ht,
", ",
italic(p), hp),
list(hl = resid.hetlab,
ht = hetstat.tau2.resid, hp = hetstat.pval.Q.resid))
else
hetstat.resid <-
substitute(paste(hl, tau, ht,
", ",
italic(p), hp),
list(hl = resid.hetlab,
ht = hetstat.tau.resid, hp = hetstat.pval.Q.resid))
else if (!print.I2 & print.tau2.tau.resid & !print.Q & !print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl, tau^2, ht,
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
ht = hetstat.tau2.resid, hb = hetstat.Rb.resid))
else
hetstat.resid <-
substitute(paste(hl, tau, ht,
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
ht = hetstat.tau.resid, hb = hetstat.Rb.resid))
else if (!print.I2 & !print.tau2.tau.resid & print.Q & print.pval.Q &
!print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, chi[df]^2, hq,
" (",
italic(p), hp, ")"),
list(hl = resid.hetlab, df = df.Q.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid))
else if (!print.I2 & !print.tau2.tau.resid & print.Q & !print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, chi[df]^2, hq,
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
hq = hetstat.Q.resid, hb = hetstat.Rb.resid))
else if (!print.I2 & !print.tau2.tau.resid & !print.Q & print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, italic(p), hp,
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
hp = hetstat.pval.Q.resid, hb = hetstat.Rb.resid))
##
## Three
##
else if (print.I2 & print.tau2.tau.resid & print.Q & !print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid,
hq = hetstat.Q.resid))
else
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau.resid,
hq = hetstat.Q.resid))
else if (print.I2 & print.tau2.tau.resid & !print.Q & print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(p), hp),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid,
hp = hetstat.pval.Q.resid))
else
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(p), hp),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau.resid,
hp = hetstat.pval.Q.resid))
else if (print.I2 & !print.tau2.tau.resid & print.Q & print.pval.Q &
!print.Rb.resid)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid))
else if (!print.I2 & print.tau2.tau.resid & print.Q & print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau2.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid))
else
hetstat.resid <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid))
else if (print.I2 & print.tau2.tau.resid & !print.Q & !print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid,
hb = hetstat.Rb.resid))
else
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau.resid,
hb = hetstat.Rb.resid))
else if (print.I2 & !print.tau2.tau.resid & print.Q & !print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid,
hq = hetstat.Q.resid,
hb = hetstat.Rb.resid))
else if (!print.I2 & print.tau2.tau.resid & print.Q & !print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau2.resid,
hq = hetstat.Q.resid,
hb = hetstat.Rb.resid))
else
hetstat.resid <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau.resid,
hq = hetstat.Q.resid,
hb = hetstat.Rb.resid))
else if (print.I2 & !print.tau2.tau.resid & !print.Q & print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
else if (!print.I2 & print.tau2.tau.resid & !print.Q & print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
tau^2, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
ht = hetstat.tau2.resid,
hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
else
hetstat.resid <-
substitute(paste(hl,
tau, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
ht = hetstat.tau.resid,
hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
else if (!print.I2 & !print.tau2.tau.resid & print.Q & print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl,
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
##
## Four
##
if (print.I2 & print.tau2.tau.resid & print.Q & print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid))
else
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid))
else if (print.I2 & print.tau2.tau.resid & print.Q & !print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid,
hq = hetstat.Q.resid, hb = hetstat.Rb.resid))
else
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau.resid,
hq = hetstat.Q.resid, hb = hetstat.Rb.resid))
else if (print.I2 & print.tau2.tau.resid & !print.Q & print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid,
hp = hetstat.pval.Q.resid, hb = hetstat.Rb.resid))
else
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau.resid,
hp = hetstat.pval.Q.resid, hb = hetstat.Rb.resid))
else if (print.I2 & !print.tau2.tau.resid & print.Q & !print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau2.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
else if (!print.I2 & print.tau2.tau.resid & print.Q & print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau2.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
else
hetstat.resid <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
##
## Five
##
else if (print.I2 & print.tau2.tau.resid & print.Q & print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
else
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
}
}
##
## Label of test for overall effect
##
##
pvals.overall <- formatPT(c(x$pval.common, x$pval.random),
lab = TRUE, labval = "",
digits = digits.pval,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA")
statistics.overall <- formatN(c(x$statistic.common, x$statistic.random),
digits.stat, "NA", big.mark = big.mark)
##
## Remove superfluous spaces
##
pvals.overall <- rmSpace(pvals.overall, end = TRUE)
##
while(any(grepl(" ", pvals.overall)))
pvals.overall <- gsub(" ", " ", pvals.overall)
while(any(grepl(" ", statistics.overall)))
statistics.overall <- gsub(" ", " ", statistics.overall)
##
if (test.overall.common) {
if (print.stat) {
if (revman5)
text.overall.common <-
substitute(paste(tl,
Z, hetseparator, tt,
" (P", tp, ")"),
list(tl = label.test.overall.common,
hetseparator = hetseparator,
tt = statistics.overall[1],
tp = pvals.overall[1]))
else if (jama)
text.overall.common <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(P), tp, ")"),
list(tl = label.test.overall.common,
hetseparator = hetseparator,
tt = statistics.overall[1],
tp = pvals.overall[1]))
else
text.overall.common <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(p), tp, ")"),
list(tl = label.test.overall.common,
hetseparator = hetseparator,
tt = statistics.overall[1],
tp = pvals.overall[1]))
}
else {
if (revman5)
text.overall.common <-
substitute(paste(tl, " P", tp),
list(tl = label.test.overall.common,
tp = pvals.overall[1]))
else if (jama)
text.overall.common <-
substitute(paste(tl, " ", italic(P), tp),
list(tl = label.test.overall.common,
tp = pvals.overall[1]))
else
text.overall.common <-
substitute(paste(tl, " ", italic(p), tp),
list(tl = label.test.overall.common,
tp = pvals.overall[1]))
}
}
else
text.overall.common <- ""
##
hakn.kero <- x$method.random.ci[1] %in% c("HK", "KR")
##
if (test.overall.random) {
if (print.stat) {
if (!hakn.kero) {
if (revman5)
text.overall.random <-
substitute(paste(tl,
Z, hetseparator, tt,
" (P", tp, ")"),
list(tl = label.test.overall.random,
hetseparator = hetseparator,
tt = statistics.overall[2],
tp = pvals.overall[2]))
else if (jama)
text.overall.random <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(P), tp, ")"),
list(tl = label.test.overall.random,
hetseparator = hetseparator,
tt = statistics.overall[2],
tp = pvals.overall[2]))
else
text.overall.random <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(p), tp, ")"),
list(tl = label.test.overall.random,
hetseparator = hetseparator,
tt = statistics.overall[2],
tp = pvals.overall[2]))
}
else {
if (revman5)
text.overall.random <-
substitute(paste(tl,
t[df], hetseparator, tt,
" (P", tp, ")"),
list(tl = label.test.overall.random,
hetseparator = hetseparator,
tt = statistics.overall[2],
tp = pvals.overall[2],
df = round(x$df.random, 1)))
else if (jama)
text.overall.random <-
substitute(paste(tl,
italic(t)[df], hetseparator, tt,
" (", italic(P), tp, ")"),
list(tl = label.test.overall.random,
hetseparator = hetseparator,
tt = statistics.overall[2],
tp = pvals.overall[2],
df = round(x$df.random, 1)))
else
text.overall.random <-
substitute(paste(tl,
italic(t)[df], hetseparator, tt,
" (", italic(p), tp, ")"),
list(tl = label.test.overall.random,
hetseparator = hetseparator,
tt = statistics.overall[2],
tp = pvals.overall[2],
df = round(x$df.random, 1)))
}
}
else {
if (revman5)
text.overall.random <-
substitute(paste(tl, " P", tp),
list(tl = label.test.overall.random,
tp = pvals.overall[2]))
else if (jama)
text.overall.random <-
substitute(paste(tl, " ", italic(P), tp),
list(tl = label.test.overall.random,
tp = pvals.overall[2]))
else
text.overall.random <-
substitute(paste(tl, " ", italic(p), tp),
list(tl = label.test.overall.random,
tp = pvals.overall[2]))
}
}
else
text.overall.random <- ""
##
##
## Label of test for subgroup differences
##
if (by) {
Q.bs <- c(Q.b.common, Q.b.random)
pval.Q.bs <- c(pval.Q.b.common, pval.Q.b.random)
}
else {
Q.bs <- NA
pval.Q.bs <- NA
}
##
hetstat.Q.bs <-
paste0(hetseparator,
gsub(" ", "", formatN(Q.bs, digits.Q, "NA", big.mark = big.mark)),
if (!jama) ", df",
if (!jama) hetseparator,
if (!jama) c(df.Q.b.common,
if (length(df.Q.b.random) == 2)
paste(df.Q.b.random, collapse = ", ")
else
df.Q.b.random))
hetstat.Q.bs <- rmSpace(hetstat.Q.bs, end = TRUE)
##
hetstat.pval.Q.bs <-
paste0(formatPT(pval.Q.bs,
lab = TRUE, labval = "",
digits = digits.pval.Q,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA"))
##
## Remove superfluous spaces
##
hetstat.pval.Q.bs <- rmSpace(hetstat.pval.Q.bs, end = TRUE)
##
while(any(grepl(" ", hetstat.pval.Q.bs)))
hetstat.pval.Q.bs <- gsub(" ", " ", hetstat.pval.Q.bs)
while(any(grepl(" ", hetstat.Q.bs)))
hetstat.Q.bs <- gsub(" ", " ", hetstat.Q.bs)
##
if (test.subgroup.common) {
if (print.Q.subgroup) {
if (revman5)
text.subgroup.common <-
substitute(paste(tl,
"Chi"^2, tq,
" (P", tp, ")"),
list(tl = label.test.subgroup.common,
tq = hetstat.Q.bs[1],
tp = hetstat.pval.Q.bs[1]))
else if (jama)
text.subgroup.common <-
substitute(paste(tl,
chi[df]^2, tq,
" (", italic(P), tp, ")"),
list(tl = label.test.subgroup.common,
tq = hetstat.Q.bs[1],
tp = hetstat.pval.Q.bs[1],
df = df.Q.b.common))
else
text.subgroup.common <-
substitute(paste(tl,
chi[df]^2, tq,
" (", italic(p), tp, ")"),
list(tl = label.test.subgroup.common,
tq = hetstat.Q.bs[1],
tp = hetstat.pval.Q.bs[1],
df = df.Q.b.common))
}
else {
if (revman5)
text.subgroup.common <-
substitute(paste(tl, " P", tp),
list(tl = label.test.subgroup.common,
tp = hetstat.pval.Q.bs[1]))
else if (jama)
text.subgroup.common <-
substitute(paste(tl, " ", italic(P), tp),
list(tl = label.test.subgroup.common,
tp = hetstat.pval.Q.bs[1]))
else
text.subgroup.common <-
substitute(paste(tl, " ", italic(p), tp),
list(tl = label.test.subgroup.common,
tp = hetstat.pval.Q.bs[1]))
}
}
else
text.subgroup.common <- ""
if (test.subgroup.random) {
if (print.Q.subgroup) {
if (revman5) {
if (length(df.Q.b.random) == 2)
text.subgroup.random <-
substitute(paste(tl,
"F", tq,
" (P", tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.bs[2],
tp = hetstat.pval.Q.bs[2]))
else
text.subgroup.random <-
substitute(paste(tl,
"Chi"^2, tq,
" (P", tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.bs[2],
tp = hetstat.pval.Q.bs[2]))
}
else if (jama) {
if (length(df.Q.b.random) == 2)
text.subgroup.random <-
substitute(paste(tl,
F[df], tq,
" (", italic(P), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.bs[2],
tp = hetstat.pval.Q.bs[2],
df = paste(df.Q.b.random, collapse = ", ")))
else
text.subgroup.random <-
substitute(paste(tl,
chi[df]^2, tq,
" (", italic(P), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.bs[2],
tp = hetstat.pval.Q.bs[2],
df = df.Q.b.random))
}
else {
if (length(df.Q.b.random) == 2)
text.subgroup.random <-
substitute(paste(tl,
F[df], tq,
" (", italic(p), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.bs[2],
tp = hetstat.pval.Q.bs[2],
df = paste(df.Q.b.random, collapse = ", ")))
else
text.subgroup.random <-
substitute(paste(tl,
chi[df]^2, tq,
" (", italic(p), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.bs[2],
tp = hetstat.pval.Q.bs[2],
df = df.Q.b.random))
}
}
else {
if (revman5)
text.subgroup.random <-
substitute(paste(tl, " P", tp),
list(tl = label.test.subgroup.random,
tp = hetstat.pval.Q.bs[2]))
else if (jama)
text.subgroup.random <-
substitute(paste(tl, " ", italic(P), tp),
list(tl = label.test.subgroup.random,
tp = hetstat.pval.Q.bs[2]))
else
text.subgroup.random <-
substitute(paste(tl, " ", italic(p), tp),
list(tl = label.test.subgroup.random,
tp = hetstat.pval.Q.bs[2]))
}
}
else
text.subgroup.random <- ""
##
##
## (7) Prepare data for subgroup analysis
##
##
NAs <- rep(NA, n.com + n.ran + n.prd)
NAs.com <- rep(NA, n.com)
NAs.ran <- rep(NA, n.ran)
NAs.prd <- rep(NA, n.prd)
NAs.com1 <- rep(NA, n.com - 1)
NAs.ran1 <- rep(NA, n.ran - 1)
##
blanks <- rep("", n.com + n.ran + n.prd)
blanks.prd <- rep("", n.prd)
##
emp.com <- 1 + seq_len(n.com - 1)
emp.ran <- n.com + 1 + seq_len(n.ran - 1)
##
all.com <- seq_len(n.com)
all.ran <- n.com + seq_len(n.ran)
all.prd <- n.com + n.ran + seq_len(n.prd)
all.res <- c(all.com, all.ran, all.prd)
##
if (by) {
NAs.by <- rep(NA, n.by)
##
k.w.hetstat <- if (metabind) x$k.w.orig else x$k.w
o.w <- order(factor(x$subgroup.levels, levels = subgroup.levels))
k.w.hetstat <- k.w.hetstat[o.w]
if (hakn.kero)
df.random.w <- x$df.random.w[o.w]
##
TE.common.w <- ordermat(TE.common.w, subgroup.levels)
lower.common.w <- ordermat(lower.common.w, subgroup.levels)
upper.common.w <- ordermat(upper.common.w, subgroup.levels)
statistic.common.w <- ordermat(statistic.common.w, subgroup.levels)
pval.common.w <- ordermat(pval.common.w, subgroup.levels)
##
TE.random.w <- ordermat(TE.random.w, subgroup.levels)
lower.random.w <- ordermat(lower.random.w, subgroup.levels)
upper.random.w <- ordermat(upper.random.w, subgroup.levels)
statistic.random.w <- ordermat(statistic.random.w, subgroup.levels)
pval.random.w <- ordermat(pval.random.w, subgroup.levels)
##
lower.predict.w <- ordermat(lower.predict.w, subgroup.levels)
upper.predict.w <- ordermat(upper.predict.w, subgroup.levels)
##
Q.w <- x$Q.w[o.w]
pval.Q.w <- x$pval.Q.w[o.w]
##
I2.w <- x$I2.w[o.w]
lowI2.w <- x$lower.I2.w[o.w]
uppI2.w <- x$upper.I2.w[o.w]
##
Rb.w <- x$Rb.w[o.w]
lowRb.w <- x$lower.Rb.w[o.w]
uppRb.w <- x$upper.Rb.w[o.w]
##
tau2.w <- x$tau2.w[o.w]
tau.w <- x$tau.w[o.w]
##
w.common.w <- x$w.common.w[o.w]
w.random.w <- x$w.random.w[o.w]
e.e.w <- if (metaprop | metarate) x$event.w[o.w] else x$event.e.w[o.w]
t.e.w <- if (metainc | metarate) x$time.e.w[o.w] else NAs.by
n.e.w <-
if (metacor | metaprop | metamean | metarate)
x$n.w[o.w]
else
x$n.e.w[o.w]
e.c.w <- x$event.c.w[o.w]
t.c.w <- if (metainc) x$time.c.w[o.w] else NAs.by
n.c.w <- x$n.c.w[o.w]
n.harmonic.mean.w <- x$n.harmonic.mean.w[o.w]
t.harmonic.mean.w <- x$t.harmonic.mean.w[o.w]
##
k.all.w <- x$k.all.w[o.w]
k.study.w <- x$k.study.w[o.w]
k.w <- x$k.w[o.w]
k.TE.w <- x$k.TE.w[o.w]
##
subgroup.logical <- subgroup.logical[o.w]
subgroup.hetstat.logical <- subgroup.hetstat.logical[o.w]
##
prediction.subgroup.logical <-
prediction.subgroup.logical[o.w]
##
## Do (not) drop subgroups without studies in subgroup
## meta-analysis
##
if (allstudies)
sel.w <- rep(TRUE, length(k.all.w))
else
sel.w <- k.w > 0
##
if (hakn.kero)
df.random.w <- df.random.w[sel.w]
##
TE.common.w <- TE.common.w[repl(sel.w, n.com, n.by)]
lower.common.w <- lower.common.w[repl(sel.w, n.com, n.by)]
upper.common.w <- upper.common.w[repl(sel.w, n.com, n.by)]
statistic.common.w <- statistic.common.w[repl(sel.w, n.com, n.by)]
pval.common.w <- pval.common.w[repl(sel.w, n.com, n.by)]
##
TE.random.w <- TE.random.w[repl(sel.w, n.ran, n.by)]
lower.random.w <- lower.random.w[repl(sel.w, n.ran, n.by)]
upper.random.w <- upper.random.w[repl(sel.w, n.ran, n.by)]
statistic.random.w <- statistic.random.w[repl(sel.w, n.ran, n.by)]
pval.random.w <- pval.random.w[repl(sel.w, n.ran, n.by)]
##
lower.predict.w <- lower.predict.w[repl(sel.w, n.prd, n.by)]
upper.predict.w <- upper.predict.w[repl(sel.w, n.prd, n.by)]
##
Q.w <- Q.w[sel.w]
pval.Q.w <- pval.Q.w[sel.w]
##
I2.w <- I2.w[sel.w]
lowI2.w <- lowI2.w[sel.w]
uppI2.w <- uppI2.w[sel.w]
##
Rb.w <- Rb.w[sel.w]
lowRb.w <- lowRb.w[sel.w]
uppRb.w <- uppRb.w[sel.w]
##
tau2.w <- tau2.w[sel.w]
tau.w <- tau.w[sel.w]
##
w.common.w <- w.common.w[sel.w]
w.random.w <- w.random.w[sel.w]
e.e.w <- e.e.w[sel.w]
t.e.w <- t.e.w[sel.w]
n.e.w <- n.e.w[sel.w]
e.c.w <- e.c.w[sel.w]
t.c.w <- t.c.w[sel.w]
n.c.w <- n.c.w[sel.w]
n.harmonic.mean.w <- n.harmonic.mean.w[sel.w]
t.harmonic.mean.w <- t.harmonic.mean.w[sel.w]
##
k.all.w <- k.all.w[sel.w]
k.study.w <- k.study.w[sel.w]
k.w <- k.w[sel.w]
k.TE.w <- k.TE.w[sel.w]
##
subgroup.logical <- subgroup.logical[sel.w]
subgroup.hetstat.logical <- subgroup.hetstat.logical[sel.w]
##
prediction.subgroup.logical <-
prediction.subgroup.logical[sel.w]
##
subgroup.levels <- subgroup.levels[sel.w]
##
n.by <- length(subgroup.levels)
n.com.w <- n.com * n.by
n.ran.w <- n.ran * n.by
n.prd.w <- n.prd * n.by
##
NAs.by <- rep(NA, n.by)
NAs.com.w <- rep(NA, n.com.w)
NAs.ran.w <- rep(NA, n.ran.w)
NAs.prd.w <- rep(NA, n.prd.w)
NAs.stat.w <- rep(NA, 3 * n.by)
NAs.w <- rep(NA, n.com.w + n.ran.w + n.prd.w)
##
NAs.all <- c(NAs, NAs.w, NAs.stat.w)
##
blanks.com.w <- rep("", n.com.w)
blanks.ran.w <- rep("", n.ran.w)
blanks.prd.w <- rep("", n.prd.w)
blanks.stat.w <- rep("", 3 * n.by)
##
blanks.w <- rep("", n.com.w + n.ran.w + n.prd.w + 3 * n.by)
##
idx.com.w <- 1 + (seq_len(n.by) * n.com) - n.com
idx.ran.w <- 1 + (seq_len(n.by) * n.ran) - n.ran
idx.prd.w <- 1 + (seq_len(n.by) * n.prd) - n.prd
##
notfirst.com.w <- seq_len(n.com.w)[!(seq_len(n.com.w) %in% idx.com.w)]
notfirst.ran.w <- seq_len(n.ran.w)[!(seq_len(n.ran.w) %in% idx.ran.w)]
notfirst.prd.w <- seq_len(n.prd.w)[!(seq_len(n.prd.w) %in% idx.prd.w)]
##
## Do not consider limits of prediction intervals in subgroups to
## format confidence limits
##
sel.NA <- !repl(prediction.subgroup.logical, n.prd, n.by)
lower.predict.w[sel.NA] <- NA
upper.predict.w[sel.NA] <- NA
##
first.com.w <- n.com + n.ran + n.prd + idx.com.w
first.ran.w <- n.com + n.ran + n.prd + n.com.w + idx.ran.w
first.prd.w <- n.com + n.ran + n.prd + n.com.w + n.ran.w + idx.prd.w
##
all.com.w <-
c(seq_len(n.com),
n.com + n.ran + n.prd + seq_len(n.com.w))
all.ran.w <-
c(n.com + seq_len(n.ran),
n.com + n.ran + n.prd + n.com.w + seq_len(n.ran.w))
all.prd.w <-
c(all.prd, first.prd.w,
n.com + n.ran + n.prd + n.com.w + n.ran.w + seq_len(n.prd.w))
##
all.het.w <- n.com + n.ran + n.prd + n.com.w + n.ran.w + n.prd.w +
seq_len(n.by)
all.efc.w <- n.com + n.ran + n.prd + n.com.w + n.ran.w + n.prd.w +
n.by + seq_len(n.by)
all.efr.w <- n.com + n.ran + n.prd + n.com.w + n.ran.w + n.prd.w +
2 * n.by + seq_len(n.by)
##
all.stat.w <- c(all.het.w, all.efc.w, all.efr.w)
##
emp.w <- c(all.prd.w, all.stat.w)
emp.com.w <- c(1 + seq_len(n.com - 1),
n.com + n.ran + n.prd + notfirst.com.w)
emp.ran.w <- c(n.com + 1 + seq_len(n.ran - 1),
n.com + n.ran + n.prd + n.com.w + notfirst.ran.w)
emp.prd.w <- c(all.prd,
first.prd.w,
n.com + n.ran + n.prd + n.com.w + n.ran.w + notfirst.prd.w)
##
emp.w <- c(emp.com.w, emp.ran.w, emp.prd.w,
all.het.w, all.efc.w, all.efr.w)
##
sel.w <- c(first.com.w, first.ran.w, first.prd.w, all.stat.w)
##
if (!metainf.metacum & common) {
if (!overall) {
i <- 0
for (bylev.i in subgroup.levels) {
i <- i + 1
sel.i <- subgroup == bylev.i
x$w.common[sel.i] <- x$w.common[sel.i] / w.common.w[i]
}
w.common.w.p <- ifelse(is.na(w.common.w), NA, 100)
}
else {
if (!all(is.na(w.common.w)) && sum(w.common.w) > 0)
w.common.w.p <-
round(100 * w.common.w / sum(w.common.w, na.rm = TRUE),
digits.weight)
else
w.common.w.p <- w.common.w
}
}
else {
TE.common.w <- lower.common.w <- upper.common.w <- NAs.by
##
w.common.w.p <- NAs.by
##
missing.text.common.w <- missing(text.common.w)
missing.text.common.w <- is.na(argid(names(args), "text.common.w"))
if (!missing.text.common.w) {
text.common.w <-
deprecated(text.common.w, missing.text.common.w, args,
"text.common.w",
warn.deprecated)
missing.text.common.w <- FALSE
}
if (missing(text.common.w))
text.common.w <- rep("Overall", n.com.w)
}
##
if (!metainf.metacum & random) {
if (!overall) {
i <- 0
for (bylev.i in subgroup.levels) {
i <- i + 1
sel.i <- subgroup == bylev.i
x$w.random[sel.i] <- x$w.random[sel.i] / w.random.w[i]
}
w.random.w.p <- ifelse(is.na(w.random.w), NA, 100)
}
else {
if (!all(is.na(w.random.w)) && sum(w.random.w) > 0)
w.random.w.p <-
round(100 * w.random.w / sum(w.random.w, na.rm = TRUE),
digits.weight)
else
w.random.w.p <- w.random.w
}
}
else {
TE.random.w <- lower.random.w <- upper.random.w <- NAs.by
##
w.random.w.p <- NAs.ran.w
text.random.w <- blanks.ran.w
}
##
hetstat.w <- vector("list", n.by)
##
if (is.character(hetstat) || hetstat) {
##
hetstat.I2.w <-
paste0(hetseparator,
round(100 * I2.w, digits.I2), "%",
if (print.I2.ci)
ifelse(!(is.na(lowI2.w) | is.na(uppI2.w)),
pasteCI(100 * lowI2.w, 100 * uppI2.w,
digits.I2, big.mark,
text.NA = lab.NA, unit = "%"),
""))
##
hetstat.tau2.w <-
paste0(hetseparator,
ifelse(is.na(tau.w), "NA",
ifelse(tau2.w == 0, "0",
formatPT(tau2.w, digits = digits.tau2,
big.mark = big.mark, lab.NA = "NA"))))
##
hetstat.tau.w <-
paste0(hetseparator,
ifelse(is.na(tau.w), "NA",
ifelse(tau.w == 0, "0",
formatPT(tau.w, digits = digits.tau,
big.mark = big.mark, lab.NA = "NA"))))
##
hetstat.Q.w <-
paste0(hetseparator, round(Q.w, digits.Q),
if (revman5)
paste0(", df", hetseparator, k.w.hetstat - 1))
##
hetstat.pval.Q.w <-
paste0(formatPT(replaceNULL(pval.Q.w, pvalQ(Q.w, k.w - 1)),
lab = TRUE, labval = "",
digits = digits.pval.Q,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA"))
##
hetstat.Rb.w <-
paste0(hetseparator,
round(100 * Rb.w, digits.I2), "%",
if (print.Rb.ci)
ifelse(!(is.na(lowRb.w) | is.na(uppRb.w)),
pasteCI(100 * lowRb.w, 100 * uppRb.w,
digits.I2, big.mark,
text.NA = lab.NA, unit = "%"),
""))
##
## Remove superfluous spaces
##
hetstat.pval.Q.w <- rmSpace(hetstat.pval.Q.w, end = TRUE)
##
while(any(grepl(" ", hetstat.I2.w)))
hetstat.I2.w <- gsub(" ", " ", hetstat.I2.w)
while(any(grepl(" ", hetstat.tau2.w)))
hetstat.tau2.w <- gsub(" ", " ", hetstat.tau2.w)
while(any(grepl(" ", hetstat.tau.w)))
hetstat.tau.w <- gsub(" ", " ", hetstat.tau.w)
while(any(grepl(" ", hetstat.Q.w)))
hetstat.Q.w <- gsub(" ", " ", hetstat.Q.w)
while(any(grepl(" ", hetstat.pval.Q.w)))
hetstat.pval.Q.w <- gsub(" ", " ", hetstat.pval.Q.w)
while(any(grepl(" ", hetstat.Rb.w)))
hetstat.Rb.w <- gsub(" ", " ", hetstat.Rb.w)
##
for (i in seq_len(n.by)) {
if (revman5)
hetstat.w[[i]] <- substitute(paste(hl,
"Tau"^2, ht, "; ",
"Chi"^2, hq,
" (",
P, hp,
"); ",
I^2, hi),
list(hl = hetlab,
hi = hetstat.I2.w[i],
ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i]))
else if (jama)
hetstat.w[[i]] <- substitute(paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi
),
list(hl = hetlab,
hi = hetstat.I2.w[i],
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
df = k.w.hetstat[i] - 1))
else {
##
## One
##
if (print.I2 & !print.tau2.tau & !print.Q & !print.pval.Q & !print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, italic(I)^2, hi),
list(hl = hetlab, hi = hetstat.I2.w[i]))
else if (!print.I2 & print.tau2.tau & !print.Q & !print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl, tau^2, ht),
list(hl = hetlab, ht = hetstat.tau2.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl, tau, ht),
list(hl = hetlab, ht = hetstat.tau.w[i]))
else if (!print.I2 & !print.tau2.tau & print.Q & !print.pval.Q &
!print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, chi[df]^2, hq),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i]))
else if (!print.I2 & !print.tau2.tau & !print.Q & print.pval.Q &
!print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, italic(p), hp),
list(hl = hetlab, hp = hetstat.pval.Q.w[i]))
else if (!print.I2 & !print.tau2.tau & !print.Q & !print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, italic(R)[italic(b)], hb),
list(hl = hetlab, hb = hetstat.Rb.w[i]))
##
## Two
##
else if (print.I2 & print.tau2.tau & !print.Q & !print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl, italic(I)^2, hi,
", ",
tau^2, ht),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl, italic(I)^2, hi,
", ",
tau, ht),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i]))
else if (print.I2 & !print.tau2.tau & print.Q & !print.pval.Q &
!print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, italic(I)^2, hi,
", ",
chi[df]^2, hq),
list(hl = hetlab,
hi = hetstat.I2.w[i], hq = hetstat.Q.w[i]))
else if (print.I2 & !print.tau2.tau & !print.Q & print.pval.Q &
!print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, italic(I)^2, hi,
", ",
italic(p), hp),
list(hl = hetlab,
hi = hetstat.I2.w[i], hp = hetstat.pval.Q.w[i]))
else if (print.I2 & !print.tau2.tau & !print.Q & !print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, italic(I)^2, hi,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2.w[i], hb = hetstat.Rb.w[i]))
else if (!print.I2 & print.tau2.tau & print.Q & !print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl, tau^2, ht,
", ",
chi[df]^2, hq),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau2.w[i], hq = hetstat.Q.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl, tau, ht,
", ",
chi[df]^2, hq),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau.w[i], hq = hetstat.Q.w[i]))
else if (!print.I2 & print.tau2.tau & !print.Q & print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl, tau^2, ht,
", ",
italic(p), hp),
list(hl = hetlab,
ht = hetstat.tau2.w[i],
hp = hetstat.pval.Q.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl, tau, ht,
", ",
italic(p), hp),
list(hl = hetlab,
ht = hetstat.tau.w[i],
hp = hetstat.pval.Q.w[i]))
else if (!print.I2 & print.tau2.tau & !print.Q & !print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl, tau^2, ht,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau2.w[i], hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl, tau, ht,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau.w[i], hb = hetstat.Rb.w[i]))
else if (!print.I2 & !print.tau2.tau & print.Q & print.pval.Q &
!print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, chi[df]^2, hq,
" (",
italic(p), hp, ")"),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i]))
else if (!print.I2 & !print.tau2.tau & print.Q & !print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, chi[df]^2, hq,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i], hb = hetstat.Rb.w[i]))
else if (!print.I2 & !print.tau2.tau & !print.Q & print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, italic(p), hp,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hp = hetstat.pval.Q.w[i], hb = hetstat.Rb.w[i]))
##
## Three
##
else if (print.I2 & print.tau2.tau & print.Q & !print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i]))
else if (print.I2 & print.tau2.tau & !print.Q & print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(p), hp),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i],
hp = hetstat.pval.Q.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(p), hp),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i],
hp = hetstat.pval.Q.w[i]))
else if (print.I2 & !print.tau2.tau & print.Q & print.pval.Q &
!print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i]))
else if (!print.I2 & print.tau2.tau & print.Q & print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i]))
else if (print.I2 & print.tau2.tau & !print.Q & !print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i],
hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i],
hb = hetstat.Rb.w[i]))
else if (print.I2 & !print.tau2.tau & print.Q & !print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i],
hq = hetstat.Q.w[i],
hb = hetstat.Rb.w[i]))
else if (!print.I2 & print.tau2.tau & print.Q & !print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i],
hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i],
hb = hetstat.Rb.w[i]))
else if (print.I2 & !print.tau2.tau & !print.Q & print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2.w[i], hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
else if (!print.I2 & print.tau2.tau & !print.Q & print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
tau^2, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau2.w[i],
hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
tau, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau.w[i],
hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
else if (!print.I2 & !print.tau2.tau & print.Q & print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl,
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
##
## Four
##
if (print.I2 & print.tau2.tau & print.Q & print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i]))
else if (print.I2 & print.tau2.tau & print.Q & !print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i], hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i], hb = hetstat.Rb.w[i]))
else if (print.I2 & print.tau2.tau & !print.Q & print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i],
hp = hetstat.pval.Q.w[i], hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i],
hp = hetstat.pval.Q.w[i], hb = hetstat.Rb.w[i]))
else if (print.I2 & !print.tau2.tau & print.Q & print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2.w[i], df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
else if (!print.I2 & print.tau2.tau & print.Q & print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
##
## Five
##
else if (print.I2 & print.tau2.tau & print.Q & print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
}
if (hetstat.pooled != "study" &
!is.logical(text.subgroup.nohet) & k.w.hetstat[i] < 2)
hetstat.w[[i]] <- paste0(hetlab, text.subgroup.nohet)
}
}
##
TE.w <- c(TE.common.w, TE.random.w, NAs.prd.w, NAs.stat.w)
lowTE.w <-
c(lower.common.w, lower.random.w, lower.predict.w, NAs.stat.w)
uppTE.w <-
c(upper.common.w, upper.random.w, upper.predict.w, NAs.stat.w)
##
n.harmonic.mean.w <-
c(rep(n.harmonic.mean.w, n.com + n.ran + n.prd), NAs.stat.w)
t.harmonic.mean.w <-
c(rep(t.harmonic.mean.w, n.com + n.ran + n.prd), NAs.stat.w)
##
## Label of test for effect in subgroups
##
pvals.effect.w <-
formatPT(c(pval.common.w, pval.random.w),
lab = TRUE, labval = "",
digits = digits.pval,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA")
statistics.effect.w <-
formatN(c(statistic.common.w, statistic.random.w),
digits.stat, "NA", big.mark = big.mark)
##
## Remove superfluous spaces
##
pvals.effect.w <- rmSpace(pvals.effect.w, end = TRUE)
##
while(any(grepl(" ", pvals.effect.w)))
pvals.effect.w <- gsub(" ", " ", pvals.effect.w)
while(any(grepl(" ", statistics.effect.w)))
statistics.effect.w <- gsub(" ", " ", statistics.effect.w)
##
if (any(test.effect.subgroup.common.logical)) {
text.effect.subgroup.common <- vector("list", n.by)
for (i in seq_len(n.by)) {
if (print.stat) {
if (revman5)
text.effect.subgroup.common[[i]] <-
substitute(paste(tl,
Z, hetseparator, tt,
" (P", tp, ")"),
list(tl = label.test.effect.subgroup.common,
hetseparator = hetseparator,
tt = statistics.effect.w[i],
tp = rmSpace(pvals.effect.w[i], end = TRUE)))
else if (jama)
text.effect.subgroup.common[[i]] <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(P), tp, ")"),
list(tl = label.test.effect.subgroup.common,
hetseparator = hetseparator,
tt = statistics.effect.w[i],
tp = rmSpace(pvals.effect.w[i], end = TRUE)))
else
text.effect.subgroup.common[[i]] <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(p), tp, ")"),
list(tl = label.test.effect.subgroup.common,
hetseparator = hetseparator,
tt = statistics.effect.w[i],
tp = rmSpace(pvals.effect.w[i], end = TRUE)))
}
else {
if (revman5)
text.effect.subgroup.common[[i]] <-
substitute(paste(tl,
" P", tp),
list(tl = label.test.effect.subgroup.common,
tp = rmSpace(pvals.effect.w[i], end = TRUE)))
else if (jama)
text.effect.subgroup.common[[i]] <-
substitute(paste(tl,
" ", italic(P), tp),
list(tl = label.test.effect.subgroup.common,
tp = rmSpace(pvals.effect.w[i], end = TRUE)))
else
text.effect.subgroup.common[[i]] <-
substitute(paste(tl,
" ", italic(p), tp),
list(tl = label.test.effect.subgroup.common,
tp = rmSpace(pvals.effect.w[i], end = TRUE)))
}
}
}
else {
text.effect.subgroup.common <- vector("list", n.by)
for (i in seq_len(n.by))
text.effect.subgroup.common[[i]] <- ""
}
##
if (any(test.effect.subgroup.random.logical)) {
text.effect.subgroup.random <- vector("list", n.by)
for (i in seq_len(n.by)) {
if (print.stat) {
if (!hakn.kero) {
if (revman5)
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
Z, hetseparator, tt,
" (P", tp, ")"),
list(tl = label.test.effect.subgroup.random,
hetseparator = hetseparator,
tt = statistics.effect.w[n.by + i],
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE)))
else if (jama)
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(P), tp, ")"),
list(tl = label.test.effect.subgroup.random,
hetseparator = hetseparator,
tt = statistics.effect.w[n.by + i],
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE)))
else
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(p), tp, ")"),
list(tl = label.test.effect.subgroup.random,
hetseparator = hetseparator,
tt = statistics.effect.w[n.by + i],
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE)))
}
else {
if (revman5)
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
t[df], hetseparator, tt,
" (P", tp, ")"),
list(tl = label.test.effect.subgroup.random,
hetseparator = hetseparator,
tt = statistics.effect.w[n.by + i],
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE),
df = df.random.w[i]))
else if (jama)
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
italic(t)[df], hetseparator, tt,
" (", italic(P), tp, ")"),
list(tl = label.test.effect.subgroup.random,
hetseparator = hetseparator,
tt = statistics.effect.w[n.by + i],
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE),
df = df.random.w[i]))
else
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
italic(t)[df], hetseparator, tt,
" (", italic(p), tp, ")"),
list(tl = label.test.effect.subgroup.random,
hetseparator = hetseparator,
tt = statistics.effect.w[n.by + i],
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE),
df = df.random.w[i]))
}
}
else {
if (revman5)
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
" P", tp),
list(tl = label.test.effect.subgroup.random,
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE)))
else if (jama)
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
" ", italic(P)),
list(tl = label.test.effect.subgroup.random,
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE)))
else
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
" ", italic(p), tp),
list(tl = label.test.effect.subgroup.random,
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE)))
}
}
}
else {
text.effect.subgroup.random <- vector("list", n.by)
for (i in seq_len(n.by))
text.effect.subgroup.random[[i]] <- ""
}
}
##
##
## (8) Backtransform data
##
##
TE.orig <- TE
##
if (backtransf) {
##
## Freeman-Tukey Arcsin transformation
##
if (metainf.metacum | metabind) {
if (sm == "IRFT") {
npft <- x$t.harmonic.mean
npft.ma <- x$t.harmonic.mean.ma
}
else {
npft <- x$n.harmonic.mean
npft.ma <- x$n.harmonic.mean.ma
}
}
else {
if (sm == "IRFT") {
npft <- x$time
npft.ma <- 1 / mean(1 / x$time)
}
else {
npft <- x$n
npft.ma <- 1 / mean(1 / x$n)
}
}
##
## Individual study results
##
if (metaprop) {
TE <- x$event.e / x$n.e
}
else if (metarate) {
TE <- x$event.e / x$time.e
}
##
else if (!log.xaxis) {
TE <- backtransf(TE, sm, "mean", npft, fbt, abt)
lowTE <- backtransf(lowTE, sm, "lower", npft, fbt, abt)
uppTE <- backtransf(uppTE, sm, "upper", npft, fbt, abt)
}
##
## Results of meta-analysis
##
if (!log.xaxis) {
TE.common <- backtransf(TE.common, sm, "mean", npft.ma, fbt, abt)
lowTE.common <- backtransf(lowTE.common, sm, "lower", npft.ma, fbt, abt)
uppTE.common <- backtransf(uppTE.common, sm, "upper", npft.ma, fbt, abt)
##
TE.random <- backtransf(TE.random, sm, "mean", npft.ma, fbt, abt)
lowTE.random <- backtransf(lowTE.random, sm, "lower", npft.ma, fbt, abt)
uppTE.random <- backtransf(uppTE.random, sm, "upper", npft.ma, fbt, abt)
##
if (!metainf.metacum) {
lowTE.predict <-
backtransf(lowTE.predict, sm, "lower", npft.ma, fbt, abt)
uppTE.predict <-
backtransf(uppTE.predict, sm, "upper", npft.ma, fbt, abt)
}
##
if (by) {
if (sm == "IRFT")
npft.w <- t.harmonic.mean.w
else
npft.w <- n.harmonic.mean.w
##
TE.w <- backtransf(TE.w, sm, "mean", npft.w, fbt, abt)
lowTE.w <- backtransf(lowTE.w, sm, "lower", npft.w, fbt, abt)
uppTE.w <- backtransf(uppTE.w, sm, "upper", npft.w, fbt, abt)
}
}
##
## Apply argument 'pscale' to proportions / risk differences
##
if (is_prop(sm) | sm == "RD") {
TE <- pscale * TE
lowTE <- pscale * lowTE
uppTE <- pscale * uppTE
##
TE.common <- pscale * TE.common
lowTE.common <- pscale * lowTE.common
uppTE.common <- pscale * uppTE.common
##
TE.random <- pscale * TE.random
lowTE.random <- pscale * lowTE.random
uppTE.random <- pscale * uppTE.random
##
lowTE.predict <- pscale * lowTE.predict
uppTE.predict <- pscale * uppTE.predict
##
if (by) {
TE.w <- pscale * TE.w
lowTE.w <- pscale * lowTE.w
uppTE.w <- pscale * uppTE.w
}
}
}
##
## Apply argument 'irscale' to rates / incidence rate differences
##
if (is_rate(sm) | sm == "IRD") {
TE <- irscale * TE
lowTE <- irscale * lowTE
uppTE <- irscale * uppTE
##
TE.common <- irscale * TE.common
lowTE.common <- irscale * lowTE.common
uppTE.common <- irscale * uppTE.common
##
TE.random <- irscale * TE.random
lowTE.random <- irscale * lowTE.random
uppTE.random <- irscale * uppTE.random
##
lowTE.predict <- irscale * lowTE.predict
uppTE.predict <- irscale * uppTE.predict
##
if (by) {
TE.w <- irscale * TE.w
lowTE.w <- irscale * lowTE.w
uppTE.w <- irscale * uppTE.w
}
}
##
## Switch lower and upper limit for VE if results have been
## backtransformed
##
if (backtransf & sm == "VE") {
tmp.l <- lowTE
lowTE <- uppTE
uppTE <- tmp.l
##
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.w
lowTE.w <- uppTE.w
uppTE.w <- tmp.l
}
}
##
## Exclude study results from forest plot
##
TE.exclude <- TE
lowTE.exclude <- lowTE
uppTE.exclude <- uppTE
##
if (!null.exclude) {
TE.exclude[exclude] <- NA
lowTE.exclude[exclude] <- NA
uppTE.exclude[exclude] <- NA
}
##
if (!common) {
TE.common <- NAs.com
lowTE.common <- NAs.com
uppTE.common <- NAs.com
##
if (by) {
TE.common.w <- NAs.com.w
lowTE.common.w <- NAs.com.w
uppTE.common.w <- NAs.com.w
}
}
##
method.random.ci <- x$method.random.ci
##
if (!random) {
TE.random <- NAs.ran
lowTE.random <- NAs.ran
uppTE.random <- NAs.ran
##
if (by) {
TE.random.w <- NAs.ran.w
lowTE.random.w <- NAs.ran.w
uppTE.random.w <- NAs.ran.w
}
}
##
if (!prediction) {
lowTE.predict <- NAs.prd
uppTE.predict <- NAs.prd
}
##
if (!metainf.metacum) {
if (by & !overall)
w.common.p <- round(100 * x$w.common, digits.weight)
else {
if (!all(is.na(x$w.common)) && sum(x$w.common) > 0) {
if (is.matrix(x$w.common))
w.common.p <-
round(apply(x$w.common, 2, calcPercent), digits.weight)
else
w.common.p <-
round(calcPercent(x$w.common), digits.weight)
}
else
w.common.p <- x$w.common
}
##
if (by & !overall)
w.random.p <- round(100 * x$w.random, digits.weight)
else {
if (!all(is.na(x$w.random)) && sum(x$w.random) > 0) {
if (is.matrix(x$w.random))
w.random.p <-
round(apply(x$w.random, 2, calcPercent), digits.weight)
else
w.random.p <-
round(calcPercent(x$w.random), digits.weight)
}
else
w.random.p <- x$w.random
}
}
else {
w.common.p <- rep(NA, length(TE))
w.random.p <- rep(NA, length(TE))
}
##
if (is.matrix(w.common.p))
w.common.p <- as.vector(w.common.p[, 1])
if (is.matrix(w.random.p))
w.random.p <- as.vector(w.random.p[, 1])
##
##
## (9) Determine column labels
##
##
labs <- list()
##
if (lsel) {
if (missing(leftlabs) || length(leftcols) != length(leftlabs)) {
for (i in seq_along(leftcols)) {
j <- match(leftcols[i], colnames)
if (!is.na(j))
labs[[paste0("lab.", leftcols[i])]] <- labnames[j]
}
}
else if (length(leftcols) == length(leftlabs)) {
for (i in seq_along(leftcols)) {
j <- match(leftcols[i], colnames)
if (!is.na(leftlabs[i]))
labs[[paste0("lab.", leftcols[i])]] <- leftlabs[i]
else
if (!is.na(j))
labs[[paste0("lab.", leftcols[i])]] <- labnames[j]
}
}
}
##
if (missing(rightlabs) || length(rightcols) != length(rightlabs)) {
for (i in seq_along(rightcols)) {
j <- match(rightcols[i], colnames)
if (!is.na(j))
labs[[paste0("lab.", rightcols[i])]] <- labnames[j]
}
}
else if (length(rightcols) == length(rightlabs)) {
for (i in seq_along(rightcols)) {
j <- match(rightcols[i], colnames)
if (!is.na(rightlabs[i]))
labs[[paste0("lab.", rightcols[i])]] <- rightlabs[i]
else
if (!is.na(j))
labs[[paste0("lab.", rightcols[i])]] <- labnames[j]
}
}
##
if (!slab)
labs[["lab.studlab"]] <- ""
##
## Check for "%" in weight labels
##
w.common.percent <- TRUE
if (!is.null(labs[["lab.w.common"]])) {
if (grepl("%", labs[["lab.w.common"]]))
w.common.percent <- FALSE
}
##
w.random.percent <- TRUE
if (!is.null(labs[["lab.w.random"]])) {
if (grepl("%", labs[["lab.w.random"]]))
w.random.percent <- FALSE
}
## "studlab", "TE", "seTE",
## "cluster",
## "n.e", "n.c",
## "event.e", "event.c",
## "mean.e", "mean.c",
## "sd.e", "sd.c",
## "cor",
## "time.e", "time.c",
## "pval", "tau2", "tau", "I2" (for metainf.metacum)
##
## Check for "\n" in label of column 'studlab'
##
clines <- twolines(labs[["lab.studlab"]], "studlab")
##
if (clines$newline) {
newline.studlab <- TRUE
labs[["lab.studlab"]] <- clines$bottom
add.studlab <- clines$top
longer.studlab <- clines$longer
}
else {
newline.studlab <- FALSE
longer.studlab <- labs[["lab.studlab"]]
}
##
## Check for "\n" in label of column 'TE'
##
clines <- twolines(labs[["lab.TE"]], "TE")
##
if (clines$newline) {
newline.TE <- TRUE
labs[["lab.TE"]] <- clines$bottom
add.TE <- clines$top
longer.TE <- clines$longer
}
else {
newline.TE <- FALSE
longer.TE <- labs[["lab.TE"]]
}
##
## Check for "\n" in label of column 'seTE'
##
clines <- twolines(labs[["lab.seTE"]], "seTE")
##
if (clines$newline) {
newline.seTE <- TRUE
labs[["lab.seTE"]] <- clines$bottom
add.seTE <- clines$top
longer.seTE <- clines$longer
}
else {
newline.seTE <- FALSE
longer.seTE <- labs[["lab.seTE"]]
}
##
## Check for "\n" in label of column 'cluster'
##
clines <- twolines(labs[["lab.cluster"]], "cluster")
##
if (clines$newline) {
newline.cluster <- TRUE
labs[["lab.cluster"]] <- clines$bottom
add.cluster <- clines$top
longer.cluster <- clines$longer
}
else {
newline.cluster <- FALSE
longer.cluster <- labs[["lab.cluster"]]
}
##
## Check for "\n" in label of column 'n.e'
##
clines <- twolines(labs[["lab.n.e"]], "n.e")
##
if (clines$newline) {
newline.n.e <- TRUE
labs[["lab.n.e"]] <- clines$bottom
add.n.e <- clines$top
longer.n.e <- clines$longer
}
else {
newline.n.e <- FALSE
longer.n.e <- labs[["lab.n.e"]]
}
##
## Check for "\n" in label of column 'n.c'
##
clines <- twolines(labs[["lab.n.c"]], "n.c")
##
if (clines$newline) {
newline.n.c <- TRUE
labs[["lab.n.c"]] <- clines$bottom
add.n.c <- clines$top
longer.n.c <- clines$longer
}
else {
newline.n.c <- FALSE
longer.n.c <- labs[["lab.n.c"]]
}
##
## Check for "\n" in label of column 'event.e'
##
clines <- twolines(labs[["lab.event.e"]], "event.e")
##
if (clines$newline) {
newline.event.e <- TRUE
labs[["lab.event.e"]] <- clines$bottom
add.event.e <- clines$top
longer.event.e <- clines$longer
}
else {
newline.event.e <- FALSE
longer.event.e <- labs[["lab.event.e"]]
}
##
## Check for "\n" in label of column 'event.c'
##
clines <- twolines(labs[["lab.event.c"]], "event.c")
##
if (clines$newline) {
newline.event.c <- TRUE
labs[["lab.event.c"]] <- clines$bottom
add.event.c <- clines$top
longer.event.c <- clines$longer
}
else {
newline.event.c <- FALSE
longer.event.c <- labs[["lab.event.c"]]
}
##
## Check for "\n" in label of column 'mean.e'
##
clines <- twolines(labs[["lab.mean.e"]], "mean.e")
##
if (clines$newline) {
newline.mean.e <- TRUE
labs[["lab.mean.e"]] <- clines$bottom
add.mean.e <- clines$top
longer.mean.e <- clines$longer
}
else {
newline.mean.e <- FALSE
longer.mean.e <- labs[["lab.mean.e"]]
}
##
## Check for "\n" in label of column 'mean.c'
##
clines <- twolines(labs[["lab.mean.c"]], "mean.c")
##
if (clines$newline) {
newline.mean.c <- TRUE
labs[["lab.mean.c"]] <- clines$bottom
add.mean.c <- clines$top
longer.mean.c <- clines$longer
}
else {
newline.mean.c <- FALSE
longer.mean.c <- labs[["lab.mean.c"]]
}
##
## Check for "\n" in label of column 'sd.e'
##
clines <- twolines(labs[["lab.sd.e"]], "sd.e")
##
if (clines$newline) {
newline.sd.e <- TRUE
labs[["lab.sd.e"]] <- clines$bottom
add.sd.e <- clines$top
longer.sd.e <- clines$longer
}
else {
newline.sd.e <- FALSE
longer.sd.e <- labs[["lab.sd.e"]]
}
##
## Check for "\n" in label of column 'sd.c'
##
clines <- twolines(labs[["lab.sd.c"]], "sd.c")
##
if (clines$newline) {
newline.sd.c <- TRUE
labs[["lab.sd.c"]] <- clines$bottom
add.sd.c <- clines$top
longer.sd.c <- clines$longer
}
else {
newline.sd.c <- FALSE
longer.sd.c <- labs[["lab.sd.c"]]
}
##
## Check for "\n" in label of column 'cor'
##
clines <- twolines(labs[["lab.cor"]], "cor")
##
if (clines$newline) {
newline.cor <- TRUE
labs[["lab.cor"]] <- clines$bottom
add.cor <- clines$top
longer.cor <- clines$longer
}
else {
newline.cor <- FALSE
longer.cor <- labs[["lab.cor"]]
}
##
## Check for "\n" in label of column 'time.e'
##
clines <- twolines(labs[["lab.time.e"]], "time.e")
##
if (clines$newline) {
newline.time.e <- TRUE
labs[["lab.time.e"]] <- clines$bottom
add.time.e <- clines$top
longer.time.e <- clines$longer
}
else {
newline.time.e <- FALSE
longer.time.e <- labs[["lab.time.e"]]
}
##
## Check for "\n" in label of column 'time.c'
##
clines <- twolines(labs[["lab.time.c"]], "time.c")
##
if (clines$newline) {
newline.time.c <- TRUE
labs[["lab.time.c"]] <- clines$bottom
add.time.c <- clines$top
longer.time.c <- clines$longer
}
else {
newline.time.c <- FALSE
longer.time.c <- labs[["lab.time.c"]]
}
##
## Check for "\n" in label of column 'effect'
##
clines <- twolines(labs[["lab.effect"]], "effect")
##
if (clines$newline) {
newline.effect <- TRUE
labs[["lab.effect"]] <- clines$bottom
add.effect <- clines$top
longer.effect <- clines$longer
}
else {
newline.effect <- FALSE
longer.effect <- labs[["lab.effect"]]
}
##
## Check for "\n" in label of column 'ci'
##
clines <- twolines(labs[["lab.ci"]], "ci")
##
if (clines$newline) {
newline.ci <- TRUE
labs[["lab.ci"]] <- clines$bottom
add.ci <- clines$top
longer.ci <- clines$longer
}
else {
newline.ci <- FALSE
longer.ci <- labs[["lab.ci"]]
}
##
## Check for "\n" in label of column 'effect.ci'
##
clines <- twolines(labs[["lab.effect.ci"]], "effect.ci")
##
if (clines$newline) {
newline.effect.ci <- TRUE
labs[["lab.effect.ci"]] <- clines$bottom
add.effect.ci <- clines$top
longer.effect.ci <- clines$longer
}
else {
newline.effect.ci <- FALSE
longer.effect.ci <- labs[["lab.effect.ci"]]
}
##
## Check for "\n" in label of column 'w.common'
##
clines <- twolines(labs[["lab.w.common"]], "w.common")
##
if (clines$newline) {
newline.w.common <- TRUE
labs[["lab.w.common"]] <- clines$bottom
add.w.common <- clines$top
longer.w.common <- clines$longer
}
else {
newline.w.common <- FALSE
longer.w.common <- labs[["lab.w.common"]]
}
##
## Check for "\n" in label of column 'w.random'
##
clines <- twolines(labs[["lab.w.random"]], "w.random")
##
if (clines$newline) {
newline.w.random <- TRUE
labs[["lab.w.random"]] <- clines$bottom
add.w.random <- clines$top
longer.w.random <- clines$longer
}
else {
newline.w.random <- FALSE
longer.w.random <- labs[["lab.w.random"]]
}
##
## Check for "\n" in label of column 'pval'
##
clines <- twolines(labs[["lab.pval"]], "pval")
##
if (clines$newline) {
newline.pval <- TRUE
labs[["lab.pval"]] <- clines$bottom
add.pval <- clines$top
longer.pval <- clines$longer
}
else {
newline.pval <- FALSE
longer.pval <- labs[["lab.pval"]]
}
##
## Check for "\n" in label of column 'tau2'
##
clines <- twolines(labs[["lab.tau2"]], "tau2")
##
if (clines$newline) {
newline.tau2 <- TRUE
labs[["lab.tau2"]] <- clines$bottom
add.tau2 <- clines$top
longer.tau2 <- clines$longer
}
else {
newline.tau2 <- FALSE
longer.tau2 <- labs[["lab.tau2"]]
}
##
## Check for "\n" in label of column 'tau'
##
clines <- twolines(labs[["lab.tau"]], "tau")
##
if (clines$newline) {
newline.tau <- TRUE
labs[["lab.tau"]] <- clines$bottom
add.tau <- clines$top
longer.tau <- clines$longer
}
else {
newline.tau <- FALSE
longer.tau <- labs[["lab.tau"]]
}
##
## Check for "\n" in label of column 'I2'
##
clines <- twolines(labs[["lab.I2"]], "I2")
##
if (clines$newline) {
newline.I2 <- TRUE
labs[["lab.I2"]] <- clines$bottom
add.I2 <- clines$top
longer.I2 <- clines$longer
}
else {
newline.I2 <- FALSE
longer.I2 <- labs[["lab.I2"]]
}
##
## Check for "\n" in argument 'smlab'
##
clines <- twolines(smlab, arg = TRUE)
##
if (clines$newline) {
smlab1 <- clines$top
smlab2 <- clines$bottom
##
newline.smlab <- TRUE
}
else {
smlab1 <- smlab
smlab2 <- ""
##
newline.smlab <- FALSE
}
##
## Check for "\n" in argument 'xlab'
##
clines <- twolines(xlab, arg = TRUE)
##
if (clines$newline) {
newline.xlab <- TRUE
xlab <- clines$top
xlab.add <- clines$bottom
}
else {
xlab.add <- ""
newline.xlab <- FALSE
}
##
## Check for "\n" in argument 'label.left'
##
clines <- twolines(label.left, arg = TRUE)
##
if (clines$newline) {
ll1 <- clines$top
ll2 <- clines$bottom
##
newline.ll <- TRUE
}
else {
ll1 <- label.left
ll2 <- ""
##
newline.ll <- FALSE
}
##
## Check for "\n" in argument 'label.right'
##
clines <- twolines(label.right, arg = TRUE)
##
if (clines$newline) {
lr1 <- clines$top
lr2 <- clines$bottom
##
newline.lr <- TRUE
}
else {
lr1 <- label.right
lr2 <- ""
##
newline.lr <- FALSE
}
##
## Check for "\n" in additional columns
##
newline.addcol.left <- FALSE
newline.addcol.right <- FALSE
##
if (newcols) {
if (length(leftcols.new) > 0) {
for (i in seq_along(leftcols.new)) {
## Check for "\n" in label of new column
clines <- twolines(leftlabs.new[i], leftcols.new[i])
newline.addcol.left <- c(newline.addcol.left, clines$newline)
}
newline.addcol.right <- sum(newline.addcol.right) > 0
}
if (length(leftcols.new) > 0) {
for (i in seq_along(leftcols.new)) {
## Check for "\n" in label of new column
clines <- twolines(leftlabs.new[i], leftcols.new[i])
newline.addcol.left <- c(newline.addcol.left, clines$newline)
}
newline.addcol.left <- sum(newline.addcol.left) > 0
}
}
##
newline <- newline.studlab | newline.effect | newline.ci | newline.effect.ci |
newline.w.common | newline.w.random | newline.TE | newline.seTE |
newline.cluster |
newline.n.e | newline.n.c | newline.event.e | newline.event.c |
newline.mean.e | newline.mean.c | newline.sd.e | newline.sd.c |
newline.cor | newline.time.e | newline.time.c |
newline.pval | newline.tau2 | newline.tau | newline.I2 |
newline.smlab | newline.addcol.left | newline.addcol.right
##
newline.all <- newline | (!newline & (newline.ll | newline.lr) & !addrow)
##
##
## (10) Define columns in forest plot as well as x- and y-limits
##
##
type.common <-
deprecated(type.common, missing(type.common),
args, "type.common",
warn.deprecated)
##
type.subgroup.common <-
deprecated(type.subgroup.common, missing.type.subgroup.common,
args, "type.subgroup.common",
warn.deprecated)
##
col.inside.common <-
deprecated(col.inside.common, missing(col.inside.common),
args, "col.inside.common",
warn.deprecated)
##
if (by) {
##
subgroup.name <-
bylabel(subgroup.name, subgroup.levels, print.subgroup.name,
sep.subgroup, big.mark = big.mark)
##
wrong.common <- FALSE
wrong.random <- FALSE
wrong.predict <- FALSE
##
if (n.by > 1) {
if (length(text.common.w) == 1)
text.common.w <- rep(text.common.w, n.com.w)
else if (length(text.common.w) == n.com)
text.common.w <- rep(text.common.w, n.by)
else if (length(text.common.w) == n.by)
text.common.w <- rep(text.common.w, n.com)
else
wrong.common <- TRUE
##
if (length(text.random.w) == 1)
text.random.w <- rep(text.random.w, n.ran.w)
else if (length(text.random.w) == n.ran)
text.random.w <- rep(text.random.w, n.by)
else if (length(text.random.w) == n.by)
text.random.w <- rep(text.random.w, n.ran)
else
wrong.random <- TRUE
##
if (length(text.predict.w) == 1)
text.predict.w <- rep(text.predict.w, n.prd.w)
else if (length(text.predict.w) == n.prd)
text.predict.w <- rep(text.predict.w, n.by)
else if (length(text.predict.w) == n.by)
text.predict.w <- rep(text.predict.w, n.prd)
else
wrong.predict <- TRUE
}
else if (n.by == 1) {
if (length(text.common.w) != n.com)
wrong.common <- TRUE
if (length(text.random.w) != n.ran)
wrong.random <- TRUE
if (length(text.predict.w) != n.prd)
wrong.predict <- TRUE
}
##
if (wrong.common)
stop("Argument 'text.common.w' must be a single character string",
if (n.by > 1 | n.com > 1)
paste0(" or of length\n -", n.by, " (number of subgroups) or",
" \n -", n.com, " (number of common effect analyses)")
else
".")
##
if (wrong.random)
stop("Argument 'text.random.w' must be a single character string",
if (n.by > 1 | n.ran > 1)
paste0(" or of length\n -", n.by, " (number of subgroups) or",
" \n -", n.ran, " (number of random effects analyses)")
else
".")
##
if (wrong.predict)
stop("Argument 'text.predict.w' must be a single character string",
if (n.by > 1 | n.prd > 1)
paste0(" or of length\n -", n.by, " (number of subgroups) or",
" \n -", n.prd, " (number of prediction intervals)")
else
".")
##
if (hetstat.pooled == "common") {
text.common <- hetstat.overall
text.common.w <- hetstat.w
hetstat <- FALSE
}
else if (hetstat.pooled == "random") {
text.random <- hetstat.overall
text.random.w <- hetstat.w
hetstat <- FALSE
}
else if (hetstat.pooled == "study") {
studlab <- hetstat.w
hetstat <- FALSE
}
##
modlabs <- c(text.common, text.random, text.predict,
hetstat.overall, hetstat.resid,
text.overall.common, text.overall.random,
text.subgroup.common, text.subgroup.random,
text.addline1, text.addline2,
subgroup.name, text.common.w, text.random.w, text.predict.w,
hetstat.w,
unlist(text.effect.subgroup.common),
unlist(text.effect.subgroup.random),
studlab)
##
TEs <- c(TE.common, TE.random, NAs.prd, TE.w, TE)
lowTEs <- c(lowTE.common, lowTE.random, lowTE.predict, lowTE.w, lowTE)
uppTEs <- c(uppTE.common, uppTE.random, uppTE.predict, uppTE.w, uppTE)
##
TEs.exclude <- c(TE.common, TE.random, NAs.prd,
TE.w, TE.exclude)
lowTEs.exclude <- c(lowTE.common, lowTE.random, lowTE.predict, lowTE.w,
lowTE.exclude)
uppTEs.exclude <- c(uppTE.common, uppTE.random, uppTE.predict, uppTE.w,
uppTE.exclude)
##
TEs.study <- c(blanks, blanks.w,
formatN(TE.orig, digits.TE, lab.NA, big.mark = big.mark))
##
seTEs.study <- c(blanks, blanks.w,
formatN(seTE, digits.se, lab.NA, big.mark = big.mark))
##
w.commons <- c(NAs.com, NAs.ran, NAs.prd,
NAs.com.w, NAs.ran.w, NAs.prd.w,
NAs.stat.w,
w.common.p)
w.randoms <- c(NAs.com, NAs.ran, NAs.prd,
NAs.com.w, NAs.ran.w, NAs.prd.w,
NAs.stat.w,
w.random.p)
##
format.w.commons <- c(rep(100, n.com), NAs.ran, NAs.prd,
repl(w.common.w.p, n.com, n.by),
NAs.ran.w, NAs.prd.w, NAs.stat.w,
w.common.p)
format.w.randoms <- c(NAs.com, rep(100, n.ran), NAs.prd,
NAs.com.w,
repl(w.random.w.p, n.ran, n.by),
NAs.prd.w, NAs.stat.w,
w.random.p)
##
Wc.format <-
formatN(format.w.commons, digits.weight, text.NA = lab.NA.weight)
Wr.format <-
formatN(format.w.randoms, digits.weight, text.NA = lab.NA.weight)
##
sel.common <- Wc.format == lab.NA.weight
sel.random <- Wr.format == lab.NA.weight
##
sel.common[first.ran.w] <- TRUE
sel.random[first.com.w] <- TRUE
##
type.pooled <- c(rep(type.common, n.com),
rep(type.random, n.ran),
rep("predict", n.prd),
rep(type.subgroup.common, n.com.w),
rep(type.subgroup.random, n.ran.w),
rep("predict", n.prd.w),
blanks.stat.w)
col.diamond.pooled <-
c(rep(col.diamond.common, n.com),
rep(col.diamond.random, n.ran),
rep(col.predict, n.prd),
rep(col.diamond.common, n.com.w),
rep(col.diamond.random, n.ran.w),
rep(col.predict, n.prd.w),
NAs.stat.w)
col.diamond.lines.pooled <-
c(rep(col.diamond.lines.common, n.com),
rep(col.diamond.lines.random, n.ran),
rep(col.predict.lines, n.prd),
rep(col.diamond.lines.common, n.com.w),
rep(col.diamond.lines.random, n.ran.w),
rep(col.predict.lines, n.prd.w),
NAs.stat.w)
col.inside.pooled <-
c(rep(col.inside.common, n.com),
rep(col.inside.random, n.ran),
blanks.prd,
rep(col.inside.common, n.com.w),
rep(col.inside.random, n.ran.w),
rep("", n.prd.w),
NAs.stat.w)
}
else {
##
if (hetstat.pooled == "common")
text.common <- hetstat.overall
else if (hetstat.pooled == "random")
text.random <- hetstat.overall
##
modlabs <- c(text.common, text.random, text.predict,
hetstat.overall, hetstat.resid,
text.overall.common, text.overall.random,
text.subgroup.common, text.subgroup.random,
text.addline1, text.addline2,
studlab)
##
TEs <- c(TE.common, TE.random, NAs.prd, TE)
lowTEs <- c(lowTE.common, lowTE.random, lowTE.predict, lowTE)
uppTEs <- c(uppTE.common, uppTE.random, uppTE.predict, uppTE)
##
TEs.exclude <- c(TE.common, TE.random, NAs.prd, TE.exclude)
lowTEs.exclude <- c(lowTE.common, lowTE.random,
lowTE.predict, lowTE.exclude)
uppTEs.exclude <- c(uppTE.common, uppTE.random,
uppTE.predict, uppTE.exclude)
##
TEs.study <- c(blanks,
formatN(TE.orig, digits.TE, lab.NA, big.mark = big.mark))
seTEs.study <- c(blanks,
formatN(seTE, digits.se, lab.NA, big.mark = big.mark))
##
w.commons <- c(NAs, w.common.p)
w.randoms <- c(NAs, w.random.p)
##
format.w.common <- formatN(c(100, w.common.p), digits.weight)
format.w.random <- formatN(c(100, w.random.p), digits.weight)
##
Wc.format <- c(rep(format.w.common[1], n.com),
rep(lab.NA.weight, n.ran),
blanks.prd,
format.w.common[-1])
Wr.format <- c(rep(lab.NA.weight, n.com),
rep(format.w.random[1], n.ran),
blanks.prd,
format.w.random[-1])
##
sel.common <- Wc.format == lab.NA.weight
sel.random <- Wr.format == lab.NA.weight
##
type.pooled <- c(rep(type.common, n.com),
rep(type.random, n.ran),
rep("predict", n.prd))
##
col.diamond.pooled <-
c(rep(col.diamond.common, n.com),
rep(col.diamond.random, n.ran),
rep(col.predict, n.prd))
##
col.diamond.lines.pooled <-
c(rep(col.diamond.lines.common, n.com),
rep(col.diamond.lines.random, n.ran),
rep(col.predict.lines, n.prd))
##
col.inside.pooled <- c(rep(col.inside.common, n.com),
rep(col.inside.random, n.ran),
blanks.prd)
}
##
## Treatment effect and confidence interval
##
if (backtransf & log.xaxis) {
effect.format <-
formatN(exp(TEs), digits, lab.NA.effect, big.mark = big.mark)
ci.format <-
ifelse(is.na(lowTEs) | is.na(uppTEs), lab.NA.effect,
formatCI(formatN(exp(lowTEs), digits = digits, text.NA = lab.NA,
big.mark = big.mark),
formatN(exp(uppTEs), digits = digits, text.NA = lab.NA,
big.mark = big.mark)))
}
else {
effect.format <- formatN(TEs, digits, lab.NA.effect, big.mark = big.mark)
ci.format <-
ifelse(is.na(lowTEs) | is.na(uppTEs), lab.NA.effect,
formatCI(formatN(lowTEs, digits = digits, text.NA = lab.NA,
big.mark = big.mark),
formatN(uppTEs, digits = digits, text.NA = lab.NA,
big.mark = big.mark)))
}
effect.ci.format <- paste0(effect.format,
ifelse(is.na(TEs), "", " "),
ci.format)
##
## No treatment effect for prediction interval
##
effect.format[all.prd] <- ""
##
## Only print prediction interval if requested
##
if (!prediction) {
ci.format[all.prd] <- ""
effect.ci.format[all.prd] <- ""
}
##
## No treatment effect and confidence interval in statistics lines
##
if (by) {
effect.format[all.stat.w] <- ""
ci.format[all.stat.w] <- ""
effect.ci.format[all.stat.w] <- ""
}
##
## Weights of common and random effects model
##
Wc.format <- paste0(Wc.format, if (w.common.percent) "%")
Wr.format <- paste0(Wr.format, if (w.random.percent) "%")
##
Wc.format[Wc.format == "%"] <- ""
Wr.format[Wr.format == "%"] <- ""
##
Wc.format[sel.common] <- lab.NA.weight
Wr.format[sel.random] <- lab.NA.weight
##
## Treatment estimate and its standard error
##
TE.format <- TEs.study
seTE.format <- seTEs.study
##
## Number of patients, events, and person times
##
if (!is.null(x$n.e.pooled))
sum.n.e <- x$n.e.pooled
else
sum.n.e <- sum(x$n.e, na.rm = TRUE)
##
if (!is.null(x$n.c.pooled))
sum.n.c <- x$n.c.pooled
else
sum.n.c <- sum(x$n.c, na.rm = TRUE)
##
if (!is.null(x$event.e.pooled))
sum.e.e <- x$event.e.pooled
else
sum.e.e <- sum(x$event.e, na.rm = TRUE)
##
if (!is.null(x$event.c.pooled))
sum.e.c <- x$event.c.pooled
else
sum.e.c <- sum(x$event.c, na.rm = TRUE)
##
if (!is.null(x$time.e.pooled))
sum.t.e <- x$time.e.pooled
else
sum.t.e <- sum(x$time.e, na.rm = TRUE)
##
if (!is.null(x$time.c.pooled))
sum.t.c <- x$time.c.pooled
else
sum.t.c <- sum(x$time.c, na.rm = TRUE)
##
if (is.character(x$cluster))
as.character.cluster <- TRUE
else if (is.factor(x$cluster)) {
if (anyNA(suppressWarnings(as.numeric(as.character(x$cluster)))))
as.character.cluster <- TRUE
else
as.character.cluster <- FALSE
##
x$cluster <- as.character(x$cluster)
}
else
as.character.cluster <- FALSE
##
if (by) {
if (pooled.totals) {
Ne <- c(c(sum.n.e, NAs.com1),
c(sum.n.e, NAs.ran1),
NAs.prd,
repl(n.e.w, n.com, n.by),
repl(n.e.w, n.ran, n.by),
NAs.prd.w, NAs.stat.w,
x$n.e)
Nc <- c(c(sum.n.c, NAs.com1),
c(sum.n.c, NAs.ran1),
NAs.prd,
repl(n.c.w, n.com, n.by),
repl(n.c.w, n.ran, n.by),
NAs.prd.w, NAs.stat.w,
x$n.c)
}
else {
Ne <- c(NAs.all, x$n.e)
Nc <- c(NAs.all, x$n.c)
}
if (pooled.events) {
Ee <- c(c(sum.e.e, NAs.com1),
c(sum.e.e, NAs.ran1),
NAs.prd,
repl(e.e.w, n.com, n.by),
repl(e.e.w, n.ran, n.by),
NAs.prd.w, NAs.stat.w,
x$event.e)
Ec <- c(c(sum.e.c, NAs.com1),
c(sum.e.c, NAs.ran1),
NAs.prd,
repl(e.c.w, n.com, n.by),
repl(e.c.w, n.ran, n.by),
NAs.prd.w, NAs.stat.w,
x$event.c)
}
else {
Ee <- c(NAs.all, x$event.e)
Ec <- c(NAs.all, x$event.c)
}
if (pooled.times) {
Te <- c(c(sum.t.e, NAs.com1),
c(sum.t.e, NAs.ran1),
NAs.prd,
repl(t.e.w, n.com, n.by),
repl(t.e.w, n.ran, n.by),
NAs.prd.w, NAs.stat.w,
x$time.e)
Tc <- c(c(sum.t.c, NAs.com1),
c(sum.t.c, NAs.ran1),
NAs.prd,
repl(t.c.w, n.com, n.by),
repl(t.c.w, n.ran, n.by),
NAs.prd.w, NAs.stat.w,
x$time.c)
}
else {
Te <- c(NAs.all, x$time.e)
Tc <- c(NAs.all, x$time.c)
}
}
else {
if (pooled.totals) {
Ne <- c(c(sum.n.e, NAs.com1),
c(sum.n.e, NAs.ran1),
NAs.prd,
x$n.e)
Nc <- c(c(sum.n.c, NAs.com1),
c(sum.n.c, NAs.ran1),
NAs.prd,
x$n.c)
}
else {
Ne <- c(NAs,
x$n.e)
Nc <- c(NAs,
x$n.c)
}
if (pooled.events) {
Ee <- c(c(sum.e.e, NAs.com1),
c(sum.e.e, NAs.ran1),
NAs.prd,
x$event.e)
Ec <- c(c(sum.e.c, NAs.com1),
c(sum.e.c, NAs.ran1),
NAs.prd,
x$event.c)
}
else {
Ee <- c(NAs,
x$event.e)
Ec <- c(NAs,
x$event.c)
}
if (pooled.times) {
Te <- c(c(sum.t.e, NAs.com1),
c(sum.t.e, NAs.ran1),
NAs.prd,
x$time.e)
Tc <- c(c(sum.t.c, NAs.com1),
c(sum.t.c, NAs.ran1),
NAs.prd,
x$time.c)
}
else {
Te <- c(NAs,
x$time.e)
Tc <- c(NAs,
x$time.c)
}
}
##
if (by) {
bla <- rep("", length(Ne))
scom.w <- sran.w <- sprd.w <- bla
scom.w[first.com.w] <- "yes"
sran.w[first.ran.w] <- "yes"
sprd.w[first.prd.w] <- "yes"
##
ncom.w <- nran.w <- nprd.w <- notfirst <- bla
ncom.w[emp.com.w] <- "yes"
nran.w[emp.ran.w] <- "yes"
nprd.w[emp.prd.w] <- "yes"
notfirst[emp.w] <- "yes"
##
if (FALSE)
print(data.frame(TEs = round(TEs, 2),
lowTEs = round(lowTEs, 2),
uppTEs = round(uppTEs, 2)
))
if (FALSE)
print(data.frame(row = c(paste0("C", seq_len(n.com)),
paste0("R", seq_len(n.ran)),
paste0("P", seq_len(n.prd)),
paste0("C.w", seq_len(n.com.w)),
paste0("R.w", seq_len(n.ran.w)),
paste0("P.w", seq_len(n.prd.w)),
paste0("het.w", seq_len(n.by)),
paste0("efc.w", seq_len(n.by)),
paste0("efr.w", seq_len(n.by)),
paste0("TE", seq_len(k.all))),
Ne, notfirst))
}
Ne.format <- formatN(Ne, digits = 0, text.NA = lab.NA, big.mark = big.mark)
Nc.format <- formatN(Nc, digits = 0, text.NA = lab.NA, big.mark = big.mark)
Ee.format <- formatN(Ee, digits = 0, text.NA = lab.NA, big.mark = big.mark)
Ec.format <- formatN(Ec, digits = 0, text.NA = lab.NA, big.mark = big.mark)
##
if (all(is_wholenumber(Te), na.rm = TRUE) & missing.digits.time)
Te.format <-
formatN(Te, digits = 0, text.NA = lab.NA, big.mark = big.mark)
else
Te.format <- formatN(Te, digits.time, lab.NA, big.mark = big.mark)
##
if (all(is_wholenumber(Tc), na.rm = TRUE) & missing.digits.time)
Tc.format <-
formatN(Tc, digits = 0, text.NA = lab.NA, big.mark = big.mark)
else
Tc.format <- formatN(Tc, digits.time, lab.NA, big.mark = big.mark)
##
## Print nothing in lines with prediction interval
##
Ne.format[all.prd] <- Nc.format[all.prd] <- ""
Ee.format[all.prd] <- Ec.format[all.prd] <- ""
Te.format[all.prd] <- Tc.format[all.prd] <- ""
Wc.format[all.prd] <- Wr.format[all.prd] <- ""
Wc.format[emp.com] <- Wr.format[emp.com] <- ""
Wc.format[emp.ran] <- Wr.format[emp.ran] <- ""
##
if (by) {
##
## Print nothing in selected subgroup lines
##
Ne.format[emp.w] <- Nc.format[emp.w] <- ""
Ee.format[emp.w] <- Ec.format[emp.w] <- ""
Te.format[emp.w] <- Tc.format[emp.w] <- ""
Wc.format[emp.w] <- Wr.format[emp.w] <- ""
}
##
if (common.random) {
##
## Print nothing in lines with results for random effects model
##
Ne.format[all.ran] <- Nc.format[all.ran] <- ""
Ee.format[all.ran] <- Ec.format[all.ran] <- ""
Te.format[all.ran] <- Tc.format[all.ran] <- ""
##
if (by) {
Ne.format[all.ran.w] <- Nc.format[all.ran.w] <- ""
Ee.format[all.ran.w] <- Ec.format[all.ran.w] <- ""
Te.format[all.ran.w] <- Tc.format[all.ran.w] <- ""
}
}
##
## Print nothing in lines for second, third etc. common effect or
## random effects model
##
Ne.format[emp.com] <- Nc.format[emp.com] <- ""
Ee.format[emp.com] <- Ec.format[emp.com] <- ""
Te.format[emp.com] <- Tc.format[emp.com] <- ""
##
Ne.format[emp.ran] <- Nc.format[emp.ran] <- ""
Ee.format[emp.ran] <- Ec.format[emp.ran] <- ""
Te.format[emp.ran] <- Tc.format[emp.ran] <- ""
##
if (by) {
Ne.format[emp.com.w] <- Nc.format[emp.com.w] <- ""
Ee.format[emp.com.w] <- Ec.format[emp.com.w] <- ""
Te.format[emp.com.w] <- Tc.format[emp.com.w] <- ""
##
Ne.format[emp.ran.w] <- Nc.format[emp.ran.w] <- ""
Ee.format[emp.ran.w] <- Ec.format[emp.ran.w] <- ""
Te.format[emp.ran.w] <- Tc.format[emp.ran.w] <- ""
}
##
## Only print total number of events if pooled.events is TRUE
##
if (!pooled.events) {
Ee.format[all.com] <- Ec.format[all.com] <- ""
Ee.format[all.ran] <- Ec.format[all.ran] <- ""
##
if (by) {
Ee.format[all.com.w] <- Ec.format[all.com.w] <- ""
Ee.format[all.ran.w] <- Ec.format[all.ran.w] <- ""
}
}
##
## Only print total person times if pooled.times is TRUE
##
if (!pooled.times) {
Te.format[all.com] <- Tc.format[all.com] <- ""
Te.format[all.ran] <- Tc.format[all.ran] <- ""
##
if (by) {
Te.format[all.com.w] <- Tc.format[all.com.w] <- ""
Te.format[all.ran.w] <- Tc.format[all.ran.w] <- ""
}
}
##
## Mean and standard deviation
##
if (by) {
Me <- c(NAs.all, x$mean.e)
Mc <- c(NAs.all, x$mean.c)
Se <- c(NAs.all, x$sd.e)
Sc <- c(NAs.all, x$sd.c)
}
else {
Me <- c(NAs, x$mean.e)
Mc <- c(NAs, x$mean.c)
Se <- c(NAs, x$sd.e)
Sc <- c(NAs, x$sd.c)
}
##
digits.R <- options()$digits
##
if (is.null(digits.mean)) {
if (all(is_wholenumber(Me), na.rm = TRUE))
Me.format <-
formatN(Me, digits = 0, text.NA = lab.NA, big.mark = big.mark)
else
Me.format <-
formatN(Me, digits = digits.R, text.NA = lab.NA, big.mark = big.mark)
##
if (all(is_wholenumber(Mc), na.rm = TRUE))
Mc.format <-
formatN(Mc, digits = 0, text.NA = lab.NA, big.mark = big.mark)
else
Mc.format <-
formatN(Mc, digits = digits.R, text.NA = lab.NA, big.mark = big.mark)
}
else {
Me.format <- formatN(Me, digits.mean, lab.NA, big.mark = big.mark)
Mc.format <- formatN(Mc, digits.mean, lab.NA, big.mark = big.mark)
}
if (is.null(digits.sd)) {
if (all(is_wholenumber(Se), na.rm = TRUE))
Se.format <-
formatN(Se, digits = 0, text.NA = lab.NA, big.mark = big.mark)
else
Se.format <-
formatN(Se, digits = digits.R, text.NA = lab.NA, big.mark = big.mark)
##
if (all(is_wholenumber(Sc), na.rm = TRUE))
Sc.format <-
formatN(Sc, digits = 0, text.NA = lab.NA, big.mark = big.mark)
else
Sc.format <-
formatN(Sc, digits = digits.R, text.NA = lab.NA, big.mark = big.mark)
}
else {
Se.format <- formatN(Se, digits.sd, lab.NA, big.mark = big.mark)
Sc.format <- formatN(Sc, digits.sd, lab.NA, big.mark = big.mark)
}
##
## Print nothing for lines with summary results
##
Me.format[all.res] <- Mc.format[all.res] <-
Se.format[all.res] <- Sc.format[all.res] <- ""
##
if (by) {
Me.format[sel.w] <- Mc.format[sel.w] <- ""
Se.format[sel.w] <- Sc.format[sel.w] <- ""
}
##
## Correlation
##
if (by)
cor <- c(NAs.all, x$cor)
else
cor <- c(NAs, x$cor)
##
if (is.null(digits.cor))
cor.format <- formatN(cor, digits = digits.R, text.NA = lab.NA)
else
cor.format <- formatN(cor, digits.cor, lab.NA, big.mark = big.mark)
##
## Print nothing for lines with summary results
##
cor.format[all.res] <- ""
##
if (by)
cor.format[sel.w] <- ""
##
## P-value of effect
##
pval.format <-
formatPT(c(x$pval.common, x$pval.random, NAs.prd, x$pval),
digits = digits.pval,
big.mark = big.mark,
lab = FALSE, labval = "",
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = lab.NA)
pval.format[all.prd] <- ""
##
## Cluster variable
##
if (by)
cluster.format <- c(NAs.all, x$cluster)
else
cluster.format <- c(NAs, x$cluster)
##
## Print nothing for lines with summary results
##
cluster.format[all.res] <- ""
##
if (by)
cluster.format[sel.w] <- ""
##
## Leave-one-out / cumulative meta-analysis
##
if (metainf.metacum) {
tau2.format <- c(x$tau2.overall, x$tau2.overall, NA, x$tau2)
tau.format <- c(x$tau.overall, x$tau.overall, NA, x$tau)
I2.format <- c(x$I2.overall, x$I2.overall, NA, x$I2)
##
tau2.format <- formatPT(tau2.format, digits = digits.tau2,
big.mark = big.mark,
lab = FALSE, labval = "",
lab.NA = lab.NA)
tau.format <- formatPT(tau.format, digits = digits.tau,
big.mark = big.mark,
lab = FALSE, labval = "",
lab.NA = lab.NA)
I2.format <- formatN(100 * I2.format, digits.I2, lab.NA)
I2.format <- paste0(I2.format, ifelse(I2.format == lab.NA, "", "%"))
##
## Print nothing for lines with prediction interval
##
tau2.format[all.prd] <- tau.format[all.prd] <- I2.format[all.prd] <- ""
}
##
##
## y-axis:
##
##
if ((!(metaprop | metacor) &
(any(rightcols %in% c("n.e", "n.c")) |
any(leftcols %in% c("n.e", "n.c")))
) |
(metainc &
(any(rightcols %in% c("time.e", "time.c")) |
any(leftcols %in% c("time.e", "time.c")))
) |
(metacont &
(any(rightcols %in% c("sd.e", "sd.c")) |
any(leftcols %in% c("sd.e", "sd.c")))
) |
(metamean &
(any(rightcols %in% c("sd.e")) |
any(leftcols %in% c("sd.e")))
) |
(!is.null(label.e.attach) & !is.null(label.e)) |
(!is.null(label.c.attach) & !is.null(label.c)) |
newline.all
) {
yHead <- 2
yHeadadd <- 1
}
else {
yHead <- 1
yHeadadd <- NA
}
##
if (!by) {
N <- n.stud
if (study.results)
yTE <- 1:N
else
yTE <- rep(NA, N)
}
else {
##
j <- 1
k <- 0
yBylab <- NAs.by
yTE <- rep(NA, n.stud)
yTE.common.w <- rep(yBylab, n.com)
yTE.random.w <- rep(yBylab, n.ran)
yTE.predict.w <- rep(yBylab, n.prd)
yTE.hetstat.w <- yBylab
yTE.effect.common.w <- yBylab
yTE.effect.random.w <- yBylab
##
seq.com.w <- seq_len(n.com)
seq.ran.w <- seq_len(n.ran)
seq.prd.w <- seq_len(n.prd)
##
n.by.i <- 0
##
for (i in seq_len(n.by)) {
##
if (allstudies)
k.i <- k.all.w[i]
else
k.i <- k.TE.w[i]
##
k <- k + k.i
##
if (print.subgroup.labels) {
yBylab[i] <- j
j <- j + 1
}
##
if (study.results) {
yTE[(k - k.i + 1):k] <- j:(j + k.i - 1)
j <- j + k.i
}
else
yTE[(k - k.i + 1):k] <- NA
##
## Common effect model
##
if (common & subgroup.logical[i]) {
yTE.common.w[n.by.i * n.com + seq.com.w] <-
j + seq.com.w - 1
j <- j + max(seq.com.w)
}
else
yTE.common.w[n.by.i * n.com + seq.com.w] <- NA
##
## Random effects model
##
if (random & subgroup.logical[i]) {
yTE.random.w[n.by.i * n.ran + seq.ran.w] <-
j + seq.ran.w - 1
j <- j + max(seq.ran.w)
}
else
yTE.random.w[n.by.i * n.ran + seq.ran.w] <- NA
##
## Only pooled totals
##
if (pooled.totals & subgroup.logical[i] & !(common | random)) {
yTE.common.w[n.by.i * n.com + seq.com.w] <-
j + seq.com.w - 1
j <- j + max(seq.com.w)
}
##
## Prediction interval in subgroups
##
##yTE.predict.w[n.by.i * n.prd + seq.prd.w] <- NA
##
if (prediction.subgroup.logical[i]) {
yTE.predict.w[n.by.i * n.prd + seq.prd.w] <-
j + seq.prd.w - 1
j <- j + max(seq.prd.w)
}
##
## Heterogeneity statistics
##
if (subgroup.hetstat.logical[i]) {
yTE.hetstat.w[i] <- j
j <- j + 1
}
else
yTE.hetstat.w[i] <- NA
##
## Test for effect in subgroup (common effect)
##
if (test.effect.subgroup.common.logical[i]) {
yTE.effect.common.w[i] <- j
j <- j + 1
}
else
yTE.effect.common.w[i] <- NA
##
## Test for effect in subgroup (random effects)
##
if (test.effect.subgroup.random.logical[i]) {
yTE.effect.random.w[i] <- j
j <- j + 1
}
else
yTE.effect.random.w[i] <- NA
##
y.w.i <- c(yTE.common.w[i], yTE.random.w[i], yTE.predict.w[i],
yTE.hetstat.w[i],
yTE.effect.common.w[i],
yTE.effect.random.w[i])
##
if (!study.results & !any(!is.na(y.w.i))) {
yBylab[i] <- NA
if (print.subgroup.labels)
j <- j - 1
}
##
if (!is.na(yBylab[i]) & addrow.subgroups)
j <- j + 1
##
n.by.i <- n.by.i + 1
}
##
if (!addrow.subgroups)
j <- j + 1
##
yTE.w <- c(yTE.common.w, yTE.random.w, yTE.predict.w, yTE.hetstat.w,
yTE.effect.common.w, yTE.effect.random.w)
}
##
##
## x-axis:
##
##
if (notmiss.xlim && is.numeric(xlim[1]))
if (log.xaxis)
xlim <- log(xlim)
##
if (is.null(xlim)) {
if (metaprop | metarate) {
xlim <- c(min(lowTEs, na.rm = TRUE),
max(uppTEs, na.rm = TRUE))
##
if (!is.na(ref) && ref < xlim[1])
xlim[1] <- ref
if (!is.na(ref) && ref > xlim[2])
xlim[2] <- ref
##
if (!is.na(lower.equi) && lower.equi < xlim[1])
xlim[1] <- lower.equi
if (!is.na(lower.equi) && lower.equi > xlim[2])
xlim[2] <- lower.equi
##
if (!is.na(upper.equi) && upper.equi < xlim[1])
xlim[1] <- upper.equi
if (!is.na(upper.equi) && upper.equi > xlim[2])
xlim[2] <- upper.equi
}
else {
sel.low <- is.finite(lowTEs)
sel.upp <- is.finite(uppTEs)
##
if (all(!sel.low))
minTE <- -0.5
else
minTE <- min(lowTEs[sel.low], na.rm = TRUE)
if (all(!sel.upp))
maxTE <- 0.5
else
maxTE <- max(uppTEs[sel.upp], na.rm = TRUE)
##
xlim <- c(minTE, maxTE)
##
if (!is.na(ref) && ref < xlim[1])
xlim[1] <- ref
if (!is.na(ref) && ref > xlim[2])
xlim[2] <- ref
##
if (!is.na(lower.equi) && lower.equi < xlim[1])
xlim[1] <- lower.equi
if (!is.na(lower.equi) && lower.equi > xlim[2])
xlim[2] <- lower.equi
##
if (!is.na(upper.equi) && upper.equi < xlim[1])
xlim[1] <- upper.equi
if (!is.na(upper.equi) && upper.equi > xlim[2])
xlim[2] <- upper.equi
}
}
##
symmetric <- FALSE
##
if (!is.null(xlim) && is.character(xlim[1])) {
##
xlim <- setchar(xlim, "symmetric",
paste0("should be a numeric vector (min, max) or ",
"the character string \"symmetric\""))
symmetric <- TRUE
##
if (metaprop | metarate | metamean) {
xlim <- c(min(lowTEs, na.rm = TRUE),
max(uppTEs, na.rm = TRUE))
}
else {
sel.low <- is.finite(lowTEs)
sel.upp <- is.finite(uppTEs)
##
if (all(!sel.low))
minTE <- -0.5
else
minTE <- min(lowTEs[sel.low], na.rm = TRUE)
if (all(!sel.upp))
maxTE <- 0.5
else
maxTE <- max(uppTEs[sel.upp], na.rm = TRUE)
##
if (minTE < 0 & maxTE < 0)
xlim <- c(minTE, -minTE)
else if (minTE > 0 & maxTE > 0)
xlim <- c(-maxTE, maxTE)
else
xlim <- c(-max(abs(c(minTE, maxTE))), max(abs(c(minTE, maxTE))))
}
}
##
if (!is.na(ref) &&
round(xlim[2] - ref, 6) == round(ref - xlim[1], 6))
symmetric <- TRUE
##
if (by) {
if (all(is.na(c(yTE, yTE.w))))
max.yTE <- 0
else
max.yTE <- max(c(yTE, yTE.w), na.rm = TRUE)
}
else {
if (all(is.na(yTE)))
max.yTE <- 0
else
max.yTE <- max(yTE, na.rm = TRUE)
}
##
yNext <- max.yTE + ifelse(max.yTE == 0 | !addrow.overall, 1, 2)
##
if (missing(xlab.pos))
xlab.pos <- mean(xlim)
##
if (missing(smlab.pos))
smlab.pos <- mean(xlim)
##
yTE.common <- rep(NA, n.com)
yTE.random <- rep(NA, n.ran)
yPredict <- rep(NA, n.prd)
yHetstat <- NA
yResidHetstat <- NA
yOverall.common <- NA
yOverall.random <- NA
ySubgroup.common <- NA
ySubgroup.random <- NA
yText.addline1 <- NA
yText.addline2 <- NA
##
seq.com <- seq_len(n.com) - 1
seq.ran <- seq_len(n.ran) - 1
seq.prd <- seq_len(n.prd) - 1
##
if (common & random & overall) {
yTE.common <- yNext + seq.com
yNext <- yNext + 1 + max(seq.com)
##
yTE.random <- yNext + seq.ran
yNext <- yNext + 1 + max(seq.ran)
}
##
else if (common & !random & overall) {
yTE.common <- yNext + seq.com
yNext <- yNext + 1 + max(seq.com)
}
##
else if (!common & random & overall) {
yTE.random <- yNext + seq.ran
yNext <- yNext + 1 + max(seq.ran)
}
##
else if (!common & !random & pooled.totals & overall) {
yTE.common <- yNext + seq.com
yNext <- yNext + 1 + max(seq.com)
##
if (missing(text.common))
text.common <- "Overall"
}
##
if (prediction & overall) {
yPredict <- yNext + seq.prd
yNext <- yNext + 1 + max(seq.prd)
}
##
yNext <- yNext + addrows.below.overall
##
if (overall.hetstat) {
yHetstat <- yNext
yNext <- yNext + 1
}
##
if (resid.hetstat) {
yResidHetstat <- yNext
yNext <- yNext + 1
}
##
if (test.overall.common) {
yOverall.common <- yNext
yNext <- yNext + 1
}
##
if (test.overall.random) {
yOverall.random <- yNext
yNext <- yNext + 1
}
##
if (test.subgroup.common) {
ySubgroup.common <- yNext
yNext <- yNext + 1
}
##
if (test.subgroup.random) {
ySubgroup.random <- yNext
yNext <- yNext + 1
}
##
if (!missing.text.addline1) {
yText.addline1 <- yNext
yNext <- yNext + 1
}
##
if (!missing.text.addline2)
yText.addline2 <- yNext
##
if (!common & !pooled.totals) text.common <- ""
if (!random) text.random <- ""
if (!prediction) text.predict <- ""
##
yTE <- yHead + yTE + addrow
##
yTE.common <- yHead + yTE.common + addrow
yTE.random <- yHead + yTE.random + addrow
yPredict <- yHead + yPredict + addrow
##
yHetstat <- yHead + yHetstat + addrow
yResidHetstat <- yHead + yResidHetstat + addrow
yOverall.common <- yHead + yOverall.common + addrow
yOverall.random <- yHead + yOverall.random + addrow
ySubgroup.common <- yHead + ySubgroup.common + addrow
ySubgroup.random <- yHead + ySubgroup.random + addrow
yText.addline1 <- yHead + yText.addline1 + addrow
yText.addline2 <- yHead + yText.addline2 + addrow
##
yStats <- c(yHetstat,
yResidHetstat,
yOverall.common, yOverall.random,
ySubgroup.common, ySubgroup.random,
yText.addline1, yText.addline2)
##
if (by) {
yBylab <- yHead + yBylab + addrow
yTE.w <- yHead + yTE.w + addrow
##
yLab <- c(yHead,
yTE.common, yTE.random, yPredict,
yStats,
yBylab, yTE.w,
yTE)
##
yS <- c(yHead, yTE.common, yTE.random, yPredict, yTE.w, yTE)
}
else {
yLab <- c(yHead, yTE.common, yTE.random, yPredict,
yStats,
yTE)
##
yS <- c(yHead, yTE.common, yTE.random, yPredict, yTE)
}
##
##
## (11) Format columns in forest plot
##
##
col.studlab <- list(labels =
lapply(as.list(c(labs[["lab.studlab"]], modlabs)),
tg,
xpos = xpos.s, just = just.s,
fs = fs.study.labels,
ff = ff.study.labels,
fontfamily = fontfamily),
rows = yLab
)
## Study label:
col.studlab$labels[[1]] <- tg(labs[["lab.studlab"]], xpos.s,
just.s, fs.head, ff.head, fontfamily)
## Common effect estimate:
strt <- j <- 1
for (i in seq_len(n.com)) {
col.studlab$labels[[strt + i]] <-
tg(text.common[i], xpos.s, just.s,
fs.common.labels, ff.common.labels, fontfamily)
j <- j + 1
}
## Random effects estimate:
strt <- j
for (i in seq_len(n.ran)) {
col.studlab$labels[[strt + i]] <-
tg(text.random[i], xpos.s, just.s,
fs.random.labels, ff.random.labels, fontfamily)
j <- j + 1
}
## Prediction interval:
strt <- j
for (i in seq_len(n.prd)) {
col.studlab$labels[[strt + i]] <-
tg(text.predict[i], xpos.s, just.s,
fs.predict.labels, ff.predict.labels, fontfamily)
j <- j + 1
}
## Heterogeneity statistics:
col.studlab$labels[[j + 1]] <-
tg(hetstat.overall, xpos.s, just.s, fs.hetstat, ff.hetstat, fontfamily)
## Statistic for residual heterogeneity:
col.studlab$labels[[j + 2]] <-
tg(hetstat.resid, xpos.s, just.s, fs.hetstat, ff.hetstat, fontfamily)
## Test for overall effect (common effect model):
col.studlab$labels[[j + 3]] <-
tg(text.overall.common, xpos.s, just.s, fs.test.overall, ff.test.overall,
fontfamily)
## Test for overall effect (random effects model):
col.studlab$labels[[j + 4]] <-
tg(text.overall.random, xpos.s, just.s, fs.test.overall, ff.test.overall,
fontfamily)
## Test for subgroup differences (common effect model):
col.studlab$labels[[j + 5]] <-
tg(text.subgroup.common, xpos.s, just.s, fs.test.subgroup, ff.test.subgroup,
fontfamily)
## Test for subgroup differences (random effects model):
col.studlab$labels[[j + 6]] <-
tg(text.subgroup.random, xpos.s, just.s, fs.test.subgroup, ff.test.subgroup,
fontfamily)
## First additional line:
col.studlab$labels[[j + 7]] <-
tg(text.addline1, xpos.s, just.s, fs.addline, ff.addline, fontfamily)
## Second additional line:
col.studlab$labels[[j + 8]] <-
tg(text.addline2, xpos.s, just.s, fs.addline, ff.addline, fontfamily)
##
if (by) {
## Subgroup labels:
strt <- j <- j + 8
for (i in seq_len(n.by)) {
col.studlab$labels[[strt + i]] <-
tg(subgroup.name[i], xpos.s, just.s,
fs.head, ff.head, fontfamily, col.subgroup)
j <- j + 1
}
## Common effect estimates:
strt <- j
for (i in seq_len(n.com.w)) {
col.studlab$labels[[strt + i]] <-
tg(text.common.w[i], xpos.s, just.s,
fs.common.labels, ff.common.labels, fontfamily, col.subgroup)
j <- j + 1
}
## Random effects estimates:
strt <- j
for (i in seq_len(n.ran.w)) {
col.studlab$labels[[strt + i]] <-
tg(text.random.w[i], xpos.s, just.s,
fs.random.labels, ff.random.labels, fontfamily, col.subgroup)
j <- j + 1
}
## Prediction interval:
strt <- j
for (i in seq_len(n.prd.w)) {
col.studlab$labels[[strt + i]] <-
tg(text.predict.w[i], xpos.s, just.s,
fs.predict.labels, ff.predict.labels, fontfamily, col.subgroup)
j <- j + 1
}
## Heterogeneity statistics:
strt <- j
for (i in seq_len(n.by)) {
col.studlab$labels[[strt + i]] <-
tg(hetstat.w[[i]], xpos.s, just.s,
fs.hetstat, ff.hetstat, fontfamily, col.subgroup)
j <- j + 1
}
## Test for effect in subgroup (common effect model):
strt <- j
for (i in seq_len(n.by)) {
col.studlab$labels[[strt + i]] <-
tg(text.effect.subgroup.common[[i]], xpos.s, just.s,
fs.test.effect.subgroup, ff.test.effect.subgroup,
fontfamily, col.subgroup)
j <- j + 1
}
## Test for effect in subgroup (random effects model):
strt <- j
for (i in seq_len(n.by)) {
col.studlab$labels[[strt + i]] <-
tg(text.effect.subgroup.random[[i]], xpos.s, just.s,
fs.test.effect.subgroup, ff.test.effect.subgroup,
fontfamily, col.subgroup)
j <- j + 1
}
}
##
fcs <- list(fs.study = fs.study, ff.study = ff.study,
fs.heading = fs.head, ff.heading = ff.head,
fs.common = fs.common, ff.common = ff.common,
fs.random = fs.random, ff.random = ff.random,
fs.predict = fs.predict, ff.predict = ff.predict,
by = by, n.by = n.by, col.subgroup = col.subgroup)
##
col.effect <- formatcol(labs[["lab.effect"]], effect.format,
yS, just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.ci <- formatcol(labs[["lab.ci"]], ci.format, yS, just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.effect.ci <-
formatcol(labs[["lab.effect.ci"]], effect.ci.format, yS,
if (revman5) "center" else just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.w.common <- formatcol(labs[["lab.w.common"]], Wc.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
col.w.random <- formatcol(labs[["lab.w.random"]], Wr.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.TE <- formatcol(labs[["lab.TE"]], TE.format, yS, just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
col.seTE <- formatcol(labs[["lab.seTE"]], seTE.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.cluster <-
formatcol(labs[["lab.cluster"]], cluster.format, yS,
if (as.character.cluster) "left" else just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.n.e <- formatcol(labs[["lab.n.e"]], Ne.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.n.c <- formatcol(labs[["lab.n.c"]], Nc.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.event.e <- formatcol(labs[["lab.event.e"]], Ee.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.event.c <- formatcol(labs[["lab.event.c"]], Ec.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.mean.e <- formatcol(labs[["lab.mean.e"]], Me.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.mean.c <- formatcol(labs[["lab.mean.c"]], Mc.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.sd.e <- formatcol(labs[["lab.sd.e"]], Se.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.sd.c <- formatcol(labs[["lab.sd.c"]], Sc.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.cor <- formatcol(labs[["lab.cor"]], cor.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.time.e <- formatcol(labs[["lab.time.e"]], Te.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.time.c <- formatcol(labs[["lab.time.c"]], Tc.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.pval <- formatcol(labs[["lab.pval"]], pval.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
if (metainf.metacum) {
col.tau2 <- formatcol(labs[["lab.tau2"]], tau2.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.tau <- formatcol(labs[["lab.tau"]], tau.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.I2 <- formatcol(labs[["lab.I2"]], I2.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
}
##
##
##
col.effect.calc <- formatcol(longer.effect, effect.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.ci.calc <- formatcol(longer.ci, ci.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.effect.ci.calc <- formatcol(longer.effect.ci, effect.ci.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.w.common.calc <- formatcol(longer.w.common, Wc.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
col.w.random.calc <- formatcol(longer.w.random, Wr.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.TE.calc <- formatcol(longer.TE, TE.format, yS, just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
col.seTE.calc <- formatcol(longer.seTE, seTE.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.cluster.calc <- formatcol(longer.cluster, cluster.format,
yS, just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.n.e.calc <- formatcol(longer.n.e, Ne.format, yS, just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
col.n.c.calc <- formatcol(longer.n.c, Nc.format, yS, just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.event.e.calc <- formatcol(longer.event.e, Ee.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
col.event.c.calc <- formatcol(longer.event.c, Ec.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.mean.e.calc <- formatcol(longer.mean.e, Me.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.mean.c.calc <- formatcol(longer.mean.c, Mc.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.sd.e.calc <- formatcol(longer.sd.e, Se.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.sd.c.calc <- formatcol(longer.sd.c, Sc.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.cor.calc <- formatcol(longer.cor, cor.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.time.e.calc <- formatcol(longer.time.e, Te.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.time.c.calc <- formatcol(longer.time.c, Tc.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.pval.calc <- formatcol(longer.pval, pval.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
if (metainf.metacum) {
col.tau2.calc <- formatcol(longer.tau2, tau2.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.tau.calc <- formatcol(longer.tau, tau.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.I2.calc <- formatcol(longer.I2, I2.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
}
##
col.forest <- list(eff = TEs.exclude,
low = lowTEs.exclude,
upp = uppTEs.exclude,
rows = yS[-1],
##
## "square" - normal confidence interval
## "diamond" - meta-analysis diamond
## "predict" - prediction interval
##
type = c(type.pooled, type.study),
##
col = c(col.diamond.lines.pooled, col.study),
col.square = c(col.diamond.pooled, col.square),
col.square.lines =
c(col.diamond.lines.pooled, col.square.lines),
col.inside = c(col.inside.pooled, col.inside),
##
col.diamond = c(col.diamond.pooled, col.square),
col.diamond.lines =
c(col.diamond.lines.pooled, col.square.lines),
##
lwd = lwd
)
##
## Sizes of squares
##
if (weight.study == "same") {
information <- rep(0.9, length(TEs))
}
else {
##
if (weight.study == "common")
information <- sqrt(w.commons)
else if (weight.study == "random")
information <- sqrt(w.randoms)
## Square height equal to 1 for most precise study result
if (!all(is.na(information)))
information <- information / max(information, na.rm = TRUE)
else
information <- rep(0.9, length(TEs))
## Same / maximum polygon height for all meta-analytical results
## (both overall and subgroup results)
information[is.na(information)] <- 1
}
##
col.forest$sizes <- information
col.forest$sizes <- col.forest$sizes * squaresize
##
## Width of column 3
col.forestwidth <- plotwidth
##
## Range on the x-axis for column 3
col.forest$range <- xlim
##
cols <- list(col.studlab = col.studlab,
col.effect = col.effect,
col.ci = col.ci,
col.effect.ci = col.effect.ci,
col.w.common = col.w.common,
col.w.random = col.w.random,
col.TE = col.TE,
col.seTE = col.seTE)
##
cols.calc <- list(col.studlab = col.studlab,
col.effect = col.effect.calc,
col.ci = col.ci.calc,
col.effect.ci = col.effect.ci.calc,
col.w.common = col.w.common.calc,
col.w.random = col.w.random.calc,
col.TE = col.TE.calc,
col.seTE = col.seTE.calc)
##
cols[["col.cluster"]] <- col.cluster
##
cols[["col.n.e"]] <- col.n.e
cols[["col.n.c"]] <- col.n.c
cols[["col.event.e"]] <- col.event.e
cols[["col.event.c"]] <- col.event.c
##
cols[["col.mean.e"]] <- col.mean.e
cols[["col.mean.c"]] <- col.mean.c
cols[["col.sd.e"]] <- col.sd.e
cols[["col.sd.c"]] <- col.sd.c
##
cols[["col.cor"]] <- col.cor
##
cols[["col.time.e"]] <- col.time.e
cols[["col.time.c"]] <- col.time.c
##
cols[["col.pval"]] <- col.pval
##
if (metainf.metacum) {
cols[["col.tau2"]] <- col.tau2
cols[["col.tau"]] <- col.tau
cols[["col.I2"]] <- col.I2
}
##
## Calculate
##
cols.calc[["col.cluster"]] <- col.cluster.calc
##
cols.calc[["col.n.e"]] <- col.n.e.calc
cols.calc[["col.n.c"]] <- col.n.c.calc
cols.calc[["col.event.e"]] <- col.event.e.calc
cols.calc[["col.event.c"]] <- col.event.c.calc
##
cols.calc[["col.mean.e"]] <- col.mean.e.calc
cols.calc[["col.mean.c"]] <- col.mean.c.calc
cols.calc[["col.sd.e"]] <- col.sd.e.calc
cols.calc[["col.sd.c"]] <- col.sd.c.calc
##
cols.calc[["col.cor"]] <- col.cor.calc
##
cols.calc[["col.time.e"]] <- col.time.e.calc
cols.calc[["col.time.c"]] <- col.time.c.calc
##
cols.calc[["col.pval"]] <- col.pval.calc
##
if (metainf.metacum) {
cols.calc[["col.tau2"]] <- col.tau2.calc
cols.calc[["col.tau"]] <- col.tau.calc
cols.calc[["col.I2"]] <- col.I2.calc
}
##
if (newcols) {
##
## Check just.addcols
##
if (length(leftcols.new) > 0)
if (length(just.addcols.left) != 1) {
if (length(just.addcols.left) != length(leftcols.new))
stop("Length of argument 'just.addcols.left' must be one or ",
"same as number of additional columms in argument 'leftcols'.")
}
else
just.addcols.left <- rep(just.addcols.left, length(leftcols.new))
##
if (length(rightcols.new) > 0)
if (length(just.addcols.right) != 1) {
if (length(just.addcols.right) != length(rightcols.new))
stop("Length of argument 'just.addcols.right' must be one or ",
"same as number of additional columms in argument 'rightcols'.")
}
else
just.addcols.right <- rep(just.addcols.right, length(rightcols.new))
##
## Check digits.addcols
##
if (length(leftcols.new) > 0)
if (length(digits.addcols.left) != 1) {
if (length(digits.addcols.left) != length(leftcols.new))
stop("Length of argument 'digits.addcols.left' must be one or ",
"same as number of additional columms in argument 'leftcols'.")
}
else
digits.addcols.left <- rep(digits.addcols.left, length(leftcols.new))
##
if (length(rightcols.new) > 0)
if (length(digits.addcols.right) != 1) {
if (length(digits.addcols.right) != length(rightcols.new))
stop("Length of argument 'digits.addcols.right' must be one or ",
"same as number of additional columms in argument 'rightcols'.")
}
else
digits.addcols.right <- rep(digits.addcols.right, length(rightcols.new))
##
if (by) {
for (i in seq_along(rightcols.new)) {
tname <- paste0("col.", rightcols.new[i])
if (length(dataset1[[rightcols.new[i]]]) != 0)
tmp.r <- dataset1[[rightcols.new[i]]]
else if (length(dataset2[[rightcols.new[i]]]) != 0)
tmp.r <- dataset2[[rightcols.new[i]]]
else
stop("Variable '", rightcols.new[i],
"' not available in meta-analysis object.",
call. = FALSE)
##
if (!is.character(tmp.r)) {
if (is.factor(tmp.r))
tmp.r <- as.character(tmp.r)
else if (missing.addcols.right &
all(is_wholenumber(tmp.r), na.rm = TRUE))
tmp.r <- formatN(tmp.r, digits = 0,
text.NA = lab.NA, big.mark = big.mark)
else if (is.numeric(tmp.r)) {
if (rightcols.new[i] == "pval")
tmp.r <- formatPT(tmp.r, digits = digits.pval,
big.mark = big.mark)
else if (rightcols.new[i] == "tau2")
tmp.r <- formatPT(tmp.r, digits = digits.tau2,
big.mark = big.mark)
else if (rightcols.new[i] == "tau")
tmp.r <- formatPT(tmp.r, digits = digits.tau,
big.mark = big.mark)
else if (rightcols.new[i] == "I2") {
format.r <- formatN(100 * tmp.r, digits.I2, lab.NA)
tmp.r <- ifelse(format.r == lab.NA, lab.NA,
paste0(format.r, "%"))
}
else
tmp.r <- formatN(tmp.r, digits = digits.addcols.right[i],
text.NA = "", big.mark = big.mark)
}
}
##
tmp.r <- ifelse(is.na(tmp.r), lab.NA, tmp.r)
##
## Check for "\n" in label of new column
##
clines <- twolines(rightlabs.new[i], rightcols.new[i])
##
if (clines$newline) {
lab.new <- clines$bottom
longer.new <- clines$longer
}
else
lab.new <- longer.new <- rightlabs.new[i]
cols[[tname]] <-
formatcol(lab.new,
c("", "", "", rep("", length(TE.w)), tmp.r),
yS,
if (rightcols.new[i] %in%
c("pval", "tau2", "tau", "I2", "Q", "pval.Q"))
just
else
just.addcols.right[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
cols.calc[[tname]] <- formatcol(longer.new,
c("", "", "", rep("", length(TE.w)),
tmp.r),
yS,
just.addcols.right[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
}
for (i in seq_along(leftcols.new)) {
tname <- paste0("col.", leftcols.new[i])
if (length(dataset1[[leftcols.new[i]]]) != 0)
tmp.l <- dataset1[[leftcols.new[i]]]
else if (length(dataset2[[leftcols.new[i]]]) != 0)
tmp.l <- dataset2[[leftcols.new[i]]]
else
stop("Variable '", leftcols.new[i],
"' not available in meta-analysis object.",
call. = FALSE)
##
if (!is.character(tmp.l)) {
if (is.factor(tmp.l))
tmp.l <- as.character(tmp.l)
else if (missing.addcols.left &
all(is_wholenumber(tmp.l), na.rm = TRUE))
tmp.l <- formatN(tmp.l, digits = 0,
text.NA = lab.NA, big.mark = big.mark)
else if (is.numeric(tmp.l)) {
if (leftcols.new[i] == "pval")
tmp.l <- formatPT(tmp.l, digits = digits.pval,
big.mark = big.mark)
else if (leftcols.new[i] == "tau2")
tmp.l <- formatPT(tmp.l, digits = digits.tau2,
big.mark = big.mark)
else if (leftcols.new[i] == "tau")
tmp.l <- formatPT(tmp.l, digits = digits.tau,
big.mark = big.mark)
else if (leftcols.new[i] == "I2") {
format.l <- formatN(100 * tmp.l, digits.I2, lab.NA)
tmp.l <- ifelse(format.l == lab.NA, lab.NA,
paste0(format.l, "%"))
}
else
tmp.l <- formatN(tmp.l, digits = digits.addcols.left[i],
text.NA = "", big.mark = big.mark)
}
}
##
tmp.l <- ifelse(is.na(tmp.l), lab.NA, tmp.l)
##
## Check for "\n" in label of new column
##
clines <- twolines(leftlabs.new[i], leftcols.new[i])
##
if (clines$newline) {
lab.new <- clines$bottom
longer.new <- clines$longer
}
else
lab.new <- longer.new <- leftlabs.new[i]
##
cols[[tname]] <-
formatcol(lab.new,
c("", "", "",
rep("", length(TE.w)), tmp.l),
yS,
if (leftcols.new[i] %in%
c("pval", "tau2", "tau", "I2", "Q", "pval.Q"))
just
else
just.addcols.left[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
##
cols.calc[[tname]] <- formatcol(longer.new,
c("", "", "",
rep("", length(TE.w)), tmp.l),
yS,
just.addcols.left[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
}
}
else {
for (i in seq_along(rightcols.new)) {
tname <- paste0("col.", rightcols.new[i])
if (length(dataset1[[rightcols.new[i]]]) != 0)
tmp.r <- dataset1[[rightcols.new[i]]]
else if (length(dataset2[[rightcols.new[i]]]) != 0)
tmp.r <- dataset2[[rightcols.new[i]]]
else
stop("Variable '", rightcols.new[i],
"' not available in meta-analysis object.",
call. = FALSE)
##
if (!is.character(tmp.r)) {
if (is.factor(tmp.r))
tmp.r <- as.character(tmp.r)
else if (missing.addcols.left &
all(is_wholenumber(tmp.r), na.rm = TRUE))
tmp.r <- formatN(tmp.r, digits = 0,
text.NA = lab.NA, big.mark = big.mark)
else if (is.numeric(tmp.r)) {
if (rightcols.new[i] == "pval")
tmp.r <- formatPT(tmp.r, digits = digits.pval,
big.mark = big.mark,
lab = FALSE, labval = "",
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA")
else if (rightcols.new[i] == "tau2")
tmp.r <- formatPT(tmp.r, digits = digits.tau2,
big.mark = big.mark,
lab = FALSE, labval = "",
lab.NA = "NA")
else if (rightcols.new[i] == "tau")
tmp.r <- formatPT(tmp.r, digits = digits.tau,
big.mark = big.mark,
lab = FALSE, labval = "",
lab.NA = "NA")
else if (rightcols.new[i] == "I2")
tmp.r <-
paste0(formatN(100 * tmp.r, digits.I2, "NA"), "%")
else
tmp.r <- formatN(tmp.r, digits = digits.addcols.right[i],
text.NA = "", big.mark = big.mark)
}
}
##
tmp.r <- ifelse(is.na(tmp.r), "", tmp.r)
##
## Check for "\n" in label of new column
##
clines <- twolines(rightlabs.new[i], rightcols.new[i])
##
if (clines$newline) {
lab.new <- clines$bottom
longer.new <- clines$longer
}
else
lab.new <- longer.new <- rightlabs.new[i]
##
cols[[tname]] <-
formatcol(lab.new,
c("", "", "", tmp.r),
yS,
if (rightcols.new[i] %in% c("pval", "tau2", "tau", "I2"))
just
else
just.addcols.right[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
cols.calc[[tname]] <- formatcol(longer.new,
c("", "", "", tmp.r),
yS,
just.addcols.right[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
}
for (i in seq_along(leftcols.new)) {
tname <- paste0("col.", leftcols.new[i])
if (length(dataset1[[leftcols.new[i]]]) != 0)
tmp.l <- dataset1[[leftcols.new[i]]]
else if (length(dataset2[[leftcols.new[i]]]) != 0)
tmp.l <- dataset2[[leftcols.new[i]]]
else
stop("Variable '", leftcols.new[i],
"' not available in meta-analysis object.",
call. = FALSE)
##
if (!is.character(tmp.l)) {
if (is.factor(tmp.l))
tmp.l <- as.character(tmp.l)
else if (missing.addcols.left &
all(is_wholenumber(tmp.l), na.rm = TRUE))
tmp.l <- formatN(tmp.l, digits = 0,
text.NA = lab.NA, big.mark = big.mark)
else if (is.numeric(tmp.l)) {
if (leftcols.new[i] == "pval")
tmp.l <- formatPT(tmp.l, digits = digits.pval,
big.mark = big.mark,
lab = FALSE, labval = "",
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA")
else if (leftcols.new[i] == "tau2")
tmp.l <- formatPT(tmp.l, digits = digits.tau2,
big.mark = big.mark,
lab = FALSE, labval = "",
lab.NA = "NA")
else if (leftcols.new[i] == "tau")
tmp.l <- formatPT(tmp.l, digits = digits.tau,
big.mark = big.mark,
lab = FALSE, labval = "",
lab.NA = "NA")
else if (leftcols.new[i] == "I2")
tmp.l <-
paste0(formatN(100 * tmp.l, digits.I2, "NA"), "%")
else
tmp.l <- formatN(tmp.l, digits = digits.addcols.left[i],
text.NA = "", big.mark = big.mark)
}
}
##
tmp.l <- ifelse(is.na(tmp.l), "", tmp.l)
##
## Check for "\n" in label of new column
##
clines <- twolines(leftlabs.new[i], leftcols.new[i])
##
if (clines$newline) {
lab.new <- clines$bottom
longer.new <- clines$longer
}
else
lab.new <- longer.new <- leftlabs.new[i]
##
cols[[tname]] <-
formatcol(lab.new,
c("", "", "", tmp.l),
yS,
if (leftcols.new[i] %in% c("pval", "tau2", "tau", "I2"))
just
else
just.addcols.left[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
cols.calc[[tname]] <- formatcol(longer.new,
c("", "", "", tmp.l),
yS,
just.addcols.left[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
}
}
}
##
col.label.e <- tgl(label.e, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
col.label.c <- tgl(label.c, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
##
##
if (newline.studlab)
col.add.studlab <- tgl(add.studlab, xpos.s, just.s, fs.head, ff.head,
fontfamily)
##
if (newline.effect)
col.add.effect <- tgl(add.effect, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.ci)
col.add.ci <- tgl(add.ci, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
if (newline.effect.ci)
col.add.effect.ci <- tgl(add.effect.ci,
if (revman5) 0.5 else xpos.c,
if (revman5) "center" else just.c,
fs.head, ff.head, fontfamily)
##
if (newline.w.common)
col.add.w.common <- tgl(add.w.common, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.w.random)
col.add.w.random <- tgl(add.w.random, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.TE)
col.add.TE <- tgl(add.TE, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.seTE)
col.add.seTE <- tgl(add.seTE, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
if (newline.cluster)
col.add.cluster <-
tgl(add.cluster,
if (as.character.cluster) 0 else xpos.c,
if (as.character.cluster) "left" else just.c,
fs.head, ff.head, fontfamily)
##
if (newline.n.e)
col.add.n.e <- tgl(add.n.e, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
if (newline.n.c)
col.add.n.c <- tgl(add.n.c, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
if (newline.event.e)
col.add.event.e <- tgl(add.event.e, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.event.c)
col.add.event.c <- tgl(add.event.c, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.mean.e)
col.add.mean.e <- tgl(add.mean.e, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.mean.c)
col.add.mean.c <- tgl(add.mean.c, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.sd.e)
col.add.sd.e <- tgl(add.sd.e, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
if (newline.sd.c)
col.add.sd.c <- tgl(add.sd.c, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
if (newline.cor)
col.add.cor <- tgl(add.cor, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
if (newline.time.e)
col.add.time.e <- tgl(add.time.e, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.time.c)
col.add.time.c <- tgl(add.time.c, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (metainf.metacum) {
if (newline.pval)
col.add.pval <- tgl(add.pval, xpos.c, just.c, fs.head, ff.head,
fontfamily)
if (newline.tau2)
col.add.tau2 <- tgl(add.tau2, xpos.c, just.c, fs.head, ff.head,
fontfamily)
if (newline.tau)
col.add.tau <- tgl(add.tau, xpos.c, just.c, fs.head, ff.head,
fontfamily)
if (newline.I2)
col.add.I2 <- tgl(add.I2, xpos.c, just.c, fs.head, ff.head,
fontfamily)
}
##
leftcols <- paste0("col.", leftcols)
rightcols <- paste0("col.", rightcols)
##
##
## (12) Calculate width of columns in forest plot
##
##
## Exclude lines with summary measures from calculation of column
## width for study labels
##
del.lines <- NULL
##
if (!calcwidth.common)
del.lines <- 1 + seq_len(n.com)
##
if (!calcwidth.random)
del.lines <-
c(del.lines, 1 + n.com + seq_len(n.ran))
##
if (!calcwidth.predict)
del.lines <-
c(del.lines, 1 + n.com + n.ran + seq_len(n.prd))
##
if (!calcwidth.hetstat)
del.lines <-
c(del.lines, 1 + n.com + n.ran + n.prd + 1:2)
##
if (!calcwidth.tests)
del.lines <-
c(del.lines, 1 + n.com + n.ran + n.prd + 2 + 1:4)
##
if (!calcwidth.addline)
del.lines <-
c(del.lines, 1 + n.com + n.ran + n.prd + 2 + 4 + 1:2)
##
if (by) {
if (!calcwidth.subgroup)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + seq_len(n.by))
##
if (!calcwidth.common)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + n.by +
seq_len(n.by * n.com))
##
if (!calcwidth.random)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + n.by +
n.by * n.com + seq_len(n.by * n.ran))
##
if (!calcwidth.predict)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + n.by +
n.by * n.com + n.by * n.ran + seq_len(n.by * n.prd))
##
if (!calcwidth.hetstat)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + n.by +
n.by * n.com + n.by * n.ran + n.by * n.prd +
seq_len(n.by))
## test for effect (CE)
if (!calcwidth.tests)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + n.by +
n.by * n.com + n.by * n.ran + n.by * n.prd +
n.by + seq_len(n.by))
## test for effect (RE)
if (!calcwidth.tests)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + n.by +
n.by * n.com + n.by * n.ran + n.by * n.prd +
n.by + n.by + seq_len(n.by))
}
##
if (lsel) {
for (i in seq_along(leftcols)) {
if (i == 1) {
if (leftcols[[i]] == "col.studlab" & !is.null(del.lines))
x1 <- unit.c(wcalc(cols.calc[[leftcols[i]]]$labels[-del.lines]))
else
x1 <- unit.c(wcalc(cols.calc[[leftcols[i]]]$labels))
}
else {
if (leftcols[[i]] == "col.studlab" & !is.null(del.lines))
x1 <- unit.c(x1,
colgap.left,
wcalc(cols.calc[[leftcols[i]]]$labels[-del.lines]))
else
x1 <- unit.c(x1,
if (leftcols[[i - 1]] == "col.studlab")
colgap.studlab
else colgap.left,
wcalc(cols.calc[[leftcols[i]]]$labels))
}
}
##
x1 <- unit.c(x1, colgap.forest.left, col.forestwidth)
}
else
x1 <- unit.c(col.forestwidth)
##
if (rsel) {
for (i in seq_along(rightcols)) {
x1 <- unit.c(x1,
if (i == 1) colgap.forest.right else colgap.right,
wcalc(cols.calc[[rightcols[i]]]$labels))
}
}
##
##
## (13) Process arguments smlab, label.left and label.right
##
##
if (by) {
addline <- addrow * (!any(c(overall.hetstat,
test.overall.common, test.overall.random,
resid.hetstat,
test.subgroup.common, test.subgroup.random)))
##
nrow <- max(addline + c(yTE, yTE.common, yTE.random, yPredict,
yStats, yTE.w), na.rm = TRUE)
}
else {
addline <- addrow * (!any(c(test.overall.common, test.overall.random,
overall.hetstat)))
##
nrow <- max(addline + c(yTE, yTE.common, yTE.random, yPredict,
yStats), na.rm = TRUE)
}
##
## Determine minimal value on y-axis for lines of common / random
## effect estimate or reference line
##
n.lines <- sum(!is.na(yStats))
ymin.line <- max(addrow | addrow.overall,
n.lines + (n.lines > 0) * addrows.below.overall)
##
if (!by) {
if (overall & (common | random | prediction)) {
if (ymin.line == addrows.below.overall & !(!addrow.overall | !addrow))
ymin.line <- ymin.line + 1
##
if ((!missing.text.addline1 | !missing.text.addline2) &
(!missing.text.addline1 + !missing.text.addline2) == n.lines &
!(!addrow.overall | !addrow))
ymin.line <- ymin.line + 1
##
if (addrow.overall & !addrow & n.lines == 0)
ymin.line <- ymin.line - 1
}
##
if (!overall & addrow & n.lines == 0)
ymin.line <- ymin.line - 1
}
else {
if (!overall & !overall.hetstat & addrow &
((n.lines > !missing.text.addline1 + !missing.text.addline2) |
n.lines == 0))
ymin.line <- ymin.line - 1
}
##
if (hetstat %in% c("common", "random") &
(!missing.text.addline1 | !missing.text.addline2))
ymin.line <- ymin.line + 1
##
ymin.common <- spacing * (ymin.line + prediction * n.prd + random * n.ran + 0.5)
ymin.random <- spacing * (ymin.line + prediction * n.prd + 0.5)
ymin.ref <- spacing * (ymin.line + (!(overall | overall.hetstat) & addrow))
##
ymax <- spacing * (nrow - ifelse(is.na(yHeadadd), 1, 2) - 1 * addrow)
##
## Position on y-axis of left and right labels (at bottom of forest plot)
##
y.bottom.lr <- ymin.line - 2.5 + (!(overall | overall.hetstat) & addrow)
##
## Position on y-axis of label below x-axis
##
xlab.ypos <- y.bottom.lr - 1 * (print.label & bottom.lr) -
1 * (print.label & bottom.lr & (newline.lr | newline.ll))
##
## Summary label at top of forest plot
##
smlab1 <- tgl(smlab1, unit(smlab.pos, "native"), "center",
fs.smlab, ff.smlab,
fontfamily, rows = 1 + (!is.na(yHeadadd) & !newline.smlab))
##
if (newline.smlab)
smlab2 <- tgl(smlab2, unit(smlab.pos, "native"),
"center", fs.smlab, ff.smlab, fontfamily,
rows = 2)
##
## Left and right label on x-axis:
##
if (!bottom.lr & !is.na(ref)) {
row1.lr <- if (!newline & (newline.ll | newline.lr) & !addrow)
1
else if (!is.na(yHeadadd) & addrow)
2
else if (is.na(yHeadadd))
1
else
2
##
ll1 <- tgl(ll1, unit(ref - (xlim[2] - xlim[1]) / 30, "native"),
"right", fs.lr, ff.lr, fontfamily, col.label.left,
rows = row1.lr)
##
if (newline.ll)
ll2 <- tgl(ll2, unit(ref - (xlim[2] - xlim[1]) / 30, "native"),
"right", fs.lr, ff.lr, fontfamily, col.label.left,
rows = row1.lr + 1)
##
lr1 <- tgl(lr1, unit(ref + (xlim[2] - xlim[1]) / 30, "native"),
"left", fs.lr, ff.lr, fontfamily, col.label.right,
rows = row1.lr)
##
if (newline.lr)
lr2 <- tgl(lr2, unit(ref + (xlim[2] - xlim[1]) / 30, "native"),
"left", fs.lr, ff.lr, fontfamily, col.label.right,
rows = row1.lr + 1)
}
##
##
## (14) Generate forest plot
##
##
if (new)
grid.newpage()
##
pushViewport(viewport(layout = grid.layout(
nrow,
length(x1),
widths = x1,
heights = unit(spacing, "lines"))))
##
## Left side of forest plot
##
j <- 1
##
if (lsel) {
for (i in seq_along(leftcols)) {
add.text(cols[[leftcols[i]]], j)
##
if (!is.na(yHeadadd)) {
if (!is.null(label.e.attach)) {
if (leftcols[i] == paste0("col.", label.e.attach))
add.text(col.label.e, j)
}
else if (metabin) {
if (leftcols[i] == "col.n.e" & just.c == "right")
add.text(col.label.e, j)
else if (leftcols[i] == "col.event.e" &
just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
else if (metacont) {
if (leftcols[i] == "col.sd.e" & just.c == "right")
add.text(col.label.e, j)
else if (leftcols[i] == "col.mean.e" &
just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
else if (metainc) {
if (leftcols[i] == "col.time.e" & just.c == "right")
add.text(col.label.e, j)
else if (leftcols[i] == "col.event.e" &
just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
else if (metamean) {
if (revman5 & leftcols[i] == "col.n.e" &
just.c == "right")
add.text(col.label.e, j)
else if (!revman5 & leftcols[i] == "col.sd.e" &
just.c == "right")
add.text(col.label.e, j)
else if (leftcols[i] == "col.sd.e" &
just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
##
if (!is.null(label.c.attach)) {
if (leftcols[i] == paste0("col.", label.c.attach))
add.text(col.label.c, j)
}
else if (metabin) {
if (leftcols[i] == "col.n.c" & just.c == "right")
add.text(col.label.c, j)
else if (leftcols[i] == "col.event.c" &
just.c %in% c("left", "center"))
add.text(col.label.c, j)
}
else if (metacont) {
if (leftcols[i] == "col.sd.c" & just.c == "right")
add.text(col.label.c, j)
else if (leftcols[i] == "col.mean.c" &
just.c %in% c("left", "center"))
add.text(col.label.c, j)
}
else if (metainc) {
if (leftcols[i] == "col.time.c" & just.c == "right")
add.text(col.label.c, j)
else if (leftcols[i] == "col.event.c" &
just.c %in% c("left", "center"))
add.text(col.label.c, j)
}
##
if (newline.studlab & leftcols[i] == "col.studlab")
add.text(col.add.studlab, j)
if (newline.effect & leftcols[i] == "col.effect")
add.text(col.add.effect, j)
if (newline.ci & leftcols[i] == "col.ci")
add.text(col.add.ci, j)
if (newline.effect.ci & leftcols[i] == "col.effect.ci")
add.text(col.add.effect.ci, j)
if (newline.w.common & leftcols[i] == "col.w.common")
add.text(col.add.w.common, j)
if (newline.w.random & leftcols[i] == "col.w.random")
add.text(col.add.w.random, j)
if (newline.TE & leftcols[i] == "col.TE")
add.text(col.add.TE, j)
if (newline.seTE & leftcols[i] == "col.seTE")
add.text(col.add.seTE, j)
if (newline.cluster & leftcols[i] == "col.cluster")
add.text(col.add.cluster, j)
if (newline.n.e & leftcols[i] == "col.n.e")
add.text(col.add.n.e, j)
if (newline.n.c & leftcols[i] == "col.n.c")
add.text(col.add.n.c, j)
if (newline.event.e & leftcols[i] == "col.event.e")
add.text(col.add.event.e, j)
if (newline.event.c & leftcols[i] == "col.event.c")
add.text(col.add.event.c, j)
if (newline.mean.e & leftcols[i] == "col.mean.e")
add.text(col.add.mean.e, j)
if (newline.mean.c & leftcols[i] == "col.mean.c")
add.text(col.add.mean.c, j)
if (newline.sd.e & leftcols[i] == "col.sd.e")
add.text(col.add.sd.e, j)
if (newline.sd.c & leftcols[i] == "col.sd.c")
add.text(col.add.sd.c, j)
if (newline.cor & leftcols[i] == "col.cor")
add.text(col.add.cor, j)
if (newline.time.e & leftcols[i] == "col.time.e")
add.text(col.add.time.e, j)
if (newline.time.c & leftcols[i] == "col.time.c")
add.text(col.add.time.c, j)
##
if (metainf.metacum) {
if (newline.pval & leftcols[i] == "col.pval")
add.text(col.add.pval, j)
if (newline.tau2 & leftcols[i] == "col.tau2")
add.text(col.add.tau2, j)
if (newline.tau & leftcols[i] == "col.tau")
add.text(col.add.tau, j)
if (newline.I2 & leftcols[i] == "col.I2")
add.text(col.add.I2, j)
}
##
## Add text in first line of forest plot for new columns
##
if (newcols)
if (length(leftcols.new) > 0 &
leftcols[i] %in% paste0("col.", leftcols.new)) {
sel <- paste0("col.", leftcols.new) == leftcols[i]
##
## Check for "\n" in label of new column
##
clines <- twolines(leftlabs.new[sel], leftcols[i])
##
just.new <- just.addcols.left[sel]
##
if (just.new == "left")
xpos.new <- 0
else if (just.new == "center")
xpos.new <- 0.5
else if (just.new == "right")
xpos.new <- 1
##
## Add first line
##
if (clines$newline)
add.text(tgl(clines$top, xpos.new, just.new, fs.head, ff.head,
fontfamily), j)
}
}
##
j <- j + 2
}
}
##
## Produce forest plot
##
draw.lines(col.forest, j,
ref, TE.common, unique(TE.random),
overall, common, random, prediction,
ymin.common, ymin.random, ymin.ref,
ymax + 0.5 * header.line * addrow,
lwd, lty.common, lty.random, col.common, col.random,
xlim[1], xlim[2],
lower.equi, upper.equi, lty.equi, col.equi,
fill.lower.equi, fill.upper.equi)
##
draw.axis(col.forest, j, yS, log.xaxis, at, label,
fs.axis, ff.axis, fontfamily, lwd,
xlim, notmiss.xlim)
##
if (bottom.lr) {
add.text(smlab1, j, xscale = col.forest$range)
##
if (newline.smlab)
add.text(smlab2, j, xscale = col.forest$range)
}
##
if (print.label) {
if (!bottom.lr) {
if (!is.na(ref)) {
add.text(ll1, j, xscale = col.forest$range)
##
if (newline.ll)
add.text(ll2, j, xscale = col.forest$range)
##
add.text(lr1, j, xscale = col.forest$range)
##
if (newline.lr)
add.text(lr2, j, xscale = col.forest$range)
}
}
else {
add.label(ll1, j,
unit(ref - (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr, "lines"),
"right",
fs.lr, ff.lr, col.label.left, fontfamily,
xscale = col.forest$range)
##
if (newline.ll)
add.label(ll2, j,
unit(ref - (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr - 1, "lines"),
"right",
fs.lr, ff.lr, col.label.left, fontfamily,
xscale = col.forest$range)
##
add.label(lr1, j,
unit(ref + (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr, "lines"),
"left",
fs.lr, ff.lr, col.label.right, fontfamily,
xscale = col.forest$range)
##
if (newline.lr)
add.label(lr2, j,
unit(ref + (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr - 1, "lines"),
"left",
fs.lr, ff.lr, col.label.right, fontfamily,
xscale = col.forest$range)
}
}
##
add.xlab(col.forest, j, xlab, xlab.add, newline.xlab,
xlab.pos, xlab.ypos, fs.xlab, ff.xlab,
fontfamily)
##
draw.forest(col.forest, j)
##
j <- j + 2
##
##
## Right side of forest plot
##
##
if (rsel) {
for (i in seq_along(rightcols)) {
add.text(cols[[rightcols[i]]], j)
##
if (!is.na(yHeadadd)) {
if (!is.null(label.e.attach)) {
if (rightcols[i] == paste0("col.", label.e.attach))
add.text(col.label.e, j)
}
else if (metabin) {
if (rightcols[i] == "col.n.e" & just.c == "right")
add.text(col.label.e, j)
else if (rightcols[i] == "col.event.e" &
just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
else if (metacont) {
if (rightcols[i] == "col.sd.e" & just.c == "right")
add.text(col.label.e, j)
else if (rightcols[i] == "col.mean.e" &
just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
else if (metainc) {
if (rightcols[i] == "col.time.e" & just.c == "right")
add.text(col.label.e, j)
else if (rightcols[i] == "col.event.e" &
just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
else if (metamean) {
if (revman5 & rightcols[i] == "col.n.e" & just.c == "right")
add.text(col.label.e, j)
else if (!revman5 & rightcols[i] == "col.sd.e" & just.c == "right")
add.text(col.label.e, j)
else if (rightcols[i] == "col.sd.e" & just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
##
if (!is.null(label.c.attach)) {
if (rightcols[i] == paste0("col.", label.c.attach))
add.text(col.label.c, j)
}
else if (metabin) {
if (rightcols[i] == "col.n.c" & just.c == "right")
add.text(col.label.c, j)
else if (rightcols[i] == "col.event.c" &
just.c %in% c("left", "center"))
add.text(col.label.c, j)
}
else if (metacont) {
if (rightcols[i] == "col.sd.c" & just.c == "right")
add.text(col.label.c, j)
else if (rightcols[i] == "col.mean.c" &
just.c %in% c("left", "center"))
add.text(col.label.c, j)
}
else if (metainc) {
if (rightcols[i] == "col.time.c" & just.c == "right")
add.text(col.label.c, j)
else if (rightcols[i] == "col.event.c" &
just.c %in% c("left", "center"))
add.text(col.label.c, j)
}
##
if (newline.studlab & rightcols[i] == "col.studlab")
add.text(col.add.studlab, j)
if (newline.effect & rightcols[i] == "col.effect")
add.text(col.add.effect, j)
if (newline.ci & rightcols[i] == "col.ci")
add.text(col.add.ci, j)
if (newline.effect.ci & rightcols[i] == "col.effect.ci")
add.text(col.add.effect.ci, j)
if (newline.w.common & rightcols[i] == "col.w.common")
add.text(col.add.w.common, j)
if (newline.w.random & rightcols[i] == "col.w.random")
add.text(col.add.w.random, j)
if (newline.TE & rightcols[i] == "col.TE")
add.text(col.add.TE, j)
if (newline.seTE & rightcols[i] == "col.seTE")
add.text(col.add.seTE, j)
if (newline.cluster & rightcols[i] == "col.cluster")
add.text(col.add.cluster, j)
if (newline.n.e & rightcols[i] == "col.n.e")
add.text(col.add.n.e, j)
if (newline.n.c & rightcols[i] == "col.n.c")
add.text(col.add.n.c, j)
if (newline.event.e & rightcols[i] == "col.event.e")
add.text(col.add.event.e, j)
if (newline.event.c & rightcols[i] == "col.event.c")
add.text(col.add.event.c, j)
if (newline.mean.e & rightcols[i] == "col.mean.e")
add.text(col.add.mean.e, j)
if (newline.mean.c & rightcols[i] == "col.mean.c")
add.text(col.add.mean.c, j)
if (newline.sd.e & rightcols[i] == "col.sd.e")
add.text(col.add.sd.e, j)
if (newline.sd.c & rightcols[i] == "col.sd.c")
add.text(col.add.sd.c, j)
if (newline.cor & rightcols[i] == "col.cor")
add.text(col.add.cor, j)
if (newline.time.e & rightcols[i] == "col.time.e")
add.text(col.add.time.e, j)
if (newline.time.c & rightcols[i] == "col.time.c")
add.text(col.add.time.c, j)
##
if (metainf.metacum) {
if (newline.pval & rightcols[i] == "col.pval")
add.text(col.add.pval, j)
if (newline.tau2 & rightcols[i] == "col.tau2")
add.text(col.add.tau2, j)
if (newline.tau & rightcols[i] == "col.tau")
add.text(col.add.tau, j)
if (newline.I2 & rightcols[i] == "col.I2")
add.text(col.add.I2, j)
}
##
## Add text in first line of forest plot for new columns
##
if (newcols)
if (length(rightcols.new) > 0 &
rightcols[i] %in% paste0("col.", rightcols.new)) {
sel <- paste0("col.", rightcols.new) == rightcols[i]
##
## Check for "\n" in label of new column
##
clines <- twolines(rightlabs.new[sel], rightcols[i])
##
just.new <- just.addcols.right[sel]
##
if (just.new == "left")
xpos.new <- 0
else if (just.new == "center")
xpos.new <- 0.5
else if (just.new == "right")
xpos.new <- 1
##
## Add first line
##
if (clines$newline)
add.text(tgl(clines$top, xpos.new, just.new,
fs.head, ff.head, fontfamily), j)
}
}
##
j <- j + 2
}
}
##
popViewport()
##
## Add header line
##
pushViewport(viewport(layout = grid.layout(
nrow,
length(x1),
widths = x1,
heights = unit(spacing, "lines"))))
##
if (jama)
hcols <- lsel * 2 * length(leftcols)
else
hcols <-
lsel * 2 * length(leftcols) + 1 + rsel * 2 * length(rightcols)
##
if (header.line) {
if (header.line.pos == "both") {
for (i in seq_len(hcols)) {
pushViewport(viewport(layout.pos.col = i, xscale = col.forest$range))
grid.lines(x = unit(0:1, "npc"),
y = unit(nrow + 0.5 * addrow, "lines"),
gp = gpar(lwd = lwd))
popViewport()
}
}
##
for (i in seq_len(hcols)) {
pushViewport(viewport(layout.pos.col = i, xscale = col.forest$range))
grid.lines(x = unit(0:1, "npc"),
y = unit(ymax + 0.5 * addrow, "lines"),
gp = gpar(lwd = lwd))
popViewport()
}
}
##
## Add JAMA lines
##
if (jama & header.line & !by) {
for (i in seq_len(hcols)) {
pushViewport(viewport(layout.pos.col = i, xscale = col.forest$range))
for (j in seq_len(k.all + n.com * common + n.ran * random +
n.prd * prediction))
grid.lines(x = unit(0:1, "npc"),
y = unit(ymax + 0.5 * addrow - j, "lines"),
gp = gpar(lwd = 0.5 * lwd, col = col.subgroup))
popViewport()
}
}
res <- list(xlim = xlim, addrows.below.overall = addrows.below.overall,
##
colgap = colgap,
colgap.left = colgap.left,
colgap.right = colgap.right,
colgap.studlab = colgap.studlab,
colgap.forest = colgap.forest.left,
colgap.forest.left = colgap.forest,
colgap.forest.right = colgap.forest.right,
##
studlab = studlab,
TE.format = TE.format,
seTE.format = seTE.format,
cluster.format = cluster.format,
effect.format = effect.format,
ci.format = ci.format)
##
if (metainf.metacum) {
res$pval.format <- pval.format
res$tau2.format <- tau2.format
res$tau.format <- tau.format
res$I2.format <- I2.format
}
invisible(res)
}
Try the meta package in your browser
Any scripts or data that you put into this service are public.
meta documentation built on June 7, 2023, 5:08 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 forest.meta
Documented in forest.meta
#' Forest plot to display the result of a meta-analysis
#'
#' @description
#' Draws a forest plot in the active graphics window (using grid
#' graphics system).
#'
#' @aliases forest forest.meta
#'
#' @param x An object of class \code{meta}.
#' @param sortvar An optional vector used to sort the individual
#' studies (must be of same length as \code{x$TE}).
#' @param studlab A logical indicating whether study labels should be
#' printed in the graph. A vector with study labels can also be
#' provided (must be of same length as \code{x$TE} then).
#' @param layout A character string specifying the layout of the
#' forest plot (see Details).
#' @param common A logical indicating whether common effect estimate
#' should be plotted.
#' @param random A logical indicating whether random effects estimate
#' should be plotted.
#' @param overall A logical indicating whether overall summaries
#' should be plotted. This argument is useful in a meta-analysis
#' with subgroups if summaries should only be plotted on group
#' level.
#' @param text.common A character string used in the plot to label the
#' pooled common effect estimate.
#' @param text.random A character string used in the plot to label the
#' pooled random effects estimate.
#' @param lty.common Line type (pooled common effect estimate).
#' @param lty.random Line type (pooled random effects estimate).
#' @param col.common Line colour (pooled common effect estimate).
#' @param col.random Line colour (pooled random effects estimate).
#' @param text.w.common A character string used to label weights of
#' common effect model.
#' @param text.w.random A character string used to label weights of
#' random effects model.
#' @param prediction A logical indicating whether a prediction
#' interval should be printed.
#' @param text.predict A character string used in the plot to label
#' the prediction interval.
#' @param subgroup A single logical or logical vector indicating
#' whether / which subgroup results should be shown in forest
#' plot. This argument is useful in a meta-analysis with subgroups
#' if summaries should not be plotted for (some) subgroups.
#' @param subgroup.hetstat A single logical or logical vector
#' indicating whether / which information on heterogeneity in
#' subgroups should be shown in forest plot. This argument is useful
#' in a meta-analysis with subgroups if heterogeneity statistics
#' should not be printed for (some) subgroups.
#' @param print.subgroup.labels A logical indicating whether subgroup
#' label should be printed.
#' @param subgroup.name A character string with a label 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 text.common.w A character string to label the pooled common
#' effect estimate within subgroups, or a character vector of same
#' length as number of subgroups with corresponging labels.
#' @param text.random.w A character string to label the pooled random
#' effect estimate within subgroups, or a character vector of same
#' length as number of subgroups with corresponging labels.
#' @param text.predict.w A character string to label the prediction
#' interval within subgroups, or a character vector of same length
#' as number of subgroups with corresponging labels.
#' @param sort.subgroup A logical indicating whether groups should be
#' ordered alphabetically.
#' @param pooled.totals A logical indicating whether total number of
#' observations should be given in the figure.
#' @param pooled.events A logical indicating whether total number of
#' events should be given in the figure.
#' @param pooled.times A logical indicating whether total person time
#' at risk should be given in the figure.
#' @param study.results A logical indicating whether results for
#' individual studies should be shown in the figure (useful to only
#' plot subgroup results).
#' @param xlab A label for the x-axis.
#' @param xlab.pos A numeric specifying the center of the label on the
#' x-axis.
#' @param smlab A label for the summary measure (printed at top of
#' figure).
#' @param smlab.pos A numeric specifying the center of the label for
#' the summary measure.
#' @param xlim The x limits (min,max) of the plot, or the character
#' string "symmetric" to produce symmetric forest plots.
#' @param allstudies A logical indicating whether studies with
#' inestimable treatment effects should be included in the forest
#' plot.
#' @param weight.study A character string indicating weighting used to
#' determine size of squares or diamonds (argument
#' \code{type.study}) to plot individual study results. One of
#' missing, \code{"same"}, \code{"common"}, or \code{"random"}, can
#' be abbreviated. Plot symbols have the same size for all studies
#' or represent study weights from common effect or random effects
#' model.
#' @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 ref A numerical giving the reference value to be plotted as
#' a line in the forest plot. No reference line is plotted if
#' argument \code{ref} is equal to \code{NA}.
#' @param lower.equi A numerical giving the lower limit of equivalence
#' to be plotted as a line in the forest plot. Or a vector to
#' provide several limits, e.g., for large, moderate and small
#' effects. No line is plotted if argument \code{lower.equi} is
#' equal to \code{NA}.
#' @param upper.equi A numerical giving the upper limit of equivalence
#' to be plotted as a line in the forest plot. Or a vector to
#' provide several limits, e.g., for small, moderate and large
#' effects. No line is plotted if argument \code{upper.equi} is
#' equal to \code{NA}.
#' @param lty.equi Line type (limits of equivalence).
#' @param col.equi Line colour (limits of equivalence).
#' @param fill.equi Colour(s) for area between limits of equivalence
#' or more general limits.
#' @param fill.lower.equi Colour of area between lower limit(s) and
#' reference value. Can be equal to the number of lower limits or
#' the number of limits plus 1 (in this case the the region between
#' minimum and smallest limit is also filled).
#' @param fill.upper.equi Colour of area between reference value and
#' upper limit(s). Can be equal to the number of upper limits or the
#' number of limits plus 1 (in this case the region between largest
#' limit and maximum is also filled).
#' @param leftcols A character vector specifying (additional) columns
#' to be printed on the left side of the forest plot or a logical
#' value (see Details).
#' @param rightcols A character vector specifying (additional) columns
#' to be printed on the right side of the forest plot or a logical
#' value (see Details).
#' @param leftlabs A character vector specifying labels for
#' (additional) columns on left side of the forest plot (see
#' Details).
#' @param rightlabs A character vector specifying labels for
#' (additional) columns on right side of the forest plot (see
#' Details).
#' @param label.e Label to be used for experimental group in table
#' heading.
#' @param label.c Label to be used for control group in table heading.
#' @param label.e.attach A character specifying the column name where
#' label \code{label.e} should be attached to in table heading.
#' @param label.c.attach A character specifying the column name where
#' label \code{label.c} should be attached to in table heading.
#' @param label.left Graph label on left side of forest plot.
#' @param label.right Graph label on right side of forest plot.
#' @param bottom.lr A logical indicating whether labels on right and
#' left side should be printed at bottom or top of forest plot.
#' @param lab.NA A character string to label missing values.
#' @param lab.NA.effect A character string to label missing values in
#' individual treatment estimates and confidence intervals.
#' @param lab.NA.weight A character string to label missing weights.
#' @param lwd The line width, see \code{\link{par}}.
#' @param at The points at which tick-marks are to be drawn, see
#' \code{grid.xaxis}.
#' @param label A logical value indicating whether to draw the labels
#' on the tick marks, or an expression or character vector which
#' specify the labels to use. See \code{\link{grid.xaxis}}.
#' @param type.study A character string or vector specifying how to
#' plot treatment effects and confidence intervals for individual
#' studies (see Details).
#' @param type.common A character string specifying how to plot
#' treatment effect and confidence interval for common effect
#' meta-analysis (see Details).
#' @param type.random A character string specifying how to plot
#' treatment effect and confidence interval for random effects
#' meta-analysis (see Details).
#' @param type.subgroup A character string specifying how to plot
#' treatment effect and confidence interval for subgroup results
#' (see Details).
#' @param type.subgroup.common A character string specifying how to
#' plot treatment effect and confidence interval for subgroup
#' results (common effect model).
#' @param type.subgroup.random A character string specifying how to
#' plot treatment effect and confidence interval for subgroup
#' results (random effects model).
#' @param col.study The colour for individual study results and
#' confidence limits.
#' @param col.inside The colour for individual study results and
#' confidence limits if confidence limits are completely within
#' squares.
#' @param col.inside.common The colour for result of common effect
#' meta-analysis if confidence limit lies completely within square.
#' @param col.inside.random The colour for result of random effects
#' meta-analysis if confidence limit lies completely within square.
#' @param col.square The colour for squares reflecting study's weight
#' in the meta-analysis.
#' @param col.square.lines The colour for the outer lines of squares
#' reflecting study's weight in the meta-analysis.
#' @param col.diamond The colour of diamonds representing the results
#' for common effect and random effects models.
#' @param col.diamond.common The colour of diamonds for common effect
#' estimates.
#' @param col.diamond.random The colour of diamonds for random effects
#' estimates.
#' @param col.diamond.lines The colour of the outer lines of diamonds
#' representing the results for common effect and random effects
#' models.
#' @param col.diamond.lines.common The colour of the outer lines of
#' diamond for common effect estimate.
#' @param col.diamond.lines.random The colour of the outer lines of
#' diamond for random effects estimate.
#' @param col.predict Background colour of prediction interval.
#' @param col.predict.lines Colour of outer lines of prediction
#' interval.
#' @param col.subgroup The colour to print information on subgroups.
#' @param col.label.right The colour for label on right side of null
#' effect.
#' @param col.label.left The colour for label on left side of null
#' effect.
#' @param hetstat Either a logical value indicating whether to print
#' results for heterogeneity measures at all or a character string
#' (see Details).
#' @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 hetlab Label printed in front of results for heterogeneity
#' measures.
#' @param resid.hetstat A logical value indicating whether to print
#' measures of residual heterogeneity in a meta-analysis with
#' subgroups.
#' @param resid.hetlab Label printed in front of results for residual
#' heterogeneity measures.
#' @param print.I2 A logical value indicating whether to print the
#' value of the I-squared statistic.
#' @param print.I2.ci A logical value indicating whether to print the
#' confidence interval of the I-squared statistic.
#' @param print.tau2 A logical value indicating whether to print the
#' value of the between-study variance \eqn{\tau^2}.
#' @param print.tau2.ci A logical value indicating whether to print
#' the confidence interval of \eqn{\tau^2}.
#' @param print.tau A logical value indicating whether to print
#' \eqn{\tau}, the square root of the between-study variance
#' \eqn{\tau^2}.
#' @param print.tau.ci A logical value indicating whether to print the
#' confidence interval of \eqn{\tau}.
#' @param print.Q A logical value indicating whether to print the
#' value of the heterogeneity statistic Q.
#' @param print.pval.Q A logical value indicating whether to print the
#' p-value of the heterogeneity statistic Q.
#' @param print.Rb A logical value indicating whether to print the
#' value of the I-squared statistic.
#' @param print.Rb.ci A logical value indicating whether to print the
#' confidence interval of the I-squared statistic.
#' @param text.subgroup.nohet A logical value or character string
#' which is printed to indicate subgroups with less than two studies
#' contributing to meta-analysis (and thus without
#' heterogeneity). If FALSE, heterogeneity statistics are printed
#' (with NAs).
#' @param LRT A logical value indicating whether to report
#' Likelihood-Ratio or Wald-type test of heterogeneity for
#' generalized linear mixed models.
#' @param test.overall A logical value indicating whether to print
#' results of test for overall effect.
#' @param test.overall.common A logical value indicating whether to
#' print results of test for overall effect (common effect model).
#' @param test.overall.random A logical value indicating whether to
#' print results of test for overall effect (random effects model).
#' @param label.test.overall.common Label printed in front of results
#' of test for overall effect (common effect model).
#' @param label.test.overall.random Label printed in front of results
#' of test for overall effect (random effects model).
#' @param print.stat A logical value indicating whether z- or t-value
#' for test of treatment effect should be printed.
#' @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 (common effect
#' model).
#' @param test.subgroup.random A logical value indicating whether to
#' print results of test for subgroup differences (random effects
#' model).
#' @param prediction.subgroup A single logical or logical vector
#' indicating whether / which prediction intervals should be printed
#' for subgroups.
#' @param print.Q.subgroup A logical value indicating whether to print
#' the value of the heterogeneity statistic Q (test for subgroup
#' differences).
#' @param label.test.subgroup.common Label printed in front of results
#' of test for subgroup differences (common effect model).
#' @param label.test.subgroup.random Label printed in front of results
#' of test for subgroup differences (random effects model).
#' @param test.effect.subgroup A single logical or logical vector
#' indicating whether / which tests for effect in subgroups should
#' be printed.
#' @param test.effect.subgroup.common A single logical or logical
#' vector indicating whether / which tests for effect in subgroups
#' should be printed (common effect model).
#' @param test.effect.subgroup.random A single logical or logical
#' vector indicating whether / which tests for effect in subgroups
#' should be printed (random effects model).
#' @param label.test.effect.subgroup.common Label printed in front of
#' results of test for effect in subgroups (common effect model).
#' @param label.test.effect.subgroup.random Label printed in front of
#' results of test for effect in subgroups (random effects model).
#' @param text.addline1 Text for first additional line (below
#' meta-analysis results).
#' @param text.addline2 Text for second additional line (below
#' meta-analysis results).
#' @param header.line A logical value indicating whether to print a
#' header line or a character string ("both", "below", "").
#' @param fontsize The size of text (in points), see
#' \code{\link{gpar}}.
#' @param fontfamily The font family, see \code{\link{gpar}}.
#' @param fs.heading The size of text for column headings, see
#' \code{\link{gpar}}.
#' @param fs.common The size of text for results of common effect
#' model, see \code{\link{gpar}}.
#' @param fs.random The size of text for results of random effects
#' model, see \code{\link{gpar}}.
#' @param fs.predict The size of text for results of prediction
#' interval, see \code{\link{gpar}}.
#' @param fs.common.labels The size of text for label of common effect
#' model, see \code{\link{gpar}}.
#' @param fs.random.labels The size of text for label of random
#' effects model, see \code{\link{gpar}}.
#' @param fs.predict.labels The size of text for label of prediction
#' interval, see \code{\link{gpar}}.
#' @param fs.study The size of text for results of individual studies,
#' see \code{\link{gpar}}.
#' @param fs.study.labels The size of text for labels of individual
#' studies, see \code{\link{gpar}}.
#' @param fs.hetstat The size of text for heterogeneity measures, see
#' \code{\link{gpar}}.
#' @param fs.test.overall The size of text of test for overall effect,
#' see \code{\link{gpar}}.
#' @param fs.test.subgroup The size of text of test of subgroup
#' differences, see \code{\link{gpar}}.
#' @param fs.test.effect.subgroup The size of text of test of effect
#' in subgroups, see \code{\link{gpar}}.
#' @param fs.addline The size of text for additional lines, see
#' \code{\link{gpar}}.
#' @param fs.axis The size of text on x-axis, see \code{\link{gpar}}.
#' @param fs.smlab The size of text of label for summary measure, see
#' \code{\link{gpar}}.
#' @param fs.xlab The size of text of label on x-axis, see
#' \code{\link{gpar}}.
#' @param fs.lr The size of text of label on left and right side of
#' forest plot, see \code{\link{gpar}}.
#' @param ff.heading The fontface for column headings, see
#' \code{\link{gpar}}.
#' @param ff.common The fontface of text for results of common effect
#' model, see \code{\link{gpar}}.
#' @param ff.random The fontface of text for results of random effects
#' model, see \code{\link{gpar}}.
#' @param ff.predict The fontface of text for results of prediction
#' interval, see \code{\link{gpar}}.
#' @param ff.common.labels The fontface of text for label of common
#' effect model, see \code{\link{gpar}}.
#' @param ff.random.labels The fontface of text for label of random
#' effects model, see \code{\link{gpar}}.
#' @param ff.predict.labels The fontface of text for label of
#' prediction interval, see \code{\link{gpar}}.
#' @param ff.study The fontface of text for results of individual
#' studies, see \code{\link{gpar}}.
#' @param ff.study.labels The fontface of text for labels of
#' individual studies, see \code{\link{gpar}}.
#' @param ff.hetstat The fontface of text for heterogeneity measures,
#' see \code{\link{gpar}}.
#' @param ff.test.overall The fontface of text of test for overall
#' effect, see \code{\link{gpar}}.
#' @param ff.test.subgroup The fontface of text for test of subgroup
#' differences, see \code{\link{gpar}}.
#' @param ff.test.effect.subgroup The fontface of text for test of
#' effect in subgroups, see \code{\link{gpar}}.
#' @param ff.addline The fontface of text for additional lines, see
#' \code{\link{gpar}}.
#' @param ff.axis The fontface of text on x-axis, see
#' \code{\link{gpar}}.
#' @param ff.smlab The fontface of text of label for summary measure,
#' see \code{\link{gpar}}.
#' @param ff.xlab The fontface of text of label on x-axis, see
#' \code{\link{gpar}}.
#' @param ff.lr The fontface of text of label on left and right side
#' of forest plot, see \code{\link{gpar}}.
#' @param squaresize A numeric used to increase or decrease the size
#' of squares in the forest plot.
#' @param plotwidth Either a character string, e.g., "8cm", "60mm", or
#' "3inch", or a \code{\link[grid]{unit}} object specifying width of
#' the forest plot.
#' @param colgap Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between columns
#' printed on left and right side of forest plot.
#' @param colgap.left Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between columns
#' printed on left side of forest plot.
#' @param colgap.right Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between columns
#' printed on right side of forest plot.
#' @param colgap.studlab Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between column
#' with study labels and subsequent column.
#' @param colgap.forest Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between column
#' adjacent to forest plot and the forest plot.
#' @param colgap.forest.left Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between column on
#' the left side of forest plot and the forest plot.
#' @param colgap.forest.right Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between column on
#' the right side of forest plot and the forest plot.
#' @param calcwidth.pooled A logical indicating whether text for
#' common effect and random effects model should be considered to
#' calculate width of the column with study labels.
#' @param calcwidth.common A logical indicating whether text given in
#' arguments \code{text.common} and \code{text.common.w} should be
#' considered to calculate width of the column with study labels.
#' @param calcwidth.random A logical indicating whether text given in
#' arguments \code{text.random} and \code{text.random.w} should be
#' considered to calculate width of the column with study labels.
#' @param calcwidth.predict A logical indicating whether text given in
#' argument \code{text.predict} and \code{text.predict.w} should be
#' considered to calculate width of the column with study labels.
#' @param calcwidth.hetstat A logical indicating whether text for
#' heterogeneity statistics should be considered to calculate width
#' of the column with study labels.
#' @param calcwidth.tests A logical indicating whether text for tests
#' of overall effect or subgroup differences should be considered to
#' calculate width of the column with study labels.
#' @param calcwidth.subgroup A logical indicating whether text with
#' subgroup labels should be considered to calculate width of the
#' column with study labels.
#' @param calcwidth.addline A logical indicating whether text for
#' additional lines should be considered to calculate width of the
#' column with study labels.
#' @param just Justification of text in all columns but columns with
#' study labels and additional variables (possible values: "left",
#' "right", "center").
#' @param just.studlab Justification of text for study labels
#' (possible values: "left", "right", "center").
#' @param just.addcols Justification of text for additional columns
#' (possible values: "left", "right", "center").
#' @param just.addcols.left Justification of text for additional
#' columns on left side of forest plot (possible values: "left",
#' "right", "center"). Can be of same length as number of additional
#' columns on left side of forest plot.
#' @param just.addcols.right Justification of text for additional
#' columns on right side of forest plot (possible values: "left",
#' "right", "center"). Can be of same length as number of additional
#' columns on right side of forest plot.
#' @param spacing A numeric determining line spacing in a forest plot.
#' @param addrow A logical value indicating whether an empty row is
#' printed above study results.
#' @param addrow.overall A logical value indicating whether an empty
#' row is printed above overall meta-analysis results.
#' @param addrow.subgroups A logical value indicating whether an empty
#' row is printed between results for subgroups.
#' @param addrows.below.overall A numeric value indicating how many
#' empty rows are printed between meta-analysis results and
#' heterogeneity statistics and test results.
#' @param new A logical value indicating whether a new figure should
#' be printed in an existing graphics window.
#' @param backtransf A logical indicating whether results should be
#' back transformed in forest plots. If \code{backtransf = TRUE},
#' results for \code{sm = "OR"} are presented as odds ratios rather
#' than log odds ratios and results for \code{sm = "ZCOR"} are
#' presented as correlations rather than Fisher's z transformed
#' correlations, for example.
#' @param digits Minimal number of significant digits for treatment
#' effects, see \code{print.default}.
#' @param digits.se Minimal number of significant digits for standard
#' errors, see \code{print.default}.
#' @param digits.stat Minimal number of significant digits for z- or
#' t-statistic for test of overall effect, see \code{print.default}.
#' @param digits.tau2 Minimal number of significant digits for
#' between-study variance, see \code{print.default}.
#' @param digits.tau Minimal number of significant digits for square
#' root of between-study variance, 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.I2 Minimal number of significant digits for I-squared
#' statistic, see \code{print.default}.
#' @param digits.weight Minimal number of significant digits for
#' weights, see \code{print.default}.
#' @param digits.mean Minimal number of significant digits for means;
#' only applies to \code{\link{metacont}} objects.
#' @param digits.sd Minimal number of significant digits for standard
#' deviations; only applies to \code{\link{metacont}} objects.
#' @param digits.cor Minimal number of significant digits for
#' correlations; only applies to \code{\link{metacor}} objects.
#' @param digits.time Minimal number of significant digits for times;
#' only applies to \code{\link{metainc}} and \code{\link{metarate}}
#' objects.
#' @param digits.TE Minimal number of significant digits for list
#' element 'TE'.
#' @param digits.addcols A vector or scalar with minimal number of
#' significant digits for additional columns.
#' @param digits.addcols.left A vector or scalar with minimal number
#' of significant digits for additional columns on left side of
#' forest plot.
#' @param digits.addcols.right A vector or scalar with minimal number
#' of significant digits for additional columns on right side of
#' forest plot.
#' @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 warn.deprecated A logical indicating whether warnings should
#' be printed if deprecated arguments are used.
#' @param \dots Additional graphical arguments.
#'
#' @details
#' A forest plot, also called confidence interval plot, is drawn in
#' the active graphics window. The forest functions in R package
#' \bold{meta} are based on the grid graphics system. In order to
#' print the forest plot, resize the graphics window and either use
#' \code{\link{dev.copy2eps}} or \code{\link{dev.copy2pdf}}. Another
#' possibility is to create a file using \code{\link{pdf}},
#' \code{\link{png}}, or \code{\link{svg}} and to specify the width and
#' height of the graphic (see Examples).
#'
#' \subsection{Default layout for studies and pooled effects}{
#'
#' By default, treatment estimates and confidence intervals are
#' plotted in the following way:
#' \itemize{
#' \item For an individual study, a square with treatment estimate in
#' the center and confidence interval as line extending either side
#' of the square (\code{type.study = "square"})
#' \item For meta-analysis results, a diamond with treatment estimate
#' in the center and right and left side corresponding to lower and
#' upper confidence limits (\code{type.common = "diamond"},
#' \code{type.random = "diamond"}, and \code{type.subgroup = "diamond"})
#' }
#'
#' In a forest plot, size of the squares typically reflects the precision of
#' individual treatment estimates based either on the common effect
#' (\code{weight.study = "common"}) or random effects meta-analysis
#' (\code{weight.study = "random"}). Information from meta-analysis object
#' \code{x} is utilised if argument \code{weight.study} is missing. Weights
#' from the common effect model are used if argument \code{x$common} is
#' \code{TRUE}; weights from the random effects model are used if argument
#' \code{x$random} is \code{TRUE} and \code{x$common} is \code{FALSE}.
#' The same square sizes are used if \code{weight.study = "same"}.
#'
#' A prediction interval for treatment effect of a new study (Higgins
#' et al., 2009) is given in the forest plot if arguments
#' \code{prediction} and \code{random} are \code{TRUE}. For
#' graphical presentation of prediction intervals the approach by
#' Guddat et al. (2012) is used.
#' }
#'
#' \subsection{Columns printed on left side of forest plot}{
#'
#' Argument \code{leftcols} can be used to specify columns which are
#' printed on the left side of the forest plot. By default, i.e. if
#' argument \code{leftcols} is \code{NULL} and \code{layout = "meta"},
#' and depending on the class of the meta-analysis object (which is
#' defined by the R function used to generate the object) a different
#' set of \emph{\bold{columns}} is printed \emph{\bold{on the left
#' side of the forest plot}}:
#' \tabular{ll}{
#' \bold{Function} \tab \bold{Value of argument leftcols} \cr
#' \code{\link{metabin}} \tab \code{c("studlab", "event.e", "n.e",
#' "event.c", "n.c")} \cr
#' \code{\link{metacont}} \tab \code{c("studlab", "n.e", "mean.e",
#' "sd.e", "n.c", "mean.c", "sd.c")} \cr
#' \code{\link{metacor}} \tab \code{c("studlab", "n")} \cr
#' \code{\link{metagen}} \tab \code{c("studlab", "TE", "seTE")} \cr
#' \code{\link{metainc}} \tab \code{c("studlab", "event.e", "time.e",
#' "event.c", "time.c")} \cr
#' \code{\link{metamean}} \tab \code{c("studlab", "n", "mean", "sd")}
#' \cr
#' \code{\link{metaprop}} \tab \code{c("studlab", "event", "n")} \cr
#' \code{\link{metarate}} \tab \code{c("studlab", "event", "time", "n")}
#' \cr
#' \code{\link{metacum}} \tab \code{"studlab"} \cr
#' \code{\link{metainf}} \tab \code{"studlab"}
#' }
#'
#' For three-level models, the cluster variable is printed next to the
#' study labels (value \code{"cluster"} in argument \code{leftcols}).
#'
#' By default, study labels and labels for pooled estimates and
#' heterogeneity statistics will be printed in the first column on the
#' left side of the forest plot. The character string \code{"studlab"}
#' is used to identify study labels as this is the name of the list
#' element of a meta-analysis object.
#'
#' If the character string \code{"studlab"} is not provided in
#' \code{leftcols} and \code{rightcols}, the first \emph{additional}
#' variable specified by the user is used as study labels (and labels
#' for pooled estimates are printed in this column). Additional
#' variables are any variables not mentioned in the section on
#' predefined column names below. For example, \code{leftcols =
#' "studlab"} and \code{leftcols = "study"} would result in the same
#' forest plot if the variable \code{"study"} was used in the command
#' to conduct the meta-analysis. If no additional variable is provided
#' by the user, no study labels will be printed.
#' }
#'
#' \subsection{Overlapping information on left side of forest plot}{
#'
#' Depending on the number of columns printed on the left side of the
#' forest plot, information on heterogeneity measures or statistical
#' tests (see below) can be overlapping with the x-axis. Argument
#' \code{addrows.below.overall} can be used to specify the number of
#' empty rows that are printed between meta-analysis results and
#' information on heterogeneity measures and statistical tests. By
#' default, no additional rows are added to the forest plot. If
#' \code{addrows.below.overall = NULL}, the function tries to add a
#' sufficient number of empty rows to prevent overlapping
#' text. Another possibility is to manually increase the space between
#' the columns on the left side (argument \code{colgap.left}) or
#' between the columns on the left side and the forest plot (argument
#' \code{colgap.forest.left}).
#' }
#'
#' \subsection{Columns printed on right side of forest plot}{
#'
#' Argument \code{rightcols} can be used to
#' specify columns which are printed on the right side of the
#' forest plot. If argument \code{rightcols} is
#' \code{FALSE}, no columns will be printed on the right side. By
#' default, i.e. if argument \code{rightcols} is
#' \code{NULL} and \code{layout = "meta"}, the following
#' \emph{\bold{columns}} will be printed \emph{\bold{on the right side
#' of the forest plot}}:
#' \tabular{ll}{
#' \bold{Meta-analysis results} \tab \bold{Value of argument
#' rightcols} \cr
#' No summary \tab \code{c("effect", "ci")} \cr
#' Only common effect model \tab \code{c("effect", "ci", "w.common")}
#' \cr
#' Only random effects model \tab \code{c("effect", "ci", "w.random")}
#' \cr
#' Both models \tab \code{c("effect", "ci", "w.common", "w.random")}
#' }
#'
#' By default, estimated treatment effect and corresponding confidence
#' interval will be printed. Depending on arguments \code{common} and
#' \code{random}, weights of the common effect and/or random effects
#' model will be given too.
#'
#' For an object of class \code{\link{metacum}} or
#' \code{\link{metainf}} the following columns will be printed:
#' \code{c("effect", "ci", "pval", "tau2", "tau", "I2")}. This
#' information corresponds to the printout with
#' \code{\link{print.meta}}.
#' }
#'
#' \subsection{Predefined column names}{
#'
#' The arguments \code{leftlabs} and \code{rightlabs} can be used to
#' specify column headings which are printed on left or right side of
#' the forest plot. For certain columns predefined labels exist which
#' are used by default, i.e., if arguments \code{leftlabs} and
#' \code{rightlabs} are \code{NULL}:
#' \tabular{rcccccc}{
#' Column: \tab \code{studlab} \tab \code{TE} \tab \code{seTE} \tab
#' \code{cluster} \tab \code{n.e} \tab \code{n.c} \cr
#' Label: \tab "Study" \tab "TE" \tab "seTE" \tab "Cluster" \tab
#' "Total" \tab "Total" \cr
#' \cr
#' Column: \tab \code{n} \tab \code{event.e} \tab \code{event.c} \tab
#' \code{event} \tab \code{mean.e} \tab \code{mean.c} \cr
#' Label: \tab "Total" \tab "Events" \tab "Events" \tab "Events" \tab
#' "Mean" \tab "Mean" \cr
#' \cr
#' Column: \tab \code{sd.e} \tab \code{sd.c} \tab \code{time.e}
#' \tab \code{time.c} \tab \code{effect} \tab \cr
#' Label: \tab "SD" \tab "SD" \tab "Time" \tab "Time" \tab
#' \code{x$sm} \tab \cr
#' \cr
#' Column: \tab \code{ci} \tab \code{effect.ci} \tab
#' \code{w.common} \tab \code{w.random} \tab \tab \cr
#' Label: \tab \code{x$level}"\%-CI" \tab \emph{effect+ci} \tab
#' "W(common)" \tab "W(random)" \tab \tab
#' }
#'
#' For other columns, the column name will be used as a label if no
#' column label is defined. It is possible to only provide labels for
#' new columns (see Examples). Otherwise the length of \code{leftlabs}
#' and \code{rightlabs} must be the same as the number of printed
#' columns. The value \code{NA} can be used to specify columns which
#' should use default labels (see Examples).
#'
#'
#' In pairwise meta-analysis comparing two groups (i.e.,
#' \code{\link{metabin}}, \code{\link{metacont}},
#' \code{\link{metainc}}, and \code{\link{metagen}} depending on the
#' outcome), arguments \code{label.e} and \code{label.c} are used to
#' label columns belonging to the two treatment groups. By default,
#' labels defined in the meta-analysis object are used. The columns
#' where treatment labels are attached can be changed using arguments
#' \code{label.e.attach} and \code{label.c.attach}.
#' }
#'
#' \subsection{Information on heterogeneity and statistical tests}{
#'
#' Argument \code{hetstat} can be a character string to specify where
#' to print heterogeneity information:
#' \itemize{
#' \item row with results for common effect model (\code{hetstat =
#' "common"}),
#' \item row with results for random effects model (\code{hetstat =
#' "random"}).
#' }
#'
#' Otherwise, information on heterogeneity measures is printed below
#' the meta-analysis results if argument \code{overall.hetstat = TRUE}
#' (default). The heterogeneity measures to print can be specified
#' (see list of arguments following \code{overall.hetstat}).
#'
#' In addition, the following arguments can be used to print results
#' for various statistical tests:
#' \tabular{ll}{
#' \bold{Argument} \tab \bold{Statistical test} \cr
#' \code{test.overall.common} \tab Test for overall effect (common
#' effect model) \cr
#' \code{test.overall.random} \tab Test for overall effect (random
#' effects model) \cr
#' \code{test.effect.subgroup.common} \tab Test for effect in subgroup
#' (CE model) \cr
#' \code{test.effect.subgroup.random} \tab Test for effect in subgroup
#' (RE model) \cr
#' \code{test.subgroup.common} \tab Test for subgroup differences (CE
#' model) \cr
#' \code{test.subgroup.random} \tab Test for subgroup differences (RE
#' model)
#' }
#'
#' By default, these arguments are \code{FALSE} with exception of
#' tests for subgroup differences which are \code{TRUE}. R function
#' \code{\link{settings.meta}} can be used to change this default for
#' the entire R session. For example, use the following command to
#' always print results of tests for an overall effect:
#' \code{settings.meta(test.overall = TRUE)}.
#' }
#'
#' \subsection{Flexible printing of subgroup results}{
#'
#' Argument \code{subgroup} determines whether summary results are
#' printed for subgroups. A logical vector of length equal to the
#' number of subgroups can be provided to determine which subgroup
#' summaries are printed. By default, only subgroup results based on
#' at least two studies are printed which is identical to use argument
#' \code{subgroup = k.w > 1}. The order of the logical vector
#' corresponds to the order of subgroups in list element 'subgroup.levels' of a
#' meta-analysis object. Argument \code{subgroup = k.w >= 1} can be
#' used to show results for all subgroups (including those with a
#' single study).
#'
#' The following arguments can be used in a similar way:
#'
#' \itemize{
#' \item \code{subgroup.hetstat} (heterogeneity statistic in
#' subgroups),
#' \item \code{prediction.subgroup} (prediction interval in
#' subgroups),
#' \item \code{test.effect.subgroup} (test for effect in subgroups),
#' \item \code{test.effect.subgroup.common} (test for effect in
#' subgroups, common effect model),
#' \item \code{test.effect.subgroup.random} (test for effect in
#' subgroups, random effects model).
#' }
#' }
#'
#' \subsection{Additional general settings}{
#'
#' Arguments \code{text.common}, \code{text.random}, and
#' \code{text.predict} can be used to change the label to identify
#' overall results (common effect and random effects model as well as
#' prediction interval). By default the following text is printed:
#' \itemize{
#' \item "Common effect model" (argument \code{text.common})
#' \item "Random effects model" (\code{text.random})
#' \item "Prediction interval" (\code{text.predict})
#' }
#'
#' If confidence interval levels are different for individual studies,
#' meta-analysis, and prediction interval (arguments \code{level},
#' \code{level.ma}, \code{level.predict} in meta-analysis functions,
#' e.g., \code{\link{metabin}}), additional information is printed,
#' e.g., " (99\%-CI)" for a 99\% confidence interval in the
#' meta-analysis.
#'
#' 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.
#' }
#'
#' \subsection{Forest plots in RevMan5 layout}{
#'
#' If argument \code{layout = "RevMan5"} (and arguments \code{leftcols} and
#' \code{rightcols} are \code{NULL}), the layout for forest plots used for
#' Cochrane reviews (which are generated with Review Manager 5,
#' \url{https://training.cochrane.org/online-learning/core-software/revman})
#' is reproduced:
#' \enumerate{
#' \item All columns are printed on the left side of the forest plot
#' (see arguments \code{leftcols} and \code{rightcols})
#' \item Tests for overall effect and subgroup differences are printed
#' (\code{test.overall}, \code{test.effect.subgroup},
#' \code{test.subgroup})
#' \item Diamonds representing meta-analysis results are printed in
#' black (\code{diamond.common}, \code{diamond.random})
#' \item Colour of squares depends on the meta-analysis object
#' (\code{col.square}, \code{col.square.lines})
#' \item Information on effect measure and meta-analysis method is
#' printed above the forest plot (\code{smlab})
#' \item Label "Study or Subgroup" is printed for meta-analysis with
#' subgroups (\code{leftlabs})
#' }
#' }
#'
#' \subsection{Forest plots in JAMA layout}{
#'
#' If argument \code{layout = "JAMA"} (and arguments \code{leftcols} and
#' \code{rightcols} are \code{NULL}), instructions for authors of the
#' \emph{Journal of the American Medical Association}, see
#' \url{https://jamanetwork.com/journals/jama/pages/instructions-for-authors/},
#' are taken into account:
#' \enumerate{
#' \item Graph labels on right and left side are printed in bold font
#' at top of forest plot (see arguments \code{bottom.lr} and
#' \code{ff.lr})
#' \item Information on effect measure and level of confidence
#' interval is printed at bottom of forest plot (\code{xlab})
#' \item Tests for overall effect are printed (\code{test.overall})
#' \item Diamonds representing meta-analysis results are printed in
#' lightblue (\code{diamond.common}, \code{diamond.random})
#' \item Squares representing individual study results are printed in
#' darkblue (\code{col.square}, \code{col.square.lines})
#' \item Between-study variance \eqn{\tau^2} is not printed
#' \item Empty rows are omitted (\code{addrow}, \code{addrow.overall},
#' \code{addrow.subgroups})
#' \item Label "Source" is printed instead of "Study" (\code{leftlabs})
#' \item P-values are printed without leading zeros (\code{zero.pval})
#' \item P-values are rounded to three digits (for 0.001 < p \eqn{\le}
#' 0.01) or two digits (p > 0.01) (\code{JAMA.pval})
#' }
#' Study labels according to JAMA guidelines can be generated using
#' \code{\link{labels.meta}}.
#' }
#'
#' \subsection{Forest plots showing results of subgroups}{
#'
#' The following changes are conducted if argument
#' \code{layout = "subgroup"} (and arguments \code{leftcols} and
#' \code{rightcols} are \code{NULL}) and a subgroup analysis was
#' conducted:
#' \enumerate{
#' \item Individual study results are omitted (see argument
#' \code{study.results})
#' \item Total number of observations is not printed
#' (\code{pooled.totals})
#' \item Label "Subgroup" is printed instead of "Study"
#' (\code{leftlabs})
#' }
#' }
#'
#' @author Guido Schwarzer \email{guido.schwarzer@@uniklinik-freiburg.de}
#'
#' @seealso \code{\link{metabin}}, \code{\link{metacont}},
#' \code{\link{metagen}}, \code{\link{forest.metabind}},
#' \code{\link{settings.meta}}, \code{\link{labels.meta}}
#'
#' @references
#' Guddat C, Grouven U, Bender R, Skipka G (2012):
#' A note on the graphical presentation of prediction intervals in
#' random-effects meta-analyses.
#' \emph{Systematic Reviews},
#' \bold{1}, 34
#'
#' Higgins JPT, Thompson SG, Spiegelhalter DJ (2009):
#' A re-evaluation of random-effects meta-analysis.
#' \emph{Journal of the Royal Statistical Society: Series A},
#' \bold{172}, 137-59
#'
#' @keywords hplot
#'
#' @examples
#' data(Olkin1995)
#' m1 <- metabin(ev.exp, n.exp, ev.cont, n.cont,
#' data = Olkin1995, subset = c(41, 47, 51, 59),
#' sm = "RR", method = "I",
#' studlab = paste(author, year))
#'
#'
#' \dontrun{
#' # Do standard (symmetric) forest plot
#' #
#' forest(m1)
#' }
#'
#' # Layout of forest plot similar to Review Manager 5
#' #
#' # Furthermore, add labels on both sides of forest plot and
#' # prediction interval
#' #
#' forest(m1, layout = "RevMan5", common = FALSE,
#' label.right = "Favours control", col.label.right = "red",
#' label.left = "Favours experimental", col.label.left = "green",
#' prediction = TRUE)
#'
#'
#' \dontrun{
#' # Create a PDF file forest-m1.pdf with the forest plot
#' #
#' pdf("forest-m1.pdf", width = 10, height = 3)
#' forest(m1)
#' dev.off()
#'
#' # Define equivalence limits: 0.75 and 1 / 0.75
#' #
#' forest(m1, layout = "RevMan5", common = FALSE,
#' lower.equi = 0.75, upper.equi = 1 / 0.75, fill.equi = "lightgray")
#'
#' # Fill areas with beneficial and detrimental effects
#' #
#' forest(m1, layout = "RevMan5", common = FALSE,
#' lower.equi = 0.75, upper.equi = 1 / 0.75,
#' fill.lower.equi = c("green", "lightgray"),
#' fill.upper.equi = c("lightgray", "red"))
#'
#' # Define thresholds for small, moderate and large effects
#' # and use hcl.colors() to define colours to fill areas
#' #
#' thresholds <- c(0.25, 0.5, 0.75)
#' n.cols <- length(thresholds) + 1
#' forest(m1, layout = "RevMan5", common = FALSE,
#' label.right = "Undesirable effect",
#' label.left = "Desirable effect",
#' lty.equi = 3, col.equi = "darkgray",
#' lower.equi = thresholds, upper.equi = 1 / rev(thresholds),
#' fill.lower.equi =
#' hcl.colors(n.cols, palette = "Blues 2", alpha = 0.6),
#' fill.upper.equi =
#' hcl.colors(n.cols, palette = "Oranges", alpha = 0.6, rev = TRUE))
#'
#' # Conduct subgroup meta-analysis
#' #
#' m2 <- update(m1,
#' subgroup = ifelse(year < 1987, "Before 1987", "1987 and later"),
#' print.subgroup.name = FALSE)
#'
#' # Show summary results for subgroups with at least two studies
#' #
#' forest(m2, sortvar = -TE, random = FALSE)
#'
#' # Show results for all subgroups
#' #
#' forest(m2, sortvar = -TE, random = FALSE, subgroup = k.w >= 1)
#'
#' # Forest plot specifying argument xlim
#' #
#' forest(m1, xlim = c(0.01, 10))
#'
#' # Print results of test for overall effect
#' #
#' forest(m1, test.overall.common = TRUE, test.overall.random = TRUE)
#'
#' # Forest plot with 'classic' layout used in R package meta,
#' # version < 1.6-0
#' #
#' forest(m1, col.square = "black", hetstat = FALSE)
#'
#' # Change set of columns printed on left side of forest plot
#' # (resulting in overlapping text)
#' #
#' forest(m1, random = FALSE, leftcols = "studlab")
#'
#' # Use argument 'calcwidth.hetstat' to consider text for heterogeneity
#' # measures in width of column with study labels
#' #
#' forest(m1, random = FALSE, leftcols = "studlab",
#' calcwidth.hetstat = TRUE)
#'
#' # Use argument 'addrows.below.overall' to manually add two empty
#' # rows
#' #
#' forest(m1, random = FALSE, leftcols = "studlab", addrows = 2)
#'
#' # Do not print columns on right side of forest plot
#' #
#' forest(m1, rightcols = FALSE)
#'
#' # Change study label to "Author"
#' #
#' forest(m1, random = FALSE, leftlabs = c("Author", NA, NA, NA, NA))
#'
#' # Just give effect estimate and 95% confidence interval on right
#' # side of forest plot (in one column)
#' #
#' forest(m1, rightcols = c("effect.ci"))
#'
#' # Just give effect estimate and 95% confidence interval on right
#' # side of forest plot
#' #
#' forest(m1, rightcols = c("effect", "ci"))
#'
#' # 1. Change order of columns on left side
#' # 2. Attach labels to columns 'event.e' and 'event.c' instead of
#' # columns 'n.e' and 'n.c'
#' #
#' forest(m1,
#' leftcols = c("studlab", "n.e", "event.e", "n.c", "event.c"),
#' label.e.attach = "event.e", label.c.attach = "event.c")
#'
#' # Specify column labels only for variables 'year' and 'author'
#' # (and define digits for additional variables)
#' #
#' forest(m1,
#' leftcols = c("studlab", "event.e", "n.e", "event.c", "n.c", "author", "year"),
#' leftlabs = c("Author", "Year of Publ"))
#'
#' # Center text in all columns
#' #
#' forest(m1,
#' leftcols = c("studlab", "event.e", "n.e", "event.c", "n.c",
#' "author", "year"),
#' leftlabs = c("Author", "Year of Publ"), hetstat = FALSE,
#' just = "center", just.addcols = "center", just.studlab = "center")
#'
#' # Same result
#' #
#' forest(m1,
#' leftcols = c("studlab", "event.e", "n.e", "event.c", "n.c",
#' "author", "year"),
#' leftlabs = c("Author", "Year of Publ"), hetstat = FALSE,
#' just = "c", just.addcols = "c", just.studlab = "c")
#'
#' # Change some fontsizes and fontfaces
#' #
#' forest(m1,
#' fs.study = 10, ff.study = "italic",
#' fs.study.label = 11, ff.study.label = "bold",
#' fs.axis = 5, ff.axis = "italic",
#' ff.smlab = "bold.italic",
#' ff.common = "plain", ff.hetstat = "plain")
#'
#' # Change some colours
#' #
#' forest(m1,
#' col.diamond = "green", col.diamond.lines = "red",
#' col.study = c("green", "blue", "red", "orange"),
#' col.square = "pink", col.square.lines = "black")
#'
#' # Sort by weight in common effect model
#' #
#' forest(m1, sortvar = w.common, random = FALSE)
#'
#' # Sort by decreasing weight in common effect model
#' #
#' forest(m1, sortvar = -w.common, random = FALSE)
#'
#' # Sort by size of treatment effect
#' #
#' forest(m1, sortvar = TE, random = FALSE)
#'
#' # Sort by size of treatment effect
#' #
#' forest(m1, sortvar = -TE, random = FALSE)
#'
#' # Sort by decreasing year of publication
#' #
#' forest(m1, sortvar = -year, random = FALSE)
#'
#' # Print results of test for subgroup differences (random effects
#' # model)
#' #
#' forest(m2, sortvar = -TE, common = FALSE)
#'
#' # Print only subgroup results
#' #
#' forest(m2, layout = "subgroup")
#'
#' # Print only subgroup results (and consider text for tests of
#' # subgroup differences in width of subgroup column)
#' #
#' forest(m2, layout = "subgroup", calcwidth.tests = TRUE)
#'
#' # Print only subgroup results (and consider text for heterogeneity
#' # in width of subgroup column)
#' #
#' forest(m2, layout = "subgroup", calcwidth.hetstat = TRUE)
#' }
#'
#' @method forest meta
#' @export
#' @export forest.meta
forest.meta <- function(x,
sortvar,
studlab = TRUE,
##
layout = gs("layout"),
##
common = x$common,
random = x$random,
overall = x$overall,
text.common = x$text.common,
text.random = x$text.random,
lty.common = gs("lty.common"),
lty.random = gs("lty.random"),
col.common = gs("col.common"),
col.random = gs("col.random"),
text.w.common = x$text.w.common,
text.w.random = x$text.w.random,
##
prediction = x$prediction,
text.predict = x$text.predict,
##
subgroup = TRUE,
subgroup.hetstat =
subgroup & (is.character(hetstat) || hetstat),
print.subgroup.labels = TRUE,
##
subgroup.name = x$subgroup.name,
print.subgroup.name = x$print.subgroup.name,
sep.subgroup = x$sep.subgroup,
text.common.w = text.common,
text.random.w = text.random,
text.predict.w = text.predict,
sort.subgroup = gs("sort.subgroup"),
##
pooled.totals = common | random,
pooled.events = gs("pooled.events"),
pooled.times = gs("pooled.times"),
##
study.results = gs("study.results"),
##
xlab = "", xlab.pos,
smlab = NULL, smlab.pos, xlim = "symmetric",
##
allstudies = TRUE,
weight.study = NULL,
pscale = x$pscale,
irscale = x$irscale, irunit = x$irunit,
##
ref,
##
lower.equi = gs("lower.equi"),
upper.equi = gs("upper.equi"),
lty.equi = gs("lty.equi"),
col.equi = gs("col.equi"),
fill.equi = gs("fill.equi"),
fill.lower.equi = fill.equi,
fill.upper.equi = rev(fill.equi),
##
leftcols = NULL, rightcols = NULL,
leftlabs = NULL, rightlabs = NULL,
##
label.e = x$label.e,
label.c = x$label.c,
##
label.e.attach = NULL,
label.c.attach = NULL,
##
label.right = x$label.right,
label.left = x$label.left,
bottom.lr = gs("bottom.lr"),
##
lab.NA = gs("lab.NA"),
lab.NA.effect = gs("lab.NA.effect"),
lab.NA.weight = gs("lab.NA.weight"),
##
lwd = gs("lwd"),
##
at = NULL,
label = TRUE,
##
type.study = gs("type.study"),
type.common = gs("type.common"),
type.random = type.common,
type.subgroup =
ifelse(study.results, "diamond", "square"),
type.subgroup.common = type.subgroup,
type.subgroup.random = type.subgroup,
##
col.study = gs("col.study"),
col.square = gs("col.square"),
col.square.lines = col.square,
##
col.inside = gs("col.inside"),
col.inside.common = col.inside,
col.inside.random = col.inside,
##
col.diamond = gs("col.diamond"),
col.diamond.common = col.diamond,
col.diamond.random = col.diamond,
col.diamond.lines = gs("col.diamond.lines"),
col.diamond.lines.common = col.diamond.lines,
col.diamond.lines.random = col.diamond.lines,
##
col.predict = gs("col.predict"),
col.predict.lines = gs("col.predict.lines"),
##
col.subgroup = gs("col.subgroup"),
##
col.label.right = gs("col.label.right"),
col.label.left = gs("col.label.left"),
##
hetstat = common | random | overall.hetstat,
overall.hetstat = x$overall.hetstat,
hetlab = gs("hetlab"),
resid.hetstat = gs("resid.hetstat"),
resid.hetlab = gs("resid.hetlab"),
##
print.I2 = gs("forest.I2"),
print.I2.ci = gs("forest.I2.ci"),
print.tau2 = gs("forest.tau2"),
print.tau2.ci = gs("forest.tau2.ci"),
print.tau = gs("forest.tau"),
print.tau.ci = gs("forest.tau.ci"),
print.Q = gs("forest.Q"),
print.pval.Q = gs("forest.pval.Q"),
print.Rb = gs("forest.Rb"),
print.Rb.ci = gs("forest.Rb.ci"),
text.subgroup.nohet = gs("text.subgroup.nohet"),
##
LRT = gs("LRT"),
##
test.overall = gs("test.overall"),
test.overall.common = common & overall & test.overall,
test.overall.random =
random & overall & test.overall,
label.test.overall.common,
label.test.overall.random,
##
print.stat = gs("forest.stat"),
##
test.subgroup = x$test.subgroup,
test.subgroup.common = test.subgroup & common,
test.subgroup.random = test.subgroup & random,
prediction.subgroup = x$prediction.subgroup,
print.Q.subgroup = gs("forest.Q.subgroup"),
label.test.subgroup.common,
label.test.subgroup.random,
##
test.effect.subgroup = gs("test.effect.subgroup"),
test.effect.subgroup.common,
test.effect.subgroup.random,
label.test.effect.subgroup.common,
label.test.effect.subgroup.random,
##
text.addline1,
text.addline2,
##
header.line,
##
fontsize = gs("fontsize"),
fontfamily = gs("fontfamily"),
fs.heading = fontsize,
fs.common = gs("fs.common"),
fs.random = gs("fs.random"),
fs.predict = gs("fs.predict"),
fs.common.labels = gs("fs.common.labels"),
fs.random.labels = gs("fs.random.labels"),
fs.predict.labels = gs("fs.predict.labels"),
fs.study = fontsize,
fs.study.labels = fs.study,
fs.hetstat = gs("fs.hetstat"),
fs.test.overall = gs("fs.test.overall"),
fs.test.subgroup = gs("fs.test.subgroup"),
fs.test.effect.subgroup = gs("fs.test.effect.subgroup"),
fs.addline = gs("fs.addline"),
fs.axis = fontsize,
fs.smlab = fontsize,
fs.xlab = fontsize,
fs.lr = fontsize,
##
ff.heading = "bold",
ff.common = gs("ff.common"),
ff.random = gs("ff.random"),
ff.predict = gs("ff.predict"),
ff.common.labels = gs("ff.common.labels"),
ff.random.labels = gs("ff.random.labels"),
ff.predict.labels = gs("ff.predict.labels"),
ff.study = "plain",
ff.study.labels = ff.study,
ff.hetstat = gs("ff.hetstat"),
ff.test.overall = gs("ff.test.overall"),
ff.test.subgroup = gs("ff.test.subgroup"),
ff.test.effect.subgroup = gs("ff.test.effect.subgroup"),
ff.addline = gs("ff.addline"),
ff.axis = gs("ff.axis"),
ff.smlab = gs("ff.smlab"),
ff.xlab = gs("ff.xlab"),
ff.lr = gs("ff.lr"),
##
squaresize = 0.8 / spacing,
##
plotwidth = if (layout == "JAMA") "8cm" else "6cm",
colgap = gs("colgap"),
colgap.left = colgap,
colgap.right = colgap,
colgap.studlab = colgap.left,
colgap.forest = colgap,
colgap.forest.left = colgap.forest,
colgap.forest.right = colgap.forest,
##
calcwidth.pooled =
(common | random) &
(overall | !is.null(x$subgroup)),
calcwidth.common = calcwidth.pooled,
calcwidth.random = calcwidth.pooled,
calcwidth.predict = gs("calcwidth.predict"),
calcwidth.hetstat = gs("calcwidth.hetstat"),
calcwidth.tests = gs("calcwidth.tests"),
calcwidth.subgroup = gs("calcwidth.subgroup"),
calcwidth.addline = gs("calcwidth.addline"),
##
just = if (layout == "JAMA") "left" else "right",
just.studlab = gs("just.studlab"),
just.addcols = gs("just.addcols"),
just.addcols.left = just.addcols,
just.addcols.right = just.addcols,
##
spacing = gs("spacing"),
addrow = gs("addrow"),
addrow.overall = gs("addrow.overall"),
addrow.subgroups = gs("addrow.subgroups"),
addrows.below.overall = gs("addrows.below.overall"),
##
new = TRUE,
##
backtransf = x$backtransf,
digits = gs("digits.forest"),
digits.se = gs("digits.se"),
digits.stat = gs("digits.stat"),
digits.pval = max(gs("digits.pval") - 2, 2),
digits.pval.Q = max(gs("digits.pval.Q") - 2, 2),
digits.Q = gs("digits.Q"),
digits.tau2 = gs("digits.tau2"),
digits.tau = gs("digits.tau"),
digits.I2 = max(gs("digits.I2") - 1, 0),
digits.weight = gs("digits.weight"),
##
digits.mean = digits,
digits.sd = digits.se,
digits.cor = digits,
digits.time = digits,
##
digits.TE = gs("digits.TE.forest"),
##
digits.addcols = digits,
digits.addcols.right = digits.addcols,
digits.addcols.left = digits.addcols,
##
scientific.pval = gs("scientific.pval"),
big.mark = gs("big.mark"),
zero.pval =
if (layout == "JAMA") FALSE else gs("zero.pval"),
JAMA.pval =
if (layout == "JAMA") TRUE else gs("JAMA.pval"),
##
warn.deprecated = gs("warn.deprecated"),
...) {
##
##
## (1) Check for meta object and upgrade older meta objects
##
##
chkclass(x, "meta")
x.name <- deparse(substitute(x))
x <- updateversion(x)
##
K.all <- length(x$TE)
##
sm <- x$sm
##
metabin <- inherits(x, "metabin")
metacont <- inherits(x, "metacont")
metacor <- inherits(x, "metacor")
metagen <- inherits(x, "metagen")
metainc <- inherits(x, "metainc")
metamean <- inherits(x, "metamean")
metaprop <- inherits(x, "metaprop")
metarate <- inherits(x, "metarate")
metabind <- inherits(x, "is.metabind")
##
metainf.metacum <- inherits(x, "metainf") | inherits(x, "metacum")
##
meta <- !metabind &&
(metabin | metacont | metacor | metagen | metainc | metamean |
metaprop | metarate | metainf.metacum)
##
ftr <- x$func.transf
atr <- x$args.transf
fbt <- x$func.backtransf
abt <- x$args.backtransf
##
##
## (2) Extract data on subgroup analysis
##
##
by <- !is.null(x$subgroup)
##
if (by) {
n.by <- length(x$subgroup.levels)
##
TE.common.w <- collapsemat(x$TE.common.w)
statistic.common.w <- collapsemat(x$statistic.common.w)
pval.common.w <- collapsemat(x$pval.common.w)
lower.common.w <- collapsemat(x$lower.common.w)
upper.common.w <- collapsemat(x$upper.common.w)
##
if (!is.matrix(x$TE.random.w) & is.matrix(x$seTE.random.w)) {
TE.random.w <-
collapsemat(matrix(x$TE.random.w,
nrow = nrow(x$seTE.random.w),
ncol = ncol(x$seTE.random.w),
dimnames = list(rownames(x$seTE.random.w),
colnames(x$seTE.random.w))))
}
else
TE.random.w <- collapsemat(x$TE.random.w)
##
lower.random.w <- collapsemat(x$lower.random.w)
upper.random.w <- collapsemat(x$upper.random.w)
statistic.random.w <- collapsemat(x$statistic.random.w)
pval.random.w <- collapsemat(x$pval.random.w)
##
lower.predict.w <- collapsemat(x$lower.predict.w)
upper.predict.w <- collapsemat(x$upper.predict.w)
}
else
n.by <- 0
##
##
## (3) Determine columns on left and right side of forest plot
##
##
missing.leftcols <- missing(leftcols)
missing.rightcols <- missing(rightcols)
##
layout <- setchar(layout, c("meta", "RevMan5", "JAMA", "subgroup"))
if (layout == "subgroup" & is.null(x$subgroup)) {
warning("Argument 'layout' set to \"meta\" (default) as ",
"no subgroup analysis was conducted.")
layout <- "meta"
}
missing.type.subgroup.common <- missing(type.subgroup.common)
if (layout == "subgroup") {
if (missing(type.subgroup))
type.subgroup <- "square"
if (missing.type.subgroup.common)
type.subgroup.common <- "square"
if (missing(type.subgroup.random))
type.subgroup.random <- "square"
##
if (missing(pooled.totals))
pooled.totals <- FALSE
}
revman5 <- layout == "RevMan5"
jama <- layout == "JAMA"
revman5.jama <- revman5 | jama
##
lsel <- TRUE
if (is.logical(leftcols)) {
if (!leftcols)
lsel <- FALSE
##
leftcols <- NULL
}
##
rsel <- !(is.logical(rightcols) && length(rightcols) == 1 && !rightcols)
if (revman5.jama)
rsel <- FALSE
##
if (!rsel)
rightcols <- NULL
##
## Check for duplicate columns
##
if (length(c(rightcols, leftcols)) > 0 &&
any(duplicated(c(rightcols, leftcols))))
stop("Duplicate entries in 'leftcols' and 'rightcols'.")
##
colnames <- c("studlab",
"TE", "seTE",
"cluster",
"n.e", "n.c",
"event.e", "event.c",
"mean.e", "mean.c",
"sd.e", "sd.c",
"cor",
"time.e", "time.c",
"effect", "ci",
"effect.ci",
"w.fixed", "w.common", "w.random",
"pval")
##
if (metainf.metacum)
colnames <- c(colnames, "tau2", "tau", "I2")
##
## If any of the following list elements is NULL, these 'special'
## variable names are searched for in original data set (i.e., list
## element x$data)
##
colnames.notNULL <- colnames
colnames.notNULL <- removeNULL(x, colnames.notNULL, "cluster")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "n.e")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "n.c")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "event.e")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "event.c")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "mean.e")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "mean.c")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "sd.e")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "sd.c")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "cor")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "time.e")
colnames.notNULL <- removeNULL(x, colnames.notNULL, "time.c")
##
## Identify and process columns in addition to columns
## defined above in variable 'colnames'
##
colnames.new <-
c(leftcols, rightcols)[!c(leftcols, rightcols) %in% colnames.notNULL]
##
newcols <- length(colnames.new) > 0
##
withstudlab <-
(lsel & missing(leftcols)) |
(lsel & !missing(leftcols) & "studlab" %in% leftcols) |
(rsel & !missing(rightcols) & "studlab" %in% rightcols)
##
if (!withstudlab || newcols) {
dataset2 <- as.data.frame(x)
##
if (!is.null(x$data))
dataset1 <- x$data
else if (!is.null(x$x$data))
dataset1 <- x$x$data
else
dataset1 <- dataset2
##
if (!is.null(x$subset))
dataset1 <- dataset1[x$subset, ]
##
if (!withstudlab && newcols) {
##
## Check whether first additional variable is part of
## meta-object
##
firstvar <- colnames.new[1]
colnames.new <- colnames.new[-1]
newcols <- length(colnames.new) > 0
##
if (length(dataset1[[firstvar]]) == 0 &
length(dataset2[[firstvar]]) == 0)
stop("Variable '", firstvar, "' not available in '",
x.name, "'.",
call. = FALSE)
else {
if (length(dataset1[[firstvar]]) != 0)
studlab.new <- dataset1[[firstvar]]
else if (length(dataset2[[firstvar]]) != 0)
studlab.new <- dataset2[[firstvar]]
##
if (metainf.metacum)
studlab.new <- c(studlab.new, "", rev(x$studlab)[1])
##
if (length(x$studlab) != length(studlab.new))
stop("Variable '", firstvar, "' has different length ",
"than list element '", x.name, "' with study labels.",
call. = FALSE)
##
x$studlab <- studlab.new
switch.l <- leftcols == firstvar
switch.r <- rightcols == firstvar
if (any(switch.l))
leftcols[switch.l] <- "studlab"
if (any(switch.r))
rightcols[switch.r] <- "studlab"
##
}
}
}
##
if (newcols) {
##
## Determine labels for new columns
## 1. Use column name as label if no label is given
## 2. Otherwise use specified labels
##
rightcols.new <- rightcols[!rightcols %in% colnames.notNULL]
leftcols.new <- leftcols[!leftcols %in% colnames.notNULL]
}
##
##
## (3) Check other arguments
##
##
sfsp <- sys.frame(sys.parent())
mc <- match.call()
##
error <-
try(sortvar <- catch("sortvar", mc, x, sfsp),
silent = TRUE)
if (inherits(error, "try-error")) {
sortvar <- catch("sortvar", mc, x$data, sfsp)
if (isCol(x$data, ".subset"))
sortvar <- sortvar[x$data$.subset]
}
##
if (!is.null(sortvar) & metainf.metacum)
warning("Argument 'sortvar' ignored for objects ",
"created with metacum() or metainf().")
sort <- !is.null(sortvar) & !metainf.metacum
if (sort && (length(sortvar) != K.all))
stop("Number of studies in object 'x' and argument 'sortvar' ",
"have different length.")
if (!sort)
sortvar <- 1:K.all
##
missing.subgroup <- missing(subgroup)
missing.subgroup.hetstat <- missing(subgroup.hetstat)
missing.prediction.subgroup <- missing(prediction.subgroup)
##
if (!by) {
if (!missing.subgroup)
warning("Argument 'subgroup' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
if (!missing.subgroup.hetstat)
warning("Argument 'subgroup.hetstat' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
if (!missing.prediction.subgroup)
warning("Argument 'prediction.subgroup' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
if (!missing(test.effect.subgroup))
warning("Argument 'test.effect.subgroup' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
if (!missing(test.effect.subgroup.common))
warning("Argument 'test.effect.subgroup.common' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
if (!missing(test.effect.subgroup.random))
warning("Argument 'test.effect.subgroup.random' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
}
##
missing.studlab <- missing(studlab)
if (!missing.studlab) {
error <-
try(studlab <- catch("studlab", mc, x, sfsp),
silent = TRUE)
if (inherits(error, "try-error")) {
studlab <- catch("studlab", mc, x$data, NULL)
if (isCol(x$data, ".subset"))
studlab <- studlab[x$data$.subset]
}
}
##
slab <- TRUE
if (length(studlab) == 1 & is.logical(studlab)) {
if (studlab == FALSE) {
studlab <- rep("", K.all)
slab <- FALSE
}
else studlab <- x$studlab
}
##
if (missing.studlab && K.all == 1 && studlab == "")
studlab <- "1"
##
if (length(studlab) != (K.all - 2 * (metainf.metacum & !missing.studlab)))
stop("Number of studies in object 'x' and argument 'studlab' have ",
"different length.")
##
## Additional arguments in '...'
##
args <- list(...)
## Check whether first argument is a list. In this case only use
## this list as input.
if (length(args) > 0 && is.list(args[[1]]))
args <- args[[1]]
##
common <- deprecated(common, missing(common), args, "fixed",
warn.deprecated)
chklogical(common)
chklogical(random)
overall <- replaceNULL(overall, common | random)
chklogical(overall)
##
lty.common <- deprecated(lty.common, missing(lty.common), args, "lty.fixed",
warn.deprecated)
if (!is.null(lty.common))
chknumeric(lty.common, length = 1)
if (!is.null(lty.random))
chknumeric(lty.random, length = 1)
col.common <- deprecated(col.common, missing(col.common), args, "col.fixed",
warn.deprecated)
chkcolor(col.common, length = 1)
chkcolor(col.random, length = 1)
chklogical(prediction)
##
chklogical(print.subgroup.labels)
if (!is.null(print.subgroup.name))
chklogical(print.subgroup.name)
if (!is.null(sep.subgroup))
chkchar(sep.subgroup)
##
sort.subgroup <- deprecated(sort.subgroup, missing(sort.subgroup),
args, "bysort", warn.deprecated)
chklogical(sort.subgroup)
##
chklogical(pooled.totals)
chklogical(pooled.events)
chklogical(pooled.times)
chklogical(study.results)
## chknumeric(xlab.pos) ??
## chknumeric(smlab.pos) ??
chklogical(allstudies)
##
chklogical(backtransf)
##
if (!is.null(pscale))
chknumeric(pscale, length = 1)
else
pscale <- 1
if (!is.null(irscale))
chknumeric(irscale, length = 1)
else
irscale <- 1
if (!is.null(irunit) && !is.na(irunit))
chkchar(irunit)
##
missing.ref <- missing(ref)
## Use logarithmic x-axis?
## (for back-transformed relative effect measures)
log.xaxis <-
backtransf & (is_relative_effect(sm) | (!is.null(fbt) && fbt == "exp"))
##
if (missing.ref) {
if (is_prop(sm) | is_rate(sm) | is_mean(sm))
ref <- NA
else if (log.xaxis)
ref <- 1
else
ref <- 0
##
}
else
chknumeric(ref, length = 1)
##
chknumeric(lower.equi)
chknumeric(upper.equi)
##
if (all(is.na(lower.equi)))
max.lower.equi <- NA
else {
max.lower.equi <- max(lower.equi, na.rm = TRUE)
##
if (!is.na(ref) && any(lower.equi[!is.na(lower.equi)] > ref))
stop("All values provided for argument 'lower.equi' must be ",
"smaller than reference value of ", ref, ".",
call. = FALSE)
}
##
if (all(is.na(upper.equi)))
min.upper.equi <- NA
else {
min.upper.equi <- min(upper.equi, na.rm = TRUE)
##
if (!is.na(ref) && any(upper.equi[!is.na(upper.equi)] < ref))
stop("All values provided for argument 'upper.equi' must be ",
"larger than reference value of ", ref, ".",
call. = FALSE)
}
##
if (!is.na(max.lower.equi) && !is.na(min.upper.equi) &&
max.lower.equi > min.upper.equi)
stop("Value", if (length(lower.equi) > 1) "s " else " ",
"of 'lower.equi' must be smaller than 'upper.equi'.",
call. = FALSE)
##
if (any(lower.equi != sort(lower.equi), na.rm = TRUE))
stop("Values of 'lower.equi' must be increasing.",
call. = FALSE)
##
if (any(upper.equi != sort(upper.equi), na.rm = TRUE))
stop("Values of 'upper.equi' must be increasing.",
call. = FALSE)
##
if (!is.na(max.lower.equi))
if (length(fill.lower.equi) == 1 & sum(!is.na(lower.equi)) > 1)
fill.lower.equi <- rep(fill.lower.equi, sum(!is.na(lower.equi)))
else if (all(length(fill.lower.equi) != sum(!is.na(lower.equi)) + 0:1))
stop("Number of fill colours must be equal to the number of values ",
"for 'lower.equi' or +1.",
call. = FALSE)
##
if (!is.na(min.upper.equi))
if (length(fill.upper.equi) == 1 & sum(!is.na(upper.equi)) > 1)
fill.upper.equi <- rep(fill.upper.equi, sum(!is.na(upper.equi)))
else if (all(length(fill.upper.equi) != sum(!is.na(upper.equi)) + 0:1))
stop("Number of fill colours must be equal to the number of values ",
"for 'upper.equi' or +1.",
call. = FALSE)
##
chknumeric(lty.equi)
chkcolor(col.equi)
##
type.study <- setchar(type.study, c("square", "diamond", "predict"))
type.common <- setchar(type.common, c("square", "diamond", "predict"))
type.random <- setchar(type.random, c("square", "diamond", "predict"))
type.subgroup <- setchar(type.subgroup, c("square", "diamond", "predict"))
type.subgroup.common <- setchar(type.subgroup.common,
c("square", "diamond", "predict"))
type.subgroup.random <- setchar(type.subgroup.random,
c("square", "diamond", "predict"))
##
chklogical(bottom.lr)
chkchar(lab.NA)
if (is.null(lab.NA.effect))
if (metainf.metacum)
lab.NA.effect <- lab.NA
else
lab.NA.effect <- ""
chkchar(lab.NA.effect)
chkchar(lab.NA.weight)
if (!is.null(at))
chknumeric(at)
chkcolor(col.diamond)
chkcolor(col.diamond.random)
chkcolor(col.predict)
chkcolor(col.predict.lines)
##
col.subgroup <- deprecated(col.subgroup, missing(col.subgroup), args,
"col.by", warn.deprecated)
##
missing.hetstat <- missing(hetstat)
missing.overall.hetstat <- missing(overall.hetstat)
##
overall.hetstat <- replaceNULL(overall.hetstat, TRUE)
chklogical(overall.hetstat)
##
if (is.null(print.I2))
if (is.character(hetstat) || hetstat || overall.hetstat)
print.I2 <- TRUE
else
print.I2 <- FALSE
else
chklogical(print.I2)
##
chklogical(print.I2.ci)
##
if (is.null(print.tau2))
if (is.character(hetstat) || hetstat || overall.hetstat)
print.tau2 <- TRUE
else
print.tau2 <- FALSE
else
chklogical(print.tau2)
##
chklogical(print.tau2.ci)
chklogical(print.tau)
chklogical(print.tau.ci)
print.tau2.tau <- print.tau2 | print.tau
if (print.tau2 & print.tau)
print.tau2 <- FALSE
if (print.tau2.ci & print.tau.ci)
print.tau2.ci <- FALSE
##
chklogical(print.Q)
##
if (is.null(print.pval.Q))
if (is.character(hetstat) || hetstat || overall.hetstat)
print.pval.Q <- TRUE
else
print.pval.Q <- FALSE
else
chklogical(print.pval.Q)
##
chklogical(print.Rb)
chklogical(print.Rb.ci)
if (!is.logical(text.subgroup.nohet))
chkchar(text.subgroup.nohet)
else if (text.subgroup.nohet)
text.subgroup.nohet <- "not applicable"
##
hetstat.pooled <- ""
if (is.character(hetstat)) {
hetstat <- setchar(hetstat, c("common", "random", "study", "fixed"))
hetstat[hetstat == "fixed"] <- "common"
hetstat.pooled <- hetstat
if (!metabind & hetstat.pooled == "study") {
warning("Argument 'hetstat = \"study\"' ",
"only considered for 'metabind' objects.")
hetstat <- print.I2 | print.tau2.tau | print.Q | print.pval.Q | print.Rb
}
}
else
chklogical(hetstat)
##
if (hetstat.pooled == "common") {
common <- TRUE
overall <- TRUE
}
if (hetstat.pooled == "random") {
if (length(x$TE.random) == 1) {
random <- TRUE
overall <- TRUE
}
else
hetstat.pooled <- ""
}
##
if (missing.overall.hetstat) {
if (!missing.hetstat)
if (is.character(hetstat))
overall.hetstat <- FALSE
else
overall.hetstat <- hetstat
}
else
chklogical(overall.hetstat)
##
chklogical(LRT)
if (LRT & all(x$method != "GLMM")) {
warning("Likelihood-Ratio test of heterogeneity only ",
"available for generalized linear mixed models.")
LRT <- FALSE
}
##
chkchar(hetlab)
if (!is.null(resid.hetstat))
chklogical(resid.hetstat)
else {
if (overall && (is.character(hetstat) || hetstat) && !LRT &&
!is.null(x$tau.common) && x$tau.common)
resid.hetstat <- TRUE
else
resid.hetstat <- FALSE
}
chkchar(resid.hetlab)
##
test.overall.common <-
deprecated(test.overall.common, missing(test.overall.common),
args, "test.overall.fixed",
warn.deprecated)
chklogical(test.overall.common)
chklogical(test.overall.random)
##
test.subgroup <- replaceNULL(test.subgroup, TRUE)
chklogical(test.subgroup)
test.subgroup.common <-
deprecated(test.subgroup.common, missing(test.subgroup.common),
args, "test.subgroup.fixed",
warn.deprecated)
chklogical(test.subgroup.common)
chklogical(test.subgroup.random)
##
chklogical(print.Q.subgroup)
##
if (missing(header.line)) {
if (is.character(gs("header.line")))
header.line <- gs("header.line")
else
header.line <- gs("header.line") |
(layout %in% c("JAMA", "RevMan5"))
}
##
if (is.character(header.line)) {
header.line.pos <- setchar(header.line, c("below", "both", ""))
header.line <- header.line.pos != ""
}
else {
chklogical(header.line)
if (header.line)
header.line.pos <- "below"
else
header.line.pos <- ""
}
##
chknumeric(fontsize, length = 1)
chknumeric(fs.heading, length = 1)
##
missing.fs.common <- missing(fs.common)
missing.fs.fixed <- is.na(argid(names(args), "fs.fixed"))
if (!missing.fs.fixed) {
fs.common <-
deprecated(fs.common, missing.fs.common, args, "fs.fixed",
warn.deprecated)
missing.fs.common <- FALSE
}
if (!missing.fs.common)
chknumeric(fs.common, length = 1)
##
if (!is.null(fs.random))
chknumeric(fs.random, length = 1)
if (!is.null(fs.predict))
chknumeric(fs.predict, length = 1)
##
missing.fs.common.labels <- missing(fs.common.labels)
missing.fs.fixed.labels <- is.na(argid(names(args), "fs.fixed.labels"))
if (!missing.fs.fixed.labels) {
fs.common.labels <-
deprecated(fs.common.labels, missing.fs.common.labels,
args, "fs.fixed.labels",
warn.deprecated)
missing.fs.common.labels <- FALSE
}
if (!missing.fs.common.labels)
chknumeric(fs.common.labels, length = 1)
##
if (!is.null(fs.random.labels))
chknumeric(fs.random.labels, length = 1)
if (!is.null(fs.predict.labels))
chknumeric(fs.predict.labels, length = 1)
if (!is.null(fs.study))
chknumeric(fs.study, length = 1)
if (!is.null(fs.study.labels))
chknumeric(fs.study.labels, length = 1)
if (!is.null(fs.hetstat))
chknumeric(fs.hetstat, length = 1)
if (!is.null(fs.test.overall))
chknumeric(fs.test.overall, length = 1)
if (!is.null(fs.test.subgroup))
chknumeric(fs.test.subgroup, length = 1)
if (!is.null(fs.test.effect.subgroup))
chknumeric(fs.test.effect.subgroup, length = 1)
if (!is.null(fs.addline))
chknumeric(fs.addline, length = 1)
chknumeric(fs.axis, length = 1)
chknumeric(fs.smlab, length = 1)
chknumeric(fs.xlab, length = 1)
chknumeric(fs.lr, length = 1)
##
missing.ff.common <- missing(ff.common)
missing.ff.fixed <- is.na(argid(names(args), "ff.fixed"))
if (!missing.ff.fixed) {
ff.common <-
deprecated(ff.common, missing.ff.common, args, "ff.fixed",
warn.deprecated)
missing.ff.common <- FALSE
}
##
missing.ff.common.labels <- missing(ff.common.labels)
missing.ff.fixed.labels <- is.na(argid(names(args), "ff.fixed.labels"))
if (!missing.ff.fixed.labels) {
ff.common.labels <-
deprecated(ff.common.labels, missing.ff.common.labels,
args, "ff.fixed.labels",
warn.deprecated)
missing.ff.common.labels <- FALSE
}
##
chknumeric(squaresize, length = 1)
chklogical(calcwidth.pooled)
calcwidth.common <-
deprecated(calcwidth.common, missing(calcwidth.common),
args, "calcwidth.fixed",
warn.deprecated)
chklogical(calcwidth.common)
chklogical(calcwidth.random)
chklogical(calcwidth.predict)
chklogical(calcwidth.hetstat)
chklogical(calcwidth.tests)
chklogical(calcwidth.subgroup)
chklogical(calcwidth.addline)
just.cols <- setchar(just, c("right", "center", "left"))
just.studlab <- setchar(just.studlab, c("right", "center", "left"))
just.addcols <- setchar(just.addcols, c("right", "center", "left"))
just.addcols.left <- setchar(just.addcols.left, c("right", "center", "left"))
just.addcols.right <-
setchar(just.addcols.right, c("right", "center", "left"))
##
chknumeric(spacing, length = 1)
##
missing.text.addline1 <- missing(text.addline1)
if (!missing.text.addline1) {
chkchar(text.addline1)
if (text.addline1 == "")
missing.text.addline1 <- TRUE
}
else
text.addline1 <- ""
missing.text.addline2 <- missing(text.addline2)
if (!missing.text.addline2) {
chkchar(text.addline2)
if (text.addline2 == "")
missing.text.addline2 <- TRUE
}
else
text.addline2 <- ""
##
## Check and set additional empty rows in forest plot
##
if (!is.null(addrow))
chklogical(addrow)
else
addrow <- !jama
if (!is.null(addrow.overall)) {
chklogical(addrow.overall)
if (!(overall & (common | random | prediction)))
addrow.overall <- FALSE
}
else
addrow.overall <- !jama & overall & (common | random | prediction)
if (!is.null(addrow.subgroups))
chklogical(addrow.subgroups)
else
addrow.subgroups <- !jama
##
chknumeric(digits, min = 0, length = 1)
chknumeric(digits.tau2, 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.I2, min = 0, length = 1)
chknumeric(digits.se, min = 0, length = 1)
if (!missing(digits.mean))
chknumeric(digits.mean, min = 0, length = 1)
if (!missing(digits.sd))
chknumeric(digits.sd, min = 0, length = 1)
if (!missing(digits.cor))
chknumeric(digits.cor, min = 0, length = 1)
missing.digits.time <- missing(digits.time)
if (!missing.digits.time)
chknumeric(digits.time, min = 0, length = 1)
missing.digits.TE <- missing(digits.TE)
if (!missing.digits.TE)
chknumeric(digits.TE, min = 0, length = 1)
missing.addcols.left <-
missing(digits.addcols) & missing(digits.addcols.left)
missing.addcols.right <-
missing(digits.addcols) & missing(digits.addcols.right)
if (!missing(digits.addcols))
chknumeric(digits.addcols, min = 0)
if (!missing(digits.addcols.right))
chknumeric(digits.addcols.right, min = 0)
if (!missing(digits.addcols.left))
chknumeric(digits.addcols.left, min = 0)
chklogical(scientific.pval)
chklogical(zero.pval)
chklogical(JAMA.pval)
##
## Check for deprecated arguments in '...'
##
weight.study <-
deprecated(weight.study, missing(weight.study), args, "weight",
warn.deprecated)
if (missing(weight.study) || is.null(weight.study))
weight.study <- ifelse(random & !common, "random", "common")
weight.study <- setchar(weight.study, c("same", "common", "random", "fixed"))
weight.study[weight.study == "fixed"] <- "common"
##
digits.stat <-
deprecated(digits.stat, missing(digits.stat), args, "digits.zval",
warn.deprecated)
chknumeric(digits.stat, min = 0, length = 1)
##
print.stat <-
deprecated(print.stat, missing(print.stat), args, "print.zval",
warn.deprecated)
chklogical(print.stat)
##
label <- deprecated(label, missing(label), args, "labels",
warn.deprecated)
##
label.e <- deprecated(label.e, missing(label.e), args, "lab.e",
warn.deprecated)
label.c <- deprecated(label.c, missing(label.c), args, "lab.c",
warn.deprecated)
##
label.e.attach <- deprecated(label.e.attach, missing(label.e.attach),
args, "lab.e.attach.to.col",
warn.deprecated)
label.c.attach <- deprecated(label.c.attach, missing(label.c.attach),
args, "lab.c.attach.to.col",
warn.deprecated)
##
col.inside <-
deprecated(col.inside, missing(col.inside), args, "col.i.inside.square",
warn.deprecated)
chkcolor(col.inside)
chkcolor(col.inside.common)
chkcolor(col.inside.random)
##
if (!is.na(argid(names(args), "col.diamond.lines.fixed"))) {
col.diamond.lines.common <-
deprecated(col.diamond.lines.common, missing(col.diamond.lines.common),
args, "col.diamond.lines.fixed",
warn.deprecated)
}
else if (!is.na(argid(names(args), "col.diamond.fixed.lines"))) {
col.diamond.lines.common <-
deprecated(col.diamond.lines.common, missing(col.diamond.lines.common),
args, "col.diamond.fixed.lines",
warn.deprecated)
}
chkcolor(col.diamond.lines)
chkcolor(col.diamond.lines.common)
##
col.diamond.lines.random <-
deprecated(col.diamond.lines.random, missing(col.diamond.lines.random),
args, "col.diamond.random.lines",
warn.deprecated)
chkcolor(col.diamond.lines.random)
##
## Additional assignments
##
if (jama) {
if (missing.ff.common)
ff.common <- "plain"
if (missing(ff.random))
ff.random <- ff.common
if (missing(ff.predict))
ff.predict <- ff.common
if (missing.ff.common.labels)
ff.common.labels <- ff.common
if (missing(ff.random.labels))
ff.random.labels <- ff.random
if (missing(ff.predict.labels))
ff.predict.labels <- ff.predict
##
if (missing.fs.common)
fs.common <- fontsize
if (missing(fs.random))
fs.random <- fs.common
if (missing(fs.predict))
fs.predict <- fs.common
if (missing.fs.common.labels)
fs.common.labels <- fs.common
if (missing(fs.random.labels))
fs.random.labels <- fs.random
if (missing(fs.predict.labels))
fs.predict.labels <- fs.predict
}
else {
if (missing.ff.common)
ff.common <- "bold"
if (missing(ff.random))
ff.random <- ff.common
if (missing(ff.predict))
ff.predict <- ff.common
if (missing.ff.common.labels)
ff.common.labels <- ff.common
if (missing(ff.random.labels))
ff.random.labels <- ff.random
if (missing(ff.predict.labels))
ff.predict.labels <- ff.predict
##
if (missing.fs.common)
fs.common <- fontsize
if (missing(fs.random))
fs.random <- fs.common
if (missing(fs.predict))
fs.predict <- fs.common
if (missing.fs.common.labels)
fs.common.labels <- fs.common
if (missing(fs.random.labels))
fs.random.labels <- fs.random
if (missing(fs.predict.labels))
fs.predict.labels <- fs.predict
}
hetseparator <- " = "
##
if (revman5) {
if (missing(ff.hetstat))
ff.hetstat <- "plain"
if (missing(ff.test.overall))
ff.test.overall <- ff.hetstat
if (missing(ff.test.subgroup))
ff.test.subgroup <- ff.hetstat
if (missing(ff.test.effect.subgroup))
ff.test.effect.subgroup <- ff.hetstat
if (missing(ff.addline))
ff.addline <- ff.hetstat
##
if (missing(fs.hetstat))
fs.hetstat <- fontsize - 1
if (missing(fs.test.overall))
fs.test.overall <- fs.hetstat
if (missing(fs.test.subgroup))
fs.test.subgroup <- fs.hetstat
if (missing(fs.test.effect.subgroup))
fs.test.effect.subgroup <- fs.hetstat
if (missing(fs.addline))
fs.addline <- fs.hetstat
}
else if (jama) {
if (missing(ff.hetstat))
ff.hetstat <- "plain"
if (missing(ff.test.overall))
ff.test.overall <- ff.hetstat
if (missing(ff.test.subgroup))
ff.test.subgroup <- ff.hetstat
if (missing(ff.test.effect.subgroup))
ff.test.effect.subgroup <- ff.hetstat
if (missing(ff.addline))
ff.addline <- ff.hetstat
##
if (missing(fs.hetstat))
fs.hetstat <- fontsize - 1
if (missing(fs.test.overall))
fs.test.overall <- fs.hetstat
if (missing(fs.test.subgroup))
fs.test.subgroup <- fs.hetstat
if (missing(fs.test.effect.subgroup))
fs.test.effect.subgroup <- fs.hetstat
if (missing(fs.addline))
fs.addline <- fs.hetstat
}
else {
if (missing(ff.hetstat))
ff.hetstat <- "plain"
if (missing(ff.test.overall))
ff.test.overall <- ff.hetstat
if (missing(ff.test.subgroup))
ff.test.subgroup <- ff.hetstat
if (missing(ff.test.effect.subgroup))
ff.test.effect.subgroup <- ff.hetstat
if (missing(ff.addline))
ff.addline <- ff.hetstat
##
if (missing(fs.hetstat))
fs.hetstat <- fontsize - 1
if (missing(fs.test.overall))
fs.test.overall <- fs.hetstat
if (missing(fs.test.subgroup))
fs.test.subgroup <- fs.hetstat
if (missing(fs.test.effect.subgroup))
fs.test.effect.subgroup <- fs.hetstat
if (missing(fs.addline))
fs.addline <- fs.hetstat
}
##
##
## (4) Check length of variables
##
##
fun <- "forest.meta"
##
if (length(col.study) == 1)
col.study <- rep(col.study, K.all)
else
chklength(col.study, K.all, fun)
##
if (length(col.inside) == 1)
col.inside <- rep(col.inside, K.all)
else
chklength(col.inside, K.all, fun)
##
miss.col.square <- missing(col.square)
miss.col.square.lines <- missing(col.square.lines)
if (length(col.square) == 1)
col.square <- rep(col.square, K.all)
else
chklength(col.square, K.all, fun)
##
if (length(col.square.lines) == 1)
col.square.lines <- rep(col.square.lines, K.all)
else
chklength(col.square.lines, K.all, fun)
##
##
## (5) Some assignments and additional checks
##
##
n.com <- max(length(x$TE.common), 1)
n.ran <- max(length(x$seTE.random), 1)
n.prd <- max(length(x$lower.predict), 1)
##
prediction <- prediction &
any(!is.na(x$lower.predict) & !is.na(x$upper.predict))
##
if (by) {
if (!missing.subgroup & !metabind)
subgroup <- catch("subgroup", mc, x, sfsp)
##
if (length(subgroup) == 1)
subgroup.logical <- rep(subgroup, n.by) &
(x$k.w > 1 | layout == "subgroup")
else {
chklength(subgroup, n.by,
text = paste("Length of argument 'subgroup' must be",
"equal to 1 or number of subgroups."))
subgroup.logical <- subgroup
}
chklogical(subgroup[1])
##
if (!missing.subgroup.hetstat & !metabind)
subgroup.hetstat <- catch("subgroup.hetstat", mc, x, sfsp)
##
if (length(subgroup.hetstat) == 1 & is.character(subgroup.hetstat))
subgroup.hetstat.logical <- rep(TRUE, n.by)
else if (length(subgroup.hetstat) == 1) {
chklogical(subgroup.hetstat)
subgroup.hetstat.logical <- subgroup.hetstat &
(x$k.w > 1 | layout == "subgroup")
}
else {
chklength(subgroup.hetstat, n.by,
text = paste("Length of argument 'subgroup.hetstat' must be",
"equal to 1 or number of subgroups."))
chklogical(subgroup.hetstat[1])
subgroup.hetstat.logical <- subgroup.hetstat
}
##
if (!missing.prediction.subgroup & !metabind)
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
}
chklogical(prediction.subgroup[1])
##
if (!missing(test.effect.subgroup)) {
test.effect.subgroup <-
catch("test.effect.subgroup", mc, x, sfsp)
test.effect.subgroup <- replaceNULL(test.effect.subgroup, FALSE)
##
if (length(test.effect.subgroup) == 1) {
chklogical(test.effect.subgroup)
##
test.effect.subgroup.logical <-
rep(test.effect.subgroup, n.by) &
(x$k.w > 1 | layout == "subgroup")
}
else {
chklength(test.effect.subgroup, n.by,
text = paste("Length of argument 'test.effect.subgroup'",
"must be equal to 1 or number of subgroups."))
chklogical(test.effect.subgroup[1])
test.effect.subgroup.logical <- test.effect.subgroup
}
}
else
test.effect.subgroup.logical <- rep(test.effect.subgroup, n.by)
##
if (missing(test.effect.subgroup.common))
test.effect.subgroup.common.logical <-
common & test.effect.subgroup.logical
else {
test.effect.subgroup.common <-
catch("test.effect.subgroup.common", mc, x, sfsp)
test.effect.subgroup.common <-
replaceNULL(test.effect.subgroup.common, FALSE)
##
if (length(test.effect.subgroup.common) == 1) {
chklogical(test.effect.subgroup.common)
##
test.effect.subgroup.common.logical <-
rep(test.effect.subgroup.common, n.by) &
(x$k.w > 1 | layout == "subgroup")
}
else {
chklength(test.effect.subgroup.common, n.by,
text = paste("Length of argument",
"'test.effect.subgroup.common'",
"must be equal to 1 or number of subgroups."))
chklogical(test.effect.subgroup.common[1])
test.effect.subgroup.common.logical <- test.effect.subgroup.common
}
}
##
if (missing(test.effect.subgroup.random))
test.effect.subgroup.random.logical <-
random & test.effect.subgroup.logical
else {
test.effect.subgroup.random <-
catch("test.effect.subgroup.random", mc, x, sfsp)
test.effect.subgroup.random <-
replaceNULL(test.effect.subgroup.random, FALSE)
##
if (length(test.effect.subgroup.random) == 1) {
chklogical(test.effect.subgroup.random)
##
test.effect.subgroup.random.logical <-
rep(test.effect.subgroup.random, n.by) &
(x$k.w > 1 | layout == "subgroup")
}
else {
chklength(test.effect.subgroup.random, n.by,
text = paste("Length of argument",
"'test.effect.subgroup.random'",
"must be equal to 1 or number of subgroups."))
chklogical(test.effect.subgroup.random[1])
test.effect.subgroup.random.logical <- test.effect.subgroup.random
}
}
}
##
level <- x$level
level.ma <- x$level.ma
level.predict <- x$level.predict
##
if (is.null(label.right))
label.right <- ""
if (is.null(label.left))
label.left <- ""
##
subgroup <- x$subgroup
##
three.level <- !is.null(x$three.level) && any(x$three.level)
##
if (!by) {
common.random <- common & random
##
test.subgroup.common <- FALSE
test.subgroup.random <- FALSE
}
else
common.random <-
any(common | test.subgroup.common | test.effect.subgroup.common.logical) &
any(random | test.subgroup.random | test.effect.subgroup.random.logical)
##
if (layout == "subgroup") {
if (!missing(study.results) & study.results)
warning("Argument 'study.results' set to FALSE as ",
"argument 'layout' is \"subgroup\".")
study.results <- FALSE
}
##
missing.text.common <- missing(text.common)
missing.text.fixed <- is.na(argid(names(args), "text.fixed"))
if (!missing.text.fixed) {
text.common <-
deprecated(text.common, missing.text.common, args, "text.fixed",
warn.deprecated)
missing.text.common <- FALSE
}
##
if (missing.text.common | is.null(text.common)) {
if (is.null(text.common) || length(text.common) == 1) {
if (study.results & (x$level != x$level.ma | revman5)) {
if (revman5.jama)
text.common <- paste0("Total (",
if (common.random)
paste0(gs("text.w.common"), " effect, "),
round(x$level.ma * 100), "% CI)")
else if (!is.null(text.common))
text.common <- paste0(text.common, " (",
round(x$level.ma * 100), "%-CI)")
else
text.common <- paste0(gs("text.common"), " (",
round(x$level.ma * 100), "%-CI)")
}
else {
if (revman5.jama) {
text.common <- "Total"
if (common.random)
text.common <- paste0(text.common, " (", gs("text.w.common"),
" effect)")
}
else if (is.null(text.common))
text.common <- gs("text.common")
}
}
}
##
missing.text.random <- missing(text.random)
if (missing.text.random | is.null(text.random)) {
if (is.null(text.random) || length(text.random) == 1) {
if (study.results & (x$level != x$level.ma | revman5)) {
if (revman5.jama) {
text.random <- paste0("Total (",
if (common.random)
paste0(gs("text.w.random"), " effect, "))
if (length(x$lower.random) > 1) {
meth.r <- gsub("classic", "", x$method.random.ci)
text.random <-
paste0(text.random, meth.r,
ifelse(meth.r == "HK" & x$adhoc.hakn.ci != "",
paste0("-",
toupper(substring(x$adhoc.hakn.ci, 1, 2))),
""),
ifelse(meth.r != "", ", ", ""))
}
text.random <- paste0(text.random,
round(x$level.ma * 100), "% CI)")
}
else if (!is.null(text.random))
text.random <- paste0(text.random, " (",
round(x$level.ma * 100), "%-CI)")
else
text.random <- paste0(gs("text.random"), " (",
round(x$level.ma * 100), "%-CI)")
}
else {
if (revman5.jama) {
text.random <- "Total"
if (common.random || length(x$lower.random) > 1) {
text.random <- paste0(text.random, " (", gs("text.w.random"),
" effect")
if (length(x$lower.random) > 1) {
meth.r <- gsub("classic", "", x$method.random.ci)
text.random <-
paste0(text.random,
ifelse(meth.r != "", ", ", ""),
meth.r,
ifelse(meth.r == "HK" & x$adhoc.hakn.ci != "",
paste0("-",
toupper(substring(x$adhoc.hakn.ci, 1, 2))),
""))
}
text.random <- paste0(text.random, ")")
}
}
else if (is.null(text.random)) {
text.random <- gs("text.random")
if (length(x$lower.random) > 1) {
meth.r <- gsub("classic", "", x$method.random.ci)
text.random <-
paste0(text.random,
ifelse(meth.r != "", "(", ""),
meth.r,
ifelse(meth.r == "HK" & x$adhoc.hakn.ci != "",
paste0("-",
toupper(substring(x$adhoc.hakn.ci, 1, 2))),
""),
ifelse(meth.r != "", ")", ""))
}
}
}
}
}
##
if (length(text.random) == 1 & n.ran > 1)
text.random <- rep(text.random, n.ran)
##
missing.text.predict <- missing(text.predict)
if (missing.text.predict | is.null(text.predict)) {
if (is.null(text.predict))
text.predict <- rep("Prediction interval", n.prd)
if (!(length(x$level.predict) == 0) &&
(study.results & (x$level != x$level.predict |
x$level.ma != x$level.predict)))
text.predict <- paste0(text.predict, " (",
round(x$level.predict * 100), "%-PI)")
}
##
if (metainf.metacum) {
overall.hetstat <- FALSE
test.overall.common <- FALSE
test.overall.random <- FALSE
resid.hetstat <- FALSE
test.subgroup.common <- FALSE
test.subgroup.random <- FALSE
##
hetstat <- FALSE
prediction <- FALSE
}
##
if (is.null(x$null.effect) || is.na(x$null.effect)) {
test.overall.common <- FALSE
test.overall.random <- FALSE
}
##
if (!overall) {
if (test.overall)
test.overall <- FALSE
if (test.overall.common)
test.overall.common <- FALSE
if (test.overall.random)
test.overall.random <- FALSE
}
##
## Add space for heterogeneity statistics (if needed)
##
if (is.null(addrows.below.overall)) {
addrows.below.overall <- 0
##
if (layout == "JAMA")
addrows.below.overall <- 3
else if (layout == "meta" & (metacor | metagen) &
missing.leftcols &
(overall.hetstat | test.overall.common |
test.overall.random) &
!(calcwidth.hetstat | calcwidth.tests))
addrows.below.overall <- 2
else if (layout %in% c("meta", "subgroup") &
(test.subgroup.common & test.subgroup.random) &
!calcwidth.tests) {
addrows.below.overall <- 1
##
if (layout == "meta")
addrows.below.overall <-
addrows.below.overall +
as.numeric((label.left != "" | label.right != "")) +
as.numeric(xlab != "")
}
}
##
chknumeric(addrows.below.overall, min = 0, length = 1, integer = TRUE)
##
notmiss.xlim <- !missing(xlim)
##
if (just.studlab == "left")
xpos.s <- 0
else if (just.studlab == "center")
xpos.s <- 0.5
else if (just.studlab == "right")
xpos.s <- 1
##
if (just.cols == "left")
xpos.c <- 0
else if (just.cols == "center")
xpos.c <- 0.5
else if (just.cols == "right")
xpos.c <- 1
##
if (log.xaxis) {
ref <- log(ref)
lower.equi <- log(lower.equi)
upper.equi <- log(upper.equi)
}
##
if (!backtransf & !missing(pscale) & pscale != 1 & !is_untransformed(sm)) {
warning("Argument 'pscale' set to 1 as argument 'backtransf' is FALSE.")
pscale <- 1
}
##
if (!backtransf & pscale != 1)
pscale <- 1
##
if (!backtransf & !missing(irscale) & irscale != 1 & !is_untransformed(sm)) {
warning("Argument 'irscale' set to 1 as argument 'backtransf' is FALSE.")
irscale <- 1
}
##
if (!backtransf & irscale != 1)
irscale <- 1
##
if (is.null(xlab))
xlab <- xlab(sm, backtransf, newline = revman5.jama, revman5 = revman5,
big.mark = big.mark)
##
smlab.null <- is.null(smlab)
if (smlab.null)
if (is_rate(sm))
smlab <- xlab(sm, backtransf, irscale = irscale, irunit = irunit,
newline = !revman5.jama, revman5 = revman5,
big.mark = big.mark)
else
smlab <- xlab(sm, backtransf, pscale = pscale,
newline = !revman5.jama, revman5 = revman5,
big.mark = big.mark)
##
print.label <- (label.left != "" | label.right != "") & !is.na(ref)
if (print.label & !bottom.lr) {
if (!smlab.null)
warning("Argument 'smlab' ignored as argument 'bottom.lr' is FALSE.")
smlab <- ""
}
##
if (!by)
addrow.subgroups <- FALSE
##
if (resid.hetstat &&
(!by || (by && is.null(x$tau.common) || !x$tau.common))) {
if (!missing(resid.hetstat))
warning("Information on residual heterogeneity only added to ",
"forest plot of meta-analysis with subgroups ",
"assuming common estimator for between-study heterogeneity ",
"(argument 'tau.common = TRUE' in meta-analysis functions)",
call. = FALSE)
resid.hetstat <- FALSE
}
##
plotwidth <- setunit(plotwidth)
colgap <- setunit(colgap)
colgap.left <- setunit(colgap.left)
colgap.right <- setunit(colgap.right)
colgap.studlab <- setunit(colgap.studlab)
colgap.forest <- setunit(colgap.forest)
colgap.forest.left <- setunit(colgap.forest.left)
colgap.forest.right <- setunit(colgap.forest.right)
##
missing.label.test.overall.common <- missing(label.test.overall.common)
missing.label.test.overall.fixed <-
is.na(argid(names(args), "label.test.overall.fixed"))
if (!missing.label.test.overall.fixed) {
label.test.overall.common <-
deprecated(label.test.overall.common, missing.label.test.overall.common,
args, "label.test.overall.fixed",
warn.deprecated)
missing.label.test.overall.common <- FALSE
}
if (missing.label.test.overall.common)
label.test.overall.common <-
paste0("Test for overall effect",
if (common.random)
paste0(" (", gs("text.w.common"), " effect)"),
": ")
if (missing(label.test.overall.random))
label.test.overall.random <-
paste0("Test for overall effect",
if (common.random)
paste0(" (", gs("text.w.random"), " effects)"),
": ")
##
missing.label.test.subgroup.common <- missing(label.test.subgroup.common)
missing.label.test.subgroup.fixed <-
is.na(argid(names(args), "label.test.subgroup.fixed"))
if (!missing.label.test.subgroup.fixed) {
label.test.subgroup.common <-
deprecated(label.test.subgroup.common,
missing.label.test.subgroup.common,
args, "label.test.subgroup.fixed",
warn.deprecated)
missing.label.test.subgroup.common <- FALSE
}
if (missing.label.test.subgroup.common)
label.test.subgroup.common <-
paste0("Test for subgroup differences",
if (common.random)
paste0(" (", gs("text.w.common"), " effect)"),
": ")
if (missing(label.test.subgroup.random))
label.test.subgroup.random <-
paste0("Test for subgroup differences",
if (common.random)
paste0(" (", gs("text.w.random"), " effects)"),
": ")
##
missing.label.test.effect.subgroup.common <-
missing(label.test.effect.subgroup.common)
missing.label.test.effect.subgroup.fixed <-
is.na(argid(names(args), "label.test.effect.subgroup.fixed"))
if (!missing.label.test.effect.subgroup.fixed) {
label.test.effect.subgroup.common <-
deprecated(label.test.effect.subgroup.common,
missing.label.test.effect.subgroup.common,
args, "label.test.effect.subgroup.fixed",
warn.deprecated)
missing.label.test.effect.subgroup.common <- FALSE
}
if (missing.label.test.effect.subgroup.common)
label.test.effect.subgroup.common <-
paste0(if (revman5.jama)
"Test for overall effect"
else
"Test for effect in subgroup",
if (common.random)
paste0(" (", gs("text.w.common"), " effect)"),
": ")
if (missing(label.test.effect.subgroup.random))
label.test.effect.subgroup.random <-
paste0(if (revman5.jama)
"Test for overall effect"
else
"Test for effect in subgroup",
if (common.random)
paste0(" (", gs("text.w.random"), " effects)"),
": ")
##
fs.head <- fs.heading
ff.head <- ff.heading
##
just.c <- just.cols
just.s <- just.studlab
##
##
## (6) Labels for columns on left and right side of forest plot
##
##
sm.lab <- sm
##
if (backtransf) {
if (sm == "ZCOR")
sm.lab <- "COR"
else if (is_prop(sm)) {
if (pscale == 1)
sm.lab <- "Proportion"
else
sm.lab <- "Events"
}
else if (is_rate(sm)) {
if (irscale == 1)
sm.lab <- "Rate"
else
sm.lab <- "Events"
}
else if (sm == "proportion")
sm.lab <- "Proportion"
else if (sm == "MLN")
sm.lab <- "Mean"
}
else if (is_relative_effect(sm) | (!is.null(fbt) && fbt == "exp"))
sm.lab <- paste0("log", sm)
##
sel.studlab <- pmatch(layout, c("meta", "RevMan5", "JAMA", "subgroup"))
lab.studlab <- c("Study", "Study", "Source", "Subgroup")[sel.studlab]
if (revman5 & by)
lab.studlab <- c("Study or\nSubgroup")
##
if (revman5.jama)
cisep <- " "
else
cisep <- "-"
##
if (study.results)
ci.lab <- paste0(100 * level, "%", cisep, "CI")
else
ci.lab <- paste0(100 * level.ma, "%", cisep, "CI")
##
missing.col.diamond.common <- missing(col.diamond.common)
missing.col.diamond.fixed <- is.na(argid(names(args), "col.diamond.fixed"))
if (!missing.col.diamond.fixed) {
col.diamond.common <-
deprecated(col.diamond.common, missing.col.diamond.common,
args, "col.diamond.fixed",
warn.deprecated)
missing.col.diamond.common <- FALSE
}
chkcolor(col.diamond.common)
##
if (jama) {
if (missing(ff.lr))
ff.lr <- "bold"
if (xlab == "")
xlab <- paste0(sm.lab, " (", ci.lab, ")")
if (miss.col.square)
col.square <- rep("darkblue", K.all)
if (miss.col.square.lines)
col.square.lines <- rep("darkblue", K.all)
if (missing.col.diamond.common)
col.diamond.common <- "lightblue"
if (missing(col.diamond.random))
col.diamond.random <- "lightblue"
##
smlab <- ""
bottom.lr <- FALSE
}
else {
if (revman5) {
if (miss.col.square) {
if (metacont | metamean)
col.square <- rep("green", K.all)
else if (metabin)
col.square <- rep("blue", K.all)
else
col.square <- rep("red", K.all)
}
if (miss.col.square.lines) {
if (metacont | metamean)
col.square.lines <- rep("green", K.all)
else if (metabin)
col.square.lines <- rep("darkblue", K.all)
else
col.square.lines <- rep("red", K.all)
}
if (missing.col.diamond.common)
col.diamond.common <- "black"
if (missing(col.diamond.random))
col.diamond.random <- "black"
##
sel.method <- pmatch(x$method, c("Inverse", "MH", "Peto", "GLMM"))
lab.method <- c("IV", "MH", "Peto", "GLMM")[sel.method]
##
if (common.random)
lab.model <- "Fixed + Random, "
else if (common)
lab.model <- "Fixed, "
else if (random)
lab.model <- "Random, "
else
lab.model <- ""
##
if (smlab.null)
smlab <- paste0(smlab, "\n", lab.method[1], ", ", lab.model, ci.lab)
}
}
##
if (jama | gs("CIbracket") == "(")
ci.lab.bracket <- paste0("(", ci.lab, ")")
else if (gs("CIbracket") == "[")
ci.lab.bracket <- paste0("[", ci.lab, "]")
else if (gs("CIbracket") == "{")
ci.lab.bracket <- paste0("{", ci.lab, "}")
else if (gs("CIbracket") == "")
ci.lab.bracket <- ci.lab
##
if (!common.random) {
text.w.common <- "Weight"
text.w.random <- "Weight"
}
else {
text.w.common <-
deprecated(text.w.common, missing(text.w.common), args, "text.w.fixed",
warn.deprecated)
##
if (is.null(text.w.common))
text.w.common <- paste0("Weight\n(", gs("text.w.common"), ")")
else
text.w.common <- paste0("Weight\n(", text.w.common, ")")
##
if (is.null(text.w.random))
text.w.random <- paste0("Weight\n(", gs("text.w.random"), ")")
else
text.w.random <- paste0("Weight\n(", text.w.random, ")")
}
##
lab.TE <- sm
##
if (log.xaxis | sm == "VE")
lab.TE <- paste0("log", sm)
else if (!log.xaxis & !is.null(ftr)) {
lab.TE <-
paste0(ftr, "(", sm,
if (!is.null(atr) && length(names(atr)) >= 1)
paste0(", ",
paste0(names(atr), "=", paste(atr), collapse = ", ")),
")")
}
else if (sm == "")
lab.TE <- "TE"
##
labnames <- c(lab.studlab,
lab.TE,
if (revman5) "SE" else paste0("SE(", lab.TE, ")"),
"Cluster",
"Total", "Total", "Events", "Events",
"Mean", "Mean", "SD", "SD",
"Cor",
"Time", "Time",
sm.lab,
ci.lab,
if (revman5 & smlab.null)
smlab
else
paste(sm.lab, ci.lab.bracket),
text.w.common,
text.w.common,
text.w.random,
"P-value")
##
if (metainf.metacum)
labnames <- c(labnames, "Tau2", "Tau", "I2")
##
if (newcols) {
##
if (length(rightcols.new) > 0) {
if (missing(rightlabs)) {
rightlabs.new <- rightcols.new
##
if ((metacor | metaprop | metamean | metarate) &
any(rightcols.new == "n"))
rightlabs.new[rightlabs.new == "n"] <- "Total"
##
if (metamean & any(rightcols.new == "mean"))
rightlabs.new[rightlabs.new == "mean"] <- "Mean"
##
if (metamean & any(rightcols.new == "sd"))
rightlabs.new[rightlabs.new == "sd"] <- "SD"
##
if (metarate & any(rightcols.new == "time"))
rightlabs.new[rightlabs.new == "time"] <- "Time"
##
if (any(rightcols.new == "pval"))
rightlabs.new[rightlabs.new == "pval"] <- "P-value"
##
if (any(rightcols.new == "tau2"))
rightlabs.new[rightlabs.new == "tau2"] <- "Tau2"
##
if (any(rightcols.new == "tau"))
rightlabs.new[rightlabs.new == "tau"] <- "Tau"
##
if (any(rightcols.new == "I2"))
rightlabs.new[rightlabs.new == "I2"] <- "I2"
##
if (three.level & any(rightcols.new == "cluster"))
rightlabs.new[rightlabs.new == "cluster"] <- "Cluster"
}
else {
if (length(rightcols.new) == length(rightlabs))
rightlabs.new <- rightlabs
else if (length(rightcols.new) > length(rightlabs))
stop("Too few labels defined for argument 'rightcols'.")
else {
rightlabs.new <- rightcols.new
##
for (i in seq_along(rightcols.new)) {
match1.i <- match(rightcols.new[i], rightcols)
if (!is.na(rightlabs[match1.i]))
rightlabs.new[i] <- rightlabs[match1.i]
else {
match2.i <- match(rightcols.new[i], colnames)
if (!is.na(match2.i))
rightlabs.new[i] <- labnames[match2.i]
else if (rightcols.new[i] == "pval")
rightlabs.new[i] <- "P-value"
else if (rightcols.new[i] == "tau2")
rightlabs.new[i] <- "Tau2"
else if (rightcols.new[i] == "tau")
rightlabs.new[i] <- "Tau"
else if (rightcols.new[i] == "I2")
rightlabs.new[i] <- "I2"
}
}
}
}
}
##
if (length(leftcols.new) > 0) {
if (missing(leftlabs)) {
leftlabs.new <- leftcols.new
##
if ((metacor | metaprop | metamean | metarate) &
any(leftcols.new == "n"))
leftlabs.new[leftlabs.new == "n"] <- "Total"
##
if (metamean & any(leftcols.new == "mean"))
leftlabs.new[leftlabs.new == "mean"] <- "Mean"
##
if (metamean & any(leftcols.new == "sd"))
leftlabs.new[leftlabs.new == "sd"] <- "SD"
##
if (metarate & any(leftcols.new == "time"))
leftlabs.new[leftlabs.new == "time"] <- "Time"
##
if (any(leftcols.new == "pval"))
leftlabs.new[leftlabs.new == "pval"] <- "P-value"
##
if (any(leftcols.new == "tau2"))
leftlabs.new[leftlabs.new == "tau2"] <- "Tau2"
##
if (any(leftcols.new == "tau"))
leftlabs.new[leftlabs.new == "tau"] <- "Tau"
##
if (any(leftcols.new == "I2"))
leftlabs.new[leftlabs.new == "I2"] <- "I2"
##
if (three.level & any(leftcols.new == "cluster"))
leftlabs.new[leftlabs.new == "cluster"] <- "Cluster"
}
else {
if (length(leftcols.new) == length(leftlabs))
leftlabs.new <- leftlabs
else if (length(leftcols.new) > length(leftlabs))
stop("Too few labels defined for argument 'leftcols'.")
else {
leftlabs.new <- leftcols.new
##
for (i in seq_along(leftcols.new)) {
match1.i <- match(leftcols.new[i], leftcols)
if (!is.na(leftlabs[match1.i]))
leftlabs.new[i] <- leftlabs[match1.i]
else {
match2.i <- match(leftcols.new[i], colnames)
if (!is.na(match2.i))
leftlabs.new[i] <- labnames[match2.i]
else if (leftcols.new[i] == "pval")
leftlabs.new[i] <- "P-value"
else if (leftcols.new[i] == "tau2")
leftlabs.new[i] <- "Tau2"
else if (leftcols.new[i] == "tau")
leftlabs.new[i] <- "Tau"
else if (leftcols.new[i] == "I2")
leftlabs.new[i] <- "I2"
}
}
}
}
}
}
##
## Default set of columns if argument leftcols and / or
## rightcols not specified
##
if (is.null(leftcols) && lsel) {
##
leftcols <- "studlab"
##
if (three.level)
leftcols <- c(leftcols, "cluster")
##
if (jama) {
leftcols <- c(leftcols, "effect.ci")
}
else {
if (metabin) {
if (study.results)
leftcols <- c(leftcols,
"event.e", "n.e",
"event.c", "n.c")
else {
leftcols <- c(leftcols,
if (pooled.events) "event.e",
if (pooled.totals) "n.e",
if (pooled.events) "event.c",
if (pooled.totals) "n.c")
if (pooled.events & !pooled.totals) {
if (is.null(label.e.attach))
label.e.attach <- "event.e"
if (is.null(label.c.attach))
label.c.attach <- "event.c"
}
}
}
##
if (metacont) {
if (study.results) {
if (revman5)
leftcols <- c(leftcols,
"mean.e", "sd.e", "n.e",
"mean.c", "sd.c", "n.c")
else
leftcols <- c(leftcols,
"n.e", "mean.e", "sd.e",
"n.c", "mean.c", "sd.c")
}
else if (pooled.totals) {
leftcols <- c(leftcols, "n.e", "n.c")
if (is.null(label.e.attach))
label.e.attach <- "n.e"
if (is.null(label.c.attach))
label.c.attach <- "n.c"
}
}
##
if (metagen & study.results) {
leftcols <- c(leftcols,
"TE", "seTE")
if (!is.null(x$n.e)) {
leftcols <- c(leftcols, "n.e")
if (is.null(label.e.attach))
label.e.attach <- "n.e"
}
if (!is.null(x$n.c)) {
leftcols <- c(leftcols, "n.c")
if (is.null(label.c.attach))
label.c.attach <- "n.c"
}
}
##
if (metamean) {
if (study.results) {
if (revman5)
leftcols <- c(leftcols,
"mean.e", "sd.e", "n.e")
else
leftcols <- c(leftcols,
"n.e", "mean.e", "sd.e")
}
else if (pooled.totals) {
leftcols <- c(leftcols, "n.e")
if (is.null(label.e.attach))
label.e.attach <- "n.e"
}
}
##
if (metaprop) {
if (study.results)
leftcols <- c(leftcols, "event.e", "n.e")
else {
leftcols <- c(leftcols,
if (pooled.events) "event.e",
if (pooled.totals) "n.e")
if (pooled.events & !pooled.totals) {
if (is.null(label.e.attach))
label.e.attach <- "event.e"
}
}
}
##
if (metarate) {
if (study.results)
leftcols <- c(leftcols,
"event.e", "time.e",
if (!is.null(x$n)) "n.e")
else {
leftcols <- c(leftcols,
if (pooled.events) "event.e",
if (pooled.times) "time.e")
if (pooled.events & !pooled.times) {
if (is.null(label.e.attach))
label.e.attach <- "event.e"
}
}
}
##
if (metacor) {
if (study.results | pooled.totals)
leftcols <- c(leftcols,
"n.e")
}
##
if (metainc) {
if (study.results)
leftcols <- c(leftcols,
"event.e", "time.e",
"event.c", "time.c")
else {
leftcols <- c(leftcols,
if (pooled.events) "event.e",
if (pooled.times) "time.e",
if (pooled.events) "event.c",
if (pooled.times) "time.c")
if (pooled.events & !pooled.times) {
if (is.null(label.e.attach))
label.e.attach <- "event.e"
if (is.null(label.c.attach))
label.c.attach <- "event.c"
}
}
}
}
##
## Add columns for RevMan 5 layout
##
if (revman5) {
##
if (!metainf.metacum & overall & study.results & !any(x$method == "GLMM")) {
if (common)
leftcols <- c(leftcols, "w.common")
if (random)
leftcols <- c(leftcols, "w.random")
}
##
leftcols <- c(leftcols, "effect.ci")
}
}
##
leftcols[leftcols == "w.fixed"] <- "w.common"
leftcols <- unique(leftcols)
##
if (is.null(rightcols) && rsel) {
rightcols <- c("effect", "ci")
##
if (!metainf.metacum & overall & study.results & !any(x$method == "GLMM")) {
if (common)
rightcols <- c(rightcols, "w.common")
if (random)
rightcols <- c(rightcols, "w.random")
}
##
if (metainf.metacum)
rightcols <- c(rightcols, "pval", "tau2", "tau", "I2")
}
##
rightcols[rightcols == "w.fixed"] <- "w.common"
rightcols <- unique(rightcols)
##
if (any(leftcols == "w.common") & any(rightcols == "w.common"))
leftcols <- leftcols[!leftcols == "w.common"]
##
##
## (6) Select data for forest plot
##
##
if (metacor) {
x$n.e <- x$n
}
##
if (metamean) {
x$n.e <- x$n
x$mean.e <- x$mean
x$sd.e <- x$sd
##
if (!is.null(rightcols)) {
if (any(rightcols == "n"))
rightcols[rightcols == "n"] <- "n.e"
if (any(rightcols == "mean"))
rightcols[rightcols == "mean"] <- "mean.e"
if (any(rightcols == "sd"))
rightcols[rightcols == "sd"] <- "sd.e"
}
##
if (!is.null(leftcols)) {
if (any(leftcols == "n"))
leftcols[leftcols == "n"] <- "n.e"
if (any(leftcols == "mean"))
leftcols[leftcols == "mean"] <- "mean.e"
if (any(leftcols == "sd"))
leftcols[leftcols == "sd"] <- "sd.e"
}
}
##
if (metaprop) {
x$event.e <- x$event
x$n.e <- x$n
##
if (!is.null(rightcols)) {
if (any(rightcols == "n"))
rightcols[rightcols == "n"] <- "n.e"
if (any(rightcols == "event"))
rightcols[rightcols == "event"] <- "event.e"
}
##
if (!is.null(leftcols)) {
if (any(leftcols == "n"))
leftcols[leftcols == "n"] <- "n.e"
if (any(leftcols == "event"))
leftcols[leftcols == "event"] <- "event.e"
}
}
##
if (metarate) {
x$event.e <- x$event
x$time.e <- x$time
x$n.e <- x$n
##
if (!is.null(rightcols)) {
if (any(rightcols == "time"))
rightcols[rightcols == "time"] <- "time.e"
if (any(rightcols == "event"))
rightcols[rightcols == "event"] <- "event.e"
if (any(rightcols == "n"))
rightcols[rightcols == "n"] <- "n.e"
}
##
if (!is.null(leftcols)) {
if (any(leftcols == "time"))
leftcols[leftcols == "time"] <- "time.e"
if (any(leftcols == "event"))
leftcols[leftcols == "event"] <- "event.e"
if (any(leftcols == "n"))
leftcols[leftcols == "n"] <- "n.e"
}
}
##
if (metainf.metacum) {
##
x$TE.common <- rev(x$TE)[1]
x$seTE.common <- rev(x$seTE)[1]
x$lower.common <- rev(x$lower)[1]
x$upper.common <- rev(x$upper)[1]
##
x$TE.random <- rev(x$TE)[1]
x$seTE.random <- rev(x$seTE)[1]
x$lower.random <- rev(x$lower)[1]
x$upper.random <- rev(x$upper)[1]
##
x$n.harmonic.mean.ma <- rev(x$n.harmonic.mean)[1]
x$t.harmonic.mean.ma <- rev(x$t.harmonic.mean)[1]
##
x$w.all <- rev(x$w)[1]
##
x$TE <- rev(rev(x$TE)[-(1:2)])
x$seTE <- rev(rev(x$seTE)[-(1:2)])
x$studlab <- rev(rev(x$studlab)[-(1:2)])
##
x$lower <- rev(rev(x$lower)[-(1:2)])
x$upper <- rev(rev(x$upper)[-(1:2)])
##
x$w.common <- rev(rev(x$w)[-(1:2)])
x$w.random <- rev(rev(x$w)[-(1:2)])
##
x$n.harmonic.mean <- rev(rev(x$n.harmonic.mean)[-(1:2)])
x$t.harmonic.mean <- rev(rev(x$t.harmonic.mean)[-(1:2)])
##
x$pval.common <- x$pval.random <- rev(x$pval)[1]
x$tau2.overall <- rev(x$tau2)[1]
x$tau.overall <- rev(x$tau)[1]
x$I2.overall <- rev(x$I2)[1]
##
x$pval <- rev(rev(x$pval)[-(1:2)])
x$tau2 <- rev(rev(x$tau2)[-(1:2)])
x$tau <- rev(rev(x$tau)[-(1:2)])
x$I2 <- rev(rev(x$I2)[-(1:2)])
##
if (overall & x$pooled == "common") {
common <- TRUE
random <- FALSE
if (weight.study != "same")
weight.study <- "common"
}
else if (overall & x$pooled == "random") {
common <- FALSE
random <- TRUE
if (weight.study != "same")
weight.study <- "random"
}
}
## Total number of studies to plot (*not* number of studies combined)
k.all <- length(x$TE)
##
if (allstudies)
n.stud <- k.all # all studies
else
n.stud <- sum(!is.na(x$TE)) # number of studies with treatment estimates
##
if (length(type.study) == 1)
type.study <- rep(type.study, k.all)
else if (length(type.study) != k.all)
stop("Argument 'type.study' must be a single character or of ",
"same length as number of studies.")
##
if (!by)
subgroup <- rep(1, k.all)
##
if (by & anyNA(subgroup))
stop("Missing values in 'subgroup'")
##
if (allstudies)
sel <- rep(TRUE, k.all)
else
sel <- !is.na(x$TE)
##
x$n.e <- x$n.e[sel]
x$n.c <- x$n.c[sel]
##
x$event.e <- x$event.e[sel]
x$event.c <- x$event.c[sel]
##
x$mean.e <- x$mean.e[sel]
x$mean.c <- x$mean.c[sel]
##
x$sd.e <- x$sd.e[sel]
x$sd.c <- x$sd.c[sel]
##
x$cor <- x$cor[sel]
##
x$time.e <- x$time.e[sel]
x$time.c <- x$time.c[sel]
##
x$TE <- x$TE[sel]
x$seTE <- x$seTE[sel]
##
x$lower <- x$lower[sel]
x$upper <- x$upper[sel]
##
if (is.matrix(x$w.common))
x$w.common <- x$w.common[sel, , drop = FALSE]
else
x$w.common <- x$w.common[sel]
##
if (is.matrix(x$w.random))
x$w.random <- x$w.random[sel, , drop = FALSE]
else
x$w.random <- x$w.random[sel]
##
studlab <- studlab[sel]
type.study <- type.study[sel]
##
x$n.harmonic.mean <- x$n.harmonic.mean[sel]
x$t.harmonic.mean <- x$t.harmonic.mean[sel]
##
x$pval <- x$pval[sel]
##
x$cluster <- x$cluster[sel]
##
if (metainf.metacum) {
x$tau2 <- x$tau2[sel]
x$tau <- x$tau[sel]
x$I2 <- x$I2[sel]
}
##
subgroup <- subgroup[sel]
sortvar <- sortvar[sel]
##
col.study <- col.study[sel]
col.square <- col.square[sel]
col.square.lines <- col.square.lines[sel]
##
col.inside <- col.inside[sel]
##
null.exclude <- is.null(x$exclude)
if (!null.exclude)
exclude <- x$exclude[sel]
##
if (sort | by) {
if (sort.subgroup)
subgroup.levels <- sort(x$subgroup.levels)
else
subgroup.levels <- x$subgroup.levels
##
subgroup.factor <- factor(subgroup, levels = subgroup.levels)
o <- order(subgroup.factor, sortvar)
##
x$cluster <- x$cluster[o]
##
x$n.e <- x$n.e[o]
x$n.c <- x$n.c[o]
##
x$event.e <- x$event.e[o]
x$event.c <- x$event.c[o]
##
x$mean.e <- x$mean.e[o]
x$mean.c <- x$mean.c[o]
##
x$sd.e <- x$sd.e[o]
x$sd.c <- x$sd.c[o]
##
x$cor <- x$cor[o]
##
x$time.e <- x$time.e[o]
x$time.c <- x$time.c[o]
##
x$TE <- x$TE[o]
x$seTE <- x$seTE[o]
##
x$lower <- x$lower[o]
x$upper <- x$upper[o]
##
if (is.matrix(x$w.common))
x$w.common <- x$w.common[o, , drop = FALSE]
else
x$w.common <- x$w.common[o]
##
if (is.matrix(x$w.random))
x$w.random <- x$w.random[o, , drop = FALSE]
else
x$w.random <- x$w.random[o]
##
studlab <- studlab[o]
type.study <- type.study[o]
##
x$n.harmonic.mean <- x$n.harmonic.mean[o]
x$t.harmonic.mean <- x$t.harmonic.mean[o]
##
x$pval <- x$pval[o]
##
if (metainf.metacum) {
x$tau2 <- x$tau2[o]
x$tau <- x$tau[o]
x$I2 <- x$I2[o]
}
##
subgroup <- subgroup[o]
sortvar <- sortvar[o]
##
col.study <- col.study[o]
col.square <- col.square[o]
col.square.lines <- col.square.lines[o]
##
col.inside <- col.inside[o]
##
if (!null.exclude)
exclude <- exclude[o]
##
if (newcols) {
dataset1 <- dataset1[o, ]
dataset2 <- dataset2[o, ]
}
}
##
if (metainf.metacum) {
TE <- x$TE
seTE <- x$seTE
lowTE <- x$lower
uppTE <- x$upper
##
TE.common <- x$TE.common
lowTE.common <- x$lower.common
uppTE.common <- x$upper.common
##
TE.random <- x$TE.random
lowTE.random <- x$lower.random
uppTE.random <- x$upper.random
##
lowTE.predict <- NA
uppTE.predict <- NA
##
Q <- NA
df.Q <- NA
pval.Q <- NA
I2 <- NA
tau2 <- NA
lower.tau2 <- NA
upper.tau2 <- NA
tau <- NA
lower.tau <- NA
upper.tau <- NA
sign.lower.tau <- ""
sign.upper.tau <- ""
lowI2 <- NA
uppI2 <- NA
Rb <- NA
lowRb <- NA
uppRb <- NA
##
Q.b.common <- NA
Q.b.random <- NA
df.Q.b <- NA
df.Q.b.common <- NA
df.Q.b.random <- NA
pval.Q.b.common <- NA
pval.Q.b.random <- NA
}
else {
TE <- x$TE
seTE <- x$seTE
lowTE <- x$lower
uppTE <- x$upper
##
if ((metaprop | metarate) & !backtransf) {
ciTE <- ci(TE, seTE, level = level)
lowTE <- ciTE$lower
uppTE <- ciTE$upper
}
##
TE.common <- x$TE.common
lowTE.common <- x$lower.common
uppTE.common <- x$upper.common
##
TE.random <- x$TE.random
lowTE.random <- x$lower.random
uppTE.random <- x$upper.random
if (n.ran > 1 && length(TE.random) == 1)
TE.random <- rep(TE.random, n.ran)
##
lowTE.predict <- x$lower.predict
uppTE.predict <- x$upper.predict
##
if (LRT)
Q <- x$Q.LRT
else
Q <- unlist(x$Q)
##
df.Q <- unlist(x$df.Q)
pval.Q <- replaceNULL(unlist(x$pval.Q), pvalQ(Q, df.Q))
##
## Keep the first heterogeneity statistics
##
if (length(Q) > 1) {
Q <- Q[1]
df.Q <- df.Q[1]
pval.Q <- pval.Q[1]
}
##
tau2 <- x$tau2
lower.tau2 <- x$lower.tau2
upper.tau2 <- x$upper.tau2
##
if (is.null(tau2)) {
tau2 <- x$tau^2
lower.tau2 <- upper.tau2 <- NA
}
##
if (length(tau2) > 1) {
if (three.level) {
tau2 <- sum(tau2)
lower.tau2 <- NA
upper.tau2 <- NA
}
else {
tau2 <- tau2[1]
lower.tau2 <- lower.tau2[1]
upper.tau2 <- upper.tau2[1]
}
}
##
tau <- x$tau
lower.tau <- x$lower.tau
upper.tau <- x$upper.tau
##
if (length(tau) > 1) {
if (three.level) {
tau <- sqrt(sum(tau^2))
lower.tau2 <- NA
upper.tau2 <- NA
}
else {
tau <- tau[1]
lower.tau <- lower.tau[1]
upper.tau <- upper.tau[1]
}
}
##
sign.lower.tau <- x$sign.lower.tau
sign.upper.tau <- x$sign.lower.tau
##
if (is.null(lower.tau)) {
lower.tau <- upper.tau <- NA
sign.lower.tau <- sign.upper.tau <- ""
}
##
I2 <- unlist(x$I2)
lowI2 <- unlist(x$lower.I2)
uppI2 <- unlist(x$upper.I2)
##
if (length(I2) > 1) {
I2 <- I2[1]
lowI2 <- lowI2[1]
uppI2 <- uppI2[1]
}
##
Rb <- unlist(x$Rb)
lowRb <- unlist(x$lower.Rb)
uppRb <- unlist(x$upper.Rb)
##
if (length(Rb) > 1) {
Rb <- Rb[1]
lowRb <- lowRb[1]
uppRb <- uppRb[1]
}
##
if (by) {
df.Q.b <- x$df.Q.b
df.Q.b.random <- replaceNULL(x$df.Q.b.random, df.Q.b)
##
Q.b.common <- x$Q.b.common
df.Q.b.common <- replaceNULL(x$df.Q.b.common, df.Q.b)
pval.Q.b.common <-
replaceNULL(x$pval.Q.b.common, pvalQ(Q.b.common, df.Q.b.common))
## Only consider test for subgroup differences for first random
## effects meta-analysis method
Q.b.random <- x$Q.b.random[1]
if (is.list(df.Q.b.random))
df.Q.b.random <- df.Q.b.random[[1]]
##
if (length(df.Q.b.random) == 1)
pval.Q.b.random <-
replaceNULL(x$pval.Q.b.random[1], pvalQ(Q.b.random, df.Q.b.random))
else if (length(df.Q.b.random) == 2)
pval.Q.b.random <-
replaceNULL(x$pval.Q.b.random[1],
pf(Q.b.random, df.Q.b.random[1], df.Q.b.random[2],
lower.tail = FALSE))
else
pval.Q.b.random <- x$pval.Q.b.random
##
Q.resid <- x$Q.resid
df.Q.resid <- x$df.Q.resid
pval.Q.resid <- x$pval.Q.resid
##
tau2.resid <- x$tau2.resid
lower.tau2.resid <- x$lower.tau2.resid
upper.tau2.resid <- x$upper.tau2.resid
if (is.null(tau2.resid)) {
tau2.resid <- x$tau.resid^2
lower.tau2.resid <- upper.tau2.resid <- NA
}
tau.resid <- x$tau.resid
lower.tau.resid <- x$lower.tau.resid
upper.tau.resid <- x$upper.tau.resid
sign.lower.tau.resid <- x$sign.lower.tau.resid
sign.upper.tau.resid <- x$sign.lower.tau.resid
if (is.null(lower.tau.resid)) {
lower.tau.resid <- upper.tau.resid <- NA
sign.lower.tau.resid <- sign.upper.tau.resid <- ""
}
##
I2.resid <- x$I2.resid
lowI2.resid <- x$lower.I2.resid
uppI2.resid <- x$upper.I2.resid
}
else {
Q.b.common <- NA
Q.b.random <- NA
df.Q.b <- NA
df.Q.b.common <- NA
df.Q.b.random <- NA
}
}
##
hetstat.overall <- ""
##
if (overall.hetstat || is.character(hetstat)) {
##
hetstat.I2 <-
paste0(hetseparator,
formatN(100 * I2, digits.I2, "NA"), "%",
if (print.I2.ci && !(is.na(lowI2) | is.na(uppI2)))
pasteCI(100 * lowI2, 100 * uppI2,
digits.I2, big.mark,
text.NA = lab.NA, unit = "%"))
##
hetstat.tau2 <-
paste0(formatPT(tau2, digits = digits.tau2, big.mark = big.mark,
lab = TRUE, labval = "", lab.NA = "NA"),
if (print.tau2.ci && !(is.na(lower.tau2) | is.na(upper.tau2)))
pasteCI(lower.tau2, upper.tau2, digits.tau2, big.mark,
sign.lower.tau, sign.upper.tau, lab.NA))
##
hetstat.tau <-
paste0(formatPT(tau, digits = digits.tau, big.mark = big.mark,
lab = TRUE, labval = "", lab.NA = "NA"),
if (print.tau.ci && !(is.na(lower.tau) | is.na(upper.tau)))
pasteCI(lower.tau, upper.tau, digits.tau, big.mark,
sign.lower.tau, sign.upper.tau, lab.NA))
##
hetstat.Q <-
paste0(hetseparator,
formatN(Q, digits.Q, "NA", big.mark = big.mark),
if (revman5) ", df",
if (revman5) hetseparator,
if (revman5) df.Q)
##
hetstat.pval.Q <-
formatPT(pval.Q,
lab = TRUE, labval = "",
digits = digits.pval.Q,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA")
##
if (print.Rb)
hetstat.Rb <-
paste0(hetseparator,
formatN(100 * Rb, digits.I2, "NA", big.mark = big.mark),
"%",
if (print.Rb.ci && !(is.na(lowRb) | is.na(uppRb)))
pasteCI(100 * lowRb, 100 * uppRb,
digits.I2, big.mark,
text.NA = lab.NA, unit = "%"))
##
## Remove superfluous spaces
##
while(grepl(" ", hetstat.I2))
hetstat.I2 <- gsub(" ", " ", hetstat.I2)
while(grepl(" ", hetstat.tau2))
hetstat.tau2 <- gsub(" ", " ", hetstat.tau2)
while(grepl(" ", hetstat.Q))
hetstat.Q <- gsub(" ", " ", hetstat.Q)
while(grepl(" ", hetstat.pval.Q))
hetstat.pval.Q <- gsub(" ", " ", hetstat.pval.Q)
if (print.Rb)
while(grepl(" ", hetstat.Rb))
hetstat.Rb <- gsub(" ", " ", hetstat.Rb)
##
if (revman5)
hetstat.overall <- substitute(paste(hl,
"Tau"^2, ht, "; ",
"Chi"^2, hq,
" (",
P, hp,
"); ",
I^2, hi),
list(hl = hetlab,
hi = hetstat.I2,
ht = hetstat.tau2,
hq = hetstat.Q,
hp = hetstat.pval.Q))
else if (jama)
hetstat.overall <- substitute(paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi
),
list(hl = hetlab,
hi = hetstat.I2,
hq = hetstat.Q,
hp = hetstat.pval.Q,
df = df.Q))
else {
##
## One
##
if (print.I2 & !print.tau2.tau & !print.Q & !print.pval.Q & !print.Rb)
hetstat.overall <-
substitute(paste(hl, italic(I)^2, hi),
list(hl = hetlab, hi = hetstat.I2))
else if (!print.I2 & print.tau2.tau & !print.Q & !print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.overall <- substitute(paste(hl, tau^2, ht),
list(hl = hetlab, ht = hetstat.tau2))
else
hetstat.overall <- substitute(paste(hl, tau, ht),
list(hl = hetlab, ht = hetstat.tau))
else if (!print.I2 & !print.tau2.tau & print.Q & !print.pval.Q &
!print.Rb)
hetstat.overall <-
substitute(paste(hl, chi[df]^2, hq),
list(hl = hetlab, df = df.Q, hq = hetstat.Q))
else if (!print.I2 & !print.tau2.tau & !print.Q & print.pval.Q &
!print.Rb)
hetstat.overall <-
substitute(paste(hl, italic(p), hp),
list(hl = hetlab, hp = hetstat.pval.Q))
else if (!print.I2 & !print.tau2.tau & !print.Q & !print.pval.Q &
print.Rb)
hetstat.overall <-
substitute(paste(hl, italic(R)[italic(b)], hb),
list(hl = hetlab, hb = hetstat.Rb))
##
## Two
##
else if (print.I2 & print.tau2.tau & !print.Q & !print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl, italic(I)^2, hi,
", ",
tau^2, ht),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau2))
else
hetstat.overall <-
substitute(paste(hl, italic(I)^2, hi,
", ",
tau, ht),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau))
else if (print.I2 & !print.tau2.tau & print.Q & !print.pval.Q & !print.Rb)
hetstat.overall <-
substitute(paste(hl, italic(I)^2, hi,
", ",
chi[df]^2, hq),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, hq = hetstat.Q))
else if (print.I2 & !print.tau2.tau & !print.Q & print.pval.Q & !print.Rb)
hetstat.overall <-
substitute(paste(hl, italic(I)^2, hi,
", ",
italic(p), hp),
list(hl = hetlab,
hi = hetstat.I2, hp = hetstat.pval.Q))
else if (print.I2 & !print.tau2.tau & !print.Q & !print.pval.Q & print.Rb)
hetstat.overall <-
substitute(paste(hl, italic(I)^2, hi,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2, hb = hetstat.Rb))
else if (!print.I2 & print.tau2.tau & print.Q & !print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl, tau^2, ht,
", ",
chi[df]^2, hq),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau2, hq = hetstat.Q))
else
hetstat.overall <-
substitute(paste(hl, tau, ht,
", ",
chi[df]^2, hq),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau, hq = hetstat.Q))
else if (!print.I2 & print.tau2.tau & !print.Q & print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl, tau^2, ht,
", ",
italic(p), hp),
list(hl = hetlab,
ht = hetstat.tau2, hp = hetstat.pval.Q))
else
hetstat.overall <-
substitute(paste(hl, tau, ht,
", ",
italic(p), hp),
list(hl = hetlab,
ht = hetstat.tau, hp = hetstat.pval.Q))
else if (!print.I2 & print.tau2.tau & !print.Q & !print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl, tau^2, ht,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau2, hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl, tau, ht,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau, hb = hetstat.Rb))
else if (!print.I2 & !print.tau2.tau & print.Q & print.pval.Q & !print.Rb)
hetstat.overall <-
substitute(paste(hl, chi[df]^2, hq,
" (",
italic(p), hp, ")"),
list(hl = hetlab, df = df.Q,
hq = hetstat.Q, hp = hetstat.pval.Q))
else if (!print.I2 & !print.tau2.tau & print.Q & !print.pval.Q & print.Rb)
hetstat.overall <-
substitute(paste(hl, chi[df]^2, hq,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hq = hetstat.Q, hb = hetstat.Rb))
else if (!print.I2 & !print.tau2.tau & !print.Q & print.pval.Q & print.Rb)
hetstat.overall <-
substitute(paste(hl, italic(p), hp,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hp = hetstat.pval.Q, hb = hetstat.Rb))
##
## Three
##
else if (print.I2 & print.tau2.tau & print.Q & !print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau2,
hq = hetstat.Q))
else
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau,
hq = hetstat.Q))
else if (print.I2 & print.tau2.tau & !print.Q & print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(p), hp),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau2,
hp = hetstat.pval.Q))
else
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(p), hp),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau,
hp = hetstat.pval.Q))
else if (print.I2 & !print.tau2.tau & print.Q & print.pval.Q & !print.Rb)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2,
hq = hetstat.Q, hp = hetstat.pval.Q))
else if (!print.I2 & print.tau2.tau & print.Q & print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau2,
hq = hetstat.Q, hp = hetstat.pval.Q))
else
hetstat.overall <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau,
hq = hetstat.Q, hp = hetstat.pval.Q))
else if (print.I2 & print.tau2.tau & !print.Q & !print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau2,
hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau,
hb = hetstat.Rb))
else if (print.I2 & !print.tau2.tau & print.Q & !print.pval.Q & print.Rb)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2,
hq = hetstat.Q,
hb = hetstat.Rb))
else if (!print.I2 & print.tau2.tau & print.Q & !print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau2,
hq = hetstat.Q,
hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau,
hq = hetstat.Q,
hb = hetstat.Rb))
else if (print.I2 & !print.tau2.tau & !print.Q & print.pval.Q & print.Rb)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2, hp = hetstat.pval.Q,
hb = hetstat.Rb))
else if (!print.I2 & print.tau2.tau & !print.Q & print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
tau^2, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau2,
hp = hetstat.pval.Q,
hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl,
tau, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau,
hp = hetstat.pval.Q,
hb = hetstat.Rb))
else if (!print.I2 & !print.tau2.tau & print.Q & print.pval.Q & print.Rb)
hetstat.overall <-
substitute(paste(hl,
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hq = hetstat.Q, hp = hetstat.pval.Q,
hb = hetstat.Rb))
##
## Four
##
if (print.I2 & print.tau2.tau & print.Q & print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau2,
hq = hetstat.Q, hp = hetstat.pval.Q))
else
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau,
hq = hetstat.Q, hp = hetstat.pval.Q))
else if (print.I2 & print.tau2.tau & print.Q & !print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau2,
hq = hetstat.Q, hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau,
hq = hetstat.Q, hb = hetstat.Rb))
else if (print.I2 & print.tau2.tau & !print.Q & print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau2,
hp = hetstat.pval.Q, hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2, ht = hetstat.tau,
hp = hetstat.pval.Q, hb = hetstat.Rb))
else if (print.I2 & !print.tau2.tau & print.Q & print.pval.Q & print.Rb)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2,
hq = hetstat.Q, hp = hetstat.pval.Q,
hb = hetstat.Rb))
else if (!print.I2 & print.tau2.tau & print.Q & print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau2,
hq = hetstat.Q, hp = hetstat.pval.Q,
hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
ht = hetstat.tau,
hq = hetstat.Q, hp = hetstat.pval.Q,
hb = hetstat.Rb))
##
## Five
##
else if (print.I2 & print.tau2.tau & print.Q & print.pval.Q & print.Rb)
if (print.tau2)
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau2,
hq = hetstat.Q, hp = hetstat.pval.Q,
hb = hetstat.Rb))
else
hetstat.overall <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = df.Q,
hi = hetstat.I2, ht = hetstat.tau,
hq = hetstat.Q, hp = hetstat.pval.Q,
hb = hetstat.Rb))
}
}
##
## Line with residual heterogeneity
##
hetstat.resid <- ""
##
if (by && (length(tau2.resid) == 0 || is.na(tau2.resid)))
print.tau2.tau.resid <- FALSE
else
print.tau2.tau.resid <- print.tau2.tau
##
if (resid.hetstat) {
##
hetstat.I2.resid <-
paste0(hetseparator,
formatN(100 * I2.resid, digits.I2, "NA"), "%",
if (print.I2.ci && !(is.na(lowI2.resid) | is.na(uppI2.resid)))
pasteCI(100 * lowI2.resid, 100 * uppI2.resid,
digits.I2, big.mark,
text.NA = lab.NA, unit = "%"))
##
hetstat.tau2.resid <-
paste0(formatPT(tau2.resid, digits = digits.tau2, big.mark = big.mark,
lab = TRUE, labval = "", lab.NA = "NA"),
if (print.tau2.ci &&
!(is.na(lower.tau2.resid) | is.na(upper.tau2.resid)))
pasteCI(lower.tau2.resid, upper.tau2.resid, digits.tau2,
big.mark,
sign.lower.tau.resid, sign.upper.tau.resid, lab.NA))
hetstat.tau.resid <-
paste0(formatPT(tau.resid, digits = digits.tau, big.mark = big.mark,
lab = TRUE, labval = "", lab.NA = "NA"),
if (print.tau.ci &&
!(is.na(lower.tau.resid) | is.na(upper.tau.resid)))
pasteCI(lower.tau.resid, upper.tau.resid, digits.tau,
big.mark,
sign.lower.tau.resid, sign.upper.tau.resid, lab.NA))
##
hetstat.Q.resid <-
paste0(hetseparator,
formatN(Q.resid, digits.Q, "NA", big.mark = big.mark),
if (revman5) ", df",
if (revman5) hetseparator,
if (revman5) df.Q.resid)
##
hetstat.pval.Q.resid <-
formatPT(pval.Q.resid,
lab = TRUE, labval = "",
digits = digits.pval.Q,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA")
##
hetstat.Rb.resid <- ""
print.Rb.resid <- FALSE
##
## Remove superfluous spaces
##
while(grepl(" ", hetstat.I2.resid))
hetstat.I2.resid <- gsub(" ", " ", hetstat.I2.resid)
while(grepl(" ", hetstat.tau2.resid))
hetstat.tau2.resid <- gsub(" ", " ", hetstat.tau2.resid)
while(grepl(" ", hetstat.tau.resid))
hetstat.tau.resid <- gsub(" ", " ", hetstat.tau.resid)
while(grepl(" ", hetstat.Q.resid))
hetstat.Q.resid <- gsub(" ", " ", hetstat.Q.resid)
while(grepl(" ", hetstat.pval.Q.resid))
hetstat.pval.Q.resid <- gsub(" ", " ", hetstat.pval.Q.resid)
while(grepl(" ", hetstat.Rb.resid))
hetstat.Rb.resid <- gsub(" ", " ", hetstat.Rb.resid)
##
if (revman5)
hetstat.resid <- substitute(paste(hl,
"Tau"^2, ht, "; ",
"Chi"^2, hq,
" (",
P, hp,
"); ",
I^2, hi),
list(hl = resid.hetlab,
hi = hetstat.I2.resid,
ht = hetstat.tau2.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid))
else if (jama)
hetstat.resid <- substitute(paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi
),
list(hl = resid.hetlab,
hi = hetstat.I2.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
df = df.Q.resid))
else {
##
## One
##
if (print.I2 & !print.tau2.tau.resid & !print.Q & !print.pval.Q &
!print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, italic(I)^2, hi),
list(hl = resid.hetlab, hi = hetstat.I2.resid))
else if (!print.I2 & print.tau2.tau.resid & !print.Q & !print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl, tau^2, ht),
list(hl = resid.hetlab, ht = hetstat.tau2.resid))
else
hetstat.resid <-
substitute(paste(hl, tau, ht),
list(hl = resid.hetlab, ht = hetstat.tau.resid))
else if (!print.I2 & !print.tau2.tau.resid & print.Q & !print.pval.Q &
!print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, chi[df]^2, hq),
list(hl = resid.hetlab, df = df.Q.resid, hq = hetstat.Q.resid))
else if (!print.I2 & !print.tau2.tau.resid & !print.Q & print.pval.Q &
!print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, italic(p), hp),
list(hl = resid.hetlab, hp = hetstat.pval.Q.resid))
else if (!print.I2 & !print.tau2.tau.resid & !print.Q & !print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, italic(R)[italic(b)], hb),
list(hl = resid.hetlab, hb = hetstat.Rb.resid))
##
## Two
##
else if (print.I2 & print.tau2.tau.resid & !print.Q & !print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl, italic(I)^2, hi,
", ",
tau^2, ht),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid))
else
hetstat.resid <-
substitute(paste(hl, italic(I)^2, hi,
", ",
tau, ht),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau.resid))
else if (print.I2 & !print.tau2.tau.resid & print.Q & !print.pval.Q &
!print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, italic(I)^2, hi,
", ",
chi[df]^2, hq),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, hq = hetstat.Q.resid))
else if (print.I2 & !print.tau2.tau.resid & !print.Q & print.pval.Q &
!print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, italic(I)^2, hi,
", ",
italic(p), hp),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, hp = hetstat.pval.Q.resid))
else if (print.I2 & !print.tau2.tau.resid & !print.Q & !print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, italic(I)^2, hi,
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, hb = hetstat.Rb.resid))
else if (!print.I2 & print.tau2.tau.resid & print.Q & !print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl, tau^2, ht,
", ",
chi[df]^2, hq),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau2.resid, hq = hetstat.Q.resid))
else
hetstat.resid <-
substitute(paste(hl, tau, ht,
", ",
chi[df]^2, hq),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau.resid, hq = hetstat.Q.resid))
else if (!print.I2 & print.tau2.tau.resid & !print.Q & print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl, tau^2, ht,
", ",
italic(p), hp),
list(hl = resid.hetlab,
ht = hetstat.tau2.resid, hp = hetstat.pval.Q.resid))
else
hetstat.resid <-
substitute(paste(hl, tau, ht,
", ",
italic(p), hp),
list(hl = resid.hetlab,
ht = hetstat.tau.resid, hp = hetstat.pval.Q.resid))
else if (!print.I2 & print.tau2.tau.resid & !print.Q & !print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl, tau^2, ht,
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
ht = hetstat.tau2.resid, hb = hetstat.Rb.resid))
else
hetstat.resid <-
substitute(paste(hl, tau, ht,
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
ht = hetstat.tau.resid, hb = hetstat.Rb.resid))
else if (!print.I2 & !print.tau2.tau.resid & print.Q & print.pval.Q &
!print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, chi[df]^2, hq,
" (",
italic(p), hp, ")"),
list(hl = resid.hetlab, df = df.Q.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid))
else if (!print.I2 & !print.tau2.tau.resid & print.Q & !print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, chi[df]^2, hq,
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
hq = hetstat.Q.resid, hb = hetstat.Rb.resid))
else if (!print.I2 & !print.tau2.tau.resid & !print.Q & print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl, italic(p), hp,
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
hp = hetstat.pval.Q.resid, hb = hetstat.Rb.resid))
##
## Three
##
else if (print.I2 & print.tau2.tau.resid & print.Q & !print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid,
hq = hetstat.Q.resid))
else
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau.resid,
hq = hetstat.Q.resid))
else if (print.I2 & print.tau2.tau.resid & !print.Q & print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(p), hp),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid,
hp = hetstat.pval.Q.resid))
else
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(p), hp),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau.resid,
hp = hetstat.pval.Q.resid))
else if (print.I2 & !print.tau2.tau.resid & print.Q & print.pval.Q &
!print.Rb.resid)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid))
else if (!print.I2 & print.tau2.tau.resid & print.Q & print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau2.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid))
else
hetstat.resid <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid))
else if (print.I2 & print.tau2.tau.resid & !print.Q & !print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid,
hb = hetstat.Rb.resid))
else
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau.resid,
hb = hetstat.Rb.resid))
else if (print.I2 & !print.tau2.tau.resid & print.Q & !print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid,
hq = hetstat.Q.resid,
hb = hetstat.Rb.resid))
else if (!print.I2 & print.tau2.tau.resid & print.Q & !print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau2.resid,
hq = hetstat.Q.resid,
hb = hetstat.Rb.resid))
else
hetstat.resid <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau.resid,
hq = hetstat.Q.resid,
hb = hetstat.Rb.resid))
else if (print.I2 & !print.tau2.tau.resid & !print.Q & print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
else if (!print.I2 & print.tau2.tau.resid & !print.Q & print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
tau^2, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
ht = hetstat.tau2.resid,
hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
else
hetstat.resid <-
substitute(paste(hl,
tau, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
ht = hetstat.tau.resid,
hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
else if (!print.I2 & !print.tau2.tau.resid & print.Q & print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl,
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
##
## Four
##
if (print.I2 & print.tau2.tau.resid & print.Q & print.pval.Q &
!print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid))
else
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid))
else if (print.I2 & print.tau2.tau.resid & print.Q & !print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid,
hq = hetstat.Q.resid, hb = hetstat.Rb.resid))
else
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau.resid,
hq = hetstat.Q.resid, hb = hetstat.Rb.resid))
else if (print.I2 & print.tau2.tau.resid & !print.Q & print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid,
hp = hetstat.pval.Q.resid, hb = hetstat.Rb.resid))
else
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab,
hi = hetstat.I2.resid, ht = hetstat.tau.resid,
hp = hetstat.pval.Q.resid, hb = hetstat.Rb.resid))
else if (print.I2 & !print.tau2.tau.resid & print.Q & !print.pval.Q &
print.Rb.resid)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau2.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
else if (!print.I2 & print.tau2.tau.resid & print.Q & print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau2.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
else
hetstat.resid <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
ht = hetstat.tau.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
##
## Five
##
else if (print.I2 & print.tau2.tau.resid & print.Q & print.pval.Q &
print.Rb.resid)
if (print.tau2)
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau2.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
else
hetstat.resid <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = resid.hetlab, df = df.Q.resid,
hi = hetstat.I2.resid, ht = hetstat.tau.resid,
hq = hetstat.Q.resid, hp = hetstat.pval.Q.resid,
hb = hetstat.Rb.resid))
}
}
##
## Label of test for overall effect
##
##
pvals.overall <- formatPT(c(x$pval.common, x$pval.random),
lab = TRUE, labval = "",
digits = digits.pval,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA")
statistics.overall <- formatN(c(x$statistic.common, x$statistic.random),
digits.stat, "NA", big.mark = big.mark)
##
## Remove superfluous spaces
##
pvals.overall <- rmSpace(pvals.overall, end = TRUE)
##
while(any(grepl(" ", pvals.overall)))
pvals.overall <- gsub(" ", " ", pvals.overall)
while(any(grepl(" ", statistics.overall)))
statistics.overall <- gsub(" ", " ", statistics.overall)
##
if (test.overall.common) {
if (print.stat) {
if (revman5)
text.overall.common <-
substitute(paste(tl,
Z, hetseparator, tt,
" (P", tp, ")"),
list(tl = label.test.overall.common,
hetseparator = hetseparator,
tt = statistics.overall[1],
tp = pvals.overall[1]))
else if (jama)
text.overall.common <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(P), tp, ")"),
list(tl = label.test.overall.common,
hetseparator = hetseparator,
tt = statistics.overall[1],
tp = pvals.overall[1]))
else
text.overall.common <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(p), tp, ")"),
list(tl = label.test.overall.common,
hetseparator = hetseparator,
tt = statistics.overall[1],
tp = pvals.overall[1]))
}
else {
if (revman5)
text.overall.common <-
substitute(paste(tl, " P", tp),
list(tl = label.test.overall.common,
tp = pvals.overall[1]))
else if (jama)
text.overall.common <-
substitute(paste(tl, " ", italic(P), tp),
list(tl = label.test.overall.common,
tp = pvals.overall[1]))
else
text.overall.common <-
substitute(paste(tl, " ", italic(p), tp),
list(tl = label.test.overall.common,
tp = pvals.overall[1]))
}
}
else
text.overall.common <- ""
##
hakn.kero <- x$method.random.ci[1] %in% c("HK", "KR")
##
if (test.overall.random) {
if (print.stat) {
if (!hakn.kero) {
if (revman5)
text.overall.random <-
substitute(paste(tl,
Z, hetseparator, tt,
" (P", tp, ")"),
list(tl = label.test.overall.random,
hetseparator = hetseparator,
tt = statistics.overall[2],
tp = pvals.overall[2]))
else if (jama)
text.overall.random <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(P), tp, ")"),
list(tl = label.test.overall.random,
hetseparator = hetseparator,
tt = statistics.overall[2],
tp = pvals.overall[2]))
else
text.overall.random <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(p), tp, ")"),
list(tl = label.test.overall.random,
hetseparator = hetseparator,
tt = statistics.overall[2],
tp = pvals.overall[2]))
}
else {
if (revman5)
text.overall.random <-
substitute(paste(tl,
t[df], hetseparator, tt,
" (P", tp, ")"),
list(tl = label.test.overall.random,
hetseparator = hetseparator,
tt = statistics.overall[2],
tp = pvals.overall[2],
df = round(x$df.random, 1)))
else if (jama)
text.overall.random <-
substitute(paste(tl,
italic(t)[df], hetseparator, tt,
" (", italic(P), tp, ")"),
list(tl = label.test.overall.random,
hetseparator = hetseparator,
tt = statistics.overall[2],
tp = pvals.overall[2],
df = round(x$df.random, 1)))
else
text.overall.random <-
substitute(paste(tl,
italic(t)[df], hetseparator, tt,
" (", italic(p), tp, ")"),
list(tl = label.test.overall.random,
hetseparator = hetseparator,
tt = statistics.overall[2],
tp = pvals.overall[2],
df = round(x$df.random, 1)))
}
}
else {
if (revman5)
text.overall.random <-
substitute(paste(tl, " P", tp),
list(tl = label.test.overall.random,
tp = pvals.overall[2]))
else if (jama)
text.overall.random <-
substitute(paste(tl, " ", italic(P), tp),
list(tl = label.test.overall.random,
tp = pvals.overall[2]))
else
text.overall.random <-
substitute(paste(tl, " ", italic(p), tp),
list(tl = label.test.overall.random,
tp = pvals.overall[2]))
}
}
else
text.overall.random <- ""
##
##
## Label of test for subgroup differences
##
if (by) {
Q.bs <- c(Q.b.common, Q.b.random)
pval.Q.bs <- c(pval.Q.b.common, pval.Q.b.random)
}
else {
Q.bs <- NA
pval.Q.bs <- NA
}
##
hetstat.Q.bs <-
paste0(hetseparator,
gsub(" ", "", formatN(Q.bs, digits.Q, "NA", big.mark = big.mark)),
if (!jama) ", df",
if (!jama) hetseparator,
if (!jama) c(df.Q.b.common,
if (length(df.Q.b.random) == 2)
paste(df.Q.b.random, collapse = ", ")
else
df.Q.b.random))
hetstat.Q.bs <- rmSpace(hetstat.Q.bs, end = TRUE)
##
hetstat.pval.Q.bs <-
paste0(formatPT(pval.Q.bs,
lab = TRUE, labval = "",
digits = digits.pval.Q,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA"))
##
## Remove superfluous spaces
##
hetstat.pval.Q.bs <- rmSpace(hetstat.pval.Q.bs, end = TRUE)
##
while(any(grepl(" ", hetstat.pval.Q.bs)))
hetstat.pval.Q.bs <- gsub(" ", " ", hetstat.pval.Q.bs)
while(any(grepl(" ", hetstat.Q.bs)))
hetstat.Q.bs <- gsub(" ", " ", hetstat.Q.bs)
##
if (test.subgroup.common) {
if (print.Q.subgroup) {
if (revman5)
text.subgroup.common <-
substitute(paste(tl,
"Chi"^2, tq,
" (P", tp, ")"),
list(tl = label.test.subgroup.common,
tq = hetstat.Q.bs[1],
tp = hetstat.pval.Q.bs[1]))
else if (jama)
text.subgroup.common <-
substitute(paste(tl,
chi[df]^2, tq,
" (", italic(P), tp, ")"),
list(tl = label.test.subgroup.common,
tq = hetstat.Q.bs[1],
tp = hetstat.pval.Q.bs[1],
df = df.Q.b.common))
else
text.subgroup.common <-
substitute(paste(tl,
chi[df]^2, tq,
" (", italic(p), tp, ")"),
list(tl = label.test.subgroup.common,
tq = hetstat.Q.bs[1],
tp = hetstat.pval.Q.bs[1],
df = df.Q.b.common))
}
else {
if (revman5)
text.subgroup.common <-
substitute(paste(tl, " P", tp),
list(tl = label.test.subgroup.common,
tp = hetstat.pval.Q.bs[1]))
else if (jama)
text.subgroup.common <-
substitute(paste(tl, " ", italic(P), tp),
list(tl = label.test.subgroup.common,
tp = hetstat.pval.Q.bs[1]))
else
text.subgroup.common <-
substitute(paste(tl, " ", italic(p), tp),
list(tl = label.test.subgroup.common,
tp = hetstat.pval.Q.bs[1]))
}
}
else
text.subgroup.common <- ""
if (test.subgroup.random) {
if (print.Q.subgroup) {
if (revman5) {
if (length(df.Q.b.random) == 2)
text.subgroup.random <-
substitute(paste(tl,
"F", tq,
" (P", tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.bs[2],
tp = hetstat.pval.Q.bs[2]))
else
text.subgroup.random <-
substitute(paste(tl,
"Chi"^2, tq,
" (P", tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.bs[2],
tp = hetstat.pval.Q.bs[2]))
}
else if (jama) {
if (length(df.Q.b.random) == 2)
text.subgroup.random <-
substitute(paste(tl,
F[df], tq,
" (", italic(P), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.bs[2],
tp = hetstat.pval.Q.bs[2],
df = paste(df.Q.b.random, collapse = ", ")))
else
text.subgroup.random <-
substitute(paste(tl,
chi[df]^2, tq,
" (", italic(P), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.bs[2],
tp = hetstat.pval.Q.bs[2],
df = df.Q.b.random))
}
else {
if (length(df.Q.b.random) == 2)
text.subgroup.random <-
substitute(paste(tl,
F[df], tq,
" (", italic(p), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.bs[2],
tp = hetstat.pval.Q.bs[2],
df = paste(df.Q.b.random, collapse = ", ")))
else
text.subgroup.random <-
substitute(paste(tl,
chi[df]^2, tq,
" (", italic(p), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.bs[2],
tp = hetstat.pval.Q.bs[2],
df = df.Q.b.random))
}
}
else {
if (revman5)
text.subgroup.random <-
substitute(paste(tl, " P", tp),
list(tl = label.test.subgroup.random,
tp = hetstat.pval.Q.bs[2]))
else if (jama)
text.subgroup.random <-
substitute(paste(tl, " ", italic(P), tp),
list(tl = label.test.subgroup.random,
tp = hetstat.pval.Q.bs[2]))
else
text.subgroup.random <-
substitute(paste(tl, " ", italic(p), tp),
list(tl = label.test.subgroup.random,
tp = hetstat.pval.Q.bs[2]))
}
}
else
text.subgroup.random <- ""
##
##
## (7) Prepare data for subgroup analysis
##
##
NAs <- rep(NA, n.com + n.ran + n.prd)
NAs.com <- rep(NA, n.com)
NAs.ran <- rep(NA, n.ran)
NAs.prd <- rep(NA, n.prd)
NAs.com1 <- rep(NA, n.com - 1)
NAs.ran1 <- rep(NA, n.ran - 1)
##
blanks <- rep("", n.com + n.ran + n.prd)
blanks.prd <- rep("", n.prd)
##
emp.com <- 1 + seq_len(n.com - 1)
emp.ran <- n.com + 1 + seq_len(n.ran - 1)
##
all.com <- seq_len(n.com)
all.ran <- n.com + seq_len(n.ran)
all.prd <- n.com + n.ran + seq_len(n.prd)
all.res <- c(all.com, all.ran, all.prd)
##
if (by) {
NAs.by <- rep(NA, n.by)
##
k.w.hetstat <- if (metabind) x$k.w.orig else x$k.w
o.w <- order(factor(x$subgroup.levels, levels = subgroup.levels))
k.w.hetstat <- k.w.hetstat[o.w]
if (hakn.kero)
df.random.w <- x$df.random.w[o.w]
##
TE.common.w <- ordermat(TE.common.w, subgroup.levels)
lower.common.w <- ordermat(lower.common.w, subgroup.levels)
upper.common.w <- ordermat(upper.common.w, subgroup.levels)
statistic.common.w <- ordermat(statistic.common.w, subgroup.levels)
pval.common.w <- ordermat(pval.common.w, subgroup.levels)
##
TE.random.w <- ordermat(TE.random.w, subgroup.levels)
lower.random.w <- ordermat(lower.random.w, subgroup.levels)
upper.random.w <- ordermat(upper.random.w, subgroup.levels)
statistic.random.w <- ordermat(statistic.random.w, subgroup.levels)
pval.random.w <- ordermat(pval.random.w, subgroup.levels)
##
lower.predict.w <- ordermat(lower.predict.w, subgroup.levels)
upper.predict.w <- ordermat(upper.predict.w, subgroup.levels)
##
Q.w <- x$Q.w[o.w]
pval.Q.w <- x$pval.Q.w[o.w]
##
I2.w <- x$I2.w[o.w]
lowI2.w <- x$lower.I2.w[o.w]
uppI2.w <- x$upper.I2.w[o.w]
##
Rb.w <- x$Rb.w[o.w]
lowRb.w <- x$lower.Rb.w[o.w]
uppRb.w <- x$upper.Rb.w[o.w]
##
tau2.w <- x$tau2.w[o.w]
tau.w <- x$tau.w[o.w]
##
w.common.w <- x$w.common.w[o.w]
w.random.w <- x$w.random.w[o.w]
e.e.w <- if (metaprop | metarate) x$event.w[o.w] else x$event.e.w[o.w]
t.e.w <- if (metainc | metarate) x$time.e.w[o.w] else NAs.by
n.e.w <-
if (metacor | metaprop | metamean | metarate)
x$n.w[o.w]
else
x$n.e.w[o.w]
e.c.w <- x$event.c.w[o.w]
t.c.w <- if (metainc) x$time.c.w[o.w] else NAs.by
n.c.w <- x$n.c.w[o.w]
n.harmonic.mean.w <- x$n.harmonic.mean.w[o.w]
t.harmonic.mean.w <- x$t.harmonic.mean.w[o.w]
##
k.all.w <- x$k.all.w[o.w]
k.study.w <- x$k.study.w[o.w]
k.w <- x$k.w[o.w]
k.TE.w <- x$k.TE.w[o.w]
##
subgroup.logical <- subgroup.logical[o.w]
subgroup.hetstat.logical <- subgroup.hetstat.logical[o.w]
##
prediction.subgroup.logical <-
prediction.subgroup.logical[o.w]
##
## Do (not) drop subgroups without studies in subgroup
## meta-analysis
##
if (allstudies)
sel.w <- rep(TRUE, length(k.all.w))
else
sel.w <- k.w > 0
##
if (hakn.kero)
df.random.w <- df.random.w[sel.w]
##
TE.common.w <- TE.common.w[repl(sel.w, n.com, n.by)]
lower.common.w <- lower.common.w[repl(sel.w, n.com, n.by)]
upper.common.w <- upper.common.w[repl(sel.w, n.com, n.by)]
statistic.common.w <- statistic.common.w[repl(sel.w, n.com, n.by)]
pval.common.w <- pval.common.w[repl(sel.w, n.com, n.by)]
##
TE.random.w <- TE.random.w[repl(sel.w, n.ran, n.by)]
lower.random.w <- lower.random.w[repl(sel.w, n.ran, n.by)]
upper.random.w <- upper.random.w[repl(sel.w, n.ran, n.by)]
statistic.random.w <- statistic.random.w[repl(sel.w, n.ran, n.by)]
pval.random.w <- pval.random.w[repl(sel.w, n.ran, n.by)]
##
lower.predict.w <- lower.predict.w[repl(sel.w, n.prd, n.by)]
upper.predict.w <- upper.predict.w[repl(sel.w, n.prd, n.by)]
##
Q.w <- Q.w[sel.w]
pval.Q.w <- pval.Q.w[sel.w]
##
I2.w <- I2.w[sel.w]
lowI2.w <- lowI2.w[sel.w]
uppI2.w <- uppI2.w[sel.w]
##
Rb.w <- Rb.w[sel.w]
lowRb.w <- lowRb.w[sel.w]
uppRb.w <- uppRb.w[sel.w]
##
tau2.w <- tau2.w[sel.w]
tau.w <- tau.w[sel.w]
##
w.common.w <- w.common.w[sel.w]
w.random.w <- w.random.w[sel.w]
e.e.w <- e.e.w[sel.w]
t.e.w <- t.e.w[sel.w]
n.e.w <- n.e.w[sel.w]
e.c.w <- e.c.w[sel.w]
t.c.w <- t.c.w[sel.w]
n.c.w <- n.c.w[sel.w]
n.harmonic.mean.w <- n.harmonic.mean.w[sel.w]
t.harmonic.mean.w <- t.harmonic.mean.w[sel.w]
##
k.all.w <- k.all.w[sel.w]
k.study.w <- k.study.w[sel.w]
k.w <- k.w[sel.w]
k.TE.w <- k.TE.w[sel.w]
##
subgroup.logical <- subgroup.logical[sel.w]
subgroup.hetstat.logical <- subgroup.hetstat.logical[sel.w]
##
prediction.subgroup.logical <-
prediction.subgroup.logical[sel.w]
##
subgroup.levels <- subgroup.levels[sel.w]
##
n.by <- length(subgroup.levels)
n.com.w <- n.com * n.by
n.ran.w <- n.ran * n.by
n.prd.w <- n.prd * n.by
##
NAs.by <- rep(NA, n.by)
NAs.com.w <- rep(NA, n.com.w)
NAs.ran.w <- rep(NA, n.ran.w)
NAs.prd.w <- rep(NA, n.prd.w)
NAs.stat.w <- rep(NA, 3 * n.by)
NAs.w <- rep(NA, n.com.w + n.ran.w + n.prd.w)
##
NAs.all <- c(NAs, NAs.w, NAs.stat.w)
##
blanks.com.w <- rep("", n.com.w)
blanks.ran.w <- rep("", n.ran.w)
blanks.prd.w <- rep("", n.prd.w)
blanks.stat.w <- rep("", 3 * n.by)
##
blanks.w <- rep("", n.com.w + n.ran.w + n.prd.w + 3 * n.by)
##
idx.com.w <- 1 + (seq_len(n.by) * n.com) - n.com
idx.ran.w <- 1 + (seq_len(n.by) * n.ran) - n.ran
idx.prd.w <- 1 + (seq_len(n.by) * n.prd) - n.prd
##
notfirst.com.w <- seq_len(n.com.w)[!(seq_len(n.com.w) %in% idx.com.w)]
notfirst.ran.w <- seq_len(n.ran.w)[!(seq_len(n.ran.w) %in% idx.ran.w)]
notfirst.prd.w <- seq_len(n.prd.w)[!(seq_len(n.prd.w) %in% idx.prd.w)]
##
## Do not consider limits of prediction intervals in subgroups to
## format confidence limits
##
sel.NA <- !repl(prediction.subgroup.logical, n.prd, n.by)
lower.predict.w[sel.NA] <- NA
upper.predict.w[sel.NA] <- NA
##
first.com.w <- n.com + n.ran + n.prd + idx.com.w
first.ran.w <- n.com + n.ran + n.prd + n.com.w + idx.ran.w
first.prd.w <- n.com + n.ran + n.prd + n.com.w + n.ran.w + idx.prd.w
##
all.com.w <-
c(seq_len(n.com),
n.com + n.ran + n.prd + seq_len(n.com.w))
all.ran.w <-
c(n.com + seq_len(n.ran),
n.com + n.ran + n.prd + n.com.w + seq_len(n.ran.w))
all.prd.w <-
c(all.prd, first.prd.w,
n.com + n.ran + n.prd + n.com.w + n.ran.w + seq_len(n.prd.w))
##
all.het.w <- n.com + n.ran + n.prd + n.com.w + n.ran.w + n.prd.w +
seq_len(n.by)
all.efc.w <- n.com + n.ran + n.prd + n.com.w + n.ran.w + n.prd.w +
n.by + seq_len(n.by)
all.efr.w <- n.com + n.ran + n.prd + n.com.w + n.ran.w + n.prd.w +
2 * n.by + seq_len(n.by)
##
all.stat.w <- c(all.het.w, all.efc.w, all.efr.w)
##
emp.w <- c(all.prd.w, all.stat.w)
emp.com.w <- c(1 + seq_len(n.com - 1),
n.com + n.ran + n.prd + notfirst.com.w)
emp.ran.w <- c(n.com + 1 + seq_len(n.ran - 1),
n.com + n.ran + n.prd + n.com.w + notfirst.ran.w)
emp.prd.w <- c(all.prd,
first.prd.w,
n.com + n.ran + n.prd + n.com.w + n.ran.w + notfirst.prd.w)
##
emp.w <- c(emp.com.w, emp.ran.w, emp.prd.w,
all.het.w, all.efc.w, all.efr.w)
##
sel.w <- c(first.com.w, first.ran.w, first.prd.w, all.stat.w)
##
if (!metainf.metacum & common) {
if (!overall) {
i <- 0
for (bylev.i in subgroup.levels) {
i <- i + 1
sel.i <- subgroup == bylev.i
x$w.common[sel.i] <- x$w.common[sel.i] / w.common.w[i]
}
w.common.w.p <- ifelse(is.na(w.common.w), NA, 100)
}
else {
if (!all(is.na(w.common.w)) && sum(w.common.w) > 0)
w.common.w.p <-
round(100 * w.common.w / sum(w.common.w, na.rm = TRUE),
digits.weight)
else
w.common.w.p <- w.common.w
}
}
else {
TE.common.w <- lower.common.w <- upper.common.w <- NAs.by
##
w.common.w.p <- NAs.by
##
missing.text.common.w <- missing(text.common.w)
missing.text.common.w <- is.na(argid(names(args), "text.common.w"))
if (!missing.text.common.w) {
text.common.w <-
deprecated(text.common.w, missing.text.common.w, args,
"text.common.w",
warn.deprecated)
missing.text.common.w <- FALSE
}
if (missing(text.common.w))
text.common.w <- rep("Overall", n.com.w)
}
##
if (!metainf.metacum & random) {
if (!overall) {
i <- 0
for (bylev.i in subgroup.levels) {
i <- i + 1
sel.i <- subgroup == bylev.i
x$w.random[sel.i] <- x$w.random[sel.i] / w.random.w[i]
}
w.random.w.p <- ifelse(is.na(w.random.w), NA, 100)
}
else {
if (!all(is.na(w.random.w)) && sum(w.random.w) > 0)
w.random.w.p <-
round(100 * w.random.w / sum(w.random.w, na.rm = TRUE),
digits.weight)
else
w.random.w.p <- w.random.w
}
}
else {
TE.random.w <- lower.random.w <- upper.random.w <- NAs.by
##
w.random.w.p <- NAs.ran.w
text.random.w <- blanks.ran.w
}
##
hetstat.w <- vector("list", n.by)
##
if (is.character(hetstat) || hetstat) {
##
hetstat.I2.w <-
paste0(hetseparator,
round(100 * I2.w, digits.I2), "%",
if (print.I2.ci)
ifelse(!(is.na(lowI2.w) | is.na(uppI2.w)),
pasteCI(100 * lowI2.w, 100 * uppI2.w,
digits.I2, big.mark,
text.NA = lab.NA, unit = "%"),
""))
##
hetstat.tau2.w <-
paste0(hetseparator,
ifelse(is.na(tau.w), "NA",
ifelse(tau2.w == 0, "0",
formatPT(tau2.w, digits = digits.tau2,
big.mark = big.mark, lab.NA = "NA"))))
##
hetstat.tau.w <-
paste0(hetseparator,
ifelse(is.na(tau.w), "NA",
ifelse(tau.w == 0, "0",
formatPT(tau.w, digits = digits.tau,
big.mark = big.mark, lab.NA = "NA"))))
##
hetstat.Q.w <-
paste0(hetseparator, round(Q.w, digits.Q),
if (revman5)
paste0(", df", hetseparator, k.w.hetstat - 1))
##
hetstat.pval.Q.w <-
paste0(formatPT(replaceNULL(pval.Q.w, pvalQ(Q.w, k.w - 1)),
lab = TRUE, labval = "",
digits = digits.pval.Q,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA"))
##
hetstat.Rb.w <-
paste0(hetseparator,
round(100 * Rb.w, digits.I2), "%",
if (print.Rb.ci)
ifelse(!(is.na(lowRb.w) | is.na(uppRb.w)),
pasteCI(100 * lowRb.w, 100 * uppRb.w,
digits.I2, big.mark,
text.NA = lab.NA, unit = "%"),
""))
##
## Remove superfluous spaces
##
hetstat.pval.Q.w <- rmSpace(hetstat.pval.Q.w, end = TRUE)
##
while(any(grepl(" ", hetstat.I2.w)))
hetstat.I2.w <- gsub(" ", " ", hetstat.I2.w)
while(any(grepl(" ", hetstat.tau2.w)))
hetstat.tau2.w <- gsub(" ", " ", hetstat.tau2.w)
while(any(grepl(" ", hetstat.tau.w)))
hetstat.tau.w <- gsub(" ", " ", hetstat.tau.w)
while(any(grepl(" ", hetstat.Q.w)))
hetstat.Q.w <- gsub(" ", " ", hetstat.Q.w)
while(any(grepl(" ", hetstat.pval.Q.w)))
hetstat.pval.Q.w <- gsub(" ", " ", hetstat.pval.Q.w)
while(any(grepl(" ", hetstat.Rb.w)))
hetstat.Rb.w <- gsub(" ", " ", hetstat.Rb.w)
##
for (i in seq_len(n.by)) {
if (revman5)
hetstat.w[[i]] <- substitute(paste(hl,
"Tau"^2, ht, "; ",
"Chi"^2, hq,
" (",
P, hp,
"); ",
I^2, hi),
list(hl = hetlab,
hi = hetstat.I2.w[i],
ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i]))
else if (jama)
hetstat.w[[i]] <- substitute(paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi
),
list(hl = hetlab,
hi = hetstat.I2.w[i],
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
df = k.w.hetstat[i] - 1))
else {
##
## One
##
if (print.I2 & !print.tau2.tau & !print.Q & !print.pval.Q & !print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, italic(I)^2, hi),
list(hl = hetlab, hi = hetstat.I2.w[i]))
else if (!print.I2 & print.tau2.tau & !print.Q & !print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl, tau^2, ht),
list(hl = hetlab, ht = hetstat.tau2.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl, tau, ht),
list(hl = hetlab, ht = hetstat.tau.w[i]))
else if (!print.I2 & !print.tau2.tau & print.Q & !print.pval.Q &
!print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, chi[df]^2, hq),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i]))
else if (!print.I2 & !print.tau2.tau & !print.Q & print.pval.Q &
!print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, italic(p), hp),
list(hl = hetlab, hp = hetstat.pval.Q.w[i]))
else if (!print.I2 & !print.tau2.tau & !print.Q & !print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, italic(R)[italic(b)], hb),
list(hl = hetlab, hb = hetstat.Rb.w[i]))
##
## Two
##
else if (print.I2 & print.tau2.tau & !print.Q & !print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl, italic(I)^2, hi,
", ",
tau^2, ht),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl, italic(I)^2, hi,
", ",
tau, ht),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i]))
else if (print.I2 & !print.tau2.tau & print.Q & !print.pval.Q &
!print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, italic(I)^2, hi,
", ",
chi[df]^2, hq),
list(hl = hetlab,
hi = hetstat.I2.w[i], hq = hetstat.Q.w[i]))
else if (print.I2 & !print.tau2.tau & !print.Q & print.pval.Q &
!print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, italic(I)^2, hi,
", ",
italic(p), hp),
list(hl = hetlab,
hi = hetstat.I2.w[i], hp = hetstat.pval.Q.w[i]))
else if (print.I2 & !print.tau2.tau & !print.Q & !print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, italic(I)^2, hi,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2.w[i], hb = hetstat.Rb.w[i]))
else if (!print.I2 & print.tau2.tau & print.Q & !print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl, tau^2, ht,
", ",
chi[df]^2, hq),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau2.w[i], hq = hetstat.Q.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl, tau, ht,
", ",
chi[df]^2, hq),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau.w[i], hq = hetstat.Q.w[i]))
else if (!print.I2 & print.tau2.tau & !print.Q & print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl, tau^2, ht,
", ",
italic(p), hp),
list(hl = hetlab,
ht = hetstat.tau2.w[i],
hp = hetstat.pval.Q.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl, tau, ht,
", ",
italic(p), hp),
list(hl = hetlab,
ht = hetstat.tau.w[i],
hp = hetstat.pval.Q.w[i]))
else if (!print.I2 & print.tau2.tau & !print.Q & !print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl, tau^2, ht,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau2.w[i], hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl, tau, ht,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau.w[i], hb = hetstat.Rb.w[i]))
else if (!print.I2 & !print.tau2.tau & print.Q & print.pval.Q &
!print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, chi[df]^2, hq,
" (",
italic(p), hp, ")"),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i]))
else if (!print.I2 & !print.tau2.tau & print.Q & !print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, chi[df]^2, hq,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i], hb = hetstat.Rb.w[i]))
else if (!print.I2 & !print.tau2.tau & !print.Q & print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl, italic(p), hp,
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hp = hetstat.pval.Q.w[i], hb = hetstat.Rb.w[i]))
##
## Three
##
else if (print.I2 & print.tau2.tau & print.Q & !print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i]))
else if (print.I2 & print.tau2.tau & !print.Q & print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(p), hp),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i],
hp = hetstat.pval.Q.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(p), hp),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i],
hp = hetstat.pval.Q.w[i]))
else if (print.I2 & !print.tau2.tau & print.Q & print.pval.Q &
!print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i]))
else if (!print.I2 & print.tau2.tau & print.Q & print.pval.Q &
!print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i]))
else if (print.I2 & print.tau2.tau & !print.Q & !print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i],
hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i],
hb = hetstat.Rb.w[i]))
else if (print.I2 & !print.tau2.tau & print.Q & !print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i],
hq = hetstat.Q.w[i],
hb = hetstat.Rb.w[i]))
else if (!print.I2 & print.tau2.tau & print.Q & !print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i],
hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i],
hb = hetstat.Rb.w[i]))
else if (print.I2 & !print.tau2.tau & !print.Q & print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2.w[i], hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
else if (!print.I2 & print.tau2.tau & !print.Q & print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
tau^2, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau2.w[i],
hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
tau, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
ht = hetstat.tau.w[i],
hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
else if (!print.I2 & !print.tau2.tau & print.Q & print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl,
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
##
## Four
##
if (print.I2 & print.tau2.tau & print.Q & print.pval.Q & !print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")"),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i]))
else if (print.I2 & print.tau2.tau & print.Q & !print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i], hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i], hb = hetstat.Rb.w[i]))
else if (print.I2 & print.tau2.tau & !print.Q & print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i],
hp = hetstat.pval.Q.w[i], hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
italic(p), hp, ", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i],
hp = hetstat.pval.Q.w[i], hb = hetstat.Rb.w[i]))
else if (print.I2 & !print.tau2.tau & print.Q & print.pval.Q &
print.Rb)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab,
hi = hetstat.I2.w[i], df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
else if (!print.I2 & print.tau2.tau & print.Q & print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
##
## Five
##
else if (print.I2 & print.tau2.tau & print.Q & print.pval.Q &
print.Rb)
if (print.tau2)
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau^2, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
else
hetstat.w[[i]] <-
substitute(paste(hl,
italic(I)^2, hi, ", ",
tau, ht, ", ",
chi[df]^2, hq,
" (", italic(p), hp, ")",
", ",
italic(R)[italic(b)], hb),
list(hl = hetlab, df = k.w.hetstat[i] - 1,
hi = hetstat.I2.w[i], ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i], hp = hetstat.pval.Q.w[i],
hb = hetstat.Rb.w[i]))
}
if (hetstat.pooled != "study" &
!is.logical(text.subgroup.nohet) & k.w.hetstat[i] < 2)
hetstat.w[[i]] <- paste0(hetlab, text.subgroup.nohet)
}
}
##
TE.w <- c(TE.common.w, TE.random.w, NAs.prd.w, NAs.stat.w)
lowTE.w <-
c(lower.common.w, lower.random.w, lower.predict.w, NAs.stat.w)
uppTE.w <-
c(upper.common.w, upper.random.w, upper.predict.w, NAs.stat.w)
##
n.harmonic.mean.w <-
c(rep(n.harmonic.mean.w, n.com + n.ran + n.prd), NAs.stat.w)
t.harmonic.mean.w <-
c(rep(t.harmonic.mean.w, n.com + n.ran + n.prd), NAs.stat.w)
##
## Label of test for effect in subgroups
##
pvals.effect.w <-
formatPT(c(pval.common.w, pval.random.w),
lab = TRUE, labval = "",
digits = digits.pval,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA")
statistics.effect.w <-
formatN(c(statistic.common.w, statistic.random.w),
digits.stat, "NA", big.mark = big.mark)
##
## Remove superfluous spaces
##
pvals.effect.w <- rmSpace(pvals.effect.w, end = TRUE)
##
while(any(grepl(" ", pvals.effect.w)))
pvals.effect.w <- gsub(" ", " ", pvals.effect.w)
while(any(grepl(" ", statistics.effect.w)))
statistics.effect.w <- gsub(" ", " ", statistics.effect.w)
##
if (any(test.effect.subgroup.common.logical)) {
text.effect.subgroup.common <- vector("list", n.by)
for (i in seq_len(n.by)) {
if (print.stat) {
if (revman5)
text.effect.subgroup.common[[i]] <-
substitute(paste(tl,
Z, hetseparator, tt,
" (P", tp, ")"),
list(tl = label.test.effect.subgroup.common,
hetseparator = hetseparator,
tt = statistics.effect.w[i],
tp = rmSpace(pvals.effect.w[i], end = TRUE)))
else if (jama)
text.effect.subgroup.common[[i]] <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(P), tp, ")"),
list(tl = label.test.effect.subgroup.common,
hetseparator = hetseparator,
tt = statistics.effect.w[i],
tp = rmSpace(pvals.effect.w[i], end = TRUE)))
else
text.effect.subgroup.common[[i]] <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(p), tp, ")"),
list(tl = label.test.effect.subgroup.common,
hetseparator = hetseparator,
tt = statistics.effect.w[i],
tp = rmSpace(pvals.effect.w[i], end = TRUE)))
}
else {
if (revman5)
text.effect.subgroup.common[[i]] <-
substitute(paste(tl,
" P", tp),
list(tl = label.test.effect.subgroup.common,
tp = rmSpace(pvals.effect.w[i], end = TRUE)))
else if (jama)
text.effect.subgroup.common[[i]] <-
substitute(paste(tl,
" ", italic(P), tp),
list(tl = label.test.effect.subgroup.common,
tp = rmSpace(pvals.effect.w[i], end = TRUE)))
else
text.effect.subgroup.common[[i]] <-
substitute(paste(tl,
" ", italic(p), tp),
list(tl = label.test.effect.subgroup.common,
tp = rmSpace(pvals.effect.w[i], end = TRUE)))
}
}
}
else {
text.effect.subgroup.common <- vector("list", n.by)
for (i in seq_len(n.by))
text.effect.subgroup.common[[i]] <- ""
}
##
if (any(test.effect.subgroup.random.logical)) {
text.effect.subgroup.random <- vector("list", n.by)
for (i in seq_len(n.by)) {
if (print.stat) {
if (!hakn.kero) {
if (revman5)
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
Z, hetseparator, tt,
" (P", tp, ")"),
list(tl = label.test.effect.subgroup.random,
hetseparator = hetseparator,
tt = statistics.effect.w[n.by + i],
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE)))
else if (jama)
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(P), tp, ")"),
list(tl = label.test.effect.subgroup.random,
hetseparator = hetseparator,
tt = statistics.effect.w[n.by + i],
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE)))
else
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
italic(z), hetseparator, tt,
" (", italic(p), tp, ")"),
list(tl = label.test.effect.subgroup.random,
hetseparator = hetseparator,
tt = statistics.effect.w[n.by + i],
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE)))
}
else {
if (revman5)
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
t[df], hetseparator, tt,
" (P", tp, ")"),
list(tl = label.test.effect.subgroup.random,
hetseparator = hetseparator,
tt = statistics.effect.w[n.by + i],
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE),
df = df.random.w[i]))
else if (jama)
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
italic(t)[df], hetseparator, tt,
" (", italic(P), tp, ")"),
list(tl = label.test.effect.subgroup.random,
hetseparator = hetseparator,
tt = statistics.effect.w[n.by + i],
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE),
df = df.random.w[i]))
else
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
italic(t)[df], hetseparator, tt,
" (", italic(p), tp, ")"),
list(tl = label.test.effect.subgroup.random,
hetseparator = hetseparator,
tt = statistics.effect.w[n.by + i],
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE),
df = df.random.w[i]))
}
}
else {
if (revman5)
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
" P", tp),
list(tl = label.test.effect.subgroup.random,
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE)))
else if (jama)
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
" ", italic(P)),
list(tl = label.test.effect.subgroup.random,
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE)))
else
text.effect.subgroup.random[[i]] <-
substitute(paste(tl,
" ", italic(p), tp),
list(tl = label.test.effect.subgroup.random,
tp = rmSpace(pvals.effect.w[n.by + i],
end = TRUE)))
}
}
}
else {
text.effect.subgroup.random <- vector("list", n.by)
for (i in seq_len(n.by))
text.effect.subgroup.random[[i]] <- ""
}
}
##
##
## (8) Backtransform data
##
##
TE.orig <- TE
##
if (backtransf) {
##
## Freeman-Tukey Arcsin transformation
##
if (metainf.metacum | metabind) {
if (sm == "IRFT") {
npft <- x$t.harmonic.mean
npft.ma <- x$t.harmonic.mean.ma
}
else {
npft <- x$n.harmonic.mean
npft.ma <- x$n.harmonic.mean.ma
}
}
else {
if (sm == "IRFT") {
npft <- x$time
npft.ma <- 1 / mean(1 / x$time)
}
else {
npft <- x$n
npft.ma <- 1 / mean(1 / x$n)
}
}
##
## Individual study results
##
if (metaprop) {
TE <- x$event.e / x$n.e
}
else if (metarate) {
TE <- x$event.e / x$time.e
}
##
else if (!log.xaxis) {
TE <- backtransf(TE, sm, "mean", npft, fbt, abt)
lowTE <- backtransf(lowTE, sm, "lower", npft, fbt, abt)
uppTE <- backtransf(uppTE, sm, "upper", npft, fbt, abt)
}
##
## Results of meta-analysis
##
if (!log.xaxis) {
TE.common <- backtransf(TE.common, sm, "mean", npft.ma, fbt, abt)
lowTE.common <- backtransf(lowTE.common, sm, "lower", npft.ma, fbt, abt)
uppTE.common <- backtransf(uppTE.common, sm, "upper", npft.ma, fbt, abt)
##
TE.random <- backtransf(TE.random, sm, "mean", npft.ma, fbt, abt)
lowTE.random <- backtransf(lowTE.random, sm, "lower", npft.ma, fbt, abt)
uppTE.random <- backtransf(uppTE.random, sm, "upper", npft.ma, fbt, abt)
##
if (!metainf.metacum) {
lowTE.predict <-
backtransf(lowTE.predict, sm, "lower", npft.ma, fbt, abt)
uppTE.predict <-
backtransf(uppTE.predict, sm, "upper", npft.ma, fbt, abt)
}
##
if (by) {
if (sm == "IRFT")
npft.w <- t.harmonic.mean.w
else
npft.w <- n.harmonic.mean.w
##
TE.w <- backtransf(TE.w, sm, "mean", npft.w, fbt, abt)
lowTE.w <- backtransf(lowTE.w, sm, "lower", npft.w, fbt, abt)
uppTE.w <- backtransf(uppTE.w, sm, "upper", npft.w, fbt, abt)
}
}
##
## Apply argument 'pscale' to proportions / risk differences
##
if (is_prop(sm) | sm == "RD") {
TE <- pscale * TE
lowTE <- pscale * lowTE
uppTE <- pscale * uppTE
##
TE.common <- pscale * TE.common
lowTE.common <- pscale * lowTE.common
uppTE.common <- pscale * uppTE.common
##
TE.random <- pscale * TE.random
lowTE.random <- pscale * lowTE.random
uppTE.random <- pscale * uppTE.random
##
lowTE.predict <- pscale * lowTE.predict
uppTE.predict <- pscale * uppTE.predict
##
if (by) {
TE.w <- pscale * TE.w
lowTE.w <- pscale * lowTE.w
uppTE.w <- pscale * uppTE.w
}
}
}
##
## Apply argument 'irscale' to rates / incidence rate differences
##
if (is_rate(sm) | sm == "IRD") {
TE <- irscale * TE
lowTE <- irscale * lowTE
uppTE <- irscale * uppTE
##
TE.common <- irscale * TE.common
lowTE.common <- irscale * lowTE.common
uppTE.common <- irscale * uppTE.common
##
TE.random <- irscale * TE.random
lowTE.random <- irscale * lowTE.random
uppTE.random <- irscale * uppTE.random
##
lowTE.predict <- irscale * lowTE.predict
uppTE.predict <- irscale * uppTE.predict
##
if (by) {
TE.w <- irscale * TE.w
lowTE.w <- irscale * lowTE.w
uppTE.w <- irscale * uppTE.w
}
}
##
## Switch lower and upper limit for VE if results have been
## backtransformed
##
if (backtransf & sm == "VE") {
tmp.l <- lowTE
lowTE <- uppTE
uppTE <- tmp.l
##
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.w
lowTE.w <- uppTE.w
uppTE.w <- tmp.l
}
}
##
## Exclude study results from forest plot
##
TE.exclude <- TE
lowTE.exclude <- lowTE
uppTE.exclude <- uppTE
##
if (!null.exclude) {
TE.exclude[exclude] <- NA
lowTE.exclude[exclude] <- NA
uppTE.exclude[exclude] <- NA
}
##
if (!common) {
TE.common <- NAs.com
lowTE.common <- NAs.com
uppTE.common <- NAs.com
##
if (by) {
TE.common.w <- NAs.com.w
lowTE.common.w <- NAs.com.w
uppTE.common.w <- NAs.com.w
}
}
##
method.random.ci <- x$method.random.ci
##
if (!random) {
TE.random <- NAs.ran
lowTE.random <- NAs.ran
uppTE.random <- NAs.ran
##
if (by) {
TE.random.w <- NAs.ran.w
lowTE.random.w <- NAs.ran.w
uppTE.random.w <- NAs.ran.w
}
}
##
if (!prediction) {
lowTE.predict <- NAs.prd
uppTE.predict <- NAs.prd
}
##
if (!metainf.metacum) {
if (by & !overall)
w.common.p <- round(100 * x$w.common, digits.weight)
else {
if (!all(is.na(x$w.common)) && sum(x$w.common) > 0) {
if (is.matrix(x$w.common))
w.common.p <-
round(apply(x$w.common, 2, calcPercent), digits.weight)
else
w.common.p <-
round(calcPercent(x$w.common), digits.weight)
}
else
w.common.p <- x$w.common
}
##
if (by & !overall)
w.random.p <- round(100 * x$w.random, digits.weight)
else {
if (!all(is.na(x$w.random)) && sum(x$w.random) > 0) {
if (is.matrix(x$w.random))
w.random.p <-
round(apply(x$w.random, 2, calcPercent), digits.weight)
else
w.random.p <-
round(calcPercent(x$w.random), digits.weight)
}
else
w.random.p <- x$w.random
}
}
else {
w.common.p <- rep(NA, length(TE))
w.random.p <- rep(NA, length(TE))
}
##
if (is.matrix(w.common.p))
w.common.p <- as.vector(w.common.p[, 1])
if (is.matrix(w.random.p))
w.random.p <- as.vector(w.random.p[, 1])
##
##
## (9) Determine column labels
##
##
labs <- list()
##
if (lsel) {
if (missing(leftlabs) || length(leftcols) != length(leftlabs)) {
for (i in seq_along(leftcols)) {
j <- match(leftcols[i], colnames)
if (!is.na(j))
labs[[paste0("lab.", leftcols[i])]] <- labnames[j]
}
}
else if (length(leftcols) == length(leftlabs)) {
for (i in seq_along(leftcols)) {
j <- match(leftcols[i], colnames)
if (!is.na(leftlabs[i]))
labs[[paste0("lab.", leftcols[i])]] <- leftlabs[i]
else
if (!is.na(j))
labs[[paste0("lab.", leftcols[i])]] <- labnames[j]
}
}
}
##
if (missing(rightlabs) || length(rightcols) != length(rightlabs)) {
for (i in seq_along(rightcols)) {
j <- match(rightcols[i], colnames)
if (!is.na(j))
labs[[paste0("lab.", rightcols[i])]] <- labnames[j]
}
}
else if (length(rightcols) == length(rightlabs)) {
for (i in seq_along(rightcols)) {
j <- match(rightcols[i], colnames)
if (!is.na(rightlabs[i]))
labs[[paste0("lab.", rightcols[i])]] <- rightlabs[i]
else
if (!is.na(j))
labs[[paste0("lab.", rightcols[i])]] <- labnames[j]
}
}
##
if (!slab)
labs[["lab.studlab"]] <- ""
##
## Check for "%" in weight labels
##
w.common.percent <- TRUE
if (!is.null(labs[["lab.w.common"]])) {
if (grepl("%", labs[["lab.w.common"]]))
w.common.percent <- FALSE
}
##
w.random.percent <- TRUE
if (!is.null(labs[["lab.w.random"]])) {
if (grepl("%", labs[["lab.w.random"]]))
w.random.percent <- FALSE
}
## "studlab", "TE", "seTE",
## "cluster",
## "n.e", "n.c",
## "event.e", "event.c",
## "mean.e", "mean.c",
## "sd.e", "sd.c",
## "cor",
## "time.e", "time.c",
## "pval", "tau2", "tau", "I2" (for metainf.metacum)
##
## Check for "\n" in label of column 'studlab'
##
clines <- twolines(labs[["lab.studlab"]], "studlab")
##
if (clines$newline) {
newline.studlab <- TRUE
labs[["lab.studlab"]] <- clines$bottom
add.studlab <- clines$top
longer.studlab <- clines$longer
}
else {
newline.studlab <- FALSE
longer.studlab <- labs[["lab.studlab"]]
}
##
## Check for "\n" in label of column 'TE'
##
clines <- twolines(labs[["lab.TE"]], "TE")
##
if (clines$newline) {
newline.TE <- TRUE
labs[["lab.TE"]] <- clines$bottom
add.TE <- clines$top
longer.TE <- clines$longer
}
else {
newline.TE <- FALSE
longer.TE <- labs[["lab.TE"]]
}
##
## Check for "\n" in label of column 'seTE'
##
clines <- twolines(labs[["lab.seTE"]], "seTE")
##
if (clines$newline) {
newline.seTE <- TRUE
labs[["lab.seTE"]] <- clines$bottom
add.seTE <- clines$top
longer.seTE <- clines$longer
}
else {
newline.seTE <- FALSE
longer.seTE <- labs[["lab.seTE"]]
}
##
## Check for "\n" in label of column 'cluster'
##
clines <- twolines(labs[["lab.cluster"]], "cluster")
##
if (clines$newline) {
newline.cluster <- TRUE
labs[["lab.cluster"]] <- clines$bottom
add.cluster <- clines$top
longer.cluster <- clines$longer
}
else {
newline.cluster <- FALSE
longer.cluster <- labs[["lab.cluster"]]
}
##
## Check for "\n" in label of column 'n.e'
##
clines <- twolines(labs[["lab.n.e"]], "n.e")
##
if (clines$newline) {
newline.n.e <- TRUE
labs[["lab.n.e"]] <- clines$bottom
add.n.e <- clines$top
longer.n.e <- clines$longer
}
else {
newline.n.e <- FALSE
longer.n.e <- labs[["lab.n.e"]]
}
##
## Check for "\n" in label of column 'n.c'
##
clines <- twolines(labs[["lab.n.c"]], "n.c")
##
if (clines$newline) {
newline.n.c <- TRUE
labs[["lab.n.c"]] <- clines$bottom
add.n.c <- clines$top
longer.n.c <- clines$longer
}
else {
newline.n.c <- FALSE
longer.n.c <- labs[["lab.n.c"]]
}
##
## Check for "\n" in label of column 'event.e'
##
clines <- twolines(labs[["lab.event.e"]], "event.e")
##
if (clines$newline) {
newline.event.e <- TRUE
labs[["lab.event.e"]] <- clines$bottom
add.event.e <- clines$top
longer.event.e <- clines$longer
}
else {
newline.event.e <- FALSE
longer.event.e <- labs[["lab.event.e"]]
}
##
## Check for "\n" in label of column 'event.c'
##
clines <- twolines(labs[["lab.event.c"]], "event.c")
##
if (clines$newline) {
newline.event.c <- TRUE
labs[["lab.event.c"]] <- clines$bottom
add.event.c <- clines$top
longer.event.c <- clines$longer
}
else {
newline.event.c <- FALSE
longer.event.c <- labs[["lab.event.c"]]
}
##
## Check for "\n" in label of column 'mean.e'
##
clines <- twolines(labs[["lab.mean.e"]], "mean.e")
##
if (clines$newline) {
newline.mean.e <- TRUE
labs[["lab.mean.e"]] <- clines$bottom
add.mean.e <- clines$top
longer.mean.e <- clines$longer
}
else {
newline.mean.e <- FALSE
longer.mean.e <- labs[["lab.mean.e"]]
}
##
## Check for "\n" in label of column 'mean.c'
##
clines <- twolines(labs[["lab.mean.c"]], "mean.c")
##
if (clines$newline) {
newline.mean.c <- TRUE
labs[["lab.mean.c"]] <- clines$bottom
add.mean.c <- clines$top
longer.mean.c <- clines$longer
}
else {
newline.mean.c <- FALSE
longer.mean.c <- labs[["lab.mean.c"]]
}
##
## Check for "\n" in label of column 'sd.e'
##
clines <- twolines(labs[["lab.sd.e"]], "sd.e")
##
if (clines$newline) {
newline.sd.e <- TRUE
labs[["lab.sd.e"]] <- clines$bottom
add.sd.e <- clines$top
longer.sd.e <- clines$longer
}
else {
newline.sd.e <- FALSE
longer.sd.e <- labs[["lab.sd.e"]]
}
##
## Check for "\n" in label of column 'sd.c'
##
clines <- twolines(labs[["lab.sd.c"]], "sd.c")
##
if (clines$newline) {
newline.sd.c <- TRUE
labs[["lab.sd.c"]] <- clines$bottom
add.sd.c <- clines$top
longer.sd.c <- clines$longer
}
else {
newline.sd.c <- FALSE
longer.sd.c <- labs[["lab.sd.c"]]
}
##
## Check for "\n" in label of column 'cor'
##
clines <- twolines(labs[["lab.cor"]], "cor")
##
if (clines$newline) {
newline.cor <- TRUE
labs[["lab.cor"]] <- clines$bottom
add.cor <- clines$top
longer.cor <- clines$longer
}
else {
newline.cor <- FALSE
longer.cor <- labs[["lab.cor"]]
}
##
## Check for "\n" in label of column 'time.e'
##
clines <- twolines(labs[["lab.time.e"]], "time.e")
##
if (clines$newline) {
newline.time.e <- TRUE
labs[["lab.time.e"]] <- clines$bottom
add.time.e <- clines$top
longer.time.e <- clines$longer
}
else {
newline.time.e <- FALSE
longer.time.e <- labs[["lab.time.e"]]
}
##
## Check for "\n" in label of column 'time.c'
##
clines <- twolines(labs[["lab.time.c"]], "time.c")
##
if (clines$newline) {
newline.time.c <- TRUE
labs[["lab.time.c"]] <- clines$bottom
add.time.c <- clines$top
longer.time.c <- clines$longer
}
else {
newline.time.c <- FALSE
longer.time.c <- labs[["lab.time.c"]]
}
##
## Check for "\n" in label of column 'effect'
##
clines <- twolines(labs[["lab.effect"]], "effect")
##
if (clines$newline) {
newline.effect <- TRUE
labs[["lab.effect"]] <- clines$bottom
add.effect <- clines$top
longer.effect <- clines$longer
}
else {
newline.effect <- FALSE
longer.effect <- labs[["lab.effect"]]
}
##
## Check for "\n" in label of column 'ci'
##
clines <- twolines(labs[["lab.ci"]], "ci")
##
if (clines$newline) {
newline.ci <- TRUE
labs[["lab.ci"]] <- clines$bottom
add.ci <- clines$top
longer.ci <- clines$longer
}
else {
newline.ci <- FALSE
longer.ci <- labs[["lab.ci"]]
}
##
## Check for "\n" in label of column 'effect.ci'
##
clines <- twolines(labs[["lab.effect.ci"]], "effect.ci")
##
if (clines$newline) {
newline.effect.ci <- TRUE
labs[["lab.effect.ci"]] <- clines$bottom
add.effect.ci <- clines$top
longer.effect.ci <- clines$longer
}
else {
newline.effect.ci <- FALSE
longer.effect.ci <- labs[["lab.effect.ci"]]
}
##
## Check for "\n" in label of column 'w.common'
##
clines <- twolines(labs[["lab.w.common"]], "w.common")
##
if (clines$newline) {
newline.w.common <- TRUE
labs[["lab.w.common"]] <- clines$bottom
add.w.common <- clines$top
longer.w.common <- clines$longer
}
else {
newline.w.common <- FALSE
longer.w.common <- labs[["lab.w.common"]]
}
##
## Check for "\n" in label of column 'w.random'
##
clines <- twolines(labs[["lab.w.random"]], "w.random")
##
if (clines$newline) {
newline.w.random <- TRUE
labs[["lab.w.random"]] <- clines$bottom
add.w.random <- clines$top
longer.w.random <- clines$longer
}
else {
newline.w.random <- FALSE
longer.w.random <- labs[["lab.w.random"]]
}
##
## Check for "\n" in label of column 'pval'
##
clines <- twolines(labs[["lab.pval"]], "pval")
##
if (clines$newline) {
newline.pval <- TRUE
labs[["lab.pval"]] <- clines$bottom
add.pval <- clines$top
longer.pval <- clines$longer
}
else {
newline.pval <- FALSE
longer.pval <- labs[["lab.pval"]]
}
##
## Check for "\n" in label of column 'tau2'
##
clines <- twolines(labs[["lab.tau2"]], "tau2")
##
if (clines$newline) {
newline.tau2 <- TRUE
labs[["lab.tau2"]] <- clines$bottom
add.tau2 <- clines$top
longer.tau2 <- clines$longer
}
else {
newline.tau2 <- FALSE
longer.tau2 <- labs[["lab.tau2"]]
}
##
## Check for "\n" in label of column 'tau'
##
clines <- twolines(labs[["lab.tau"]], "tau")
##
if (clines$newline) {
newline.tau <- TRUE
labs[["lab.tau"]] <- clines$bottom
add.tau <- clines$top
longer.tau <- clines$longer
}
else {
newline.tau <- FALSE
longer.tau <- labs[["lab.tau"]]
}
##
## Check for "\n" in label of column 'I2'
##
clines <- twolines(labs[["lab.I2"]], "I2")
##
if (clines$newline) {
newline.I2 <- TRUE
labs[["lab.I2"]] <- clines$bottom
add.I2 <- clines$top
longer.I2 <- clines$longer
}
else {
newline.I2 <- FALSE
longer.I2 <- labs[["lab.I2"]]
}
##
## Check for "\n" in argument 'smlab'
##
clines <- twolines(smlab, arg = TRUE)
##
if (clines$newline) {
smlab1 <- clines$top
smlab2 <- clines$bottom
##
newline.smlab <- TRUE
}
else {
smlab1 <- smlab
smlab2 <- ""
##
newline.smlab <- FALSE
}
##
## Check for "\n" in argument 'xlab'
##
clines <- twolines(xlab, arg = TRUE)
##
if (clines$newline) {
newline.xlab <- TRUE
xlab <- clines$top
xlab.add <- clines$bottom
}
else {
xlab.add <- ""
newline.xlab <- FALSE
}
##
## Check for "\n" in argument 'label.left'
##
clines <- twolines(label.left, arg = TRUE)
##
if (clines$newline) {
ll1 <- clines$top
ll2 <- clines$bottom
##
newline.ll <- TRUE
}
else {
ll1 <- label.left
ll2 <- ""
##
newline.ll <- FALSE
}
##
## Check for "\n" in argument 'label.right'
##
clines <- twolines(label.right, arg = TRUE)
##
if (clines$newline) {
lr1 <- clines$top
lr2 <- clines$bottom
##
newline.lr <- TRUE
}
else {
lr1 <- label.right
lr2 <- ""
##
newline.lr <- FALSE
}
##
## Check for "\n" in additional columns
##
newline.addcol.left <- FALSE
newline.addcol.right <- FALSE
##
if (newcols) {
if (length(leftcols.new) > 0) {
for (i in seq_along(leftcols.new)) {
## Check for "\n" in label of new column
clines <- twolines(leftlabs.new[i], leftcols.new[i])
newline.addcol.left <- c(newline.addcol.left, clines$newline)
}
newline.addcol.right <- sum(newline.addcol.right) > 0
}
if (length(leftcols.new) > 0) {
for (i in seq_along(leftcols.new)) {
## Check for "\n" in label of new column
clines <- twolines(leftlabs.new[i], leftcols.new[i])
newline.addcol.left <- c(newline.addcol.left, clines$newline)
}
newline.addcol.left <- sum(newline.addcol.left) > 0
}
}
##
newline <- newline.studlab | newline.effect | newline.ci | newline.effect.ci |
newline.w.common | newline.w.random | newline.TE | newline.seTE |
newline.cluster |
newline.n.e | newline.n.c | newline.event.e | newline.event.c |
newline.mean.e | newline.mean.c | newline.sd.e | newline.sd.c |
newline.cor | newline.time.e | newline.time.c |
newline.pval | newline.tau2 | newline.tau | newline.I2 |
newline.smlab | newline.addcol.left | newline.addcol.right
##
newline.all <- newline | (!newline & (newline.ll | newline.lr) & !addrow)
##
##
## (10) Define columns in forest plot as well as x- and y-limits
##
##
type.common <-
deprecated(type.common, missing(type.common),
args, "type.common",
warn.deprecated)
##
type.subgroup.common <-
deprecated(type.subgroup.common, missing.type.subgroup.common,
args, "type.subgroup.common",
warn.deprecated)
##
col.inside.common <-
deprecated(col.inside.common, missing(col.inside.common),
args, "col.inside.common",
warn.deprecated)
##
if (by) {
##
subgroup.name <-
bylabel(subgroup.name, subgroup.levels, print.subgroup.name,
sep.subgroup, big.mark = big.mark)
##
wrong.common <- FALSE
wrong.random <- FALSE
wrong.predict <- FALSE
##
if (n.by > 1) {
if (length(text.common.w) == 1)
text.common.w <- rep(text.common.w, n.com.w)
else if (length(text.common.w) == n.com)
text.common.w <- rep(text.common.w, n.by)
else if (length(text.common.w) == n.by)
text.common.w <- rep(text.common.w, n.com)
else
wrong.common <- TRUE
##
if (length(text.random.w) == 1)
text.random.w <- rep(text.random.w, n.ran.w)
else if (length(text.random.w) == n.ran)
text.random.w <- rep(text.random.w, n.by)
else if (length(text.random.w) == n.by)
text.random.w <- rep(text.random.w, n.ran)
else
wrong.random <- TRUE
##
if (length(text.predict.w) == 1)
text.predict.w <- rep(text.predict.w, n.prd.w)
else if (length(text.predict.w) == n.prd)
text.predict.w <- rep(text.predict.w, n.by)
else if (length(text.predict.w) == n.by)
text.predict.w <- rep(text.predict.w, n.prd)
else
wrong.predict <- TRUE
}
else if (n.by == 1) {
if (length(text.common.w) != n.com)
wrong.common <- TRUE
if (length(text.random.w) != n.ran)
wrong.random <- TRUE
if (length(text.predict.w) != n.prd)
wrong.predict <- TRUE
}
##
if (wrong.common)
stop("Argument 'text.common.w' must be a single character string",
if (n.by > 1 | n.com > 1)
paste0(" or of length\n -", n.by, " (number of subgroups) or",
" \n -", n.com, " (number of common effect analyses)")
else
".")
##
if (wrong.random)
stop("Argument 'text.random.w' must be a single character string",
if (n.by > 1 | n.ran > 1)
paste0(" or of length\n -", n.by, " (number of subgroups) or",
" \n -", n.ran, " (number of random effects analyses)")
else
".")
##
if (wrong.predict)
stop("Argument 'text.predict.w' must be a single character string",
if (n.by > 1 | n.prd > 1)
paste0(" or of length\n -", n.by, " (number of subgroups) or",
" \n -", n.prd, " (number of prediction intervals)")
else
".")
##
if (hetstat.pooled == "common") {
text.common <- hetstat.overall
text.common.w <- hetstat.w
hetstat <- FALSE
}
else if (hetstat.pooled == "random") {
text.random <- hetstat.overall
text.random.w <- hetstat.w
hetstat <- FALSE
}
else if (hetstat.pooled == "study") {
studlab <- hetstat.w
hetstat <- FALSE
}
##
modlabs <- c(text.common, text.random, text.predict,
hetstat.overall, hetstat.resid,
text.overall.common, text.overall.random,
text.subgroup.common, text.subgroup.random,
text.addline1, text.addline2,
subgroup.name, text.common.w, text.random.w, text.predict.w,
hetstat.w,
unlist(text.effect.subgroup.common),
unlist(text.effect.subgroup.random),
studlab)
##
TEs <- c(TE.common, TE.random, NAs.prd, TE.w, TE)
lowTEs <- c(lowTE.common, lowTE.random, lowTE.predict, lowTE.w, lowTE)
uppTEs <- c(uppTE.common, uppTE.random, uppTE.predict, uppTE.w, uppTE)
##
TEs.exclude <- c(TE.common, TE.random, NAs.prd,
TE.w, TE.exclude)
lowTEs.exclude <- c(lowTE.common, lowTE.random, lowTE.predict, lowTE.w,
lowTE.exclude)
uppTEs.exclude <- c(uppTE.common, uppTE.random, uppTE.predict, uppTE.w,
uppTE.exclude)
##
TEs.study <- c(blanks, blanks.w,
formatN(TE.orig, digits.TE, lab.NA, big.mark = big.mark))
##
seTEs.study <- c(blanks, blanks.w,
formatN(seTE, digits.se, lab.NA, big.mark = big.mark))
##
w.commons <- c(NAs.com, NAs.ran, NAs.prd,
NAs.com.w, NAs.ran.w, NAs.prd.w,
NAs.stat.w,
w.common.p)
w.randoms <- c(NAs.com, NAs.ran, NAs.prd,
NAs.com.w, NAs.ran.w, NAs.prd.w,
NAs.stat.w,
w.random.p)
##
format.w.commons <- c(rep(100, n.com), NAs.ran, NAs.prd,
repl(w.common.w.p, n.com, n.by),
NAs.ran.w, NAs.prd.w, NAs.stat.w,
w.common.p)
format.w.randoms <- c(NAs.com, rep(100, n.ran), NAs.prd,
NAs.com.w,
repl(w.random.w.p, n.ran, n.by),
NAs.prd.w, NAs.stat.w,
w.random.p)
##
Wc.format <-
formatN(format.w.commons, digits.weight, text.NA = lab.NA.weight)
Wr.format <-
formatN(format.w.randoms, digits.weight, text.NA = lab.NA.weight)
##
sel.common <- Wc.format == lab.NA.weight
sel.random <- Wr.format == lab.NA.weight
##
sel.common[first.ran.w] <- TRUE
sel.random[first.com.w] <- TRUE
##
type.pooled <- c(rep(type.common, n.com),
rep(type.random, n.ran),
rep("predict", n.prd),
rep(type.subgroup.common, n.com.w),
rep(type.subgroup.random, n.ran.w),
rep("predict", n.prd.w),
blanks.stat.w)
col.diamond.pooled <-
c(rep(col.diamond.common, n.com),
rep(col.diamond.random, n.ran),
rep(col.predict, n.prd),
rep(col.diamond.common, n.com.w),
rep(col.diamond.random, n.ran.w),
rep(col.predict, n.prd.w),
NAs.stat.w)
col.diamond.lines.pooled <-
c(rep(col.diamond.lines.common, n.com),
rep(col.diamond.lines.random, n.ran),
rep(col.predict.lines, n.prd),
rep(col.diamond.lines.common, n.com.w),
rep(col.diamond.lines.random, n.ran.w),
rep(col.predict.lines, n.prd.w),
NAs.stat.w)
col.inside.pooled <-
c(rep(col.inside.common, n.com),
rep(col.inside.random, n.ran),
blanks.prd,
rep(col.inside.common, n.com.w),
rep(col.inside.random, n.ran.w),
rep("", n.prd.w),
NAs.stat.w)
}
else {
##
if (hetstat.pooled == "common")
text.common <- hetstat.overall
else if (hetstat.pooled == "random")
text.random <- hetstat.overall
##
modlabs <- c(text.common, text.random, text.predict,
hetstat.overall, hetstat.resid,
text.overall.common, text.overall.random,
text.subgroup.common, text.subgroup.random,
text.addline1, text.addline2,
studlab)
##
TEs <- c(TE.common, TE.random, NAs.prd, TE)
lowTEs <- c(lowTE.common, lowTE.random, lowTE.predict, lowTE)
uppTEs <- c(uppTE.common, uppTE.random, uppTE.predict, uppTE)
##
TEs.exclude <- c(TE.common, TE.random, NAs.prd, TE.exclude)
lowTEs.exclude <- c(lowTE.common, lowTE.random,
lowTE.predict, lowTE.exclude)
uppTEs.exclude <- c(uppTE.common, uppTE.random,
uppTE.predict, uppTE.exclude)
##
TEs.study <- c(blanks,
formatN(TE.orig, digits.TE, lab.NA, big.mark = big.mark))
seTEs.study <- c(blanks,
formatN(seTE, digits.se, lab.NA, big.mark = big.mark))
##
w.commons <- c(NAs, w.common.p)
w.randoms <- c(NAs, w.random.p)
##
format.w.common <- formatN(c(100, w.common.p), digits.weight)
format.w.random <- formatN(c(100, w.random.p), digits.weight)
##
Wc.format <- c(rep(format.w.common[1], n.com),
rep(lab.NA.weight, n.ran),
blanks.prd,
format.w.common[-1])
Wr.format <- c(rep(lab.NA.weight, n.com),
rep(format.w.random[1], n.ran),
blanks.prd,
format.w.random[-1])
##
sel.common <- Wc.format == lab.NA.weight
sel.random <- Wr.format == lab.NA.weight
##
type.pooled <- c(rep(type.common, n.com),
rep(type.random, n.ran),
rep("predict", n.prd))
##
col.diamond.pooled <-
c(rep(col.diamond.common, n.com),
rep(col.diamond.random, n.ran),
rep(col.predict, n.prd))
##
col.diamond.lines.pooled <-
c(rep(col.diamond.lines.common, n.com),
rep(col.diamond.lines.random, n.ran),
rep(col.predict.lines, n.prd))
##
col.inside.pooled <- c(rep(col.inside.common, n.com),
rep(col.inside.random, n.ran),
blanks.prd)
}
##
## Treatment effect and confidence interval
##
if (backtransf & log.xaxis) {
effect.format <-
formatN(exp(TEs), digits, lab.NA.effect, big.mark = big.mark)
ci.format <-
ifelse(is.na(lowTEs) | is.na(uppTEs), lab.NA.effect,
formatCI(formatN(exp(lowTEs), digits = digits, text.NA = lab.NA,
big.mark = big.mark),
formatN(exp(uppTEs), digits = digits, text.NA = lab.NA,
big.mark = big.mark)))
}
else {
effect.format <- formatN(TEs, digits, lab.NA.effect, big.mark = big.mark)
ci.format <-
ifelse(is.na(lowTEs) | is.na(uppTEs), lab.NA.effect,
formatCI(formatN(lowTEs, digits = digits, text.NA = lab.NA,
big.mark = big.mark),
formatN(uppTEs, digits = digits, text.NA = lab.NA,
big.mark = big.mark)))
}
effect.ci.format <- paste0(effect.format,
ifelse(is.na(TEs), "", " "),
ci.format)
##
## No treatment effect for prediction interval
##
effect.format[all.prd] <- ""
##
## Only print prediction interval if requested
##
if (!prediction) {
ci.format[all.prd] <- ""
effect.ci.format[all.prd] <- ""
}
##
## No treatment effect and confidence interval in statistics lines
##
if (by) {
effect.format[all.stat.w] <- ""
ci.format[all.stat.w] <- ""
effect.ci.format[all.stat.w] <- ""
}
##
## Weights of common and random effects model
##
Wc.format <- paste0(Wc.format, if (w.common.percent) "%")
Wr.format <- paste0(Wr.format, if (w.random.percent) "%")
##
Wc.format[Wc.format == "%"] <- ""
Wr.format[Wr.format == "%"] <- ""
##
Wc.format[sel.common] <- lab.NA.weight
Wr.format[sel.random] <- lab.NA.weight
##
## Treatment estimate and its standard error
##
TE.format <- TEs.study
seTE.format <- seTEs.study
##
## Number of patients, events, and person times
##
if (!is.null(x$n.e.pooled))
sum.n.e <- x$n.e.pooled
else
sum.n.e <- sum(x$n.e, na.rm = TRUE)
##
if (!is.null(x$n.c.pooled))
sum.n.c <- x$n.c.pooled
else
sum.n.c <- sum(x$n.c, na.rm = TRUE)
##
if (!is.null(x$event.e.pooled))
sum.e.e <- x$event.e.pooled
else
sum.e.e <- sum(x$event.e, na.rm = TRUE)
##
if (!is.null(x$event.c.pooled))
sum.e.c <- x$event.c.pooled
else
sum.e.c <- sum(x$event.c, na.rm = TRUE)
##
if (!is.null(x$time.e.pooled))
sum.t.e <- x$time.e.pooled
else
sum.t.e <- sum(x$time.e, na.rm = TRUE)
##
if (!is.null(x$time.c.pooled))
sum.t.c <- x$time.c.pooled
else
sum.t.c <- sum(x$time.c, na.rm = TRUE)
##
if (is.character(x$cluster))
as.character.cluster <- TRUE
else if (is.factor(x$cluster)) {
if (anyNA(suppressWarnings(as.numeric(as.character(x$cluster)))))
as.character.cluster <- TRUE
else
as.character.cluster <- FALSE
##
x$cluster <- as.character(x$cluster)
}
else
as.character.cluster <- FALSE
##
if (by) {
if (pooled.totals) {
Ne <- c(c(sum.n.e, NAs.com1),
c(sum.n.e, NAs.ran1),
NAs.prd,
repl(n.e.w, n.com, n.by),
repl(n.e.w, n.ran, n.by),
NAs.prd.w, NAs.stat.w,
x$n.e)
Nc <- c(c(sum.n.c, NAs.com1),
c(sum.n.c, NAs.ran1),
NAs.prd,
repl(n.c.w, n.com, n.by),
repl(n.c.w, n.ran, n.by),
NAs.prd.w, NAs.stat.w,
x$n.c)
}
else {
Ne <- c(NAs.all, x$n.e)
Nc <- c(NAs.all, x$n.c)
}
if (pooled.events) {
Ee <- c(c(sum.e.e, NAs.com1),
c(sum.e.e, NAs.ran1),
NAs.prd,
repl(e.e.w, n.com, n.by),
repl(e.e.w, n.ran, n.by),
NAs.prd.w, NAs.stat.w,
x$event.e)
Ec <- c(c(sum.e.c, NAs.com1),
c(sum.e.c, NAs.ran1),
NAs.prd,
repl(e.c.w, n.com, n.by),
repl(e.c.w, n.ran, n.by),
NAs.prd.w, NAs.stat.w,
x$event.c)
}
else {
Ee <- c(NAs.all, x$event.e)
Ec <- c(NAs.all, x$event.c)
}
if (pooled.times) {
Te <- c(c(sum.t.e, NAs.com1),
c(sum.t.e, NAs.ran1),
NAs.prd,
repl(t.e.w, n.com, n.by),
repl(t.e.w, n.ran, n.by),
NAs.prd.w, NAs.stat.w,
x$time.e)
Tc <- c(c(sum.t.c, NAs.com1),
c(sum.t.c, NAs.ran1),
NAs.prd,
repl(t.c.w, n.com, n.by),
repl(t.c.w, n.ran, n.by),
NAs.prd.w, NAs.stat.w,
x$time.c)
}
else {
Te <- c(NAs.all, x$time.e)
Tc <- c(NAs.all, x$time.c)
}
}
else {
if (pooled.totals) {
Ne <- c(c(sum.n.e, NAs.com1),
c(sum.n.e, NAs.ran1),
NAs.prd,
x$n.e)
Nc <- c(c(sum.n.c, NAs.com1),
c(sum.n.c, NAs.ran1),
NAs.prd,
x$n.c)
}
else {
Ne <- c(NAs,
x$n.e)
Nc <- c(NAs,
x$n.c)
}
if (pooled.events) {
Ee <- c(c(sum.e.e, NAs.com1),
c(sum.e.e, NAs.ran1),
NAs.prd,
x$event.e)
Ec <- c(c(sum.e.c, NAs.com1),
c(sum.e.c, NAs.ran1),
NAs.prd,
x$event.c)
}
else {
Ee <- c(NAs,
x$event.e)
Ec <- c(NAs,
x$event.c)
}
if (pooled.times) {
Te <- c(c(sum.t.e, NAs.com1),
c(sum.t.e, NAs.ran1),
NAs.prd,
x$time.e)
Tc <- c(c(sum.t.c, NAs.com1),
c(sum.t.c, NAs.ran1),
NAs.prd,
x$time.c)
}
else {
Te <- c(NAs,
x$time.e)
Tc <- c(NAs,
x$time.c)
}
}
##
if (by) {
bla <- rep("", length(Ne))
scom.w <- sran.w <- sprd.w <- bla
scom.w[first.com.w] <- "yes"
sran.w[first.ran.w] <- "yes"
sprd.w[first.prd.w] <- "yes"
##
ncom.w <- nran.w <- nprd.w <- notfirst <- bla
ncom.w[emp.com.w] <- "yes"
nran.w[emp.ran.w] <- "yes"
nprd.w[emp.prd.w] <- "yes"
notfirst[emp.w] <- "yes"
##
if (FALSE)
print(data.frame(TEs = round(TEs, 2),
lowTEs = round(lowTEs, 2),
uppTEs = round(uppTEs, 2)
))
if (FALSE)
print(data.frame(row = c(paste0("C", seq_len(n.com)),
paste0("R", seq_len(n.ran)),
paste0("P", seq_len(n.prd)),
paste0("C.w", seq_len(n.com.w)),
paste0("R.w", seq_len(n.ran.w)),
paste0("P.w", seq_len(n.prd.w)),
paste0("het.w", seq_len(n.by)),
paste0("efc.w", seq_len(n.by)),
paste0("efr.w", seq_len(n.by)),
paste0("TE", seq_len(k.all))),
Ne, notfirst))
}
Ne.format <- formatN(Ne, digits = 0, text.NA = lab.NA, big.mark = big.mark)
Nc.format <- formatN(Nc, digits = 0, text.NA = lab.NA, big.mark = big.mark)
Ee.format <- formatN(Ee, digits = 0, text.NA = lab.NA, big.mark = big.mark)
Ec.format <- formatN(Ec, digits = 0, text.NA = lab.NA, big.mark = big.mark)
##
if (all(is_wholenumber(Te), na.rm = TRUE) & missing.digits.time)
Te.format <-
formatN(Te, digits = 0, text.NA = lab.NA, big.mark = big.mark)
else
Te.format <- formatN(Te, digits.time, lab.NA, big.mark = big.mark)
##
if (all(is_wholenumber(Tc), na.rm = TRUE) & missing.digits.time)
Tc.format <-
formatN(Tc, digits = 0, text.NA = lab.NA, big.mark = big.mark)
else
Tc.format <- formatN(Tc, digits.time, lab.NA, big.mark = big.mark)
##
## Print nothing in lines with prediction interval
##
Ne.format[all.prd] <- Nc.format[all.prd] <- ""
Ee.format[all.prd] <- Ec.format[all.prd] <- ""
Te.format[all.prd] <- Tc.format[all.prd] <- ""
Wc.format[all.prd] <- Wr.format[all.prd] <- ""
Wc.format[emp.com] <- Wr.format[emp.com] <- ""
Wc.format[emp.ran] <- Wr.format[emp.ran] <- ""
##
if (by) {
##
## Print nothing in selected subgroup lines
##
Ne.format[emp.w] <- Nc.format[emp.w] <- ""
Ee.format[emp.w] <- Ec.format[emp.w] <- ""
Te.format[emp.w] <- Tc.format[emp.w] <- ""
Wc.format[emp.w] <- Wr.format[emp.w] <- ""
}
##
if (common.random) {
##
## Print nothing in lines with results for random effects model
##
Ne.format[all.ran] <- Nc.format[all.ran] <- ""
Ee.format[all.ran] <- Ec.format[all.ran] <- ""
Te.format[all.ran] <- Tc.format[all.ran] <- ""
##
if (by) {
Ne.format[all.ran.w] <- Nc.format[all.ran.w] <- ""
Ee.format[all.ran.w] <- Ec.format[all.ran.w] <- ""
Te.format[all.ran.w] <- Tc.format[all.ran.w] <- ""
}
}
##
## Print nothing in lines for second, third etc. common effect or
## random effects model
##
Ne.format[emp.com] <- Nc.format[emp.com] <- ""
Ee.format[emp.com] <- Ec.format[emp.com] <- ""
Te.format[emp.com] <- Tc.format[emp.com] <- ""
##
Ne.format[emp.ran] <- Nc.format[emp.ran] <- ""
Ee.format[emp.ran] <- Ec.format[emp.ran] <- ""
Te.format[emp.ran] <- Tc.format[emp.ran] <- ""
##
if (by) {
Ne.format[emp.com.w] <- Nc.format[emp.com.w] <- ""
Ee.format[emp.com.w] <- Ec.format[emp.com.w] <- ""
Te.format[emp.com.w] <- Tc.format[emp.com.w] <- ""
##
Ne.format[emp.ran.w] <- Nc.format[emp.ran.w] <- ""
Ee.format[emp.ran.w] <- Ec.format[emp.ran.w] <- ""
Te.format[emp.ran.w] <- Tc.format[emp.ran.w] <- ""
}
##
## Only print total number of events if pooled.events is TRUE
##
if (!pooled.events) {
Ee.format[all.com] <- Ec.format[all.com] <- ""
Ee.format[all.ran] <- Ec.format[all.ran] <- ""
##
if (by) {
Ee.format[all.com.w] <- Ec.format[all.com.w] <- ""
Ee.format[all.ran.w] <- Ec.format[all.ran.w] <- ""
}
}
##
## Only print total person times if pooled.times is TRUE
##
if (!pooled.times) {
Te.format[all.com] <- Tc.format[all.com] <- ""
Te.format[all.ran] <- Tc.format[all.ran] <- ""
##
if (by) {
Te.format[all.com.w] <- Tc.format[all.com.w] <- ""
Te.format[all.ran.w] <- Tc.format[all.ran.w] <- ""
}
}
##
## Mean and standard deviation
##
if (by) {
Me <- c(NAs.all, x$mean.e)
Mc <- c(NAs.all, x$mean.c)
Se <- c(NAs.all, x$sd.e)
Sc <- c(NAs.all, x$sd.c)
}
else {
Me <- c(NAs, x$mean.e)
Mc <- c(NAs, x$mean.c)
Se <- c(NAs, x$sd.e)
Sc <- c(NAs, x$sd.c)
}
##
digits.R <- options()$digits
##
if (is.null(digits.mean)) {
if (all(is_wholenumber(Me), na.rm = TRUE))
Me.format <-
formatN(Me, digits = 0, text.NA = lab.NA, big.mark = big.mark)
else
Me.format <-
formatN(Me, digits = digits.R, text.NA = lab.NA, big.mark = big.mark)
##
if (all(is_wholenumber(Mc), na.rm = TRUE))
Mc.format <-
formatN(Mc, digits = 0, text.NA = lab.NA, big.mark = big.mark)
else
Mc.format <-
formatN(Mc, digits = digits.R, text.NA = lab.NA, big.mark = big.mark)
}
else {
Me.format <- formatN(Me, digits.mean, lab.NA, big.mark = big.mark)
Mc.format <- formatN(Mc, digits.mean, lab.NA, big.mark = big.mark)
}
if (is.null(digits.sd)) {
if (all(is_wholenumber(Se), na.rm = TRUE))
Se.format <-
formatN(Se, digits = 0, text.NA = lab.NA, big.mark = big.mark)
else
Se.format <-
formatN(Se, digits = digits.R, text.NA = lab.NA, big.mark = big.mark)
##
if (all(is_wholenumber(Sc), na.rm = TRUE))
Sc.format <-
formatN(Sc, digits = 0, text.NA = lab.NA, big.mark = big.mark)
else
Sc.format <-
formatN(Sc, digits = digits.R, text.NA = lab.NA, big.mark = big.mark)
}
else {
Se.format <- formatN(Se, digits.sd, lab.NA, big.mark = big.mark)
Sc.format <- formatN(Sc, digits.sd, lab.NA, big.mark = big.mark)
}
##
## Print nothing for lines with summary results
##
Me.format[all.res] <- Mc.format[all.res] <-
Se.format[all.res] <- Sc.format[all.res] <- ""
##
if (by) {
Me.format[sel.w] <- Mc.format[sel.w] <- ""
Se.format[sel.w] <- Sc.format[sel.w] <- ""
}
##
## Correlation
##
if (by)
cor <- c(NAs.all, x$cor)
else
cor <- c(NAs, x$cor)
##
if (is.null(digits.cor))
cor.format <- formatN(cor, digits = digits.R, text.NA = lab.NA)
else
cor.format <- formatN(cor, digits.cor, lab.NA, big.mark = big.mark)
##
## Print nothing for lines with summary results
##
cor.format[all.res] <- ""
##
if (by)
cor.format[sel.w] <- ""
##
## P-value of effect
##
pval.format <-
formatPT(c(x$pval.common, x$pval.random, NAs.prd, x$pval),
digits = digits.pval,
big.mark = big.mark,
lab = FALSE, labval = "",
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = lab.NA)
pval.format[all.prd] <- ""
##
## Cluster variable
##
if (by)
cluster.format <- c(NAs.all, x$cluster)
else
cluster.format <- c(NAs, x$cluster)
##
## Print nothing for lines with summary results
##
cluster.format[all.res] <- ""
##
if (by)
cluster.format[sel.w] <- ""
##
## Leave-one-out / cumulative meta-analysis
##
if (metainf.metacum) {
tau2.format <- c(x$tau2.overall, x$tau2.overall, NA, x$tau2)
tau.format <- c(x$tau.overall, x$tau.overall, NA, x$tau)
I2.format <- c(x$I2.overall, x$I2.overall, NA, x$I2)
##
tau2.format <- formatPT(tau2.format, digits = digits.tau2,
big.mark = big.mark,
lab = FALSE, labval = "",
lab.NA = lab.NA)
tau.format <- formatPT(tau.format, digits = digits.tau,
big.mark = big.mark,
lab = FALSE, labval = "",
lab.NA = lab.NA)
I2.format <- formatN(100 * I2.format, digits.I2, lab.NA)
I2.format <- paste0(I2.format, ifelse(I2.format == lab.NA, "", "%"))
##
## Print nothing for lines with prediction interval
##
tau2.format[all.prd] <- tau.format[all.prd] <- I2.format[all.prd] <- ""
}
##
##
## y-axis:
##
##
if ((!(metaprop | metacor) &
(any(rightcols %in% c("n.e", "n.c")) |
any(leftcols %in% c("n.e", "n.c")))
) |
(metainc &
(any(rightcols %in% c("time.e", "time.c")) |
any(leftcols %in% c("time.e", "time.c")))
) |
(metacont &
(any(rightcols %in% c("sd.e", "sd.c")) |
any(leftcols %in% c("sd.e", "sd.c")))
) |
(metamean &
(any(rightcols %in% c("sd.e")) |
any(leftcols %in% c("sd.e")))
) |
(!is.null(label.e.attach) & !is.null(label.e)) |
(!is.null(label.c.attach) & !is.null(label.c)) |
newline.all
) {
yHead <- 2
yHeadadd <- 1
}
else {
yHead <- 1
yHeadadd <- NA
}
##
if (!by) {
N <- n.stud
if (study.results)
yTE <- 1:N
else
yTE <- rep(NA, N)
}
else {
##
j <- 1
k <- 0
yBylab <- NAs.by
yTE <- rep(NA, n.stud)
yTE.common.w <- rep(yBylab, n.com)
yTE.random.w <- rep(yBylab, n.ran)
yTE.predict.w <- rep(yBylab, n.prd)
yTE.hetstat.w <- yBylab
yTE.effect.common.w <- yBylab
yTE.effect.random.w <- yBylab
##
seq.com.w <- seq_len(n.com)
seq.ran.w <- seq_len(n.ran)
seq.prd.w <- seq_len(n.prd)
##
n.by.i <- 0
##
for (i in seq_len(n.by)) {
##
if (allstudies)
k.i <- k.all.w[i]
else
k.i <- k.TE.w[i]
##
k <- k + k.i
##
if (print.subgroup.labels) {
yBylab[i] <- j
j <- j + 1
}
##
if (study.results) {
yTE[(k - k.i + 1):k] <- j:(j + k.i - 1)
j <- j + k.i
}
else
yTE[(k - k.i + 1):k] <- NA
##
## Common effect model
##
if (common & subgroup.logical[i]) {
yTE.common.w[n.by.i * n.com + seq.com.w] <-
j + seq.com.w - 1
j <- j + max(seq.com.w)
}
else
yTE.common.w[n.by.i * n.com + seq.com.w] <- NA
##
## Random effects model
##
if (random & subgroup.logical[i]) {
yTE.random.w[n.by.i * n.ran + seq.ran.w] <-
j + seq.ran.w - 1
j <- j + max(seq.ran.w)
}
else
yTE.random.w[n.by.i * n.ran + seq.ran.w] <- NA
##
## Only pooled totals
##
if (pooled.totals & subgroup.logical[i] & !(common | random)) {
yTE.common.w[n.by.i * n.com + seq.com.w] <-
j + seq.com.w - 1
j <- j + max(seq.com.w)
}
##
## Prediction interval in subgroups
##
##yTE.predict.w[n.by.i * n.prd + seq.prd.w] <- NA
##
if (prediction.subgroup.logical[i]) {
yTE.predict.w[n.by.i * n.prd + seq.prd.w] <-
j + seq.prd.w - 1
j <- j + max(seq.prd.w)
}
##
## Heterogeneity statistics
##
if (subgroup.hetstat.logical[i]) {
yTE.hetstat.w[i] <- j
j <- j + 1
}
else
yTE.hetstat.w[i] <- NA
##
## Test for effect in subgroup (common effect)
##
if (test.effect.subgroup.common.logical[i]) {
yTE.effect.common.w[i] <- j
j <- j + 1
}
else
yTE.effect.common.w[i] <- NA
##
## Test for effect in subgroup (random effects)
##
if (test.effect.subgroup.random.logical[i]) {
yTE.effect.random.w[i] <- j
j <- j + 1
}
else
yTE.effect.random.w[i] <- NA
##
y.w.i <- c(yTE.common.w[i], yTE.random.w[i], yTE.predict.w[i],
yTE.hetstat.w[i],
yTE.effect.common.w[i],
yTE.effect.random.w[i])
##
if (!study.results & !any(!is.na(y.w.i))) {
yBylab[i] <- NA
if (print.subgroup.labels)
j <- j - 1
}
##
if (!is.na(yBylab[i]) & addrow.subgroups)
j <- j + 1
##
n.by.i <- n.by.i + 1
}
##
if (!addrow.subgroups)
j <- j + 1
##
yTE.w <- c(yTE.common.w, yTE.random.w, yTE.predict.w, yTE.hetstat.w,
yTE.effect.common.w, yTE.effect.random.w)
}
##
##
## x-axis:
##
##
if (notmiss.xlim && is.numeric(xlim[1]))
if (log.xaxis)
xlim <- log(xlim)
##
if (is.null(xlim)) {
if (metaprop | metarate) {
xlim <- c(min(lowTEs, na.rm = TRUE),
max(uppTEs, na.rm = TRUE))
##
if (!is.na(ref) && ref < xlim[1])
xlim[1] <- ref
if (!is.na(ref) && ref > xlim[2])
xlim[2] <- ref
##
if (!is.na(lower.equi) && lower.equi < xlim[1])
xlim[1] <- lower.equi
if (!is.na(lower.equi) && lower.equi > xlim[2])
xlim[2] <- lower.equi
##
if (!is.na(upper.equi) && upper.equi < xlim[1])
xlim[1] <- upper.equi
if (!is.na(upper.equi) && upper.equi > xlim[2])
xlim[2] <- upper.equi
}
else {
sel.low <- is.finite(lowTEs)
sel.upp <- is.finite(uppTEs)
##
if (all(!sel.low))
minTE <- -0.5
else
minTE <- min(lowTEs[sel.low], na.rm = TRUE)
if (all(!sel.upp))
maxTE <- 0.5
else
maxTE <- max(uppTEs[sel.upp], na.rm = TRUE)
##
xlim <- c(minTE, maxTE)
##
if (!is.na(ref) && ref < xlim[1])
xlim[1] <- ref
if (!is.na(ref) && ref > xlim[2])
xlim[2] <- ref
##
if (!is.na(lower.equi) && lower.equi < xlim[1])
xlim[1] <- lower.equi
if (!is.na(lower.equi) && lower.equi > xlim[2])
xlim[2] <- lower.equi
##
if (!is.na(upper.equi) && upper.equi < xlim[1])
xlim[1] <- upper.equi
if (!is.na(upper.equi) && upper.equi > xlim[2])
xlim[2] <- upper.equi
}
}
##
symmetric <- FALSE
##
if (!is.null(xlim) && is.character(xlim[1])) {
##
xlim <- setchar(xlim, "symmetric",
paste0("should be a numeric vector (min, max) or ",
"the character string \"symmetric\""))
symmetric <- TRUE
##
if (metaprop | metarate | metamean) {
xlim <- c(min(lowTEs, na.rm = TRUE),
max(uppTEs, na.rm = TRUE))
}
else {
sel.low <- is.finite(lowTEs)
sel.upp <- is.finite(uppTEs)
##
if (all(!sel.low))
minTE <- -0.5
else
minTE <- min(lowTEs[sel.low], na.rm = TRUE)
if (all(!sel.upp))
maxTE <- 0.5
else
maxTE <- max(uppTEs[sel.upp], na.rm = TRUE)
##
if (minTE < 0 & maxTE < 0)
xlim <- c(minTE, -minTE)
else if (minTE > 0 & maxTE > 0)
xlim <- c(-maxTE, maxTE)
else
xlim <- c(-max(abs(c(minTE, maxTE))), max(abs(c(minTE, maxTE))))
}
}
##
if (!is.na(ref) &&
round(xlim[2] - ref, 6) == round(ref - xlim[1], 6))
symmetric <- TRUE
##
if (by) {
if (all(is.na(c(yTE, yTE.w))))
max.yTE <- 0
else
max.yTE <- max(c(yTE, yTE.w), na.rm = TRUE)
}
else {
if (all(is.na(yTE)))
max.yTE <- 0
else
max.yTE <- max(yTE, na.rm = TRUE)
}
##
yNext <- max.yTE + ifelse(max.yTE == 0 | !addrow.overall, 1, 2)
##
if (missing(xlab.pos))
xlab.pos <- mean(xlim)
##
if (missing(smlab.pos))
smlab.pos <- mean(xlim)
##
yTE.common <- rep(NA, n.com)
yTE.random <- rep(NA, n.ran)
yPredict <- rep(NA, n.prd)
yHetstat <- NA
yResidHetstat <- NA
yOverall.common <- NA
yOverall.random <- NA
ySubgroup.common <- NA
ySubgroup.random <- NA
yText.addline1 <- NA
yText.addline2 <- NA
##
seq.com <- seq_len(n.com) - 1
seq.ran <- seq_len(n.ran) - 1
seq.prd <- seq_len(n.prd) - 1
##
if (common & random & overall) {
yTE.common <- yNext + seq.com
yNext <- yNext + 1 + max(seq.com)
##
yTE.random <- yNext + seq.ran
yNext <- yNext + 1 + max(seq.ran)
}
##
else if (common & !random & overall) {
yTE.common <- yNext + seq.com
yNext <- yNext + 1 + max(seq.com)
}
##
else if (!common & random & overall) {
yTE.random <- yNext + seq.ran
yNext <- yNext + 1 + max(seq.ran)
}
##
else if (!common & !random & pooled.totals & overall) {
yTE.common <- yNext + seq.com
yNext <- yNext + 1 + max(seq.com)
##
if (missing(text.common))
text.common <- "Overall"
}
##
if (prediction & overall) {
yPredict <- yNext + seq.prd
yNext <- yNext + 1 + max(seq.prd)
}
##
yNext <- yNext + addrows.below.overall
##
if (overall.hetstat) {
yHetstat <- yNext
yNext <- yNext + 1
}
##
if (resid.hetstat) {
yResidHetstat <- yNext
yNext <- yNext + 1
}
##
if (test.overall.common) {
yOverall.common <- yNext
yNext <- yNext + 1
}
##
if (test.overall.random) {
yOverall.random <- yNext
yNext <- yNext + 1
}
##
if (test.subgroup.common) {
ySubgroup.common <- yNext
yNext <- yNext + 1
}
##
if (test.subgroup.random) {
ySubgroup.random <- yNext
yNext <- yNext + 1
}
##
if (!missing.text.addline1) {
yText.addline1 <- yNext
yNext <- yNext + 1
}
##
if (!missing.text.addline2)
yText.addline2 <- yNext
##
if (!common & !pooled.totals) text.common <- ""
if (!random) text.random <- ""
if (!prediction) text.predict <- ""
##
yTE <- yHead + yTE + addrow
##
yTE.common <- yHead + yTE.common + addrow
yTE.random <- yHead + yTE.random + addrow
yPredict <- yHead + yPredict + addrow
##
yHetstat <- yHead + yHetstat + addrow
yResidHetstat <- yHead + yResidHetstat + addrow
yOverall.common <- yHead + yOverall.common + addrow
yOverall.random <- yHead + yOverall.random + addrow
ySubgroup.common <- yHead + ySubgroup.common + addrow
ySubgroup.random <- yHead + ySubgroup.random + addrow
yText.addline1 <- yHead + yText.addline1 + addrow
yText.addline2 <- yHead + yText.addline2 + addrow
##
yStats <- c(yHetstat,
yResidHetstat,
yOverall.common, yOverall.random,
ySubgroup.common, ySubgroup.random,
yText.addline1, yText.addline2)
##
if (by) {
yBylab <- yHead + yBylab + addrow
yTE.w <- yHead + yTE.w + addrow
##
yLab <- c(yHead,
yTE.common, yTE.random, yPredict,
yStats,
yBylab, yTE.w,
yTE)
##
yS <- c(yHead, yTE.common, yTE.random, yPredict, yTE.w, yTE)
}
else {
yLab <- c(yHead, yTE.common, yTE.random, yPredict,
yStats,
yTE)
##
yS <- c(yHead, yTE.common, yTE.random, yPredict, yTE)
}
##
##
## (11) Format columns in forest plot
##
##
col.studlab <- list(labels =
lapply(as.list(c(labs[["lab.studlab"]], modlabs)),
tg,
xpos = xpos.s, just = just.s,
fs = fs.study.labels,
ff = ff.study.labels,
fontfamily = fontfamily),
rows = yLab
)
## Study label:
col.studlab$labels[[1]] <- tg(labs[["lab.studlab"]], xpos.s,
just.s, fs.head, ff.head, fontfamily)
## Common effect estimate:
strt <- j <- 1
for (i in seq_len(n.com)) {
col.studlab$labels[[strt + i]] <-
tg(text.common[i], xpos.s, just.s,
fs.common.labels, ff.common.labels, fontfamily)
j <- j + 1
}
## Random effects estimate:
strt <- j
for (i in seq_len(n.ran)) {
col.studlab$labels[[strt + i]] <-
tg(text.random[i], xpos.s, just.s,
fs.random.labels, ff.random.labels, fontfamily)
j <- j + 1
}
## Prediction interval:
strt <- j
for (i in seq_len(n.prd)) {
col.studlab$labels[[strt + i]] <-
tg(text.predict[i], xpos.s, just.s,
fs.predict.labels, ff.predict.labels, fontfamily)
j <- j + 1
}
## Heterogeneity statistics:
col.studlab$labels[[j + 1]] <-
tg(hetstat.overall, xpos.s, just.s, fs.hetstat, ff.hetstat, fontfamily)
## Statistic for residual heterogeneity:
col.studlab$labels[[j + 2]] <-
tg(hetstat.resid, xpos.s, just.s, fs.hetstat, ff.hetstat, fontfamily)
## Test for overall effect (common effect model):
col.studlab$labels[[j + 3]] <-
tg(text.overall.common, xpos.s, just.s, fs.test.overall, ff.test.overall,
fontfamily)
## Test for overall effect (random effects model):
col.studlab$labels[[j + 4]] <-
tg(text.overall.random, xpos.s, just.s, fs.test.overall, ff.test.overall,
fontfamily)
## Test for subgroup differences (common effect model):
col.studlab$labels[[j + 5]] <-
tg(text.subgroup.common, xpos.s, just.s, fs.test.subgroup, ff.test.subgroup,
fontfamily)
## Test for subgroup differences (random effects model):
col.studlab$labels[[j + 6]] <-
tg(text.subgroup.random, xpos.s, just.s, fs.test.subgroup, ff.test.subgroup,
fontfamily)
## First additional line:
col.studlab$labels[[j + 7]] <-
tg(text.addline1, xpos.s, just.s, fs.addline, ff.addline, fontfamily)
## Second additional line:
col.studlab$labels[[j + 8]] <-
tg(text.addline2, xpos.s, just.s, fs.addline, ff.addline, fontfamily)
##
if (by) {
## Subgroup labels:
strt <- j <- j + 8
for (i in seq_len(n.by)) {
col.studlab$labels[[strt + i]] <-
tg(subgroup.name[i], xpos.s, just.s,
fs.head, ff.head, fontfamily, col.subgroup)
j <- j + 1
}
## Common effect estimates:
strt <- j
for (i in seq_len(n.com.w)) {
col.studlab$labels[[strt + i]] <-
tg(text.common.w[i], xpos.s, just.s,
fs.common.labels, ff.common.labels, fontfamily, col.subgroup)
j <- j + 1
}
## Random effects estimates:
strt <- j
for (i in seq_len(n.ran.w)) {
col.studlab$labels[[strt + i]] <-
tg(text.random.w[i], xpos.s, just.s,
fs.random.labels, ff.random.labels, fontfamily, col.subgroup)
j <- j + 1
}
## Prediction interval:
strt <- j
for (i in seq_len(n.prd.w)) {
col.studlab$labels[[strt + i]] <-
tg(text.predict.w[i], xpos.s, just.s,
fs.predict.labels, ff.predict.labels, fontfamily, col.subgroup)
j <- j + 1
}
## Heterogeneity statistics:
strt <- j
for (i in seq_len(n.by)) {
col.studlab$labels[[strt + i]] <-
tg(hetstat.w[[i]], xpos.s, just.s,
fs.hetstat, ff.hetstat, fontfamily, col.subgroup)
j <- j + 1
}
## Test for effect in subgroup (common effect model):
strt <- j
for (i in seq_len(n.by)) {
col.studlab$labels[[strt + i]] <-
tg(text.effect.subgroup.common[[i]], xpos.s, just.s,
fs.test.effect.subgroup, ff.test.effect.subgroup,
fontfamily, col.subgroup)
j <- j + 1
}
## Test for effect in subgroup (random effects model):
strt <- j
for (i in seq_len(n.by)) {
col.studlab$labels[[strt + i]] <-
tg(text.effect.subgroup.random[[i]], xpos.s, just.s,
fs.test.effect.subgroup, ff.test.effect.subgroup,
fontfamily, col.subgroup)
j <- j + 1
}
}
##
fcs <- list(fs.study = fs.study, ff.study = ff.study,
fs.heading = fs.head, ff.heading = ff.head,
fs.common = fs.common, ff.common = ff.common,
fs.random = fs.random, ff.random = ff.random,
fs.predict = fs.predict, ff.predict = ff.predict,
by = by, n.by = n.by, col.subgroup = col.subgroup)
##
col.effect <- formatcol(labs[["lab.effect"]], effect.format,
yS, just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.ci <- formatcol(labs[["lab.ci"]], ci.format, yS, just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.effect.ci <-
formatcol(labs[["lab.effect.ci"]], effect.ci.format, yS,
if (revman5) "center" else just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.w.common <- formatcol(labs[["lab.w.common"]], Wc.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
col.w.random <- formatcol(labs[["lab.w.random"]], Wr.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.TE <- formatcol(labs[["lab.TE"]], TE.format, yS, just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
col.seTE <- formatcol(labs[["lab.seTE"]], seTE.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.cluster <-
formatcol(labs[["lab.cluster"]], cluster.format, yS,
if (as.character.cluster) "left" else just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.n.e <- formatcol(labs[["lab.n.e"]], Ne.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.n.c <- formatcol(labs[["lab.n.c"]], Nc.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.event.e <- formatcol(labs[["lab.event.e"]], Ee.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.event.c <- formatcol(labs[["lab.event.c"]], Ec.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.mean.e <- formatcol(labs[["lab.mean.e"]], Me.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.mean.c <- formatcol(labs[["lab.mean.c"]], Mc.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.sd.e <- formatcol(labs[["lab.sd.e"]], Se.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.sd.c <- formatcol(labs[["lab.sd.c"]], Sc.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.cor <- formatcol(labs[["lab.cor"]], cor.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.time.e <- formatcol(labs[["lab.time.e"]], Te.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.time.c <- formatcol(labs[["lab.time.c"]], Tc.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.pval <- formatcol(labs[["lab.pval"]], pval.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
if (metainf.metacum) {
col.tau2 <- formatcol(labs[["lab.tau2"]], tau2.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.tau <- formatcol(labs[["lab.tau"]], tau.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.I2 <- formatcol(labs[["lab.I2"]], I2.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
}
##
##
##
col.effect.calc <- formatcol(longer.effect, effect.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.ci.calc <- formatcol(longer.ci, ci.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.effect.ci.calc <- formatcol(longer.effect.ci, effect.ci.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.w.common.calc <- formatcol(longer.w.common, Wc.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
col.w.random.calc <- formatcol(longer.w.random, Wr.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.TE.calc <- formatcol(longer.TE, TE.format, yS, just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
col.seTE.calc <- formatcol(longer.seTE, seTE.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.cluster.calc <- formatcol(longer.cluster, cluster.format,
yS, just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.n.e.calc <- formatcol(longer.n.e, Ne.format, yS, just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
col.n.c.calc <- formatcol(longer.n.c, Nc.format, yS, just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
##
col.event.e.calc <- formatcol(longer.event.e, Ee.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
col.event.c.calc <- formatcol(longer.event.c, Ec.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.mean.e.calc <- formatcol(longer.mean.e, Me.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.mean.c.calc <- formatcol(longer.mean.c, Mc.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.sd.e.calc <- formatcol(longer.sd.e, Se.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.sd.c.calc <- formatcol(longer.sd.c, Sc.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.cor.calc <- formatcol(longer.cor, cor.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.time.e.calc <- formatcol(longer.time.e, Te.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.time.c.calc <- formatcol(longer.time.c, Tc.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
col.pval.calc <- formatcol(longer.pval, pval.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
##
if (metainf.metacum) {
col.tau2.calc <- formatcol(longer.tau2, tau2.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.tau.calc <- formatcol(longer.tau, tau.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
col.I2.calc <- formatcol(longer.I2, I2.format, yS, just.c, fcs,
fontfamily,
n.com, n.ran, n.prd)
}
##
col.forest <- list(eff = TEs.exclude,
low = lowTEs.exclude,
upp = uppTEs.exclude,
rows = yS[-1],
##
## "square" - normal confidence interval
## "diamond" - meta-analysis diamond
## "predict" - prediction interval
##
type = c(type.pooled, type.study),
##
col = c(col.diamond.lines.pooled, col.study),
col.square = c(col.diamond.pooled, col.square),
col.square.lines =
c(col.diamond.lines.pooled, col.square.lines),
col.inside = c(col.inside.pooled, col.inside),
##
col.diamond = c(col.diamond.pooled, col.square),
col.diamond.lines =
c(col.diamond.lines.pooled, col.square.lines),
##
lwd = lwd
)
##
## Sizes of squares
##
if (weight.study == "same") {
information <- rep(0.9, length(TEs))
}
else {
##
if (weight.study == "common")
information <- sqrt(w.commons)
else if (weight.study == "random")
information <- sqrt(w.randoms)
## Square height equal to 1 for most precise study result
if (!all(is.na(information)))
information <- information / max(information, na.rm = TRUE)
else
information <- rep(0.9, length(TEs))
## Same / maximum polygon height for all meta-analytical results
## (both overall and subgroup results)
information[is.na(information)] <- 1
}
##
col.forest$sizes <- information
col.forest$sizes <- col.forest$sizes * squaresize
##
## Width of column 3
col.forestwidth <- plotwidth
##
## Range on the x-axis for column 3
col.forest$range <- xlim
##
cols <- list(col.studlab = col.studlab,
col.effect = col.effect,
col.ci = col.ci,
col.effect.ci = col.effect.ci,
col.w.common = col.w.common,
col.w.random = col.w.random,
col.TE = col.TE,
col.seTE = col.seTE)
##
cols.calc <- list(col.studlab = col.studlab,
col.effect = col.effect.calc,
col.ci = col.ci.calc,
col.effect.ci = col.effect.ci.calc,
col.w.common = col.w.common.calc,
col.w.random = col.w.random.calc,
col.TE = col.TE.calc,
col.seTE = col.seTE.calc)
##
cols[["col.cluster"]] <- col.cluster
##
cols[["col.n.e"]] <- col.n.e
cols[["col.n.c"]] <- col.n.c
cols[["col.event.e"]] <- col.event.e
cols[["col.event.c"]] <- col.event.c
##
cols[["col.mean.e"]] <- col.mean.e
cols[["col.mean.c"]] <- col.mean.c
cols[["col.sd.e"]] <- col.sd.e
cols[["col.sd.c"]] <- col.sd.c
##
cols[["col.cor"]] <- col.cor
##
cols[["col.time.e"]] <- col.time.e
cols[["col.time.c"]] <- col.time.c
##
cols[["col.pval"]] <- col.pval
##
if (metainf.metacum) {
cols[["col.tau2"]] <- col.tau2
cols[["col.tau"]] <- col.tau
cols[["col.I2"]] <- col.I2
}
##
## Calculate
##
cols.calc[["col.cluster"]] <- col.cluster.calc
##
cols.calc[["col.n.e"]] <- col.n.e.calc
cols.calc[["col.n.c"]] <- col.n.c.calc
cols.calc[["col.event.e"]] <- col.event.e.calc
cols.calc[["col.event.c"]] <- col.event.c.calc
##
cols.calc[["col.mean.e"]] <- col.mean.e.calc
cols.calc[["col.mean.c"]] <- col.mean.c.calc
cols.calc[["col.sd.e"]] <- col.sd.e.calc
cols.calc[["col.sd.c"]] <- col.sd.c.calc
##
cols.calc[["col.cor"]] <- col.cor.calc
##
cols.calc[["col.time.e"]] <- col.time.e.calc
cols.calc[["col.time.c"]] <- col.time.c.calc
##
cols.calc[["col.pval"]] <- col.pval.calc
##
if (metainf.metacum) {
cols.calc[["col.tau2"]] <- col.tau2.calc
cols.calc[["col.tau"]] <- col.tau.calc
cols.calc[["col.I2"]] <- col.I2.calc
}
##
if (newcols) {
##
## Check just.addcols
##
if (length(leftcols.new) > 0)
if (length(just.addcols.left) != 1) {
if (length(just.addcols.left) != length(leftcols.new))
stop("Length of argument 'just.addcols.left' must be one or ",
"same as number of additional columms in argument 'leftcols'.")
}
else
just.addcols.left <- rep(just.addcols.left, length(leftcols.new))
##
if (length(rightcols.new) > 0)
if (length(just.addcols.right) != 1) {
if (length(just.addcols.right) != length(rightcols.new))
stop("Length of argument 'just.addcols.right' must be one or ",
"same as number of additional columms in argument 'rightcols'.")
}
else
just.addcols.right <- rep(just.addcols.right, length(rightcols.new))
##
## Check digits.addcols
##
if (length(leftcols.new) > 0)
if (length(digits.addcols.left) != 1) {
if (length(digits.addcols.left) != length(leftcols.new))
stop("Length of argument 'digits.addcols.left' must be one or ",
"same as number of additional columms in argument 'leftcols'.")
}
else
digits.addcols.left <- rep(digits.addcols.left, length(leftcols.new))
##
if (length(rightcols.new) > 0)
if (length(digits.addcols.right) != 1) {
if (length(digits.addcols.right) != length(rightcols.new))
stop("Length of argument 'digits.addcols.right' must be one or ",
"same as number of additional columms in argument 'rightcols'.")
}
else
digits.addcols.right <- rep(digits.addcols.right, length(rightcols.new))
##
if (by) {
for (i in seq_along(rightcols.new)) {
tname <- paste0("col.", rightcols.new[i])
if (length(dataset1[[rightcols.new[i]]]) != 0)
tmp.r <- dataset1[[rightcols.new[i]]]
else if (length(dataset2[[rightcols.new[i]]]) != 0)
tmp.r <- dataset2[[rightcols.new[i]]]
else
stop("Variable '", rightcols.new[i],
"' not available in meta-analysis object.",
call. = FALSE)
##
if (!is.character(tmp.r)) {
if (is.factor(tmp.r))
tmp.r <- as.character(tmp.r)
else if (missing.addcols.right &
all(is_wholenumber(tmp.r), na.rm = TRUE))
tmp.r <- formatN(tmp.r, digits = 0,
text.NA = lab.NA, big.mark = big.mark)
else if (is.numeric(tmp.r)) {
if (rightcols.new[i] == "pval")
tmp.r <- formatPT(tmp.r, digits = digits.pval,
big.mark = big.mark)
else if (rightcols.new[i] == "tau2")
tmp.r <- formatPT(tmp.r, digits = digits.tau2,
big.mark = big.mark)
else if (rightcols.new[i] == "tau")
tmp.r <- formatPT(tmp.r, digits = digits.tau,
big.mark = big.mark)
else if (rightcols.new[i] == "I2") {
format.r <- formatN(100 * tmp.r, digits.I2, lab.NA)
tmp.r <- ifelse(format.r == lab.NA, lab.NA,
paste0(format.r, "%"))
}
else
tmp.r <- formatN(tmp.r, digits = digits.addcols.right[i],
text.NA = "", big.mark = big.mark)
}
}
##
tmp.r <- ifelse(is.na(tmp.r), lab.NA, tmp.r)
##
## Check for "\n" in label of new column
##
clines <- twolines(rightlabs.new[i], rightcols.new[i])
##
if (clines$newline) {
lab.new <- clines$bottom
longer.new <- clines$longer
}
else
lab.new <- longer.new <- rightlabs.new[i]
cols[[tname]] <-
formatcol(lab.new,
c("", "", "", rep("", length(TE.w)), tmp.r),
yS,
if (rightcols.new[i] %in%
c("pval", "tau2", "tau", "I2", "Q", "pval.Q"))
just
else
just.addcols.right[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
cols.calc[[tname]] <- formatcol(longer.new,
c("", "", "", rep("", length(TE.w)),
tmp.r),
yS,
just.addcols.right[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
}
for (i in seq_along(leftcols.new)) {
tname <- paste0("col.", leftcols.new[i])
if (length(dataset1[[leftcols.new[i]]]) != 0)
tmp.l <- dataset1[[leftcols.new[i]]]
else if (length(dataset2[[leftcols.new[i]]]) != 0)
tmp.l <- dataset2[[leftcols.new[i]]]
else
stop("Variable '", leftcols.new[i],
"' not available in meta-analysis object.",
call. = FALSE)
##
if (!is.character(tmp.l)) {
if (is.factor(tmp.l))
tmp.l <- as.character(tmp.l)
else if (missing.addcols.left &
all(is_wholenumber(tmp.l), na.rm = TRUE))
tmp.l <- formatN(tmp.l, digits = 0,
text.NA = lab.NA, big.mark = big.mark)
else if (is.numeric(tmp.l)) {
if (leftcols.new[i] == "pval")
tmp.l <- formatPT(tmp.l, digits = digits.pval,
big.mark = big.mark)
else if (leftcols.new[i] == "tau2")
tmp.l <- formatPT(tmp.l, digits = digits.tau2,
big.mark = big.mark)
else if (leftcols.new[i] == "tau")
tmp.l <- formatPT(tmp.l, digits = digits.tau,
big.mark = big.mark)
else if (leftcols.new[i] == "I2") {
format.l <- formatN(100 * tmp.l, digits.I2, lab.NA)
tmp.l <- ifelse(format.l == lab.NA, lab.NA,
paste0(format.l, "%"))
}
else
tmp.l <- formatN(tmp.l, digits = digits.addcols.left[i],
text.NA = "", big.mark = big.mark)
}
}
##
tmp.l <- ifelse(is.na(tmp.l), lab.NA, tmp.l)
##
## Check for "\n" in label of new column
##
clines <- twolines(leftlabs.new[i], leftcols.new[i])
##
if (clines$newline) {
lab.new <- clines$bottom
longer.new <- clines$longer
}
else
lab.new <- longer.new <- leftlabs.new[i]
##
cols[[tname]] <-
formatcol(lab.new,
c("", "", "",
rep("", length(TE.w)), tmp.l),
yS,
if (leftcols.new[i] %in%
c("pval", "tau2", "tau", "I2", "Q", "pval.Q"))
just
else
just.addcols.left[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
##
cols.calc[[tname]] <- formatcol(longer.new,
c("", "", "",
rep("", length(TE.w)), tmp.l),
yS,
just.addcols.left[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
}
}
else {
for (i in seq_along(rightcols.new)) {
tname <- paste0("col.", rightcols.new[i])
if (length(dataset1[[rightcols.new[i]]]) != 0)
tmp.r <- dataset1[[rightcols.new[i]]]
else if (length(dataset2[[rightcols.new[i]]]) != 0)
tmp.r <- dataset2[[rightcols.new[i]]]
else
stop("Variable '", rightcols.new[i],
"' not available in meta-analysis object.",
call. = FALSE)
##
if (!is.character(tmp.r)) {
if (is.factor(tmp.r))
tmp.r <- as.character(tmp.r)
else if (missing.addcols.left &
all(is_wholenumber(tmp.r), na.rm = TRUE))
tmp.r <- formatN(tmp.r, digits = 0,
text.NA = lab.NA, big.mark = big.mark)
else if (is.numeric(tmp.r)) {
if (rightcols.new[i] == "pval")
tmp.r <- formatPT(tmp.r, digits = digits.pval,
big.mark = big.mark,
lab = FALSE, labval = "",
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA")
else if (rightcols.new[i] == "tau2")
tmp.r <- formatPT(tmp.r, digits = digits.tau2,
big.mark = big.mark,
lab = FALSE, labval = "",
lab.NA = "NA")
else if (rightcols.new[i] == "tau")
tmp.r <- formatPT(tmp.r, digits = digits.tau,
big.mark = big.mark,
lab = FALSE, labval = "",
lab.NA = "NA")
else if (rightcols.new[i] == "I2")
tmp.r <-
paste0(formatN(100 * tmp.r, digits.I2, "NA"), "%")
else
tmp.r <- formatN(tmp.r, digits = digits.addcols.right[i],
text.NA = "", big.mark = big.mark)
}
}
##
tmp.r <- ifelse(is.na(tmp.r), "", tmp.r)
##
## Check for "\n" in label of new column
##
clines <- twolines(rightlabs.new[i], rightcols.new[i])
##
if (clines$newline) {
lab.new <- clines$bottom
longer.new <- clines$longer
}
else
lab.new <- longer.new <- rightlabs.new[i]
##
cols[[tname]] <-
formatcol(lab.new,
c("", "", "", tmp.r),
yS,
if (rightcols.new[i] %in% c("pval", "tau2", "tau", "I2"))
just
else
just.addcols.right[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
cols.calc[[tname]] <- formatcol(longer.new,
c("", "", "", tmp.r),
yS,
just.addcols.right[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
}
for (i in seq_along(leftcols.new)) {
tname <- paste0("col.", leftcols.new[i])
if (length(dataset1[[leftcols.new[i]]]) != 0)
tmp.l <- dataset1[[leftcols.new[i]]]
else if (length(dataset2[[leftcols.new[i]]]) != 0)
tmp.l <- dataset2[[leftcols.new[i]]]
else
stop("Variable '", leftcols.new[i],
"' not available in meta-analysis object.",
call. = FALSE)
##
if (!is.character(tmp.l)) {
if (is.factor(tmp.l))
tmp.l <- as.character(tmp.l)
else if (missing.addcols.left &
all(is_wholenumber(tmp.l), na.rm = TRUE))
tmp.l <- formatN(tmp.l, digits = 0,
text.NA = lab.NA, big.mark = big.mark)
else if (is.numeric(tmp.l)) {
if (leftcols.new[i] == "pval")
tmp.l <- formatPT(tmp.l, digits = digits.pval,
big.mark = big.mark,
lab = FALSE, labval = "",
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA")
else if (leftcols.new[i] == "tau2")
tmp.l <- formatPT(tmp.l, digits = digits.tau2,
big.mark = big.mark,
lab = FALSE, labval = "",
lab.NA = "NA")
else if (leftcols.new[i] == "tau")
tmp.l <- formatPT(tmp.l, digits = digits.tau,
big.mark = big.mark,
lab = FALSE, labval = "",
lab.NA = "NA")
else if (leftcols.new[i] == "I2")
tmp.l <-
paste0(formatN(100 * tmp.l, digits.I2, "NA"), "%")
else
tmp.l <- formatN(tmp.l, digits = digits.addcols.left[i],
text.NA = "", big.mark = big.mark)
}
}
##
tmp.l <- ifelse(is.na(tmp.l), "", tmp.l)
##
## Check for "\n" in label of new column
##
clines <- twolines(leftlabs.new[i], leftcols.new[i])
##
if (clines$newline) {
lab.new <- clines$bottom
longer.new <- clines$longer
}
else
lab.new <- longer.new <- leftlabs.new[i]
##
cols[[tname]] <-
formatcol(lab.new,
c("", "", "", tmp.l),
yS,
if (leftcols.new[i] %in% c("pval", "tau2", "tau", "I2"))
just
else
just.addcols.left[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
cols.calc[[tname]] <- formatcol(longer.new,
c("", "", "", tmp.l),
yS,
just.addcols.left[i],
fcs, fontfamily,
n.com, n.ran, n.prd)
}
}
}
##
col.label.e <- tgl(label.e, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
col.label.c <- tgl(label.c, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
##
##
if (newline.studlab)
col.add.studlab <- tgl(add.studlab, xpos.s, just.s, fs.head, ff.head,
fontfamily)
##
if (newline.effect)
col.add.effect <- tgl(add.effect, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.ci)
col.add.ci <- tgl(add.ci, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
if (newline.effect.ci)
col.add.effect.ci <- tgl(add.effect.ci,
if (revman5) 0.5 else xpos.c,
if (revman5) "center" else just.c,
fs.head, ff.head, fontfamily)
##
if (newline.w.common)
col.add.w.common <- tgl(add.w.common, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.w.random)
col.add.w.random <- tgl(add.w.random, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.TE)
col.add.TE <- tgl(add.TE, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.seTE)
col.add.seTE <- tgl(add.seTE, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
if (newline.cluster)
col.add.cluster <-
tgl(add.cluster,
if (as.character.cluster) 0 else xpos.c,
if (as.character.cluster) "left" else just.c,
fs.head, ff.head, fontfamily)
##
if (newline.n.e)
col.add.n.e <- tgl(add.n.e, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
if (newline.n.c)
col.add.n.c <- tgl(add.n.c, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
if (newline.event.e)
col.add.event.e <- tgl(add.event.e, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.event.c)
col.add.event.c <- tgl(add.event.c, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.mean.e)
col.add.mean.e <- tgl(add.mean.e, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.mean.c)
col.add.mean.c <- tgl(add.mean.c, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.sd.e)
col.add.sd.e <- tgl(add.sd.e, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
if (newline.sd.c)
col.add.sd.c <- tgl(add.sd.c, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
if (newline.cor)
col.add.cor <- tgl(add.cor, xpos.c, just.c, fs.head, ff.head, fontfamily)
##
if (newline.time.e)
col.add.time.e <- tgl(add.time.e, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (newline.time.c)
col.add.time.c <- tgl(add.time.c, xpos.c, just.c, fs.head, ff.head,
fontfamily)
##
if (metainf.metacum) {
if (newline.pval)
col.add.pval <- tgl(add.pval, xpos.c, just.c, fs.head, ff.head,
fontfamily)
if (newline.tau2)
col.add.tau2 <- tgl(add.tau2, xpos.c, just.c, fs.head, ff.head,
fontfamily)
if (newline.tau)
col.add.tau <- tgl(add.tau, xpos.c, just.c, fs.head, ff.head,
fontfamily)
if (newline.I2)
col.add.I2 <- tgl(add.I2, xpos.c, just.c, fs.head, ff.head,
fontfamily)
}
##
leftcols <- paste0("col.", leftcols)
rightcols <- paste0("col.", rightcols)
##
##
## (12) Calculate width of columns in forest plot
##
##
## Exclude lines with summary measures from calculation of column
## width for study labels
##
del.lines <- NULL
##
if (!calcwidth.common)
del.lines <- 1 + seq_len(n.com)
##
if (!calcwidth.random)
del.lines <-
c(del.lines, 1 + n.com + seq_len(n.ran))
##
if (!calcwidth.predict)
del.lines <-
c(del.lines, 1 + n.com + n.ran + seq_len(n.prd))
##
if (!calcwidth.hetstat)
del.lines <-
c(del.lines, 1 + n.com + n.ran + n.prd + 1:2)
##
if (!calcwidth.tests)
del.lines <-
c(del.lines, 1 + n.com + n.ran + n.prd + 2 + 1:4)
##
if (!calcwidth.addline)
del.lines <-
c(del.lines, 1 + n.com + n.ran + n.prd + 2 + 4 + 1:2)
##
if (by) {
if (!calcwidth.subgroup)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + seq_len(n.by))
##
if (!calcwidth.common)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + n.by +
seq_len(n.by * n.com))
##
if (!calcwidth.random)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + n.by +
n.by * n.com + seq_len(n.by * n.ran))
##
if (!calcwidth.predict)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + n.by +
n.by * n.com + n.by * n.ran + seq_len(n.by * n.prd))
##
if (!calcwidth.hetstat)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + n.by +
n.by * n.com + n.by * n.ran + n.by * n.prd +
seq_len(n.by))
## test for effect (CE)
if (!calcwidth.tests)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + n.by +
n.by * n.com + n.by * n.ran + n.by * n.prd +
n.by + seq_len(n.by))
## test for effect (RE)
if (!calcwidth.tests)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + n.by +
n.by * n.com + n.by * n.ran + n.by * n.prd +
n.by + n.by + seq_len(n.by))
}
##
if (lsel) {
for (i in seq_along(leftcols)) {
if (i == 1) {
if (leftcols[[i]] == "col.studlab" & !is.null(del.lines))
x1 <- unit.c(wcalc(cols.calc[[leftcols[i]]]$labels[-del.lines]))
else
x1 <- unit.c(wcalc(cols.calc[[leftcols[i]]]$labels))
}
else {
if (leftcols[[i]] == "col.studlab" & !is.null(del.lines))
x1 <- unit.c(x1,
colgap.left,
wcalc(cols.calc[[leftcols[i]]]$labels[-del.lines]))
else
x1 <- unit.c(x1,
if (leftcols[[i - 1]] == "col.studlab")
colgap.studlab
else colgap.left,
wcalc(cols.calc[[leftcols[i]]]$labels))
}
}
##
x1 <- unit.c(x1, colgap.forest.left, col.forestwidth)
}
else
x1 <- unit.c(col.forestwidth)
##
if (rsel) {
for (i in seq_along(rightcols)) {
x1 <- unit.c(x1,
if (i == 1) colgap.forest.right else colgap.right,
wcalc(cols.calc[[rightcols[i]]]$labels))
}
}
##
##
## (13) Process arguments smlab, label.left and label.right
##
##
if (by) {
addline <- addrow * (!any(c(overall.hetstat,
test.overall.common, test.overall.random,
resid.hetstat,
test.subgroup.common, test.subgroup.random)))
##
nrow <- max(addline + c(yTE, yTE.common, yTE.random, yPredict,
yStats, yTE.w), na.rm = TRUE)
}
else {
addline <- addrow * (!any(c(test.overall.common, test.overall.random,
overall.hetstat)))
##
nrow <- max(addline + c(yTE, yTE.common, yTE.random, yPredict,
yStats), na.rm = TRUE)
}
##
## Determine minimal value on y-axis for lines of common / random
## effect estimate or reference line
##
n.lines <- sum(!is.na(yStats))
ymin.line <- max(addrow | addrow.overall,
n.lines + (n.lines > 0) * addrows.below.overall)
##
if (!by) {
if (overall & (common | random | prediction)) {
if (ymin.line == addrows.below.overall & !(!addrow.overall | !addrow))
ymin.line <- ymin.line + 1
##
if ((!missing.text.addline1 | !missing.text.addline2) &
(!missing.text.addline1 + !missing.text.addline2) == n.lines &
!(!addrow.overall | !addrow))
ymin.line <- ymin.line + 1
##
if (addrow.overall & !addrow & n.lines == 0)
ymin.line <- ymin.line - 1
}
##
if (!overall & addrow & n.lines == 0)
ymin.line <- ymin.line - 1
}
else {
if (!overall & !overall.hetstat & addrow &
((n.lines > !missing.text.addline1 + !missing.text.addline2) |
n.lines == 0))
ymin.line <- ymin.line - 1
}
##
if (hetstat %in% c("common", "random") &
(!missing.text.addline1 | !missing.text.addline2))
ymin.line <- ymin.line + 1
##
ymin.common <- spacing * (ymin.line + prediction * n.prd + random * n.ran + 0.5)
ymin.random <- spacing * (ymin.line + prediction * n.prd + 0.5)
ymin.ref <- spacing * (ymin.line + (!(overall | overall.hetstat) & addrow))
##
ymax <- spacing * (nrow - ifelse(is.na(yHeadadd), 1, 2) - 1 * addrow)
##
## Position on y-axis of left and right labels (at bottom of forest plot)
##
y.bottom.lr <- ymin.line - 2.5 + (!(overall | overall.hetstat) & addrow)
##
## Position on y-axis of label below x-axis
##
xlab.ypos <- y.bottom.lr - 1 * (print.label & bottom.lr) -
1 * (print.label & bottom.lr & (newline.lr | newline.ll))
##
## Summary label at top of forest plot
##
smlab1 <- tgl(smlab1, unit(smlab.pos, "native"), "center",
fs.smlab, ff.smlab,
fontfamily, rows = 1 + (!is.na(yHeadadd) & !newline.smlab))
##
if (newline.smlab)
smlab2 <- tgl(smlab2, unit(smlab.pos, "native"),
"center", fs.smlab, ff.smlab, fontfamily,
rows = 2)
##
## Left and right label on x-axis:
##
if (!bottom.lr & !is.na(ref)) {
row1.lr <- if (!newline & (newline.ll | newline.lr) & !addrow)
1
else if (!is.na(yHeadadd) & addrow)
2
else if (is.na(yHeadadd))
1
else
2
##
ll1 <- tgl(ll1, unit(ref - (xlim[2] - xlim[1]) / 30, "native"),
"right", fs.lr, ff.lr, fontfamily, col.label.left,
rows = row1.lr)
##
if (newline.ll)
ll2 <- tgl(ll2, unit(ref - (xlim[2] - xlim[1]) / 30, "native"),
"right", fs.lr, ff.lr, fontfamily, col.label.left,
rows = row1.lr + 1)
##
lr1 <- tgl(lr1, unit(ref + (xlim[2] - xlim[1]) / 30, "native"),
"left", fs.lr, ff.lr, fontfamily, col.label.right,
rows = row1.lr)
##
if (newline.lr)
lr2 <- tgl(lr2, unit(ref + (xlim[2] - xlim[1]) / 30, "native"),
"left", fs.lr, ff.lr, fontfamily, col.label.right,
rows = row1.lr + 1)
}
##
##
## (14) Generate forest plot
##
##
if (new)
grid.newpage()
##
pushViewport(viewport(layout = grid.layout(
nrow,
length(x1),
widths = x1,
heights = unit(spacing, "lines"))))
##
## Left side of forest plot
##
j <- 1
##
if (lsel) {
for (i in seq_along(leftcols)) {
add.text(cols[[leftcols[i]]], j)
##
if (!is.na(yHeadadd)) {
if (!is.null(label.e.attach)) {
if (leftcols[i] == paste0("col.", label.e.attach))
add.text(col.label.e, j)
}
else if (metabin) {
if (leftcols[i] == "col.n.e" & just.c == "right")
add.text(col.label.e, j)
else if (leftcols[i] == "col.event.e" &
just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
else if (metacont) {
if (leftcols[i] == "col.sd.e" & just.c == "right")
add.text(col.label.e, j)
else if (leftcols[i] == "col.mean.e" &
just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
else if (metainc) {
if (leftcols[i] == "col.time.e" & just.c == "right")
add.text(col.label.e, j)
else if (leftcols[i] == "col.event.e" &
just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
else if (metamean) {
if (revman5 & leftcols[i] == "col.n.e" &
just.c == "right")
add.text(col.label.e, j)
else if (!revman5 & leftcols[i] == "col.sd.e" &
just.c == "right")
add.text(col.label.e, j)
else if (leftcols[i] == "col.sd.e" &
just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
##
if (!is.null(label.c.attach)) {
if (leftcols[i] == paste0("col.", label.c.attach))
add.text(col.label.c, j)
}
else if (metabin) {
if (leftcols[i] == "col.n.c" & just.c == "right")
add.text(col.label.c, j)
else if (leftcols[i] == "col.event.c" &
just.c %in% c("left", "center"))
add.text(col.label.c, j)
}
else if (metacont) {
if (leftcols[i] == "col.sd.c" & just.c == "right")
add.text(col.label.c, j)
else if (leftcols[i] == "col.mean.c" &
just.c %in% c("left", "center"))
add.text(col.label.c, j)
}
else if (metainc) {
if (leftcols[i] == "col.time.c" & just.c == "right")
add.text(col.label.c, j)
else if (leftcols[i] == "col.event.c" &
just.c %in% c("left", "center"))
add.text(col.label.c, j)
}
##
if (newline.studlab & leftcols[i] == "col.studlab")
add.text(col.add.studlab, j)
if (newline.effect & leftcols[i] == "col.effect")
add.text(col.add.effect, j)
if (newline.ci & leftcols[i] == "col.ci")
add.text(col.add.ci, j)
if (newline.effect.ci & leftcols[i] == "col.effect.ci")
add.text(col.add.effect.ci, j)
if (newline.w.common & leftcols[i] == "col.w.common")
add.text(col.add.w.common, j)
if (newline.w.random & leftcols[i] == "col.w.random")
add.text(col.add.w.random, j)
if (newline.TE & leftcols[i] == "col.TE")
add.text(col.add.TE, j)
if (newline.seTE & leftcols[i] == "col.seTE")
add.text(col.add.seTE, j)
if (newline.cluster & leftcols[i] == "col.cluster")
add.text(col.add.cluster, j)
if (newline.n.e & leftcols[i] == "col.n.e")
add.text(col.add.n.e, j)
if (newline.n.c & leftcols[i] == "col.n.c")
add.text(col.add.n.c, j)
if (newline.event.e & leftcols[i] == "col.event.e")
add.text(col.add.event.e, j)
if (newline.event.c & leftcols[i] == "col.event.c")
add.text(col.add.event.c, j)
if (newline.mean.e & leftcols[i] == "col.mean.e")
add.text(col.add.mean.e, j)
if (newline.mean.c & leftcols[i] == "col.mean.c")
add.text(col.add.mean.c, j)
if (newline.sd.e & leftcols[i] == "col.sd.e")
add.text(col.add.sd.e, j)
if (newline.sd.c & leftcols[i] == "col.sd.c")
add.text(col.add.sd.c, j)
if (newline.cor & leftcols[i] == "col.cor")
add.text(col.add.cor, j)
if (newline.time.e & leftcols[i] == "col.time.e")
add.text(col.add.time.e, j)
if (newline.time.c & leftcols[i] == "col.time.c")
add.text(col.add.time.c, j)
##
if (metainf.metacum) {
if (newline.pval & leftcols[i] == "col.pval")
add.text(col.add.pval, j)
if (newline.tau2 & leftcols[i] == "col.tau2")
add.text(col.add.tau2, j)
if (newline.tau & leftcols[i] == "col.tau")
add.text(col.add.tau, j)
if (newline.I2 & leftcols[i] == "col.I2")
add.text(col.add.I2, j)
}
##
## Add text in first line of forest plot for new columns
##
if (newcols)
if (length(leftcols.new) > 0 &
leftcols[i] %in% paste0("col.", leftcols.new)) {
sel <- paste0("col.", leftcols.new) == leftcols[i]
##
## Check for "\n" in label of new column
##
clines <- twolines(leftlabs.new[sel], leftcols[i])
##
just.new <- just.addcols.left[sel]
##
if (just.new == "left")
xpos.new <- 0
else if (just.new == "center")
xpos.new <- 0.5
else if (just.new == "right")
xpos.new <- 1
##
## Add first line
##
if (clines$newline)
add.text(tgl(clines$top, xpos.new, just.new, fs.head, ff.head,
fontfamily), j)
}
}
##
j <- j + 2
}
}
##
## Produce forest plot
##
draw.lines(col.forest, j,
ref, TE.common, unique(TE.random),
overall, common, random, prediction,
ymin.common, ymin.random, ymin.ref,
ymax + 0.5 * header.line * addrow,
lwd, lty.common, lty.random, col.common, col.random,
xlim[1], xlim[2],
lower.equi, upper.equi, lty.equi, col.equi,
fill.lower.equi, fill.upper.equi)
##
draw.axis(col.forest, j, yS, log.xaxis, at, label,
fs.axis, ff.axis, fontfamily, lwd,
xlim, notmiss.xlim)
##
if (bottom.lr) {
add.text(smlab1, j, xscale = col.forest$range)
##
if (newline.smlab)
add.text(smlab2, j, xscale = col.forest$range)
}
##
if (print.label) {
if (!bottom.lr) {
if (!is.na(ref)) {
add.text(ll1, j, xscale = col.forest$range)
##
if (newline.ll)
add.text(ll2, j, xscale = col.forest$range)
##
add.text(lr1, j, xscale = col.forest$range)
##
if (newline.lr)
add.text(lr2, j, xscale = col.forest$range)
}
}
else {
add.label(ll1, j,
unit(ref - (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr, "lines"),
"right",
fs.lr, ff.lr, col.label.left, fontfamily,
xscale = col.forest$range)
##
if (newline.ll)
add.label(ll2, j,
unit(ref - (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr - 1, "lines"),
"right",
fs.lr, ff.lr, col.label.left, fontfamily,
xscale = col.forest$range)
##
add.label(lr1, j,
unit(ref + (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr, "lines"),
"left",
fs.lr, ff.lr, col.label.right, fontfamily,
xscale = col.forest$range)
##
if (newline.lr)
add.label(lr2, j,
unit(ref + (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr - 1, "lines"),
"left",
fs.lr, ff.lr, col.label.right, fontfamily,
xscale = col.forest$range)
}
}
##
add.xlab(col.forest, j, xlab, xlab.add, newline.xlab,
xlab.pos, xlab.ypos, fs.xlab, ff.xlab,
fontfamily)
##
draw.forest(col.forest, j)
##
j <- j + 2
##
##
## Right side of forest plot
##
##
if (rsel) {
for (i in seq_along(rightcols)) {
add.text(cols[[rightcols[i]]], j)
##
if (!is.na(yHeadadd)) {
if (!is.null(label.e.attach)) {
if (rightcols[i] == paste0("col.", label.e.attach))
add.text(col.label.e, j)
}
else if (metabin) {
if (rightcols[i] == "col.n.e" & just.c == "right")
add.text(col.label.e, j)
else if (rightcols[i] == "col.event.e" &
just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
else if (metacont) {
if (rightcols[i] == "col.sd.e" & just.c == "right")
add.text(col.label.e, j)
else if (rightcols[i] == "col.mean.e" &
just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
else if (metainc) {
if (rightcols[i] == "col.time.e" & just.c == "right")
add.text(col.label.e, j)
else if (rightcols[i] == "col.event.e" &
just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
else if (metamean) {
if (revman5 & rightcols[i] == "col.n.e" & just.c == "right")
add.text(col.label.e, j)
else if (!revman5 & rightcols[i] == "col.sd.e" & just.c == "right")
add.text(col.label.e, j)
else if (rightcols[i] == "col.sd.e" & just.c %in% c("left", "center"))
add.text(col.label.e, j)
}
##
if (!is.null(label.c.attach)) {
if (rightcols[i] == paste0("col.", label.c.attach))
add.text(col.label.c, j)
}
else if (metabin) {
if (rightcols[i] == "col.n.c" & just.c == "right")
add.text(col.label.c, j)
else if (rightcols[i] == "col.event.c" &
just.c %in% c("left", "center"))
add.text(col.label.c, j)
}
else if (metacont) {
if (rightcols[i] == "col.sd.c" & just.c == "right")
add.text(col.label.c, j)
else if (rightcols[i] == "col.mean.c" &
just.c %in% c("left", "center"))
add.text(col.label.c, j)
}
else if (metainc) {
if (rightcols[i] == "col.time.c" & just.c == "right")
add.text(col.label.c, j)
else if (rightcols[i] == "col.event.c" &
just.c %in% c("left", "center"))
add.text(col.label.c, j)
}
##
if (newline.studlab & rightcols[i] == "col.studlab")
add.text(col.add.studlab, j)
if (newline.effect & rightcols[i] == "col.effect")
add.text(col.add.effect, j)
if (newline.ci & rightcols[i] == "col.ci")
add.text(col.add.ci, j)
if (newline.effect.ci & rightcols[i] == "col.effect.ci")
add.text(col.add.effect.ci, j)
if (newline.w.common & rightcols[i] == "col.w.common")
add.text(col.add.w.common, j)
if (newline.w.random & rightcols[i] == "col.w.random")
add.text(col.add.w.random, j)
if (newline.TE & rightcols[i] == "col.TE")
add.text(col.add.TE, j)
if (newline.seTE & rightcols[i] == "col.seTE")
add.text(col.add.seTE, j)
if (newline.cluster & rightcols[i] == "col.cluster")
add.text(col.add.cluster, j)
if (newline.n.e & rightcols[i] == "col.n.e")
add.text(col.add.n.e, j)
if (newline.n.c & rightcols[i] == "col.n.c")
add.text(col.add.n.c, j)
if (newline.event.e & rightcols[i] == "col.event.e")
add.text(col.add.event.e, j)
if (newline.event.c & rightcols[i] == "col.event.c")
add.text(col.add.event.c, j)
if (newline.mean.e & rightcols[i] == "col.mean.e")
add.text(col.add.mean.e, j)
if (newline.mean.c & rightcols[i] == "col.mean.c")
add.text(col.add.mean.c, j)
if (newline.sd.e & rightcols[i] == "col.sd.e")
add.text(col.add.sd.e, j)
if (newline.sd.c & rightcols[i] == "col.sd.c")
add.text(col.add.sd.c, j)
if (newline.cor & rightcols[i] == "col.cor")
add.text(col.add.cor, j)
if (newline.time.e & rightcols[i] == "col.time.e")
add.text(col.add.time.e, j)
if (newline.time.c & rightcols[i] == "col.time.c")
add.text(col.add.time.c, j)
##
if (metainf.metacum) {
if (newline.pval & rightcols[i] == "col.pval")
add.text(col.add.pval, j)
if (newline.tau2 & rightcols[i] == "col.tau2")
add.text(col.add.tau2, j)
if (newline.tau & rightcols[i] == "col.tau")
add.text(col.add.tau, j)
if (newline.I2 & rightcols[i] == "col.I2")
add.text(col.add.I2, j)
}
##
## Add text in first line of forest plot for new columns
##
if (newcols)
if (length(rightcols.new) > 0 &
rightcols[i] %in% paste0("col.", rightcols.new)) {
sel <- paste0("col.", rightcols.new) == rightcols[i]
##
## Check for "\n" in label of new column
##
clines <- twolines(rightlabs.new[sel], rightcols[i])
##
just.new <- just.addcols.right[sel]
##
if (just.new == "left")
xpos.new <- 0
else if (just.new == "center")
xpos.new <- 0.5
else if (just.new == "right")
xpos.new <- 1
##
## Add first line
##
if (clines$newline)
add.text(tgl(clines$top, xpos.new, just.new,
fs.head, ff.head, fontfamily), j)
}
}
##
j <- j + 2
}
}
##
popViewport()
##
## Add header line
##
pushViewport(viewport(layout = grid.layout(
nrow,
length(x1),
widths = x1,
heights = unit(spacing, "lines"))))
##
if (jama)
hcols <- lsel * 2 * length(leftcols)
else
hcols <-
lsel * 2 * length(leftcols) + 1 + rsel * 2 * length(rightcols)
##
if (header.line) {
if (header.line.pos == "both") {
for (i in seq_len(hcols)) {
pushViewport(viewport(layout.pos.col = i, xscale = col.forest$range))
grid.lines(x = unit(0:1, "npc"),
y = unit(nrow + 0.5 * addrow, "lines"),
gp = gpar(lwd = lwd))
popViewport()
}
}
##
for (i in seq_len(hcols)) {
pushViewport(viewport(layout.pos.col = i, xscale = col.forest$range))
grid.lines(x = unit(0:1, "npc"),
y = unit(ymax + 0.5 * addrow, "lines"),
gp = gpar(lwd = lwd))
popViewport()
}
}
##
## Add JAMA lines
##
if (jama & header.line & !by) {
for (i in seq_len(hcols)) {
pushViewport(viewport(layout.pos.col = i, xscale = col.forest$range))
for (j in seq_len(k.all + n.com * common + n.ran * random +
n.prd * prediction))
grid.lines(x = unit(0:1, "npc"),
y = unit(ymax + 0.5 * addrow - j, "lines"),
gp = gpar(lwd = 0.5 * lwd, col = col.subgroup))
popViewport()
}
}
res <- list(xlim = xlim, addrows.below.overall = addrows.below.overall,
##
colgap = colgap,
colgap.left = colgap.left,
colgap.right = colgap.right,
colgap.studlab = colgap.studlab,
colgap.forest = colgap.forest.left,
colgap.forest.left = colgap.forest,
colgap.forest.right = colgap.forest.right,
##
studlab = studlab,
TE.format = TE.format,
seTE.format = seTE.format,
cluster.format = cluster.format,
effect.format = effect.format,
ci.format = ci.format)
##
if (metainf.metacum) {
res$pval.format <- pval.format
res$tau2.format <- tau2.format
res$tau.format <- tau.format
res$I2.format <- I2.format
}
invisible(res)
}
Try the meta package in your browser
Any scripts or data that you put into this service are public.
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.