R/colors.R

In rstudio/leaflet: Create Interactive Web Maps with the JavaScript 'Leaflet' Library

#' Color mapping
#'
#' Conveniently maps data values (numeric or factor/character) to colors
#' according to a given palette, which can be provided in a variety of formats.
#'
#' `colorNumeric()` is a simple linear mapping from continuous numeric data
#' to an interpolated palette.
#'
#' @param palette The colors or color function that values will be mapped to
#' @param domain The possible values that can be mapped.
#'
#'   For `colorNumeric()` and `colorBin()`, this can be a simple numeric
#'   range (e.g. `c(0, 100)`); `colorQuantile()` needs representative
#'   numeric data; and `colorFactor()` needs categorical data.
#'
#'   If `NULL`, then whenever the resulting color function is called, the
#'   `x` value will represent the domain. This implies that if the function
#'   is invoked multiple times, the encoding between values and colors may not
#'   be consistent; if consistency is needed, you must provide a non-`NULL`
#'   domain.
#' @param na.color The color to return for `NA` values. Note that
#'   `na.color = NA` is valid.
#' @param alpha Whether alpha channels should be respected or ignored. If
#'   `TRUE` then colors without explicit alpha information will be treated
#'   as fully opaque.
#' @param reverse Whether the colors (or color function) in `palette`
#'   should be used in reverse order. For example, if the default order of a
#'   palette goes from blue to green, then `reverse = TRUE` will result in
#'   the colors going from green to blue.
#'
#' @return A function that takes a single parameter `x`; when called with a
#'   vector of numbers (except for `colorFactor()`, which expects
#'   factors/characters), #RRGGBB color strings are returned (unless
#'   `alpha = TRUE` in which case #RRGGBBAA may also be possible).
#'
#' @export
colorNumeric <- function(palette, domain, na.color = "#808080", alpha = FALSE, reverse = FALSE) {
  rng <- NULL
  if (length(domain) > 0) {
    rng <- range(domain, na.rm = TRUE)
    if (!all(is.finite(rng))) {
      stop("Wasn't able to determine range of domain")
    }
  }

  pf <- safePaletteFunc(palette, na.color, alpha)

  withColorAttr("numeric", list(na.color = na.color), function(x) {
    if (length(x) == 0 || all(is.na(x))) {
      return(pf(x))
    }

    if (is.null(rng)) rng <- range(x, na.rm = TRUE)

    rescaled <- scales::rescale(x, from = rng)
    if (any(rescaled < 0 | rescaled > 1, na.rm = TRUE))
      warning("Some values were outside the color scale and will be treated as NA")

    if (reverse) {
      rescaled <- 1 - rescaled
    }
    pf(rescaled)
  })
}

# Attach an attribute colorType to a color function f so we can derive legend
# items from it
withColorAttr <- function(type, args = list(), fun) {
  structure(fun, colorType = type, colorArgs = args)
}

# domain may or may not be NULL.
# Iff domain is non-NULL, x may be NULL.
# bins is non-NULL. It may be a scalar value (# of breaks) or a set of breaks.
getBins <- function(domain, x, bins, pretty) {
  if (is.null(domain) && is.null(x)) {
    stop("Assertion failed: domain and x can't both be NULL")
  }

  # Hard-coded bins
  if (length(bins) > 1) {
    return(bins)
  }

  if (bins < 2) {
    stop("Invalid bins value of ", bins, "; bin count must be at least 2")
  }
  if (pretty) {
    base::pretty(domain %||% x, n = bins)
  } else {
    rng <- range(domain %||% x, na.rm = TRUE)
    seq(rng[1], rng[2], length.out = bins + 1)
  }
}

