tests/testthat/test-helpers.R

In pintervals: Model Agnostic Prediction Intervals

# Tests for internal helper functions

# ============================================================
# ncs_compute() and NCS functions
# ============================================================

test_that("ncs_compute: absolute_error works", {
	pred <- c(1, 2, 3)
	truth <- c(1.1, 2.2, 2.7)
	result <- pintervals:::ncs_compute("absolute_error", pred, truth)
	expect_equal(result, abs(pred - truth))
})

test_that("ncs_compute: raw_error works", {
	pred <- c(1, 2, 3)
	truth <- c(1.1, 2.2, 2.7)
	result <- pintervals:::ncs_compute("raw_error", pred, truth)
	expect_equal(result, truth - pred)
})

test_that("ncs_compute: relative_error works", {
	pred <- c(1, 2, 3)
	truth <- c(1.1, 2.2, 2.7)
	result <- pintervals:::ncs_compute("relative_error", pred, truth)
	expect_equal(result, abs((pred - truth) / pred))
})

test_that("ncs_compute: za_relative_error works", {
	pred <- c(1, 2, 3)
	truth <- c(1.1, 2.2, 2.7)
	result <- pintervals:::ncs_compute("za_relative_error", pred, truth)
	expect_equal(result, abs((pred - truth) / (1 + pred)))
})

test_that("ncs_compute: heterogeneous_error works with coefs", {
	pred <- c(1, 2, 3)
	truth <- c(1.1, 2.2, 2.7)
	coefs <- c(0.1, 0.5) # intercept + slope
	result <- pintervals:::ncs_compute(
		"heterogeneous_error",
		pred,
		truth,
		coefs = coefs
	)
	expected <- abs(pred - truth) / (coefs[1] + coefs[2] * pred)
	expect_equal(result, expected)
})

test_that("ncs_compute: unknown type errors", {
	expect_error(
		pintervals:::ncs_compute("nonexistent", c(1), c(1)),
		"unknown.*non-conformity"
	)
})

test_that("ncs_compute: heterogeneous_error requires coefs", {
	expect_error(
		pintervals:::ncs_compute(
			"heterogeneous_error",
			c(1, 2),
			c(1, 2),
			coefs = NULL
		),
		"coefs.*provided"
	)
})

test_that("rel_error warns on zero prediction", {
	expect_warning(
		pintervals:::rel_error(c(0, 1), c(1, 2)),
		"zero.*Inf"
	)
})

test_that("heterogeneous_error warns on non-positive denominators", {
	expect_warning(
		pintervals:::heterogeneous_error(c(1, 2), c(1, 2), coefs = c(1, -1)),
		"non-positive"
	)
})

test_that("heterogeneous_error requires coefs of length 2", {
	expect_error(
		pintervals:::heterogeneous_error(c(1), c(1), coefs = c(1, 2, 3)),
		"length 2"
	)
})

# ============================================================
# resolve_weight_function()
# ============================================================

test_that("resolve_weight_function returns correct kernel functions", {
	gk <- pintervals:::resolve_weight_function("gaussian_kernel")
	expect_equal(gk(0), 1)
	expect_true(gk(1) < 1)

	ck <- pintervals:::resolve_weight_function("caucy_kernel")
	expect_equal(ck(0), 1)

	lk <- pintervals:::resolve_weight_function("logistic")
	expect_equal(lk(0), 0.5)

	rl <- pintervals:::resolve_weight_function("reciprocal_linear")
	expect_equal(rl(0), 1)
})

test_that("resolve_weight_function accepts a custom function", {
	custom_fn <- function(d) exp(-d)
	result <- pintervals:::resolve_weight_function(custom_fn)
	expect_true(is.function(result))
	expect_equal(result(0), 1)
})

test_that("resolve_weight_function errors on invalid string", {
	expect_error(
		pintervals:::resolve_weight_function("invalid_kernel"),
		"arg"
	)
})

# ============================================================
# validate_distance_inputs()
# ============================================================

test_that("validate_distance_inputs: errors on NULL inputs", {
	expect_error(
		pintervals:::validate_distance_inputs(NULL, matrix(1:4, 2, 2), 2, 2),
		"must be provided"
	)
	expect_error(
		pintervals:::validate_distance_inputs(matrix(1:4, 2, 2), NULL, 2, 2),
		"must be provided"
	)
})

test_that("validate_distance_inputs: errors on wrong type", {
	expect_error(
		pintervals:::validate_distance_inputs("abc", matrix(1:4, 2, 2), 2, 2),
		"must be a matrix"
	)
})

test_that("validate_distance_inputs: errors on wrong nrow", {
	expect_error(
		pintervals:::validate_distance_inputs(
			matrix(1:6, 3, 2),
			matrix(1:4, 2, 2),
			2,
			2
		),
		"rows.*match"
	)
})

test_that("validate_distance_inputs: errors on mismatched ncol", {
	expect_error(
		pintervals:::validate_distance_inputs(
			matrix(1:6, 2, 3),
			matrix(1:4, 2, 2),
			2,
			2
		),
		"same number of columns"
	)
})

test_that("validate_distance_inputs: accepts numeric vectors", {
	expect_silent(
		pintervals:::validate_distance_inputs(c(1, 2, 3), c(4, 5), 3, 2)
	)
})

# ============================================================
# bin_chopper()
# ============================================================

test_that("bin_chopper: produces correct number of bins", {
	set.seed(42)
	x <- rnorm(100)
	bins <- pintervals:::bin_chopper(x, nbins = 4)
	expect_equal(length(unique(bins)), 4)
	expect_equal(length(bins), 100)
})

test_that("bin_chopper: errors when nbins < 2", {
	expect_error(
		pintervals:::bin_chopper(1:10, nbins = 1),
		"nbins.*greater than 1"
	)
})

test_that("bin_chopper: errors when nbins > length(x)", {
	expect_error(
		pintervals:::bin_chopper(1:5, nbins = 10),
		"nbins.*less than or equal"
	)
})

test_that("bin_chopper: errors when x has single unique value", {
	expect_error(
		pintervals:::bin_chopper(rep(1, 10), nbins = 2),
		"more than one unique"
	)
})

test_that("bin_chopper: return_breaks works", {
	set.seed(42)
	x <- rnorm(100)
	brks <- pintervals:::bin_chopper(x, nbins = 4, return_breaks = TRUE)
	expect_true(is.numeric(brks))
	expect_equal(length(brks), 5) # nbins + 1 breaks
	expect_equal(brks[1], -Inf)
	expect_equal(brks[length(brks)], Inf)
})