Scale name function (#6200)

* `Scale$make_title()` can uses functions

* Disentangle `Layout$resolve_label()`

* pre-resolve functions in `labs()`

* rework how guides make titles

* add test

* add news bullet

Author: teunbrand

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 

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(...)
   }
 )

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
   },

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,

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) {

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]
     }

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

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) {

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]
   },
 

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(...)
   }
 )