#' @details `colorBin()` also maps continuous numeric data, but performs
#'   binning based on value (see the [base::cut()] function). `colorBin()`
#'   defaults for the [base::cut()] function are `include.lowest
#'   = TRUE` and `right = FALSE`.
#' @param bins Either a numeric vector of two or more unique cut points or a
#'   single number (greater than or equal to 2) giving the number of intervals
#'   into which the domain values are to be cut.
#' @param pretty Whether to use the function [pretty()] to generate
#'   the bins when the argument `bins` is a single number. When
#'   `pretty = TRUE`, the actual number of bins may not be the number of
#'   bins you specified. When `pretty = FALSE`, [seq()] is used
#'   to generate the bins and the breaks may not be "pretty".
#' @param right parameter supplied to cut. See Details
#' @rdname colorNumeric
#' @export
colorBin <- function(palette, domain, bins = 7, pretty = TRUE,
  na.color = "#808080", alpha = FALSE, reverse = FALSE, right = FALSE) {

  # domain usually needs to be explicitly provided (even if NULL) but not if
  # breaks are specified
  if (missing(domain) && length(bins) > 1) {
    domain <- NULL
  }
  autobin <- is.null(domain) && length(bins) == 1
  if (!is.null(domain))
    bins <- getBins(domain, NULL, bins, pretty)
  numColors <- if (length(bins) == 1) bins else length(bins) - 1
  colorFunc <- colorFactor(palette, domain = if (!autobin) 1:numColors,
    na.color = na.color, alpha = alpha, reverse = reverse)
  pf <- safePaletteFunc(palette, na.color, alpha)

  withColorAttr("bin", list(bins = bins, na.color = na.color), function(x) {
    if (length(x) == 0 || all(is.na(x))) {
      return(pf(x))
    }
    binsToUse <- getBins(domain, x, bins, pretty)
    ints <- cut(x, binsToUse, labels = FALSE, include.lowest = TRUE, right = right)
    if (any(is.na(x) != is.na(ints)))
      warning("Some values were outside the color scale and will be treated as NA")
    colorFunc(ints)
  })
}

#' @details `colorQuantile()` similarly bins numeric data, but via [stats::quantile()].
#' @param n Number of equal-size quantiles desired. For more precise control,
#'   use `probs` instead.
#' @param probs See [stats::quantile()]. If provided, `n` is ignored.
#' @rdname colorNumeric
#' @export
colorQuantile <- function(palette, domain, n = 4,
  probs = seq(0, 1, length.out = n + 1), na.color = "#808080", alpha = FALSE,
  reverse = FALSE, right = FALSE) {

  if (!is.null(domain)) {
    bins <- quantile(domain, probs, na.rm = TRUE, names = FALSE)
    return(withColorAttr(
      "quantile", list(probs = probs, na.color = na.color),
      colorBin(palette, domain = NULL, bins = bins, na.color = na.color,
        alpha = alpha, reverse = reverse)
    ))
  }

  # I don't have a precise understanding of how quantiles are meant to map to colors.
  # If you say probs = seq(0, 1, 0.25), which has length 5, does that map to 4 colors
  # or 5? 4, right?
  colorFunc <- colorFactor(palette, domain = 1:(length(probs) - 1),
    na.color = na.color, alpha = alpha, reverse = reverse)

  withColorAttr("quantile", list(probs = probs, na.color = na.color), function(x) {
    binsToUse <- quantile(x, probs, na.rm = TRUE, names = FALSE)
    ints <- cut(x, binsToUse, labels = FALSE, include.lowest = TRUE, right = right)
    if (any(is.na(x) != is.na(ints)))
      warning("Some values were outside the color scale and will be treated as NA")
    colorFunc(ints)
  })
}

# If already a factor, return the levels. Otherwise, convert to factor then
# return the levels.
calcLevels <- function(x, ordered) {
  if (is.null(x)) {
    NULL
  } else if (is.factor(x)) {
    levels(x)
  } else if (ordered) {
    unique(x)
  } else {
    sort(unique(x))
  }
}

getLevels <- function(domain, x, lvls, ordered) {
  if (!is.null(lvls))
    return(as.character(lvls))

  if (!is.null(domain)) {
    return(calcLevels(domain, ordered))
  }

  if (!is.null(x)) {
    return(calcLevels(x, ordered))
  }
}

