R/print.summary.netmeta.R

In netmeta: Network Meta-Analysis using Frequentist Methods

#' Print detailed results of network meta-analysis
#' 
#' @description
#' Print method for objects of class \code{summary.netmeta}.
#' 
#' @param x An object of class \code{summary.netmeta}.
#' @param sortvar An optional vector used to sort individual studies
#'   (must be of same length as \code{x$TE}).
#' @param common A logical indicating whether results for the common
#'   effects model should be printed.
#' @param random A logical indicating whether results for the random
#'   effects model should be printed.
#' @param prediction A logical indicating whether prediction intervals
#'   should be printed.
#' @param reference.group Reference treatment.
#' @param baseline.reference A logical indicating whether results
#'   should be expressed as comparisons of other treatments versus the
#'   reference treatment (default) or vice versa. This argument is
#'   only considered if \code{reference.group} has been specified.
#' @param all.treatments A logical or \code{"NULL"}. If \code{TRUE},
#'   matrices with all treatment effects, and confidence limits will
#'   be printed.
#' @param details A logical indicating whether further details for
#'   individual studies should be printed.
#' @param nma A logical indicating whether summary results of network
#'   meta-analysis should be printed.
#' @param overall.hetstat A logical indicating whether to print heterogeneity
#'   measures.
#' @param backtransf A logical indicating whether results should be
#'   back transformed in printouts and forest plots. If
#'   \code{backtransf = TRUE}, results for \code{sm = "OR"} are
#'   presented as odds ratios rather than log odds ratios, for
#'   example.
#' @param nchar.trts A numeric defining the minimum number of
#'   characters used to create unique treatment names.
#' @param nchar.studlab A numeric defining the minimum number of
#'   characters used to create unique study labels.
#' @param digits Minimal number of significant digits, see
#'   \code{print.default}.
#' @param digits.se Minimal number of significant digits for standard
#'   deviations and standard errors, see \code{print.default}.
#' @param digits.pval.Q Minimal number of significant digits for
#'   p-value of heterogeneity tests, see \code{print.default}.
#' @param digits.Q Minimal number of significant digits for
#'   heterogeneity statistics, see \code{print.default}.
#' @param digits.tau2 Minimal number of significant digits for
#'   between-study variance, see \code{print.default}.
#' @param digits.I2 Minimal number of significant digits for I-squared
#'   statistic, see \code{print.default}.
#' @param big.mark A character used as thousands separator.
#' @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 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 print.tau2 A logical specifying whether between-study
#'   variance \eqn{\tau^2} should be printed.
#' @param print.tau A logical specifying whether \eqn{\tau}, the
#'   square root of the between-study variance \eqn{\tau^2}, should be
#'   printed.
#' @param print.Q A logical value indicating whether to print the
#'   results of the test of heterogeneity.
#' @param print.I2 A logical specifying whether heterogeneity
#'   statistic I\eqn{^2} should be printed.
#' @param print.I2.ci A logical specifying whether confidence interval for
#'   heterogeneity statistic I\eqn{^2} should be printed.
#' @param truncate An optional vector used to truncate the printout of
#'   results for individual studies (must be a logical vector of
#'   length corresponding to the number of pairwise comparisons
#'   \code{x$TE} or contain numerical values).
#' @param text.truncate A character string printed if study results
#'   were truncated from the printout.
#' @param details.methods A logical specifying whether details on statistical
#'   methods should be printed.
#' @param legend A logical indicating whether a legend should be
#'   printed.
#' @param warn.deprecated A logical indicating whether warnings should
#'   be printed if deprecated arguments are used.
#' @param \dots Additional arguments.
#' 
#' @author Guido Schwarzer \email{guido.schwarzer@@uniklinik-freiburg.de}
#'
#' @seealso \code{\link{netmeta}}, \code{\link{summary.netmeta}}
#' 
#' @keywords print
#' 
#' @examples
#' # Examples: example(summary.netmeta)
#' 
#' @method print summary.netmeta
#' @export

