tests/testthat/test-simultaneousci.R

In PosiR: Post-Selection Inference via Simultaneous Confidence Intervals

test_that("Basic functionality works with intercept-only model", {
  X <- matrix(1, 10, 1, dimnames = list(NULL, "(Intercept)"))
  y <- rnorm(10)
  Q <- list(null_model = 1)
  result <- simultaneous_ci(X, y, Q, B = 50, add_intercept = FALSE, verbose = FALSE)
  expect_s3_class(result, "simultaneous_ci_result")
  expect_true(nrow(result$intervals) == 1)
})

test_that("Function adds intercept and handles single predictor", {
  X <- matrix(rnorm(10), 10, 1)
  colnames(X) <- "X1"
  y <- rnorm(10)
  Q <- list(model_with_intercept = 1:2)  # intercept will be col 1, X1 will be col 2
  result <- simultaneous_ci(X, y, Q, B = 50, add_intercept = TRUE, verbose = FALSE)
  expect_s3_class(result, "simultaneous_ci_result")
  expect_true("X1" %in% result$intervals$coefficient_name)
})

test_that("Handles perfect collinearity gracefully", {
  set.seed(123)
  x1 <- rnorm(20)
  x2 <- x1  # perfectly collinear
  X <- cbind(1, x1, x2)
  colnames(X) <- c("(Intercept)", "V1", "V2")

  y <- rnorm(20)
  Q <- list(collinear = 1:3)

  result <- simultaneous_ci(X, y, Q, B = 50, add_intercept = FALSE, verbose = FALSE)

  # Check: at least one variance estimate is NA or very small
  psi_values <- unlist(result$intervals$psi_hat_nqj)
  expect_true(any(is.na(psi_values) | psi_values < 1e-6))
})


test_that("Returns proper structure with valid input", {
  X <- matrix(rnorm(100*2), 100, 2)
  colnames(X) <- c("X1", "X2")  # <- add unique names
  y <- X[,1] + rnorm(100)
  Q <- list(m1 = 1:2)
  result <- simultaneous_ci(X, y, Q, B = 100, verbose = FALSE)
  expect_named(result,
               c("intervals", "K_alpha", "alpha", "B", "n_valid_T_star_b",
                 "T_star_b", "bootstrap_method", "warnings_list",
                 "valid_bootstrap_counts", "n_bootstrap_errors")
  )
})

test_that("Handles multiple models in Q_universe", {
  X <- matrix(rnorm(100*3), 100, 3, dimnames = list(NULL, c("X1", "X2", "X3")))
  y <- rnorm(100)
  Q <- list(
    model1 = 1:2,           # (Intercept) + X1
    model2 = 1:3,           # (Intercept) + X1 + X2
    model3 = c(1, 4)        # (Intercept) + X3
  )
  result <- simultaneous_ci(X, y, Q, B = 100, add_intercept = TRUE, verbose = FALSE)

  # Verify all models appear in results
  expect_equal(length(unique(result$intervals$model_id)), 3)

  # Verify coefficient counts
  expect_equal(nrow(result$intervals),
               2 + 3 + 2) # 2 coefficients in model1, 3 in model2, 2 in model3
})

test_that("Sequential mode works and produces output", {
  X <- matrix(rnorm(200*2), 200, 2, dimnames = list(NULL, c("V1", "V2")))
  y <- X[,1] + rnorm(200)
  Q <- list(full_model = 1:3) # Assumes add_intercept=TRUE

  set.seed(123)
  res_seq <- simultaneous_ci(X, y, Q, B = 100, cores = 1, seed = 123)

  expect_s3_class(res_seq, "simultaneous_ci_result")
})

test_that("Parallel mode works and produces consistent results", {
  X <- matrix(rnorm(200*2), 200, 2, dimnames = list(NULL, c("V1", "V2")))
  y <- X[,1] + rnorm(200)
  Q <- list(full_model = 1:3)

  set.seed(123)
  res_par <- simultaneous_ci(X, y, Q, B = 100, cores = 2, seed = 123)

  expect_s3_class(res_par, "simultaneous_ci_result")
})

test_that("Parallel and sequential modes are approximately consistent", {
  X <- matrix(rnorm(200*2), 200, 2, dimnames = list(NULL, c("V1", "V2")))
  y <- X[,1] + rnorm(200)
  Q <- list(full_model = 1:3)

  set.seed(123)
  res_seq <- simultaneous_ci(X, y, Q, B = 100, cores = 1, seed = 123)

  set.seed(123)
  res_par <- simultaneous_ci(X, y, Q, B = 100, cores = 2, seed = 123)

  # Only compare critical values (allow slight randomness tolerance)
  expect_equal(res_seq$K_alpha, res_par$K_alpha, tolerance = 0.25)
})

