Violin quantiles are based on observations (#5912)

* plumbing for `draw_quantiles` in `stat_ydensity()`

* stat computes quantiles

* geom draws quantiles, not compute them

* migrate docs

* add test

* accept snapshot changes

* add news bullet

* stat param is named `quantiles`

* quantile drawing is controlled by graphical params

* adapt tests

* document

* add news bullets

* dedup news bullets

* Deprecation of the `draw_quantiles` parameter coming from `geom_violin()` parity

Author: teunbrand

NEWS.md

@@ -51,6 +51,13 @@
   (@teunbrand, #4320)
 * `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 additional arguments to style the colour, linetype and
+  linewidths of the quantiles, which replace the now-deprecated `draw_quantiles` 
+  argument (#5912).
+* (breaking) `geom_violin(quantiles)` now has actual quantiles based on
+  the data, rather than inferred quantiles based on the computed density. The
+  `quantiles` parameter that replaces `draw_quantiles` now belongs to 
+  `stat_ydensity()` instead of `geom_violin()` (@teunbrand, #4120).
 * (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-violin.R

@@ -10,8 +10,6 @@
 #' @eval rd_aesthetics("geom", "violin")
 #' @inheritParams layer
 #' @inheritParams geom_bar
-#' @param draw_quantiles If `not(NULL)` (default), draw horizontal lines
-#'   at the given quantiles of the density estimate.
 #' @param trim If `TRUE` (default), trim the tails of the violins
 #'   to the range of the data. If `FALSE`, don't trim the tails.
 #' @param geom,stat Use to override the default connection between
@@ -23,6 +21,12 @@
 #'   finite, boundary effect of default density estimation will be corrected by
 #'   reflecting tails outside `bounds` around their closest edge. Data points
 #'   outside of bounds are removed with a warning.
+#' @param quantile.colour,quantile.color,quantile.linewidth,quantile.linetype
+#'   Default aesthetics for the quantile lines. Set to `NULL` to inherit from
+#'   the data's aesthetics. By default, quantile lines are hidden and can be
+#'   turned on by changing `quantile.linetype`.
+#' @param draw_quantiles `r lifecycle::badge("deprecated")` Previous
+#'   specification of drawing quantiles.
 #' @export
 #' @references Hintze, J. L., Nelson, R. D. (1998) Violin Plots: A Box
 #' Plot-Density Trace Synergism. The American Statistician 52, 181-184.
@@ -91,14 +95,46 @@
 geom_violin <- function(mapping = NULL, data = NULL,
                         stat = "ydensity", position = "dodge",
                         ...,
-                        draw_quantiles = NULL,
                         trim = TRUE,
                         bounds = c(-Inf, Inf),
+                        quantile.colour = NULL,
+                        quantile.color = NULL,
+                        quantile.linetype = 0L,
+                        quantile.linewidth = NULL,
+                        draw_quantiles = deprecated(),
                         scale = "area",
                         na.rm = FALSE,
                         orientation = NA,
                         show.legend = NA,
                         inherit.aes = TRUE) {
+
+  extra <- list()
+  if (lifecycle::is_present(draw_quantiles)) {
+    deprecate_soft0(
+      "3.6.0",
+      what = "geom_violin(draw_quantiles)",
+      with = "geom_violin(quantiles.linetype)"
+    )
+    check_numeric(draw_quantiles)
+
+    # Pass on to stat when stat accepts 'quantiles'
+    stat <- check_subclass(stat, "Stat", current_call(), caller_env())
+    if ("quantiles" %in% stat$parameters()) {
+      extra$quantiles <- draw_quantiles
+    }
+
+    # Turn on quantile lines
+    if (!is.null(quantile.linetype)) {
+      quantile.linetype <- max(quantile.linetype, 1)
+    }
+  }
+
+  quantile_gp <- list(
+    colour    = quantile.color %||% quantile.colour,
+    linetype  = quantile.linetype,
+    linewidth = quantile.linewidth
+  )
+
   layer(
     data = data,
     mapping = mapping,
@@ -110,10 +146,11 @@ geom_violin <- function(mapping = NULL, data = NULL,
     params = list2(
       trim = trim,
       scale = scale,
-      draw_quantiles = draw_quantiles,
       na.rm = na.rm,
       orientation = orientation,
       bounds = bounds,
+      quantile_gp = quantile_gp,
+      !!!extra,
       ...
     )
   )
@@ -146,7 +183,7 @@ GeomViolin <- ggproto("GeomViolin", Geom,
     flip_data(data, params$flipped_aes)
   },
 
-  draw_group = function(self, data, ..., draw_quantiles = NULL, flipped_aes = FALSE) {
+  draw_group = function(self, data, ..., quantile_gp = list(linetype = 0), flipped_aes = FALSE) {
     data <- flip_data(data, flipped_aes)
     # Find the points for the line to go all the way around
     data <- transform(data,
@@ -165,36 +202,28 @@ GeomViolin <- ggproto("GeomViolin", Geom,
     newdata <- vec_rbind0(newdata, newdata[1,])
     newdata <- flip_data(newdata, flipped_aes)
 
+    violin_grob <- GeomPolygon$draw_panel(newdata, ...)
+
+    if (!"quantile" %in% names(newdata) ||
+        all(quantile_gp$linetype == 0) ||
+        all(quantile_gp$linetype == "blank")) {
+      return(ggname("geom_violin", violin_grob))
+    }
+
     # Draw quantiles if requested, so long as there is non-zero y range
-    if (length(draw_quantiles) > 0 & !scales::zero_range(range(data$y))) {
-      if (!(all(draw_quantiles >= 0) && all(draw_quantiles <= 1))) {
-        cli::cli_abort("{.arg draw_quantiles} must be between 0 and 1.")
-      }
-
-      # Compute the quantile segments and combine with existing aesthetics
-      quantiles <- create_quantile_segment_frame(data, draw_quantiles)
-      aesthetics <- data[
-        rep(1, nrow(quantiles)),
-        setdiff(names(data), c("x", "y", "group")),
-        drop = FALSE
-      ]
-      aesthetics$alpha <- rep(1, nrow(quantiles))
-      both <- vec_cbind(quantiles, aesthetics)
-      both <- both[!is.na(both$group), , drop = FALSE]
-      both <- flip_data(both, flipped_aes)
-      quantile_grob <- if (nrow(both) == 0) {
-        zeroGrob()
-      } else {
-        GeomPath$draw_panel(both, ...)
-      }
-
-      ggname("geom_violin", grobTree(
-        GeomPolygon$draw_panel(newdata, ...),
-        quantile_grob)
-      )
+    quantiles <- newdata[!is.na(newdata$quantile),]
+    quantiles$group <- match(quantiles$quantile, unique(quantiles$quantile))
+    quantiles$linetype  <- quantile_gp$linetype  %||% quantiles$linetype
+    quantiles$linewidth <- quantile_gp$linewidth %||% quantiles$linewidth
+    quantiles$colour    <- quantile_gp$colour    %||% quantiles$colour
+
+    quantile_grob <- if (nrow(quantiles) == 0) {
+      zeroGrob()
     } else {
-      ggname("geom_violin", GeomPolygon$draw_panel(newdata, ...))
+      GeomPath$draw_panel(quantiles, ...)
     }
+
+    ggname("geom_violin", grobTree(violin_grob, quantile_grob))
   },
 
   draw_key = draw_key_polygon,

R/stat-ydensity.R

@@ -7,6 +7,8 @@
 #' @param drop Whether to discard groups with less than 2 observations
 #'   (`TRUE`, default) or keep such groups for position adjustment purposes
 #'   (`FALSE`).
+#' @param quantiles If not `NULL` (default), compute the `quantile` variable
+#'   and draw horizontal lines at the given quantiles in `geom_violin()`.
 #'
 #' @eval rd_computed_vars(
 #'   density = "Density estimate.",
@@ -16,7 +18,8 @@
 #'   violinwidth = "Density scaled for the violin plot, according to area,
 #'   counts or to a constant maximum width.",
 #'   n = "Number of points.",
-#'   width = "Width of violin bounding box."
+#'   width = "Width of violin bounding box.",
+#'   quantile = "Whether the row is part of the `quantiles` computation."
 #' )
 #'
 #' @seealso [geom_violin()] for examples, and [stat_density()]
@@ -26,6 +29,7 @@
 stat_ydensity <- function(mapping = NULL, data = NULL,
                           geom = "violin", position = "dodge",
                           ...,
+                          quantiles = c(0.25, 0.50, 0.75),
                           bw = "nrd0",
                           adjust = 1,
                           kernel = "gaussian",
@@ -56,6 +60,7 @@ stat_ydensity <- function(mapping = NULL, data = NULL,
       drop  = drop,
       na.rm = na.rm,
       bounds = bounds,
+      quantiles = quantiles,
       ...
     )
   )
@@ -73,14 +78,26 @@ StatYdensity <- ggproto("StatYdensity", Stat,
   setup_params = function(data, params) {
     params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = TRUE, group_has_equal = TRUE)
 
+    if (!is.null(params$draw_quantiles)) {
+      deprecate_soft0(
+        "3.6.0",
+        what = "stat_ydensity(draw_quantiles)",
+        with = "stat_ydensity(quantiles)"
+      )
+      params$quantiles <- params$draw_quantiles
+      check_numeric(params$quantiles, arg = "quantiles")
+    }
+
     params
   },
 
-  extra_params = c("na.rm", "orientation"),
+  # `draw_quantiles` is here for deprecation repair reasons
+  extra_params = c("na.rm", "orientation", "draw_quantiles"),
 
   compute_group = function(self, data, scales, width = NULL, bw = "nrd0", adjust = 1,
                        kernel = "gaussian", trim = TRUE, na.rm = FALSE,
-                       drop = TRUE, flipped_aes = FALSE, bounds = c(-Inf, Inf)) {
+                       drop = TRUE, flipped_aes = FALSE, bounds = c(-Inf, Inf),
+                       quantiles = c(0.25, 0.50, 0.75)) {
     if (nrow(data) < 2) {
       if (isTRUE(drop)) {
         cli::cli_warn(c(
@@ -115,17 +132,43 @@ StatYdensity <- ggproto("StatYdensity", Stat,
     }
     dens$width <- width
 
+    if (!is.null(quantiles)) {
+      if (!(all(quantiles >= 0) && all(quantiles <= 1))) {
+        cli::cli_abort("{.arg quantiles} must be between 0 and 1.")
+      }
+      if (!is.null(data[["weight"]]) || !all(data[["weight"]] == 1)) {
+        cli::cli_warn(
+          "{.arg quantiles} for weighted data is not implemented."
+        )
+      }
+      quants <- quantile(data$y, probs = quantiles)
+      quants <- data_frame0(
+        y = unname(quants),
+        quantile = quantiles
+      )
+
+      # Interpolate other metrics
+      for (var in setdiff(names(dens), names(quants))) {
+        quants[[var]] <-
+          approx(dens$y, dens[[var]], xout = quants$y, ties = "ordered")$y
+      }
+
+      dens <- vec_slice(dens, !dens$y %in% quants$y)
+      dens <- vec_c(dens, quants)
+    }
+
     dens
   },
 
   compute_panel = function(self, data, scales, width = NULL, bw = "nrd0", adjust = 1,
                            kernel = "gaussian", trim = TRUE, na.rm = FALSE,
                            scale = "area", flipped_aes = FALSE, drop = TRUE,
-                           bounds = c(-Inf, Inf)) {
+                           bounds = c(-Inf, Inf), quantiles = c(0.25, 0.50, 0.75)) {
     data <- flip_data(data, flipped_aes)
     data <- ggproto_parent(Stat, self)$compute_panel(
       data, scales, width = width, bw = bw, adjust = adjust, kernel = kernel,
       trim = trim, na.rm = na.rm, drop = drop, bounds = bounds,
+      quantiles = quantiles
     )
     if (!drop && any(data$n < 2)) {
       cli::cli_warn(

man/geom_violin.Rd

@@ -1,14 +1,12 @@
 # quantiles fails outside 0-1 bound
 
-    Problem while converting geom to grob.
-    i Error occurred in the 1st layer.
-    Caused by error in `draw_group()`:
-    ! `draw_quantiles` must be between 0 and 1.
+    Computation failed in `stat_ydensity()`.
+    Caused by error in `compute_group()`:
+    ! `quantiles` must be between 0 and 1.
 
 ---
 
-    Problem while converting geom to grob.
-    i Error occurred in the 1st layer.
-    Caused by error in `draw_group()`:
-    ! `draw_quantiles` must be between 0 and 1.
+    Computation failed in `stat_ydensity()`.
+    Caused by error in `compute_group()`:
+    ! `quantiles` must be between 0 and 1.