R/forest.R
In guido-s/meta: General Package for Meta-Analysis
Defines functions
.forestArgs
plot.meta
forest.meta
Documented in
.forestArgs
forest.meta
plot.meta
#' Forest plot to display the result of a meta-analysis
#'
#' @description
#' Draw a forest plot (using grid graphics system) in the active
#' graphics window or store the forest plot in a file.
#'
#' @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 of pooled common effect estimate.
#' @param lty.random Line type of pooled random effects estimate.
#' @param col.common Line colour of pooled common effect estimate.
#' @param col.random Line colour of 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 rob Risk of bias (RoB) assessment.
#' @param rob.text Column heading for RoB table.
#' @param rob.xpos A numeric specifying the horizontal position of the
#' risk of bias label in RoB table heading. The value is a so called
#' normalised parent coordinate in the horizontal direction (see
#' \code{\link[grid]{unit}}).
#' @param rob.legend A logical specifying whether a legend with RoB
#' domains should be printed.
#' @param rob.only A logical indicating whether the risk of bias
#' assessment is the only information printed on the right side of
#' the forest plot.
#' @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 file File name.
#' @param width Width of graphics file.
#' @param rows.gr Additional rows in forest plot to change height of
#' graphics file (e.g., in order to add a title at the top of the
#' forest plot).
#' @param func.gr Name of graphics function, e.g., \code{\link{pdf}}.
#' @param args.gr List with additional graphical parameters passed on
#' to graphics function (argument 'height' cannot be provided as the
#' height is calculated internally; use instead argument 'rows.gr').
#' @param dev.off A logical to specify whether current graphics device
#' should be shut down, i.e., whether file should be stored.
#' @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 fill Colour for background of confidence interval plot.
#' @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 col.label The colour of labels on the x-axis.
#' @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.circle The colour for circles reflecting study weights
#' in the meta-analysis.
#' @param col.circle.lines The colour for the outer lines of circles
#' 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 common.subgroup A single logical or logical vector
#' indicating whether / which common effect estimates should be
#' printed for subgroups.
#' @param random.subgroup A single logical or logical vector
#' indicating whether / which random effects estimates should be
#' printed for subgroups.
#' @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 details A logical specifying whether details on statistical
#' methods should be printed.
#' @param col.lines The colour of lines.
#' @param header.line A logical value indicating whether to print a
#' header line or a character string ("both", "below", "").
#' @param col.header.line Colour of the header line(s).
#' @param col.jama.line Colour of the additional JAMA lines.
#' @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 fs.rob The size of text of risk of bias items in the legend,
#' see \code{\link{gpar}}.
#' @param fs.rob.symbols The size of risk of bias symbols, see
#' \code{\link{gpar}}.
#' @param fs.details The size of text for details on (meta-analysis)
#' methods, 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 ff.rob The fontface of text of risk of bias items, see
#' \code{\link{gpar}}.
#' @param ff.rob.symbols The fontface of risk of bias symbols, see
#' \code{\link{gpar}}.
#' @param ff.details The fontface for details on (meta-analysis)
#' methods, see \code{\link{gpar}}.
#' @param squaresize A numeric used to increase or decrease the size
#' of squares in the forest plot.
#' @param lwd.square The line width of the border around squares.
#' @param lwd.diamond The line width of the border around diamonds.
#' @param arrow.type A character string indicating whether arrows
#' printed for results outside the forest plot should be
#' \code{"open"}, or \code{"closed"}, can be abbreviated.
#' @param arrow.length The length of arrows in inches.
#' @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 colgap.rob Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between risk of
#' bias columns.
#' @param colgap.rob.overall Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap before column with
#' overall risk of bias assessment.
#' @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 bmj.text A character string used in the plot with BMJ layout
#' to label the group specific information.
#' @param bmj.xpos A numeric specifying the horizontal position of the
#' BMJ label. The value is a so called normalised parent coordinate
#' in the horizontal direction (see \code{\link[grid]{unit}}).
#' @param bmj.sep A character string used to separate sample sizes
#' from number of events or means / standard deviations.
#' @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.
#' @param digits.stat Minimal number of significant digits for z- or
#' t-statistic for test of overall effect.
#' @param digits.tau2 Minimal number of significant digits for
#' between-study variance.
#' @param digits.tau Minimal number of significant digits for square
#' root of between-study variance.
#' @param digits.pval Minimal number of significant digits for p-value
#' of overall treatment effect.
#' @param digits.pval.Q Minimal number of significant digits for
#' p-value of heterogeneity test.
#' @param digits.Q Minimal number of significant digits for
#' heterogeneity statistic Q.
#' @param digits.I2 Minimal number of significant digits for I-squared
#' statistic.
#' @param digits.weight Minimal number of significant digits for
#' weights.
#' @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.n Minimal number of significant digits for sample
#' sizes.
#' @param digits.event Minimal number of significant digits for event
#' numbers.
#' @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. Resize the
#' graphics windows if the forest plot is too large or too small for
#' the graphics window. Alternatively, save the forest plot in a file.
#'
#' \subsection{Saving forest plots}{
#'
#' A forest plot can be directly stored in a file using argument
#' \code{file} or specifying the R function for the graphics device
#' driver using argument \code{func.gr}, e.g., \code{\link{pdf}}. If
#' only the filename is provided, the extension is checked and matched
#' against the most common graphics device drivers.
#'
#' \tabular{ll}{
#' \bold{Extension} \tab \bold{Graphics device} \cr
#' \code{.pdf} \tab \code{\link{pdf}} \cr
#' \code{.ps} \tab \code{\link{postscript}} \cr
#' \code{.svg} \tab \code{\link{svg}} \cr
#' \code{.bmp} \tab \code{\link{bmp}} \cr
#' \code{.jpg} / \code{.jpeg} \tab \code{\link{jpeg}} \cr
#' \code{.png} \tab \code{\link{png}} \cr
#' \code{.tif} / \code{.tiff} \tab \code{\link{tiff}}
#' }
#'
#' The height of the graphics device is automatically determined if
#' the forest plot is saved to a file. Argument \code{rows.gr} can be
#' used to increase or decrease the number of rows shown in the forest
#' plot (either to show missing information or to remove
#' whitespace). The width of the graphics device can be specified with
#' argument \code{width}, see, for example, \code{\link{pdf}} or
#' \code{\link{jpeg}}. Other arguments of graphics device functions
#' can be provided as a list in argument \code{args.gr}.
#'
#' Alternatively, the (resized) graphics window can be stored to a
#' file using either \code{\link{dev.copy2eps}} or
#' \code{\link{dev.copy2pdf}}. It is also possible to manually create
#' a file using, for example, \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{Risk of bias assessment}{
#'
#' A risk of bias (RoB) assessment can be shown in the forest plot by
#' either using a meta-analysis object with an RoB assessment as main
#' input or providing a suitable object created with
#' \code{\link{rob}}. Argument \code{rob = FALSE} can be used to
#' suppress the print of the risk of bias information.
#'
#' RoB assessments are shown as the only information on the right side
#' of the forest plot. Thus, arguments \code{rightcols} and
#' \code{rightlabs} should not be used. Predefined columns shown by
#' default on the right side of a forest plot will be moved to the
#' left side.
#' }
#'
#'
#' \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{common.subgroup} (common effect estimates in
#' subgroups),
#' \item \code{random.subgroup} (random effects estimates 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})
#' }
#' }
#'
#' @note
#' R function \code{.forestArgs} generates a character vector with all
#' arguments of \code{forest.meta}.
#'
#' @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 PDF files with the forest plot
#' #
#' # - specify filename (R function pdf() is used due to extension .pdf)
#' # - height of the figure is automatically determined
#' # - width is set to 10 inches
#' forest(m1, file = "forest-m1-1.pdf", width = 10)
#' #
#' # - specify graphics device function
#' # (filename "Rplots.pdf" used, see help page of R function pdf())
#' # - height of the figure is automatically determined
#' # - width is set to 10 inches
#' # - set title for PDF file
#' # - set background of forest plot
#' forest(m1, func.gr = pdf, width = 10,
#' args.gr = list(title = "My Forest Plot", bg = "green"))
#' #
#' # - manually specify the height of the figure
#' pdf("forest-m1-2.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 = "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
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"),
#
rob = x$rob,
rob.text = "Risk of Bias",
rob.xpos = 0,
rob.legend = TRUE,
rob.only = FALSE,
#
xlab = "", xlab.pos,
smlab = NULL, smlab.pos, xlim,
#
allstudies = TRUE,
weight.study = NULL,
pscale = x$pscale,
irscale = x$irscale, irunit = x$irunit,
#
file = NULL, width = gs("width"), rows.gr = NULL,
func.gr = NULL, args.gr = NULL,
dev.off = NULL,
#
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),
#
fill = gs("fill"),
#
leftcols = gs("leftcols"),
rightcols = gs("rightcols"),
leftlabs = gs("leftlabs"),
rightlabs = gs("rightlabs"),
#
label.e = x$label.e,
label.c = x$label.c,
#
label.e.attach = gs("label.e.attach"),
label.c.attach = gs("label.c.attach"),
#
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,
col.label = gs("col.label"),
#
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 = gs("col.square.lines"),
col.circle = gs("col.circle"),
col.circle.lines = col.circle,
#
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 & !inherits(x, "metamerge"),
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,
#
common.subgroup = common,
random.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,
#
details = gs("forest.details"),
#
col.lines = gs("col.lines"),
header.line,
col.header.line = col.lines,
col.jama.line = col.subgroup,
#
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,
fs.rob = fontsize,
fs.rob.symbols = fontsize,
fs.details = 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"),
ff.rob = "plain",
ff.rob.symbols = "bold",
ff.details = "plain",
#
squaresize =
if (layout == "BMJ") 0.9 / spacing else 0.8 / spacing,
lwd.square = gs("lwd.square"),
lwd.diamond = gs("lwd.diamond"),
#
arrow.type = gs("arrow.type"),
arrow.length = gs("arrow.length"),
#
plotwidth =
if (layout %in% c("BMJ", "JAMA")) "8cm" else "6cm",
colgap = gs("colgap"),
colgap.left = colgap,
colgap.right = colgap,
colgap.studlab = colgap.left,
colgap.forest = gs("colgap.forest"),
colgap.forest.left = colgap.forest,
colgap.forest.right = colgap.forest,
colgap.rob = "1mm",
colgap.rob.overall = "2mm",
#
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,
#
bmj.text = NULL,
bmj.xpos = 0,
bmj.sep = " / ",
#
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 = gs("digits.mean"),
digits.sd = gs("digits.sd"),
digits.cor = digits,
digits.time = digits,
#
digits.n = 0,
digits.event = 0,
#
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")
#
metamerge <- inherits(x, "metamerge")
#
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.leftlabs <- missing(leftlabs)
missing.rightcols <- missing(rightcols)
missing.rightlabs <- missing(rightlabs)
#
layout <- setchar(layout, c("meta", "BMJ", "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
}
bmj <- layout == "BMJ"
revman5 <- layout == "RevMan5"
jama <- layout == "JAMA"
revman5.jama <- revman5 | jama
bmj.revman5 <- bmj | revman5
bmj.revman5.jama <- bmj | revman5 | jama
#
lsel <- TRUE
if (is.logical(leftcols)) {
if (!leftcols)
lsel <- FALSE
#
leftcols <- NULL
}
#
if (revman5.jama)
rsel <- FALSE
else
rsel <- !(is.logical(rightcols) && length(rightcols) == 1 && !rightcols)
#
chkchar(rob.text, length = 1)
chknumeric(rob.xpos, length = 1)
chklogical(rob.legend)
chklogical(rob.only)
#
text.rob <- ""
RoB.available <- !is.null(rob) && !(is.logical(rob) && !rob)
RoB.legend <- RoB.available & rob.legend
#
if (RoB.available) {
if (!inherits(rob, "rob"))
stop("Argument 'rob' must be of class \"rob\".", call. = FALSE)
#
rsel <- TRUE
#
rob.labels <-
colnames(rob)[!(colnames(rob) %in% c("Study", "Weight"))]
rob.labels[rob.labels == "Overall"] <- "O"
#
rob.categories <- attr(rob, "categories")
rob.symbols <- attr(rob, "symbols")
rob.col <- attr(rob, "col")
#
text.rob <- c("Risk of bias legend", catleg(rob))
#
rob <- rob[, !(colnames(rob) %in% c("Study", "Weight")), drop = FALSE]
#
colnames(rob)[colnames(rob) == "Overall"] <- "O"
colnames(rob) <- gsub(" ", "_", paste0("RoB.", rob.labels))
#
rightcols.rob <- colnames(rob)
#
text.rob <- text.rob[text.rob != ""]
}
else
rightcols.rob <- NULL
#
if (!rsel)
rightcols <- NULL
#
# Check for duplicate columns
#
if (length(c(rightcols, rightcols.rob, leftcols)) > 0 &&
any(duplicated(c(rightcols, rightcols.rob, leftcols))))
stop("Duplicate entries in 'leftcols' and 'rightcols'.")
#
colnames <- c("studlab",
"TE",
"seTE",
"cluster",
#
"n.e", "n.c", "event.e", "event.c",
"event.n.e", "event.n.c",
"mean.e", "mean.c", "sd.e", "sd.c",
"mean.sd.n.e", "mean.sd.n.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")
#
bmj.bin <- bmj && metabin
bmj.cont <- bmj && metacont
#
# Identify and process columns in addition to columns
# defined above in variable 'colnames'
#
colnames.new <-
c(leftcols, rightcols, rightcols.rob)[
!c(leftcols, rightcols, rightcols.rob) %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 <- c(rightcols, rightcols.rob)[
!(c(rightcols, rightcols.rob) %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.common.subgroup <- missing(common.subgroup)
missing.random.subgroup <- missing(random.subgroup)
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.common.subgroup)
warning("Argument 'common.subgroup' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
if (!missing.random.subgroup)
warning("Argument 'random.subgroup' 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)
#
if (!is.null(file))
chkchar(file, length = 1)
#
if (!is.null(width))
chknumeric(width, min = 0, zero = TRUE, length = 1)
#
if (!is.null(rows.gr))
chknumeric(rows.gr, length = 1)
else
rows.gr <- 0
#
if (!is.null(args.gr))
chklist(args.gr)
#
if (!is.null(dev.off))
chklogical(dev.off)
else
dev.off <-
if (!is.null(file) | !is.null(func.gr))
TRUE
else
FALSE
#
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)
#
if (bmj)
type.study <- "squarediamond"
else
type.study <-
setchar(type.study,
c("square", "diamond", "predict", "circle", "squarediamond"))
#
type.common <-
setchar(type.common,
c("square", "diamond", "predict", "circle", "squarediamond"))
#
type.random <-
setchar(type.random,
c("square", "diamond", "predict", "circle", "squarediamond"))
#
type.subgroup <-
setchar(type.subgroup,
c("square", "diamond", "predict", "circle", "squarediamond"))
type.subgroup.common <-
setchar(type.subgroup.common,
c("square", "diamond", "predict", "circle", "squarediamond"))
#
type.subgroup.random <-
setchar(type.subgroup.random,
c("square", "diamond", "predict", "circle", "squarediamond"))
#
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)
#
chkcolor(col.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)
#
missing.print.I2 <- missing(print.I2)
missing.print.tau2 <- missing(print.tau2)
missing.print.tau <- missing(print.tau)
missing.print.Q <- missing(print.Q)
missing.print.pval.Q <- missing(print.pval.Q)
missing.print.Rb <- missing(print.Rb)
#
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 (bmj & overall.hetstat) {
if (!missing.print.I2 && !print.I2)
warning("Heterogeneity statistic I2 printed for BMJ layout.")
if (!missing.print.Q && !print.Q)
warning("Heterogeneity statistic Q printed for BMJ layout.")
if (!missing.print.pval.Q && !print.pval.Q)
warning("P-value of test for heterogeneity printed for BMJ layout.")
if (!missing.print.Rb && print.Rb)
warning("Heterogeneity statistic Rb not printed for BMJ layout.")
}
#
if (jama & overall.hetstat) {
if (!missing.print.I2 && !print.I2)
warning("Heterogeneity statistic I2 printed for JAMA layout.")
if (!missing.print.Q && !print.Q)
warning("Heterogeneity statistic Q printed for JAMA layout.")
if (!missing.print.pval.Q && !print.pval.Q)
warning("P-value of test for heterogeneity printed for JAMA layout.")
if (!missing.print.Rb && print.Rb)
warning("Heterogeneity statistic Rb not printed for JAMA layout.")
}
#
if (revman5 && overall.hetstat) {
if ((!missing.print.tau2 & !print.tau2 & !print.tau) |
(!missing.print.tau & !print.tau2 & !print.tau))
warning(paste("Information on between-study variance printed for",
"RevMan5 layout"))
if (!missing.print.I2 && !print.I2)
warning("Heterogeneity statistic I2 printed for RevMan5 layout.")
if (!missing.print.Q && !print.Q)
warning("Heterogeneity statistic Q printed for RevMan5 layout.")
if (!missing.print.pval.Q && !print.pval.Q)
warning("P-value of test for heterogeneity printed for RevMan5 layout.")
if (!missing.print.Rb && print.Rb)
warning("Heterogeneity statistic Rb not printed for RevMan5 layout.")
}
#
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") | bmj.revman5.jama
}
#
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)
#
if (!is.null(fontfamily)) {
chkchar(fontfamily, length = 1)
monospaced <- fontfamily %in% "Courier New"
}
else
monospaced <- FALSE
#
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.random <- missing(ff.random)
missing.ff.predict <- missing(ff.predict)
#
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)
chknumeric(lwd, length = 1)
chknumeric(lwd.square, length = 1)
chknumeric(lwd.diamond, length = 1)
#
arrow.type <- setchar(arrow.type, c("open", "closed"))
chknumeric(arrow.length, min = 0, zero = FALSE)
#
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)
#
missing.just <- missing(just)
if (missing.just && bmj)
just <- "center"
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"))
#
if (!is.null(bmj.text))
chkchar(bmj.text, length = 1)
chknumeric(bmj.xpos)
chkchar(bmj.sep, length = 1)
#
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)
chknumeric(digits.n, min = 0, length = 1)
chknumeric(digits.event, 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 (bmj) {
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 (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 (bmj) {
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 (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
}
#
chklogical(details)
#
#
# (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)
#
miss.col.circle <- missing(col.circle)
miss.col.circle.lines <- missing(col.circle.lines)
if (length(col.circle) == 1)
col.circle <- rep(col.circle, K.all)
else
chklength(col.circle, K.all, fun)
#
if (length(col.circle.lines) == 1)
col.circle.lines <- rep(col.circle.lines, K.all)
else
chklength(col.circle.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.common.subgroup)
common.subgroup <- catch("common.subgroup", mc, x, sfsp)
#
if (!missing.random.subgroup)
random.subgroup <- catch("random.subgroup", mc, x, sfsp)
#
if (!missing.prediction.subgroup & !metabind)
prediction.subgroup <- catch("prediction.subgroup", mc, x, sfsp)
#
common.subgroup <- replaceNULL(common.subgroup, FALSE)
random.subgroup <- replaceNULL(random.subgroup, FALSE)
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
# }
#
common.subgroup.logical <-
show_subgroup_results(common.subgroup, n.by,
x$lower.common.w, x$upper.common.w)
#
random.subgroup.logical <-
show_subgroup_results(random.subgroup, n.by,
x$lower.random.w, x$upper.random.w)
#
prediction.subgroup.logical <-
show_subgroup_results(prediction.subgroup, n.by,
x$lower.predict.w, x$upper.predict.w)
#
chklogical(common.subgroup[1])
chklogical(random.subgroup[1])
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) & subgroup.logical
#
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 | bmj.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 (bmj)
text.common <- paste0("Total (",
round(x$level.ma * 100), "% CI)",
if (common.random)
paste0(", ", gs("text.w.common"))
)
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 (bmj.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 | bmj.revman5)) {
if (bmj.revman5.jama) {
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 (bmj)
text.random <- paste0("Total (",
round(x$level.ma * 100), "% CI)",
if (common.random)
paste0(", ", gs("text.w.random"))
)
}
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 (bmj.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 (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) &
!(details | RoB.legend))
addrows.below.overall <- 2
else if (layout %in% c("meta", "subgroup") &
(test.subgroup.common & test.subgroup.random) &
!calcwidth.tests &
!(details | RoB.legend)) {
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 (!notmiss.xlim) {
if (metaprop || metarate || metamean ||
(metabind & sm %in% c(gs("sm4prop"), gs("sm4rate"), gs("sm4mean")))) {
xlim <- NULL
notmiss.xlim <- FALSE
}
else
xlim <- "symmetric"
}
#
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)
#
scale <- 1
if (pscale != 1 || irscale != 1) {
if (pscale != 1 && irscale != 1)
stop("Provide either arguments 'pscale' or 'irscale' but not ",
"both arguments.",
call. = FALSE)
if (pscale != 1)
scale <- pscale
else
scale <- irscale
}
#
smlab.null <- is.null(smlab)
if (smlab.null) {
if (is_rate(sm))
smlab <- xlab(sm, backtransf, irscale = irscale, irunit = irunit,
newline = !bmj.revman5.jama, revman5 = revman5,
big.mark = big.mark)
else if (is_prop(sm))
smlab <- xlab(sm, backtransf, pscale = pscale,
newline = !bmj.revman5.jama, revman5 = revman5,
big.mark = big.mark)
else
smlab <- xlab(sm, backtransf, pscale = pscale,
irscale = irscale, irunit = irunit,
newline = !bmj.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)
colgap.rob <- setunit(colgap.rob)
colgap.rob.overall <- setunit(colgap.rob.overall)
#
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 (bmj.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 (bmj.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) | sm == "VE" |
(!is.null(fbt) && fbt == "exp"))
sm.lab <- paste0("log", if (sm == "VE") "VR" else sm)
#
sel.studlab <-
pmatch(layout, c("meta", "BMJ", "RevMan5", "JAMA", "subgroup"))
lab.studlab <-
c("Study", "Study or\nsubgroup", "Study",
"Source", "Subgroup")[sel.studlab]
if (revman5 & by)
lab.studlab <- c("Study or\nSubgroup")
#
if (bmj.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 (miss.col.circle)
col.circle <- rep("darkblue", K.all)
if (miss.col.circle.lines)
col.circle.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 (miss.col.circle) {
if (metacont | metamean)
col.circle <- rep("green", K.all)
else if (metabin)
col.circle <- rep("blue", K.all)
else
col.circle <- rep("red", K.all)
}
if (miss.col.circle.lines) {
if (metacont | metamean)
col.circle.lines <- rep("green", K.all)
else if (metabin)
col.circle.lines <- rep("darkblue", K.all)
else
col.circle.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) {
if (smlab != "")
smlab <- paste0(smlab, "\n")
smlab <- paste0(smlab, lab.method[1], ", ", lab.model, ci.lab)
}
}
else if (bmj) {
sel.method <- pmatch(x$method, c("Inverse", "MH", "Peto", "GLMM"))
lab.method <- c("IV", "MH", "Peto", "GLMM")[sel.method]
#
if (common.random)
lab.model <- "common + random "
else if (common)
lab.model <- "common "
else if (random)
lab.model <- "random "
else
lab.model <- ""
#
if (smlab.null) {
if (smlab != "")
smlab <- paste0(smlab, ", ")
smlab <- paste0(smlab, lab.method[1], ",\n", 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 <- paste0("Weight", if (bmj) "\n(%)")
text.w.random <- paste0("Weight", if (bmj) "\n(%)")
}
else {
text.w.common <-
deprecated(text.w.common, missing(text.w.common), args, "text.w.fixed",
warn.deprecated)
#
if (bmj) {
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)
}
else {
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", if (sm == "VE") "VR" else 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",
label.e, label.c,
"Mean", "Mean", "SD", "SD",
label.e, label.c,
#
"Cor",
"Time", "Time",
#
sm.lab,
ci.lab,
if (bmj.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 (RoB.available)
rightlabs.new[rightlabs.new %in% colnames(rob)] <- rob.labels
#
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) {
if (metainf.metacum)
leftcols <- c(leftcols, "pval", "tau2", "tau", "I2")
#
leftcols <- c(leftcols, "effect.ci")
}
else {
if (metabin) {
if (study.results) {
if (bmj) {
leftcols <- c(leftcols,
"event.n.e",
"event.n.c")
label.e.attach <- "event.n.e"
#
if (is.null(bmj.text))
label.e <- "No of events / total"
else
label.e <- bmj.text
}
else
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 (bmj) {
leftcols <- c(leftcols,
"mean.sd.n.e",
"mean.sd.n.c")
label.e.attach <- "mean.sd.n.e"
#
if (is.null(bmj.text))
label.e <- "Mean (SD) / total"
else
label.e <- bmj.text
}
else 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") & !metamerge) {
if (common && !all(is.na(x$w.common)))
leftcols <- c(leftcols, "w.common")
if (random && !all(is.na(x$w.random)))
leftcols <- c(leftcols, "w.random")
}
else if (metainf.metacum)
leftcols <- c(leftcols, "pval", "tau2", "tau", "I2")
#
leftcols <- c(leftcols, "effect.ci")
}
#
# Add columns if risk of bias assessmen is only information on
# right side of the forest plot
#
if (!revman5.jama & rob.only) {
#
if (!metainf.metacum & overall & study.results &
!any(x$method == "GLMM") & !metamerge) {
if (common)
leftcols <- c(leftcols, "w.common")
if (random)
leftcols <- c(leftcols, "w.random")
}
else if (metainf.metacum)
leftcols <- c(leftcols, "pval", "tau2", "tau", "I2")
#
if (bmj)
leftcols <- c(leftcols, "effect.ci")
else
leftcols <- c(leftcols, "effect", "ci")
}
}
#
leftcols[leftcols == "w.fixed"] <- "w.common"
leftcols <- unique(leftcols)
#
if (is.null(rightcols) && rsel) {
if (bmj)
rightcols <- "effect.ci"
else
rightcols <- c("effect", "ci")
#
if (!metainf.metacum & overall & study.results &
!any(x$method == "GLMM") & !metamerge) {
wcols <- c(if (common && !all(is.na(x$w.common))) "w.common",
if (random && !all(is.na(x$w.random))) "w.random")
#
if (bmj)
rightcols <- c(wcols, rightcols)
else
rightcols <- c(rightcols, wcols)
}
#
if (metainf.metacum)
rightcols <- c(rightcols, "pval", "tau2", "tau", "I2")
}
else if (RoB.available & rob.only &
missing.leftcols & !revman5.jama) {
if (!metainf.metacum & overall & study.results &
!any(x$method == "GLMM" & !metamerge)) {
if (common)
leftcols <- c(leftcols, "w.common")
if (random)
leftcols <- c(leftcols, "w.random")
}
#
if (bmj)
leftcols <- c(leftcols, "effect.ci")
else
leftcols <- c(leftcols, "effect", "ci")
}
#
rightcols[rightcols == "w.fixed"] <- "w.common"
rightcols <- unique(rightcols)
#
if (rob.only)
rightcols <- rightcols.rob
else
rightcols <- c(rightcols, rightcols.rob)
#
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.circle <- col.circle[sel]
col.circle.lines <- col.circle.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.circle <- col.circle[o]
col.circle.lines <- col.circle.lines[o]
#
col.inside <- col.inside[o]
#
if (!null.exclude)
exclude <- exclude[o]
#
if (newcols) {
dataset1 <- dataset1[o, ]
dataset2 <- dataset2[o, ]
#
if (RoB.available)
rob <- rob[o, ]
}
}
#
if (bmj)
studlab <- paste0(" ", studlab)
#
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
#
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) {
Q.b.common <- unlist(x$Q.b.common)
names(Q.b.common) <- colnames(lower.common.w)
Q.w.common <- x$Q.w.common
#
Q.b.random <- unlist(x$Q.b.random)
Q.w.random <- x$Q.w.random
#
Q.w <- x$Q.w
#
df.Q.w <- replaceNULL(x$df.Q.w, sum((k.w - 1)[!is.na(x$Q.w)]))
df.Q.b <- replaceNULL(x$df.Q.b, (k - 1) - sum((k.w - 1)[!is.na(x$Q.w)]))
df.Q.b.common <- replaceNULL(x$df.Q.b.common, df.Q.b)
df.Q.b.random <- replaceNULL(x$df.Q.b.random, df.Q.b)
#
pval.Q.b.common <-
replaceNULL(x$pval.Q.b.common, pvalQ(Q.b.common, df.Q.b.common))
pval.Q.w.common <-
replaceNULL(x$pval.Q.w.common, pvalQ(Q.w.common, df.Q.w))
#
pval.Q.b.random <-
unlist(replaceNULL(x$pval.Q.b.random, pvalQ(Q.b.random, df.Q.b.random)))
pval.Q.w.random <-
unlist(replaceNULL(x$pval.Q.w.random, pvalQ(Q.w.random, df.Q.w)))
#
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 <- Q.b.random <- NA
df.Q.b <- df.Q.b.common <- df.Q.b.random <- NA
pval.Q.b.common <- pval.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 (bmj.revman5) ", df",
if (bmj.revman5) hetseparator,
if (bmj.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.tau))
hetstat.tau <- gsub(" ", " ", hetstat.tau)
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 (bmj) {
hetstat.tau2 <- gsub(" = ", "=", hetstat.tau2)
hetstat.tau <- gsub(" = ", "=", hetstat.tau)
hetstat.Q <- gsub(" = ", "=", hetstat.Q)
hetstat.pval.Q <- gsub(" = ", "=", hetstat.pval.Q)
hetstat.I2 <- gsub(" = ", "=", hetstat.I2)
}
#
if (bmj) {
if (print.tau)
hetstat.overall <-
substitute(
paste(hl,
tau, ht, "; ",
chi^2, hq,
", P", hp, "; ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2,
df = df.Q)
)
else if (print.tau2)
hetstat.overall <-
substitute(
paste(hl,
tau^2, ht, "; ",
chi^2, hq,
", P", hp, "; ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau2,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2,
df = df.Q)
)
else
hetstat.overall <-
substitute(
paste(hl,
chi^2, hq,
", P", hp, "; ",
I^2, hi),
list(hl = hetlab,
hi = hetstat.I2,
hq = hetstat.Q,
hp = hetstat.pval.Q,
df = df.Q)
)
}
else if (jama) {
if (!missing.print.tau2 | !missing.print.tau) {
if (print.tau)
hetstat.overall <-
substitute(
paste(hl,
chi[df]^2, hq,
" (", italic(P), hp, "), ",
italic(I)^2, hi, ", ",
tau, ht),
list(hl = hetlab,
df = df.Q,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2,
ht = hetstat.tau)
)
else if (print.tau2)
hetstat.overall <-
substitute(
paste(hl,
chi[df]^2, hq,
" (", italic(P), hp, "), ",
italic(I)^2, hi, ", ",
tau^2, ht),
list(hl = hetlab,
df = df.Q,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2,
ht = hetstat.tau2)
)
else
hetstat.overall <-
substitute(
paste(hl,
chi[df]^2, hq,
" (", italic(P), hp, "), ",
italic(I)^2, hi),
list(hl = hetlab,
df = df.Q,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2)
)
}
else
hetstat.overall <-
substitute(
paste(hl,
chi[df]^2, hq,
" (", italic(P), hp, "), ",
italic(I)^2, hi),
list(hl = hetlab,
df = df.Q,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2)
)
}
else if (revman5) {
if (print.tau)
hetstat.overall <-
substitute(
paste(hl,
"Tau", ht, "; ",
"Chi"^2, hq,
" (", P, hp, "); ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2)
)
else
hetstat.overall <-
substitute(
paste(hl,
"Tau"^2, ht, "; ",
"Chi"^2, hq,
" (", P, hp, "); ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau2,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2)
)
}
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 (bmj.revman5) ", df",
if (bmj.revman5) hetseparator,
if (bmj.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 (bmj) {
if (print.tau)
hetstat.resid <-
substitute(
paste(hl,
tau, ht, "; ",
chi^2, hq,
", df=",
df,
", P"=, hp,
"; ",
I^2, hi),
list(hl = resid.hetlab,
ht = hetstat.tau.resid,
df = df.Q,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
hi = hetstat.I2.resid)
)
else
hetstat.resid <-
substitute(
paste(hl,
tau^2, ht, "; ",
chi^2, hq,
", df=",
df,
", P"=, hp,
"; ",
I^2, hi),
list(hl = resid.hetlab,
df = df.Q.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
hi = hetstat.I2.resid)
)
}
else if (jama) {
if (!missing.print.tau2 | !missing.print.tau) {
if (print.tau)
hetstat.resid <-
substitute(
paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi,
tau, ht),
list(hl = resid.hetlab,
df = df.Q.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
hi = hetstat.I2.resid,
ht = hetstat.tau.resid)
)
else if (print.tau2)
hetstat.resid <-
substitute(
paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi,
tau^2, ht),
list(hl = resid.hetlab,
df = df.Q.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
hi = hetstat.I2.resid,
ht = hetstat.tau2.resid)
)
else
hetstat.resid <-
substitute(
paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi),
list(hl = resid.hetlab,
df = df.Q.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
hi = hetstat.I2.resid)
)
}
}
else if (revman5) {
if (print.tau)
hetstat.resid <-
substitute(
paste(hl,
"Tau", ht, "; ",
"Chi"^2, hq,
" (", P, hp, "); ",
I^2, hi),
list(hl = resid.hetlab,
ht = hetstat.tau.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
hi = hetstat.I2.resid)
)
else
hetstat.resid <-
substitute(
paste(hl,
"Tau"^2, ht, "; ",
"Chi"^2, hq,
" (", P, hp, "); ",
I^2, hi),
list(hl = resid.hetlab,
ht = hetstat.tau2.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
hi = hetstat.I2.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 (bmj)
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 (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 (bmj)
text.overall.common <-
substitute(paste(tl, " P", tp),
list(tl = label.test.overall.common,
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 (bmj)
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 (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 (bmj)
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 (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 (bmj)
text.overall.random <-
substitute(paste(tl, " P", tp),
list(tl = label.test.overall.random,
tp = pvals.overall[2]))
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))
#
#
if (by)
hetstat.Q.b.common <- hetstat.pval.Q.b.common <-
hetstat.Q.b.random <- hetstat.pval.Q.b.random <- NULL
else
hetstat.Q.b.common <- hetstat.pval.Q.b.common <-
hetstat.Q.b.random <- hetstat.pval.Q.b.random <- NA
#
for (i in seq_along(Q.b.common)) {
hetstat.i <-
paste0(hetseparator,
gsub(" ", "",
formatN(Q.b.common[i], digits.Q, "NA", big.mark = big.mark)),
if (!jama) ", df",
if (!jama) hetseparator,
if (!jama) df.Q.b.common[i])
#
pval.i <-
paste0(formatPT(pval.Q.b.common[i],
lab = TRUE, labval = "",
digits = digits.pval.Q,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA"))
#
# Remove superfluous spaces
#
hetstat.i <- rmSpace(hetstat.i, end = TRUE)
pval.i <- rmSpace(pval.i, end = TRUE)
#
while(any(grepl(" ", hetstat.i)))
hetstat.i <- gsub(" ", " ", hetstat.i)
while(any(grepl(" ", pval.i)))
pval.i <- gsub(" ", " ", pval.i)
#
hetstat.Q.b.common <- c(hetstat.Q.b.common, hetstat.i)
hetstat.pval.Q.b.common <- c(hetstat.pval.Q.b.common, pval.i)
}
#
for (i in seq_along(Q.b.random)) {
hetstat.i <-
paste0(hetseparator,
gsub(" ", "",
formatN(Q.b.random[i], digits.Q, "NA", big.mark = big.mark)),
if (!jama) ", df",
if (!jama) hetseparator,
if (!jama) collapse(df.Q.b.random[[i]], quote = ""))
#
pval.i <-
paste0(formatPT(pval.Q.b.random[i],
lab = TRUE, labval = "",
digits = digits.pval.Q,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA"))
#
# Remove superfluous spaces
#
hetstat.i <- rmSpace(hetstat.i, end = TRUE)
pval.i <- rmSpace(pval.i, end = TRUE)
#
while(any(grepl(" ", hetstat.i)))
hetstat.i <- gsub(" ", " ", hetstat.i)
while(any(grepl(" ", pval.i)))
pval.i <- gsub(" ", " ", pval.i)
#
hetstat.Q.b.random <- c(hetstat.Q.b.random, hetstat.i)
hetstat.pval.Q.b.random <- c(hetstat.pval.Q.b.random, pval.i)
}
#
if (test.subgroup.common) {
if (print.Q.subgroup) {
if (bmj)
text.subgroup.common <-
substitute(paste(tl,
chi^2, tq,
", P", tp),
list(tl = label.test.subgroup.common,
tq = hetstat.Q.b.common[1],
tp = hetstat.pval.Q.b.common[1]))
else if (revman5)
text.subgroup.common <-
substitute(paste(tl,
"Chi"^2, tq,
" (P", tp, ")"),
list(tl = label.test.subgroup.common,
tq = hetstat.Q.b.common[1],
tp = hetstat.pval.Q.b.common[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.b.common[1],
tp = hetstat.pval.Q.b.common[1],
df = df.Q.b.common[1]))
else
text.subgroup.common <-
substitute(paste(tl,
chi[df]^2, tq,
" (", italic(p), tp, ")"),
list(tl = label.test.subgroup.common,
tq = hetstat.Q.b.common[1],
tp = hetstat.pval.Q.b.common[1],
df = df.Q.b.common[1]))
}
else {
if (bmj)
text.subgroup.common <-
substitute(paste(tl, " P", tp),
list(tl = label.test.subgroup.common,
tp = hetstat.pval.Q.b.common[1]))
else if (revman5)
text.subgroup.common <-
substitute(paste(tl, " P", tp),
list(tl = label.test.subgroup.common,
tp = hetstat.pval.Q.b.common[1]))
else if (jama)
text.subgroup.common <-
substitute(paste(tl, " ", italic(P), tp),
list(tl = label.test.subgroup.common,
tp = hetstat.pval.Q.b.common[1]))
else
text.subgroup.common <-
substitute(paste(tl, " ", italic(p), tp),
list(tl = label.test.subgroup.common,
tp = hetstat.pval.Q.b.common[1]))
}
}
else
text.subgroup.common <- ""
#
if (test.subgroup.random) {
if (print.Q.subgroup) {
if (bmj) {
if (length(df.Q.b.random[[1]]) == 2)
text.subgroup.random <-
substitute(paste(tl, "F", tq, ", P", tp),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1]))
else
text.subgroup.random <-
substitute(paste(tl, chi^2, tq, " P", tp),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1]))
}
else if (revman5) {
if (length(df.Q.b.random[[1]]) == 2)
text.subgroup.random <-
substitute(paste(tl,
"F", tq,
" (P", tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1]))
else
text.subgroup.random <-
substitute(paste(tl,
"Chi"^2, tq,
" (P", tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1]))
}
else if (jama) {
if (length(df.Q.b.random[[1]]) == 2)
text.subgroup.random <-
substitute(paste(tl,
F[df], tq,
" (", italic(P), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1],
df = paste(df.Q.b.random[[1]], collapse = ", ")))
else
text.subgroup.random <-
substitute(paste(tl,
chi[df]^2, tq,
" (", italic(P), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1],
df = df.Q.b.random[[1]]))
}
else {
if (length(df.Q.b.random[[1]]) == 2)
text.subgroup.random <-
substitute(paste(tl,
F[df], tq,
" (", italic(p), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1],
df = paste(df.Q.b.random[[1]], collapse = ", ")))
else
text.subgroup.random <-
substitute(paste(tl,
chi[df]^2, tq,
" (", italic(p), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1],
df = df.Q.b.random[[1]]))
}
}
else {
if (bmj)
text.subgroup.random <-
substitute(paste(tl, " P", tp),
list(tl = label.test.subgroup.random,
tp = hetstat.pval.Q.b.random[1]))
else if (revman5)
text.subgroup.random <-
substitute(paste(tl, " P", tp),
list(tl = label.test.subgroup.random,
tp = hetstat.pval.Q.b.random[1]))
else if (jama)
text.subgroup.random <-
substitute(paste(tl, " ", italic(P), tp),
list(tl = label.test.subgroup.random,
tp = hetstat.pval.Q.b.random[1]))
else
text.subgroup.random <-
substitute(paste(tl, " ", italic(p), tp),
list(tl = label.test.subgroup.random,
tp = hetstat.pval.Q.b.random[1]))
}
}
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.common.w <- list2vec(TE.common.w)
lower.common.w <- list2vec(lower.common.w)
upper.common.w <- list2vec(upper.common.w)
statistic.common.w <- list2vec(statistic.common.w)
pval.common.w <- list2vec(pval.common.w)
#
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)
#
TE.random.w <- list2vec(TE.random.w)
lower.random.w <- list2vec(lower.random.w)
upper.random.w <- list2vec(upper.random.w)
statistic.random.w <- list2vec(statistic.random.w)
pval.random.w <- list2vec(pval.random.w)
#
lower.predict.w <- ordermat(lower.predict.w, subgroup.levels)
upper.predict.w <- ordermat(upper.predict.w, subgroup.levels)
#
lower.predict.w <- list2vec(lower.predict.w)
upper.predict.w <- list2vec(upper.predict.w)
#
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]
#
if (is.list(x$tau2.w))
x$tau2.w <- x$tau2.w[[1]]
if (is.list(x$tau.w))
x$tau.w <- x$tau.w[[1]]
#
tau2.w <- x$tau2.w[o.w]
tau.w <- x$tau.w[o.w]
#
w.common.w <- collapsemat(x$w.common.w)
if (is.list(w.common.w))
w.common.w <- w.common.w[[1]]
#
w.random.w <- collapsemat(x$w.random.w)
if (is.list(w.random.w))
w.random.w <- w.random.w[[1]]
#
w.common.w <- collapsemat(w.common.w)[o.w]
w.random.w <- collapsemat(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]
#
common.subgroup.logical <- common.subgroup.logical[o.w]
random.subgroup.logical <- random.subgroup.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]
#
common.subgroup.logical <- common.subgroup.logical[sel.w]
random.subgroup.logical <- random.subgroup.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 confidence or prediction intervals in
# subgroups to format confidence limits
#
sel.NA <- !repl(common.subgroup.logical, n.com, n.by)
lower.common.w[sel.NA] <- NA
upper.common.w[sel.NA] <- NA
#
sel.NA <- !repl(random.subgroup.logical, n.ran, n.by)
lower.random.w[sel.NA] <- NA
upper.random.w[sel.NA] <- NA
#
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 (bmj.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 (bmj) {
if (print.tau)
hetstat.w[[i]] <-
substitute(
paste(hl,
tau, ht, "; ",
chi^2, hq,
", P", hp,
"; ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i])
)
else if (print.tau2)
hetstat.w[[i]] <-
substitute(
paste(hl,
tau^2, ht, "; ",
chi^2, hq,
", P", hp,
"; ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i])
)
else
hetstat.w[[i]] <-
substitute(
paste(hl,
chi^2, hq,
", P", hp,
"; ",
I^2, hi),
list(hl = hetlab,
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i])
)
}
else if (jama) {
if (!missing.print.tau2 | !missing.print.tau) {
if (print.tau)
hetstat.w[[i]] <-
substitute(
paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi,
tau, ht),
list(hl = hetlab,
df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i],
ht = hetstat.tau.w[i])
)
else if (print.tau2)
hetstat.w[[i]] <-
substitute(
paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi,
tau^2, ht),
list(hl = hetlab,
df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i],
ht = hetstat.tau2.w[i])
)
else
hetstat.w[[i]] <-
substitute(
paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi),
list(hl = hetlab,
df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i])
)
}
else
hetstat.w[[i]] <-
substitute(
paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi),
list(hl = hetlab,
df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i])
)
}
else if (revman5) {
if (print.tau)
hetstat.w[[i]] <-
substitute(
paste(hl,
"Tau", ht, "; ",
"Chi"^2, hq,
" (",
P, hp,
"); ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i])
)
else
hetstat.w[[i]] <-
substitute(
paste(hl,
"Tau"^2, ht, "; ",
"Chi"^2, hq,
" (",
P, hp,
"); ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i])
)
}
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 (bmj)
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 (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 (bmj)
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 (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 (bmj)
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 (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 (bmj)
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 (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 (bmj)
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 (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]] <- ""
}
}
#
x$pscale <- pscale
x$irscale <- irscale
#
text.details <- ""
if (details) {
if (K.all == 1) {
text.details <-
catmeth(x,
common, random, prediction, overall, overall.hetstat,
x$func.transf, backtransf, fbt,
big.mark, digits, digits.tau, gs("text.tau"), gs("text.tau2"),
print.tau2 = FALSE,
forest = TRUE)
}
else {
text.details <-
catmeth(x,
common, random, prediction, overall, overall.hetstat,
x$func.transf, backtransf, fbt,
big.mark, digits, digits.tau, gs("text.tau"), gs("text.tau2"),
print.tau2, print.tau2.ci,
print.tau, print.tau.ci,
forest = TRUE)
}
#
text.details <- unlist(strsplit(text.details, "\n"))
text.details <- text.details[text.details != ""]
#
td <- vector("list", length(text.details))
#
for (i in seq_along(text.details))
td[[i]] <- text.details[i]
#
is.tau <- grepl(" for tau", td, fixed = TRUE)
is.tau.c <- grepl("assuming common", td, fixed = TRUE)
is.tau <- ifelse(is.tau & is.tau.c, FALSE, is.tau)
#
any.tau <- sum(is.tau)
any.tau.c <- sum(is.tau.c)
#
if (any.tau | any.tau.c) {
id.tau <- seq_along(is.tau)[is.tau]
id.tau.c <- seq_along(is.tau.c)[is.tau.c]
#
if (print.tau) {
if (any.tau.c)
for (i in id.tau.c)
td[[i]] <-
gsub(" for tau (assuming common tau in subgroups)", " for ",
td[[i]], fixed = TRUE)
#
if (any.tau)
for (i in id.tau)
td[[i]] <-
gsub(" for tau", " for ", td[[i]], fixed = TRUE)
}
else {
if (any.tau.c)
for (i in id.tau.c)
td[[i]] <-
gsub(" for tau^2 (assuming common tau^2 in subgroups)", " for ",
td[[i]], fixed = TRUE)
#
if (any.tau)
for (i in id.tau)
td[[i]] <-
gsub(" for tau^2", " for ", td[[i]], fixed = TRUE)
}
#
if (print.tau) {
if (revman5) {
if (any.tau.c)
for (i in id.tau.c)
td[[i]] <-
substitute(paste(txt1, txt2),
list(txt1 = td[[i]],
txt2 =
"Tau (assuming common Tau in subgroups)"))
#
if (any.tau)
for (i in id.tau)
td[[i]] <-
substitute(paste(txt1, txt2),
list(txt1 = td[[i]], txt2 = "Tau"))
}
else {
if (any.tau.c)
for (i in id.tau.c)
td[[i]] <-
substitute(paste(txt1, tau, txt2, tau, txt3),
list(txt1 = td[[i]],
txt2 = " (assuming common ",
txt3 = " in subgroups)"))
#
if (any.tau)
for (i in id.tau)
td[[i]] <-
substitute(paste(txt, tau), list(txt = td[[i]]))
}
}
else {
if (revman5) {
if (any.tau.c)
for (i in id.tau.c)
td[[i]] <-
substitute(paste(txt1, txt2^2, txt3, txt4^2, txt5),
list(txt1 = td[[i]],
txt2 = "Tau",
txt3 = " (assuming common ",
txt4 = "Tau",
txt5 = " in subgroups)"))
#
if (any.tau)
for (i in id.tau)
td[[i]] <-
substitute(paste(txt1, txt2^2),
list(txt1 = td[[i]], txt2 = "Tau"))
}
else {
if (any.tau.c)
for (i in id.tau.c)
td[[i]] <-
substitute(paste(txt1, tau^2, txt2, tau^2, txt3),
list(txt1 = td[[i]],
txt2 = " (assuming common ",
txt3 = " in subgroups)"))
#
if (any.tau)
for (i in id.tau)
td[[i]] <-
substitute(paste(txt, tau^2), list(txt = td[[i]]))
}
}
}
#
tau.ci.line <-
grepl(" of tau^2 and tau", text.details, fixed = TRUE) |
grepl(" of tau", text.details, fixed = TRUE) |
grepl(" of tau^2", text.details, fixed = TRUE)
#
if (any(tau.ci.line)) {
id <- seq_along(tau.ci.line)[tau.ci.line]
#
for (i in id) {
td[[i]] <- gsub(" of tau^2 and tau", " of ", td[[i]], fixed = TRUE)
td[[i]] <- gsub(" of tau", " of ", td[[i]], fixed = TRUE)
td[[i]] <- gsub(" of tau^2", " of ", td[[i]], fixed = TRUE)
}
#
if (print.tau.ci) {
if (revman5)
for (i in id)
td[[i]] <-
substitute(paste(txt1, txt2),
list(txt1 = td[[i]], txt2 = "Tau"))
else
for (i in id)
td[[i]] <- substitute(paste(txt1, tau), list(txt1 = td[[i]]))
}
else {
if (revman5)
for (i in id)
td[[i]] <-
substitute(paste(txt1, txt2^2),
list(txt1 = td[[i]], txt2 = "Tau"))
else
for (i in id)
td[[i]] <- substitute(paste(txt1, tau^2), list(txt1 = td[[i]]))
}
}
#
text.details <- td
}
#
#
# (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, npft, npft, fbt, abt)
#
if (!log.xaxis) {
lowTE <- backtransf(lowTE, sm, npft, npft, fbt, abt)
uppTE <- backtransf(uppTE, sm, npft, npft, fbt, abt)
}
#
# Results of meta-analysis
#
if (!log.xaxis) {
TE.common <- backtransf(TE.common, sm, npft.ma, npft.ma, fbt, abt)
lowTE.common <- backtransf(lowTE.common, sm, npft.ma, npft.ma, fbt, abt)
uppTE.common <- backtransf(uppTE.common, sm, npft.ma, npft.ma, fbt, abt)
#
TE.random <- backtransf(TE.random, sm, npft.ma, npft.ma, fbt, abt)
lowTE.random <- backtransf(lowTE.random, sm, npft.ma, npft.ma, fbt, abt)
uppTE.random <- backtransf(uppTE.random, sm, npft.ma, npft.ma, fbt, abt)
#
if (!metainf.metacum) {
lowTE.predict <-
backtransf(lowTE.predict, sm, npft.ma, npft.ma, fbt, abt)
uppTE.predict <-
backtransf(uppTE.predict, sm, npft.ma, 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, npft.w, npft.w, fbt, abt)
lowTE.w <- backtransf(lowTE.w, sm, npft.w, npft.w, fbt, abt)
uppTE.w <- backtransf(uppTE.w, sm, npft.w, npft.w, fbt, abt)
}
}
#
# Apply argument 'pscale' or 'irscale'
#
TE <- scale * TE
lowTE <- scale * lowTE
uppTE <- scale * uppTE
#
TE.common <- scale * TE.common
lowTE.common <- scale * lowTE.common
uppTE.common <- scale * uppTE.common
#
TE.random <- scale * TE.random
lowTE.random <- scale * lowTE.random
uppTE.random <- scale * uppTE.random
#
lowTE.predict <- scale * lowTE.predict
uppTE.predict <- scale * uppTE.predict
#
if (by) {
TE.w <- scale * TE.w
lowTE.w <- scale * lowTE.w
uppTE.w <- scale * uppTE.w
}
#
# Switch lower and upper limit for VE if results have been
# backtransformed
#
if (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
}
}
}
#
# Set study confidence intervals to NA if they should not be printed
#
if (!study.results) {
lowTE[!is.na(lowTE)] <- NA
uppTE[!is.na(uppTE)] <- NA
}
#
# 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 'event.n.e'
#
clines <- twolines(labs[["lab.event.n.e"]], "event.n.e")
#
if (clines$newline) {
newline.event.n.e <- TRUE
labs[["lab.event.n.e"]] <- clines$bottom
add.event.n.e <- clines$top
longer.event.n.e <- clines$longer
}
else {
newline.event.n.e <- FALSE
longer.event.n.e <- labs[["lab.event.n.e"]]
}
#
# Check for "\n" in label of column 'event.n.c'
#
clines <- twolines(labs[["lab.event.n.c"]], "event.n.c")
#
if (clines$newline) {
newline.event.n.c <- TRUE
labs[["lab.event.n.c"]] <- clines$bottom
add.event.n.c <- clines$top
longer.event.n.c <- clines$longer
}
else {
newline.event.n.c <- FALSE
longer.event.n.c <- labs[["lab.event.n.c"]]
}
#
# Check for "\n" in label of column 'mean.sd.n.e'
#
clines <- twolines(labs[["lab.mean.sd.n.e"]], "mean.sd.n.e")
#
if (clines$newline) {
newline.mean.sd.n.e <- TRUE
labs[["lab.mean.sd.n.e"]] <- clines$bottom
add.mean.sd.n.e <- clines$top
longer.mean.sd.n.e <- clines$longer
}
else {
newline.mean.sd.n.e <- FALSE
longer.mean.sd.n.e <- labs[["lab.mean.sd.n.e"]]
}
#
# Check for "\n" in label of column 'mean.sd.n.c'
#
clines <- twolines(labs[["lab.mean.sd.n.c"]], "mean.sd.n.c")
#
if (clines$newline) {
newline.mean.sd.n.c <- TRUE
labs[["lab.mean.sd.n.c"]] <- clines$bottom
add.mean.sd.n.c <- clines$top
longer.mean.sd.n.c <- clines$longer
}
else {
newline.mean.sd.n.c <- FALSE
longer.mean.sd.n.c <- labs[["lab.mean.sd.n.c"]]
}
#
# 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,
if (details) text.details else NULL,
if (RoB.legend) text.rob else NULL,
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,
monospaced = monospaced))
#
seTEs.study <- c(blanks, blanks.w,
formatN(seTE, digits.se, lab.NA, big.mark = big.mark,
monospaced = monospaced))
#
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,
monospaced = monospaced)
Wr.format <-
formatN(format.w.randoms, digits.weight, text.NA = lab.NA.weight,
monospaced = monospaced)
#
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,
if (details) text.details else NULL,
if (RoB.legend) text.rob else NULL,
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,
monospaced = monospaced)
format.w.random <- formatN(c(100, w.random.p), digits.weight,
monospaced = monospaced)
#
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(scale * exp(TEs / scale),
digits, lab.NA.effect, big.mark = big.mark)
ci.format <-
ifelse(is.na(lowTEs) | is.na(uppTEs), lab.NA.effect,
formatCI(formatN(scale * exp(lowTEs / scale),
digits = digits, text.NA = lab.NA,
big.mark = big.mark),
formatN(scale * exp(uppTEs / scale),
digits = digits, text.NA = lab.NA,
big.mark = big.mark)))
}
else {
effect.format <- formatN(TEs, digits, lab.NA.effect, big.mark = big.mark,
monospaced = monospaced)
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,
monospaced = monospaced),
formatN(uppTEs, digits = digits, text.NA = lab.NA,
big.mark = big.mark,
monospaced = monospaced)))
}
#
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 & !bmj) "%")
Wr.format <- paste0(Wr.format, if (w.random.percent & !bmj) "%")
#
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 = digits.n, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
Nc.format <-
formatN(Nc, digits = digits.n, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
Ee.format <-
formatN(Ee, digits = digits.event, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
Ec.format <-
formatN(Ec, digits = digits.event, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
#
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,
monospaced = monospaced)
else
Me.format <-
formatN(Me, digits = digits.R, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
#
if (all(is_wholenumber(Mc), na.rm = TRUE))
Mc.format <-
formatN(Mc, digits = 0, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
else
Mc.format <-
formatN(Mc, digits = digits.R, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
}
else {
Me.format <- formatN(Me, digits.mean, lab.NA, big.mark = big.mark,
monospaced = monospaced)
Mc.format <- formatN(Mc, digits.mean, lab.NA, big.mark = big.mark,
monospaced = monospaced)
}
#
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,
monospaced = monospaced)
else
Se.format <-
formatN(Se, digits = digits.R, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
#
if (all(is_wholenumber(Sc), na.rm = TRUE))
Sc.format <-
formatN(Sc, digits = 0, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
else
Sc.format <-
formatN(Sc, digits = digits.R, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
}
else {
Se.format <- formatN(Se, digits.sd, lab.NA, big.mark = big.mark,
monospaced = monospaced)
Sc.format <- formatN(Sc, digits.sd, lab.NA, big.mark = big.mark,
monospaced = monospaced)
}
#
# 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] <- ""
}
#
if (bmj.bin) {
Ee.bmj <- Ee.format
Ec.bmj <- Ec.format
#
Ne.bmj <- Ne.format
Nc.bmj <- Nc.format
#
Ne.bmj <- ifelse(Ee.bmj == "", "", Ne.bmj)
Nc.bmj <- ifelse(Ec.bmj == "", "", Nc.bmj)
#
while(all(substring(Ee.bmj[Ee.bmj != ""], 1, 1) == " "))
Ee.bmj[Ee.bmj != ""] <- substring(Ee.bmj[Ee.bmj != ""], 2)
#
while(all(substring(Ec.bmj[Ec.bmj != ""], 1, 1) == " "))
Ec.bmj[Ec.bmj != ""] <- substring(Ec.bmj[Ec.bmj != ""], 2)
#
while(all(substring(Ne.bmj[Ne.bmj != ""], 1, 1) == " "))
Ne.bmj[Ne.bmj != ""] <- substring(Ne.bmj[Ne.bmj != ""], 2)
#
while(all(substring(Nc.bmj[Nc.bmj != ""], 1, 1) == " "))
Nc.bmj[Nc.bmj != ""] <- substring(Nc.bmj[Nc.bmj != ""], 2)
#
Ne.bmj <- rmSpace(Ne.bmj, end = FALSE)
if (monospaced) {
nchar.Ne.bmj <- nchar(Ne.bmj)
Ne.bmj[nchar.Ne.bmj > 0] <-
str_pad(Ne.bmj[nchar.Ne.bmj > 0], width = max(nchar.Ne.bmj),
side = "right")
}
#
Nc.bmj <- rmSpace(Nc.bmj, end = FALSE)
if (monospaced) {
nchar.Nc.bmj <- nchar(Nc.bmj)
Nc.bmj[nchar.Nc.bmj > 0] <-
str_pad(Nc.bmj[nchar.Nc.bmj > 0], width = max(nchar.Nc.bmj),
side = "right")
}
#
event.n.e.format <-
ifelse(Ee.bmj != "",
paste0(Ee.bmj, bmj.sep, Ne.bmj),
"")
event.n.c.format <-
ifelse(Ec.format != "",
paste0(Ec.bmj, bmj.sep, Nc.bmj),
"")
#
if (pooled.totals & !pooled.events) {
event.n.e.format[Ne.format != "" & Ee.format == ""] <-
Ne.format[Ne.format != "" & Ee.format == ""]
event.n.c.format[Nc.format != "" & Ec.format == ""] <-
Nc.format[Nc.format != "" & Ec.format == ""]
}
}
#
if (bmj.cont) {
Ne.bmj <- Ne.format
Nc.bmj <- Nc.format
#
while(all(substring(Ne.bmj[Ne.bmj != ""], 1, 1) == " "))
Ne.bmj[Ne.bmj != ""] <- substring(Ne.bmj[Ne.bmj != ""], 2)
#
while(all(substring(Nc.bmj[Nc.bmj != ""], 1, 1) == " "))
Nc.bmj[Nc.bmj != ""] <- substring(Nc.bmj[Nc.bmj != ""], 2)
#
Ne.bmj <- rmSpace(Ne.bmj, end = FALSE)
if (monospaced) {
nchar.Ne.bmj <- nchar(Ne.bmj)
Ne.bmj[nchar.Ne.bmj > 0] <-
str_pad(Ne.bmj[nchar.Ne.bmj > 0], width = max(nchar.Ne.bmj),
side = "right")
}
#
Nc.bmj <- rmSpace(Nc.bmj, end = FALSE)
if (monospaced) {
nchar.Nc.bmj <- nchar(Nc.bmj)
Nc.bmj[nchar.Nc.bmj > 0] <-
str_pad(Nc.bmj[nchar.Nc.bmj > 0], width = max(nchar.Nc.bmj),
side = "right")
}
#
mean.sd.n.e.format <-
ifelse(Me.format != "",
paste0(Me.format, " (", Se.format, ")", bmj.sep, Ne.bmj),
"")
mean.sd.n.c.format <-
ifelse(Mc.format != "",
paste0(Mc.format, " (", Sc.format, ")", bmj.sep, Nc.bmj),
"")
#
sel.e <- Ne.format != "" & mean.sd.n.e.format == ""
mean.sd.n.e.format[sel.e] <- Ne.format[sel.e]
#
sel.c <- Nc.format != "" & mean.sd.n.c.format == ""
mean.sd.n.c.format[sel.c] <- Nc.format[sel.c]
}
#
# 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)) |
RoB.available |
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] & 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)
}
#
# Random effects model
#
if (random.subgroup.logical[i] & 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)
}
#
# Only pooled totals
#
# cat("pooled.totals\n")
# print(pooled.totals)
# cat("subgroup.logical[i]\n")
# print(subgroup.logical[i])
# cat("common.subgroup.logical[i]\n")
# print(common.subgroup.logical[i])
# cat("random.subgroup.logical[i]\n")
# print(random.subgroup.logical[i])
#
if (pooled.totals & subgroup.logical[i] &
!(common.subgroup.logical[i] | random.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)
}
#
# Prediction interval in subgroups
#
if (prediction.subgroup.logical[i] & 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)) {
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
#
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
#
if (details)
yText.details <- rep_len(NA, length(text.details))
else
yText.details <- NULL
#
if (RoB.legend)
yText.rob <- rep_len(NA, length(text.rob))
else
yText.rob <- NULL
#
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
yNext <- yNext + 1
}
#
if (details) {
yNext <- yNext + 1
yText.details <- seq(yNext, yNext + length(yText.details) - 1)
yNext <- yNext + length(yText.details)
}
#
if (RoB.legend) {
yNext <- yNext + 1
yText.rob <- seq(yNext, yNext + length(yText.rob) - 1)
}
#
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
if (details)
yText.details <- yHead + yText.details + addrow
if (RoB.legend)
yText.rob <- yHead + yText.rob + addrow
#
yStats <- c(yHetstat,
yResidHetstat,
yOverall.common, yOverall.random,
ySubgroup.common, ySubgroup.random,
yText.addline1, yText.addline2)
#
yStatsDetails <- c(yHetstat,
yResidHetstat,
yOverall.common, yOverall.random,
ySubgroup.common, ySubgroup.random,
yText.addline1, yText.addline2,
yText.details, yText.rob)
#
if (by) {
yBylab <- yHead + yBylab + addrow
yTE.w <- yHead + yTE.w + addrow
#
yLab <- c(yHead,
yTE.common, yTE.random, yPredict,
yStatsDetails,
yBylab, yTE.w,
yTE)
#
yS <- c(yHead, yTE.common, yTE.random, yPredict, yTE.w, yTE)
yS.noma <- c(yHead,
rep_len(NA, length(yTE.common)),
rep_len(NA, length(yTE.random)),
rep_len(NA, length(yPredict)),
rep_len(NA, length(yTE.w)),
yTE)
}
else {
yLab <- c(yHead, yTE.common, yTE.random, yPredict,
yStatsDetails,
yTE)
#
yS <- c(yHead, yTE.common, yTE.random, yPredict, yTE)
yS.noma <- c(yHead,
rep_len(NA, length(yTE.common)),
rep_len(NA, length(yTE.random)),
rep_len(NA, length(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 <- 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)
}
# Random effects estimate:
strt <- strt + i
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)
}
# Prediction interval:
strt <- strt + i
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)
}
# Heterogeneity statistics:
strt <- strt + i
col.studlab$labels[[strt + 1]] <-
tg(hetstat.overall, xpos.s, just.s, fs.hetstat, ff.hetstat, fontfamily)
# Statistic for residual heterogeneity:
col.studlab$labels[[strt + 2]] <-
tg(hetstat.resid, xpos.s, just.s, fs.hetstat, ff.hetstat, fontfamily)
# Test for overall effect (common effect model):
col.studlab$labels[[strt + 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[[strt + 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[[strt + 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[[strt + 6]] <-
tg(text.subgroup.random, xpos.s, just.s, fs.test.subgroup, ff.test.subgroup,
fontfamily)
# First additional line:
col.studlab$labels[[strt + 7]] <-
tg(text.addline1, xpos.s, just.s, fs.addline, ff.addline, fontfamily)
# Second additional line:
col.studlab$labels[[strt + 8]] <-
tg(text.addline2, xpos.s, just.s, fs.addline, ff.addline, fontfamily)
# Details on meta-analysis methods:
strt <- strt + 8
i <- 0
if (details) {
for (i in seq_len(length(text.details))) {
col.studlab$labels[[strt + i]] <-
tg(text.details[[i]], xpos.s, just.s,
if (i == 1) fs.heading else fs.details,
if (i == 1) ff.heading else ff.details,
fontfamily)
}
}
# Risk of bias:
strt <- strt + i
i <- 0
if (RoB.legend) {
for (i in seq_len(length(text.rob))) {
col.studlab$labels[[strt + i]] <-
tg(text.rob[i], xpos.s, just.s,
if (i == 1) fs.heading else fs.rob,
if (i == 1) ff.heading else ff.rob,
fontfamily)
}
}
#
if (by) {
# Subgroup labels:
strt <- strt + i
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)
}
# Common effect estimates:
strt <- strt + i
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)
}
# Random effects estimates:
strt <- strt + i
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)
}
# Prediction interval:
strt <- strt + i
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)
}
# Heterogeneity statistics:
strt <- strt + i
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)
}
# Test for effect in subgroup (common effect model):
strt <- strt + i
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)
}
# Test for effect in subgroup (random effects model):
strt <- strt + i
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)
}
}
#
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 (bmj.revman5 & missing.just) "center" else just.c,
fcs, fontfamily,
n.com, n.ran, n.prd)
#
if (bmj.bin) {
col.event.n.e <-
formatcol(labs[["lab.event.n.e"]], event.n.e.format, yS,
if (bmj.revman5 & missing.just) "center" else just.c,
fcs, fontfamily,
n.com, n.ran, n.prd)
#
col.event.n.c <-
formatcol(labs[["lab.event.n.c"]], event.n.c.format, yS,
if (bmj.revman5 & missing.just) "center" else just.c,
fcs, fontfamily,
n.com, n.ran, n.prd)
}
#
if (bmj.cont) {
col.mean.sd.n.e <-
formatcol(labs[["lab.mean.sd.n.e"]], mean.sd.n.e.format, yS,
if (bmj.revman5 & missing.just) "center" else just.c,
fcs, fontfamily,
n.com, n.ran, n.prd)
#
col.mean.sd.n.c <-
formatcol(labs[["lab.mean.sd.n.c"]], mean.sd.n.c.format, yS,
if (bmj.revman5 & missing.just) "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)
#
if (bmj.bin) {
col.event.n.e.calc <- formatcol(longer.event.n.e, event.n.e.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
#
col.event.n.c.calc <- formatcol(longer.event.n.c, event.n.c.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
}
#
if (bmj.cont) {
col.mean.sd.n.e.calc <-
formatcol(longer.mean.sd.n.e, mean.sd.n.e.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
#
col.mean.sd.n.c.calc <-
formatcol(longer.mean.sd.n.c, mean.sd.n.c.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 CI with square
# "circle" - normal CI with circle
# "squarediamond" - normal CI with squarediamond
# "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.circle = c(col.diamond.pooled, col.circle),
col.circle.lines =
c(col.diamond.lines.pooled, col.circle.lines),
#
col.diamond = c(col.diamond.pooled, col.square),
col.diamond.lines =
c(col.diamond.lines.pooled, col.square.lines),
#
lwd = lwd,
lwd.square = lwd.square, lwd.diamond = lwd.diamond,
#
arrow.type = arrow.type, arrow.length = arrow.length
)
#
# 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)
if (length(unique(type.study)) == 1 &&
unique(type.study) == "squarediamond")
information[information < 0.35 * max(information, na.rm = TRUE)] <-
0.35
}
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)
#
if (bmj.bin) {
cols$col.event.n.e <- col.event.n.e
cols$col.event.n.c <- col.event.n.c
}
#
if (bmj.cont) {
cols$col.mean.sd.n.e <- col.mean.sd.n.e
cols$col.mean.sd.n.c <- col.mean.sd.n.c
}
#
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)
#
if (bmj.bin) {
cols.calc$col.event.n.e <- col.event.n.e.calc
cols.calc$col.event.n.c <- col.event.n.c.calc
}
#
if (bmj.cont) {
cols.calc$col.mean.sd.n.e <- col.mean.sd.n.e.calc
cols.calc$col.mean.sd.n.c <- col.mean.sd.n.c.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])
#
rob.i <- length(rob[[rightcols.new[i]]]) != 0
#
if (rob.i)
tmp.r <- rob[[rightcols.new[i]]]
else 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),
if (!rob.i) yS else yS.noma,
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,
rightcols.new[i] %in% colnames(rob))
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])
#
rob.i <- length(rob[[rightcols.new[i]]]) != 0
#
if (rob.i)
tmp.r <- rob[[rightcols.new[i]]]
else 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),
if (!rob.i) yS else yS.noma,
if (rightcols.new[i] %in% c("pval", "tau2", "tau", "I2"))
just
else
just.addcols.right[i],
fcs, fontfamily,
n.com, n.ran, n.prd,
rightcols.new[i] %in% colnames(rob))
#
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,
if (bmj) bmj.xpos else xpos.c,
if (bmj) "left" else just.c,
fs.head, ff.head, fontfamily)
#
col.label.c <- tgl(label.c, xpos.c, just.c, fs.head, ff.head, fontfamily)
#
col.rob <- tgl(rob.text, rob.xpos, "left", 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 (bmj.revman5) 0.5 else xpos.c,
if (bmj.revman5) "center" else just.c,
fs.head, ff.head, fontfamily)
#
if (bmj.bin) {
if (newline.event.n.e)
col.add.event.n.e <- tgl(add.event.n.e,
if (bmj.revman5) 0.5 else xpos.c,
if (bmj.revman5) "center" else just.c,
fs.head, ff.head, fontfamily)
#
if (newline.event.n.c)
col.add.event.n.c <- tgl(add.event.n.c,
if (bmj.revman5) 0.5 else xpos.c,
if (bmj.revman5) "center" else just.c,
fs.head, ff.head, fontfamily)
}
#
if (bmj.cont) {
if (newline.mean.sd.n.e)
col.add.mean.sd.n.e <- tgl(add.mean.sd.n.e,
if (bmj.revman5) 0.5 else xpos.c,
if (bmj.revman5) "center" else just.c,
fs.head, ff.head, fontfamily)
#
if (newline.mean.sd.n.c)
col.add.mean.sd.n.c <- tgl(add.mean.sd.n.c,
if (bmj.revman5) 0.5 else xpos.c,
if (bmj.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 + seq(2))
#
if (!calcwidth.tests)
del.lines <-
c(del.lines, 1 + n.com + n.ran + n.prd + 2 + seq(4))
#
if (!calcwidth.addline)
del.lines <-
c(del.lines, 1 + n.com + n.ran + n.prd + 2 + 4 + seq(2))
#
if (details)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + seq_along(text.details))
#
if (RoB.legend)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + length(text.details) +
seq_along(text.rob))
#
nd <- 1 + n.com + n.ran + n.prd + 2 + 4 + 2 +
details * length(text.details) +
RoB.legend * length(text.rob)
#
#nd <- n.com + n.ran + n.prd + 2 + 4 + 2
#
if (by) {
if (!calcwidth.subgroup)
del.lines <-
c(del.lines, nd + seq_len(n.by))
#
if (!calcwidth.common)
del.lines <-
c(del.lines, nd + n.by + seq_len(n.by * n.com))
#
if (!calcwidth.random)
del.lines <-
c(del.lines,
nd + n.by + n.by * n.com + seq_len(n.by * n.ran))
#
if (!calcwidth.predict)
del.lines <-
c(del.lines,
nd + n.by + n.by * n.com + n.by * n.ran + seq_len(n.by * n.prd))
#
if (!calcwidth.hetstat)
del.lines <-
c(del.lines,
nd + 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,
nd + 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,
nd + 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)
#
rob.attach <- NULL
#
if (RoB.available) {
colnames(rob) <- paste0("col.", colnames(rob))
rob.attach <- colnames(rob)[1]
}
#
if (rsel) {
for (i in seq_along(rightcols)) {
colgap.right.i <- colgap.right
#
if (RoB.available && i > 1 &&
rightcols[i] %in% colnames(rob) &&
rightcols[i - 1] %in% colnames(rob)) {
if (rightcols[i] == "col.RoB.O")
colgap.right.i <- colgap.rob.overall
else
colgap.right.i <- colgap.rob
}
#
x1 <- unit.c(x1,
if (i == 1) colgap.forest.right else colgap.right.i,
if (rightcols[i] %in% colnames(rob))
wcalc(grid.text("aa",
just = "center",
gp = gpar(col = "transparent",
fontsize = fs.head,
fontface = ff.head,
fontfamily = fontfamily)))
else
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,
yStatsDetails, 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,
yStatsDetails), na.rm = TRUE)
}
#
# Determine minimal value on y-axis for lines of common / random
# effect estimate or reference line
#
n.lines <- sum(!is.na(yStatsDetails)) + details + RoB.legend
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 (!is.null(file) | !is.null(func.gr)) {
if (is.null(func.gr)) {
if (grepl("pdf$", tolower(file)))
func.gr <- "pdf"
else if (grepl("ps$", tolower(file)))
func.gr <- "postscript"
else if (grepl("svg$", tolower(file)))
func.gr <- "svg"
else if (grepl("bmp$", tolower(file)))
func.gr <- "bmp"
else if (grepl("jpg$", tolower(file)) |
grepl("jpeg$", tolower(file)))
func.gr <- "jpeg"
else if (grepl("png$", tolower(file)))
func.gr <- "png"
else if (grepl("tif$", tolower(file)) |
grepl("tiff$", tolower(file)))
func.gr <- "tiff"
else
stop("Argument 'file' has unknown file extension; either provide ",
"admissible file extension\n (\".pdf\", \".ps\", \".svg\", ",
"\".bmp\", \".jpg\", \".png\", \"tif\") or ",
"\n graphics function (argument 'func.gr').")
#
type.gr <- func.gr
}
else
type.gr <- deparse(substitute(func.gr))
#
figheight <- gh(type.gr, rows.gr,
#
if (metabind) length(x$TE) else n.stud,
lowTE.common, lowTE.random, lowTE.predict,
x$subgroup, subgroup.levels,
lower.common.w, lower.random.w, lower.predict.w,
#
if (metabind) FALSE else common,
if (metabind) FALSE else random,
if (metabind) FALSE else overall,
if (metabind) FALSE else prediction,
if (metabind) FALSE else overall.hetstat,
study.results,
#
spacing,
#
xlab, xlab.add, label.right, label.left, bottom.lr,
#
prediction.subgroup, subgroup.hetstat,
if (metabind) FALSE else test.overall.common,
if (metabind) FALSE else test.overall.random,
if (metabind) FALSE else test.subgroup.common,
if (metabind) FALSE else test.subgroup.random,
#
text.addline1, text.addline2,
text.details, text.rob,
#
addrow, addrow.overall,
addrow.subgroups,
if (metabind) 0 else addrows.below.overall,
#
c(leftcols, rightcols), labs,
text.w.common, text.w.random)
#
args.gr.all <-
c(list(file = file,
height = figheight$total_height,
width = width),
args.gr)
runNN(func.gr, args.gr.all)
}
else
figheight <- gh("no_device_defined", rows.gr,
#
n.stud,
lowTE.common, lowTE.random, lowTE.predict,
x$subgroup, subgroup.levels,
lower.common.w, lower.random.w, lower.predict.w,
#
common, random, overall,
prediction, overall.hetstat,
study.results,
#
spacing,
#
xlab, xlab.add, label.right, label.left, bottom.lr,
#
prediction.subgroup, subgroup.hetstat,
test.overall.common, test.overall.random,
test.subgroup.common, test.subgroup.random,
#
text.addline1, text.addline2,
text.details, text.rob,
#
addrow, addrow.overall,
addrow.subgroups, addrows.below.overall,
#
c(leftcols, rightcols), labs,
text.w.common, text.w.random)
#
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.event.n.e & leftcols[i] == "col.event.n.e")
add.text(col.add.event.n.e, j)
if (newline.event.n.c & leftcols[i] == "col.event.n.c")
add.text(col.add.event.n.c, j)
if (newline.mean.sd.n.e & leftcols[i] == "col.mean.sd.n.e")
add.text(col.add.mean.sd.n.e, j)
if (newline.mean.sd.n.c & leftcols[i] == "col.mean.sd.n.c")
add.text(col.add.mean.sd.n.c, 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,
fill,
col.lines)
#
draw.axis(col.forest, j, yS, log.xaxis, at, label,
fs.axis, ff.axis, fontfamily, lwd,
xlim, notmiss.xlim,
col.lines, col.label)
#
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,
if (bmj)
unit(xlim[1], "native")
else
unit(ref - (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr, "lines"),
if (bmj) "left" else "right",
fs.lr, ff.lr, col.label.left, fontfamily,
xscale = col.forest$range)
#
if (newline.ll)
add.label(ll2, j,
if (bmj)
unit(xlim[1], "native")
else
unit(ref - (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr - 1, "lines"),
if (bmj) "left" else "right",
fs.lr, ff.lr, col.label.left, fontfamily,
xscale = col.forest$range)
#
add.label(lr1, j,
if (bmj)
unit(xlim[2], "native")
else
unit(ref + (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr, "lines"),
if (bmj) "right" else "left",
fs.lr, ff.lr, col.label.right, fontfamily,
xscale = col.forest$range)
#
if (newline.lr)
add.label(lr2, j,
if (bmj)
unit(xlim[2], "native")
else
unit(ref + (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr - 1, "lines"),
if (bmj) "right" else "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) {
i.rob <- 0
#
for (i in seq_along(rightcols)) {
if (substring(rightcols[i], 1, 8) == "col.RoB.") {
i.rob <- i.rob + 1
#
add.rob(cols[[rightcols[i]]], j, 0.85, fs.rob.symbols, ff.rob.symbols,
fontfamily,
rob[[rightcols[[i]]]],
rob.categories[[i.rob]], rob.symbols[[i.rob]], rob.col[[i.rob]])
}
else
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 (!is.null(rob.attach)) {
if (rightcols[i] == rob.attach)
add.text(col.rob, 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.mean.sd.n.e & rightcols[i] == "col.mean.sd.n.e")
add.text(col.add.mean.sd.n.e, j)
if (newline.mean.sd.n.c & rightcols[i] == "col.mean.sd.n.c")
add.text(col.add.mean.sd.n.c, 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
}
}
#
# Add header line
#
if (jama)
hcols <- lsel * 2 * length(leftcols)
else
hcols <-
lsel * 2 * length(leftcols) + 1 + rsel * 2 * length(rightcols)
#
if (bmj.bin) {
sel1 <- grep("col.event.n.e",
c(leftcols, if (all(rightcols != "col.")) rightcols))
sel2 <- grep("col.event.n.c",
c(leftcols, if (all(rightcols != "col.")) rightcols))
#
if (length(sel1) > 0 & length(sel2) > 0) {
if (sel1 > sel2) {
sel3 <- sel2
sel2 <- sel1
sel1 <- sel2
}
#
for (i in seq(2 * sel1 - 1, 2 * sel2 - 1)) {
pushViewport(
viewport(
layout.pos.col = i,
xscale = col.forest$range))
#
grid.lines(x = unit(0:1, "npc"),
y = unit(nrow - 1.5 + 0.5 * addrow, "lines"),
gp = gpar(lwd = lwd))
#
popViewport()
}
}
}
#
if (bmj.cont) {
sel1 <- grep("col.mean.sd.n.e",
c(leftcols, if (all(rightcols != "col.")) rightcols))
sel2 <- grep("col.mean.sd.n.c",
c(leftcols, if (all(rightcols != "col.")) rightcols))
#
if (length(sel1) > 0 & length(sel2) > 0) {
if (sel1 > sel2) {
sel3 <- sel2
sel2 <- sel1
sel1 <- sel2
}
#
for (i in seq(2 * sel1 - 1, 2 * sel2 - 1)) {
pushViewport(
viewport(
layout.pos.col = i,
xscale = col.forest$range))
#
grid.lines(x = unit(0:1, "npc"),
y = unit(nrow - 1.5 + 0.5 * addrow, "lines"),
gp = gpar(lwd = lwd))
#
popViewport()
}
}
}
#
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, col = col.header.line))
#
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, col = col.header.line))
#
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.jama.line))
#
popViewport()
}
}
#
popViewport()
#
if (dev.off)
invisible(dev.off())
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,
effect.ci.format = effect.ci.format,
#
if (bmj.bin) effect.ci.format = effect.ci.format,
if (bmj.bin) effect.ci.format = effect.ci.format,
#
figheight = figheight,
#
leftcols = leftcols,
leftlabs= leftlabs,
rightcols = rightcols,
rightlabs = rightlabs)
#
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)
}
#' @rdname forest.meta
#' @method plot meta
#' @export
#'
plot.meta <- function(x, ...)
forest(x, ...)
#' @rdname forest.meta
#' @export .forestArgs
.forestArgs <- function()
formalArgs(forest.meta)
guido-s/meta documentation built on April 18, 2024, 7:11 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions .forestArgs plot.meta forest.meta
Documented in .forestArgs forest.meta plot.meta
#' Forest plot to display the result of a meta-analysis
#'
#' @description
#' Draw a forest plot (using grid graphics system) in the active
#' graphics window or store the forest plot in a file.
#'
#' @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 of pooled common effect estimate.
#' @param lty.random Line type of pooled random effects estimate.
#' @param col.common Line colour of pooled common effect estimate.
#' @param col.random Line colour of 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 rob Risk of bias (RoB) assessment.
#' @param rob.text Column heading for RoB table.
#' @param rob.xpos A numeric specifying the horizontal position of the
#' risk of bias label in RoB table heading. The value is a so called
#' normalised parent coordinate in the horizontal direction (see
#' \code{\link[grid]{unit}}).
#' @param rob.legend A logical specifying whether a legend with RoB
#' domains should be printed.
#' @param rob.only A logical indicating whether the risk of bias
#' assessment is the only information printed on the right side of
#' the forest plot.
#' @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 file File name.
#' @param width Width of graphics file.
#' @param rows.gr Additional rows in forest plot to change height of
#' graphics file (e.g., in order to add a title at the top of the
#' forest plot).
#' @param func.gr Name of graphics function, e.g., \code{\link{pdf}}.
#' @param args.gr List with additional graphical parameters passed on
#' to graphics function (argument 'height' cannot be provided as the
#' height is calculated internally; use instead argument 'rows.gr').
#' @param dev.off A logical to specify whether current graphics device
#' should be shut down, i.e., whether file should be stored.
#' @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 fill Colour for background of confidence interval plot.
#' @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 col.label The colour of labels on the x-axis.
#' @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.circle The colour for circles reflecting study weights
#' in the meta-analysis.
#' @param col.circle.lines The colour for the outer lines of circles
#' 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 common.subgroup A single logical or logical vector
#' indicating whether / which common effect estimates should be
#' printed for subgroups.
#' @param random.subgroup A single logical or logical vector
#' indicating whether / which random effects estimates should be
#' printed for subgroups.
#' @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 details A logical specifying whether details on statistical
#' methods should be printed.
#' @param col.lines The colour of lines.
#' @param header.line A logical value indicating whether to print a
#' header line or a character string ("both", "below", "").
#' @param col.header.line Colour of the header line(s).
#' @param col.jama.line Colour of the additional JAMA lines.
#' @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 fs.rob The size of text of risk of bias items in the legend,
#' see \code{\link{gpar}}.
#' @param fs.rob.symbols The size of risk of bias symbols, see
#' \code{\link{gpar}}.
#' @param fs.details The size of text for details on (meta-analysis)
#' methods, 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 ff.rob The fontface of text of risk of bias items, see
#' \code{\link{gpar}}.
#' @param ff.rob.symbols The fontface of risk of bias symbols, see
#' \code{\link{gpar}}.
#' @param ff.details The fontface for details on (meta-analysis)
#' methods, see \code{\link{gpar}}.
#' @param squaresize A numeric used to increase or decrease the size
#' of squares in the forest plot.
#' @param lwd.square The line width of the border around squares.
#' @param lwd.diamond The line width of the border around diamonds.
#' @param arrow.type A character string indicating whether arrows
#' printed for results outside the forest plot should be
#' \code{"open"}, or \code{"closed"}, can be abbreviated.
#' @param arrow.length The length of arrows in inches.
#' @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 colgap.rob Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap between risk of
#' bias columns.
#' @param colgap.rob.overall Either a character string or a
#' \code{\link[grid]{unit}} object specifying gap before column with
#' overall risk of bias assessment.
#' @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 bmj.text A character string used in the plot with BMJ layout
#' to label the group specific information.
#' @param bmj.xpos A numeric specifying the horizontal position of the
#' BMJ label. The value is a so called normalised parent coordinate
#' in the horizontal direction (see \code{\link[grid]{unit}}).
#' @param bmj.sep A character string used to separate sample sizes
#' from number of events or means / standard deviations.
#' @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.
#' @param digits.stat Minimal number of significant digits for z- or
#' t-statistic for test of overall effect.
#' @param digits.tau2 Minimal number of significant digits for
#' between-study variance.
#' @param digits.tau Minimal number of significant digits for square
#' root of between-study variance.
#' @param digits.pval Minimal number of significant digits for p-value
#' of overall treatment effect.
#' @param digits.pval.Q Minimal number of significant digits for
#' p-value of heterogeneity test.
#' @param digits.Q Minimal number of significant digits for
#' heterogeneity statistic Q.
#' @param digits.I2 Minimal number of significant digits for I-squared
#' statistic.
#' @param digits.weight Minimal number of significant digits for
#' weights.
#' @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.n Minimal number of significant digits for sample
#' sizes.
#' @param digits.event Minimal number of significant digits for event
#' numbers.
#' @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. Resize the
#' graphics windows if the forest plot is too large or too small for
#' the graphics window. Alternatively, save the forest plot in a file.
#'
#' \subsection{Saving forest plots}{
#'
#' A forest plot can be directly stored in a file using argument
#' \code{file} or specifying the R function for the graphics device
#' driver using argument \code{func.gr}, e.g., \code{\link{pdf}}. If
#' only the filename is provided, the extension is checked and matched
#' against the most common graphics device drivers.
#'
#' \tabular{ll}{
#' \bold{Extension} \tab \bold{Graphics device} \cr
#' \code{.pdf} \tab \code{\link{pdf}} \cr
#' \code{.ps} \tab \code{\link{postscript}} \cr
#' \code{.svg} \tab \code{\link{svg}} \cr
#' \code{.bmp} \tab \code{\link{bmp}} \cr
#' \code{.jpg} / \code{.jpeg} \tab \code{\link{jpeg}} \cr
#' \code{.png} \tab \code{\link{png}} \cr
#' \code{.tif} / \code{.tiff} \tab \code{\link{tiff}}
#' }
#'
#' The height of the graphics device is automatically determined if
#' the forest plot is saved to a file. Argument \code{rows.gr} can be
#' used to increase or decrease the number of rows shown in the forest
#' plot (either to show missing information or to remove
#' whitespace). The width of the graphics device can be specified with
#' argument \code{width}, see, for example, \code{\link{pdf}} or
#' \code{\link{jpeg}}. Other arguments of graphics device functions
#' can be provided as a list in argument \code{args.gr}.
#'
#' Alternatively, the (resized) graphics window can be stored to a
#' file using either \code{\link{dev.copy2eps}} or
#' \code{\link{dev.copy2pdf}}. It is also possible to manually create
#' a file using, for example, \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{Risk of bias assessment}{
#'
#' A risk of bias (RoB) assessment can be shown in the forest plot by
#' either using a meta-analysis object with an RoB assessment as main
#' input or providing a suitable object created with
#' \code{\link{rob}}. Argument \code{rob = FALSE} can be used to
#' suppress the print of the risk of bias information.
#'
#' RoB assessments are shown as the only information on the right side
#' of the forest plot. Thus, arguments \code{rightcols} and
#' \code{rightlabs} should not be used. Predefined columns shown by
#' default on the right side of a forest plot will be moved to the
#' left side.
#' }
#'
#'
#' \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{common.subgroup} (common effect estimates in
#' subgroups),
#' \item \code{random.subgroup} (random effects estimates 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})
#' }
#' }
#'
#' @note
#' R function \code{.forestArgs} generates a character vector with all
#' arguments of \code{forest.meta}.
#'
#' @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 PDF files with the forest plot
#' #
#' # - specify filename (R function pdf() is used due to extension .pdf)
#' # - height of the figure is automatically determined
#' # - width is set to 10 inches
#' forest(m1, file = "forest-m1-1.pdf", width = 10)
#' #
#' # - specify graphics device function
#' # (filename "Rplots.pdf" used, see help page of R function pdf())
#' # - height of the figure is automatically determined
#' # - width is set to 10 inches
#' # - set title for PDF file
#' # - set background of forest plot
#' forest(m1, func.gr = pdf, width = 10,
#' args.gr = list(title = "My Forest Plot", bg = "green"))
#' #
#' # - manually specify the height of the figure
#' pdf("forest-m1-2.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 = "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
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"),
#
rob = x$rob,
rob.text = "Risk of Bias",
rob.xpos = 0,
rob.legend = TRUE,
rob.only = FALSE,
#
xlab = "", xlab.pos,
smlab = NULL, smlab.pos, xlim,
#
allstudies = TRUE,
weight.study = NULL,
pscale = x$pscale,
irscale = x$irscale, irunit = x$irunit,
#
file = NULL, width = gs("width"), rows.gr = NULL,
func.gr = NULL, args.gr = NULL,
dev.off = NULL,
#
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),
#
fill = gs("fill"),
#
leftcols = gs("leftcols"),
rightcols = gs("rightcols"),
leftlabs = gs("leftlabs"),
rightlabs = gs("rightlabs"),
#
label.e = x$label.e,
label.c = x$label.c,
#
label.e.attach = gs("label.e.attach"),
label.c.attach = gs("label.c.attach"),
#
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,
col.label = gs("col.label"),
#
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 = gs("col.square.lines"),
col.circle = gs("col.circle"),
col.circle.lines = col.circle,
#
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 & !inherits(x, "metamerge"),
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,
#
common.subgroup = common,
random.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,
#
details = gs("forest.details"),
#
col.lines = gs("col.lines"),
header.line,
col.header.line = col.lines,
col.jama.line = col.subgroup,
#
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,
fs.rob = fontsize,
fs.rob.symbols = fontsize,
fs.details = 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"),
ff.rob = "plain",
ff.rob.symbols = "bold",
ff.details = "plain",
#
squaresize =
if (layout == "BMJ") 0.9 / spacing else 0.8 / spacing,
lwd.square = gs("lwd.square"),
lwd.diamond = gs("lwd.diamond"),
#
arrow.type = gs("arrow.type"),
arrow.length = gs("arrow.length"),
#
plotwidth =
if (layout %in% c("BMJ", "JAMA")) "8cm" else "6cm",
colgap = gs("colgap"),
colgap.left = colgap,
colgap.right = colgap,
colgap.studlab = colgap.left,
colgap.forest = gs("colgap.forest"),
colgap.forest.left = colgap.forest,
colgap.forest.right = colgap.forest,
colgap.rob = "1mm",
colgap.rob.overall = "2mm",
#
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,
#
bmj.text = NULL,
bmj.xpos = 0,
bmj.sep = " / ",
#
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 = gs("digits.mean"),
digits.sd = gs("digits.sd"),
digits.cor = digits,
digits.time = digits,
#
digits.n = 0,
digits.event = 0,
#
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")
#
metamerge <- inherits(x, "metamerge")
#
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.leftlabs <- missing(leftlabs)
missing.rightcols <- missing(rightcols)
missing.rightlabs <- missing(rightlabs)
#
layout <- setchar(layout, c("meta", "BMJ", "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
}
bmj <- layout == "BMJ"
revman5 <- layout == "RevMan5"
jama <- layout == "JAMA"
revman5.jama <- revman5 | jama
bmj.revman5 <- bmj | revman5
bmj.revman5.jama <- bmj | revman5 | jama
#
lsel <- TRUE
if (is.logical(leftcols)) {
if (!leftcols)
lsel <- FALSE
#
leftcols <- NULL
}
#
if (revman5.jama)
rsel <- FALSE
else
rsel <- !(is.logical(rightcols) && length(rightcols) == 1 && !rightcols)
#
chkchar(rob.text, length = 1)
chknumeric(rob.xpos, length = 1)
chklogical(rob.legend)
chklogical(rob.only)
#
text.rob <- ""
RoB.available <- !is.null(rob) && !(is.logical(rob) && !rob)
RoB.legend <- RoB.available & rob.legend
#
if (RoB.available) {
if (!inherits(rob, "rob"))
stop("Argument 'rob' must be of class \"rob\".", call. = FALSE)
#
rsel <- TRUE
#
rob.labels <-
colnames(rob)[!(colnames(rob) %in% c("Study", "Weight"))]
rob.labels[rob.labels == "Overall"] <- "O"
#
rob.categories <- attr(rob, "categories")
rob.symbols <- attr(rob, "symbols")
rob.col <- attr(rob, "col")
#
text.rob <- c("Risk of bias legend", catleg(rob))
#
rob <- rob[, !(colnames(rob) %in% c("Study", "Weight")), drop = FALSE]
#
colnames(rob)[colnames(rob) == "Overall"] <- "O"
colnames(rob) <- gsub(" ", "_", paste0("RoB.", rob.labels))
#
rightcols.rob <- colnames(rob)
#
text.rob <- text.rob[text.rob != ""]
}
else
rightcols.rob <- NULL
#
if (!rsel)
rightcols <- NULL
#
# Check for duplicate columns
#
if (length(c(rightcols, rightcols.rob, leftcols)) > 0 &&
any(duplicated(c(rightcols, rightcols.rob, leftcols))))
stop("Duplicate entries in 'leftcols' and 'rightcols'.")
#
colnames <- c("studlab",
"TE",
"seTE",
"cluster",
#
"n.e", "n.c", "event.e", "event.c",
"event.n.e", "event.n.c",
"mean.e", "mean.c", "sd.e", "sd.c",
"mean.sd.n.e", "mean.sd.n.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")
#
bmj.bin <- bmj && metabin
bmj.cont <- bmj && metacont
#
# Identify and process columns in addition to columns
# defined above in variable 'colnames'
#
colnames.new <-
c(leftcols, rightcols, rightcols.rob)[
!c(leftcols, rightcols, rightcols.rob) %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 <- c(rightcols, rightcols.rob)[
!(c(rightcols, rightcols.rob) %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.common.subgroup <- missing(common.subgroup)
missing.random.subgroup <- missing(random.subgroup)
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.common.subgroup)
warning("Argument 'common.subgroup' only considered for ",
"meta-analysis with subgroups.",
call. = FALSE)
if (!missing.random.subgroup)
warning("Argument 'random.subgroup' 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)
#
if (!is.null(file))
chkchar(file, length = 1)
#
if (!is.null(width))
chknumeric(width, min = 0, zero = TRUE, length = 1)
#
if (!is.null(rows.gr))
chknumeric(rows.gr, length = 1)
else
rows.gr <- 0
#
if (!is.null(args.gr))
chklist(args.gr)
#
if (!is.null(dev.off))
chklogical(dev.off)
else
dev.off <-
if (!is.null(file) | !is.null(func.gr))
TRUE
else
FALSE
#
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)
#
if (bmj)
type.study <- "squarediamond"
else
type.study <-
setchar(type.study,
c("square", "diamond", "predict", "circle", "squarediamond"))
#
type.common <-
setchar(type.common,
c("square", "diamond", "predict", "circle", "squarediamond"))
#
type.random <-
setchar(type.random,
c("square", "diamond", "predict", "circle", "squarediamond"))
#
type.subgroup <-
setchar(type.subgroup,
c("square", "diamond", "predict", "circle", "squarediamond"))
type.subgroup.common <-
setchar(type.subgroup.common,
c("square", "diamond", "predict", "circle", "squarediamond"))
#
type.subgroup.random <-
setchar(type.subgroup.random,
c("square", "diamond", "predict", "circle", "squarediamond"))
#
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)
#
chkcolor(col.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)
#
missing.print.I2 <- missing(print.I2)
missing.print.tau2 <- missing(print.tau2)
missing.print.tau <- missing(print.tau)
missing.print.Q <- missing(print.Q)
missing.print.pval.Q <- missing(print.pval.Q)
missing.print.Rb <- missing(print.Rb)
#
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 (bmj & overall.hetstat) {
if (!missing.print.I2 && !print.I2)
warning("Heterogeneity statistic I2 printed for BMJ layout.")
if (!missing.print.Q && !print.Q)
warning("Heterogeneity statistic Q printed for BMJ layout.")
if (!missing.print.pval.Q && !print.pval.Q)
warning("P-value of test for heterogeneity printed for BMJ layout.")
if (!missing.print.Rb && print.Rb)
warning("Heterogeneity statistic Rb not printed for BMJ layout.")
}
#
if (jama & overall.hetstat) {
if (!missing.print.I2 && !print.I2)
warning("Heterogeneity statistic I2 printed for JAMA layout.")
if (!missing.print.Q && !print.Q)
warning("Heterogeneity statistic Q printed for JAMA layout.")
if (!missing.print.pval.Q && !print.pval.Q)
warning("P-value of test for heterogeneity printed for JAMA layout.")
if (!missing.print.Rb && print.Rb)
warning("Heterogeneity statistic Rb not printed for JAMA layout.")
}
#
if (revman5 && overall.hetstat) {
if ((!missing.print.tau2 & !print.tau2 & !print.tau) |
(!missing.print.tau & !print.tau2 & !print.tau))
warning(paste("Information on between-study variance printed for",
"RevMan5 layout"))
if (!missing.print.I2 && !print.I2)
warning("Heterogeneity statistic I2 printed for RevMan5 layout.")
if (!missing.print.Q && !print.Q)
warning("Heterogeneity statistic Q printed for RevMan5 layout.")
if (!missing.print.pval.Q && !print.pval.Q)
warning("P-value of test for heterogeneity printed for RevMan5 layout.")
if (!missing.print.Rb && print.Rb)
warning("Heterogeneity statistic Rb not printed for RevMan5 layout.")
}
#
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") | bmj.revman5.jama
}
#
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)
#
if (!is.null(fontfamily)) {
chkchar(fontfamily, length = 1)
monospaced <- fontfamily %in% "Courier New"
}
else
monospaced <- FALSE
#
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.random <- missing(ff.random)
missing.ff.predict <- missing(ff.predict)
#
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)
chknumeric(lwd, length = 1)
chknumeric(lwd.square, length = 1)
chknumeric(lwd.diamond, length = 1)
#
arrow.type <- setchar(arrow.type, c("open", "closed"))
chknumeric(arrow.length, min = 0, zero = FALSE)
#
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)
#
missing.just <- missing(just)
if (missing.just && bmj)
just <- "center"
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"))
#
if (!is.null(bmj.text))
chkchar(bmj.text, length = 1)
chknumeric(bmj.xpos)
chkchar(bmj.sep, length = 1)
#
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)
chknumeric(digits.n, min = 0, length = 1)
chknumeric(digits.event, 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 (bmj) {
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 (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 (bmj) {
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 (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
}
#
chklogical(details)
#
#
# (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)
#
miss.col.circle <- missing(col.circle)
miss.col.circle.lines <- missing(col.circle.lines)
if (length(col.circle) == 1)
col.circle <- rep(col.circle, K.all)
else
chklength(col.circle, K.all, fun)
#
if (length(col.circle.lines) == 1)
col.circle.lines <- rep(col.circle.lines, K.all)
else
chklength(col.circle.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.common.subgroup)
common.subgroup <- catch("common.subgroup", mc, x, sfsp)
#
if (!missing.random.subgroup)
random.subgroup <- catch("random.subgroup", mc, x, sfsp)
#
if (!missing.prediction.subgroup & !metabind)
prediction.subgroup <- catch("prediction.subgroup", mc, x, sfsp)
#
common.subgroup <- replaceNULL(common.subgroup, FALSE)
random.subgroup <- replaceNULL(random.subgroup, FALSE)
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
# }
#
common.subgroup.logical <-
show_subgroup_results(common.subgroup, n.by,
x$lower.common.w, x$upper.common.w)
#
random.subgroup.logical <-
show_subgroup_results(random.subgroup, n.by,
x$lower.random.w, x$upper.random.w)
#
prediction.subgroup.logical <-
show_subgroup_results(prediction.subgroup, n.by,
x$lower.predict.w, x$upper.predict.w)
#
chklogical(common.subgroup[1])
chklogical(random.subgroup[1])
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) & subgroup.logical
#
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 | bmj.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 (bmj)
text.common <- paste0("Total (",
round(x$level.ma * 100), "% CI)",
if (common.random)
paste0(", ", gs("text.w.common"))
)
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 (bmj.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 | bmj.revman5)) {
if (bmj.revman5.jama) {
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 (bmj)
text.random <- paste0("Total (",
round(x$level.ma * 100), "% CI)",
if (common.random)
paste0(", ", gs("text.w.random"))
)
}
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 (bmj.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 (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) &
!(details | RoB.legend))
addrows.below.overall <- 2
else if (layout %in% c("meta", "subgroup") &
(test.subgroup.common & test.subgroup.random) &
!calcwidth.tests &
!(details | RoB.legend)) {
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 (!notmiss.xlim) {
if (metaprop || metarate || metamean ||
(metabind & sm %in% c(gs("sm4prop"), gs("sm4rate"), gs("sm4mean")))) {
xlim <- NULL
notmiss.xlim <- FALSE
}
else
xlim <- "symmetric"
}
#
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)
#
scale <- 1
if (pscale != 1 || irscale != 1) {
if (pscale != 1 && irscale != 1)
stop("Provide either arguments 'pscale' or 'irscale' but not ",
"both arguments.",
call. = FALSE)
if (pscale != 1)
scale <- pscale
else
scale <- irscale
}
#
smlab.null <- is.null(smlab)
if (smlab.null) {
if (is_rate(sm))
smlab <- xlab(sm, backtransf, irscale = irscale, irunit = irunit,
newline = !bmj.revman5.jama, revman5 = revman5,
big.mark = big.mark)
else if (is_prop(sm))
smlab <- xlab(sm, backtransf, pscale = pscale,
newline = !bmj.revman5.jama, revman5 = revman5,
big.mark = big.mark)
else
smlab <- xlab(sm, backtransf, pscale = pscale,
irscale = irscale, irunit = irunit,
newline = !bmj.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)
colgap.rob <- setunit(colgap.rob)
colgap.rob.overall <- setunit(colgap.rob.overall)
#
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 (bmj.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 (bmj.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) | sm == "VE" |
(!is.null(fbt) && fbt == "exp"))
sm.lab <- paste0("log", if (sm == "VE") "VR" else sm)
#
sel.studlab <-
pmatch(layout, c("meta", "BMJ", "RevMan5", "JAMA", "subgroup"))
lab.studlab <-
c("Study", "Study or\nsubgroup", "Study",
"Source", "Subgroup")[sel.studlab]
if (revman5 & by)
lab.studlab <- c("Study or\nSubgroup")
#
if (bmj.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 (miss.col.circle)
col.circle <- rep("darkblue", K.all)
if (miss.col.circle.lines)
col.circle.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 (miss.col.circle) {
if (metacont | metamean)
col.circle <- rep("green", K.all)
else if (metabin)
col.circle <- rep("blue", K.all)
else
col.circle <- rep("red", K.all)
}
if (miss.col.circle.lines) {
if (metacont | metamean)
col.circle.lines <- rep("green", K.all)
else if (metabin)
col.circle.lines <- rep("darkblue", K.all)
else
col.circle.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) {
if (smlab != "")
smlab <- paste0(smlab, "\n")
smlab <- paste0(smlab, lab.method[1], ", ", lab.model, ci.lab)
}
}
else if (bmj) {
sel.method <- pmatch(x$method, c("Inverse", "MH", "Peto", "GLMM"))
lab.method <- c("IV", "MH", "Peto", "GLMM")[sel.method]
#
if (common.random)
lab.model <- "common + random "
else if (common)
lab.model <- "common "
else if (random)
lab.model <- "random "
else
lab.model <- ""
#
if (smlab.null) {
if (smlab != "")
smlab <- paste0(smlab, ", ")
smlab <- paste0(smlab, lab.method[1], ",\n", 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 <- paste0("Weight", if (bmj) "\n(%)")
text.w.random <- paste0("Weight", if (bmj) "\n(%)")
}
else {
text.w.common <-
deprecated(text.w.common, missing(text.w.common), args, "text.w.fixed",
warn.deprecated)
#
if (bmj) {
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)
}
else {
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", if (sm == "VE") "VR" else 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",
label.e, label.c,
"Mean", "Mean", "SD", "SD",
label.e, label.c,
#
"Cor",
"Time", "Time",
#
sm.lab,
ci.lab,
if (bmj.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 (RoB.available)
rightlabs.new[rightlabs.new %in% colnames(rob)] <- rob.labels
#
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) {
if (metainf.metacum)
leftcols <- c(leftcols, "pval", "tau2", "tau", "I2")
#
leftcols <- c(leftcols, "effect.ci")
}
else {
if (metabin) {
if (study.results) {
if (bmj) {
leftcols <- c(leftcols,
"event.n.e",
"event.n.c")
label.e.attach <- "event.n.e"
#
if (is.null(bmj.text))
label.e <- "No of events / total"
else
label.e <- bmj.text
}
else
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 (bmj) {
leftcols <- c(leftcols,
"mean.sd.n.e",
"mean.sd.n.c")
label.e.attach <- "mean.sd.n.e"
#
if (is.null(bmj.text))
label.e <- "Mean (SD) / total"
else
label.e <- bmj.text
}
else 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") & !metamerge) {
if (common && !all(is.na(x$w.common)))
leftcols <- c(leftcols, "w.common")
if (random && !all(is.na(x$w.random)))
leftcols <- c(leftcols, "w.random")
}
else if (metainf.metacum)
leftcols <- c(leftcols, "pval", "tau2", "tau", "I2")
#
leftcols <- c(leftcols, "effect.ci")
}
#
# Add columns if risk of bias assessmen is only information on
# right side of the forest plot
#
if (!revman5.jama & rob.only) {
#
if (!metainf.metacum & overall & study.results &
!any(x$method == "GLMM") & !metamerge) {
if (common)
leftcols <- c(leftcols, "w.common")
if (random)
leftcols <- c(leftcols, "w.random")
}
else if (metainf.metacum)
leftcols <- c(leftcols, "pval", "tau2", "tau", "I2")
#
if (bmj)
leftcols <- c(leftcols, "effect.ci")
else
leftcols <- c(leftcols, "effect", "ci")
}
}
#
leftcols[leftcols == "w.fixed"] <- "w.common"
leftcols <- unique(leftcols)
#
if (is.null(rightcols) && rsel) {
if (bmj)
rightcols <- "effect.ci"
else
rightcols <- c("effect", "ci")
#
if (!metainf.metacum & overall & study.results &
!any(x$method == "GLMM") & !metamerge) {
wcols <- c(if (common && !all(is.na(x$w.common))) "w.common",
if (random && !all(is.na(x$w.random))) "w.random")
#
if (bmj)
rightcols <- c(wcols, rightcols)
else
rightcols <- c(rightcols, wcols)
}
#
if (metainf.metacum)
rightcols <- c(rightcols, "pval", "tau2", "tau", "I2")
}
else if (RoB.available & rob.only &
missing.leftcols & !revman5.jama) {
if (!metainf.metacum & overall & study.results &
!any(x$method == "GLMM" & !metamerge)) {
if (common)
leftcols <- c(leftcols, "w.common")
if (random)
leftcols <- c(leftcols, "w.random")
}
#
if (bmj)
leftcols <- c(leftcols, "effect.ci")
else
leftcols <- c(leftcols, "effect", "ci")
}
#
rightcols[rightcols == "w.fixed"] <- "w.common"
rightcols <- unique(rightcols)
#
if (rob.only)
rightcols <- rightcols.rob
else
rightcols <- c(rightcols, rightcols.rob)
#
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.circle <- col.circle[sel]
col.circle.lines <- col.circle.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.circle <- col.circle[o]
col.circle.lines <- col.circle.lines[o]
#
col.inside <- col.inside[o]
#
if (!null.exclude)
exclude <- exclude[o]
#
if (newcols) {
dataset1 <- dataset1[o, ]
dataset2 <- dataset2[o, ]
#
if (RoB.available)
rob <- rob[o, ]
}
}
#
if (bmj)
studlab <- paste0(" ", studlab)
#
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
#
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) {
Q.b.common <- unlist(x$Q.b.common)
names(Q.b.common) <- colnames(lower.common.w)
Q.w.common <- x$Q.w.common
#
Q.b.random <- unlist(x$Q.b.random)
Q.w.random <- x$Q.w.random
#
Q.w <- x$Q.w
#
df.Q.w <- replaceNULL(x$df.Q.w, sum((k.w - 1)[!is.na(x$Q.w)]))
df.Q.b <- replaceNULL(x$df.Q.b, (k - 1) - sum((k.w - 1)[!is.na(x$Q.w)]))
df.Q.b.common <- replaceNULL(x$df.Q.b.common, df.Q.b)
df.Q.b.random <- replaceNULL(x$df.Q.b.random, df.Q.b)
#
pval.Q.b.common <-
replaceNULL(x$pval.Q.b.common, pvalQ(Q.b.common, df.Q.b.common))
pval.Q.w.common <-
replaceNULL(x$pval.Q.w.common, pvalQ(Q.w.common, df.Q.w))
#
pval.Q.b.random <-
unlist(replaceNULL(x$pval.Q.b.random, pvalQ(Q.b.random, df.Q.b.random)))
pval.Q.w.random <-
unlist(replaceNULL(x$pval.Q.w.random, pvalQ(Q.w.random, df.Q.w)))
#
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 <- Q.b.random <- NA
df.Q.b <- df.Q.b.common <- df.Q.b.random <- NA
pval.Q.b.common <- pval.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 (bmj.revman5) ", df",
if (bmj.revman5) hetseparator,
if (bmj.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.tau))
hetstat.tau <- gsub(" ", " ", hetstat.tau)
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 (bmj) {
hetstat.tau2 <- gsub(" = ", "=", hetstat.tau2)
hetstat.tau <- gsub(" = ", "=", hetstat.tau)
hetstat.Q <- gsub(" = ", "=", hetstat.Q)
hetstat.pval.Q <- gsub(" = ", "=", hetstat.pval.Q)
hetstat.I2 <- gsub(" = ", "=", hetstat.I2)
}
#
if (bmj) {
if (print.tau)
hetstat.overall <-
substitute(
paste(hl,
tau, ht, "; ",
chi^2, hq,
", P", hp, "; ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2,
df = df.Q)
)
else if (print.tau2)
hetstat.overall <-
substitute(
paste(hl,
tau^2, ht, "; ",
chi^2, hq,
", P", hp, "; ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau2,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2,
df = df.Q)
)
else
hetstat.overall <-
substitute(
paste(hl,
chi^2, hq,
", P", hp, "; ",
I^2, hi),
list(hl = hetlab,
hi = hetstat.I2,
hq = hetstat.Q,
hp = hetstat.pval.Q,
df = df.Q)
)
}
else if (jama) {
if (!missing.print.tau2 | !missing.print.tau) {
if (print.tau)
hetstat.overall <-
substitute(
paste(hl,
chi[df]^2, hq,
" (", italic(P), hp, "), ",
italic(I)^2, hi, ", ",
tau, ht),
list(hl = hetlab,
df = df.Q,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2,
ht = hetstat.tau)
)
else if (print.tau2)
hetstat.overall <-
substitute(
paste(hl,
chi[df]^2, hq,
" (", italic(P), hp, "), ",
italic(I)^2, hi, ", ",
tau^2, ht),
list(hl = hetlab,
df = df.Q,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2,
ht = hetstat.tau2)
)
else
hetstat.overall <-
substitute(
paste(hl,
chi[df]^2, hq,
" (", italic(P), hp, "), ",
italic(I)^2, hi),
list(hl = hetlab,
df = df.Q,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2)
)
}
else
hetstat.overall <-
substitute(
paste(hl,
chi[df]^2, hq,
" (", italic(P), hp, "), ",
italic(I)^2, hi),
list(hl = hetlab,
df = df.Q,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2)
)
}
else if (revman5) {
if (print.tau)
hetstat.overall <-
substitute(
paste(hl,
"Tau", ht, "; ",
"Chi"^2, hq,
" (", P, hp, "); ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2)
)
else
hetstat.overall <-
substitute(
paste(hl,
"Tau"^2, ht, "; ",
"Chi"^2, hq,
" (", P, hp, "); ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau2,
hq = hetstat.Q,
hp = hetstat.pval.Q,
hi = hetstat.I2)
)
}
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 (bmj.revman5) ", df",
if (bmj.revman5) hetseparator,
if (bmj.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 (bmj) {
if (print.tau)
hetstat.resid <-
substitute(
paste(hl,
tau, ht, "; ",
chi^2, hq,
", df=",
df,
", P"=, hp,
"; ",
I^2, hi),
list(hl = resid.hetlab,
ht = hetstat.tau.resid,
df = df.Q,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
hi = hetstat.I2.resid)
)
else
hetstat.resid <-
substitute(
paste(hl,
tau^2, ht, "; ",
chi^2, hq,
", df=",
df,
", P"=, hp,
"; ",
I^2, hi),
list(hl = resid.hetlab,
df = df.Q.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
hi = hetstat.I2.resid)
)
}
else if (jama) {
if (!missing.print.tau2 | !missing.print.tau) {
if (print.tau)
hetstat.resid <-
substitute(
paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi,
tau, ht),
list(hl = resid.hetlab,
df = df.Q.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
hi = hetstat.I2.resid,
ht = hetstat.tau.resid)
)
else if (print.tau2)
hetstat.resid <-
substitute(
paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi,
tau^2, ht),
list(hl = resid.hetlab,
df = df.Q.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
hi = hetstat.I2.resid,
ht = hetstat.tau2.resid)
)
else
hetstat.resid <-
substitute(
paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi),
list(hl = resid.hetlab,
df = df.Q.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
hi = hetstat.I2.resid)
)
}
}
else if (revman5) {
if (print.tau)
hetstat.resid <-
substitute(
paste(hl,
"Tau", ht, "; ",
"Chi"^2, hq,
" (", P, hp, "); ",
I^2, hi),
list(hl = resid.hetlab,
ht = hetstat.tau.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
hi = hetstat.I2.resid)
)
else
hetstat.resid <-
substitute(
paste(hl,
"Tau"^2, ht, "; ",
"Chi"^2, hq,
" (", P, hp, "); ",
I^2, hi),
list(hl = resid.hetlab,
ht = hetstat.tau2.resid,
hq = hetstat.Q.resid,
hp = hetstat.pval.Q.resid,
hi = hetstat.I2.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 (bmj)
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 (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 (bmj)
text.overall.common <-
substitute(paste(tl, " P", tp),
list(tl = label.test.overall.common,
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 (bmj)
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 (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 (bmj)
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 (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 (bmj)
text.overall.random <-
substitute(paste(tl, " P", tp),
list(tl = label.test.overall.random,
tp = pvals.overall[2]))
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))
#
#
if (by)
hetstat.Q.b.common <- hetstat.pval.Q.b.common <-
hetstat.Q.b.random <- hetstat.pval.Q.b.random <- NULL
else
hetstat.Q.b.common <- hetstat.pval.Q.b.common <-
hetstat.Q.b.random <- hetstat.pval.Q.b.random <- NA
#
for (i in seq_along(Q.b.common)) {
hetstat.i <-
paste0(hetseparator,
gsub(" ", "",
formatN(Q.b.common[i], digits.Q, "NA", big.mark = big.mark)),
if (!jama) ", df",
if (!jama) hetseparator,
if (!jama) df.Q.b.common[i])
#
pval.i <-
paste0(formatPT(pval.Q.b.common[i],
lab = TRUE, labval = "",
digits = digits.pval.Q,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA"))
#
# Remove superfluous spaces
#
hetstat.i <- rmSpace(hetstat.i, end = TRUE)
pval.i <- rmSpace(pval.i, end = TRUE)
#
while(any(grepl(" ", hetstat.i)))
hetstat.i <- gsub(" ", " ", hetstat.i)
while(any(grepl(" ", pval.i)))
pval.i <- gsub(" ", " ", pval.i)
#
hetstat.Q.b.common <- c(hetstat.Q.b.common, hetstat.i)
hetstat.pval.Q.b.common <- c(hetstat.pval.Q.b.common, pval.i)
}
#
for (i in seq_along(Q.b.random)) {
hetstat.i <-
paste0(hetseparator,
gsub(" ", "",
formatN(Q.b.random[i], digits.Q, "NA", big.mark = big.mark)),
if (!jama) ", df",
if (!jama) hetseparator,
if (!jama) collapse(df.Q.b.random[[i]], quote = ""))
#
pval.i <-
paste0(formatPT(pval.Q.b.random[i],
lab = TRUE, labval = "",
digits = digits.pval.Q,
zero = zero.pval, JAMA = JAMA.pval,
scientific = scientific.pval,
lab.NA = "NA"))
#
# Remove superfluous spaces
#
hetstat.i <- rmSpace(hetstat.i, end = TRUE)
pval.i <- rmSpace(pval.i, end = TRUE)
#
while(any(grepl(" ", hetstat.i)))
hetstat.i <- gsub(" ", " ", hetstat.i)
while(any(grepl(" ", pval.i)))
pval.i <- gsub(" ", " ", pval.i)
#
hetstat.Q.b.random <- c(hetstat.Q.b.random, hetstat.i)
hetstat.pval.Q.b.random <- c(hetstat.pval.Q.b.random, pval.i)
}
#
if (test.subgroup.common) {
if (print.Q.subgroup) {
if (bmj)
text.subgroup.common <-
substitute(paste(tl,
chi^2, tq,
", P", tp),
list(tl = label.test.subgroup.common,
tq = hetstat.Q.b.common[1],
tp = hetstat.pval.Q.b.common[1]))
else if (revman5)
text.subgroup.common <-
substitute(paste(tl,
"Chi"^2, tq,
" (P", tp, ")"),
list(tl = label.test.subgroup.common,
tq = hetstat.Q.b.common[1],
tp = hetstat.pval.Q.b.common[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.b.common[1],
tp = hetstat.pval.Q.b.common[1],
df = df.Q.b.common[1]))
else
text.subgroup.common <-
substitute(paste(tl,
chi[df]^2, tq,
" (", italic(p), tp, ")"),
list(tl = label.test.subgroup.common,
tq = hetstat.Q.b.common[1],
tp = hetstat.pval.Q.b.common[1],
df = df.Q.b.common[1]))
}
else {
if (bmj)
text.subgroup.common <-
substitute(paste(tl, " P", tp),
list(tl = label.test.subgroup.common,
tp = hetstat.pval.Q.b.common[1]))
else if (revman5)
text.subgroup.common <-
substitute(paste(tl, " P", tp),
list(tl = label.test.subgroup.common,
tp = hetstat.pval.Q.b.common[1]))
else if (jama)
text.subgroup.common <-
substitute(paste(tl, " ", italic(P), tp),
list(tl = label.test.subgroup.common,
tp = hetstat.pval.Q.b.common[1]))
else
text.subgroup.common <-
substitute(paste(tl, " ", italic(p), tp),
list(tl = label.test.subgroup.common,
tp = hetstat.pval.Q.b.common[1]))
}
}
else
text.subgroup.common <- ""
#
if (test.subgroup.random) {
if (print.Q.subgroup) {
if (bmj) {
if (length(df.Q.b.random[[1]]) == 2)
text.subgroup.random <-
substitute(paste(tl, "F", tq, ", P", tp),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1]))
else
text.subgroup.random <-
substitute(paste(tl, chi^2, tq, " P", tp),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1]))
}
else if (revman5) {
if (length(df.Q.b.random[[1]]) == 2)
text.subgroup.random <-
substitute(paste(tl,
"F", tq,
" (P", tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1]))
else
text.subgroup.random <-
substitute(paste(tl,
"Chi"^2, tq,
" (P", tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1]))
}
else if (jama) {
if (length(df.Q.b.random[[1]]) == 2)
text.subgroup.random <-
substitute(paste(tl,
F[df], tq,
" (", italic(P), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1],
df = paste(df.Q.b.random[[1]], collapse = ", ")))
else
text.subgroup.random <-
substitute(paste(tl,
chi[df]^2, tq,
" (", italic(P), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1],
df = df.Q.b.random[[1]]))
}
else {
if (length(df.Q.b.random[[1]]) == 2)
text.subgroup.random <-
substitute(paste(tl,
F[df], tq,
" (", italic(p), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1],
df = paste(df.Q.b.random[[1]], collapse = ", ")))
else
text.subgroup.random <-
substitute(paste(tl,
chi[df]^2, tq,
" (", italic(p), tp, ")"),
list(tl = label.test.subgroup.random,
tq = hetstat.Q.b.random[1],
tp = hetstat.pval.Q.b.random[1],
df = df.Q.b.random[[1]]))
}
}
else {
if (bmj)
text.subgroup.random <-
substitute(paste(tl, " P", tp),
list(tl = label.test.subgroup.random,
tp = hetstat.pval.Q.b.random[1]))
else if (revman5)
text.subgroup.random <-
substitute(paste(tl, " P", tp),
list(tl = label.test.subgroup.random,
tp = hetstat.pval.Q.b.random[1]))
else if (jama)
text.subgroup.random <-
substitute(paste(tl, " ", italic(P), tp),
list(tl = label.test.subgroup.random,
tp = hetstat.pval.Q.b.random[1]))
else
text.subgroup.random <-
substitute(paste(tl, " ", italic(p), tp),
list(tl = label.test.subgroup.random,
tp = hetstat.pval.Q.b.random[1]))
}
}
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.common.w <- list2vec(TE.common.w)
lower.common.w <- list2vec(lower.common.w)
upper.common.w <- list2vec(upper.common.w)
statistic.common.w <- list2vec(statistic.common.w)
pval.common.w <- list2vec(pval.common.w)
#
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)
#
TE.random.w <- list2vec(TE.random.w)
lower.random.w <- list2vec(lower.random.w)
upper.random.w <- list2vec(upper.random.w)
statistic.random.w <- list2vec(statistic.random.w)
pval.random.w <- list2vec(pval.random.w)
#
lower.predict.w <- ordermat(lower.predict.w, subgroup.levels)
upper.predict.w <- ordermat(upper.predict.w, subgroup.levels)
#
lower.predict.w <- list2vec(lower.predict.w)
upper.predict.w <- list2vec(upper.predict.w)
#
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]
#
if (is.list(x$tau2.w))
x$tau2.w <- x$tau2.w[[1]]
if (is.list(x$tau.w))
x$tau.w <- x$tau.w[[1]]
#
tau2.w <- x$tau2.w[o.w]
tau.w <- x$tau.w[o.w]
#
w.common.w <- collapsemat(x$w.common.w)
if (is.list(w.common.w))
w.common.w <- w.common.w[[1]]
#
w.random.w <- collapsemat(x$w.random.w)
if (is.list(w.random.w))
w.random.w <- w.random.w[[1]]
#
w.common.w <- collapsemat(w.common.w)[o.w]
w.random.w <- collapsemat(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]
#
common.subgroup.logical <- common.subgroup.logical[o.w]
random.subgroup.logical <- random.subgroup.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]
#
common.subgroup.logical <- common.subgroup.logical[sel.w]
random.subgroup.logical <- random.subgroup.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 confidence or prediction intervals in
# subgroups to format confidence limits
#
sel.NA <- !repl(common.subgroup.logical, n.com, n.by)
lower.common.w[sel.NA] <- NA
upper.common.w[sel.NA] <- NA
#
sel.NA <- !repl(random.subgroup.logical, n.ran, n.by)
lower.random.w[sel.NA] <- NA
upper.random.w[sel.NA] <- NA
#
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 (bmj.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 (bmj) {
if (print.tau)
hetstat.w[[i]] <-
substitute(
paste(hl,
tau, ht, "; ",
chi^2, hq,
", P", hp,
"; ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i])
)
else if (print.tau2)
hetstat.w[[i]] <-
substitute(
paste(hl,
tau^2, ht, "; ",
chi^2, hq,
", P", hp,
"; ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i])
)
else
hetstat.w[[i]] <-
substitute(
paste(hl,
chi^2, hq,
", P", hp,
"; ",
I^2, hi),
list(hl = hetlab,
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i])
)
}
else if (jama) {
if (!missing.print.tau2 | !missing.print.tau) {
if (print.tau)
hetstat.w[[i]] <-
substitute(
paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi,
tau, ht),
list(hl = hetlab,
df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i],
ht = hetstat.tau.w[i])
)
else if (print.tau2)
hetstat.w[[i]] <-
substitute(
paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi,
tau^2, ht),
list(hl = hetlab,
df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i],
ht = hetstat.tau2.w[i])
)
else
hetstat.w[[i]] <-
substitute(
paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi),
list(hl = hetlab,
df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i])
)
}
else
hetstat.w[[i]] <-
substitute(
paste(hl,
chi[df]^2, hq,
" (",
italic(P), hp,
"), ",
italic(I)^2, hi),
list(hl = hetlab,
df = k.w.hetstat[i] - 1,
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i])
)
}
else if (revman5) {
if (print.tau)
hetstat.w[[i]] <-
substitute(
paste(hl,
"Tau", ht, "; ",
"Chi"^2, hq,
" (",
P, hp,
"); ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau.w[i],
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i])
)
else
hetstat.w[[i]] <-
substitute(
paste(hl,
"Tau"^2, ht, "; ",
"Chi"^2, hq,
" (",
P, hp,
"); ",
I^2, hi),
list(hl = hetlab,
ht = hetstat.tau2.w[i],
hq = hetstat.Q.w[i],
hp = hetstat.pval.Q.w[i],
hi = hetstat.I2.w[i])
)
}
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 (bmj)
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 (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 (bmj)
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 (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 (bmj)
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 (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 (bmj)
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 (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 (bmj)
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 (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]] <- ""
}
}
#
x$pscale <- pscale
x$irscale <- irscale
#
text.details <- ""
if (details) {
if (K.all == 1) {
text.details <-
catmeth(x,
common, random, prediction, overall, overall.hetstat,
x$func.transf, backtransf, fbt,
big.mark, digits, digits.tau, gs("text.tau"), gs("text.tau2"),
print.tau2 = FALSE,
forest = TRUE)
}
else {
text.details <-
catmeth(x,
common, random, prediction, overall, overall.hetstat,
x$func.transf, backtransf, fbt,
big.mark, digits, digits.tau, gs("text.tau"), gs("text.tau2"),
print.tau2, print.tau2.ci,
print.tau, print.tau.ci,
forest = TRUE)
}
#
text.details <- unlist(strsplit(text.details, "\n"))
text.details <- text.details[text.details != ""]
#
td <- vector("list", length(text.details))
#
for (i in seq_along(text.details))
td[[i]] <- text.details[i]
#
is.tau <- grepl(" for tau", td, fixed = TRUE)
is.tau.c <- grepl("assuming common", td, fixed = TRUE)
is.tau <- ifelse(is.tau & is.tau.c, FALSE, is.tau)
#
any.tau <- sum(is.tau)
any.tau.c <- sum(is.tau.c)
#
if (any.tau | any.tau.c) {
id.tau <- seq_along(is.tau)[is.tau]
id.tau.c <- seq_along(is.tau.c)[is.tau.c]
#
if (print.tau) {
if (any.tau.c)
for (i in id.tau.c)
td[[i]] <-
gsub(" for tau (assuming common tau in subgroups)", " for ",
td[[i]], fixed = TRUE)
#
if (any.tau)
for (i in id.tau)
td[[i]] <-
gsub(" for tau", " for ", td[[i]], fixed = TRUE)
}
else {
if (any.tau.c)
for (i in id.tau.c)
td[[i]] <-
gsub(" for tau^2 (assuming common tau^2 in subgroups)", " for ",
td[[i]], fixed = TRUE)
#
if (any.tau)
for (i in id.tau)
td[[i]] <-
gsub(" for tau^2", " for ", td[[i]], fixed = TRUE)
}
#
if (print.tau) {
if (revman5) {
if (any.tau.c)
for (i in id.tau.c)
td[[i]] <-
substitute(paste(txt1, txt2),
list(txt1 = td[[i]],
txt2 =
"Tau (assuming common Tau in subgroups)"))
#
if (any.tau)
for (i in id.tau)
td[[i]] <-
substitute(paste(txt1, txt2),
list(txt1 = td[[i]], txt2 = "Tau"))
}
else {
if (any.tau.c)
for (i in id.tau.c)
td[[i]] <-
substitute(paste(txt1, tau, txt2, tau, txt3),
list(txt1 = td[[i]],
txt2 = " (assuming common ",
txt3 = " in subgroups)"))
#
if (any.tau)
for (i in id.tau)
td[[i]] <-
substitute(paste(txt, tau), list(txt = td[[i]]))
}
}
else {
if (revman5) {
if (any.tau.c)
for (i in id.tau.c)
td[[i]] <-
substitute(paste(txt1, txt2^2, txt3, txt4^2, txt5),
list(txt1 = td[[i]],
txt2 = "Tau",
txt3 = " (assuming common ",
txt4 = "Tau",
txt5 = " in subgroups)"))
#
if (any.tau)
for (i in id.tau)
td[[i]] <-
substitute(paste(txt1, txt2^2),
list(txt1 = td[[i]], txt2 = "Tau"))
}
else {
if (any.tau.c)
for (i in id.tau.c)
td[[i]] <-
substitute(paste(txt1, tau^2, txt2, tau^2, txt3),
list(txt1 = td[[i]],
txt2 = " (assuming common ",
txt3 = " in subgroups)"))
#
if (any.tau)
for (i in id.tau)
td[[i]] <-
substitute(paste(txt, tau^2), list(txt = td[[i]]))
}
}
}
#
tau.ci.line <-
grepl(" of tau^2 and tau", text.details, fixed = TRUE) |
grepl(" of tau", text.details, fixed = TRUE) |
grepl(" of tau^2", text.details, fixed = TRUE)
#
if (any(tau.ci.line)) {
id <- seq_along(tau.ci.line)[tau.ci.line]
#
for (i in id) {
td[[i]] <- gsub(" of tau^2 and tau", " of ", td[[i]], fixed = TRUE)
td[[i]] <- gsub(" of tau", " of ", td[[i]], fixed = TRUE)
td[[i]] <- gsub(" of tau^2", " of ", td[[i]], fixed = TRUE)
}
#
if (print.tau.ci) {
if (revman5)
for (i in id)
td[[i]] <-
substitute(paste(txt1, txt2),
list(txt1 = td[[i]], txt2 = "Tau"))
else
for (i in id)
td[[i]] <- substitute(paste(txt1, tau), list(txt1 = td[[i]]))
}
else {
if (revman5)
for (i in id)
td[[i]] <-
substitute(paste(txt1, txt2^2),
list(txt1 = td[[i]], txt2 = "Tau"))
else
for (i in id)
td[[i]] <- substitute(paste(txt1, tau^2), list(txt1 = td[[i]]))
}
}
#
text.details <- td
}
#
#
# (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, npft, npft, fbt, abt)
#
if (!log.xaxis) {
lowTE <- backtransf(lowTE, sm, npft, npft, fbt, abt)
uppTE <- backtransf(uppTE, sm, npft, npft, fbt, abt)
}
#
# Results of meta-analysis
#
if (!log.xaxis) {
TE.common <- backtransf(TE.common, sm, npft.ma, npft.ma, fbt, abt)
lowTE.common <- backtransf(lowTE.common, sm, npft.ma, npft.ma, fbt, abt)
uppTE.common <- backtransf(uppTE.common, sm, npft.ma, npft.ma, fbt, abt)
#
TE.random <- backtransf(TE.random, sm, npft.ma, npft.ma, fbt, abt)
lowTE.random <- backtransf(lowTE.random, sm, npft.ma, npft.ma, fbt, abt)
uppTE.random <- backtransf(uppTE.random, sm, npft.ma, npft.ma, fbt, abt)
#
if (!metainf.metacum) {
lowTE.predict <-
backtransf(lowTE.predict, sm, npft.ma, npft.ma, fbt, abt)
uppTE.predict <-
backtransf(uppTE.predict, sm, npft.ma, 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, npft.w, npft.w, fbt, abt)
lowTE.w <- backtransf(lowTE.w, sm, npft.w, npft.w, fbt, abt)
uppTE.w <- backtransf(uppTE.w, sm, npft.w, npft.w, fbt, abt)
}
}
#
# Apply argument 'pscale' or 'irscale'
#
TE <- scale * TE
lowTE <- scale * lowTE
uppTE <- scale * uppTE
#
TE.common <- scale * TE.common
lowTE.common <- scale * lowTE.common
uppTE.common <- scale * uppTE.common
#
TE.random <- scale * TE.random
lowTE.random <- scale * lowTE.random
uppTE.random <- scale * uppTE.random
#
lowTE.predict <- scale * lowTE.predict
uppTE.predict <- scale * uppTE.predict
#
if (by) {
TE.w <- scale * TE.w
lowTE.w <- scale * lowTE.w
uppTE.w <- scale * uppTE.w
}
#
# Switch lower and upper limit for VE if results have been
# backtransformed
#
if (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
}
}
}
#
# Set study confidence intervals to NA if they should not be printed
#
if (!study.results) {
lowTE[!is.na(lowTE)] <- NA
uppTE[!is.na(uppTE)] <- NA
}
#
# 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 'event.n.e'
#
clines <- twolines(labs[["lab.event.n.e"]], "event.n.e")
#
if (clines$newline) {
newline.event.n.e <- TRUE
labs[["lab.event.n.e"]] <- clines$bottom
add.event.n.e <- clines$top
longer.event.n.e <- clines$longer
}
else {
newline.event.n.e <- FALSE
longer.event.n.e <- labs[["lab.event.n.e"]]
}
#
# Check for "\n" in label of column 'event.n.c'
#
clines <- twolines(labs[["lab.event.n.c"]], "event.n.c")
#
if (clines$newline) {
newline.event.n.c <- TRUE
labs[["lab.event.n.c"]] <- clines$bottom
add.event.n.c <- clines$top
longer.event.n.c <- clines$longer
}
else {
newline.event.n.c <- FALSE
longer.event.n.c <- labs[["lab.event.n.c"]]
}
#
# Check for "\n" in label of column 'mean.sd.n.e'
#
clines <- twolines(labs[["lab.mean.sd.n.e"]], "mean.sd.n.e")
#
if (clines$newline) {
newline.mean.sd.n.e <- TRUE
labs[["lab.mean.sd.n.e"]] <- clines$bottom
add.mean.sd.n.e <- clines$top
longer.mean.sd.n.e <- clines$longer
}
else {
newline.mean.sd.n.e <- FALSE
longer.mean.sd.n.e <- labs[["lab.mean.sd.n.e"]]
}
#
# Check for "\n" in label of column 'mean.sd.n.c'
#
clines <- twolines(labs[["lab.mean.sd.n.c"]], "mean.sd.n.c")
#
if (clines$newline) {
newline.mean.sd.n.c <- TRUE
labs[["lab.mean.sd.n.c"]] <- clines$bottom
add.mean.sd.n.c <- clines$top
longer.mean.sd.n.c <- clines$longer
}
else {
newline.mean.sd.n.c <- FALSE
longer.mean.sd.n.c <- labs[["lab.mean.sd.n.c"]]
}
#
# 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,
if (details) text.details else NULL,
if (RoB.legend) text.rob else NULL,
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,
monospaced = monospaced))
#
seTEs.study <- c(blanks, blanks.w,
formatN(seTE, digits.se, lab.NA, big.mark = big.mark,
monospaced = monospaced))
#
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,
monospaced = monospaced)
Wr.format <-
formatN(format.w.randoms, digits.weight, text.NA = lab.NA.weight,
monospaced = monospaced)
#
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,
if (details) text.details else NULL,
if (RoB.legend) text.rob else NULL,
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,
monospaced = monospaced)
format.w.random <- formatN(c(100, w.random.p), digits.weight,
monospaced = monospaced)
#
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(scale * exp(TEs / scale),
digits, lab.NA.effect, big.mark = big.mark)
ci.format <-
ifelse(is.na(lowTEs) | is.na(uppTEs), lab.NA.effect,
formatCI(formatN(scale * exp(lowTEs / scale),
digits = digits, text.NA = lab.NA,
big.mark = big.mark),
formatN(scale * exp(uppTEs / scale),
digits = digits, text.NA = lab.NA,
big.mark = big.mark)))
}
else {
effect.format <- formatN(TEs, digits, lab.NA.effect, big.mark = big.mark,
monospaced = monospaced)
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,
monospaced = monospaced),
formatN(uppTEs, digits = digits, text.NA = lab.NA,
big.mark = big.mark,
monospaced = monospaced)))
}
#
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 & !bmj) "%")
Wr.format <- paste0(Wr.format, if (w.random.percent & !bmj) "%")
#
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 = digits.n, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
Nc.format <-
formatN(Nc, digits = digits.n, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
Ee.format <-
formatN(Ee, digits = digits.event, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
Ec.format <-
formatN(Ec, digits = digits.event, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
#
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,
monospaced = monospaced)
else
Me.format <-
formatN(Me, digits = digits.R, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
#
if (all(is_wholenumber(Mc), na.rm = TRUE))
Mc.format <-
formatN(Mc, digits = 0, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
else
Mc.format <-
formatN(Mc, digits = digits.R, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
}
else {
Me.format <- formatN(Me, digits.mean, lab.NA, big.mark = big.mark,
monospaced = monospaced)
Mc.format <- formatN(Mc, digits.mean, lab.NA, big.mark = big.mark,
monospaced = monospaced)
}
#
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,
monospaced = monospaced)
else
Se.format <-
formatN(Se, digits = digits.R, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
#
if (all(is_wholenumber(Sc), na.rm = TRUE))
Sc.format <-
formatN(Sc, digits = 0, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
else
Sc.format <-
formatN(Sc, digits = digits.R, text.NA = lab.NA, big.mark = big.mark,
monospaced = monospaced)
}
else {
Se.format <- formatN(Se, digits.sd, lab.NA, big.mark = big.mark,
monospaced = monospaced)
Sc.format <- formatN(Sc, digits.sd, lab.NA, big.mark = big.mark,
monospaced = monospaced)
}
#
# 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] <- ""
}
#
if (bmj.bin) {
Ee.bmj <- Ee.format
Ec.bmj <- Ec.format
#
Ne.bmj <- Ne.format
Nc.bmj <- Nc.format
#
Ne.bmj <- ifelse(Ee.bmj == "", "", Ne.bmj)
Nc.bmj <- ifelse(Ec.bmj == "", "", Nc.bmj)
#
while(all(substring(Ee.bmj[Ee.bmj != ""], 1, 1) == " "))
Ee.bmj[Ee.bmj != ""] <- substring(Ee.bmj[Ee.bmj != ""], 2)
#
while(all(substring(Ec.bmj[Ec.bmj != ""], 1, 1) == " "))
Ec.bmj[Ec.bmj != ""] <- substring(Ec.bmj[Ec.bmj != ""], 2)
#
while(all(substring(Ne.bmj[Ne.bmj != ""], 1, 1) == " "))
Ne.bmj[Ne.bmj != ""] <- substring(Ne.bmj[Ne.bmj != ""], 2)
#
while(all(substring(Nc.bmj[Nc.bmj != ""], 1, 1) == " "))
Nc.bmj[Nc.bmj != ""] <- substring(Nc.bmj[Nc.bmj != ""], 2)
#
Ne.bmj <- rmSpace(Ne.bmj, end = FALSE)
if (monospaced) {
nchar.Ne.bmj <- nchar(Ne.bmj)
Ne.bmj[nchar.Ne.bmj > 0] <-
str_pad(Ne.bmj[nchar.Ne.bmj > 0], width = max(nchar.Ne.bmj),
side = "right")
}
#
Nc.bmj <- rmSpace(Nc.bmj, end = FALSE)
if (monospaced) {
nchar.Nc.bmj <- nchar(Nc.bmj)
Nc.bmj[nchar.Nc.bmj > 0] <-
str_pad(Nc.bmj[nchar.Nc.bmj > 0], width = max(nchar.Nc.bmj),
side = "right")
}
#
event.n.e.format <-
ifelse(Ee.bmj != "",
paste0(Ee.bmj, bmj.sep, Ne.bmj),
"")
event.n.c.format <-
ifelse(Ec.format != "",
paste0(Ec.bmj, bmj.sep, Nc.bmj),
"")
#
if (pooled.totals & !pooled.events) {
event.n.e.format[Ne.format != "" & Ee.format == ""] <-
Ne.format[Ne.format != "" & Ee.format == ""]
event.n.c.format[Nc.format != "" & Ec.format == ""] <-
Nc.format[Nc.format != "" & Ec.format == ""]
}
}
#
if (bmj.cont) {
Ne.bmj <- Ne.format
Nc.bmj <- Nc.format
#
while(all(substring(Ne.bmj[Ne.bmj != ""], 1, 1) == " "))
Ne.bmj[Ne.bmj != ""] <- substring(Ne.bmj[Ne.bmj != ""], 2)
#
while(all(substring(Nc.bmj[Nc.bmj != ""], 1, 1) == " "))
Nc.bmj[Nc.bmj != ""] <- substring(Nc.bmj[Nc.bmj != ""], 2)
#
Ne.bmj <- rmSpace(Ne.bmj, end = FALSE)
if (monospaced) {
nchar.Ne.bmj <- nchar(Ne.bmj)
Ne.bmj[nchar.Ne.bmj > 0] <-
str_pad(Ne.bmj[nchar.Ne.bmj > 0], width = max(nchar.Ne.bmj),
side = "right")
}
#
Nc.bmj <- rmSpace(Nc.bmj, end = FALSE)
if (monospaced) {
nchar.Nc.bmj <- nchar(Nc.bmj)
Nc.bmj[nchar.Nc.bmj > 0] <-
str_pad(Nc.bmj[nchar.Nc.bmj > 0], width = max(nchar.Nc.bmj),
side = "right")
}
#
mean.sd.n.e.format <-
ifelse(Me.format != "",
paste0(Me.format, " (", Se.format, ")", bmj.sep, Ne.bmj),
"")
mean.sd.n.c.format <-
ifelse(Mc.format != "",
paste0(Mc.format, " (", Sc.format, ")", bmj.sep, Nc.bmj),
"")
#
sel.e <- Ne.format != "" & mean.sd.n.e.format == ""
mean.sd.n.e.format[sel.e] <- Ne.format[sel.e]
#
sel.c <- Nc.format != "" & mean.sd.n.c.format == ""
mean.sd.n.c.format[sel.c] <- Nc.format[sel.c]
}
#
# 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)) |
RoB.available |
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] & 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)
}
#
# Random effects model
#
if (random.subgroup.logical[i] & 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)
}
#
# Only pooled totals
#
# cat("pooled.totals\n")
# print(pooled.totals)
# cat("subgroup.logical[i]\n")
# print(subgroup.logical[i])
# cat("common.subgroup.logical[i]\n")
# print(common.subgroup.logical[i])
# cat("random.subgroup.logical[i]\n")
# print(random.subgroup.logical[i])
#
if (pooled.totals & subgroup.logical[i] &
!(common.subgroup.logical[i] | random.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)
}
#
# Prediction interval in subgroups
#
if (prediction.subgroup.logical[i] & 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)) {
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
#
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
#
if (details)
yText.details <- rep_len(NA, length(text.details))
else
yText.details <- NULL
#
if (RoB.legend)
yText.rob <- rep_len(NA, length(text.rob))
else
yText.rob <- NULL
#
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
yNext <- yNext + 1
}
#
if (details) {
yNext <- yNext + 1
yText.details <- seq(yNext, yNext + length(yText.details) - 1)
yNext <- yNext + length(yText.details)
}
#
if (RoB.legend) {
yNext <- yNext + 1
yText.rob <- seq(yNext, yNext + length(yText.rob) - 1)
}
#
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
if (details)
yText.details <- yHead + yText.details + addrow
if (RoB.legend)
yText.rob <- yHead + yText.rob + addrow
#
yStats <- c(yHetstat,
yResidHetstat,
yOverall.common, yOverall.random,
ySubgroup.common, ySubgroup.random,
yText.addline1, yText.addline2)
#
yStatsDetails <- c(yHetstat,
yResidHetstat,
yOverall.common, yOverall.random,
ySubgroup.common, ySubgroup.random,
yText.addline1, yText.addline2,
yText.details, yText.rob)
#
if (by) {
yBylab <- yHead + yBylab + addrow
yTE.w <- yHead + yTE.w + addrow
#
yLab <- c(yHead,
yTE.common, yTE.random, yPredict,
yStatsDetails,
yBylab, yTE.w,
yTE)
#
yS <- c(yHead, yTE.common, yTE.random, yPredict, yTE.w, yTE)
yS.noma <- c(yHead,
rep_len(NA, length(yTE.common)),
rep_len(NA, length(yTE.random)),
rep_len(NA, length(yPredict)),
rep_len(NA, length(yTE.w)),
yTE)
}
else {
yLab <- c(yHead, yTE.common, yTE.random, yPredict,
yStatsDetails,
yTE)
#
yS <- c(yHead, yTE.common, yTE.random, yPredict, yTE)
yS.noma <- c(yHead,
rep_len(NA, length(yTE.common)),
rep_len(NA, length(yTE.random)),
rep_len(NA, length(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 <- 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)
}
# Random effects estimate:
strt <- strt + i
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)
}
# Prediction interval:
strt <- strt + i
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)
}
# Heterogeneity statistics:
strt <- strt + i
col.studlab$labels[[strt + 1]] <-
tg(hetstat.overall, xpos.s, just.s, fs.hetstat, ff.hetstat, fontfamily)
# Statistic for residual heterogeneity:
col.studlab$labels[[strt + 2]] <-
tg(hetstat.resid, xpos.s, just.s, fs.hetstat, ff.hetstat, fontfamily)
# Test for overall effect (common effect model):
col.studlab$labels[[strt + 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[[strt + 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[[strt + 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[[strt + 6]] <-
tg(text.subgroup.random, xpos.s, just.s, fs.test.subgroup, ff.test.subgroup,
fontfamily)
# First additional line:
col.studlab$labels[[strt + 7]] <-
tg(text.addline1, xpos.s, just.s, fs.addline, ff.addline, fontfamily)
# Second additional line:
col.studlab$labels[[strt + 8]] <-
tg(text.addline2, xpos.s, just.s, fs.addline, ff.addline, fontfamily)
# Details on meta-analysis methods:
strt <- strt + 8
i <- 0
if (details) {
for (i in seq_len(length(text.details))) {
col.studlab$labels[[strt + i]] <-
tg(text.details[[i]], xpos.s, just.s,
if (i == 1) fs.heading else fs.details,
if (i == 1) ff.heading else ff.details,
fontfamily)
}
}
# Risk of bias:
strt <- strt + i
i <- 0
if (RoB.legend) {
for (i in seq_len(length(text.rob))) {
col.studlab$labels[[strt + i]] <-
tg(text.rob[i], xpos.s, just.s,
if (i == 1) fs.heading else fs.rob,
if (i == 1) ff.heading else ff.rob,
fontfamily)
}
}
#
if (by) {
# Subgroup labels:
strt <- strt + i
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)
}
# Common effect estimates:
strt <- strt + i
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)
}
# Random effects estimates:
strt <- strt + i
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)
}
# Prediction interval:
strt <- strt + i
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)
}
# Heterogeneity statistics:
strt <- strt + i
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)
}
# Test for effect in subgroup (common effect model):
strt <- strt + i
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)
}
# Test for effect in subgroup (random effects model):
strt <- strt + i
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)
}
}
#
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 (bmj.revman5 & missing.just) "center" else just.c,
fcs, fontfamily,
n.com, n.ran, n.prd)
#
if (bmj.bin) {
col.event.n.e <-
formatcol(labs[["lab.event.n.e"]], event.n.e.format, yS,
if (bmj.revman5 & missing.just) "center" else just.c,
fcs, fontfamily,
n.com, n.ran, n.prd)
#
col.event.n.c <-
formatcol(labs[["lab.event.n.c"]], event.n.c.format, yS,
if (bmj.revman5 & missing.just) "center" else just.c,
fcs, fontfamily,
n.com, n.ran, n.prd)
}
#
if (bmj.cont) {
col.mean.sd.n.e <-
formatcol(labs[["lab.mean.sd.n.e"]], mean.sd.n.e.format, yS,
if (bmj.revman5 & missing.just) "center" else just.c,
fcs, fontfamily,
n.com, n.ran, n.prd)
#
col.mean.sd.n.c <-
formatcol(labs[["lab.mean.sd.n.c"]], mean.sd.n.c.format, yS,
if (bmj.revman5 & missing.just) "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)
#
if (bmj.bin) {
col.event.n.e.calc <- formatcol(longer.event.n.e, event.n.e.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
#
col.event.n.c.calc <- formatcol(longer.event.n.c, event.n.c.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
}
#
if (bmj.cont) {
col.mean.sd.n.e.calc <-
formatcol(longer.mean.sd.n.e, mean.sd.n.e.format, yS,
just.c, fcs, fontfamily,
n.com, n.ran, n.prd)
#
col.mean.sd.n.c.calc <-
formatcol(longer.mean.sd.n.c, mean.sd.n.c.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 CI with square
# "circle" - normal CI with circle
# "squarediamond" - normal CI with squarediamond
# "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.circle = c(col.diamond.pooled, col.circle),
col.circle.lines =
c(col.diamond.lines.pooled, col.circle.lines),
#
col.diamond = c(col.diamond.pooled, col.square),
col.diamond.lines =
c(col.diamond.lines.pooled, col.square.lines),
#
lwd = lwd,
lwd.square = lwd.square, lwd.diamond = lwd.diamond,
#
arrow.type = arrow.type, arrow.length = arrow.length
)
#
# 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)
if (length(unique(type.study)) == 1 &&
unique(type.study) == "squarediamond")
information[information < 0.35 * max(information, na.rm = TRUE)] <-
0.35
}
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)
#
if (bmj.bin) {
cols$col.event.n.e <- col.event.n.e
cols$col.event.n.c <- col.event.n.c
}
#
if (bmj.cont) {
cols$col.mean.sd.n.e <- col.mean.sd.n.e
cols$col.mean.sd.n.c <- col.mean.sd.n.c
}
#
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)
#
if (bmj.bin) {
cols.calc$col.event.n.e <- col.event.n.e.calc
cols.calc$col.event.n.c <- col.event.n.c.calc
}
#
if (bmj.cont) {
cols.calc$col.mean.sd.n.e <- col.mean.sd.n.e.calc
cols.calc$col.mean.sd.n.c <- col.mean.sd.n.c.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])
#
rob.i <- length(rob[[rightcols.new[i]]]) != 0
#
if (rob.i)
tmp.r <- rob[[rightcols.new[i]]]
else 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),
if (!rob.i) yS else yS.noma,
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,
rightcols.new[i] %in% colnames(rob))
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])
#
rob.i <- length(rob[[rightcols.new[i]]]) != 0
#
if (rob.i)
tmp.r <- rob[[rightcols.new[i]]]
else 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),
if (!rob.i) yS else yS.noma,
if (rightcols.new[i] %in% c("pval", "tau2", "tau", "I2"))
just
else
just.addcols.right[i],
fcs, fontfamily,
n.com, n.ran, n.prd,
rightcols.new[i] %in% colnames(rob))
#
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,
if (bmj) bmj.xpos else xpos.c,
if (bmj) "left" else just.c,
fs.head, ff.head, fontfamily)
#
col.label.c <- tgl(label.c, xpos.c, just.c, fs.head, ff.head, fontfamily)
#
col.rob <- tgl(rob.text, rob.xpos, "left", 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 (bmj.revman5) 0.5 else xpos.c,
if (bmj.revman5) "center" else just.c,
fs.head, ff.head, fontfamily)
#
if (bmj.bin) {
if (newline.event.n.e)
col.add.event.n.e <- tgl(add.event.n.e,
if (bmj.revman5) 0.5 else xpos.c,
if (bmj.revman5) "center" else just.c,
fs.head, ff.head, fontfamily)
#
if (newline.event.n.c)
col.add.event.n.c <- tgl(add.event.n.c,
if (bmj.revman5) 0.5 else xpos.c,
if (bmj.revman5) "center" else just.c,
fs.head, ff.head, fontfamily)
}
#
if (bmj.cont) {
if (newline.mean.sd.n.e)
col.add.mean.sd.n.e <- tgl(add.mean.sd.n.e,
if (bmj.revman5) 0.5 else xpos.c,
if (bmj.revman5) "center" else just.c,
fs.head, ff.head, fontfamily)
#
if (newline.mean.sd.n.c)
col.add.mean.sd.n.c <- tgl(add.mean.sd.n.c,
if (bmj.revman5) 0.5 else xpos.c,
if (bmj.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 + seq(2))
#
if (!calcwidth.tests)
del.lines <-
c(del.lines, 1 + n.com + n.ran + n.prd + 2 + seq(4))
#
if (!calcwidth.addline)
del.lines <-
c(del.lines, 1 + n.com + n.ran + n.prd + 2 + 4 + seq(2))
#
if (details)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + seq_along(text.details))
#
if (RoB.legend)
del.lines <-
c(del.lines,
1 + n.com + n.ran + n.prd + 2 + 4 + 2 + length(text.details) +
seq_along(text.rob))
#
nd <- 1 + n.com + n.ran + n.prd + 2 + 4 + 2 +
details * length(text.details) +
RoB.legend * length(text.rob)
#
#nd <- n.com + n.ran + n.prd + 2 + 4 + 2
#
if (by) {
if (!calcwidth.subgroup)
del.lines <-
c(del.lines, nd + seq_len(n.by))
#
if (!calcwidth.common)
del.lines <-
c(del.lines, nd + n.by + seq_len(n.by * n.com))
#
if (!calcwidth.random)
del.lines <-
c(del.lines,
nd + n.by + n.by * n.com + seq_len(n.by * n.ran))
#
if (!calcwidth.predict)
del.lines <-
c(del.lines,
nd + n.by + n.by * n.com + n.by * n.ran + seq_len(n.by * n.prd))
#
if (!calcwidth.hetstat)
del.lines <-
c(del.lines,
nd + 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,
nd + 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,
nd + 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)
#
rob.attach <- NULL
#
if (RoB.available) {
colnames(rob) <- paste0("col.", colnames(rob))
rob.attach <- colnames(rob)[1]
}
#
if (rsel) {
for (i in seq_along(rightcols)) {
colgap.right.i <- colgap.right
#
if (RoB.available && i > 1 &&
rightcols[i] %in% colnames(rob) &&
rightcols[i - 1] %in% colnames(rob)) {
if (rightcols[i] == "col.RoB.O")
colgap.right.i <- colgap.rob.overall
else
colgap.right.i <- colgap.rob
}
#
x1 <- unit.c(x1,
if (i == 1) colgap.forest.right else colgap.right.i,
if (rightcols[i] %in% colnames(rob))
wcalc(grid.text("aa",
just = "center",
gp = gpar(col = "transparent",
fontsize = fs.head,
fontface = ff.head,
fontfamily = fontfamily)))
else
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,
yStatsDetails, 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,
yStatsDetails), na.rm = TRUE)
}
#
# Determine minimal value on y-axis for lines of common / random
# effect estimate or reference line
#
n.lines <- sum(!is.na(yStatsDetails)) + details + RoB.legend
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 (!is.null(file) | !is.null(func.gr)) {
if (is.null(func.gr)) {
if (grepl("pdf$", tolower(file)))
func.gr <- "pdf"
else if (grepl("ps$", tolower(file)))
func.gr <- "postscript"
else if (grepl("svg$", tolower(file)))
func.gr <- "svg"
else if (grepl("bmp$", tolower(file)))
func.gr <- "bmp"
else if (grepl("jpg$", tolower(file)) |
grepl("jpeg$", tolower(file)))
func.gr <- "jpeg"
else if (grepl("png$", tolower(file)))
func.gr <- "png"
else if (grepl("tif$", tolower(file)) |
grepl("tiff$", tolower(file)))
func.gr <- "tiff"
else
stop("Argument 'file' has unknown file extension; either provide ",
"admissible file extension\n (\".pdf\", \".ps\", \".svg\", ",
"\".bmp\", \".jpg\", \".png\", \"tif\") or ",
"\n graphics function (argument 'func.gr').")
#
type.gr <- func.gr
}
else
type.gr <- deparse(substitute(func.gr))
#
figheight <- gh(type.gr, rows.gr,
#
if (metabind) length(x$TE) else n.stud,
lowTE.common, lowTE.random, lowTE.predict,
x$subgroup, subgroup.levels,
lower.common.w, lower.random.w, lower.predict.w,
#
if (metabind) FALSE else common,
if (metabind) FALSE else random,
if (metabind) FALSE else overall,
if (metabind) FALSE else prediction,
if (metabind) FALSE else overall.hetstat,
study.results,
#
spacing,
#
xlab, xlab.add, label.right, label.left, bottom.lr,
#
prediction.subgroup, subgroup.hetstat,
if (metabind) FALSE else test.overall.common,
if (metabind) FALSE else test.overall.random,
if (metabind) FALSE else test.subgroup.common,
if (metabind) FALSE else test.subgroup.random,
#
text.addline1, text.addline2,
text.details, text.rob,
#
addrow, addrow.overall,
addrow.subgroups,
if (metabind) 0 else addrows.below.overall,
#
c(leftcols, rightcols), labs,
text.w.common, text.w.random)
#
args.gr.all <-
c(list(file = file,
height = figheight$total_height,
width = width),
args.gr)
runNN(func.gr, args.gr.all)
}
else
figheight <- gh("no_device_defined", rows.gr,
#
n.stud,
lowTE.common, lowTE.random, lowTE.predict,
x$subgroup, subgroup.levels,
lower.common.w, lower.random.w, lower.predict.w,
#
common, random, overall,
prediction, overall.hetstat,
study.results,
#
spacing,
#
xlab, xlab.add, label.right, label.left, bottom.lr,
#
prediction.subgroup, subgroup.hetstat,
test.overall.common, test.overall.random,
test.subgroup.common, test.subgroup.random,
#
text.addline1, text.addline2,
text.details, text.rob,
#
addrow, addrow.overall,
addrow.subgroups, addrows.below.overall,
#
c(leftcols, rightcols), labs,
text.w.common, text.w.random)
#
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.event.n.e & leftcols[i] == "col.event.n.e")
add.text(col.add.event.n.e, j)
if (newline.event.n.c & leftcols[i] == "col.event.n.c")
add.text(col.add.event.n.c, j)
if (newline.mean.sd.n.e & leftcols[i] == "col.mean.sd.n.e")
add.text(col.add.mean.sd.n.e, j)
if (newline.mean.sd.n.c & leftcols[i] == "col.mean.sd.n.c")
add.text(col.add.mean.sd.n.c, 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,
fill,
col.lines)
#
draw.axis(col.forest, j, yS, log.xaxis, at, label,
fs.axis, ff.axis, fontfamily, lwd,
xlim, notmiss.xlim,
col.lines, col.label)
#
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,
if (bmj)
unit(xlim[1], "native")
else
unit(ref - (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr, "lines"),
if (bmj) "left" else "right",
fs.lr, ff.lr, col.label.left, fontfamily,
xscale = col.forest$range)
#
if (newline.ll)
add.label(ll2, j,
if (bmj)
unit(xlim[1], "native")
else
unit(ref - (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr - 1, "lines"),
if (bmj) "left" else "right",
fs.lr, ff.lr, col.label.left, fontfamily,
xscale = col.forest$range)
#
add.label(lr1, j,
if (bmj)
unit(xlim[2], "native")
else
unit(ref + (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr, "lines"),
if (bmj) "right" else "left",
fs.lr, ff.lr, col.label.right, fontfamily,
xscale = col.forest$range)
#
if (newline.lr)
add.label(lr2, j,
if (bmj)
unit(xlim[2], "native")
else
unit(ref + (xlim[2] - xlim[1]) / 30, "native"),
unit(y.bottom.lr - 1, "lines"),
if (bmj) "right" else "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) {
i.rob <- 0
#
for (i in seq_along(rightcols)) {
if (substring(rightcols[i], 1, 8) == "col.RoB.") {
i.rob <- i.rob + 1
#
add.rob(cols[[rightcols[i]]], j, 0.85, fs.rob.symbols, ff.rob.symbols,
fontfamily,
rob[[rightcols[[i]]]],
rob.categories[[i.rob]], rob.symbols[[i.rob]], rob.col[[i.rob]])
}
else
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 (!is.null(rob.attach)) {
if (rightcols[i] == rob.attach)
add.text(col.rob, 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.mean.sd.n.e & rightcols[i] == "col.mean.sd.n.e")
add.text(col.add.mean.sd.n.e, j)
if (newline.mean.sd.n.c & rightcols[i] == "col.mean.sd.n.c")
add.text(col.add.mean.sd.n.c, 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
}
}
#
# Add header line
#
if (jama)
hcols <- lsel * 2 * length(leftcols)
else
hcols <-
lsel * 2 * length(leftcols) + 1 + rsel * 2 * length(rightcols)
#
if (bmj.bin) {
sel1 <- grep("col.event.n.e",
c(leftcols, if (all(rightcols != "col.")) rightcols))
sel2 <- grep("col.event.n.c",
c(leftcols, if (all(rightcols != "col.")) rightcols))
#
if (length(sel1) > 0 & length(sel2) > 0) {
if (sel1 > sel2) {
sel3 <- sel2
sel2 <- sel1
sel1 <- sel2
}
#
for (i in seq(2 * sel1 - 1, 2 * sel2 - 1)) {
pushViewport(
viewport(
layout.pos.col = i,
xscale = col.forest$range))
#
grid.lines(x = unit(0:1, "npc"),
y = unit(nrow - 1.5 + 0.5 * addrow, "lines"),
gp = gpar(lwd = lwd))
#
popViewport()
}
}
}
#
if (bmj.cont) {
sel1 <- grep("col.mean.sd.n.e",
c(leftcols, if (all(rightcols != "col.")) rightcols))
sel2 <- grep("col.mean.sd.n.c",
c(leftcols, if (all(rightcols != "col.")) rightcols))
#
if (length(sel1) > 0 & length(sel2) > 0) {
if (sel1 > sel2) {
sel3 <- sel2
sel2 <- sel1
sel1 <- sel2
}
#
for (i in seq(2 * sel1 - 1, 2 * sel2 - 1)) {
pushViewport(
viewport(
layout.pos.col = i,
xscale = col.forest$range))
#
grid.lines(x = unit(0:1, "npc"),
y = unit(nrow - 1.5 + 0.5 * addrow, "lines"),
gp = gpar(lwd = lwd))
#
popViewport()
}
}
}
#
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, col = col.header.line))
#
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, col = col.header.line))
#
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.jama.line))
#
popViewport()
}
}
#
popViewport()
#
if (dev.off)
invisible(dev.off())
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,
effect.ci.format = effect.ci.format,
#
if (bmj.bin) effect.ci.format = effect.ci.format,
if (bmj.bin) effect.ci.format = effect.ci.format,
#
figheight = figheight,
#
leftcols = leftcols,
leftlabs= leftlabs,
rightcols = rightcols,
rightlabs = rightlabs)
#
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)
}
#' @rdname forest.meta
#' @method plot meta
#' @export
#'
plot.meta <- function(x, ...)
forest(x, ...)
#' @rdname forest.meta
#' @export .forestArgs
.forestArgs <- function()
formalArgs(forest.meta)
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.