Classed palettes with properties (#427)

NAMESPACE

@@ -1,5 +1,11 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(as_continuous_pal,"function")
+S3method(as_continuous_pal,default)
+S3method(as_continuous_pal,pal_discrete)
+S3method(as_discrete_pal,"function")
+S3method(as_discrete_pal,default)
+S3method(as_discrete_pal,pal_continuous)
 S3method(fullseq,Date)
 S3method(fullseq,POSIXt)
 S3method(fullseq,difftime)
@@ -38,6 +44,8 @@ export(alpha)
 export(area_pal)
 export(as.trans)
 export(as.transform)
+export(as_continuous_pal)
+export(as_discrete_pal)
 export(asinh_trans)
 export(asn_trans)
 export(atanh_trans)
@@ -97,6 +105,11 @@ export(identity_pal)
 export(identity_trans)
 export(is.trans)
 export(is.transform)
+export(is_colour_pal)
+export(is_continuous_pal)
+export(is_discrete_pal)
+export(is_numeric_pal)
+export(is_pal)
 export(label_bytes)
 export(label_comma)
 export(label_currency)
@@ -129,6 +142,8 @@ export(minor_breaks_n)
 export(minor_breaks_width)
 export(modulus_trans)
 export(muted)
+export(new_continuous_palette)
+export(new_discrete_palette)
 export(new_transform)
 export(number)
 export(number_bytes)
@@ -160,6 +175,9 @@ export(pal_rescale)
 export(pal_seq_gradient)
 export(pal_shape)
 export(pal_viridis)
+export(palette_na_safe)
+export(palette_nlevels)
+export(palette_type)
 export(parse_format)
 export(percent)
 export(percent_format)

R/colour-ramp.R

@@ -66,13 +66,11 @@ colour_ramp <- function(colors, na.color = NA, alpha = TRUE) {
     alpha_interp <- stats::approxfun(x_in, lab_in[, 4])
   }
 
-  structure(
-    function(x) {
-      lab_out <- cbind(l_interp(x), u_interp(x), v_interp(x))
-      out <- farver::encode_colour(lab_out, alpha = alpha_interp(x), from = "lab")
-      out[is.na(out)] <- na.color
-      out
-    },
-    safe_palette_func = TRUE
-  )
+  fun <- function(x) {
+    lab_out <- cbind(l_interp(x), u_interp(x), v_interp(x))
+    out <- farver::encode_colour(lab_out, alpha = alpha_interp(x), from = "lab")
+    out[is.na(out)] <- na.color
+    out
+  }
+  new_continuous_palette(fun, type = "colour", na_safe = !is.na(na.color))
 }

R/pal-.R