#' @details `colorFactor()` maps factors to colors. If the palette is
#'   discrete and has a different number of colors than the number of factors,
#'   interpolation is used.
#' @param levels An alternate way of specifying levels; if specified, domain is
#'   ignored
#' @param ordered If `TRUE` and `domain` needs to be coerced to a
#'   factor, treat it as already in the correct order
#' @rdname colorNumeric
#' @export
colorFactor <- function(palette, domain, levels = NULL, ordered = FALSE,
  na.color = "#808080", alpha = FALSE, reverse = FALSE) {

  # domain usually needs to be explicitly provided (even if NULL) but not if
  # levels are specified
  if (missing(domain) && !is.null(levels)) {
    domain <- NULL
  }

  if (!is.null(levels) && anyDuplicated(levels)) {
    warning("Duplicate levels detected")
    levels <- unique(levels)
  }
  lvls <- getLevels(domain, NULL, levels, ordered)

  force(palette) # palette loses scope
  withColorAttr("factor", list(na.color = na.color), function(x) {
    if (length(x) == 0 || all(is.na(x))) {
      return(rep.int(na.color, length(x)))
    }

    lvls <- getLevels(domain, x, lvls, ordered)
    pf <- safePaletteFunc(palette, na.color, alpha, nlevels = length(lvls) * ifelse(reverse, -1, 1))

    origNa <- is.na(x)
    x <- match(as.character(x), lvls)
    if (any(is.na(x) != origNa)) {
      warning("Some values were outside the color scale and will be treated as NA")
    }

    scaled <- scales::rescale(as.integer(x), from = c(1, length(lvls)))
    if (any(scaled < 0 | scaled > 1, na.rm = TRUE)) {
      warning("Some values were outside the color scale and will be treated as NA")
    }
    if (reverse) {
      scaled <- 1 - scaled
    }
    pf(scaled)
  })
}

#' @details The `palette` argument can be any of the following:
#' \enumerate{
#'   \item{A character vector of RGB or named colors. Examples: `palette()`, `c("#000000", "#0000FF", "#FFFFFF")`, `topo.colors(10)`}
#'   \item{The name of an RColorBrewer palette, e.g. `"BuPu"` or `"Greens"`.}
#'   \item{The full name of a viridis palette: `"viridis"`, `"magma"`, `"inferno"`, or `"plasma"`.}
#'   \item{A function that receives a single value between 0 and 1 and returns a color. Examples: `colorRamp(c("#000000", "#FFFFFF"), interpolate = "spline")`.}
#' }
#' @examples
#' pal <- colorBin("Greens", domain = 0:100)
#' pal(runif(10, 60, 100))
#'
#' if (interactive()) {
#'   # Exponential distribution, mapped continuously
#'   previewColors(colorNumeric("Blues", domain = NULL), sort(rexp(16)))
#'   # Exponential distribution, mapped by interval
#'   previewColors(colorBin("Blues", domain = NULL, bins = 4), sort(rexp(16)))
#'   # Exponential distribution, mapped by quantile
#'   previewColors(colorQuantile("Blues", domain = NULL), sort(rexp(16)))
#'
#'   # Categorical data; by default, the values being colored span the gamut...
#'   previewColors(colorFactor("RdYlBu", domain = NULL), LETTERS[1:5])
#'   # ...unless the data is a factor, without droplevels...
#'   previewColors(colorFactor("RdYlBu", domain = NULL), factor(LETTERS[1:5], levels = LETTERS))
#'   # ...or the domain is stated explicitly.
#'   previewColors(colorFactor("RdYlBu", levels = LETTERS), LETTERS[1:5])
#' }
#' @rdname colorNumeric
#' @name colorNumeric
NULL


safePaletteFunc <- function(pal, na.color, alpha, nlevels = NULL) {
  toPaletteFunc(pal, alpha = alpha, nlevels = nlevels) %>%
    filterRGB() %>%
    filterZeroLength() %>%
    filterNA(na.color) %>%
    filterRange()
}

# nlevels is a positive or negative integer (or integral number) indicating the
# number of levels to use for a discrete scale (i.e. factor, i.e. qualitative,
# i.e. categorical); or NULL if it is a continuous scale. A negative value means
# that the user has asked for a "reversed" palette, so pull from the tail of the
# color palette rather than from the head.
#
# (Previous versions of this code didn't have nlevels and simply interpolated
# between colors in a qualitative palette--clearly the wrong thing to do.)
toPaletteFunc <- function(pal, alpha, nlevels) {
  UseMethod("toPaletteFunc")
}

