Miscellaneous improvements to guides (#5345)

* Handle `labels = NULL` better

* Convert `guides()` error to warning

* Ignore no guides

* Swap old train order

* Fix `even.steps`/`show.limits` interaction

* Change to soft deprecation

* Fix old guide title

* Fix `draw_axis()` with `NULL` labels

* Default old guide title is `waiver()`

* `guide_for_position` becomes <Guides> method

* GuideColoursteps is a named class

* `guide_colourbar()` rejects discrete scales

* Fix test TODO

* Use `vec_slice()` to preserve attributes

* Document extension points

* Handle hashing in `train()`

R/coord-cartesian-.R

@@ -147,37 +147,9 @@ view_scales_from_scale <- function(scale, coord_limits = NULL, expand = TRUE) {
 }
 
 panel_guides_grob <- function(guides, position, theme) {
- pair <- guide_for_position(guides, position) %||%
- list(guide = guide_none(), params = NULL)
- pair$guide$draw(theme, pair$params)
-}
-
-guide_for_position <- function(guides, position) {
- params <- guides$params
- has_position <- vapply(
- params, function(p) identical(p$position, position), logical(1)
- )
- if (!any(has_position)) {
- return(NULL)
- }
-
- # Subset guides and parameters
- guides <- guides$get_guide(has_position)
- params <- params[has_position]
- # Pair up guides with parameters
- pairs <- Map(list, guide = guides, params = params)
-
- # Early exit, nothing to merge
- if (length(pairs) == 1) {
- return(pairs[[1]])
+ if (!inherits(guides, "Guides")) {
+ return(zeroGrob())
  }
-
- # TODO: There must be a smarter way to merge these
- order <- order(vapply(params, function(p) as.numeric(p$order), numeric(1)))
- Reduce(
- function(old, new) {
- old$guide$merge(old$params, new$guide, new$params)
- },
- pairs[order]
- )
+ pair <- guides$get_position(position)
+ pair$guide$draw(theme, pair$params)
 }

R/guide-.R

@@ -74,7 +74,79 @@ new_guide <- function(..., available_aes = "any", super) {
 #' To create a new type of Guide object, you typically will want to override
 #' one or more of the following:
 #'
-#' TODO: Fill this in properly
+#' Properties:
+#'
+#' - `available_aes` A `character` vector with aesthetics that this guide
+#' supports. The value `"any"` indicates all non-position aesthetics.
+#'
+#' - `params` A named `list` of parameters that the guide needs to function.
+#' It has the following roles:
+#'
+#' - `params` provides the defaults for a guide.
+#' - `names(params)` determines what are valid arguments to `new_guide()`.
+#' Some parameters are *required* to render the guide. These are: `title`,
+#' `name`, `position`, `direction`, `order` and `hash`.
+#' - During build stages, `params` holds information about the guide.
+#'
+#' - `elements` A named list of `character`s, giving the name of theme elements
+#' that should be retrieved automatically, for example `"legend.text"`.
+#'
+#' - `hashables` An `expression` that can be evaluated in the context of
+#' `params`. The hash of the evaluated expression determines the merge
+#' compatibility of guides, and is stored in `params$hash`.
+#'
+#' Methods:
+#'
+#' - `extract_key()` Returns a `data.frame` with (mapped) breaks and labels
+#' extracted from the scale, which will be stored in `params$key`.
+#'
+#' - `extract_decor()` Returns a `data.frame` containing other structured
+#' information extracted from the scale, which will be stored in
+#' `params$decor`. The `decor` has a guide-specific meaning: it is the bar in
+#' `guide_colourbar()`, but specifies the `axis.line` in `guide_axis()`.
+#'
+#' - `extract_params()` Updates the `params` with other, unstructured
+#' information from the scale. An example of this is inheriting the guide's
+#' title from the `scale$name` field.
+#'
+#' - `transform()` Updates the `params$key` based on the coordinates. This
+#' applies to position guides, as it rescales the aesthetic to the \[0, 1\]
+#' range.
+#'
+#' - `merge()` Combines information from multiple guides with the same
+#' `params$hash`. This ensures that e.g. `guide_legend()` can display both
+#' `shape` and `colour` in the same guide.
+#'
+#' - `get_layer_key()` Extract information from layers. This can be used to
+#' check that the guide's aesthetic is actually in use, or to gather
+#' information about how legend keys should be displayed.
+#'
+#' - `setup_params()` Set up parameters at the beginning of drawing stages.
+#' It can be used to overrule user-supplied parameters or perform checks on
+#' the `params` property.
+#'
+#' - `override_elements()` Take populated theme elements derived from the
+#' `elements` property and allows overriding these theme settings.
+#'
+#' - `build_title()` Render the guide's title.
+#'
+#' - `build_labels()` Render the guide's labels.
+#'
+#' - `build_decor()` Render the `params$decor`, which is different for every
+#' guide.
+#'
+#' - `build_ticks()` Render tick marks.
+#'
+#' - `measure_grobs()` Measure dimensions of the graphical objects produced
+#' by the `build_*()` methods to be used in the layout or assembly.
+#'
+#' - `arrange_layout()` Set up a layout for how graphical objects produced by
+#' the `build_*()` methods should be arranged.
+#'
+#' - `assemble_drawing()` Take the graphical objects produced by the `build_*()`
+#' methods, the measurements from `measure_grobs()` and layout from
+#' `arrange_layout()` to finalise the guide.
+#'
 #' @rdname ggplot2-ggproto
 #' @format NULL
 #' @usage NULL
@@ -117,14 +189,15 @@ Guide <- ggproto(
  return(NULL)
  }
  params$decor <- inject(self$extract_decor(scale, !!!params))
- self$extract_params(scale, params, self$hashables, ...)
+ params <- self$extract_params(scale, params, ...)
+ # Make hash
+ # TODO: Maybe we only need the hash on demand during merging?
+ params$hash <- hash(lapply(unname(self$hashables), eval_tidy, data = params))
+ params
  },
 
  # Setup parameters that are only available after training
- # TODO: Maybe we only need the hash on demand during merging?
- extract_params = function(scale, params, hashables, ...) {
- # Make hash
- params$hash <- hash(lapply(unname(hashables), eval_tidy, data = params))
+ extract_params = function(scale, params, ...) {
  params
  },
 
@@ -137,13 +210,18 @@ Guide <- ggproto(
 
  mapped <- scale$map(breaks)
  labels <- scale$get_labels(breaks)
+ # {vctrs} doesn't play nice with expressions, convert to list.
+ # see also https://github.com/r-lib/vctrs/issues/559
+ if (is.expression(labels)) {
+ labels <- as.list(labels)
+ }
 
  key <- data_frame(mapped, .name_repair = ~ aesthetic)
  key$.value <- breaks
  key$.label <- labels
 
  if (is.numeric(breaks)) {
- key[is.finite(breaks), , drop = FALSE]
+ vec_slice(key, is.finite(breaks))
  } else {
  key
  }
@@ -342,3 +420,14 @@ flip_names = c(
 # Shortcut for position argument matching
 .trbl <- c("top", "right", "bottom", "left")
 
+# Ensure that labels aren't a list of expressions, but proper expressions
+validate_labels <- function(labels) {
+ if (!is.list(labels)) {
+ return(labels)
+ }
+ if (any(vapply(labels, is.language, logical(1)))) {
+ do.call(expression, labels)
+ } else {
+ unlist(labels)
+ }
+}

R/guide-axis.R

@@ -103,9 +103,9 @@ GuideAxis <- ggproto(
  ticks_length = "axis.ticks.length"
  ),
 
- extract_params = function(scale, params, hashables, ...) {
+ extract_params = function(scale, params, ...) {
  params$name <- paste0(params$name, "_", params$aesthetic)
- Guide$extract_params(scale, params, hashables)
+ params
  },
 
  extract_decor = function(scale, aesthetic, position, key, cap = "none", ...) {
@@ -281,22 +281,14 @@ GuideAxis <- ggproto(
  },
 
  build_labels = function(key, elements, params) {
- labels <- key$.label
+ labels  <- validate_labels(key$.label)
  n_labels <- length(labels)
 
  if (n_labels < 1) {
  return(list(zeroGrob()))
  }
 
- pos <- key[[params$aes]]
-
- if (is.list(labels)) {
- if (any(vapply(labels, is.language, logical(1)))) {
- labels <- do.call(expression, labels)
- } else {
- labels <- unlist(labels)
- }
- }
+ pos <- key[[params$aes]]
 
  dodge_pos <- rep(seq_len(params$n.dodge %||% 1), length.out = n_labels)
  dodge_indices <- unname(split(seq_len(n_labels), dodge_pos))
@@ -432,9 +424,10 @@ draw_axis <- function(break_positions, break_labels, axis_position, theme,
  aes <- if (axis_position %in% c("top", "bottom")) "x" else "y"
  opp <- setdiff(c("x", "y"), aes)
  opp_value <- if (axis_position %in% c("top", "right")) 0 else 1
- key <- data_frame(
- break_positions, break_positions, break_labels,
- .name_repair = ~ c(aes, ".value", ".label")
+ key <- data_frame0(
+ !!aes := break_positions,
+ .value = break_positions,
+ .label = break_labels
  )
  params$key <- key
  params$decor <- data_frame0(

R/guide-bins.R

@@ -266,7 +266,7 @@ GuideBins <- ggproto(
  return(key)
  },
 
- extract_params = function(scale, params, hashables,
+ extract_params = function(scale, params,
  title = waiver(), direction = NULL, ...) {
 
  show.limits <- params$show.limits %||% scale$show.limits %||% FALSE
@@ -320,8 +320,7 @@ GuideBins <- ggproto(
  "not {.val {params$label.position}}."
  ))
  }
-
- Guide$extract_params(scale, params, hashables)
+ params
  },
 
  setup_params = function(params) {
@@ -340,7 +339,11 @@ GuideBins <- ggproto(
  },
 
  build_labels = function(key, elements, params) {
- key$.label[c(1, nrow(key))[!params$show.limits]] <- ""
+ n_labels <- length(key$.label)
+ if (n_labels < 1) {
+ return(list(labels = zeroGrob()))
+ }
+ key$.label[c(1, n_labels)[!params$show.limits]] <- ""
 
  just <- if (params$direction == "horizontal") {
  elements$text$vjust

R/guide-colorbar.R

@@ -317,6 +317,14 @@ GuideColourbar <- ggproto(
  theme.title = "legend.title"
  ),
 
+ extract_key = function(scale, aesthetic, ...) {
+ if (scale$is_discrete()) {
+ cli::cli_warn("{.fn guide_colourbar} needs continuous scales.")
+ return(NULL)
+ }
+ Guide$extract_key(scale, aesthetic, ...)
+ },
+
  extract_decor = function(scale, aesthetic, nbin = 300, reverse = FALSE, ...) {
 
  limits <- scale$get_limits()
@@ -335,7 +343,7 @@ GuideColourbar <- ggproto(
  return(bar)
  },
 
- extract_params = function(scale, params, hashables,
+ extract_params = function(scale, params,
  title = waiver(), direction = "vertical", ...) {
  params$title <- scale$make_title(
  params$title %|W|% scale$name %|W|% title
@@ -364,7 +372,7 @@ GuideColourbar <- ggproto(
  c(0.5, params$nbin - 0.5) / params$nbin,
  limits
  )
- Guide$extract_params(scale, params, hashables)
+ params
  },
 
  merge = function(self, params, new_guide, new_params) {
@@ -414,6 +422,11 @@ GuideColourbar <- ggproto(
  },
 
  build_labels = function(key, elements, params) {
+ n_labels <- length(key$.label)
+ if (n_labels < 1) {
+ return(list(labels = zeroGrob()))
+ }
+
  just <- if (params$direction == "horizontal") {
  elements$text$vjust
  } else {
@@ -422,7 +435,7 @@ GuideColourbar <- ggproto(
 
  list(labels = flip_element_grob(
  elements$text,
- label = key$.label,
+ label = validate_labels(key$.label),
  x = unit(key$.value, "npc"),
  y = rep(just, nrow(key)),
  margin_x = FALSE,

R/guide-colorsteps.R

@@ -74,7 +74,7 @@ guide_colorsteps <- guide_coloursteps
 #' @usage NULL
 #' @export
 GuideColoursteps <- ggproto(
- NULL, GuideColourbar,
+ "GuideColoursteps", GuideColourbar,
 
  params = c(
  list(even.steps = TRUE, show.limits = NULL),
@@ -135,7 +135,7 @@ GuideColoursteps <- ggproto(
  return(bar)
  },
 
- extract_params = function(scale, params, hashables, ...) {
+ extract_params = function(scale, params, ...) {
 
  if (params$even.steps) {
  params$nbin <- nbin <- sum(!is.na(params$key[[1]])) + 1
@@ -164,7 +164,7 @@ GuideColoursteps <- ggproto(
  from = c(0.5, nbin - 0.5) / nbin
  )
  key <- params$key
- limits <- attr(key, "limits", TRUE)
+ limits <- attr(key, "limits", TRUE) %||% scale$get_limits()
  key <- key[c(NA, seq_len(nrow(key)), NA), , drop = FALSE]
  key$.value[c(1, nrow(key))] <- edges
  key$.label[c(1, nrow(key))] <- scale$get_labels(limits)
@@ -177,6 +177,6 @@ GuideColoursteps <- ggproto(
  params$key <- key
  }
 
- GuideColourbar$extract_params(scale, params, hashables, ...)
+ GuideColourbar$extract_params(scale, params, ...)
  }
 )

R/guide-legend.R

@@ -259,7 +259,7 @@ GuideLegend <- ggproto(
  theme.title = "legend.title"
  ),
 
- extract_params = function(scale, params, hashables,
+ extract_params = function(scale, params,
  title = waiver(), direction = NULL, ...) {
  params$title <- scale$make_title(
  params$title %|W|% scale$name %|W|% title
@@ -271,8 +271,7 @@ GuideLegend <- ggproto(
  if (isTRUE(params$reverse %||% FALSE)) {
  params$key <- params$key[nrow(params$key):1, , drop = FALSE]
  }
-
- Guide$extract_params(scale, params, hashables)
+ params
  },
 
  merge = function(self, params, new_guide, new_params) {
@@ -476,6 +475,11 @@ GuideLegend <- ggproto(
  },
 
  build_labels = function(key, elements, params) {
+ n_labels <- length(key$.label)
+ if (n_labels < 1) {
+ out <- rep(list(zeroGrob()), nrow(key))
+ return(out)
+ }
  lapply(key$.label, function(lab) {
  ggname(
  "guide.label",