R/colors.R

In ggraham/delfiVisID: Provides DELFI Visual Identity Colors and ggplot Theme Modifications

#' List of colors
#'
#' Use \code{\link{delfi_palette}} to construct palettes of desired length from
#' delfi visual identity colors
#'
#' @export
delfi_palettes <- list(
  Diverging = c("#2E83B7", "white", "#DD6627"),
  Categorical = c("#004766", "#77C8DD", "#DD6627", "#8B07F0", "#68C734")
)

#' DELFI Diagnostics visual identity palette generator
#'
#'
#' @param n (int) Number of colors returned, up to per-palette max (if n >= max,
#'   returns all).
#' @param name (str) Name of desired palette. Choices currently are:
#'   \code{"Diverging"}, \code{"Categorical"}
#' @param type (str) One of \code{"continuous"} or \code{"discrete"}. Will interpolate to n colors
#'   if continuous.
#' @importFrom graphics rect par image text
#' @importFrom grDevices rgb
#' @return A vector of colors.
#' @export
#' @keywords colors
#' @examples
#' delfi_palette("Diverging")
#' delfi_palette("Categorical", 3)
#'
#' # If you need more colours than normally found in a palette, you
#' # can use type="continuous" to interpolate between existing colors

delfi_palette <- function(name, n, type = c("discrete", "continuous")) {
  type <- match.arg(type)

  pal <- delfi_palettes[[name]]
  if (is.null(pal))
    stop("Palette not found.")

  if (missing(n)) {
    n <- length(pal)
  }

  if (type == "discrete" && n > length(pal)) {
    message(paste0("Number of requested colors greater than number of colors in palette (",
                   length(pal),
                   "), using all colors."))
    n <- length(pal)
  }

  out <- switch(type,
                continuous = grDevices::colorRampPalette(pal)(n),
                discrete = pal[1:n]
  )
  structure(out, class = "palette", name = name)
}

#' @export
#' @importFrom graphics rect par image text
#' @importFrom grDevices rgb
print.palette <- function(x, ...) {
  n <- length(x)
  old <- par(mar = c(0.5, 0.5, 0.5, 0.5))
  on.exit(par(old))

  image(1:n, 1, as.matrix(1:n), col = x,
        ylab = "", xaxt = "n", yaxt = "n", bty = "n")

  rect(0, 0.9, n + 1, 1.1, col = rgb(1, 1, 1, 0.8), border = NA)
  text((n + 1) / 2, 1, labels = attr(x, "name"), cex = 3, family = "sans")
}