R/forest.tcc.R

In mtrank: Ranking using Probabilistic Models and Treatment Choice Criteria

#' Forest plot showing the treatment preference format of the NMA estimates 
#' according to treatment choice criterion.
#' 
#' @description
#' This function produces a forest plot and visualizes the treatment preference 
#' format of the NMA estimates as defined from the treatment choice criterion in 
#' \code{\link{tcc}}.
#' 
#' @param x An object of class \code{\link{tcc}}.
#' @param reference.group Reference treatment(s). By default, the graph plots
#' the NMA estimates of all treatments versus the common reference treatment
#' used in the \code{\link[netmeta]{netmeta}} object.
#' @param baseline.reference A logical indicating whether results
#'   should be expressed as comparisons of other treatments versus the
#'   reference treatment (default) or vice versa.
#' @param backtransf A logical indicating whether results should be
#'   back transformed. If \code{backtransf = TRUE} (default), results for
#'   \code{sm = "OR"} are printed as odds ratios rather than log odds ratios,
#'   for example.
#' @param leftcols A character vector specifying columns
#'   to be printed on the left side of the forest plot
#'   (see \code{\link[meta]{forest.meta}}).
#' @param rightcols A character vector specifying columns
#'   to be printed on the right side of the forest plot
#'   (see \code{\link[meta]{forest.meta}}).
#' @param leftlabs A character vector specifying labels for
#'   columns on left side of the forest plot.
#' @param col.winner Colour to highlight results for TCC winner.
#' @param col.tie Colour to highlight results for TCC ties.
#' @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.
#' @param fill.swd.below.null Colour of area below lower SWD limit.
#' @param fill.swd.above.null Colour of area above upper SWD limit.
#' @param smlab A label for the summary measure (printed at top of
#'   figure).
#' @param header.line A logical value indicating whether to print a
#'   header line or a character string ("both", "below", "").
#' @param \dots Additional arguments (passed on to
#'   \code{\link[meta]{forest.meta}}).
#' 
#' @details
#' This function produces forest plots for the NMA treatment effect estimates. 
#' The color indicates whether treatment effects show a preference (red color)
#' or tie (black color). Additionally, the respective range of equivalence
#' defined at the function \code{\link{tcc}} is visualized for the forest plot.
#' 
#' The argument \code{reference.group} is optional. By default, the graph plots
#' the NMA  estimates of all treatments versus the common reference treatment
#' used in the \code{\link[netmeta]{netmeta}} object.
#' 
#' @return
#' A forest plot is plotted in the active graphics device.
#' 
#' @references
#' Evrenoglou T, Nikolakopoulou A, Schwarzer G, Rücker G, Chaimani A (2024):
#' Producing treatment hierarchies in network meta-analysis using probabilistic
#' models and treatment-choice criteria,
#' \url{https://arxiv.org/abs/2406.10612}
#'
#' @keywords hplot
#' 
#' @examples
#' data("antidepressants")
#' #
#' pw1 <- pairwise(studlab = studyid, treat = drug_name,
#'   n = ntotal, event = responders,
#'   data = antidepressants, sm = "OR")
#' # Use subset to reduce runtime
#' pw0 <- subset(pw1, studyid < 60)
#' #
#' net0 <- netmeta(pw0, reference.group = "tra")
#' 
#' ranks0 <- tcc(net0, swd = 1.20, small.values = "undesirable")
#' 
#' # Comparison other drugs vs trazodone
#' forest(ranks0,
#'   label.left = "Favours trazodone",
#'   label.right = "Favours other drug")
#' 
#' # Comparison escitalopram vs other drugs
#' forest(ranks0, reference.group = "esc", baseline = FALSE,
#'   label.left = "Favours other drug",
#'   label.right = "Favours escitalopram")
#' 
#' \dontrun{
#' # Store a PDF file in the current working directory showing all results
#' # (this is the default, i.e., if argument 'reference.group' is missing)
#' forest(ranks0, baseline = FALSE, reference.group = trts,
#'   file = "forest_tcc_antidepressants.pdf")
#' 
#' # Run analysis with full data set
#' net1 <- netmeta(pw1, reference.group = "tra")
#' 
#' ranks1 <- tcc(net1, swd = 1.20, small.values = "undesirable")
#' 
#' # Comparison other drugs vs trazodone
#' forest(ranks1,
#'   label.left = "Favours trazodone",
#'   label.right = "Favours other drug")
#' 
#' # Comparison escitalopram vs other drugs
#' forest(ranks1, reference.group = "esc", baseline = FALSE,
#'   label.left = "Favours other drug",
#'   label.right = "Favours escitalopram")
#' }
#' 
#' @method forest tcc
#' @export