print.summary.netmeta <- function(x,
                                  sortvar,
                                  common = x$x$common,
                                  random = x$x$random,
                                  prediction = x$prediction,
                                  reference.group = x$reference.group,
                                  baseline.reference = x$baseline.reference,
                                  all.treatments = x$all.treatments,
                                  details = TRUE, nma = TRUE,
                                  ##
                                  overall.hetstat = x$overall.hetstat,
                                  backtransf = x$backtransf,
                                  nchar.trts = x$nchar.trts,
                                  nchar.studlab = x$nchar.studlab,
                                  digits = gs("digits"),
                                  digits.se = gs("digits.se"),
                                  digits.pval.Q = max(gs("digits.pval.Q"), 2),
                                  digits.Q = gs("digits.Q"),
                                  digits.tau2 = gs("digits.tau2"),
                                  digits.I2 = gs("digits.I2"),
                                  #
                                  big.mark = gs("big.mark"),
                                  scientific.pval = gs("scientific.pval"),
                                  zero.pval = gs("zero.pval"),
                                  JAMA.pval = gs("JAMA.pval"),
                                  #
                                  print.tau2 = gs("print.tau2"),
                                  print.tau = gs("print.tau"),
                                  print.Q = gs("print.Q"),
                                  print.I2 = gs("print.I2"),
                                  print.I2.ci = gs("print.I2.ci"),
                                  #
                                  truncate,
                                  text.truncate = "*** Output truncated ***",
                                  #
                                  details.methods = gs("details"),
                                  legend = gs("legend"),
                                  #
                                  warn.deprecated = gs("warn.deprecated"),
                                  ##
                                  ...) {
  
  
  ##
  ##
  ## (1) Check for summary.netmeta object and upgrade object
  ##
  ##
  chkclass(x, "summary.netmeta")
  x <- updateversion(x)
  ##
  k.all <- length(x$x$TE)
  
  
  ##
  ##
  ## (2) Check other arguments
  ##
  ##
  chklogical(prediction)
  chklogical(baseline.reference)
  ##
  chknumeric(nchar.trts, min = 1, length = 1)
  if (is.null(nchar.studlab))
    nchar.studlab <- 666
  chknumeric(nchar.studlab, min = 1, length = 1)
  ##
  chknumeric(digits, min = 0, length = 1)
  chknumeric(digits.se, min = 0, length = 1)
  chknumeric(digits.pval.Q, min = 1, length = 1)
  chknumeric(digits.Q, min = 0, length = 1)
  chknumeric(digits.tau2, min = 0, length = 1)
  chknumeric(digits.I2, min = 0, length = 1)
  #
  chkchar(big.mark, length = 1)
  chklogical(scientific.pval)
  chklogical(zero.pval)
  chklogical(JAMA.pval)
  #
  chklogical(print.tau2)
  chklogical(print.tau)
  chklogical(print.Q)
  chklogical(print.I2)
  chklogical(print.I2.ci)
  #
  chklogical(nma)
  chklogical(details.methods)
  chklogical(legend)
  ##
  sfsp <- sys.frame(sys.parent())
  mc <- match.call()
  ##
  ## Catch 'truncate' from network meta-analysis object:
  ##
  missing.truncate <- missing(truncate)
  if (!missing.truncate) {
    truncate <- catch("truncate", mc, x$x, sfsp)
    ##
    if (is.null(truncate))
      truncate <- catch("truncate", mc, x$x$data, sfsp)
    ##
    if (length(truncate) > k.all)
      stop("Length of argument 'truncate' is too long.",
           call. = FALSE)
    else if (length(truncate) < k.all) {
      if (is.numeric(truncate)) {
        if (any(is.na(truncate)) | max(truncate) > k.all | min(truncate) < 0)
          stop("Numeric values in argument 'truncate' must be between 1 and ",
               k.all, ".",
               call. = FALSE)
        truncate2 <- rep(FALSE, k.all)
        truncate2[truncate] <- TRUE
        truncate <- truncate2
      }
      else if (is.character(truncate)) {
        if (any(!(truncate %in% x$x$studlab)))
          stop("At least one value of argument 'truncate' does not ",
               "match a study label.",
               call. = FALSE)
        truncate2 <- rep(FALSE, k.all)
        truncate2[x$x$studlab %in% truncate] <- TRUE
        truncate <- truncate2
      }
      else
        stop("Argument 'truncate' must contain integers or study labels if ",
             "length differs from number of treatment effects.",
             call. = FALSE)
    }
  }
  ##
  ## Check for deprecated arguments in '...'
  ##
  args  <- list(...)
  chklogical(warn.deprecated)
  ##
  missing.common <- missing(common)
  common <- deprecated(common, missing.common, args, "comb.fixed",
                      warn.deprecated)
  common <- deprecated(common, missing.common, args, "fixed",
                       warn.deprecated)
  chklogical(common)
  ##
  random <- deprecated(random, missing(random), args, "comb.random",
                       warn.deprecated)
  chklogical(random)
  #
  chklogical(overall.hetstat)
  #
  backtransf <-
    deprecated(backtransf, missing(backtransf), args, "logscale")
  if (is_untransformed(x$sm))
    backtransf <- TRUE
  chklogical(backtransf)
  
  
  ##
  ##
  ## (3) Some additional settings
  ##
  ##
  if (!inherits(x, "summary.netmetabin")) {
    ##
    if (missing(sortvar)) sortvar <- 1:k.all
    ##
    if (length(sortvar) != k.all)
      stop("'x' and 'sortvar' have different length")
    ##
    ci.lab <- paste0(round(100 * x$level, 1), "%-CI")
    ##
    sm <- sm.lab <- x$sm
    #
    if (!backtransf & (is_relative_effect(sm) | sm == "VE"))
      sm.lab <- paste0("log", if (sm == "VE") "VR" else sm)
    #
    if (missing.truncate)
      truncate <- rep_len(TRUE, x$x$m)
    #
    treat1 <- x$x$treat1
    treat2 <- x$x$treat2
    #
    trts <- unique(c(treat1[truncate], treat2[truncate]))
    trts.abbr <- treats(trts, nchar.trts)
    #
    studlab <- x$x$studlab
    studlab.tr <- studlab[truncate]
    #
    studies.tr <- unique(studlab.tr)
    labels.s <- treats(studies.tr, nchar.studlab)
    #
    studlab.abbr <-
      as.character(
        factor(studlab, levels = studies.tr, labels = labels.s))
    
    
    ##
    ##
    ## (4) Print title and details
    ##
    ##
    matitle(x)
    ##  
    if (details) {
      multiarm <- any(x$x$narms > 2)
      cat("Original data",
          ifelse(multiarm & (common | random),
                 paste(" (with adjusted standard errors for",
                       "multi-arm studies)"),
                 ""),
          ":\n\n",
          sep = ""
      )
      ##
      res <- data.frame(treat1,
                        treat2,
                        TE = formatN(x$x$TE, digits, text.NA = "NA",
                                     big.mark = big.mark),
                        seTE = formatN(x$x$seTE, digits.se, text.NA = "NA",
                                       big.mark = big.mark))
      ##
      if (multiarm) {
        if (is.null(x$x$seTE.adj.common))
          seTE.adj <- x$x$seTE.adj
        else
          seTE.adj <- x$x$seTE.adj.common
        #
        if (common & random & !is.null(x$x$seTE.adj.random)) {
          if (!all(is.na(seTE.adj)))
            res$seTE.adj.c <- format(round(seTE.adj, digits.se))
          if (!all(is.na(x$x$seTE.adj.random)))
            res$seTE.adj.r <- format(round(x$x$seTE.adj.random, digits.se))
        }
        else if (common) {
          if (!all(is.na(seTE.adj)))
            res$seTE.adj <- format(round(seTE.adj, digits.se))
        }
        else if (random & !is.null(x$x$seTE.adj.random)) {
          if (!all(is.na(x$x$seTE.adj.random)))
            res$seTE.adj <- format(round(x$x$seTE.adj.random, digits.se))
        }
        #
        res$narms <- x$x$n.arms
        res$multiarm <- ifelse(x$x$multiarm, "*", "")
      }
      ##
      res <- as.matrix(res)
      rownames(res) <- studlab
      #
      if (!missing.truncate) {
        sortvar <- sortvar[truncate]
        res <- res[truncate, , drop = FALSE]
      }
      #
      res <- res[order(sortvar), , drop = FALSE]
      #
      rownames(res) <-
        as.character(
          factor(rownames(res), levels = studies.tr, labels = labels.s))
      #
      res[, "treat1"] <-
        as.character(factor(res[, "treat1"], levels = trts, labels = trts.abbr))
      #
      res[, "treat2"] <-
        as.character(factor(res[, "treat2"], levels = trts, labels = trts.abbr))
      #
      prmatrix(res, quote = FALSE, right = TRUE)
      #
      if (!missing.truncate)
        cat(text.truncate, "\n")
      cat("\n")
      ##      
      studyarms <- data.frame(narms = x$x$narms, row.names = x$x$studies)
      #
      if (!missing.truncate)
        studyarms <-
          studyarms[rownames(studyarms) %in% studies.tr, , drop = FALSE]
      #
      rownames(studyarms) <-
        as.character(
          factor(rownames(studyarms), levels = studies.tr, labels = labels.s))
      #
      if (multiarm)
        studyarms$multiarm <- ifelse(studyarms$narms > 2, "*", "")
      #
      if (length(unique(studyarms$narms)) != 1) {
        studyarms <- studyarms[order(-studyarms$narms), , drop = FALSE]
        addtext <- " (by decreasing number of arms)"
      }
      else
        addtext <- ""
      #
      cat(paste0("Number of treatment arms per study", addtext, ":\n"))
      #
      prmatrix(studyarms, quote = FALSE, right = TRUE)
      #
      if (!missing.truncate)
        cat(text.truncate, "\n")
      cat("\n")
    }
    
    
    ##
    ##
    ## (5) Print results for individual studies
    ##
    ##
    TE.c    <- x$comparison.nma.common$TE
    lowTE.c <- x$comparison.nma.common$lower
    uppTE.c <- x$comparison.nma.common$upper
    ##
    if (backtransf) {
      TE.c    <- backtransf(TE.c, sm)
      lowTE.c <- backtransf(lowTE.c, sm)
      uppTE.c <- backtransf(uppTE.c, sm)
      #
      # Switch lower and upper limit for VE if results have been
      # backtransformed
      #
      if (sm == "VE") {
        tmp.l <- lowTE.c
        lowTE.c <- uppTE.c
        uppTE.c <- tmp.l
      }
    }
    #
    TE.r    <- x$comparison.nma.random$TE
    lowTE.r <- x$comparison.nma.random$lower
    uppTE.r <- x$comparison.nma.random$upper
    ##
    if (backtransf) {
      TE.r    <- backtransf(TE.r, sm)
      lowTE.r <- backtransf(lowTE.r, sm)
      uppTE.r <- backtransf(uppTE.r, sm)
      #
      # Switch lower and upper limit for VE if results have been
      # backtransformed
      #
      if (sm == "VE") {
        tmp.l <- lowTE.r
        lowTE.r <- uppTE.r
        uppTE.r <- tmp.l
      }
    }
    ##
    res.c <- cbind(treat1, treat2,
                   formatN(TE.c, digits, text.NA = "NA", big.mark = big.mark),
                   formatCI(formatN(round(lowTE.c, digits), digits, "NA",
                                    big.mark = big.mark),
                            formatN(round(uppTE.c, digits), digits, "NA",
                                    big.mark = big.mark)),
                   if (common)
                     formatN(round(x$x$Q.common, digits.Q), digits.Q, "NA",
                             big.mark = big.mark),
                   if (common & !all(x$x$narms > 2))
                     formatN(round(x$x$leverage.common, 2), 2, ".")
                   )
    dimnames(res.c) <-
      list(studlab.abbr,
           c("treat1", "treat2",
             sm.lab, ci.lab,
             if (common) "Q",
             if (common & !all(x$x$narms > 2)) "leverage"))
    #
    res.c[, "treat1"] <-
      as.character(factor(res.c[, "treat1"],
                          levels = trts, labels = trts.abbr))
    #
    res.c[, "treat2"] <-
      as.character(factor(res.c[, "treat2"],
                          levels = trts, labels = trts.abbr))
    #
    res.r <- cbind(treat1, treat2,
                   formatN(TE.r, digits, text.NA = "NA", big.mark = big.mark),
                   formatCI(formatN(round(lowTE.r, digits), digits, "NA",
                                    big.mark = big.mark),
                            formatN(round(uppTE.r, digits), digits, "NA",
                                    big.mark = big.mark)))
    dimnames(res.r) <-
      list(studlab.abbr,
           c("treat1", "treat2", sm.lab, ci.lab))
    #
    res.r[, "treat1"] <-
      as.character(factor(res.r[, "treat1"],
                          levels = trts, labels = trts.abbr))
    #
    res.r[, "treat2"] <-
      as.character(factor(res.r[, "treat2"],
                          levels = trts, labels = trts.abbr))
    #
    if (common) {
      cat("Results (common effects model):\n\n")
      ##
      if (!missing.truncate)
        res.c <- res.c[truncate, , drop = FALSE]
      ##
      prmatrix(res.c[order(sortvar), , drop = FALSE],
               quote = FALSE, right = TRUE)
      if (!missing.truncate)
        cat(text.truncate, "\n")      
      cat("\n")
    }
    ##
    if (random) {
      cat("Results (random effects model):\n\n")
      ##
      if (!missing.truncate)
        res.r <- res.r[truncate, , drop = FALSE]
      ##
      prmatrix(res.r[order(sortvar), , drop = FALSE],
               quote = FALSE, right = TRUE)
      if (!missing.truncate)
        cat(text.truncate, "\n")      
      cat("\n")
    }
  }
  ##  
  if (reference.group != "" & missing(all.treatments))
    all.treatments <- FALSE
  ##  
  if (reference.group != "")
    reference.group <- setref(reference.group, rownames(x$x$A.matrix))
  ##  
  if (nma) {
    print.netmeta(x$x,
                  common = common, random = random,
                  prediction = prediction,
                  backtransf = backtransf,
                  overall.hetstat = overall.hetstat,
                  reference.group = reference.group,
                  baseline.reference = baseline.reference,
                  all.treatments = all.treatments,
                  header = FALSE, nchar.trts = nchar.trts,
                  ##
                  digits = digits,
                  digits.pval.Q = digits.pval.Q,
                  digits.Q = digits.Q,
                  digits.tau2 = digits.tau2,
                  digits.I2 = digits.I2,
                  #
                  big.mark = big.mark,
                  scientific.pval = scientific.pval,
                  zero.pval = zero.pval,
                  JAMA.pval = JAMA.pval,
                  #
                  print.tau2 = print.tau2,
                  print.tau = print.tau,
                  print.Q = print.Q,
                  print.I2 = print.I2,
                  print.I2.ci = print.I2.ci,
                  #
                  details.methods = details.methods,
                  legend = legend)
  }
  else {
    ##
    ## Add legend with abbreviated treatment or study labels
    ##
    legendabbr(trts, trts.abbr, legend)
    legendabbr(studies.tr, labels.s, legend,
               text = "Study label",
               header = if (!any(trts != trts.abbr)) "\nLegend:\n" else "\n")
  }
  
  
  invisible(NULL)
}