From 76bb2cdd287423032f6bb56348ca8f4ec0a9b357 Mon Sep 17 00:00:00 2001
From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com>
Date: Thu, 11 Jul 2024 19:21:14 +0200
Subject: [PATCH] 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                      | 57 ++++++++++++++++++++++++++++++++-
 R/plot-build.R                  |  1 +
 R/plot-construction.R           | 19 +----------
 R/plot.R                        |  2 --
 tests/testthat/_snaps/labels.md |  2 +-
 tests/testthat/test-aes.R       |  6 ++--
 tests/testthat/test-labels.R    | 21 +++++++++---
 7 files changed, 80 insertions(+), 28 deletions(-)

diff --git a/R/labels.R b/R/labels.R
index d617bd9238..3012868874 100644
--- a/R/labels.R
+++ b/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, ...) {
diff --git a/R/plot-build.R b/R/plot-build.R
index 7b90d9cf26..2a68dd550f 100644
--- a/R/plot-build.R
+++ b/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
diff --git a/R/plot-construction.R b/R/plot-construction.R
index b6d83fe1f0..de1306098f 100644
--- a/R/plot-construction.R
+++ b/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
 }
diff --git a/R/plot.R b/R/plot.R
index 0d1df80f98..6bdcabc23f 100644
--- a/R/plot.R
+++ b/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
 }
diff --git a/tests/testthat/_snaps/labels.md b/tests/testthat/_snaps/labels.md
index 87b2cb4fe2..e1f6ed4140 100644
--- a/tests/testthat/_snaps/labels.md
+++ b/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
 
diff --git a/tests/testthat/test-aes.R b/tests/testthat/test-aes.R
index e407562082..1cb333fcac 100644
--- a/tests/testthat/test-aes.R
+++ b/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", {
diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R
index e119637f94..e338226bd4 100644
--- a/tests/testthat/test-labels.R
+++ b/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", {