Default labels from attributes (option 2) (#5879)

* resolve layers in `ggplot_build()`

* remove label updates from `ggplot_add()` methods

* pre-build for label tests

* fix bug

* add test

* `get_alt_text()` applies to build plot

R/labels.R

@@ -16,6 +16,56 @@ update_labels <- function(p, labels) {
  p
 }
 
+# Called in `ggplot_build()` to set default labels not specified by user.
+setup_plot_labels <- function(plot, layers, data) {
+ # Initiate from user-defined labels
+ labels <- plot$labels
+
+ # Find labels from every layer
+ for (i in seq_along(layers)) {
+ layer <- layers[[i]]
+ mapping <- layer$computed_mapping
+ mapping <- strip_stage(mapping)
+ mapping <- strip_dots(mapping, strip_pronoun = TRUE)
+
+ # Acquire default labels
+ mapping_default <- make_labels(mapping)
+ stat_default <- lapply(
+ make_labels(layer$stat$default_aes),
+ function(l) {
+ attr(l, "fallback") <- TRUE
+ l
+ }
+ )
+ default <- defaults(mapping_default, stat_default)
+
+ # Search for label attribute in symbolic mappings
+ symbolic <- vapply(
+ mapping, FUN.VALUE = logical(1),
+ function(x) is_quosure(x) && quo_is_symbol(x)
+ )
+ symbols <- intersect(names(mapping)[symbolic], names(data[[i]]))
+ attribs <- lapply(setNames(nm = symbols), function(x) {
+ attr(data[[i]][[x]], "label", exact = TRUE)
+ })
+ attribs <- attribs[lengths(attribs) > 0]
+ layer_labels <- defaults(attribs, default)
+
+ # Set label priority:
+ # 1. Existing labels that aren't fallback labels
+ # 2. The labels of this layer, including fallback labels
+ # 3. Existing fallback labels
+ current <- labels
+ fallbacks <- vapply(current, function(l) isTRUE(attr(l, "fallback")), logical(1))
+
+ labels <- defaults(current[!fallbacks], layer_labels)
+ if (any(fallbacks)) {
+ labels <- defaults(labels, current)
+ }
+ }
+ labels
+}
+
 #' Modify axis, legend, and plot labels
 #'
 #' Good labels are critical for making your plots accessible to a wider
@@ -144,8 +194,13 @@ get_alt_text <- function(p, ...) {
 #' @export
 get_alt_text.ggplot <- function(p, ...) {
  alt <- p$labels[["alt"]] %||% ""
+ if (!is.function(alt)) {
+ return(alt)
+ }
  p$labels[["alt"]] <- NULL
- if (is.function(alt)) alt(p) else alt
+ build <- ggplot_build(p)
+ build$plot$labels[["alt"]] <- alt
+ get_alt_text(build)
 }
 #' @export
 get_alt_text.ggplot_built <- function(p, ...) {

R/plot-build.R

@@ -60,6 +60,7 @@ ggplot_build.ggplot <- function(plot) {
 
  # Compute aesthetics to produce data with generalised variable names
  data <- by_layer(function(l, d) l$compute_aesthetics(d, plot), layers, data, "computing aesthetics")
+ plot$labels <- setup_plot_labels(plot, layers, data)
  data <- .ignore_data(data)
 
  # Transform all scales

R/plot-construction.R

@@ -133,10 +133,7 @@ ggplot_add.uneval <- function(object, plot, object_name) {
  plot$mapping <- defaults(object, plot$mapping)
  # defaults() doesn't copy class, so copy it.
  class(plot$mapping) <- class(object)
-
- labels <- make_labels(object)
- names(labels) <- names(object)
- update_labels(plot, labels)
+ plot
 }
 #' @export
 ggplot_add.Coord <- function(object, plot, object_name) {
@@ -167,19 +164,5 @@ ggplot_add.by <- function(object, plot, object_name) {
 #' @export
 ggplot_add.Layer <- function(object, plot, object_name) {
  plot$layers <- append(plot$layers, object)
-
- # Add any new labels
- mapping <- make_labels(object$mapping)
- default <- lapply(make_labels(object$stat$default_aes), function(l) {
- attr(l, "fallback") <- TRUE
- l
- })
- new_labels <- defaults(mapping, default)
- current_labels <- plot$labels
- current_fallbacks <- vapply(current_labels, function(l) isTRUE(attr(l, "fallback")), logical(1))
- plot$labels <- defaults(current_labels[!current_fallbacks], new_labels)
- if (any(current_fallbacks)) {
- plot$labels <- defaults(plot$labels, current_labels)
- }
  plot
 }

R/plot.R

@@ -133,8 +133,6 @@ ggplot.default <- function(data = NULL, mapping = aes(), ...,
  layout = ggproto(NULL, Layout)
  ), class = c("gg", "ggplot"))
 
- p$labels <- make_labels(mapping)
-
  set_last_plot(p)
  p
 }

tests/testthat/_snaps/labels.md

@@ -3,7 +3,7 @@
  Code
   get_alt_text(p)
  Output
-  [1] "A plot showing class on the x-axis and count on the y-axis using a bar layer."
+  [1] "A plot showing class on a discrete x-axis and count on a continuous y-axis using a bar layer."
 
 # plot.tag.position rejects invalid input
 

tests/testthat/test-aes.R

@@ -94,12 +94,14 @@ test_that("assignment methods pull unwrap constants from quosures", {
 
 test_that("quosures are squashed when creating default label for a mapping", {
  p <- ggplot(mtcars) + aes(!!quo(identity(!!quo(cyl))))
- expect_identical(p$labels$x, "identity(cyl)")
+ labels <- ggplot_build(p)$plot$labels
+ expect_identical(labels$x, "identity(cyl)")
 })
 
 test_that("labelling doesn't cause error if aesthetic is NULL", {
  p <- ggplot(mtcars) + aes(x = NULL)
- expect_identical(p$labels$x, "x")
+ labels <- ggplot_build(p)$plot$labels
+ expect_identical(labels$x, "x")
 })
 
 test_that("aes standardises aesthetic names", {

tests/testthat/test-labels.R

@@ -52,13 +52,26 @@ 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
 
- expect_equal(p$labels$colour[1], "colour")
- expect_true(attr(p$labels$colour, "fallback"))
+ expect_equal(labels$colour[1], "colour")
+ expect_true(attr(labels$colour, "fallback"))
 
- p <- p + geom_smooth(aes(color = drv))
+ p <- p + geom_smooth(aes(color = drv), method = "lm", formula = y ~ x)
+ labels <- ggplot_build(p)$plot$labels
 
- expect_equal(p$labels$colour, "drv")
+ expect_equal(labels$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
+
+ expect_equal(labels$x, "Miles per gallon")
+ expect_equal(labels$y, "disp")
 })
 
 test_that("alt text is returned", {