diff --git a/DESCRIPTION b/DESCRIPTION index aa36b34895..90aaf8209a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -79,7 +79,7 @@ Config/testthat/edition: 3 Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.2 Collate: 'ggproto.R' 'ggplot-global.R' diff --git a/NAMESPACE b/NAMESPACE index 67c7a4941a..96959a985a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -67,6 +67,7 @@ S3method(ggplot_add,list) S3method(ggplot_add,theme) S3method(ggplot_add,uneval) S3method(ggplot_build,ggplot) +S3method(ggplot_build,ggplot_built) S3method(ggplot_gtable,ggplot_built) S3method(grid.draw,absoluteGrob) S3method(grid.draw,ggplot) @@ -420,7 +421,9 @@ export(geom_violin) export(geom_vline) export(get_alt_text) export(get_element_tree) +export(get_geom_defaults) export(get_guide_data) +export(get_labs) export(gg_dep) export(ggplot) export(ggplotGrob) diff --git a/NEWS.md b/NEWS.md index 24cd6a5e80..a5988574f8 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,11 @@ +# ggplot2 (development version) + +* New `get_labs()` function for retrieving completed plot labels + (@teunbrand, #6008). +* New `get_geom_defaults()` for retrieving resolved default aesthetics. +* A new `ggplot_build()` S3 method for classes was added, which + returns input unaltered (@teunbrand, #5800). + # ggplot2 3.5.1 This is a small release focusing on fixing regressions from 3.5.0 and diff --git a/R/geom-defaults.R b/R/geom-defaults.R index afd2e598d4..ab681a51db 100644 --- a/R/geom-defaults.R +++ b/R/geom-defaults.R @@ -53,3 +53,54 @@ update_stat_defaults <- function(stat, new) { g$default_aes[names(new)] <- new invisible() } + +#' Resolve and get geom defaults +#' +#' @param geom Some definition of a geom: +#' * A `function` that creates a layer, e.g. `geom_path()`. +#' * A layer created by such function +#' * A string naming a geom class in snake case without the `geom_`-prefix, +#' e.g. `"contour_filled"`. +#' * A geom class object. +#' @param theme A [`theme`] object. Defaults to the current global theme. +#' +#' @return A list of aesthetics +#' @export +#' @keywords internal +#' +#' @examples +#' # Using a function +#' get_geom_defaults(geom_raster) +#' +#' # Using a layer includes static aesthetics as default +#' get_geom_defaults(geom_tile(fill = "white")) +#' +#' # Using a class name +#' get_geom_defaults("density_2d") +#' +#' # Using a class +#' get_geom_defaults(GeomPoint) +#' +#' # Changed theme +#' get_geom_defaults("point", theme(geom = element_geom(ink = "purple"))) +get_geom_defaults <- function(geom, theme = theme_get()) { + theme <- theme %||% list(geom = .default_geom_element) + + if (is.function(geom)) { + geom <- geom() + } + if (is.layer(geom)) { + data <- data_frame0(.id = 1L) + data <- geom$compute_geom_2(data = data) + data$.id <- NULL + return(data) + } + if (is.character(geom)) { + geom <- check_subclass(geom, "Geom") + } + if (inherits(geom, "Geom")) { + out <- geom$use_defaults(data = NULL) + return(out) + } + stop_input_type(geom, as_cli("a layer function, string or {.cls Geom} object")) +} diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index b8e62f82c9..0e33699774 100644 --- a/R/guide-colorbar.R +++ b/R/guide-colorbar.R @@ -266,6 +266,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 c685cdd8c7..ecf47b3089 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/guides-.R b/R/guides-.R index 2280c40def..3ad66a4bf5 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -792,9 +792,7 @@ 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) - } + 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 diff --git a/R/labels.R b/R/labels.R index a70d6d535c..c17a4f484d 100644 --- a/R/labels.R +++ b/R/labels.R @@ -105,6 +105,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/R/plot-build.R b/R/plot-build.R index d53f16ba85..291841de90 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -30,6 +30,12 @@ ggplot_build <- function(plot) { UseMethod('ggplot_build') } +#' @export +ggplot_build.ggplot_built <- function(plot) { + # This is a no-op + plot +} + #' @export ggplot_build.ggplot <- function(plot) { plot <- plot_clone(plot) diff --git a/man/get_geom_defaults.Rd b/man/get_geom_defaults.Rd new file mode 100644 index 0000000000..a39f80d720 --- /dev/null +++ b/man/get_geom_defaults.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/geom-defaults.R +\name{get_geom_defaults} +\alias{get_geom_defaults} +\title{Resolve and get geom defaults} +\usage{ +get_geom_defaults(geom, theme = theme_get()) +} +\arguments{ +\item{geom}{Some definition of a geom: +\itemize{ +\item A \code{function} that creates a layer, e.g. \code{geom_path()}. +\item A layer created by such function +\item A string naming a geom class in snake case without the \code{geom_}-prefix, +e.g. \code{"contour_filled"}. +\item A geom class object. +}} + +\item{theme}{A \code{\link{theme}} object. Defaults to the current global theme.} +} +\value{ +A list of aesthetics +} +\description{ +Resolve and get geom defaults +} +\examples{ +# Using a function +get_geom_defaults(geom_raster) + +# Using a layer includes static aesthetics as default +get_geom_defaults(geom_tile(fill = "white")) + +# Using a class name +get_geom_defaults("density_2d") + +# Using a class +get_geom_defaults(GeomPoint) + +# Changed theme +get_geom_defaults("point", theme(geom = element_geom(ink = "purple"))) +} +\keyword{internal} diff --git a/man/labs.Rd b/man/labs.Rd index 3f1687a0f6..c6ee09e2c2 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.} @@ -42,6 +45,8 @@ See \link{get_alt_text} for examples.} \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 @@ -50,6 +55,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/_snaps/coord-cartesian.md b/tests/testthat/_snaps/coord-cartesian.md index 7da67ba9c9..e7ed10569a 100644 --- a/tests/testthat/_snaps/coord-cartesian.md +++ b/tests/testthat/_snaps/coord-cartesian.md @@ -1,6 +1,6 @@ # cartesian coords throws error when limits are badly specified - `xlim` must be a vector of length 2, not a object. + `xlim` must be a vector of length 2, not a object. --- diff --git a/tests/testthat/_snaps/coord-flip.md b/tests/testthat/_snaps/coord-flip.md index b7717a7381..99806717ba 100644 --- a/tests/testthat/_snaps/coord-flip.md +++ b/tests/testthat/_snaps/coord-flip.md @@ -1,6 +1,6 @@ # flip coords throws error when limits are badly specified - `xlim` must be a vector of length 2, not a object. + `xlim` must be a vector of length 2, not a object. --- diff --git a/tests/testthat/_snaps/coord-map.md b/tests/testthat/_snaps/coord-map.md index 372d54df39..011a6dd41f 100644 --- a/tests/testthat/_snaps/coord-map.md +++ b/tests/testthat/_snaps/coord-map.md @@ -1,6 +1,6 @@ # coord map throws error when limits are badly specified - `xlim` must be a vector of length 2, not a object. + `xlim` must be a vector of length 2, not a object. --- diff --git a/tests/testthat/_snaps/coord-transform.md b/tests/testthat/_snaps/coord-transform.md index 14be4bd125..def35a0f27 100644 --- a/tests/testthat/_snaps/coord-transform.md +++ b/tests/testthat/_snaps/coord-transform.md @@ -1,6 +1,6 @@ # coord_trans() throws error when limits are badly specified - `xlim` must be a vector of length 2, not a object. + `xlim` must be a vector of length 2, not a object. --- diff --git a/tests/testthat/_snaps/coord_sf.md b/tests/testthat/_snaps/coord_sf.md index 486763d781..bb43424d33 100644 --- a/tests/testthat/_snaps/coord_sf.md +++ b/tests/testthat/_snaps/coord_sf.md @@ -21,7 +21,7 @@ # coord_sf() throws error when limits are badly specified - `xlim` must be a vector of length 2, not a object. + `xlim` must be a vector of length 2, not a object. --- diff --git a/tests/testthat/_snaps/guides/axis-guides-basic.svg b/tests/testthat/_snaps/guides/axis-guides-basic.svg index ae2a74c24d..32f3b568eb 100644 --- a/tests/testthat/_snaps/guides/axis-guides-basic.svg +++ b/tests/testthat/_snaps/guides/axis-guides-basic.svg @@ -18,47 +18,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/tests/testthat/_snaps/guides/axis-guides-check-overlap.svg b/tests/testthat/_snaps/guides/axis-guides-check-overlap.svg index cf2312f98c..ad9d4f2f71 100644 --- a/tests/testthat/_snaps/guides/axis-guides-check-overlap.svg +++ b/tests/testthat/_snaps/guides/axis-guides-check-overlap.svg @@ -18,47 +18,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/tests/testthat/_snaps/guides/axis-guides-negative-rotation.svg b/tests/testthat/_snaps/guides/axis-guides-negative-rotation.svg index f5ad2b2273..b2bb7180ab 100644 --- a/tests/testthat/_snaps/guides/axis-guides-negative-rotation.svg +++ b/tests/testthat/_snaps/guides/axis-guides-negative-rotation.svg @@ -18,47 +18,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/tests/testthat/_snaps/guides/axis-guides-positive-rotation.svg b/tests/testthat/_snaps/guides/axis-guides-positive-rotation.svg index e1cd91eb77..61084a3df1 100644 --- a/tests/testthat/_snaps/guides/axis-guides-positive-rotation.svg +++ b/tests/testthat/_snaps/guides/axis-guides-positive-rotation.svg @@ -18,47 +18,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/tests/testthat/_snaps/guides/axis-guides-text-dodged-into-rows-cols.svg b/tests/testthat/_snaps/guides/axis-guides-text-dodged-into-rows-cols.svg index 79e94af549..0af3c6bcc1 100644 --- a/tests/testthat/_snaps/guides/axis-guides-text-dodged-into-rows-cols.svg +++ b/tests/testthat/_snaps/guides/axis-guides-text-dodged-into-rows-cols.svg @@ -18,47 +18,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/tests/testthat/_snaps/guides/axis-guides-vertical-negative-rotation.svg b/tests/testthat/_snaps/guides/axis-guides-vertical-negative-rotation.svg index fb7d39a9d3..ba7d74a326 100644 --- a/tests/testthat/_snaps/guides/axis-guides-vertical-negative-rotation.svg +++ b/tests/testthat/_snaps/guides/axis-guides-vertical-negative-rotation.svg @@ -18,47 +18,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/tests/testthat/_snaps/guides/axis-guides-vertical-rotation.svg b/tests/testthat/_snaps/guides/axis-guides-vertical-rotation.svg index f379bb7797..76adc31334 100644 --- a/tests/testthat/_snaps/guides/axis-guides-vertical-rotation.svg +++ b/tests/testthat/_snaps/guides/axis-guides-vertical-rotation.svg @@ -18,47 +18,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/tests/testthat/_snaps/guides/axis-guides-zero-breaks.svg b/tests/testthat/_snaps/guides/axis-guides-zero-breaks.svg index 2ef933e31b..a89bf8e8f1 100644 --- a/tests/testthat/_snaps/guides/axis-guides-zero-breaks.svg +++ b/tests/testthat/_snaps/guides/axis-guides-zero-breaks.svg @@ -18,47 +18,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/tests/testthat/_snaps/guides/axis-guides-zero-rotation.svg b/tests/testthat/_snaps/guides/axis-guides-zero-rotation.svg index bb81af4971..8d5dad8f65 100644 --- a/tests/testthat/_snaps/guides/axis-guides-zero-rotation.svg +++ b/tests/testthat/_snaps/guides/axis-guides-zero-rotation.svg @@ -18,47 +18,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index 78a77db663..a19b84efe7 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -53,12 +53,12 @@ test_that("Labels from default stat mapping are overwritten by default labels", p <- ggplot(mpg, aes(displ, hwy)) + geom_density2d() - expect_equal(p$labels$colour[1], "colour") - expect_true(attr(p$labels$colour, "fallback")) + labels <- get_labs(p) + expect_equal(labels$colour[1], "colour") + expect_true(attr(labels$colour, "fallback")) - p <- p + geom_smooth(aes(color = drv)) - - expect_equal(p$labels$colour, "drv") + p <- p + geom_smooth(aes(color = drv), method = "lm", formula = y ~ x) + expect_equal(get_labs(p)$colour, "drv") }) test_that("alt text is returned", { @@ -97,24 +97,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) ) @@ -124,23 +125,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") ) @@ -151,12 +152,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") ) }) @@ -177,16 +178,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"), @@ -194,14 +190,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 @@ -214,14 +204,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 ------------------------------------------------------------