diff --git a/NEWS.md b/NEWS.md index c587911c83..6fa2272730 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* Scale names, guide titles and aesthetic labels can now accept functions + (@teunbrand, #4313) * Binned scales with zero-width data expand the default limits by 0.1 (@teunbrand, #5066) * New default `geom_qq_line(geom = "abline")` for better clipping in the diff --git a/R/axis-secondary.R b/R/axis-secondary.R index 23d36092b6..c1d024e288 100644 --- a/R/axis-secondary.R +++ b/R/axis-secondary.R @@ -329,7 +329,7 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, scale$train(range) scale }, - make_title = function(title) { - title + make_title = function(...) { + ScaleContinuous$make_title(...) } ) diff --git a/R/guide-bins.R b/R/guide-bins.R index c03d5179d6..b83494fb77 100644 --- a/R/guide-bins.R +++ b/R/guide-bins.R @@ -218,7 +218,7 @@ GuideBins <- ggproto( key$.value <- 1 - key$.value } - params$title <- scale$make_title(params$title %|W|% scale$name %|W|% title) + params$title <- scale$make_title(params$title, scale$name, title) params$key <- key params }, diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index c7c424c2ac..287b0087b8 100644 --- a/R/guide-colorbar.R +++ b/R/guide-colorbar.R @@ -259,7 +259,7 @@ GuideColourbar <- ggproto( extract_params = function(scale, params, title = waiver(), ...) { - params$title <- scale$make_title(params$title %|W|% scale$name %|W|% title) + params$title <- scale$make_title(params$title, scale$name, title) limits <- params$decor$value[c(1L, nrow(params$decor))] to <- switch( params$display, diff --git a/R/guide-colorsteps.R b/R/guide-colorsteps.R index 240a1e607c..14cca8563d 100644 --- a/R/guide-colorsteps.R +++ b/R/guide-colorsteps.R @@ -191,9 +191,7 @@ GuideColoursteps <- ggproto( params$key <- key } - params$title <- scale$make_title( - params$title %|W|% scale$name %|W|% title - ) + params$title <- scale$make_title(params$title, scale$name, title) limits <- c(params$decor$min[1], params$decor$max[nrow(params$decor)]) if (params$reverse) { diff --git a/R/guide-legend.R b/R/guide-legend.R index 37aad2e3f0..9355ae5a70 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -185,7 +185,7 @@ GuideLegend <- ggproto( extract_params = function(scale, params, title = waiver(), ...) { - params$title <- scale$make_title(params$title %|W|% scale$name %|W|% title) + params$title <- scale$make_title(params$title, scale$name, title) if (isTRUE(params$reverse %||% FALSE)) { params$key <- params$key[nrow(params$key):1, , drop = FALSE] } diff --git a/R/guide-old.R b/R/guide-old.R index de870965fd..d20fec0e3e 100644 --- a/R/guide-old.R +++ b/R/guide-old.R @@ -89,7 +89,7 @@ GuideOld <- ggproto( train = function(self, params, scale, aesthetic = NULL, title = waiver(), direction = NULL) { - params$title <- scale$make_title(params$title %|W|% scale$name %|W|% title) + params$title <- scale$make_title(params$title, scale$name, title) params$direction <- params$direction %||% direction %||% "vertical" params <- guide_train(params, scale, aesthetic) params diff --git a/R/labels.R b/R/labels.R index 14d7f32a41..a736e2bf54 100644 --- a/R/labels.R +++ b/R/labels.R @@ -84,6 +84,15 @@ setup_plot_labels <- function(plot, layers, data) { )) } + # User labels can be functions, so apply these to the default labels + plot_labels <- lapply(setNames(nm = names(plot_labels)), function(nm) { + label <- plot_labels[[nm]] + if (!is.function(label)) { + return(label) + } + label(labels[[nm]] %||% "") + }) + dict <- plot_labels$dictionary if (length(dict) > 0) { labels <- lapply(labels, function(x) { diff --git a/R/layout.R b/R/layout.R index d3cad0ffeb..92a28216d7 100644 --- a/R/layout.R +++ b/R/layout.R @@ -244,35 +244,39 @@ Layout <- ggproto("Layout", NULL, }, resolve_label = function(self, scale, labels) { - # General order is: guide title > scale name > labels - aes <- scale$aesthetics[[1]] - primary <- scale$name %|W|% labels[[aes]] - secondary <- if (is.null(scale$secondary.axis)) { - waiver() - } else { - scale$sec_name() - } %|W|% labels[[paste0("sec.", aes)]] - if (is.derived(secondary)) secondary <- primary + aes <- scale$aesthetics[[1]] + + prim_scale <- scale$name + seco_scale <- (scale$sec_name %||% waiver)() + + prim_label <- labels[[aes]] + seco_label <- labels[[paste0("sec. aes")]] + + prim_guide <- seco_guide <- waiver() + order <- scale$axis_order() - if (!is.null(self$panel_params[[1]]$guides)) { - if ((scale$position) %in% c("left", "right")) { - guides <- c("y", "y.sec") - } else { - guides <- c("x", "x.sec") - } - params <- self$panel_params[[1]]$guides$get_params(guides) + panel <- self$panel_params[[1]]$guides + if (!is.null(panel)) { + position <- scale$position + aes <- switch(position, left = , right = "y", "x") + params <- panel$get_params(paste0(aes, c("", ".sec"))) if (!is.null(params)) { - primary <- params[[1]]$title %|W|% primary - secondary <- params[[2]]$title %|W|% secondary - position <- params[[1]]$position %||% scale$position - if (position != scale$position) { + prim_guide <- params[[1]]$title + seco_guide <- params[[2]]$title + position <- scale$position + if ((params[[1]]$position %||% position) != position) { order <- rev(order) } } } - primary <- scale$make_title(primary) - secondary <- scale$make_sec_title(secondary) + + primary <- scale$make_title(prim_guide, prim_scale, prim_label) + secondary <- scale$make_sec_title(seco_guide, seco_scale, seco_label) + if (is.derived(secondary)) { + secondary <- primary + } + list(primary = primary, secondary = secondary)[order] }, diff --git a/R/scale-.R b/R/scale-.R index 1ab3381099..f6e42a7e1e 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -612,12 +612,25 @@ Scale <- ggproto("Scale", NULL, ord }, - make_title = function(title) { + make_title = function(self, guide_title = waiver(), scale_title = waiver(), label_title = waiver()) { + title <- label_title + scale_title <- allow_lambda(scale_title) + if (is.function(scale_title)) { + title <- scale_title(title) + } else { + title <- scale_title %|W|% title + } + guide_title <- allow_lambda(guide_title) + if (is.function(guide_title)) { + title <- guide_title(title) + } else { + title <- guide_title %|W|% title + } title }, - make_sec_title = function(title) { - title + make_sec_title = function(self, ...) { + self$make_title(...) } ) diff --git a/R/scale-continuous.R b/R/scale-continuous.R index 39b5203565..8a681c2f20 100644 --- a/R/scale-continuous.R +++ b/R/scale-continuous.R @@ -159,11 +159,11 @@ ScaleContinuousPosition <- ggproto("ScaleContinuousPosition", ScaleContinuous, self$secondary.axis$name } }, - make_sec_title = function(self, title) { + make_sec_title = function(self, ...) { if (!is.waiver(self$secondary.axis)) { - self$secondary.axis$make_title(title) + self$secondary.axis$make_title(...) } else { - ggproto_parent(ScaleContinuous, self)$make_sec_title(title) + ggproto_parent(ScaleContinuous, self)$make_sec_title(...) } } ) diff --git a/R/scale-date.R b/R/scale-date.R index 436b9b129d..dff564e71e 100644 --- a/R/scale-date.R +++ b/R/scale-date.R @@ -392,11 +392,11 @@ ScaleContinuousDatetime <- ggproto("ScaleContinuousDatetime", ScaleContinuous, self$secondary.axis$name } }, - make_sec_title = function(self, title) { + make_sec_title = function(self, ...) { if (!is.waiver(self$secondary.axis)) { - self$secondary.axis$make_title(title) + self$secondary.axis$make_title(...) } else { - ggproto_parent(ScaleContinuous, self)$make_sec_title(title) + ggproto_parent(ScaleContinuous, self)$make_sec_title(...) } } @@ -443,11 +443,11 @@ ScaleContinuousDate <- ggproto("ScaleContinuousDate", ScaleContinuous, self$secondary.axis$name } }, - make_sec_title = function(self, title) { + make_sec_title = function(self, ...) { if (!is.waiver(self$secondary.axis)) { - self$secondary.axis$make_title(title) + self$secondary.axis$make_title(...) } else { - ggproto_parent(ScaleContinuous, self)$make_sec_title(title) + ggproto_parent(ScaleContinuous, self)$make_sec_title(...) } } ) diff --git a/R/scale-view.R b/R/scale-view.R index 350d27e9c0..cf9d4195d5 100644 --- a/R/scale-view.R +++ b/R/scale-view.R @@ -76,7 +76,7 @@ view_scale_secondary <- function(scale, limits = scale$get_limits(), # different breaks and labels in a different data space aesthetics = scale$aesthetics, name = scale$sec_name(), - make_title = function(self, title) self$scale$make_sec_title(title), + make_title = function(self, ...) self$scale$make_sec_title(...), continuous_range = sort(continuous_range), dimension = function(self) self$break_info$range, get_limits = function(self) self$break_info$range, @@ -127,8 +127,8 @@ ViewScale <- ggproto("ViewScale", NULL, x } }, - make_title = function(self, title) { - self$scale$make_title(title) + make_title = function(self, ...) { + self$scale$make_title(...) }, mapped_breaks = function(self) { self$map(self$get_breaks()) diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index 0b1fc5df50..172eca6364 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -199,6 +199,29 @@ test_that("position axis label hierarchy works as intended", { ) }) +test_that("labels can be derived using functions", { + + p <- ggplot(mtcars, aes(disp, mpg, colour = drat, shape = factor(cyl))) + + geom_point() + + labs( + y = to_upper_ascii, + shape = function(x) gsub("factor", "foo", x) + ) + + scale_shape_discrete( + name = to_upper_ascii, + guide = guide_legend(title = function(x) paste0(x, "!!!")) + ) + + scale_x_continuous(name = to_upper_ascii) + + guides(colour = guide_colourbar(title = to_upper_ascii)) + + labs <- get_labs(p) + expect_equal(labs$shape, "FOO(CYL)!!!") + expect_equal(labs$colour, "DRAT") + expect_equal(labs$x, "DISP") + expect_equal(labs$y, "MPG") + +}) + test_that("moving guide positions lets titles follow", { df <- data_frame(foo = c(1e1, 1e5), bar = c(0, 100))