From d8c3716b91d435df6dbc6584da2a746e8b512818 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 15 Sep 2023 09:51:16 +0200 Subject: [PATCH 01/18] expand default aes --- R/geom-boxplot.R | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R index 2be6c25d69..13285db35e 100644 --- a/R/geom-boxplot.R +++ b/R/geom-boxplot.R @@ -325,8 +325,25 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, 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, + staple_linetype = NULL, + staple_linewidth = NULL, + staple_colour = NULL, + whisker_linetype = NULL, + whisker_linewidth = NULL, + whisker_colour = NULL, + median_linetype = NULL, + median_linewidth = NULL, + median_colour = NULL + ), required_aes = c("x|y", "lower|xlower", "upper|xupper", "middle|xmiddle", "ymin|xmin", "ymax|xmax"), From b17b91c31605d3c08df5639adb7725add6a2f91c Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 15 Sep 2023 09:51:39 +0200 Subject: [PATCH 02/18] crossbar can use boxplot's median line settings --- R/geom-crossbar.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/geom-crossbar.R b/R/geom-crossbar.R index 36c3d4b9ff..98442327db 100644 --- a/R/geom-crossbar.R +++ b/R/geom-crossbar.R @@ -54,6 +54,9 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, data <- flip_data(data, flipped_aes) middle <- transform(data, x = xmin, xend = xmax, yend = y, linewidth = linewidth * fatten, alpha = NA) + middle$linewidth <- data$median_linewidth %||% middle$linewidth + middle$linetype <- data$median_linetype %||% middle$linetype + middle$colour <- data$median_colour %||% middle$colour has_notch <- !is.null(data$ynotchlower) && !is.null(data$ynotchupper) && !is.na(data$ynotchlower) && !is.na(data$ynotchupper) From 54637f36768bc9ea7132061385d4aed98ec51369 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 15 Sep 2023 09:52:05 +0200 Subject: [PATCH 03/18] insert new aesthetics --- R/geom-boxplot.R | 33 +++++++++++++++------------------ 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R index 13285db35e..dbc1e1d3a7 100644 --- a/R/geom-boxplot.R +++ b/R/geom-boxplot.R @@ -235,36 +235,30 @@ 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(data$whisker_colour %||% data$colour, 2), + linetype = rep(data$whisker_linetype %||% data$linetype, 2), + linewidth = rep(data$whisker_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) @@ -294,6 +288,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(data$staple_linetype %||% data$linetype, 2), + linewidth = rep(data$staple_linewidth %||% data$linewidth, 2), + colour = rep(data$staple_colour %||% data$colour, 2), alpha = c(NA_real_, NA_real_), !!!common, .size = 2 From f3cb1f2488adb7941903625e98c91a5d02ab2391 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 15 Sep 2023 09:52:20 +0200 Subject: [PATCH 04/18] adapt key drawing --- R/legend-draw.R | 35 +++++++++++++++++++++++++++++------ 1 file changed, 29 insertions(+), 6 deletions(-) diff --git a/R/legend-draw.R b/R/legend-draw.R index 5f8c202f07..2d8568369b 100644 --- a/R/legend-draw.R +++ b/R/legend-draw.R @@ -107,20 +107,43 @@ draw_key_boxplot <- function(data, params, size) { linejoin = params$linejoin %||% "mitre" ) + whisker <- gpar( + col = data$whisker_colour, + lty = data$whisker_linetype, + lwd = data$whisker_linewidth + ) + + median <- gpar( + col = data$median_colour, + lty = data$median_linetype, + lwd = data$median_linewidth + ) + + staple_size <- 0.5 + c(0.375, -0.375) * params$staplewidth + staple <- gpar( + col = data$staple_colour, + lty = data$staple_linetype, + lwd = data$staple_linewidth + ) + if (isTRUE(params$flipped_aes)) { grobTree( - linesGrob(c(0.1, 0.25), 0.5), - linesGrob(c(0.75, 0.9), 0.5), + 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), - linesGrob(0.5, c(0.125, 0.875)), + 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)), + 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), - linesGrob(c(0.125, 0.875), 0.5), + 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 ) } From 5b000e10765fd56ff36a7fee5a65d7b6a1729933 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 15 Sep 2023 09:52:31 +0200 Subject: [PATCH 05/18] update snapshots --- .../_snaps/draw-key/horizontal-boxplot-and-crossbar.svg | 4 ++++ tests/testthat/_snaps/geom-boxplot/outlier-colours.svg | 6 ++++++ tests/testthat/_snaps/geom-boxplot/staples.svg | 6 ++++++ 3 files changed, 16 insertions(+) diff --git a/tests/testthat/_snaps/draw-key/horizontal-boxplot-and-crossbar.svg b/tests/testthat/_snaps/draw-key/horizontal-boxplot-and-crossbar.svg index d787461ca4..addbc59e92 100644 --- a/tests/testthat/_snaps/draw-key/horizontal-boxplot-and-crossbar.svg +++ b/tests/testthat/_snaps/draw-key/horizontal-boxplot-and-crossbar.svg @@ -71,11 +71,15 @@ + + + + a b diff --git a/tests/testthat/_snaps/geom-boxplot/outlier-colours.svg b/tests/testthat/_snaps/geom-boxplot/outlier-colours.svg index c3fcba0018..309ffcc43d 100644 --- a/tests/testthat/_snaps/geom-boxplot/outlier-colours.svg +++ b/tests/testthat/_snaps/geom-boxplot/outlier-colours.svg @@ -72,16 +72,22 @@ + + + + + + 4 6 8 diff --git a/tests/testthat/_snaps/geom-boxplot/staples.svg b/tests/testthat/_snaps/geom-boxplot/staples.svg index b0bf785867..b2f4054294 100644 --- a/tests/testthat/_snaps/geom-boxplot/staples.svg +++ b/tests/testthat/_snaps/geom-boxplot/staples.svg @@ -78,16 +78,22 @@ + + + + + + 4 6 8 From ae3a6cbe1192b847358d399a980d708b1b2da52b Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 15 Sep 2023 10:09:19 +0200 Subject: [PATCH 06/18] fix legend linewidth --- R/legend-draw.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/legend-draw.R b/R/legend-draw.R index 2d8568369b..b51ac5c57a 100644 --- a/R/legend-draw.R +++ b/R/legend-draw.R @@ -110,20 +110,20 @@ draw_key_boxplot <- function(data, params, size) { whisker <- gpar( col = data$whisker_colour, lty = data$whisker_linetype, - lwd = data$whisker_linewidth + lwd = len0_null(data$whisker_linewidth * .pt) ) median <- gpar( col = data$median_colour, lty = data$median_linetype, - lwd = data$median_linewidth + lwd = len0_null(data$median_linewidth * .pt) ) staple_size <- 0.5 + c(0.375, -0.375) * params$staplewidth staple <- gpar( col = data$staple_colour, lty = data$staple_linetype, - lwd = data$staple_linewidth + lwd = len0_null(data$staple_linewidth * .pt) ) if (isTRUE(params$flipped_aes)) { From 494caaea8dda4d541dc3742d0b4244962324c31f Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 15 Sep 2023 10:16:16 +0200 Subject: [PATCH 07/18] document --- man/geom_boxplot.Rd | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/man/geom_boxplot.Rd b/man/geom_boxplot.Rd index 4b88223a1c..adca9ff246 100644 --- a/man/geom_boxplot.Rd +++ b/man/geom_boxplot.Rd @@ -172,9 +172,18 @@ See McGill et al. (1978) for more details. \item \code{\link[=aes_group_order]{group}} \item \code{\link[=aes_linetype_size_shape]{linetype}} \item \code{\link[=aes_linetype_size_shape]{linewidth}} +\item \code{median_colour} +\item \code{median_linetype} +\item \code{median_linewidth} \item \code{\link[=aes_linetype_size_shape]{shape}} \item \code{\link[=aes_linetype_size_shape]{size}} +\item \code{staple_colour} +\item \code{staple_linetype} +\item \code{staple_linewidth} \item \code{weight} +\item \code{whisker_colour} +\item \code{whisker_linetype} +\item \code{whisker_linewidth} } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } From 75b54b540e6ef42f2ca0f7221b478b3045802fa7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 27 Oct 2023 09:54:03 +0200 Subject: [PATCH 08/18] capture outlier settings in list --- R/geom-boxplot.R | 32 +++++++++++++++++--------------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R index dbc1e1d3a7..b263c23038 100644 --- a/R/geom-boxplot.R +++ b/R/geom-boxplot.R @@ -138,6 +138,15 @@ 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 + ) + check_number_decimal(staplewidth) check_bool(outliers) @@ -151,12 +160,7 @@ 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, notch = notch, notchwidth = notchwidth, staplewidth = staplewidth, @@ -221,9 +225,7 @@ 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, + outlier_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) @@ -266,13 +268,13 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, 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) From 3ed97aa854c597b6773d6653157e69de16f56f72 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 27 Oct 2023 10:17:29 +0200 Subject: [PATCH 09/18] Use fixed parameters instead of aesthetics --- R/geom-boxplot.R | 76 +++++++++++++++++++++++++++++++++++------------ R/geom-crossbar.R | 20 ++++++------- 2 files changed, 67 insertions(+), 29 deletions(-) diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R index b263c23038..56a09110df 100644 --- a/R/geom-boxplot.R +++ b/R/geom-boxplot.R @@ -119,6 +119,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, @@ -147,6 +163,30 @@ geom_boxplot <- function(mapping = NULL, data = NULL, 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) @@ -161,6 +201,10 @@ geom_boxplot <- function(mapping = NULL, data = NULL, params = list2( outliers = outliers, 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, @@ -224,8 +268,9 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, }, draw_group = function(self, data, panel_params, coord, lineend = "butt", - linejoin = "mitre", fatten = 2, outlier.colour = NULL, - outlier_gp = 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) @@ -244,9 +289,9 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, xend = c(data$x, data$x), y = c(data$upper, data$lower), yend = c(data$ymax, data$ymin), - colour = rep(data$whisker_colour %||% data$colour, 2), - linetype = rep(data$whisker_linetype %||% data$linetype, 2), - linewidth = rep(data$whisker_linewidth %||% data$linewidth, 2), + 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 @@ -290,9 +335,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(data$staple_linetype %||% data$linetype, 2), - linewidth = rep(data$staple_linewidth %||% data$linewidth, 2), - colour = rep(data$staple_colour %||% data$colour, 2), + 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 @@ -317,7 +362,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 ) )) }, @@ -332,16 +379,7 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, alpha = NA, shape = 19, linetype = "solid", - linewidth = 0.5, - staple_linetype = NULL, - staple_linewidth = NULL, - staple_colour = NULL, - whisker_linetype = NULL, - whisker_linewidth = NULL, - whisker_colour = NULL, - median_linetype = NULL, - median_linewidth = NULL, - median_colour = NULL + linewidth = 0.5 ), required_aes = c("x|y", "lower|xlower", "upper|xupper", "middle|xmiddle", "ymin|xmin", "ymax|xmax"), diff --git a/R/geom-crossbar.R b/R/geom-crossbar.R index 98442327db..4e4206e6ac 100644 --- a/R/geom-crossbar.R +++ b/R/geom-crossbar.R @@ -49,14 +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 <- data$median_linewidth %||% middle$linewidth - middle$linetype <- data$median_linetype %||% middle$linetype - middle$colour <- data$median_colour %||% middle$colour + 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) @@ -85,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) ) @@ -97,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 ) From e853fce2c67da35b7f12cb3cbc8ba08c856a990b Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 27 Oct 2023 10:50:50 +0200 Subject: [PATCH 10/18] Adjust key drawing --- R/legend-draw.R | 28 +++++++++++++++++----------- 1 file changed, 17 insertions(+), 11 deletions(-) diff --git a/R/legend-draw.R b/R/legend-draw.R index b51ac5c57a..a61513dfeb 100644 --- a/R/legend-draw.R +++ b/R/legend-draw.R @@ -108,29 +108,35 @@ draw_key_boxplot <- function(data, params, size) { ) whisker <- gpar( - col = data$whisker_colour, - lty = data$whisker_linetype, - lwd = len0_null(data$whisker_linewidth * .pt) + col = params$whisker_gp$colour, + lty = params$whisker_gp$linetype, + lwd = len0_null(params$whisker_gp$linewidth * .pt) ) median <- gpar( - col = data$median_colour, - lty = data$median_linetype, - lwd = len0_null(data$median_linewidth * .pt) + 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 = data$staple_colour, - lty = data$staple_linetype, - lwd = len0_null(data$staple_linewidth * .pt) + 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, gp = whisker), linesGrob(c(0.75, 0.9), 0.5, gp = whisker), - rectGrob(width = 0.5, height = 0.75), + 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), @@ -140,7 +146,7 @@ draw_key_boxplot <- function(data, params, size) { grobTree( 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), + 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), From 654aab04eeedf08663eccada23a6faf2be53bb3e Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 27 Oct 2023 10:53:37 +0200 Subject: [PATCH 11/18] Add test --- .../_snaps/geom-boxplot/customised-style.svg | 167 ++++++++++++++++++ tests/testthat/test-geom-boxplot.R | 12 ++ 2 files changed, 179 insertions(+) create mode 100644 tests/testthat/_snaps/geom-boxplot/customised-style.svg diff --git a/tests/testthat/_snaps/geom-boxplot/customised-style.svg b/tests/testthat/_snaps/geom-boxplot/customised-style.svg new file mode 100644 index 0000000000..612ec93728 --- /dev/null +++ b/tests/testthat/_snaps/geom-boxplot/customised-style.svg @@ -0,0 +1,167 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2 +3 +4 +5 +6 +7 + + + + + + + + + + + + + +2seater +compact +midsize +minivan +pickup +subcompact +suv +class +displ + +class + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2seater +compact +midsize +minivan +pickup +subcompact +suv +customised style + + diff --git a/tests/testthat/test-geom-boxplot.R b/tests/testthat/test-geom-boxplot.R index e6cfa26416..f0f381d829 100644 --- a/tests/testthat/test-geom-boxplot.R +++ b/tests/testthat/test-geom-boxplot.R @@ -96,4 +96,16 @@ test_that("boxplot draws correctly", { expect_doppelganger("staples", ggplot(mtcars, aes(x = factor(cyl), y = drat, colour = factor(cyl))) + geom_boxplot(staplewidth = 0.5) ) + expect_doppelganger( + "customised style", + ggplot(mpg, aes(class, displ, colour = class)) + + geom_boxplot( + outlier.shape = 6, + whisker.linetype = 2, + median.colour = "red", + box.colour = "black", + staple.linewidth = 1, + staplewidth = 0.25 + ) + ) }) From 273b0b8d8c931702ff2b9c59751a542a4dd815aa Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Fri, 27 Oct 2023 11:12:30 +0200 Subject: [PATCH 12/18] Document --- NEWS.md | 3 +++ R/geom-boxplot.R | 19 ++++++++++++++----- man/geom_boxplot.Rd | 42 ++++++++++++++++++++++++++++++------------ 3 files changed, 47 insertions(+), 17 deletions(-) diff --git a/NEWS.md b/NEWS.md index d1818f3f0a..dc5ddd8d93 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # 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) + * `geom_violin()` gains a `bounds` argument analogous to `geom_density()`s (@eliocamp, #5493). * Legend titles no longer take up space if they've been removed by setting diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R index 56a09110df..196ee340eb 100644 --- a/R/geom-boxplot.R +++ b/R/geom-boxplot.R @@ -41,11 +41,17 @@ #' 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 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 +64,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. diff --git a/man/geom_boxplot.Rd b/man/geom_boxplot.Rd index adca9ff246..db39d3ffc0 100644 --- a/man/geom_boxplot.Rd +++ b/man/geom_boxplot.Rd @@ -19,6 +19,22 @@ geom_boxplot( 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, @@ -81,10 +97,17 @@ only, not the full data range. If outliers need to be hidden and the axes needs to show the full data range, please use \code{outlier.shape = NA} instead.} \item{outlier.colour, outlier.color, outlier.fill, outlier.shape, outlier.size, outlier.stroke, outlier.alpha}{Default aesthetics for outliers. Set to \code{NULL} to inherit from the -aesthetics used for the box. +data's aesthetics.} -In the unlikely event you specify both US and UK spellings of colour, the -US spelling will take precedence.} +\item{whisker.colour, whisker.color, whisker.linetype, whisker.linewidth}{Default aesthetics for the whiskers. Set to \code{NULL} to inherit from the +data's aesthetics.} + +\item{staple.colour, staple.color, staple.linetype, staple.linewidth}{Default aesthetics for the staples. Set to \code{NULL} to inherit from the +data's aesthetics. Note that staples don't appear unless the \code{staplewidth} +argument is set to a non-zero size.} + +\item{median.colour, median.color, median.linetype, median.linewidth}{Default aesthetics for the median line. Set to \code{NULL} to inherit from the +data's aesthetics.} \item{notch}{If \code{FALSE} (default) make a standard box plot. If \code{TRUE}, make a notched box plot. Notches are used to compare groups; @@ -131,6 +154,10 @@ The boxplot compactly displays the distribution of a continuous variable. It visualises five summary statistics (the median, two hinges and two whiskers), and all "outlying" points individually. } +\note{ +In the unlikely event you specify both US and UK spellings of colour, +the US spelling will take precedence. +} \section{Orientation}{ This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \code{orientation} parameter, which can be either \code{"x"} or \code{"y"}. The value gives the axis that the geom should run along, \code{"x"} being the default orientation you would expect for the geom. @@ -172,18 +199,9 @@ See McGill et al. (1978) for more details. \item \code{\link[=aes_group_order]{group}} \item \code{\link[=aes_linetype_size_shape]{linetype}} \item \code{\link[=aes_linetype_size_shape]{linewidth}} -\item \code{median_colour} -\item \code{median_linetype} -\item \code{median_linewidth} \item \code{\link[=aes_linetype_size_shape]{shape}} \item \code{\link[=aes_linetype_size_shape]{size}} -\item \code{staple_colour} -\item \code{staple_linetype} -\item \code{staple_linewidth} \item \code{weight} -\item \code{whisker_colour} -\item \code{whisker_linetype} -\item \code{whisker_linewidth} } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } From e41de083dc84d45aa0d81625f2e1ec85bd0a6c7c Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 31 Oct 2023 12:24:06 +0100 Subject: [PATCH 13/18] document box arguments --- R/geom-boxplot.R | 3 +++ man/geom_boxplot.Rd | 3 +++ 2 files changed, 6 insertions(+) diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R index 196ee340eb..4fa281e6e3 100644 --- a/R/geom-boxplot.R +++ b/R/geom-boxplot.R @@ -52,6 +52,9 @@ #' 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 diff --git a/man/geom_boxplot.Rd b/man/geom_boxplot.Rd index db39d3ffc0..eabc774e3b 100644 --- a/man/geom_boxplot.Rd +++ b/man/geom_boxplot.Rd @@ -109,6 +109,9 @@ argument is set to a non-zero size.} \item{median.colour, median.color, median.linetype, median.linewidth}{Default aesthetics for the median line. Set to \code{NULL} to inherit from the data's aesthetics.} +\item{box.colour, box.color, box.linetype, box.linewidth}{Default aesthetics for the boxes. Set to \code{NULL} to inherit from the +data's aesthetics.} + \item{notch}{If \code{FALSE} (default) make a standard box plot. If \code{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 From 86316ac1e2f799688be94aff4c2a7d7864f84ea3 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 13 Sep 2024 14:25:52 +0200 Subject: [PATCH 14/18] add `middle_gp` and `box_gp` to `geom_crossbar()` --- R/geom-crossbar.R | 47 ++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 38 insertions(+), 9 deletions(-) diff --git a/R/geom-crossbar.R b/R/geom-crossbar.R index 777706dac9..be7ce1f658 100644 --- a/R/geom-crossbar.R +++ b/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, @@ -55,13 +84,12 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, draw_panel = function(self, data, panel_params, coord, lineend = "butt", linejoin = "mitre", fatten = 2.5, width = NULL, 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 + 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) @@ -90,9 +118,9 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, data$ymax ), alpha = rep(data$alpha, 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), + colour = rep(data$colour, 11), + linewidth = rep(data$linewidth, 11), + linetype = rep(data$linetype, 11), fill = rep(data$fill, 11), group = rep(seq_len(nrow(data)), 11) ) @@ -102,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(box_gp$colour %||% data$colour, 5), - linewidth = rep(box_gp$linewidth %||% data$linewidth, 5), - linetype = rep(box_gp$linetype %||% data$linetype, 5), + colour = rep(data$colour, 5), + linewidth = rep(data$linewidth, 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) From 828e93dda7aaf50d79ba0e943d3c83e1b6c5699a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 13 Sep 2024 14:25:58 +0200 Subject: [PATCH 15/18] adapt legend keys --- R/legend-draw.R | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/R/legend-draw.R b/R/legend-draw.R index 506d9acb8a..0f734f8fea 100644 --- a/R/legend-draw.R +++ b/R/legend-draw.R @@ -169,16 +169,30 @@ draw_key_crossbar <- function(data, params, size) { lineend = params$lineend %||% "butt", linejoin = params$linejoin %||% "mitre" ) + + middle <- gg_par( + col = params$middle_gp$colour, + lty = params$middle_gp$linetype, + lwd = params$middle_gp$linewidth + ) + + box <- gg_par( + col = params$box_gp$colour, + lty = params$box_gp$linetype, + lwd = params$box_gp$linewidth + ) + + if (isTRUE(params$flipped_aes)) { grobTree( - rectGrob(height = 0.75, width = 0.5), - linesGrob(0.5, c(0.125, 0.875)), + rectGrob(height = 0.75, width = 0.5, gp = box), + linesGrob(0.5, c(0.125, 0.875), gp = middle), gp = gp ) } else { grobTree( - rectGrob(height = 0.5, width = 0.75), - linesGrob(c(0.125, 0.875), 0.5), + rectGrob(height = 0.5, width = 0.75, gp = box), + linesGrob(c(0.125, 0.875), 0.5, gp = middle), gp = gp ) } From 58567a3c3d474ac93068b9609df91d6bc78a99bc Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 13 Sep 2024 14:26:09 +0200 Subject: [PATCH 16/18] redocument --- man/geom_linerange.Rd | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/man/geom_linerange.Rd b/man/geom_linerange.Rd index 87bc5c8e75..e706dea94b 100644 --- a/man/geom_linerange.Rd +++ b/man/geom_linerange.Rd @@ -14,6 +14,14 @@ geom_crossbar( 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, @@ -133,6 +141,12 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} +\item{middle.colour, middle.color, middle.linetype, middle.linewidth}{Default aesthetics for the middle line. Set to \code{NULL} to inherit from the +data's aesthetics.} + +\item{box.colour, box.color, box.linetype, box.linewidth}{Default aesthetics for the boxes. Set to \code{NULL} to inherit from the +data's aesthetics.} + \item{fatten}{A multiplicative factor used to increase the size of the middle bar in \code{geom_crossbar()} and the middle point in \code{geom_pointrange()}.} From 269524a41a77f160aecee3dd7e6d29474e9775ac Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 11 Nov 2024 09:43:04 +0100 Subject: [PATCH 17/18] fix news bullet --- NEWS.md | 2 -- 1 file changed, 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index fb13e4aedc..df9de4b689 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,8 +2,6 @@ * `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). * (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 From ac80af8d5561cf29d4c83603f6a66a949a87efb7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 11 Nov 2024 10:07:32 +0100 Subject: [PATCH 18/18] skip failing test --- tests/testthat/test-patterns.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/testthat/test-patterns.R b/tests/testthat/test-patterns.R index 2f68904dbe..4939c393b0 100644 --- a/tests/testthat/test-patterns.R +++ b/tests/testthat/test-patterns.R @@ -62,6 +62,9 @@ test_that("geoms can use pattern fills", { skip_if_not_installed("grid", "4.2.0") skip_if_not_installed("svglite", "2.1.2") + # TODO: ideally we should test this on all platforms, but currently they + # don't all produce the same result + skip_if_not(.Platform$OS.type == "windows") # Workaround for vdiffr's lack of pattern support # See also https://github.com/r-lib/vdiffr/issues/132