tests/testthat/test-fps_effect_estimation.R

In FPScausal: Functional Propensity Score for Causal Inference

dat_s <- simulate_fps_data(80, "LL", outcome_type = "scalar",
                           include_functional_cov = FALSE, seed = 20)
w_s   <- fps_weighting(dat_s$X, dat_s$t_grid, c(0, 1), covariates = dat_s$C)

dat_f <- simulate_fps_data(80, "LL", outcome_type = "functional",
                           include_functional_cov = FALSE, seed = 21)
w_f   <- fps_weighting(dat_f$X, dat_f$t_grid, c(0, 1),
                        covariates = dat_f$C, domain_name = "s")
# Use a different outcome domain name to avoid the domain-overlap warning
out_domain_name_f <- "t"

# ---- Binary outcome helper ----
dat_b      <- dat_s
dat_b$Y_bin <- as.integer(dat_s$Y > median(dat_s$Y))

# ---- Scalar outcome ----

test_that("fps_effect_estimation works for scalar outcome (no bootstrap)", {
  eff <- fps_effect_estimation(dat_s$Y, w_s)
  expect_s3_class(eff, "fps_effect_estimation")
  expect_equal(eff$outcome_type, "scalar")
  expect_length(eff$beta, 51)
  expect_null(eff$ci_lower)
})

test_that("fps_effect_estimation scalar with bootstrap returns CIs", {
  eff <- fps_effect_estimation(dat_s$Y, w_s,
                                bootstrap = TRUE, B = 20, seed = 1)
  expect_length(eff$ci_lower, 51)
  expect_length(eff$ci_upper, 51)
  expect_true(all(eff$ci_lower <= eff$beta + 1e-10))
  expect_true(all(eff$ci_upper >= eff$beta - 1e-10))
})

test_that("fps_effect_estimation accepts true_beta for scalar", {
  eff <- fps_effect_estimation(dat_s$Y, w_s, true_beta = dat_s$true_beta)
  expect_equal(length(eff$true_beta), 51)
})

test_that("print and summary work for scalar outcome", {
  eff <- fps_effect_estimation(dat_s$Y, w_s, true_beta = dat_s$true_beta)
  expect_output(print(eff), "scalar")
  expect_output(summary(eff), "ISE")
})

test_that("plot type = 'effect' returns ggplot for scalar", {
  eff <- fps_effect_estimation(dat_s$Y, w_s)
  p   <- plot(eff, type = "effect")
  expect_s3_class(p, "gg")
})

test_that("plot type = 'comparison' returns ggplot for scalar", {
  eff <- fps_effect_estimation(dat_s$Y, w_s, true_beta = dat_s$true_beta)
  p   <- plot(eff, type = "comparison")
  expect_s3_class(p, "gg")
})

test_that("plot type = 'significance' works with bootstrap for scalar", {
  eff <- fps_effect_estimation(dat_s$Y, w_s,
                                bootstrap = TRUE, B = 20, seed = 2)
  p   <- plot(eff, type = "significance")
  expect_s3_class(p, "gg")
})

# ---- Binary outcome ----

test_that("fps_effect_estimation works for binary outcome", {
  eff <- fps_effect_estimation(dat_b$Y_bin, w_s)
  expect_equal(eff$outcome_type, "binary")
  expect_length(eff$beta, 51)
})

# ---- Functional outcome ----

test_that("fps_effect_estimation works for functional outcome (no bootstrap)", {
  eff <- fps_effect_estimation(
    dat_f$Y, w_f,
    outcome_t_grid      = dat_f$t_grid,
    outcome_domain      = c(0, 1),
    outcome_domain_name = out_domain_name_f
  )
  expect_equal(eff$outcome_type, "functional")
  expect_equal(dim(eff$beta), c(51, 51))
  expect_null(eff$ci_lower)
})

test_that("fps_effect_estimation functional with bootstrap returns surface CIs", {
  eff <- fps_effect_estimation(
    dat_f$Y, w_f,
    outcome_t_grid      = dat_f$t_grid,
    outcome_domain      = c(0, 1),
    outcome_domain_name = out_domain_name_f,
    bootstrap = TRUE, B = 15, seed = 3
  )
  expect_equal(dim(eff$ci_lower), c(51, 51))
  expect_equal(dim(eff$ci_upper), c(51, 51))
})

test_that("fps_effect_estimation functional with true_beta stores it", {
  eff <- fps_effect_estimation(
    dat_f$Y, w_f,
    outcome_t_grid = dat_f$t_grid,
    outcome_domain = c(0, 1),
    true_beta = dat_f$true_beta
  )
  expect_equal(dim(eff$true_beta), c(51, 51))
})

test_that("plot type = 'fpca_outcome' works for functional outcome", {
  eff <- fps_effect_estimation(
    dat_f$Y, w_f,
    outcome_t_grid = dat_f$t_grid,
    outcome_domain = c(0, 1)
  )
  p <- plot(eff, type = "fpca_outcome")
  expect_true(inherits(p, "patchwork") || inherits(p, "gg"))
})

test_that("plot type = 'bootstrap_slice' works for functional outcome", {
  eff <- fps_effect_estimation(
    dat_f$Y, w_f,
    outcome_t_grid = dat_f$t_grid,
    outcome_domain = c(0, 1),
    bootstrap = TRUE, B = 15, seed = 4
  )
  p <- plot(eff, type = "bootstrap_slice", point = 0.5,
            which_domain = "outcome")
  expect_s3_class(p, "gg")
})

test_that("plot type = 'bootstrap_slice' errors for scalar outcome", {
  eff <- fps_effect_estimation(dat_s$Y, w_s,
                                bootstrap = TRUE, B = 20, seed = 5)
  expect_error(plot(eff, type = "bootstrap_slice", point = 0.5),
               "functional")
})