Extracting guide data (version 3) (#5506)

* add `guide_data()` function

* add tests

* document

* rename getter (see #5568)

* swap from location-based to panel-based

Author: teunbrand

NAMESPACE

@@ -421,6 +421,7 @@ export(geom_violin)
 export(geom_vline)
 export(get_alt_text)
 export(get_element_tree)
+export(get_guide_data)
 export(gg_dep)
 export(ggplot)
 export(ggplotGrob)

NEWS.md

@@ -1,5 +1,8 @@
 # ggplot2 (development version)
 
+* The `get_guide_data()` function can be used to extract position and label
+  information from the plot (#5004).
+
 * The ggplot object now contains `$layout` which points to the `Layout` ggproto
   object and will be used by the `ggplot_build.ggplot` method. This was exposed
   so that package developers may extend the behavior of the `Layout` ggproto object

R/guides-.R

@@ -741,6 +741,91 @@ Guides <- ggproto(
   }
 )
 
+# Data accessor -----------------------------------------------------------
+
+#' Extract tick information from guides
+#'
+#' `get_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 panel An integer giving a panel number for which to return position guide
+#'   information.
+#'
+#' @return
+#' One of the following:
+#' * A `data.frame` representing the guide key, when the guide is unique for
+#'   the aesthetic.
+#' * A `list` when the coord does not support position axes or multiple guides
+#'   match the aesthetic.
+#' * `NULL` when no guide key 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
+#' get_guide_data(p, "size")
+#'
+#' # Note that legend guides can be merged
+#' merged <- p + guides(colour = "legend")
+#' get_guide_data(merged, "size")
+#'
+#' # Guide information for positions
+#' get_guide_data(p, "x", panel = 2)
+#'
+#' # Coord polar doesn't support proper guides, so we get a list
+#' polar <- p + coord_polar()
+#' get_guide_data(polar, "theta", panel = 2)
+get_guide_data <- function(plot = last_plot(), aesthetic, panel = 1L) {
+
+  check_string(aesthetic, allow_empty = FALSE)
+  aesthetic <- standardise_aes_names(aesthetic)
+
+  if (!inherits(plot, "ggplot_built")) {
+    plot <- ggplot_build(plot)
+  }
+
+  if (!aesthetic %in% c("x", "y", "x.sec", "y.sec", "theta", "r")) {
+    # Non position guides: check if aesthetic in colnames of key
+    keys <- lapply(plot$plot$guides$params, `[[`, "key")
+    keep <- vapply(keys, function(x) any(colnames(x) %in% aesthetic), logical(1))
+    keys <- switch(sum(keep) + 1, NULL, keys[[which(keep)]], keys[keep])
+    return(keys)
+  }
+
+  # Position guides: find the right layout entry
+  check_number_whole(panel)
+  layout <- plot$layout$layout
+  select <- layout[layout$PANEL == panel, , drop = FALSE]
+  if (nrow(select) == 0) {
+    return(NULL)
+  }
+  params <- plot$layout$panel_params[select$PANEL][[1]]
+
+  # If panel params don't have guides, we probably have old coord system
+  # that doesn't use the guide system.
+  if (is.null(params$guides)) {
+    # Old system: just return relevant parameters
+    aesthetic <- paste(aesthetic, c("major", "minor", "labels", "range"), sep = ".")
+    params <- params[intersect(names(params), aesthetic)]
+    return(params)
+  } else {
+    # Get and return key
+    key <- params$guides$get_params(aesthetic)$key
+    return(key)
+  }
+}
+
 # Helpers -----------------------------------------------------------------
 
 matched_aes <- function(layer, guide) {

man/get_guide_data.Rd

@@ -323,6 +323,55 @@ test_that("guide_colourbar merging preserves both aesthetics", {
   expect_true(all(c("colour", "fill") %in% names(merged$params$key)))
 })
 
+test_that("get_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 <- get_guide_data(b, "x", panel = 2)
+  expect_equal(test$.label, c("18", "19", "20", "21"))
+
+  # Test plain legend
+  test <- get_guide_data(b, "fill")
+  expect_equal(test$.label, c("2", "3", "4", "5"))
+
+  # Test merged legend
+  test <- get_guide_data(b, "colour")
+  expect_true(all(c("colour", "size") %in% colnames(test)))
+
+  # Unmapped data
+  expect_null(get_guide_data(b, "shape"))
+
+  # Non-existent panels
+  expect_null(get_guide_data(b, "x", panel = 4))
+
+  expect_error(get_guide_data(b, 1), "must be a single string")
+  expect_error(get_guide_data(b, "x", panel = "a"), "must be a whole number")
+})
+
+test_that("get_guide_data retrieves keys from exotic coords", {
+
+  p <- ggplot(mtcars, aes(mpg, disp)) + geom_point()
+
+  # Sanity check
+  test <- get_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 <- get_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 <- get_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"))
+})
+
 test_that("guide_colourbar warns about discrete scales", {
 
   g <- guide_colourbar()