Allow select alpha to be applied on fill (default), colour, or both

R/geom-polygon.r

@@ -15,6 +15,8 @@
 #' @export
 #' @inheritParams layer
 #' @inheritParams geom_point
+#' @param alpha_to
+#'  Whether to apply alpha to "fill" (default), "colour" ("color"), or "both".
 #' @param rule Either `"evenodd"` or `"winding"`. If polygons with holes are
 #' being drawn (using the `subgroup` aesthetic) this argument defines how the
 #' hole coordinates are interpreted. See the examples in [grid::pathGrob()] for
@@ -84,7 +86,8 @@ geom_polygon <- function(mapping = NULL, data = NULL,
                          ...,
                          na.rm = FALSE,
                          show.legend = NA,
-                         inherit.aes = TRUE) {
+                         alpha_to = c("fill", "colour", "color", "both")) {
+  alpha_to <- standardize_alpha_to(match.arg(alpha_to))
   layer(
     data = data,
     mapping = mapping,
@@ -96,6 +99,7 @@ geom_polygon <- function(mapping = NULL, data = NULL,
     params = list(
       na.rm = na.rm,
       rule = rule,
+      alpha_to = alpha_to,
       ...
     )
   )
@@ -106,7 +110,8 @@ geom_polygon <- function(mapping = NULL, data = NULL,
 #' @usage NULL
 #' @export
 GeomPolygon <- ggproto("GeomPolygon", Geom,
-  draw_panel = function(data, panel_params, coord, rule = "evenodd") {
+  draw_panel = function(data, panel_params, coord, rule = "evenodd",
+                        alpha_to = "fill") {
     n <- nrow(data)
     if (n == 1) return(zeroGrob())
 
@@ -128,8 +133,8 @@ GeomPolygon <- ggproto("GeomPolygon", Geom,
           munched$x, munched$y, default.units = "native",
           id = munched$group,
           gp = gpar(
-            col = first_rows$colour,
-            fill = alpha(first_rows$fill, first_rows$alpha),
+            col = alpha_col(first_rows$colour, first_rows$alpha, alpha_to),
+            fill = alpha_fill(first_rows$fill, first_rows$alpha, alpha_to),
             lwd = first_rows$size * .pt,
             lty = first_rows$linetype
           )

R/geom-rect.r

@@ -1,12 +1,16 @@
 #' @export
+#' @param alpha_to
+#'  Whether to apply alpha to "fill" (default), "colour" ("color"), or "both".
 #' @rdname geom_tile
 geom_rect <- function(mapping = NULL, data = NULL,
                       stat = "identity", position = "identity",
                       ...,
                       linejoin = "mitre",
                       na.rm = FALSE,
                       show.legend = NA,
-                      inherit.aes = TRUE) {
+                      inherit.aes = TRUE,
+                      alpha_to = c("fill", "colour", "color", "both")) {
+  alpha_to <- standardize_alpha_to(match.arg(alpha_to))
   layer(
     data = data,
     mapping = mapping,
@@ -18,6 +22,7 @@ geom_rect <- function(mapping = NULL, data = NULL,
     params = list(
       linejoin = linejoin,
       na.rm = na.rm,
+      alpha_to = alpha_to,
       ...
     )
   )
@@ -33,7 +38,8 @@ GeomRect <- ggproto("GeomRect", Geom,
 
   required_aes = c("xmin", "xmax", "ymin", "ymax"),
 
-  draw_panel = function(self, data, panel_params, coord, linejoin = "mitre") {
+  draw_panel = function(self, data, panel_params, coord, linejoin = "mitre",
+                        alpha_to = "fill") {
     if (!coord$is_linear()) {
       aesthetics <- setdiff(
         names(data), c("x", "y", "xmin", "xmax", "ymin", "ymax")
@@ -56,8 +62,8 @@ GeomRect <- ggproto("GeomRect", Geom,
         default.units = "native",
         just = c("left", "top"),
         gp = gpar(
-          col = coords$colour,
-          fill = alpha(coords$fill, coords$alpha),
+          col = alpha_col(coords$colour, coords$alpha, alpha_to),
+          fill = alpha_fill(coords$fill, coords$alpha, alpha_to),
           lwd = coords$size * .pt,
           lty = coords$linetype,
           linejoin = linejoin,

R/geom-ribbon.r

@@ -19,6 +19,8 @@
 #'   [geom_polygon()] for general polygons
 #' @inheritParams layer
 #' @inheritParams geom_point
+#' @param alpha_to
+#'  Whether to apply alpha to "fill" (default), "colour" ("color"), or "both".
 #' @export
 #' @examples
 #' # Generate data
@@ -37,7 +39,9 @@ geom_ribbon <- function(mapping = NULL, data = NULL,
                         ...,
                         na.rm = FALSE,
                         show.legend = NA,
-                        inherit.aes = TRUE) {
+                        inherit.aes = TRUE,
+                        alpha_to = c("fill", "colour", "color", "both")) {
+  alpha_to <- standardize_alpha_to(match.arg(alpha_to))
   layer(
     data = data,
     mapping = mapping,
@@ -48,6 +52,7 @@ geom_ribbon <- function(mapping = NULL, data = NULL,
     inherit.aes = inherit.aes,
     params = list(
       na.rm = na.rm,
+      alpha_to = alpha_to,
       ...
     )
   )
@@ -78,7 +83,8 @@ GeomRibbon <- ggproto("GeomRibbon", Geom,
     data
   },
 
-  draw_group = function(data, panel_params, coord, na.rm = FALSE) {
+  draw_group = function(data, panel_params, coord, na.rm = FALSE,
+                        alpha_to = "fill") {
     if (na.rm) data <- data[stats::complete.cases(data[c("x", "ymin", "ymax")]), ]
     data <- data[order(data$group), ]
 
@@ -112,8 +118,8 @@ GeomRibbon <- ggproto("GeomRibbon", Geom,
       munched$x, munched$y, id = munched$id,
       default.units = "native",
       gp = gpar(
-        fill = alpha(aes$fill, aes$alpha),
-        col = aes$colour,
+        fill = alpha_fill(aes$fill, aes$alpha, alpha_to),
+        col = alpha_col(aes$colour, aes$alpha, alpha_to),
         lwd = aes$size * .pt,
         lty = aes$linetype)
     ))

R/utilities.r

@@ -7,6 +7,19 @@
 #'   geom_point(colour = alpha("blue", 0.5))
 scales::alpha
 
+alpha_fill <- function(colour, alpha = NA, alpha_to = "fill") {
+  if (alpha_to %in% c("fill", "both")) return(alpha(colour, alpha))
+  colour
+}
+
+# alpha_to is "fill" by default for backward compatibility
+alpha_col <- function(colour, alpha = NA, alpha_to = "fill") {
+  if (alpha_to %in% c("colour", "both")) return(alpha(colour, alpha))
+  colour
+}
+
+standardize_alpha_to <- function(x) sub("color", "colour", x, fixed = TRUE)
+
 "%||%" <- function(a, b) {
   if (!is.null(a)) a else b
 }