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", {