test_that("Handles small sample sizes with warnings", {
  X <- matrix(rnorm(5*2), 5, 2, dimnames = list(NULL, c("X1", "X2")))
  y <- rnorm(5)
  Q <- list(small_model = 1:2)

  expect_warning(
    simultaneous_ci(X, y, Q, B = 50, verbose = FALSE),
    "Sample size.*unstable"
  )
})

test_that("Rejects invalid bootstrap methods", {
  X <- matrix(rnorm(100*2), 100, 2, dimnames = list(NULL, c("X1", "X2")))
  y <- rnorm(100)
  Q <- list(m1 = 1:2)

  expect_error(
    simultaneous_ci(X, y, Q, bootstrap_method = "invalid"),
    "only.*pairs.*bootstrap", ignore.case = TRUE
  )
})


test_that("Detects duplicate model names", {
  X <- matrix(rnorm(100*2), 100, 2, dimnames = list(NULL, c("X1", "X2")))
  y <- rnorm(100)
  Q <- list(1:2, 1:3)
  names(Q) <- c("m1", "m1")  # Force duplicate names

  expect_error(
    simultaneous_ci(X, y, Q),
    "Duplicate model names detected in Q_universe"
  )
})

test_that("Bootstrap variances approximate theoretical values", {
  # Simple 1-predictor scenario with known variance
  X <- matrix(1:100, ncol = 1)
  colnames(X) <- "X1"
  y <- 2*X[,1] + rnorm(100, sd = 5)
  Q <- list(simple_model = 1:2) # Intercept + X1

  result <- simultaneous_ci(X, y, Q, B = 1000, verbose = FALSE)

  # Theoretical SE for slope = sigma/sqrt(Sxx)
  sigma_hat <- sd(y - 2*X[,1])
  Sxx <- sum((X[,1] - mean(X[,1]))^2)
  theoretical_se <- sigma_hat/sqrt(Sxx)

  # Compare with bootstrap SE (allow 20% tolerance)
  bootstrap_se <- result$intervals$se_nqj[2] # Slope term
  expect_equal(bootstrap_se, theoretical_se, tolerance = 0.2)
})

test_that("Simultaneous intervals achieve nominal coverage", {
  true_beta <- 0.5
  n_sim <- 50
  B <- 200
  alpha <- 0.05
  coverage_tolerance <- 0.05  # Increased tolerance for small n_sim

  coverage <- replicate(n_sim, {
    X <- matrix(rnorm(100*2), 100, 2, dimnames = list(NULL, c("V1", "V2")))
    y <- X[,1] * true_beta + rnorm(100)
    Q <- list(true_model = 1:2) # Intercept + V1 + V2

    result <- simultaneous_ci(X, y, Q, B = B, alpha = alpha, verbose = FALSE)

    # Check coverage for ALL parameters simultaneously
    all_covered <- TRUE
    for (coef_row in 1:nrow(result$intervals)) {
      coef_name <- result$intervals$coefficient_name[coef_row]
      true_value <- ifelse(coef_name == "V1", true_beta, 0) # Intercept truth = 0
      interval <- result$intervals[coef_row, c("lower", "upper")]
      all_covered <- all_covered && (interval$lower <= true_value && true_value <= interval$upper)
    }
    all_covered
  })

  coverage_rate <- mean(coverage)
  message("Simultaneous coverage rate: ", round(coverage_rate, 3))
  expect_true(coverage_rate >= (1 - alpha) - coverage_tolerance) # Allow >=90% coverage
}) |> suppressWarnings()

test_that("Marginal coverage matches expectations", {
  true_beta <- 0.5
  n_sim <- 100
  B <- 500
  alpha <- 0.05
  coverage_tolerance <- 0.05

  coverage <- replicate(n_sim, {
    X <- matrix(rnorm(100), 100, 1, dimnames = list(NULL, "V1"))
    y <- X[,1] * true_beta + rnorm(100)
    Q <- list(single_param = 1) # Only V1, no intercept

    result <- simultaneous_ci(X, y, Q, B = B, add_intercept = FALSE, verbose = FALSE)
    interval <- result$intervals[result$intervals$coefficient_name == "V1", c("lower", "upper")]
    interval$lower <= true_beta && true_beta <= interval$upper
  })

  coverage_rate <- mean(coverage)
  message("Marginal coverage rate: ", round(coverage_rate, 3))
  expect_true(abs(coverage_rate - (1 - alpha)) < coverage_tolerance)
})

test_that("Plot method returns invisibly", {
  X <- matrix(rnorm(100*2), 100, 2, dimnames = list(NULL, c("Age", "Income")))
  y <- rnorm(100)
  Q <- list(model = 1:2)
  result <- simultaneous_ci(X, y, Q, B = 50, verbose = FALSE)

  # Only test invisibility here, do not assign
  expect_invisible(plot(result, verbose = FALSE))
})