Label accessor

NAMESPACE

@@ -426,6 +426,7 @@ export(get_alt_text)
 export(get_element_tree)
 export(get_geom_defaults)
 export(get_guide_data)
+export(get_labs)
 export(get_last_plot)
 export(get_layer_data)
 export(get_layer_grob)

NEWS.md

@@ -1,5 +1,7 @@
 # ggplot2 (development version)
 
+* New `get_labs()` function for retrieving completed plot labels 
+ (@teunbrand, #6008).
 * `guide_bins()`, `guide_colourbar()` and `guide_coloursteps()` gain an `angle`
  argument to overrule theme settings, similar to `guide_axis(angle)` 
  (@teunbrand, #4594).

R/guide-colorbar.R

@@ -273,6 +273,7 @@ GuideColourbar <- ggproto(
  merge = function(self, params, new_guide, new_params) {
  new_params$key$.label <- new_params$key$.value <- NULL
  params$key <- vec_cbind(params$key, new_params$key)
+ params$aesthetic <- union(params$aesthetic, new_params$aesthetic)
  return(list(guide = self, params = params))
  },
 

R/guide-legend.R

@@ -204,6 +204,7 @@ GuideLegend <- ggproto(
  cli::cli_warn("Duplicated {.arg override.aes} is ignored.")
  }
  params$override.aes <- params$override.aes[!duplicated(nms)]
+ params$aesthetic <- union(params$aesthetic, new_params$aesthetic)
 
  list(guide = self, params = params)
  },

R/labels.R

@@ -179,6 +179,39 @@ ggtitle <- function(label, subtitle = waiver()) {
  labs(title = label, subtitle = subtitle)
 }
 
+#' @rdname labs
+#' @export
+#' @param plot A ggplot object
+#' @description
+#' `get_labs()` retrieves completed labels from a plot.
+get_labs <- function(plot = get_last_plot()) {
+ plot <- ggplot_build(plot)
+
+ labs <- plot$plot$labels
+
+ xy_labs <- rename(
+ c(x = plot$layout$resolve_label(plot$layout$panel_scales_x[[1]], labs),
+ y = plot$layout$resolve_label(plot$layout$panel_scales_y[[1]], labs)),
+ c(x.primary = "x", x.secondary = "x.sec",
+ y.primary = "y", y.secondary = "y.sec")
+ )
+
+ labs <- defaults(xy_labs, labs)
+
+ guides <- plot$plot$guides
+ if (length(guides$aesthetics) == 0) {
+ return(labs)
+ }
+
+ for (aes in guides$aesthetics) {
+ param <- guides$get_params(aes)
+ aes <- param$aesthetic # Can have length > 1 when guide was merged
+ title <- vec_set_names(rep(list(param$title), length(aes)), aes)
+ labs <- defaults(title, labs)
+ }
+ labs
+}
+
 #' Extract alt text from a plot
 #'
 #' This function returns a text that can be used as alt-text in webpages etc.

tests/testthat/test-labels.R

@@ -52,24 +52,22 @@ test_that("setting guide labels works", {
 test_that("Labels from default stat mapping are overwritten by default labels", {
  p <- ggplot(mpg, aes(displ, hwy)) +
  geom_density2d()
- labels <- ggplot_build(p)$plot$labels
 
+ labels <- get_labs(p)
  expect_equal(labels$colour[1], "colour")
  expect_true(attr(labels$colour, "fallback"))
 
  p <- p + geom_smooth(aes(color = drv), method = "lm", formula = y ~ x)
- labels <- ggplot_build(p)$plot$labels
-
- expect_equal(labels$colour, "drv")
+ expect_equal(get_labs(p)$colour, "drv")
 })
 
 test_that("Labels can be extracted from attributes", {
  df <- mtcars
  attr(df$mpg, "label") <- "Miles per gallon"
 
  p <- ggplot(df, aes(mpg, disp)) + geom_point()
- labels <- ggplot_build(p)$plot$labels
 
+ labels <- get_labs(p)
  expect_equal(labels$x, "Miles per gallon")
  expect_equal(labels$y, "disp")
 })
@@ -79,14 +77,10 @@ test_that("Labels from static aesthetics are ignored (#6003)", {
  df <- data.frame(x = 1, y = 1, f = 1)
 
  p <- ggplot(df, aes(x, y, colour = f)) + geom_point()
- labels <- ggplot_build(p)$plot$labels
-
- expect_equal(labels$colour, "f")
+ expect_equal(get_labs(p)$colour, "f")
 
  p <- ggplot(df, aes(x, y, colour = f)) + geom_point(colour = "blue")
- labels <- ggplot_build(p)$plot$labels
-
- expect_null(labels$colour)
+ expect_null(get_labs(p)$colour)
 })
 
 test_that("alt text is returned", {
@@ -140,24 +134,25 @@ test_that("position axis label hierarchy works as intended", {
  geom_point(size = 5)
 
  p <- ggplot_build(p)
+ resolve_label <- function(x) p$layout$resolve_label(x, p$plot$labels)
 
  # In absence of explicit title, get title from mapping
  expect_identical(
- p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot$labels),
+ resolve_label(p$layout$panel_scales_x[[1]]),
  list(secondary = NULL, primary = "foo")
  )
  expect_identical(
- p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot$labels),
+ resolve_label(p$layout$panel_scales_y[[1]]),
  list(primary = "bar", secondary = NULL)
  )
 
  # Scale name overrules mapping label
  expect_identical(
- p$layout$resolve_label(scale_x_continuous("Baz"), p$plot$labels),
+ resolve_label(scale_x_continuous("Baz")),
  list(secondary = NULL, primary = "Baz")
  )
  expect_identical(
- p$layout$resolve_label(scale_y_continuous("Qux"), p$plot$labels),
+ resolve_label(scale_y_continuous("Qux")),
  list(primary = "Qux", secondary = NULL)
  )
 
@@ -167,23 +162,23 @@ test_that("position axis label hierarchy works as intended", {
  p$plot$layers
  )
  expect_identical(
- p$layout$resolve_label(scale_x_continuous("Baz"), p$plot$labels),
+ resolve_label(scale_x_continuous("Baz")),
  list(secondary = NULL, primary = "quuX")
  )
  expect_identical(
- p$layout$resolve_label(scale_y_continuous("Qux"), p$plot$labels),
+ resolve_label(scale_y_continuous("Qux")),
  list(primary = "corgE", secondary = NULL)
  )
 
  # Secondary axis names work
  xsec <- scale_x_continuous("Baz", sec.axis = dup_axis(name = "grault"))
  expect_identical(
- p$layout$resolve_label(xsec, p$plot$labels),
+ resolve_label(xsec),
  list(secondary = "grault", primary = "quuX")
  )
  ysec <- scale_y_continuous("Qux", sec.axis = dup_axis(name = "garply"))
  expect_identical(
- p$layout$resolve_label(ysec, p$plot$labels),
+ resolve_label(ysec),
  list(primary = "corgE", secondary = "garply")
  )
 
@@ -194,12 +189,12 @@ test_that("position axis label hierarchy works as intended", {
  p$plot$layers
  )
  expect_identical(
- p$layout$resolve_label(xsec, p$plot$labels),
+ resolve_label(xsec),
  list(secondary = "waldo", primary = "quuX")
  )
  ysec <- scale_y_continuous("Qux", sec.axis = dup_axis(name = "garply"))
  expect_identical(
- p$layout$resolve_label(ysec, p$plot$labels),
+ resolve_label(ysec),
  list(primary = "corgE", secondary = "fred")
  )
 })
@@ -220,31 +215,20 @@ test_that("moving guide positions lets titles follow", {
  ),
  p$plot$layers
  )
- expect_identical(
- p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot$labels),
- list(secondary = NULL, primary = "baz")
- )
- expect_identical(
- p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot$labels),
- list(primary = "qux", secondary = NULL)
- )
+ labs <- get_labs(p)
+ expect <- list(x = "baz", x.sec = NULL, y = "qux", y.sec = NULL)
+ expect_identical(labs[names(expect)], expect)
 
- # Guides at secondary positions (changes order of primary/secondary)
+ # Guides at secondary positions
  p$layout$setup_panel_guides(
  guides_list(
  list(x = guide_axis("baz", position = "top"),
  y = guide_axis("qux", position = "right"))
  ),
  p$plot$layers
  )
- expect_identical(
- p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot$labels),
- list(primary = "baz", secondary = NULL)
- )
- expect_identical(
- p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot$labels),
- list(secondary = NULL, primary = "qux")
- )
+ labs <- get_labs(p)
+ expect_identical(labs[names(expect)], expect)
 
  # Primary guides at secondary positions with
  # secondary guides at primary positions
@@ -257,14 +241,9 @@ test_that("moving guide positions lets titles follow", {
  ),
  p$plot$layers
  )
- expect_identical(
- p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot$labels),
- list(primary = "baz", secondary = "quux")
- )
- expect_identical(
- p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot$labels),
- list(secondary = "corge", primary = "qux")
- )
+ labs <- get_labs(p)
+ expect[c("x.sec", "y.sec")] <- list("quux", "corge")
+ expect_identical(labs[names(expect)], expect)
 })
 
 # Visual tests ------------------------------------------------------------