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)
 * (internal) Using `after_scale()` in the `Geom*$default_aes()` field is now
   evaluated in the context of data (@teunbrand, #6135)
 * Fixed bug where binned scales wouldn't simultaneously accept transformations

R/geom-boxplot.R

@@ -43,11 +43,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
@@ -60,6 +69,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.
@@ -121,6 +133,22 @@ geom_boxplot <- function(mapping = NULL, data = NULL,
                          outlier.size = NULL,
                          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,
@@ -140,6 +168,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)
 
@@ -153,12 +214,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,
@@ -222,10 +282,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 = NULL,
-                        outlier.size = NULL, 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)
@@ -237,50 +296,44 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom,
       ))
     }
 
-    common <- list(
-      colour = data$colour,
-      linewidth = data$linewidth,
-      linetype = data$linetype,
-      fill = fill_alpha(data$fill, data$alpha),
-      group = data$group
-    )
+    common <- list(fill = 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)
@@ -296,6 +349,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
@@ -320,7 +376,9 @@ 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
       )
     ))
   },

R/geom-crossbar.R

@@ -1,13 +1,40 @@
 #' @export
 #' @rdname geom_linerange
+#' @param middle.colour,middle.color,middle.linetype,middle.linewidth
+#'   Default aesthetics for the middle line. Set to `NULL` to inherit from the
+#'   data's aesthetics.
+#' @param box.colour,box.color,box.linetype,box.linewidth
+#'   Default aesthetics for the boxes. Set to `NULL` to inherit from the
+#'   data's aesthetics.
 geom_crossbar <- function(mapping = NULL, data = NULL,
                           stat = "identity", position = "identity",
                           ...,
+                          middle.colour     = NULL,
+                          middle.color      = NULL,
+                          middle.linetype   = NULL,
+                          middle.linewidth  = NULL,
+                          box.colour        = NULL,
+                          box.color         = NULL,
+                          box.linetype      = NULL,
+                          box.linewidth     = NULL,
                           fatten = 2.5,
                           na.rm = FALSE,
                           orientation = NA,
                           show.legend = NA,
                           inherit.aes = TRUE) {
+
+  middle_gp <- list(
+    colour    = middle.color %||% middle.colour,
+    linetype  = middle.linetype,
+    linewidth = middle.linewidth
+  )
+
+  box_gp <- list(
+    colour    = box.color %||% box.colour,
+    linetype  = box.linetype,
+    linewidth = box.linewidth
+  )
+
   layer(
     data = data,
     mapping = mapping,
@@ -17,6 +44,8 @@ geom_crossbar <- function(mapping = NULL, data = NULL,
     show.legend = show.legend,
     inherit.aes = inherit.aes,
     params = list2(
+      middle_gp = middle_gp,
+      box_gp = box_gp,
       fatten = fatten,
       na.rm = na.rm,
       orientation = orientation,
@@ -54,11 +83,13 @@ 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 <- data_frame0(!!!defaults(compact(middle_gp), middle))
 
     has_notch <- !is.null(data$ynotchlower) && !is.null(data$ynotchupper) &&
       !is.na(data$ynotchlower) && !is.na(data$ynotchupper)
@@ -87,9 +118,9 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom,
           data$ymax
         ),
         alpha = rep(data$alpha, 11),
-        colour = rep(data$colour, 11),
+        colour = rep(data$colour,    11),
         linewidth = rep(data$linewidth, 11),
-        linetype = rep(data$linetype, 11),
+        linetype  = rep(data$linetype,  11),
         fill = rep(data$fill, 11),
         group = rep(seq_len(nrow(data)), 11)
       )
@@ -99,13 +130,14 @@ 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),
+        colour = rep(data$colour,    5),
         linewidth = rep(data$linewidth, 5),
-        linetype = rep(data$linetype, 5),
+        linetype = rep(data$linetype,  5),
         fill = rep(data$fill, 5),
         group = rep(seq_len(nrow(data)), 5) # each bar forms it's own group
       )
     }
+    box <- data_frame0(!!!defaults(compact(box_gp), box))
     box <- flip_data(box, flipped_aes)
     middle <- flip_data(middle, flipped_aes)