remove hardcoded aesthetics setting for scales; adjust guides so they

can make full use of multiple aesthetics for one scale.

Author: clauswilke

R/guide-colorbar.r

@@ -191,7 +191,7 @@ guide_colourbar <- function(
 }
 
 #' @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, guide$available_aes)) == 0) {
@@ -210,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-alpha.r

@@ -8,6 +8,8 @@
 #' @param ... Other arguments passed on to [continuous_scale()]
 #'   or [discrete_scale()] as appropriate, to control name, limits,
 #'   breaks, labels and so forth.
+#' @param aesthetics Character string or vector of character strings listing the
+#'   name(s) of the aesthetic(s) that this scale works with.
 #' @param range Output range of alpha values. Must lie between 0 and 1.
 #' @family colour scales
 #' @export
@@ -18,8 +20,8 @@
 #' p
 #' p + scale_alpha("cylinders")
 #' p + scale_alpha(range = c(0.4, 0.8))
-scale_alpha <- function(..., range = c(0.1, 1)) {
-  continuous_scale("alpha", "alpha_c", rescale_pal(range), ...)
+scale_alpha <- function(..., range = c(0.1, 1), aesthetics = "alpha") {
+  continuous_scale(aesthetics, "alpha_c", rescale_pal(range), ...)
 }
 
 #' @rdname scale_alpha
@@ -35,9 +37,9 @@ scale_alpha_discrete <- function(...) {
 
 #' @rdname scale_alpha
 #' @export
-scale_alpha_ordinal <- function(..., range = c(0.1, 1)) {
+scale_alpha_ordinal <- function(..., range = c(0.1, 1), aesthetics = "alpha") {
   discrete_scale(
-    "alpha",
+    aesthetics,
     "alpha_d",
     function(n) seq(range[1], range[2], length.out = n),
     ...
@@ -47,13 +49,13 @@ scale_alpha_ordinal <- function(..., range = c(0.1, 1)) {
 #' @rdname scale_alpha
 #' @export
 #' @usage NULL
-scale_alpha_datetime <- function(..., range = c(0.1, 1)) {
-  datetime_scale("alpha", "time", palette = rescale_pal(range), ...)
+scale_alpha_datetime <- function(..., range = c(0.1, 1), aesthetics = "alpha") {
+  datetime_scale(aesthetics, "time", palette = rescale_pal(range), ...)
 }
 
 #' @rdname scale_alpha
 #' @export
 #' @usage NULL
-scale_alpha_date <- function(..., range = c(0.1, 1)){
-  datetime_scale("alpha", "date", palette = rescale_pal(range), ...)
+scale_alpha_date <- function(..., range = c(0.1, 1), aesthetics = "alpha"){
+  datetime_scale(aesthetics, "date", palette = rescale_pal(range), ...)
 }

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,9 @@
 #' 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.
 #' @inheritParams scales::hue_pal
 #' @rdname scale_hue
 #' @export
@@ -46,14 +48,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, ...)
 }

R/scale-identity.r

@@ -7,6 +7,7 @@
 #'
 #' @param ... Other arguments passed on to [discrete_scale()] or
 #'   [continuous_scale()]
+#' @param aesthetics The names of the aesthetics that this scale works with
 #' @param guide Guide to use for this scale. Defaults to `"none"`.
 #' @examples
 #' ggplot(luv_colours, aes(u, v)) +
@@ -48,53 +49,53 @@ NULL
 
 #' @rdname scale_identity
 #' @export
-scale_colour_identity <- function(..., guide = "none") {
-  sc <- discrete_scale("colour", "identity", identity_pal(), ..., guide = guide,
+scale_colour_identity <- function(..., guide = "none", aesthetics = "colour") {
+  sc <- discrete_scale(aesthetics, "identity", identity_pal(), ..., guide = guide,
     super = ScaleDiscreteIdentity)
 
   sc
 }
 
 #' @rdname scale_identity
 #' @export
-scale_fill_identity <- function(..., guide = "none") {
-  sc <- discrete_scale("fill", "identity", identity_pal(), ..., guide = guide,
+scale_fill_identity <- function(..., guide = "none", aesthetics = "fill") {
+  sc <- discrete_scale(aesthetics, "identity", identity_pal(), ..., guide = guide,
     super = ScaleDiscreteIdentity)
 
   sc
 }
 
 #' @rdname scale_identity
 #' @export
-scale_shape_identity <- function(..., guide = "none") {
-  sc <- continuous_scale("shape", "identity", identity_pal(), ..., guide = guide,
+scale_shape_identity <- function(..., guide = "none", aesthetics = "shape") {
+  sc <- continuous_scale(aesthetics, "identity", identity_pal(), ..., guide = guide,
     super = ScaleDiscreteIdentity)
 
   sc
 }
 
 #' @rdname scale_identity
 #' @export
-scale_linetype_identity <- function(..., guide = "none") {
-  sc <- discrete_scale("linetype", "identity", identity_pal(), ..., guide = guide,
+scale_linetype_identity <- function(..., guide = "none", aesthetics = "linetype") {
+  sc <- discrete_scale(aesthetics, "identity", identity_pal(), ..., guide = guide,
     super = ScaleDiscreteIdentity)
 
   sc
 }
 
 #' @rdname scale_identity
 #' @export
-scale_alpha_identity <- function(..., guide = "none") {
-  sc <- continuous_scale("alpha", "identity", identity_pal(), ..., guide = guide,
+scale_alpha_identity <- function(..., guide = "none", aesthetics = "alpha") {
+  sc <- continuous_scale(aesthetics, "identity", identity_pal(), ..., guide = guide,
     super = ScaleContinuousIdentity)
 
   sc
 }
 
 #' @rdname scale_identity
 #' @export
-scale_size_identity <- function(..., guide = "none") {
-  sc <- continuous_scale("size", "identity", identity_pal(), ..., guide = guide,
+scale_size_identity <- function(..., guide = "none", aesthetics = "size") {
+  sc <- continuous_scale(aesthetics, "identity", identity_pal(), ..., guide = guide,
     super = ScaleContinuousIdentity)
 
   sc