Extracting guide data

NAMESPACE

@@ -422,6 +422,7 @@ export(guide_colorbar)
 export(guide_colorsteps)
 export(guide_colourbar)
 export(guide_coloursteps)
+export(guide_data)
 export(guide_gengrob)
 export(guide_geom)
 export(guide_legend)

NEWS.md

@@ -54,6 +54,8 @@
     * `guide_coloursteps()` and `guide_bins()` sort breaks (#5152).
     * `guide_axis()` gains a `cap` argument that can be used to trim the
       axis line to extreme breaks (#4907).
+    * The `guide_data()` function can be used to extract position and label
+      information from the plot (#5004).
 
 * `geom_label()` now uses the `angle` aesthetic (@teunbrand, #2785)
 * 'lines' units in `geom_label()`, often used in the `label.padding` argument, 

R/guides-.R

@@ -244,7 +244,7 @@ Guides <- ggproto(
   #      arrange all guide grobs
 
   build = function(self, scales, layers, default_mapping,
-                   position, theme, labels) {
+                   position, theme, labels, get_key = FALSE) {
 
     position  <- legend_position(position)
     no_guides <- zeroGrob()
@@ -279,6 +279,10 @@ Guides <- ggproto(
 
     # Merge and process layers
     guides$merge()
+    if (isTRUE(get_key)) {
+      return(lapply(guides$params, `[[`, "key"))
+    }
+
     guides$process_layers(layers)
     if (length(guides$guides) == 0) {
       return(no_guides)
@@ -642,3 +646,133 @@ validate_guide <- function(guide) {
   }
   cli::cli_abort("Unknown guide: {guide}")
 }
+
+# Data accessor -----------------------------------------------------------
+
+#' Extract tick information from guides
+#'
+#' `guide_data()` builds a plot and extracts information from guide keys. This
+#' information typically contains positions, values and/or labels, depending
+#' on which aesthetic is queried or guide is used.
+#'
+#' @param plot A `ggplot` or `ggplot_build` object.
+#' @param aesthetic A string that describes a single aesthetic for which to
+#'   extract guide information. For example: `"colour"`, `"size"`, `"x"` or
+#'   `"y.sec"`.
+#' @param i,j An integer giving a row (i) and column (j) number of a facet for
+#'   which to return position guide information.
+#'
+#' @return A `data.frame` containing information extracted from the guide key,
+#'   a `list` when the coord doesn't support position axes, or `NULL` when no
+#'   such information could be found.
+#' @export
+#' @keywords internal
+#'
+#' @examples
+#' # A standard plot
+#' p <- ggplot(mtcars) +
+#'   aes(mpg, disp, colour = drat, size = drat) +
+#'   geom_point() +
+#'   facet_wrap(vars(cyl), scales = "free_x")
+#'
+#' # Guide information for legends
+#' guide_data(p, "size")
+#'
+#' # Note that legend guides can be merged
+#' merged <- p + guides(colour = "legend")
+#' guide_data(merged, "size")
+#'
+#' # Guide information for positions
+#' guide_data(p, "x", i = 1, j = 2)
+#'
+#' # Coord polar doesn't support proper guides, so we get a list
+#' polar <- p + coord_polar()
+#' guide_data(theta, "theta", i = 1, j = 2)
+guide_data <- function(plot = last_plot(), aesthetic, i = 1L, j = 1L) {
+
+  # Only handles a single aesthetic
+  check_string(aesthetic, allow_empty = FALSE)
+
+  if (!inherits(plot, "ggplot_built")) {
+    plot <- ggplot_build(plot)
+  }
+  if (aesthetic %in% c("x", "y", "x.sec", "y.sec", "theta", "r")) {
+    ans <- guide_data_position(plot, aesthetic, i = i, j = j)
+  } else {
+    ans <- guide_data_legend(plot, aesthetic)
+  }
+  ans
+}
+
+
+guide_data_legend <- function(plot, aesthetic, ...) {
+  data  <- plot$plot
+  theme <- plot_theme(data)
+
+  # Resolve guide position
+  position <- calc_element("legend.position", theme) %||% "right"
+  if (length(position) == 2) {
+    position <- "manual"
+  }
+  if (position == "none") {
+    return(NULL)
+  }
+
+  # Build guides to get keys
+  keys <- data$guides$build(
+    data$scales, position = position, theme = theme,
+    labels = data$labels, get_key = TRUE
+  )
+
+  # Might be zeroGrob if no guides were to be drawn
+  if (inherits(keys, "zeroGrob")) {
+    return(NULL)
+  }
+
+  # Find key with aesthetic
+  idx <- vapply(keys, function(key) aesthetic %in% colnames(key), logical(1))
+  if (sum(idx) == 0) {
+    return(NULL)
+  }
+  if (sum(idx) == 1L) {
+    return(keys[[which(idx)]])
+  }
+  keys[idx]
+}
+
+guide_data_position <- function(plot, aesthetic, i = 1L, j = 1L) {
+  check_number_whole(i)
+  check_number_whole(j)
+
+  # Select only the panel parameters for the relevant panel
+  layout <- plot$layout$layout
+  select <- layout[layout$ROW == i & layout$COL == j, , drop = FALSE]
+  if (nrow(select) < 1) {
+    return(NULL)
+  }
+  panel_params <- plot$layout$panel_params[select$PANEL]
+
+  # Copy layout with just the one set of panel parameters
+  layout <- ggproto(NULL, plot$layout, panel_params = panel_params)
+
+  # Setup guides
+  layout$setup_panel_guides(plot$plot$guides, plot$plot$layers)
+  guides <- layout$panel_params[[1]]$guides
+  if (is.null(guides)) {
+    # Probably an older coord that doesn't support ggproto guides
+    params <- layout$panel_params[[1]]
+    idx <- paste(aesthetic, c("major", "minor", "labels", "range"), sep = ".")
+    params <- params[intersect(names(params), idx)]
+    return(layout$panel_params[[1]][idx])
+  }
+
+  # Check if we have a guide
+  guide <- guides$get_guide(aesthetic)
+  if (inherits(guide, "GuideNone")) {
+    return(NULL)
+  }
+
+  # Get guide's key
+  guides$get_params(aesthetic)$key
+}
+

tests/testthat/test-guides.R

@@ -311,6 +311,55 @@ test_that("guide_coloursteps and guide_bins return ordered breaks", {
   expect_true(all(diff(key$.value) < 0))
 })
 
+test_that("guide_data retrieves keys appropriately", {
+
+  p <- ggplot(mtcars, aes(mpg, disp, colour = drat, size = drat, fill = wt)) +
+    geom_point(shape = 21) +
+    facet_wrap(vars(cyl), scales = "free_x") +
+    guides(colour = "legend")
+  b <- ggplot_build(p)
+
+  # Test facetted panel
+  test <- guide_data(b, "x", i = 1, j = 2)
+  expect_equal(test$.label, c("18", "19", "20", "21"))
+
+  # Test plain legend
+  test <- guide_data(b, "fill")
+  expect_equal(test$.label, c("2", "3", "4", "5"))
+
+  # Test merged legend
+  test <- guide_data(b, "colour")
+  expect_true(all(c("colour", "size") %in% colnames(test)))
+
+  # Unmapped data
+  expect_null(guide_data(b, "shape"))
+
+  # Non-existent panels
+  expect_null(guide_data(b, "x", i = 2, j = 2))
+
+  expect_error(guide_data(b, 1), "must be a single string")
+  expect_error(guide_data(b, "x", i = "a"), "must be a whole number")
+})
+
+test_that("guide_data retrieves keys from exotic coords", {
+
+  p <- ggplot(mtcars, aes(mpg, disp)) + geom_point()
+
+  # Sanity check
+  test <- guide_data(p + coord_cartesian(), "x")
+  expect_equal(test$.label, c("10", "15", "20", "25", "30", "35"))
+
+  # We're not testing the formatting, so just testing output shape
+  test <- guide_data(p + coord_sf(crs = 3347), "y")
+  expect_equal(nrow(test), 5)
+  expect_true(all(c("x", ".value", ".label", "x") %in% colnames(test)))
+
+  # For coords that don't use guide system, we expect a list
+  test <- guide_data(p + coord_polar(), "theta")
+  expect_true(is.list(test) && !is.data.frame(test))
+  expect_equal(test$theta.labels, c("15", "20", "25", "30"))
+})
+
 # Visual tests ------------------------------------------------------------
 
 test_that("axis guides are drawn correctly", {