tests/testthat/test-pinterval_bootstrap.R

In pintervals: Model Agnostic Prediction Intervals

# Tests for pinterval_bootstrap()

# --- Setup ---
set.seed(42)
n <- 500
x <- runif(n)
y <- rnorm(n, mean = 2 * x, sd = 1)
pred_cal <- 2 * x[1:250]
truth_cal <- y[1:250]
pred_test <- 2 * x[251:500]
truth_test <- y[251:500]

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

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

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

test_that("alpha must be single numeric in (0,1)", {
	expect_error(
		pinterval_bootstrap(
			pred = pred_test,
			calib = pred_cal,
			calib_truth = truth_cal,
			alpha = 0
		),
		"pinterval_bootstrap.*alpha"
	)
	expect_error(
		pinterval_bootstrap(
			pred = pred_test,
			calib = pred_cal,
			calib_truth = truth_cal,
			alpha = 1.5
		),
		"pinterval_bootstrap.*alpha"
	)
})

test_that("n_bootstraps must be a single positive integer", {
	expect_error(
		pinterval_bootstrap(
			pred = pred_test,
			calib = pred_cal,
			calib_truth = truth_cal,
			n_bootstraps = -1
		),
		"pinterval_bootstrap.*n_bootstraps"
	)
	expect_error(
		pinterval_bootstrap(
			pred = pred_test,
			calib = pred_cal,
			calib_truth = truth_cal,
			n_bootstraps = 0
		),
		"pinterval_bootstrap.*n_bootstraps"
	)
	expect_error(
		pinterval_bootstrap(
			pred = pred_test,
			calib = pred_cal,
			calib_truth = truth_cal,
			n_bootstraps = 1.5
		),
		"pinterval_bootstrap.*n_bootstraps"
	)
})

test_that("error_type must be valid", {
	expect_error(
		pinterval_bootstrap(
			pred = pred_test,
			calib = pred_cal,
			calib_truth = truth_cal,
			error_type = "invalid"
		),
		"arg"
	)
})

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

test_that("output is a tibble with correct columns and rows", {
	result <- pinterval_bootstrap(
		pred = pred_test,
		calib = pred_cal,
		calib_truth = truth_cal,
		alpha = 0.1
	)
	expect_s3_class(result, "tbl_df")
	expect_true(all(c("pred", "lower_bound", "upper_bound") %in% names(result)))
	expect_equal(nrow(result), length(pred_test))
})

test_that("lower_bound <= upper_bound", {
	result <- pinterval_bootstrap(
		pred = pred_test,
		calib = pred_cal,
		calib_truth = truth_cal,
		alpha = 0.1
	)
	expect_true(all(result$lower_bound <= result$upper_bound, na.rm = TRUE))
})

# ============================================================
# 3. Correctness / coverage
# ============================================================

test_that("coverage is reasonable", {
	set.seed(123)
	result <- pinterval_bootstrap(
		pred = pred_test,
		calib = pred_cal,
		calib_truth = truth_cal,
		alpha = 0.1,
		n_bootstraps = 5000
	)
	coverage <- mean(
		truth_test >= result$lower_bound & truth_test <= result$upper_bound,
		na.rm = TRUE
	)
	# Bootstrap doesn't have formal coverage guarantee, but should be roughly close
	expect_true(coverage >= 0.80 && coverage <= 1.0)
})

test_that("wider intervals with lower alpha", {
	result_90 <- pinterval_bootstrap(
		pred = pred_test[1:10],
		calib = pred_cal,
		calib_truth = truth_cal,
		alpha = 0.1,
		n_bootstraps = 2000
	)
	result_50 <- pinterval_bootstrap(
		pred = pred_test[1:10],
		calib = pred_cal,
		calib_truth = truth_cal,
		alpha = 0.5,
		n_bootstraps = 2000
	)
	width_90 <- mean(result_90$upper_bound - result_90$lower_bound, na.rm = TRUE)
	width_50 <- mean(result_50$upper_bound - result_50$lower_bound, na.rm = TRUE)
	expect_true(width_90 > width_50)
})

# ============================================================
# 4. Both error types produce valid output
# ============================================================

test_that("raw and absolute error types both produce valid output", {
	for (et in c("raw", "absolute")) {
		result <- pinterval_bootstrap(
			pred = pred_test[1:5],
			calib = pred_cal,
			calib_truth = truth_cal,
			error_type = et,
			alpha = 0.1
		)
		expect_s3_class(result, "tbl_df")
	}
})

# ============================================================
# 5. Alternative input formats
# ============================================================

test_that("calib as 2-column tibble works", {
	calib_tib <- tibble::tibble(pred = pred_cal, truth = truth_cal)
	result <- pinterval_bootstrap(
		pred = pred_test[1:5],
		calib = calib_tib,
		alpha = 0.1
	)
	expect_s3_class(result, "tbl_df")
})

test_that("calib as 2-column matrix works", {
	calib_mat <- cbind(pred_cal, truth_cal)
	result <- pinterval_bootstrap(
		pred = pred_test[1:5],
		calib = calib_mat,
		alpha = 0.1
	)
	expect_s3_class(result, "tbl_df")
})

# ============================================================
# 6. Edge cases
# ============================================================

test_that("single prediction works", {
	result <- pinterval_bootstrap(
		pred = 1.0,
		calib = pred_cal,
		calib_truth = truth_cal,
		alpha = 0.1
	)
	expect_equal(nrow(result), 1)
})

test_that("warns when pred contains NA", {
	expect_warning(
		pinterval_bootstrap(
			pred = c(NA_real_, 1),
			calib = pred_cal,
			calib_truth = truth_cal
		),
		"pred.*NA"
	)
})