diff --git a/NEWS.md b/NEWS.md index 070c74dd40..efe0725b72 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* Default labels are now derived from a label attribute when available + (@teunbrand, #4631). * (Internal) Applying defaults in `geom_sf()` has moved from the internal `sf_grob()` to `GeomSf$use_defaults()` (@teunbrand). * `facet_wrap()` has new options for the `dir` argument to more precisely diff --git a/R/aes-evaluation.R b/R/aes-evaluation.R index e128fd2c15..b52ba63308 100644 --- a/R/aes-evaluation.R +++ b/R/aes-evaluation.R @@ -321,7 +321,10 @@ strip_stage <- function(expr) { } # Convert aesthetic mapping into text labels -make_labels <- function(mapping) { +make_labels <- function(mapping, data = NULL) { + if (is.waive(data) || is.function(data)) { + data <- NULL + } default_label <- function(aesthetic, mapping) { # e.g., geom_smooth(aes(colour = "loess")) or aes(y = NULL) if (is.null(mapping) || is.atomic(mapping)) { @@ -331,6 +334,10 @@ make_labels <- function(mapping) { mapping <- strip_dots(mapping, strip_pronoun = TRUE) if (is_quosure(mapping) && quo_is_symbol(mapping)) { name <- as_string(quo_get_expr(mapping)) + if (!is.null(data) && name %in% names(data)) { + value <- eval_tidy(mapping, data = data) + name <- attr(value, "label", exact = TRUE) %||% name + } } else { name <- quo_text(mapping) name <- gsub("\n.*$", "...", name) diff --git a/R/labels.R b/R/labels.R index a70d6d535c..72b3e0eee3 100644 --- a/R/labels.R +++ b/R/labels.R @@ -16,6 +16,25 @@ update_labels <- function(p, labels) { p } +label_from_layer <- function(layer, plot) { + data <- (layer$data %|W|% NULL) %||% plot$data + mapping <- make_labels(layer$mapping, data) + default <- lapply( + make_labels(layer$stat$default_aes, data), + 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)) + labels <- defaults(current_labels[!current_fallbacks], new_labels) + if (any(current_fallbacks)) { + labels <- defaults(labels, current_labels) + } + labels +} + #' Modify axis, legend, and plot labels #' #' Good labels are critical for making your plots accessible to a wider diff --git a/R/plot-construction.R b/R/plot-construction.R index b6d83fe1f0..70d62b3be6 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -134,7 +134,7 @@ ggplot_add.uneval <- function(object, plot, object_name) { # defaults() doesn't copy class, so copy it. class(plot$mapping) <- class(object) - labels <- make_labels(object) + labels <- make_labels(object, plot$data) names(labels) <- names(object) update_labels(plot, labels) } @@ -167,19 +167,6 @@ 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$labels <- label_from_layer(object, plot) plot } diff --git a/R/plot.R b/R/plot.R index 0d1df80f98..f0cea24f55 100644 --- a/R/plot.R +++ b/R/plot.R @@ -133,7 +133,7 @@ ggplot.default <- function(data = NULL, mapping = aes(), ..., layout = ggproto(NULL, Layout) ), class = c("gg", "ggplot")) - p$labels <- make_labels(mapping) + p$labels <- make_labels(mapping, data) set_last_plot(p) p diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index 78a77db663..21d5a0b3da 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -90,6 +90,33 @@ test_that("plot.tag.position rejects invalid input", { }) +test_that("label attributes are being used", { + + label <- "Miles per gallon" + df <- mtcars + attr(df$mpg, "label") <- label + + # Test constructor + p <- ggplot(df, aes(mpg)) + expect_equal(p$labels, list(x = label)) + + # Test when adding mapping separately + p <- ggplot(df) + aes(mpg) + expect_equal(p$labels, list(x = label)) + + # Test it can be derived from self-contained layer + p <- ggplot() + geom_point(aes(mpg), data = df) + expect_equal(p$labels, list(x = label)) + + # Test it can be derived from main data + p <- ggplot(df) + geom_point(aes(mpg)) + expect_equal(p$labels, list(x = label)) + + # Limitation: cannot eval global mapping in layer data + # p <- ggplot(mapping = aes(mpg)) + geom_point(data = df) + # expect_equal(p$labels, list(x = label)) +}) + test_that("position axis label hierarchy works as intended", { df <- data_frame(foo = c(1e1, 1e5), bar = c(0, 100))