add weight to default aes in slabinterval

mjskay · Feb 27, 2024 · 2db2aef · 2db2aef
1 parent 5fecac3
commit 2db2aef
Show file tree

Hide file tree

Showing 19 changed files with 66 additions and 4 deletions.
diff --git a/R/stat_slabinterval.R b/R/stat_slabinterval.R
@@ -454,6 +454,8 @@ StatSlabinterval = ggproto("StatSlabinterval", AbstractStatSlabinterval,
     (when `orientation = "horizontal"` with sample data).',
     y = 'y position of the geometry (when orientation = `"horizontal"`); or sample data to be summarized
     (when `orientation = "vertical"` with sample data).',
+    weight = 'When using samples (i.e. the `x` and `y` aesthetics, not `xdist` or `ydist`), optional
+    weights to be applied to each draw.',
     xdist = 'When using analytical distributions, distribution to map on the x axis: a \\pkg{distributional}
     object (e.g. [dist_normal()]) or a [posterior::rvar()] object.',
     ydist = 'When using analytical distributions, distribution to map on the y axis: a \\pkg{distributional}
@@ -476,7 +478,8 @@ StatSlabinterval = ggproto("StatSlabinterval", AbstractStatSlabinterval,
     arg6 = NULL,
     arg7 = NULL,
     arg8 = NULL,
-    arg9 = NULL
+    arg9 = NULL,
+    weight = NULL
   ), AbstractStatSlabinterval$default_aes),
 
   # interval parameter used to determine if the stat re-groups

diff --git a/man/stat_ccdfinterval.Rd b/man/stat_ccdfinterval.Rd
diff --git a/man/stat_cdfinterval.Rd b/man/stat_cdfinterval.Rd
diff --git a/man/stat_dots.Rd b/man/stat_dots.Rd
diff --git a/man/stat_dotsinterval.Rd b/man/stat_dotsinterval.Rd
diff --git a/man/stat_eye.Rd b/man/stat_eye.Rd
diff --git a/man/stat_gradientinterval.Rd b/man/stat_gradientinterval.Rd
diff --git a/man/stat_halfeye.Rd b/man/stat_halfeye.Rd
diff --git a/man/stat_histinterval.Rd b/man/stat_histinterval.Rd
diff --git a/man/stat_interval.Rd b/man/stat_interval.Rd
diff --git a/man/stat_lineribbon.Rd b/man/stat_lineribbon.Rd
diff --git a/man/stat_mcse_dots.Rd b/man/stat_mcse_dots.Rd
diff --git a/man/stat_pointinterval.Rd b/man/stat_pointinterval.Rd
diff --git a/man/stat_ribbon.Rd b/man/stat_ribbon.Rd
diff --git a/man/stat_slab.Rd b/man/stat_slab.Rd
diff --git a/man/stat_slabinterval.Rd b/man/stat_slabinterval.Rd
diff --git a/man/stat_spike.Rd b/man/stat_spike.Rd
diff --git a/tests/testthat/test.geom_slabinterval.R b/tests/testthat/test.geom_slabinterval.R
@@ -3,9 +3,9 @@
 # Author: mjskay
 ###############################################################################
 
-library(dplyr)
-
-
+suppressPackageStartupMessages(suppressWarnings({
+  library(dplyr)
+}))
 
 
 # group_slab_data_by -------------------------------------------------

diff --git a/tests/testthat/test.stat_sample_slabinterval.R b/tests/testthat/test.stat_sample_slabinterval.R
@@ -410,6 +410,33 @@ test_that("logical conditions at bin edges on histograms work", {
 })
 
 
+# weights -----------------------------------------------------------------
+
+test_that("sample weights work", {
+  df = data.frame(
+    x = 1:9/10,
+    w = 0:8
+  )
+
+  p = ggplot(df, aes(x, weight = w))
+
+  ld_slab = layer_data(p + stat_slab(n = 9, density = "unbounded", .width = .5))
+  expect_equal(
+    ld_slab$pdf,
+    density(df$x, weights = df$w/36, bw = bandwidth_dpi(df$x), n = 9, cut = 0)$y
+  )
+  expect_equal(ld_slab$cdf, cumsum(df$w/36))
+  expect_equal(ld_slab$.width, c(rep(NA, 5), rep(0.5, 3), NA))
+
+  ld_interval = layer_data(p + stat_pointinterval(.width = .5))
+  expect_equal(ld_interval$x, 0.7)
+  expect_equal(ld_interval$xmin, weighted_quantile(df$x, 0.25, weights = df$w, names = FALSE))
+  expect_equal(ld_interval$xmax, weighted_quantile(df$x, 0.75, weights = df$w, names = FALSE))
+  ld_interval_mean = layer_data(p + stat_pointinterval(.width = .5, point_interval = mean_qi))
+  expect_equal(ld_interval_mean$x, 2/3)
+})
+
+
 # deprecated params -------------------------------------------------------
 
 test_that("slab_type throws appropriate warnings and errors", {