Improve palette fallback (#6674)

* scales have fallback palettes

* replace fallback mechanism

* populate fallback palettes

* document news

* add news bullet

* Apply suggestion from code review

Co-authored-by: Thomas Lin Pedersen <[email protected]>

---------

Co-authored-by: Thomas Lin Pedersen <[email protected]>

Author: teunbrand

NEWS.md

@@ -9,8 +9,7 @@
   (@mitchelloharawild, #6609).
 * Fixed regression where `scale_{x,y}_*()` threw an error when an expression
   object is set to `labels` argument (@yutannihilation, #6617).
-
-
+* Improved palette fallback mechanism in scales (@teunbrand, #6669).
 * Allow `stat` in `geom_hline`, `geom_vline`, and `geom_abline`. (@sierrajohnson, #6559)
 * `stat_boxplot()` treats `width` as an optional aesthetic (@Yunuuuu, #6575)
 

R/scale-.R

@@ -92,6 +92,8 @@
 #'   to generate the values for the `expand` argument. The defaults are to
 #'   expand the scale by 5% on each side for continuous variables, and by
 #'   0.6 units on each side for discrete variables.
+#' @param fallback.palette Function to use when `palette = NULL` and the
+#'   palette is not represented in the theme.
 #' @param position For position scales, The position of the axis.
 #' `left` or `right` for y axes, `top` or `bottom` for x axes.
 #' @param call The `call` used to construct the scale for reporting messages.
@@ -107,6 +109,7 @@ continuous_scale <- function(aesthetics, scale_name = deprecated(), palette, nam
                              oob = censor, expand = waiver(), na.value = NA,
                              transform = "identity", trans = deprecated(),
                              guide = "legend", position = "left",
+                             fallback.palette = NULL,
                              call = caller_call(),
                              super = ScaleContinuous) {
   call <- call %||% current_call()
@@ -121,6 +124,7 @@ continuous_scale <- function(aesthetics, scale_name = deprecated(), palette, nam
   aesthetics <- standardise_aes_names(aesthetics)
 
   check_breaks_labels(breaks, labels, call = call)
+  check_fallback_palette(palette, fallback.palette, call = call)
 
   position <- arg_match0(position, c("left", "right", "top", "bottom"))
 
@@ -152,6 +156,7 @@ continuous_scale <- function(aesthetics, scale_name = deprecated(), palette, nam
 
     aesthetics = aesthetics,
     palette = palette,
+    fallback_palette = fallback.palette,
 
     range = ContinuousRange$new(),
     limits = limits,
@@ -211,6 +216,7 @@ discrete_scale <- function(aesthetics, scale_name = deprecated(), palette, name
                            labels = waiver(), limits = NULL, expand = waiver(),
                            na.translate = TRUE, na.value = NA, drop = TRUE,
                            guide = "legend", position = "left",
+                           fallback.palette = NULL,
                            call = caller_call(),
                            super = ScaleDiscrete) {
   call <- call %||% current_call()
@@ -221,6 +227,7 @@ discrete_scale <- function(aesthetics, scale_name = deprecated(), palette, name
   aesthetics <- standardise_aes_names(aesthetics)
 
   check_breaks_labels(breaks, labels, call = call)
+  check_fallback_palette(palette, fallback.palette, call = call)
 
   # Convert formula input to function if appropriate
   limits <- allow_lambda(limits)
@@ -251,6 +258,7 @@ discrete_scale <- function(aesthetics, scale_name = deprecated(), palette, name
 
     aesthetics = aesthetics,
     palette = palette,
+    fallback_palette = fallback.palette,
 
     range = DiscreteRange$new(),
     limits = limits,
@@ -303,6 +311,7 @@ binned_scale <- function(aesthetics, scale_name = deprecated(), palette, name =
                          right = TRUE, transform = "identity",
                          trans = deprecated(), show.limits = FALSE,
                          guide = "bins", position = "left",
+                         fallback.palette = NULL,
                          call = caller_call(),
                          super = ScaleBinned) {
   if (lifecycle::is_present(scale_name)) {
@@ -318,6 +327,7 @@ binned_scale <- function(aesthetics, scale_name = deprecated(), palette, name =
   aesthetics <- standardise_aes_names(aesthetics)
 
   check_breaks_labels(breaks, labels, call = call)
+  check_fallback_palette(palette, fallback.palette, call = call)
 
   position <- arg_match0(position, c("left", "right", "top", "bottom"))
 
@@ -346,6 +356,7 @@ binned_scale <- function(aesthetics, scale_name = deprecated(), palette, name =
 
     aesthetics = aesthetics,
     palette = palette,
+    fallback_palette = fallback.palette,
 
     range = ContinuousRange$new(),
     limits = limits,
@@ -589,7 +600,7 @@ Scale <- ggproto("Scale", NULL,
     if (empty(df)) {
       return()
     }
-    self$palette <- self$palette %||% fallback_palette(self)
+    self$palette <- self$palette %||% fetch_ggproto(self, "fallback_palette")
 
     aesthetics <- intersect(self$aesthetics, names(df))
     names(aesthetics) <- aesthetics
@@ -1775,6 +1786,15 @@ check_continuous_limits <- function(limits, ...,
   check_length(limits, 2L, arg = arg, call = call)
 }
 
+check_fallback_palette <- function(pal, fallback, call = caller_env()) {
+  if (!is.null(pal) || is.function(fallback)) {
+    return(invisible())
+  }
+  cli::cli_abort(
+    "When {.code palette = NULL}, the {.arg fallback.palette} must be defined."
+  )
+}
+
 allow_lambda <- function(x) {
   # we check the 'call' class to prevent interpreting `bquote()` calls as a function
   if (is_formula(x, lhs = FALSE) && !inherits(x, "call")) as_function(x) else x

R/scale-alpha.R

@@ -33,7 +33,11 @@
 #' p + scale_alpha("cylinders")
 scale_alpha <- function(name = waiver(), ..., range = NULL, aesthetics = "alpha") {
   palette <- if (!is.null(range)) pal_rescale(range) else NULL
-  continuous_scale(aesthetics, name = name, palette = palette, ...)
+  continuous_scale(
+    aesthetics, name = name, palette = palette,
+    fallback.palette = pal_rescale(c(0.1, 1)),
+    ...
+  )
 }
 
 #' @rdname scale_alpha
@@ -44,7 +48,11 @@ scale_alpha_continuous <- scale_alpha
 #' @export
 scale_alpha_binned <- function(name = waiver(), ..., range = NULL, aesthetics = "alpha") {
   palette <- if (!is.null(range)) pal_rescale(range) else NULL
-  binned_scale(aesthetics, name = name, palette = palette, ...)
+  binned_scale(
+    aesthetics, name = name, palette = palette,
+    fallback.palette = pal_rescale(c(0.1, 1)),
+    ...
+  )
 }
 
 #' @rdname scale_alpha
@@ -64,7 +72,11 @@ scale_alpha_ordinal <- function(name = waiver(), ..., range = NULL, aesthetics =
   } else {
     NULL
   }
-  discrete_scale(aesthetics, name = name, palette = palette, ...)
+  discrete_scale(
+    aesthetics, name = name, palette = palette,
+    fallback.palette = function(n) seq(0.1, 1, length.out = n),
+    ...
+  )
 }
 
 #' @rdname scale_alpha
@@ -74,7 +86,8 @@ scale_alpha_datetime <- function(name = waiver(), ..., range = NULL, aesthetics
   palette <- if (!is.null(range)) pal_rescale(range) else NULL
   datetime_scale(
     aesthetics = aesthetics, transform = "time", name = name,
-    palette = palette, ...
+    palette = palette, fallback.palette = pal_rescale(c(0.1, 1)),
+    ...
   )
 }
 
@@ -85,6 +98,7 @@ scale_alpha_date <- function(name = waiver(), ..., range = NULL, aesthetics = "a
   palette <- if (!is.null(range)) pal_rescale(range) else NULL
   datetime_scale(
     aesthetics = aesthetics, transform = "date", name = name,
-    palette = palette, ...
+    palette = palette, fallback.palette = pal_rescale(c(0.1, 1)),
+    ...
   )
 }

R/scale-colour.R

@@ -93,6 +93,7 @@ scale_colour_continuous <- function(..., palette = NULL, aesthetics = "colour",
   palette <- if (!is.null(palette)) as_continuous_pal(palette)
   continuous_scale(
     aesthetics, palette = palette, guide = guide, na.value = na.value,
+    fallback.palette = pal_seq_gradient("#132B43", "#56B1F7"),
     ...
   )
 }
@@ -115,6 +116,7 @@ scale_fill_continuous <- function(..., palette = NULL, aesthetics = "fill", guid
   palette <- if (!is.null(palette)) as_continuous_pal(palette)
   continuous_scale(
     aesthetics, palette = palette, guide = guide, na.value = na.value,
+    fallback.palette = pal_seq_gradient("#132B43", "#56B1F7"),
     ...
   )
 }
@@ -137,6 +139,7 @@ scale_colour_binned <- function(..., palette = NULL, aesthetics = "colour", guid
   palette <- if (!is.null(palette)) pal_binned(as_discrete_pal(palette))
   binned_scale(
     aesthetics, palette = palette, guide = guide, na.value = na.value,
+    fallback.palette = pal_seq_gradient("#132B43", "#56B1F7"),
     ...
   )
 }
@@ -158,6 +161,7 @@ scale_fill_binned <- function(..., palette = NULL, aesthetics = "fill", guide =
   palette <- if (!is.null(palette)) pal_binned(as_discrete_pal(palette))
   binned_scale(
     aesthetics, palette = palette, guide = guide, na.value = na.value,
+    fallback.palette = pal_seq_gradient("#132B43", "#56B1F7"),
     ...
   )
 }
@@ -227,6 +231,7 @@ scale_colour_discrete <- function(..., palette = NULL, aesthetics = "colour", na
   palette <- if (!is.null(palette)) as_discrete_pal(palette)
   discrete_scale(
     aesthetics, palette = palette, na.value = na.value,
+    fallback.palette = pal_hue(),
     ...
   )
 }
@@ -248,6 +253,7 @@ scale_fill_discrete <- function(..., palette = NULL, aesthetics = "fill", na.val
   palette <- if (!is.null(palette)) as_discrete_pal(palette)
   discrete_scale(
     aesthetics, palette = palette, na.value = na.value,
+    fallback.palette = pal_hue(),
     ...
   )
 }

R/scale-discrete-.R

@@ -10,7 +10,7 @@
 #' level, and increasing by one for each level (i.e. the labels are placed
 #' at integer positions).  This is what allows jittering to work.
 #'
-#' @inheritDotParams discrete_scale -scale_name
+#' @inheritDotParams discrete_scale -scale_name -fallback.palette
 #' @inheritParams discrete_scale
 #' @param palette A palette function that when called with a single integer
 #'   argument (the number of levels in the scale) returns the numerical values

R/scale-gradient.R

@@ -16,7 +16,7 @@
 #' @param low,high Colours for low and high ends of the gradient.
 #' @param guide Type of legend. Use `"colourbar"` for continuous
 #'   colour bar, or `"legend"` for discrete colour legend.
-#' @inheritDotParams continuous_scale -na.value -guide -aesthetics -expand -position -palette
+#' @inheritDotParams continuous_scale -na.value -guide -aesthetics -expand -position -palette -fallback.palette
 #' @seealso [scales::pal_seq_gradient()] for details on underlying
 #'   palette, [scale_colour_steps()] for binned variants of these scales.
 #'

R/scale-grey.R

@@ -5,7 +5,7 @@
 #'
 #' @inheritParams scales::pal_grey
 #' @inheritParams scale_colour_hue
-#' @inheritDotParams discrete_scale -expand -position -scale_name -palette
+#' @inheritDotParams discrete_scale -expand -position -scale_name -palette -fallback.palette
 #' @family colour scales
 #' @seealso
 #' The documentation on [colour aesthetics][aes_colour_fill_alpha].

R/scale-hue.R

@@ -4,7 +4,7 @@
 #' It does not generate colour-blind safe palettes.
 #'
 #' @param na.value Colour to use for missing values
-#' @inheritDotParams discrete_scale -aesthetics -expand -position -scale_name -palette
+#' @inheritDotParams discrete_scale -aesthetics -expand -position -scale_name -palette -fallback.palette
 #' @param aesthetics Character string or vector of character strings listing the
 #'   name(s) of the aesthetic(s) that this scale works with. This can be useful, for
 #'   example, to apply colour settings to the `colour` and `fill` aesthetics at the

R/scale-linetype.R

@@ -6,7 +6,7 @@
 #' no inherent order, this use is not advised.
 #'
 #' @inheritParams discrete_scale
-#' @inheritDotParams discrete_scale -expand -position -na.value -scale_name -palette
+#' @inheritDotParams discrete_scale -expand -position -na.value -scale_name -palette -fallback.palette
 #' @rdname scale_linetype
 #' @details
 #' Lines can be referred to by number, name or hex code. Contrary to base R
@@ -45,7 +45,7 @@
 scale_linetype <- function(name = waiver(), ..., aesthetics = "linetype") {
   discrete_scale(
     aesthetics, name = name,
-    palette = NULL,
+    palette = NULL, fallback.palette = pal_linetype(),
     ...
   )
 }
@@ -55,7 +55,7 @@ scale_linetype <- function(name = waiver(), ..., aesthetics = "linetype") {
 scale_linetype_binned <- function(name = waiver(), ..., aesthetics = "linetype") {
   binned_scale(
     aesthetics, name = name,
-    palette = NULL,
+    palette = NULL, fallback.palette = pal_binned(pal_linetype()),
     ...
   )
 }

R/scale-linewidth.R

@@ -36,9 +36,12 @@ scale_linewidth_continuous <- function(name = waiver(), breaks = waiver(),
                                        guide = "legend",
                                        aesthetics = "linewidth") {
   palette <- if (!is.null(range)) pal_rescale(range) else NULL
-  continuous_scale(aesthetics, palette = palette, name = name,
-                   breaks = breaks, labels = labels, limits = limits,
-                   transform = transform, trans = trans, guide = guide)
+  continuous_scale(
+    aesthetics, palette = palette, name = name,
+    breaks = breaks, labels = labels, limits = limits,
+    transform = transform, trans = trans, guide = guide,
+    fallback.palette = pal_rescale(c(1, 6))
+  )
 }
 
 #' @rdname scale_linewidth
@@ -52,10 +55,13 @@ scale_linewidth_binned <- function(name = waiver(), breaks = waiver(), labels =
                               nice.breaks = TRUE, transform = "identity",
                               trans = deprecated(), guide = "bins", aesthetics = "linewidth") {
   palette <- if (!is.null(range)) pal_rescale(range) else NULL
-  binned_scale(aesthetics, palette = palette, name = name,
-               breaks = breaks, labels = labels, limits = limits,
-               transform = transform, trans = trans, n.breaks = n.breaks,
-               nice.breaks = nice.breaks, guide = guide)
+  binned_scale(
+    aesthetics, palette = palette, name = name,
+    breaks = breaks, labels = labels, limits = limits,
+    transform = transform, trans = trans, n.breaks = n.breaks,
+    nice.breaks = nice.breaks, guide = guide,
+    fallback.palette = pal_rescale(c(1, 6))
+  )
 }
 
 #' @rdname scale_linewidth
@@ -77,7 +83,11 @@ scale_linewidth_ordinal <- function(name = waiver(), ..., range = NULL, aestheti
   } else {
     NULL
   }
-  discrete_scale(aesthetics, name = name, palette = palette, ...)
+  discrete_scale(
+    aesthetics, name = name, palette = palette,
+    fallback.palette = function(n) seq(2, 6, length.out = n),
+    ...
+  )
 }
 
 #' @rdname scale_linewidth
@@ -87,7 +97,8 @@ scale_linewidth_datetime <- function(name = waiver(), ..., range = NULL, aesthet
   palette <- if (!is.null(range)) pal_rescale(range) else NULL
   datetime_scale(
     aesthetics, transform = "time", name = name,
-    palette = palette, ...
+    palette = palette, fallback.palette = pal_rescale(c(1, 6)),
+    ...
   )
 }
 
@@ -98,6 +109,7 @@ scale_linewidth_date <- function(name = waiver(), ..., range = NULL, aesthetics
   palette <- if (!is.null(range)) pal_rescale(range) else NULL
   datetime_scale(
     aesthetics, transform = "date", name = name,
-    palette = palette, ...
+    palette = palette, fallback.palette = pal_rescale(c(1, 6)),
+    ...
   )
 }