# Generalized test template for Xi-Gallo spending functions test_sfXG_function <- function( fun, name, compute_expected, valid_param, param_bounds_fn, lower_inclusive, alpha = 0.025 ) { t_vals <- c(0.25, 0.5, 1) param_bounds <- param_bounds_fn(alpha) lower_bound <- param_bounds[1] upper_bound <- param_bounds[2] # Tests to check that the correct structure is returned test_that(paste0(name, " returns correct structure"), { res <- fun(alpha, t_vals, valid_param) expect_s3_class(res, "spendfn") expect_named(res, c("name", "param", "parname", "sf", "spend", "bound", "prob")) expect_equal(res$name, name) expect_equal(res$param, valid_param) expect_equal(res$parname, "gamma") expect_identical(res$sf, fun) }) # Tests for spending values test_that(paste0(name, " computes expected spending values"), { res <- fun(alpha, t_vals, valid_param) expected <- compute_expected(alpha, t_vals, valid_param) expect_equal(res$spend, expected) }) # Tests for t > 1 test_that(paste0(name, " caps t > 1 at 1"), { spend_at_1 <- fun(alpha, 1, valid_param)$spend spend_over_1 <- fun(alpha, c(2, 3, 10), valid_param)$spend expect_equal(spend_over_1, rep(spend_at_1, length(spend_over_1))) }) # Tests for spending < 1 test_that(paste0(name, " spending is always < 1"), { res1 <- fun(alpha, 1, valid_param)$spend res2 <- fun(alpha, 2, valid_param)$spend expect_true(all(res1 < 1)) expect_true(all(res2 < 1)) }) # Test for invalid parameter handling test_that(paste0(name, " rejects invalid gamma"), { # Below lower bound expect_error(fun(alpha, 0.5, lower_bound - 0.001)) # At upper bound (exclusive) expect_error(fun(alpha, 0.5, upper_bound)) # Above upper bound expect_error(fun(alpha, 0.5, upper_bound + 0.001)) # Wrong type expect_error(fun(alpha, 0.5, "bad")) }) # Test for lower boundary inclusivity/exclusivity test_that(paste0(name, " enforces lower bound correctly"), { if (lower_inclusive) { expect_error(fun(alpha, 0.5, lower_bound), NA) } else { expect_error(fun(alpha, 0.5, lower_bound)) } }) } # Define expected spending functions expected_sfXG1 <- function(alpha, t, gamma) { 2 - 2 * pnorm((qnorm(1 - alpha / 2) - qnorm(1 - gamma) * sqrt(1 - pmin(t, 1))) / sqrt(pmin(t, 1))) } expected_sfXG2 <- function(alpha, t, gamma) { 2 - 2 * pnorm((qnorm(1 - alpha / 2) - qnorm(1 - gamma) * (1 - pmin(t, 1))) / sqrt(pmin(t, 1))) } expected_sfXG3 <- function(alpha, t, gamma) { 2 - 2 * pnorm((qnorm(1 - alpha / 2) - qnorm(1 - gamma) * (1 - sqrt(pmin(t, 1)))) / sqrt(pmin(t, 1))) } # Define test configurations sfXG_specs <- list( list( fun = sfXG1, name = "Xi-Gallo, method 1", expected = expected_sfXG1, valid_param = 0.6, # Note: For sfXG1, valid_param must be in [0.5, 1) param_bounds = function(alpha) c(0.5, 1), # lower inclusive, upper exclusive lower_inclusive = TRUE ), list( fun = sfXG2, name = "Xi-Gallo, method 2", expected = expected_sfXG2, valid_param = 0.8, # Note: For sfXG2, valid_param must be in [1 - pnorm(qnorm(1 - alpha / 2)), 1) param_bounds = function(alpha) c(1 - pnorm(qnorm(1 - alpha / 2)), 1), lower_inclusive = TRUE ), list( fun = sfXG3, name = "Xi-Gallo, method 3", expected = expected_sfXG3, valid_param = 0.6, # Note: For sfXG3, valid_param must be in (alpha / 2, 1) param_bounds = function(alpha) c(alpha / 2, 1), lower_inclusive = FALSE ) ) # Iteratively run parameterized tests for (spec in sfXG_specs) { test_sfXG_function( fun = spec$fun, name = spec$name, compute_expected = spec$expected, valid_param = spec$valid_param, param_bounds_fn = spec$param_bounds, lower_inclusive = spec$lower_inclusive ) }