3 Part 1: Scalar continuous outcome
3.1 Data generation
We simulate \(n = 200\) subjects under setting “LL” with scalar covariates only (no functional covariate) and a scalar continuous outcome.
set.seed(42)
dat <- simulate_fps_data(
n = 200,
setting = "LL",
outcome_type = "scalar",
include_functional_cov = FALSE,
seed = 42
)
cat("Treatment X:", nrow(dat$X), "x", ncol(dat$X), "\n")
#> Treatment X: 200 x 51
cat("Outcome Y: length", length(dat$Y), "\n")
#> Outcome Y: length 200
cat("Scalar C: ", nrow(dat$C), "x", ncol(dat$C), "\n")
#> Scalar C: 200 x 3The true causal effect function is:
\[\mu(s) = 2\sqrt{2}\sin(2\pi s) + \sqrt{2}\cos(2\pi s) + \tfrac{\sqrt{2}}{2}\sin(4\pi s) + \tfrac{\sqrt{2}}{2}\cos(4\pi s)\]
plot(dat$t_grid, dat$true_beta, type = "l", lwd = 2, col = "black",
xlab = "s", ylab = expression(mu(s)), main = "True causal effect")
abline(h = 0, lty = 2, col = "grey")
True causal effect function.
3.2 Weight estimation
The treatment domain treat_domain is inferred automatically from treat_grid when omitted:
w_obj <- fps_weighting(
treatment = dat$X,
treat_grid = dat$t_grid,
domain_name = "s",
pve = 0.95,
covariates = dat$C
)
print(w_obj)
#> Functional Propensity Score Weighting
#> --------------------------------------
#> Observations : 200
#> Treatment FPCs (L) : 4 (96.9% variance explained)
#> Convergence code : 0 (converged)
#> Weights : min = 0.0000 max = 0.0315 mean = 0.00503.2.1 Diagnostic plots
Weight distribution:
plot(w_obj, type = "weights")
Distribution of FPS weights.
Treatment FPCA: scree and eigenfunctions:
plot(w_obj, type = "fpca_treatment")
Treatment FPCA.
Covariate balance: absolute Pearson correlations before (red) and after (blue) weighting. Dashed line at 0.1:
plot(w_obj, type = "balance")
Covariate balance for scalar outcome.
3.3 Effect estimation (analytical CI)
eff <- fps_effect_estimation(
outcome = dat$Y,
fps_object = w_obj,
true_beta = dat$true_beta
)
print(eff)
#> Functional Propensity Score Effect Estimation
#> ----------------------------------------------
#> Outcome type : scalar
#> Treatment FPCs : 4 (96.9% variance explained)
#> Bootstrap CIs : no
#> Beta range : [-3.4264, 3.8265]Weighted vs unweighted comparison (with analytical CI):
plot(eff, type = "comparison")
Weighted vs unweighted causal effect.
3.4 Effect estimation with bootstrap CI
eff_boot <- fps_effect_estimation(
outcome = dat$Y,
fps_object = w_obj,
bootstrap = TRUE,
B = 200,
alpha = 0.05,
true_beta = dat$true_beta,
seed = 123
)Effect with 95% bootstrap CI:
plot(eff_boot, type = "effect")
Causal effect with 95% bootstrap CI.
Significant time points (CI excludes 0):
plot(eff_boot, type = "significance")
Significant regions at alpha = 0.05.
3.5 Binary outcome
When the outcome is binary (0/1), fps_effect_estimation automatically detects it and fits a linear probability model (weighted least squares), returning the average treatment effect on the probability scale.
Y_bin <- as.integer(dat$Y > median(dat$Y))
eff_bin <- fps_effect_estimation(Y_bin, w_obj)
print(eff_bin)
#> Functional Propensity Score Effect Estimation
#> ----------------------------------------------
#> Outcome type : binary
#> Treatment FPCs : 4 (96.9% variance explained)
#> Bootstrap CIs : no
#> Beta range : [-0.1644, 0.1944]Weighted vs unweighted comparison (with analytical CI):
plot(eff_bin, type = "comparison")
Binary outcome: weighted vs unweighted.
3.6 Scalar outcome with a functional covariate
When a functional covariate \(D(s)\) is available, it enters the balancing step through its own FPC scores. We use \(n = 2000\) to ensure a stable weight solution (the constraint dimension grows with the number of FPCs).
dat_fc <- simulate_fps_data(
n = 2000,
setting = "LL",
outcome_type = "scalar",
include_functional_cov = TRUE,
seed = 7
)w_fc <- fps_weighting(
treatment = dat_fc$X,
treat_grid = dat_fc$t_grid,
domain_name = "s",
pve = 0.95,
covariates = list(
scalar = dat_fc$C,
functional = list(dat_fc$D)
),
cov_grids = list(dat_fc$t_grid),
cov_pve = 0.95
)
print(w_fc)
#> Functional Propensity Score Weighting
#> --------------------------------------
#> Observations : 2000
#> Treatment FPCs (L) : 4 (96.5% variance explained)
#> Convergence code : 0 (converged)
#> Weights : min = 0.0000 max = 0.0288 mean = 0.0005
#> Functional covariates : 1 (FPCs retained: 4)The FPC scores of the functional covariate are automatically named Func_Cov1_FPC1, Func_Cov1_FPC2, … in the balance plot:
plot(w_fc, type = "balance")
Balance with functional covariate.
eff_fc <- fps_effect_estimation(
outcome = dat_fc$Y,
fps_object = w_fc,
true_beta = dat_fc$true_beta
)
plot(eff_fc, type = "comparison")
3.7 All four simulation settings
The table below shows the Integrated Squared Error (ISE) and Integrated Squared Bias (ISB) of the weighted vs unweighted estimate across settings.
settings <- c("LL", "LN", "NL", "NN")
results_tbl <- lapply(settings, function(s) {
d <- simulate_fps_data(200, setting = s, outcome_type = "scalar",
include_functional_cov = FALSE, seed = 1)
w <- fps_weighting(d$X, treat_grid = d$t_grid,
covariates = d$C)
eff <- fps_effect_estimation(d$Y, w, true_beta = d$true_beta)
data.frame(
Setting = s,
ISE_weighted = round(mean((eff$beta - d$true_beta)^2), 4),
ISE_unweighted = round(mean((eff$beta_unweighted - d$true_beta)^2), 4),
ISB_weighted = round(mean(eff$beta - d$true_beta)^2, 6),
ISB_unweighted = round(mean(eff$beta_unweighted - d$true_beta)^2, 6)
)
})
knitr::kable(
do.call(rbind, results_tbl),
caption = "ISE and ISB for weighted vs unweighted estimate across settings"
)| Setting | ISE_weighted | ISE_unweighted | ISB_weighted | ISB_unweighted |
|---|---|---|---|---|
| LL | 0.1431 | 0.4140 | 0e+00 | 1e-06 |
| LN | 0.1471 | 0.3976 | 0e+00 | 3e-06 |
| NL | 0.0666 | 0.3082 | 2e-06 | 5e-06 |
| NN | 0.0702 | 0.2902 | 2e-06 | 3e-06 |