@@ -0,0 +1,199 @@
+# Constructors ------------------------------------------------------------
+
+#' Constructors for palettes
+#'
+#' These constructor functions attach metadata to palette functions. This
+#' metadata can be used in testing or coercion.
+#'
+#' @param fun A function to serve as a palette. For continuous palettes, these
+#'   typically take vectors of numeric values between (0, 1) and return a
+#'   vector of equal length. For discrete palettes, these typically take a
+#'   scalar integer and return a vector of that length.
+#' @param type A string giving the type of return values. Some example strings
+#'   include `"colour"`, `"numeric"`, `"linetype"` or `"shape"`.
+#' @param na_safe A boolean indicating whether `NA` values are translated to
+#'   palette values (`TRUE`) or are kept as `NA` (`FALSE`). Applies to
+#'   continuous palettes.
+#' @param nlevels An integer giving the number of distinct palette values
+#'   that can be returned by the discrete palette.
+#' @param x An object to test or coerce.
+#' @param pal A palette to retrieve properties from.
+#' @param ... Additional arguments. Currently not in use.
+#'
+#' @return
+#' For `new_continuous_palette()`, `new_discret_palette()`, `as_discrete_pal()`
+#' and `as_continuous_pal()`: a function of class `pal_continuous` or `pal_discrete`.
+#' For `is_pal()`, `is_continuous_pal()`, `is_discret_pal()`, `is_colour_pal()`,
+#' or `is_numeric_pal()`: a logical value of length 1.
+#' For `palette_nlevels()` a single integer. For `palette_na_safe()` a boolean.
+#' For `palette_type()` a string.
+#' @export
+#'
+#' @examples
+#' # Creating a new discrete palette
+#' new_discrete_palette(
+#'   fun = grDevices::terrain.colors,
+#'   type = "colour", nlevels = 255
+#' )
+#'
+#' # Creating a new continuous palette
+#' new_continuous_palette(
+#'   fun = function(x) rescale(x, to = c(1, 0)),
+#'   type = "numeric", na_safe = FALSE
+#' )
+#'
+#' # Testing palette properties
+#' is_continuous_pal(pal_seq_gradient())
+#' is_discrete_pal(pal_viridis())
+#' is_numeric_pal(pal_area())
+#' is_colour_pal(pal_manual(c("red", "green")))
+#' is_pal(transform_log10())
+#'
+#' # Extracting properties
+#' palette_nlevels(pal_viridis())
+#' palette_na_safe(colour_ramp(c("red", "green"), na.color = "grey50"))
+#' palette_type(pal_shape())
+#'
+#' # Switching discrete to continuous
+#' pal <- as_continuous_pal(pal_viridis())
+#' show_col(pal(c(0, 0.1, 0.2, 0.4, 1)))
+#'
+#' # Switching continuous to discrete
+#' pal <- as_discrete_pal(pal_div_gradient())
+#' show_col(pal(9))
+new_continuous_palette <- function(fun, type, na_safe = NA) {
+  if (!is.function(fun)) {
+    cli::cli_abort("{.arg fun} must be a function.")
+  }
+  class(fun) <- union("pal_continuous", class(fun))
+  attr(fun, "type") <- type
+  attr(fun, "na_safe") <- na_safe
+  fun
+}
+
+#' @rdname new_continuous_palette
+#' @export
+new_discrete_palette <- function(fun, type, nlevels = NA) {
+  if (!is.function(fun)) {
+    cli::cli_abort("{.arg fun} must be a function.")
+  }
+  class(fun) <- union("pal_discrete", class(fun))
+  attr(fun, "type") <- type
+  attr(fun, "nlevels") <- nlevels
+  fun
+}
+
+# Testing -----------------------------------------------------------------
+
+#' @rdname new_continuous_palette
+#' @export
+is_pal <- function(x) inherits(x, c("pal_discrete", "pal_continuous"))
+
+#' @rdname new_continuous_palette
+#' @export
+is_continuous_pal <- function(x) inherits(x, "pal_continuous")
+
+#' @rdname new_continuous_palette
+#' @export
+is_discrete_pal <- function(x) inherits(x, "pal_discrete")
+
+#' @rdname new_continuous_palette
+#' @export
+is_colour_pal <- function(x) {
+  is_pal(x) && any(palette_type(x) %in% c("color", "colour"))
+}
+
+#' @rdname new_continuous_palette
+#' @export
+is_numeric_pal <- function(x) {
+  is_pal(x) && any(palette_type(x) %in% c("numeric", "double", "integer"))
+}
+
+# Getters -----------------------------------------------------------------
+
+#' @rdname new_continuous_palette
+#' @export
+palette_nlevels <- function(pal) {
+  as.integer(attr(pal, "nlevels")[1] %||% NA_integer_)
+}
+#' @rdname new_continuous_palette
+#' @export
+palette_na_safe <- function(pal) {
+  as.logical(attr(pal, "na_safe")[1] %||% FALSE)
+}
+#' @rdname new_continuous_palette
+#' @export
+palette_type <- function(pal) {
+  as.character(attr(pal, "type")[1] %||% NA_character_)
+}
+
+# Coercion ----------------------------------------------------------------
+
+## As discrete palette ----------------------------------------------------
+
+#' @rdname new_continuous_palette
+#' @export
+as_discrete_pal <- function(x, ...) {
+  UseMethod("as_discrete_pal")
+}
+
+#' @export
+as_discrete_pal.default <- function(x, ...) {
+  cli::cli_abort("Cannot convert {.arg x} to a discrete palette.")
+}
+
+#' @export
+as_discrete_pal.function <- function(x, ...) {
+  x
+}
+
+#' @export
+as_discrete_pal.pal_continuous <- function(x, ...) {
+  force(x)
+  new_discrete_palette(
+    function(n) x(seq(0, 1, length.out = n)),
+    type = palette_type(x), nlevels = 255
+  )
+}
+
+## As continuous palette --------------------------------------------------
+
+#' @rdname new_continuous_palette
+#' @export
+as_continuous_pal <- function(x, ...) {
+  UseMethod("as_continuous_pal")
+}
+
+#' @export
+as_continuous_pal.default <- function(x, ...) {
+  cli::cli_abort("Cannot convert {.arg x} to a continuous palette.")
+}
+
+#' @export
+as_continuous_pal.function <- function(x, ...) {
+  x
+}
+
+#' @export
+as_continuous_pal.pal_discrete <- function(x, ...) {
+  nlevels <- palette_nlevels(x)
+  if (!is_scalar_integerish(nlevels, finite = TRUE)) {
+    cli::cli_abort(c(
+      "Cannot convert {.arg x} to continuous palette.",
+      i = "Unknown number of supported levels."
+    ))
+  }
+  type <- palette_type(x)
+  switch(
+    type,
+    color = , colour = colour_ramp(x(nlevels)),
+    numeric = new_continuous_palette(
+      stats::approxfun(seq(0, 1, length.out = nlevels), x(nlevels)),
+      type = "numeric", na_safe = FALSE
+    ),
+    cli::cli_abort(
+      "Don't know how to convert a discrete {.field {type}} palette to \\
+      a continuous palette."
+    )
+  )
+}

