Extra boxplot features

NEWS.md

@@ -1,5 +1,7 @@
 # ggplot2 (development version)
 
+* `geom_boxplot()` gains additional arguments to style the colour, linetype and
+  linewidths of the box, whiskers, median line and staples (@teunbrand, #5126)
 * `ggsave()` no longer sometimes creates new directories, which is now 
   controlled by the new `create.dir` argument (#5489).
 

R/geom-boxplot.R

@@ -41,11 +41,20 @@
 #'   needs to show the full data range, please use `outlier.shape = NA` instead.
 #' @param outlier.colour,outlier.color,outlier.fill,outlier.shape,outlier.size,outlier.stroke,outlier.alpha
 #'   Default aesthetics for outliers. Set to `NULL` to inherit from the
-#'   aesthetics used for the box.
-#'
-#'   In the unlikely event you specify both US and UK spellings of colour, the
-#'   US spelling will take precedence.
-#'
+#'   data's aesthetics.
+#' @param whisker.colour,whisker.color,whisker.linetype,whisker.linewidth
+#'   Default aesthetics for the whiskers. Set to `NULL` to inherit from the
+#'   data's aesthetics.
+#' @param median.colour,median.color,median.linetype,median.linewidth
+#'   Default aesthetics for the median line. Set to `NULL` to inherit from the
+#'   data's aesthetics.
+#' @param staple.colour,staple.color,staple.linetype,staple.linewidth
+#'   Default aesthetics for the staples. Set to `NULL` to inherit from the
+#'   data's aesthetics. Note that staples don't appear unless the `staplewidth`
+#'   argument is set to a non-zero size.
+#' @param box.colour,box.color,box.linetype,box.linewidth
+#'   Default aesthetics for the boxes. Set to `NULL` to inherit from the
+#'   data's aesthetics.
 #' @param notch If `FALSE` (default) make a standard box plot. If
 #'   `TRUE`, make a notched box plot. Notches are used to compare groups;
 #'   if the notches of two boxes do not overlap, this suggests that the medians
@@ -58,6 +67,9 @@
 #'   `TRUE`, boxes are drawn with widths proportional to the
 #'   square-roots of the number of observations in the groups (possibly
 #'   weighted, using the `weight` aesthetic).
+#' @note In the unlikely event you specify both US and UK spellings of colour,
+#'   the US spelling will take precedence.
+#'
 #' @export
 #' @references McGill, R., Tukey, J. W. and Larsen, W. A. (1978) Variations of
 #'     box plots. The American Statistician 32, 12-16.
@@ -119,6 +131,22 @@ geom_boxplot <- function(mapping = NULL, data = NULL,
                          outlier.size = 1.5,
                          outlier.stroke = 0.5,
                          outlier.alpha = NULL,
+                         whisker.colour    = NULL,
+                         whisker.color     = NULL,
+                         whisker.linetype  = NULL,
+                         whisker.linewidth = NULL,
+                         staple.colour     = NULL,
+                         staple.color      = NULL,
+                         staple.linetype   = NULL,
+                         staple.linewidth  = NULL,
+                         median.colour     = NULL,
+                         median.color      = NULL,
+                         median.linetype   = NULL,
+                         median.linewidth  = NULL,
+                         box.colour        = NULL,
+                         box.color         = NULL,
+                         box.linetype      = NULL,
+                         box.linewidth     = NULL,
                          notch = FALSE,
                          notchwidth = 0.5,
                          staplewidth = 0,
@@ -138,6 +166,39 @@ geom_boxplot <- function(mapping = NULL, data = NULL,
     }
   }
 
+  outlier_gp <- list(
+    colour = outlier.color %||% outlier.colour,
+    fill   = outlier.fill,
+    shape  = outlier.shape,
+    size   = outlier.size,
+    stroke = outlier.stroke,
+    alpha  = outlier.alpha
+  )
+
+  whisker_gp <- list(
+    colour    = whisker.color %||% whisker.colour,
+    linetype  = whisker.linetype,
+    linewidth = whisker.linewidth
+  )
+
+  staple_gp <- list(
+    colour    = staple.color %||% staple.colour,
+    linetype  = staple.linetype,
+    linewidth = staple.linewidth
+  )
+
+  median_gp <- list(
+    colour    = median.color %||% median.colour,
+    linetype  = median.linetype,
+    linewidth = median.linewidth
+  )
+
+  box_gp <- list(
+    colour    = box.color %||% box.colour,
+    linetype  = box.linetype,
+    linewidth = box.linewidth
+  )
+
   check_number_decimal(staplewidth)
   check_bool(outliers)
 
@@ -151,12 +212,11 @@ geom_boxplot <- function(mapping = NULL, data = NULL,
     inherit.aes = inherit.aes,
     params = list2(
       outliers = outliers,
-      outlier.colour = outlier.color %||% outlier.colour,
-      outlier.fill = outlier.fill,
-      outlier.shape = outlier.shape,
-      outlier.size = outlier.size,
-      outlier.stroke = outlier.stroke,
-      outlier.alpha = outlier.alpha,
+      outlier_gp = outlier_gp,
+      whisker_gp = whisker_gp,
+      staple_gp  = staple_gp,
+      median_gp  = median_gp,
+      box_gp     = box_gp,
       notch = notch,
       notchwidth = notchwidth,
       staplewidth = staplewidth,
@@ -220,10 +280,9 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom,
   },
 
   draw_group = function(self, data, panel_params, coord, lineend = "butt",
-                        linejoin = "mitre", fatten = 2, outlier.colour = NULL,
-                        outlier.fill = NULL, outlier.shape = 19,
-                        outlier.size = 1.5, outlier.stroke = 0.5,
-                        outlier.alpha = NULL, notch = FALSE, notchwidth = 0.5,
+                        linejoin = "mitre", fatten = 2, outlier_gp = NULL,
+                        whisker_gp = NULL, staple_gp = NULL, median_gp = NULL,
+                        box_gp = NULL, notch = FALSE, notchwidth = 0.5,
                         staplewidth = 0, varwidth = FALSE, flipped_aes = FALSE) {
     data <- check_linewidth(data, snake_class(self))
     data <- flip_data(data, flipped_aes)
@@ -235,50 +294,44 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom,
       ))
     }
 
-    common <- list(
-      colour = data$colour,
-      linewidth = data$linewidth,
-      linetype = data$linetype,
-      fill = alpha(data$fill, data$alpha),
-      group = data$group
-    )
+    common <- list(fill = alpha(data$fill, data$alpha), group = data$group)
 
     whiskers <- data_frame0(
       x = c(data$x, data$x),
       xend = c(data$x, data$x),
       y = c(data$upper, data$lower),
       yend = c(data$ymax, data$ymin),
+      colour    = rep(whisker_gp$colour    %||% data$colour,    2),
+      linetype  = rep(whisker_gp$linetype  %||% data$linetype,  2),
+      linewidth = rep(whisker_gp$linewidth %||% data$linewidth, 2),
       alpha = c(NA_real_, NA_real_),
       !!!common,
       .size = 2
     )
     whiskers <- flip_data(whiskers, flipped_aes)
 
-    box <- data_frame0(
-      xmin = data$xmin,
-      xmax = data$xmax,
-      ymin = data$lower,
-      y = data$middle,
-      ymax = data$upper,
-      ynotchlower = ifelse(notch, data$notchlower, NA),
-      ynotchupper = ifelse(notch, data$notchupper, NA),
-      notchwidth = notchwidth,
-      alpha = data$alpha,
-      !!!common
+    box <- transform(
+      data,
+      y = middle,
+      ymax = upper,
+      ymin = lower,
+      ynotchlower = ifelse(notch, notchlower, NA),
+      ynotchupper = ifelse(notch, notchupper, NA),
+      notchwidth = notchwidth
     )
     box <- flip_data(box, flipped_aes)
 
     if (!is.null(data$outliers) && length(data$outliers[[1]]) >= 1) {
       outliers <- data_frame0(
         y = data$outliers[[1]],
         x = data$x[1],
-        colour = outlier.colour %||% data$colour[1],
-        fill = outlier.fill %||% data$fill[1],
-        shape = outlier.shape %||% data$shape[1],
-        size = outlier.size %||% data$size[1],
-        stroke = outlier.stroke %||% data$stroke[1],
+        colour = outlier_gp$colour %||% data$colour[1],
+        fill   = outlier_gp$fill   %||% data$fill[1],
+        shape  = outlier_gp$shape  %||% data$shape[1]  %||% 19,
+        size   = outlier_gp$size   %||% data$size[1]   %||% 1.5,
+        stroke = outlier_gp$stroke %||% data$stroke[1] %||% 0.5,
         fill = NA,
-        alpha = outlier.alpha %||% data$alpha[1],
+        alpha = outlier_gp$alpha %||% data$alpha[1],
         .size = length(data$outliers[[1]])
       )
       outliers <- flip_data(outliers, flipped_aes)
@@ -294,6 +347,9 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom,
         xend = rep((data$xmax - data$x) * staplewidth + data$x, 2),
         y    = c(data$ymax, data$ymin),
         yend = c(data$ymax, data$ymin),
+        linetype  = rep(staple_gp$linetype  %||% data$linetype, 2),
+        linewidth = rep(staple_gp$linewidth %||% data$linewidth, 2),
+        colour    = rep(staple_gp$colour    %||% data$colour, 2),
         alpha = c(NA_real_, NA_real_),
         !!!common,
         .size = 2
@@ -318,15 +374,25 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom,
         coord,
         lineend = lineend,
         linejoin = linejoin,
-        flipped_aes = flipped_aes
+        flipped_aes = flipped_aes,
+        middle_gp = median_gp,
+        box_gp = box_gp
       )
     ))
   },
 
   draw_key = draw_key_boxplot,
 