# Wrapper function for brewer.pal that deals with n < 3, plus returns maxcolors
# by default
brewer_pal <- function(palette, n = NULL) {
  if (is.null(n))
    n <- RColorBrewer::brewer.pal.info[palette, "maxcolors"]

  # Work around the fact that if brewer.pal is passed a number smaller than 3,
  # it returns 3 colors anyway with a warning.
  #
  # It also warns if passed a number greater than maxcolors, but that's OK, we
  # want the user to see that warning.
  colors <- RColorBrewer::brewer.pal(max(3, n), palette)
  if (n == 1) {
    colors[1]
  } else if (n == 2) {
    colors[c(1, 3)]
  } else {
    colors
  }
}

# Strings are interpreted as color names, unless length is 1 and it's the name
# of an RColorBrewer palette that is marked as qualitative
#' @export
toPaletteFunc.character <- function(pal, alpha, nlevels) {
  if (length(pal) == 1 && pal %in% row.names(RColorBrewer::brewer.pal.info)) {
    paletteInfo <- RColorBrewer::brewer.pal.info[pal, ]
    if (!is.null(nlevels)) {
      colors <- brewer_pal(pal, abs(nlevels))
    } else {
      colors <- brewer_pal(pal) # Get all colors
    }
  } else if (length(pal) == 1 && pal %in% c("viridis", "magma", "inferno", "plasma")) {
    colors <- viridisLite::viridis(n = 256, option = pal)
  } else {
    colors <- pal
  }

  scales::colour_ramp(colors, alpha = alpha)
}

# Accept colorRamp style matrix
#' @export
toPaletteFunc.matrix <- function(pal, alpha, nlevels) {
  toPaletteFunc(rgb(pal, maxColorValue = 255), alpha = alpha)
}

# If a function, just assume it's already a function over [0-1]
#' @export
toPaletteFunc.function <- function(pal, alpha, nlevels) {
  pal
}

#' Color previewing utility
#'
#' @param pal A color mapping function, like those returned from [colorNumeric()], et al
#' @param values A set of values to preview colors for
#' @return An HTML-based list of the colors and values
#' @export
previewColors <- function(pal, values) {
  heading <- htmltools::tags$code(deparse(substitute(pal)))
  subheading <- htmltools::tags$code(deparse(substitute(values)))

  htmltools::browsable(
    with(htmltools::tags, htmltools::tagList(
      head(
        style(type = "text/css",
          "table { border-spacing: 1px; }",
          "body { font-family: Helvetica; font-size: 13px; color: #444; }",
          ".swatch { width: 24px; height: 18px; }",
          ".value { padding-left: 6px; }",
          "h3 code { font-weight: normal; }"
        )
      ),
      h3("Colors:", heading, br(), "Values:", class = "subhead", subheading),
      table(
        mapply(pal(values), values, FUN = function(color, x) {
          htmltools::tagList(tr(
            td(class = "swatch", style = paste0("background-color:", color)),
            td(class = "value", format(x, digits = 5))
          ))
        })
      )
    ))
  )
}

# colorRamp(space = "Lab") throws error when called with
# zero-length input
filterZeroLength <- function(f) {
  force(f)
  function(x) {
    if (length(x) == 0) {
      character(0)
    } else {
      f(x)
    }
  }
}

# Wraps an underlying non-NA-safe function (like colorRamp).
filterNA <- function(f, na.color) {
  force(f)
  function(x) {
    results <- character(length(x))
    nas <- is.na(x)
    results[nas] <- na.color
    results[!nas] <- f(x[!nas])
    results
  }
}

# Wraps a function that may return RGB color matrix instead of rgb string.
filterRGB <- function(f) {
  force(f)
  function(x) {
    results <- f(x)
    if (is.character(results)) {
      results
    } else if (is.matrix(results)) {
      rgb(results, maxColorValue = 255)
    } else {
      stop("Unexpected result type ", class(x)[[1]])
    }
  }
}

filterRange <- function(f) {
  force(f)
  function(x) {
    x[x < 0 | x > 1] <- NA
    f(x)
  }
}