Scale name function

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)

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

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

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

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

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]] %||% "")
+  })
+
   defaults(plot_labels, labels)
 }
 

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

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

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

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

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

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