diff --git a/NAMESPACE b/NAMESPACE index f0ccf3bec1..1220e7e6ef 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index 5df6059f0f..8d7f8760d0 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* New `get_labs()` function for retrieving completed plot labels + (@teunbrand, #6008). * Built-in `theme_*()` functions now have `ink` and `paper` arguments to control foreground and background colours respectively (@teunbrand) * The `summary()` method for ggplots is now more terse about facets diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index 586caee124..c7c424c2ac 100644 --- a/R/guide-colorbar.R +++ b/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)) }, diff --git a/R/guide-legend.R b/R/guide-legend.R index 671acf1a1c..37aad2e3f0 100644 --- a/R/guide-legend.R +++ b/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) }, diff --git a/R/labels.R b/R/labels.R index 20cc929d37..50e3776555 100644 --- a/R/labels.R +++ b/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. diff --git a/man/labs.Rd b/man/labs.Rd index 6fc7e9aa08..5d6fb93b52 100644 --- a/man/labs.Rd +++ b/man/labs.Rd @@ -5,6 +5,7 @@ \alias{xlab} \alias{ylab} \alias{ggtitle} +\alias{get_labs} \title{Modify axis, legend, and plot labels} \usage{ labs( @@ -22,6 +23,8 @@ xlab(label) ylab(label) ggtitle(label, subtitle = waiver()) + +get_labs(plot = get_last_plot()) } \arguments{ \item{...}{A list of new name-value pairs. The name should be an aesthetic.} @@ -44,6 +47,8 @@ rlang \link[rlang:as_function]{lambda} function notation.} \item{label}{The title of the respective axis (for \code{xlab()} or \code{ylab()}) or of the plot (for \code{ggtitle()}).} + +\item{plot}{A ggplot object} } \description{ Good labels are critical for making your plots accessible to a wider @@ -52,6 +57,8 @@ variable name. Use the plot \code{title} and \code{subtitle} to explain the main findings. It's common to use the \code{caption} to provide information about the data source. \code{tag} can be used for adding identification tags to differentiate between multiple plots. + +\code{get_labs()} retrieves completed labels from a plot. } \details{ You can also set axis and legend labels in the individual scales (using diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index 60f5165c1b..6a26578c0b 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -52,15 +52,13 @@ 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", { @@ -68,8 +66,8 @@ test_that("Labels can be extracted from attributes", { 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,16 +215,11 @@ 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"), @@ -237,14 +227,8 @@ 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 = 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 ------------------------------------------------------------