Weighted densities support (#90)

* add minimal support for weight aesthetic in stat_density_ridges

* document weight aesthetic

* add two tests, one verifying the unweighted density and one verifying the weighted density

* re-oxygenize

* spaces after commas

* add NEWS item for weighted density feature

* forgot to wrap text

---------

Co-authored-by: Joran Elias <[email protected]>

NEWS.md

@@ -1,6 +1,7 @@
 ggridges 0.5.6.9000
 ----------------------------------------------------------------
-
+- Add support for weighted density estimates in `stat_density_ridges()` by 
+  allowing the use of the `weight` aesthetic (@joranE, #90)
 
 ggridges 0.5.6
 ----------------------------------------------------------------

R/geoms.R

@@ -390,6 +390,7 @@ GeomRidgeline <- ggproto("GeomRidgeline", Geom,
 #'
 #' * **`x`**
 #' * **`y`**
+#' * `weight` Optional case weights passed to `stats::density` to calculate a weighted density estimate
 #' * `group` Defines the grouping. Not needed if a categorical variable is mapped onto `y`, but needed otherwise. Will typically be the same
 #' variable as is mapped to `y`.
 #' * `height` The height of each ridgeline at the respective x value. Automatically calculated and
@@ -475,7 +476,7 @@ GeomDensityRidges <- ggproto("GeomDensityRidges", GeomRidgeline,
 
   required_aes = c("x", "y", "height"),
 
-  optional_aes = c("point_color", "vline_color", "vline_size", "vline_width"),
+  optional_aes = c("point_color", "vline_color", "vline_size", "vline_width", "weight"),
 
   extra_params = c("na.rm", "panel_scaling"),
 

R/stats.R

@@ -99,7 +99,9 @@ stat_density_ridges <- function(mapping = NULL, data = NULL, geom = "density_rid
 StatDensityRidges <- ggproto("StatDensityRidges", Stat,
   required_aes = "x",
 
-  default_aes = aes(height = after_stat(density)),
+  default_aes = aes(height = after_stat(density), weight = NULL),
+
+  dropped_aes = "weight",
 
   calc_panel_params = function(data, params) {
     if (is.null(params$bandwidth)) {
@@ -166,8 +168,15 @@ StatDensityRidges <- ggproto("StatDensityRidges", Stat,
     }
     panel_id <- as.numeric(panel)
 
+    if (is.null(data$weight)) {
+      weights <- NULL
+    } else {
+      weights <- data$weight / sum(data$weight)
+    }
+
     d <- stats::density(
       data$x,
+      weights = weights,
       bw = bandwidth[panel_id], from = from[panel_id], to = to[panel_id], na.rm = TRUE,
       n = n
     )

tests/testthat/test_stat_density_ridges.R

@@ -110,3 +110,23 @@ test_that("alternative quantile function can be provided", {
   expect_setequal(out$datatype, c("ridgeline", "vline"))
   expect_equal(out$x[out$datatype=="vline"], mean(df$x))
 })
+
+test_that("unweighted densities are calculated correctly", {
+  df <- data.frame(x = rnorm(100), wts = runif(100))
+  df$wts <- df$wts / sum(df$wts)
+
+  gg_no_wts <- layer_data(ggplot(df, aes(x = x, y = 0)) + stat_density_ridges())
+  d_no_wts <- stats::density(df$x)
+
+  expect_equal(gg_no_wts$density, d_no_wts$y)
+})
+
+test_that("weighted densities are calculated correctly", {
+  df <- data.frame(x = rnorm(100), wts = runif(100))
+  df$wts <- df$wts / sum(df$wts)
+
+  gg_wts <- layer_data(ggplot(df, aes(x = x, y = 0, weight = wts)) + stat_density_ridges())
+  d_wts <- stats::density(df$x, weights = df$wts)
+
+  expect_equal(gg_wts$density, d_wts$y)
+})