tests/testthat/test-pinterval_bccp.R

In pintervals: Model Agnostic Prediction Intervals

# Tests for pinterval_bccp()

# --- Setup ---
set.seed(42)
n <- 800
x <- runif(n)
y <- rnorm(n, mean = 3 * x, sd = 1)
pred_cal <- 3 * x[1:400]
truth_cal <- y[1:400]
pred_test <- 3 * x[401:800]
truth_test <- y[401:800]

# Create bins based on truth quartiles
breaks <- quantile(truth_cal, probs = seq(0, 1, by = 0.25))
calib_bins <- cut(truth_cal, breaks = breaks, labels = FALSE, include.lowest = TRUE)

# ============================================================
# 1. Input validation
# ============================================================

test_that("pred must be numeric", {
	expect_error(
		pinterval_bccp(pred = "a", calib = pred_cal, calib_truth = truth_cal, calib_bins = calib_bins),
		"pinterval_bccp.*pred.*numeric"
	)
})

test_that("calib must be provided", {
	expect_error(
		pinterval_bccp(pred = pred_test, calib = NULL),
		"pinterval_bccp.*calib.*provided"
	)
})

test_that("alpha must be valid", {
	expect_error(
		pinterval_bccp(
			pred = pred_test, calib = pred_cal, calib_truth = truth_cal,
			calib_bins = calib_bins, alpha = 0
		),
		"pinterval_bccp.*alpha"
	)
})

test_that("breaks must be sorted and numeric", {
	expect_error(
		pinterval_bccp(
			pred = pred_test, calib = pred_cal, calib_truth = truth_cal,
			breaks = c(3, 1, 2)
		),
		"pinterval_bccp.*breaks.*sorted"
	)
	expect_error(
		pinterval_bccp(
			pred = pred_test, calib = pred_cal, calib_truth = truth_cal,
			breaks = "abc"
		),
		"pinterval_bccp.*breaks.*numeric"
	)
})

test_that("right must be a single logical", {
	expect_error(
		pinterval_bccp(
			pred = pred_test, calib = pred_cal, calib_truth = truth_cal,
			calib_bins = calib_bins, right = "yes"
		),
		"pinterval_bccp.*right.*logical"
	)
})

test_that("contiguize must be a single logical", {
	expect_error(
		pinterval_bccp(
			pred = pred_test, calib = pred_cal, calib_truth = truth_cal,
			calib_bins = calib_bins, contiguize = "yes"
		),
		"pinterval_bccp.*contiguize.*logical"
	)
})

test_that("must have at least two bins", {
	one_bin <- rep(1, length(pred_cal))
	expect_error(
		pinterval_bccp(
			pred = pred_test, calib = pred_cal, calib_truth = truth_cal,
			calib_bins = one_bin
		),
		"at least two bins"
	)
})

test_that("calib_bins must have same length as calib", {
	expect_error(
		pinterval_bccp(
			pred = pred_test, calib = pred_cal, calib_truth = truth_cal,
			calib_bins = calib_bins[1:10]
		),
		"same length"
	)
})

# ============================================================
# 2. Output structure
# ============================================================

test_that("contiguize=TRUE returns tibble with lower/upper bounds", {
	result <- suppressWarnings(pinterval_bccp(
		pred = pred_test[1:10], calib = pred_cal, calib_truth = truth_cal,
		calib_bins = calib_bins, alpha = 0.1, contiguize = TRUE
	))
	expect_s3_class(result, "tbl_df")
	expect_true(all(c("pred", "lower_bound", "upper_bound") %in% names(result)))
})

test_that("contiguize=FALSE returns tibble with intervals list-column", {
	result <- suppressWarnings(pinterval_bccp(
		pred = pred_test[1:10], calib = pred_cal, calib_truth = truth_cal,
		calib_bins = calib_bins, alpha = 0.1, contiguize = FALSE
	))
	expect_s3_class(result, "tbl_df")
	expect_true("intervals" %in% names(result))
})

# ============================================================
# 3. Breaks vs calib_bins
# ============================================================

test_that("breaks parameter works to define bins", {
	result <- pinterval_bccp(
		pred = pred_test[1:10], calib = pred_cal, calib_truth = truth_cal,
		breaks = as.numeric(breaks), alpha = 0.1, contiguize = TRUE
	)
	expect_s3_class(result, "tbl_df")
})

test_that("warns when both breaks and calib_bins provided", {
	expect_warning(
		pinterval_bccp(
			pred = pred_test[1:10], calib = pred_cal, calib_truth = truth_cal,
			calib_bins = calib_bins, breaks = as.numeric(breaks), alpha = 0.1, contiguize = TRUE
		),
		"breaks.*calib_bins.*ignored"
	)
})