Gradient as colourbar

NEWS.md

@@ -1,5 +1,8 @@
 # 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.
+
 * Legend keys that can draw arrows have their size adjusted for arrows.
 
 * The `trans` argument in scales and secondary axes has been renamed to 

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 draw.ulim A logical specifying if the upper limit tick marks should
 #' be visible.
 #' @param draw.llim A logical specifying if the lower limit tick marks should
@@ -105,8 +113,9 @@ NULL
 guide_colourbar <- function(
  title = waiver(),
  theme = NULL,
- nbin = 300,
- raster = TRUE,
+ nbin = NULL,
+ display = "raster",
+ raster = deprecated(),
  draw.ulim = TRUE,
  draw.llim = TRUE,
  position = NULL,
@@ -116,6 +125,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)) {
@@ -126,7 +142,7 @@ guide_colourbar <- function(
  title = title,
  theme = theme,
  nbin = nbin,
- raster = raster,
+ display = display,
  draw_lim = c(isTRUE(draw.llim), isTRUE(draw.ulim)),
  position = position,
  direction = direction,
@@ -161,7 +177,7 @@ GuideColourbar <- ggproto(
 
  # bar
  nbin = 300,
- raster = TRUE,
+ display = "raster",
 
  draw_lim = c(TRUE, TRUE),
 
@@ -225,13 +241,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
  },
 
@@ -321,8 +337,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),
@@ -336,7 +351,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
@@ -355,6 +370,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)