#' Forest plot for network meta-analysis
#' 
#' @description
#' Draws a forest plot in the active graphics window (using grid
#' graphics system).
#'
#' @aliases forest.netmeta plot.netmeta
#' 
#' @param x An object of class \code{netmeta}.
#' @param pooled A character string indicating whether results for the
#'   common (\code{"common"}) or random effects model
#'   (\code{"random"}) should be plotted. Can be abbreviated.
#' @param reference.group Reference treatment(s).
#' @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 labels An optional vector with treatment labels.
#' @param equal.size A logical indicating whether all squares should
#'   be of equal size. Otherwise, the square size is proportional to
#'   the precision of estimates.
#' @param leftcols A character vector specifying columns to be plotted
#'   on the left 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 rightcols A character vector specifying columns to be
#'   plotted on the right side of the forest plot or a logical value
#'   (see Details).
#' @param rightlabs A character vector specifying labels for
#'   (additional) columns on right side of the forest plot (see
#'   Details).
#' @param digits Minimal number of significant digits for treatment
#'   effects and confidence intervals, see \code{print.default}.
#' @param small.values A character string specifying whether small
#'   treatment effects indicate a beneficial (\code{"desirable"}) or
#'   harmful (\code{"undesirable"}) effect, can be abbreviated; see
#'   \code{\link{netrank}}.
#' @param nsim Number of repetitions to calculate SUCRAs.
#' @param digits.prop Minimal number of significant digits for
#'   P-scores, SUCRAs and direct evidence proportions, see
#'   \code{\link{print.default}} and \code{\link{netrank}}.
#' @param smlab A label printed at top of figure. By default, text
#'   indicating either common or random effects model is printed.
#' @param sortvar An optional vector used to sort treatments (must be
#'   of same length as the total number of treatments).
#' @param overall.hetstat A logical indicating whether to print heterogeneity
#'   measures.
#' @param print.tau2 A logical value indicating whether to print the
#'   value of the between-study variance \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.I2 A logical value indicating whether to print the
#'   value of the I-squared statistic.
#' @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, for example.
#' @param lab.NA A character string to label missing values.
#' @param add.data An optional data frame with additional columns to
#'   print in forest plot (see Details).
#' @param addrows.below.overall A numeric value indicating how many
#'   empty rows are printed between meta-analysis results and
#'   heterogeneity statistics.
#' @param drop.reference.group A logical indicating whether the
#'   reference group should be printed in the forest plot.
#' @param col.subgroup The colour to print information on subgroups.
#' @param print.subgroup.name A logical indicating whether the name of
#'   the grouping variable should be printed in front of the group
#'   labels.
#' @param \dots Additional arguments for \code{\link[meta]{forest.meta}}
#'   function.
#' 
#' @details
#' A forest plot, also called confidence interval plot, is drawn in
#' the active graphics window.
#' 
#' Argument \code{sortvar} can be either a numeric or character vector
#' with length of number of treatments. If \code{sortvar} is numeric
#' the \code{\link[base]{order}} function is utilised internally to
#' determine the order of values. If \code{sortvar} is character it
#' must be a permutation of the treatment names. It is also possible
#' to provide either \code{sortvar = Pscore}, \code{sortvar =
#' "Pscore"}, \code{sortvar = -Pscore}, or \code{sortvar = "-Pscore"}
#' in order to sort treatments according to the ranking generated by
#' \code{\link{netrank}} which is called internally. It is also
#' possible to use "SUCRA" instead of "Pscore". Similar expressions
#' are possible to sort by treatment comparisons (\code{sortvar = TE},
#' etc.), standard error (\code{sortvar = seTE}), number of studies
#' with direct treatment comparisons (\code{sortvar = k}), and direct
#' evidence proportion (\code{sortvar = prop.direct}, see also
#' \code{\link{netmeasures}}).
#'
#' The arguments \code{leftcols} and \code{rightcols} can be used to
#' specify columns which are plotted on the left and right side of the
#' forest plot, respectively. The following columns are available:
#' \tabular{ll}{
#' \bold{Name} \tab \bold{Definition} \cr
#' \code{"studlab"} \tab Treatments \cr
#' \code{"TE"} \tab Network estimates (either from common or random
#'   effects model) \cr
#' \code{"seTE"} \tab Corresponding standard errors \cr
#' \code{"Pscore"} \tab P-scores (see \code{\link{netrank}}) \cr
#' \code{"SUCRA"} \tab SUCRAs (see \code{\link{netrank}}) \cr
#' \code{"n.trts"} \tab Number of participants per treatment arm \cr
#' \code{"k"} \tab Number of studies in pairwise comparisons \cr
#' \code{"prop.direct"} \tab Direct evidence proportions (see
#'   \code{\link{netmeasures}}) \cr
#' \code{"effect"} \tab (Back-transformed) network estimates \cr
#' \code{"ci"} \tab Confidence intervals \cr
#' \code{"effect.ci"} \tab (Back-transformed) network estimates and
#'   confidence intervals
#' }
#'
#' As a sidenote, the rather odd column name \code{"studlab"} to
#' describe the treatment comparisons comes from internally calling
#' \code{\link[meta]{forest.meta}} which uses study labels as the essential
#' information.
#' 
#' Argument \code{add.data} can be used to add additional columns to
#' the forest plot. This argument must be a data frame with row names
#' equal to the treatment names in R object \code{x}, i.e.,
#' \code{x$trts}.
#' 
#' See help page of \code{\link[meta]{forest.meta}} for more information on
#' the generation of forest plots and additional arguments.
#' 
#' @author Guido Schwarzer \email{guido.schwarzer@@uniklinik-freiburg.de}
#' 
#' @seealso \code{\link[meta]{forest.meta}}
#' 
#' @keywords hplot
#' 
#' @examples
#' # Examples: example(netmeta)
#' 
#' @method forest netmeta
#' @export

