Violin quantiles are based on observations

NEWS.md

@@ -1,5 +1,9 @@
 # ggplot2 (development version)
 
+* (breaking) `geom_violin(draw_quantiles)` now has actual quantiles based on
+  the data, rather than inferred quantiles based on the computed density. The
+  `draw_quantiles` parameter now belongs to `stat_ydensity()` instead of 
+  `geom_violin()`. (@teunbrand, #4120)
 * The `arrow.fill` parameter is now applied to more line-based functions: 
   `geom_path()`, `geom_line()`, `geom_step()` `geom_function()`, line 
    geometries in `geom_sf()` and `element_line()`.

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
@@ -91,7 +89,6 @@
 geom_violin <- function(mapping = NULL, data = NULL,
                         stat = "ydensity", position = "dodge",
                         ...,
-                        draw_quantiles = NULL,
                         trim = TRUE,
                         bounds = c(-Inf, Inf),
                         scale = "area",
@@ -110,7 +107,6 @@ 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,
@@ -144,7 +140,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, ..., flipped_aes = FALSE) {
     data <- flip_data(data, flipped_aes)
     # Find the points for the line to go all the way around
     data <- transform(data,
@@ -164,26 +160,15 @@ GeomViolin <- ggproto("GeomViolin", Geom,
     newdata <- flip_data(newdata, flipped_aes)
 
     # 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.")
-      }
+    if ("quantile" %in% names(newdata)) {
+
+      quantiles <- newdata[!is.na(newdata$quantile),]
+      quantiles$group <- match(quantiles$quantile, unique(quantiles$quantile))
 
-      # 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) {
+      quantile_grob <- if (nrow(quantiles) == 0) {
         zeroGrob()
       } else {
-        GeomPath$draw_panel(both, ...)
+        GeomPath$draw_panel(quantiles, ...)
       }
 
       ggname("geom_violin", grobTree(

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 draw_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 `draw_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",
                           ...,
+                          draw_quantiles = NULL,
                           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,
+      draw_quantiles = draw_quantiles,
       ...
     )
   )
@@ -80,7 +85,8 @@ StatYdensity <- ggproto("StatYdensity", Stat,
 
   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),
+                       draw_quantiles = NULL) {
     if (nrow(data) < 2) {
       if (isTRUE(drop)) {
         cli::cli_warn(c(
@@ -115,17 +121,43 @@ StatYdensity <- ggproto("StatYdensity", Stat,
     }
     dens$width <- width
 
+    if (!is.null(draw_quantiles)) {
+      if (!(all(draw_quantiles >= 0) && all(draw_quantiles <= 1))) {
+        cli::cli_abort("{.arg draw_quantiles} must be between 0 and 1.")
+      }
+      if (!is.null(data[["weight"]]) || !all(data[["weight"]] == 1)) {
+        cli::cli_warn(
+          "{.arg draw_quantiles} for weighted data is not implemented."
+        )
+      }
+      quants <- quantile(data$y, probs = draw_quantiles)
+      quants <- data_frame0(
+        y = unname(quants),
+        quantile = draw_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), draw_quantiles = NULL) {
     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,
+      draw_quantiles = draw_quantiles
     )
     if (!drop && any(data$n < 2)) {
       cli::cli_warn(

tests/testthat/_snaps/geom-violin.md

@@ -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()`:
+    Computation failed in `stat_ydensity()`.
+    Caused by error in `compute_group()`:
     ! `draw_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()`:
+    Computation failed in `stat_ydensity()`.
+    Caused by error in `compute_group()`:
     ! `draw_quantiles` must be between 0 and 1.