diff --git a/NEWS.md b/NEWS.md index 0c493a8f58..5e36fb6f05 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) * Custom and raster annotation now respond to scale transformations, and can use AsIs variables for relative placement (@teunbrand based on @yutannihilation's prior work, #3120) 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 0124ea6052..29ff1d4565 100644 --- a/R/guide-bins.R +++ b/R/guide-bins.R @@ -212,7 +212,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 54cd89a948..0fb5f8864a 100644 --- a/R/guide-colorsteps.R +++ b/R/guide-colorsteps.R @@ -189,9 +189,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 050d42829e..37761bfa41 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]] %||% "") + }) + defaults(plot_labels, labels) } diff --git a/R/layout.R b/R/layout.R index 25088798b1..0a1821a1cb 100644 --- a/R/layout.R +++ b/R/layout.R @@ -243,35 +243,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 b8c03571bd..6a4e2e849f 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -604,12 +604,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 510f99f837..87afadb52f 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, @@ -124,8 +124,8 @@ ViewScale <- ggproto("ViewScale", NULL, x } }, - make_title = function(self, title) { - self$scale$make_title(title) + make_title = function(self, ...) { + self$scale$make_title(...) }, break_positions = function(self) { self$rescale(self$get_breaks()) diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index b8b002a3db..98b39bca18 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))