-  default_aes = aes(weight = 1, colour = "grey20", fill = "white", size = NULL,
-    alpha = NA, shape = 19, linetype = "solid", linewidth = 0.5),
+  default_aes = aes(
+    weight = 1,
+    colour = "grey20",
+    fill = "white",
+    size = NULL,
+    alpha = NA,
+    shape = 19,
+    linetype = "solid",
+    linewidth = 0.5
+  ),
 
   required_aes = c("x|y", "lower|xlower", "upper|xupper", "middle|xmiddle", "ymin|xmin", "ymax|xmax"),
 

R/geom-crossbar.R

@@ -49,11 +49,14 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom,
 
   draw_panel = function(self, data, panel_params, coord, lineend = "butt",
                         linejoin = "mitre", fatten = 2.5, width = NULL,
-                        flipped_aes = FALSE) {
+                        flipped_aes = FALSE, middle_gp = NULL, box_gp = NULL) {
     data <- check_linewidth(data, snake_class(self))
     data <- flip_data(data, flipped_aes)
 
     middle <- transform(data, x = xmin, xend = xmax, yend = y, linewidth = linewidth * fatten, alpha = NA)
+    middle$linewidth <- middle_gp$linewidth %||% middle$linewidth
+    middle$linetype  <- middle_gp$linetype  %||% middle$linetype
+    middle$colour    <- middle_gp$colour    %||% middle$colour
 
     has_notch <- !is.null(data$ynotchlower) && !is.null(data$ynotchupper) &&
       !is.na(data$ynotchlower) && !is.na(data$ynotchupper)
@@ -82,9 +85,9 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom,
           data$ymax
         ),
         alpha = rep(data$alpha, 11),
