Gradient as colourbar (#5548)

* deprecate `raster` in favour of `display`

* Use 15 colours as default for gradient

* Don't account for bins to offset labels

* add gradient display

* deal with old R versions

* document options

* use `arg_match0()`

* Add news bullet

NEWS.md

@@ -1,5 +1,7 @@
 # ggplot2 (development version)
 
+* New `display` argument in `guide_colourbar()` supplants the `raster` argument.
+ In R 4.1.0 and above, `display = "gradient"` will draw a gradient.
 * When using `geom_dotplot(binaxis = "x")` with a discrete y-variable, dots are
  now stacked from the y-position rather than from 0 (@teunbrand, #5462)
 

R/backports.R

@@ -52,6 +52,9 @@ version_unavailable <- function(...) {
 viewport <- function(..., mask) grid::viewport(...)
 pattern <- version_unavailable
 as.mask <- version_unavailable
+# Unavailable prior to R 4.1.0
+linearGradient <- version_unavailable
+
 on_load({
  if ("mask" %in% fn_fmls_names(grid::viewport)) {
  viewport <- grid::viewport
@@ -63,5 +66,7 @@ on_load({
  if ("as.mask" %in% getNamespaceExports("grid")) {
  as.mask <- grid::as.mask
  }
+ if ("linearGradient" %in% getNamespaceExports("grid")) {
+ linearGradient <- grid::linearGradient()
+ }
 })
-

R/guide-colorbar.R

@@ -17,10 +17,18 @@ NULL
 #' @inheritParams guide_legend
 #' @param nbin A numeric specifying the number of bins for drawing the
 #' colourbar. A smoother colourbar results from a larger value.
-#' @param raster A logical. If `TRUE` then the colourbar is rendered as a
-#' raster object. If `FALSE` then the colourbar is rendered as a set of
-#' rectangles. Note that not all graphics devices are capable of rendering
-#' raster image.
+#' @param display A string indicating a method to display the colourbar. Can be
+#' one of the following:
+#'
+#' * `"raster"` to display as a bitmap image.
+#' * `"rectangles"` to display as a series of rectangles.
+#' * `"gradient"` to display as a linear gradient.
+#'
+#' Note that not all devices are able to render rasters and gradients.
+#' @param raster `r lifecycle::badge("deprecated")` A logical. If `TRUE` then
+#' the colourbar is rendered as a raster object. If `FALSE` then the colourbar
+#' is rendered as a set of rectangles. Note that not all graphics devices are
+#' capable of rendering raster image.
 #' @param alpha A numeric between 0 and 1 setting the colour transparency of
 #' the bar. Use `NA` to preserve the alpha encoded in the colour itself
 #' (default).
@@ -108,8 +116,9 @@ NULL
 guide_colourbar <- function(
  title = waiver(),
  theme = NULL,
- nbin = 300,
- raster = TRUE,
+ nbin = NULL,
+ display = "raster",
+ raster = deprecated(),
  alpha = NA,
  draw.ulim = TRUE,
  draw.llim = TRUE,
@@ -120,6 +129,13 @@ guide_colourbar <- function(
  available_aes = c("colour", "color", "fill"),
  ...
 ) {
+ if (lifecycle::is_present(raster)) {
+ deprecate_soft0("3.5.0", "guide_colourbar(raster)", "guide_colourbar(display)")
+ check_bool(raster)
+ display <- if (raster) "raster" else "rectangles"
+ }
+ display <- arg_match0(display, c("raster", "rectangles", "gradient"))
+ nbin <- nbin %||% switch(display, gradient = 15, 300)
 
  theme <- deprecated_guide_args(theme, ...)
  if (!is.null(position)) {
@@ -131,7 +147,7 @@ guide_colourbar <- function(
  title = title,
  theme = theme,
  nbin = nbin,
- raster = raster,
+ display = display,
  alpha = alpha,
  draw_lim = c(isTRUE(draw.llim), isTRUE(draw.ulim)),
  position = position,
@@ -167,7 +183,7 @@ GuideColourbar <- ggproto(
 
  # bar
  nbin = 300,
- raster = TRUE,
+ display = "raster",
  alpha = NA,
 
  draw_lim = c(TRUE, TRUE),
@@ -232,13 +248,13 @@ GuideColourbar <- ggproto(
  extract_params = function(scale, params,
  title = waiver(), ...) {
  params$title <- scale$make_title(params$title %|W|% scale$name %|W|% title)
-
  limits <- params$decor$value[c(1L, nrow(params$decor))]
- params$key$.value <- rescale(
- params$key$.value,
- c(0.5, params$nbin - 0.5) / params$nbin,
- limits
+ to <- switch(
+ params$display,
+ gradient = c(0, 1),
+ c(0.5, params$nbin - 0.5) / params$nbin
  )
+ params$key$.value <- rescale(params$key$.value, to = to, from = limits)
  params
  },
 
@@ -328,8 +344,7 @@ GuideColourbar <- ggproto(
  },
 
  build_decor = function(decor, grobs, elements, params) {
-
- if (params$raster) {
+ if (params$display == "raster") {
  image <- switch(
  params$direction,
  "horizontal" = t(decor$colour),
@@ -343,7 +358,7 @@ GuideColourbar <- ggproto(
  gp = gpar(col = NA),
  interpolate = TRUE
  )
- } else{
+ } else if (params$display == "rectangles") {
  if (params$direction == "horizontal") {
  width <- 1 / nrow(decor)
  height <- 1
@@ -362,6 +377,20 @@ GuideColourbar <- ggproto(
  default.units = "npc",
  gp = gpar(col = NA, fill = decor$colour)
  )
+ } else if (params$display == "gradient") {
+ check_device("gradients", call = expr(guide_colourbar()))
+ value <- if (isTRUE(params$reverse)) {
+ rescale(decor$value, to = c(1, 0))
+ } else {
+ rescale(decor$value, to = c(0, 1))
+ }
+ position <- switch(
+ params$direction,
+ horizontal = list(y1 = unit(0.5, "npc"), y2 = unit(0.5, "npc")),
+ vertical = list(x1 = unit(0.5, "npc"), x2 = unit(0.5, "npc"))
+ )
+ gradient <- inject(linearGradient(decor$colour, value, !!!position))
+ grob <- rectGrob(gp = gpar(fill = gradient, col = NA))
  }
 
  frame <- element_grob(elements$frame, fill = NA)