R/netgraph-internal.R

In netmeta: Network Meta-Analysis using Frequentist Methods

multicols <- function(studies, narms, missing.col.multiarm,
                      col.multiarm, alpha.transparency) {
  ##
  ## Define coloured regions for multi-arm studies
  ##
  dat <- data.frame(studies = studies, narms = narms)
  dat <- dat[rev(order(dat$narms)), ]
  dat <- dat[dat$narms > 2, ]
  multiarm.studies <- dat$studies
  ##
  n.multi <- length(multiarm.studies)
  ##
  missing.col.multiarm <- missing(col.multiarm)
  ##
  if (missing.col.multiarm | is.null(col.multiarm)) {
    ## Check for R package colorspace & use various gray values if
    ## not installed packages
    if (!any(as.data.frame(installed.packages())$Package == "colorspace"))
      cols <- grDevices::rainbow(n.multi, alpha = alpha.transparency)
    else
      cols <- colorspace::sequential_hcl(n.multi, alpha = alpha.transparency)
  }
  else {
    ##
    if (is.function(col.multiarm)) {
      mcname <- deparse(substitute(col.multiarm))
      ##
      csfun <- function(fcall, fname) {
        is.cs <- length(grep(fname, fcall)) > 0
        if (is.cs)
          is.installed.package("colorspace")
        is.cs
      }
      ##
      if (csfun(mcname, "rainbow_hcl"))
        cols <- colorspace::rainbow_hcl(n.multi, start = 240, end = 60, alpha = alpha.transparency)
      else if (csfun(mcname, "sequential_hcl"))
        cols <- colorspace::sequential_hcl(n.multi, alpha = alpha.transparency)
      else if (csfun(mcname, "diverge_hcl"))
        cols <- colorspace::diverge_hcl(n.multi, alpha = alpha.transparency)
      else if (csfun(mcname, "heat_hcl"))
        cols <- colorspace::heat_hcl(n.multi, alpha = alpha.transparency)
      else if (csfun(mcname, "terrain_hcl"))
        cols <- colorspace::terrain_hcl(n.multi, alpha = alpha.transparency)
      else if (csfun(mcname, "diverge_hsv"))
        cols <- colorspace::diverge_hsv(n.multi, alpha = alpha.transparency)
      else if (csfun(mcname, "choose_palette")) {
        fcolm <- colorspace::choose_palette(n = n.multi)
        cols <- fcolm(n = n.multi)
      }
      else
        cols <- sapply(n.multi, col.multiarm, alpha = alpha.transparency)
      ##
      if (csfun(mcname, "sequential_hcl") |
          csfun(mcname, "diverge_hcl") |
          csfun(mcname, "heat_hcl"))
        cols <- rev(cols)
    }
  }
  ##
  if (!missing.col.multiarm & is.character(col.multiarm)) {
    if (length(col.multiarm) > 1 & length(col.multiarm) != n.multi)
      stop("Length of argument 'col.multiarm' must be equal to one or the number of multi-arm studies: ", n.multi)
    cols <- col.multiarm
  }
  
  
  res <- list(cols = cols, multiarm.studies = multiarm.studies)
  res
}