Configurable qualitative color scales

DESCRIPTION

@@ -56,6 +56,7 @@ Suggests:
     nlme,
     profvis,
     quantreg,
+    RColorBrewer,
     rgeos,
     rmarkdown,
     rpart,

R/scale-hue.r

@@ -1,8 +1,7 @@
 #' Evenly spaced colours for discrete data
 #'
-#' This is the default colour scale for categorical variables. It maps each
-#' level to an evenly spaced hue on the colour wheel. It does not generate
-#' colour-blind safe palettes.
+#' Maps each level to an evenly spaced hue on the colour wheel.
+#' It does not generate colour-blind safe palettes.
 #'
 #' @param na.value Colour to use for missing values
 #' @inheritDotParams discrete_scale -aesthetics
@@ -63,3 +62,118 @@ scale_fill_hue <- function(..., h = c(0, 360) + 15, c = 100, l = 65, h.start = 0
   discrete_scale(aesthetics, "hue", hue_pal(h, c, l, h.start, direction),
     na.value = na.value, ...)
 }
+
+
+#' Discrete colour scales
+#'
+#' The default discrete colour scale. Defaults to [scale_fill_hue()]/[scale_fill_brewer()]
+#' unless `type` (which defaults to the `ggplot2.discrete.fill`/`ggplot2.discrete.colour` options)
+#' is specified.
+#'
+#' @param ... Additional parameters passed on to the scale type,
+#' @param type One of the following:
+#'   * A character vector of color codes. The codes are used for a 'manual' color
+#'   scale as long as the number of codes exceeds the number of data levels
+#'   (if there are more levels than codes, [scale_colour_hue()]/[scale_fill_hue()]
+#'   are used to construct the default scale).
+#'   * A list of character vectors of color codes. The minimum length vector that exceeds the
+#'   number of data levels is chosen for the color scaling. This is useful if you
+#'   want to change the color palette based on the number of levels.
+#'   * A function that returns a discrete colour/fill scale (e.g., [scale_fill_hue()],
+#'   [scale_fill_brewer()], etc).
+#' @export
+#' @rdname
+#' @examples
+#' # Template function for creating densities grouped by a variable
+#' cty_by_var <- function(var) {
+#'   ggplot(mpg, aes(cty, colour = factor({{var}}), fill = factor({{var}}))) +
+#'     geom_density(alpha = 0.2)
+#' }
+#'
+#' # The default, scale_fill_hue(), is not colour-blind safe
+#' cty_by_var(class)
+#'
+#' # (Temporarily) set the default to Okabe-Ito (which is colour-blind safe)
+#' okabe <- c("#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")
+#' withr::with_options(
+#'   list(ggplot2.discrete.fill = okabe),
+#'   print(cty_by_var(class))
+#' )
+#'
+#' # Define a collection of palettes to alter the default based on number of levels to encode
+#' discrete_palettes <- list(
+#'   c("skyblue", "orange"),
+#'   RColorBrewer::brewer.pal(3, "Set2"),
+#'   RColorBrewer::brewer.pal(6, "Accent")
+#' )
+#' withr::with_options(
+#'   list(ggplot2.discrete.fill = discrete_palettes), {
+#'   # 1st palette is used when there 1-2 levels (e.g., year)
+#'   print(cty_by_var(year))
+#'   # 2nd palette is used when there are 3 levels
+#'   print(cty_by_var(drv))
+#'   # 3rd palette is used when there are 4-6 levels
+#'   print(cty_by_var(fl))
+#' })
+#'
+scale_colour_discrete <- function(..., type = getOption("ggplot2.discrete.colour", getOption("ggplot2.discrete.fill"))) {
+  # TODO: eventually `type` should default to a set of colour-blind safe color codes (e.g. Okabe-Ito)
+  type <- type %||% scale_colour_hue
+  if (is.function(type)) {
+    type(...)
+  } else {
+    scale_colour_qualitative(..., type = type)
+  }
+}
+
+#' @rdname scale_colour_discrete
+#' @export
+scale_fill_discrete <- function(..., type = getOption("ggplot2.discrete.fill", getOption("ggplot2.discrete.colour"))) {
+  # TODO: eventually `type` should default to a set of colour-blind safe color codes (e.g. Okabe-Ito)
+  type <- type %||% scale_fill_hue
+  if (is.function(type)) {
+    type(...)
+  } else {
+    scale_fill_qualitative(..., type = type)
+  }
+}
+
+scale_colour_qualitative <- function(..., type = NULL, h = c(0, 360) + 15, c = 100, l = 65, h.start = 0,
+                                     direction = 1, na.value = "grey50", aesthetics = "colour") {
+  discrete_scale(
+    aesthetics, "qualitative", qualitative_pal(type, h, c, l, h.start, direction),
+    na.value = na.value, ...
+  )
+}
+
+scale_fill_qualitative <- function(..., type = NULL, h = c(0, 360) + 15, c = 100, l = 65, h.start = 0,
+                                   direction = 1, na.value = "grey50", aesthetics = "fill") {
+  discrete_scale(
+    aesthetics, "qualitative", qualitative_pal(type, h, c, l, h.start, direction),
+    na.value = na.value, ...
+  )
+}
+
+#' Given set(s) of colour codes (i.e., type), find the smallest set that can support n levels
+#' @param type a character vector or a list of character vectors
+#' @noRd
+qualitative_pal <- function(type, h, c, l, h.start, direction) {
+  function(n) {
+    type_list <- if (!is.list(type)) list(type) else type
+    if (!all(vapply(type_list, is.character, logical(1)))) {
+      abort("`type` must be a character vector or a list of character vectors", call. = FALSE)
+    }
+    type_lengths <- vapply(type_list, length, integer(1))
+    # If there are more levels than color codes default to hue_pal()
+    if (max(type_lengths) < n) {
+      return(scales::hue_pal(h, c, l, h.start, direction)(n))
+    }
+    # Use the minimum length vector that exceeds the number of levels (n)
+    type_list <- type_list[order(type_lengths)]
+    i <- 1
+    while (length(type_list[[i]]) < n) {
+      i <- i + 1
+    }
+    type_list[[i]][seq_len(n)]
+  }
+}

