Named palettes

DESCRIPTION

@@ -39,4 +39,4 @@ Config/testthat/edition: 3
 Encoding: UTF-8
 LazyLoad: yes
 Roxygen: list(markdown = TRUE, r6 = FALSE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.2

NAMESPACE

@@ -1,9 +1,11 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(as_continuous_pal,"function")
+S3method(as_continuous_pal,character)
 S3method(as_continuous_pal,default)
 S3method(as_continuous_pal,pal_discrete)
 S3method(as_discrete_pal,"function")
+S3method(as_discrete_pal,character)
 S3method(as_discrete_pal,default)
 S3method(as_discrete_pal,pal_continuous)
 S3method(fullseq,Date)
@@ -97,6 +99,7 @@ export(expand_range)
 export(extended_breaks)
 export(format_format)
 export(fullseq)
+export(get_palette)
 export(gradient_n_pal)
 export(grey_pal)
 export(hms_trans)
@@ -176,6 +179,7 @@ export(pal_seq_gradient)
 export(pal_shape)
 export(pal_viridis)
 export(palette_na_safe)
+export(palette_names)
 export(palette_nlevels)
 export(palette_type)
 export(parse_format)
@@ -194,10 +198,12 @@ export(rescale_max)
 export(rescale_mid)
 export(rescale_none)
 export(rescale_pal)
+export(reset_palettes)
 export(reverse_trans)
 export(scientific)
 export(scientific_format)
 export(seq_gradient_pal)
+export(set_palette)
 export(shape_pal)
 export(show_col)
 export(sqrt_trans)

NEWS.md

@@ -1,5 +1,8 @@
 # scales (development version)
 
+* The scales package now keeps track of known palettes. These can be retrieved
+  using `get_palette()` or registered using `set_palette()` (#396).
+
 # scales 1.3.0
 
 ## Better type support

R/colour-manip.R

@@ -87,6 +87,14 @@ alpha <- function(colour, alpha = NA) {
 show_col <- function(colours, labels = TRUE, borders = NULL, cex_label = 1,
                      ncol = NULL) {
   n <- length(colours)
+  if (n == 1 && (is.function(colours) || !is_color(colours))) {
+    colours <- as_discrete_pal(colours)
+    n <- palette_nlevels(colours)
+    n <- if (is.na(n)) 16 else n
+    colours <- colours(n = n)
+    n <- length(colours)
+  }
+
   ncol <- ncol %||% ceiling(sqrt(length(colours)))
   nrow <- ceiling(n / ncol)
 

R/pal-.R

@@ -156,6 +156,14 @@ as_discrete_pal.pal_continuous <- function(x, ...) {
   )
 }
 
+#' @export
+as_discrete_pal.character <- function(x, ...) {
+  if (length(x) > 1)  {
+    return(pal_manual(x))
+  }
+  as_discrete_pal(get_palette(x, ...))
+}
+
 ## As continuous palette --------------------------------------------------
 
 #' @rdname new_continuous_palette
@@ -197,3 +205,11 @@ as_continuous_pal.pal_discrete <- function(x, ...) {
     )
   )
 }
+
+#' @export
+as_continuous_pal.character <- function(x, ...) {
+  if (length(x) > 1) {
+    return(colour_ramp(x))
+  }
+  as_continuous_pal(get_palette(x, ...))
+}

R/palette-registry.R

@@ -0,0 +1,157 @@
+.known_palettes <- new_environment(parent = empty_env())
+
+#' Known palettes
+#'
+#' The scales packages keeps track of a set of palettes it considers 'known'.
+#' The benefit of a known palette is that it can be called by name in functions
+#' as `as_continuous_pal()` or `as_discrete_pal()`.
+#'
+#' @param name A string giving the palette name.
+#' @param palette A [palette][new_continuous_palette], `function` or character
+#'   vector.
+#' @param warn_conflict A boolean which if `TRUE` (default), warns when
+#'   replacing a known palette.
+#' @param ... Additional arguments to pass to palette when it is a function
+#'   but not a palette class function.
+#'
+#' @return The `get_palette()` function returns a palette. The `set_palette()`
+#'   function is called for side effects and returns nothing.
+#' @export
+#'
+#' @examples
+#' # Get one of the known palettes
+#' get_palette("hue")
+#'
+#' # Set a new custom palette
+#' cols <- c("palegreen", "deepskyblue", "magenta")
+#' set_palette("aurora", palette = cols)
+#'
+#' # Palette is now known
+#' "aurora" %in% palette_names()
+#' as_continuous_pal("aurora")
+#'
+#' # Resetting palettes
+#' reset_palettes()
+get_palette <- function(name, ...) {
+
+  name <- tolower(name)
+  if (!exists(name, envir = .known_palettes)) {
+    cli::cli_abort("Unknown palette: {name}")
+  }
+
+  pal <- env_get(.known_palettes, name)
+
+  # Palette could be factory, in which case we want the product, or
+  # palette can be a palette function that isn't registered as such,
+  # in which case we want the colours it gives
+  if (is_function(pal) && !is_pal(pal)) {
+    pal <- try_fetch(
+      pal(...),
+      error = function(cnd) {
+        cli::cli_abort("Failed to interpret {name} as palette.", parent = cnd)
+      }
+    )
+  }
+  if (is.character(pal)) {
+    pal <- manual_pal(pal, type = "colour")
+  }
+  if (is_pal(pal)) {
+    return(pal)
+  }
+  cli::cli_abort("Failed to interpret {name} as palette.")
+}
+
+#' @export
+#' @rdname get_palette
+set_palette <- function(name, palette, warn_conflict = TRUE) {
+  name <- tolower(name)
+  if (!is_function(palette) && !is_character(palette)) {
+    cli::cli_abort(
+      "The {.arg palette} argument must be a {.cls function} or \\
+      {.cls character} vector."
+    )
+  }
+  if (warn_conflict & exists(name, envir = .known_palettes)) {
+    cli::cli_warn("Overwriting pre-existing {.val {name}} palette.")
+  }
+  env_bind(.known_palettes, !!name := palette)
+  invisible(NULL)
+}
+
+#' @export
+#' @rdname get_palette
+palette_names <- function() {
+  names(.known_palettes)
+}
+
+#' @export
+#' @rdname get_palette
+reset_palettes <- function() {
+  env_unbind(.known_palettes, palette_names())
+  init_palettes()
+}
+
+init_palettes <- function() {
+  register_hcl_pals()
+  register_base_pals()
+  register_viridis_pals()
+  register_brewer_pals()
+  register_dichromat_pals()
+  set_palette("grey", pal_grey, warn_conflict = FALSE)
+  set_palette("hue", pal_hue, warn_conflict = FALSE)
+}
+
+on_load(init_palettes())
+
+register_hcl_pals <- function(n = 31) {
+  names <- grDevices::hcl.pals()
+  for (name in names) {
+    fun <- colour_ramp(grDevices::hcl.colors(n, palette = name))
+    set_palette(name, fun, warn_conflict = FALSE)
+  }
+  invisible(NULL)
+}
+
+register_base_pals <- function() {
+  if (getRversion() < "4.0.0") {
+    return(invisible(NULL))
+  }
+  names   <- utils::getFromNamespace("palette.pals",   "grDevices")()
+  palette <- utils::getFromNamespace("palette.colors", "grDevices")
+  for (name in names) {
+    fun <- manual_pal(palette(palette = name), type = "colour")
+    set_palette(name, fun, warn_conflict = FALSE)
+  }
+  invisible(NULL)
+}
+
+register_viridis_pals <- function() {
+  names <- c("magma", "inferno", "plasma", "viridis",
+             "cividis", "rocket", "mako", "turbo")
+  for (name in names) {
+    fun <- pal_viridis(option = name)
+    set_palette(name, fun, warn_conflict = FALSE)
+  }
+  invisible(NULL)
+}
+
+register_brewer_pals <- function() {
+  names <- rownames(RColorBrewer::brewer.pal.info)
+  for (name in names) {
+    fun <- pal_brewer(palette = name)
+    set_palette(name, fun, warn_conflict = FALSE)
+  }
+  invisible(NULL)
+}
+
+register_dichromat_pals <- function() {
+  if (!is_installed("dichromat")) {
+    return(invisible(NULL))
+  }
+  names <- names(dichromat::colorschemes)
+  for (name in names) {
+    fun <- manual_pal(dichromat::colorschemes[[name]], type = "colour")
+    set_palette(name, fun, warn_conflict = FALSE)
+  }
+  invisible(NULL)
+}

R/utils.R

@@ -100,3 +100,7 @@ recycle_common <- function(..., size = NULL, call = caller_env()) {
   x[to_recycle] <- lapply(x[to_recycle], rep_len, length.out = size)
   x
 }
+
+.onLoad <- function(lib, pkg) {
+  run_on_load()
+}

_pkgdown.yml

@@ -68,6 +68,7 @@ reference:
   - contains("col")
   - muted
   - alpha
+  - get_palette
 
 - title: Non-colour palette functions
   desc: >

tests/testthat/test-palette-registry.R

@@ -0,0 +1,41 @@
+test_that("palette getters and setters work as intended", {
+
+  # Test that palettes have been populated in .onLoad
+  expect_in(c("hue", "grey"), palette_names())
+
+  # We cannot get unknown palettes
+  expect_error(get_palette("rgb"), "Unknown palette")
+
+  # We cannot set nonsense palettes
+  expect_error(
+    set_palette("foobar", list(a = 1:2, b = "A")),
+    "must be a"
+  )
+
+  # Test we can set custom palettes
+  colours <- c("red", "green", 'blue')
+  set_palette("rgb", palette = colours)
+  expect_in("rgb", palette_names())
+
+  # Test we can get custom palettes
+  pal <- get_palette("rgb")
+  expect_equal(pal(length(colours)), colours)
+
+  # Test we can reset palettes
+  reset_palettes()
+  expect_false("rgb" %in% palette_names())
+})
+
+test_that("as_continuous_pal and as_discrete_pal can retrieve known palettes", {
+
+  colours <- c("#FF0000", "#00FF00", '#0000FF')
+  set_palette("rgb", colours)
+
+  pal <- as_discrete_pal("rgb")
+  expect_equal(pal(length(colours)), colours)
+
+  pal <- as_continuous_pal("rgb")
+  expect_equal(pal(seq(0, 1, length.out = length(colours))), colours)
+
+  reset_palettes()
+})