Miscellaneous improvements to guides

R/coord-cartesian-.R

@@ -145,37 +145,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

@@ -319,6 +319,14 @@ GuideColourbar <- ggproto(
     title.align = "legend.title.align"
   ),
 
+  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()
@@ -337,7 +345,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
@@ -366,7 +374,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) {
@@ -416,6 +424,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 {
@@ -424,7 +437,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

@@ -261,7 +261,7 @@ GuideLegend <- ggproto(
     title.align = "legend.title.align"
   ),
 
-  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
@@ -273,8 +273,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) {
@@ -480,6 +479,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",