Port improvements to color mapping functions from leaflet (#191)

* Port improvements to color mapping functions from leaflet

* Code review feedback

Note the long comment on test-colors-advanced.r:118;
this represents differing behavior from the original
versions of these functions in leaflet.

* Rearrange color mapping tests (no tests were altered, added, or removed)

* Fix NOTE in R CMD check

* Remove unnecessary namespace

NEWS.md

@@ -38,6 +38,23 @@
 * `train_continuous()` now maintains the class of inputs when they are not
   numeric (@billdenney, #166).
 
+* `col_numeric()`, `col_bin()`, `col_quantile()`, and `col_factor()` now support
+  viridis colors. Just pass a palette name (`"magma"`, `"inferno"`, `"plasma"`,
+  or `"viridis"`) as the `palette` argument (@jcheng5, #191).
+
+* `col_numeric()`, `col_bin()`, `col_quantile()`, and `col_factor()` now have a
+  `reverse` parameter, to apply color palettes in the opposite of their usual
+  order (i.e. high-to-low instead of low-to-high) (@jcheng5, #191).
+
+* `col_bin()` and `col_quantile()` now take a `right` argument, which is passed
+  to `base::cut()`; it indicates whether the bin/quantile intervals should be
+  closed on the right (and open on the left), or vice versa (@jcheng5, #191).
+
+* `col_factor()` now tries to avoid interpolating qualitative RColorBrewer
+  palettes. Instead, it attempts to assign a palette color to each factor level.
+  Interpolation will still be used if there are more factor levels than
+  available colors, and a warning will be emitted in that case (@jcheng5, #191).
+
 # scales 1.0.0
 
 ## New Features

R/colour-mapping.r

@@ -20,13 +20,20 @@
 #'   domain.
 #' @param na.color The colour 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 `col_factor`, which expects
-#'   factors/characters), #RRGGBB colour strings are returned.
+#'   factors/characters), #RRGGBB colour strings are returned (unless
+#'   `alpha = TRUE` in which case #RRGGBBAA may also be possible).
 #'
 #' @export
-col_numeric <- function(palette, domain, na.color = "#808080") {
+col_numeric <- function(palette, domain, na.color = "#808080", alpha = FALSE, reverse = FALSE) {
   rng <- NULL
   if (length(domain) > 0) {
     rng <- range(domain, na.rm = TRUE)
@@ -35,7 +42,7 @@ col_numeric <- function(palette, domain, na.color = "#808080") {
     }
   }
 
-  pf <- safePaletteFunc(palette, na.color)
+  pf <- safePaletteFunc(palette, na.color, alpha)
 
   withColorAttr("numeric", list(na.color = na.color), function(x) {
     if (length(x) == 0 || all(is.na(x))) {
@@ -44,9 +51,12 @@ col_numeric <- function(palette, domain, na.color = "#808080") {
 
     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 colour scale and will be treated as NA")
+    rescaled <- 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", call. = FALSE)
+
+    if (reverse) {
+      rescaled <- 1 - rescaled
     }
     pf(rescaled)
   })
@@ -83,7 +93,9 @@ getBins <- function(domain, x, bins, pretty) {
 }
 
 #' @details `col_bin` also maps continuous numeric data, but performs
-#'   binning based on value (see the [base::cut()] function).
+#'   binning based on value (see the [base::cut()] function). `col_bin`
+#'   defaults for the `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.
@@ -92,31 +104,33 @@ getBins <- function(domain, x, bins, pretty) {
 #'   `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 [base::cut()]. See Details
 #' @rdname col_numeric
 #' @export
-col_bin <- function(palette, domain, bins = 7, pretty = TRUE, na.color = "#808080") {
+col_bin <- 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)) {
+  if (!is.null(domain))
     bins <- getBins(domain, NULL, bins, pretty)
-  }
   numColors <- if (length(bins) == 1) bins else length(bins) - 1
-  colorFunc <- col_factor(palette, domain = if (!autobin) 1:numColors, na.color = na.color)
-  pf <- safePaletteFunc(palette, na.color)
+  colorFunc <- col_factor(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) {
+  withColorAttr("bin", list(bins = bins, na.color = na.color, right = right), 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 = FALSE)
-    if (any(is.na(x) != is.na(ints))) {
-      warning("Some values were outside the color scale and will be treated as NA")
-    }
+    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", call. = FALSE)
     colorFunc(ints)
   })
 }
@@ -130,25 +144,29 @@ col_bin <- function(palette, domain, bins = 7, pretty = TRUE, na.color = "#80808
 #' @rdname col_numeric
 #' @export
 col_quantile <- function(palette, domain, n = 4,
-                         probs = seq(0, 1, length.out = n + 1), na.color = "#808080") {
+  probs = seq(0, 1, length.out = n + 1), na.color = "#808080", alpha = FALSE,
+  reverse = FALSE, right = FALSE) {
+
   if (!is.null(domain)) {
     bins <- stats::quantile(domain, probs, na.rm = TRUE, names = FALSE)
     return(withColorAttr(
-      "quantile", list(probs = probs, na.color = na.color),
-      col_bin(palette, domain = NULL, bins = bins, na.color = na.color)
+      "quantile", list(probs = probs, na.color = na.color, right = right),
+      col_bin(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 <- col_factor(palette, domain = 1:(length(probs) - 1), na.color = na.color)
-  withColorAttr("quantile", list(probs = probs, na.color = na.color), function(x) {
+  colorFunc <- col_factor(palette, domain = 1:(length(probs) - 1),
+    na.color = na.color, alpha = alpha, reverse = reverse)
+
+  withColorAttr("quantile", list(probs = probs, na.color = na.color, right = right), function(x) {
     binsToUse <- stats::quantile(x, probs, na.rm = TRUE, names = FALSE)
-    ints <- cut(x, binsToUse, labels = FALSE, include.lowest = TRUE, right = FALSE)
-    if (any(is.na(x) != is.na(ints))) {
-      warning("Some values were outside the color scale and will be treated as NA")
-    }
+    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", call. = FALSE)
     colorFunc(ints)
   })
 }
@@ -191,7 +209,7 @@ getLevels <- function(domain, x, lvls, ordered) {
 #' @rdname col_numeric
 #' @export
 col_factor <- function(palette, domain, levels = NULL, ordered = FALSE,
-                       na.color = "#808080") {
+  na.color = "#808080", alpha = FALSE, reverse = FALSE) {
 
   # domain usually needs to be explicitly provided (even if NULL) but not if
   # levels are specified
@@ -200,34 +218,32 @@ col_factor <- function(palette, domain, levels = NULL, ordered = FALSE,
   }
 
   if (!is.null(levels) && anyDuplicated(levels)) {
-    warning("Duplicate levels detected")
+    warning("Duplicate levels detected", call. = FALSE)
     levels <- unique(levels)
   }
   lvls <- getLevels(domain, NULL, levels, ordered)
-  hasFixedLevels <- is.null(lvls)
-  pf <- safePaletteFunc(palette, na.color)
 
+  force(palette) # palette loses scope
   withColorAttr("factor", list(na.color = na.color), function(x) {
     if (length(x) == 0 || all(is.na(x))) {
-      return(pf(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))
 
-    if (!is.factor(x) || hasFixedLevels) {
-      origNa <- is.na(x)
-      # Seems like we need to re-factor if hasFixedLevels, in case the x value
-      # has a different set of levels (like if droplevels was called in between
-      # when the domain was given and now)
-      x <- factor(x, lvls)
-      if (any(is.na(x) != origNa)) {
-        warning("Some values were outside the colour scale and will be treated as NA")
-      }
+    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", call. = FALSE)
     }
 
-    scaled <- scales::rescale(as.integer(x), from = c(1, length(lvls)))
+    scaled <- rescale(as.integer(x), from = c(1, length(lvls)))
     if (any(scaled < 0 | scaled > 1, na.rm = TRUE)) {
-      warning("Some values were outside the colour scale and will be treated as NA")
+      warning("Some values were outside the color scale and will be treated as NA", call. = FALSE)
+    }
+    if (reverse) {
+      scaled <- 1 - scaled
     }
     pf(scaled)
   })
@@ -237,6 +253,7 @@ col_factor <- function(palette, domain, levels = NULL, ordered = FALSE,
 #' \enumerate{
 #'   \item{A character vector of RGB or named colours. 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 colour. Examples: `colorRamp(c("#000000", "#FFFFFF"), interpolate="spline")`.}
 #' }
 #' @examples
@@ -261,42 +278,51 @@ col_factor <- function(palette, domain, levels = NULL, ordered = FALSE,
 NULL
 
 
-safePaletteFunc <- function(pal, na.color) {
+safePaletteFunc <- function(pal, na.color, alpha, nlevels = NULL) {
   filterRange(
     filterNA(
       na.color = na.color,
       filterZeroLength(
         filterRGB(
-          toPaletteFunc(pal)
+          toPaletteFunc(pal, alpha = alpha, nlevels = nlevels)
         )
       )
     )
   )
 }
 
-toPaletteFunc <- function(pal) {
+toPaletteFunc <- function(pal, alpha, nlevels) {
   UseMethod("toPaletteFunc")
 }
 
 # Strings are interpreted as color names, unless length is 1 and it's the name
-# of an RColorBrewer palette
-toPaletteFunc.character <- function(pal) {
+# of an RColorBrewer palette that is marked as qualitative
+toPaletteFunc.character <- function(pal, alpha, nlevels) {
   if (length(pal) == 1 && pal %in% row.names(RColorBrewer::brewer.pal.info)) {
-    return(colour_ramp(
-      RColorBrewer::brewer.pal(RColorBrewer::brewer.pal.info[pal, "maxcolors"], pal)
-    ))
+    paletteInfo <- RColorBrewer::brewer.pal.info[pal, ]
+    if (!is.null(nlevels)) {
+      # brewer_pal will return NAs if you ask for more colors than the palette has
+      colors <- brewer_pal(palette = pal)(abs(nlevels))
+      colors <- colors[!is.na(colors)]
+    } else {
+      colors <- brewer_pal(palette = pal)(RColorBrewer::brewer.pal.info[pal, "maxcolors"]) # Get all colors
+    }
+  } else if (length(pal) == 1 && pal %in% c("viridis", "magma", "inferno", "plasma")) {
+    colors <- viridis_pal(option = pal)(256)
+  } else {
+    colors <- pal
   }
 
-  colour_ramp(pal)
+  colour_ramp(colors, alpha = alpha)
 }
 
 # Accept colorRamp style matrix
-toPaletteFunc.matrix <- function(pal) {
-  toPaletteFunc(grDevices::rgb(pal, maxColorValue = 255))
+toPaletteFunc.matrix <- function(pal, alpha, nlevels) {
+  toPaletteFunc(grDevices::rgb(pal, maxColorValue = 255), alpha = alpha)
 }
 
 # If a function, just assume it's already a function over [0-1]
-toPaletteFunc.function <- function(pal) {
+toPaletteFunc.function <- function(pal, alpha, nlevels) {
   pal
 }