R/zxx.r

@@ -1,10 +1,5 @@
 # Default scales -------------------------------------------------------------
 
-#' @export
-#' @rdname scale_hue
-#' @usage NULL
-scale_colour_discrete <- scale_colour_hue
-
 #' @export
 #' @rdname scale_viridis
 #' @usage NULL
@@ -64,11 +59,6 @@ scale_colour_date <- function(...,
 #' @usage NULL
 scale_color_date <- scale_colour_date
 
-#' @export
-#' @rdname scale_hue
-#' @usage NULL
-scale_fill_discrete <- scale_fill_hue
-
 #' @export
 #' @rdname scale_viridis
 #' @usage NULL
@@ -143,7 +133,7 @@ scale_color_binned <- scale_colour_binned
 #' @export
 #' @rdname scale_hue
 #' @usage NULL
-scale_color_discrete <- scale_colour_hue
+scale_color_discrete <- scale_colour_discrete
 
 #' @export
 #' @rdname scale_gradient

tests/testthat/test-scale-discrete.R

@@ -87,3 +87,45 @@ test_that("discrete non-position scales can accept functional limits", {
   scale$train(c("a", "b", "c"))
   expect_identical(scale$get_limits(), c("c", "b", "a"))
 })
+
+
+test_that("discrete scale defaults can be set globally", {
+  df <- data_frame(
+    x = 1:4, y = 1:4,
+    two = c("a", "b", "a", "b"),
+    four = c("a", "b", "c", "d")
+  )
+
+  withr::with_options(
+    list(ggplot2.discrete.fill = c("#FFFFFF", "#000000")), {
+      # nlevels == ncodes
+      two <- ggplot(df, aes(x, y, colour = two, fill = two)) + geom_point()
+      expect_equal(layer_data(two)$colour, rep(c("#FFFFFF", "#000000"), 2))
+      expect_equal(layer_data(two)$fill, rep(c("#FFFFFF", "#000000"), 2))
+
+      # nlevels > ncodes (so should fallback to scale_fill_hue())
+      four_default <- ggplot(df, aes(x, y, colour = four, fill = four)) +
+        geom_point()
+      four_hue <- four_default + scale_fill_hue()
+      expect_equal(layer_data(four_default)$colour, layer_data(four_hue)$colour)
+  })
+
+  withr::with_options(
+    list(
+      ggplot2.discrete.fill = list(
+        c("#FFFFFF", "#000000"),
+        c("#FF0000", "#00FF00", "#0000FF", "#FF00FF")
+      )
+    ), {
+      # nlevels == 2
+      two <- ggplot(df, aes(x, y, colour = two, fill = two)) + geom_point()
+      expect_equal(layer_data(two)$colour, rep(c("#FFFFFF", "#000000"), 2))
+      expect_equal(layer_data(two)$fill, rep(c("#FFFFFF", "#000000"), 2))
+
+      # nlevels == 4
+      four <- ggplot(df, aes(x, y, colour = four, fill = four)) + geom_point()
+      expect_equal(layer_data(four)$colour, c("#FF0000", "#00FF00", "#0000FF", "#FF00FF"))
+      expect_equal(layer_data(four)$fill, c("#FF0000", "#00FF00", "#0000FF", "#FF00FF"))
+    })
+
+})