-        colour = rep(data$colour, 11),
-        linewidth = rep(data$linewidth, 11),
-        linetype = rep(data$linetype, 11),
+        colour    = rep(box_gp$colour    %||% data$colour,    11),
+        linewidth = rep(box_gp$linewidth %||% data$linewidth, 11),
+        linetype  = rep(box_gp$linetype  %||% data$linetype,  11),
         fill = rep(data$fill, 11),
         group = rep(seq_len(nrow(data)), 11)
       )
@@ -94,9 +97,9 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom,
         x = c(data$xmin, data$xmin, data$xmax, data$xmax, data$xmin),
         y = c(data$ymax, data$ymin, data$ymin, data$ymax, data$ymax),
         alpha = rep(data$alpha, 5),
-        colour = rep(data$colour, 5),
-        linewidth = rep(data$linewidth, 5),
-        linetype = rep(data$linetype, 5),
+        colour    = rep(box_gp$colour    %||% data$colour,    5),
+        linewidth = rep(box_gp$linewidth %||% data$linewidth, 5),
+        linetype  = rep(box_gp$linetype  %||% data$linetype,  5),
         fill = rep(data$fill, 5),
         group = rep(seq_len(nrow(data)), 5) # each bar forms it's own group
       )

R/legend-draw.R

@@ -107,20 +107,49 @@ draw_key_boxplot <- function(data, params, size) {
     linejoin = params$linejoin %||% "mitre"
   )
 
+  whisker <- gpar(
+    col = params$whisker_gp$colour,
+    lty = params$whisker_gp$linetype,
+    lwd = len0_null(params$whisker_gp$linewidth * .pt)
+  )
+
+  median <- gpar(
+    col = params$median_gp$colour,
+    lty = params$median_gp$linetype,
+    lwd = len0_null(params$median_gp$linewidth * .pt)
+  )
+
+  box <- gpar(
+    col = params$box_gp$colour,
+    lty = params$box_gp$linetype,
+    lwd = len0_null(params$box_gp$linewidth * .pt)
+  )
+
+  staple_size <- 0.5 + c(0.375, -0.375) * params$staplewidth
+  staple <- gpar(
+    col = params$staple_gp$colour,
+    lty = params$staple_gp$linetype,
+    lwd = len0_null(params$staple_gp$linewidth * .pt)
+  )
+
   if (isTRUE(params$flipped_aes)) {
     grobTree(
-      linesGrob(c(0.1, 0.25), 0.5),
-      linesGrob(c(0.75, 0.9), 0.5),
-      rectGrob(width = 0.5, height = 0.75),
-      linesGrob(0.5, c(0.125, 0.875)),
+      linesGrob(c(0.1, 0.25), 0.5, gp = whisker),
+      linesGrob(c(0.75, 0.9), 0.5, gp = whisker),
+      rectGrob(width = 0.5, height = 0.75, gp = box),
+      linesGrob(0.5, c(0.125, 0.875), gp = median),
+      linesGrob(0.1, staple_size, gp = staple),
+      linesGrob(0.9, staple_size, gp = staple),
       gp = gp
     )
   } else {
     grobTree(
-      linesGrob(0.5, c(0.1, 0.25)),
-      linesGrob(0.5, c(0.75, 0.9)),
-      rectGrob(height = 0.5, width = 0.75),
-      linesGrob(c(0.125, 0.875), 0.5),
+      linesGrob(0.5, c(0.1, 0.25), gp = whisker),
+      linesGrob(0.5, c(0.75, 0.9), gp = whisker),
+      rectGrob(height = 0.5, width = 0.75, gp = box),
+      linesGrob(c(0.125, 0.875), 0.5, gp = median),
+      linesGrob(staple_size, 0.1, gp = staple),
+      linesGrob(staple_size, 0.9, gp = staple),
       gp = gp
     )
   }