forest.netmeta <- function(x,
                           pooled = ifelse(x$random, "random", "common"),
                           reference.group = x$reference.group,
                           baseline.reference = x$baseline.reference,
                           labels = x$trts,
                           equal.size = gs("equal.size"),
                           leftcols = "studlab",
                           leftlabs,
                           rightcols = c("effect", "ci"),
                           rightlabs,
                           digits = gs("digits.forest"),
                           small.values = x$small.values,
                           nsim = gs("nsim"),
                           digits.prop = 2,
                           smlab = NULL,
                           sortvar = x$seq,
                           overall.hetstat = gs("overall.hetstat"),
                           print.tau2 = gs("forest.tau2"),
                           print.tau = gs("forest.tau"),
                           print.I2 = gs("forest.I2"),
                           backtransf = x$backtransf,
                           lab.NA = gs("lab.NA"),
                           add.data,
                           addrows.below.overall =
                             if (x$overall.hetstat) 2 else
                               gs("addrows.below.overall"),
                           drop.reference.group = gs("drop.reference.group"),
                           ##
                           col.subgroup = "black",
                           print.subgroup.name = FALSE,
                           ##
                           ...) {
  
  
  ##
  ##
  ## (1) Check and set arguments
  ##
  ##
  chkclass(x, "netmeta")
  x <- updateversion(x)
  ##
  is.bin <- inherits(x, "netmetabin")
  ##
  pooled <- setchar(pooled, c("common", "random", "fixed"))
  pooled[pooled == "fixed"] <- "common"
  ##
  chklogical(equal.size)
  ##
  chknumeric(digits, min = 0, length = 1)
  ##
  small.values <- setsv(small.values)
  ##
  chknumeric(nsim, min = 1, length = 1)
  chknumeric(digits.prop, min = 0, length = 1)
  ##
  chklogical(baseline.reference)
  ##
  trts <- x$trts
  ##
  if (!missing(labels)) {
    ##
    labels <- catch("labels", match.call(), x, sys.frame(sys.parent()))
    ##
    if (is.null(labels))
      stop("Argument 'labels' must be not NULL.")
    ##
    if (length(labels) != length(trts))
      stop("Length of argument 'labels' must be equal to number of treatments.")
    ##
    names(labels) <- trts
  }
  ##
  chklogical(drop.reference.group)
  chklogical(print.subgroup.name)
  #
  overall.hetstat <- replaceNULL(overall.hetstat, FALSE)
  print.tau2 <- replaceNULL(print.tau2, overall.hetstat)
  print.tau <- replaceNULL(print.tau, overall.hetstat)
  print.I2 <- replaceNULL(print.I2, overall.hetstat)
  #
  chklogical(print.tau2)
  chklogical(print.tau)
  chklogical(print.I2)
  #
  if (print.tau)
    print.tau2 <- FALSE
  #
  chklogical(backtransf)
  chkchar(lab.NA)
  ##
  stdlabs <- c("event.e", "n.e", "event.c", "n.c",
               "mean.e", "sd.e", "mean.c", "sd.c",
               "n", "time", "event",
               "TE", "seTE",
               "time.e", "time.c",
               "effect", "ci", "effect.ci",
               "w.common", "w.random")
  #
  missing.leftlabs <- missing(leftlabs)
  if (missing.leftlabs) {
    leftlabs <- leftcols
    leftlabs[leftcols %in% stdlabs] <- NA
  }
  #
  missing.rightlabs <- missing(rightlabs)
  if (missing.rightlabs) {
    rightlabs <- rightcols
    rightlabs[rightcols %in% stdlabs] <- NA
  }
  #
  for (i in names(list(...))) {
    if (!is.null(setchar(i, "weight.study", stop.at.error = FALSE)))
      stop("Argument 'weight.study' set internally.", call. = TRUE)
    if (!is.null(setchar(i, "prediction", stop.at.error = FALSE)))
      stop("For prediction intervals see example in help file of ",
           "forest.netsplit().", call. = TRUE)
  }
  
  
  ##
  ##
  ## (2) Extract results for common and random effects model and
  ##     calculate P-scores and SUCRAs if calcSUCRA == TRUE
  ##
  ##
  one.rg <- length(reference.group) == 1
  ##
  sortvar.c <- deparse(substitute(sortvar))
  sortvar.c <- gsub("\"", "", sortvar.c)
  ##
  calcPscore <-
    anyCol(rightcols, "Pscore") || anyCol(leftcols, "Pscore") ||
    any(matchVar(sortvar.c, "Pscore")) || any(matchVar(sortvar.c, "-Pscore"))
  ##
  calcSUCRA <-
    anyCol(rightcols, "SUCRA") || anyCol(leftcols, "SUCRA") ||
    any(matchVar(sortvar.c, "SUCRA")) || any(matchVar(sortvar.c, "-SUCRA"))
  ##
  if (one.rg && reference.group == "") {
    warning("First treatment used as reference as argument ",
            "'reference.group' is unspecified.",
            call. = FALSE)
    reference.group <- trts[1]
  }
  ##
  reference.group <- setref(reference.group, trts, length = 0)
  ##
  if (pooled == "common") {
    TE   <- x$TE.common
    seTE <- x$seTE.common
    ##
    prop.direct <- x$P.common
    ##
    if (calcPscore)
      Pscore <- netrank(x, small.values = small.values,
                        method = "P-score")$ranking.common
    if (calcSUCRA) {
      x$common <- TRUE
      x$random <- FALSE
      SUCRA <- netrank(x, small.values = small.values,
                       method = "SUCRA", nsim = nsim)$ranking.common
    }
    ##
    text.pooled <- "Common Effects Model"
  }
  ##
  if (pooled == "random") {
    TE   <- x$TE.random
    seTE <- x$seTE.random
    ##
    prop.direct <- x$P.random
    ##
    ##
    if (calcPscore)
      Pscore <- netrank(x, small.values = small.values,
                        method = "P-score")$ranking.random
    if (calcSUCRA) {
      x$common <- FALSE
      x$random <- TRUE
      SUCRA <- netrank(x, small.values = small.values,
                       method = "SUCRA", nsim = nsim)$ranking.random
    }
    ##
    text.pooled <- "Random Effects Model"
  }
  ##
  if (is.null(smlab)) {
    if (one.rg) {
      if (baseline.reference)
        smlab <- paste0("Comparison: other vs '",
                        reference.group, "'\n(",
                        text.pooled,
                        ")")
      else
        smlab <- paste0("Comparison: '",
                        reference.group,
                        "' vs other \n(",
                        text.pooled,
                        ")")
    }
    else
      smlab  <- text.pooled
  }
  #
  if (!missing.rightlabs && length(rightlabs) > length(rightcols))
    stop("Too many labels defined in argument 'rightlabs': ",
         length(rightlabs), " label", if (length(rightlabs) > 1) "s",
         " for ", length(rightcols), " column",
         if (length(rightcols) > 1) "s",
         ".",
         call. = FALSE)
  #
  rightcols <- setCol(rightcols, "Pscore")
  rightcols <- setCol(rightcols, "SUCRA")
  rightcols <- setCol(rightcols, "n.trts")
  rightcols <- setCol(rightcols, "k")
  rightcols <- setCol(rightcols, "prop.direct")
  #
  if (missing.rightlabs || (length(rightlabs) < length(rightcols))) {
    rightlabs <- setLab(rightlabs, rightcols, "Pscore", "P-score")
    rightlabs <- setLab(rightlabs, rightcols, "SUCRA", "SUCRA")
    rightlabs <- setLab(rightlabs, rightcols, "n.trts",
                        "Number of\nParticipants")
    rightlabs <- setLab(rightlabs, rightcols, "k", "Direct\nComparisons")
    rightlabs <- setLab(rightlabs, rightcols, "prop.direct",
                        "Direct Evidence\nProportion")
  }
  else if (length(rightlabs) == length(rightcols) && any(is.na(rightlabs))) {
    if (naLab(rightlabs[matchVar(rightcols, "Pscore")]))
      rightlabs <- setLab(rightlabs, rightcols, "Pscore", "P-score")
    #
    if (naLab(rightlabs[matchVar(rightcols, "SUCRA")]))
      rightlabs <- setLab(rightlabs, rightcols, "SUCRA", "SUCRA")
    
    if (naLab(rightlabs[matchVar(rightcols, "n.trts")]))
      rightlabs <- 
        setLab(rightlabs, rightcols, "n.trts", "Number of\nParticipants")
    #
    if (naLab(rightlabs[matchVar(rightcols, "k")]))
      rightlabs <- setLab(rightlabs, rightcols, "k", "Direct\nComparisons")
    #
    if (naLab(rightlabs[matchVar(rightcols, "prop.direct")]))
      rightlabs <- setLab(rightlabs, rightcols, "prop.direct",
                          "Direct Evidence\nProportion")
  }
  #
  if (!missing.leftlabs && length(leftlabs) > length(leftcols))
    stop("Too many labels defined in argument 'leftlabs': ",
         length(leftlabs), " label", if (length(leftlabs) > 1) "s",
         " for ", length(leftcols), " column",
         if (length(leftcols) > 1) "s",
         ".",
         call. = FALSE)
  #
  leftcols <- setCol(leftcols, "Pscore")
  leftcols <- setCol(leftcols, "SUCRA")
  leftcols <- setCol(leftcols, "n.trts")
  leftcols <- setCol(leftcols, "k")
  leftcols <- setCol(leftcols, "prop.direct")
  #
  if (missing.leftlabs || (length(leftlabs) < length(leftcols))) {
    if (length(reference.group) > 1)
      leftlabs[matchVar(leftcols, "studlab")] <- "Comparison"
    else
      leftlabs[matchVar(leftcols, "studlab")] <- "Treatment"
    #
    leftlabs <- setLab(leftlabs, leftcols, "Pscore", "P-score")
    leftlabs <- setLab(leftlabs, leftcols, "SUCRA", "SUCRA")
    leftlabs <- setLab(leftlabs, leftcols, "n.trts", "Number of\nParticipants")
    leftlabs <- setLab(leftlabs, leftcols, "k", "Direct\nComparisons")
    leftlabs <- setLab(leftlabs, leftcols, "prop.direct",
                       "Direct Evidence\nProportion")
  }
  else if (length(leftlabs) == length(leftcols) && any(is.na(leftlabs))) {
    if (is.na(leftlabs[matchVar(leftcols, "studlab")])) {
      if (length(reference.group) > 1)
        leftlabs[matchVar(leftcols, "studlab")] <- "Comparison"
      else
        leftlabs[matchVar(leftcols, "studlab")] <- "Treatment"
    }
    #
    if (naLab(leftlabs[matchVar(leftcols, "Pscore")]))
      leftlabs <- setLab(leftlabs, leftcols, "Pscore", "P-score")
    #
    if (naLab(leftlabs[matchVar(leftcols, "SUCRA")]))
      leftlabs <- setLab(leftlabs, leftcols, "SUCRA", "SUCRA")
    
    if (naLab(leftlabs[matchVar(leftcols, "n.trts")]))
      leftlabs <- 
        setLab(leftlabs, leftcols, "n.trts", "Number of\nParticipants")
    #
    if (naLab(leftlabs[matchVar(leftcols, "k")]))
      leftlabs <- setLab(leftlabs, leftcols, "k", "Direct\nComparisons")
    #
    if (naLab(leftlabs[matchVar(leftcols, "prop.direct")]))
      leftlabs <- setLab(leftlabs, leftcols, "prop.direct",
                         "Direct Evidence\nProportion")
  }
  
  
  ##
  ##
  ## (3) Extract comparisons with reference group
  ##
  ##
  dat <- data.frame(comparison = character(0),
                    treat = character(0),
                    TE = numeric(0), seTE = numeric(0),
                    Pscore = numeric(0),
                    SUCRA = numeric(0),
                    k = numeric(0),
                    prop.direct = numeric(0),
                    stringsAsFactors = FALSE)
  ##
  for (i in seq_along(reference.group)) {
    rg.i <- reference.group[i]
    ##
    if (baseline.reference)
      dat.i <- data.frame(comparison = rg.i,
                          treat = colnames(TE),
                          labels = labels,
                          TE = TE[, colnames(TE) == rg.i],
                          seTE = seTE[, colnames(seTE) == rg.i],
                          Pscore = if (calcPscore) Pscore else NA,
                          SUCRA = if (calcSUCRA) SUCRA else NA,
                          k = x$A.matrix[, colnames(TE) == rg.i],
                          prop.direct =
                            if (is.bin) prop.direct
                            else prop.direct[, colnames(TE) == rg.i],
                          stringsAsFactors = FALSE)
    else
      dat.i <- data.frame(comparison = rg.i,
                          treat = rownames(TE),
                          labels = labels,
                          TE = TE[rownames(TE) == rg.i, ],
                          seTE = seTE[rownames(seTE) == rg.i, ],
                          Pscore = if (calcPscore) Pscore else NA,
                          SUCRA = if (calcSUCRA) SUCRA else NA,
                          k = x$A.matrix[rownames(TE) == rg.i, ],
                          prop.direct =
                            if (is.bin) prop.direct
                            else prop.direct[rownames(TE) == rg.i, ],
                          stringsAsFactors = FALSE)
    ##
    if (!is.null(x$n.trts))
      dat.i$n.trts <- x$n.trts
    ##
    if (!missing(add.data)) {
      if (!is.data.frame(add.data))
        stop("Argument 'add.data' must be a data frame.",
             call. = FALSE)
      if (nrow(add.data) != length(trts))
        stop("Dataset 'add.data' must have ", nrow(dat.i),
             " rows (corresponding to number of treatments)",
             call. = FALSE)
      if (any(rownames(add.data) != trts))
        stop("Dataset 'add.data' must have the following row names:\n",
             paste(paste0("'", trts, "'"), collapse = " - "),
             call. = FALSE)
      ##
      dat.i <- cbind(dat.i, add.data)
    }
    ##
    ## Sort dataset according to argument sortvar
    ##
    if (any(matchVar(sortvar.c, "Pscore")))
      sortvar <- Pscore
    else if (any(matchVar(sortvar.c, "-Pscore")))
      sortvar <- -Pscore
    else if (any(matchVar(sortvar.c, "SUCRA")))
      sortvar <- SUCRA
    else if (any(matchVar(sortvar.c, "-SUCRA")))
      sortvar <- -SUCRA
    else if (any(matchVar(sortvar.c, "TE")))
      sortvar <- dat.i$TE
    else if (any(matchVar(sortvar.c, "-TE")))
      sortvar <- -dat.i$TE
    else if (any(matchVar(sortvar.c, "seTE")))
      sortvar <- dat.i$seTE
    else if (any(matchVar(sortvar.c, "-seTE")))
      sortvar <- -dat.i$seTE
    else if (any(matchVar(sortvar.c, "k")))
      sortvar <- dat.i$k
    else if (any(matchVar(sortvar.c, "-k")))
      sortvar <- -dat.i$k
    else if (any(matchVar(sortvar.c, "n.trts")))
      sortvar <- dat.i$n.trts
    else if (any(matchVar(sortvar.c, "-n.trts")))
      sortvar <- -dat.i$n.trts
    else if (any(matchVar(sortvar.c, "prop.direct")))
      sortvar <- dat.i$prop.direct
    else if (any(matchVar(sortvar.c, "-prop.direct")))
      sortvar <- -dat.i$prop.direct
    ##
    if (!is.null(sortvar)) {
      if (is.character(sortvar))
        sort <- setseq(sortvar, trts)
      else
        sort <- order(sortvar)
      ##
      dat.i <- dat.i[sort, ]
    }
    ##
    if (drop.reference.group)
      dat.i <- subset(dat.i, treat != rg.i)
    ##
    if (baseline.reference)
      dat.i$comparison <- paste0("Other vs '", dat.i$comparison, "'")
    else
      dat.i$comparison <- paste0("'", dat.i$comparison, "' vs other")
    ##
    dat <- rbind(dat, dat.i)
  }
  ##
  dat.out <- dat
  ##
  if ("Pscore" %in% names(dat))
    dat$Pscore <- formatN(dat$Pscore, digits = digits.prop,
                          text.NA = lab.NA)
  ##
  if ("SUCRA" %in% names(dat))
    dat$SUCRA <- formatN(dat$SUCRA, digits = digits.prop,
                         text.NA = lab.NA)
  ##
  if ("prop.direct" %in% names(dat))
    dat$prop.direct <- formatN(dat$prop.direct,
                               digits = digits.prop, text.NA = lab.NA)
  ##
  rm(TE)
  rm(seTE)
  
  
  ##
  ##
  ## (5) Generate forest plot
  ##
  ##
  treat <- dat$treat
  ##
  if (one.rg)
    m1 <- suppressWarnings(metagen(TE, seTE, data = dat,
                                   sm = x$sm,
                                   studlab = labels, backtransf = backtransf,
                                   method.tau = "DL", method.tau.ci = "",
                                   warn = FALSE))
  else
    m1 <- suppressWarnings(metagen(TE, seTE, data = dat,
                                   subgroup = dat$comparison,
                                   sm = x$sm,
                                   studlab = labels, backtransf = backtransf,
                                   method.tau = "DL", method.tau.ci = "",
                                   warn = FALSE))
  #
  m1 <- setHet(m1, x)
  m1$.text.details.methods <-
    textmeth(x, pooled == "random", print.tau2, print.tau,
             "", "", gs("digits.tau2"), gs("digits.tau"),
             print.I2, gs("text.I2"),
             big.mark = gs("big.mark"), forest = TRUE)
  #
  forest(m1,
         digits = digits,
         #
         overall = FALSE, common = FALSE, random = FALSE,
         overall.hetstat = overall.hetstat,
         print.tau2 = print.tau2, print.tau = print.tau,
         print.I2 = print.I2,
         test.subgroup = FALSE,
         #
         leftcols = leftcols,
         leftlabs = leftlabs,
         rightcols = rightcols,
         rightlabs = rightlabs,
         #
         smlab = smlab, lab.NA = lab.NA,
         ##
         col.subgroup = col.subgroup,
         print.subgroup.name = print.subgroup.name,
         ##
         weight.study = if (equal.size) "same" else pooled,
         #
         addrows.below.overall = addrows.below.overall,
         #
         ...)
  
  rownames(dat.out) <- seq_len(nrow(dat.out))
  #
  attr(dat.out, "pooled") <- pooled
  attr(dat.out, "small.values") <- small.values
  #
  invisible(dat.out)
}


#' @rdname forest.netmeta
#' @method plot netmeta
#' @export

plot.netmeta <- function(x, ...)
  forest(x, ...)