R/pal-area.R

@@ -5,7 +5,10 @@
 #' @export
 pal_area <- function(range = c(1, 6)) {
   force(range)
-  function(x) rescale(sqrt(x), range, c(0, 1))
+  new_continuous_palette(
+    function(x) rescale(sqrt(x), range, c(0, 1)),
+    type = "numeric"
+  )
 }
 
 #' @export

R/pal-brewer.R

@@ -20,7 +20,7 @@
 pal_brewer <- function(type = "seq", palette = 1, direction = 1) {
   pal <- pal_name(palette, type)
   force(direction)
-  function(n) {
+  fun <- function(n) {
     # If <3 colors are requested, brewer.pal will return a 3-color palette and
     # give a warning. This warning isn't useful, so suppress it.
     # If the palette has k colors and >k colors are requested, brewer.pal will
@@ -40,6 +40,8 @@ pal_brewer <- function(type = "seq", palette = 1, direction = 1) {
 
     pal
   }
+  nlevels <- RColorBrewer::brewer.pal.info[pal, "maxcolors"]
+  new_discrete_palette(fun, "colour", nlevels)
 }
 
 #' @export

R/pal-dichromat.R

@@ -20,7 +20,8 @@ pal_dichromat <- function(name) {
   }
 
   pal <- dichromat::colorschemes[[name]]
-  function(n) pal[seq_len(n)]
+
+  pal_manual(pal, type = "colour")
 }
 
 #' @export

R/pal-gradient.R

@@ -15,7 +15,7 @@ pal_gradient_n <- function(colours, values = NULL, space = "Lab") {
   ramp <- colour_ramp(colours)
   force(values)
 
-  function(x) {
+  fun <- function(x) {
     if (length(x) == 0) {
       return(character())
     }
@@ -28,6 +28,7 @@ pal_gradient_n <- function(colours, values = NULL, space = "Lab") {
 
     ramp(x)
   }
+  new_continuous_palette(fun, "colour", na_safe = FALSE)
 }
 
 #' @export

R/pal-grey.R

@@ -9,7 +9,10 @@
 #' show_col(pal_grey(0, 1)(25))
 pal_grey <- function(start = 0.2, end = 0.8) {
   force_all(start, end)
-  function(n) grDevices::grey.colors(n, start = start, end = end)
+  new_discrete_palette(
+    function(n) grDevices::grey.colors(n, start = start, end = end),
+    type = "colour", nlevels = 255
+  )
 }
 
 #' @export

R/pal-hue.R

@@ -29,7 +29,7 @@ pal_hue <- function(h = c(0, 360) + 15, c = 100, l = 65, h.start = 0, direction
   if (length(l) != 1) cli::cli_abort("{.arg l} must have length 1.")
   if (length(c) != 1) cli::cli_abort("{.arg c} must have length 1.")
   force_all(h, c, l, h.start, direction)
-  function(n) {
+  fun <- function(n) {
     if (n == 0) {
       cli::cli_abort("Must request at least one colour from a hue palette.")
     }
@@ -51,6 +51,7 @@ pal_hue <- function(h = c(0, 360) + 15, c = 100, l = 65, h.start = 0, direction
       pal
     }
   }
+  new_discrete_palette(fun, "colour", 255)
 }
 
 #' @export

R/pal-linetype.R

@@ -9,9 +9,7 @@ pal_linetype <- function() {
     "12223242", "F282", "F4448444", "224282F2", "F1"
   )
 
-  function(n) {
-    types[seq_len(n)]
-  }
+  manual_pal(types, "linetype")
 }
 
 #' @export