diff --git a/NEWS.md b/NEWS.md index af643760..5dba5d8e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # bayesplot (development version) +* Added singleton-dimension edge-case tests for exported `_data()` functions. * Fixed `is_chain_list()` to correctly reject empty lists instead of silently returning `TRUE`. * Added unit tests for `mcmc_areas_ridges_data()`, `mcmc_parcoord_data()`, and `mcmc_trace_data()`. * Added unit tests for `ppc_error_data()` and `ppc_loo_pit_data()` covering output structure, argument handling, and edge cases. diff --git a/tests/testthat/test-ppc-discrete.R b/tests/testthat/test-ppc-discrete.R index 7b0a6471..8cd20f57 100644 --- a/tests/testthat/test-ppc-discrete.R +++ b/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) diff --git a/tests/testthat/test-ppc-distributions.R b/tests/testthat/test-ppc-distributions.R index 34e1c82f..c6072af2 100644 --- a/tests/testthat/test-ppc-distributions.R +++ b/tests/testthat/test-ppc-distributions.R @@ -221,6 +221,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 ----------------------------------------------------------------- diff --git a/tests/testthat/test-ppc-errors.R b/tests/testthat/test-ppc-errors.R index e88c65b5..e50829b1 100644 --- a/tests/testthat/test-ppc-errors.R +++ b/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 ----------------------------------------------------------------- diff --git a/tests/testthat/test-ppc-intervals.R b/tests/testthat/test-ppc-intervals.R index a1499303..e40b66fc 100644 --- a/tests/testthat/test-ppc-intervals.R +++ b/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))) diff --git a/tests/testthat/test-ppc-loo.R b/tests/testthat/test-ppc-loo.R index a722ad46..b52c6f9e 100644 --- a/tests/testthat/test-ppc-loo.R +++ b/tests/testthat/test-ppc-loo.R @@ -399,3 +399,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) +}) diff --git a/tests/testthat/test-ppc-scatterplots.R b/tests/testthat/test-ppc-scatterplots.R index 02494796..e829c003 100644 --- a/tests/testthat/test-ppc-scatterplots.R +++ b/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 ------------------------------------------------------------ diff --git a/tests/testthat/test-ppc-test-statistics.R b/tests/testthat/test-ppc-test-statistics.R index bc95ccc3..75a6dc75 100644 --- a/tests/testthat/test-ppc-test-statistics.R +++ b/tests/testthat/test-ppc-test-statistics.R @@ -129,6 +129,16 @@ 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") +}) + # Visual tests ------------------------------------------------------------