inst/examples/test_todo_fixes.R

In FPScausal: Functional Propensity Score for Causal Inference

# test_todo_fixes.R
#
# Eseguire con: source("inst/examples/test_todo_fixes.R")
# (dalla root del pacchetto, dopo devtools::load_all() )
#
# Ogni test stampa PASS o FAIL con una breve descrizione.
# -----------------------------------------------------------------

library(FPScausal)

results <- list()

pass <- function(id, msg) {
  cat(sprintf("[PASS] #%-2s %s\n", id, msg))
  results[[id]] <<- TRUE
}

fail <- function(id, msg, err = NULL) {
  cat(sprintf("[FAIL] #%-2s %s\n", id, msg))
  if (!is.null(err)) cat("       Error:", conditionMessage(err), "\n")
  results[[id]] <<- FALSE
}

# ----------------------------------------------------------------
# Dati comuni (n=200, LL, scalare, senza covariata funzionale)
# ----------------------------------------------------------------
dat <- simulate_fps_data(
  n                      = 2000,
  setting                = "LL",
  outcome_type           = "scalar",
  include_functional_cov = TRUE,   # serve per test #1 e #2
  seed                   = 42
)

# ================================================================
# TEST 1 — Fix #1: nomi FPC covariate funzionali
# Covariate scalari NOMINATE + covariata funzionale SENZA NOME
# => balance plot deve girare senza errore "livello factor duplicato"
# ================================================================
cat("\n--- Test 1: nomi FPC covariate funzionali ---\n")
C_named <- dat$C
colnames(C_named) <- c("Age", "Sex", "BMI")

tryCatch({
  w1 <- fps_weighting(
    treatment   = dat$X,
    treat_grid  = dat$t_grid,
    covariates  = list(scalar = C_named, functional = list(dat$D)),
    cov_grids   = list(dat$t_grid)
  )
  # Se i nomi non sono assegnati, plot da errore di factor duplicato
  p1 <- plot(w1, type = "balance")
  pass("1", "Balance plot con scalari nominati + cov. funzionale: OK")
}, error = function(e) {
  fail("1", "Balance plot con scalari nominati + cov. funzionale", e)
})

# ================================================================
# TEST 2 — Fix #2/#3/#4: outcome di tipo fd
# ================================================================
cat("\n--- Test 2: outcome fd ---\n")
tryCatch({
  # Costruiamo un oggetto fd dall'outcome funzionale simulato
  dat_fn <- simulate_fps_data(
    n                      = 2000,
    setting                = "LL",
    outcome_type           = "functional",
    include_functional_cov = FALSE,
    seed                   = 99
  )
  w_fn <- fps_weighting(dat_fn$X, treat_grid = dat_fn$t_grid,
                         covariates = dat_fn$C)

  # Converti Y in fd
  basis_y <- fda::create.bspline.basis(rangeval = c(0, 1), nbasis = 15)
  Y_fd    <- fda::Data2fd(argvals = dat_fn$t_grid,
                           y       = t(dat_fn$Y),
                           basisobj = basis_y)

  eff_fd <- fps_effect_estimation(
    outcome    = Y_fd,
    fps_object = w_fn
  )
  stopifnot(eff_fd$outcome_type == "functional")
  pass("2", "fps_effect_estimation con outcome fd: OK")
}, error = function(e) {
  fail("2", "fps_effect_estimation con outcome fd", e)
})

# ================================================================
# TEST 3 — Fix #5: rinomina parametri (treat_grid, treat_domain, cov_grids)
# ================================================================
cat("\n--- Test 3: nomi parametri rinominati ---\n")
tryCatch({
  w3 <- fps_weighting(
    treatment    = dat$X,
    treat_grid   = dat$t_grid,
    treat_domain = c(0, 1),
    covariates   = list(scalar = dat$C, functional = list(dat$D)),
    cov_grids    = list(dat$t_grid)
  )
  pass("3", "fps_weighting con treat_grid/treat_domain/cov_grids: OK")
}, error = function(e) {
  fail("3", "fps_weighting con parametri rinominati", e)
})

# ================================================================
# TEST 4 — Fix #6: inferenza automatica di treat_domain da treat_grid
# ================================================================
cat("\n--- Test 4: inferenza automatica treat_domain ---\n")
tryCatch({
  w4 <- fps_weighting(
    treatment  = dat$X,
    treat_grid = dat$t_grid,   # treat_domain NON passato
    covariates = dat$C
  )
  dom <- w4$fpca_treatment$domain
  stopifnot(length(dom) == 2)
  stopifnot(abs(dom[1] - min(dat$t_grid)) < 1e-9)
  stopifnot(abs(dom[2] - max(dat$t_grid)) < 1e-9)
  pass("4", paste0("treat_domain inferito automaticamente = [",
                   round(dom[1], 3), ", ", round(dom[2], 3), "]: OK"))
}, error = function(e) {
  fail("4", "Inferenza automatica treat_domain", e)
})

# ================================================================
# TEST 5 — Fix #7: default domain_name = "s" per fps_weighting
#                   default outcome_domain_name = "t" per fps_effect_estimation
# ================================================================
cat("\n--- Test 5: default domain_name ---\n")
tryCatch({
  w5  <- fps_weighting(dat$X, treat_grid = dat$t_grid, covariates = dat$C)
  eff5 <- fps_effect_estimation(dat$Y, w5)
  stopifnot(w5$domain_name == "s")
  stopifnot(eff5$domain_name == "s")
  pass("5a", paste0("fps_weighting default domain_name = '",
                    w5$domain_name, "': OK"))
}, error = function(e) {
  fail("5a", "Default domain_name = 's' in fps_weighting", e)
})