forest.tcc <- function(x,
                       reference.group = x$reference.group,
                       baseline.reference = x$baseline.reference,
                       backtransf = FALSE,
                       #
                       leftcols = "studlab", leftlabs,
                       rightcols = c("effect", "ci"),
                       #
                       col.winner = "red", col.tie = "black",
                       #
                       lty.equi = gs("lty.cid"),
                       col.equi = gs("col.cid"),
                       fill.equi = "lightblue",
                       fill.swd.below.null = "transparent",
                       fill.swd.above.null = "transparent",
                       #
                       smlab,
                       header.line = TRUE,
                       ...) {
  
  #
  #
  # (1) Check arguments
  #
  #
  
  chkclass(x, "tcc")
  #
  if (!missing(reference.group))
    reference.group <-
      catch("reference.group", match.call(), x, sys.frame(sys.parent()))
  #
  if (is.null(reference.group) || all(reference.group == ""))
    reference.group <- x$trts[1]
  #
  reference.group <- unique(setchar(reference.group, x$trts))
  #
  chklogical(baseline.reference)
  chklogical(backtransf)
  #
  chkcolor(col.winner, length = 1)
  chkcolor(col.tie, length = 1)
  #
  chknumeric(lty.equi, min = 0, length = 1)
  chkcolor(col.equi, length = 1)
  #
  chklogical(header.line)
  
  
  swd.below.null <- x$swd.below.null
  swd.above.null <- x$swd.above.null
  #
  if (is_relative_effect(x$sm) & !backtransf) {
    swd.below.null <- log(swd.below.null)
    swd.above.null <- log(swd.above.null)
  }
  
  # Get rid of warning "no visible binding for global variable"
  #
  comparison <- treat1 <- treat2 <- TE <- seTE <- NULL
  #
  ppdata <- x$ppdata
  #
  dat <- NULL
  #
  for (i in seq_along(reference.group)) {
    dat.i <- ppdata %>%
      filter(treat1 == reference.group[i] | treat2 == reference.group[i])
    #
    wo <- baseline.reference & dat.i$treat1 == reference.group[i] |
      !baseline.reference & dat.i$treat2 == reference.group[i]
    #
    if (any(wo)) {
      dat.i$TE[wo] <- -dat.i$TE[wo]
      #
      ttreat1 <- dat.i$treat1[wo]
      dat.i$treat1[wo] <- dat.i$treat2[wo]
      dat.i$treat2[wo] <- ttreat1
    }
    #
    dat.i$comparison <- reference.group[i]
    #
    if (baseline.reference) {
      dat.i$comparison <- paste0("Other vs '", dat.i$comparison, "'")
      dat.i$labels <- dat.i$treat1
    }
    else {
      dat.i$comparison <- paste0("'", dat.i$comparison, "' vs other")
      dat.i$labels <- dat.i$treat2
    }
    #
    dat <- rbind(dat, dat.i)
  }
  #
  dat$color <- ifelse(dat$outcome == "winner", col.winner, col.tie)
  #
  dat <- dat %>% arrange(comparison, treat1, treat2)
  
  if (length(reference.group) == 1) {
    m <- suppressWarnings(metagen(TE, seTE, data = dat, sm = x$sm,
                                  studlab = labels, backtransf = backtransf,
                                  method.tau = "DL", method.tau.ci = "",
                                  warn = FALSE))
    #
    if (missing(leftlabs))
      leftlabs <- "Treatment"
    #
    if (missing(smlab))
      smlab <- paste0("Comparison: ", unique(dat$comparison), "\n(",
                      if (x$pooled == "random") "Random" else "Common",
                      " Effects Model)")
  }
  else {
    m <- suppressWarnings(metagen(TE, seTE, data = dat, sm = x$sm,
                                  studlab = labels, backtransf = backtransf,
                                  subgroup = dat$comparison,
                                  print.subgroup.name = FALSE,
                                  method.tau = "DL", method.tau.ci = "",
                                  warn = FALSE))
    #
    if (missing(leftlabs))
      leftlabs <- "Comparison / \nTreatment"
    #
    if (missing(smlab))
      smlab <- paste0(if (x$pooled == "random") "Random" else "Common",
                      " Effects Model")
  }
  #
  dots_list <- drop_from_dots(list(...),
                              c("lty.cid", "col.cid",
                                "cid.below.null", "cid.above.null",
                                "fill.cid.below.null", "fill.cid.above.null",
                                "weight.study", "col.study", 
                                "col.square", "col.square.lines",
                                "calcwidth.subgroup",
                                "common", "random", "hetstat",
                                "overall", "overall.hetstat"),
                              c("lty.equi", "col.equi",
                                "swd.below.null", "swd.above.null",
                                "fill.swd.below.null", "fill.swd.above.null",
                                "", "",
                                "", "",
                                "",
                                "", "", "",
                                "", ""))
  #
  args_list <-
    list(x = m,
         header.line = header.line,
         leftcols = leftcols, leftlabs = leftlabs,
         rightcols = rightcols,
         #
         lty.cid = lty.equi, col.cid = col.equi,
         fill.cid.below.null = fill.swd.below.null,
         fill.cid.above.null = fill.swd.above.null,
         #
         fill.equi = fill.equi,
         cid.below.null = swd.below.null,
         cid.above.null = swd.above.null,
         #
         weight.study = "same",
         col.study = dat$color,
         col.square = dat$color,
         col.square.lines = dat$color,
         #
         calcwidth.subgroup = TRUE,
         #
         common = FALSE, random = FALSE, hetstat = FALSE,
         overall = FALSE, overall.hetstat = FALSE,
         smlab = smlab)
  #
  res <- do.call("forest", c(args_list, dots_list))
  #
  invisible(res)
}