Merge pull request #521 from utkarshpawade/test/data-functions-edge-cases

Add singleton-dimension edge-case tests for exported `_data()` functions

Author: jgabry

NEWS.md

@@ -1,5 +1,6 @@
 # bayesplot (development version)
 
+* Added singleton-dimension edge-case tests for exported `_data()` functions.
 * Validate empty list and zero-row matrix inputs in `nuts_params.list()`.
 * Validate user-provided `pit` values in `ppc_loo_pit_data()` and `ppc_loo_pit_qq()`, rejecting non-numeric inputs, missing values, and values outside `[0, 1]`.
 * New `show_marginal` argument to `ppd_*()` functions to show the PPD - the marginal predictive distribution by @mattansb (#425)

tests/testthat/test-ppc-discrete.R

@@ -77,6 +77,27 @@ test_that("ppc_bars_data includes all levels", {
   expect_equal(d3$h[2], 0, ignore_attr = TRUE)
 })
 
+test_that("ppc_bars_data handles single observation and single draw", {
+  y1 <- 2L
+  yrep1 <- matrix(c(1L, 2L, 3L, 2L, 2L), ncol = 1)
+  d <- ppc_bars_data(y1, yrep1)
+  expect_s3_class(d, "data.frame")
+  expect_equal(d$y_obs[d$x == 2], 1)
+
+  # single draw: interval collapses to a point
+  y_s <- c(1L, 2L, 3L, 2L)
+  yrep_s <- matrix(c(1L, 2L, 2L, 3L), nrow = 1)
+  d2 <- ppc_bars_data(y_s, yrep_s)
+  expect_equal(d2$l, d2$m, ignore_attr = TRUE)
+  expect_equal(d2$m, d2$h, ignore_attr = TRUE)
+})
+
+test_that("ppc_bars_data prob = 0 collapses interval to median", {
+  d <- ppc_bars_data(y_ord, yrep_ord, prob = 0)
+  expect_equal(d$l, d$m, ignore_attr = TRUE)
+  expect_equal(d$m, d$h, ignore_attr = TRUE)
+})
+
 
 # rootograms -----------------------------------------------------------
 yrep3 <- matrix(yrep2, nrow = 5, ncol = ncol(yrep2), byrow = TRUE)

tests/testthat/test-ppc-distributions.R

@@ -237,6 +237,14 @@ test_that("ppd_data handles a single replicate matrix", {
   expect_equal(d$value, c(11, 21))
 })
 
+test_that("ppd_data handles single observation (single column)", {
+  ypred <- matrix(c(1, 2, 3), ncol = 1)
+  d <- ppd_data(ypred)
+  expect_equal(nrow(d), 3)
+  expect_true(all(d$y_id == 1))
+  expect_equal(d$value, c(1, 2, 3))
+})
+
 
 # Visual tests -----------------------------------------------------------------
 

tests/testthat/test-ppc-errors.R

@@ -85,6 +85,15 @@ test_that("ppc_error_data with group returns exact structure", {
   expect_equal(d$group[d$rep_id == 1], group)
 })
 
+test_that("ppc_error_data handles single observation", {
+  y1 <- 5
+  yrep1 <- matrix(c(4, 6, 5), ncol = 1)
+  d <- ppc_error_data(y1, yrep1)
+  expect_equal(nrow(d), 3)
+  expect_equal(d$value, y1 - yrep1[, 1])
+  expect_true(all(d$y_obs == 5))
+})
+
 
 # Visual tests -----------------------------------------------------------------
 

tests/testthat/test-ppc-intervals.R

@@ -72,6 +72,19 @@ test_that("ppd_intervals_data + y_obs column same as ppc_intervals_data", {
   expect_equal(tibble::add_column(d_group2, y_obs = d_group$y_obs, .after = "y_id"), d_group)
 })
 
+test_that("ppd_intervals_data handles single observation and single draw", {
+  yrep_1obs <- matrix(rnorm(25), ncol = 1)
+  d <- ppd_intervals_data(yrep_1obs)
+  expect_equal(nrow(d), 1)
+  expect_true(d$ll <= d$l && d$l <= d$m && d$m <= d$h && d$h <= d$hh)
+
+  # single draw: all quantiles collapse to the value
+  yrep_1draw <- matrix(rnorm(10), nrow = 1)
+  d2 <- ppd_intervals_data(yrep_1draw)
+  expect_equal(d2$ll, d2$m)
+  expect_equal(d2$hh, d2$m)
+})
+
 test_that("ppc_intervals_data does math correctly", {
   d <- ppc_intervals_data(y, yrep, prob = .4, prob_outer = .8)
   qs <- unname(quantile(yrep[, 1], c(.1, .3, .5, .7, .9)))

tests/testthat/test-ppc-loo.R

@@ -432,3 +432,10 @@ test_that("ppc_loo_pit_data returns the expected structure for both boundary mod
   expect_equal(nrow(yrep_rows), grid_len * n_samples)
   expect_false(anyNA(d_bc$x))
 })
+
+test_that("ppc_loo_pit_data works with a single pit value", {
+  d <- suppressMessages(ppc_loo_pit_data(pit = 0.5, boundary_correction = FALSE, samples = 3))
+  y_rows <- d[d$is_y, ]
+  expect_equal(nrow(y_rows), 1)
+  expect_equal(y_rows$value, 0.5)
+})

tests/testthat/test-ppc-scatterplots.R

@@ -34,6 +34,29 @@ test_that("ppc_scatter_avg_data can take a custom fun_avg", {
   expect_equal(sums$value, colSums(yrep))
 })
 
+test_that("ppc_scatter_data handles single observation and single draw", {
+  y1 <- 5
+  yrep1 <- matrix(c(4, 6, 5), ncol = 1)
+  d <- ppc_scatter_data(y1, yrep1)
+  expect_equal(nrow(d), 3)
+  expect_true(all(d$y_obs == 5))
+  expect_equal(d$value, c(4, 6, 5))
+
+  # single draw
+  d2 <- ppc_scatter_data(y, yrep[1, , drop = FALSE])
+  expect_equal(nrow(d2), length(y))
+  expect_equal(d2$value, yrep[1, ])
+  expect_equal(d2$y_obs, y)
+})
+
+test_that("ppc_scatter_avg_data handles single observation", {
+  y1 <- 5
+  yrep1 <- matrix(c(4, 6, 5), ncol = 1)
+  d <- ppc_scatter_avg_data(y1, yrep1)
+  expect_equal(nrow(d), 1)
+  expect_equal(d$value, mean(c(4, 6, 5)))
+  expect_equal(d$y_obs, 5)
+})
 
 
 # Visual tests ------------------------------------------------------------

tests/testthat/test-ppc-test-statistics.R

@@ -129,6 +129,17 @@ test_that("ppc_stat_data and ppd_stat_data throw correct errors", {
                "object 'not_a_known_function' of mode 'function' was not found")
 })
 
+test_that("ppd_stat_data handles single draw and single observation", {
+  yrep_single <- matrix(rnorm(10), nrow = 1)
+  d <- ppd_stat_data(yrep_single, stat = "mean")
+  expect_equal(nrow(d), 1)
+
+  yrep_1obs <- matrix(rnorm(5), ncol = 1)
+  d2 <- ppd_stat_data(yrep_1obs, stat = "mean")
+  expect_s3_class(d2, "data.frame")
+  expect_equal(nrow(d2), 5)
+})
+
 
 # Visual tests ------------------------------------------------------------