tryCatch({
  # outcome_domain_name default = "t" (non passato)
  dat_fn2 <- simulate_fps_data(2000, "LL", outcome_type = "functional",
                                include_functional_cov = FALSE, seed = 5)
  w5b  <- fps_weighting(dat_fn2$X, treat_grid = dat_fn2$t_grid,
                         covariates = dat_fn2$C)
  eff5b <- fps_effect_estimation(
    outcome        = dat_fn2$Y,
    fps_object     = w5b,
    outcome_t_grid = dat_fn2$t_grid
  )
  stopifnot(eff5b$outcome_domain_name == "t")
  pass("5b", paste0("fps_effect_estimation default outcome_domain_name = '",
                    eff5b$outcome_domain_name, "': OK"))
}, error = function(e) {
  fail("5b", "Default outcome_domain_name = 't' in fps_effect_estimation", e)
})

# ================================================================
# TEST 6 — Fix #8: plot usa mu invece di beta, usa domain_name reale
# (verifica visiva — check che non crashi)
# ================================================================
cat("\n--- Test 6: plot mu labels (no crash) ---\n")
tryCatch({
  w6   <- fps_weighting(dat$X, treat_grid = dat$t_grid,
                         domain_name = "s", covariates = dat$C)
  eff6 <- fps_effect_estimation(dat$Y, w6)
  p6a  <- plot(eff6, type = "effect")
  p6b  <- plot(eff6, type = "comparison")
  stopifnot(inherits(p6a, "gg") || inherits(p6a, "patchwork"))
  stopifnot(inherits(p6b, "gg") || inherits(p6b, "patchwork"))
  pass("6", "plot type='effect' e 'comparison' non crashano: OK")
  cat("       >> Verifica visiva: y-label deve essere mu-hat(s), non beta(t)\n")
}, error = function(e) {
  fail("6", "Plot type='effect'/'comparison'", e)
})

# ================================================================
# TEST 7 — Fix #9: legende nei plot (effect, significance, bootstrap_slice)
# ================================================================
cat("\n--- Test 7: legende nei plot ---\n")

# 7a: legenda in type="effect" con true_beta
tryCatch({
  w7   <- fps_weighting(dat$X, treat_grid = dat$t_grid, covariates = dat$C)
  eff7 <- fps_effect_estimation(dat$Y, w7,
                                 bootstrap = TRUE, B = 30, seed = 1,
                                 true_beta = dat$true_beta)
  p7a  <- plot(eff7, type = "effect")
  # La legenda è presente quando ci sono più livelli nel dato
  stopifnot(inherits(p7a, "gg"))
  pass("7a", "plot type='effect' con true_beta (legenda attesa): OK")
  cat("       >> Verifica visiva: deve comparire legenda 'Estimated' + 'True'\n")
}, error = function(e) {
  fail("7a", "Plot type='effect' con true_beta", e)
})

# 7b: legenda in type="significance" con true_beta
tryCatch({
  w7b   <- fps_weighting(dat$X, treat_grid = dat$t_grid, covariates = dat$C)
  eff7b <- fps_effect_estimation(dat$Y, w7b,
                                  bootstrap = TRUE, B = 30, seed = 2,
                                  true_beta = dat$true_beta)
  p7b   <- plot(eff7b, type = "significance")
  stopifnot(inherits(p7b, "gg"))
  pass("7b", "plot type='significance' con true_beta (legenda True mu): OK")
  cat("       >> Verifica visiva: legenda deve includere 'True μ'\n")
}, error = function(e) {
  fail("7b", "Plot type='significance' con true_beta", e)
})

# 7c: legenda in bootstrap_slice con true_beta
tryCatch({
  dat_fn3 <- simulate_fps_data(2000, "LL", outcome_type = "functional",
                                include_functional_cov = FALSE, seed = 3)
  w7c   <- fps_weighting(dat_fn3$X, treat_grid = dat_fn3$t_grid,
                          covariates = dat_fn3$C)
  eff7c <- fps_effect_estimation(dat_fn3$Y, w7c,
                                  outcome_t_grid = dat_fn3$t_grid,
                                  bootstrap      = TRUE,
                                  B              = 20, seed = 3,
                                  true_beta      = dat_fn3$true_beta)
  p7c   <- plot(eff7c, type = "bootstrap_slice",
                point = 0.5, which_domain = "outcome")
  stopifnot(inherits(p7c, "gg"))
  pass("7c", "plot type='bootstrap_slice' con true_beta (legenda True): OK")
  cat("       >> Verifica visiva: legenda deve includere 'True'\n")
}, error = function(e) {
  fail("7c", "Plot type='bootstrap_slice' con true_beta", e)
})

# ================================================================
# RIEPILOGO
# ================================================================
cat("\n", strrep("=", 50), "\n", sep = "")
cat("RIEPILOGO TEST\n")
cat(strrep("=", 50), "\n", sep = "")
n_pass <- sum(unlist(results))
n_fail <- sum(!unlist(results))
cat(sprintf("PASS: %d / %d\n", n_pass, n_pass + n_fail))
cat(sprintf("FAIL: %d / %d\n", n_fail, n_pass + n_fail))
if (n_fail == 0) {
  cat("\nTutti i test sono passati!\n")
} else {
  ids_fail <- names(results)[!unlist(results)]
  cat("\nTest falliti:", paste(ids_fail, collapse = ", "), "\n")
}