Nonstandard aesthetics (#2555)

* enable guide_colorbar to work with nonstandard aesthetics

* remove hardcoded aesthetics setting for scales; adjust guides so they
can make full use of multiple aesthetics for one scale.

* update NEWS

* add regression tests

* exported discrete manual scale.

* add generic manual and identity scales

* add test cases for new generic scales.

* improve docs

Author: clauswilke

NAMESPACE

@@ -443,6 +443,9 @@ export(scale_colour_manual)
 export(scale_colour_ordinal)
 export(scale_colour_viridis_c)
 export(scale_colour_viridis_d)
+export(scale_continuous_identity)
+export(scale_discrete_identity)
+export(scale_discrete_manual)
 export(scale_fill_brewer)
 export(scale_fill_continuous)
 export(scale_fill_date)

NEWS.md

@@ -186,6 +186,10 @@ up correct aspect ratio, and draws a graticule.
   use matrix-columns. These are rarely used but are produced by `scale()`;
   to continue use `scale()` you'll need to wrap it with `as.numeric()`, 
   e.g. `as.numeric(scale(x))`.
+  
+* The function `guide_train()` now has an optional parameter `aesthetic`
+  that allows to override the `aesthetic` setting in the scale. This change
+  will only affect code that implements custom guides. (@clauswilke)
 
 ## Minor bug fixes and improvements
 
@@ -220,6 +224,15 @@ up correct aspect ratio, and draws a graticule.
 
 * Legends no longer try and use set aesthetics that are not length one (#1932).
 
+* All colour and fill scales now have an `aesthetics` argument that can
+  be used to set the aesthetic(s) the scale works with. This makes it
+  possible to apply a colour scale to both colour and fill aesthetics
+  at the same time, via `aesthetics = c("colour", "fill"). (@clauswilke)
+  
+* Three generic scales were added that work with any aesthetic or set of
+  aesthetics: `scale_continuous_identity()`, `scale_discrete_identity()`,
+  `scale_discrete_manual()`. (@clauswilke) 
+
 ### Layers
 
 * `geom_label` no longer produces an undesired border around labels when

R/guide-colorbar.r

@@ -44,6 +44,8 @@
 #'   for `barwidth` and `barheight`.
 #' @param reverse logical. If `TRUE` the colorbar is reversed. By default,
 #'   the highest value is on the top and the lowest value is on the bottom
+#' @param available_aes A vector of charater strings listing the aesthetics
+#'   for which a colorbar can be drawn.
 #' @param ... ignored.
 #' @return A guide object
 #' @export
@@ -134,6 +136,7 @@ guide_colourbar <- function(
   default.unit = "line",
   reverse = FALSE,
   order = 0,
+  available_aes = c("colour", "color", "fill"),
 
   ...) {
 
@@ -180,17 +183,20 @@ guide_colourbar <- function(
     order = order,
 
     # parameter
-    available_aes = c("colour", "color", "fill"), ..., name = "colorbar"),
+    available_aes = available_aes,
+    ...,
+    name = "colorbar"),
     class = c("guide", "colorbar")
   )
 }
 
 #' @export
-guide_train.colorbar <- function(guide, scale) {
+guide_train.colorbar <- function(guide, scale, aesthetic = NULL) {
 
   # do nothing if scale are inappropriate
-  if (length(intersect(scale$aesthetics, c("color", "colour", "fill"))) == 0) {
-    warning("colorbar guide needs colour or fill scales.")
+  if (length(intersect(scale$aesthetics, guide$available_aes)) == 0) {
+    warning("colorbar guide needs appropriate scales: ",
+            paste(guide$available_aes, collapse = ", "))
     return(NULL)
   }
   if (scale$is_discrete()) {
@@ -204,7 +210,7 @@ guide_train.colorbar <- function(guide, scale) {
   if (length(breaks) == 0 || all(is.na(breaks)))
     return()
 
-  ticks <- as.data.frame(setNames(list(scale$map(breaks)), scale$aesthetics[1]))
+  ticks <- as.data.frame(setNames(list(scale$map(breaks)), aesthetic %||% scale$aesthetics[1]))
   ticks$.value <- breaks
   ticks$.label <- scale$get_labels(breaks)
 

R/guide-legend.r

@@ -215,14 +215,14 @@ guide_legend <- function(# title
 }
 
 #' @export
-guide_train.legend <- function(guide, scale) {
+guide_train.legend <- function(guide, scale, aesthetic = NULL) {
   breaks <- scale$get_breaks()
   if (length(breaks) == 0 || all(is.na(breaks))) {
     return()
   }
 
   key <- as.data.frame(
-    setNames(list(scale$map(breaks)), scale$aesthetics[1]),
+    setNames(list(scale$map(breaks)), aesthetic %||% scale$aesthetics[1]),
     stringsAsFactors = FALSE
   )
   key$.label <- scale$get_labels(breaks)

R/guides-.r

@@ -162,37 +162,38 @@ guides_train <- function(scales, theme, guides, labels) {
 
   gdefs <- list()
   for (scale in scales$scales) {
+    for (output in scale$aesthetics) {
 
-    # guides(XXX) is stored in guides[[XXX]],
-    # which is prior to scale_ZZZ(guide=XXX)
-    # guide is determined in order of:
-    #   + guides(XXX) > + scale_ZZZ(guide=XXX) > default(i.e., legend)
-    output <- scale$aesthetics[1]
-    guide <- guides[[output]] %||% scale$guide
+      # guides(XXX) is stored in guides[[XXX]],
+      # which is prior to scale_ZZZ(guide=XXX)
+      # guide is determined in order of:
+      #   + guides(XXX) > + scale_ZZZ(guide=XXX) > default(i.e., legend)
+      guide <- guides[[output]] %||% scale$guide
 
-    # this should be changed to testing guide == "none"
-    # scale$legend is backward compatibility
-    # if guides(XXX=FALSE), then scale_ZZZ(guides=XXX) is discarded.
-    if (guide == "none" || (is.logical(guide) && !guide)) next
+      # this should be changed to testing guide == "none"
+      # scale$legend is backward compatibility
+      # if guides(XXX=FALSE), then scale_ZZZ(guides=XXX) is discarded.
+      if (guide == "none" || (is.logical(guide) && !guide)) next
 
-    # check the validity of guide.
-    # if guide is character, then find the guide object
-    guide <- validate_guide(guide)
+      # check the validity of guide.
+      # if guide is character, then find the guide object
+      guide <- validate_guide(guide)
 
-    # check the consistency of the guide and scale.
-    if (guide$available_aes != "any" && !scale$aesthetics %in% guide$available_aes)
-      stop("Guide '", guide$name, "' cannot be used for '", scale$aesthetics, "'.")
+      # check the consistency of the guide and scale.
+      if (guide$available_aes != "any" && !scale$aesthetics %in% guide$available_aes)
+        stop("Guide '", guide$name, "' cannot be used for '", scale$aesthetics, "'.")
 
-    guide$title <- scale$make_title(guide$title %|W|% scale$name %|W|% labels[[output]])
+      guide$title <- scale$make_title(guide$title %|W|% scale$name %|W|% labels[[output]])
 
-    # direction of this grob
-    guide$direction <- guide$direction %||% theme$legend.direction
+      # direction of this grob
+      guide$direction <- guide$direction %||% theme$legend.direction
 
-    # each guide object trains scale within the object,
-    # so Guides (i.e., the container of guides) need not to know about them
-    guide <- guide_train(guide, scale)
+      # each guide object trains scale within the object,
+      # so Guides (i.e., the container of guides) need not to know about them
+      guide <- guide_train(guide, scale, output)
 
-    if (!is.null(guide)) gdefs[[length(gdefs) + 1]] <- guide
+      if (!is.null(guide)) gdefs[[length(gdefs) + 1]] <- guide
+    }
   }
   gdefs
 }
@@ -309,7 +310,7 @@ NULL
 
 #' @export
 #' @rdname guide-exts
-guide_train <- function(guide, scale) UseMethod("guide_train")
+guide_train <- function(guide, scale, aesthetic = NULL) UseMethod("guide_train")
 
 #' @export
 #' @rdname guide-exts

R/scale-brewer.r

@@ -65,37 +65,37 @@
 #' v
 #' v + scale_fill_distiller()
 #' v + scale_fill_distiller(palette = "Spectral")
-scale_colour_brewer <- function(..., type = "seq", palette = 1, direction = 1) {
-  discrete_scale("colour", "brewer", brewer_pal(type, palette, direction), ...)
+scale_colour_brewer <- function(..., type = "seq", palette = 1, direction = 1, aesthetics = "colour") {
+  discrete_scale(aesthetics, "brewer", brewer_pal(type, palette, direction), ...)
 }
 
 #' @export
 #' @rdname scale_brewer
-scale_fill_brewer <- function(..., type = "seq", palette = 1, direction = 1) {
-  discrete_scale("fill", "brewer", brewer_pal(type, palette, direction), ...)
+scale_fill_brewer <- function(..., type = "seq", palette = 1, direction = 1, aesthetics = "fill") {
+  discrete_scale(aesthetics, "brewer", brewer_pal(type, palette, direction), ...)
 }
 
 #' @export
 #' @rdname scale_brewer
-scale_colour_distiller <- function(..., type = "seq", palette = 1, direction = -1, values = NULL, space = "Lab", na.value = "grey50", guide = "colourbar") {
+scale_colour_distiller <- function(..., type = "seq", palette = 1, direction = -1, values = NULL, space = "Lab", na.value = "grey50", guide = "colourbar", aesthetics = "colour") {
   # warn about using a qualitative brewer palette to generate the gradient
   type <- match.arg(type, c("seq", "div", "qual"))
   if (type == "qual") {
     warning("Using a discrete colour palette in a continuous scale.\n  Consider using type = \"seq\" or type = \"div\" instead", call. = FALSE)
   }
-  continuous_scale("colour", "distiller",
+  continuous_scale(aesthetics, "distiller",
     gradient_n_pal(brewer_pal(type, palette, direction)(6), values, space), na.value = na.value, guide = guide, ...)
   # NB: 6 colours per palette gives nice gradients; more results in more saturated colours which do not look as good
 }
 
 #' @export
 #' @rdname scale_brewer
-scale_fill_distiller <- function(..., type = "seq", palette = 1, direction = -1, values = NULL, space = "Lab", na.value = "grey50", guide = "colourbar") {
+scale_fill_distiller <- function(..., type = "seq", palette = 1, direction = -1, values = NULL, space = "Lab", na.value = "grey50", guide = "colourbar", aesthetics = "fill") {
   type <- match.arg(type, c("seq", "div", "qual"))
   if (type == "qual") {
     warning("Using a discrete colour palette in a continuous scale.\n  Consider using type = \"seq\" or type = \"div\" instead", call. = FALSE)
   }
-  continuous_scale("fill", "distiller",
+  continuous_scale(aesthetics, "distiller",
     gradient_n_pal(brewer_pal(type, palette, direction)(6), values, space), na.value = na.value, guide = guide, ...)
 }
 

R/scale-gradient.r

@@ -54,15 +54,17 @@
 #'   scale_colour_gradient(low = "white", high = "black")
 #' # Avoid red-green colour contrasts because ~10% of men have difficulty
 #' # seeing them
-scale_colour_gradient <- function(..., low = "#132B43", high = "#56B1F7", space = "Lab", na.value = "grey50", guide = "colourbar") {
-  continuous_scale("colour", "gradient", seq_gradient_pal(low, high, space),
+scale_colour_gradient <- function(..., low = "#132B43", high = "#56B1F7", space = "Lab",
+                                  na.value = "grey50", guide = "colourbar", aesthetics = "colour") {
+  continuous_scale(aesthetics, "gradient", seq_gradient_pal(low, high, space),
     na.value = na.value, guide = guide, ...)
 }
 
 #' @rdname scale_gradient
 #' @export
-scale_fill_gradient <- function(..., low = "#132B43", high = "#56B1F7", space = "Lab", na.value = "grey50", guide = "colourbar") {
-  continuous_scale("fill", "gradient", seq_gradient_pal(low, high, space),
+scale_fill_gradient <- function(..., low = "#132B43", high = "#56B1F7", space = "Lab",
+                                na.value = "grey50", guide = "colourbar", aesthetics = "fill") {
+  continuous_scale(aesthetics, "gradient", seq_gradient_pal(low, high, space),
     na.value = na.value, guide = guide, ...)
 }
 
@@ -71,16 +73,20 @@ scale_fill_gradient <- function(..., low = "#132B43", high = "#56B1F7", space =
 #'   Defaults to 0.
 #' @rdname scale_gradient
 #' @export
-scale_colour_gradient2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"), midpoint = 0, space = "Lab", na.value = "grey50", guide = "colourbar") {
-  continuous_scale("colour", "gradient2",
+scale_colour_gradient2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"),
+                                   midpoint = 0, space = "Lab", na.value = "grey50", guide = "colourbar",
+                                   aesthetics = "colour") {
+  continuous_scale(aesthetics, "gradient2",
     div_gradient_pal(low, mid, high, space), na.value = na.value, guide = guide, ...,
     rescaler = mid_rescaler(mid = midpoint))
 }
 
 #' @rdname scale_gradient
 #' @export
-scale_fill_gradient2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"), midpoint = 0, space = "Lab", na.value = "grey50", guide = "colourbar") {
-  continuous_scale("fill", "gradient2",
+scale_fill_gradient2 <- function(..., low = muted("red"), mid = "white", high = muted("blue"),
+                                 midpoint = 0, space = "Lab", na.value = "grey50", guide = "colourbar",
+                                 aesthetics = "fill") {
+  continuous_scale(aesthetics, "gradient2",
     div_gradient_pal(low, mid, high, space), na.value = na.value, guide = guide, ...,
     rescaler = mid_rescaler(mid = midpoint))
 }
@@ -95,17 +101,19 @@ mid_rescaler <- function(mid) {
 #' @param colours,colors Vector of colours to use for n-colour gradient.
 #' @rdname scale_gradient
 #' @export
-scale_colour_gradientn <- function(..., colours, values = NULL, space = "Lab", na.value = "grey50", guide = "colourbar", colors) {
+scale_colour_gradientn <- function(..., colours, values = NULL, space = "Lab", na.value = "grey50",
+                                   guide = "colourbar", aesthetics = "colour", colors) {
   colours <- if (missing(colours)) colors else colours
 
-  continuous_scale("colour", "gradientn",
+  continuous_scale(aesthetics, "gradientn",
     gradient_n_pal(colours, values, space), na.value = na.value, guide = guide, ...)
 }
 #' @rdname scale_gradient
 #' @export
-scale_fill_gradientn <- function(..., colours, values = NULL, space = "Lab", na.value = "grey50", guide = "colourbar", colors) {
+scale_fill_gradientn <- function(..., colours, values = NULL, space = "Lab", na.value = "grey50",
+                                 guide = "colourbar", aesthetics = "fill", colors) {
   colours <- if (missing(colours)) colors else colours
 
-  continuous_scale("fill", "gradientn",
+  continuous_scale(aesthetics, "gradientn",
     gradient_n_pal(colours, values, space), na.value = na.value, guide = guide, ...)
 }

R/scale-grey.r

@@ -25,14 +25,14 @@
 #' ggplot(mtcars, aes(mpg, wt)) +
 #'   geom_point(aes(colour = miss)) +
 #'   scale_colour_grey(na.value = "green")
-scale_colour_grey <- function(..., start = 0.2, end = 0.8, na.value = "red") {
-  discrete_scale("colour", "grey", grey_pal(start, end),
+scale_colour_grey <- function(..., start = 0.2, end = 0.8, na.value = "red", aesthetics = "colour") {
+  discrete_scale(aesthetics, "grey", grey_pal(start, end),
     na.value = na.value, ...)
 }
 
 #' @rdname scale_grey
 #' @export
-scale_fill_grey <- function(..., start = 0.2, end = 0.8, na.value = "red") {
-  discrete_scale("fill", "grey", grey_pal(start, end),
+scale_fill_grey <- function(..., start = 0.2, end = 0.8, na.value = "red", aesthetics = "fill") {
+  discrete_scale(aesthetics, "grey", grey_pal(start, end),
     na.value = na.value, ...)
 }

R/scale-hue.r

@@ -5,7 +5,11 @@
 #' colour-blind safe palettes.
 #'
 #' @param na.value Colour to use for missing values
-#' @inheritDotParams discrete_scale
+#' @inheritDotParams discrete_scale -aesthetics
+#' @param aesthetics Character string or vector of character strings listing the
+#'   name(s) of the aesthetic(s) that this scale works with. This can be useful, for
+#'   example, to apply colour settings to the `colour` and `fill` aesthetics at the
+#'   same time, via `aesthetics = c("colour", "fill")`.
 #' @inheritParams scales::hue_pal
 #' @rdname scale_hue
 #' @export
@@ -46,14 +50,16 @@
 #'   geom_point(aes(colour = miss)) +
 #'   scale_colour_hue(na.value = "black")
 #' }
-scale_colour_hue <- function(..., h = c(0, 360) + 15, c = 100, l = 65, h.start = 0, direction = 1, na.value = "grey50") {
-  discrete_scale("colour", "hue", hue_pal(h, c, l, h.start, direction),
+scale_colour_hue <- function(..., h = c(0, 360) + 15, c = 100, l = 65, h.start = 0,
+                             direction = 1, na.value = "grey50", aesthetics = "colour") {
+  discrete_scale(aesthetics, "hue", hue_pal(h, c, l, h.start, direction),
     na.value = na.value, ...)
 }
 
 #' @rdname scale_hue
 #' @export
-scale_fill_hue <- function(..., h = c(0, 360) + 15, c = 100, l = 65, h.start = 0, direction = 1, na.value = "grey50") {
-  discrete_scale("fill", "hue", hue_pal(h, c, l, h.start, direction),
+scale_fill_hue <- function(..., h = c(0, 360) + 15, c = 100, l = 65, h.start = 0,
+                           direction = 1, na.value = "grey50", aesthetics = "fill") {
+  discrete_scale(aesthetics, "hue", hue_pal(h, c, l, h.start, direction),
     na.value = na.value, ...)
 }