Merge branch 'master' into fix/validate-chain-list-colnames-check

Author: jgabry

NEWS.md

@@ -1,6 +1,10 @@
 # bayesplot (development version)
 
 * Fixed `validate_chain_list()` colnames check to compare all chains, not just the first two.
+* Added test verifying `legend_move("none")` behaves equivalently to `legend_none()`.
+* 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)
 * `ppc_ecdf_overlay()`, `ppc_ecdf_overlay_grouped()`, and `ppd_ecdf_overlay()` now always use `geom_step()`. The `discrete` argument is deprecated.
 * Fixed missing `drop = FALSE` in `nuts_params.CmdStanMCMC()`.

R/bayesplot-extractors.R

@@ -145,10 +145,18 @@ nuts_params.stanreg <-
 #' @export
 #' @method nuts_params list
 nuts_params.list <- function(object, pars = NULL, ...) {
+  if (length(object) == 0) {
+    abort("'object' must be a non-empty list.")
+  }
+
   if (!all(sapply(object, is.matrix))) {
     abort("All list elements should be matrices.")
   }
 
+  if (any(vapply(object, nrow, integer(1)) == 0)) {
+    abort("All matrices in the list must have at least one row.")
+  }
+
   dd <- lapply(object, dim)
   if (length(unique(dd)) != 1) {
     abort("All matrices in the list must have the same dimensions.")

R/ppc-loo.R

@@ -302,7 +302,10 @@ ppc_loo_pit_data <-
            boundary_correction = TRUE,
            grid_len = 512) {
     if (!is.null(pit)) {
-      stopifnot(is.numeric(pit), is_vector_or_1Darray(pit))
+      pit <- validate_pit(pit)
+      if (boundary_correction && length(pit) < 2L) {
+        abort("At least 2 PIT values are required when 'boundary_correction' is TRUE.")
+      }
       inform("'pit' specified so ignoring 'y','yrep','lw' if specified.")
     } else {
       suggested_package("rstantools")
@@ -348,7 +351,7 @@ ppc_loo_pit_qq <- function(y,
 
   compare <- match.arg(compare)
   if (!is.null(pit)) {
-    stopifnot(is.numeric(pit), is_vector_or_1Darray(pit))
+    pit <- validate_pit(pit)
     inform("'pit' specified so ignoring 'y','yrep','lw' if specified.")
   } else {
     suggested_package("rstantools")
@@ -795,14 +798,6 @@ ppc_loo_ribbon <-
   # Generate boundary corrected values via a linear convolution using a
   # 1-D Gaussian window filter. This method uses the "reflection method"
   # to estimate these pvalues and helps speed up the code
-  if (any(is.infinite(x))) {
-    warn(paste(
-      "Ignored", sum(is.infinite(x)),
-      "Non-finite PIT values are invalid for KDE boundary correction method"
-    ))
-    x <- x[is.finite(x)]
-  }
-
   if (grid_len < 100) {
     grid_len <- 100
   }
@@ -819,6 +814,10 @@ ppc_loo_ribbon <-
   # 1-D Convolution
   bc_pvals <- .linear_convolution(x, bw, grid_counts, grid_breaks, grid_len)
 
+  if (all(is.na(bc_pvals))) {
+    abort("KDE boundary correction produced all NA values.")
+  }
+
   # Generate vector of x-axis values for plotting based on binned relative freqs
   n_breaks <- length(grid_breaks)
 

tests/testthat/test-convenience-functions.R

@@ -120,6 +120,13 @@ test_that("legend_text returns correct theme object", {
     theme(legend.text = element_text(color = "purple", size = 16))
   )
 })
+test_that("legend_move('none') behaves like legend_none", {
+  expect_equal(
+    legend_move("none")$legend.position,
+    legend_none()$legend.position,
+    ignore_attr = TRUE
+  )
+})
 
 # axis and facet text --------------------------------------------------
 test_that("xaxis_text returns correct theme object", {
@@ -186,8 +193,6 @@ test_that("overlay_function returns the correct object", {
   a$constructor <- b$constructor <- NULL
   expect_equal(a, b, ignore_function_env = TRUE)
 })
-
-
 # tagged functions  -------------------------------------------------------
 
 test_that("as_tagged_function handles bare function (symbol)", {

tests/testthat/test-extractors.R

@@ -9,6 +9,8 @@ x <- list(cbind(a = 1:3, b = rnorm(3)), cbind(a = 1:3, b = rnorm(3)))
 
 # nuts_params and log_posterior methods -----------------------------------
 test_that("nuts_params.list throws errors", {
+  expect_error(nuts_params.list(list()), "non-empty list")
+
   x[[3]] <- c(a = 1:3, b = rnorm(3))
   expect_error(nuts_params.list(x), "list elements should be matrices")
 
@@ -17,6 +19,20 @@ test_that("nuts_params.list throws errors", {
 
   x[[3]] <- cbind(a = 1:4, b = rnorm(4))
   expect_error(nuts_params.list(x), "same dimensions")
+
+  zero_row <- list(cbind(a = numeric(0), b = numeric(0)))
+  expect_error(nuts_params.list(zero_row), "at least one row")
+
+  zero_row_nonfirst <- list(cbind(a = 1:3, b = rnorm(3)), cbind(a = numeric(0), b = numeric(0)))
+  expect_error(nuts_params.list(zero_row_nonfirst), "at least one row")
+})
+
+test_that("nuts_params.list works with single-chain list", {
+  single <- list(cbind(a = 1:3, b = rnorm(3)))
+  np <- nuts_params.list(single)
+  expect_identical(colnames(np), c("Chain", "Iteration", "Parameter", "Value"))
+  expect_true(all(np$Chain == 1L))
+  expect_equal(nrow(np), 6L)
 })
 
 test_that("nuts_params.list parameter selection ok", {

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

@@ -59,17 +59,50 @@ test_that("ppc_loo_pit_overlay works with boundary_correction=FALSE", {
   expect_gg(p1)
 })
 
-test_that(".kde_correction warns when PIT values are non-finite", {
-  set.seed(123)
-  pit_vals <- c(stats::runif(500), Inf)
-  expect_warning(
-    out <- .kde_correction(pit_vals, bw = "nrd0", grid_len = 128),
-    "Non-finite PIT values are invalid"
+test_that("ppc_loo_pit_data validates user-provided pit values", {
+  expect_error(
+    ppc_loo_pit_data(pit = c(0.5, Inf)),
+    "between 0 and 1"
+  )
+  expect_error(
+    ppc_loo_pit_data(pit = c(-1, 0.5)),
+    "between 0 and 1"
+  )
+  expect_error(
+    ppc_loo_pit_data(pit = c(0.5, NA)),
+    "NAs not allowed"
+  )
+  expect_error(
+    ppc_loo_pit_data(pit = "not numeric"),
+    "is.numeric"
+  )
+  expect_error(
+    ppc_loo_pit_data(pit = c(Inf, -Inf, Inf)),
+    "between 0 and 1"
+  )
+  expect_error(
+    ppc_loo_pit_data(pit = 0.5, boundary_correction = TRUE),
+    "At least 2 PIT values"
+  )
+})
+
+test_that("ppc_loo_pit_qq validates user-provided pit values", {
+  expect_error(
+    ppc_loo_pit_qq(pit = c(0.5, Inf)),
+    "between 0 and 1"
+  )
+  expect_error(
+    ppc_loo_pit_qq(pit = c(-1, 0.5)),
+    "between 0 and 1"
+  )
+  expect_error(
+    ppc_loo_pit_qq(pit = c(0.5, NA)),
+    "NAs not allowed"
+  )
+  expect_error(
+    ppc_loo_pit_qq(pit = "not numeric"),
+    "is.numeric"
   )
-  expect_type(out, "list")
-  expect_true(all(c("xs", "bc_pvals") %in% names(out)))
-  expect_equal(length(out$xs), 128)
-  expect_equal(length(out$bc_pvals), 128)
 })
 
 test_that("ppc_loo_pit_qq returns ggplot object", {
@@ -399,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)
+})