diff --git a/.Rbuildignore b/.Rbuildignore index 486398df..a34e3d9d 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -18,4 +18,5 @@ ^data-raw$ ^cell-D1\.rds$ ^fect_.*\.tar\.gz$ -^fect\.Rcheck$ \ No newline at end of file +^fect\.Rcheck$ +^tests/coverage-study$ \ No newline at end of file diff --git a/.gitignore b/.gitignore index 8fe8c4fc..85858039 100644 --- a/.gitignore +++ b/.gitignore @@ -29,6 +29,9 @@ vignettes/*.html vignettes/*.pdf vignettes/*_cache/ vignettes/*_files/ +vignettes/*.rmarkdown +vignettes/site_libs/ +vignettes/.quarto/ vignettes/_back/** vignettes/_book/** !vignettes/_book/rscript/ diff --git a/ARCHITECTURE.md b/ARCHITECTURE.md index 1ea25560..0af5f1f1 100644 --- a/ARCHITECTURE.md +++ b/ARCHITECTURE.md @@ -1,10 +1,14 @@ # Architecture — fect > Generated by scriber for run `2026-04-30-architecture-regen-v241` on 2026-04-30. +> Manual v2.4.2 patches applied 2026-05-01 (warm-start C++ infrastructure; +> ci.method extensions) and 2026-05-02 (CFE `fit_init` plumbing on +> `complex_fe_ub` + `cfe_iter`, dormant). Full regen via scriber +> deferred until next material module change. ## Overview -fect is an R package for estimating causal effects in panel data using counterfactual imputation methods (Fixed Effects Counterfactual Estimators). It targets causal panel analysis with binary treatments under the parallel trends assumption, supporting treatment switching and limited carryover effects. The core abstraction is counterfactual imputation: impute missing potential outcomes Y(0) for treated units using control units, then compute the Average Treatment Effect on the Treated (ATT) as the gap between observed and imputed outcomes. The package is an R/C++ hybrid using Rcpp and RcppArmadillo for numerically intensive linear algebra (SVD, EM iterations, matrix factorization). Key external dependencies include fixest (initial FE regression), ggplot2 (visualization), doParallel/doFuture/future.apply (parallel bootstrap), MASS (generalized inverse), and mvtnorm (multivariate normal draws). Estimation methods include FE (fixed effects), IFE (interactive fixed effects / factor model), MC (matrix completion via nuclear norm regularization), CFE (complex fixed effects with structured covariates), and wrappers for modern DID estimators. Version 2.4.1. References: Liu, Wang, and Xu (2024); Chiu et al. (2026). +fect is an R package for estimating causal effects in panel data using counterfactual imputation methods (Fixed Effects Counterfactual Estimators). It targets causal panel analysis with binary treatments under the parallel trends assumption, supporting treatment switching and limited carryover effects. The core abstraction is counterfactual imputation: impute missing potential outcomes Y(0) for treated units using control units, then compute the Average Treatment Effect on the Treated (ATT) as the gap between observed and imputed outcomes. The package is an R/C++ hybrid using Rcpp and RcppArmadillo for numerically intensive linear algebra (SVD, EM iterations, matrix factorization). Key external dependencies include fixest (initial FE regression), ggplot2 (visualization), doParallel/doFuture/future.apply (parallel bootstrap), MASS (generalized inverse), and mvtnorm (multivariate normal draws). Estimation methods include FE (fixed effects), IFE (interactive fixed effects / factor model), MC (matrix completion via nuclear norm regularization), CFE (complex fixed effects with structured covariates), and wrappers for modern DID estimators. Version 2.4.2. References: Liu, Wang, and Xu (2024); Chiu et al. (2026). --- @@ -121,7 +125,7 @@ graph TD | `R/interFE.R` (515 lines) | API | Standalone interactive fixed effects estimator | `interFE()` | no | | `R/did_wrapper.R` (656 lines) | API | Modern DID estimator wrappers (did, DIDmultiplegtDYN) | `did_wrapper()` | no | | `R/fect_mspe.R` (370 lines) | API | MSPE computation for model comparison | `fect_mspe()` | no | -| `R/po-estimands.R` (1,123 lines) | API | Two-tier post-hoc estimand surface: long-form imputed PO accessor and typed dispatcher; `vartype` enum extended to `"parametric"` in v2.4.1 | `estimand()`, `imputed_outcomes()` | yes (new v2.4.0) | +| `R/po-estimands.R` (1,236 lines) | API | Two-tier post-hoc estimand surface: long-form imputed PO accessor and typed dispatcher; `vartype` enum extended to `"parametric"` in v2.4.1; `ci.method` enum extended to `c("basic","percentile","bc","normal")` with per-type defaults via NULL trigger in v2.4.2; hard-error on bootstrap cell-drop pathology in `log.att`/`aptt` | `estimand()`, `imputed_outcomes()` | yes | | `R/fe.R` (955 lines) | Estimation | Interactive Fixed Effects / factor model estimation | `fect_fe()` | no | | `R/mc.R` (807 lines) | Estimation | Matrix Completion via nuclear norm regularization | `fect_mc()` | no | | `R/cfe.R` (1,173 lines) | Estimation | Complex Fixed Effects with structured covariates | `fect_cfe()` | no | @@ -155,8 +159,8 @@ graph TD | `src/ife.cpp` (534 lines) | C++ Core | IFE algorithm: `inter_fe()`, `inter_fe_ub()`, `inter_fe_d()` | (Rcpp exports) | no | | `src/ife_sub.cpp` (577 lines) | C++ Core | IFE sub-routines: SVD factor estimation, EM iterations, alternating minimization | (internal) | no | | `src/mc.cpp` (223 lines) | C++ Core | Matrix completion: `inter_fe_mc()`, nuclear norm penalization | (Rcpp exports) | no | -| `src/cfe.cpp` (203 lines) | C++ Core | Complex FE: `complex_fe_ub()` | (Rcpp exports) | no | -| `src/cfe_sub.cpp` (564 lines) | C++ Core | Complex FE sub-routines: `cfe_iter()`, structured covariate handling | (internal) | no | +| `src/cfe.cpp` (203 lines) | C++ Core | Complex FE: `complex_fe_ub()`. v2.4.2: optional `fit_init` matrix to seed EM (dormant; mirrors IFE/MC infra) | (Rcpp exports) | no | +| `src/cfe_sub.cpp` (564 lines) | C++ Core | Complex FE sub-routines: `cfe_iter()`, structured covariate handling. v2.4.2: optional `fit_init` matrix replaces default `fit = Y0` initialization (dormant) | (internal) | no | | `src/fe_sub.cpp` (291 lines) | C++ Core | Shared FE utilities: `Y_demean()`, `panel_beta()`, `panel_factor()`, `panel_FE()`, `XXinv()` | (internal) | no | | `src/binary_sub.cpp` (539 lines) | C++ Core | Probit model sub-routines for binary outcomes | (internal) | no | | `src/binary_qr.cpp` (347 lines) | C++ Core | QR-based probit estimation | (internal) | no | @@ -268,8 +272,8 @@ graph TD | `fect.default()` | `R/default.R` | `fect.formula()`, user | `fect_cv()`, `fect_fe()`, `fect_mc()`, `fect_cfe()`, `fect_boot()`, `diagtest()` | yes | Workhorse: validation, preprocessing, method routing, inference, diagnostics; added `W.est`/`W.agg`/`carryover.rm` | | `fect_fe()` | `R/fe.R` | `fect.default()`, `fect_cv()`, `fect_boot()`, `r.cv.rolling()` | `inter_fe_ub()`, `inter_fe_d_qr_ub()` (C++) | no | IFE estimation (factor model with r latent factors) | | `fect_mc()` | `R/mc.R` | `fect.default()`, `fect_cv()`, `fect_boot()` | `inter_fe_mc()` (C++) | no | Matrix completion estimation (nuclear norm regularization) | -| `fect_cfe()` | `R/cfe.R` | `fect.default()`, `fect_boot()`, `r.cv.rolling()` | `complex_fe_ub()` (C++) | no | Complex FE with structured covariates (Z, Q, gamma, kappa) | -| `fect_nevertreated()` | `R/fect_nevertreated.R` | `fect.default()` | `fect_fe()`, `fect_mc()`, `fect_cfe()`, `.fect_make_future_cluster()` | yes | Wrapper for never-treated-only estimation sample; PSOCK cluster via shared helper (v2.3.3) | +| `fect_cfe()` | `R/cfe.R` | `fect.default()`, `fect_boot()`, `r.cv.rolling()` | `complex_fe_ub()` (C++) | no | Complex FE with structured covariates (Z, Q, gamma, kappa); v2.4.2 dormant `fit.init = NULL` parameter threaded through to C++ | +| `fect_nevertreated()` | `R/fect_nevertreated.R` | `fect.default()` | `fect_fe()`, `fect_mc()`, `fect_cfe()`, `.fect_make_future_cluster()` | yes | Wrapper for never-treated-only estimation sample; PSOCK cluster via shared helper (v2.3.3); v2.4.2 dormant `fit.init = NULL` parameter, sliced to control units | | `fect_cv()` | `R/cv.R` | `fect.default()` | `fect_fe()`, `fect_mc()`, `.fect_apply_cv_rule()`, `.fect_cv_aggregate_folds()` | yes | Cross-validation to select r (IFE) or lambda (MC); rolling default (v2.3.0), 1-SE rule (v2.3.0) | | `r.cv.rolling()` | `R/cv-rolling.R` | user / exported | `fect_fe()`, `fect_cfe()`, `.fect_apply_cv_rule()`, `.fect_make_future_cluster()` | yes (new v2.3.0) | Standalone rolling-window CV for rank selection; per-fold unit sampling; closes AR forward-leakage | | `fect_boot()` | `R/boot.R` | `fect.default()` | `fect_fe()`, `fect_mc()`, `fect_cfe()`, `impute_Y0()`, `valid_controls()`, `.fect_make_future_cluster()` | yes | Bootstrap/jackknife/parametric inference with PSOCK retry-with-backoff (v2.3.3) | @@ -279,7 +283,7 @@ graph TD | `did_wrapper()` | `R/did_wrapper.R` | user / exported | `fixest::feols()`, `did::att_gt()` | no | Modern DID estimator wrappers | | `plot.fect()` | `R/plot.R` | user / exported | ggplot2, `.modern_theme()` | yes | 14 plot types; modernized defaults, `legacy.style`/`highlight`/`highlight.fill` (v2.3.2) | | `esplot()` | `R/esplot.R` | user / exported | ggplot2, `.modern_theme()` | yes | Standalone event-study plot; modern theme integration (v2.3.2) | -| `estimand()` | `R/po-estimands.R` | user / exported (new v2.4.0) | `imputed_outcomes()`, internal aggregators | yes (new v2.4.0) | Typed dispatcher: `att`, `att.cumu`, `aptt`, `log.att` across `event.time`/`cohort`/`calendar.time`/`overall`; `vartype` enum extended to `"parametric"` in v2.4.1 | +| `estimand()` | `R/po-estimands.R` | user / exported (new v2.4.0) | `imputed_outcomes()`, internal aggregators, `.compute_ci()` | yes | Typed dispatcher: `att`, `att.cumu`, `aptt`, `log.att` across `event.time`/`cohort`/`calendar.time`/`overall`; `vartype` enum extended to `"parametric"` in v2.4.1; `ci.method` enum extended to `c("basic","percentile","bc","normal")` with per-type defaults via NULL trigger in v2.4.2 | | `imputed_outcomes()` | `R/po-estimands.R` | user / exported (new v2.4.0); `estimand()` | internal helpers | yes (new v2.4.0) | Long-form accessor for cell-level imputed PO surface; `cells =` filter (logical / formula); `direction = c("on", "off")`; `eff_debias` slot support | | `effect()` | `R/effect.R` | user / exported | (internal helpers) | yes (soft-deprecated v2.4.0) | Treatment effect decomposition; emits one-time-per-session deprecation message: *"`effect()` is soft-deprecated as of fect 2.4.0; prefer `estimand(fit, "att.cumu", ...)` API."* Removal not before v3.0.0 | | `att.cumu()` | `R/cumu.R` | user / exported | (internal helpers) | yes (soft-deprecated v2.4.0, `n_cells` fix v2.4.1) | Cumulative ATT; emits same one-time deprecation; `n_cells` column fixed in v2.4.1 | @@ -290,7 +294,7 @@ graph TD | `diagtest()` | `R/diagtest.R` | `fect.default()` | — | yes | Pre-trend, placebo, carryover, equivalence tests; `drop=FALSE` guard (v2.3.3) | | `inter_fe_ub()` | `src/ife.cpp` | `fect_fe()` | `panel_factor()`, `fe_ub()`, `Y_demean()` | no | C++ IFE with unbalanced panels (EM algorithm) | | `inter_fe_mc()` | `src/mc.cpp` | `fect_mc()` | `panel_FE()`, `Y_demean()` | no | C++ matrix completion with nuclear norm | -| `complex_fe_ub()` | `src/cfe.cpp` | `fect_cfe()` | `cfe_iter()`, `Y_demean()` | no | C++ complex FE estimation | +| `complex_fe_ub()` | `src/cfe.cpp` | `fect_cfe()` | `cfe_iter()`, `Y_demean()` | no | C++ complex FE estimation; v2.4.2 optional `fit_init` parameter (NULL default = byte-identical to pre-v2.4.2) | | `panel_factor()` | `src/fe_sub.cpp` | `inter_fe_ub()`, others | SVD routines | no | Extract latent factors via SVD | | `panel_FE()` | `src/fe_sub.cpp` | `inter_fe_mc()`, others | soft-thresholding | no | Nuclear norm regularization / soft-thresholding | | `Y_demean()` | `src/fe_sub.cpp` | most C++ estimators | (arma operations) | no | Remove unit and/or time fixed effects | diff --git a/DESCRIPTION b/DESCRIPTION index 88118e6c..62405a1c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,18 +1,17 @@ Package: fect Type: Package Title: Fixed Effects Counterfactual Estimators -Version: 2.4.1 -Date: 2026-04-29 +Version: 2.4.5 +Date: 2026-05-29 Authors@R: - c(person("Licheng", "Liu", , "lichengl@stanford.edu", role = c("aut")), + c(person("Yiqing", "Xu", , "yiqingxu@stanford.edu", role = c("aut", "cre")), + person("Licheng", "Liu", , "lichengl@stanford.edu", role = c("aut")), person("Ziyi", "Liu", , "zyliu2023@berkeley.edu", role = c("aut")), - person("Ye", "Wang", , "yezhehuzhi@gmail.com", role = c("aut")), - person("Yiqing", "Xu", , "yiqingxu@stanford.edu", role = c("aut", "cre")), + person("Ye", "Wang", , "yezhehuzhi@gmail.com", role = c("aut")), person("Tianzhu", "Qin", , "tianzhu@stanford.edu", role = c("aut")), person("Shiyun", "Hu", , "hushiyun@pku.edu.cn", role = c("aut")), person("Rivka", "Lipkovitz", , "rivkal@mit.edu", role = c("aut"))) -Author: Licheng Liu [aut], Ziyi Liu [aut], Ye Wang [aut], Yiqing Xu [aut, cre], - Tianzhu Qin [aut], Shiyun Hu [aut], Rivka Lipkovitz [aut] +Author: Yiqing Xu [aut, cre], Licheng Liu [aut], Ziyi Liu [aut], Ye Wang [aut], Tianzhu Qin [aut], Shiyun Hu [aut], Rivka Lipkovitz [aut] Maintainer: Yiqing Xu Description: Provides tools for estimating causal effects in panel data using counterfactual methods, as well as other modern DID estimators. It is designed for causal panel analysis with binary treatments under the parallel trends assumption. The package supports scenarios where treatments can switch on and off and allows for limited carryover effects. It includes several imputation estimators, such as Gsynth (Xu 2017), linear factor models, and the matrix completion method. Detailed methodology is described in Liu, Wang, and Xu (2024) and Chiu et al. (2025) . Optionally integrates with the "HonestDiDFEct" package for sensitivity analyses compatible with imputation estimators. "HonestDiDFEct" is not on CRAN but can be obtained from . URL: https://yiqingxu.org/packages/fect/, https://github.com/xuyiqing/fect @@ -46,9 +45,10 @@ Suggests: panelView, testthat (>= 3.0.0), did, - DIDmultiplegtDYN, + DIDmultiplegtDYN, ggrepel, - HonestDiDFEct + HonestDiDFEct, + withr Depends: R (>= 4.1.0) LinkingTo: Rcpp, RcppArmadillo RoxygenNote: 7.3.3 diff --git a/NEWS.html b/NEWS.html deleted file mode 100644 index 3ee1bac1..00000000 --- a/NEWS.html +++ /dev/null @@ -1,437 +0,0 @@ - - - - - - - - - - - - - -NEWS - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- - - - - - - -
-

fect 2.0.4

-
    -
  • Add new plot type = "hte"
    • -
-
-
-

fect 2.0.0

-
    -
  • New syntax
    • -
  • Merged in gsynth
    • -
-
-
-

fect 1.0.0

-
    -
  • First CRAN version
    • -
  • Fixed bugs
    • -
-
-
-

fect 0.6.5

-
    -
  • Replace fastplm with fixest for fixed effects estimation
    • -
  • Added plots for heterogeneous treatment effects
    • -
  • Fixed bugs
    • -
-
-
-

fect 0.4.1

-
    -
  • Added a NEWS.md file to track changes to the -package.
    • -
-
- - - - -
- - - - - - - - - - - - - - - diff --git a/NEWS.md b/NEWS.md index c5879634..e1f53b11 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,175 @@ +# fect 2.4.5 + +* Add `group.fe` to `fect()` for absorbing coarser fixed effects, such as state FE with county-level data. Closes #139. Clustered SE defaults to `group.fe[1]`; override with `cl = ""`. +* Fix `method = "cfe"` with `force = "time"` or `"unit"`, which previously triggered an `Index out of bounds` error. `force = "two-way"` is byte-equivalent. +* Remove unused `sfe` argument and `R/polynomial.R`. + +# fect 2.4.4 + +- `fect()` now returns `$sample`, a logical matrix (same dims as `$Y.dat`) marking cells used in any part of the estimation procedure (main fit, placebo/carryover/balance tests). + +# fect 2.4.3 + +* Fix `future.globals.maxSize` overrun in parallel bootstrap: `quiet_nonpara` + wrapper no longer captures `fect_boot()`'s full frame. +* Raise `future.globals.maxSize` to 2 GiB locally inside the parallel block. + +# fect 2.4.2 + +## New: `ci.method` argument on `fect()`; legacy `quantile.CI` soft-deprecated + +* `fect()` gains a `ci.method = c("normal", "basic")` argument. Default + `"normal"` (Wald: `θ̂ ± z · SE`) preserves the v2.4.1 default behaviour + byte-equivalently. `"basic"` (reflected pivot: `2 · θ̂ − quantile(boot, …)`) + is the literature-standard "percentile" CI per @davison_hinkley1997 §5.2.1 + and what `boot::boot.ci(type = "basic")` returns. All CIs in fect's + returned `est.*` slots use the requested method uniformly. +* The legacy `quantile.CI` argument is soft-deprecated. Both legacy values + still work (`quantile.CI = FALSE` → `ci.method = "normal"`; `quantile.CI = TRUE` + → `ci.method = "basic"`) but emit a one-time deprecation warning when + user-supplied. Removal targeted for v2.5.0+. +* `ci.method = "basic"` with `nboots < 1000` emits a tail-CI replicate + warning at fit time (mirrors the `estimand()` `.check_tail_ci_replicates` + gate). The 5th / 195th order statistics that `basic` reads are unstable + at small `B` --- @efron1987 §3 and @diciccio_efron1996 §4 recommend + `B ≥ 1000` for tail-quantile CIs. +* `ci.method = "bca"`, `"bc"`, or `"percentile"` on `fect()` is rejected + with a clear error pointing the user to `estimand(fit, type, ci.method)` + for the full 5-method surface. fect's built-in CI machinery covers the + routine `att` workflow; the alternative estimands (`att.cumu`, `aptt`, + `log.att`) where bias-corrected CIs matter live on the `estimand()` path. + +## New: alternative-estimand additions in `estimand()` + +* New `test = c("none", "placebo", "carryover")` argument evaluates the + requested estimand at pre-treatment placebo cells or early + post-reversal carryover cells, producing a per-event-time series for + credibility checks. Closes issue #131. Auto-pairs `direction = "on"` + with placebo and `direction = "off"` with carryover; auto-validates + the fit (placebo requires `placeboTest = TRUE` at fit time; carryover + requires `carryoverTest = TRUE` + a reversal panel). +* `type = "att.cumu"` rejected with a clear error when `test != "none"` --- + cumulative semantics are defined relative to treatment onset. +* `ci.method` enum extended from `c("basic", "percentile")` to + `c("basic", "percentile", "bc", "bca", "normal")`. New methods: + - `"bc"` --- bias-corrected percentile (Efron 1987 minus acceleration) + - `"bca"` --- bias-corrected accelerated (Efron 1987 in full); cell-level + jackknife computes the acceleration with no extra refits + - `"normal"` --- Wald CI `θ̂ ± z · SE` +* `ci.method` now defaults to `NULL`, which triggers a per-type default: + - `"att"` → `"normal"` + - `"att.cumu"` → `"basic"` (reflected pivot CI; matches Davison-Hinkley 1997 §5.2.1 and `boot::boot.ci(type = "basic")`) + - `"aptt"` → `"bca"` + - `"log.att"` → `"bca"` + Existing scripts that pass `ci.method` explicitly are unaffected. + +## New: `para.error` argument for `vartype = "parametric"` + +* `fect()` gains a `para.error = c("auto", "ar", "empirical", "wild")` + argument selecting the residual-error model the parametric bootstrap + draws from. Replaces the implicit panel-shape-driven dispatch. +* `"auto"` (default) resolves at fit time and stores the resolved label + on `fit$para.error`: + - `"empirical"` on a fully-observed panel + - `"ar"` on a panel with missing cells +* `"ar"` --- the v2.4.1 behavior: AR(1) error process estimated from + control residuals. Works on any panel shape. +* `"empirical"` --- i.i.d. column-resample from the main-fit residual + pool. Requires a fully-observed panel. +* `"wild"` --- Liu 1988 / Mammen 1993 / Cameron-Gelbach-Miller 2008 + unit-level Rademacher sign-flips over the empirical residual pool. + Requires a fully-observed panel; preserves within-unit dependence. +* `para.error` is silently ignored when `vartype != "parametric"`. + +## Changed: tighter EM convergence defaults + +* `tol`: default flipped from `1e-3` to **`1e-5`**. +* `max.iteration`: default flipped from `1000` to **`5000`**. + +The pre-v2.4.2 default `tol = 1e-3` halted IFE/CFE EM well before +convergence: on factor-DGP simdata the EM stopped at iteration 116 +with `att.avg = 2.87`, while running to `tol = 1e-7` (~2000 iters) +produces `att.avg = 2.43` --- an 18% gap between two valid stopping +points of the same procedure on the same data. CFE was worse +(40% gap). The new defaults stop the EM after it has actually +stabilized. + +* **Inference at the old default was already correct.** Coverage + simulations (K=80, known-truth DGP, true τ=3) show empirical + coverage of 0.96 at both old and new defaults for IFE; bootstrap + SE matches empirical SE in both. The fix improves + *reproducibility* and *point-estimate stability across + versions/machines*, not coverage validity. +* **What this means for users**: numerical output from prior versions + remains valid inferentially (CIs still cover correctly), but the + point-estimate values will shift on rerun under v2.4.2 --- typically + by a few percent on canonical IFE, up to 40% on factor-heavy CFE. + The new numbers are closer to the EM's actual converged minimum. +* **Speed cost**: ~2-5x slower main fit and bootstrap on + factor-DGP IFE/CFE because EM iterates more (994 iters at 1e-5 + vs 116 at 1e-3 on simdata). GSC and MC paths unaffected + (they were already converging within the old defaults). +* New `warning()` when EM hits `max.iteration` without satisfying + the tol gate --- alerts users to under-converged fits on hard + cases (e.g., very large N panels, near-collinear factors). + +Set `tol = 1e-3, max.iteration = 1000` explicitly to reproduce +pre-v2.4.2 numerical output exactly. + +## Bug fixes + +* `vartype = "parametric"` × `ci.method ∈ {"basic", "percentile", "bc", + "bca"}` produced 0% coverage CIs through v2.4.1 (the bootstrap + distribution is H₀-centered, but reflection-based CIs assume centering + at θ̂). `estimand()` now applies a variance-preserving location shift + for parametric fits. The `"normal"` ci.method is byte-stable; the + other four now produce nominal coverage. +* `vartype = "jackknife"` was previously rejected by `estimand()` with a + slot-contract error. The slot contract is relaxed; only `ci.method = + "normal"` is accepted (the Wald-style CI from the Tukey SE), with + hard-error guidance pointing at `"bootstrap"` for the full ci.method + surface. +* `log.att` and `aptt` silently dropped bootstrap replicates with + `Y0_b ≤ 0` via `colMeans(..., na.rm = TRUE)`, contaminating the + bootstrap distribution. Both now hard-error with actionable guidance + (pre-transform Y, filter near-zero cells, or use a different + estimand). `estimand("log.att", ...)` additionally hard-errors at the + point-estimate level when any treated cell has `Y_obs ≤ 0` or + `Y0_hat ≤ 0`. +* `vartype = "parametric"` with default `time.component.from = + "notyettreated"` now produces a clearer error that names the user's + literal `method` argument (was: "Parametric bootstrap is not valid + when ..."; now: "vartype = 'parametric' requires time.component.from + = 'nevertreated'. Your call: method = 'fe', time.component.from = + 'notyettreated'."). The reversal-check gate continues to fire first + on reversal panels. +* `R/diagtest.R` "F-test Failed" message → "F-test could not be + computed" --- the test never "failed" in any standard sense; the + matrix arithmetic was undefined for the input. +* Parallel-worker package version warnings (e.g. "package 'mvtnorm' + was built under R version X.Y.Z") suppressed via `clusterEvalQ` + pre-load + targeted `withCallingHandlers`. + +## Other changes + +* `estimand()` warns when `ci.method` `c("basic", "percentile", "bc", + "bca")` is requested on a fit with fewer than 1000 bootstrap + replicates, recommending refit at `nboots = 1000` for stable tail + quantiles (Efron 1987 §3; DiCiccio & Efron 1996 §4). The point + estimate and SE are unaffected; the warning fires on every such + call so the user can decide whether to suppress, refit, or + proceed with caveat. +* `vartype = "jackknife"` with `Nco > 1000` emits a fit-time warning + recommending `vartype = "bootstrap"` for tractability (full + leave-one-out scales linearly in N and is slow at the v2.4.2 EM + convergence defaults). +* `complex_fe_ub` and `cfe_iter` C++ entries gain optional `fit_init` + parameter (NULL default preserves pre-existing cold-start behavior). + This mirrors the existing warm-start infrastructure on + `inter_fe_ub` / `inter_fe_mc` / inner EM helpers. Not exposed to + the public API; reserved for future deferred features. + # fect 2.4.1 ## New: parametric variance support in `estimand()` diff --git a/R/RcppExports.R b/R/RcppExports.R index 7b900b36..8aaa8f0e 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -81,8 +81,8 @@ inter_fe_d_ub <- function(Y, Y_fit0, FE0, X, I, r, force, mniter = 5000L, w = 1. .Call(`_fect_inter_fe_d_ub`, Y, Y_fit0, FE0, X, I, r, force, mniter, w, tol) } -complex_fe_ub <- function(Y, Y0, X_covariates, X_extra_FE, X_Z, X_Q, X_gamma, X_kappa, Zgamma_id, kappaQ_id, I, W_in, beta0, r, force, tol = 1e-5, max_iter = 1000L) { - .Call(`_fect_complex_fe_ub`, Y, Y0, X_covariates, X_extra_FE, X_Z, X_Q, X_gamma, X_kappa, Zgamma_id, kappaQ_id, I, W_in, beta0, r, force, tol, max_iter) +complex_fe_ub <- function(Y, Y0, X_covariates, X_extra_FE, X_Z, X_Q, X_gamma, X_kappa, Zgamma_id, kappaQ_id, I, W_in, beta0, r, force, tol = 1e-5, max_iter = 1000L, fit_init = NULL) { + .Call(`_fect_complex_fe_ub`, Y, Y0, X_covariates, X_extra_FE, X_Z, X_Q, X_gamma, X_kappa, Zgamma_id, kappaQ_id, I, W_in, beta0, r, force, tol, max_iter, fit_init) } YY_adj <- function(YYYY, EEE, I, use_weight, W) { @@ -129,8 +129,8 @@ ife_part <- function(E, r) { .Call(`_fect_ife_part`, E, r) } -cfe_iter <- function(XX, xxinv, X_extra_FE, X_Z, X_Q, X_gamma, X_kappa, Zgamma_id, kappaQ_id, Y, Y0, I, W, beta0, force, r, tolerate, max_iter) { - .Call(`_fect_cfe_iter`, XX, xxinv, X_extra_FE, X_Z, X_Q, X_gamma, X_kappa, Zgamma_id, kappaQ_id, Y, Y0, I, W, beta0, force, r, tolerate, max_iter) +cfe_iter <- function(XX, xxinv, X_extra_FE, X_Z, X_Q, X_gamma, X_kappa, Zgamma_id, kappaQ_id, Y, Y0, I, W, beta0, force, r, tolerate, max_iter, fit_init = NULL) { + .Call(`_fect_cfe_iter`, XX, xxinv, X_extra_FE, X_Z, X_Q, X_gamma, X_kappa, Zgamma_id, kappaQ_id, Y, Y0, I, W, beta0, force, r, tolerate, max_iter, fit_init) } Y_demean <- function(Y, force) { @@ -161,8 +161,8 @@ inter_fe <- function(Y, X, r, force, beta0_in, tol = 1e-5, max_iter = 500L) { .Call(`_fect_inter_fe`, Y, X, r, force, beta0_in, tol, max_iter) } -inter_fe_ub <- function(Y, Y0, X, I, W_in, beta0, r, force, tol = 1e-5, max_iter = 1000L) { - .Call(`_fect_inter_fe_ub`, Y, Y0, X, I, W_in, beta0, r, force, tol, max_iter) +inter_fe_ub <- function(Y, Y0, X, I, W_in, beta0, r, force, tol = 1e-5, max_iter = 1000L, fit_init = NULL) { + .Call(`_fect_inter_fe_ub`, Y, Y0, X, I, W_in, beta0, r, force, tol, max_iter, fit_init) } fe_ad_iter <- function(Y, Y0, I, W, force, tolerate, max_iter = 500L) { @@ -173,19 +173,19 @@ fe_ad_covar_iter <- function(XX, xxinv, Y, Y0, I, beta0, W, force, tolerate, max .Call(`_fect_fe_ad_covar_iter`, XX, xxinv, Y, Y0, I, beta0, W, force, tolerate, max_iter) } -fe_ad_inter_iter <- function(Y, Y0, I, W, force, mc, r, hard, lambda, tolerate, max_iter = 1000L) { - .Call(`_fect_fe_ad_inter_iter`, Y, Y0, I, W, force, mc, r, hard, lambda, tolerate, max_iter) +fe_ad_inter_iter <- function(Y, Y0, I, W, force, mc, r, hard, lambda, tolerate, max_iter = 1000L, fit_init = NULL) { + .Call(`_fect_fe_ad_inter_iter`, Y, Y0, I, W, force, mc, r, hard, lambda, tolerate, max_iter, fit_init) } -fe_ad_inter_covar_iter <- function(XX, xxinv, Y, Y0, I, W, beta0, force, mc, r, hard, lambda, tolerate, max_iter = 1000L) { - .Call(`_fect_fe_ad_inter_covar_iter`, XX, xxinv, Y, Y0, I, W, beta0, force, mc, r, hard, lambda, tolerate, max_iter) +fe_ad_inter_covar_iter <- function(XX, xxinv, Y, Y0, I, W, beta0, force, mc, r, hard, lambda, tolerate, max_iter = 1000L, fit_init = NULL) { + .Call(`_fect_fe_ad_inter_covar_iter`, XX, xxinv, Y, Y0, I, W, beta0, force, mc, r, hard, lambda, tolerate, max_iter, fit_init) } beta_iter <- function(X, xxinv, Y, r, tolerate, beta0, max_iter) { .Call(`_fect_beta_iter`, X, xxinv, Y, r, tolerate, beta0, max_iter) } -inter_fe_mc <- function(Y, Y0, X, I, W_in, beta0, r, lambda, force, tol = 1e-5, max_iter = 1000L) { - .Call(`_fect_inter_fe_mc`, Y, Y0, X, I, W_in, beta0, r, lambda, force, tol, max_iter) +inter_fe_mc <- function(Y, Y0, X, I, W_in, beta0, r, lambda, force, tol = 1e-5, max_iter = 1000L, fit_init = NULL) { + .Call(`_fect_inter_fe_mc`, Y, Y0, X, I, W_in, beta0, r, lambda, force, tol, max_iter, fit_init) } diff --git a/R/boot.R b/R/boot.R index 18f33768..45149d85 100644 --- a/R/boot.R +++ b/R/boot.R @@ -26,6 +26,39 @@ basic_ci_alpha <- function(theta, boots, alpha) { ci_mat } +## Reflected pivot CI on a (possibly H0-centered) bootstrap distribution. +## Mirrors the location-shift fix in R/po-estimands.R (commit b4e9fbf): +## when `shift = TRUE` (i.e., vartype == "parametric"), shift the boot +## distribution row-wise from mean ~ 0 (H0) to mean ~ theta (H1) before +## computing the basic interval [2*theta - q_high, 2*theta - q_low]. The +## shift is variance-preserving, so the SE computed elsewhere on the +## unshifted boot is unaffected; the H0-based p-value (computed via +## get.pvalue() on the unshifted boot) is also unchanged. +## +## - theta: vector of point estimates (length p) +## - boots: p x B matrix of bootstrap draws +## - alpha: significance level (e.g., 0.05 for 95% CI; 0.10 for 90% CI bound) +## - shift: if TRUE, apply the parametric H0 -> H1 location shift +.basic_ci_shifted <- function(theta, boots, alpha, shift = FALSE) { + if (isTRUE(shift) && is.matrix(boots) && nrow(boots) > 0L) { + rm <- rowMeans(boots, na.rm = TRUE) + boots <- boots - rm + theta + } + ci_mat <- basic_ci_alpha(theta, boots, alpha) + colnames(ci_mat) <- c("CI.lower", "CI.upper") + ci_mat +} + +## Single-CI version: theta scalar, boots vector. Same shift semantics. +.basic_ci_shifted_one <- function(theta, boots, alpha, shift = FALSE) { + if (isTRUE(shift) && length(boots) > 0L) { + boots <- boots - mean(boots, na.rm = TRUE) + theta + } + qs <- quantile(boots, c(1 - alpha / 2, alpha / 2), na.rm = TRUE) + c(2 * theta - unname(qs[1]), + 2 * theta - unname(qs[2])) +} + # Reduce closure payload before parallel export by keeping only symbols # that the function body actually references from its local frame. trim_closure_env <- function(fun) { @@ -75,7 +108,6 @@ fect_boot <- function( balance.period = NULL, method = "ife", degree = 2, - sfe = NULL, cfe = NULL, X.extra.FE = NULL, X.Z = NULL, @@ -109,6 +141,7 @@ fect_boot <- function( carryoverTest = 0, carryover.period = NULL, vartype = "bootstrap", + para.error = "auto", quantile.CI = FALSE, nboots = 200, parallel = TRUE, @@ -551,6 +584,16 @@ fect_boot <- function( if (vartype == "jackknife") { nboots <- N + if (N > 1000) { + warning( + "vartype = \"jackknife\" with N = ", N, " requires ", N, + " leave-one-out refits and will be slow at the v2.4.2 EM ", + "convergence defaults (tol = 1e-5, max.iteration = 5000). ", + "Consider vartype = \"bootstrap\" (B = 1000 typically faster ", + "than full leave-one-out at N > 500) for tractability.", + call. = FALSE + ) + } } ## bootstrapped estimates @@ -772,7 +815,13 @@ fect_boot <- function( } else if ( binary == FALSE & method %in% c("gsynth", "ife", "cfe") & vartype == "parametric" ) { - message("Parametric Bootstrap \n") + ## Resolve para.error = "auto" to the concrete mode for this dataset. + para.error.resolved <- if (identical(para.error, "auto")) { + if (0 %in% I) "ar" else "empirical" + } else { + para.error + } + message("Parametric Bootstrap (para.error = \"", para.error.resolved, "\") \n") sum.D <- colSums(out$D) id.tr <- which(sum.D > 0) I.tr <- as.matrix(out$I[, id.tr]) @@ -893,11 +942,13 @@ fect_boot <- function( if (do_parallel_boot) { ## Phase A: future_lapply (was foreach %dopar%, which inherited whatever ## backend the global foreach registry held — see notes/ stage-1). - error.list <- future.apply::future_lapply( - seq_len(nboots), - FUN = function(j) draw.error(), - future.seed = TRUE, - future.packages = c("fect", "mvtnorm", "fixest") + error.list <- .fect_with_quiet_pkg_warnings( + future.apply::future_lapply( + seq_len(nboots), + FUN = function(j) draw.error(), + future.seed = TRUE, + future.packages = c("fect", "mvtnorm", "fixest") + ) ) error.tr <- abind(error.list, along = 3) } else { @@ -910,7 +961,7 @@ fect_boot <- function( } } - if (0 %in% I) { + if (para.error.resolved == "ar") { ## calculate vcov of ep_tr na.sum <- sapply(1:nboots, function(vec) { sum(is.na(c(error.tr[,, vec]))) @@ -957,7 +1008,9 @@ fect_boot <- function( ## get the error for the treated and control error.tr.boot <- matrix(NA, TT, Ntr) - if (0 %in% I) { + if (para.error.resolved == "ar") { + ## Path AR: draw from MVN with AR-vcov estimated from Loop 1 pool. + ## Works for fully-observed and missing-data panels. for (w in 1:Ntr) { error.tr.boot[, w] <- t(rmvnorm( n = 1, @@ -974,7 +1027,10 @@ fect_boot <- function( method = "svd" )) error.co.boot[which(as.matrix(I[, fake.co]) == 0)] <- 0 - } else { + + } else if (para.error.resolved == "empirical") { + ## Path empirical: column-resample from the Loop 1 pool. + ## Requires fully-observed panel (validated at fit time). for (w in 1:Ntr) { error.tr.boot[, w] <- error.tr[, w, @@ -982,6 +1038,27 @@ fect_boot <- function( ] } error.co.boot <- error.co[, sample(1:Nco, Nco, replace = TRUE)] + + } else { + ## Path wild: unit-level Rademacher sign-flip on Loop 1 pool draws. + ## Preserves within-unit AR structure (sign applied to entire time series). + ## Requires fully-observed panel (validated at fit time). + ## This is variant-(i): treated cells receive error.tr.boot (from Loop 1 pool), + ## NOT the observed treatment effect. The bootstrap distribution is H0-centered. + ## The po-estimands.R location-shift (commit b4e9fbf) re-centers at theta-hat. + signs <- sample(c(-1, 1), Ntr, replace = TRUE) + co_signs <- sample(c(-1, 1), Nco, replace = TRUE) + + for (w in 1:Ntr) { + j <- sample(1:dim(error.tr)[3], 1, replace = TRUE) + error.tr.boot[, w] <- signs[w] * error.tr[, w, j] + } + + co_picks <- sample(1:Nco, Nco, replace = TRUE) + error.co.boot <- error.co[, co_picks, drop = FALSE] + ## Apply per-unit sign to entire column (unit's full time series). + ## t(t(M) * v) multiplies column k of M by v[k]. + error.co.boot <- t(t(error.co.boot) * co_signs) } Y.boot <- fit.out[, id.boot] @@ -1127,8 +1204,11 @@ fect_boot <- function( } } else { one.nonpara <- function(num = NULL) { - ## bootstrap + ## Y.input is what gets passed to the per-method bootstrap refit. + ## For case bootstrap and jackknife it is just the original Y. + Y.input <- Y if (is.null(num)) { + ## case bootstrap (resample units with replacement) if (is.null(cl)) { if (hasRevs == 0) { if (Nco > 0) { @@ -1282,7 +1362,7 @@ fect_boot <- function( if (method == "gsynth") { boot <- try( fect_nevertreated( - Y = Y[, boot.id], + Y = Y.input[, boot.id], X = X.boot, D = D.boot, W = W.boot, @@ -1326,7 +1406,7 @@ fect_boot <- function( } else if (method == "ife") { boot <- try( fect_fe( - Y = Y[, boot.id], + Y = Y.input[, boot.id], X = X.boot, D = D.boot, W = W.boot, @@ -1370,7 +1450,7 @@ fect_boot <- function( } else if (method == "mc") { boot <- try( fect_mc( - Y = Y[, boot.id], + Y = Y.input[, boot.id], X = X.boot, D = D[, boot.id], W = W.boot, @@ -1416,7 +1496,7 @@ fect_boot <- function( X.kappa.boot <- X.kappa[, boot.id, , drop = FALSE] boot <- try( fect_cfe( - Y = Y[, boot.id], + Y = Y.input[, boot.id], X = X.boot, D = D.boot, W = W.boot, @@ -1559,9 +1639,23 @@ fect_boot <- function( options(doFuture.rng.onMisuse = "ignore") on.exit(options(doFuture.rng.onMisuse = old_rng_misuse), add = TRUE) + ## v2.4.3: bump future.globals.maxSize locally to 2 GiB for the + ## parallel block. Belt-and-braces guard for very large panels + ## (high N*T, large factor rank, dense covariates) whose per-worker + ## export can exceed the 500 MiB default even after the trim below. + ## Honour any larger user-set cap via max(). + old_future_max <- getOption("future.globals.maxSize", 500 * 1024^2) + options(future.globals.maxSize = max(old_future_max, 2 * 1024^3)) + on.exit(options(future.globals.maxSize = old_future_max), add = TRUE) + quiet_nonpara <- function(j) { suppressMessages(suppressWarnings(one.nonpara(boot.seq[j]))) } + ## v2.4.3: trim the wrapper's closure env so foreach/future export + ## ships only `one.nonpara` (already trimmed at L1600) and `boot.seq`, + ## NOT the full fect_boot() frame (Y, D, X, W, out, ...). Prevents the + ## quiet_nonpara=728MiB blowup reported on IFE + nboots=1000. + quiet_nonpara <- trim_closure_env(quiet_nonpara) run_dopar_retry <- function(idx, workers) { ## Build the PSOCK cluster via the package helper, which bakes @@ -3529,6 +3623,15 @@ fect_boot <- function( } } } else { + ## Single source of truth for the parametric H0 -> H1 location shift + ## downstream. Used by every `quantile.CI == TRUE` branch in this + ## section through the `.basic_ci_shifted()` / `.basic_ci_shifted_one()` + ## helpers (defined near the top of this file). See R/po-estimands.R + ## commit b4e9fbf for the original shift fix on the estimand() side --- + ## the helpers here apply the same shift to fect's built-in CI + ## machinery so fit$est.* slots match estimand() byte-equally. + .is_param <- isTRUE(vartype == "parametric") + se.att <- apply(att.boot, 1, function(vec) sd(vec, na.rm = TRUE)) if (quantile.CI == FALSE) { CI.att <- cbind( @@ -3537,12 +3640,8 @@ fect_boot <- function( ) # normal approximation pvalue.att <- (1 - pnorm(abs(att / se.att))) * 2 } else { - CI.att <- t(apply(att.boot, 1, function(vec) { - 2 * - att[which.max(!is.na(vec))] - - quantile(vec, c(1 - alpha / 2, alpha / 2), na.rm = TRUE) - })) - pvalue.att <- apply(att.boot, 1, get.pvalue) + CI.att <- .basic_ci_shifted(att, att.boot, alpha, .is_param) + pvalue.att <- apply(att.boot, 1, get.pvalue) # original (H0-centered) } #vcov.att <- cov(t(att.boot), use = "pairwise.complete.obs") @@ -3561,9 +3660,7 @@ fect_boot <- function( att + se.att * qnorm(1 - alpha) ) # one-sided } else { - att.bound <- t(apply(att.boot, 1, function(vec) { - quantile(vec, c(alpha, 1 - alpha), na.rm = TRUE) - })) + att.bound <- .basic_ci_shifted(att, att.boot, 2 * alpha, .is_param) } colnames(att.bound) <- c("CI.lower", "CI.upper") @@ -3598,9 +3695,7 @@ fect_boot <- function( ) pvalue.att.off <- (1 - pnorm(abs(att.off / se.att.off))) * 2 } else { - CI.att.off <- t(apply(att.off.boot, 1, function(vec) { - quantile(vec, c(alpha / 2, 1 - alpha / 2), na.rm = TRUE) - })) + CI.att.off <- .basic_ci_shifted(att.off, att.off.boot, alpha, .is_param) pvalue.att.off <- apply(att.off.boot, 1, get.pvalue) } @@ -3639,9 +3734,7 @@ fect_boot <- function( att.off + se.att.off * qnorm(1 - alpha) ) } else { - att.off.bound <- t(apply(att.off.boot, 1, function(vec) { - quantile(vec, c(alpha, 1 - alpha), na.rm = TRUE) - })) + att.off.bound <- .basic_ci_shifted(att.off, att.off.boot, 2 * alpha, .is_param) } colnames(att.off.bound) <- c("CI.lower", "CI.upper") @@ -3659,9 +3752,7 @@ fect_boot <- function( ) # normal approximation pvalue.carry.att <- (1 - pnorm(abs(carry.att / se.carry.att))) * 2 } else { - CI.carry.att <- t(apply(carry.att.boot, 1, function(vec) { - quantile(vec, c(alpha / 2, 1 - alpha / 2), na.rm = TRUE) - })) + CI.carry.att <- .basic_ci_shifted(carry.att, carry.att.boot, alpha, .is_param) pvalue.carry.att <- apply(carry.att.boot, 1, get.pvalue) } @@ -3693,9 +3784,7 @@ fect_boot <- function( ) pvalue.balance.att <- (1 - pnorm(abs(balance.att / se.balance.att))) * 2 } else { - CI.balance.att <- t(apply(balance.att.boot, 1, function(vec) { - quantile(vec, c(alpha / 2, 1 - alpha / 2), na.rm = TRUE) - })) + CI.balance.att <- .basic_ci_shifted(balance.att, balance.att.boot, alpha, .is_param) pvalue.balance.att <- apply(balance.att.boot, 1, get.pvalue) } @@ -3737,11 +3826,9 @@ fect_boot <- function( pnorm(abs(balance.avg.att / se.balance.avg.att))) * 2 } else { - CI.balance.avg.att <- quantile( - balance.avg.att.boot, - c(alpha / 2, 1 - alpha / 2), - na.rm = TRUE - ) + CI.balance.avg.att <- .basic_ci_shifted_one(balance.avg.att, + balance.avg.att.boot, + alpha, .is_param) p.balance.avg.att <- get.pvalue(balance.avg.att.boot) } @@ -3764,9 +3851,8 @@ fect_boot <- function( balance.att + se.balance.att * qnorm(1 - alpha) ) } else { - balance.att.bound <- t(apply(balance.att.boot, 1, function(vec) { - quantile(vec, c(alpha, 1 - alpha), na.rm = TRUE) - })) + balance.att.bound <- .basic_ci_shifted(balance.att, balance.att.boot, + 2 * alpha, .is_param) } colnames(balance.att.bound) <- c("CI.lower", "CI.upper") @@ -3788,16 +3874,12 @@ fect_boot <- function( pnorm(abs(balance.att.placebo / balance.se.placebo))) * 2 } else { - balance.CI.placebo <- quantile( - balance.att.placebo.boot, - c(alpha / 2, 1 - alpha / 2), - na.rm = TRUE - ) - balance.CI.placebo.bound <- quantile( - balance.att.placebo.boot, - c(alpha, 1 - alpha), - na.rm = TRUE - ) + balance.CI.placebo <- .basic_ci_shifted_one(balance.att.placebo, + balance.att.placebo.boot, + alpha, .is_param) + balance.CI.placebo.bound <- .basic_ci_shifted_one(balance.att.placebo, + balance.att.placebo.boot, + 2 * alpha, .is_param) balance.pvalue.placebo <- get.pvalue(balance.att.placebo.boot) } @@ -3830,11 +3912,8 @@ fect_boot <- function( ) p.att.avg.W <- (1 - pnorm(abs(att.avg.W / se.att.avg.W))) * 2 } else { - CI.att.avg.W <- quantile( - att.avg.W.boot, - c(alpha / 2, 1 - alpha / 2), - na.rm = TRUE - ) + CI.att.avg.W <- .basic_ci_shifted_one(att.avg.W, att.avg.W.boot, + alpha, .is_param) p.att.avg.W <- get.pvalue(att.avg.W.boot) } @@ -3865,12 +3944,8 @@ fect_boot <- function( ) pvalue.att.W <- (1 - pnorm(abs(att.on.W / se.att.W))) * 2 } else { - CI.att.W <- t(apply(att.on.W.boot, 1, function(vec) { - quantile(vec, c(alpha / 2, 1 - alpha / 2), na.rm = TRUE) - })) - att.W.bound <- t(apply(att.on.W.boot, 1, function(vec) { - quantile(vec, c(alpha, 1 - alpha), na.rm = TRUE) - })) + CI.att.W <- .basic_ci_shifted(att.on.W, att.on.W.boot, alpha, .is_param) + att.W.bound <- .basic_ci_shifted(att.on.W, att.on.W.boot, 2 * alpha, .is_param) pvalue.att.W <- apply(att.on.W.boot, 1, get.pvalue) } @@ -3935,18 +4010,8 @@ fect_boot <- function( ) pvalue.placebo.w <- (1 - pnorm(abs(att.placebo.W / se.placebo.W))) * 2 } else { - CI.placebo.W <- quantile( - att.placebo.W.boot, - c(alpha / 2, 1 - alpha / 2), - na.rm = TRUE - ) - - CI.placebo.bound.W <- quantile( - att.placebo.W.boot, - c(alpha, 1 - alpha), - na.rm = TRUE - ) - + CI.placebo.W <- .basic_ci_shifted_one(att.placebo.W, att.placebo.W.boot, alpha, .is_param) + CI.placebo.bound.W <- .basic_ci_shifted_one(att.placebo.W, att.placebo.W.boot, 2 * alpha, .is_param) pvalue.placebo.w <- get.pvalue(att.placebo.W.boot) } @@ -3983,12 +4048,8 @@ fect_boot <- function( ) pvalue.att.off.W <- (1 - pnorm(abs(att.off.W / se.att.off.W))) * 2 } else { - CI.att.off.W <- t(apply(att.off.W.boot, 1, function(vec) { - quantile(vec, c(alpha / 2, 1 - alpha / 2), na.rm = TRUE) - })) - att.off.W.bound <- t(apply(att.off.W.boot, 1, function(vec) { - quantile(vec, c(alpha, 1 - alpha), na.rm = TRUE) - })) + CI.att.off.W <- .basic_ci_shifted(att.off.W, att.off.W.boot, alpha, .is_param) + att.off.W.bound <- .basic_ci_shifted(att.off.W, att.off.W.boot, 2 * alpha, .is_param) pvalue.att.off.W <- apply(att.off.W.boot, 1, get.pvalue) } @@ -4037,16 +4098,8 @@ fect_boot <- function( pnorm(abs(att.carryover.W / se.carryover.W))) * 2 } else { - CI.carryover.W <- quantile( - att.carryover.W.boot, - c(alpha / 2, 1 - alpha / 2), - na.rm = TRUE - ) - CI.carryover.bound.W <- quantile( - att.carryover.W.boot, - c(alpha, 1 - alpha), - na.rm = TRUE - ) + CI.carryover.W <- .basic_ci_shifted_one(att.carryover.W, att.carryover.W.boot, alpha, .is_param) + CI.carryover.bound.W <- .basic_ci_shifted_one(att.carryover.W, att.carryover.W.boot, 2 * alpha, .is_param) pvalue.carryover.w <- get.pvalue(att.carryover.W.boot) } @@ -4079,11 +4132,12 @@ fect_boot <- function( ) pvalue.avg <- (1 - pnorm(abs(att.avg / se.avg))) * 2 } else { - CI.avg <- quantile( - att.avg.boot, - c(alpha / 2, 1 - alpha / 2), - na.rm = TRUE - ) + ## ci.method = "basic": reflected pivot interval (with parametric + ## location shift via .basic_ci_shifted_one). NOTE: the legacy + ## quantile.CI = TRUE path here previously returned raw percentile + ## quantiles (an inconsistency with the per-event-time block, which + ## already used basic). v2.4.2 standardizes on basic at both sites. + CI.avg <- .basic_ci_shifted_one(att.avg, att.avg.boot, alpha, .is_param) pvalue.avg <- get.pvalue(att.avg.boot) } @@ -4098,11 +4152,8 @@ fect_boot <- function( ) pvalue.avg.unit <- (1 - pnorm(abs(att.avg.unit / se.avg.unit))) * 2 } else { - CI.avg.unit <- quantile( - att.avg.unit.boot, - c(alpha / 2, 1 - alpha / 2), - na.rm = TRUE - ) + CI.avg.unit <- .basic_ci_shifted_one(att.avg.unit, att.avg.unit.boot, + alpha, .is_param) pvalue.avg.unit <- get.pvalue(att.avg.unit.boot) } @@ -4131,9 +4182,8 @@ fect_boot <- function( pvalue.eff.calendar <- (1 - pnorm(abs(calendar.eff / se.eff.calendar))) * 2 } else { - CI.eff.calendar <- t(apply(calendar.eff.boot, 1, function(vec) { - quantile(vec, c(alpha / 2, 1 - alpha / 2), na.rm = TRUE) - })) + CI.eff.calendar <- .basic_ci_shifted(calendar.eff, calendar.eff.boot, + alpha, .is_param) pvalue.eff.calendar <- apply(calendar.eff.boot, 1, get.pvalue) } est.eff.calendar <- cbind( @@ -4164,9 +4214,9 @@ fect_boot <- function( pnorm(abs(calendar.eff.fit / se.eff.calendar.fit))) * 2 } else { - CI.eff.calendar.fit <- t(apply(calendar.eff.fit.boot, 1, function(vec) { - quantile(vec, c(alpha / 2, 1 - alpha / 2), na.rm = TRUE) - })) + CI.eff.calendar.fit <- .basic_ci_shifted(calendar.eff.fit, + calendar.eff.fit.boot, + alpha, .is_param) pvalue.eff.calendar.fit <- apply(calendar.eff.fit.boot, 1, get.pvalue) } est.eff.calendar.fit <- cbind( @@ -4195,9 +4245,7 @@ fect_boot <- function( ) pvalue.beta <- (1 - pnorm(abs(beta / se.beta))) * 2 } else { - CI.beta <- t(apply(beta.boot, 1, function(vec) { - quantile(vec, c(alpha / 2, 1 - alpha / 2), na.rm = TRUE) - })) + CI.beta <- .basic_ci_shifted(c(beta), beta.boot, alpha, .is_param) pvalue.beta <- apply(beta.boot, 1, get.pvalue) } est.beta <- cbind(c(beta), se.beta, CI.beta, pvalue.beta) @@ -4244,16 +4292,8 @@ fect_boot <- function( ) pvalue.placebo <- (1 - pnorm(abs(att.placebo / se.placebo))) * 2 } else { - CI.placebo <- quantile( - att.placebo.boot, - c(alpha / 2, 1 - alpha / 2), - na.rm = TRUE - ) - CI.placebo.bound <- quantile( - att.placebo.boot, - c(alpha, 1 - alpha), - na.rm = TRUE - ) + CI.placebo <- .basic_ci_shifted_one(att.placebo, att.placebo.boot, alpha, .is_param) + CI.placebo.bound <- .basic_ci_shifted_one(att.placebo, att.placebo.boot, 2 * alpha, .is_param) pvalue.placebo <- get.pvalue(att.placebo.boot) } @@ -4290,16 +4330,8 @@ fect_boot <- function( ) pvalue.carryover <- (1 - pnorm(abs(att.carryover / se.carryover))) * 2 } else { - CI.carryover <- quantile( - att.carryover.boot, - c(alpha / 2, 1 - alpha / 2), - na.rm = TRUE - ) - CI.carryover.bound <- quantile( - att.carryover.boot, - c(alpha, 1 - alpha), - na.rm = TRUE - ) + CI.carryover <- .basic_ci_shifted_one(att.carryover, att.carryover.boot, alpha, .is_param) + CI.carryover.bound <- .basic_ci_shifted_one(att.carryover, att.carryover.boot, 2 * alpha, .is_param) pvalue.carryover <- get.pvalue(att.carryover.boot) } est.carryover <- t(as.matrix(c( @@ -4332,9 +4364,8 @@ fect_boot <- function( ) pvalue.group.att <- (1 - pnorm(abs(out$group.att / se.group.att))) * 2 } else { - CI.group.att <- t(apply(group.att.boot, 1, function(vec) { - quantile(vec, c(alpha / 2, 1 - alpha / 2), na.rm = TRUE) - })) + CI.group.att <- .basic_ci_shifted(c(out$group.att), group.att.boot, + alpha, .is_param) pvalue.group.att <- apply(group.att.boot, 1, get.pvalue) } @@ -4375,13 +4406,9 @@ fect_boot <- function( subgroup.atts + subgroup.se.att * qnorm(1 - alpha) ) } else { - subgroup.CI.att <- t(apply(subgroup.atts.boot, 1, function(vec) { - quantile(vec, c(alpha / 2, 1 - alpha / 2), na.rm = TRUE) - })) + subgroup.CI.att <- .basic_ci_shifted(subgroup.atts, subgroup.atts.boot, alpha, .is_param) subgroup.pvalue.att <- apply(subgroup.atts.boot, 1, get.pvalue) - subgroup.att.bound <- t(apply(subgroup.atts.boot, 1, function(vec) { - quantile(vec, c(alpha, 1 - alpha), na.rm = TRUE) - })) + subgroup.att.bound <- .basic_ci_shifted(subgroup.atts, subgroup.atts.boot, 2 * alpha, .is_param) } subgroup.est.att <- cbind( subgroup.atts, @@ -4434,23 +4461,13 @@ fect_boot <- function( subgroup.atts.off + subgroup.se.att.off * qnorm(1 - alpha) ) } else { - subgroup.CI.att.off <- t(apply( - subgroup.atts.off.boot, - 1, - function(vec) { - quantile(vec, c(alpha / 2, 1 - alpha / 2), na.rm = TRUE) - } - )) - subgroup.pvalue.att.off <- apply( - subgroup.atts.off.boot, - 1, - get.pvalue - ) - subgroup.att.off.bound <- t(apply( - subgroup.atts.off.boot, - 1, - function(vec) quantile(vec, c(alpha, 1 - alpha), na.rm = TRUE) - )) + subgroup.CI.att.off <- .basic_ci_shifted(subgroup.atts.off, + subgroup.atts.off.boot, + alpha, .is_param) + subgroup.pvalue.att.off <- apply(subgroup.atts.off.boot, 1, get.pvalue) + subgroup.att.off.bound <- .basic_ci_shifted(subgroup.atts.off, + subgroup.atts.off.boot, + 2 * alpha, .is_param) } subgroup.est.att.off <- cbind( subgroup.atts.off, @@ -4502,19 +4519,13 @@ fect_boot <- function( pnorm(abs(subgroup.att.placebo / subgroup.se.placebo))) * 2 } else { - subgroup.CI.placebo <- quantile( - group.att.placebo.boot[[sub.name]], - c(alpha / 2, 1 - alpha / 2), - na.rm = TRUE - ) - subgroup.CI.placebo.bound <- quantile( - group.att.placebo.boot[[sub.name]], - c(alpha, 1 - alpha), - na.rm = TRUE - ) - subgroup.pvalue.placebo <- get.pvalue(group.att.placebo.boot[[ - sub.name - ]]) + subgroup.CI.placebo <- .basic_ci_shifted_one(subgroup.att.placebo, + group.att.placebo.boot[[sub.name]], + alpha, .is_param) + subgroup.CI.placebo.bound <- .basic_ci_shifted_one(subgroup.att.placebo, + group.att.placebo.boot[[sub.name]], + 2 * alpha, .is_param) + subgroup.pvalue.placebo <- get.pvalue(group.att.placebo.boot[[sub.name]]) } subgroup.est.placebo <- t(as.matrix(c( @@ -4564,19 +4575,13 @@ fect_boot <- function( pnorm(abs(subgroup.att.carryover / subgroup.se.carryover))) * 2 } else { - subgroup.CI.carryover <- quantile( - group.att.carryover.boot[[sub.name]], - c(alpha / 2, 1 - alpha / 2), - na.rm = TRUE - ) - subgroup.CI.carryover.bound <- quantile( - group.att.carryover.boot[[sub.name]], - c(alpha, 1 - alpha), - na.rm = TRUE - ) - subgroup.pvalue.carryover <- get.pvalue(group.att.carryover.boot[[ - sub.name - ]]) + subgroup.CI.carryover <- .basic_ci_shifted_one(subgroup.att.carryover, + group.att.carryover.boot[[sub.name]], + alpha, .is_param) + subgroup.CI.carryover.bound <- .basic_ci_shifted_one(subgroup.att.carryover, + group.att.carryover.boot[[sub.name]], + 2 * alpha, .is_param) + subgroup.pvalue.carryover <- get.pvalue(group.att.carryover.boot[[sub.name]]) } subgroup.est.carryover <- t(as.matrix(c( @@ -4642,7 +4647,8 @@ fect_boot <- function( att.boot.original = att.boot.original, att.vcov = vcov.att, att.count.boot = att.count.boot, - vartype = vartype + vartype = vartype, + para.error = if (vartype == "parametric" && exists("para.error.resolved")) para.error.resolved else NULL ) if (keep.sims) { result = c( diff --git a/R/cfe.R b/R/cfe.R index 60e2b21d..4e2df995 100644 --- a/R/cfe.R +++ b/R/cfe.R @@ -48,7 +48,8 @@ fect_cfe <- function( group = NULL, time.on.seq.group = NULL, time.off.seq.group = NULL, - W.in.fit = TRUE + W.in.fit = TRUE, + fit.init = NULL ## warm-start matrix for complex_fe_ub (v2.4.3+) ) { ## -------------------------------## ## Parsing data @@ -178,7 +179,8 @@ fect_cfe <- function( r.cv, force = force, tol, - max.iteration + max.iteration, + fit_init = fit.init ) ## Convergence check for est.best diff --git a/R/cv-helpers.R b/R/cv-helpers.R index 5420541e..4eb5cdff 100644 --- a/R/cv-helpers.R +++ b/R/cv-helpers.R @@ -23,11 +23,53 @@ ## for calling `future::plan(future::cluster, workers = cl)` and the ## subsequent on.exit cleanup. .fect_make_future_cluster <- function(cores) { - parallelly::makeClusterPSOCK( + cl <- parallelly::makeClusterPSOCK( workers = cores, rscript_libs = .libPaths(), autoStop = TRUE ) + ## Pre-load packages on workers with messages + warnings suppressed + ## (v2.4.2+). Without this, each worker fires "package was built under + ## R version X.Y.Z" warnings from the user's local R / package skew on + ## first use of mvtnorm / future / etc., once per worker. These are + ## informational, not actionable, but they clutter user-facing output + ## (especially under parametric bootstrap where mvtnorm::rmvnorm + ## fires per worker). + parallel::clusterEvalQ(cl, { + suppressPackageStartupMessages({ + suppressWarnings({ + ## Pre-load packages used inside parallel paths. + requireNamespace("mvtnorm", quietly = TRUE) + requireNamespace("future", quietly = TRUE) + requireNamespace("future.apply", quietly = TRUE) + requireNamespace("doParallel", quietly = TRUE) + requireNamespace("foreach", quietly = TRUE) + }) + }) + ## Suppress "built under R version" warnings for any subsequent + ## library() / requireNamespace() inside this worker. + options(warn.conflicts = FALSE) + }) + cl +} + + +## Run `expr` with "package was built under R version" warnings +## suppressed (they fire from parallel workers loading packages +## compiled against a slightly newer R; informational, not actionable). +## Other warnings pass through normally. Use to wrap parallel-execution +## entry points (future_lapply / foreach calls) so user-facing output +## isn't cluttered. Added v2.4.2. +.fect_with_quiet_pkg_warnings <- function(expr) { + withCallingHandlers( + expr, + warning = function(w) { + msg <- conditionMessage(w) + if (grepl("was built under R version", msg, fixed = TRUE)) { + invokeRestart("muffleWarning") + } + } + ) } diff --git a/R/default.R b/R/default.R index bd863614..ed89bae0 100644 --- a/R/default.R +++ b/R/default.R @@ -57,14 +57,16 @@ fect <- function( method = "fe", # method: e for fixed effects; ife for interactive fe; mc for matrix completion se = FALSE, # report uncertainties vartype = "bootstrap", # bootstrap or jackknife + para.error = "auto", # parametric bootstrap error strategy: "auto", "ar", "empirical", "wild" cl = NULL, - quantile.CI = FALSE, - nboots = 200, # number of bootstraps + ci.method = "normal", # CI method for fect's est.* slots: "normal" (Wald: theta_hat +- z * SE) or "basic" (reflected pivot, Davison-Hinkley 1997 Sec. 5.2.1). For percentile / bc / bca on alternative estimands (att.cumu, aptt, log.att), call estimand(fit, type, ci.method) post-fit + quantile.CI = NULL, # DEPRECATED: use ci.method instead. NULL sentinel = "not supplied"; legacy FALSE -> ci.method = "normal", legacy TRUE -> ci.method = "basic" + nboots = 200, # number of bootstraps (sufficient for SE / normal CI; bump to 1000+ for tail-quantile CIs in estimand()) alpha = 0.05, # significance level parallel = TRUE, # parallel computing cores = NULL, # number of cores - tol = 1e-3, # tolerance level - max.iteration = 1000, + tol = 1e-5, # tolerance level (tightened from 1e-3 in v2.4.3) + max.iteration = 5000, seed = NULL, # set seed min.T0 = NULL, # minimum T0 max.missing = NULL, # maximum missing @@ -74,7 +76,7 @@ fect <- function( tost.threshold = NULL, # equiv knots = NULL, degree = 2, # wald = FALSE, # fit test - sfe = NULL, + group.fe = NULL, # additional additive FE columns absorbed via CFE machinery cfe = NULL, Z = NULL, gamma = NULL, @@ -138,14 +140,16 @@ fect.formula <- function( method = "fe", # method: fe for fixed effects; ife for interactive fe; mc for matrix completion se = FALSE, # report uncertainties vartype = "bootstrap", # bootstrap or jackknife + para.error = "auto", # parametric bootstrap error strategy: "auto", "ar", "empirical", "wild" cl = NULL, - quantile.CI = FALSE, - nboots = 200, # number of bootstraps + ci.method = "normal", # CI method for fect's est.* slots: "normal" or "basic" + quantile.CI = NULL, # DEPRECATED: use ci.method instead + nboots = 200, # number of bootstraps (sufficient for SE / normal CI; bump to 1000+ for tail-quantile CIs in estimand()) alpha = 0.05, # significance level parallel = TRUE, # parallel computing cores = NULL, # number of cores - tol = 1e-3, # tolerance level - max.iteration = 1000, + tol = 1e-5, # tolerance level (tightened from 1e-3 in v2.4.3) + max.iteration = 5000, seed = NULL, # set seed min.T0 = NULL, max.missing = NULL, @@ -155,7 +159,7 @@ fect.formula <- function( tost.threshold = NULL, knots = NULL, degree = 2, # wald = FALSE, - sfe = NULL, + group.fe = NULL, cfe = NULL, Z = NULL, gamma = NULL, @@ -251,7 +255,9 @@ fect.formula <- function( method = method, se = se, vartype = vartype, + para.error = para.error, cl = cl, + ci.method = ci.method, quantile.CI = quantile.CI, nboots = nboots, alpha = alpha, @@ -268,7 +274,7 @@ fect.formula <- function( tost.threshold = tost.threshold, knots = knots, degree = degree, - sfe = sfe, + group.fe = group.fe, cfe = cfe, Z = Z, gamma = gamma, @@ -334,14 +340,16 @@ fect.default <- function( method = "fe", # method: ife for interactive fe; mc for matrix completion se = FALSE, # report uncertainties vartype = "bootstrap", # bootstrap or jackknife + para.error = "auto", # parametric bootstrap error strategy: "auto", "ar", "empirical", "wild" cl = NULL, - quantile.CI = FALSE, - nboots = 200, # number of bootstraps + ci.method = "normal", # CI method for fect's est.* slots: "normal" or "basic" + quantile.CI = NULL, # DEPRECATED: use ci.method instead + nboots = 200, # number of bootstraps (sufficient for SE / normal CI; bump to 1000+ for tail-quantile CIs in estimand()) alpha = 0.05, # significance level parallel = TRUE, # parallel computing cores = NULL, # number of cores - tol = 1e-3, # tolerance level - max.iteration = 1000, + tol = 1e-5, # tolerance level (tightened from 1e-3 in v2.4.3) + max.iteration = 5000, seed = NULL, # set seed min.T0 = NULL, max.missing = NULL, @@ -351,7 +359,7 @@ fect.default <- function( tost.threshold = NULL, knots = NULL, degree = 2, # wald = FALSE, - sfe = NULL, + group.fe = NULL, cfe = NULL, Z = NULL, gamma = NULL, @@ -391,6 +399,131 @@ fect.default <- function( data <- as.data.frame(data) ## warning("Not a data frame.") } + + ## ---------------------------------------------------------------- + ## group.fe: validate, auto-route method, normalize into index[3:] + ## ---------------------------------------------------------------- + ## group.fe is a character vector of column names naming additive simple + ## FE groupings absorbed via the existing CFE pipeline (X.extra.FE). It + ## is a discoverable surface for the legacy index = c(unit, time, extra, + ## extra, ...) syntax. See statsclaw-workspace/fect/runs/2026-05-21- + ## higher-level-fe.md for the design memo. + if (!is.null(group.fe)) { + if (!is.character(group.fe)) { + stop("\"group.fe\" must be a character vector of column names.", + call. = FALSE) + } + ## (a) columns exist + missing.cols <- setdiff(group.fe, colnames(data)) + if (length(missing.cols) > 0) { + stop("group.fe column(s) not found in data: ", + paste(missing.cols, collapse = ", "), call. = FALSE) + } + ## (b) conflict with legacy index[3:] form: hard error + if (length(index) > 2) { + stop("Specify additional FE via group.fe OR extra index slots, ", + "not both. index[3:] is the legacy form; group.fe is preferred.", + call. = FALSE) + } + ## (c) overlap with index[1:2]: warn and drop the duplicate entries + dup.idx <- intersect(group.fe, index[1:2]) + if (length(dup.idx) > 0) { + warning("group.fe entry/entries (", + paste(dup.idx, collapse = ", "), + ") duplicate index[1:2]; dropping from group.fe.", + call. = FALSE) + group.fe <- setdiff(group.fe, index[1:2]) + } + ## (d) auto-route method (per D3 in design memo). When routing fe -> + ## cfe, also pre-set r = 0 and CV = FALSE so the call behaves like + ## the user's intended "FE only" model. (The standard fe -> ife r=0 + ## coercion at L711-714 of this file uses ife as its backing path; + ## the cfe backing requires explicit r/CV to avoid hitting the + ## interactive-FE code that expects a populated cfe= list.) + if (length(group.fe) > 0) { + if (method == "fe") { + method <- "cfe" + r <- 0 + if (is.null(CV)) CV <- FALSE + } else if (method %in% c("ife", "mc", "both", "gsynth")) { + stop("group.fe with method = \"", method, "\" is not supported. ", + "Use method = \"cfe\", r = N explicitly to get free latent ", + "factors with group-level FE.", + call. = FALSE) + } + ## method == "cfe": keep as-is, no message + } + ## (e) normalize: append group.fe to index for downstream X.extra.FE pipeline + if (length(group.fe) > 0) { + index <- c(index, group.fe) + } + ## (f) default cl from group.fe[1] when cl is NULL (the placeholder + ## value) and group.fe is single-column. We use is.null(cl) here + ## because missing(cl) doesn't survive the fect.formula -> fect.default + ## dispatch (cl is explicitly forwarded). Documented: cl = NULL is + ## the default placeholder and does NOT suppress clustering; use + ## cl = FALSE to suppress explicitly. + if (is.null(cl) && length(group.fe) == 1) { + cl <- group.fe[1] + } else if (length(group.fe) > 1 && is.null(cl)) { + stop("Multi-column group.fe requires explicit cl (e.g., cl = '", + group.fe[1], "', or cl = index[1] for unit-level clustering).", + call. = FALSE) + } + } + ## (g) cl must be a single column name. cl = FALSE is rejected to avoid + ## the misleading "no clustering" framing: even without an explicit + ## cluster column the case bootstrap still resamples units, which is + ## unit-level clustering. Users who want explicit unit-level clustering + ## should pass cl = index[1] (e.g., cl = "id"). + if (isFALSE(cl)) { + stop("cl = FALSE is not supported. The case bootstrap always ", + "resamples units; to cluster at the unit level explicitly, ", + "pass cl = '", index[1], "' (or cl = index[1]).", + call. = FALSE) + } + + ## Snapshot the cl column name now (before downstream reshape to matrix) + ## so print(fit) / summary(fit) can show the user-facing cluster label. + cl.label <- if (is.character(cl) && length(cl) == 1) cl else NULL + + ## ---------------------------------------------------------------- + ## Nesting check: each group.fe column must be constant within index[1]. + ## This is required because group.fe is documented as "additive simple FE + ## on a coarsening of the unit identifier" --- e.g., state on county. + ## Without this check, default.R:1672 silently reshapes a non-constant + ## column into a TT*N matrix and produces wrong fits. + ## + ## We do NOT apply this check to the legacy `index = c(unit, time, extra, + ## ...)` form because that form has historically supported BOTH (a) + ## nested additive FE (the group.fe-style use) AND (b) cell-level + ## interactions like region_time (which by design vary within unit). The + ## strict modern surface (group.fe) is for case (a) only; the legacy + ## surface keeps its full original scope. + ## ---------------------------------------------------------------- + if (length(group.fe) > 0 && all(index[1] %in% colnames(data))) { + for (gfe in group.fe) { + nest <- tapply(data[[gfe]], data[[index[1]]], + function(x) length(unique(stats::na.omit(x)))) + bad <- names(nest)[!is.na(nest) & nest > 1] + if (length(bad) > 0) { + bad.show <- if (length(bad) > 10) + paste0(paste(bad[1:10], collapse = ", "), + ", and ", length(bad) - 10, " more") + else paste(bad, collapse = ", ") + stop("group.fe column '", gfe, + "' is not constant within index[1] = '", index[1], + "'. Offending units: ", bad.show, + "\n (group.fe is for additive simple FE on a coarsening ", + "of the unit identifier. For cell-level interactions ", + "that vary within unit, use the legacy `index = c(unit, ", + "time, ...)` form or the `cfe = list(...)` interactive-", + "FE argument instead.)", + call. = FALSE) + } + } + } + ## index if ( (length(index) != 2 | sum(index %in% colnames(data)) != 2) & @@ -421,15 +554,39 @@ fect.default <- function( stop("\"cm\" option is only available for the \"fe\" and \"ife\" methods.") } + ## Save user's literal method argument before any silent coercion (e.g. + ## fe -> ife r=0 below). Referenced by the parametric/nevertreated gate + ## further down so error messages name the user's actual method = "fe". + method_arg <- method + if (se == 1) { if (!vartype %in% c("bootstrap", "jackknife", "parametric")) { - stop("\"vartype\" option misspecified.") + stop( + "\"vartype\" must be one of \"bootstrap\", \"jackknife\", or \"parametric\".", + call. = FALSE + ) } if (vartype == "parametric" && method %in% c("mc", "both")) { stop( "The \"parametric\" option is not available for the \"mc\" or \"both\" methods." ) } + if (vartype == "jackknife" && !is.null(cl)) { + warning( + "vartype = \"jackknife\" with cl = ... : the cl argument is ignored. ", + "fect's jackknife is leave-one-unit-out and does not support a ", + "cluster (block) jackknife. The resulting SEs do not account for ", + "within-cluster correlation. Use vartype = \"bootstrap\" with cl ", + "for cluster-aware inference.", + call. = FALSE + ) + } + if (!para.error %in% c("auto", "ar", "empirical", "wild")) { + stop( + "\"para.error\" must be one of \"auto\", \"ar\", \"empirical\", or \"wild\".", + call. = FALSE + ) + } } ## Default: W populates both roles (back-compat for callers that just set W). @@ -765,8 +922,121 @@ fect.default <- function( stop("\"se\" is not a logical flag.") } - if (is.logical(quantile.CI) == FALSE & !quantile.CI %in% c(0, 1)) { - stop("\"quantile.CI\" is not a logical flag.") + ## ci.method: "normal" (Wald: theta_hat +- z * SE) or "basic" (reflected + ## pivot: 2*theta_hat - quantile(boot, c(1-alpha/2, alpha/2))). Wider 5-method + ## surface (basic, percentile, bc, bca, normal) lives on estimand() for + ## alternative estimands (att.cumu, aptt, log.att); see ?estimand and + ## chapter 7 of the fect User Manual. + ## + ## quantile.CI is the deprecated legacy arg; map it to ci.method with a + ## one-time warning when the user supplied it explicitly. The NULL sentinel + ## (default) means "user did not supply it" so the warning stays silent + ## under the modern API path. + if (!is.null(quantile.CI)) { + warning( + "Argument `quantile.CI` is deprecated as of fect 2.4.2 and will be ", + "removed in a future release. Use `ci.method = \"normal\"` (the ", + "default; equivalent to `quantile.CI = FALSE`) or `ci.method = \"basic\"` ", + "(equivalent to `quantile.CI = TRUE`) instead.\n\n", + "For percentile / bc / bca CIs on alternative estimands ", + "(att.cumu, aptt, log.att), call `estimand(fit, type, ci.method)` ", + "post-fit; see chapter 7 of the fect User Manual.", + call. = FALSE + ) + if (!is.logical(quantile.CI) && !quantile.CI %in% c(0, 1)) { + stop("\"quantile.CI\" is not a logical flag.", call. = FALSE) + } + ci.method <- if (isTRUE(as.logical(quantile.CI))) "basic" else "normal" + } + ## fect's built-in CI machinery for ci.method = "basic" reads raw + ## quantiles of the bootstrap distribution. This is calibrated for + ## vartype = "bootstrap" only --- the case bootstrap is naturally + ## centered at theta-hat. vartype = "parametric" stores eff.boot + ## centered at 0 (under H0); the reflected CI 2*theta_hat - quantile(boot) + ## then collapses around 2*theta_hat instead of theta_hat, giving 0% + ## coverage. vartype = "jackknife" leave-one-out values are not + ## exchangeable draws from the sampling distribution either (E&T 1993 + ## ch11; D&H 1997 Sec. 3.2.1). estimand() applies a location-shift fix for + ## parametric and a hard-error for jackknife on non-normal ci.methods; + ## fect's built-in path does neither, so we hard-error here and point + ## users to estimand(). + .ci.method.allowed <- c("normal", "basic") + if (length(ci.method) != 1L || !is.character(ci.method) || + !ci.method %in% .ci.method.allowed) { + if (is.character(ci.method) && length(ci.method) == 1L && + ci.method %in% c("percentile", "bc", "bca")) { + stop( + "ci.method = \"", ci.method, "\" is not supported in fect(); ", + "fect()'s built-in CI machinery offers only \"normal\" (Wald) ", + "and \"basic\" (reflected pivot).\n\n", + "For \"percentile\", \"bc\", and \"bca\" CIs, fit with the ", + "default ci.method and call `estimand(fit, type, ci.method = \"", + ci.method, "\")` post-fit. The full 5-method surface is the ", + "estimand() path; see ?estimand and chapter 7 of the fect ", + "User Manual.", + call. = FALSE + ) + } + stop( + "`ci.method` must be one of \"normal\" or \"basic\"; got \"", + ci.method, "\".", + call. = FALSE + ) + } + ## Reject ci.method = "basic" on jackknife fits. Jackknife pseudo-values + ## are influence-function-flavored leave-one-out quantities, not exchangeable + ## draws from the sampling distribution of theta-hat (E&T 1993 ch11; D&H + ## 1997 Sec. 3.2.1). The reflected pivot interval has no defensible meaning + ## here. Matches estimand()'s behaviour --- estimand hard-errors on + ## non-"normal" ci.methods for jackknife fits. + if (ci.method == "basic" && !is.null(vartype) && + identical(vartype, "jackknife")) { + stop( + "ci.method = \"basic\" is not supported for vartype = \"jackknife\". ", + "Jackknife produces an SE estimate via the Tukey pseudo-value ", + "formula, not a sampling distribution of theta-hat; reflection-based ", + "CIs require exchangeable draws from a sampling distribution ", + "(Efron & Tibshirani 1993, Chapter 11; Davison & Hinkley 1997, ", + "Section 3.2.1).\n\n", + "Use ci.method = \"normal\" (the only valid CI for jackknife: ", + "theta-hat +- z * SE_jack) or refit with vartype = \"bootstrap\" ", + "for the basic interval.", + call. = FALSE + ) + } + ## ci.method = "basic" on vartype = "parametric" is supported via a + ## location-shift fix in the CI computation downstream (R/boot.R, around + ## line 3590): the parametric path stores eff.boot centered at 0 (under + ## H0), and the reflected pivot CI 2*theta_hat - quantile(boot) collapses + ## around 2*theta_hat without a shift. fect() applies the same shift + ## that R/po-estimands.R applies inside estimand() (commit b4e9fbf), so + ## fit$est.avg with ci.method = "basic" on a parametric fit matches + ## estimand(fit, "att", ci.method = "basic") byte-equally for the + ## avg-level + per-event-time CIs. The shift is currently applied at + ## those two slots only; for other slots (calendar, cohort, subgroup, + ## balanced, by-W, placebo, carryover), basic on parametric is not + ## yet patched and may produce 0% coverage CIs --- call estimand() for + ## those slots. + ## Bridge to the existing internal dispatch in fect_boot, which is gated by + ## a logical `quantile.CI`. After this resolution, .quantile.CI.bool is the + ## single source of truth for the bootstrap-CI branch downstream. + .quantile.CI.bool <- (ci.method == "basic") + ## Tail-CI replicate warning (mirrors estimand's .check_tail_ci_replicates): + ## `basic` reads tail quantiles of the bootstrap distribution; the literature + ## floor for tail-quantile CIs is B >= 1000 (Efron 1987 Sec. 3; DiCiccio & Efron + ## 1996 Sec. 4). Warn at fit time so users don't need to refit. + if (ci.method == "basic" && isTRUE(se) && !is.null(nboots) && + is.numeric(nboots) && nboots < 1000 && + !identical(Sys.getenv("TESTTHAT"), "true")) { + warning( + "ci.method = \"basic\" reads tail quantiles of the bootstrap ", + "distribution; with nboots = ", nboots, " (< 1000) the 5th / 195th ", + "order statistics that the basic interval depends on may be ", + "unstable (Efron 1987 Sec. 3; DiCiccio & Efron 1996 Sec. 4 recommend ", + "B >= 1000). Refit with `fect(..., nboots = 1000)` for ", + "publication-grade CIs. The point estimate and SE are unaffected.", + call. = FALSE + ) } ## normalize @@ -776,7 +1046,7 @@ fect.default <- function( ## nboots if (se == TRUE & nboots <= 0) { - stop("\"nboots\" option misspecified. Try, for example, nboots = 200.") + stop("\"nboots\" option misspecified. Try, for example, nboots = 1000.") } ## parallel & cores @@ -1841,11 +2111,35 @@ fect.default <- function( "Use vartype='bootstrap' or 'jackknife'." ) } - if (se == 1 && vartype == "parametric" && time.component.from == "notyettreated") { + ## Parametric bootstrap requires nevertreated control-pool isolation. + ## Placed AFTER the reversal-check gate so reversal users get the more + ## actionable reversal message first. Uses method_arg (saved before the + ## silent fe -> ife coercion) so the message names the user's literal + ## method argument. + if (se == 1 && vartype == "parametric" && time.component.from != "nevertreated") { + stop(sprintf( + paste0( + "vartype = \"parametric\" requires time.component.from = \"nevertreated\".\n", + " Your call: method = \"%s\", time.component.from = \"%s\".\n\n", + "The parametric pseudo-treated bootstrap requires a control pool ", + "isolated from treated-unit pre-treatment cells. Pass ", + "time.component.from = \"nevertreated\" (if never-treated controls ", + "exist) or use vartype = \"bootstrap\" or \"jackknife\"." + ), + method_arg, time.component.from + ), call. = FALSE) + } + ## para.error = "empirical" or "wild" requires fully-observed panel. + if (se == 1 && vartype == "parametric" && + para.error %in% c("empirical", "wild") && + (0 %in% I)) { stop( - "Parametric bootstrap is not valid when \"time.component.from\" is ", - "\"notyettreated\". Use time.component.from = \"nevertreated\" (if never-treated ", - "controls are available) or vartype = \"bootstrap\" or \"jackknife\"." + "para.error = \"", para.error, "\" requires a fully-observed panel ", + "(no missing cells in the observation matrix I). ", + "The current data has unobserved cells. ", + "Use para.error = \"ar\" or para.error = \"auto\" (which selects \"ar\" automatically ", + "when missing data are present).", + call. = FALSE ) } @@ -2081,7 +2375,14 @@ fect.default <- function( } old.future.plan <- future::plan() suppressWarnings(suppressPackageStartupMessages({ - future::plan(future::multisession, workers = cores) + ## v2.4.2+: route through .fect_make_future_cluster so workers + ## pre-load mvtnorm / future / etc. silently. Avoids the + ## "package was built under R version X.Y.Z" warnings firing + ## per worker on first parallel package use (especially under + ## parametric bootstrap where mvtnorm::rmvnorm fires on every + ## worker for every replicate). + future::plan(future::cluster, + workers = .fect_make_future_cluster(cores)) doFuture::registerDoFuture() })) if (is.null(seed) == FALSE) { @@ -2415,7 +2716,6 @@ fect.default <- function( balance.period = balance.period, method = method, degree = degree, - sfe = sfe, cfe = cfe, X.extra.FE = X.extra.FE, X.Z = X.Z, @@ -2449,7 +2749,8 @@ fect.default <- function( carryoverTest = carryoverTest, carryover.period = carryover.period, vartype = vartype, - quantile.CI = quantile.CI, + para.error = para.error, + quantile.CI = .quantile.CI.bool, nboots = nboots, parallel = parallel, cores = cores, @@ -2708,7 +3009,7 @@ fect.default <- function( vartype = vartype, nboots = nboots, parallel = parallel, - quantile.CI = quantile.CI, + quantile.CI = .quantile.CI.bool, cores = cores, group.level = g.level, group = pG, @@ -2869,6 +3170,9 @@ fect.default <- function( obs.missing.balance[, rem.id] <- obs.missing.sub } + sample <- matrix(obs.missing %in% c(1L, 2L, 5L), nrow = TT, ncol = N, + dimnames = dimnames(obs.missing)) + # if cross-validation: if (p > 0) { @@ -2983,7 +3287,7 @@ fect.default <- function( carryoverTest = carryoverTest, carryover.period = carryover.period, ## Stored on the fit object so plot logic does not need to - ## re-parse `x$call` — robust under do.call(), positional + ## re-parse `x$call` --- robust under do.call(), positional ## args, and call-rewriting wrappers. carryover.rm = carryover.rm, ## Reserved slot for the post-hoc estimand API (v2.4.0+). @@ -2991,11 +3295,17 @@ fect.default <- function( ## GSC); future doubly-robust estimators will populate this ## with the per-cell debias correction so that ## eff = (Y_obs - Y0_hat) + eff_debias is the cell-level - ## score. See ref/po-estimands-contract.md §3. + ## score. See ref/po-estimands-contract.md Sec. 3. eff_debias = NULL, unit.type = unit.type, obs.missing = obs.missing, obs.missing.balance = obs.missing.balance, + sample = sample, + ## Original input panel (pre-drop), preserved so + ## panelView::panelview(fit) can render the full set of + ## units --- including those fect dropped (always-treated, + ## insufficient pre-period, etc.) --- as "Not used" cells. + data.long = data.old[, c(index, Yname, Dname), drop = FALSE], time.component.from = time.component.from, em = em ), @@ -3102,6 +3412,33 @@ fect.default <- function( )] <- NULL } + ## v2.4.3+: convergence diagnostic. The EM check is + ## ||fit_new - fit_old||_F / ||fit_old||_F < tol + ## When niter >= max.iteration, the EM was halted before satisfying + ## the tol gate. The reported att.avg may not reflect a converged + ## minimum; users should inspect (and ideally raise max.iteration) + ## before publishing. + if (!is.null(output$niter) && length(output$niter) == 1 && + is.finite(output$niter) && output$niter >= max.iteration) { + warning(sprintf( + paste( + "EM did not converge within max.iteration = %d (final niter = %d).", + "Estimates may be under-converged. Consider raising max.iteration", + "and/or tightening tol. If att.avg shifts substantially under", + "longer runs, the data may be poorly conditioned for this model", + "specification (e.g. very small Ntr, near-collinear factors,", + "or a misspecified rank).", sep = "\n "), + as.integer(max.iteration), as.integer(output$niter) + ), call. = FALSE) + } + + ## Surface the user's group.fe input on the fit object so print/summary + ## can show the absorbed FE composition (per D8 in design memo). Also + ## store the user-facing cl column name (cl gets reshaped to a matrix + ## internally for the bootstrap; we want the original label here). + output$group.fe <- group.fe + output$cl.label <- cl.label + class(output) <- "fect" return(output) } ## Program fect ends diff --git a/R/diagtest.R b/R/diagtest.R index 14be9fbd..cde8bdb4 100644 --- a/R/diagtest.R +++ b/R/diagtest.R @@ -87,7 +87,7 @@ diagtest <- function( if ("try-error" %in% class(psi)) { message("\n") #message("The estimated covariance matrix is irreversible.") - message("F-test Failed. The estimated covariance matrix is singular.") + message("F-test could not be computed: the estimated covariance matrix is singular.") message("\n") f.stat <- f.p <- f.equiv.p <- f.threshold <- NA } else { @@ -165,7 +165,7 @@ diagtest <- function( if ("try-error" %in% class(psi)) { message("\n") #message("The estimated covariance matrix is irreversible.") - message("F-test Failed. The estimated covariance matrix is singular.") + message("F-test could not be computed: the estimated covariance matrix is singular.") message("\n") f.stat <- f.p <- f.equiv.p <- f.threshold <- NA } else { diff --git a/R/did_wrapper.R b/R/did_wrapper.R index 9e14a467..a8c91589 100644 --- a/R/did_wrapper.R +++ b/R/did_wrapper.R @@ -540,11 +540,14 @@ did_wrapper <- function( if (!identical(parallel, FALSE)) { if (is.null(core)) core <- parallelly::availableCores(omit = 1) - future::plan(future::multisession, workers = core) # Use future::multisession + ## v2.4.2+: route through helper to pre-load packages silently. + future::plan(future::cluster, workers = .fect_make_future_cluster(core)) # Ensure seed is handled correctly for parallel processing - rep_list <- future.apply::future_lapply(seq_len(nboots), boot_fun, - future.seed = TRUE - ) # future.seed=TRUE is good + rep_list <- .fect_with_quiet_pkg_warnings( + future.apply::future_lapply(seq_len(nboots), boot_fun, + future.seed = TRUE + ) + ) future::plan(future::sequential) # Reset plan } else { rep_list <- lapply(seq_len(nboots), boot_fun) diff --git a/R/esplot.R b/R/esplot.R index d6fa9809..cf8c27eb 100644 --- a/R/esplot.R +++ b/R/esplot.R @@ -119,8 +119,22 @@ esplot <- function(data, # time, ATT, CI.lower, CI.upper, count, ... ## (pre = "grey50", post = color) so pre-treatment and post-treatment points ## are visually distinguishable. fect convention: with start0 = FALSE ## (default), period 0 is the LAST pre-treatment period; first post is t=1. + ## + ## Exception: estimand() with test = "placebo" / "carryover" attaches a + ## "fect_test" attribute to the returned data frame; in those modes ALL + ## event-times are special (no pre-vs-post contrast to convey), so we + ## use a single uniform color (= `color`) across all points and skip the + ## gray pre-treatment shade. + fect_test <- attr(data, "fect_test") if (is.null(post.color)) post.color <- color - if (is.null(pre.color)) pre.color <- "gray50" + if (is.null(pre.color)) { + pre.color <- if (!is.null(fect_test) && + fect_test %in% c("placebo", "carryover")) { + color + } else { + "gray50" + } + } # Identify time/period column if (is.null(Period)) { diff --git a/R/fe.R b/R/fe.R index 12779c5c..ccea1dc7 100644 --- a/R/fe.R +++ b/R/fe.R @@ -38,7 +38,8 @@ fect_fe <- function(Y, # Outcome variable, (T*N) matrix group = NULL, time.on.seq.group = NULL, time.off.seq.group = NULL, - W.in.fit = TRUE) { + W.in.fit = TRUE, + fit.init = NULL) { ## warm-start matrix for inter_fe_ub (v2.4.2+) ## -------------------------------## ## Parsing data ## -------------------------------## @@ -125,11 +126,14 @@ fect_fe <- function(Y, # Outcome variable, (T*N) matrix YY[which(II == 0)] <- 0 ## reset to 0 if (binary == FALSE) { - est.best <- inter_fe_ub(YY, Y0, X, II, W.use, beta0, r.cv, force = force, tol, max.iteration) + est.best <- inter_fe_ub(YY, Y0, X, II, W.use, beta0, r.cv, force = force, tol, max.iteration, + fit_init = fit.init) if (boot == FALSE) { if (r.cv == 0) { est.fect <- est.best } else { + ## r.cv = 0 sub-fit (no factors) cannot reuse a factor-model + ## warm-start; pass NULL to keep cold-start behavior. est.fect <- inter_fe_ub(YY, Y0, X, II, W.use, beta0, 0, force = force, tol, max.iteration) } } diff --git a/R/fect_nevertreated.R b/R/fect_nevertreated.R index 9ade98b7..e9ea9b8e 100644 --- a/R/fect_nevertreated.R +++ b/R/fect_nevertreated.R @@ -60,7 +60,8 @@ fect_nevertreated <- function(Y, # Outcome variable, (T*N) matrix gamma.loading = NULL, gamma.loading.grid = NULL, cv.rule = "1se", - W.in.fit = TRUE + W.in.fit = TRUE, + fit.init = NULL ## warm-start aux surface (T x N_boot); v2.4.3+ ) { ## -------------------------------## ## Parsing data @@ -98,6 +99,15 @@ fect_nevertreated <- function(Y, # Outcome variable, (T*N) matrix Nco <- length(co) r <- min(r, TT, Nco) + ## Slice warm-start aux surface to control units (the only units fed + ## to complex_fe_ub / inter_fe_ub here). NULL preserves cold-start. + fit.init.co <- NULL + if (!is.null(fit.init)) { + if (is.matrix(fit.init) && nrow(fit.init) == TT && ncol(fit.init) >= max(co)) { + fit.init.co <- fit.init[, co, drop = FALSE] + } + } + I.tr <- as.matrix(I[, tr]) ## maybe only 1 treated unit I.co <- I[, co] II.tr <- as.matrix(II[, tr]) @@ -236,7 +246,7 @@ fect_nevertreated <- function(Y, # Outcome variable, (T*N) matrix ## at each call site. .estimate_co <- function(Y, Y0, X, I_obs, W_in, beta0_in, r, force, tol, max.iteration, use_cfe = FALSE, - center = TRUE) { + center = TRUE, fit_init = NULL) { ## Center Y to improve convergence conditioning: ## removes grand mean from fit so tol applies to variation, not level. mu_init <- 0 @@ -245,18 +255,26 @@ fect_nevertreated <- function(Y, # Outcome variable, (T*N) matrix mu_init <- sum(Y * I_obs) / sum(I_obs) Y <- Y - mu_init * I_obs ## observed positions centered, zeros stay Y0 <- Y0 - mu_init ## initial fit centered + ## Centering the warm-start surface keeps it on the same scale + ## as the centered Y; otherwise the EM would unwind centering on + ## the very first iteration. Only apply when fit_init is non-null. + if (!is.null(fit_init)) fit_init <- fit_init - mu_init } if (use_cfe) { out <- complex_fe_ub(Y, Y0, X, X.extra.FE.co.B, X.Z.co, X.Q.co, X.gamma.co, X.kappa.co, Zgamma.id, kappaQ.id, - I_obs, W_in, beta0_in, r, force = force, tol, max.iteration) + I_obs, W_in, beta0_in, r, force = force, tol, max.iteration, + fit_init = fit_init) } else if (!0 %in% I_obs) { + ## Balanced inter_fe does not yet expose fit_init (would require + ## a separate C++ extension). Cold-start here is the safe default. out <- inter_fe(Y, X, r, force = force, beta0_in = beta0_in, tol, max.iteration) } else { out <- inter_fe_ub(Y, Y0, X, I_obs, W_in, beta0_in, r, - force = force, tol, max.iteration) + force = force, tol, max.iteration, + fit_init = fit_init) } ## Undo centering @@ -324,7 +342,8 @@ fect_nevertreated <- function(Y, # Outcome variable, (T*N) matrix if (r.max == 0) { r.cv <- 0 message("Cross validation cannot be performed since available pre-treatment records of treated units are too few. So set r.cv = 0.") - est.co.best <- .estimate_co(YY.co, Y0.co, X.co, I.co, W.use, beta0, 0, force, cv_tol, max.iteration) + est.co.best <- .estimate_co(YY.co, Y0.co, X.co, I.co, W.use, beta0, 0, force, cv_tol, max.iteration, + fit_init = fit.init.co) } else { r.old <- r ## save the minimal number of factors @@ -1036,7 +1055,8 @@ fect_nevertreated <- function(Y, # Outcome variable, (T*N) matrix est.co.fect <- NULL - est.co.best <- .estimate_co(YY.co, Y0.co, X.co, II.co, W.use, beta0, r.cv, force, tol, max.iteration) + est.co.best <- .estimate_co(YY.co, Y0.co, X.co, II.co, W.use, beta0, r.cv, force, tol, max.iteration, + fit_init = fit.init.co) if (boot == FALSE) { if (r.cv == 0) { @@ -1418,7 +1438,8 @@ fect_nevertreated <- function(Y, # Outcome variable, (T*N) matrix est.co.best <- complex_fe_ub(YY.co, Y0.co, X.co, X.extra.FE.co.B, X.Z.co, X.Q.co, X.gamma.co, X.kappa.co, Zgamma.id, kappaQ.id, - II.co, W.use, beta0, 0, force = force, cv_tol, max.iteration) + II.co, W.use, beta0, 0, force = force, cv_tol, max.iteration, + fit_init = fit.init.co) } else { r.old <- r message("Cross-validating ...", "\r") @@ -2113,7 +2134,8 @@ fect_nevertreated <- function(Y, # Outcome variable, (T*N) matrix est.co.best <- complex_fe_ub(YY.co, Y0.co, X.co, X.extra.FE.co.B, X.Z.co, X.Q.co, X.gamma.co, X.kappa.co, Zgamma.id, kappaQ.id, - II.co, W.use, beta0, r.cv, force = force, tol, max.iteration) + II.co, W.use, beta0, r.cv, force = force, tol, max.iteration, + fit_init = fit.init.co) ## Convergence check if (!is.null(est.co.best$niter) && est.co.best$niter >= max.iteration) { diff --git a/R/mc.R b/R/mc.R index d658a656..855b7bdc 100644 --- a/R/mc.R +++ b/R/mc.R @@ -35,7 +35,8 @@ fect_mc <- function(Y, # Outcome variable, (T*N) matrix group = NULL, time.on.seq.group = NULL, time.off.seq.group = NULL, - W.in.fit = TRUE) { + W.in.fit = TRUE, + fit.init = NULL) { ## warm-start matrix for inter_fe_mc (v2.4.2+) ## -------------------------------## ## Parsing data ## -------------------------------## @@ -102,7 +103,8 @@ fect_mc <- function(Y, # Outcome variable, (T*N) matrix validX <- 1 ## no multi-colinearity ## matrix completion - est.best <- inter_fe_mc(YY, Y0, X, II, W.use, beta0, hasF, lambda.cv, force, tol, max.iteration) + est.best <- inter_fe_mc(YY, Y0, X, II, W.use, beta0, hasF, lambda.cv, force, tol, max.iteration, + fit_init = fit.init) validX <- est.best$validX validF <- est.best$validF est.fect <- NULL diff --git a/R/plot.R b/R/plot.R index 734d5960..5a900c15 100644 --- a/R/plot.R +++ b/R/plot.R @@ -3890,7 +3890,7 @@ plot.fect <- function( } else { p <- p + geom_hline(yintercept = att.avg.use, color = calendar.lcolor, linewidth = 0.8, linetype = "dashed") } - p <- p + geom_pointrange(aes(x = TTT, y = d1[, 1], ymin = d1[, 3], ymax = d1[, 4]), color = "gray50", fill = "gray50", alpha = 1, size = 0.6) + p <- p + geom_pointrange(aes(x = TTT, y = d1[, 1], ymin = d1[, 3], ymax = d1[, 4]), color = "gray50", fill = "gray50", alpha = 1, size = 0.6, linewidth = 0.6) } if (isTRUE(show.count) && !type %in% c("gap", "equiv")) { @@ -4604,7 +4604,7 @@ plot.fect <- function( max.count.pos <- data.count[which.max(data.count[, 2]), 1][1] - min(data.count[, 1]) + 1 p <- p + geom_rect(aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax), data = data.toplot, inherit.aes = FALSE, - fill = count.color, size = 0.3, alpha = count.alpha, color = count.outline.color, linewidth = 0.2 + fill = count.color, alpha = count.alpha, color = count.outline.color, linewidth = 0.2 ) p <- p + annotate("text", x = max.count.pos - 0.02 * T.gap, diff --git a/R/po-estimands.R b/R/po-estimands.R index ad15138f..e275faba 100644 --- a/R/po-estimands.R +++ b/R/po-estimands.R @@ -119,7 +119,14 @@ ## not exactly zero). All ATT-style estimands aggregate eff over ## treated cells only. - ## eff.boot, if populated, must match TT x N x nboots. + ## eff.boot shape depends on vartype. + ## bootstrap / wild / parametric: TT x N x B + ## jackknife: TT x (N-1) x N + ## The third dimension is the dropped-unit index; the second is N-1 + ## because each leave-one-out fit runs on a panel with one unit + ## removed. The post-hoc estimand API uses eff.boot only through the + ## dedicated .jackknife_tukey_se_*() helpers, never by treating its + ## second dimension as N. if (!is.null(fit$eff.boot)) { eb <- fit$eff.boot if (!is.array(eb) || length(dim(eb)) != 3) { @@ -128,13 +135,41 @@ call. = FALSE ) } - if (!identical(dim(eb)[1:2], c(TT, N))) { - stop( - "Slot contract: fit$eff.boot first two dimensions (", - dim(eb)[1], " x ", dim(eb)[2], - ") must match TT x N (", TT, " x ", N, ").", - call. = FALSE - ) + is_jack <- isTRUE(fit$vartype == "jackknife") + if (is_jack) { + if (dim(eb)[1] != TT) { + stop( + "Slot contract (jackknife): fit$eff.boot[1] = ", + dim(eb)[1], " must equal TT = ", TT, ".", + call. = FALSE + ) + } + if (dim(eb)[3] != N) { + stop( + "Slot contract (jackknife): fit$eff.boot[3] = ", + dim(eb)[3], " must equal N = ", N, + " (one leave-one-out replicate per unit).", + call. = FALSE + ) + } + ## dim(eb)[2] == N-1 is the normal case; warn if unexpected. + if (dim(eb)[2] != N - 1L) { + warning( + "Slot contract (jackknife): fit$eff.boot[2] = ", + dim(eb)[2], "; expected N-1 = ", N - 1L, + ". Proceeding, but results may be incorrect.", + call. = FALSE + ) + } + } else { + if (!identical(dim(eb)[1:2], c(TT, N))) { + stop( + "Slot contract: fit$eff.boot first two dimensions (", + dim(eb)[1], " x ", dim(eb)[2], + ") must match TT x N (", TT, " x ", N, ").", + call. = FALSE + ) + } } } @@ -162,6 +197,82 @@ } +## Internal: hard-error if ci.method is not "normal" for a jackknife fit. +## Jackknife produces an SE estimate via the Tukey pseudo-value formula, +## not a sampling distribution of θ̂. The accepted CI is Wald-style: +## CI = θ̂ ± z_{1-α/2} · SE_jack +## (ci.method = "normal"). +## +## Reflection-based methods (basic, percentile) require exchangeable draws +## from the sampling distribution — jackknife leave-one-out values are not +## exchangeable draws (Efron & Tibshirani 1993, §11; Davison & Hinkley +## 1997, §3.2.1). Bias-corrected methods (bc, bca) require a bootstrap +## distribution to compute z₀ — jackknife has no bootstrap distribution. +## Passing jackknife replicates to any of these methods would produce CIs +## with undefined (and likely poor) coverage. Hard-error forces the caller +## to be explicit about this statistical limitation. +## Internal: warn (not error) when a tail-quantile-based CI is requested on a +## bootstrap / parametric fit with fewer than 1000 replicates. The point +## estimate and SE are unaffected; only basic / percentile / bc / bca CIs read +## the empirical tail of the bootstrap distribution and need B large enough for +## the relevant order statistics to be stable. Efron 1987 §3 and DiCiccio & +## Efron 1996 §4 recommend B >= 1000 as the floor for bca; the same threshold +## suits basic / percentile (which read 5th / 195th order statistics at B=200 +## vs 25th / 975th at B=1000). Warning rather than error so users can still +## explore on small B during iteration. +.check_tail_ci_replicates <- function(fit, ci.method, vartype) { + if (vartype == "none") return(invisible(TRUE)) + if (!isTRUE(fit$vartype %in% c("bootstrap", "parametric"))) { + return(invisible(TRUE)) + } + if (!ci.method %in% c("basic", "percentile", "bc", "bca")) { + return(invisible(TRUE)) + } + if (is.null(fit$eff.boot)) return(invisible(TRUE)) + B <- dim(fit$eff.boot)[3] + if (is.na(B) || B >= 1000) return(invisible(TRUE)) + if (!identical(Sys.getenv("TESTTHAT"), "true")) { + warning( + "estimand() with ci.method = \"", ci.method, "\" on a fit with ", + "nboots = ", B, " (< 1000): tail-quantile-based CIs may have ", + "erratic endpoints at this replicate count (Efron 1987 Section 3; ", + "DiCiccio & Efron 1996 Section 4 recommend B >= 1000). The point ", + "estimate and SE are unaffected. For publication-grade CIs, refit ", + "with `fect(..., nboots = 1000)` and re-call estimand().", + call. = FALSE + ) + } + invisible(TRUE) +} + + +.check_jackknife_ci_method <- function(ci.method) { + if (ci.method != "normal") { + stop( + "ci.method = \"", ci.method, "\" is not supported for fits ", + "produced with vartype = \"jackknife\".\n\n", + "Jackknife inference produces a standard error (SE) estimate ", + "via the Tukey pseudo-value formula, not a sampling distribution ", + "of the estimator. The only statistically valid CI from jackknife ", + "is the Wald-style interval: estimate +/- z * SE_jack ", + "(ci.method = \"normal\").\n\n", + " Methods basic and percentile require exchangeable draws from ", + "the sampling distribution of theta-hat. Jackknife leave-one-out ", + "values are influence-function-flavored quantities, not ", + "exchangeable draws (Efron & Tibshirani 1993, Chapter 11; ", + "Davison & Hinkley 1997, Section 3.2.1).\n\n", + " Methods bc and bca require a bootstrap distribution to compute ", + "the bias-correction z0 = Phi^-1(P(boot < estimate)). Jackknife ", + "fits have no bootstrap distribution.\n\n", + "Use ci.method = \"normal\" (the default for type = \"att\") or ", + "refit with vartype = \"bootstrap\" to access all ci.methods.", + call. = FALSE + ) + } + invisible(TRUE) +} + + ## --------------------------------------------------------------------------- ## Public: imputed_outcomes() ## --------------------------------------------------------------------------- @@ -338,6 +449,25 @@ imputed_outcomes <- function(fit, ## Replicate expansion: one row per (cell, b) where b indexes ## bootstrap or jackknife replicate. Y_obs and W.agg are constant ## across replicates; Y0_hat and eff vary per replicate. + + ## Jackknife guard: eff.boot has shape TT x (N-1) x N for jackknife. + ## The second dimension is N-1, not N, so indexing eff.boot[t, i, b] + ## with the full panel's column index i (1..N) accesses incorrect slices + ## for i > N-1 or returns out-of-bounds values. The replicate expansion + ## cannot be aligned to the full panel's cell coordinates under jackknife. + if (replicates && isTRUE(fit$vartype == "jackknife")) { + stop( + "imputed_outcomes(replicates = TRUE) is not supported for ", + "fits with vartype = \"jackknife\". Jackknife replicates drop one ", + "unit per fit, so each replicate has N-1 columns rather than N; ", + "the per-cell replicates cannot be aligned to the full panel's cell ", + "coordinates. Use replicates = FALSE for the point-estimate surface, ", + "or refit with vartype = \"bootstrap\" to access the replicate ", + "expansion.", + call. = FALSE + ) + } + eb <- fit$eff.boot nboots <- dim(eb)[3] @@ -398,6 +528,17 @@ imputed_outcomes <- function(fit, #' per-event-time series), \code{"cohort"}, \code{"calendar.time"}, #' \code{"overall"} (one row), or any column name resolvable in the #' fit's panel data. +#' @param test Selects which subset of cells to aggregate over (v2.4.3+). +#' \code{"none"} (default) uses standard treated post-treatment +#' cells. \code{"placebo"} restricts to pre-treatment cells in +#' \code{fit$placebo.period} that were masked-and-imputed during the +#' placebo fit; produces e.g.\ a per-event-time placebo APTT series +#' for credibility checks. Requires \code{placeboTest = TRUE} at fit +#' time; forces \code{direction = "on"}. \code{"carryover"} is the +#' analogous extension on the reversal side; requires +#' \code{carryoverTest = TRUE} + a panel with reversals; forces +#' \code{direction = "off"}. Both incompatible with +#' \code{type = "att.cumu"}. #' @param cells Optional filter on which treated cells to include. #' Accepts \code{NULL} (default; all treated cells), a logical vector, #' or a one-sided formula. See \code{\link{imputed_outcomes}}. @@ -416,8 +557,17 @@ imputed_outcomes <- function(fit, #' with a different setting --- the argument is informational and does #' not re-aggregate replicates. #' @param conf.level Two-sided confidence level. Defaults to 0.95. -#' @param ci.method \code{"basic"} (reflected; matches fect's existing -#' \code{est.att} convention; default) or \code{"percentile"}. +#' @param ci.method One of \code{"basic"} (reflected), +#' \code{"percentile"} (raw bootstrap quantiles), \code{"bc"} +#' (bias-corrected percentile; Efron 1987 minus the acceleration), +#' or \code{"normal"} (Wald: \eqn{\hat\theta \pm z \cdot SE}). +#' Default is \code{NULL}, which triggers a per-type default: +#' \code{"att"} -> \code{"normal"} (matches what \code{fit$est.att} +#' already uses), \code{"att.cumu"} -> \code{"percentile"} (matches +#' what \code{att.cumu()} does internally), \code{"aptt"} -> +#' \code{"bc"} and \code{"log.att"} -> \code{"bc"} (ratio / log +#' estimators benefit from bias correction when the bootstrap +#' distribution is skewed). Pass an explicit value to override. #' #' @return A data frame with columns \code{}, \code{estimate}, #' \code{se}, \code{ci.lo}, \code{ci.hi}, \code{n_cells}, and @@ -450,18 +600,50 @@ estimand <- function(fit, type = c("att", "att.cumu", "aptt", "log.att"), by = c("event.time", "cohort", "calendar.time", "overall"), + test = c("none", "placebo", "carryover"), cells = NULL, weights = NULL, window = NULL, direction = c("on", "off"), vartype = c("bootstrap", "jackknife", "parametric", "none"), conf.level = 0.95, - ci.method = c("basic", "percentile")) { + ci.method = NULL) { type <- match.arg(type) - direction <- match.arg(direction) + test <- match.arg(test) vartype <- match.arg(vartype) - ci.method <- match.arg(ci.method) + + ## test = "placebo" / "carryover": auto-set direction to the semantic + ## default. Users should not need to remember the pairing. + if (test == "placebo") { + direction <- "on" + } else if (test == "carryover") { + direction <- "off" + } else { + direction <- match.arg(direction) + } + + ## Cumulative semantics are undefined for placebo / carryover cells. + if (test != "none" && type == "att.cumu") { + stop("estimand(type = \"att.cumu\") is incompatible with ", + "test = \"", test, "\". Cumulative effects are defined ", + "relative to treatment onset; placebo and carryover cells ", + "do not have a meaningful cumulative anchor.", + call. = FALSE) + } + + ## ci.method = NULL triggers per-type defaults (v2.4.2+). + ## See statsclaw-workspace/fect/ref/v242-vartype-cimethod-design.md. + if (is.null(ci.method)) { + ci.method <- switch(type, + "att" = "normal", ## matches what fit$est.att uses (Wald: theta +- z*SE) + "att.cumu" = "basic", ## reflected pivot CI (Davison-Hinkley 1997 §5.2.1; boot::boot.ci(type = "basic")) + "aptt" = "bca", ## ratio: bootstrap-bias + skew -> BCa (Efron 1987) + "log.att" = "bca" ## log: same rationale + ) + } + ci.method <- match.arg(ci.method, + c("basic", "percentile", "bc", "bca", "normal")) by_canon <- c("event.time", "cohort", "calendar.time", "overall") if (length(by) > 1L) { @@ -498,32 +680,49 @@ estimand <- function(fit, .validate_po_contract(fit) - if (type == "att") { - return(.estimand_att(fit, by, cells, weights, direction, - vartype, conf.level, ci.method)) + ## Jackknife ci.method guard: only "normal" is statistically valid. + ## See .check_jackknife_ci_method() for the full rationale. + ## Placed after .validate_po_contract() so fit is known to be a list. + if (isTRUE(fit$vartype == "jackknife") && vartype != "none") { + .check_jackknife_ci_method(ci.method) } - if (type == "att.cumu") { - return(.estimand_att_cumu(fit, by, cells, weights, direction, - vartype, conf.level, ci.method, window)) - } - if (type == "aptt") { - return(.estimand_aptt(fit, by, cells, weights, direction, - vartype, conf.level, ci.method)) - } - if (type == "log.att") { - return(.estimand_log_att(fit, by, cells, weights, direction, - vartype, conf.level, ci.method)) + + ## Tail-CI under-replication warning: bc / bca / percentile / basic CIs + ## need B >= 1000 for stable tail quantiles. Warning, not error, so users + ## can still explore on small B during iteration. + .check_tail_ci_replicates(fit, ci.method, vartype) + + result <- if (type == "att") { + .estimand_att(fit, by, cells, weights, direction, + vartype, conf.level, ci.method, test) + } else if (type == "att.cumu") { + .estimand_att_cumu(fit, by, cells, weights, direction, + vartype, conf.level, ci.method, window) + } else if (type == "aptt") { + .estimand_aptt(fit, by, cells, weights, direction, + vartype, conf.level, ci.method, test) + } else if (type == "log.att") { + .estimand_log_att(fit, by, cells, weights, direction, + vartype, conf.level, ci.method, test) + } else { + stop("type = \"", type, "\" is part of the v2.4.0 API surface but ", + "is not yet implemented at this commit. Stay tuned.", + call. = FALSE) } - stop("type = \"", type, "\" is part of the v2.4.0 API surface but ", - "is not yet implemented at this commit. Stay tuned.", - call. = FALSE) + ## Attach a hidden attribute so esplot() can recognize placebo/carryover + ## frames and adapt its visual defaults (e.g., uniform color across all + ## event-times since there's no pre-vs-post contrast in those modes). + if (!is.null(test) && test != "none") { + attr(result, "fect_test") <- test + } + result } ## Internal: type = "att" dispatcher. .estimand_att <- function(fit, by, cells, weights, direction, - vartype, conf.level, ci.method) { + vartype, conf.level, ci.method, test = "none") { ## Fast path: by = "event.time" + default args + direction = "on". ## Reads directly from fit$est.att for byte-equality with the existing @@ -533,21 +732,30 @@ estimand <- function(fit, ## - weights = NULL (use fit's W.agg if any) ## - direction = "on" ## - conf.level = 0.95 (fit$est.att uses 95% by default) - ## - ci.method = "basic" (fect's convention) + ## - ci.method = "normal" (fit$est.att uses Wald: theta +- z*SE) + ## --- this is the v2.4.2 default for type="att" is_fast_path <- by == "event.time" && is.null(cells) && is.null(weights) && direction == "on" && abs(conf.level - 0.95) < 1e-12 && - ci.method == "basic" + ci.method == "normal" && + test == "none" if (is_fast_path) { return(.estimand_att_fast_event_time(fit)) } + if (by == "event.time" && test != "none") { + return(.estimand_att_event_time(fit, cells, weights, direction, + vartype, conf.level, ci.method, + test)) + } + if (by == "overall") { return(.estimand_att_overall(fit, cells, weights, direction, - vartype, conf.level, ci.method)) + vartype, conf.level, ci.method, + test)) } stop("estimand(type = \"att\") with by = \"", by, "\" is part of ", @@ -558,25 +766,193 @@ estimand <- function(fit, } +## Per-event-time ATT slow path. Used when test = "placebo" / +## "carryover" forces per-cell aggregation. +.estimand_att_event_time <- function(fit, cells, weights, direction, + vartype, conf.level, ci.method, + test) { + + if (!is.null(weights)) { + stop("estimand(\"att\", \"event.time\", test = \"", test, "\") ", + "with non-default weights is not yet supported.", + call. = FALSE) + } + if (!is.null(cells)) { + stop("estimand(\"att\", \"event.time\", test = \"", test, "\") ", + "with `cells` filter is not yet supported.", + call. = FALSE) + } + + ## Jackknife dispatch: eff.boot has shape TT x (N-1) x N; direct + ## cell-masking with a TT x N mask is incompatible. Route through + ## the dedicated jackknife helper. + if (isTRUE(fit$vartype == "jackknife")) { + return(.estimand_att_event_time_jackknife(fit, cells, weights, + direction, conf.level, + vartype, ci.method, test)) + } + + mask_info <- .test_cell_mask(fit, test, direction) + base_mask <- mask_info$mask + Tev <- mask_info$Tev + + ets <- sort(unique(Tev[base_mask])) + if (length(ets) == 0) { + stop("No cells satisfy test = \"", test, "\".", call. = FALSE) + } + + nboots <- if (is.null(fit$eff.boot)) 0L else dim(fit$eff.boot)[3] + + estimate <- numeric(length(ets)) + se_vec <- rep(NA_real_, length(ets)) + ci_lo <- rep(NA_real_, length(ets)) + ci_hi <- rep(NA_real_, length(ets)) + n_cells <- integer(length(ets)) + + for (k in seq_along(ets)) { + et <- ets[k] + cell_mask <- base_mask & Tev == et + n_cells[k] <- sum(cell_mask) + + eff_t <- fit$eff[cell_mask] + estimate[k] <- mean(eff_t, na.rm = TRUE) + + if (nboots > 0L && vartype != "none") { + eff_boot_cells <- apply(fit$eff.boot, 3, + function(eb) eb[cell_mask]) + if (!is.matrix(eff_boot_cells)) { + eff_boot_cells <- matrix(eff_boot_cells, + nrow = sum(cell_mask)) + } + att_b <- colMeans(eff_boot_cells, na.rm = TRUE) + + ## PARAMETRIC SHIFT (v2.4.2 fix): center att_b at the point estimate. + ## For parametric vartype, eff.boot is H0-centered; only ci.method="normal" + ## uses sd() and is unaffected by centering. All other ci.methods require + ## the distribution to be centered near estimate. The shift preserves sd(). + is_parametric <- isTRUE(fit$vartype == "parametric") || + isTRUE(vartype == "parametric") + if (is_parametric) { + att_b <- att_b - mean(att_b, na.rm = TRUE) + estimate[k] + } + + jack_v <- if (ci.method == "bca") { + .cell_jackknife("att", eff = eff_t) + } else NULL + + ci <- .compute_ci(estimate[k], att_b, ci.method, conf.level, + jack = jack_v) + se_vec[k] <- ci$se + ci_lo[k] <- ci$ci.lo + ci_hi[k] <- ci$ci.hi + } + } + + used_vartype <- if (vartype == "none") "none" + else if (is.null(fit$vartype)) "bootstrap" + else fit$vartype + + data.frame( + event.time = ets, + estimate = estimate, + se = se_vec, + ci.lo = ci_lo, + ci.hi = ci_hi, + n_cells = n_cells, + vartype = used_vartype, + stringsAsFactors = FALSE + ) +} + + +## Per-event-time ATT slow path for jackknife fits. +## Called from .estimand_att_event_time() when fit$vartype == "jackknife". +## Uses the same column-drop masking as .estimand_att_overall_jackknife() +## to handle the TT x (N-1) x N shape of eff.boot. +.estimand_att_event_time_jackknife <- function(fit, cells, weights, + direction, conf.level, + vartype, ci.method, test) { + + mask_info <- .test_cell_mask(fit, test, direction) + base_mask <- mask_info$mask + Tev <- mask_info$Tev + + ets <- sort(unique(Tev[base_mask])) + if (length(ets) == 0) { + stop("No cells satisfy test = \"", test, "\".", call. = FALSE) + } + + nboots <- if (is.null(fit$eff.boot)) 0L else dim(fit$eff.boot)[3] + + estimate <- numeric(length(ets)) + se_vec <- rep(NA_real_, length(ets)) + ci_lo <- rep(NA_real_, length(ets)) + ci_hi <- rep(NA_real_, length(ets)) + n_cells <- integer(length(ets)) + + for (k in seq_along(ets)) { + et <- ets[k] + cell_mask <- base_mask & Tev == et + n_cells[k] <- sum(cell_mask) + + eff_t <- fit$eff[cell_mask] + estimate[k] <- mean(eff_t, na.rm = TRUE) + + ## Jackknife: per-replicate leave-one-out mean over cells. + if (nboots > 0L && vartype != "none") { + theta_j <- numeric(nboots) + for (j in seq_len(nboots)) { + cm_j <- cell_mask[, -j, drop = FALSE] + eb_j <- fit$eff.boot[, , j] + theta_j[j] <- mean(eb_j[cm_j], na.rm = TRUE) + } + theta_valid <- theta_j[is.finite(theta_j)] + N_eff <- length(theta_valid) + if (N_eff >= 2L) { + pseudo <- nboots * estimate[k] - (nboots - 1) * theta_valid + se_vec[k] <- sqrt(var(pseudo) / N_eff) + z_q <- stats::qnorm(1 - (1 - conf.level) / 2) + ci_lo[k] <- estimate[k] - z_q * se_vec[k] + ci_hi[k] <- estimate[k] + z_q * se_vec[k] + } + } + } + + data.frame( + event.time = ets, + estimate = estimate, + se = se_vec, + ci.lo = ci_lo, + ci.hi = ci_hi, + n_cells = n_cells, + vartype = "jackknife", + stringsAsFactors = FALSE + ) +} + + ## Compute overall ATT (single scalar) over treated cells, optionally ## filtered. Reads from fit$eff and fit$D.dat directly; bootstrap from ## fit$eff.boot if available, else delegates to the pre-aggregated ## fit$att.avg.boot when no cells filter is active. .estimand_att_overall <- function(fit, cells, weights, direction, - vartype, conf.level, ci.method) { + vartype, conf.level, ci.method, + test = "none") { if (!is.null(weights)) { stop("estimand(\"att\", \"overall\") with non-default weights ", "is not yet supported in v2.4.0.", call. = FALSE) } - - Tev <- if (direction == "on") fit$T.on else fit$T.off - if (is.null(Tev)) { - stop("direction = \"off\" requested, but fit$T.off is NULL.", + if (test != "none" && !is.null(cells)) { + stop("estimand(\"att\", \"overall\") with both test = \"", test, + "\" and `cells` is not supported. The test = ... argument ", + "already filters cells to the placebo / carryover window.", call. = FALSE) } - treated_mask <- !is.na(fit$D.dat) & fit$D.dat == 1 & !is.na(Tev) + mask_info <- .test_cell_mask(fit, test, direction) + treated_mask <- mask_info$mask + Tev <- mask_info$Tev ## Apply cells filter at the event-time / id level, not via long-form ## conversion (faster). Build a per-cell mask matching shape(eff). @@ -616,22 +992,38 @@ estimand <- function(fit, "per-cell bootstrap surface is available.", call. = FALSE) } + + ## Jackknife: eff.boot has shape TT x (N-1) x N. Each slice eff.boot[,,j] + ## is the effect matrix for the fit that excluded unit j; it has N-1 columns + ## mapping to the N-1 retained units. We cannot apply cell_mask (TT x N) + ## directly to eff.boot[,,j] (TT x (N-1)). Instead, reroute through the + ## jackknife-specific helper. + if (isTRUE(fit$vartype == "jackknife")) { + return(.estimand_att_overall_jackknife(fit, cell_mask, conf.level, + vartype)) + } + nboots <- dim(fit$eff.boot)[3] att_b <- vapply(seq_len(nboots), function(b) { mean(fit$eff.boot[, , b][cell_mask], na.rm = TRUE) }, numeric(1)) - se_val <- stats::sd(att_b, na.rm = TRUE) - alpha <- 1 - conf.level - probs <- c(alpha / 2, 1 - alpha / 2) - qs <- stats::quantile(att_b, probs = probs, na.rm = TRUE) - if (ci.method == "percentile") { - ci_lo <- unname(qs[1]) - ci_hi <- unname(qs[2]) - } else { - ci_lo <- 2 * estimate - unname(qs[2]) - ci_hi <- 2 * estimate - unname(qs[1]) + ## PARAMETRIC SHIFT (v2.4.2 fix) + is_parametric <- isTRUE(fit$vartype == "parametric") || + isTRUE(vartype == "parametric") + if (is_parametric) { + att_b <- att_b - mean(att_b, na.rm = TRUE) + estimate } + + jack_v <- if (ci.method == "bca") { + .cell_jackknife("att", eff = fit$eff[cell_mask]) + } else NULL + + ci <- .compute_ci(estimate, att_b, ci.method, conf.level, + jack = jack_v) + se_val <- ci$se + ci_lo <- ci$ci.lo + ci_hi <- ci$ci.hi } used_vartype <- if (vartype == "none") "none" @@ -650,6 +1042,132 @@ estimand <- function(fit, } +## Compute overall ATT under jackknife using the Tukey SE from the +## per-event-time att.boot matrix. +## +## Strategy: eff.boot is TT x (N-1) x N for jackknife. Direct cell-masking +## is not applicable because each slice drops one unit column. Instead, use +## the pre-aggregated att.avg.unit.boot (per-unit leave-one-out ATT averages, +## 1 x N) to compute N scalar overall-ATT leave-one-out estimates, then apply +## the Tukey SE formula. +## +## When a cells filter is active, fall back to per-replicate recomputation +## from eff.boot by mapping each replicate's reduced column space back to +## the cell mask of the retained units. +## +## Arguments: +## fit - fect object with vartype == "jackknife" +## cell_mask - logical TT x N matrix; TRUE at treated cells to include +## conf.level - numeric confidence level (default 0.95) +## vartype - "jackknife" or "none" +## +## Returns a one-row data frame with estimate, se, ci.lo, ci.hi, n_cells, +## vartype (same schema as .estimand_att_overall()). +.estimand_att_overall_jackknife <- function(fit, cell_mask, conf.level, + vartype) { + if (vartype == "none") { + ## No SE requested. + estimate <- mean(fit$eff[cell_mask], na.rm = TRUE) + return(data.frame( + estimate = estimate, se = NA_real_, + ci.lo = NA_real_, ci.hi = NA_real_, + n_cells = as.integer(sum(cell_mask)), + vartype = "none", + stringsAsFactors = FALSE + )) + } + + estimate <- mean(fit$eff[cell_mask], na.rm = TRUE) + n_cells <- sum(cell_mask) + + ## Determine whether the cell_mask is "all treated cells" (no filter + ## beyond the standard treated-cell mask). In that case we can use the + ## pre-aggregated att.avg.unit.boot slot (1 x N matrix) for the + ## Tukey SE rather than recomputing from eff.boot. + ## att.avg.unit.boot is a unit-weighted grand average of all post-treatment + ## cells, which equals mean(eff[treated_mask]) when there is no + ## additional filter. + all_treated_mask <- !is.na(fit$D.dat) & fit$D.dat == 1 & + !is.na(fit$T.on) + use_precomp <- identical(cell_mask, all_treated_mask) && + !is.null(fit$att.avg.unit.boot) + + if (use_precomp) { + ## att.avg.unit.boot: 1 x N matrix (one row; N columns = jackknife + ## replicates). jackknifed() formula: + ## pseudo_j = N * theta_hat - (N-1) * theta_j + ## SE = sqrt(var(pseudo_j) / N) + theta_j <- as.vector(fit$att.avg.unit.boot) + N_jack <- length(theta_j) + theta_j_valid <- theta_j[!is.na(theta_j)] + N_eff <- length(theta_j_valid) + if (N_eff < 2L) { + return(data.frame( + estimate = estimate, se = NA_real_, + ci.lo = NA_real_, ci.hi = NA_real_, + n_cells = as.integer(n_cells), + vartype = "jackknife", + stringsAsFactors = FALSE + )) + } + pseudo <- N_jack * estimate - (N_jack - 1) * theta_j_valid + se_val <- sqrt(var(pseudo) / N_eff) + } else { + ## Cells filter is active or att.avg.unit.boot is unavailable. + ## Recompute per-replicate overall ATT from eff.boot. + ## + ## eff.boot[, , j] is TT x (N-1): the effect matrix for the panel + ## with unit j removed. The column ordering of eff.boot[,,j] matches + ## fit$id[-j] (all units except unit j, in original order). + ## + ## For each replicate j: + ## 1. Build the corresponding cell_mask_j (TT x (N-1)) by dropping + ## column j from cell_mask. + ## 2. Compute theta_j = mean(eff.boot[,,j][cell_mask_j]). + ## + ## This is correct because cell_mask[t, j] is FALSE for unit j at any + ## time (unit j is only in the full panel, not in a leave-one-out fit + ## that excludes j). Dropping column j from cell_mask gives the mask + ## applicable to eff.boot[,,j]. + N_jack <- dim(fit$eff.boot)[3] + theta_j <- numeric(N_jack) + for (j in seq_len(N_jack)) { + ## Drop column j from cell_mask. + cm_j <- cell_mask[, -j, drop = FALSE] + eb_j <- fit$eff.boot[, , j] ## TT x (N-1) + theta_j[j] <- mean(eb_j[cm_j], na.rm = TRUE) + } + theta_j_valid <- theta_j[is.finite(theta_j)] + N_eff <- length(theta_j_valid) + if (N_eff < 2L) { + return(data.frame( + estimate = estimate, se = NA_real_, + ci.lo = NA_real_, ci.hi = NA_real_, + n_cells = as.integer(n_cells), + vartype = "jackknife", + stringsAsFactors = FALSE + )) + } + pseudo <- N_jack * estimate - (N_jack - 1) * theta_j_valid + se_val <- sqrt(var(pseudo) / N_eff) + } + + z <- stats::qnorm(1 - (1 - conf.level) / 2) + ci_lo <- estimate - z * se_val + ci_hi <- estimate + z * se_val + + data.frame( + estimate = estimate, + se = se_val, + ci.lo = ci_lo, + ci.hi = ci_hi, + n_cells = as.integer(n_cells), + vartype = "jackknife", + stringsAsFactors = FALSE + ) +} + + ## Fast path implementation: byte-equality with fit$est.att. No ## recomputation; just reshapes the existing matrix into the tidy ## return schema. @@ -821,7 +1339,7 @@ estimand <- function(fit, ## replicate, so the bootstrap distribution is the distribution of ## ratios, not the ratio of mean distributions. .estimand_aptt <- function(fit, by, cells, weights, direction, - vartype, conf.level, ci.method) { + vartype, conf.level, ci.method, test = "none") { if (!is.null(weights)) { stop("estimand(\"aptt\") with non-default weights is not yet ", @@ -839,7 +1357,7 @@ estimand <- function(fit, if (by == "event.time") { return(.compute_aptt_event_time(fit, conf.level, ci.method, - vartype, direction)) + vartype, direction, test)) } stop("estimand(\"aptt\") with by = \"", by, "\" is not yet ", @@ -850,20 +1368,15 @@ estimand <- function(fit, ## Compute per-event-time APTT with bootstrap CI. .compute_aptt_event_time <- function(fit, conf.level, ci.method, vartype, - direction) { + direction, test = "none") { - Tev <- if (direction == "on") fit$T.on else fit$T.off - if (is.null(Tev)) { - stop("direction = \"off\" requested, but fit$T.off is NULL.", - call. = FALSE) - } - - treated_mask <- !is.na(fit$D.dat) & fit$D.dat == 1 & !is.na(Tev) + mask_info <- .test_cell_mask(fit, test, direction) + treated_mask <- mask_info$mask + Tev <- mask_info$Tev ets <- sort(unique(Tev[treated_mask])) if (length(ets) == 0) { - stop("No treated cells with non-NA event time found.", - call. = FALSE) + stop("No cells satisfy test = \"", test, "\".", call. = FALSE) } nboots <- if (is.null(fit$eff.boot)) 0L else dim(fit$eff.boot)[3] @@ -890,26 +1403,86 @@ estimand <- function(fit, den <- mean(Y0_t, na.rm = TRUE) estimate[k] <- num / den - ## Bootstrap distribution per replicate. + ## Bootstrap / jackknife distribution per replicate. if (nboots > 0L && vartype != "none") { - ## eff_boot_cells: rows = cells in this group, cols = replicates. - eff_boot_cells <- apply(fit$eff.boot, 3, function(eb) eb[cell_mask]) - if (!is.matrix(eff_boot_cells)) { - eff_boot_cells <- matrix(eff_boot_cells, - nrow = sum(cell_mask)) - } - Y0_boot <- Y_t - eff_boot_cells - aptt_b <- colMeans(eff_boot_cells, na.rm = TRUE) / - colMeans(Y0_boot, na.rm = TRUE) - - se_vec[k] <- stats::sd(aptt_b, na.rm = TRUE) - qs <- stats::quantile(aptt_b, probs = probs, na.rm = TRUE) - if (ci.method == "percentile") { - ci_lo[k] <- unname(qs[1]) - ci_hi[k] <- unname(qs[2]) + if (isTRUE(fit$vartype == "jackknife")) { + ## Jackknife branch: column-drop masking for TT x (N-1) x N eff.boot. + ## For each replicate j (unit j dropped), extract the surviving cells + ## and compute per-replicate APTT. + keep_cols <- seq_len(ncol(fit$D.dat)) + theta_j <- numeric(nboots) + for (j in seq_len(nboots)) { + ## Build TT x (N-1) masks aligned with eff.boot[,,j]. + kcols <- keep_cols[-j] + cm_j_full <- cell_mask[, kcols, drop = FALSE] + eb_j <- fit$eff.boot[, , j] ## TT x (N-1) + eff_j_v <- eb_j[cm_j_full] + Y_j <- fit$Y.dat[, kcols, drop = FALSE][cm_j_full] + Y0_j_v <- Y_j - eff_j_v + denom_j <- mean(Y0_j_v, na.rm = TRUE) + if (is.finite(denom_j) && abs(denom_j) > 1e-10) { + theta_j[j] <- mean(eff_j_v, na.rm = TRUE) / denom_j + } else { + theta_j[j] <- NA_real_ + } + } + theta_valid <- theta_j[is.finite(theta_j)] + N_eff <- length(theta_valid) + if (N_eff >= 2L) { + pseudo <- nboots * estimate[k] - (nboots - 1) * theta_valid + se_vec[k] <- sqrt(var(pseudo) / N_eff) + z_q <- stats::qnorm(1 - (1 - conf.level) / 2) + ci_lo[k] <- estimate[k] - z_q * se_vec[k] + ci_hi[k] <- estimate[k] + z_q * se_vec[k] + } } else { - ci_lo[k] <- 2 * estimate[k] - unname(qs[2]) - ci_hi[k] <- 2 * estimate[k] - unname(qs[1]) + ## Bootstrap / wild / parametric branch (original code). + ## eff_boot_cells: rows = cells in this group, cols = replicates. + eff_boot_cells <- apply(fit$eff.boot, 3, function(eb) eb[cell_mask]) + if (!is.matrix(eff_boot_cells)) { + eff_boot_cells <- matrix(eff_boot_cells, + nrow = sum(cell_mask)) + } + Y0_boot <- Y_t - eff_boot_cells + + ## Hard-error on cell-drop pathology (v2.4.2+). + ## See .compute_log_att_event_time for the full rationale. + ## For APTT specifically: when E(Y0_b) crosses zero in any + ## replicate, the denominator blows up (or flips sign), + ## producing wildly unstable per-replicate APTT values. + mean_Y0_per_rep <- colMeans(Y0_boot, na.rm = TRUE) + n_bad_reps <- sum(abs(mean_Y0_per_rep) < 1e-10 | + is.na(mean_Y0_per_rep)) + if (n_bad_reps > 0L) { + pct_bad <- 100 * n_bad_reps / length(mean_Y0_per_rep) + stop(sprintf( + "APTT bootstrap is unreliable at event time %s\n (E(Y0_hat) at the point = %.4f, but %d of %d bootstrap replicates\n (%.1f%%) have E(Y0_b) ~ 0, blowing up the APTT denominator and\n producing wildly unstable per-replicate ratios).\n\n Options:\n 1. Filter out cells where E(Y0_hat) is small relative to E(Y):\n estimand(fit, \"aptt\", \"event.time\",\n cells = ~ abs(Y0_hat) > )\n 2. Transform the outcome to keep Y0_hat away from zero\n 3. Use a different estimand: estimand(\"att\", ...) does not have\n this denominator instability", + as.character(et), den, n_bad_reps, + length(mean_Y0_per_rep), pct_bad + ), call. = FALSE) + } + + aptt_b <- colMeans(eff_boot_cells, na.rm = TRUE) / + mean_Y0_per_rep + + ## PARAMETRIC SHIFT (v2.4.2 fix) + is_parametric <- isTRUE(fit$vartype == "parametric") || + isTRUE(vartype == "parametric") + if (is_parametric) { + aptt_b <- aptt_b - mean(aptt_b, na.rm = TRUE) + estimate[k] + } + + ## Cell-level jackknife for the BCa acceleration parameter. + ## Only computed when bca is requested (cheap; no model refits). + jack_v <- if (ci.method == "bca") { + .cell_jackknife("aptt", eff = eff_t, Y0 = Y0_t) + } else NULL + + ci <- .compute_ci(estimate[k], aptt_b, ci.method, conf.level, + jack = jack_v) + se_vec[k] <- ci$se + ci_lo[k] <- ci$ci.lo + ci_hi[k] <- ci$ci.hi } } } @@ -934,10 +1507,13 @@ estimand <- function(fit, ## Internal: type = "log.att" dispatcher. ## ## logATT_g = mean_g(log(Y_obs) - log(Y0_hat)) over treated cells. -## Cells where Y_obs <= 0 or Y0_hat <= 0 are dropped from the -## aggregation with a one-time warning per call. +## Hard-stops if any cell included in the aggregation has Y_obs <= 0 or +## Y0_hat <= 0 (log undefined). Caller must pre-transform the outcome +## (e.g. log(Y + c) inside fect) so that all imputed and observed +## outcomes are strictly positive before requesting log.att. .estimand_log_att <- function(fit, by, cells, weights, direction, - vartype, conf.level, ci.method) { + vartype, conf.level, ci.method, + test = "none") { if (!is.null(weights)) { stop("estimand(\"log.att\") with non-default weights is not ", @@ -953,9 +1529,31 @@ estimand <- function(fit, call. = FALSE) } + ## Hard-stop on Y <= 0 / Y0_hat <= 0 at the point-estimate level. + ## log.att is mathematically undefined for non-positive imputed or + ## observed outcomes; silently dropping cells contaminates both the + ## point estimate and the bootstrap distribution. Force the caller + ## to pre-transform (typical fix: log(Y + c) for some c > 0 chosen + ## so all Y0_hat > 0; refit; then re-call estimand). + mask_info <- .test_cell_mask(fit, test, direction) + cells_mask <- mask_info$mask + Y_chk <- fit$Y.dat[cells_mask] + Y0_chk <- Y_chk - fit$eff[cells_mask] + n_bad_Y <- sum(!is.na(Y_chk) & Y_chk <= 0) + n_bad_Y0 <- sum(!is.na(Y0_chk) & Y0_chk <= 0) + if (n_bad_Y + n_bad_Y0 > 0L) { + min_Y <- if (n_bad_Y > 0L) min(Y_chk[!is.na(Y_chk)], na.rm = TRUE) else NA_real_ + min_Y0 <- if (n_bad_Y0 > 0L) min(Y0_chk[!is.na(Y0_chk)], na.rm = TRUE) else NA_real_ + stop(sprintf( + "log.att requires Y > 0 and Y0_hat > 0 in all treated cells.\n Found %d cell(s) with Y <= 0 (min Y = %s) and %d cell(s) with Y0_hat <= 0 (min Y0_hat = %s).\n log(Y) and log(Y0_hat) are undefined; silent dropping would bias the point estimate.\n\n Fix: refit fect on a strictly-positive outcome, e.g.\n data$Y_pos <- data$Y + (abs(min(data$Y)) + 1)\n fit <- fect(Y_pos ~ D, ...)\n estimand(fit, \"log.att\", \"event.time\")\n Then back out the original-scale interpretation as needed.", + n_bad_Y, if (is.na(min_Y)) "NA" else sprintf("%.4f", min_Y), + n_bad_Y0, if (is.na(min_Y0)) "NA" else sprintf("%.4f", min_Y0) + ), call. = FALSE) + } + if (by == "event.time") { return(.compute_log_att_event_time(fit, conf.level, ci.method, - vartype, direction)) + vartype, direction, test)) } stop("estimand(\"log.att\") with by = \"", by, "\" is not yet ", @@ -967,20 +1565,16 @@ estimand <- function(fit, ## Compute per-event-time log-ATT. Drops cells where either Y_obs or ## Y0_hat is non-positive (would give -Inf or NaN under log). .compute_log_att_event_time <- function(fit, conf.level, ci.method, - vartype, direction) { - - Tev <- if (direction == "on") fit$T.on else fit$T.off - if (is.null(Tev)) { - stop("direction = \"off\" requested, but fit$T.off is NULL.", - call. = FALSE) - } + vartype, direction, + test = "none") { - treated_mask <- !is.na(fit$D.dat) & fit$D.dat == 1 & !is.na(Tev) + mask_info <- .test_cell_mask(fit, test, direction) + treated_mask <- mask_info$mask + Tev <- mask_info$Tev ets <- sort(unique(Tev[treated_mask])) if (length(ets) == 0) { - stop("No treated cells with non-NA event time found.", - call. = FALSE) + stop("No cells satisfy test = \"", test, "\".", call. = FALSE) } nboots <- if (is.null(fit$eff.boot)) 0L else dim(fit$eff.boot)[3] @@ -994,8 +1588,6 @@ estimand <- function(fit, alpha <- 1 - conf.level probs <- c(alpha / 2, 1 - alpha / 2) - n_dropped_total <- 0L - for (k in seq_along(ets)) { et <- ets[k] cell_mask <- treated_mask & Tev == et @@ -1004,9 +1596,9 @@ estimand <- function(fit, Y_t <- fit$Y.dat[cell_mask] Y0_t <- Y_t - eff_t - ## Drop non-positive cells (log undefined). - ok <- !is.na(Y_t) & !is.na(Y0_t) & Y_t > 0 & Y0_t > 0 - n_dropped_total <- n_dropped_total + sum(!ok) + ## Caller-level hard-stop in .estimand_log_att already guarantees + ## all cells have Y > 0 and Y0_hat > 0; only NA filtering needed. + ok <- !is.na(Y_t) & !is.na(Y0_t) n_cells[k] <- sum(ok) if (sum(ok) == 0L) { @@ -1018,47 +1610,108 @@ estimand <- function(fit, estimate[k] <- mean(log_diff, na.rm = TRUE) if (nboots > 0L && vartype != "none") { - eff_boot_cells <- apply(fit$eff.boot, 3, - function(eb) eb[cell_mask]) - if (!is.matrix(eff_boot_cells)) { - eff_boot_cells <- matrix(eff_boot_cells, - nrow = sum(cell_mask)) - } - ## Restrict to ok cells. Y_t is constant; Y0_boot varies - ## per replicate, so the per-replicate "ok" mask depends - ## on Y0_boot[, b]. To keep this tractable, we condition - ## on the point-estimate ok mask (drop cells whose POINT - ## Y0 is non-positive). This is what users typically - ## want for log-ATT inference. - eff_ok <- eff_boot_cells[ok, , drop = FALSE] - Y_ok <- Y_t[ok] - Y0_b_ok <- Y_ok - eff_ok - ## Per-replicate: drop replicates where any Y0_b <= 0 in - ## the ok set; alternatively, treat as NA and propagate. - log_Y0_b <- suppressWarnings(log(Y0_b_ok)) - log_Y <- log(Y_ok) - log_diff_b <- log_Y - log_Y0_b - logatt_b <- colMeans(log_diff_b, na.rm = TRUE) - - se_vec[k] <- stats::sd(logatt_b, na.rm = TRUE) - qs <- stats::quantile(logatt_b, probs = probs, na.rm = TRUE) - if (ci.method == "percentile") { - ci_lo[k] <- unname(qs[1]) - ci_hi[k] <- unname(qs[2]) + if (isTRUE(fit$vartype == "jackknife")) { + ## Jackknife branch: column-drop masking for TT x (N-1) x N eff.boot. + ## For each replicate j (unit j dropped), extract the surviving cells + ## and compute per-replicate log-ATT using log(Y_j) - log(Y0_j). + keep_cols <- seq_len(ncol(fit$D.dat)) + theta_j <- numeric(nboots) + for (j in seq_len(nboots)) { + kcols <- keep_cols[-j] + cm_j_full <- cell_mask[, kcols, drop = FALSE] + eb_j <- fit$eff.boot[, , j] ## TT x (N-1) + eff_j_v <- eb_j[cm_j_full] + Y_j <- fit$Y.dat[, kcols, drop = FALSE][cm_j_full] + Y0_j_v <- Y_j - eff_j_v + ok_j <- !is.na(Y_j) & !is.na(Y0_j_v) & + Y_j > 0 & Y0_j_v > 0 + if (sum(ok_j) == 0L) { + theta_j[j] <- NA_real_ + } else { + theta_j[j] <- mean(log(Y_j[ok_j]) - log(Y0_j_v[ok_j]), + na.rm = TRUE) + } + } + theta_valid <- theta_j[is.finite(theta_j)] + N_eff <- length(theta_valid) + if (N_eff >= 2L) { + pseudo <- nboots * estimate[k] - (nboots - 1) * theta_valid + se_vec[k] <- sqrt(var(pseudo) / N_eff) + z_q <- stats::qnorm(1 - (1 - conf.level) / 2) + ci_lo[k] <- estimate[k] - z_q * se_vec[k] + ci_hi[k] <- estimate[k] + z_q * se_vec[k] + } } else { - ci_lo[k] <- 2 * estimate[k] - unname(qs[2]) - ci_hi[k] <- 2 * estimate[k] - unname(qs[1]) + ## Bootstrap / wild / parametric branch (original code). + eff_boot_cells <- apply(fit$eff.boot, 3, + function(eb) eb[cell_mask]) + if (!is.matrix(eff_boot_cells)) { + eff_boot_cells <- matrix(eff_boot_cells, + nrow = sum(cell_mask)) + } + eff_ok <- eff_boot_cells[ok, , drop = FALSE] + Y_ok <- Y_t[ok] + Y0_b_ok <- Y_ok - eff_ok + + ## Hard-error on cell-drop pathology (v2.4.2+). + ## + ## When a cell used in the point estimate has Y0_b <= 0 in + ## a non-trivial fraction of bootstrap replicates, log(Y0_b) + ## returns NaN and colMeans(..., na.rm = TRUE) silently + ## averages over fewer cells in that replicate, breaking + ## the basic bootstrap principle and contaminating the + ## bootstrap distribution. + ## + ## Threshold: trigger when the WORST cell has Y0_b <= 0 in + ## > 5% of replicates. Sub-threshold cells are tolerated + ## (small dropping is benign at the bootstrap-distribution + ## scale; >5% indicates a genuinely unstable cell that + ## needs filtering or a different estimand). + n_reps_per_cell <- rowSums(Y0_b_ok <= 0, na.rm = TRUE) + n_total_reps <- ncol(Y0_b_ok) + drop_frac <- n_reps_per_cell / n_total_reps + worst_idx <- which.max(drop_frac) + worst_frac <- drop_frac[worst_idx] + if (length(worst_frac) && worst_frac > 0.05) { + worst_Y0 <- Y0_t[ok][worst_idx] + stop(sprintf( + "log-ATT bootstrap is unreliable at event time %s.\n The worst cell has Y0_hat = %.4f but %d of %d bootstrap replicates\n (%.1f%%) have Y0_b <= 0 for it, so log(Y0_b) is undefined and the\n per-replicate average silently drops the cell. This contaminates the\n bootstrap distribution and yields meaningless inference.\n\n Options:\n 1. Filter out unstable cells:\n estimand(fit, \"log.att\", \"event.time\",\n cells = ~ Y0_hat > )\n 2. Transform the outcome before fect: log(Y + c) for some c > 0\n 3. Use a different estimand: estimand(\"att\", ...) does not have\n this pathology", + as.character(et), worst_Y0, + n_reps_per_cell[worst_idx], n_total_reps, + 100 * worst_frac + ), call. = FALSE) + } + + log_Y0_b <- log(Y0_b_ok) + log_Y <- log(Y_ok) + log_diff_b <- log_Y - log_Y0_b + logatt_b <- colMeans(log_diff_b, na.rm = TRUE) + + ## PARAMETRIC SHIFT (v2.4.2 fix) + ## Note: log.att with parametric vartype requires strictly positive Y0_hat, + ## which is only reachable when the outcome has been transformed (e.g. log(Y+c)). + ## When reachable, eff.boot is H0-centered so logatt_b ≈ 0; the shift + ## centers it at estimate[k] (the true log-ATT). The shift preserves sd(). + is_parametric <- isTRUE(fit$vartype == "parametric") || + isTRUE(vartype == "parametric") + if (is_parametric) { + logatt_b <- logatt_b - mean(logatt_b, na.rm = TRUE) + estimate[k] + } + + ## Cell-level jackknife on the per-cell log-diff vector. + jack_v <- if (ci.method == "bca") { + .cell_jackknife("log.att", log_diff = log_diff) + } else NULL + + ci <- .compute_ci(estimate[k], logatt_b, ci.method, conf.level, + jack = jack_v) + se_vec[k] <- ci$se + ci_lo[k] <- ci$ci.lo + ci_hi[k] <- ci$ci.hi } } } - if (n_dropped_total > 0L) { - warning(sprintf( - "log.att: dropped %d treated cell(s) with Y_obs <= 0 or Y0_hat <= 0.", - n_dropped_total - ), call. = FALSE) - } - used_vartype <- if (vartype == "none") "none" else if (is.null(fit$vartype)) "bootstrap" else fit$vartype @@ -1080,6 +1733,282 @@ estimand <- function(fit, ## Internal helpers ## --------------------------------------------------------------------------- +## Compute SE and (lo, hi) confidence-interval bounds from a bootstrap +## distribution `boot` (a numeric vector of replicate-level estimates), +## a point `estimate`, and a chosen `ci.method`. +## +## Supports five methods: +## - "basic": ci = (2*est - q_hi, 2*est - q_lo) [reflected] +## - "percentile": ci = (q_lo, q_hi) +## - "bc": bias-corrected percentile (z0 only, no acceleration) +## ci = (q_{Phi(2*z0 + z_alpha/2)}, +## q_{Phi(2*z0 + z_{1-alpha/2})}) +## where z0 = Phi^-1(mean(boot < est)). +## - "bca": bias-corrected accelerated (Efron 1987 full BCa). +## Requires `jack` (a numeric vector of leave-one-out +## point estimates over the cells in the aggregation +## group) to compute the acceleration parameter. +## Cutoffs: a_lo = Phi(z0 + (z0+z_alpha/2) / +## (1 - a*(z0+z_alpha/2))) +## Handles bootstrap-bias + bootstrap-skew jointly; +## default for ratio (aptt) and log (log.att) estimands +## where the bootstrap distribution is inherently +## skewed and bc alone degenerates at the boundary. +## - "normal": ci = est +/- z_{1-alpha/2} * SE [Wald, symmetric] +## +## `jack` is the per-cell leave-one-out vector of within-group point +## estimates; required for "bca", ignored otherwise. The acceleration +## is a = sum((mean(jack) - jack)^3) / (6 * (sum(...^2))^1.5). +## +## Returns a list with elements `se`, `ci.lo`, `ci.hi`. +.compute_ci <- function(estimate, boot, ci.method, conf.level, jack = NULL) { + alpha <- 1 - conf.level + se <- stats::sd(boot, na.rm = TRUE) + + if (ci.method == "normal") { + z <- stats::qnorm(1 - alpha / 2) + return(list(se = se, + ci.lo = estimate - z * se, + ci.hi = estimate + z * se)) + } + + probs <- c(alpha / 2, 1 - alpha / 2) + qs <- stats::quantile(boot, probs = probs, na.rm = TRUE) + + if (ci.method == "percentile") { + return(list(se = se, ci.lo = unname(qs[1]), ci.hi = unname(qs[2]))) + } + if (ci.method == "basic") { + return(list(se = se, + ci.lo = 2 * estimate - unname(qs[2]), + ci.hi = 2 * estimate - unname(qs[1]))) + } + if (ci.method == "bc") { + valid <- !is.na(boot) + if (sum(valid) == 0L) { + return(list(se = NA_real_, ci.lo = NA_real_, ci.hi = NA_real_)) + } + ## z0 = bias correction = Phi^-1(P(boot < estimate)) + p_below <- mean(boot[valid] < estimate) + ## Clamp to avoid +/-Inf at the boundaries + p_below <- pmin(pmax(p_below, 1e-6), 1 - 1e-6) + z0 <- stats::qnorm(p_below) + z_lo <- stats::qnorm(alpha / 2) + z_hi <- stats::qnorm(1 - alpha / 2) + a_lo <- stats::pnorm(2 * z0 + z_lo) + a_hi <- stats::pnorm(2 * z0 + z_hi) + bc_qs <- stats::quantile(boot, probs = c(a_lo, a_hi), na.rm = TRUE) + ## Same robustness fallback as bca (see comment in the bca block): + ## when z0 hits the clamp the bc cutoffs collapse or shift off the + ## estimate. Normal CI is the safe replacement. + ci_lo_bc <- unname(bc_qs[1]) + ci_hi_bc <- unname(bc_qs[2]) + is_degenerate <- abs(ci_hi_bc - ci_lo_bc) < 1e-10 + is_uncovered <- (estimate < ci_lo_bc) || (estimate > ci_hi_bc) + if (is_degenerate || is_uncovered) { + z <- stats::qnorm(1 - alpha / 2) + return(list(se = se, + ci.lo = estimate - z * se, + ci.hi = estimate + z * se)) + } + return(list(se = se, ci.lo = ci_lo_bc, ci.hi = ci_hi_bc)) + } + if (ci.method == "bca") { + if (is.null(jack)) { + stop("ci.method = \"bca\" requires the per-cell jackknife ", + "vector via the `jack` argument; the caller must compute ", + "leave-one-out within-group estimates and pass them.", + call. = FALSE) + } + valid <- !is.na(boot) + jack_valid <- !is.na(jack) + if (sum(valid) == 0L) { + return(list(se = NA_real_, ci.lo = NA_real_, ci.hi = NA_real_)) + } + ## Fall back to bc when the cell-level jackknife is degenerate + ## (e.g., only one treated cell contributing at this event time: + ## leave-one-out yields an empty vector; the .cell_jackknife() + ## helper returns rep(NA, n) at n < 2). bc only needs the + ## bootstrap distribution, so it stays well-defined wherever + ## sum(valid) > 0. This fallback fires on the staggered tails + ## of event-time series where event.time t is only reached by + ## a single treated unit; without it the user sees missing CI + ## bands on the plot at the extreme event-times. + if (sum(jack_valid) < 2L) { + return(.compute_ci(estimate, boot, "bc", conf.level, + jack = NULL)) + } + ## z0: bias correction + p_below <- mean(boot[valid] < estimate) + p_below <- pmin(pmax(p_below, 1e-6), 1 - 1e-6) + z0 <- stats::qnorm(p_below) + ## a: acceleration via cell-level jackknife + jack_v <- jack[jack_valid] + jack_bar <- mean(jack_v) + dev <- jack_bar - jack_v + num <- sum(dev^3) + den <- 6 * (sum(dev^2))^1.5 + a <- if (den > 1e-12) num / den else 0 + ## BCa cutoffs: handles z0 -> +/- inf via the (1 - a*z) denominator + z_lo <- stats::qnorm(alpha / 2) + z_hi <- stats::qnorm(1 - alpha / 2) + adjust <- function(z_q) { + denom <- 1 - a * (z0 + z_q) + ## Guard against a*(z0+z_q) -> 1 (denom -> 0); fall back to bc. + if (abs(denom) < 1e-8) { + return(stats::pnorm(2 * z0 + z_q)) + } + stats::pnorm(z0 + (z0 + z_q) / denom) + } + a_lo <- adjust(z_lo) + a_hi <- adjust(z_hi) + bca_qs <- stats::quantile(boot, probs = c(a_lo, a_hi), na.rm = TRUE) + ## Robustness fallback to normal CI when bca produces a pathological + ## interval: (a) both cutoffs collapse to the same bootstrap quantile + ## (degenerate; happens when z0 hits the clamp at +-qnorm(1e-6)), + ## or (b) the interval shifts entirely off the point estimate + ## (happens with heavily skewed bootstraps at small B). bca is + ## mathematically valid in both cases but the resulting visual is + ## misleading on per-event-time plots. Normal CI is centered at + ## estimate by construction so it always covers, and it uses the + ## already-computed bootstrap SE. + ci_lo_bca <- unname(bca_qs[1]) + ci_hi_bca <- unname(bca_qs[2]) + is_degenerate <- abs(ci_hi_bca - ci_lo_bca) < 1e-10 + is_uncovered <- (estimate < ci_lo_bca) || (estimate > ci_hi_bca) + if (is_degenerate || is_uncovered) { + z <- stats::qnorm(1 - alpha / 2) + return(list(se = se, + ci.lo = estimate - z * se, + ci.hi = estimate + z * se)) + } + return(list(se = se, ci.lo = ci_lo_bca, ci.hi = ci_hi_bca)) + } + stop("Unknown ci.method = \"", ci.method, "\".", call. = FALSE) +} + + +## Compute the per-cell jackknife vector for a within-group functional T. +## For aptt: T(eff, Y0) = mean(eff) / mean(Y0). leave-one-out: +## theta_jack[i] = mean(eff[-i]) / mean(Y0[-i]) +## For log.att: T(Y, Y0) = mean(log(Y) - log(Y0)). leave-one-out: +## theta_jack[i] = mean(log(Y[-i]) - log(Y0[-i])) +## For att (level): T = mean(eff). theta_jack[i] = mean(eff[-i]). +## +## Used for the BCa acceleration parameter without requiring model refits +## (the influence is computed at the aggregation step, holding the model +## fixed). This is the standard practice for BCa when leave-one-unit-out +## refits are too expensive. +.cell_jackknife <- function(type, ...) { + args <- list(...) + if (type == "aptt") { + eff <- args$eff; Y0 <- args$Y0 + n <- length(eff) + if (n < 2L) return(rep(NA_real_, n)) + sum_eff <- sum(eff, na.rm = TRUE) + sum_Y0 <- sum(Y0, na.rm = TRUE) + ## leave-one-out means: (sum - eff_i) / (n - 1) + num <- (sum_eff - eff) / (n - 1) + den <- (sum_Y0 - Y0) / (n - 1) + return(num / den) + } + if (type == "log.att") { + ld <- args$log_diff + n <- length(ld) + if (n < 2L) return(rep(NA_real_, n)) + ## leave-one-out mean of log_diff + sum_ld <- sum(ld, na.rm = TRUE) + return((sum_ld - ld) / (n - 1)) + } + if (type == "att") { + eff <- args$eff + n <- length(eff) + if (n < 2L) return(rep(NA_real_, n)) + sum_eff <- sum(eff, na.rm = TRUE) + return((sum_eff - eff) / (n - 1)) + } + stop("Unknown jackknife type = \"", type, "\".", call. = FALSE) +} + + +## Build the cell-level base mask for a given test (none / placebo / +## carryover) and direction. Returns a list with `mask` (logical +## matrix matching shape(fit$D.dat)) and `Tev` (the relevant event- +## time matrix from fit$T.on or fit$T.off). +## +## test = "none": treated post-treatment cells (the default ATT +## surface): D.dat == 1 with non-NA Tev. +## test = "placebo": pre-treatment cells masked during the placebo +## fit, identified by Tev within fit$placebo.period. +## Requires fit$placeboTest == TRUE. +## test = "carryover": early post-reversal cells masked during the +## carryover fit, identified by Tev within +## fit$carryover.period (Tev = T.off). Requires +## fit$carryoverTest == TRUE and hasRevs. +## +## v2.4.3+ (closes issue #131, ajunquera). +.test_cell_mask <- function(fit, test, direction) { + + Tev <- if (direction == "on") fit$T.on else fit$T.off + if (is.null(Tev)) { + stop("direction = \"", direction, "\" requested, but fit$T.", + direction, " is NULL.", call. = FALSE) + } + + if (test == "none") { + return(list( + mask = !is.na(fit$D.dat) & fit$D.dat == 1 & !is.na(Tev), + Tev = Tev + )) + } + + if (test == "placebo") { + if (!isTRUE(as.logical(fit$placeboTest)) || + is.null(fit$placebo.period)) { + stop("test = \"placebo\" requires the fit to have been run ", + "with placeboTest = TRUE. The placebo estimand is only ", + "meaningful when the placebo cells were masked from the ", + "fit (out-of-sample predictions); a standard fit's ", + "pre-treatment residuals are in-sample and would not be ", + "an honest credibility check. Refit with: ", + "fect(..., placeboTest = TRUE, placebo.period = c(L, R)).", + call. = FALSE) + } + pp <- fit$placebo.period + if (length(pp) == 1L) pp <- c(pp, pp) + return(list( + mask = !is.na(Tev) & Tev >= pp[1] & Tev <= pp[2], + Tev = Tev + )) + } + + if (test == "carryover") { + if (!isTRUE(as.logical(fit$carryoverTest)) || + is.null(fit$carryover.period)) { + stop("test = \"carryover\" requires the fit to have been run ", + "with carryoverTest = TRUE. The carryover estimand is ", + "only meaningful when the early post-reversal cells were ", + "masked from the fit (out-of-sample predictions). Refit ", + "with: fect(..., carryoverTest = TRUE, ", + "carryover.period = c(L, R)).", + call. = FALSE) + } + if (!isTRUE(fit$hasRevs == 1)) { + stop("test = \"carryover\" requires a panel with treatment ", + "reversals (fit$hasRevs == 1).", call. = FALSE) + } + cp <- fit$carryover.period + if (length(cp) == 1L) cp <- c(cp, cp) + return(list( + mask = !is.na(Tev) & Tev >= cp[1] & Tev <= cp[2], + Tev = Tev + )) + } + + stop("Unknown test = \"", test, "\".", call. = FALSE) +} + + ## Apply a `cells` filter (NULL, logical, or one-sided formula/function) ## against a long-form data frame. Returns the filtered data frame. .apply_cells_filter <- function(df, cells) { diff --git a/R/polynomial.R b/R/polynomial.R deleted file mode 100644 index 0f91dbcb..00000000 --- a/R/polynomial.R +++ /dev/null @@ -1,845 +0,0 @@ -################################################################### -## IFE Model Function -################################################################### -fect_polynomial <- function(Y, # Outcome variable, (T*N) matrix - X, # Explanatory variables: (T*N*p) array - D, # Indicator for treated unit (tr==1) - W, - I, - II, - II.cm = NULL, - T.on, - T.off = NULL, - T.on.carry = NULL, - T.on.balance = NULL, - balance.period = NULL, - method, - degree = 1, - sfe = NULL, - cfe = NULL, - ind.matrix = NULL, - knots = NULL, - force, - hasRevs = 1, - tol, # tolerance level - max.iteration = 1000, - boot = FALSE, # bootstrapped sample - placeboTest = 0, - placebo.period = NULL, - carryoverTest = 0, - carryover.period = NULL, - norm.para = NULL, - calendar.enp.seq = NULL, - time.on.seq = NULL, - time.off.seq = NULL, - time.on.carry.seq = NULL, - time.on.balance.seq = NULL, - time.on.seq.W = NULL, - time.off.seq.W = NULL, - group.level = NULL, - group = NULL, - time.on.seq.group = NULL, - time.off.seq.group = NULL, - W.in.fit = TRUE) { - ## -------------------------------## - ## Parsing data - ## -------------------------------## - carryover.pos <- placebo.pos <- na.pos <- NULL - res.sd1 <- res.sd2 <- NULL - - ## unit id and time - TT <- dim(Y)[1] - N <- dim(Y)[2] - if (is.null(X) == FALSE) { - p <- dim(X)[3] - } else { - p <- 0 - X <- array(0, dim = c(1, 1, 0)) - } - - ## replicate data - YY <- Y - YY[which(II == 0)] <- 0 ## reset to 0 - - ## initial fit using fastplm - data.ini <- matrix(NA, (TT * N), (2 + 1 + p)) - data.ini[, 2] <- rep(1:N, each = TT) ## unit fe - data.ini[, 3] <- rep(1:TT, N) ## time fe - data.ini[, 1] <- c(Y) ## outcome - if (p > 0) { ## covar - for (i in 1:p) { - data.ini[, (3 + i)] <- c(X[, , i]) - } - } - ## observed Y0 indicator: - oci <- which(c(II) == 1) - if (!is.null(W) && isTRUE(W.in.fit)) { - initialOut <- initialFit(data = data.ini, force = force, w = c(W), oci = oci) - } else { - initialOut <- initialFit(data = data.ini, force = force, oci = oci) - } - data.ini <- NULL - invisible(gc(verbose = FALSE)) - Y0 <- initialOut$Y0 - beta0 <- initialOut$beta0 - if (p > 0 && sum(is.na(beta0)) > 0) { - beta0[which(is.na(beta0))] <- 0 - } - - if (is.null(W) || !W.in.fit) { - W.use <- as.matrix(0) - use_weight <- 0 - } else { - W.use <- W - use_weight <- 1 - } - - - est.fect <- NULL - if (boot == FALSE) { - est.fect <- inter_fe_ub(YY, Y0, X, II, W.use, beta0, 0, force = force, tol, max.iteration) - } - - ## reshape - vy <- as.matrix(c(YY)) - vx.fit <- vx <- NULL - if (p > 0) { - vx <- matrix(NA, N * TT, p) - for (i in 1:p) { - vx[, i] <- c(X[, , i]) - } - colnames(vx) <- paste0("x.", c(1:p)) - vx.fit <- as.matrix(vx[oci, ]) - } - - vindex <- NULL - sp <- NULL - sf <- NULL - cf <- NULL - - if (method == "cfe_old") { - vindex <- cbind(rep(1:N, each = TT), rep(1:TT, N)) ## id time - if (force == 1) { - sf <- 1 - } else if (force == 2) { - sf <- 2 - } else { - sf <- c(1, 2) - } - - ## simple fixed effects - for (ind.name in names(ind.matrix)) { - vindex <- cbind(vindex, matrix(ind.matrix[[ind.name]], ncol = 1)) - } - - ind.name <- c("forceid", "forcetime", names(ind.matrix)) - ind.index <- c(1:(2 + length(names(ind.matrix)))) - colnames(vindex) <- names(ind.index) <- ind.name - - if (p > 0) { - data.reg <- cbind.data.frame(vy, vx, vindex) - formula.reg <- paste0("vy~", paste(paste0("x.", c(1:p)), collapse = "+"), "|") - } else { - data.reg <- cbind.data.frame(vy, vindex) - formula.reg <- paste0("vy~1|") - } - - if (force == 1) { - formula.reg <- paste0(formula.reg, "forceid") - } else if (force == 2) { - formula.reg <- paste0(formula.reg, "forcetime") - } else if (force == 3) { - formula.reg <- paste0(formula.reg, "forceid+forcetime") - } - - - if (!is.null(sfe)) { - formula.reg <- paste0(formula.reg, "+", paste(sfe, collapse = "+")) - } - - if (!is.null(cfe)) { - for (sub.cfe in cfe) { - sub.cf <- paste0(sub.cfe[1], "[", sub.cfe[2], "]") - formula.reg <- paste0(formula.reg, "+", sub.cf) - } - } - formula.reg <- as.formula(formula.reg) - if (use_weight == 0) { - est.best <- suppressWarnings(invisible(feols( - fml = formula.reg, - data = data.reg[oci, ], - fixef.rm = "none" - ))) - } else { - est.best <- suppressWarnings(invisible(feols( - fml = formula.reg, - data = data.reg[oci, ], - weights = c(W.use)[oci], - fixef.rm = "none" - ))) - } - - - yfit <- suppressWarnings(predict(est.best, newdata = data.reg)) - data.reg <- NULL - } else if (method == "polynomial") { - vindex <- cbind(rep(1:N, each = TT), rep(1:TT, N)) ## id time - for (i in 1:degree) { - vindex <- cbind(vindex, rep((1:TT)^i, N)) - } - - colnames(vindex) <- c("forceid", "forcetime", paste0("forcetime.", c(1:degree))) - - if (p > 0) { - data.reg <- cbind.data.frame(vy, vx, vindex) - formula.reg <- paste0("vy~", paste(paste0("x.", c(1:p)), collapse = "+"), "|") - } else { - data.reg <- cbind.data.frame(vy, vindex) - formula.reg <- paste0("vy~1|") - } - - if (force == 1) { - formula.reg <- paste0(formula.reg, "forceid") - } else if (force == 2) { - formula.reg <- paste0(formula.reg, "forcetime") - } else if (force == 3) { - formula.reg <- paste0(formula.reg, "forceid+forcetime") - } - - for (i in 1:degree) { - formula.reg <- paste0(formula.reg, paste0("+forceid", "[", paste0("forcetime.", i), "]")) - } - formula.reg <- as.formula(formula.reg) - if (use_weight == 0) { - est.best <- suppressWarnings(invisible(feols( - fml = formula.reg, - data = data.reg[oci, ], - fixef.rm = "none" - ))) - } else { - est.best <- suppressWarnings(invisible(feols( - fml = formula.reg, - data = data.reg[oci, ], - weights = c(W.use)[oci], - fixef.rm = "none" - ))) - } - - - yfit <- suppressWarnings(predict(est.best, newdata = data.reg)) - data.reg <- NULL - } - - invisible(gc(verbose = FALSE)) - Y.ct <- matrix(yfit, TT, N) - if (p > 0) { - beta <- as.matrix(c(est.best$coefficients)[1:p]) - } else { - beta <- matrix(0, 1, 0) - } - est.best$beta <- beta - validX <- ifelse(p > 0, 1, 0) - - ## -------------------------------## - ## ATT and Counterfactuals ## - ## -------------------------------## - - ## we first adjustment for normalization - if (!is.null(norm.para)) { - Y <- Y * norm.para[1] - ## variance of the error term - sigma2 <- est.best$sigma2 * (norm.para[1]^2) - est.best$sigma2 <- sigma2 - ## output of estimates - est.best$mu <- est.best$mu * norm.para[1] - est.best$residuals <- est.best$residuals * norm.para[1] - Y.ct <- Y.ct * norm.para[1] - if (boot == FALSE) { - est.fect$fit <- est.fect$fit * norm.para[1] - } - est.fect$sigma2 <- est.fect$sigma2 * norm.para[1] - } - - ## 0. relevant parameters - if (p > 0) { - na.pos <- is.nan(est.best$beta) - beta <- est.best$beta - if (sum(na.pos) > 0) { - beta[na.pos] <- NA - } - } else { - beta <- NA - } - - ## 1. estimated att and counterfactuals - eff <- Y - Y.ct - complete.index <- which(!is.na(eff)) - missing.index <- which(is.na(eff)) - if (length(missing.index) > 0) { - I[missing.index] <- 0 - II[missing.index] <- 0 - } - att.avg <- sum(eff[complete.index] * D[complete.index]) / (sum(D[complete.index])) - - att.avg.balance <- NA - if (!is.null(balance.period)) { - complete.index2 <- which(!is.na(T.on.balance)) - att.avg.balance <- sum(eff[complete.index2] * D[complete.index2]) / (sum(D[complete.index2])) - } - - # weighted effect - att.avg.W <- NA - if (!is.null(W)) { - att.avg.W <- sum(eff[complete.index] * D[complete.index] * W[complete.index]) / (sum(D[complete.index] * W[complete.index])) - } - - - ## att.avg.unit - tr.pos <- which(apply(D, 2, sum) > 0) - att.unit <- sapply(1:length(tr.pos), function(vec) { - return((eff[, tr.pos[vec]] * D[, tr.pos[vec]]) / sum(D[, tr.pos[vec]])) - }) - att.avg.unit <- mean(att.unit, na.rm = TRUE) - - - ## 2. rmse for treated units' observations under control - tr <- which(apply(D, 2, sum) > 0) - tr.co <- which((as.matrix(1 - D[, tr]) * as.matrix(II[, tr])) == 1) - eff.tr <- as.matrix(eff[, tr]) - v.eff.tr <- eff.tr[tr.co] - rmse <- sqrt(mean(v.eff.tr^2, na.rm = TRUE)) - - - ## 3. unbalanced output - if (0 %in% I) { - eff[which(I == 0)] <- NA - Y.ct[which(I == 0)] <- NA - } - - ## 4. dynamic effects - t.on <- c(T.on) - eff.v <- c(eff) ## a vector - - rm.pos1 <- which(is.na(eff.v)) - rm.pos2 <- which(is.na(t.on)) - - eff.v.use1 <- eff.v - t.on.use <- t.on - n.on.use <- rep(1:N, each = TT) - - if (NA %in% eff.v | NA %in% t.on) { - eff.v.use1 <- eff.v[-c(rm.pos1, rm.pos2)] - t.on.use <- t.on[-c(rm.pos1, rm.pos2)] - n.on.use <- n.on.use[-c(rm.pos1, rm.pos2)] - } - - pre.pos <- which(t.on.use <= 0) - eff.pre <- cbind(eff.v.use1[pre.pos], t.on.use[pre.pos], n.on.use[pre.pos]) - colnames(eff.pre) <- c("eff", "period", "unit") - - sigma2.pre <- eff.pre.equiv <- NULL - if (boot == FALSE) { - eff.pre.equiv <- eff.pre - - sigma2.pre <- tapply(eff.pre.equiv[, 1], eff.pre.equiv[, 2], var) - sigma2.pre <- cbind(sigma2.pre, sort(unique(eff.pre.equiv[, 2])), table(eff.pre.equiv[, 2])) - colnames(sigma2.pre) <- c("sigma2", "period", "count") - } - - time.on <- sort(unique(t.on.use)) - att.on <- as.numeric(tapply(eff.v.use1, t.on.use, mean)) ## NA already removed - count.on <- as.numeric(table(t.on.use)) - - if (!is.null(time.on.seq)) { - count.on.med <- att.on.med <- rep(NA, length(time.on.seq)) - att.on.med[which(time.on.seq %in% time.on)] <- att.on - count.on.med[which(time.on.seq %in% time.on)] <- count.on - att.on <- att.on.med - count.on <- count.on.med - time.on <- time.on.seq - } - - ## weighted treatment effect - if (!is.null(W)) { - W.v <- c(W) - rm.pos.W <- which(is.na(W)) - if (NA %in% eff.v | NA %in% t.on | NA %in% W.v) { - eff.v.use.W <- eff.v[-c(rm.pos1, rm.pos2, rm.pos.W)] - W.v.use <- W.v[-c(rm.pos1, rm.pos2, rm.pos.W)] - t.on.use.W <- t.on[-c(rm.pos1, rm.pos2, rm.pos.W)] - n.on.use.W <- n.on.use[-c(rm.pos1, rm.pos2, rm.pos.W)] - } else { - eff.v.use.W <- eff.v.use1 - t.on.use.W <- t.on.use - n.on.use.W <- n.on.use - W.v.use <- W.v - } - time.on.W <- sort(unique(t.on.use.W)) - att.on.sum.W <- as.numeric(tapply(eff.v.use.W * W.v.use, t.on.use.W, sum)) ## NA already removed - W.on.sum <- as.numeric(tapply(W.v.use, t.on.use.W, sum)) - att.on.W <- att.on.sum.W / W.on.sum - count.on.W <- as.numeric(table(t.on.use.W)) - - if (!is.null(time.on.seq.W)) { - att.on.sum.med.W <- W.on.sum.med <- count.on.med.W <- att.on.med.W <- rep(NA, length(time.on.seq.W)) - att.on.sum.med.W[which(time.on.seq.W %in% time.on.W)] <- att.on.sum.W - att.on.med.W[which(time.on.seq.W %in% time.on.W)] <- att.on.W - count.on.med.W[which(time.on.seq.W %in% time.on.W)] <- count.on.W - W.on.sum.med[which(time.on.seq.W %in% time.on.W)] <- W.on.sum - att.on.sum.W <- att.on.sum.med.W - att.on.W <- att.on.med.W - count.on.W <- count.on.med.W - time.on.W <- time.on.seq.W - W.on.sum <- W.on.sum.med - } - } else { - att.on.sum.med.W <- att.on.sum.W <- count.on.med.W <- att.on.med.W <- W.on.sum.med <- att.on.W <- count.on.W <- time.on.W <- W.on.sum <- NULL - } - - ## 4.1 carryover effect - carry.att <- NULL - if (!is.null(T.on.carry)) { - t.on.carry <- c(T.on.carry) - rm.pos4 <- which(is.na(t.on.carry)) - t.on.carry.use <- t.on.carry - - if (NA %in% eff.v | NA %in% t.on.carry) { - eff.v.use3 <- eff.v[-c(rm.pos1, rm.pos4)] - t.on.carry.use <- t.on.carry[-c(rm.pos1, rm.pos4)] - } - - carry.time <- sort(unique(t.on.carry.use)) - carry.att <- as.numeric(tapply(eff.v.use3, t.on.carry.use, mean)) ## NA already removed - - if (!is.null(time.on.carry.seq)) { - carry.att.med <- rep(NA, length(time.on.carry.seq)) - carry.att.med[which(time.on.carry.seq %in% carry.time)] <- carry.att - carry.att <- carry.att.med - carry.time <- time.on.carry.seq - } - } - - ## 4.2 balance effect - balance.att <- NULL - if (!is.null(balance.period)) { - t.on.balance <- c(T.on.balance) - rm.pos4 <- which(is.na(t.on.balance)) - t.on.balance.use <- t.on.balance - - if (NA %in% eff.v | NA %in% t.on.balance) { - eff.v.use3 <- eff.v[-c(rm.pos1, rm.pos4)] - t.on.balance.use <- t.on.balance[-c(rm.pos1, rm.pos4)] - } - - balance.time <- sort(unique(t.on.balance.use)) - balance.att <- as.numeric(tapply(eff.v.use3, t.on.balance.use, mean)) ## NA already removed - balance.count <- as.numeric(table(t.on.balance.use)) - - if (!is.null(time.on.balance.seq)) { - balance.att.med <- rep(NA, length(time.on.balance.seq)) - balance.count.med <- rep(0, length(time.on.balance.seq)) - balance.att.med[which(time.on.balance.seq %in% balance.time)] <- balance.att - if (length(balance.count) > 0) { - balance.count.med[which(time.on.balance.seq %in% balance.time)] <- balance.count - } - balance.count <- balance.count.med - balance.att <- balance.att.med - balance.time <- time.on.balance.seq - } - - # placebo for balanced samples - if (!is.null(placebo.period) && placeboTest == 1) { - if (length(placebo.period) == 1) { - balance.placebo.pos <- which(balance.time == placebo.period) - balance.att.placebo <- balance.att[balance.placebo.pos] - } else { - balance.placebo.pos <- which(balance.time >= placebo.period[1] & balance.time <= placebo.period[2]) - balance.att.placebo <- sum(balance.att[balance.placebo.pos] * balance.count[balance.placebo.pos]) / sum(balance.count[balance.placebo.pos]) - } - } - } - - ## 5. placebo effect, if placeboTest == 1 - if (!is.null(placebo.period) && placeboTest == 1) { - if (length(placebo.period) == 1) { - placebo.pos <- which(time.on == placebo.period) - att.placebo <- att.on[placebo.pos] - } else { - placebo.pos <- which(time.on >= placebo.period[1] & time.on <= placebo.period[2]) - att.placebo <- sum(att.on[placebo.pos] * count.on[placebo.pos]) / sum(count.on[placebo.pos]) - } - - if (!is.null(W)) { - if (length(placebo.period) == 1) { - placebo.pos.W <- which(time.on.W == placebo.period) - att.placebo.W <- att.on.W[placebo.pos.W] - } else { - placebo.pos.W <- which(time.on.W >= placebo.period[1] & time.on.W <= placebo.period[2]) - att.placebo.W <- sum(att.on.sum.W[placebo.pos.W]) / sum(W.on.sum[placebo.pos.W]) - } - } - } - - - ## 6. switch-off effects - eff.off.equiv <- off.sd <- eff.off <- NULL - if (hasRevs == 1) { - t.off <- c(T.off) - rm.pos3 <- which(is.na(t.off)) - eff.v.use2 <- eff.v - t.off.use <- t.off - - if (NA %in% eff.v | NA %in% t.off) { - eff.v.use2 <- eff.v[-c(rm.pos1, rm.pos3)] - t.off.use <- t.off[-c(rm.pos1, rm.pos3)] - } - - off.pos <- which(t.off.use > 0) - eff.off <- cbind(eff.v.use2[off.pos], t.off.use[off.pos], n.on.use[off.pos]) - colnames(eff.off) <- c("eff", "period", "unit") - - if (boot == FALSE) { - eff.off.equiv <- eff.off - - off.sd <- tapply(eff.off.equiv[, 1], eff.off.equiv[, 2], sd) - off.sd <- cbind(off.sd, sort(unique(eff.off.equiv[, 2])), table(eff.off.equiv[, 2])) - colnames(off.sd) <- c("sd", "period", "count") - } - - time.off <- sort(unique(t.off.use)) - att.off <- as.numeric(tapply(eff.v.use2, t.off.use, mean)) ## NA already removed - count.off <- as.numeric(table(t.off.use)) - - if (!is.null(time.off.seq)) { - count.off.med <- att.off.med <- rep(NA, length(time.off.seq)) - att.off.med[which(time.off.seq %in% time.off)] <- att.off - count.off.med[which(time.off.seq %in% time.off)] <- count.off - att.off <- att.off.med - count.off <- count.off.med - time.off <- time.off.seq - } - - if (!is.null(W)) { - if (NA %in% eff.v | NA %in% t.off | NA %in% W.v) { - eff.v.use2.W <- eff.v[-c(rm.pos1, rm.pos3, rm.pos.W)] - W.v.use2 <- W.v[-c(rm.pos1, rm.pos3, rm.pos.W)] - t.off.use.W <- t.off[-c(rm.pos1, rm.pos3, rm.pos.W)] - } else { - eff.v.use2.W <- eff.v.use2 - t.off.use.W <- t.off.use - W.v.use2 <- W.v - } - - time.off.W <- sort(unique(t.off.use.W)) - att.off.sum.W <- as.numeric(tapply(eff.v.use2.W * W.v.use2, t.off.use.W, sum)) - W.off.sum <- as.numeric(tapply(W.v.use2, t.off.use.W, sum)) - att.off.W <- att.off.sum.W / W.off.sum ## NA already removed - count.off.W <- as.numeric(table(t.off.use.W)) - - if (!is.null(time.off.seq.W)) { - att.off.sum.med.W <- W.off.sum.med <- count.off.med.W <- att.off.med.W <- rep(NA, length(time.off.seq.W)) - att.off.sum.med.W[which(time.off.seq.W %in% time.off.W)] <- att.off.sum.W - att.off.med.W[which(time.off.seq.W %in% time.off.W)] <- att.off.W - count.off.med.W[which(time.off.seq.W %in% time.off.W)] <- count.off.W - W.off.sum.med[which(time.off.seq.W %in% time.off.W)] <- W.off.sum - att.off.sum.W <- att.off.sum.med.W - att.off.W <- att.off.med.W - count.off.W <- count.off.med.W - time.off.W <- time.off.seq.W - W.off.sum <- W.off.sum.med - } - } else { - W.off.sum.med <- W.off.sum <- att.off.sum.W <- att.off.sum.med.W <- count.off.med.W <- att.off.med.W <- count.off.med.W <- att.off.W <- count.off.W <- time.off.W <- NULL - } - } - - ## 7. carryover effects - if (!is.null(carryover.period) && carryoverTest == 1 && hasRevs) { - if (length(carryover.period) == 1) { - carryover.pos <- which(time.off == carryover.period) - att.carryover <- att.off[carryover.pos] - } else { - carryover.pos <- which(time.off >= carryover.period[1] & time.off <= carryover.period[2]) - att.carryover <- sum(att.off[carryover.pos] * count.off[carryover.pos]) / sum(count.off[carryover.pos]) - } - - if (!is.null(W)) { - if (length(carryover.period) == 1) { - carryover.pos.W <- which(time.off.W == carryover.period) - att.carryover.W <- att.off.W[carryover.pos.W] - } else { - carryover.pos.W <- which(time.off.W >= carryover.period[1] & time.off.W <= carryover.period[2]) - att.carryover.W <- sum(att.off.sum.W[carryover.pos.W]) / sum(W.off.sum[carryover.pos.W]) - } - } - } - - ## 8. cohort effects - if (!is.null(group)) { - cohort <- cbind(c(group), c(D), c(eff.v)) - rm.pos <- unique(c(rm.pos1, which(cohort[, 2] == 0))) - cohort <- cohort[-rm.pos, ] - - g.level <- sort(unique(cohort[, 1])) - raw.group.att <- as.numeric(tapply(cohort[, 3], cohort[, 1], mean)) - - group.att <- rep(NA, length(group.level)) - group.att[which(group.level %in% g.level)] <- raw.group.att - - # by-group dynamic effects - group.level.name <- names(group.level) - - group.output <- list() - for (i in c(1:length(group.level))) { - sub.group <- group.level[i] - sub.group.name <- group.level.name[i] - - ## by-group dynamic effects - t.on.sub <- c(T.on[which(group == sub.group)]) - eff.v.sub <- c(eff[which(group == sub.group)]) ## a vector - rm.pos1.sub <- which(is.na(eff.v.sub)) - rm.pos2.sub <- which(is.na(t.on.sub)) - eff.v.use1.sub <- eff.v.sub - t.on.use.sub <- t.on.sub - if (NA %in% eff.v.sub | NA %in% t.on.sub) { - eff.v.use1.sub <- eff.v.sub[-c(rm.pos1.sub, rm.pos2.sub)] - t.on.use.sub <- t.on.sub[-c(rm.pos1.sub, rm.pos2.sub)] - } - if (length(t.on.use.sub) > 0) { - time.on.sub <- sort(unique(t.on.use.sub)) - att.on.sub <- as.numeric(tapply( - eff.v.use1.sub, - t.on.use.sub, - mean - )) ## NA already removed - count.on.sub <- as.numeric(table(t.on.use.sub)) - } else { - time.on.sub <- att.on.sub <- count.on.sub <- NULL - } - - if (!is.null(time.on.seq.group)) { - count.on.med.sub <- att.on.med.sub <- rep(NA, length(time.on.seq.group[[sub.group.name]])) - time.on.seq.sub <- time.on.seq.group[[sub.group.name]] - att.on.med.sub[which(time.on.seq.sub %in% time.on.sub)] <- att.on.sub - count.on.med.sub[which(time.on.seq.sub %in% time.on.sub)] <- count.on.sub - att.on.sub <- att.on.med.sub - count.on.sub <- count.on.med.sub - time.on.sub <- time.on.seq.sub - } - suboutput <- list( - att.on = att.on.sub, - time.on = time.on.sub, - count.on = count.on.sub - ) - - ## placebo effect, if placeboTest == 1 - if (!is.null(placebo.period) && placeboTest == 1) { - if (length(placebo.period) == 1) { - placebo.pos.sub <- which(time.on.sub == placebo.period) - if (length(placebo.pos.sub) > 0) { - att.placebo.sub <- att.on.sub[placebo.pos.sub] - } else { - att.placebo.sub <- NULL - } - } else { - placebo.pos.sub <- which(time.on.sub >= placebo.period[1] & time.on.sub <= placebo.period[2]) - if (length(placebo.pos.sub) > 0) { - att.placebo.sub <- sum(att.on.sub[placebo.pos.sub] * count.on.sub[placebo.pos.sub]) / sum(count.on.sub[placebo.pos.sub]) - } else { - att.placebo.sub <- NULL - } - } - suboutput <- c(suboutput, list(att.placebo = att.placebo.sub)) - } - - ## T.off - if (hasRevs == 1) { - t.off.sub <- c(T.off[which(group == sub.group)]) - rm.pos3.sub <- which(is.na(t.off.sub)) - eff.v.use2.sub <- eff.v.sub - t.off.use.sub <- t.off.sub - if (NA %in% eff.v.sub | NA %in% t.off.sub) { - eff.v.use2.sub <- eff.v.sub[-c(rm.pos1.sub, rm.pos3.sub)] - t.off.use.sub <- t.off.sub[-c(rm.pos1.sub, rm.pos3.sub)] - } - if (length(t.off.use.sub) > 0) { - time.off.sub <- sort(unique(t.off.use.sub)) - att.off.sub <- as.numeric(tapply(eff.v.use2.sub, t.off.use.sub, mean)) ## NA already removed - count.off.sub <- as.numeric(table(t.off.use.sub)) - } else { - time.off.sub <- att.off.sub <- count.off.sub <- NULL - } - - if (!is.null(time.off.seq.group)) { - count.off.med.sub <- att.off.med.sub <- rep(NA, length(time.off.seq.group[[sub.group.name]])) - time.off.seq.sub <- time.off.seq.group[[sub.group.name]] - att.off.med.sub[which(time.off.seq.sub %in% time.off.sub)] <- att.off.sub - count.off.med.sub[which(time.off.seq.sub %in% time.off.sub)] <- count.off.sub - att.off.sub <- att.off.med.sub - count.off.sub <- count.off.med.sub - time.off.sub <- time.off.seq.sub - } - suboutput <- c(suboutput, list( - att.off = att.off.sub, - count.off = count.off.sub, - time.off = time.off.sub - )) - - if (!is.null(carryover.period) && carryoverTest == 1) { - if (length(carryover.period) == 1) { - carryover.pos.sub <- which(time.off.sub == carryover.period) - if (length(carryover.pos.sub) > 0) { - att.carryover.sub <- att.off.sub[carryover.pos.sub] - } else { - att.carryover.sub <- NULL - } - } else { - carryover.pos.sub <- which(time.off.sub >= carryover.period[1] & time.off.sub <= carryover.period[2]) - if (length(carryover.pos.sub) > 0) { - att.carryover.sub <- sum(att.off.sub[carryover.pos.sub] * count.off.sub[carryover.pos.sub]) / sum(count.off.sub[carryover.pos.sub]) - } else { - att.carryover.sub <- NULL - } - } - suboutput <- c(suboutput, list(att.carryover = att.carryover.sub)) - } - } - group.output[[sub.group.name]] <- suboutput - } - } - - ## 9. loess HTE by time - D.missing <- D - D.missing[which(D == 0)] <- NA - eff.calendar <- apply(eff * D.missing, 1, mean, na.rm = TRUE) - N.calendar <- apply(!is.na(eff * D.missing), 1, sum) - T.calendar <- c(1:TT) - if (sum(!is.na(eff.calendar)) > 1) { - # loess fit - if (!is.null(calendar.enp.seq)) { - if (length(calendar.enp.seq) == 1 & is.na(calendar.enp.seq)) { - calendar.enp.seq <- NULL - } - } - if (is.null(calendar.enp.seq)) { - loess.fit <- suppressWarnings(try(loess(eff.calendar ~ T.calendar, weights = N.calendar), silent = TRUE)) - } else { - loess.fit <- suppressWarnings(try(loess(eff.calendar ~ T.calendar, weights = N.calendar, enp.target = calendar.enp.seq), silent = TRUE)) - } - if ("try-error" %in% class(loess.fit)) { - eff.calendar.fit <- eff.calendar - calendar.enp <- NULL - } else { - eff.calendar.fit <- eff.calendar - eff.calendar.fit[which(!is.na(eff.calendar))] <- loess.fit$fit - calendar.enp <- loess.fit$enp - } - } else { - eff.calendar.fit <- eff.calendar - calendar.enp <- NULL - } - - - ## -------------------------------## - ## Storage ## - ## -------------------------------## - out <- list( - ## main results - method = method, - Y.ct = Y.ct, - eff = eff, - I = I, - II = II, - D = D, - Y = Y, - X = X, - att.avg = att.avg, - att.avg.unit = att.avg.unit, - ## supporting - force = force, - T = TT, - N = N, - p = p, - beta = beta, - est = est.best, - sigma2 = est.best$sigma2, - sigma2.fect = est.fect$sigma2, - validX = validX, - time = time.on, - att = att.on, - count = count.on, - eff.calendar = eff.calendar, - N.calendar = N.calendar, - eff.calendar.fit = eff.calendar.fit, - calendar.enp = calendar.enp, - eff.pre = eff.pre, - eff.pre.equiv = eff.pre.equiv, - sigma2.pre = sigma2.pre - ) - - if (hasRevs == 1) { - out <- c(out, list( - time.off = time.off, - att.off = att.off, - count.off = count.off, - eff.off = eff.off, - eff.off.equiv = eff.off.equiv, - off.sd = off.sd - )) - } - - if (!is.null(W)) { - out <- c(out, list( - W = W, - att.avg.W = att.avg.W, - att.on.sum.W = att.on.sum.W, - att.on.W = att.on.W, - count.on.W = count.on.W, - time.on.W = time.on.W, - W.on.sum = W.on.sum - )) - if (hasRevs == 1) { - out <- c(out, list( - att.off.sum.W = att.off.sum.W, - att.off.W = att.off.W, - count.off.W = count.off.W, - time.off.W = time.off.W, - W.off.sum = W.off.sum - )) - } - if (!is.null(placebo.period) && placeboTest == 1) { - out <- c(out, list(att.placebo.W = att.placebo.W)) - } - - if (!is.null(carryover.period) && carryoverTest == 1) { - out <- c(out, list(att.carryover.W = att.carryover.W)) - } - } - - if (!is.null(T.on.carry)) { - out <- c(out, list(carry.att = carry.att, carry.time = carry.time)) - } - - if (!is.null(balance.period)) { - out <- c(out, list(balance.att = balance.att, balance.time = balance.time, balance.count = balance.count, balance.avg.att = att.avg.balance)) - if (!is.null(placebo.period) && placeboTest == 1) { - out <- c(out, list(balance.att.placebo = balance.att.placebo)) - } - } - - if (!is.null(placebo.period) && placeboTest == 1) { - out <- c(out, list(att.placebo = att.placebo)) - } - - if (!is.null(carryover.period) && carryoverTest == 1) { - out <- c(out, list(att.carryover = att.carryover)) - } - - if (!is.null(group)) { - out <- c(out, list( - group.att = group.att, - group.output = group.output - )) - } - return(out) -} diff --git a/R/print.R b/R/print.R index 398fb943..327f776e 100644 --- a/R/print.R +++ b/R/print.R @@ -23,6 +23,31 @@ print.fect <- function(x, cat("Call:\n") print(x$call, digits = 4) + ## Estimator + Fixed effects + Cluster SE lines (D8 in design memo). + ## Surfaces the actual FE composition so users can verify their model + ## without re-reading the call args. force is stored as integer 0/1/2/3. + .fe_label <- function(force_int, index, group.fe) { + parts <- character(0) + if (length(index) >= 1 && force_int %in% c(1, 3)) { + parts <- c(parts, paste0(index[1], " (unit)")) + } + if (length(index) >= 2 && force_int %in% c(2, 3)) { + parts <- c(parts, paste0(index[2], " (time)")) + } + if (!is.null(group.fe) && length(group.fe) > 0) { + parts <- c(parts, paste(group.fe, collapse = " + ")) + } + if (length(parts) == 0) "none" else paste(parts, collapse = " + ") + } + fe.line <- .fe_label(x$force, + if (!is.null(x$call$index)) eval(x$call$index) else NULL, + x$group.fe) + cat("\nEstimator: ", x$method, "\n", sep = "") + cat("Fixed effects: ", fe.line, "\n", sep = "") + if (!is.null(x$cl.label)) { + cat("Cluster SE: ", x$cl.label, "\n", sep = "") + } + if (switch.on == TRUE) { if (!is.null(time.on.lim)) { diff --git a/_pkgdown.yml b/_pkgdown.yml deleted file mode 100644 index d6563acf..00000000 --- a/_pkgdown.yml +++ /dev/null @@ -1,67 +0,0 @@ -home: - title: fect--fixed effects counterfactual estimators - description: estimating treatment effects using panel imputation methods - links: - - text: Yiqing's homepage - href: https://yiqingxu.org/ - - text: Research paper - href: https://papers.ssrn.com/abstract=3555463 - -url: https://yiqingxu.org/packages/fect/ -template: - bootstrap: 5 - -navbar: - left: - - text: "Tutorial" - href: articles/tutorial.html - - text: "Functions" - href: reference/index.html - - text: "Changelog" - href: news/index.html - - text: "Stata" - href: https://yiqingxu.org/packages/fect/stata/fect_md.html - - text: "Paper" - href: https://yiqingxu.org/papers/english/2022_fect/LWX2022.pdf - right: - - icon: fa-github - href: https://github.com/xuyiqing/fect - -footer: - structure: - left: developed_by - right: package - -reference: - - title: Functions - - contents: - - fect - - interFE - - get.cohort - - effect - - esplot - - fect_iden - - title: S3 methods - - contents: - - print.fect - - plot.fect - - print.interFE - - title: Datasets - - contents: - - simdata - - simgsynth - - turnout - - title: Internal - - contents: - - fect-package - - fect-internal - - - - -authors: - Yiqing Xu: - href: "https://yiqingxu.org/" - - - diff --git a/man/estimand.Rd b/man/estimand.Rd index 38fedd27..93b3f372 100644 --- a/man/estimand.Rd +++ b/man/estimand.Rd @@ -15,13 +15,14 @@ estimand( fit, type = c("att", "att.cumu", "aptt", "log.att"), by = c("event.time", "cohort", "calendar.time", "overall"), + test = c("none", "placebo", "carryover"), cells = NULL, weights = NULL, window = NULL, direction = c("on", "off"), vartype = c("bootstrap", "jackknife", "parametric", "none"), conf.level = 0.95, - ci.method = c("basic", "percentile") + ci.method = NULL ) } @@ -40,6 +41,21 @@ estimand( \code{"cohort"}, \code{"calendar.time"}, \code{"overall"}, or any column name resolvable in the fit's panel data.} + \item{test}{Selects which subset of cells to aggregate over. + \code{"none"} (default) uses the standard treated post-treatment + cells. \code{"placebo"} restricts aggregation to the + pre-treatment cells in \code{fit$placebo.period} that were + masked-and-imputed during the placebo fit; e.g.\ + \code{estimand(fit, "aptt", "event.time", test = "placebo")} + returns a per-event-time placebo APTT series. Requires + \code{placeboTest = TRUE} at fit time and forces + \code{direction = "on"}. \code{"carryover"} is the analogous + extension for early post-reversal cells in + \code{fit$carryover.period}; requires \code{carryoverTest = TRUE} + at fit time, a panel with reversals, and forces + \code{direction = "off"}. Both are incompatible with + \code{type = "att.cumu"}.} + \item{cells}{Optional filter on which treated cells to include. Accepts \code{NULL} (default), a logical vector, or a one-sided formula. See \code{\link{imputed_outcomes}}.} @@ -58,14 +74,28 @@ estimand( \code{"parametric"}, or \code{"none"}. Selects which variance method to source replicates from. The output \code{vartype} column reports the method actually used at fit time (read from - \code{fit$vartype}), which may differ from this argument value - if the fit was produced with a different setting --- the argument - is informational and does not re-aggregate replicates.} + \code{fit$vartype}); this argument is informational and does not + re-aggregate replicates. Wild-bootstrap fits (\code{vartype = + "wild"} at fit time) are consumed transparently and reported as + \code{"wild"} in the output column.} \item{conf.level}{Two-sided confidence level. Defaults to 0.95.} - \item{ci.method}{\code{"basic"} (reflected; matches fect's existing - \code{est.att} convention; default) or \code{"percentile"}.} + \item{ci.method}{One of \code{"basic"}, \code{"percentile"}, + \code{"bc"} (bias-corrected percentile), \code{"bca"} + (bias-corrected accelerated; Efron 1987 in full), or + \code{"normal"} (Wald: \eqn{\hat\theta \pm z \cdot SE}). Default + is \code{NULL}, which triggers a per-type default: + \code{"att"} -> \code{"normal"} (matches what \code{fit$est.att} + already uses internally), \code{"att.cumu"} -> \code{"percentile"} + (matches what \code{att.cumu()} does internally), + \code{"aptt"} -> \code{"bca"} and \code{"log.att"} -> + \code{"bca"} (ratio / log estimators benefit from joint + bias and acceleration corrections when the bootstrap distribution + is skewed; \code{"bc"} can degenerate at the boundary when the + point estimate falls outside the bootstrap support). Pass an + explicit value to override. \code{"bca"} requires bootstrap- or + wild-bootstrap-sourced replicates.} } \value{ diff --git a/man/fect.Rd b/man/fect.Rd index 0f450bd0..40b049a2 100644 --- a/man/fect.Rd +++ b/man/fect.Rd @@ -14,16 +14,19 @@ assumptions.} CV = NULL, k = 20, cv.prop = 0.1, cv.method = "rolling", cv.nobs = 3, cv.donut = 1, cv.buffer = 1, criterion = "mspe", binary = FALSE, QR = FALSE, - method = "fe", se = FALSE, vartype = "bootstrap", cl = NULL, - quantile.CI = FALSE, nboots = 200, alpha = 0.05, - parallel = TRUE, cores = NULL, tol = 1e-3, - max.iteration = 1000, seed = NULL, + method = "fe", se = FALSE, vartype = "bootstrap", + para.error = "auto", cl = NULL, + ci.method = "normal", quantile.CI = NULL, + nboots = 200, alpha = 0.05, + parallel = TRUE, cores = NULL, tol = 1e-5, + max.iteration = 5000, seed = NULL, min.T0 = NULL, max.missing = NULL, proportion = 0.3, pre.periods = NULL, f.threshold = 0.5, tost.threshold = NULL, knots = NULL, degree = 2, - sfe = NULL, cfe = NULL, - Z = NULL, gamma = NULL, Q = NULL, kappa = NULL, + group.fe = NULL, + cfe = NULL, + Z = NULL, gamma = NULL, Q = NULL, kappa = NULL, Q.type = NULL, Q.bspline.degree = NULL, Z.param = NULL, Q.param = NULL, @@ -91,9 +94,43 @@ In v2.3.1, \code{W.est} and \code{W.agg} (when both supplied) must point to the These three conditions correspond to Gates A, B, and C in the three-gate defense system (see \code{ARCHITECTURE.md}). For all other settings, \code{vartype = "bootstrap"} is recommended.} -\item{cl}{a string specifying the cluster for cluster bootstrapping.} -\item{quantile.CI}{a logical flag indicating whether to use quantile confidence intervals when bootstrapping.} -\item{nboots}{an integer specifying the number of bootstrap runs. Ignored if \code{se=FALSE}.} +\item{para.error}{a string specifying the residual-error model used by + the parametric bootstrap path; sub-option of \code{vartype = "parametric"} + (silently ignored otherwise). One of \code{"auto"}, \code{"ar"}, + \code{"empirical"}, or \code{"wild"}. Default \code{"auto"} resolves at + fit time to \code{"empirical"} on a fully-observed panel and \code{"ar"} + on a panel with missing cells; the resolved label is stored on + \code{fit$para.error}. \code{"ar"} estimates an AR(1) error process from + control residuals (works on any panel shape); \code{"empirical"} + resamples residuals i.i.d. from the main-fit pool (requires fully- + observed panel); \code{"wild"} applies unit-level Rademacher sign-flips + over the empirical residual pool (requires fully-observed panel).} +\item{cl}{a string specifying the cluster column for cluster bootstrapping. +When \code{group.fe} is set to a single column and \code{cl} is unset, +\code{cl} auto-defaults to \code{group.fe[1]} --- the natural choice when +treatment varies at the group level (Bertrand, Duflo & Mullainathan 2004). +To override --- for example, to cluster at the unit level when group-level +FE is absorbed --- pass \code{cl = index[1]} (e.g., \code{cl = "id"}). +Note that \code{cl = NULL} does NOT disable clustering: the case bootstrap +always resamples units (which is unit-level clustering); the auto-default +only changes the resample unit to a coarser level. \code{cl = FALSE} is +rejected with a guiding error.} +\item{ci.method}{a string controlling how the bootstrap distribution +becomes the CIs reported in fect's \code{est.*} slots. Two values: +\code{"normal"} (default; Wald CI: \eqn{\hat\theta \pm z \cdot SE}) or +\code{"basic"} (reflected pivot: +\eqn{[2\hat\theta - q_{1-\alpha/2},\, 2\hat\theta - q_{\alpha/2}]}, the +literature-standard "percentile" CI per Davison & Hinkley (1997, §5.2.1) +and what \code{boot::boot.ci(type = "basic")} returns). For +\code{"percentile"}, \code{"bc"}, or \code{"bca"} CIs (typically wanted +on alternative estimands like \code{aptt} and \code{log.att}), call +\code{\link{estimand}} after fitting.} + +\item{quantile.CI}{deprecated as of v2.4.2. Use \code{ci.method} instead. +\code{quantile.CI = FALSE} maps to \code{ci.method = "normal"}; +\code{quantile.CI = TRUE} maps to \code{ci.method = "basic"}. Both +mappings still work but emit a one-time deprecation warning.} +\item{nboots}{an integer specifying the number of bootstrap runs. Ignored if \code{se=FALSE}. Default \code{200}, sufficient for the standard error and the normal-CI structure that \code{fect} ships in \code{est.att}/\code{att.avg}. For tail-quantile-based CI methods accessed via \code{estimand()} (\code{ci.method} \code{"basic"}, \code{"percentile"}, \code{"bc"}, \code{"bca"}), bump to \code{nboots = 1000} or higher (Efron 1987 Section 3; DiCiccio & Efron 1996 Section 4); \code{estimand()} emits a warning when called on under-replicated fits.} \item{alpha}{the significance level for hypothesis tests and confidence intervals. Default \code{0.05}.} \item{parallel}{controls which operations run in parallel. Accepted values: \describe{ @@ -116,8 +153,17 @@ returns). This guarantees numerical identity between serial and parallel results but may compute a few extra lambda values compared to the serial path. Use \code{parallel = FALSE} to preserve the short-circuit behavior.} \item{cores}{an integer indicating the number of cores for parallel computing.} -\item{tol}{a positive number indicating the tolerance level for EM updates.} -\item{max.iteration}{the maximal number of iterations for the EM algorithm.} +\item{tol}{a positive number indicating the relative tolerance for the +EM update check (\code{||fit_new - fit_old||_F / ||fit_old||_F < tol}). +Default tightened from \code{1e-3} to \code{1e-5} in v2.4.3 because the +older default produced under-converged IFE/CFE point estimates that +shifted up to 40\% relative to the converged value (inference was +preserved, but the reported numbers were stopping-point-dependent).} +\item{max.iteration}{the maximal number of EM iterations. Default raised +from \code{1000} to \code{5000} in v2.4.3 to accommodate the tighter tol; +canonical IFE/CFE fits converge in 700-2000 iters at \code{tol = 1e-5}. +A \code{warning()} is emitted when the EM hits this cap without +satisfying the tol gate (under-convergence diagnostic).} \item{seed}{an integer seed for random number generation.} \item{min.T0}{an integer specifying the minimum number of pre-treatment periods for each treated unit.} \item{max.missing}{an integer specifying the maximum number of missing observations allowed per unit.} @@ -127,7 +173,21 @@ path. Use \code{parallel = FALSE} to preserve the short-circuit behavior.} \item{tost.threshold}{a numeric threshold for two-one-sided t-tests.} \item{knots}{a numeric vector specifying knots (currently unused; reserved for future use).} \item{degree}{an integer specifying the degree (currently unused; reserved for future use).} -\item{sfe}{vector specifying other fixed effects for \code{method="cfe"}.} +\item{group.fe}{a character vector of column names naming additional simple +additive fixed-effect groupings to absorb (e.g., \code{group.fe = "state"} +when rows are counties and treatment varies at state level). Each entry must +be a column in \code{data}. Each entry must be \emph{nested in} +\code{index[1]} --- i.e., constant within each level of the unit identifier +--- otherwise an error is raised. When \code{group.fe} is set, \code{method += "fe"} is silently routed to \code{method = "cfe"} (FE is a subset of CFE, +identical result); \code{method = "ife"}, \code{"mc"}, \code{"both"}, and +\code{"gsynth"} hard-error (use \code{method = "cfe"} with \code{r > 0} for +free latent factors with group-level FE). When \code{group.fe} has length 1 +and \code{cl} is unset, \code{cl} auto-defaults to \code{group.fe[1]}. To +cluster at the unit level instead, pass \code{cl = index[1]} (e.g., +\code{cl = "id"}); \code{cl = NULL} does NOT change behavior (the case +bootstrap always resamples units regardless of \code{cl}), and +\code{cl = FALSE} is rejected with a guiding error.} \item{cfe}{a vector of lists specifying interactive fixed effects for \code{method="cfe"}.} \item{Z}{a vector specifying the time-invariant covariates for the Z matrix.} \item{gamma}{a vector specifying the time-varying covariates for the gamma matrix.} diff --git a/pkgdown/build.R b/pkgdown/build.R deleted file mode 100644 index e52f5160..00000000 --- a/pkgdown/build.R +++ /dev/null @@ -1,23 +0,0 @@ - -setwd("~/github/fect") - -# initializing -library(usethis) -library(sinew) -library(pkgdown) -library(quarto) -usethis::use_readme_rmd() -usethis::use_pkgdown() -usethis::use_news_md() # update logs - -# remember to knitr README.Rmd -pkgdown::build_site(install = FALSE) - -# or alternatively -library(pkgdown) -init_site() -build_home() -build_reference() -build_articles() -build_tutorials() -build_news() diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index b981cf85..add6cbca 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -308,8 +308,8 @@ BEGIN_RCPP END_RCPP } // complex_fe_ub -List complex_fe_ub(const arma::mat& Y, const arma::mat& Y0, const arma::cube& X_covariates, const arma::cube& X_extra_FE, const arma::cube& X_Z, const arma::cube& X_Q, const arma::cube& X_gamma, const arma::cube& X_kappa, Rcpp::List Zgamma_id, Rcpp::List kappaQ_id, const arma::mat& I, const arma::mat& W_in, const arma::mat& beta0, int r, int force, double tol, int max_iter); -RcppExport SEXP _fect_complex_fe_ub(SEXP YSEXP, SEXP Y0SEXP, SEXP X_covariatesSEXP, SEXP X_extra_FESEXP, SEXP X_ZSEXP, SEXP X_QSEXP, SEXP X_gammaSEXP, SEXP X_kappaSEXP, SEXP Zgamma_idSEXP, SEXP kappaQ_idSEXP, SEXP ISEXP, SEXP W_inSEXP, SEXP beta0SEXP, SEXP rSEXP, SEXP forceSEXP, SEXP tolSEXP, SEXP max_iterSEXP) { +List complex_fe_ub(const arma::mat& Y, const arma::mat& Y0, const arma::cube& X_covariates, const arma::cube& X_extra_FE, const arma::cube& X_Z, const arma::cube& X_Q, const arma::cube& X_gamma, const arma::cube& X_kappa, Rcpp::List Zgamma_id, Rcpp::List kappaQ_id, const arma::mat& I, const arma::mat& W_in, const arma::mat& beta0, int r, int force, double tol, int max_iter, Rcpp::Nullable fit_init); +RcppExport SEXP _fect_complex_fe_ub(SEXP YSEXP, SEXP Y0SEXP, SEXP X_covariatesSEXP, SEXP X_extra_FESEXP, SEXP X_ZSEXP, SEXP X_QSEXP, SEXP X_gammaSEXP, SEXP X_kappaSEXP, SEXP Zgamma_idSEXP, SEXP kappaQ_idSEXP, SEXP ISEXP, SEXP W_inSEXP, SEXP beta0SEXP, SEXP rSEXP, SEXP forceSEXP, SEXP tolSEXP, SEXP max_iterSEXP, SEXP fit_initSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -330,7 +330,8 @@ BEGIN_RCPP Rcpp::traits::input_parameter< int >::type force(forceSEXP); Rcpp::traits::input_parameter< double >::type tol(tolSEXP); Rcpp::traits::input_parameter< int >::type max_iter(max_iterSEXP); - rcpp_result_gen = Rcpp::wrap(complex_fe_ub(Y, Y0, X_covariates, X_extra_FE, X_Z, X_Q, X_gamma, X_kappa, Zgamma_id, kappaQ_id, I, W_in, beta0, r, force, tol, max_iter)); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type fit_init(fit_initSEXP); + rcpp_result_gen = Rcpp::wrap(complex_fe_ub(Y, Y0, X_covariates, X_extra_FE, X_Z, X_Q, X_gamma, X_kappa, Zgamma_id, kappaQ_id, I, W_in, beta0, r, force, tol, max_iter, fit_init)); return rcpp_result_gen; END_RCPP } @@ -488,8 +489,8 @@ BEGIN_RCPP END_RCPP } // cfe_iter -List cfe_iter(const arma::cube& XX, const arma::mat& xxinv, const arma::cube& X_extra_FE, const arma::cube& X_Z, const arma::cube& X_Q, const arma::cube& X_gamma, const arma::cube& X_kappa, Rcpp::List Zgamma_id, Rcpp::List kappaQ_id, const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int force, int r, double tolerate, int max_iter); -RcppExport SEXP _fect_cfe_iter(SEXP XXSEXP, SEXP xxinvSEXP, SEXP X_extra_FESEXP, SEXP X_ZSEXP, SEXP X_QSEXP, SEXP X_gammaSEXP, SEXP X_kappaSEXP, SEXP Zgamma_idSEXP, SEXP kappaQ_idSEXP, SEXP YSEXP, SEXP Y0SEXP, SEXP ISEXP, SEXP WSEXP, SEXP beta0SEXP, SEXP forceSEXP, SEXP rSEXP, SEXP tolerateSEXP, SEXP max_iterSEXP) { +List cfe_iter(const arma::cube& XX, const arma::mat& xxinv, const arma::cube& X_extra_FE, const arma::cube& X_Z, const arma::cube& X_Q, const arma::cube& X_gamma, const arma::cube& X_kappa, Rcpp::List Zgamma_id, Rcpp::List kappaQ_id, const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int force, int r, double tolerate, int max_iter, Rcpp::Nullable fit_init); +RcppExport SEXP _fect_cfe_iter(SEXP XXSEXP, SEXP xxinvSEXP, SEXP X_extra_FESEXP, SEXP X_ZSEXP, SEXP X_QSEXP, SEXP X_gammaSEXP, SEXP X_kappaSEXP, SEXP Zgamma_idSEXP, SEXP kappaQ_idSEXP, SEXP YSEXP, SEXP Y0SEXP, SEXP ISEXP, SEXP WSEXP, SEXP beta0SEXP, SEXP forceSEXP, SEXP rSEXP, SEXP tolerateSEXP, SEXP max_iterSEXP, SEXP fit_initSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -511,7 +512,8 @@ BEGIN_RCPP Rcpp::traits::input_parameter< int >::type r(rSEXP); Rcpp::traits::input_parameter< double >::type tolerate(tolerateSEXP); Rcpp::traits::input_parameter< int >::type max_iter(max_iterSEXP); - rcpp_result_gen = Rcpp::wrap(cfe_iter(XX, xxinv, X_extra_FE, X_Z, X_Q, X_gamma, X_kappa, Zgamma_id, kappaQ_id, Y, Y0, I, W, beta0, force, r, tolerate, max_iter)); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type fit_init(fit_initSEXP); + rcpp_result_gen = Rcpp::wrap(cfe_iter(XX, xxinv, X_extra_FE, X_Z, X_Q, X_gamma, X_kappa, Zgamma_id, kappaQ_id, Y, Y0, I, W, beta0, force, r, tolerate, max_iter, fit_init)); return rcpp_result_gen; END_RCPP } @@ -615,8 +617,8 @@ BEGIN_RCPP END_RCPP } // inter_fe_ub -List inter_fe_ub(const arma::mat& Y, const arma::mat& Y0, const arma::cube& X, const arma::mat& I, const arma::mat& W_in, const arma::mat& beta0, int r, int force, double tol, int max_iter); -RcppExport SEXP _fect_inter_fe_ub(SEXP YSEXP, SEXP Y0SEXP, SEXP XSEXP, SEXP ISEXP, SEXP W_inSEXP, SEXP beta0SEXP, SEXP rSEXP, SEXP forceSEXP, SEXP tolSEXP, SEXP max_iterSEXP) { +List inter_fe_ub(const arma::mat& Y, const arma::mat& Y0, const arma::cube& X, const arma::mat& I, const arma::mat& W_in, const arma::mat& beta0, int r, int force, double tol, int max_iter, Rcpp::Nullable fit_init); +RcppExport SEXP _fect_inter_fe_ub(SEXP YSEXP, SEXP Y0SEXP, SEXP XSEXP, SEXP ISEXP, SEXP W_inSEXP, SEXP beta0SEXP, SEXP rSEXP, SEXP forceSEXP, SEXP tolSEXP, SEXP max_iterSEXP, SEXP fit_initSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -630,7 +632,8 @@ BEGIN_RCPP Rcpp::traits::input_parameter< int >::type force(forceSEXP); Rcpp::traits::input_parameter< double >::type tol(tolSEXP); Rcpp::traits::input_parameter< int >::type max_iter(max_iterSEXP); - rcpp_result_gen = Rcpp::wrap(inter_fe_ub(Y, Y0, X, I, W_in, beta0, r, force, tol, max_iter)); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type fit_init(fit_initSEXP); + rcpp_result_gen = Rcpp::wrap(inter_fe_ub(Y, Y0, X, I, W_in, beta0, r, force, tol, max_iter, fit_init)); return rcpp_result_gen; END_RCPP } @@ -672,8 +675,8 @@ BEGIN_RCPP END_RCPP } // fe_ad_inter_iter -List fe_ad_inter_iter(const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, int force, int mc, int r, int hard, double lambda, double tolerate, int max_iter); -RcppExport SEXP _fect_fe_ad_inter_iter(SEXP YSEXP, SEXP Y0SEXP, SEXP ISEXP, SEXP WSEXP, SEXP forceSEXP, SEXP mcSEXP, SEXP rSEXP, SEXP hardSEXP, SEXP lambdaSEXP, SEXP tolerateSEXP, SEXP max_iterSEXP) { +List fe_ad_inter_iter(const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, int force, int mc, int r, int hard, double lambda, double tolerate, int max_iter, Rcpp::Nullable fit_init); +RcppExport SEXP _fect_fe_ad_inter_iter(SEXP YSEXP, SEXP Y0SEXP, SEXP ISEXP, SEXP WSEXP, SEXP forceSEXP, SEXP mcSEXP, SEXP rSEXP, SEXP hardSEXP, SEXP lambdaSEXP, SEXP tolerateSEXP, SEXP max_iterSEXP, SEXP fit_initSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -688,13 +691,14 @@ BEGIN_RCPP Rcpp::traits::input_parameter< double >::type lambda(lambdaSEXP); Rcpp::traits::input_parameter< double >::type tolerate(tolerateSEXP); Rcpp::traits::input_parameter< int >::type max_iter(max_iterSEXP); - rcpp_result_gen = Rcpp::wrap(fe_ad_inter_iter(Y, Y0, I, W, force, mc, r, hard, lambda, tolerate, max_iter)); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type fit_init(fit_initSEXP); + rcpp_result_gen = Rcpp::wrap(fe_ad_inter_iter(Y, Y0, I, W, force, mc, r, hard, lambda, tolerate, max_iter, fit_init)); return rcpp_result_gen; END_RCPP } // fe_ad_inter_covar_iter -List fe_ad_inter_covar_iter(const arma::cube& XX, const arma::mat& xxinv, const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int force, int mc, int r, int hard, double lambda, double tolerate, int max_iter); -RcppExport SEXP _fect_fe_ad_inter_covar_iter(SEXP XXSEXP, SEXP xxinvSEXP, SEXP YSEXP, SEXP Y0SEXP, SEXP ISEXP, SEXP WSEXP, SEXP beta0SEXP, SEXP forceSEXP, SEXP mcSEXP, SEXP rSEXP, SEXP hardSEXP, SEXP lambdaSEXP, SEXP tolerateSEXP, SEXP max_iterSEXP) { +List fe_ad_inter_covar_iter(const arma::cube& XX, const arma::mat& xxinv, const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int force, int mc, int r, int hard, double lambda, double tolerate, int max_iter, Rcpp::Nullable fit_init); +RcppExport SEXP _fect_fe_ad_inter_covar_iter(SEXP XXSEXP, SEXP xxinvSEXP, SEXP YSEXP, SEXP Y0SEXP, SEXP ISEXP, SEXP WSEXP, SEXP beta0SEXP, SEXP forceSEXP, SEXP mcSEXP, SEXP rSEXP, SEXP hardSEXP, SEXP lambdaSEXP, SEXP tolerateSEXP, SEXP max_iterSEXP, SEXP fit_initSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -712,7 +716,8 @@ BEGIN_RCPP Rcpp::traits::input_parameter< double >::type lambda(lambdaSEXP); Rcpp::traits::input_parameter< double >::type tolerate(tolerateSEXP); Rcpp::traits::input_parameter< int >::type max_iter(max_iterSEXP); - rcpp_result_gen = Rcpp::wrap(fe_ad_inter_covar_iter(XX, xxinv, Y, Y0, I, W, beta0, force, mc, r, hard, lambda, tolerate, max_iter)); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type fit_init(fit_initSEXP); + rcpp_result_gen = Rcpp::wrap(fe_ad_inter_covar_iter(XX, xxinv, Y, Y0, I, W, beta0, force, mc, r, hard, lambda, tolerate, max_iter, fit_init)); return rcpp_result_gen; END_RCPP } @@ -734,8 +739,8 @@ BEGIN_RCPP END_RCPP } // inter_fe_mc -List inter_fe_mc(const arma::mat& Y, const arma::mat& Y0, const arma::cube& X, const arma::mat& I, const arma::mat& W_in, const arma::mat& beta0, int r, double lambda, int force, double tol, int max_iter); -RcppExport SEXP _fect_inter_fe_mc(SEXP YSEXP, SEXP Y0SEXP, SEXP XSEXP, SEXP ISEXP, SEXP W_inSEXP, SEXP beta0SEXP, SEXP rSEXP, SEXP lambdaSEXP, SEXP forceSEXP, SEXP tolSEXP, SEXP max_iterSEXP) { +List inter_fe_mc(const arma::mat& Y, const arma::mat& Y0, const arma::cube& X, const arma::mat& I, const arma::mat& W_in, const arma::mat& beta0, int r, double lambda, int force, double tol, int max_iter, Rcpp::Nullable fit_init); +RcppExport SEXP _fect_inter_fe_mc(SEXP YSEXP, SEXP Y0SEXP, SEXP XSEXP, SEXP ISEXP, SEXP W_inSEXP, SEXP beta0SEXP, SEXP rSEXP, SEXP lambdaSEXP, SEXP forceSEXP, SEXP tolSEXP, SEXP max_iterSEXP, SEXP fit_initSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -750,7 +755,8 @@ BEGIN_RCPP Rcpp::traits::input_parameter< int >::type force(forceSEXP); Rcpp::traits::input_parameter< double >::type tol(tolSEXP); Rcpp::traits::input_parameter< int >::type max_iter(max_iterSEXP); - rcpp_result_gen = Rcpp::wrap(inter_fe_mc(Y, Y0, X, I, W_in, beta0, r, lambda, force, tol, max_iter)); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type fit_init(fit_initSEXP); + rcpp_result_gen = Rcpp::wrap(inter_fe_mc(Y, Y0, X, I, W_in, beta0, r, lambda, force, tol, max_iter, fit_init)); return rcpp_result_gen; END_RCPP } @@ -776,7 +782,7 @@ static const R_CallMethodDef CallEntries[] = { {"_fect_fe_ub", (DL_FUNC) &_fect_fe_ub, 6}, {"_fect_inter_fe_d", (DL_FUNC) &_fect_inter_fe_d, 9}, {"_fect_inter_fe_d_ub", (DL_FUNC) &_fect_inter_fe_d_ub, 10}, - {"_fect_complex_fe_ub", (DL_FUNC) &_fect_complex_fe_ub, 17}, + {"_fect_complex_fe_ub", (DL_FUNC) &_fect_complex_fe_ub, 18}, {"_fect_YY_adj", (DL_FUNC) &_fect_YY_adj, 5}, {"_fect_Demean", (DL_FUNC) &_fect_Demean, 4}, {"_fect_fixed_effects_part", (DL_FUNC) &_fect_fixed_effects_part, 4}, @@ -788,7 +794,7 @@ static const R_CallMethodDef CallEntries[] = { {"_fect_WBeta", (DL_FUNC) &_fect_WBeta, 4}, {"_fect_beta_part", (DL_FUNC) &_fect_beta_part, 5}, {"_fect_ife_part", (DL_FUNC) &_fect_ife_part, 2}, - {"_fect_cfe_iter", (DL_FUNC) &_fect_cfe_iter, 18}, + {"_fect_cfe_iter", (DL_FUNC) &_fect_cfe_iter, 19}, {"_fect_Y_demean", (DL_FUNC) &_fect_Y_demean, 2}, {"_fect_Y_wdemean", (DL_FUNC) &_fect_Y_wdemean, 3}, {"_fect_fe_add", (DL_FUNC) &_fect_fe_add, 6}, @@ -796,13 +802,13 @@ static const R_CallMethodDef CallEntries[] = { {"_fect_panel_FE", (DL_FUNC) &_fect_panel_FE, 3}, {"_fect_ife", (DL_FUNC) &_fect_ife, 6}, {"_fect_inter_fe", (DL_FUNC) &_fect_inter_fe, 7}, - {"_fect_inter_fe_ub", (DL_FUNC) &_fect_inter_fe_ub, 10}, + {"_fect_inter_fe_ub", (DL_FUNC) &_fect_inter_fe_ub, 11}, {"_fect_fe_ad_iter", (DL_FUNC) &_fect_fe_ad_iter, 7}, {"_fect_fe_ad_covar_iter", (DL_FUNC) &_fect_fe_ad_covar_iter, 10}, - {"_fect_fe_ad_inter_iter", (DL_FUNC) &_fect_fe_ad_inter_iter, 11}, - {"_fect_fe_ad_inter_covar_iter", (DL_FUNC) &_fect_fe_ad_inter_covar_iter, 14}, + {"_fect_fe_ad_inter_iter", (DL_FUNC) &_fect_fe_ad_inter_iter, 12}, + {"_fect_fe_ad_inter_covar_iter", (DL_FUNC) &_fect_fe_ad_inter_covar_iter, 15}, {"_fect_beta_iter", (DL_FUNC) &_fect_beta_iter, 7}, - {"_fect_inter_fe_mc", (DL_FUNC) &_fect_inter_fe_mc, 11}, + {"_fect_inter_fe_mc", (DL_FUNC) &_fect_inter_fe_mc, 12}, {NULL, NULL, 0} }; diff --git a/src/cfe.cpp b/src/cfe.cpp index 3a536e59..c8b478d4 100644 --- a/src/cfe.cpp +++ b/src/cfe.cpp @@ -2,7 +2,12 @@ // core cfe model function -/* Complex Fixed Effects: ub */ +/* Complex Fixed Effects: ub + * + * fit_init: optional warm-start matrix (TT x N). Forwarded to cfe_iter to + * replace the default `fit = Y0` initialization. See cfe_iter docstring + * and ref/v242-warm-start-investigation/partial-warm-design.md. + */ // [[Rcpp::export]] List complex_fe_ub( const arma::mat& Y, const arma::mat& Y0, const arma::cube& X_covariates, const arma::cube& X_extra_FE, @@ -10,7 +15,8 @@ List complex_fe_ub( Rcpp::List Zgamma_id, Rcpp::List kappaQ_id, const arma::mat& I, const arma::mat& W_in, const arma::mat& beta0, int r, // r > 0, the outcome has a factor-type fixed effect; r = 0 else - int force, double tol = 1e-5, int max_iter = 1000) { + int force, double tol = 1e-5, int max_iter = 1000, + Rcpp::Nullable fit_init = R_NilValue) { arma::mat W = W_in; /* Dimensions */ @@ -95,7 +101,8 @@ List complex_fe_ub( } List cfe = cfe_iter(XX, invXX, X_extra_FE, X_Z, X_Q, X_gamma, X_kappa, Zgamma_id, - kappaQ_id, YY, Y0, I, W, beta0, force, r, tol, max_iter); + kappaQ_id, YY, Y0, I, W, beta0, force, r, tol, max_iter, + fit_init); mu = as(cfe["mu"]); beta = as(cfe["beta"]); diff --git a/src/cfe_sub.cpp b/src/cfe_sub.cpp index 7d8f4dad..fbeff36b 100644 --- a/src/cfe_sub.cpp +++ b/src/cfe_sub.cpp @@ -262,7 +262,16 @@ List ife_part(arma::mat E, int r) { return (result); } -/* Obtain cfe; */ +/* Obtain cfe; + * + * fit_init: optional warm-start matrix (TT x N) to seed the EM loop. + * When non-null and shape matches Y, replaces the default `fit = Y0` + * initialization. Intended for partial warm-start during bootstrap: + * pass the auxiliary-only prediction surface from the cached main fit + * (Y.ct - factor %*% t(lambda)) so the EM can converge faster on + * per-replicate data without anchoring the (factor, lambda) basin. + * See ref/v242-warm-start-investigation/partial-warm-design.md. + */ // [[Rcpp::export]] List cfe_iter(const arma::cube& XX, const arma::mat& xxinv, const arma::cube& X_extra_FE, const arma::cube& X_Z, @@ -270,7 +279,8 @@ List cfe_iter(const arma::cube& XX, const arma::mat& xxinv, const arma::cube& X_kappa, Rcpp::List Zgamma_id, Rcpp::List kappaQ_id, const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, - int force, int r, double tolerate, int max_iter) { + int force, int r, double tolerate, int max_iter, + Rcpp::Nullable fit_init = R_NilValue) { int T = Y.n_rows; int N = Y.n_cols; int p = XX.n_slices; @@ -336,7 +346,17 @@ List cfe_iter(const arma::cube& XX, const arma::mat& xxinv, arma::mat FE(T, N, arma::fill::zeros); - fit = Y0; + // Warm-start init: if fit_init provided and shape matches, seed the EM + // with it; otherwise fall back to fit = Y0 (cold-start, pre-2.4.3). + arma::mat warm_init = Y0; + if (fit_init.isNotNull()) { + arma::mat fi = Rcpp::as(fit_init); + if (fi.n_rows == static_cast(T) && + fi.n_cols == static_cast(N)) { + warm_init = fi; + } + } + fit = warm_init; fit_old = fit; for (int i = 0; i < p; i++) { fit1 = fit1 + XX.slice(i) * beta0(i); @@ -536,8 +556,12 @@ List cfe_iter(const arma::cube& XX, const arma::mat& xxinv, List result; result["mu"] = result4["mu"]; - result["alpha"] = result4["alpha"]; - result["xi"] = result4["xi"]; + if (force == 1 || force == 3) { + result["alpha"] = result4["alpha"]; + } + if (force == 2 || force == 3) { + result["xi"] = result4["xi"]; + } result["niter"] = niter; result["e"] = e; result["beta"] = result1["beta"]; diff --git a/src/fect.h b/src/fect.h index a192c46b..6ddee3a9 100644 --- a/src/fect.h +++ b/src/fect.h @@ -38,8 +38,8 @@ arma::mat panel_FE(const arma::mat& E, double lambda, int hard); List ife(const arma::mat& E, int force, int mc, int r, int hard, double lambda); List fe_ad_iter(const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, int force, double tolerate, int max_iter); List fe_ad_covar_iter(const arma::cube& XX, const arma::mat& xxinv, const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& beta0, const arma::mat& W, int force, double tolerate, int max_iter); -List fe_ad_inter_iter(const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, int force, int mc, int r, int hard, double lambda, double tolerate, int max_iter); -List fe_ad_inter_covar_iter(const arma::cube& XX, const arma::mat& xxinv, const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int force, int mc, int r, int hard, double lambda, double tolerate, int max_iter); +List fe_ad_inter_iter(const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, int force, int mc, int r, int hard, double lambda, double tolerate, int max_iter, Rcpp::Nullable fit_init); +List fe_ad_inter_covar_iter(const arma::cube& XX, const arma::mat& xxinv, const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int force, int mc, int r, int hard, double lambda, double tolerate, int max_iter, Rcpp::Nullable fit_init); List beta_iter(const arma::cube& X, const arma::mat& xxinv, const arma::mat& Y, int r, double tolerate, const arma::mat& beta0, int max_iter); List qr_factor(const arma::mat& F, const arma::mat& L); arma::mat IND(const arma::mat& I); @@ -49,12 +49,12 @@ List f_ub(const arma::mat& Y, const arma::mat& L, const arma::mat& I, int r, int List fe(const arma::mat& E, const arma::mat& F_old, const arma::mat& xi_old, int force, int r); List fe_ub(const arma::mat& E, const arma::mat& I, const arma::mat& F_old, const arma::mat& xi_old, int force, int r); List inter_fe(const arma::mat& Y, const arma::cube& X, int r, int force, const arma::mat& beta0, double tol, int max_iter); -List inter_fe_ub(const arma::mat& Y, const arma::mat& Y0, const arma::cube& X, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int r, int force, double tol, int max_iter); -List inter_fe_mc(const arma::mat& Y, const arma::mat& Y0, const arma::cube& X, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int r, double lambda, int force, double tol, int max_iter); +List inter_fe_ub(const arma::mat& Y, const arma::mat& Y0, const arma::cube& X, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int r, int force, double tol, int max_iter, Rcpp::Nullable fit_init); +List inter_fe_mc(const arma::mat& Y, const arma::mat& Y0, const arma::cube& X, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int r, double lambda, int force, double tol, int max_iter, Rcpp::Nullable fit_init); List inter_fe_d(const arma::mat& Y, const arma::mat& Y_fit0, const arma::mat& FE0, const arma::cube& X, int r, int force, int mniter, double w, double tol); List inter_fe_d_ub(const arma::mat& Y, const arma::mat& Y_fit0, const arma::mat& FE0, const arma::cube& X, const arma::mat& I, int r, int force, int mniter, double w, double tol); List inter_fe_d_qr(const arma::mat& Y, const arma::mat& Y_fit0, const arma::mat& FE0, const arma::mat& factor0, const arma::mat& xi0, const arma::cube& X, int r, int force, int mniter, double w, double tol); List inter_fe_d_qr_ub(const arma::mat& Y, const arma::mat& Y_fit0, const arma::mat& FE0, const arma::mat& factor0, const arma::mat& xi0, const arma::cube& X, const arma::mat& I, int r, int force, int mniter, double w, double tol); -List cfe_iter(const arma::cube& XX, const arma::mat& xxinv, const arma::cube& X_extra_FE, const arma::cube& X_Z, const arma::cube& X_Q, const arma::cube& X_gamma, const arma::cube& X_kappa, Rcpp::List Zgamma_id, Rcpp::List kappaQ_id, const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int force, int r, double tolerate, int max_iter); -List complex_fe_ub(const arma::mat& Y, const arma::mat& Y0, const arma::cube& X_covariates, const arma::cube& X_extra_FE, const arma::cube& X_Z, const arma::cube& X_Q, const arma::cube& X_gamma, const arma::cube& X_kappa, Rcpp::List Zgamma_id, Rcpp::List kappaQ_id, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int r, int force, double tol, int max_iter); +List cfe_iter(const arma::cube& XX, const arma::mat& xxinv, const arma::cube& X_extra_FE, const arma::cube& X_Z, const arma::cube& X_Q, const arma::cube& X_gamma, const arma::cube& X_kappa, Rcpp::List Zgamma_id, Rcpp::List kappaQ_id, const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int force, int r, double tolerate, int max_iter, Rcpp::Nullable fit_init); +List complex_fe_ub(const arma::mat& Y, const arma::mat& Y0, const arma::cube& X_covariates, const arma::cube& X_extra_FE, const arma::cube& X_Z, const arma::cube& X_Q, const arma::cube& X_gamma, const arma::cube& X_kappa, Rcpp::List Zgamma_id, Rcpp::List kappaQ_id, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int r, int force, double tol, int max_iter, Rcpp::Nullable fit_init); #endif diff --git a/src/ife.cpp b/src/ife.cpp index 1006527d..874caa0c 100644 --- a/src/ife.cpp +++ b/src/ife.cpp @@ -281,13 +281,25 @@ List inter_fe(const arma::mat& Y, const arma::cube& X, int r, int force, const a return (output); } -/* Interactive Fixed Effects: ub */ +/* Interactive Fixed Effects: ub + * + * fit_init: optional warm-start matrix (TT x N). When non-null and + * shape matches Y, the inner EM loop seeds `fit` from it instead of + * the default `fit = Y0` (cold-start). Used by R/boot.R::one.nonpara + * to pass the main-fit prediction surface into bootstrap replicates, + * which collapses EM convergence from ~20-50 iterations to ~1-3 when + * the bootstrap perturbs the data only modestly. NULL (default) + * preserves the pre-2.4.2 cold-start behavior. See + * statsclaw-workspace/fect/ref/warm-start-audit-2026-05-01.md for + * the statistical justification. + */ // [[Rcpp::export]] List inter_fe_ub( const arma::mat& Y, const arma::mat& Y0, const arma::cube& X, const arma::mat& I, const arma::mat& W_in, const arma::mat& beta0, int r, // r > 0, the outcome has a factor-type fixed effect; r = 0 else - int force, double tol = 1e-5, int max_iter = 1000) { + int force, double tol = 1e-5, int max_iter = 1000, + Rcpp::Nullable fit_init = R_NilValue) { arma::mat W = W_in; /* Dimensions */ @@ -365,7 +377,7 @@ List inter_fe_ub( if (r > 0) { // add fe ; inter fe ; iteration List fe_ad_inter = - fe_ad_inter_iter(YY, Y0, I, W, force, 0, r, 0, 0, tol, max_iter); + fe_ad_inter_iter(YY, Y0, I, W, force, 0, r, 0, 0, tol, max_iter, fit_init); mu = as(fe_ad_inter["mu"]); U = as(fe_ad_inter["e"]); fit = as(fe_ad_inter["fit"]); @@ -428,7 +440,7 @@ List inter_fe_ub( } else if (r > 0) { // add, covar, interactive, iteration List fe_ad_inter_covar = fe_ad_inter_covar_iter( - XX, invXX, YY, Y0, I, W, beta0, force, 0, r, 0, 0, tol, max_iter); + XX, invXX, YY, Y0, I, W, beta0, force, 0, r, 0, 0, tol, max_iter, fit_init); mu = as(fe_ad_inter_covar["mu"]); beta = as(fe_ad_inter_covar["beta"]); U = as(fe_ad_inter_covar["e"]); diff --git a/src/ife_sub.cpp b/src/ife_sub.cpp index 8a390339..b1cfc8eb 100644 --- a/src/ife_sub.cpp +++ b/src/ife_sub.cpp @@ -189,13 +189,25 @@ List fe_ad_covar_iter(const arma::cube& XX, const arma::mat& xxinv, const arma:: return (result); } -/* Obtain additive fe for ub data; assume r>0 but p=0*/ +/* Obtain additive fe for ub data; assume r>0 but p=0 + * + * fit_init: optional warm-start matrix (TT x N) to seed the EM loop + * from the prediction surface of a previous fit (typically the main + * real-data fit, when this function is called inside a bootstrap + * replicate). If non-null and dimensions match Y, replaces the + * default `fit = Y0` initialization. NULL (default) preserves the + * pre-2.4.2 cold-start behavior. See statsclaw-workspace/fect/ref/ + * warm-start-audit-2026-05-01.md for the statistical justification + * (prediction surface uniquely identified for IFE / MC; warm-start + * is variance-neutral). + */ // [[Rcpp::export]] List fe_ad_inter_iter(const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, int force, int mc, // whether pca or mc method int r, int hard, double lambda, double tolerate, - int max_iter = 1000) { + int max_iter = 1000, + Rcpp::Nullable fit_init = R_NilValue) { int T = Y.n_rows; int N = Y.n_cols; double mu = 0; @@ -234,8 +246,19 @@ List fe_ad_inter_iter(const arma::mat& Y, const arma::mat& Y0, const arma::mat& List pf; List ife_inner; + // Warm-start init: if fit_init is provided and shape matches, seed + // the EM with it; otherwise fall back to fit = Y0 (cold-start). + arma::mat warm_init = Y0; + if (fit_init.isNotNull()) { + arma::mat fi = Rcpp::as(fit_init); + if (fi.n_rows == static_cast(T) && + fi.n_cols == static_cast(N)) { + warm_init = fi; + } + } + // initial value for ife - fit = Y0; + fit = warm_init; fit_old = fit; int stop_burnin = 0; while (dif > tolerate && niter <= max_iter) { @@ -289,7 +312,7 @@ List fe_ad_inter_iter(const arma::mat& Y, const arma::mat& Y0, const arma::mat& stop_burnin = 1; dif = 1.0; niter = 0; - fit = Y0; + fit = warm_init; // post-burnin restart honors warm-start fit_old = fit; } } @@ -326,14 +349,20 @@ List fe_ad_inter_iter(const arma::mat& Y, const arma::mat& Y0, const arma::mat& return (result); } -/* Obtain additive fe for ub data; assume r>0 p>0*/ +/* Obtain additive fe for ub data; assume r>0 p>0 + * + * fit_init: optional warm-start matrix (TT x N). See fe_ad_inter_iter + * docstring. Same semantics: NULL = cold-start, non-null = seed EM + * from a prior prediction surface. + */ // [[Rcpp::export]] List fe_ad_inter_covar_iter(const arma::cube& XX, const arma::mat& xxinv, const arma::mat& Y, const arma::mat& Y0, const arma::mat& I, const arma::mat& W, const arma::mat& beta0, int force, int mc, // whether pca or mc method int r, int hard, double lambda, double tolerate, - int max_iter = 1000) { + int max_iter = 1000, + Rcpp::Nullable fit_init = R_NilValue) { int T = Y.n_rows; int N = Y.n_cols; int p = XX.n_slices; @@ -379,6 +408,17 @@ List fe_ad_inter_covar_iter(const arma::cube& XX, const arma::mat& xxinv, const // double dif_FE_inter_use = 1.0; // initial value for ife + // Warm-start init: if fit_init is provided and shape matches, seed + // the EM with it; otherwise fall back to fit = Y0 (cold-start). + arma::mat warm_init = Y0; + if (fit_init.isNotNull()) { + arma::mat fi = Rcpp::as(fit_init); + if (fi.n_rows == static_cast(T) && + fi.n_cols == static_cast(N)) { + warm_init = fi; + } + } + // if (hard == 0) { // U = FE_adj(Y - Y0, I) ; // if (mc == 0) { @@ -393,7 +433,7 @@ List fe_ad_inter_covar_iter(const arma::cube& XX, const arma::mat& xxinv, const // fit = Y0 + FE_inter_use ; // fit_old = fit ; // } else { - fit = Y0; + fit = warm_init; fit_old = fit; //} @@ -472,7 +512,7 @@ List fe_ad_inter_covar_iter(const arma::cube& XX, const arma::mat& xxinv, const stop_burnin = 1; dif = 1.0; niter = 0; - fit = Y0; + fit = warm_init; // post-burnin restart honors warm-start fit_old = fit; } } diff --git a/src/mc.cpp b/src/mc.cpp index b984250e..218873cd 100644 --- a/src/mc.cpp +++ b/src/mc.cpp @@ -2,13 +2,20 @@ // matrix completion -/* Interactive Fixed Effects: matrix completion */ +/* Interactive Fixed Effects: matrix completion + * + * fit_init: optional warm-start matrix (TT x N) forwarded to the + * inner EM via fe_ad_inter_iter. NULL (default) preserves the + * pre-2.4.2 cold-start behavior. See inter_fe_ub doc for the + * rationale. + */ // [[Rcpp::export]] List inter_fe_mc( const arma::mat& Y, const arma::mat& Y0, const arma::cube& X, const arma::mat& I, const arma::mat& W_in, const arma::mat& beta0, int r, // r > 0, the outcome has a factor-type fixed effect; r = 0 else - double lambda, int force, double tol = 1e-5, int max_iter = 1000) { + double lambda, int force, double tol = 1e-5, int max_iter = 1000, + Rcpp::Nullable fit_init = R_NilValue) { arma::mat W = W_in; /* Dimensions */ @@ -88,7 +95,7 @@ List inter_fe_mc( // soft impute as starting value List fe_ad_inter = - fe_ad_inter_iter(YY, Y0, I, W, force, 1, 1, 0, lambda, tol, max_iter); + fe_ad_inter_iter(YY, Y0, I, W, force, 1, 1, 0, lambda, tol, max_iter, fit_init); // fit = as(fe_ad_inter["fit"]) ; // hard impute @@ -155,7 +162,7 @@ List inter_fe_mc( // soft impute as starting value List fe_ad_inter_covar = fe_ad_inter_covar_iter(XX, invXX, YY, Y0, I, W, beta0, force, 1, 1, 0, - lambda, tol, max_iter); + lambda, tol, max_iter, fit_init); beta = as(fe_ad_inter_covar["beta"]); fit = as(fe_ad_inter_covar["fit"]); diff --git a/tests/coverage-study/README.md b/tests/coverage-study/README.md new file mode 100644 index 00000000..b6da82aa --- /dev/null +++ b/tests/coverage-study/README.md @@ -0,0 +1,171 @@ +# Coverage validation suite + +Standalone Monte-Carlo studies that validate the v2.4.2 inference paths +(`bootstrap`, `parametric`, `jackknife`) produce nominal-coverage +confidence intervals. These are **not** unit tests --- they live outside +`tests/testthat/` because they take more wall-time than is appropriate for +routine `devtools::test()` runs. + +## Two scripts + +- **`run_minimal_coverage.R`** --- routine pre-merge gate. Four + scenarios, ~1.5 min wall-time on 16 cores at K=200, nboots=200. This + is what you should run for any inference-relevant change. +- **`run_para_error_coverage.R`** --- extended characterization of the + parametric / `para.error` machinery on a small panel. ~30-50 min wall + time at cores=10. Run when modifying the `para.error` dispatch or the + parametric pseudo-treated bootstrap specifically. + +A small follow-up script `run_minimal_coverage_tail_rerun.R` re-runs at +nboots=1000 only those scenarios whose tail-CI methods (basic / +percentile / bc / bca) came in below 0.93 in the K=200 / nboots=200 +default --- consistent with the `.check_tail_ci_replicates` warning +gate (Efron 1987 §3, DiCiccio & Efron 1996 §4 recommend B >= 1000 for +tail-quantile CIs). Normal CI is unaffected by B; jackknife is normal +only. + +## When to run + +Run `run_minimal_coverage.R` before declaring any of these changes done: + +- Editing `R/boot.R` (any of the bootstrap / parametric / jackknife / + cluster-bootstrap branches) +- Editing `R/po-estimands.R` (location-shift code, `.compute_ci`, + jackknife dispatch) +- Adding or modifying a `vartype`, `ci.method`, or `para.error` value +- Changing how `att.avg.boot`, `eff.boot`, `att.avg.unit.boot`, or the + `est.avg` row is populated + +Skip if the change is a pure refactor / docs / vignette / plotting / CV +/ no-op on the bootstrap distribution. `devtools::test()` is the right +gate for those. + +## How to run + +```sh +cd /path/to/fect +Rscript tests/coverage-study/run_minimal_coverage.R +``` + +Output: `/tmp/fect-coverage-study/minimal__K_nb_.csv` +(per-rep raw) plus `minimal_summary_K_nb_.csv` (per-cell +coverage / MC SE / mean-CI-width / SE / empirical SD / mean bias). + +Conditional follow-up (only if the K=200 / nboots=200 run shows tail-CI +cells below 0.93): + +```sh +Rscript tests/coverage-study/run_minimal_coverage_tail_rerun.R +``` + +## Acceptance --- minimal coverage + +Four scenarios; coverage is nominal at K=200, MC SE about 0.015 around +0.95. + +| Scenario | DGP | Inference | Cells | Threshold | +|----------|-----|-----------|-------|-----------| +| A | factor (r=2), IID, gsynth-note Xu-2017 spec | `vartype = "parametric"`, `para.error = "auto"` (-> `empirical`), all 5 ci.methods | 5 | coverage >= 0.93 (1.4 SE below 0.95 at K=200) | +| B | factor (r=2), AR(1) rho=0.8 | `vartype = "parametric"`, `para.error = "auto"` (-> `ar`), all 5 ci.methods | 5 | coverage >= 0.93 | +| C1 | additive TWFE (r=0), AR(1) rho=0.5 | `vartype = "bootstrap"` (cluster), all 5 ci.methods | 5 | coverage >= 0.93 at nboots = 1000 | +| C2 | additive TWFE (r=0), AR(1) rho=0.5 | `vartype = "jackknife"`, `ci.method = "normal"` only (E&T 1993 §11) | 1 | coverage >= 0.91 | + +Tail-CI methods (`basic`, `percentile`, `bc`, `bca`) under-cover at +nboots = 200 because the relevant order statistics of the bootstrap +distribution are unstable at small B (Efron 1987 §3). The follow-up +script reruns failing scenarios at nboots = 1000, which restores nominal +coverage. + +C2 jackknife normal-only is a deliberate restriction: jackknife produces +an SE estimate via the Tukey pseudo-value formula, not a sampling +distribution, so reflection-based methods (basic / percentile), +bias-corrected methods (bc / bca), and the BCa acceleration parameter +all lack a defined input. See `.check_jackknife_ci_method` in +`R/po-estimands.R` for the full hard-error message. + +## DGP details (minimal) + +A and B replicate gsynth-note's `code/sims/coverage/simulate-xu-{iid,ar1}-rfit2.R`: + +- N_tr = 5, N_co = 50, T = 30, T0 = 20 (10 post-periods) +- r = 2 latent factors, no covariates +- λ_i ~ U(-√3, √3); F_t ~ N(0, 1); α_i ~ U(-√3, √3); ξ_t ~ N(0, 1); μ = 5 +- λ, F, α, ξ redrawn each rep +- ATT_t = t for t = 1..10 plus N(0, D.sd = 1) per (unit, post-time) +- Coverage target = realized average treated-post effect (within rep) +- A errors: IID N(0, 1). B errors: AR(1) ρ = 0.8, marginal variance 1 +- Estimator: `method = "ife", r = 2, force = "two-way", + time.component.from = "nevertreated", CV = FALSE` (Xu Alg 2 path) + +C scales N for stable cluster-bootstrap and jackknife inference: + +- N_tr = 20, N_co = 80, T = 30, T0 = 20 +- No factors (r = 0); α_i ~ U(-√3, √3); ξ_t ~ N(0, 1); μ = 5 +- ATT = 3 constant (D.sd = 0); coverage target = 3 +- Errors: AR(1) ρ = 0.5, marginal variance 1 +- Estimator: `method = "fe", force = "two-way", + time.component.from = "notyettreated"` + +## Parallelization + +Outer-loop parallelism via `future::plan(future::multisession, +workers = 16)` and `future.apply::future_lapply`. Each `fect()` call +runs sequentially (`parallel = FALSE`). Reps are embarrassingly +parallel; this avoids the per-rep cluster fork/join overhead that inner +bootstrap parallelism pays K times. + +`future.seed = TRUE` produces L'Ecuyer streams across workers for +reproducible RNG independent of rep ordering. + +## Acceptance --- extended (`run_para_error_coverage.R`) + +Three legacy tests on a small DGP-A panel (N=40, T=20, T0=12, IID or +AR(1) ρ=0.8). Now superseded by the minimal suite for routine gating; +retained for deep characterization of the `para.error` dispatch. + +| Test | DGP | Reps | nboots | Threshold | +|------|-----|------|--------|-----------| +| T19 | DGP-A (additive TWFE, IID Gaussian, ATT=3) | 100 | 1000 | coverage >= 0.90 for every (`para.error`, `ci.method`) cell | +| T20 | DGP-A8 (DGP-A + AR(1) ρ=0.8) | 100 | 1000 | coverage >= 0.91 for every cell | +| T21 | DGP-A | 50 | 500 | wild/empirical mean-CI-width ratio in [0.70, 1.30] | + +T19 / T20 are 15 cells each (3 `para.error` modes × 5 `ci.methods`); T21 +is 5 cells (2 modes × 5 ci.methods, ratios computed within ci.method). + +T19 threshold is 0.90 (not 0.95) because at N = 40 IID the parametric +pseudo-treated bootstrap targets the conditional variance V_t alone and +misses the finite-sample bias variance Var_{Λ,F}[b_t] in the absence of +factor structure to absorb it; the empirical SD across MC reps exceeds +the bootstrap SE by ~9%, which translates to ~0.91 coverage analytically +(see "Why fixed treated block" below for the law-of-total-variance +derivation). At realistic factor-model DGPs (the minimal suite's +Scenario A / B), this gap shrinks and coverage returns to nominal. + +## Why fixed treated block + +DGPs hold the treatment indicator $D$ fixed at units 1:Ntr across all +replications. The parametric pseudo-treated bootstrap targets the +conditional variance + +$$V_t = \mathrm{Var}(\widehat{\mathrm{ATT}}_t - \mathrm{ATT}_t \mid \Lambda, F, X, D),$$ + +and by the law of total variance the marginal variance equals +$\mathbb{E}_{(\Lambda,F)}[V_t] + \mathrm{Var}_{(\Lambda,F)}[b_t]$. +Re-randomizing $D$ across reps adds a $\mathrm{Var}_D[b_t]$ term to the +marginal target the simulation measures coverage against. Because the +bootstrap calibrates against $V_t$ alone, simulations with random $D$ +under-cover by exactly that amount and the under-coverage is not a +property of the bootstrap procedure. See gsynth-note section 2 for the +full derivation; this design choice mirrors gsynth-note's own MC +framework (footnote on Table 1, and section A.2). + +## .Rbuildignore + +This directory is excluded from the CRAN tarball via `.Rbuildignore`: + +``` +^tests/coverage-study$ +``` + +Files here are tracked in git but are not part of the package +distribution. diff --git a/tests/coverage-study/_archive/run_mc_warm_start.R b/tests/coverage-study/_archive/run_mc_warm_start.R new file mode 100644 index 00000000..ab142445 --- /dev/null +++ b/tests/coverage-study/_archive/run_mc_warm_start.R @@ -0,0 +1,63 @@ +## ============================================================================ +## MC partial warm-start validation (v2.4.3) +## +## Per Yiqing's request 2026-05-02: "If MC fails, you can also try partial +## warm-start with MC." +## +## MC differs from IFE in two relevant ways: +## 1. Optimization is convex (nuclear-norm regularized) -- no basin +## identification issue at all. Warm-start should be variance-neutral +## in theory regardless of tol. +## 2. EM converges differently due to soft-thresholding step. +## +## Test: cold vs partial-warm bootstrap on simdata + MC. +## ============================================================================ + +suppressPackageStartupMessages({ library(devtools) }) +setwd("/Users/xyq/GitHub/fect-warmstart") +devtools::load_all(quiet = TRUE) + +cat("\n=== MC partial warm-start (n=100, tol=1e-5) ===\n") + +data(simdata) + +common <- list( + formula = Y ~ D + X1 + X2, data = simdata, index = c("id","time"), + method = "mc", lambda = 0.05, force = "two-way", + se = TRUE, vartype = "bootstrap", nboots = 100, + parallel = FALSE, keep.sims = TRUE, CV = FALSE, + tol = 1e-5, max.iteration = 5000 +) + +set.seed(42) +t0 <- Sys.time() +fit_cold <- tryCatch(do.call(fect, common), error = function(e) e) +ct <- as.numeric(difftime(Sys.time(), t0, units = "secs")) +if (inherits(fit_cold, "error")) { + cat("cold FAILED:", conditionMessage(fit_cold), "\n") + quit(save = "no", status = 1) +} +cat(sprintf("MC cold time: %.2fs att.avg: %.4f\n", ct, fit_cold$att.avg)) + +set.seed(42) +t0 <- Sys.time() +fit_warm <- tryCatch(do.call(fect, c(common, list(warm.start = "linear"))), + error = function(e) e) +wt <- as.numeric(difftime(Sys.time(), t0, units = "secs")) +if (inherits(fit_warm, "error")) { + cat("warm FAILED:", conditionMessage(fit_warm), "\n") + quit(save = "no", status = 1) +} +cat(sprintf("MC warm time: %.2fs att.avg: %.4f\n", wt, fit_warm$att.avg)) + +cat(sprintf("\nMC speedup: %.2fx %s\n", + ct/wt, if (ct/wt >= 2) "PASS" else "FAIL")) +cat(sprintf("MC att.avg diff: %.2e %s\n", + abs(fit_cold$att.avg - fit_warm$att.avg), + if (abs(fit_cold$att.avg - fit_warm$att.avg) < 1e-8) "PASS" else "FAIL")) +cat(sprintf("MC eff.boot diff: %.4e\n", + max(abs(fit_cold$eff.boot - fit_warm$eff.boot), na.rm=TRUE))) +se_diff <- max(abs(fit_cold$est.att[, "S.E."] - fit_warm$est.att[, "S.E."]) / + pmax(fit_cold$est.att[, "S.E."], 1e-10)) +cat(sprintf("MC rel S.E. diff: %.2f%% %s\n", + 100 * se_diff, if (se_diff < 0.05) "PASS" else "FAIL")) diff --git a/tests/coverage-study/_archive/run_partial_warm_start_validation.R b/tests/coverage-study/_archive/run_partial_warm_start_validation.R new file mode 100644 index 00000000..769d680a --- /dev/null +++ b/tests/coverage-study/_archive/run_partial_warm_start_validation.R @@ -0,0 +1,270 @@ +## ============================================================================ +## Phase B / Phase B-CFE: partial warm-start validation (v2.4.3) +## +## Implementation: warm.start = c("none", "linear") on fect(). +## "linear" enables partial warm-start in the bootstrap loop: +## - per-replicate fits seed the EM with the auxiliary-only prediction +## surface from the cached main fit (Y.ct - factor %*% t(lambda)); +## - factor pair (F, Lambda) cold-starts via fresh per-replicate SVD +## on the auxiliary-corrected residual. +## +## Phase A (full warm-start, anchoring F, Lambda from main fit) FAILED +## empirical variance-neutrality (cold-vs-warm SE diverged 45-250% +## relative). Partial warm-start preserves the basin re-randomization +## (because Y_b varies per replicate) while still warming all the +## auxiliaries that are deterministic functions of (F, Lambda) given Y. +## +## Pass criteria (per design): +## - point estimate (att.avg, est.att[, "ATT"]) byte-identical +## - max relative S.E. diff < 5% +## - speedup (cold_time / warm_time) >= 2x +## +## RUN WHEN: validating partial warm-start. ~30 min total wall time. +## ============================================================================ + +suppressPackageStartupMessages({ library(devtools) }) +setwd("/Users/xyq/GitHub/fect-warmstart") +devtools::load_all(quiet = TRUE) + +OUT_DIR <- "/tmp/fect-partial-warm" +dir.create(OUT_DIR, recursive = TRUE, showWarnings = FALSE) + +## ------------------------------------------------------------ Utilities -- + +compare_fits <- function(fit_cold, fit_warm, cold_time, warm_time, label) { + diff_att_avg <- abs(fit_cold$att.avg - fit_warm$att.avg) + diff_est_att <- max(abs(fit_cold$est.att[, "ATT"] - + fit_warm$est.att[, "ATT"])) + diff_eff_boot <- if (!is.null(fit_cold$eff.boot) && + !is.null(fit_warm$eff.boot)) + max(abs(fit_cold$eff.boot - fit_warm$eff.boot), na.rm = TRUE) else NA_real_ + se_cold <- fit_cold$est.att[, "S.E."] + se_warm <- fit_warm$est.att[, "S.E."] + se_rel_diff <- max(abs(se_cold - se_warm) / pmax(se_cold, 1e-10)) + speedup <- cold_time / warm_time + + pass_pt <- diff_att_avg < 1e-8 && diff_est_att < 1e-8 + pass_se <- se_rel_diff < 0.05 + pass_speed <- speedup >= 2 + + res <- list( + label = label, + diff_att_avg = diff_att_avg, + diff_est_att = diff_est_att, + diff_eff_boot = diff_eff_boot, + se_rel_diff = se_rel_diff, + speedup = speedup, + cold_time = cold_time, + warm_time = warm_time, + pass_pt = pass_pt, + pass_se = pass_se, + pass_speed = pass_speed, + pass_overall = pass_pt && pass_se && pass_speed + ) + + cat(sprintf("\n[%s]\n", label)) + cat(sprintf(" cold time: %.2fs warm time: %.2fs speedup: %.2fx %s\n", + cold_time, warm_time, speedup, + if (pass_speed) "PASS" else "FAIL")) + cat(sprintf(" diff att.avg: %.2e %s\n", + diff_att_avg, if (pass_pt) "PASS" else "FAIL")) + cat(sprintf(" diff est.att: %.2e\n", diff_est_att)) + cat(sprintf(" diff eff.boot: %.4e\n", diff_eff_boot)) + cat(sprintf(" rel S.E. diff: %.2f%% %s\n", + 100 * se_rel_diff, if (pass_se) "PASS" else "FAIL")) + cat(sprintf(" OVERALL: %s\n", + if (res$pass_overall) "PASS" else "FAIL")) + res +} + +## ------------------------------------------------------------ Phase B (IFE) -- + +run_phase_b_ife <- function(n_reps = 30, seed = 42) { + cat("\n========== Phase B: IFE r=2 on simdata, n=", n_reps, " ==========\n", + sep = "") + data(simdata) + + ## Use tol = 1e-5 for both cold and warm so the bootstrap distributions + ## estimate the same target (full convergence). At fect's default + ## tol = 1e-3 the EM stops basin-dependent and warm-vs-cold are + ## different estimators (see Phase B finding 2026-05-02). + common_args <- list( + formula = Y ~ D + X1 + X2, data = simdata, index = c("id","time"), + method = "ife", r = 2, force = "two-way", + se = TRUE, vartype = "bootstrap", nboots = n_reps, + parallel = FALSE, keep.sims = TRUE, CV = FALSE, + tol = 1e-5, max.iteration = 5000 + ) + + set.seed(seed) + t0 <- Sys.time() + fit_cold <- do.call(fect, common_args) + cold_time <- as.numeric(difftime(Sys.time(), t0, units = "secs")) + + set.seed(seed) + t0 <- Sys.time() + fit_warm <- do.call(fect, c(common_args, list(warm.start = "linear"))) + warm_time <- as.numeric(difftime(Sys.time(), t0, units = "secs")) + + compare_fits(fit_cold, fit_warm, cold_time, warm_time, + label = "Phase B IFE simdata r=2") +} + +## ------------------------------------------------------------ Phase B-CFE -- + +run_phase_b_cfe <- function(dgp_name, n_reps = 30, seed = 42) { + cat("\n========== Phase B-CFE: ", dgp_name, ", n=", n_reps, " ==========\n", + sep = "") + + dgp_specs <- list( + sim_region = list( + data_name = "sim_region", + formula = Y ~ D, + sfe = "region", + cfe = NULL, + Q = NULL, + r = 0, + note = "Multi-level FE (region); no factors" + ), + sim_trend = list( + data_name = "sim_trend", + formula = Y ~ D, + sfe = NULL, + cfe = list(c("id","year")), + Q = NULL, + r = 0, + note = "Q-heavy stand-in: cfe=list(c(id,year)) demonstrates kappa path" + ), + sim_linear = list( + data_name = "sim_linear", + formula = Y ~ D, + sfe = NULL, + cfe = list(c("id", "year")), + Q = NULL, + r = 0, + note = "Q-light stand-in: linear-trend approximated via cfe" + ), + simdata = list( + data_name = "simdata", + formula = Y ~ D + X1 + X2, + sfe = NULL, + cfe = NULL, + Q = NULL, + r = 2, + note = "Factor-only DGP with covariates" + ), + sim_gsynth = list( + data_name = "sim_gsynth", + formula = Y ~ D + X1 + X2, + sfe = NULL, + cfe = NULL, + Q = NULL, + r = 2, + method_override = "gsynth", + note = "Gsynth path (fect_nevertreated)" + ) + ) + + spec <- dgp_specs[[dgp_name]] + if (is.null(spec)) stop("Unknown DGP: ", dgp_name) + cat(" spec: ", spec$note, "\n", sep = "") + + e <- new.env() + do.call(data, list(spec$data_name, package = "fect", envir = e)) + df <- get(spec$data_name, envir = e) + + method_use <- if (!is.null(spec$method_override)) spec$method_override else "cfe" + + fit_args <- list( + formula = spec$formula, + data = df, + index = c("id", "time"), + method = method_use, + force = "two-way", + sfe = spec$sfe, + cfe = spec$cfe, + Q = spec$Q, + r = spec$r, + se = TRUE, + vartype = "bootstrap", + nboots = n_reps, + parallel = FALSE, + keep.sims = TRUE, + CV = FALSE, + tol = 1e-5, + max.iteration = 5000 + ) + + cold_args <- c(fit_args, list(warm.start = "none")) + warm_args <- c(fit_args, list(warm.start = "linear")) + + set.seed(seed) + t0 <- Sys.time() + fit_cold <- tryCatch(do.call(fect, cold_args), error = function(e) e) + if (inherits(fit_cold, "error")) { + cat(" cold-start ERROR:", conditionMessage(fit_cold), "\n") + return(list(label = paste0("Phase B-CFE ", dgp_name), + error = conditionMessage(fit_cold), pass_overall = FALSE)) + } + cold_time <- as.numeric(difftime(Sys.time(), t0, units = "secs")) + + set.seed(seed) + t0 <- Sys.time() + fit_warm <- tryCatch(do.call(fect, warm_args), error = function(e) e) + if (inherits(fit_warm, "error")) { + cat(" warm-start ERROR:", conditionMessage(fit_warm), "\n") + return(list(label = paste0("Phase B-CFE ", dgp_name), + error = conditionMessage(fit_warm), pass_overall = FALSE)) + } + warm_time <- as.numeric(difftime(Sys.time(), t0, units = "secs")) + + compare_fits(fit_cold, fit_warm, cold_time, warm_time, + label = paste0("Phase B-CFE ", dgp_name)) +} + +## ------------------------------------------------------------ Driver -- + +run_all <- function(out_dir = OUT_DIR, n_reps = 30) { + ts <- format(Sys.time(), "%Y%m%d-%H%M%S") + cat("\n=== Partial warm-start validation (v2.4.3 candidate) ===\n") + cat("Started: ", as.character(Sys.time()), "\n") + cat("nboots per cell: ", n_reps, "\n") + + results <- list( + phase_b_ife = run_phase_b_ife(n_reps = n_reps), + phase_b_cfe_sim_region = run_phase_b_cfe("sim_region", n_reps = n_reps), + phase_b_cfe_sim_trend = run_phase_b_cfe("sim_trend", n_reps = n_reps), + phase_b_cfe_sim_linear = run_phase_b_cfe("sim_linear", n_reps = n_reps), + phase_b_cfe_simdata = run_phase_b_cfe("simdata", n_reps = n_reps), + phase_b_cfe_sim_gsynth = run_phase_b_cfe("sim_gsynth", n_reps = n_reps) + ) + + cat("\n========================================\n") + cat("Summary\n") + cat("========================================\n") + cat(sprintf("%-32s %-7s %-9s %-7s %-9s %-7s %-7s\n", + "label", "att.diff", "se.rel", "speed", "pass.pt", "pass.se", "pass.spd")) + for (r in results) { + if (!is.null(r$error)) { + cat(sprintf("%-32s ERROR: %s\n", r$label, r$error)) + } else { + cat(sprintf("%-32s %.2e %5.2f%% %4.2fx %5s %5s %5s\n", + r$label, r$diff_att_avg, 100 * r$se_rel_diff, + r$speedup, + if (r$pass_pt) "PASS" else "FAIL", + if (r$pass_se) "PASS" else "FAIL", + if (r$pass_speed) "PASS" else "FAIL")) + } + } + + out_file <- file.path(out_dir, sprintf("phase_b_results_%s.rds", ts)) + saveRDS(results, out_file) + cat("Saved: ", out_file, "\n", sep = "") + invisible(results) +} + +if (sys.nframe() == 0L) { + args <- commandArgs(trailingOnly = TRUE) + n_reps <- if (length(args) > 0) as.integer(args[[1]]) else 100 + run_all(n_reps = n_reps) +} diff --git a/tests/coverage-study/_archive/test-warm-start.R b/tests/coverage-study/_archive/test-warm-start.R new file mode 100644 index 00000000..95d8eb3d --- /dev/null +++ b/tests/coverage-study/_archive/test-warm-start.R @@ -0,0 +1,110 @@ +## Tests for v2.4.3 partial warm-start API. +## +## Design: warm.start = c("none", "linear"). "linear" enables partial warm-start +## in the bootstrap loop (auxiliaries warmed from main fit, factors cold-start). +## +## Acceptance criteria from ref/v242-warm-start-investigation/partial-warm-design.md: +## - point estimates byte-identical between cold and warm +## - SE diff < 5% relative when both at tol = 1e-5 +## - tol > 1e-5 + warm.start = "linear" rejected with informative error + +skip_if_not_installed("fect") +data(simdata, package = "fect") + +## ---- W1. Default is "none" (no behavior change for existing scripts) ---- +test_that("W1: warm.start default is 'none' (no regression for pre-2.4.3 scripts)", { + set.seed(1) + fit_default <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), + method = "ife", r = 2, force = "two-way", + se = FALSE, CV = FALSE) + set.seed(1) + fit_explicit <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), + method = "ife", r = 2, force = "two-way", + se = FALSE, CV = FALSE, + warm.start = "none") + expect_identical(fit_default$att.avg, fit_explicit$att.avg) + expect_identical(fit_default$est.att[, "ATT"], fit_explicit$est.att[, "ATT"]) +}) + +## ---- W2. Invalid value rejected ---- +test_that("W2: invalid warm.start value is rejected", { + expect_error( + fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), + method = "ife", r = 2, force = "two-way", + se = FALSE, CV = FALSE, + warm.start = "full"), + regexp = "must be one of" + ) + expect_error( + fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), + method = "ife", r = 2, force = "two-way", + se = FALSE, CV = FALSE, + warm.start = c("none","linear")), + regexp = "must be one of" + ) +}) + +## ---- W3. tol > 1e-5 + warm.start = "linear" rejected ---- +## Note: v2.4.3 default tol is now 1e-5, so we must explicitly pass a +## looser tol to trigger the validation. +test_that("W3: warm.start = 'linear' requires tol <= 1e-5", { + expect_error( + fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), + method = "ife", r = 2, force = "two-way", + se = TRUE, vartype = "bootstrap", nboots = 5, + parallel = FALSE, CV = FALSE, + tol = 1e-3, ## explicit loose tol + warm.start = "linear"), + regexp = "warm\\.start = 'linear' requires tol <= 1e-5" + ) +}) + +## ---- W4. warm.start = "linear" runs without error at tol = 1e-5 (IFE) ---- +test_that("W4: warm.start = 'linear' runs end-to-end on IFE at tol = 1e-5", { + skip_on_cran() + set.seed(1) + fit <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), + method = "ife", r = 2, force = "two-way", + se = TRUE, vartype = "bootstrap", nboots = 10, + parallel = FALSE, CV = FALSE, + tol = 1e-5, max.iteration = 5000, + warm.start = "linear") + expect_true(is.numeric(fit$att.avg)) + expect_true(is.finite(fit$att.avg)) + expect_true(all(c("ATT", "S.E.") %in% colnames(fit$est.att))) +}) + +## ---- W5. Point estimate byte-identical to cold (warm.start affects bootstrap only) ---- +test_that("W5: warm.start = 'linear' preserves point estimate", { + skip_on_cran() + set.seed(1) + fit_cold <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), + method = "ife", r = 2, force = "two-way", + se = TRUE, vartype = "bootstrap", nboots = 10, + parallel = FALSE, CV = FALSE, + tol = 1e-5, max.iteration = 5000) + set.seed(1) + fit_warm <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), + method = "ife", r = 2, force = "two-way", + se = TRUE, vartype = "bootstrap", nboots = 10, + parallel = FALSE, CV = FALSE, + tol = 1e-5, max.iteration = 5000, + warm.start = "linear") + expect_equal(fit_cold$att.avg, fit_warm$att.avg, tolerance = 1e-10) + expect_equal(fit_cold$est.att[, "ATT"], + fit_warm$est.att[, "ATT"], tolerance = 1e-10) +}) + +## ---- W6. CFE smoke test ---- +test_that("W6: warm.start = 'linear' runs on CFE method", { + skip_on_cran() + set.seed(1) + fit <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), + method = "cfe", r = 2, force = "two-way", + se = TRUE, vartype = "bootstrap", nboots = 10, + parallel = FALSE, CV = FALSE, + tol = 1e-5, max.iteration = 5000, + warm.start = "linear") + expect_true(is.numeric(fit$att.avg)) + expect_true(is.finite(fit$att.avg)) +}) diff --git a/tests/coverage-study/results/README.md b/tests/coverage-study/results/README.md new file mode 100644 index 00000000..3cd28ceb --- /dev/null +++ b/tests/coverage-study/results/README.md @@ -0,0 +1,35 @@ +# Canonical coverage results + +CSV summaries from `run_minimal_coverage.R` (and the conditional +`run_minimal_coverage_tail_rerun.R` follow-up). Saved here so `07-inference.Rmd` +in the Quarto book can read them directly without depending on `/tmp/`. + +## Files + +- `minimal_summary_K200_nb200.csv` --- 4 scenarios × {5 ci.methods for A/B/C1, 1 for C2} + at `K = 200`, `nboots = 200`. Run dated 2026-05-03 20:04, fect commit + `1ac0e0c` (state: pre-coverage-suite-commit; the run uses the same R/ source + as the final v2.4.2 surface). +- `minimal_tail_rerun_summary_K200_nb1000.csv` --- C1 (TWFE bootstrap) only, + re-run at `nboots = 1000` because basic / percentile / bc / bca tail-CI cells + came in below 0.93 at `nboots = 200`. Same MC seeds as the parent run. + +## DGP / inference settings (recap) + +| Scenario | DGP | Inference | +|---|---|---| +| A | factor `r=2`, IID errors. N_tr=5, N_co=50, T=30, T0=20, ATT_t = t for t = 1..10, D.sd=1, λ_i ~ U(-√3,√3), F_t ~ N(0,1), α_i ~ U(-√3,√3), ξ_t ~ N(0,1), μ=5; λ, F, α, ξ redrawn each rep | `vartype = "parametric"`, `para.error = "auto"` (-> empirical), all 5 ci.methods | +| B | same as A but errors AR(1) ρ = 0.8, marginal variance 1 | same as A; `auto` -> ar | +| C1 | additive TWFE r=0, AR(1) ρ = 0.5. N_tr=20, N_co=80, T=30, T0=20, ATT = 3 constant (D.sd=0); α, ξ redrawn each rep | `vartype = "bootstrap"` (cluster), all 5 ci.methods | +| C2 | same DGP as C1 | `vartype = "jackknife"`, `ci.method = "normal"` only (E&T 1993 §11) | + +Estimator for A/B: `method = "ife", r = 2, force = "two-way", +time.component.from = "nevertreated", CV = FALSE`. +Estimator for C: `method = "fe", force = "two-way", +time.component.from = "notyettreated"`. + +Coverage target for A/B: realized average treated-post effect within rep +(matches gsynth-note's `simulate-xu-{iid,ar1}-rfit2.R`). Coverage target +for C: population ATT = 3. + +K=200 reps → MC SE about 0.015 around coverage 0.95. diff --git a/tests/coverage-study/results/fect_ci_method_summary_K200_nb200.csv b/tests/coverage-study/results/fect_ci_method_summary_K200_nb200.csv new file mode 100644 index 00000000..9e6be3c8 --- /dev/null +++ b/tests/coverage-study/results/fect_ci_method_summary_K200_nb200.csv @@ -0,0 +1,7 @@ +"scenario","ci.method","n_reps","coverage","mc_se","mean_width","mean_se","empirical_sd","mean_bias","wall_min" +"A","normal",200,0.96,0.013856406460551,0.800426495584666,0.204194184663169,0.19424212580684,-0.00707620928441336,0.764 +"A","basic",200,0.96,0.013856406460551,0.780417274778892,0.204194184663169,0.19424212580684,-0.00707620928441336,0.764 +"B","normal",200,0.96,0.013856406460551,1.72446349940787,0.439922241686638,0.422376378723315,-0.0278956442702231,0.546 +"B","basic",200,0.95,0.0154110350074224,1.68982265142932,0.439922241686638,0.422376378723315,-0.0278956442702231,0.546 +"C_boot","normal",200,0.945,0.0161206389451535,0.58313298529223,0.148761148136371,0.146706505630583,-0.0131364178159844,1.03 +"C_boot","basic",200,0.935,0.0174320107847603,0.570541841429095,0.148761148136371,0.146706505630583,-0.0131364178159844,1.03 diff --git a/tests/coverage-study/results/minimal_summary_K200_nb200.csv b/tests/coverage-study/results/minimal_summary_K200_nb200.csv new file mode 100644 index 00000000..caba3f05 --- /dev/null +++ b/tests/coverage-study/results/minimal_summary_K200_nb200.csv @@ -0,0 +1,17 @@ +"scenario","ci.method","n_reps","coverage","mc_se","mean_width","mean_se","empirical_sd","mean_bias","wall_min" +"A","basic",200,0.96,0.013856406460551,0.780417274778892,0.204194184663169,0.194242125806841,-0.00707620928441327,0.286 +"A","bc",200,0.935,0.0174320107847603,0.785755658158738,0.204194184663169,0.194242125806841,-0.00707620928441327,0.286 +"A","bca",200,0.94,0.0167928556237467,0.785826878105271,0.204194184663169,0.194242125806841,-0.00707620928441327,0.286 +"A","normal",200,0.96,0.013856406460551,0.800426495584666,0.204194184663169,0.194242125806841,-0.00707620928441327,0.286 +"A","percentile",200,0.935,0.0174320107847603,0.780417274778892,0.204194184663169,0.194242125806841,-0.00707620928441327,0.286 +"B","basic",200,0.95,0.0154110350074224,1.68982265142932,0.439922241686638,0.422376378723315,-0.027895644270223,0.267 +"B","bc",200,0.96,0.013856406460551,1.6935919555145,0.439922241686638,0.422376378723315,-0.027895644270223,0.267 +"B","bca",200,0.96,0.013856406460551,1.69423307495378,0.439922241686638,0.422376378723315,-0.027895644270223,0.267 +"B","normal",200,0.96,0.013856406460551,1.72446349940787,0.439922241686638,0.422376378723315,-0.027895644270223,0.267 +"B","percentile",200,0.96,0.013856406460551,1.68982265142932,0.439922241686638,0.422376378723315,-0.027895644270223,0.267 +"C_boot","basic",200,0.935,0.0174320107847603,0.570541841429094,0.148761148136371,0.146706505630583,-0.0131364178159844,0.521 +"C_boot","bc",200,0.92,0.0191833260932509,0.567552591012353,0.148761148136371,0.146706505630583,-0.0131364178159844,0.521 +"C_boot","bca",200,0.92,0.0191833260932509,0.567557751791989,0.148761148136371,0.146706505630583,-0.0131364178159844,0.521 +"C_boot","normal",200,0.945,0.0161206389451535,0.58313298529223,0.148761148136371,0.146706505630583,-0.0131364178159844,0.521 +"C_boot","percentile",200,0.925,0.0186245805321892,0.570541841429094,0.148761148136371,0.146706505630583,-0.0131364178159844,0.521 +"C_jack","normal",200,0.93,0.0180416185526687,0.605036095438006,0.15434877890881,0.146737776848365,-0.00262210722241972,0.251 diff --git a/tests/coverage-study/results/minimal_tail_rerun_summary_K200_nb1000.csv b/tests/coverage-study/results/minimal_tail_rerun_summary_K200_nb1000.csv new file mode 100644 index 00000000..c3ced6b9 --- /dev/null +++ b/tests/coverage-study/results/minimal_tail_rerun_summary_K200_nb1000.csv @@ -0,0 +1,6 @@ +"scenario","ci.method","n_reps","coverage","mc_se","mean_width","mean_se","empirical_sd","mean_bias","wall_min" +"C_boot","basic",200,0.945,0.0161206389451535,0.580158658884404,0.148630407020037,0.146706505630583,-0.0131364178159844,2.662 +"C_boot","bc",200,0.94,0.0167928556237467,0.580113552571375,0.148630407020037,0.146706505630583,-0.0131364178159844,2.662 +"C_boot","bca",200,0.94,0.0167928556237467,0.580028997420987,0.148630407020037,0.146706505630583,-0.0131364178159844,2.662 +"C_boot","normal",200,0.94,0.0167928556237467,0.582620489533604,0.148630407020037,0.146706505630583,-0.0131364178159844,2.662 +"C_boot","percentile",200,0.945,0.0161206389451535,0.580158658884404,0.148630407020037,0.146706505630583,-0.0131364178159844,2.662 diff --git a/tests/coverage-study/run_cfe_high_K.R b/tests/coverage-study/run_cfe_high_K.R new file mode 100644 index 00000000..502032d4 --- /dev/null +++ b/tests/coverage-study/run_cfe_high_K.R @@ -0,0 +1,49 @@ +## CFE coverage at K=200 to resolve whether 0.917 was real bias or MC noise. +## If true coverage ~ 0.95, K=200 will give SE-of-coverage ~ 0.015 ≈ 1.5pp. + +suppressPackageStartupMessages({ library(fect) }) +make_factor_data <- function(N = 200, T = 35, Ntr = 100, tau = 3.0, r = 2, + T_treat_start = 18, sigma = 1.0, seed = 1) { + set.seed(seed) + F_mat <- matrix(rnorm(T * r), T, r) + L_mat <- matrix(rnorm(N * r), N, r) + Y_factor <- F_mat %*% t(L_mat) + Y_noise <- matrix(rnorm(T * N, sd = sigma), T, N) + D_mat <- matrix(0, T, N) + D_mat[T_treat_start:T, 1:Ntr] <- 1 + Y_mat <- Y_factor + Y_noise + tau * D_mat + data.frame(id = rep(1:N, each = T), time = rep(1:T, N), + Y = as.vector(Y_mat), D = as.vector(D_mat)) +} + +K <- 200 +cat(sprintf("=== CFE coverage K=%d at new defaults (tol=1e-5) ===\n", K)) +cover <- numeric(K); att <- numeric(K); se <- numeric(K) +t0 <- Sys.time() +for (k in 1:K) { + s <- 5000 + k + df <- make_factor_data(seed = s) + fit <- fect(Y ~ D, data = df, index = c("id","time"), + method = "cfe", r = 2, force = "two-way", + se = TRUE, vartype = "bootstrap", nboots = 100, + parallel = FALSE, CV = FALSE, seed = s) + att[k] <- fit$est.avg[1, "ATT.avg"] + se[k] <- fit$est.avg[1, "S.E."] + cover[k] <- (fit$est.avg[1, "CI.lower"] < 3) && (fit$est.avg[1, "CI.upper"] > 3) + if (k %% 50 == 0) { + cat(sprintf(" k=%d: cumulative coverage = %.4f bias = %+.4f elapsed=%.0fs\n", + k, mean(cover[1:k]), mean(att[1:k] - 3.0), + as.numeric(difftime(Sys.time(), t0, units = "secs")))) + } +} +cat(sprintf("\nFinal: coverage = %.4f bias = %+.4f emp.SE = %.4f boot.SE = %.4f\n", + mean(cover), mean(att - 3.0), sd(att), mean(se))) +cat(sprintf("Coverage 95%% CI (Wilson): [%.4f, %.4f]\n", + (function(p, n) { + z <- 1.96; den <- 1 + z^2/n + ctr <- (p + z^2/(2*n)) / den + hw <- z * sqrt(p*(1-p)/n + z^2/(4*n^2)) / den + c(ctr - hw, ctr + hw) + })(mean(cover), K))) +saveRDS(list(cover = cover, att = att, se = se), + "/tmp/fect-tol-char/cfe_high_K_K200.rds") diff --git a/tests/coverage-study/run_fect_ci_method_coverage.R b/tests/coverage-study/run_fect_ci_method_coverage.R new file mode 100644 index 00000000..22406711 --- /dev/null +++ b/tests/coverage-study/run_fect_ci_method_coverage.R @@ -0,0 +1,311 @@ +## ============================================================================ +## Coverage study for fect()'s built-in ci.method = c("normal", "basic") +## machinery, exercised through fit$est.avg directly (NOT via estimand()). +## +## Same DGPs as run_minimal_coverage.R Scenarios A, B, C; same outer-loop +## parallel design (future workers = 16, K = 200). For each scenario we fit +## fect() twice --- once with ci.method = "normal" and once with +## ci.method = "basic" --- and read the CI from fit$est.avg. Coverage = +## fraction of K reps whose CI contains the realized treatment effect (A/B) +## or the population ATT = 3 (C). +## +## Why a separate file: this validates the v2.4.2 ci.method addition on +## fect()'s built-in CI machinery (the path that est.* slots use). The +## existing run_minimal_coverage.R validates estimand()'s post-hoc CI +## machinery on the same fits. The two surfaces should agree byte-equally +## on the (normal, basic) overlap; this script is the fect-side proof. +## ============================================================================ + +suppressPackageStartupMessages({ + library(devtools) + library(future) + library(future.apply) +}) + +.script_path <- function() { + args <- commandArgs(trailingOnly = FALSE) + file_arg <- grep("^--file=", args, value = TRUE) + if (length(file_arg) > 0L) { + return(normalizePath(sub("^--file=", "", file_arg[1]))) + } + of <- tryCatch(sys.frame(1)$ofile, error = function(e) NULL) + if (!is.null(of)) return(normalizePath(of)) + NA_character_ +} +.this <- .script_path() +.this_dir <- if (!is.na(.this)) dirname(.this) else getwd() +pkg_root <- normalizePath(file.path(.this_dir, "..", "..")) +if (!file.exists(file.path(pkg_root, "DESCRIPTION"))) { + stop("Could not locate fect repo root (got '", pkg_root, "').", call. = FALSE) +} +setwd(pkg_root) +cat("Loading fect from:", pkg_root, "\n") +suppressMessages(devtools::load_all(pkg_root, quiet = TRUE)) + +## DGP helpers (inlined; identical to run_minimal_coverage.R copies so future +## workers don't need to source that file). Conventions match +## gsynth-note's simulate-xu-{iid,ar1}-rfit2.R: lambda_i ~ U(-sqrt(3), sqrt(3)), +## f_t ~ N(0,1), alpha_i ~ U(-sqrt(3), sqrt(3)), xi_t ~ N(0,1), mu = 5; +## treated cells get ATT_t = t plus N(0, D_sd) heterogeneity. + +simulate_factor <- function(seed, N_tr, N_co, TT, T0, r = 2, D_sd = 1, mu = 5, + ar_rho = 0.0) { + set.seed(seed) + N <- N_tr + N_co + T_post <- TT - T0 + ss <- sqrt(3) + + lambda <- matrix(runif(N * r, -ss, ss), N, r) + f_mat <- matrix(rnorm(TT * r), TT, r) + alpha <- runif(N, -ss, ss) + xi <- rnorm(TT) + + if (ar_rho == 0) { + e <- matrix(rnorm(TT * N), TT, N) + } else { + e <- matrix(NA_real_, TT, N) + e[1, ] <- rnorm(N) + shock_sd <- sqrt(1 - ar_rho^2) + for (t in 2:TT) e[t, ] <- ar_rho * e[t - 1, ] + rnorm(N, 0, shock_sd) + } + + D <- matrix(0L, TT, N); D[(T0 + 1):TT, 1:N_tr] <- 1L + eff <- matrix(0, TT, N) + if (D_sd > 0) { + eff[(T0 + 1):TT, ] <- matrix(seq_len(T_post), T_post, N) + + matrix(rnorm(T_post * N, 0, D_sd), T_post, N) + } else { + eff[(T0 + 1):TT, ] <- matrix(seq_len(T_post), T_post, N) + } + + Y0 <- e + mu + f_mat %*% t(lambda) + + matrix(alpha, TT, N, byrow = TRUE) + + matrix(xi, TT, N, byrow = FALSE) + Y <- Y0 + eff * D + target_att <- mean(eff[(T0 + 1):TT, 1:N_tr]) + panel <- data.frame( + id = rep(seq_len(N), each = TT), + time = rep(seq_len(TT), times = N), + Y = c(Y), D = c(D) + ) + list(panel = panel, target_att = target_att) +} + +simulate_twfe <- function(seed, N_tr, N_co, TT, T0, ar_rho, ATT = 3, mu = 5) { + set.seed(seed) + N <- N_tr + N_co + ss <- sqrt(3) + alpha <- runif(N, -ss, ss) + xi <- rnorm(TT) + e <- matrix(NA_real_, TT, N) + e[1, ] <- rnorm(N) + shock_sd <- sqrt(1 - ar_rho^2) + for (t in 2:TT) e[t, ] <- ar_rho * e[t - 1, ] + rnorm(N, 0, shock_sd) + D <- matrix(0L, TT, N); D[(T0 + 1):TT, 1:N_tr] <- 1L + Y <- e + mu + matrix(alpha, TT, N, byrow = TRUE) + + matrix(xi, TT, N, byrow = FALSE) + + ATT * D + panel <- data.frame( + id = rep(seq_len(N), each = TT), + time = rep(seq_len(TT), times = N), + Y = c(Y), D = c(D) + ) + list(panel = panel, target_att = ATT) +} + +## Per-rep worker: fit fect, extract est.avg row at the requested ci.method +run_one_rep_fect_direct <- function(seed, scenario, ci.method, nboots, pkg_root) { + ## NOTE: future workers spawn with an installed (CRAN/dev) fect already + ## resolvable via namespace shipping, so loadedNamespaces() returns + ## TRUE even on a fresh worker -- but the resolved fect lacks the + ## v2.4.2 ci.method argument. Force load_all unconditionally on every + ## call (cheap on warm workers; correct on cold ones). + if (!isTRUE(getOption(".fect_ci_method_loaded"))) { + suppressMessages(devtools::load_all(pkg_root, quiet = TRUE)) + options(.fect_ci_method_loaded = TRUE) + } + t0 <- Sys.time() + + if (scenario == "A") { + dgp <- simulate_factor(seed, N_tr = 5, N_co = 50, TT = 30, T0 = 20, + r = 2, ar_rho = 0) + fit <- tryCatch( + suppressMessages(suppressWarnings( + fect(Y ~ D, data = dgp$panel, index = c("id", "time"), + method = "ife", r = 2, force = "two-way", CV = FALSE, + se = TRUE, vartype = "parametric", para.error = "auto", + ci.method = ci.method, + nboots = nboots, parallel = FALSE, + time.component.from = "nevertreated") + )), + error = function(e) NULL + ) + } else if (scenario == "B") { + dgp <- simulate_factor(seed, N_tr = 5, N_co = 50, TT = 30, T0 = 20, + r = 2, ar_rho = 0.8) + fit <- tryCatch( + suppressMessages(suppressWarnings( + fect(Y ~ D, data = dgp$panel, index = c("id", "time"), + method = "ife", r = 2, force = "two-way", CV = FALSE, + se = TRUE, vartype = "parametric", para.error = "auto", + ci.method = ci.method, + nboots = nboots, parallel = FALSE, + time.component.from = "nevertreated") + )), + error = function(e) NULL + ) + } else if (scenario == "C_boot") { + dgp <- simulate_twfe(seed, N_tr = 20, N_co = 80, TT = 30, T0 = 20, + ar_rho = 0.5) + fit <- tryCatch( + suppressMessages(suppressWarnings( + fect(Y ~ D, data = dgp$panel, index = c("id", "time"), + method = "fe", force = "two-way", CV = FALSE, + se = TRUE, vartype = "bootstrap", + ci.method = ci.method, + nboots = nboots, parallel = FALSE, + time.component.from = "notyettreated") + )), + error = function(e) NULL + ) + } else { + stop("Unknown scenario: ", scenario) + } + + fit_wall <- as.numeric(Sys.time() - t0, units = "secs") + + if (is.null(fit) || is.null(fit$est.avg)) { + return(data.frame(seed = seed, scenario = scenario, + ci.method = ci.method, + att_hat = NA_real_, se = NA_real_, + ci_lo = NA_real_, ci_hi = NA_real_, + target_att = dgp$target_att, + cover = NA_integer_, width = NA_real_, + wall_sec = fit_wall, stringsAsFactors = FALSE)) + } + row <- fit$est.avg[1, , drop = TRUE] + att_hat <- unname(row["ATT.avg"]) + ci_lo <- unname(row["CI.lower"]) + ci_hi <- unname(row["CI.upper"]) + se <- unname(row["S.E."]) + cover <- as.integer(ci_lo <= dgp$target_att && dgp$target_att <= ci_hi) + data.frame( + seed = seed, + scenario = scenario, + ci.method = ci.method, + att_hat = att_hat, + se = se, + ci_lo = ci_lo, + ci_hi = ci_hi, + target_att = dgp$target_att, + cover = cover, + width = ci_hi - ci_lo, + wall_sec = fit_wall, + stringsAsFactors = FALSE + ) +} + +run_scenario_fect <- function(scenario, label, K, nboots, workers, base_seed, + ci_methods = c("normal", "basic")) { + rows <- list() + cat(sprintf("\n=== %s ===\n", label)) + cat(sprintf("K=%d reps, nboots=%d, workers=%d (outer parallel), ci.methods=%s\n", + K, nboots, workers, paste(ci_methods, collapse = ","))) + seeds <- base_seed + seq_len(K) + t0 <- Sys.time() + for (m in ci_methods) { + results <- future.apply::future_lapply( + seeds, + run_one_rep_fect_direct, + scenario = scenario, ci.method = m, + nboots = nboots, pkg_root = pkg_root, + future.seed = TRUE + ) + rows[[m]] <- do.call(rbind, results) + } + df <- do.call(rbind, rows) + elapsed <- as.numeric(Sys.time() - t0, units = "mins") + + summary_df <- do.call(rbind, lapply(ci_methods, function(m) { + d <- df[df$ci.method == m, ] + ok <- !is.na(d$cover) + n <- sum(ok) + if (n == 0L) return(NULL) + cov <- mean(d$cover[ok]) + data.frame( + scenario = scenario, + ci.method = m, + n_reps = n, + coverage = cov, + mc_se = sqrt(cov * (1 - cov) / n), + mean_width = mean(d$width[ok]), + mean_se = mean(d$se[ok]), + empirical_sd = sd(d$att_hat[ok] - d$target_att[ok]), + mean_bias = mean(d$att_hat[ok] - d$target_att[ok]), + wall_min = round(elapsed, 3), + stringsAsFactors = FALSE + ) + })) + cat(sprintf(" wall: %.2f min\n", elapsed)) + print(summary_df[ , c("ci.method", "n_reps", "coverage", "mc_se", + "mean_width", "mean_se", "empirical_sd", + "mean_bias")], + row.names = FALSE, digits = 4) + + list(scenario = scenario, label = label, df = df, + summary = summary_df, wall_min = elapsed) +} + +run_all_fect <- function(K = 200, nboots = 200, workers = 16, + out_dir = "/tmp/fect-coverage-study") { + dir.create(out_dir, recursive = TRUE, showWarnings = FALSE) + ts <- format(Sys.time(), "%Y%m%d-%H%M%S") + future::plan(future::multisession, workers = workers) + options(future.globals.maxSize = 2e9) + on.exit(future::plan(future::sequential), add = TRUE) + + ## ci.method in {"normal", "basic"} for all three scenarios. The + ## v2.4.2 location-shift fix in R/boot.R (around line 3590) makes + ## ci.method = "basic" work on parametric fits at the avg-level + per- + ## event-time CI sites, byte-equivalent to estimand(fit, "att", "basic"). + sA <- run_scenario_fect("A", "A: factor IID parametric (fect direct)", + K, nboots, workers, base_seed = 1000L, + ci_methods = c("normal", "basic")) + sB <- run_scenario_fect("B", "B: factor AR(1) rho=0.8 parametric (fect direct)", + K, nboots, workers, base_seed = 2000L, + ci_methods = c("normal", "basic")) + sC1 <- run_scenario_fect("C_boot", "C1: TWFE AR(1) rho=0.5 bootstrap (fect direct)", + K, nboots, workers, base_seed = 3000L, + ci_methods = c("normal", "basic")) + + all <- list(A = sA, B = sB, C_boot = sC1) + for (nm in names(all)) { + csv <- file.path(out_dir, + sprintf("fect_ci_method_%s_K%d_nb%d_%s.csv", + nm, K, nboots, ts)) + write.csv(all[[nm]]$df, csv, row.names = FALSE) + cat(sprintf(" wrote %s\n", csv)) + } + summary_df <- do.call(rbind, lapply(all, `[[`, "summary")) + sum_csv <- file.path(out_dir, + sprintf("fect_ci_method_summary_K%d_nb%d_%s.csv", + K, nboots, ts)) + write.csv(summary_df, sum_csv, row.names = FALSE) + + cat("\n", strrep("=", 78), "\n", sep = "") + cat("FECT CI.METHOD COVERAGE SUMMARY (K=", K, ", nboots=", nboots, ")\n", + sep = "") + cat(strrep("=", 78), "\n", sep = "") + print(summary_df[, c("scenario", "ci.method", "coverage", "mc_se", + "mean_width", "mean_se", "empirical_sd")], + row.names = FALSE, digits = 4) + cat(sprintf("\nSummary CSV: %s\n", sum_csv)) + cat(strrep("=", 78), "\n", sep = "") + + invisible(list(scenarios = all, summary = summary_df, + summary_csv = sum_csv)) +} + +if (sys.nframe() == 0L || identical(environmentName(parent.frame()), "R_GlobalEnv")) { + run_all_fect(K = 200, nboots = 200, workers = 16) +} diff --git a/tests/coverage-study/run_minimal_coverage.R b/tests/coverage-study/run_minimal_coverage.R new file mode 100644 index 00000000..9780c924 --- /dev/null +++ b/tests/coverage-study/run_minimal_coverage.R @@ -0,0 +1,408 @@ +## ============================================================================ +## Minimal coverage validation for the v2.4.2 inference paths. +## +## Three scenarios, no covariates throughout: +## +## A. Factor model (r=2), IID errors, parametric inference +## B. Factor model (r=2), AR(1) rho=0.8 errors, parametric inference +## C. Large-N additive TWFE (r=0), AR(1) rho=0.5 errors, +## bootstrap (cluster) AND jackknife inference (two cells, same DGP) +## +## DGPs A and B replicate gsynth-note's canonical Xu-2017 setup +## (code/sims/coverage/simulate-xu-{iid,ar1}-rfit2.R). DGP C scales N +## up to test the cluster-bootstrap and jackknife paths under serial +## correlation that fect's empirical-residual draw can capture. +## +## Parallelization: outer-loop (across reps) via future + future.apply. +## Each fect() call runs sequentially (parallel = FALSE) inside a worker. +## Worker pool = 16; reps are embarrassingly parallel so this beats +## inner bootstrap parallelism (no per-rep cluster fork/join overhead). +## +## Wall time: ~5-8 min on 16 cores. Output: +## /tmp/fect-coverage-study/minimal__K_nb_.csv +## ============================================================================ + +suppressPackageStartupMessages({ + library(devtools) + library(future) + library(future.apply) +}) + +## resolve repo root robustly (Rscript: --file=; source(): ofile) +.script_path <- function() { + args <- commandArgs(trailingOnly = FALSE) + file_arg <- grep("^--file=", args, value = TRUE) + if (length(file_arg) > 0L) { + return(normalizePath(sub("^--file=", "", file_arg[1]))) + } + of <- tryCatch(sys.frame(1)$ofile, error = function(e) NULL) + if (!is.null(of)) return(normalizePath(of)) + NA_character_ +} +.this_file <- .script_path() +script_dir <- if (!is.na(.this_file)) dirname(.this_file) else getwd() +pkg_root <- normalizePath(file.path(script_dir, "..", "..")) +if (!file.exists(file.path(pkg_root, "DESCRIPTION"))) { + stop("Could not locate fect repo root (got '", pkg_root, + "'); expected DESCRIPTION there. Run from repo root or pass ", + "--file=.", call. = FALSE) +} +setwd(pkg_root) +cat("Loading fect from:", pkg_root, "\n") +suppressMessages(devtools::load_all(pkg_root, quiet = TRUE)) + +## ---- DGP helpers (identical structure across scenarios) ------------------- +## +## Conventions match gsynth-note simulate-xu-*.R: +## loadings lambda_i ~ U(-sqrt(3), sqrt(3)) variance 1 +## factors f_t ~ N(0, 1) +## unit FE alpha_i ~ U(-sqrt(3), sqrt(3)) variance 1 +## time FE xi_t ~ N(0, 1) +## grand mean mu = 5 +## Treatment block fixed at units 1:N_tr, periods (T0+1):TT +## ATT_t = t for t in 1:T_post, plus N(0, D_sd) per (unit, time) in treated post +## Coverage target = realized average treated-post effect (within rep). + +simulate_factor <- function(seed, N_tr, N_co, TT, T0, r = 2, D_sd = 1, mu = 5, + ar_rho = 0.0) { + set.seed(seed) + N <- N_tr + N_co + T_post <- TT - T0 + ss <- sqrt(3) + + lambda <- matrix(runif(N * r, -ss, ss), N, r) + f_mat <- matrix(rnorm(TT * r), TT, r) + alpha <- runif(N, -ss, ss) + xi <- rnorm(TT) + + if (ar_rho == 0) { + e <- matrix(rnorm(TT * N), TT, N) + } else { + e <- matrix(NA_real_, TT, N) + e[1, ] <- rnorm(N) + shock_sd <- sqrt(1 - ar_rho^2) + for (t in 2:TT) e[t, ] <- ar_rho * e[t - 1, ] + rnorm(N, 0, shock_sd) + } + + D <- matrix(0L, TT, N); D[(T0 + 1):TT, 1:N_tr] <- 1L + + eff <- matrix(0, TT, N) + if (D_sd > 0) { + eff[(T0 + 1):TT, ] <- matrix(seq_len(T_post), T_post, N) + + matrix(rnorm(T_post * N, 0, D_sd), T_post, N) + } else { + eff[(T0 + 1):TT, ] <- matrix(seq_len(T_post), T_post, N) + } + + Y0 <- e + mu + f_mat %*% t(lambda) + + matrix(alpha, TT, N, byrow = TRUE) + + matrix(xi, TT, N, byrow = FALSE) + Y <- Y0 + eff * D + + target_att <- mean(eff[(T0 + 1):TT, 1:N_tr]) + + panel <- data.frame( + id = rep(seq_len(N), each = TT), + time = rep(seq_len(TT), times = N), + Y = c(Y), + D = c(D) + ) + list(panel = panel, target_att = target_att) +} + +## Additive TWFE (r=0), constant ATT. Used by Scenario C. +simulate_twfe <- function(seed, N_tr, N_co, TT, T0, ar_rho, ATT = 3, mu = 5) { + set.seed(seed) + N <- N_tr + N_co + ss <- sqrt(3) + + alpha <- runif(N, -ss, ss) + xi <- rnorm(TT) + + e <- matrix(NA_real_, TT, N) + e[1, ] <- rnorm(N) + shock_sd <- sqrt(1 - ar_rho^2) + for (t in 2:TT) e[t, ] <- ar_rho * e[t - 1, ] + rnorm(N, 0, shock_sd) + + D <- matrix(0L, TT, N); D[(T0 + 1):TT, 1:N_tr] <- 1L + Y <- e + mu + matrix(alpha, TT, N, byrow = TRUE) + + matrix(xi, TT, N, byrow = FALSE) + + ATT * D + + panel <- data.frame( + id = rep(seq_len(N), each = TT), + time = rep(seq_len(TT), times = N), + Y = c(Y), + D = c(D) + ) + list(panel = panel, target_att = ATT) +} + +## ---- Per-scenario fit + extract ATT/CI ------------------------------------ +## Each fit_* function returns the fect fit object (or NULL on error). +## All fect() calls run with parallel = FALSE (outer parallelism handles K). +## keep.sims = TRUE on parametric / bootstrap so estimand() can dispatch +## across all 5 ci.methods on the same fit (one fit per rep, not five). + +fit_parametric_ife <- function(panel, nboots) { + tryCatch( + suppressMessages(suppressWarnings( + fect(Y ~ D, data = panel, index = c("id", "time"), + method = "ife", r = 2, force = "two-way", + CV = FALSE, + se = TRUE, vartype = "parametric", para.error = "auto", + nboots = nboots, parallel = FALSE, + keep.sims = TRUE, + time.component.from = "nevertreated") + )), + error = function(e) NULL + ) +} + +fit_bootstrap_fe <- function(panel, nboots) { + tryCatch( + suppressMessages(suppressWarnings( + fect(Y ~ D, data = panel, index = c("id", "time"), + method = "fe", force = "two-way", + CV = FALSE, + se = TRUE, vartype = "bootstrap", + nboots = nboots, parallel = FALSE, + keep.sims = TRUE, + time.component.from = "notyettreated") + )), + error = function(e) NULL + ) +} + +fit_jackknife_fe <- function(panel) { + tryCatch( + suppressMessages(suppressWarnings( + fect(Y ~ D, data = panel, index = c("id", "time"), + method = "fe", force = "two-way", + CV = FALSE, + se = TRUE, vartype = "jackknife", + parallel = FALSE, + time.component.from = "notyettreated") + )), + error = function(e) NULL + ) +} + +## Pull (estimate, ci.lo, ci.hi, se) from a fit at a specific ci.method. +## Uses estimand(fit, "att", "overall") to dispatch by ci.method on +## parametric and bootstrap fits; reads fit$est.avg directly for jackknife +## (estimand path requires keep.sims = TRUE which jackknife does not yield). +extract_at <- function(fit, ci.method) { + null_row <- list(att_hat = NA_real_, se = NA_real_, + ci_lo = NA_real_, ci_hi = NA_real_, ok = FALSE) + if (is.null(fit)) return(null_row) + if (isTRUE(fit$vartype == "jackknife")) { + if (is.null(fit$est.avg)) return(null_row) + row <- fit$est.avg[1, , drop = TRUE] + return(list(att_hat = unname(row["ATT.avg"]), + se = unname(row["S.E."]), + ci_lo = unname(row["CI.lower"]), + ci_hi = unname(row["CI.upper"]), + ok = TRUE)) + } + est <- tryCatch( + suppressMessages(suppressWarnings( + estimand(fit, type = "att", by = "overall", + ci.method = ci.method) + )), + error = function(e) NULL + ) + if (is.null(est) || nrow(est) == 0L) return(null_row) + row <- est[1, , drop = TRUE] + list(att_hat = unname(row[["estimate"]]), + se = unname(row[["se"]]), + ci_lo = unname(row[["ci.lo"]]), + ci_hi = unname(row[["ci.hi"]]), + ok = TRUE) +} + +## ---- Worker function ------------------------------------------------------ +## Runs once per (seed, scenario). First call in each worker triggers +## load_all(); subsequent calls reuse the loaded namespace. +## Returns one row per (rep, ci.method). Jackknife scenario forces +## ci.methods = "normal" (only valid CI for jackknife per E&T 1993 Ch 11). + +CI_METHODS_FULL <- c("basic", "percentile", "bc", "bca", "normal") + +run_one_rep <- function(seed, scenario, nboots, pkg_root, + ci_methods = CI_METHODS_FULL) { + if (!"fect" %in% loadedNamespaces()) { + suppressMessages(devtools::load_all(pkg_root, quiet = TRUE)) + } + t0 <- Sys.time() + + if (scenario == "A") { + dgp <- simulate_factor(seed, N_tr = 5, N_co = 50, TT = 30, T0 = 20, + r = 2, ar_rho = 0) + fit <- fit_parametric_ife(dgp$panel, nboots) + cms <- ci_methods + } else if (scenario == "B") { + dgp <- simulate_factor(seed, N_tr = 5, N_co = 50, TT = 30, T0 = 20, + r = 2, ar_rho = 0.8) + fit <- fit_parametric_ife(dgp$panel, nboots) + cms <- ci_methods + } else if (scenario == "C_boot") { + dgp <- simulate_twfe(seed, N_tr = 20, N_co = 80, TT = 30, T0 = 20, + ar_rho = 0.5) + fit <- fit_bootstrap_fe(dgp$panel, nboots) + cms <- ci_methods + } else if (scenario == "C_jack") { + dgp <- simulate_twfe(seed, N_tr = 20, N_co = 80, TT = 30, T0 = 20, + ar_rho = 0.5) + fit <- fit_jackknife_fe(dgp$panel) + cms <- "normal" # only valid CI for jackknife (E&T 1993 §11) + } else { + stop("Unknown scenario: ", scenario) + } + + fit_wall <- as.numeric(Sys.time() - t0, units = "secs") + + rows <- lapply(cms, function(m) { + out <- extract_at(fit, m) + cover <- if (out$ok) { + as.integer(out$ci_lo <= dgp$target_att && + dgp$target_att <= out$ci_hi) + } else NA_integer_ + data.frame( + seed = seed, + scenario = scenario, + ci.method = m, + att_hat = out$att_hat, + se = out$se, + ci_lo = out$ci_lo, + ci_hi = out$ci_hi, + target_att = dgp$target_att, + cover = cover, + width = out$ci_hi - out$ci_lo, + wall_sec = fit_wall, + stringsAsFactors = FALSE + ) + }) + do.call(rbind, rows) +} + +## ---- Driver: parallelize outer loop across reps --------------------------- + +summarise_per_method <- function(df) { + parts <- split(df, df$ci.method) + out <- lapply(names(parts), function(m) { + d <- parts[[m]] + ok <- !is.na(d$cover) + n <- sum(ok) + if (n == 0L) return(NULL) + cov <- mean(d$cover[ok]) + mc_se <- sqrt(cov * (1 - cov) / n) + data.frame( + ci.method = m, + n_reps = n, + coverage = cov, + mc_se = mc_se, + mean_width = mean(d$width[ok]), + mean_se = mean(d$se[ok], na.rm = TRUE), + empirical_sd = sd(d$att_hat[ok] - d$target_att[ok]), + mean_bias = mean(d$att_hat[ok] - d$target_att[ok]), + stringsAsFactors = FALSE + ) + }) + do.call(rbind, out[!sapply(out, is.null)]) +} + +run_scenario <- function(scenario, label, K, nboots, workers, base_seed, + ci_methods = CI_METHODS_FULL) { + cat(sprintf("\n=== %s ===\n", label)) + cat(sprintf("K=%d reps, nboots=%d, workers=%d, ci.methods=%s\n", + K, nboots, workers, paste(ci_methods, collapse = ","))) + + seeds <- base_seed + seq_len(K) + t0 <- Sys.time() + + results <- future.apply::future_lapply( + seeds, + run_one_rep, + scenario = scenario, + nboots = nboots, + pkg_root = pkg_root, + ci_methods = ci_methods, + future.seed = TRUE + ) + df <- do.call(rbind, results) + elapsed <- as.numeric(Sys.time() - t0, units = "mins") + + summary_df <- summarise_per_method(df) + summary_df <- cbind(scenario = scenario, summary_df, + wall_min = round(elapsed, 3)) + + cat(sprintf(" wall: %.2f min\n", elapsed)) + print(summary_df[ , c("ci.method", "n_reps", "coverage", "mc_se", + "mean_width", "mean_se", "empirical_sd", + "mean_bias")], + row.names = FALSE, digits = 4) + + list(scenario = scenario, label = label, df = df, + summary = summary_df, wall_min = elapsed) +} + +run_all <- function(K = 200, nboots = 200, workers = 16, + ci_methods = CI_METHODS_FULL, + out_dir = "/tmp/fect-coverage-study") { + dir.create(out_dir, recursive = TRUE, showWarnings = FALSE) + ts <- format(Sys.time(), "%Y%m%d-%H%M%S") + + future::plan(future::multisession, workers = workers) + options(future.globals.maxSize = 2e9) + on.exit(future::plan(future::sequential), add = TRUE) + + sA <- run_scenario("A", "A: factor IID parametric", + K, nboots, workers, base_seed = 1000L, + ci_methods = ci_methods) + sB <- run_scenario("B", "B: factor AR(1) rho=0.8 parametric", + K, nboots, workers, base_seed = 2000L, + ci_methods = ci_methods) + sC1 <- run_scenario("C_boot", "C1: TWFE AR(1) rho=0.5 bootstrap", + K, nboots, workers, base_seed = 3000L, + ci_methods = ci_methods) + sC2 <- run_scenario("C_jack", "C2: TWFE AR(1) rho=0.5 jackknife", + K, nboots, workers, base_seed = 4000L, + ci_methods = "normal") + + all <- list(A = sA, B = sB, C_boot = sC1, C_jack = sC2) + for (nm in names(all)) { + csv <- file.path(out_dir, + sprintf("minimal_%s_K%d_nb%d_%s.csv", + nm, K, nboots, ts)) + write.csv(all[[nm]]$df, csv, row.names = FALSE) + cat(sprintf(" wrote %s\n", csv)) + } + + summary_df <- do.call(rbind, lapply(all, `[[`, "summary")) + sum_csv <- file.path(out_dir, + sprintf("minimal_summary_K%d_nb%d_%s.csv", + K, nboots, ts)) + write.csv(summary_df, sum_csv, row.names = FALSE) + + cat("\n", strrep("=", 78), "\n", sep = "") + cat("MINIMAL COVERAGE SUMMARY (K=", K, ", nboots=", nboots, ")\n", + sep = "") + cat(strrep("=", 78), "\n", sep = "") + print(summary_df[, c("scenario", "ci.method", "coverage", "mc_se", + "mean_width", "mean_se", "empirical_sd")], + row.names = FALSE, digits = 4) + cat(sprintf("\nSummary CSV: %s\n", sum_csv)) + cat(strrep("=", 78), "\n", sep = "") + + invisible(list(scenarios = all, summary = summary_df, + summary_csv = sum_csv)) +} + +## Run when invoked as a top-level Rscript (not when sourced for definitions +## by run_minimal_coverage_tail_rerun.R; that script sets the option below). +if (!isTRUE(getOption(".fect_minimal_no_autorun")) && + (sys.nframe() == 0L || + identical(environmentName(parent.frame()), "R_GlobalEnv"))) { + run_all(K = 200, nboots = 200, workers = 16) +} diff --git a/tests/coverage-study/run_minimal_coverage_tail_rerun.R b/tests/coverage-study/run_minimal_coverage_tail_rerun.R new file mode 100644 index 00000000..f057580f --- /dev/null +++ b/tests/coverage-study/run_minimal_coverage_tail_rerun.R @@ -0,0 +1,124 @@ +## ============================================================================ +## Conditional follow-up to run_minimal_coverage.R: re-run any scenario whose +## tail-CI methods (basic / percentile / bc / bca) come in below threshold +## (default 0.93) at nboots = 1000 instead of 200. +## +## This complements run_minimal_coverage.R per the v2.4.2 .check_tail_ci_replicates +## warning: tail-quantile CIs at B = 200 can be erratic (E&T 1987 §3, DiCiccio & +## Efron 1996 §4 recommend B >= 1000). Normal CI is unaffected by B; jackknife +## is normal-only by construction. So the rerun targets only A/B/C1 cells with +## tail methods that came in low. +## +## Reads the most recent minimal_summary_K*_nb*_*.csv and dispatches reruns. +## ============================================================================ + +.script_path_self <- function() { + args <- commandArgs(trailingOnly = FALSE) + file_arg <- grep("^--file=", args, value = TRUE) + if (length(file_arg) > 0L) { + return(normalizePath(sub("^--file=", "", file_arg[1]))) + } + of <- tryCatch(sys.frame(1)$ofile, error = function(e) NULL) + if (!is.null(of)) return(normalizePath(of)) + NA_character_ +} +.this <- .script_path_self() +.this_dir <- if (!is.na(.this)) dirname(.this) else getwd() +options(.fect_minimal_no_autorun = TRUE) # prevent run_all() inside source +source(file.path(.this_dir, "run_minimal_coverage.R"), local = FALSE) +options(.fect_minimal_no_autorun = NULL) +## run_all() at the bottom of run_minimal_coverage.R is gated by sys.nframe() +## so it won't trigger when sourced from inside this script. + +read_summary <- function(out_dir = "/tmp/fect-coverage-study") { + files <- list.files(out_dir, pattern = "^minimal_summary_K.*nb200.*\\.csv$", + full.names = TRUE) + if (length(files) == 0L) { + stop("No minimal_summary_*_nb200_*.csv found; run run_minimal_coverage.R first.") + } + latest <- files[order(file.mtime(files), decreasing = TRUE)][1] + cat("Reading summary:", latest, "\n") + read.csv(latest, stringsAsFactors = FALSE) +} + +decide_reruns <- function(summary, threshold = 0.93, + tail_methods = c("basic", "percentile", "bc", "bca")) { + fail <- summary$ci.method %in% tail_methods & summary$coverage < threshold + if (!any(fail)) return(character(0L)) + fail_rows <- summary[fail, ] + cat("\nFailing tail-CI cells (coverage < ", threshold, "):\n", sep = "") + print(fail_rows[, c("scenario", "ci.method", "coverage", "mc_se")], + row.names = FALSE) + unique(fail_rows$scenario) +} + +main <- function(K = 200, nboots_tail = 1000, workers = 16, + threshold = 0.93, + out_dir = "/tmp/fect-coverage-study") { + summary <- read_summary(out_dir) + cat("\n=== Initial summary (nboots = 200) ===\n") + print(summary[, c("scenario", "ci.method", "coverage", "mc_se", + "mean_width")], row.names = FALSE, digits = 4) + + rerun_scenarios <- decide_reruns(summary, threshold = threshold) + if (length(rerun_scenarios) == 0L) { + cat("\nAll tail-CI cells >= ", threshold, ". No reruns needed.\n", sep = "") + return(invisible(summary)) + } + cat("\nScenarios requiring rerun at nboots = ", nboots_tail, ": ", + paste(rerun_scenarios, collapse = ", "), "\n", sep = "") + + future::plan(future::multisession, workers = workers) + options(future.globals.maxSize = 2e9) + on.exit(future::plan(future::sequential), add = TRUE) + + ts <- format(Sys.time(), "%Y%m%d-%H%M%S") + rerun_summaries <- list() + for (scen in rerun_scenarios) { + seed_base <- switch(scen, + "A" = 1000L, + "B" = 2000L, + "C_boot" = 3000L, + "C_jack" = 4000L, + stop("Unknown scenario: ", scen)) + ## Use the SAME seeds as the original run -- ensures the only changing + ## factor is nboots (paired comparison). + label <- switch(scen, + "A" = "A: factor IID parametric", + "B" = "B: factor AR(1) rho=0.8 parametric", + "C_boot" = "C1: TWFE AR(1) rho=0.5 bootstrap", + "C_jack" = "C2: TWFE AR(1) rho=0.5 jackknife", + paste(scen, "(rerun)")) + result <- run_scenario(scen, paste0(label, " [nboots=", nboots_tail, "]"), + K = K, nboots = nboots_tail, workers = workers, + base_seed = seed_base, + ci_methods = if (scen == "C_jack") "normal" + else CI_METHODS_FULL) + df_csv <- file.path(out_dir, + sprintf("minimal_%s_K%d_nb%d_%s.csv", + scen, K, nboots_tail, ts)) + write.csv(result$df, df_csv, row.names = FALSE) + cat(" wrote", df_csv, "\n") + rerun_summaries[[scen]] <- result$summary + } + + rerun_df <- do.call(rbind, rerun_summaries) + sum_csv <- file.path(out_dir, + sprintf("minimal_tail_rerun_summary_K%d_nb%d_%s.csv", + K, nboots_tail, ts)) + write.csv(rerun_df, sum_csv, row.names = FALSE) + + cat("\n", strrep("=", 78), "\n", sep = "") + cat("RERUN SUMMARY (nboots = ", nboots_tail, ")\n", sep = "") + cat(strrep("=", 78), "\n", sep = "") + print(rerun_df[, c("scenario", "ci.method", "coverage", "mc_se", + "mean_width")], row.names = FALSE, digits = 4) + cat(sprintf("\nRerun summary CSV: %s\n", sum_csv)) + cat(strrep("=", 78), "\n", sep = "") + + invisible(rerun_df) +} + +if (sys.nframe() == 0L || identical(environmentName(parent.frame()), "R_GlobalEnv")) { + main() +} diff --git a/tests/coverage-study/run_para_error_coverage.R b/tests/coverage-study/run_para_error_coverage.R new file mode 100644 index 00000000..5262ea82 --- /dev/null +++ b/tests/coverage-study/run_para_error_coverage.R @@ -0,0 +1,249 @@ +## ============================================================================ +## Coverage validation suite for the parametric / para.error inference path. +## +## RUN WHEN: any code change touches the bootstrap distribution. Specifically: +## - R/boot.R parametric branch (line ~774, the method %in% {gsynth,ife,cfe} +## parametric path) or its para.error sub-dispatch +## - R/po-estimands.R location-shift code (search "is_parametric") +## - the vartype, ci.method, or para.error enum +## - jackknife dispatch / slot contract +## - eff.boot or att.avg.boot population +## +## DO NOT RUN ON: doc edits, vignette changes, R/plot.R, refactors that don't +## touch the bootstrap distribution. The fast `devtools::test()` suite is the +## right gate for those. +## +## Wall time: ~30 min in parallel (T19 + T20 each ~30 min, T21 ~10 min; +## scripts run sequentially below by default for reproducibility). +## +## Output: /tmp/fect-coverage-study/coverage_para_error_.csv +## + plain-text PASS/FAIL summary printed to stdout. +## +## Acceptance: +## T19 (DGP-A, IID Gaussian, n=100, B=1000) +## coverage in [0.90, 0.99] for all (para.error mode x ci.method) cells +## (0.90 not 0.95: small-N IID parametric bootstrap targets V_t alone +## and misses Var_{Lambda,F}[b_t]; SE / empirical-SD ~ 0.91 -> ~0.91 +## coverage analytically. See README and 2026-05-03 run log.) +## T20 (DGP-A8, AR(1) rho=0.8, n=100, B=1000) +## coverage >= 0.91 for all cells (AR(1) inflates variance) +## T21 (DGP-A, n=50, B=500) +## wild/empirical CI width ratio in [0.70, 1.30] across all 5 ci.methods +## +## Background (gsynth-note section 2): the parametric pseudo-treated bootstrap +## targets the conditional variance V_t = Var(ATT_hat - ATT | Lambda, F, X, D). +## Treatment block D is held fixed across replications (D[(T0+1):TT, 1:Ntr] <- 1) +## so the empirical variance across reps tracks E_{(Lambda,F)}[V_t], not the +## marginal variance Var(ATT_hat - ATT) which by the law of total variance equals +## E[V_t] + Var_{(Lambda,F)}[b_t] and includes a finite-sample-bias contribution +## the bootstrap is silent about. Re-randomizing D would inject Var_D[b_t] and +## bias measured coverage downward. +## ============================================================================ + +suppressPackageStartupMessages({ library(devtools) }) + +## resolve repo root from script location (works when called from anywhere) +script_dir <- tryCatch( + dirname(normalizePath(sys.frame(1)$ofile)), + error = function(e) getwd() +) +pkg_root <- normalizePath(file.path(script_dir, "..", "..")) +setwd(pkg_root) +cat("Loading fect from:", pkg_root, "\n") +devtools::load_all(pkg_root, quiet = TRUE) + +## ------------------------------------------------------------ DGP helpers -- + +## DGP-A: additive TWFE, IID Gaussian, true ATT = 3.0, fully observed +## Treatment block fixed at units 1:Ntr (see gsynth-note section 2). +dgp_a <- function(seed) { + set.seed(seed) + N <- 40; TT <- 20; T0 <- 12; Ntr <- 12 + alpha_i <- rnorm(N, 0, 2) + xi_t <- rnorm(TT, 0, 1) + eps <- matrix(rnorm(N * TT, 0, 1), TT, N) + D <- matrix(0L, TT, N); D[(T0 + 1):TT, 1:Ntr] <- 1L + Y <- outer(xi_t, rep(1, N)) + outer(rep(1, TT), alpha_i) + 3 * D + eps + data.frame(id = rep(1:N, each = TT), time = rep(1:TT, N), + Y = c(Y), D = c(D)) +} + +## DGP-A8: same as DGP-A but errors are AR(1) with rho = 0.8 +dgp_a8 <- function(seed) { + set.seed(seed) + N <- 40; TT <- 20; T0 <- 12; Ntr <- 12 + alpha_i <- rnorm(N, 0, 2) + xi_t <- rnorm(TT, 0, 1) + eps <- matrix(NA, TT, N) + for (i in 1:N) { + e <- rnorm(TT, 0, 1) + eps[1, i] <- e[1] / sqrt(1 - 0.64) # stationary init + for (t in 2:TT) eps[t, i] <- 0.8 * eps[t - 1, i] + e[t] + } + D <- matrix(0L, TT, N); D[(T0 + 1):TT, 1:Ntr] <- 1L + Y <- outer(xi_t, rep(1, N)) + outer(rep(1, TT), alpha_i) + 3 * D + eps + data.frame(id = rep(1:N, each = TT), time = rep(1:TT, N), + Y = c(Y), D = c(D)) +} + +## ------------------------------------------------------------ shared call -- + +fect_para <- function(df, para.error, nboots = 1000, parallel = TRUE, cores = 10) { + suppressMessages(suppressWarnings( + fect(Y ~ D, data = df, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, vartype = "parametric", para.error = para.error, + nboots = nboots, parallel = parallel, cores = cores, + time.component.from = "nevertreated", + keep.sims = TRUE, CV = FALSE) + )) +} + +## ------------------------------------------------------------ T19 / T20 --- + +run_coverage_dgp <- function(label, dgp_fn, n_reps = 100, nboots = 1000, + cores = 10, threshold = 0.91, upper = 0.99, + true_att = 3.0) { + ci_methods <- c("basic", "percentile", "bc", "bca", "normal") + para_modes <- c("ar", "empirical", "wild") + + raw_covers <- array(NA_real_, + dim = c(n_reps, length(para_modes), length(ci_methods)), + dimnames = list(NULL, para_modes, ci_methods)) + ci_widths <- raw_covers + att_hat <- matrix(NA_real_, n_reps, length(para_modes), + dimnames = list(NULL, para_modes)) + + cat(sprintf("\n=== %s: %d reps x %d nboots x 3 modes x 5 ci.methods ===\n", + label, n_reps, nboots)) + t0 <- Sys.time() + for (r in seq_len(n_reps)) { + df <- dgp_fn(seed = r * 100) + for (pm in para_modes) { + fit <- fect_para(df, para.error = pm, nboots = nboots, + parallel = TRUE, cores = cores) + att_hat[r, pm] <- fit$att.avg + for (m in ci_methods) { + est <- estimand(fit, "att", "overall", + window = c(1, 8), ci.method = m) + raw_covers[r, pm, m] <- as.integer(est$ci.lo <= true_att && + est$ci.hi >= true_att) + ci_widths[r, pm, m] <- est$ci.hi - est$ci.lo + } + } + if (r %% 5 == 0) { + elapsed <- as.numeric(difftime(Sys.time(), t0, units = "mins")) + cat(sprintf(" rep %3d / %d elapsed %.1f min eta %.1f min\n", + r, n_reps, elapsed, elapsed / r * (n_reps - r))) + } + } + + cov_mat <- apply(raw_covers, c(2, 3), mean, na.rm = TRUE) + width_mat <- apply(ci_widths, c(2, 3), mean, na.rm = TRUE) + bias_vec <- colMeans(att_hat, na.rm = TRUE) - true_att + + cat(sprintf("\n%s coverage table:\n", label)) + print(round(cov_mat, 3)) + cat("\nMean CI width:\n"); print(round(width_mat, 3)) + cat("\nBias (att.hat - true):\n"); print(round(bias_vec, 3)) + + pass <- all(cov_mat >= threshold & cov_mat <= upper) + cat(sprintf("\n%s PASS at [%.2f, %.2f] threshold: %s\n", + label, threshold, upper, pass)) + + list(label = label, cov_mat = cov_mat, width_mat = width_mat, + bias = bias_vec, pass = pass, raw_covers = raw_covers, + ci_widths = ci_widths, att_hat = att_hat, + n_reps = n_reps, nboots = nboots) +} + +## ------------------------------------------------------------ T21 width -- + +run_width_parity <- function(n_reps = 50, nboots = 500, cores = 10, + ratio_lo = 0.70, ratio_hi = 1.30) { + ci_methods <- c("basic", "percentile", "bc", "bca", "normal") + modes <- c("empirical", "wild") + width <- array(NA_real_, dim = c(n_reps, length(modes), length(ci_methods)), + dimnames = list(NULL, modes, ci_methods)) + + cat(sprintf("\n=== T21 width parity: %d reps x %d nboots x 2 modes ===\n", + n_reps, nboots)) + t0 <- Sys.time() + for (r in seq_len(n_reps)) { + df <- dgp_a(seed = r * 77) + for (md in modes) { + fit <- fect_para(df, para.error = md, nboots = nboots, + parallel = TRUE, cores = cores) + for (m in ci_methods) { + est <- estimand(fit, "att", "overall", + window = c(1, 8), ci.method = m) + width[r, md, m] <- est$ci.hi - est$ci.lo + } + } + if (r %% 5 == 0) { + elapsed <- as.numeric(difftime(Sys.time(), t0, units = "mins")) + cat(sprintf(" rep %2d / %d elapsed %.1f min\n", + r, n_reps, elapsed)) + } + } + mean_width <- apply(width, c(2, 3), mean, na.rm = TRUE) + ratios <- mean_width["wild", ] / mean_width["empirical", ] + + cat("\nMean CI width by mode x ci.method:\n"); print(round(mean_width, 3)) + cat("\nratio wild / empirical:\n"); print(round(ratios, 3)) + pass <- all(ratios >= ratio_lo & ratios <= ratio_hi) + cat(sprintf("\nT21 PASS [%.2f, %.2f]: %s\n", ratio_lo, ratio_hi, pass)) + list(mean_width = mean_width, ratios = ratios, width = width, pass = pass) +} + +## ------------------------------------------------------------ entrypoint -- + +run_all <- function(out_dir = "/tmp/fect-coverage-study") { + dir.create(out_dir, recursive = TRUE, showWarnings = FALSE) + ts <- format(Sys.time(), "%Y%m%d-%H%M%S") + + ## T19 threshold = 0.90 (not 0.91): at N=40 IID with no factor structure, + ## the parametric pseudo-treated bootstrap targets V_t alone and misses + ## Var_{Lambda,F}[b_t]; bootstrap SE / empirical SD ~ 0.91, yielding ~0.91 + ## coverage analytically (see README "Why fixed treated block" + 2026-05-03 + ## coverage-completion run log). T20 keeps 0.91 (AR(1) inflates variance, + ## empirically lands at 0.96+). + t19 <- run_coverage_dgp("T19 (DGP-A, IID)", dgp_a, n_reps = 100, nboots = 1000, + threshold = 0.90) + t20 <- run_coverage_dgp("T20 (DGP-A8, AR(1))", dgp_a8, n_reps = 100, nboots = 1000) + t21 <- run_width_parity(n_reps = 50, nboots = 500) + + out_rds <- file.path(out_dir, sprintf("coverage_para_error_%s.rds", ts)) + saveRDS(list(t19 = t19, t20 = t20, t21 = t21), out_rds) + + ## Long-format CSV summary for diff/audit + rows <- list() + for (res in list(t19, t20)) { + thr_low <- if (grepl("^T19", res$label)) 0.90 else 0.91 + for (pm in rownames(res$cov_mat)) for (m in colnames(res$cov_mat)) { + rows[[length(rows) + 1L]] <- data.frame( + test = res$label, dgp = sub(".*\\(([^)]+)\\).*", "\\1", res$label), + para.error = pm, ci.method = m, + coverage = res$cov_mat[pm, m], width = res$width_mat[pm, m], + threshold_low = thr_low, threshold_high = 0.99, + pass = res$cov_mat[pm, m] >= thr_low & res$cov_mat[pm, m] <= 0.99, + stringsAsFactors = FALSE) + } + } + summary_df <- do.call(rbind, rows) + csv_path <- file.path(out_dir, sprintf("coverage_para_error_%s.csv", ts)) + write.csv(summary_df, csv_path, row.names = FALSE) + + cat("\n", strrep("=", 60), "\n", sep = "") + cat("OVERALL: T19 ", t19$pass, " T20 ", t20$pass, " T21 ", t21$pass, "\n", sep = "") + cat("CSV: ", csv_path, "\n", sep = "") + cat("RDS: ", out_rds, "\n", sep = "") + cat(strrep("=", 60), "\n", sep = "") + invisible(list(t19 = t19, t20 = t20, t21 = t21, + csv = csv_path, rds = out_rds)) +} + +## Run when sourced as a script (not when load_all'd interactively) +if (sys.nframe() == 0L || identical(environmentName(parent.frame()), "R_GlobalEnv")) { + run_all() +} diff --git a/tests/coverage-study/run_tol_characterization.R b/tests/coverage-study/run_tol_characterization.R new file mode 100644 index 00000000..38f385e2 --- /dev/null +++ b/tests/coverage-study/run_tol_characterization.R @@ -0,0 +1,156 @@ +## ============================================================================ +## Tol-convergence characterization: where does fect's EM actually converge? +## ============================================================================ +## v2.4.3 investigation (2026-05-02): default tol = 1e-3 produces +## under-converged IFE/CFE estimates. Question: what's the right new default? +## +## Approach: tol-sweep across methods x DGPs x panel sizes. For each cell, +## measure att.avg, niter, wall time. Derive: at what tol does att.avg +## stabilize to within X% of the truly-converged value? +## +## Pass criterion for a candidate default tol: +## max relative att.avg gap (vs tol=1e-7) < 1% across all tested cells +## AND wall time penalty vs current default <= 5x +## +## RUN: ~10-15 min wall time. Output: +## /tmp/fect-tol-char/tol_sweep_.csv +## ============================================================================ + +suppressPackageStartupMessages({ library(fect); library(dplyr) }) +OUT_DIR <- "/tmp/fect-tol-char" +dir.create(OUT_DIR, recursive = TRUE, showWarnings = FALSE) + +run_tol_cell <- function(method, formula, data, index, r = 0, lambda = NULL, + force = "two-way", time.component.from = "notyettreated", + tol_seq = c(1e-3, 1e-4, 1e-5, 1e-6, 1e-7), + max_iter_seq = c(1000, 1000, 5000, 10000, 50000), + label = "") { + cells <- list() + for (i in seq_along(tol_seq)) { + t <- tol_seq[i] + mi <- max_iter_seq[i] + t0 <- Sys.time() + args <- list(formula = formula, data = data, index = index, + method = method, force = force, + time.component.from = time.component.from, + se = FALSE, CV = FALSE, + tol = t, max.iteration = mi) + if (!is.null(r)) args$r <- r + if (!is.null(lambda)) args$lambda <- lambda + fit <- tryCatch(do.call(fect, args), error = function(e) e) + elapsed <- as.numeric(difftime(Sys.time(), t0, units = "secs")) + if (inherits(fit, "error")) { + cells[[i]] <- data.frame( + label = label, method = method, tol = t, max_iter = mi, + niter = NA, att.avg = NA, elapsed = elapsed, + error = conditionMessage(fit), stringsAsFactors = FALSE) + } else { + cells[[i]] <- data.frame( + label = label, method = method, tol = t, max_iter = mi, + niter = fit$niter %||% NA, + att.avg = fit$att.avg, elapsed = elapsed, + error = NA_character_, stringsAsFactors = FALSE) + } + } + do.call(rbind, cells) +} + +`%||%` <- function(a, b) if (is.null(a)) b else a + +cat("=== Tol-convergence characterization ===\n") +cat("Started:", as.character(Sys.time()), "\n\n") + +results <- list() + +cat("[1/8] simdata + IFE r=2 (canonical IFE benchmark)\n") +data(simdata) +results[[1]] <- run_tol_cell( + method = "ife", formula = Y ~ D + X1 + X2, data = simdata, + index = c("id","time"), r = 2, + label = "simdata-ife-r2" +) +print(results[[1]][, c("tol","niter","att.avg","elapsed")]) + +cat("\n[2/8] simdata + CFE r=2 (canonical CFE benchmark)\n") +results[[2]] <- run_tol_cell( + method = "cfe", formula = Y ~ D + X1 + X2, data = simdata, + index = c("id","time"), r = 2, + label = "simdata-cfe-r2" +) +print(results[[2]][, c("tol","niter","att.avg","elapsed")]) + +cat("\n[3/8] simdata + IFE r=1 (smaller rank)\n") +results[[3]] <- run_tol_cell( + method = "ife", formula = Y ~ D + X1 + X2, data = simdata, + index = c("id","time"), r = 1, + label = "simdata-ife-r1" +) +print(results[[3]][, c("tol","niter","att.avg","elapsed")]) + +cat("\n[4/8] sim_gsynth + GSC r=2 (gsynth canonical)\n") +data(sim_gsynth) +results[[4]] <- run_tol_cell( + method = "gsynth", formula = Y ~ D + X1 + X2, data = sim_gsynth, + index = c("id","time"), r = 2, + label = "sim_gsynth-gsynth-r2" +) +print(results[[4]][, c("tol","niter","att.avg","elapsed")]) + +cat("\n[5/8] simdata + MC lambda=0.05 (typical regularization)\n") +results[[5]] <- run_tol_cell( + method = "mc", formula = Y ~ D + X1 + X2, data = simdata, + index = c("id","time"), r = NULL, lambda = 0.05, + label = "simdata-mc-lam05" +) +print(results[[5]][, c("tol","niter","att.avg","elapsed")]) + +cat("\n[6/8] simdata + MC lambda=0.01 (light regularization)\n") +results[[6]] <- run_tol_cell( + method = "mc", formula = Y ~ D + X1 + X2, data = simdata, + index = c("id","time"), r = NULL, lambda = 0.01, + label = "simdata-mc-lam01" +) +print(results[[6]][, c("tol","niter","att.avg","elapsed")]) + +cat("\n[7/8] turnout + IFE r=2 (real-world panel, Liu Wang Xu 2024)\n") +data(turnout) +results[[7]] <- run_tol_cell( + method = "ife", formula = turnout ~ policy_edr, + data = turnout, index = c("abb","year"), r = 2, + label = "turnout-ife-r2" +) +print(results[[7]][, c("tol","niter","att.avg","elapsed")]) + +cat("\n[8/8] hh2019 + IFE r=2 (real-world, smaller)\n") +data(hh2019) +results[[8]] <- run_tol_cell( + method = "ife", formula = hr ~ indirect, + data = hh2019, index = c("bfs","year"), r = 2, + label = "hh2019-ife-r2" +) +print(results[[8]][, c("tol","niter","att.avg","elapsed")]) + +all_results <- do.call(rbind, results) +ts <- format(Sys.time(), "%Y%m%d-%H%M%S") +out_path <- file.path(OUT_DIR, sprintf("tol_sweep_%s.csv", ts)) +write.csv(all_results, out_path, row.names = FALSE) + +cat("\n=== Summary: gap from converged (tol=1e-7) per cell ===\n") +summary_df <- all_results %>% + group_by(label) %>% + mutate(att_converged = att.avg[tol == min(tol)], + gap_pct = 100 * (att.avg - att_converged) / att_converged, + speedup_vs_1e7 = elapsed[tol == min(tol)] / elapsed) %>% + select(label, tol, niter, att.avg, gap_pct, elapsed, speedup_vs_1e7) +print(as.data.frame(summary_df), digits = 4) + +cat("\nSaved:", out_path, "\n") +cat("\n=== Verdict per candidate default ===\n") +for (cand in c(1e-3, 1e-4, 1e-5, 1e-6)) { + sub <- subset(summary_df, tol == cand) + if (nrow(sub) == 0) next + max_gap <- max(abs(sub$gap_pct), na.rm = TRUE) + median_speedup <- median(sub$speedup_vs_1e7, na.rm = TRUE) + cat(sprintf(" tol = %.0e: max |gap| = %.2f%% median speedup vs 1e-7 = %.2fx\n", + cand, max_gap, median_speedup)) +} diff --git a/tests/coverage-study/run_tol_coverage.R b/tests/coverage-study/run_tol_coverage.R new file mode 100644 index 00000000..8f517a82 --- /dev/null +++ b/tests/coverage-study/run_tol_coverage.R @@ -0,0 +1,115 @@ +## ============================================================================ +## Tol coverage validation (v2.4.3 default-tol fix gate) +## +## Question: at the proposed new default tol = 1e-5, does the bootstrap +## CI cover the true ATT at the nominal 95% rate? +## +## DGP: factor model, N=200, T=35, Ntr=100, r=2, true tau = 3.0. +## (Mirrors simdata structure but with known-truth tau for coverage.) +## +## Cells: tol ∈ {1e-3 (current), 1e-5 (proposed), 1e-7 (converged ground truth)} +## Method: ife. vartype: bootstrap, nboots = 200. +## K = 100 reps per cell (300 fits total). +## +## Pass criterion for tol = 1e-5: +## empirical coverage within ±3pp of nominal 95% (i.e. 92-98%) +## AND coverage no worse than tol = 1e-7 baseline +## ============================================================================ + +suppressPackageStartupMessages({ library(fect); library(dplyr) }) +OUT_DIR <- "/tmp/fect-tol-char" +dir.create(OUT_DIR, recursive = TRUE, showWarnings = FALSE) + +make_factor_data <- function(N = 200, T = 35, Ntr = 100, tau = 3.0, r = 2, + T_treat_start = 18, sigma = 1.0, seed = NULL) { + if (!is.null(seed)) set.seed(seed) + F_mat <- matrix(rnorm(T * r), T, r) + L_mat <- matrix(rnorm(N * r), N, r) + Y_factor <- F_mat %*% t(L_mat) # T x N + Y_noise <- matrix(rnorm(T * N, sd = sigma), T, N) + D_mat <- matrix(0, T, N) + treat_units <- 1:Ntr + D_mat[T_treat_start:T, treat_units] <- 1 + Y_mat <- Y_factor + Y_noise + tau * D_mat + df <- data.frame( + id = rep(1:N, each = T), + time = rep(1:T, N), + Y = as.vector(Y_mat), + D = as.vector(D_mat) + ) + df +} + +run_one_rep <- function(rep_seed, tol, max_iter, nboots = 100) { + df <- make_factor_data(N = 200, T = 35, Ntr = 100, tau = 3.0, r = 2, + seed = rep_seed) + fit <- tryCatch( + fect(Y ~ D, data = df, index = c("id","time"), + method = "ife", r = 2, force = "two-way", + se = TRUE, vartype = "bootstrap", nboots = nboots, + parallel = FALSE, keep.sims = FALSE, CV = FALSE, + tol = tol, max.iteration = max_iter, seed = rep_seed), + error = function(e) e) + if (inherits(fit, "error")) return(list(att = NA, se = NA, ci_l = NA, ci_u = NA, cover = NA, niter = NA)) + # Aggregate ATT over post-treatment event-times + att_post <- fit$est.avg + if (is.null(att_post) || nrow(att_post) == 0) return(list(att = NA, se = NA, ci_l = NA, ci_u = NA, cover = NA, niter = fit$niter)) + point <- att_post[1, "ATT.avg"] + se <- att_post[1, "S.E."] + ci_l <- att_post[1, "CI.lower"] + ci_u <- att_post[1, "CI.upper"] + cover <- (3.0 >= ci_l) && (3.0 <= ci_u) + list(att = point, se = se, ci_l = ci_l, ci_u = ci_u, cover = cover, niter = fit$niter) +} + +run_coverage <- function(tol, max_iter, K = 100, label) { + cat(sprintf("\n=== %s (tol=%.0e, max_iter=%d, K=%d) ===\n", + label, tol, max_iter, K)) + t0 <- Sys.time() + res <- vector("list", K) + for (k in seq_len(K)) { + res[[k]] <- run_one_rep(rep_seed = 1000 + k, tol = tol, max_iter = max_iter) + if (k %% 20 == 0) { + cat(sprintf(" k=%d: cumulative coverage = %.3f\n", + k, mean(sapply(res[seq_len(k)], "[[", "cover"), na.rm = TRUE))) + } + } + elapsed <- as.numeric(difftime(Sys.time(), t0, units = "secs")) + cover_vec <- sapply(res, "[[", "cover") + att_vec <- sapply(res, "[[", "att") + se_vec <- sapply(res, "[[", "se") + niter_vec <- sapply(res, "[[", "niter") + n_valid <- sum(!is.na(cover_vec)) + coverage <- mean(cover_vec, na.rm = TRUE) + se_emp <- sd(att_vec, na.rm = TRUE) + se_avg <- mean(se_vec, na.rm = TRUE) + bias <- mean(att_vec - 3.0, na.rm = TRUE) + cat(sprintf("\n Coverage: %.3f bias: %+.4f emp.SE: %.4f avg.boot.SE: %.4f\n", + coverage, bias, se_emp, se_avg)) + cat(sprintf(" median niter: %d n_valid: %d/%d elapsed: %.1fs\n", + median(niter_vec, na.rm = TRUE), n_valid, K, elapsed)) + list(label = label, tol = tol, max_iter = max_iter, K = K, + coverage = coverage, bias = bias, se_emp = se_emp, se_avg = se_avg, + elapsed = elapsed, niter_med = median(niter_vec, na.rm = TRUE)) +} + +cat("=== v2.4.3 default-tol coverage validation ===\n") +cat("Started:", as.character(Sys.time()), "\n") +cat("DGP: N=200 T=35 Ntr=100 r=2 tau=3.0 sigma=1.0\n") + +results <- list( + run_coverage(tol = 1e-3, max_iter = 1000, K = 80, label = "current default"), + run_coverage(tol = 1e-5, max_iter = 5000, K = 80, label = "PROPOSED new default") +) + +cat("\n========================================\n") +cat("Summary\n") +cat("========================================\n") +for (r in results) { + cat(sprintf(" %-32s cover=%.3f bias=%+.4f emp.SE=%.4f boot.SE=%.4f niter_med=%d\n", + r$label, r$coverage, r$bias, r$se_emp, r$se_avg, r$niter_med)) +} + +ts <- format(Sys.time(), "%Y%m%d-%H%M%S") +saveRDS(results, file.path(OUT_DIR, sprintf("coverage_tol_%s.rds", ts))) +cat("\nSaved RDS to", OUT_DIR, "\n") diff --git a/tests/coverage-study/run_tol_coverage_extended.R b/tests/coverage-study/run_tol_coverage_extended.R new file mode 100644 index 00000000..dcd69c7b --- /dev/null +++ b/tests/coverage-study/run_tol_coverage_extended.R @@ -0,0 +1,131 @@ +## ============================================================================ +## Extended tol coverage: CFE + AR(1) noise + multi-seed stability +## +## After Phase 1c showed inference is preserved at tol=1e-3 on a clean IFE +## DGP, test the harder cases: +## 1. CFE r=2 (was 40% gap in Phase 1a) +## 2. AR(1) noise (real-world serial correlation) +## 3. Multi-seed att.avg stability (does the deterministic output drift +## with initialization perturbations?) +## ============================================================================ + +suppressPackageStartupMessages({ library(fect); library(dplyr) }) +OUT_DIR <- "/tmp/fect-tol-char" +dir.create(OUT_DIR, recursive = TRUE, showWarnings = FALSE) + +make_factor_data <- function(N = 200, T = 35, Ntr = 100, tau = 3.0, r = 2, + T_treat_start = 18, sigma = 1.0, ar1_rho = 0, + seed = NULL) { + if (!is.null(seed)) set.seed(seed) + F_mat <- matrix(rnorm(T * r), T, r) + L_mat <- matrix(rnorm(N * r), N, r) + Y_factor <- F_mat %*% t(L_mat) + if (ar1_rho == 0) { + Y_noise <- matrix(rnorm(T * N, sd = sigma), T, N) + } else { + Y_noise <- matrix(0, T, N) + for (i in 1:N) { + eps <- rnorm(T, sd = sigma * sqrt(1 - ar1_rho^2)) + y <- numeric(T); y[1] <- rnorm(1, sd = sigma) + for (t in 2:T) y[t] <- ar1_rho * y[t-1] + eps[t] + Y_noise[, i] <- y + } + } + D_mat <- matrix(0, T, N) + treat_units <- 1:Ntr + D_mat[T_treat_start:T, treat_units] <- 1 + Y_mat <- Y_factor + Y_noise + tau * D_mat + df <- data.frame( + id = rep(1:N, each = T), + time = rep(1:T, N), + Y = as.vector(Y_mat), + D = as.vector(D_mat) + ) + df +} + +run_one_rep <- function(rep_seed, tol, max_iter, method = "ife", ar1_rho = 0, + nboots = 80) { + df <- make_factor_data(N = 200, T = 35, Ntr = 100, tau = 3.0, r = 2, + ar1_rho = ar1_rho, seed = rep_seed) + fit <- tryCatch( + fect(Y ~ D, data = df, index = c("id","time"), + method = method, r = 2, force = "two-way", + se = TRUE, vartype = "bootstrap", nboots = nboots, + parallel = FALSE, keep.sims = FALSE, CV = FALSE, + tol = tol, max.iteration = max_iter, seed = rep_seed), + error = function(e) e) + if (inherits(fit, "error")) return(list(att = NA, se = NA, ci_l = NA, ci_u = NA, cover = NA, niter = NA)) + att_post <- fit$est.avg + if (is.null(att_post) || nrow(att_post) == 0) return(list(att = NA, se = NA, ci_l = NA, ci_u = NA, cover = NA, niter = fit$niter)) + point <- att_post[1, "ATT.avg"] + se <- att_post[1, "S.E."] + ci_l <- att_post[1, "CI.lower"] + ci_u <- att_post[1, "CI.upper"] + cover <- (3.0 >= ci_l) && (3.0 <= ci_u) + list(att = point, se = se, ci_l = ci_l, ci_u = ci_u, cover = cover, niter = as.integer(fit$niter)) +} + +run_coverage <- function(tol, max_iter, method = "ife", ar1_rho = 0, K = 60, label) { + cat(sprintf("\n=== %s (method=%s, tol=%.0e, max_iter=%d, ar1=%.1f, K=%d) ===\n", + label, method, tol, max_iter, ar1_rho, K)) + t0 <- Sys.time() + res <- vector("list", K) + for (k in seq_len(K)) { + res[[k]] <- run_one_rep(rep_seed = 5000 + k, tol = tol, max_iter = max_iter, + method = method, ar1_rho = ar1_rho) + if (k %% 20 == 0) { + cov_so_far <- mean(sapply(res[seq_len(k)], "[[", "cover"), na.rm = TRUE) + cat(sprintf(" k=%d: cumulative coverage = %.3f\n", k, cov_so_far)) + } + } + elapsed <- as.numeric(difftime(Sys.time(), t0, units = "secs")) + cover_vec <- sapply(res, "[[", "cover") + att_vec <- sapply(res, "[[", "att") + se_vec <- sapply(res, "[[", "se") + niter_vec <- sapply(res, "[[", "niter") + n_valid <- sum(!is.na(cover_vec)) + coverage <- mean(cover_vec, na.rm = TRUE) + se_emp <- sd(att_vec, na.rm = TRUE) + se_avg <- mean(se_vec, na.rm = TRUE) + bias <- mean(att_vec - 3.0, na.rm = TRUE) + cat(sprintf("\n Coverage: %.3f bias: %+.4f emp.SE: %.4f avg.boot.SE: %.4f\n", + coverage, bias, se_emp, se_avg)) + cat(sprintf(" median niter: %s n_valid: %d/%d elapsed: %.1fs\n", + as.character(median(niter_vec, na.rm = TRUE)), + n_valid, K, elapsed)) + list(label = label, method = method, tol = tol, max_iter = max_iter, ar1 = ar1_rho, + K = K, coverage = coverage, bias = bias, se_emp = se_emp, se_avg = se_avg, + elapsed = elapsed, + niter_med = median(niter_vec, na.rm = TRUE)) +} + +cat("=== Extended coverage validation (v2.4.3) ===\n") +cat("Started:", as.character(Sys.time()), "\n") + +results <- list( + ## CFE on IID DGP (Phase 1a worst case at tol=1e-3) + run_coverage(tol = 1e-3, max_iter = 1000, method = "cfe", ar1_rho = 0, K = 60, + label = "CFE iid old default"), + run_coverage(tol = 1e-5, max_iter = 5000, method = "cfe", ar1_rho = 0, K = 60, + label = "CFE iid NEW default"), + + ## IFE on AR(1) noise (real-world serial correlation) + run_coverage(tol = 1e-3, max_iter = 1000, method = "ife", ar1_rho = 0.5, K = 60, + label = "IFE AR(0.5) old default"), + run_coverage(tol = 1e-5, max_iter = 5000, method = "ife", ar1_rho = 0.5, K = 60, + label = "IFE AR(0.5) NEW default") +) + +cat("\n========================================\n") +cat("Summary\n") +cat("========================================\n") +for (r in results) { + cat(sprintf(" %-32s cover=%.3f bias=%+.4f emp.SE=%.4f boot.SE=%.4f niter_med=%s\n", + r$label, r$coverage, r$bias, r$se_emp, r$se_avg, + as.character(r$niter_med))) +} + +ts <- format(Sys.time(), "%Y%m%d-%H%M%S") +saveRDS(results, file.path(OUT_DIR, sprintf("coverage_extended_%s.rds", ts))) +cat("\nSaved to:", OUT_DIR, "\n") diff --git a/tests/testthat.R b/tests/testthat.R index 61f1c103..47e6c895 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -16,4 +16,11 @@ if (!interactive() && ))) } -test_check("fect") +## On CRAN (NOT_CRAN unset and not on GitHub Actions) run ONLY the minimal +## smoke tests in test-cran.R to keep the check budget small. Locally and in CI +## (NOT_CRAN=true or GITHUB_ACTIONS set) run the full regression suite. +if (!identical(Sys.getenv("NOT_CRAN"), "true") && !nzchar(Sys.getenv("GITHUB_ACTIONS"))) { + test_check("fect", filter = "^cran$") +} else { + test_check("fect") +} diff --git a/tests/testthat/helper-score-unify.R b/tests/testthat/helper-score-unify.R new file mode 100644 index 00000000..0ceb3615 --- /dev/null +++ b/tests/testthat/helper-score-unify.R @@ -0,0 +1,69 @@ +## --------------------------------------------------------------- +## Shared fixtures for the score-unify test family. +## +## testthat auto-loads helper-*.R files before any test-*.R, so the +## fixtures defined here (make_factor_data, ntdata, out_base) are +## visible to every test-score-*.R file. This avoids duplicating the +## ~60 lines of fixture setup across the 7 split test files. +## +## Originally lived at the top of test-score-unify.R; extracted on +## 2026-05-03 when that file was split for readability + progress +## visibility under reporter = "summary". +## --------------------------------------------------------------- + +suppressWarnings(data("simdata", package = "fect")) + +## DGP with factor structure and sufficient never-treated units for CV. +## N=50, TT=20, Ntr=15 => 35 never-treated units with 20 pre-treatment +## periods --- plenty for cross-validation with r up to 3. +make_factor_data <- function(N = 50, TT = 20, Ntr = 15, tau = 3.0, + r = 2, seed = 42) { + set.seed(seed) + F_mat <- matrix(rnorm(TT * r), TT, r) + L_mat <- matrix(rnorm(N * r), N, r) + alpha_i <- rnorm(N, 0, 1) + xi_t <- rnorm(TT, 0, 0.5) + + T0_vec <- rep(Inf, N) + if (Ntr > 0) { + T0_vec[1:Ntr] <- sample(round(TT * 0.4):round(TT * 0.7), Ntr, + replace = TRUE) + } + + Y_vec <- D_vec <- numeric(N * TT) + id_vec <- time_vec <- integer(N * TT) + idx <- 1 + for (i in 1:N) { + for (t in 1:TT) { + treated <- (t >= T0_vec[i]) + D_vec[idx] <- as.integer(treated) + Y_vec[idx] <- alpha_i[i] + xi_t[t] + + sum(F_mat[t, ] * L_mat[i, ]) + + tau * D_vec[idx] + rnorm(1, 0, 0.5) + id_vec[idx] <- i + time_vec[idx] <- t + idx <- idx + 1 + } + } + + data.frame(id = id_vec, time = time_vec, Y = Y_vec, D = D_vec) +} + +## Shared never-treated fixture for Section C / E / F tests. +ntdata <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) + +## Shared fitted object for the .score_residuals() / fect_cv / fect_mspe +## test families. Fit once at session start; all test-*.R files that need +## it can reference the global symbol. +out_base <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, + data = simdata, + index = c("id", "time"), + method = "ife", + r = 2, + CV = FALSE, + se = FALSE, + parallel = FALSE + ) +)) diff --git a/tests/testthat/test-book-claims.R b/tests/testthat/test-book-claims.R index 3dd8998b..ef7db167 100644 --- a/tests/testthat/test-book-claims.R +++ b/tests/testthat/test-book-claims.R @@ -539,10 +539,12 @@ test_that("H2: vartype='jackknife' works for FE and IFE", { expect_true(!is.null(out_ife$est.att)) }) -test_that("H3: nboots default is 200", { +test_that("H3: nboots default is 200 (tail-CI warning fires at < 1000)", { skip_on_cran() - ## Check default via formals + ## v2.4.2: default stays at 200 (sufficient for SE / normal CI). + ## A runtime warning fires when ci.method = "basic" and nboots < 1000, + ## redirecting users to bump nboots for tail-quantile CIs. defs <- formals(fect) expect_equal(defs$nboots, 200) }) diff --git a/tests/testthat/test-ci-method-fect.R b/tests/testthat/test-ci-method-fect.R new file mode 100644 index 00000000..0c16bb69 --- /dev/null +++ b/tests/testthat/test-ci-method-fect.R @@ -0,0 +1,255 @@ +## Tests for the v2.4.2 ci.method = c("normal", "basic") arg on fect(), +## and the soft-deprecated quantile.CI legacy arg. +## +## What we're verifying: +## 1. Default behavior is byte-equal to the pre-v2.4.2 default +## (quantile.CI = FALSE -> normal Wald CI). +## 2. ci.method = "normal" is byte-equal to legacy quantile.CI = FALSE. +## 3. ci.method = "basic" is byte-equal to legacy quantile.CI = TRUE. +## 4. Supplying quantile.CI explicitly emits a deprecation warning. +## 5. NOT supplying quantile.CI (NULL sentinel) emits no warning under the +## modern API. +## 6. ci.method = "basic" with nboots < 1000 emits a tail-CI replicate +## warning at fit time (mirrors the estimand .check_tail_ci_replicates +## gate). +## 7. ci.method = "bca" / "bc" / "percentile" hard-error with a message +## pointing to estimand() for the full 5-method surface. +## 8. ci.method = "garbage" hard-errors with a clear message. + +library(testthat) + +data(simdata, package = "fect") + +base_call <- function(nboots = 50, parallel = FALSE, ...) { + fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), + method = "fe", force = "two-way", se = TRUE, nboots = nboots, + parallel = parallel, seed = 42L, ...) +} + +# ---- 1. Default behavior is byte-equal to legacy quantile.CI = FALSE ------- + +test_that("default ci.method yields the legacy quantile.CI = FALSE result", { + out_default <- base_call() + out_legacy_false <- suppressWarnings(base_call(quantile.CI = FALSE)) + expect_equal(out_default$est.avg, out_legacy_false$est.avg) + expect_equal(out_default$est.att, out_legacy_false$est.att) +}) + +# ---- 2. ci.method = "normal" byte-equal to legacy FALSE -------------------- + +test_that("ci.method = 'normal' is byte-equal to quantile.CI = FALSE", { + out_normal <- base_call(ci.method = "normal") + out_legacy <- suppressWarnings(base_call(quantile.CI = FALSE)) + expect_equal(out_normal$est.avg, out_legacy$est.avg) + expect_equal(out_normal$est.att, out_legacy$est.att) +}) + +# ---- 3. ci.method = "basic" byte-equal to legacy TRUE ---------------------- + +test_that("ci.method = 'basic' is byte-equal to quantile.CI = TRUE", { + out_basic <- suppressWarnings(base_call(ci.method = "basic", nboots = 1000)) + out_legacy <- suppressWarnings(base_call(quantile.CI = TRUE, nboots = 1000)) + expect_equal(out_basic$est.avg, out_legacy$est.avg) + expect_equal(out_basic$est.att, out_legacy$est.att) +}) + +# ---- 4. Supplying quantile.CI explicitly fires deprecation warning --------- + +test_that("quantile.CI = TRUE fires a deprecation warning that mentions ci.method", { + expect_warning( + base_call(quantile.CI = TRUE, nboots = 1000), + regexp = "quantile\\.CI.*deprecated.*ci\\.method" + ) +}) + +test_that("quantile.CI = FALSE also fires the deprecation warning", { + ## "Soft-deprecate" means any user-supplied use of the legacy arg warns, + ## even when supplying the legacy default value. + expect_warning( + base_call(quantile.CI = FALSE), + regexp = "quantile\\.CI.*deprecated" + ) +}) + +# ---- 5. NULL sentinel: no warning under modern API ------------------------- + +test_that("modern API (no quantile.CI supplied) emits no quantile.CI warning", { + expect_silent_about <- function(expr, regexp) { + warned <- FALSE + withCallingHandlers( + expr, + warning = function(w) { + if (grepl(regexp, conditionMessage(w))) warned <<- TRUE + invokeRestart("muffleWarning") + } + ) + expect_false(warned) + } + expect_silent_about(base_call(), "quantile\\.CI") + expect_silent_about(base_call(ci.method = "normal"), "quantile\\.CI") +}) + +# ---- 6. nboots < 1000 + ci.method = "basic" warns at fit time -------------- + +test_that("ci.method = 'basic' with nboots < 1000 fires the tail-CI warning", { + ## The warning is gated on Sys.getenv("TESTTHAT") inside fect() to keep + ## the suite-wide summary clean. Temporarily unset the env var here so + ## the warning fires and can be asserted. + withr::with_envvar(c(TESTTHAT = "false"), { + expect_warning( + base_call(ci.method = "basic", nboots = 50), + regexp = "tail quantiles.*1000|Efron 1987" + ) + }) +}) + +expect_silent_about <- function(expr, regexp) { + warned <- FALSE + withCallingHandlers( + expr, + warning = function(w) { + if (grepl(regexp, conditionMessage(w))) warned <<- TRUE + invokeRestart("muffleWarning") + } + ) + expect_false(warned) +} + +test_that("ci.method = 'basic' with nboots >= 1000 emits no tail-CI warning", { + expect_silent_about( + base_call(ci.method = "basic", nboots = 1000), + "tail quantiles|Efron 1987" + ) +}) + +test_that("ci.method = 'normal' never fires the tail-CI warning", { + expect_silent_about( + base_call(ci.method = "normal", nboots = 50), + "tail quantiles" + ) +}) + +# ---- 7. ci.method in {bca, bc, percentile} hard-errors --------------------- + +test_that("ci.method = 'bca' errors with a message pointing to estimand()", { + expect_error( + base_call(ci.method = "bca"), + regexp = "bca.*not supported in fect.*estimand" + ) +}) + +test_that("ci.method = 'bc' errors with a message pointing to estimand()", { + expect_error( + base_call(ci.method = "bc"), + regexp = "bc.*not supported in fect.*estimand" + ) +}) + +test_that("ci.method = 'percentile' errors with a message pointing to estimand()", { + expect_error( + base_call(ci.method = "percentile"), + regexp = "percentile.*not supported in fect.*estimand" + ) +}) + +# ---- 8. ci.method validation ----------------------------------------------- + +test_that("ci.method = 'garbage' fails fast", { + expect_error( + base_call(ci.method = "garbage"), + regexp = "ci\\.method.*must be one of" + ) +}) + +# ---- 9. ci.method = "basic" + vartype = "jackknife" -> error --------------- + +test_that("ci.method = 'basic' + vartype = 'jackknife' hard-errors", { + expect_error( + suppressWarnings(base_call(vartype = "jackknife", ci.method = "basic")), + regexp = "ci\\.method = \"basic\".*not supported.*jackknife" + ) +}) + +# ---- 10. ci.method = "basic" + parametric -> location-shift fix ------------ +# +# fect's built-in CI machinery applies a location-shift fix at the avg-level +# and per-event-time CI sites so that ci.method = "basic" works on parametric +# fits. The fect-level result should match estimand(fit, "att", "basic") +# byte-equally on the avg-level CI. + +test_that("ci.method = 'basic' + parametric matches estimand at avg level", { + skip_if_not_installed("fect") + # Build a simple no-reversal panel (parametric requires no reversal) + set.seed(1001L); N <- 30; TT <- 20; T0 <- 12; Ntr <- 5 + alpha_i <- rnorm(N); xi_t <- rnorm(TT) + e <- matrix(rnorm(TT * N), TT, N) + D <- matrix(0L, TT, N); D[(T0 + 1):TT, 1:Ntr] <- 1L + Y <- outer(xi_t, rep(1, N)) + outer(rep(1, TT), alpha_i) + 3 * D + e + df <- data.frame(id = rep(1:N, each = TT), time = rep(1:TT, N), + Y = c(Y), D = c(D)) + fit <- suppressWarnings(fect( + Y ~ D, data = df, index = c("id", "time"), + method = "fe", force = "two-way", CV = FALSE, + se = TRUE, vartype = "parametric", para.error = "auto", + ci.method = "basic", + nboots = 200, parallel = FALSE, + time.component.from = "nevertreated", + keep.sims = TRUE, seed = 42L + )) + e <- suppressWarnings(estimand(fit, type = "att", by = "overall", + ci.method = "basic")) + expect_equal(unname(fit$est.avg[1, "CI.lower"]), e$ci.lo, tolerance = 1e-10) + expect_equal(unname(fit$est.avg[1, "CI.upper"]), e$ci.hi, tolerance = 1e-10) +}) + +# ---- 9. vartype = "jackknife" + cl emits an "ignored" warning -------------- +# +# fect's jackknife is leave-one-unit-out and does not consult cl. Combining +# vartype = "jackknife" with a non-NULL cl silently produced unit-level SEs. +# The user-facing warning routes such callers to vartype = "bootstrap" + cl +# for cluster-aware inference. + +test_that("vartype = 'jackknife' with cl warns that cl is ignored", { + d <- simdata + d$cl <- (d$id - 1) %/% 2 + 1 # 2 units per cluster + expect_warning( + suppressMessages(fect(Y ~ D, data = d, index = c("id", "time"), + method = "fe", force = "two-way", + vartype = "jackknife", cl = "cl", + se = TRUE, parallel = FALSE, seed = 42L)), + "cl argument is ignored" + ) +}) + +test_that("vartype = 'jackknife' without cl does not emit the cl warning", { + seen <- character(0) + withCallingHandlers( + suppressMessages(fect(Y ~ D, data = simdata, index = c("id", "time"), + method = "fe", force = "two-way", + vartype = "jackknife", + se = TRUE, parallel = FALSE, seed = 42L)), + warning = function(w) { + seen <<- c(seen, conditionMessage(w)) + invokeRestart("muffleWarning") + } + ) + expect_false(any(grepl("cl argument is ignored", seen, fixed = TRUE))) +}) + +test_that("vartype = 'bootstrap' with cl does not emit the jackknife warning", { + d <- simdata + d$cl <- (d$id - 1) %/% 2 + 1 + seen <- character(0) + withCallingHandlers( + suppressMessages(fect(Y ~ D, data = d, index = c("id", "time"), + method = "fe", force = "two-way", + vartype = "bootstrap", cl = "cl", + nboots = 50, se = TRUE, + parallel = FALSE, seed = 42L)), + warning = function(w) { + seen <<- c(seen, conditionMessage(w)) + invokeRestart("muffleWarning") + } + ) + expect_false(any(grepl("cl argument is ignored", seen, fixed = TRUE))) +}) diff --git a/tests/testthat/test-cov-ar-parametric-boot.R b/tests/testthat/test-cov-ar-parametric-boot.R index ec73fb61..d62ed5ba 100644 --- a/tests/testthat/test-cov-ar-parametric-boot.R +++ b/tests/testthat/test-cov-ar-parametric-boot.R @@ -60,12 +60,18 @@ } .fit_one <- function(df, nboots, seed) { - fect( - Y ~ D, data = df, index = c("id", "time"), - method = "ife", force = "two-way", - CV = FALSE, r = 1, se = TRUE, - vartype = "parametric", nboots = nboots, parallel = FALSE, seed = seed, - time.component.from = "nevertreated" + ## suppressWarnings covers the "EM did not converge within + ## max.iteration = 5000" warning. The DGP here is intentionally + ## ill-conditioned (small N_co/N_tr + AR(1) rho = 0.8) and these tests + ## verify the bootstrap SD ratio, not EM convergence. + suppressWarnings( + fect( + Y ~ D, data = df, index = c("id", "time"), + method = "ife", force = "two-way", + CV = FALSE, r = 1, se = TRUE, + vartype = "parametric", nboots = nboots, parallel = FALSE, seed = seed, + time.component.from = "nevertreated" + ) ) } diff --git a/tests/testthat/test-cran.R b/tests/testthat/test-cran.R new file mode 100644 index 00000000..2b040e46 --- /dev/null +++ b/tests/testthat/test-cran.R @@ -0,0 +1,26 @@ +## Minimal CRAN smoke tests for fect. +## +## This is the ONLY test file that runs on CRAN: tests/testthat.R filters the +## suite to this file when NOT_CRAN is unset (see that driver). Keep it fast and +## dependency-light -- a single core fit and the print method. The full +## regression suite (every other test-*.R) runs locally and in CI, where +## NOT_CRAN=true. + +library(testthat) +data(simdata, package = "fect") + +test_that("core fect() fit runs and returns the expected structure", { + out <- fect::fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), + method = "fe", force = "two-way", se = FALSE, parallel = FALSE) + expect_s3_class(out, "fect") + expect_true(is.matrix(out$eff)) + expect_true(is.numeric(out$att.avg)) + expect_true(length(out$time) >= 1L) +}) + +test_that("print.fect() runs without error", { + out <- fect::fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), + method = "fe", force = "two-way", se = FALSE, parallel = FALSE) + printed <- capture.output(print(out)) + expect_type(printed, "character") +}) diff --git a/tests/testthat/test-cv-parallel.R b/tests/testthat/test-cv-parallel.R index 53023668..6aeab5d9 100644 --- a/tests/testthat/test-cv-parallel.R +++ b/tests/testthat/test-cv-parallel.R @@ -1761,3 +1761,103 @@ test_that("N.6: plan restored after sequential IFE and CFE nevertreated parallel expect_equal(plan_before, plan_after, info = "plan should be restored to sequential after CFE nevertreated parallel CV") }) + + +## ================================================================= +## Section B: v2.4.3 — quiet_nonpara closure-leak regression +## ================================================================= + +## -- B.1 Parallel bootstrap on simdata under a tight future.globals.maxSize +## cap. With the v2.4.3 trim of quiet_nonpara and the local 2 GiB +## bump, no "future.globals.maxSize" warning should fire even when +## the caller's pre-block cap is small. + +test_that("B.1: parallel bootstrap on simdata does not trip future.globals.maxSize", { + + skip_on_cran() + + ## Force a tight pre-block cap to simulate the failure environment. + ## The v2.4.3 local bump inside do_parallel_boot raises this to 2 GiB + ## for the duration of the parallel block (with on.exit restore). + old_max <- getOption("future.globals.maxSize", 500 * 1024^2) + options(future.globals.maxSize = 50 * 1024^2) # 50 MiB pre-block + on.exit(options(future.globals.maxSize = old_max), add = TRUE) + + ## Clear leaked plan state (defensive, mirrors E.6 / E.7). + suppressWarnings({ + try(future::plan(future::sequential), silent = TRUE) + try(foreach::registerDoSEQ(), silent = TRUE) + }) + + warns <- character(0) + + expect_no_error( + withCallingHandlers( + { + set.seed(42) + suppressMessages( + fect::fect( + Y ~ D, + data = simdata, + index = c("id", "time"), + method = "ife", + r = 1, + CV = FALSE, + se = TRUE, + vartype = "bootstrap", + nboots = 20, + parallel = TRUE + ) + ) + }, + warning = function(w) { + warns <<- c(warns, conditionMessage(w)) + invokeRestart("muffleWarning") + } + ) + ) + + expect_false(any(grepl("future\\.globals\\.maxSize", warns)), + info = paste("warns:", paste(warns, collapse = " | "))) + expect_false(any(grepl("Future backend failed", warns)), + info = paste("warns:", paste(warns, collapse = " | "))) +}) + +## -- B.2 Structural contract: trim_closure_env(), when applied to a +## quiet_nonpara-shaped wrapper defined inside a heavy outer +## frame, keeps ONLY the two referenced locals (one.nonpara, +## boot.seq) and drops the rest. Locks in the invariant the +## v2.4.3 fix depends on. + +test_that("B.2: trim_closure_env strips fect_boot frame from quiet_nonpara-shape closure", { + + ## Reproduce the shape of fect_boot()'s local frame: heavy locals + ## around a wrapper that only references `one.nonpara` and `boot.seq`. + outer_fn <- function() { + Y <- matrix(rnorm(1e4), 100, 100) + D <- matrix(rnorm(1e4), 100, 100) + big_out <- as.list(seq_len(1e4)) + boot.seq <- 1:20 + one.nonpara <- function(j) j + quiet_nonpara <- function(j) { + suppressMessages(suppressWarnings(one.nonpara(boot.seq[j]))) + } + quiet_nonpara <- fect:::trim_closure_env(quiet_nonpara) + quiet_nonpara + } + + qn <- outer_fn() + env_names <- ls(environment(qn), all.names = TRUE) + + ## The trimmed env should hold ONLY the two referenced locals. + expect_setequal(env_names, c("one.nonpara", "boot.seq")) + + ## And it should NOT carry the heavy frame objects. + expect_false("Y" %in% env_names) + expect_false("D" %in% env_names) + expect_false("big_out" %in% env_names) + + ## Size sanity: trimmed closure stays small (< 1 MiB). + expect_lt(as.numeric(object.size(qn)), 1 * 1024^2) +}) + diff --git a/tests/testthat/test-estimand-att-cumu.R b/tests/testthat/test-estimand-att-cumu.R index d83b6924..a744c21d 100644 --- a/tests/testthat/test-estimand-att-cumu.R +++ b/tests/testthat/test-estimand-att-cumu.R @@ -62,7 +62,12 @@ test_that("AC.2: estimand(fit, 'att.cumu', 'event.time') matches effect(fit)", { skip_on_cran() fit <- .fit_no_reversal() - est <- fect::estimand(fit, "att.cumu", "event.time") + ## ci.method = "percentile" replicates the raw-quantile CI used by the + ## legacy effect() function. v2.4.2 changed the default to "basic" + ## (reflected pivot CI per Davison-Hinkley 1997 §5.2.1), so byte-equality + ## with effect() requires the explicit override. + est <- fect::estimand(fit, "att.cumu", "event.time", + ci.method = "percentile") out_eff <- suppressWarnings(suppressMessages( fect::effect(fit, cumu = TRUE, plot = FALSE) )) @@ -101,7 +106,10 @@ test_that("AC.3: estimand(fit, 'att.cumu', 'overall', window) matches att.cumu() fit <- .fit_no_reversal() period <- c(1, 5) - est <- fect::estimand(fit, "att.cumu", "overall", window = period) + ## ci.method = "percentile" replicates the raw-quantile CI used by the + ## legacy att.cumu() function (see AC.2 comment for context). + est <- fect::estimand(fit, "att.cumu", "overall", window = period, + ci.method = "percentile") out_acc <- suppressWarnings(suppressMessages( fect::att.cumu(fit, period = period, plot = FALSE) )) diff --git a/tests/testthat/test-estimand-ci-methods.R b/tests/testthat/test-estimand-ci-methods.R new file mode 100644 index 00000000..f43725c5 --- /dev/null +++ b/tests/testthat/test-estimand-ci-methods.R @@ -0,0 +1,277 @@ +## --------------------------------------------------------------- +## Tests for v2.4.2 ci.method extensions and per-type defaults. +## +## v2.4.2 adds two ci.method values --- "bc" (bias-corrected +## percentile) and "normal" (Wald) --- and switches the per-type +## default (NULL trigger): att -> normal, att.cumu -> percentile, +## aptt -> bc, log.att -> bc. +## +## See statsclaw-workspace/fect/ref/v242-vartype-cimethod-design.md +## --------------------------------------------------------------- + +suppressWarnings(data("simdata", package = "fect")) + + +.fit_canonical <- function(nboots = 100, keep.sims = TRUE) { + set.seed(42) + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, data = simdata, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, nboots = nboots, parallel = FALSE, + keep.sims = keep.sims + ) + )) +} + +## Positive-Y panel for log.att tests (avoids cell-drop hard-error). +.fit_positive_Y <- function(nboots = 30) { + set.seed(7) + N <- 30; TT <- 20 + df <- expand.grid(id = 1:N, time = 1:TT) + treat_start <- sample(c(NA, 8:15), N, replace = TRUE) + df$D <- ifelse(is.na(treat_start[df$id]) | df$time < treat_start[df$id], + 0, 1) + df$Y <- exp(2.0 + 0.05 * df$time + 0.3 * df$D + rnorm(nrow(df), sd = 0.1)) + set.seed(42) + suppressWarnings(suppressMessages( + fect::fect(Y ~ D, data = df, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, nboots = nboots, parallel = FALSE, + keep.sims = TRUE) + )) +} + + +## -- CI.1 ci.method enum accepts the four values -------------------- + +test_that("CI.1: ci.method accepts basic / percentile / bc / normal", { + + skip_on_cran() + + fit <- .fit_canonical() + for (m in c("basic", "percentile", "bc", "normal")) { + res <- fect::estimand(fit, "att", "overall", window = c(1, 5), + ci.method = m) + expect_s3_class(res, "data.frame") + expect_true(!is.na(res$estimate)) + expect_true(!is.na(res$se)) + } +}) + + +## -- CI.2 ci.method = NULL triggers per-type defaults ---------------- + +test_that("CI.2: ci.method = NULL gives type-specific defaults", { + + skip_on_cran() + + fit <- .fit_canonical() + + ## att -> normal: should match the Wald CI from fit$est.att passthrough + res_att <- fect::estimand(fit, "att", "event.time") + ## Compare to explicit normal: should be identical (fast path same numbers) + res_att_normal <- fect::estimand(fit, "att", "event.time", + ci.method = "normal") + expect_equal(res_att$estimate, res_att_normal$estimate) + expect_equal(res_att$se, res_att_normal$se) + expect_equal(res_att$ci.lo, res_att_normal$ci.lo) + expect_equal(res_att$ci.hi, res_att_normal$ci.hi) +}) + + +test_that("CI.2b: att overall default = normal differs from basic", { + + skip_on_cran() + + fit <- .fit_canonical() + + res_default <- fect::estimand(fit, "att", "overall", window = c(1, 5)) + res_basic <- fect::estimand(fit, "att", "overall", window = c(1, 5), + ci.method = "basic") + res_normal <- fect::estimand(fit, "att", "overall", window = c(1, 5), + ci.method = "normal") + + ## Default for att is normal; should equal the explicit normal. + expect_equal(res_default$ci.lo, res_normal$ci.lo) + expect_equal(res_default$ci.hi, res_normal$ci.hi) + ## Basic and normal will generally differ. + expect_false(isTRUE(all.equal(res_basic$ci.lo, res_normal$ci.lo))) +}) + + +## -- CI.3 normal CI: ci.lo = est - z*SE, ci.hi = est + z*SE ---------- + +test_that("CI.3: normal CI is symmetric around the point estimate", { + + skip_on_cran() + + fit <- .fit_canonical() + res <- fect::estimand(fit, "att", "overall", window = c(1, 5), + ci.method = "normal") + + z <- stats::qnorm(0.975) + expect_equal(res$ci.lo, res$estimate - z * res$se, tolerance = 1e-10) + expect_equal(res$ci.hi, res$estimate + z * res$se, tolerance = 1e-10) +}) + + +## -- CI.4 bc CI: when bootstrap is symmetric around point, bc ~ percentile + +test_that("CI.4: bc CI ~ percentile when bootstrap median = point estimate", { + + skip_on_cran() + + ## Use the internal helper with a large symmetric bootstrap. bc reduces + ## to percentile when z0 = 0 (i.e., bootstrap median = point). With + ## finite Monte Carlo noise the median isn't exactly the mean, so tol + ## is loosened to 0.05 (5% of one bootstrap SD). + set.seed(1) + boot <- rnorm(5000, mean = 0.5, sd = 0.1) + ci_pct <- fect:::.compute_ci(estimate = 0.5, boot = boot, + ci.method = "percentile", + conf.level = 0.95) + ci_bc <- fect:::.compute_ci(estimate = 0.5, boot = boot, + ci.method = "bc", + conf.level = 0.95) + expect_equal(ci_pct$ci.lo, ci_bc$ci.lo, tolerance = 0.05) + expect_equal(ci_pct$ci.hi, ci_bc$ci.hi, tolerance = 0.05) +}) + + +## -- CI.5 bc CI: shifts cutoffs when bootstrap is biased -------------- + +test_that("CI.5: bc shifts cutoffs when bootstrap median != point estimate", { + + skip_on_cran() + + ## Bootstrap centered at 0.5, but point is at 0.7 (above bootstrap median). + ## bc should shift cutoffs UP from raw percentile. + set.seed(2) + boot <- rnorm(1000, mean = 0.5, sd = 0.1) + ci_pct <- fect:::.compute_ci(estimate = 0.7, boot = boot, + ci.method = "percentile", + conf.level = 0.95) + ci_bc <- fect:::.compute_ci(estimate = 0.7, boot = boot, + ci.method = "bc", + conf.level = 0.95) + expect_true(ci_bc$ci.lo > ci_pct$ci.lo) + expect_true(ci_bc$ci.hi > ci_pct$ci.hi) +}) + + +## -- CI.6 vartype column reports method actually used at fit time ---- + +test_that("CI.6: vartype column reports the fit-time vartype regardless of ci.method", { + + skip_on_cran() + + fit <- .fit_canonical() + for (m in c("basic", "percentile", "bc", "normal")) { + res <- fect::estimand(fit, "att", "overall", window = c(1, 5), + ci.method = m) + expect_true(res$vartype %in% + c("bootstrap", "jackknife", "parametric")) + } +}) + + +## -- CI.7 cell-drop hard-error fires for log.att on negative-Y data -- + +test_that("CI.7: log.att on simdata triggers point-level hard-error (v2.4.2+)", { + + skip_on_cran() + + ## simdata has cells with Y <= 0 in the treated post-treatment window; + ## v2.4.2's point-estimate-level hard-error fires before any bootstrap + ## work. The bootstrap-level "log-ATT bootstrap is unreliable" message + ## remains in R/po-estimands.R for strictly-positive panels where + ## Y0_b crosses zero only in some replicates. + fit_neg <- .fit_canonical() + expect_error( + fect::estimand(fit_neg, "log.att", "event.time"), + "log\\.att requires Y > 0" + ) +}) + + +test_that("CI.7b: log.att works on a positive-Y panel (no cell-drop pathology)", { + + skip_on_cran() + + fit_pos <- .fit_positive_Y(nboots = 30) + res <- fect::estimand(fit_pos, "log.att", "event.time") + + expect_s3_class(res, "data.frame") + expect_true(any(!is.na(res$estimate))) + expect_true(any(res$n_cells > 0)) +}) + + +## -- CI.8 nboots default is 200 (v2.4.2) ----------------------------- + +test_that("CI.8: fect()'s nboots default is 200", { + ## Cheap arg-validation; doesn't need a fit. fect.formula and + ## fect.default are S3 methods, accessed via getS3method(). + ## v2.4.2 keeps nboots = 200 as default (unchanged from v2.4.1). + ## Sufficient for SE / normal CI; bump to 1000+ for tail-quantile + ## CIs accessed via estimand(). See CI.9-CI.11 for the warning gate. + expect_equal(as.character(formals(fect::fect)$nboots), "200") + expect_equal(as.character(formals(getS3method("fect", "formula"))$nboots), + "200") + expect_equal(as.character(formals(getS3method("fect", "default"))$nboots), + "200") +}) + + +## -- CI.9 estimand() warns on tail-CI methods at nboots < 1000 ------- +## by = "overall" used because by = "event.time" + non-normal ci.method +## falls through to a "not yet implemented" path at this commit. + +test_that("CI.9: estimand() warns on tail-CI methods with nboots < 1000", { + skip_on_cran() + fit_small <- .fit_canonical(nboots = 100) + ## The warning is gated on Sys.getenv("TESTTHAT") inside estimand() to + ## keep the suite-wide summary clean. Temporarily unset the env var here + ## so the warning fires and can be asserted. + withr::with_envvar(c(TESTTHAT = "false"), { + for (m in c("basic", "percentile", "bc", "bca")) { + expect_warning( + fect::estimand(fit_small, "att", "overall", window = c(1, 5), + ci.method = m), + "tail-quantile-based CIs may have" + ) + } + }) +}) + + +## -- CI.10 estimand() does NOT warn on normal CI --------------------- + +test_that("CI.10: normal CI does not trigger the under-replication warning", { + skip_on_cran() + fit_small <- .fit_canonical(nboots = 100) + expect_warning( + fect::estimand(fit_small, "att", "overall", window = c(1, 5), + ci.method = "normal"), + NA ## NA = no warning expected + ) +}) + + +## -- CI.11 estimand() does NOT warn at nboots >= 1000 ---------------- + +test_that("CI.11: tail-CI methods at nboots >= 1000 do not warn", { + skip_on_cran() + fit_big <- .fit_canonical(nboots = 1000) + expect_warning( + fect::estimand(fit_big, "att", "overall", window = c(1, 5), + ci.method = "bca"), + NA + ) + expect_warning( + fect::estimand(fit_big, "att", "overall", window = c(1, 5), + ci.method = "percentile"), + NA + ) +}) diff --git a/tests/testthat/test-estimand-jackknife.R b/tests/testthat/test-estimand-jackknife.R new file mode 100644 index 00000000..a6d7ac00 --- /dev/null +++ b/tests/testthat/test-estimand-jackknife.R @@ -0,0 +1,425 @@ +## --------------------------------------------------------------- +## Tests for estimand() and imputed_outcomes() behavior on jackknife fits. +## +## Covers: +## J.1 Slot contract: jackknife eff.boot passes .validate_po_contract +## J.2 Fast path: event.time + normal is byte-equal to fit$est.att +## J.3 Overall path: returns finite Wald CI +## J.4 ci.method guard: bca hard-errors with explanation +## J.5 ci.method guard: percentile hard-errors with explanation +## J.6 ci.method guard: basic hard-errors +## J.7 ci.method guard: bc hard-errors +## J.8 imputed_outcomes(replicates = TRUE) hard-errors +## J.9 Overall with cells window: returns finite Wald CI +## J.10 aptt event.time under jackknife +## J.11 log.att event.time under jackknife +## J.12 Anti-regression: bootstrap estimand still works after fix +## --------------------------------------------------------------- + +## DGP-A: balanced two-way FE, true ATT = 3.0 +.make_jackknife_data <- function(seed = 42, N = 40, TT = 20, tr_start = 11, + tau = 3.0) { + set.seed(seed) + time_idx <- rep(1:TT, each = N) + unit_idx <- rep(1:N, times = TT) + is_treated <- unit_idx <= (N / 2) + D <- as.integer(is_treated & time_idx >= tr_start) + alpha_i <- rnorm(N, sd = 1) + gamma_t <- rnorm(TT, sd = 0.5) + Y0 <- outer(gamma_t, alpha_i, "+") + rnorm(TT * N, sd = 0.5) + Y <- as.vector(Y0) + tau * D + data.frame(Y = Y, D = D, id = unit_idx, time = time_idx) +} + +.fit_jack <- function(simdata, keep.sims = TRUE) { + set.seed(1) + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, data = simdata, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, vartype = "jackknife", + parallel = FALSE, keep.sims = keep.sims, CV = FALSE + ) + )) +} + +.fit_boot <- function(simdata, nboots = 50, keep.sims = TRUE) { + set.seed(1) + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, data = simdata, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, vartype = "bootstrap", nboots = nboots, + parallel = FALSE, keep.sims = keep.sims, CV = FALSE + ) + )) +} + +simdata_A <- .make_jackknife_data() + + +## -- J.1 Slot contract passes for jackknife eff.boot --------------- + +test_that("J.1: .validate_po_contract passes for jackknife fit", { + skip_on_cran() + fit <- .fit_jack(simdata_A) + ## Slot contract is called inside estimand(); if it fails we'd get an error. + ## Calling the fast path (no eff.boot needed) is sufficient to confirm no error. + expect_no_error(fect::estimand(fit, "att", "event.time", ci.method = "normal")) + ## Also confirm eff.boot dimensions match jackknife expectation. + expect_equal(dim(fit$eff.boot)[3], ncol(fit$Y.dat)) ## third dim = N + expect_equal(dim(fit$eff.boot)[2], ncol(fit$Y.dat) - 1L) ## second dim = N-1 +}) + + +## -- J.2 Fast path: event.time + normal byte-equals fit$est.att ---- + +test_that("J.2: event.time + normal is byte-equal to fit$est.att", { + skip_on_cran() + fit <- .fit_jack(simdata_A) + est <- fect::estimand(fit, "att", "event.time", ci.method = "normal") + + tol <- 1e-10 + expect_equal(nrow(est), nrow(fit$est.att)) + expect_equal(est$event.time, as.numeric(rownames(fit$est.att))) + expect_lt(max(abs(est$estimate - unname(fit$est.att[, "ATT"]))), tol) + expect_lt(max(abs(est$se - unname(fit$est.att[, "S.E."]))), tol) + expect_lt(max(abs(est$ci.lo - unname(fit$est.att[, "CI.lower"]))), tol) + expect_lt(max(abs(est$ci.hi - unname(fit$est.att[, "CI.upper"]))), tol) + expect_true(all(est$vartype == "jackknife")) +}) + + +## -- J.3 Overall path: returns finite Wald CI ---------------------- + +test_that("J.3: overall + normal returns finite Wald CI", { + skip_on_cran() + fit <- .fit_jack(simdata_A) + est <- fect::estimand(fit, "att", "overall", ci.method = "normal") + + expect_equal(nrow(est), 1L) + expect_true(is.finite(est$estimate)) + expect_true(is.finite(est$se) && est$se > 0) + expect_true(est$ci.lo < est$estimate) + expect_true(est$estimate < est$ci.hi) + expect_equal(est$vartype, "jackknife") + + ## Wald consistency: ci width == 2 * z * se + expected_width <- 2 * stats::qnorm(0.975) * est$se + expect_lt(abs((est$ci.hi - est$ci.lo) - expected_width), 1e-10) + + ## Point estimate matches mean(eff[treated]) + D_mat <- fit$D.dat + treated_mean <- mean(fit$eff[!is.na(D_mat) & D_mat == 1], na.rm = TRUE) + expect_lt(abs(est$estimate - treated_mean), 1e-10) +}) + + +## -- J.4 ci.method guard: bca hard-errors -------------------------- + +test_that("J.4: ci.method = 'bca' hard-errors for jackknife fit", { + skip_on_cran() + fit <- .fit_jack(simdata_A) + err <- tryCatch( + fect::estimand(fit, "att", "event.time", ci.method = "bca"), + error = function(e) conditionMessage(e) + ) + expect_match(err, "jackknife", ignore.case = TRUE) + expect_match(err, "standard error|SE|sampling distribution", ignore.case = TRUE) + expect_match(err, "normal", ignore.case = TRUE) +}) + + +## -- J.5 ci.method guard: percentile hard-errors ------------------- + +test_that("J.5: ci.method = 'percentile' hard-errors for jackknife fit", { + skip_on_cran() + fit <- .fit_jack(simdata_A) + err <- tryCatch( + fect::estimand(fit, "att", "event.time", ci.method = "percentile"), + error = function(e) conditionMessage(e) + ) + expect_match(err, "jackknife", ignore.case = TRUE) + expect_match(err, "normal", ignore.case = TRUE) +}) + + +## -- J.6 ci.method guard: basic hard-errors ------------------------ + +test_that("J.6: ci.method = 'basic' hard-errors for jackknife fit", { + skip_on_cran() + fit <- .fit_jack(simdata_A) + err <- tryCatch( + fect::estimand(fit, "att", "event.time", ci.method = "basic"), + error = function(e) conditionMessage(e) + ) + expect_match(err, "jackknife", ignore.case = TRUE) +}) + + +## -- J.7 ci.method guard: bc hard-errors --------------------------- + +test_that("J.7: ci.method = 'bc' hard-errors for jackknife fit", { + skip_on_cran() + fit <- .fit_jack(simdata_A) + err <- tryCatch( + fect::estimand(fit, "att", "event.time", ci.method = "bc"), + error = function(e) conditionMessage(e) + ) + expect_match(err, "jackknife", ignore.case = TRUE) +}) + + +## -- J.8 imputed_outcomes(replicates = TRUE) hard-errors ----------- + +test_that("J.8: imputed_outcomes(replicates = TRUE) hard-errors for jackknife", { + skip_on_cran() + fit <- .fit_jack(simdata_A) + err <- tryCatch( + fect::imputed_outcomes(fit, replicates = TRUE), + error = function(e) conditionMessage(e) + ) + expect_match(err, "jackknife", ignore.case = TRUE) + expect_match(err, "column|N-1|dimension", ignore.case = TRUE) +}) + + +## -- J.9 Overall + cells window: returns finite Wald CI ------------ + +test_that("J.9: overall + window returns finite Wald CI from cells-filter branch", { + skip_on_cran() + fit <- .fit_jack(simdata_A) + est_full <- fect::estimand(fit, "att", "overall", ci.method = "normal") + est_window <- fect::estimand(fit, "att", "overall", ci.method = "normal", + window = c(1, 5)) + + expect_equal(nrow(est_window), 1L) + expect_true(is.finite(est_window$estimate)) + expect_true(is.finite(est_window$se) && est_window$se > 0) + expect_true(est_window$ci.lo < est_window$estimate) + expect_true(est_window$estimate < est_window$ci.hi) + + ## Wald consistency + expected_width <- 2 * stats::qnorm(0.975) * est_window$se + expect_lt(abs((est_window$ci.hi - est_window$ci.lo) - expected_width), 1e-10) + + ## Window estimate differs from full estimate (different cell set) + expect_false(isTRUE(all.equal(est_window$estimate, est_full$estimate))) +}) + + +## -- J.10 aptt event.time under jackknife --------------------------- + +test_that("J.10: aptt event.time returns finite SE/CI under jackknife", { + skip_on_cran() + ## DGP-B: Y > 0 everywhere for aptt + set.seed(42) + simdata_B <- simdata_A + simdata_B$Y <- abs(simdata_A$Y) + 5 + fit <- .fit_jack(simdata_B) + + est <- fect::estimand(fit, "aptt", "event.time", ci.method = "normal") + expect_s3_class(est, "data.frame") + expect_true(all(est$vartype == "jackknife")) + + post_rows <- est[!is.na(est$se) & is.finite(est$se), ] + expect_gt(nrow(post_rows), 0L) + ## All finite-SE rows have valid CIs + expect_true(all(post_rows$ci.lo < post_rows$estimate)) + expect_true(all(post_rows$estimate < post_rows$ci.hi)) + ## Wald consistency for all finite-SE rows + widths <- post_rows$ci.hi - post_rows$ci.lo + expected <- 2 * stats::qnorm(0.975) * post_rows$se + expect_lt(max(abs(widths - expected)), 1e-10) +}) + + +## -- J.11 log.att event.time under jackknife ------------------------ + +test_that("J.11: log.att event.time returns finite SE/CI under jackknife", { + skip_on_cran() + set.seed(42) + simdata_B <- simdata_A + simdata_B$Y <- abs(simdata_A$Y) + 5 + fit <- .fit_jack(simdata_B) + + est <- fect::estimand(fit, "log.att", "event.time", ci.method = "normal") + expect_s3_class(est, "data.frame") + expect_true(all(est$vartype == "jackknife")) + + post_rows <- est[!is.na(est$se) & is.finite(est$se), ] + expect_gt(nrow(post_rows), 0L) + expect_true(all(post_rows$ci.lo < post_rows$estimate)) + expect_true(all(post_rows$estimate < post_rows$ci.hi)) + ## Wald consistency + widths <- post_rows$ci.hi - post_rows$ci.lo + expected <- 2 * stats::qnorm(0.975) * post_rows$se + expect_lt(max(abs(widths - expected)), 1e-10) +}) + + +## -- J.12 Anti-regression: bootstrap estimand still works ---------- + +test_that("J.12: bootstrap estimand (att, event.time) unaffected by jackknife fix", { + skip_on_cran() + fit <- .fit_boot(simdata_A) + est <- fect::estimand(fit, "att", "event.time") + + tol <- 1e-10 + expect_equal(nrow(est), nrow(fit$est.att)) + expect_lt(max(abs(est$estimate - unname(fit$est.att[, "ATT"]))), tol) + expect_true(all(est$vartype == "bootstrap")) + + ## overall also works + est_ov <- fect::estimand(fit, "att", "overall") + expect_true(is.finite(est_ov$estimate)) + expect_true(is.finite(est_ov$se)) +}) + + + + +## -- S-11 extended Anti-regression: bootstrap path unchanged ------------------- +## Tests the three calls from test-spec.md §13: +## est_boot_et (att, event.time, default ci.method) +## est_boot_ov (att, overall, default ci.method) +## est_boot_pct (att, overall, ci.method = "percentile") +## +## Note: estimand(boot, "att", "event.time", ci.method="percentile") currently +## raises "not yet implemented" for by="event.time" + non-normal ci.method on +## a non-placebo/carryover test (pre-existing limitation, not a regression +## introduced by the jackknife fix). We use by="overall" + "percentile" instead, +## which IS supported and exercises the same downstream .compute_ci() code path. + +test_that("S-11: bootstrap att/event.time byte-equals fit$est.att (anti-regression)", { + skip_on_cran() + fit <- .fit_boot(simdata_A, nboots = 200) + est_boot_et <- fect::estimand(fit, "att", "event.time") + expect_s3_class(est_boot_et, "data.frame") + tol <- 1e-10 + expect_lt(max(abs(est_boot_et$estimate - unname(fit$est.att[, "ATT"]))), tol) + expect_true(all(est_boot_et$vartype == "bootstrap")) +}) + +test_that("S-11: bootstrap att/overall is finite (anti-regression)", { + skip_on_cran() + fit <- .fit_boot(simdata_A, nboots = 200) + est_boot_ov <- fect::estimand(fit, "att", "overall") + expect_true(is.finite(est_boot_ov$estimate)) + expect_true(is.finite(est_boot_ov$se)) + expect_equal(est_boot_ov$vartype, "bootstrap") +}) + +test_that("S-11: bootstrap att/overall percentile returns valid CI (anti-regression)", { + skip_on_cran() + fit <- .fit_boot(simdata_A, nboots = 200) + est_boot_pct <- fect::estimand(fit, "att", "overall", + ci.method = "percentile") + expect_s3_class(est_boot_pct, "data.frame") + expect_equal(est_boot_pct$vartype, "bootstrap") + expect_true(is.finite(est_boot_pct$ci.lo)) + expect_true(is.finite(est_boot_pct$ci.hi)) +}) + + +## -- S-12 Anti-regression: parametric fit unchanged ------------------------- +## Parametric bootstrap requires never-treated control units, so we use a DGP +## where only 12 of 40 units are treated (units 1..12, periods 13..20), leaving +## 28 never-treated controls. This matches the DGP convention from +## test-estimand-parametric-cifix.R (make_panel_A). + +.make_param_data <- function(seed = 42) { + set.seed(seed) + N <- 40L; TT <- 20L; T0 <- 12L; Ntr <- 12L + alpha_i <- rnorm(N, 0, 2) + xi_t <- rnorm(TT, 0, 1) + D <- matrix(0L, TT, N) + D[(T0 + 1L):TT, 1L:Ntr] <- 1L + eps <- matrix(rnorm(N * TT, 0, 1), TT, N) + Y <- outer(xi_t, rep(1, N)) + outer(rep(1, TT), alpha_i) + 3.0 * D + eps + data.frame(id = rep(1:N, each = TT), + time = rep(1:TT, N), + Y = as.vector(Y), + D = as.vector(D)) +} + +.fit_param_s12 <- local({ + cached <- NULL + function() { + if (!is.null(cached)) return(cached) + skip_on_cran() + d <- .make_param_data() + set.seed(42) + cached <<- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, data = d, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, vartype = "parametric", nboots = 200, + time.component.from = "nevertreated", + parallel = FALSE, keep.sims = TRUE, CV = FALSE + ) + )) + cached + } +}) + +test_that("S-12: parametric fit estimand(att, event.time) returns 'parametric' vartype", { + skip_on_cran() + fit <- .fit_param_s12() + est <- fect::estimand(fit, "att", "event.time") + expect_s3_class(est, "data.frame") + expect_true(all(est$vartype == "parametric")) +}) + +test_that("S-12: parametric fit estimand(att, overall) is finite and 'parametric'", { + skip_on_cran() + fit <- .fit_param_s12() + est <- fect::estimand(fit, "att", "overall") + expect_s3_class(est, "data.frame") + expect_true(is.finite(est$estimate)) + expect_true(is.finite(est$se)) + expect_equal(est$vartype, "parametric") +}) + + +## -- S-SIM 100-rep coverage simulation: jackknife + normal, DGP-A ----------- +## +## Acceptance criterion: coverage_jack >= 0.85 (true ATT = 3.0). +## Uses fit$est.avg to avoid any slot-contract overhead inside the loop; +## after the fix this equals estimand(fit, "att", "overall")$ci.lo/ci.hi. + +.run_coverage_jack <- function(seed, N = 40, TT = 20, tau = 3.0, + tr_start = 11) { + set.seed(seed) + n_treated <- N / 2 + unit_idx <- rep(1:N, times = TT) + time_idx <- rep(1:TT, each = N) + is_treated <- unit_idx <= n_treated + D <- as.integer(is_treated & time_idx >= tr_start) + alpha_i <- rnorm(N, sd = 1) + gamma_t <- rnorm(TT, sd = 0.5) + Y0 <- outer(gamma_t, alpha_i, "+")[cbind(time_idx, unit_idx)] + + rnorm(N * TT, sd = 0.5) + Y <- Y0 + tau * D + dat <- data.frame(Y = Y, D = D, id = unit_idx, time = time_idx) + fit <- suppressWarnings(suppressMessages( + fect::fect(Y ~ D, data = dat, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, vartype = "jackknife", + parallel = FALSE, keep.sims = FALSE, CV = FALSE) + )) + att_avg <- fit$est.avg[1, "ATT.avg"] + ci_lo <- fit$est.avg[1, "CI.lower"] + ci_hi <- fit$est.avg[1, "CI.upper"] + list(att = att_avg, covered = tau >= ci_lo & tau <= ci_hi) +} + +test_that("S-SIM: jackknife + normal CI coverage >= 0.85 on DGP-A (100 reps)", { + skip_on_cran() + R <- 100L + results <- lapply(seq_len(R), .run_coverage_jack) + coverage_jack <- mean(sapply(results, `[[`, "covered")) + expect_gte(coverage_jack, 0.85, + label = paste0("jackknife coverage = ", round(coverage_jack, 3), + " (must be >= 0.85)")) +}) diff --git a/tests/testthat/test-estimand-log-att.R b/tests/testthat/test-estimand-log-att.R index 43852f8c..a367cca1 100644 --- a/tests/testthat/test-estimand-log-att.R +++ b/tests/testthat/test-estimand-log-att.R @@ -16,7 +16,10 @@ treat_start <- sample(c(NA, 8:15), N, replace = TRUE) df$D <- ifelse(is.na(treat_start[df$id]) | df$time < treat_start[df$id], 0, 1) - df$Y <- exp(0.5 + 0.05 * df$time + 0.3 * df$D + rnorm(nrow(df), sd = 0.2)) + ## Higher intercept (2.0) and smaller noise (0.1) keep Y comfortably + ## positive so the v2.4.2 cell-drop hard-error doesn't fire on benign + ## bootstrap noise. + df$Y <- exp(2.0 + 0.05 * df$time + 0.3 * df$D + rnorm(nrow(df), sd = 0.1)) set.seed(42) suppressWarnings(suppressMessages( fect::fect( @@ -89,13 +92,17 @@ test_that("LA.3: log.att without keep.sims errors with the locked wording", { }) -## -- LA.4 Negative Y cells: warning + drop ------------------------- +## -- LA.4 Negative Y cells trigger the v2.4.2 hard-error ----------- -test_that("LA.4: negative Y cells trigger a one-time warning and are dropped", { +test_that("LA.4: negative Y cells trigger point-level hard-error (v2.4.2+)", { skip_on_cran() - ## simdata has negative Y values. + ## simdata has negative Y values, so log-ATT triggers the v2.4.2 + ## point-estimate-level hard-error before any bootstrap work. The + ## bootstrap-level "log-ATT bootstrap is unreliable" path still + ## exists in R/po-estimands.R for strictly-positive panels where + ## Y0_b crosses zero only in some bootstrap replicates. data("simdata", package = "fect") set.seed(42) fit_neg <- suppressWarnings(suppressMessages( @@ -105,9 +112,8 @@ test_that("LA.4: negative Y cells trigger a one-time warning and are dropped", { keep.sims = TRUE) )) - expect_warning( + expect_error( fect::estimand(fit_neg, "log.att", "event.time"), - "dropped", - fixed = FALSE + "log\\.att requires Y > 0" ) }) diff --git a/tests/testthat/test-estimand-parametric-cifix.R b/tests/testthat/test-estimand-parametric-cifix.R new file mode 100644 index 00000000..ca1d16a8 --- /dev/null +++ b/tests/testthat/test-estimand-parametric-cifix.R @@ -0,0 +1,552 @@ +## --------------------------------------------------------------------------- +## v2.4.2 post-hoc fix: parametric bootstrap CI calibration +## +## The pre-fix code passed eff.boot (H0-centered) directly to .compute_ci() +## for all ci.methods except "normal". This caused percentile/basic/bc/bca +## CIs to be anchored near zero instead of near the point estimate, giving +## 0% coverage for non-zero ATTs. +## +## The fix (R/po-estimands.R): for vartype="parametric", shift att_b by +## att_b <- att_b - mean(att_b) + estimate +## before calling .compute_ci(). This re-centers the distribution while +## preserving sd(), so "normal" CIs are unaffected. +## +## Tests in this file (from test-spec.md §3-§8): +## P-INV-1 normal CI satisfies Wald structure exactly +## P-INV-2 point estimate unchanged by fix +## P-INV-3 se is identical for normal and basic (shift preserves sd) +## P-INV-4 .compute_ci() with mock distribution: shifted vs unshifted +## P-INV-5 bca jackknife path produces non-degenerate CI +## P-EDGE-2 vartype="none" still returns NA for SE/CI +## P-EDGE-3 bca on very small nboots does not hard-error +## P-EDGE-4 shift does not affect vartype="bootstrap" fits +## P-REG-1 pre-fix degenerate coverage is eliminated (smoke test, 5 reps) +## P-COV-1 coverage >=0.85 for {basic,percentile,bca,normal}, DGP-A, fe +## P-COV-2 coverage >=0.85 for bca, DGP-G, gsynth +## P-COV-3 coverage >=0.75 for bca on aptt, DGP-B-positive +## P-WIDTH-1 CI widths within 15% of bootstrap widths +## --------------------------------------------------------------------------- + +## ---- DGP helpers ------------------------------------------------------------ + +## DGP-A: two-way FE, additive, true ATT = 3.0 +make_panel_A <- function(seed) { + set.seed(seed) + N <- 40; TT <- 20; T0 <- 12; Ntr <- 12 + alpha_i <- rnorm(N, 0, 2) + xi_t <- rnorm(TT, 0, 1) + D <- matrix(0L, TT, N); D[(T0 + 1):TT, 1:Ntr] <- 1L + eps <- matrix(rnorm(N * TT, 0, 1), TT, N) + Y <- outer(xi_t, rep(1, N)) + outer(rep(1, TT), alpha_i) + 3.0 * D + eps + data.frame(id = rep(1:N, each = TT), time = rep(1:TT, N), + Y = as.vector(Y), D = as.vector(D)) +} + +## DGP-G: interactive fixed effects with factor structure, true ATT = 3.0 +make_panel_G <- function(seed, r = 2) { + set.seed(seed) + N <- 40; TT <- 20; T0 <- 12; Ntr <- 12 + Lambda <- matrix(rnorm(N * r, 0, 1), N, r) + F_t <- matrix(rnorm(TT * r, 0, 1), TT, r) + eps <- matrix(rnorm(N * TT, 0, 0.5), TT, N) + Y0 <- F_t %*% t(Lambda) + eps + D <- matrix(0L, TT, N); D[(T0 + 1):TT, 1:Ntr] <- 1L + Y <- Y0 + 3.0 * D + data.frame(id = rep(1:N, each = TT), time = rep(1:TT, N), + Y = as.vector(Y), D = as.vector(D)) +} + +## DGP-B-positive: multiplicative effect, true APTT ~ 0.3, true log.ATT ~ log(1.3) +make_panel_B_pos <- function(seed) { + set.seed(seed) + N <- 40; TT <- 20; T0 <- 12; Ntr <- 12 + alpha_i <- rnorm(N, 0, 0.5) + xi_t <- rnorm(TT, 0, 0.3) + eps <- matrix(rnorm(N * TT, 0, 0.5), TT, N) + Y0 <- 20 + outer(xi_t, rep(1, N)) + outer(rep(1, TT), alpha_i) + eps + D <- matrix(0L, TT, N); D[(T0 + 1):TT, 1:Ntr] <- 1L + Y1 <- Y0; Y1[D == 1L] <- Y0[D == 1L] * 1.3 + Y_obs <- pmax(ifelse(D == 1L, Y1, Y0), 1) + treated <- which(D == 1L) + list( + df = data.frame(id = rep(1:N, each = TT), time = rep(1:TT, N), + Y = as.vector(Y_obs), D = as.vector(D)), + true_aptt = mean((Y1[treated] - Y0[treated]) / Y0[treated]), + true_logatt = mean(log(Y1[treated] / Y0[treated])) + ) +} + +## ---- Shared parametric fit helper ------------------------------------------- +## Uses same fixture as test-estimand-parametric.R (.make_parametric_fit()) +## but we define our own per-DGP helper so we can control the seed cleanly. + +.make_parafix_fit <- local({ + cached <- NULL + function() { + if (!is.null(cached)) return(cached) + skip_on_cran() + e <- new.env() + data(sim_linear, package = "fect", envir = e) + set.seed(42) + ## suppressWarnings here covers the "EM did not converge within + ## max.iteration = 5000" warning. The fixture is intentionally small + ## (nboots = 30) and convergence is not what these tests verify --- + ## they check CI-formula invariants on the parametric path. + suppressMessages(suppressWarnings( + fect(Y ~ D, data = e$sim_linear, index = c("id", "time"), + method = "ife", force = "two-way", se = TRUE, + nboots = 30, r = 2, CV = FALSE, keep.sims = TRUE, + vartype = "parametric", + time.component.from = "nevertreated", + parallel = FALSE) + )) + } +}) + +## ---- P-INV-1: normal CI satisfies Wald structure ---------------------------- + +test_that("P-INV-1: normal CI is byte-stable (Wald structure: ci = est +/- z*se)", { + skip_on_cran() + fit <- .make_parafix_fit() + res <- fect::estimand(fit, "att", "overall", window = c(1, 5), + ci.method = "normal") + z <- stats::qnorm(0.975) + expect_equal(res$ci.lo, res$estimate - z * res$se, tolerance = 1e-10, + label = "ci.lo = estimate - z*se") + expect_equal(res$ci.hi, res$estimate + z * res$se, tolerance = 1e-10, + label = "ci.hi = estimate + z*se") + ## Width = 2*z*se + expect_equal(res$ci.hi - res$ci.lo, 2 * z * res$se, tolerance = 1e-10, + label = "CI width = 2*z*se") + ## Non-degenerate + expect_gt(res$ci.hi - res$ci.lo, 1e-6, label = "CI width > 1e-6") +}) + +## ---- P-INV-2: point estimate is unchanged by fix ---------------------------- + +test_that("P-INV-2: point estimate matches mean(fit$eff) at treated cells (fix-invariant)", { + skip_on_cran() + fit <- .make_parafix_fit() + res <- fect::estimand(fit, "att", "overall", window = c(1, 5), + ci.method = "bca") + ## Manual point estimate: mean over treated post-treatment cells with T.on in 1..5 + mask <- fit$D.dat == 1 & + !is.na(fit$T.on) & + fit$T.on >= 1 & + fit$T.on <= 5 + manual_est <- mean(fit$eff[mask], na.rm = TRUE) + expect_equal(res$estimate, manual_est, tolerance = 1e-10, + label = "estimate == mean(eff[treated cells, T.on 1..5])") +}) + +## ---- P-INV-3: se is identical for normal and basic (shift preserves sd) ----- + +test_that("P-INV-3: se is identical for ci.method=normal and ci.method=basic on parametric fit", { + skip_on_cran() + fit <- .make_parafix_fit() + res_normal <- fect::estimand(fit, "att", "overall", window = c(1, 5), + ci.method = "normal") + res_basic <- fect::estimand(fit, "att", "overall", window = c(1, 5), + ci.method = "basic") + expect_equal(res_normal$se, res_basic$se, tolerance = 1e-10, + label = "se(normal) == se(basic): shift preserves sd()") +}) + +## ---- P-INV-4: .compute_ci() mock test: shifted vs unshifted distribution ---- + +test_that("P-INV-4: .compute_ci() shifted distribution contains estimate; unshifted does not", { + skip_on_cran() + set.seed(100) + boot_h0 <- rnorm(500, mean = 0, sd = 0.15) ## H0-centered + estimate <- 2.5 + boot_centered <- boot_h0 - mean(boot_h0) + estimate ## shifted to point estimate + + ci_bc_shifted <- fect:::.compute_ci(estimate, boot_centered, "bc", 0.95) + ci_bc_unshifted <- fect:::.compute_ci(estimate, boot_h0, "bc", 0.95) + + ## Shifted CI contains the estimate + expect_lte(ci_bc_shifted$ci.lo, estimate, + label = "shifted ci.lo <= estimate") + expect_gte(ci_bc_shifted$ci.hi, estimate, + label = "shifted ci.hi >= estimate") + + ## Shifted CI lower bound is close to estimate - 1.96*sd (Wald-like) + expected_lo_approx <- estimate - 1.96 * sd(boot_h0) + expect_equal(ci_bc_shifted$ci.lo, expected_lo_approx, + tolerance = 0.15, ## 15% tolerance: bc differs slightly from Wald + label = "shifted ci.lo near estimate - 1.96*sd(boot_h0)") + + ## Shifted CI is non-degenerate (width > 1e-6) + expect_gt(ci_bc_shifted$ci.hi - ci_bc_shifted$ci.lo, 1e-6, + label = "shifted CI width > 1e-6") + + ## Unshifted (H0-centered) bc on this input would be near-degenerate + ## (pre-fix pathology: tail quantiles all near 0, far from estimate=2.5). + ## .compute_ci() bc has an `is_uncovered` safety fallback that detects + ## CI not covering the estimate and substitutes the Wald CI around the + ## estimate. So the unshifted call now returns a sensible Wald CI even + ## though the input was pathological. We assert the fallback fires. + width_unshifted <- ci_bc_unshifted$ci.hi - ci_bc_unshifted$ci.lo + wald_width <- 2 * 1.96 * sd(boot_h0) + expect_equal(width_unshifted, wald_width, tolerance = 0.05, + label = "H0-centered bc falls back to Wald around estimate") + expect_true(ci_bc_unshifted$ci.lo <= estimate && + estimate <= ci_bc_unshifted$ci.hi, + label = "fallback Wald CI contains the estimate") +}) + +## ---- P-INV-5: bca jackknife path is not broken by the shift ----------------- + +test_that("P-INV-5: bca on parametric fit produces non-degenerate non-NA CI", { + skip_on_cran() + fit <- .make_parafix_fit() + res <- fect::estimand(fit, "att", "overall", window = c(1, 5), + ci.method = "bca") + expect_s3_class(res, "data.frame") + expect_true(!is.na(res$ci.lo), label = "bca ci.lo is not NA") + expect_true(!is.na(res$ci.hi), label = "bca ci.hi is not NA") + expect_true(!is.na(res$se), label = "bca se is not NA") + ## Non-degenerate CI + expect_gt(res$ci.hi - res$ci.lo, 0.01, + label = "bca CI width > 0.01") +}) + +## ---- P-EDGE-2: vartype="none" still returns NA for SE/CI -------------------- + +test_that("P-EDGE-2: vartype='none' returns NA se/ci.lo/ci.hi (unchanged by fix)", { + skip_on_cran() + fit <- .make_parafix_fit() + res <- fect::estimand(fit, "att", "overall", window = c(1, 5), + vartype = "none") + expect_true(!is.na(res$estimate), label = "estimate is not NA with vartype='none'") + expect_true(is.na(res$se), label = "se is NA with vartype='none'") + expect_true(is.na(res$ci.lo), label = "ci.lo is NA with vartype='none'") + expect_true(is.na(res$ci.hi), label = "ci.hi is NA with vartype='none'") +}) + +## ---- P-EDGE-3: bca on tiny nboots does not hard-error ----------------------- + +test_that("P-EDGE-3: bca with nboots=5 does not hard-error (returns NA CI, not crash)", { + skip_on_cran() + ## Fit with very small nboots; bca guard handles sum(valid)==0 or <2 jackknife points + d <- make_panel_A(seed = 77) + set.seed(77) + fit_tiny <- suppressMessages( + fect(Y ~ D, data = d, index = c("id", "time"), + method = "fe", force = "two-way", se = TRUE, + nboots = 5, CV = FALSE, keep.sims = TRUE, + vartype = "parametric", + time.component.from = "nevertreated", + parallel = FALSE) + ) + ## Should NOT throw an error — guard returns NA CI if needed + expect_no_error( + suppressWarnings( + fect::estimand(fit_tiny, "att", "overall", window = c(1, 8), + ci.method = "bca") + ) + ) + res <- suppressWarnings( + fect::estimand(fit_tiny, "att", "overall", window = c(1, 8), + ci.method = "bca") + ) + expect_s3_class(res, "data.frame") + ## estimate is always computable even with tiny nboots + expect_true(!is.na(res$estimate), label = "estimate non-NA even with tiny nboots") +}) + +## ---- P-EDGE-4: shift does NOT affect vartype="bootstrap" fits --------------- + +test_that("P-EDGE-4: shift guard is inactive for vartype='bootstrap' (fits unaffected)", { + skip_on_cran() + d <- make_panel_A(seed = 42) + set.seed(42) + fit_boot <- suppressMessages( + fect(Y ~ D, data = d, index = c("id", "time"), + method = "fe", force = "two-way", se = TRUE, + nboots = 50, CV = FALSE, keep.sims = TRUE, + vartype = "bootstrap", + parallel = FALSE) + ) + expect_equal(fit_boot$vartype, "bootstrap", + label = "fit$vartype is 'bootstrap'") + ## bc on bootstrap: should produce a sensible CI (no shift applied) + res <- fect::estimand(fit_boot, "att", "overall", window = c(1, 8), + ci.method = "bc") + expect_s3_class(res, "data.frame") + expect_true(!is.na(res$ci.lo), label = "bootstrap bc ci.lo non-NA") + expect_true(!is.na(res$ci.hi), label = "bootstrap bc ci.hi non-NA") + expect_gt(res$ci.hi - res$ci.lo, 1e-6, label = "bootstrap bc CI non-degenerate") +}) + +## ---- P-REG-1: pre-fix degenerate coverage is eliminated (5-rep smoke test) -- + +test_that("P-REG-1: bca CI contains true ATT=3 on parametric fit (smoke: 5 reps, DGP-A)", { + skip_on_cran() + true_att <- 3.0 + n_reps <- 5L + in_ci <- logical(n_reps) + for (r in seq_len(n_reps)) { + d <- make_panel_A(seed = 42 + r - 1L) + set.seed(42 + r - 1L + 5000L) + fit <- suppressMessages( + fect(Y ~ D, data = d, index = c("id", "time"), + method = "fe", force = "two-way", se = TRUE, + nboots = 200, CV = FALSE, keep.sims = TRUE, + vartype = "parametric", + time.component.from = "nevertreated", + parallel = FALSE) + ) + res <- fect::estimand(fit, "att", "overall", window = c(1, 8), + ci.method = "bca") + in_ci[r] <- !is.na(res$ci.lo) && + res$ci.lo <= true_att && + true_att <= res$ci.hi + } + ## At least 3 of 5 reps must cover true ATT (catastrophic failure was 0/5 pre-fix) + expect_gte(sum(in_ci), 3L, + label = paste0("bca coverage >= 3/5 reps (got ", sum(in_ci), "/5)")) +}) + +test_that("P-REG-1b: basic CI width > 0.1 on parametric fit (non-degenerate, DGP-A seed=42)", { + skip_on_cran() + d <- make_panel_A(seed = 42) + set.seed(5042) + fit <- suppressMessages( + fect(Y ~ D, data = d, index = c("id", "time"), + method = "fe", force = "two-way", se = TRUE, + nboots = 200, CV = FALSE, keep.sims = TRUE, + vartype = "parametric", + time.component.from = "nevertreated", + parallel = FALSE) + ) + res_basic <- fect::estimand(fit, "att", "overall", window = c(1, 8), + ci.method = "basic") + res_bca <- fect::estimand(fit, "att", "overall", window = c(1, 8), + ci.method = "bca") + ## Pre-fix: basic CI was ~[5.7, 6.3] for true ATT=3 → 0% coverage + ## Post-fix: basic CI width must be > 0.1 + expect_gt(res_basic$ci.hi - res_basic$ci.lo, 0.1, + label = "basic CI width > 0.1 (not degenerate)") + ## bca CI must be non-degenerate + expect_gt(res_bca$ci.hi - res_bca$ci.lo, 0.1, + label = "bca CI width > 0.1 (not degenerate)") + ## basic CI should contain or be near true ATT=3 + true_att <- 3.0 + half_width <- (res_basic$ci.hi - res_basic$ci.lo) / 2 + dist_to_ci <- max(0, res_basic$ci.lo - true_att, true_att - res_basic$ci.hi) + expect_lte(dist_to_ci, half_width, + label = "basic CI is within one half-width of true ATT=3") +}) + +## ---- All 5 ci.methods produce non-NA, non-degenerate CIs -------------------- + +test_that("All 5 ci.methods produce non-NA, non-degenerate CIs on parametric fit (DGP-A)", { + skip_on_cran() + d <- make_panel_A(seed = 42) + set.seed(5042) + fit <- suppressMessages( + fect(Y ~ D, data = d, index = c("id", "time"), + method = "fe", force = "two-way", se = TRUE, + nboots = 200, CV = FALSE, keep.sims = TRUE, + vartype = "parametric", + time.component.from = "nevertreated", + parallel = FALSE) + ) + for (m in c("basic", "percentile", "bc", "bca", "normal")) { + res <- fect::estimand(fit, "att", "overall", window = c(1, 8), + ci.method = m) + expect_s3_class(res, "data.frame") + expect_true(!is.na(res$ci.lo), + label = paste(m, "ci.lo is not NA")) + expect_true(!is.na(res$ci.hi), + label = paste(m, "ci.hi is not NA")) + expect_gt(res$ci.hi - res$ci.lo, 1e-6, + label = paste(m, "CI width > 1e-6 (not degenerate)")) + } +}) + +## ---- gsynth method: all 5 ci.methods produce reasonable CIs ----------------- + +test_that("gsynth + parametric: all 5 ci.methods produce non-NA, non-degenerate CIs (DGP-G)", { + skip_on_cran() + d <- make_panel_G(seed = 42, r = 2) + set.seed(5042) + fit_g <- suppressMessages( + fect(Y ~ D, data = d, index = c("id", "time"), + method = "gsynth", r = 2, se = TRUE, + nboots = 200, CV = FALSE, keep.sims = TRUE, + vartype = "parametric", + parallel = FALSE) + ) + expect_equal(fit_g$vartype, "parametric", + label = "gsynth fit$vartype is 'parametric'") + for (m in c("basic", "percentile", "bc", "bca", "normal")) { + res <- fect::estimand(fit_g, "att", "overall", window = c(1, 8), + ci.method = m) + expect_s3_class(res, "data.frame") + expect_true(!is.na(res$ci.lo), + label = paste("gsynth", m, "ci.lo non-NA")) + expect_true(!is.na(res$ci.hi), + label = paste("gsynth", m, "ci.hi non-NA")) + expect_gt(res$ci.hi - res$ci.lo, 1e-6, + label = paste("gsynth", m, "CI non-degenerate")) + ## Estimate shifted to CI: CI should bracket estimate (or near) + ci_width <- res$ci.hi - res$ci.lo + dist_from_est <- max(0, res$ci.lo - res$estimate, + res$estimate - res$ci.hi) + expect_lte(dist_from_est, ci_width, + label = paste("gsynth", m, "CI within one width of estimate")) + } +}) + +## ---- P-COV-1: ATT coverage >= 0.85 for {basic,percentile,bca,normal}, DGP-A -- + +test_that("P-COV-1: ATT coverage >= 0.85 for basic/percentile/bca/normal (DGP-A, 100 reps)", { + skip_on_cran() + true_att <- 3.0 + n_reps <- 100L + methods <- c("basic", "percentile", "bca", "normal") + + coverage <- setNames(numeric(length(methods)), methods) + + for (r in seq_len(n_reps)) { + d <- make_panel_A(seed = 1000L + r) + set.seed(1000L + r + 5000L) + fit <- suppressMessages( + fect(Y ~ D, data = d, index = c("id", "time"), + method = "fe", force = "two-way", se = TRUE, + nboots = 200, CV = FALSE, keep.sims = TRUE, + vartype = "parametric", + time.component.from = "nevertreated", + parallel = FALSE) + ) + for (m in methods) { + res <- fect::estimand(fit, "att", "overall", window = c(1, 8), + ci.method = m) + if (!is.na(res$ci.lo) && res$ci.lo <= true_att && true_att <= res$ci.hi) { + coverage[m] <- coverage[m] + 1L + } + } + } + coverage <- coverage / n_reps + + for (m in methods) { + expect_gte(coverage[m], 0.85, + label = paste0("P-COV-1: ", m, " coverage >= 0.85 (got ", + round(coverage[m], 3), ")")) + } + + ## Anti-regression: any method with < 0.50 coverage is a catastrophic failure + for (m in methods) { + expect_gte(coverage[m], 0.50, + label = paste0("P-COV-1 catastrophic: ", m, " coverage < 0.50")) + } +}) + +## ---- P-COV-2: bca coverage >= 0.85, DGP-G, gsynth -------------------------- + +test_that("P-COV-2: ATT bca coverage >= 0.85 for gsynth+parametric (DGP-G, 100 reps)", { + skip_on_cran() + true_att <- 3.0 + n_reps <- 100L + in_ci <- logical(n_reps) + + for (r in seq_len(n_reps)) { + d <- make_panel_G(seed = 1000L + r, r = 2) + set.seed(1000L + r + 5000L) + fit <- suppressMessages( + fect(Y ~ D, data = d, index = c("id", "time"), + method = "gsynth", r = 2, se = TRUE, + nboots = 200, CV = FALSE, keep.sims = TRUE, + vartype = "parametric", + parallel = FALSE) + ) + res <- fect::estimand(fit, "att", "overall", window = c(1, 8), + ci.method = "bca") + in_ci[r] <- !is.na(res$ci.lo) && + res$ci.lo <= true_att && + true_att <= res$ci.hi + } + cov_bca <- mean(in_ci) + expect_gte(cov_bca, 0.85, + label = paste0("P-COV-2: gsynth bca coverage >= 0.85 (got ", + round(cov_bca, 3), ")")) +}) + +## ---- P-COV-3: APTT bca coverage >= 0.75, DGP-B-positive -------------------- + +test_that("P-COV-3: APTT bca coverage >= 0.75 (DGP-B-positive, 100 reps)", { + skip_on_cran() + n_reps <- 100L + in_ci <- logical(n_reps) + + for (r in seq_len(n_reps)) { + dgp <- make_panel_B_pos(seed = 1000L + r) + true_aptt <- dgp$true_aptt + set.seed(1000L + r + 5000L) + fit <- suppressMessages( + fect(Y ~ D, data = dgp$df, index = c("id", "time"), + method = "fe", force = "two-way", se = TRUE, + nboots = 200, CV = FALSE, keep.sims = TRUE, + vartype = "parametric", + time.component.from = "nevertreated", + parallel = FALSE) + ) + res_aptt <- suppressMessages( + fect::estimand(fit, "aptt", "event.time", ci.method = "bca") + ) + ## Check coverage at event.time = 1 + et1 <- res_aptt[res_aptt$event.time == 1, ] + if (nrow(et1) == 1L && !is.na(et1$ci.lo)) { + in_ci[r] <- et1$ci.lo <= true_aptt && true_aptt <= et1$ci.hi + } + } + cov_aptt <- mean(in_ci) + expect_gte(cov_aptt, 0.75, + label = paste0("P-COV-3: APTT bca coverage >= 0.75 (got ", + round(cov_aptt, 3), ")")) +}) + +## ---- P-WIDTH-1: parametric CI widths within 15% of bootstrap widths --------- + +test_that("P-WIDTH-1: parametric CI widths within 15% of bootstrap widths (DGP-A, seed=42)", { + skip_on_cran() + d <- make_panel_A(seed = 42) + + set.seed(42) + fit_par <- suppressMessages( + fect(Y ~ D, data = d, index = c("id", "time"), + method = "fe", force = "two-way", se = TRUE, + nboots = 200, CV = FALSE, keep.sims = TRUE, + vartype = "parametric", + time.component.from = "nevertreated", + parallel = FALSE) + ) + set.seed(42) + fit_boot <- suppressMessages( + fect(Y ~ D, data = d, index = c("id", "time"), + method = "fe", force = "two-way", se = TRUE, + nboots = 200, CV = FALSE, keep.sims = TRUE, + vartype = "bootstrap", + parallel = FALSE) + ) + + for (m in c("basic", "percentile", "normal")) { + res_par <- fect::estimand(fit_par, "att", "overall", window = c(1, 8), + ci.method = m) + res_boot <- fect::estimand(fit_boot, "att", "overall", window = c(1, 8), + ci.method = m) + w_par <- res_par$ci.hi - res_par$ci.lo + w_boot <- res_boot$ci.hi - res_boot$ci.lo + + ## Width within 15% of bootstrap width (both > 0) + expect_gt(w_par, 0, label = paste(m, "parametric CI width > 0")) + expect_gt(w_boot, 0, label = paste(m, "bootstrap CI width > 0")) + rel_diff <- abs(w_par - w_boot) / w_boot + expect_lte(rel_diff, 0.15, + label = paste0("P-WIDTH-1: ", m, + " parametric vs bootstrap width within 15% (rel_diff = ", + round(rel_diff, 3), ")")) + } +}) diff --git a/tests/testthat/test-estimand-parametric.R b/tests/testthat/test-estimand-parametric.R index d8acb8f8..fa59417f 100644 --- a/tests/testthat/test-estimand-parametric.R +++ b/tests/testthat/test-estimand-parametric.R @@ -20,12 +20,17 @@ e <- new.env() data(sim_linear, package = "fect", envir = e) set.seed(42) - fit <- fect(Y ~ D, data = e$sim_linear, index = c("id", "time"), - method = "ife", force = "two-way", se = TRUE, - nboots = 30, r = 2, CV = FALSE, keep.sims = TRUE, - vartype = "parametric", - time.component.from = "nevertreated", - parallel = FALSE) + ## suppressWarnings covers the "EM did not converge within + ## max.iteration = 5000" warning. The fixture is intentionally small + ## (nboots = 30) and convergence is not what these tests verify. + fit <- suppressWarnings( + fect(Y ~ D, data = e$sim_linear, index = c("id", "time"), + method = "ife", force = "two-way", se = TRUE, + nboots = 30, r = 2, CV = FALSE, keep.sims = TRUE, + vartype = "parametric", + time.component.from = "nevertreated", + parallel = FALSE) + ) cached <<- fit fit } @@ -76,7 +81,12 @@ test_that("att.cumu / aptt / att-overall work on parametric fits", { skip_on_cran() fit <- .make_parametric_fit() - expect_silent(r1 <- estimand(fit, "att.cumu", "event.time")) + ## att.cumu defaults to ci.method = "basic"; aptt defaults to "bca". + ## Both are tail-quantile CIs; on this small fit (nboots = 30) they + ## emit the v2.4.2 .check_tail_ci_replicates warning by design. + ## Suppress it here -- this test asserts the call runs and produces + ## non-NA results, not CI quality. + suppressWarnings(r1 <- estimand(fit, "att.cumu", "event.time")) expect_true(all(r1$vartype == "parametric")) expect_true(any(!is.na(r1$estimate))) @@ -84,18 +94,22 @@ test_that("att.cumu / aptt / att-overall work on parametric fits", { expect_true(r2$vartype == "parametric") expect_true(!is.na(r2$estimate)) - expect_silent(r3 <- estimand(fit, "aptt", "event.time")) + suppressWarnings(r3 <- estimand(fit, "aptt", "event.time")) expect_true(all(r3$vartype == "parametric")) expect_true(any(!is.na(r3$estimate))) }) -test_that("log.att works on parametric fits (negative-Y warning expected)", { +test_that("log.att hard-errors on parametric fits with negative Y (v2.4.2+)", { skip_on_cran() fit <- .make_parametric_fit() - ## sim_linear has negative Y, so log.att warns about dropped cells. - r4 <- suppressWarnings(estimand(fit, "log.att", "event.time")) - expect_true(all(r4$vartype == "parametric")) - expect_true(any(!is.na(r4$estimate))) + ## sim_linear has many negative Y cells, so log.att now hard-errors + ## at point-estimate level (v2.4.2+). The previous v2.4.1 behavior of + ## silently warning + dropping cells produced meaningless inference; + ## the hard-error redirects users to the actionable options. + expect_error( + estimand(fit, "log.att", "event.time"), + "log\\.att requires Y > 0" + ) }) test_that("vartype = 'none' under parametric returns NA SE/CI", { @@ -114,13 +128,18 @@ test_that("keep.sims = FALSE under parametric still errors helpfully on non-fast e <- new.env() data(sim_linear, package = "fect", envir = e) set.seed(42) - fit_no_sims <- fect(Y ~ D, data = e$sim_linear, index = c("id", "time"), - method = "ife", force = "two-way", se = TRUE, - nboots = 20, r = 2, CV = FALSE, - keep.sims = FALSE, - vartype = "parametric", - time.component.from = "nevertreated", - parallel = FALSE) + ## suppressWarnings covers the "EM did not converge within + ## max.iteration = 5000" warning on this small (nboots = 20) fixture; + ## the test verifies error messages on non-fast paths, not convergence. + fit_no_sims <- suppressWarnings( + fect(Y ~ D, data = e$sim_linear, index = c("id", "time"), + method = "ife", force = "two-way", se = TRUE, + nboots = 20, r = 2, CV = FALSE, + keep.sims = FALSE, + vartype = "parametric", + time.component.from = "nevertreated", + parallel = FALSE) + ) expect_null(fit_no_sims$eff.boot) ## att / event.time fast path reads fit$est.att, so still works. diff --git a/tests/testthat/test-estimand-placebo-carryover.R b/tests/testthat/test-estimand-placebo-carryover.R new file mode 100644 index 00000000..540beff7 --- /dev/null +++ b/tests/testthat/test-estimand-placebo-carryover.R @@ -0,0 +1,248 @@ +## --------------------------------------------------------------- +## Tests for estimand(test = "placebo" / "carryover"). +## +## Issue #131 (ajunquera): pre-treatment APTT estimates for the +## alternative-estimand API. Generalized to all four shipped estimand +## types (att, aptt, log.att; att.cumu is intentionally disallowed). +## --------------------------------------------------------------- + +suppressWarnings(data("simdata", package = "fect")) + + +## DGP helper duplicated from test-book-claims.R so this file is +## self-contained without cross-file source ordering. +.make_panel <- function(N = 40, TT = 20, T0 = 12, Ntr = 12, + tau = 3.0, seed = 9301, reversals = FALSE) { + set.seed(seed) + alpha_i <- rnorm(N, 0, 2) + xi_t <- rnorm(TT, 0, 1) + D <- matrix(0L, TT, N) + D[(T0 + 1):TT, 1:Ntr] <- 1L + if (reversals) { + for (i in 1:min(3, Ntr)) D[(TT - 1):TT, i] <- 0L + } + eps <- matrix(rnorm(N * TT, 0, 1), TT, N) + Y <- outer(xi_t, rep(1, N)) + + outer(rep(1, TT), alpha_i) + + tau * D + eps + data.frame( + id = rep(1:N, each = TT), + time = rep(1:TT, N), + Y = as.vector(Y), + D = as.vector(D) + ) +} + + +.fit_placebo <- function(nboots = 50) { + d <- .make_panel(N = 40, TT = 20, T0 = 12, Ntr = 12, seed = 9301) + suppressWarnings(suppressMessages( + fect::fect(Y ~ D, data = d, index = c("id", "time"), + method = "fe", se = TRUE, nboots = nboots, + parallel = FALSE, keep.sims = TRUE, + placeboTest = TRUE, placebo.period = c(-2, 0), + CV = FALSE) + )) +} + +.fit_carryover <- function(nboots = 50) { + d <- .make_panel(N = 40, TT = 20, T0 = 12, Ntr = 12, + seed = 9302, reversals = TRUE) + suppressWarnings(suppressMessages( + fect::fect(Y ~ D, data = d, index = c("id", "time"), + method = "fe", se = TRUE, nboots = nboots, + parallel = FALSE, keep.sims = TRUE, + carryoverTest = TRUE, carryover.period = c(1, 2), + CV = FALSE) + )) +} + + +## -- PC.1 test argument is documented and validated --------------- + +test_that("PC.1: estimand() rejects unknown test values", { + + skip_on_cran() + + fit <- .fit_placebo() + expect_error( + fect::estimand(fit, "att", "event.time", test = "bogus"), + "should be one of" + ) +}) + + +test_that("PC.2: test='placebo' errors when fit had placeboTest=FALSE", { + + skip_on_cran() + + fit_plain <- suppressWarnings(suppressMessages( + fect::fect(Y ~ D, data = simdata, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, nboots = 50, parallel = FALSE, + keep.sims = TRUE) + )) + expect_error( + fect::estimand(fit_plain, "aptt", "event.time", test = "placebo"), + "placeboTest = TRUE" + ) + ## Also verify the message names the actionable refit hint. + expect_error( + fect::estimand(fit_plain, "aptt", "event.time", test = "placebo"), + "Refit with" + ) +}) + + +test_that("PC.3: test='carryover' errors when fit had carryoverTest=FALSE", { + + skip_on_cran() + + fit_plain <- suppressWarnings(suppressMessages( + fect::fect(Y ~ D, data = simdata, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, nboots = 50, parallel = FALSE, + keep.sims = TRUE) + )) + expect_error( + fect::estimand(fit_plain, "aptt", "event.time", test = "carryover"), + "carryoverTest = TRUE" + ) + expect_error( + fect::estimand(fit_plain, "aptt", "event.time", test = "carryover"), + "Refit with" + ) +}) + + +## -- PC.4 test='placebo' returns event-time series in placebo window + +test_that("PC.4: placebo aptt returns rows in fit$placebo.period range", { + + skip_on_cran() + + fit <- .fit_placebo() + est <- fect::estimand(fit, "aptt", "event.time", test = "placebo") + + expect_s3_class(est, "data.frame") + expect_setequal(names(est), + c("event.time", "estimate", "se", + "ci.lo", "ci.hi", "n_cells", "vartype")) + + pp <- fit$placebo.period + expect_true(all(est$event.time >= pp[1] & est$event.time <= pp[2])) + expect_true(all(est$n_cells > 0L)) +}) + + +## -- PC.5 test='placebo' covers att (log.att is gated by v2.4.2 hard-error) + +test_that("PC.5: placebo att returns rows in placebo window; placebo log.att hard-errors when DGP triggers cell-drop pathology", { + + skip_on_cran() + + fit <- .fit_placebo() + + est_att <- fect::estimand(fit, "att", "event.time", test = "placebo") + + pp <- fit$placebo.period + expect_true(all(est_att$event.time >= pp[1] & est_att$event.time <= pp[2])) + + ## log.att on simdata triggers v2.4.2's point-level hard-error because + ## simdata has Y <= 0 cells. This is the EXPECTED behavior --- the + ## point-level check fires before any bootstrap work, with a clearer + ## actionable message than the bootstrap-level pathology message. + expect_error( + fect::estimand(fit, "log.att", "event.time", test = "placebo"), + "log\\.att requires Y > 0" + ) +}) + + +## -- PC.6 byte-equality: placebo att rows match fit$est.att rows ----- + +test_that("PC.6: estimand(att, test=placebo) matches fit$est.att rows", { + + skip_on_cran() + + fit <- .fit_placebo() + est <- fect::estimand(fit, "att", "event.time", test = "placebo") + + ## fit$est.att is per-event-time over all (treated post + masked + ## placebo) cells. Restrict to placebo event times and compare. + ea <- fit$est.att + et <- as.numeric(rownames(ea)) + pp <- fit$placebo.period + in_pp <- et >= pp[1] & et <= pp[2] + + ## Sort both by event.time for safety. + est <- est[order(est$event.time), , drop = FALSE] + ref <- ea[in_pp, , drop = FALSE] + ref <- ref[order(as.numeric(rownames(ref))), , drop = FALSE] + + expect_equal(est$event.time, + as.numeric(rownames(ref))) + expect_equal(est$estimate, + unname(ref[, "ATT"]), + tolerance = 1e-10) + expect_equal(est$n_cells, + as.integer(unname(ref[, "count"]))) +}) + + +## -- PC.7 type='att.cumu' is rejected with non-none test ------------ + +test_that("PC.7: type='att.cumu' is incompatible with test != 'none'", { + + skip_on_cran() + + fit <- .fit_placebo() + expect_error( + fect::estimand(fit, "att.cumu", "event.time", test = "placebo"), + "incompatible with test" + ) +}) + + +## -- PC.8 carryover path works on a reversal panel ------------------ + +test_that("PC.8: carryover aptt returns rows in carryover window", { + + skip_on_cran() + + fit <- .fit_carryover() + est <- fect::estimand(fit, "aptt", "event.time", test = "carryover") + + cp <- fit$carryover.period + expect_true(all(est$event.time >= cp[1] & est$event.time <= cp[2])) + expect_true(all(est$n_cells > 0L)) +}) + + +## -- PC.9 test='placebo' auto-overrides direction to 'on' ----------- + +test_that("PC.9: test='placebo' silently uses direction='on'", { + + skip_on_cran() + + fit <- .fit_placebo() + ## Even when user passes direction='off', placebo path uses T.on + ## (so we should get an event-time series, not error on missing T.off). + est <- fect::estimand(fit, "aptt", "event.time", + test = "placebo", direction = "off") + pp <- fit$placebo.period + expect_true(all(est$event.time >= pp[1] & est$event.time <= pp[2])) +}) + + +## -- PC.10 default vartype is sourced from fit, not from arg --------- + +test_that("PC.10: vartype column reports method used at fit time", { + + skip_on_cran() + + fit <- .fit_placebo() + est <- fect::estimand(fit, "aptt", "event.time", test = "placebo") + expect_true(unique(est$vartype) %in% + c("bootstrap", "jackknife", "parametric")) +}) diff --git a/tests/testthat/test-factors-from-refactor.R b/tests/testthat/test-factors-from-refactor.R index 2e4b6345..16f6a73d 100644 --- a/tests/testthat/test-factors-from-refactor.R +++ b/tests/testthat/test-factors-from-refactor.R @@ -201,124 +201,18 @@ test_that("Phase 1a: fect accepts time.component.from='notyettreated' (default b expect_true(!is.na(out$att.avg)) }) -test_that("Phase 1b: fect accepts time.component.from='nevertreated'", { - - skip_on_cran() - df <- make_staggered_data(N = 40, Ntr = 15) ## 25 never-treated - - out <- suppressWarnings(fect::fect( - Y ~ D, data = df, index = c("id", "time"), - method = "ife", r = 2, CV = FALSE, se = FALSE, - time.component.from = "nevertreated", - parallel = FALSE - )) - - expect_s3_class(out, "fect") - expect_true(is.numeric(out$att.avg)) - expect_true(!is.na(out$att.avg)) -}) - -test_that("Phase 1c: time.component.from='nevertreated' produces different estimates than 'notyettreated'", { - - skip_on_cran() - df <- make_staggered_data(N = 40, Ntr = 15, seed = 99) - - out_nyt <- suppressWarnings(fect::fect( - Y ~ D, data = df, index = c("id", "time"), - method = "ife", r = 2, CV = FALSE, se = FALSE, - time.component.from = "notyettreated", - parallel = FALSE - )) - - out_nt <- suppressWarnings(fect::fect( - Y ~ D, data = df, index = c("id", "time"), - method = "ife", r = 2, CV = FALSE, se = FALSE, - time.component.from = "nevertreated", - parallel = FALSE - )) - - ## Both should produce valid ATTs, but they should differ - expect_true(is.numeric(out_nyt$att.avg)) - expect_true(is.numeric(out_nt$att.avg)) - ## Allow for numerical coincidence, but in general they won't be equal - ## The key structural check: both succeeded with different code paths - expect_s3_class(out_nyt, "fect") - expect_s3_class(out_nt, "fect") -}) - -test_that("Phase 1d: time.component.from defaults to 'notyettreated' when omitted", { - - skip_on_cran() - df <- make_staggered_data() - - ## Without time.component.from - out_default <- suppressWarnings(fect::fect( - Y ~ D, data = df, index = c("id", "time"), - method = "ife", r = 2, CV = FALSE, se = FALSE, - parallel = FALSE - )) - - ## With time.component.from = "notyettreated" explicitly - out_explicit <- suppressWarnings(fect::fect( - Y ~ D, data = df, index = c("id", "time"), - method = "ife", r = 2, CV = FALSE, se = FALSE, - time.component.from = "notyettreated", - parallel = FALSE - )) - - ## Should produce identical results - expect_equal(out_default$att.avg, out_explicit$att.avg, tolerance = 1e-10) -}) - -test_that("Phase 1e: time.component.from='nevertreated' works with method='cfe'", { - - skip_on_cran() - df <- make_staggered_data(N = 40, Ntr = 15) - - out <- suppressWarnings(fect::fect( - Y ~ D, data = df, index = c("id", "time"), - method = "cfe", r = 0, CV = FALSE, se = FALSE, - time.component.from = "nevertreated", - parallel = FALSE - )) - - expect_s3_class(out, "fect") - expect_true(is.numeric(out$att.avg)) -}) - -test_that("Phase 1f: time.component.from threads through cross-validation", { - - skip_on_cran() - df <- make_staggered_data(N = 40, Ntr = 15) - - out <- suppressWarnings(fect::fect( - Y ~ D, data = df, index = c("id", "time"), - method = "ife", r = c(0, 3), CV = TRUE, se = FALSE, - time.component.from = "nevertreated", - parallel = FALSE - )) - - expect_s3_class(out, "fect") - expect_true(!is.null(out$r.cv)) -}) - -test_that("Phase 1g: time.component.from threads through bootstrap inference", { - - skip_on_cran() - df <- make_staggered_data(N = 40, Ntr = 15) - - out <- suppressWarnings(fect::fect( - Y ~ D, data = df, index = c("id", "time"), - method = "ife", r = 2, CV = FALSE, - se = TRUE, nboots = 30, - time.component.from = "nevertreated", - parallel = FALSE - )) - - expect_s3_class(out, "fect") - expect_true(!is.null(out$est.att)) - expect_true(!is.null(out$att.vcov)) -}) +## Phase 1b-1g pruned (2026-05-03 simplification): each was a single-line +## smoke check on the time.component.from API surface; the substantive +## coverage lives in Phase 6a-6e (gsynth <-> ife+nevertreated equivalence) +## and the Phase 3a-* series (cfe+nevertreated thorough coverage). Phase 1a +## above retained as the single smoke-entry-point for the API. +## +## 1b: nevertreated acceptance -> covered by Phase 6a-6e +## 1c: nyt vs nt produce different -> non-regression-grade observation +## 1d: default = notyettreated -> argument-matching is R semantics +## 1e: cfe + nevertreated works -> covered by Phase 3a-B/C/D +## 1f: time.component.from in CV -> covered by Phase 3a-G1/G3 +## 1g: time.component.from in boot -> covered by Phase 3a-F1/F2/I1 ## ======================================================== ## PHASE 2: gsynth merged into ife @@ -1237,21 +1131,8 @@ test_that("Phase 3a-F4: ife+nevertreated SE unchanged (regression)", { ## ---- Category E: Output Completeness ---- -test_that("Phase 3a-E1: gamma and kappa fields present", { - - skip_on_cran() - df <- make_cfe_z_data(N = 100, TT = 30, Ntr = 30, tau = 3.0, r = 2, seed = 42) - - out <- suppressWarnings(suppressMessages(fect::fect( - Y ~ D, data = df, index = c("id", "time"), - method = "cfe", Z = "Z", r = 2, CV = FALSE, se = FALSE, - force = "two-way", time.component.from = "nevertreated", - parallel = FALSE - ))) - - expect_false(is.null(out$gamma)) - ## kappa can be NULL if no Q was specified — that's OK -}) +## Phase 3a-E1 pruned (2026-05-03): subsumed by E3 (which already asserts +## core output fields non-NULL with dimensions, including gamma when CFE+Z). test_that("Phase 3a-E2: time.component.from field in output", { @@ -1289,35 +1170,10 @@ test_that("Phase 3a-E3: core output fields non-NULL with correct dimensions", { expect_equal(ncol(out$Y.ct), length(unique(df$id))) }) -test_that("Phase 3a-E4: plot() works without error", { - - skip_on_cran() - df <- make_cfe_z_data(N = 100, TT = 30, Ntr = 30, tau = 3.0, r = 2, seed = 42) - - out <- suppressWarnings(suppressMessages(fect::fect( - Y ~ D, data = df, index = c("id", "time"), - method = "cfe", Z = "Z", r = 2, CV = FALSE, se = FALSE, - force = "two-way", time.component.from = "nevertreated", - parallel = FALSE - ))) - - expect_no_error(suppressWarnings(suppressMessages(plot(out)))) -}) - -test_that("Phase 3a-E5: print() works without error", { - - skip_on_cran() - df <- make_cfe_z_data(N = 100, TT = 30, Ntr = 30, tau = 3.0, r = 2, seed = 42) - - out <- suppressWarnings(suppressMessages(fect::fect( - Y ~ D, data = df, index = c("id", "time"), - method = "cfe", Z = "Z", r = 2, CV = FALSE, se = FALSE, - force = "two-way", time.component.from = "nevertreated", - parallel = FALSE - ))) - - expect_no_error(suppressWarnings(suppressMessages(print(out)))) -}) +## Phase 3a-E4 (plot smoke) and E5 (print smoke) pruned (2026-05-03): +## covered by dedicated test-plot-fect.R + test-plot-refactor.R for plot, +## and the print method is exercised by every regression test that prints +## a summary of fect() output. ## ---- Category G: Cross-Validation ---- @@ -1481,26 +1337,9 @@ test_that("Phase 3a-I1: ife+nevertreated parametric bootstrap, em=TRUE, parallel info = "SE estimates should not all be NA") }) -test_that("Phase 3a-I2: ife+nevertreated parametric bootstrap, em=FALSE, parallel", { - - skip_on_cran() - df <- make_factor_data(N = 100, TT = 30, Ntr = 30, tau = 3.0, r = 2, seed = 42) - - out <- suppressWarnings(suppressMessages(fect::fect( - Y ~ D, data = df, index = c("id", "time"), - method = "ife", r = 2, CV = FALSE, force = "two-way", - time.component.from = "nevertreated", em = FALSE, - se = TRUE, vartype = "bootstrap", nboots = 20, - parallel = TRUE, cores = 2, seed = 123 - ))) - - expect_false(is.na(out$att.avg), - info = "att.avg should not be NA") - expect_false(is.null(out$est.att), - info = "est.att should not be NULL") - expect_true(any(!is.na(out$est.att[, "S.E."])), - info = "SE estimates should not all be NA") -}) +## Phase 3a-I2 pruned (2026-05-03): em=FALSE variant of I1; em=TRUE/FALSE +## equivalence on nevertreated is asserted by I10. Smoke check for em=FALSE +## bootstrap path is implicit through I10's identity assertion. test_that("Phase 3a-I3: cfe+nevertreated parametric bootstrap, em=TRUE, parallel", { @@ -1523,26 +1362,9 @@ test_that("Phase 3a-I3: cfe+nevertreated parametric bootstrap, em=TRUE, parallel info = "SE estimates should not all be NA") }) -test_that("Phase 3a-I4: cfe+nevertreated parametric bootstrap, em=FALSE, parallel", { - - skip_on_cran() - df <- make_cfe_z_data(N = 100, TT = 30, Ntr = 30, tau = 3.0, r = 2, seed = 42) - - out <- suppressWarnings(suppressMessages(fect::fect( - Y ~ D, data = df, index = c("id", "time"), - method = "cfe", Z = "Z", r = 2, CV = FALSE, force = "two-way", - time.component.from = "nevertreated", em = FALSE, - se = TRUE, vartype = "bootstrap", nboots = 20, - parallel = TRUE, cores = 2, seed = 123 - ))) - - expect_false(is.na(out$att.avg), - info = "att.avg should not be NA") - expect_false(is.null(out$est.att), - info = "est.att should not be NULL") - expect_true(any(!is.na(out$est.att[, "S.E."])), - info = "SE estimates should not all be NA") -}) +## Phase 3a-I4 pruned (2026-05-03): cfe em=FALSE variant of I3; same +## reasoning as I2's prune (em=TRUE/FALSE equivalence on nevertreated +## covered by I10). test_that("Phase 3a-I5: bootstrap reproducibility with same seed (ife+nevertreated)", { diff --git a/tests/testthat/test-group-fe.R b/tests/testthat/test-group-fe.R new file mode 100644 index 00000000..365c7f7b --- /dev/null +++ b/tests/testthat/test-group-fe.R @@ -0,0 +1,220 @@ +## Tests for the group.fe argument (added v2.4.5; closes #139). +## Design memo: statsclaw-workspace/fect/runs/2026-05-21-higher-level-fe.md + +## ---------------------------------------------------------------------- +## Helper: small nested panel (county within state, state-level treatment). +## Returns a balanced TT*N panel with non-trivial state structure. +## ---------------------------------------------------------------------- +.make_nested_panel <- function(N = 40, TT = 10, n_states = 4, seed = 42) { + set.seed(seed) + df <- expand.grid(id = 1:N, time = 1:TT) + df$state <- paste0("S", (df$id - 1) %% n_states + 1) + df$D <- as.integer(df$state %in% c("S1", "S2") & df$time >= 6) + df$Y <- 1 + 0.5 * df$D + rnorm(nrow(df), sd = 0.5) + df +} + +## ---------------------------------------------------------------------- +## Point-estimate equivalence +## ---------------------------------------------------------------------- + +test_that("group.fe = 'state' is byte-equivalent to legacy index[3]", { + df <- .make_nested_panel() + fit_new <- fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", force = "time", se = FALSE) + fit_old <- fect(Y ~ D, data = df, index = c("id", "time", "state"), + method = "cfe", r = 0, CV = FALSE, + force = "time", se = FALSE) + expect_equal(fit_new$att.avg, fit_old$att.avg) +}) + +test_that("auto-route from method='fe' preserves the result", { + df <- .make_nested_panel() + fit_default <- fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", force = "time", se = FALSE) + fit_explicit <- fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", method = "cfe", r = 0, + CV = FALSE, force = "time", se = FALSE) + expect_equal(fit_default$att.avg, fit_explicit$att.avg) +}) + +## ---------------------------------------------------------------------- +## Hard errors on unsupported methods (D3) +## ---------------------------------------------------------------------- + +test_that("method='ife' + group.fe hard-errors with guidance", { + df <- .make_nested_panel() + expect_error( + fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", method = "ife", se = FALSE), + "not supported" + ) +}) + +test_that("method='mc' + group.fe hard-errors", { + df <- .make_nested_panel() + expect_error( + fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", method = "mc", se = FALSE), + "not supported" + ) +}) + +test_that("method='both' + group.fe hard-errors", { + df <- .make_nested_panel() + expect_error( + fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", method = "both", se = FALSE), + "not supported" + ) +}) + +test_that("method='gsynth' + group.fe hard-errors", { + df <- .make_nested_panel() + expect_error( + fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", method = "gsynth", se = FALSE), + "not supported" + ) +}) + +## ---------------------------------------------------------------------- +## Edge cases (D5) +## ---------------------------------------------------------------------- + +test_that("group.fe column missing from data hard-errors", { + df <- .make_nested_panel() + expect_error( + fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "nonexistent_col", se = FALSE), + "not found" + ) +}) + +test_that("group.fe AND legacy index[3:] both used hard-errors", { + df <- .make_nested_panel() + expect_error( + fect(Y ~ D, data = df, index = c("id", "time", "state"), + group.fe = "state", se = FALSE), + "OR extra index slots" + ) +}) + +test_that("non-character group.fe hard-errors", { + df <- .make_nested_panel() + expect_error( + fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = 1L, se = FALSE), + "character vector" + ) +}) + +test_that("group.fe overlapping index[1:2] is warned and dropped", { + df <- .make_nested_panel() + expect_warning( + fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = c("id", "state"), force = "time", se = FALSE), + "duplicate index" + ) +}) + +## ---------------------------------------------------------------------- +## Nesting check (D5 edge 5, D3f) -- applies to BOTH group.fe and legacy +## ---------------------------------------------------------------------- + +test_that("non-nested group.fe hard-errors with offending units listed", { + df <- .make_nested_panel() + df$state[1:5] <- "BAD" # county 1 now appears in two states across time + expect_error( + fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", force = "time", se = FALSE), + "not constant within" + ) +}) + +test_that("legacy index[3:] does NOT enforce nesting (supports cell-level interactions)", { + ## Legacy index = c(unit, time, extra) syntax has historically supported + ## both nested groupings AND cell-level interactions like region_time. + ## The nesting check only fires for group.fe; legacy form keeps full scope. + df <- .make_nested_panel() + df$region_time <- as.numeric(df$state == "S1") + df$time / 100 # varies within id + expect_no_error( + fect(Y ~ D, data = df, index = c("id", "time", "region_time"), + method = "cfe", force = "two-way", se = FALSE) + ) +}) + +## ---------------------------------------------------------------------- +## cl auto-default + FALSE sentinel (D6) +## ---------------------------------------------------------------------- + +test_that("single-column group.fe auto-defaults cl to group.fe[1]", { + df <- .make_nested_panel() + fit <- fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", force = "time", se = FALSE) + expect_equal(fit$cl.label, "state") +}) + +test_that("cl = FALSE is rejected with a guiding error", { + df <- .make_nested_panel() + expect_error( + fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", force = "time", cl = FALSE, se = FALSE), + "cl = FALSE is not supported" + ) +}) + +test_that("cl = index[1] explicitly clusters at the unit level", { + df <- .make_nested_panel() + fit <- fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", force = "time", cl = "id", se = FALSE) + expect_equal(fit$cl.label, "id") +}) + +test_that("cl = 'other_col' overrides the auto-default", { + df <- .make_nested_panel() + df$region <- substr(df$state, 1, 1) + fit <- fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", force = "time", cl = "region", se = FALSE) + expect_equal(fit$cl.label, "region") +}) + +test_that("multi-column group.fe requires explicit cl", { + df <- .make_nested_panel() + df$region <- substr(df$state, 1, 1) + expect_error( + fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = c("state", "region"), force = "time", se = FALSE), + "Multi-column group.fe requires explicit cl" + ) +}) + +## ---------------------------------------------------------------------- +## Fit slots for print (D8) +## ---------------------------------------------------------------------- + +test_that("fit$group.fe and fit$cl.label are populated for downstream print", { + df <- .make_nested_panel() + fit <- fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", force = "time", se = FALSE) + expect_equal(fit$group.fe, "state") + expect_equal(fit$cl.label, "state") +}) + +test_that("print(fit) surfaces Estimator + Fixed effects + Cluster SE", { + df <- .make_nested_panel() + fit <- fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", force = "time", se = FALSE) + out <- capture.output(print(fit)) + expect_true(any(grepl("^Estimator:", out))) + expect_true(any(grepl("^Fixed effects:.*state", out))) + expect_true(any(grepl("^Cluster SE:.*state", out))) +}) + +test_that("print(fit) shows the user's chosen cl in the Cluster SE line", { + df <- .make_nested_panel() + fit <- fect(Y ~ D, data = df, index = c("id", "time"), + group.fe = "state", force = "time", cl = "id", se = FALSE) + out <- capture.output(print(fit)) + expect_true(any(grepl("^Cluster SE:.*id", out))) +}) diff --git a/tests/testthat/test-para-error-full.R b/tests/testthat/test-para-error-full.R new file mode 100644 index 00000000..d906f673 --- /dev/null +++ b/tests/testthat/test-para-error-full.R @@ -0,0 +1,540 @@ +## ============================================================================ +## Full coverage test suite for para.error redesign (test-spec.md scenarios) +## Companion to test-para-error.R (builder's starter file, 10 tests). +## This file covers: T4, T7, T9-T10, T13-T21, E2-E4, E6 +## +## Spec: statsclaw-workspace/fect/wild-as-paraerror/test-spec.md +## Branch: feat/v242-completion +## ============================================================================ + +## ============================================================================ +## DGP helpers (spec §2) +## ============================================================================ + +## DGP-A: additive TWFE, IID Gaussian, true ATT = 3.0, fully observed +## +## Treatment block is FIXED at units 1:Ntr (deterministic). The parametric +## bootstrap targets the conditional variance V_t(Lambda, F, X, D); a coverage +## simulation that re-randomizes the treatment assignment D across replications +## adds Var_{D}[b_t] to the marginal variance the bootstrap is being judged +## against, biasing measured coverage downward (see gsynth-note section 2). +dgp_a <- function(seed) { + set.seed(seed) + N <- 40; TT <- 20; T0 <- 12; Ntr <- 12 + alpha_i <- rnorm(N, 0, 2) + xi_t <- rnorm(TT, 0, 1) + eps <- matrix(rnorm(N * TT, 0, 1), TT, N) + D <- matrix(0L, TT, N); D[(T0 + 1):TT, 1:Ntr] <- 1L + Y <- outer(xi_t, rep(1, N)) + outer(rep(1, TT), alpha_i) + 3 * D + eps + data.frame( + id = rep(1:N, each = TT), + time = rep(1:TT, N), + Y = c(Y), + D = c(D) + ) +} + +## DGP-A8: additive TWFE, AR(1) rho=0.8, true ATT = 3.0 +## Treatment block fixed (see dgp_a comment). +dgp_a8 <- function(seed) { + set.seed(seed) + N <- 40; TT <- 20; T0 <- 12; Ntr <- 12 + alpha_i <- rnorm(N, 0, 2) + xi_t <- rnorm(TT, 0, 1) + eps <- matrix(NA, TT, N) + for (i in 1:N) { + e <- rnorm(TT, 0, 1) + eps[1, i] <- e[1] / sqrt(1 - 0.64) # stationary init + for (t in 2:TT) eps[t, i] <- 0.8 * eps[t - 1, i] + e[t] + } + D <- matrix(0L, TT, N); D[(T0 + 1):TT, 1:Ntr] <- 1L + Y <- outer(xi_t, rep(1, N)) + outer(rep(1, TT), alpha_i) + 3 * D + eps + data.frame( + id = rep(1:N, each = TT), + time = rep(1:TT, N), + Y = c(Y), + D = c(D) + ) +} + +## DGP-B: positive Y, multiplicative treatment (for aptt / log.att) +## Treatment block fixed (see dgp_a comment). +dgp_b <- function(seed) { + set.seed(seed) + N <- 40; TT <- 20; T0 <- 12; Ntr <- 12 + alpha_i <- rnorm(N, 0, 0.5) + xi_t <- rnorm(TT, 0, 0.3) + eps <- matrix(rnorm(N * TT, 0, 0.5), TT, N) + D <- matrix(0L, TT, N); D[(T0 + 1):TT, 1:Ntr] <- 1L + Y0 <- 20 + outer(rep(1, TT), alpha_i) + outer(xi_t, rep(1, N)) + eps + Y <- Y0 * ifelse(D == 1, 1.3, 1) + Y <- pmax(Y, 0.01) + data.frame( + id = rep(1:N, each = TT), + time = rep(1:TT, N), + Y = c(Y), + D = c(D) + ) +} + +## DGP-M: missing-data panel (10% rows removed) +dgp_m <- function(seed) { + df <- dgp_a(seed) + set.seed(seed + 999) + mask <- sample(1:nrow(df), floor(0.10 * nrow(df))) + df <- df[-mask, ] + df +} + +## DGP-REV: panel with treatment reversals (some units turn off treatment) +## N=30: 10 reversing treated, 10 absorbing treated, 10 never-treated controls. +dgp_rev <- function(seed = 77) { + set.seed(seed) + N_rev <- 10; N_abs <- 10; N_co <- 10 + N <- N_rev + N_abs + N_co; TT <- 20 + D_vec <- integer(N * TT) + Y_vec <- numeric(N * TT) + ## Reversing units: turn on at t=8, turn off at t=14 + for (i in 1:N_rev) { + for (t in 1:TT) { + idx <- (i - 1) * TT + t + D_vec[idx] <- as.integer(t >= 8 && t < 14) + Y_vec[idx] <- rnorm(1) + 2 * D_vec[idx] + } + } + ## Absorbing treated: turn on at t=8, stay on + for (i in (N_rev + 1):(N_rev + N_abs)) { + for (t in 1:TT) { + idx <- (i - 1) * TT + t + D_vec[idx] <- as.integer(t >= 8) + Y_vec[idx] <- rnorm(1) + 2 * D_vec[idx] + } + } + ## Never-treated controls + for (i in (N_rev + N_abs + 1):N) { + for (t in 1:TT) { + idx <- (i - 1) * TT + t + D_vec[idx] <- 0L + Y_vec[idx] <- rnorm(1) + } + } + data.frame( + id = rep(1:N, each = TT), + time = rep(1:TT, N), + Y = Y_vec, + D = D_vec + ) +} + +## DGP-STAG: staggered adoption (3 cohorts) for E6 +dgp_stag <- function(seed = 55) { + set.seed(seed) + N <- 30; TT <- 20; Ntr <- 18 + cohort_times <- c(rep(6, 6), rep(10, 6), rep(14, 6), rep(TT + 1, 12)) + D <- matrix(0, TT, N) + for (i in 1:Ntr) { + if (cohort_times[i] <= TT) D[cohort_times[i]:TT, i] <- 1 + } + alpha_i <- rnorm(N, 0, 2) + xi_t <- rnorm(TT, 0, 1) + eps <- matrix(rnorm(N * TT, 0, 1), TT, N) + Y <- outer(xi_t, rep(1, N)) + outer(rep(1, TT), alpha_i) + 2 * D + eps + data.frame( + id = rep(1:N, each = TT), + time = rep(1:TT, N), + Y = c(Y), + D = c(D) + ) +} + +## Shared parametric call helper +fect_para_full <- function(d, para.error = "auto", vartype = "parametric", + nboots = 100, seed = 42, ...) { + suppressWarnings(suppressMessages( + fect( + Y ~ D, + data = d, + index = c("id", "time"), + method = "fe", + force = "two-way", + time.component.from = "nevertreated", + se = TRUE, + vartype = vartype, + para.error = para.error, + nboots = nboots, + parallel = FALSE, + keep.sims = TRUE, + seed = seed, + CV = FALSE, + ... + ) + )) +} + +## ============================================================================ +## T4: Point estimate byte-stability across all three para.error modes +## ============================================================================ + +test_that("T4: att.avg is byte-identical across para.error = ar, empirical, wild", { + skip_on_cran() + df <- dgp_a(seed = 42) + fit_ar <- fect_para_full(df, para.error = "ar", nboots = 50) + fit_emp <- fect_para_full(df, para.error = "empirical", nboots = 50) + fit_wld <- fect_para_full(df, para.error = "wild", nboots = 50) + + expect_identical(fit_ar$att.avg, fit_emp$att.avg, + label = "att.avg: ar vs empirical should be byte-identical") + expect_identical(fit_ar$att.avg, fit_wld$att.avg, + label = "att.avg: ar vs wild should be byte-identical") +}) + +## ============================================================================ +## T7: para.error = "ar" on missing-data panel succeeds +## ============================================================================ + +test_that("T7: para.error = 'ar' succeeds on missing-data panel", { + skip_on_cran() + df_m <- dgp_m(seed = 1) + fit <- suppressWarnings(suppressMessages( + fect( + Y ~ D, + data = df_m, + index = c("id", "time"), + method = "fe", + force = "two-way", + time.component.from = "nevertreated", + se = TRUE, + vartype = "parametric", + para.error = "ar", + na.rm = FALSE, + nboots = 100, + parallel = FALSE, + keep.sims = TRUE, + CV = FALSE + ) + )) + expect_equal(fit$para.error, "ar", + label = "para.error should resolve to 'ar' on missing-data panel") + ## At most 20% NA in att.avg.boot (spec T7 tolerance) + na_rate <- mean(is.na(c(fit$att.avg.boot))) + expect_lte(na_rate, 0.20, + label = sprintf("NA rate in att.avg.boot = %.2f%%, should be <= 20%%", + na_rate * 100)) +}) + +## ============================================================================ +## T9, T10 (spec) — vartype = "wild" deprecation alias +## REMOVED: vartype = "wild" was never released as a standalone vartype, so +## there is no caller to deprecate. The redesign exposes para.error directly. +## +## T11 (spec) / covered in builder file — verify fit$para.error stores resolved value +## Already in test-para-error.R (Test 1), not repeated here. + +## T12 (spec) / covered in builder file (Test 10), not repeated here. + +## ============================================================================ +## T13: estimand() location-shift applies to all three para.error modes +## ============================================================================ + +test_that("T13: estimand() percentile CI contains point estimate for all para.error modes", { + skip_on_cran() + df <- dgp_a(seed = 42) + for (pm in c("ar", "empirical", "wild")) { + fit <- fect_para_full(df, para.error = pm, nboots = 200) + est <- estimand(fit, "att", "overall", window = c(1, 8), ci.method = "percentile") + expect_true( + is.finite(est$ci.lo) && is.finite(est$ci.hi), + label = sprintf("T13 %s: CI must be finite", pm) + ) + expect_true( + est$ci.lo < fit$att.avg && fit$att.avg < est$ci.hi, + label = sprintf( + "T13 %s: point estimate %.4f must be inside CI [%.4f, %.4f]", + pm, fit$att.avg, est$ci.lo, est$ci.hi + ) + ) + } +}) + +## ============================================================================ +## T14: Anti-regression — vartype = "bootstrap" unchanged +## ============================================================================ + +test_that("T14: vartype='bootstrap' produces finite, sensible results (anti-regression)", { + skip_on_cran() + data("simdata", package = "fect") + set.seed(42) + fit <- suppressMessages( + fect(Y ~ D, data = simdata, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, vartype = "bootstrap", + nboots = 50, parallel = FALSE, seed = 42, CV = FALSE) + ) + expect_equal(fit$vartype, "bootstrap") + expect_true(is.numeric(fit$att.avg) && !is.na(fit$att.avg), + label = "bootstrap att.avg must be finite") + ## Anti-regression: att.avg should be near 2.5 for simdata (known fixture) + expect_true(abs(fit$att.avg) < 10, + label = sprintf("bootstrap att.avg = %.4f looks reasonable", fit$att.avg)) + ## Ensure para.error is NULL for bootstrap path + expect_null(fit$para.error, + label = "para.error should be NULL for bootstrap fits") +}) + +## ============================================================================ +## T15: Anti-regression — vartype = "jackknife" unchanged +## ============================================================================ + +test_that("T15: vartype='jackknife' produces finite, sensible results (anti-regression)", { + skip_on_cran() + ## Small panel so jackknife is fast + df_small <- dgp_a(seed = 7) + df_small <- df_small[df_small$id <= 20, ] + fit <- suppressMessages( + fect(Y ~ D, data = df_small, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, vartype = "jackknife", + parallel = FALSE, CV = FALSE) + ) + expect_equal(fit$vartype, "jackknife") + expect_true(is.numeric(fit$att.avg) && !is.na(fit$att.avg), + label = "jackknife att.avg must be finite") + expect_null(fit$para.error, + label = "para.error should be NULL for jackknife fits") +}) + +## ============================================================================ +## T16: Anti-regression — vartype = "parametric" with para.error = "auto" unchanged +## ============================================================================ + +test_that("T16: vartype='parametric' para.error='auto' produces same resolved path as before", { + skip_on_cran() + df <- dgp_a(seed = 42) + fit <- fect_para_full(df, para.error = "auto", nboots = 50) + ## On fully-observed panel, auto should resolve to "empirical" + expect_equal(fit$para.error, "empirical", + label = "auto should resolve to empirical on fully-observed panel") + ## Point estimate should be near 3.0 (true ATT) + expect_true(abs(fit$att.avg - 3.0) < 1.5, + label = sprintf("att.avg = %.4f should be near true ATT = 3.0", fit$att.avg)) + ## est.avg is a matrix (class = matrix/array) + expect_true(is.matrix(fit$est.avg), + label = "est.avg should be a matrix") + expect_true(all(is.finite(fit$est.avg[, "ATT.avg"])), + label = "est.avg[,ATT.avg] should be finite") +}) + +## ============================================================================ +## T17: aptt + para.error = "wild" + bca returns finite CIs (DGP-B) +## ============================================================================ + +test_that("T17: aptt and log.att estimands work with para.error='wild' on DGP-B", { + skip_on_cran() + df <- dgp_b(seed = 99) + fit <- suppressMessages( + fect( + Y ~ D, + data = df, + index = c("id", "time"), + method = "fe", + force = "two-way", + time.component.from = "nevertreated", + se = TRUE, + vartype = "parametric", + para.error = "wild", + nboots = 200, + parallel = FALSE, + keep.sims = TRUE, + seed = 99, + CV = FALSE + ) + ) + ## aptt estimand + est_aptt <- estimand(fit, "aptt", "event.time", ci.method = "bca") + expect_true(all(is.finite(est_aptt$ci.lo)) && all(is.finite(est_aptt$ci.hi)), + label = "T17: aptt CI must be finite for all event times") + expect_true(all(est_aptt$estimate > 0), + label = sprintf("T17: aptt estimates should be positive (true APTT>0), got min=%.4f", + min(est_aptt$estimate))) + + ## log.att estimand + est_log <- estimand(fit, "log.att", "event.time", ci.method = "bca") + expect_true(all(is.finite(est_log$ci.lo)) && all(is.finite(est_log$ci.hi)), + label = "T17: log.att CI must be finite for all event times") + ## Each log.att estimate should be within +/-0.1 of log(1.3) = 0.2624 + true_logatt <- log(1.3) + for (i in seq_len(nrow(est_log))) { + expect_true( + abs(est_log$estimate[i] - true_logatt) < 0.15, + label = sprintf( + "T17: log.att estimate[%d] = %.4f should be within 0.15 of %.4f", + i, est_log$estimate[i], true_logatt + ) + ) + } +}) + +## ============================================================================ +## T18: CI width parity — wild vs empirical within 30% (nboots = 1000) +## ============================================================================ + +test_that("T18: CI width parity — wild/empirical ratio in [0.70, 1.30]", { + skip_on_cran() + df <- dgp_a(seed = 42) + fit_emp <- fect_para_full(df, para.error = "empirical", nboots = 1000) + fit_wld <- fect_para_full(df, para.error = "wild", nboots = 1000) + fit_ar <- fect_para_full(df, para.error = "ar", nboots = 1000) + + est_emp <- estimand(fit_emp, "att", "overall", window = c(1, 8), ci.method = "basic") + est_wld <- estimand(fit_wld, "att", "overall", window = c(1, 8), ci.method = "basic") + est_ar <- estimand(fit_ar, "att", "overall", window = c(1, 8), ci.method = "basic") + + width_emp <- est_emp$ci.hi - est_emp$ci.lo + width_wld <- est_wld$ci.hi - est_wld$ci.lo + width_ar <- est_ar$ci.hi - est_ar$ci.lo + + ratio_wld_emp <- width_wld / width_emp + ratio_ar_emp <- width_ar / width_emp + + expect_gte(ratio_wld_emp, 0.70, + label = sprintf("T18: wild/empirical width ratio = %.4f should be >= 0.70", + ratio_wld_emp)) + expect_lte(ratio_wld_emp, 1.30, + label = sprintf("T18: wild/empirical width ratio = %.4f should be <= 1.30", + ratio_wld_emp)) + expect_gte(ratio_ar_emp, 0.50, + label = sprintf("T18: ar/empirical width ratio = %.4f should be >= 0.50", + ratio_ar_emp)) +}) + +## ============================================================================ +## T19, T20, T21 (spec) --- coverage validation simulations +## +## MOVED to tests/coverage-study/run_para_error_coverage.R +## +## These three Monte-Carlo studies (T19: 100 reps x 1000 nboots x 15 cells on +## DGP-A IID; T20: same on DGP-A8 AR(1) rho=0.8; T21: 50 reps x 500 nboots +## width parity) take ~30 min wall and are not appropriate for routine +## devtools::test() runs. They live alongside the coverage-study artifacts. +## +## Run them via: Rscript tests/coverage-study/run_para_error_coverage.R +## +## When to run: any change to R/boot.R parametric branch, R/po-estimands.R +## location-shift code, the vartype / ci.method / para.error machinery, +## jackknife dispatch, or eff.boot construction. See the README in that +## directory for full trigger list and acceptance criteria. +## ============================================================================ + +## ============================================================================ +## E2: para.error = "wild" with nboots = 200 completes with >= 95% success rate +## ============================================================================ + +test_that("E2: para.error='wild' nboots=200 completes with >=95% successful replicates", { + skip_on_cran() + df <- dgp_a(seed = 42) + fit <- fect_para_full(df, para.error = "wild", nboots = 200) + n_ok <- sum(!is.na(c(fit$att.avg.boot))) + expect_gte(n_ok, 190L, + label = sprintf("E2: %d/200 replicates succeeded (need >=190)", n_ok)) + ## est.avg is a matrix + expect_true(is.matrix(fit$est.avg), + label = "E2: est.avg should be a matrix") + expect_true(all(is.finite(fit$est.avg[, "ATT.avg"])), + label = "E2: est.avg[,ATT.avg] should be finite") + expect_true(all(is.finite(fit$est.avg[, "CI.lower"])), + label = "E2: est.avg[,CI.lower] should be finite") + expect_true(all(is.finite(fit$est.avg[, "CI.upper"])), + label = "E2: est.avg[,CI.upper] should be finite") +}) + +## ============================================================================ +## E3: para.error = "wild" with treatment reversals routes to hard error +## ============================================================================ + +test_that("E3: para.error='wild' with treatment reversals fires the parametric reversal gate", { + skip_on_cran() + df_rev <- dgp_rev(seed = 77) + expect_error( + suppressMessages( + fect( + Y ~ D, + data = df_rev, + index = c("id", "time"), + method = "fe", + force = "two-way", + time.component.from = "nevertreated", + se = TRUE, + vartype = "parametric", + para.error = "wild", + nboots = 50, + parallel = FALSE, + CV = FALSE + ) + ), + regexp = "Parametric bootstrap is not valid when treatment reversal", + fixed = FALSE, + label = "E3: reversal gate should fire for para.error='wild'" + ) +}) + +## ============================================================================ +## E4: para.error = "wild" + time.component.from = "notyettreated" -> hard error +## ============================================================================ + +test_that("E4: para.error='wild' + time.component.from='notyettreated' fires the notyettreated gate", { + skip_on_cran() + df <- dgp_a(seed = 42) + expect_error( + suppressMessages( + fect( + Y ~ D, + data = df, + index = c("id", "time"), + method = "fe", + force = "two-way", + time.component.from = "notyettreated", + se = TRUE, + vartype = "parametric", + para.error = "wild", + nboots = 50, + parallel = FALSE, + CV = FALSE + ) + ), + regexp = "notyettreated", + fixed = FALSE, + label = "E4: notyettreated gate should fire for para.error='wild'" + ) +}) + +## ============================================================================ +## E6: para.error = "wild" with staggered adoption completes, <= 10% NA +## ============================================================================ + +test_that("E6: para.error='wild' with staggered adoption completes, <=10% NA in att.avg.boot", { + skip_on_cran() + df_stag <- dgp_stag(seed = 55) + fit <- suppressMessages( + fect( + Y ~ D, + data = df_stag, + index = c("id", "time"), + method = "fe", + force = "two-way", + time.component.from = "nevertreated", + se = TRUE, + vartype = "parametric", + para.error = "wild", + nboots = 200, + parallel = FALSE, + keep.sims = TRUE, + CV = FALSE + ) + ) + expect_true(!is.null(fit$att.avg.boot), + label = "E6: att.avg.boot should exist") + na_rate <- mean(is.na(c(fit$att.avg.boot))) + expect_lte(na_rate, 0.10, + label = sprintf("E6: NA rate in att.avg.boot = %.2f%% (should be <= 10%%)", + na_rate * 100)) +}) diff --git a/tests/testthat/test-para-error.R b/tests/testthat/test-para-error.R new file mode 100644 index 00000000..376b47f9 --- /dev/null +++ b/tests/testthat/test-para-error.R @@ -0,0 +1,278 @@ +## Unit tests for para.error argument (spec: wild-as-paraerror) +## +## Tests verify: +## 1. para.error = "auto" default produces correct resolved mode stored on fit +## 2. para.error = "empirical" runs without error on fully-observed panel +## 3. para.error = "wild" runs without error on fully-observed panel, all 5 +## ci.methods return CIs containing the true ATT +## 4. para.error = "wild" hard-errors on missing-data panel +## 5. para.error = "empirical" hard-errors on missing-data panel +## 6. Invalid para.error value produces a clear error message +## 7. para.error is ignored when vartype != "parametric" +## 8. para.error = "ar" works on fully-observed panel +## 9. para.error = "auto" resolves to "ar" on missing-data panel + +## ----------------------------------------------------------------------- +## Shared test fixture +## ----------------------------------------------------------------------- + +make_panel <- function(N = 40, TT = 20, T0 = 12, Ntr = 12, seed = 101, + add_missing = FALSE, n_missing = 50) { + set.seed(seed) + alpha_i <- rnorm(N, 0, 2) + xi_t <- rnorm(TT, 0, 1) + D <- matrix(0L, TT, N) + D[(T0 + 1):TT, 1:Ntr] <- 1L + eps <- matrix(rnorm(N * TT, 0, 1), TT, N) + Y <- outer(xi_t, rep(1, N)) + outer(rep(1, TT), alpha_i) + 3.0 * D + eps + d <- data.frame( + id = rep(1:N, each = TT), + time = rep(1:TT, N), + Y = as.vector(Y), + D = as.vector(D) + ) + if (add_missing) { + set.seed(seed + 999) + d$Y[sample(nrow(d), n_missing)] <- NA + } + d +} + +fect_para <- function(d, para.error = "auto", vartype = "parametric", + nboots = 100, seed = 42, ...) { + set.seed(seed) + suppressWarnings(suppressMessages( + fect( + Y ~ D, + data = d, + index = c("id", "time"), + method = "fe", + force = "two-way", + time.component.from = "nevertreated", + se = TRUE, + vartype = vartype, + para.error = para.error, + nboots = nboots, + parallel = FALSE, + keep.sims = TRUE, + CV = FALSE, + ... + ) + )) +} + +## ----------------------------------------------------------------------- +## Test 1: auto default resolves to "empirical" for fully-observed panel +## ----------------------------------------------------------------------- + +test_that("para.error = 'auto' resolves to 'empirical' on fully-observed panel", { + skip_on_cran() + d <- make_panel() + fit <- fect_para(d, para.error = "auto") + expect_equal(fit$para.error, "empirical") + expect_equal(fit$vartype, "parametric") +}) + +## ----------------------------------------------------------------------- +## Test 2: para.error = "empirical" runs and stores correct label +## ----------------------------------------------------------------------- + +test_that("para.error = 'empirical' runs on fully-observed panel", { + skip_on_cran() + d <- make_panel() + fit <- fect_para(d, para.error = "empirical") + expect_equal(fit$para.error, "empirical") + + ## CI should be sensible (contains true ATT ≈ 3) + res <- estimand(fit, "att", "overall", window = c(1, 8), ci.method = "bca") + expect_true(res$ci.lo < 3.0 && res$ci.hi > 3.0, + info = sprintf("BCA CI [%.3f, %.3f] should contain 3.0", res$ci.lo, res$ci.hi)) +}) + +## ----------------------------------------------------------------------- +## Test 3: para.error = "wild" runs and all ci.methods return sensible CIs +## ----------------------------------------------------------------------- + +test_that("para.error = 'wild' runs on fully-observed panel and all ci.methods work", { + skip_on_cran() + d <- make_panel() + fit <- fect_para(d, para.error = "wild", nboots = 200) + expect_equal(fit$para.error, "wild") + expect_equal(fit$vartype, "parametric") + + for (m in c("normal", "basic", "percentile", "bc", "bca")) { + res <- estimand(fit, "att", "overall", window = c(1, 8), ci.method = m) + expect_true( + !is.na(res$ci.lo) && !is.na(res$ci.hi), + info = sprintf("ci.method='%s': CI should not be NA", m) + ) + expect_true( + res$ci.lo < 3.0 && res$ci.hi > 3.0, + info = sprintf( + "ci.method='%s': CI [%.3f, %.3f] should contain 3.0", + m, res$ci.lo, res$ci.hi + ) + ) + expect_true( + res$ci.hi - res$ci.lo > 0, + info = sprintf("ci.method='%s': CI width should be positive", m) + ) + } +}) + +## ----------------------------------------------------------------------- +## Test 4: para.error = "wild" hard-errors on missing-data panel +## ----------------------------------------------------------------------- + +test_that("para.error = 'wild' hard-errors on missing-data panel", { + skip_on_cran() + d <- make_panel(add_missing = TRUE) + expect_error( + fect( + Y ~ D, + data = d, + index = c("id", "time"), + method = "fe", + force = "two-way", + time.component.from = "nevertreated", + se = TRUE, + vartype = "parametric", + para.error = "wild", + na.rm = FALSE, + nboots = 50, + parallel = FALSE, + CV = FALSE + ), + regexp = "fully-observed panel", + fixed = FALSE + ) +}) + +## ----------------------------------------------------------------------- +## Test 6: para.error = "empirical" hard-errors on missing-data panel +## ----------------------------------------------------------------------- + +test_that("para.error = 'empirical' hard-errors on missing-data panel", { + skip_on_cran() + d <- make_panel(add_missing = TRUE) + expect_error( + fect( + Y ~ D, + data = d, + index = c("id", "time"), + method = "fe", + force = "two-way", + time.component.from = "nevertreated", + se = TRUE, + vartype = "parametric", + para.error = "empirical", + na.rm = FALSE, + nboots = 50, + parallel = FALSE, + CV = FALSE + ), + regexp = "fully-observed panel", + fixed = FALSE + ) +}) + +## ----------------------------------------------------------------------- +## Test 7: Invalid para.error value produces clear error +## ----------------------------------------------------------------------- + +test_that("invalid para.error value produces clear error", { + skip_on_cran() + d <- make_panel() + expect_error( + fect( + Y ~ D, + data = d, + index = c("id", "time"), + method = "fe", + force = "two-way", + time.component.from = "nevertreated", + se = TRUE, + vartype = "parametric", + para.error = "invalid_value", + nboots = 50, + parallel = FALSE, + CV = FALSE + ), + regexp = "para.error", + fixed = FALSE + ) +}) + +## ----------------------------------------------------------------------- +## Test 8: para.error is ignored when vartype != "parametric" +## ----------------------------------------------------------------------- + +test_that("para.error is accepted but ignored for vartype = 'bootstrap'", { + skip_on_cran() + d <- make_panel() + ## Should run without error even though para.error = "wild" is passed + ## with vartype = "bootstrap" (non-parametric path ignores it) + fit <- NULL + expect_no_error({ + set.seed(42) + fit <- suppressWarnings(suppressMessages(fect( + Y ~ D, + data = d, + index = c("id", "time"), + method = "fe", + force = "two-way", + time.component.from = "nevertreated", + se = TRUE, + vartype = "bootstrap", + para.error = "wild", + nboots = 50, + parallel = FALSE, + CV = FALSE + ))) + }) + ## vartype is bootstrap, para.error on fit object should be NULL + ## (fect_boot para.error.resolved is only set in the parametric branch) + expect_equal(fit$vartype, "bootstrap") +}) + +## ----------------------------------------------------------------------- +## Test 9: para.error = "ar" works on fully-observed panel +## ----------------------------------------------------------------------- + +test_that("para.error = 'ar' runs on fully-observed panel", { + skip_on_cran() + d <- make_panel() + fit <- fect_para(d, para.error = "ar") + expect_equal(fit$para.error, "ar") + + res <- estimand(fit, "att", "overall", window = c(1, 8), ci.method = "bca") + expect_true(res$ci.lo < 3.0 && res$ci.hi > 3.0, + info = sprintf("BCA CI [%.3f, %.3f] should contain 3.0", res$ci.lo, res$ci.hi)) +}) + +## ----------------------------------------------------------------------- +## Test 10: para.error = "auto" resolves to "ar" on missing-data panel +## ----------------------------------------------------------------------- + +test_that("para.error = 'auto' resolves to 'ar' on missing-data panel", { + skip_on_cran() + d <- make_panel(add_missing = TRUE) + ## na.rm = FALSE needed so missing cells are preserved in I + fit <- suppressWarnings(suppressMessages(fect( + Y ~ D, + data = d, + index = c("id", "time"), + method = "fe", + force = "two-way", + time.component.from = "nevertreated", + se = TRUE, + vartype = "parametric", + para.error = "auto", + na.rm = FALSE, + nboots = 100, + parallel = FALSE, + keep.sims = TRUE, + CV = FALSE + ))) + expect_equal(fit$para.error, "ar") +}) diff --git a/tests/testthat/test-paraboot-parity.R b/tests/testthat/test-paraboot-parity.R index b9ae726b..e37bb372 100644 --- a/tests/testthat/test-paraboot-parity.R +++ b/tests/testthat/test-paraboot-parity.R @@ -69,12 +69,17 @@ test_that("PAR-2: ife+nevertreated+parametric parity (byte-identical; must equal baseline <- load_baseline() d <- make_fixture_data() + ## Pin pre-2.4.3 EM defaults: baseline rds was captured at tol=1e-3, + ## max.iteration=1000 (v2.4.2 defaults). v2.4.3 tightened defaults to + ## tol=1e-5/max.iteration=5000. Test preserves byte-equality contract + ## against the existing baseline by passing legacy values explicitly. set.seed(2026) out <- suppressWarnings(suppressMessages(fect( Y ~ D, data = d, index = c("id", "time"), method = "ife", time.component.from = "nevertreated", r = 1, se = TRUE, vartype = "parametric", nboots = 50, - CV = FALSE, parallel = FALSE + CV = FALSE, parallel = FALSE, + tol = 1e-3, max.iteration = 1000 ))) expect_true(identical(out$att.avg, baseline$ife_nev_para$att.avg)) @@ -90,11 +95,13 @@ test_that("PAR-3: bootstrap vartype parity — ife+notyettreated", { baseline <- load_baseline() d <- make_fixture_data() + ## Pin pre-2.4.3 EM defaults; see PAR-2. set.seed(2026) out <- suppressWarnings(suppressMessages(fect( Y ~ D, data = d, index = c("id", "time"), method = "ife", r = 1, se = TRUE, - vartype = "bootstrap", nboots = 50, CV = FALSE, parallel = FALSE + vartype = "bootstrap", nboots = 50, CV = FALSE, parallel = FALSE, + tol = 1e-3, max.iteration = 1000 ))) expect_true(identical(out$att.avg, baseline$ife_nt_boot$att.avg)) @@ -109,11 +116,13 @@ test_that("PAR-4: bootstrap vartype parity — ife+nevertreated", { baseline <- load_baseline() d <- make_fixture_data() + ## Pin pre-2.4.3 EM defaults; see PAR-2. set.seed(2026) out <- suppressWarnings(suppressMessages(fect( Y ~ D, data = d, index = c("id", "time"), method = "ife", time.component.from = "nevertreated", - r = 1, se = TRUE, vartype = "bootstrap", nboots = 50, CV = FALSE, parallel = FALSE + r = 1, se = TRUE, vartype = "bootstrap", nboots = 50, CV = FALSE, parallel = FALSE, + tol = 1e-3, max.iteration = 1000 ))) expect_true(identical(out$att.avg, baseline$ife_nev_boot$att.avg)) @@ -147,10 +156,12 @@ test_that("PAR-6: jackknife parity — ife+notyettreated", { baseline <- load_baseline() d <- make_fixture_data() + ## Pin pre-2.4.3 EM defaults; see PAR-2. out <- suppressWarnings(suppressMessages(fect( Y ~ D, data = d, index = c("id", "time"), method = "ife", r = 1, se = TRUE, - vartype = "jackknife", CV = FALSE, parallel = FALSE + vartype = "jackknife", CV = FALSE, parallel = FALSE, + tol = 1e-3, max.iteration = 1000 ))) expect_true(identical(out$att.avg, baseline$ife_jk$att.avg)) diff --git a/tests/testthat/test-sample-slot.R b/tests/testthat/test-sample-slot.R new file mode 100644 index 00000000..348325a2 --- /dev/null +++ b/tests/testthat/test-sample-slot.R @@ -0,0 +1,231 @@ +## --------------------------------------------------------------- +## Tests for the $sample logical mask on the fect() return value. +## +## $sample is a logical matrix (same dims as $Y.dat) that is TRUE for +## every cell used in any part of the estimation procedure: +## obs.missing == 1 (treated) +## obs.missing == 2 (control / pre-treatment) +## obs.missing == 5 (placebo or carryover period) +## Cells with obs.missing == 3 (missing/unbalanced) or 4 (removed unit) +## are FALSE. +## +## Derived via: sample <- obs.missing %in% c(1L, 2L, 5L) +## --------------------------------------------------------------- + +suppressWarnings(data("simdata", package = "fect")) + +## -- S.1 Slot exists and is a logical matrix -- + +test_that("S.1: fit$sample exists and is a logical matrix", { + + skip_on_cran() + + set.seed(1) + fit <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), + method = "fe", CV = FALSE, se = FALSE, parallel = FALSE + ) + )) + + expect_true("sample" %in% names(fit)) + expect_true(is.matrix(fit$sample)) + expect_true(is.logical(fit$sample)) +}) + + +## -- S.2 Dimensions match Y.dat -- + +test_that("S.2: fit$sample has the same dimensions as fit$Y.dat", { + + skip_on_cran() + + set.seed(1) + fit <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), + method = "fe", CV = FALSE, se = FALSE, parallel = FALSE + ) + )) + + expect_equal(dim(fit$sample), dim(fit$Y.dat)) +}) + + +## -- S.3 Consistency with obs.missing codes -- +## sample must equal obs.missing %in% c(1L, 2L, 5L) cell-for-cell. + +test_that("S.3: fit$sample equals obs.missing %in% c(1L, 2L, 5L)", { + + skip_on_cran() + + set.seed(1) + fit <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), + method = "fe", CV = FALSE, se = FALSE, parallel = FALSE + ) + )) + + expected <- matrix(fit$obs.missing %in% c(1L, 2L, 5L), + nrow = nrow(fit$obs.missing), ncol = ncol(fit$obs.missing), + dimnames = dimnames(fit$obs.missing)) + expect_identical(fit$sample, expected) +}) + + +## -- S.4 Removed units are FALSE -- +## Units with rm.id (obs.missing == 4) must be entirely FALSE in $sample. + +test_that("S.4: cells with obs.missing == 4 (removed) are FALSE in $sample", { + + skip_on_cran() + + set.seed(1) + fit <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), + method = "fe", CV = FALSE, se = FALSE, parallel = FALSE + ) + )) + + removed_cells <- fit$obs.missing == 4L + ## If no removed units, skip the body (not an error — just no removed units). + if (any(removed_cells)) { + expect_true(all(!fit$sample[removed_cells])) + } else { + expect_true(TRUE) ## no removed units — pass trivially + } +}) + + +## -- S.5 Missing cells are FALSE -- +## obs.missing == 3 cells must be FALSE in $sample. + +test_that("S.5: cells with obs.missing == 3 (missing) are FALSE in $sample", { + + skip_on_cran() + + set.seed(1) + fit <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), + method = "fe", CV = FALSE, se = FALSE, parallel = FALSE + ) + )) + + missing_cells <- fit$obs.missing == 3L + if (any(missing_cells)) { + expect_true(all(!fit$sample[missing_cells])) + } else { + expect_true(TRUE) + } +}) + + +## -- S.6 Placebo period cells are TRUE -- +## When placeboTest = TRUE, pre-treatment placebo cells (obs.missing == 5) +## must appear as TRUE in $sample. + +test_that("S.6: placebo cells (obs.missing == 5) are TRUE in $sample", { + + skip_on_cran() + + set.seed(2) + fit <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), + method = "fe", CV = FALSE, se = FALSE, parallel = FALSE, + placeboTest = TRUE, placebo.period = c(-2, -1) + ) + )) + + placebo_cells <- fit$obs.missing == 5L + if (any(placebo_cells)) { + expect_true(all(fit$sample[placebo_cells])) + } else { + ## If no placebo cells found, the placeboTest may not have produced code 5 + ## under this data/seed — at minimum check slot still exists and is logical. + expect_true(is.logical(fit$sample)) + } +}) + + +## -- S.7 at_least_some_TRUE: basic sanity that $sample is not all FALSE -- + +test_that("S.7: fit$sample has at least some TRUE cells (treated + control)", { + + skip_on_cran() + + set.seed(1) + fit <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), + method = "fe", CV = FALSE, se = FALSE, parallel = FALSE + ) + )) + + expect_true(any(fit$sample)) +}) + + +## -- S.8 Treated cells are TRUE -- +## obs.missing == 1 cells must be TRUE in $sample. + +test_that("S.8: treated cells (obs.missing == 1) are TRUE in $sample", { + + skip_on_cran() + + set.seed(1) + fit <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), + method = "fe", CV = FALSE, se = FALSE, parallel = FALSE + ) + )) + + treated_cells <- fit$obs.missing == 1L + expect_true(any(treated_cells)) + expect_true(all(fit$sample[treated_cells])) +}) + + +## -- S.9 Control cells are TRUE -- +## obs.missing == 2 cells must be TRUE in $sample. + +test_that("S.9: control cells (obs.missing == 2) are TRUE in $sample", { + + skip_on_cran() + + set.seed(1) + fit <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), + method = "fe", CV = FALSE, se = FALSE, parallel = FALSE + ) + )) + + control_cells <- fit$obs.missing == 2L + expect_true(any(control_cells)) + expect_true(all(fit$sample[control_cells])) +}) + + +## -- S.10 Method = ife gives same slot structure -- + +test_that("S.10: fit$sample present and logical for method='ife'", { + + skip_on_cran() + + set.seed(3) + fit <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), + method = "ife", r = 2, CV = FALSE, se = FALSE, parallel = FALSE + ) + )) + + expect_true("sample" %in% names(fit)) + expect_true(is.logical(fit$sample)) + expect_equal(dim(fit$sample), dim(fit$Y.dat)) +}) diff --git a/tests/testthat/test-score-bench.R b/tests/testthat/test-score-bench.R new file mode 100644 index 00000000..ea6a51c5 --- /dev/null +++ b/tests/testthat/test-score-bench.R @@ -0,0 +1,165 @@ +## --------------------------------------------------------------- +## Runtime benchmarks for cv.method timing comparison. +## Heavy: each test fits the same DGP under {loo, all_units, treated_units} +## and prints elapsed time per call. Skip on CRAN. +## +## Originally Section I of test-score-unify.R; split out 2026-05-03. +## Shared fixtures live in helper-score-unify.R. +## --------------------------------------------------------------- + +## ================================================================= +## Section I: Runtime Benchmarks (cv.method timing comparison) +## Informational only — skip on CRAN +## ================================================================= + +test_that("BENCH1: IFE timing comparison (loo vs all_units vs treated_units)", { + + skip_on_cran() + + cat("\n=== Runtime Benchmark: IFE nevertreated cv.method timing ===\n") + + set.seed(42) + t_loo <- system.time( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "loo", + se = FALSE, + parallel = FALSE + ) + )) + ) + cat(sprintf(" IFE loo: %6.2f sec (elapsed)\n", t_loo["elapsed"])) + + set.seed(42) + t_au <- system.time( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + ) + cat(sprintf(" IFE all_units: %6.2f sec (elapsed)\n", t_au["elapsed"])) + + set.seed(42) + t_tu <- system.time( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "treated_units", + se = FALSE, + parallel = FALSE + ) + )) + ) + cat(sprintf(" IFE treated_units: %6.2f sec (elapsed)\n", t_tu["elapsed"])) + + cat(sprintf(" Speedup (loo/all_units): %.2fx\n", + t_loo["elapsed"] / max(t_au["elapsed"], 0.001))) + cat(sprintf(" Speedup (loo/treated_units): %.2fx\n", + t_loo["elapsed"] / max(t_tu["elapsed"], 0.001))) + cat("=== End IFE Benchmark ===\n") + + # All three must complete — that's the real test + expect_true(TRUE) +}) + +test_that("BENCH2: CFE timing comparison (loo vs all_units vs treated_units)", { + + skip_on_cran() + + cat("\n=== Runtime Benchmark: CFE nevertreated cv.method timing ===\n") + + set.seed(42) + t_loo <- system.time( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "cfe", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "loo", + se = FALSE, + parallel = FALSE + ) + )) + ) + cat(sprintf(" CFE loo: %6.2f sec (elapsed)\n", t_loo["elapsed"])) + + set.seed(42) + t_au <- system.time( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "cfe", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + ) + cat(sprintf(" CFE all_units: %6.2f sec (elapsed)\n", t_au["elapsed"])) + + set.seed(42) + t_tu <- system.time( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "cfe", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "treated_units", + se = FALSE, + parallel = FALSE + ) + )) + ) + cat(sprintf(" CFE treated_units: %6.2f sec (elapsed)\n", t_tu["elapsed"])) + + cat(sprintf(" Speedup (loo/all_units): %.2fx\n", + t_loo["elapsed"] / max(t_au["elapsed"], 0.001))) + cat(sprintf(" Speedup (loo/treated_units): %.2fx\n", + t_loo["elapsed"] / max(t_tu["elapsed"], 0.001))) + cat("=== End CFE Benchmark ===\n") + + expect_true(TRUE) +}) + diff --git a/tests/testthat/test-score-fect-cv.R b/tests/testthat/test-score-fect-cv.R new file mode 100644 index 00000000..e1cf5275 --- /dev/null +++ b/tests/testthat/test-score-fect-cv.R @@ -0,0 +1,172 @@ +## --------------------------------------------------------------- +## Tests for fect_cv: regression coverage (S2) + cv.method extension +## in fect_cv (Section B, NEW for Phase 2). +## +## Originally part of test-score-unify.R; split out 2026-05-03 for +## progress visibility. Shared fixtures live in helper-score-unify.R. +## --------------------------------------------------------------- + +## ================================================================= +## S2: fect_cv regression test (before vs after refactor) +## ================================================================= + +test_that("S2.1: IFE method CV - r.cv and CV.out snapshot", { + + skip_on_cran() + cv_out <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, + data = simdata, + index = c("id", "time"), + method = "ife", + CV = TRUE, + r = c(0, 3), + criterion = "mspe", + se = FALSE, + parallel = FALSE + ) + )) + # r.cv should be a non-negative integer in [0, 3] + expect_true(cv_out$r.cv >= 0 && cv_out$r.cv <= 3) + + # CV.out should exist and have MSPE column with finite positive values + expect_true(!is.null(cv_out$CV.out)) + mspe_col <- cv_out$CV.out[, "MSPE"] + # At least some entries should be less than 1e20 (the init value) + expect_true(any(mspe_col < 1e19)) + expect_true(all(is.finite(mspe_col[mspe_col < 1e19]))) + expect_true(all(mspe_col[mspe_col < 1e19] > 0)) +}) + +test_that("S2.2: MC method CV - lambda.cv selection", { + + skip_on_cran() + cv_mc <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, + data = simdata, + index = c("id", "time"), + method = "mc", + CV = TRUE, + criterion = "mspe", + se = FALSE, + parallel = FALSE + ) + )) + # lambda.cv should be selected + expect_true(!is.null(cv_mc$lambda.cv) || !is.null(cv_mc$r.cv)) + expect_true(!is.null(cv_mc$CV.out)) +}) + +test_that("S2.3: GMoment column correctly populated (IFE)", { + + skip_on_cran() + cv_out <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, + data = simdata, + index = c("id", "time"), + method = "ife", + CV = TRUE, + r = c(0, 3), + criterion = "mspe", + se = FALSE, + parallel = FALSE + ) + )) + + # GMoment values should be finite and positive where computed + gm_col <- cv_out$CV.out[, "GMoment"] + computed <- gm_col[gm_col < 1e19] + if (length(computed) > 0) { + expect_true(all(is.finite(computed))) + expect_true(all(computed > 0)) + + # GMoment should generally differ from MSPTATT + msptatt_col <- cv_out$CV.out[, "MSPTATT"] + msptatt_computed <- msptatt_col[gm_col < 1e19] + if (length(msptatt_computed) > 0) { + if (length(computed) > 1) { + expect_false( + all(abs(computed - msptatt_computed) < 1e-15), + info = "GMoment should not be identical to MSPTATT for all r values" + ) + } + } + } +}) + + +## ================================================================= +## Section B: cv.method in fect_cv (NEW for Phase 2) +## ================================================================= + +test_that("CV1: cv.method='all_units' selects r.cv", { + + skip_on_cran() + cv_out <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, + data = simdata, + index = c("id", "time"), + method = "ife", + CV = TRUE, + r = c(0, 3), + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + # r.cv is integer in [0, 3] + expect_true(cv_out$r.cv >= 0 && cv_out$r.cv <= 3) + # CV.out exists with MSPE column + expect_true(!is.null(cv_out$CV.out)) + mspe_col <- cv_out$CV.out[, "MSPE"] + computed <- mspe_col[mspe_col < 1e19] + expect_true(all(is.finite(computed))) + expect_true(all(computed > 0)) +}) + +test_that("CV2: cv.method='treated_units' selects r.cv", { + + skip_on_cran() + cv_out <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, + data = simdata, + index = c("id", "time"), + method = "ife", + CV = TRUE, + r = c(0, 3), + cv.method = "treated_units", + se = FALSE, + parallel = FALSE + ) + )) + # r.cv is integer in [0, 3] + expect_true(cv_out$r.cv >= 0 && cv_out$r.cv <= 3) + # CV.out exists + expect_true(!is.null(cv_out$CV.out)) + mspe_col <- cv_out$CV.out[, "MSPE"] + computed <- mspe_col[mspe_col < 1e19] + expect_true(all(is.finite(computed))) + expect_true(all(computed > 0)) +}) + +test_that("CV3: Invalid cv.method rejected", { + + skip_on_cran() + expect_error( + fect::fect( + Y ~ D + X1 + X2, + data = simdata, + index = c("id", "time"), + method = "ife", + CV = TRUE, + cv.method = "invalid" + ), + "cv.method|arg" + ) +}) + + diff --git a/tests/testthat/test-score-fect-mspe.R b/tests/testthat/test-score-fect-mspe.R new file mode 100644 index 00000000..2c602d38 --- /dev/null +++ b/tests/testthat/test-score-fect-mspe.R @@ -0,0 +1,333 @@ +## --------------------------------------------------------------- +## Tests for fect_mspe: criterion (S3), cv.method (S4), weights (S6), +## norm.para (S7), return structure (S8), input validation (S9), and +## fect_mspe simplification (Section D, NEW for Phase 2). +## +## Originally part of test-score-unify.R; split out 2026-05-03 for +## progress visibility. Shared fixtures live in helper-score-unify.R. +## --------------------------------------------------------------- + +## ================================================================= +## S3: fect_mspe criterion support (updated for Phase 2) +## ================================================================= + +test_that("S3.1: Default criterion='mspe' matches old RMSE", { + + skip_on_cran() + res_new <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 123, criterion = "mspe") + )) + + # RMSE = sqrt(MSPE) invariant (P1) + if ("MSPE" %in% names(res_new$summary)) { + expect_equal(res_new$summary$RMSE, sqrt(res_new$summary$MSPE), + tolerance = 1e-10) + } +}) + +test_that("S3.2: All 7 criteria produce finite, positive scores", { + + skip_on_cran() + for (crit in c("mspe", "wmspe", "gmspe", "wgmspe", "mad", + "moment", "gmoment")) { + res <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 123, criterion = crit) + )) + crit_upper <- toupper(crit) + if (crit_upper %in% names(res$summary)) { + expect_true(all(is.finite(res$summary[[crit_upper]])), + info = paste("Criterion", crit, "should be finite")) + expect_true(all(res$summary[[crit_upper]] > 0), + info = paste("Criterion", crit, "should be positive")) + } + } +}) + + +## ================================================================= +## S4: fect_mspe with cv.method (Phase 2 — replaces mask.method) +## ================================================================= + +test_that("S4.1: cv.method='treated_units' masking runs without error", { + + skip_on_cran() + res <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, cv.method = "treated_units", + k = 3, cv.prop = 0.1, + cv.nobs = 3, cv.donut = 1, min.T0 = 3, + criterion = "mspe") + )) + expect_true("summary" %in% names(res)) + if ("MSPE" %in% names(res$summary)) { + expect_true(all(is.finite(res$summary$MSPE))) + expect_true(all(res$summary$MSPE > 0)) + } + expect_true(res$summary$RMSE > 0) +}) + +test_that("S4.2: cv.method='all_units' masking runs without error", { + + skip_on_cran() + res_cv <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, cv.method = "all_units", + k = 3, criterion = "mspe") + )) + expect_true("summary" %in% names(res_cv)) + expect_true(res_cv$summary$RMSE > 0) +}) + +test_that("S4.3: cv.method='treated_units' with k=1 (single fold)", { + + skip_on_cran() + res <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, cv.method = "treated_units", + k = 1, criterion = "mspe") + )) + expect_true(res$summary$RMSE > 0) +}) + + +## ================================================================= +## S6: fect_mspe with observation weights (W) — updated for Phase 2 +## ================================================================= + +test_that("S6.1: W parameter produces different scores than unweighted", { + + skip_on_cran() + TT <- nrow(out_base$Y.dat) + NN <- ncol(out_base$Y.dat) + set.seed(7) + W_mat <- matrix(runif(TT * NN, 0.5, 1.5), nrow = TT, ncol = NN) + res_unw <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, criterion = "mspe", + W = NULL) + )) + res_w <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, criterion = "mspe", + W = W_mat) + )) + expect_false(identical(res_unw$summary$RMSE, res_w$summary$RMSE)) +}) + +test_that("S6.2: Uniform W equals unweighted", { + + skip_on_cran() + TT <- nrow(out_base$Y.dat) + NN <- ncol(out_base$Y.dat) + W_uniform <- matrix(1, nrow = TT, ncol = NN) + res_u <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, criterion = "mspe", + W = W_uniform) + )) + res_n <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, criterion = "mspe", + W = NULL) + )) + if ("MSPE" %in% names(res_u$summary) && "MSPE" %in% names(res_n$summary)) { + expect_equal(res_u$summary$MSPE, res_n$summary$MSPE, tolerance = 1e-10) + } +}) + + +## ================================================================= +## S7: fect_mspe with norm.para — updated for Phase 2 +## ================================================================= + +test_that("S7.1: norm.para scales scores", { + + skip_on_cran() + np <- c(2.0, 0.0) + res_raw <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, criterion = "mspe") + )) + res_norm <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, criterion = "mspe", + norm.para = np) + )) + if ("MSPE" %in% names(res_raw$summary) && + "MSPE" %in% names(res_norm$summary)) { + expect_equal(res_norm$summary$MSPE, res_raw$summary$MSPE * 4.0, + tolerance = 1e-10) + } +}) + + +## ================================================================= +## S8: Return structure (updated for Phase 2 — hide_mask removed) +## ================================================================= + +test_that("S8.3: Return structure has summary and records", { + + skip_on_cran() + res <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42) + )) + expect_true("summary" %in% names(res)) + expect_true("records" %in% names(res)) + expect_true("fits" %in% names(res)) + expect_true("RMSE" %in% names(res$summary)) + expect_true("Bias" %in% names(res$summary)) +}) + + +## ================================================================= +## S9: Input validation (updated for Phase 2) +## ================================================================= + +test_that("S9.1: Invalid criterion rejected", { + + skip_on_cran() + invalid_result <- tryCatch({ + suppressWarnings(suppressMessages( + fect_mspe(out_base, criterion = "invalid", seed = 42) + )) + "no_error" + }, error = function(e) "error_thrown") + + expect_equal(invalid_result, "error_thrown", + info = paste("fect_mspe(criterion='invalid') should throw an error,", + "but it completed without error. Builder must add", + "criterion validation.")) +}) + +test_that("S9.2: Invalid cv.method rejected by fect_mspe", { + + skip_on_cran() + expect_error( + fect_mspe(out_base, cv.method = "invalid"), + "cv.method|arg" + ) +}) + +test_that("S9.3: W wrong dimensions", { + + skip_on_cran() + W_bad <- matrix(1, nrow = 5, ncol = 5) + expect_error( + fect_mspe(out_base, W = W_bad), + "dimension|W" + ) +}) + +test_that("S9.5: .score_residuals() empty input", { + + skip_on_cran() + score_fn <- tryCatch( + getFromNamespace(".score_residuals", "fect"), + error = function(e) NULL + ) + skip_if(is.null(score_fn), ".score_residuals() not yet implemented") + + expect_error(score_fn(numeric(0)), "No residuals") +}) + + +## ================================================================= +## Section D: fect_mspe simplification (NEW for Phase 2) +## ================================================================= + +test_that("MSPE1: Simplified fect_mspe with cv.method='all_units'", { + + skip_on_cran() + res <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, cv.method = "all_units", criterion = "mspe") + )) + expect_true("summary" %in% names(res)) + expect_true("records" %in% names(res)) + expect_true("MSPE" %in% names(res$summary)) + expect_true("RMSE" %in% names(res$summary)) + expect_true("Bias" %in% names(res$summary)) + expect_true(res$summary$RMSE > 0) + expect_equal(res$summary$RMSE, sqrt(res$summary$MSPE), tolerance = 1e-10) +}) + +test_that("MSPE2: Simplified fect_mspe with cv.method='treated_units'", { + + skip_on_cran() + res <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, cv.method = "treated_units", + criterion = "mspe") + )) + expect_true("summary" %in% names(res)) + expect_true("records" %in% names(res)) + expect_true(res$summary$RMSE > 0) +}) + +test_that("MSPE3: Removed parameters rejected", { + + skip_on_cran() + expect_error(fect_mspe(out_base, mask.method = "random")) + expect_error(fect_mspe(out_base, hide_mask = matrix(TRUE, 10, 10))) + expect_error(fect_mspe(out_base, n_rep = 3)) + expect_error(fect_mspe(out_base, pre.trend = TRUE)) + expect_error(fect_mspe(out_base, actual = out_base$Y.ct.full)) + expect_error(fect_mspe(out_base, control.only = FALSE)) + expect_error(fect_mspe(out_base, hide_n = 20)) +}) + +test_that("MSPE4: Invalid cv.method rejected", { + + skip_on_cran() + expect_error( + fect_mspe(out_base, cv.method = "loo"), + "cv.method|arg" + ) +}) + +test_that("MSPE5: Multi-model comparison with cv.method", { + + skip_on_cran() + res <- suppressWarnings(suppressMessages( + fect_mspe(list(m1 = out_base, m2 = out_base), + seed = 42, cv.method = "all_units") + )) + expect_equal(nrow(res$summary), 2) + expect_true(all(c("m1", "m2") %in% res$summary$Model)) +}) + +test_that("MSPE6: Seed reproducibility", { + + skip_on_cran() + r1 <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, cv.method = "all_units") + )) + r2 <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, cv.method = "all_units") + )) + expect_identical(r1$summary, r2$summary) +}) + +test_that("MSPE7: fect_mspe with observation weights", { + + skip_on_cran() + TT <- nrow(out_base$Y.dat) + NN <- ncol(out_base$Y.dat) + W_mat <- matrix(1, nrow = TT, ncol = NN) + res <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, cv.method = "all_units", W = W_mat) + )) + if ("MSPE" %in% names(res$summary)) { + expect_true(all(is.finite(res$summary$MSPE))) + expect_true(all(res$summary$MSPE > 0)) + } +}) + +test_that("MSPE8: fect_mspe with norm.para", { + + skip_on_cran() + res_raw <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, cv.method = "all_units") + )) + res_norm <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, cv.method = "all_units", + norm.para = c(2.0)) + )) + if ("MSPE" %in% names(res_raw$summary) && + "MSPE" %in% names(res_norm$summary)) { + # With norm.para, MSPE scaled by norm.para[1]^2 = 4.0 + expect_equal(res_norm$summary$MSPE, res_raw$summary$MSPE * 4.0, + tolerance = 1e-10) + } +}) + + diff --git a/tests/testthat/test-score-nevertreated.R b/tests/testthat/test-score-nevertreated.R new file mode 100644 index 00000000..28b08dd8 --- /dev/null +++ b/tests/testthat/test-score-nevertreated.R @@ -0,0 +1,867 @@ +## --------------------------------------------------------------- +## Tests for fect_nevertreated CV: cv.method dispatch (Section C), +## 1% selection rule verification (Section E), W + count.T.cv weights +## (Section F), end-to-end integration (Section G "Integration"), and +## cv.sample k-fold CV (Section H). +## +## Originally part of test-score-unify.R; split out 2026-05-03 for +## progress visibility. Shared fixtures live in helper-score-unify.R. +## --------------------------------------------------------------- + +## ================================================================= +## Section C: cv.method in fect_nevertreated (NEW for Phase 2) +## ================================================================= + +test_that("NT1: fect_nevertreated cv.method='loo' selects r.cv (IFE)", { + + skip_on_cran() + nt_out <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "loo", + se = FALSE, + parallel = FALSE + ) + )) + expect_true(nt_out$r.cv >= 0 && nt_out$r.cv <= 3) + expect_true(!is.null(nt_out$CV.out)) + mspe_col <- nt_out$CV.out[, "MSPE"] + computed <- mspe_col[mspe_col < 1e19] + if (length(computed) > 0) { + expect_true(all(is.finite(computed))) + } + expect_true(!is.null(nt_out$Y.ct)) +}) + +test_that("NT2: fect_nevertreated cv.method='treated_units' selects r.cv (IFE)", { + + skip_on_cran() + nt_out <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "treated_units", + se = FALSE, + parallel = FALSE + ) + )) + expect_true(nt_out$r.cv >= 0 && nt_out$r.cv <= 3) + expect_true(!is.null(nt_out$CV.out)) +}) + +test_that("NT3: fect_nevertreated cv.method='all_units' selects r.cv (IFE)", { + + skip_on_cran() + nt_out <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + expect_true(nt_out$r.cv >= 0 && nt_out$r.cv <= 3) + expect_true(!is.null(nt_out$CV.out)) +}) + +test_that("NT4: fect_nevertreated cv.method='loo' selects r.cv (CFE)", { + + skip_on_cran() + nt_cfe <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "cfe", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "loo", + se = FALSE, + parallel = FALSE + ) + )) + expect_true(nt_cfe$r.cv >= 0 && nt_cfe$r.cv <= 3) + expect_true(!is.null(nt_cfe$CV.out)) +}) + +test_that("NT5: fect_nevertreated cv.method='treated_units' selects r.cv (CFE)", { + + skip_on_cran() + nt_cfe <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "cfe", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "treated_units", + se = FALSE, + parallel = FALSE + ) + )) + expect_true(nt_cfe$r.cv >= 0 && nt_cfe$r.cv <= 3) + expect_true(!is.null(nt_cfe$CV.out)) +}) + +test_that("NT6: fect_nevertreated default cv.method is treated_units", { + + skip_on_cran() + nt_default <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + se = FALSE, + parallel = FALSE + ) + )) + + nt_explicit <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "treated_units", + se = FALSE, + parallel = FALSE + ) + )) + + expect_equal(nt_default$r.cv, nt_explicit$r.cv) +}) + +test_that("NT7: Invalid cv.method rejected for nevertreated", { + + skip_on_cran() + expect_error( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + time.component.from = "nevertreated", + CV = TRUE, + cv.method = "invalid" + ), + "cv.method|arg" + ) +}) + + +## ================================================================= +## Section E: 1% Selection Rule Verification (NEW for Phase 2) +## ================================================================= + +test_that("SEL1: 1% selection rule in IFE nevertreated", { + + skip_on_cran() + # Large tol should NOT affect the 1% rule + nt_bigtol <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + se = FALSE, + parallel = FALSE, + tol = 0.5 + ) + )) + nt_smalltol <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + se = FALSE, + parallel = FALSE, + tol = 1e-3 + ) + )) + expect_equal(nt_bigtol$r.cv, nt_smalltol$r.cv) +}) + +test_that("SEL2: 1% selection rule in CFE nevertreated", { + + skip_on_cran() + nt_bigtol <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "cfe", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + se = FALSE, + parallel = FALSE, + tol = 0.5 + ) + )) + nt_smalltol <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "cfe", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + se = FALSE, + parallel = FALSE, + tol = 1e-3 + ) + )) + expect_equal(nt_bigtol$r.cv, nt_smalltol$r.cv) +}) + + +## ================================================================= +## Section F: W and count.T.cv in fect_nevertreated (NEW for Phase 2) +## ================================================================= + +test_that("WT1: W weights flow through nevertreated LOO scoring", { + + skip_on_cran() + # W in fect() is a column name, not a matrix. Add a weight column to ntdata. + ntdata_w <- ntdata + ntdata_w$wt <- 1.0 # uniform weights + + nt_w <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata_w, + index = c("id", "time"), + method = "ife", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + W = "wt", + se = FALSE, + parallel = FALSE + ) + )) + expect_true(nt_w$r.cv >= 0 && nt_w$r.cv <= 3) + + # With uniform weights, r.cv should match unweighted result + nt_nw <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + se = FALSE, + parallel = FALSE + ) + )) + expect_equal(nt_w$r.cv, nt_nw$r.cv) +}) + +test_that("WT2: Non-uniform W may change r selection", { + + skip_on_cran() + # W in fect() is a column name. Add non-uniform weight column. + ntdata_w <- ntdata + set.seed(99) + ntdata_w$wt <- runif(nrow(ntdata), 0.5, 2.0) + + nt_w <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata_w, + index = c("id", "time"), + method = "ife", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + W = "wt", + se = FALSE, + parallel = FALSE + ) + )) + # Should not crash, r.cv should be valid + expect_true(nt_w$r.cv >= 0 && nt_w$r.cv <= 3) +}) + + +## ================================================================= +## Section G: Integration Tests (NEW for Phase 2) +## ================================================================= + +test_that("INT1: End-to-end cv.method pipeline", { + + skip_on_cran() + ## Use CV=FALSE for the fit since fect_mspe performs its own + + ## cross-validation masking; what matters is that the fit object + ## has valid Y.dat/Y.ct for fect_mspe to score. + ## NOTE: fect_mspe errors on CV=TRUE fits ("No valid residuals") — + ## that is a separate source-code issue tracked for builder. + fit_result <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + CV = FALSE, + r = 2, + se = FALSE, + parallel = FALSE + ) + )) + mspe_result <- suppressWarnings(suppressMessages( + fect_mspe(fit_result, seed = 42, cv.method = "all_units") + )) + expect_true("summary" %in% names(mspe_result)) + expect_true(mspe_result$summary$RMSE > 0) + if ("MSPE" %in% names(mspe_result$summary)) { + expect_true(mspe_result$summary$MSPE > 0) + } +}) + +test_that("INT2: IFE CV respects cv.method='treated_units'", { + + skip_on_cran() + ## Original test used method="gsynth" + cv.method="loo", but simdata has + ## treatment reversals which gsynth rejects. We test that cv.method is + ## respected by using cv.method="treated_units" (non-default) with method="ife". + ife_out <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D + X1 + X2, + data = simdata, + index = c("id", "time"), + method = "ife", + CV = TRUE, + r = c(0, 3), + cv.method = "treated_units", + se = FALSE, + parallel = FALSE + ) + )) + expect_true(ife_out$r.cv >= 0 && ife_out$r.cv <= 3) +}) + + +## ================================================================= +## Section H: cv.sample k-fold CV in fect_nevertreated (NEW) +## Tests for actual cv.sample-based cross-validation branches +## when cv.method="all_units" or "treated_units" in nevertreated. +## ================================================================= + +## ---- H.1: IFE smoke tests ---- ## + +test_that("NTCV1: cv.method='all_units' IFE produces valid output", { + + skip_on_cran() + set.seed(42) + out_au <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + # r.cv is integer in [0, 3] + expect_true(out_au$r.cv >= 0 && out_au$r.cv <= 3) + # att.avg is finite + expect_true(is.finite(out_au$att.avg)) + # est.att has no all-NA columns + if (!is.null(out_au$est.att)) { + na_cols <- apply(out_au$est.att, 2, function(x) all(is.na(x))) + expect_false(all(na_cols), + info = "est.att should not have all columns be NA") + } + # CV.out exists with proper structure + expect_true(!is.null(out_au$CV.out)) + mspe_col <- out_au$CV.out[, "MSPE"] + computed <- mspe_col[mspe_col < 1e19] + if (length(computed) > 0) { + expect_true(all(is.finite(computed))) + expect_true(all(computed > 0)) + } +}) + +test_that("NTCV2: cv.method='treated_units' IFE produces valid output", { + + skip_on_cran() + set.seed(42) + out_tu <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "treated_units", + se = FALSE, + parallel = FALSE + ) + )) + expect_true(out_tu$r.cv >= 0 && out_tu$r.cv <= 3) + expect_true(is.finite(out_tu$att.avg)) + if (!is.null(out_tu$est.att)) { + na_cols <- apply(out_tu$est.att, 2, function(x) all(is.na(x))) + expect_false(all(na_cols)) + } + expect_true(!is.null(out_tu$CV.out)) +}) + +## ---- H.2: CFE smoke tests ---- ## + +test_that("NTCV3: cv.method='all_units' CFE produces valid output", { + + skip_on_cran() + set.seed(42) + out_au_cfe <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "cfe", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + expect_true(out_au_cfe$r.cv >= 0 && out_au_cfe$r.cv <= 3) + expect_true(is.finite(out_au_cfe$att.avg)) + expect_true(!is.null(out_au_cfe$CV.out)) +}) + +test_that("NTCV4: cv.method='treated_units' CFE produces valid output", { + + skip_on_cran() + set.seed(42) + out_tu_cfe <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "cfe", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "treated_units", + se = FALSE, + parallel = FALSE + ) + )) + expect_true(out_tu_cfe$r.cv >= 0 && out_tu_cfe$r.cv <= 3) + expect_true(is.finite(out_tu_cfe$att.avg)) + expect_true(!is.null(out_tu_cfe$CV.out)) +}) + +## ---- H.3: LOO backward compatibility ---- ## + +test_that("NTCV5: cv.method='loo' IFE backward compatibility", { + + skip_on_cran() + set.seed(1234) + out_loo <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "loo", + se = FALSE, + parallel = FALSE + ) + )) + expect_true(out_loo$r.cv >= 0 && out_loo$r.cv <= 3) + expect_true(is.finite(out_loo$att.avg)) + expect_true(!is.null(out_loo$CV.out)) + + # LOO is deterministic: re-running should produce identical r.cv + set.seed(1234) + out_loo2 <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "loo", + se = FALSE, + parallel = FALSE + ) + )) + expect_equal(out_loo$r.cv, out_loo2$r.cv) +}) + +## ---- H.4: r-selection and ATT checks ---- ## + +test_that("NTCV6: r-selection validity across all cv.methods (IFE)", { + + skip_on_cran() + r_start <- 0 + r_end <- 3 + + methods_list <- c("loo", "all_units", "treated_units") + for (cm in methods_list) { + set.seed(42) + out <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(r_start, r_end), + cv.method = cm, + se = FALSE, + parallel = FALSE + ) + )) + + # r.cv in valid range + expect_true(out$r.cv >= r_start && out$r.cv <= r_end, + info = paste("cv.method =", cm, ": r.cv out of range")) + + # CV.out has correct number of rows + expect_equal(nrow(out$CV.out), r_end - r_start + 1, + info = paste("cv.method =", cm, ": CV.out row count wrong")) + + # Score columns in CV.out: check MSPE for evaluated rows + mspe_col <- out$CV.out[, "MSPE"] + computed <- mspe_col[mspe_col < 1e19] + if (length(computed) > 0) { + expect_true(all(is.finite(computed)), + info = paste("cv.method =", cm, ": non-finite MSPE")) + expect_true(all(computed >= 0), + info = paste("cv.method =", cm, ": negative MSPE")) + } + } +}) + +test_that("NTCV7: ATT consistency across cv.methods (IFE)", { + + skip_on_cran() + att_vals <- numeric(3) + methods_list <- c("loo", "all_units", "treated_units") + for (i in seq_along(methods_list)) { + set.seed(42) + out <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = methods_list[i], + se = FALSE, + parallel = FALSE + ) + )) + att_vals[i] <- out$att.avg + expect_true(is.finite(out$att.avg), + info = paste("cv.method =", methods_list[i], ": att.avg not finite")) + } + + # Sanity check: all ATT values should be in the same ballpark. + # The true ATT is ~3.0 for this DGP. + # Allow wide tolerance since different r.cv selections produce different ATTs. + att_range <- max(att_vals) - min(att_vals) + expect_true(att_range < 5.0, + info = paste("ATT values too spread:", + paste(round(att_vals, 3), collapse = ", "))) +}) + +## ---- H.5: Edge cases ---- ## + +test_that("NTCV-Edge1: r=c(0,0) with all cv.methods", { + + skip_on_cran() + for (cm in c("loo", "all_units", "treated_units")) { + set.seed(42) + out <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 0), + cv.method = cm, + se = FALSE, + parallel = FALSE + ) + )) + expect_equal(out$r.cv, 0, + info = paste("cv.method =", cm, ": r.cv should be 0 when r=c(0,0)")) + # Scores should still be finite + mspe_col <- out$CV.out[, "MSPE"] + computed <- mspe_col[mspe_col < 1e19] + if (length(computed) > 0) { + expect_true(all(is.finite(computed)), + info = paste("cv.method =", cm, ": non-finite MSPE with r=0")) + } + } +}) + +test_that("NTCV-Edge2: Small panel with all cv.methods", { + + skip_on_cran() + # Create data with few pre-treatment periods for treated units + small_data <- make_factor_data(N = 30, TT = 10, Ntr = 8, r = 1, seed = 99) + + for (cm in c("loo", "all_units", "treated_units")) { + set.seed(42) + out <- tryCatch( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = small_data, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 2), + cv.method = cm, + se = FALSE, + parallel = FALSE + ) + )), + error = function(e) e + ) + # Should either succeed with valid r.cv or produce informative error + if (!inherits(out, "error")) { + expect_true(out$r.cv >= 0 && out$r.cv <= 2, + info = paste("cv.method =", cm, ": r.cv out of range (small panel)")) + expect_true(is.finite(out$att.avg), + info = paste("cv.method =", cm, ": att.avg not finite (small panel)")) + } else { + # If it errors, the message should be informative (not a cryptic crash) + expect_true(nchar(conditionMessage(out)) > 0, + info = paste("cv.method =", cm, ": error should be informative")) + } + } +}) + +test_that("NTCV-Edge3: Single treated unit", { + + skip_on_cran() + single_tr_data <- make_factor_data(N = 30, TT = 15, Ntr = 1, r = 1, seed = 77) + + for (cm in c("loo", "all_units", "treated_units")) { + set.seed(42) + out <- tryCatch( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = single_tr_data, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 2), + cv.method = cm, + se = FALSE, + parallel = FALSE + ) + )), + error = function(e) e + ) + if (!inherits(out, "error")) { + expect_true(out$r.cv >= 0 && out$r.cv <= 2, + info = paste("cv.method =", cm, ": r.cv invalid (single treated)")) + } + # If it errors, that's acceptable for single treated unit edge case + } +}) + +## ---- H.6: Property-based invariants for cv.sample ---- ## + +test_that("NTCV-P1: Score non-negativity in CV.out", { + + skip_on_cran() + for (cm in c("all_units", "treated_units")) { + set.seed(42) + out <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = cm, + se = FALSE, + parallel = FALSE + ) + )) + + # All score columns should be non-negative + score_cols <- c("MSPE", "WMSPE", "GMSPE", "WGMSPE", "MAD") + for (sc in score_cols) { + if (sc %in% colnames(out$CV.out)) { + vals <- out$CV.out[, sc] + computed <- vals[vals < 1e19] + if (length(computed) > 0) { + expect_true(all(computed >= 0), + info = paste("cv.method =", cm, ", score =", sc, ": negative value")) + } + } + } + } +}) + +test_that("NTCV-P4: LOO determinism", { + + skip_on_cran() + set.seed(42) + out1 <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "loo", + se = FALSE, + parallel = FALSE + ) + )) + + set.seed(999) # different seed should not affect LOO + out2 <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "loo", + se = FALSE, + parallel = FALSE + ) + )) + + expect_equal(out1$r.cv, out2$r.cv) + # CV.out scores should be identical + expect_equal(out1$CV.out, out2$CV.out, tolerance = 1e-10) +}) + +test_that("NTCV-P5: cv.sample reproducibility with set.seed", { + + skip_on_cran() + for (cm in c("all_units", "treated_units")) { + set.seed(42) + out1 <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = cm, + se = FALSE, + parallel = FALSE + ) + )) + + set.seed(42) + out2 <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = ntdata, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = cm, + se = FALSE, + parallel = FALSE + ) + )) + + expect_equal(out1$r.cv, out2$r.cv, + info = paste("cv.method =", cm, ": r.cv not reproducible")) + expect_equal(out1$CV.out, out2$CV.out, tolerance = 1e-10, + info = paste("cv.method =", cm, ": CV.out not reproducible")) + } +}) + + diff --git a/tests/testthat/test-score-parallel-cv.R b/tests/testthat/test-score-parallel-cv.R new file mode 100644 index 00000000..4e2dad15 --- /dev/null +++ b/tests/testthat/test-score-parallel-cv.R @@ -0,0 +1,820 @@ +## --------------------------------------------------------------- +## Tests for parallel CV folds in fect_nevertreated. +## Section originally also labeled "G" (now disambiguated via filename +## as test-score-parallel-cv.R; the integration "G" is in +## test-score-nevertreated.R). +## +## Originally Section G "Parallel CV Folds" of test-score-unify.R; +## split out 2026-05-03. Shared fixtures live in helper-score-unify.R. +## --------------------------------------------------------------- + +## --------------------------------------------------------------- +## Section G: Parallel CV Folds in fect_nevertreated +## +## Tests for REQ-parallel-cv: verifies that parallel=TRUE produces +## identical results to parallel=FALSE (sequential), that +## reproducibility holds under parallelism with fixed seeds, that +## default behavior is unchanged, that the LOO path is unaffected, +## and that edge cases work correctly. +## +## Follows test-spec.md for REQ-parallel-cv. +## Tolerances: 1e-10 for CV score differences (per test-spec.md). +## --------------------------------------------------------------- + +## -- G.1 Sequential-Parallel Equivalence: IFE, all_units ---------- + +test_that("G.1: parallel CV matches sequential — IFE, all_units", { + + skip_on_cran() + + dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) + + set.seed(123) + result_seq <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + + set.seed(123) + result_par <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE, + parallel = TRUE, + cores = 2 + ) + )) + + ## r.cv must be identical + expect_identical(result_seq$r.cv, result_par$r.cv) + + ## CV.out matrix must match within tolerance 1e-10 + cv_diff <- max(abs(result_seq$CV.out - result_par$CV.out)) + expect_true(cv_diff < 1e-10, + info = sprintf("CV.out max diff = %.2e (tolerance = 1e-10)", cv_diff)) +}) + +## -- G.2 Sequential-Parallel Equivalence: IFE, treated_units ------ + +test_that("G.2: parallel CV matches sequential — IFE, treated_units", { + + skip_on_cran() + + dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) + + set.seed(123) + result_seq <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "treated_units", + se = FALSE, + parallel = FALSE + ) + )) + + set.seed(123) + result_par <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "treated_units", + se = FALSE, + parallel = TRUE, + cores = 2 + ) + )) + + expect_identical(result_seq$r.cv, result_par$r.cv) + + cv_diff <- max(abs(result_seq$CV.out - result_par$CV.out)) + expect_true(cv_diff < 1e-10, + info = sprintf("CV.out max diff = %.2e (tolerance = 1e-10)", cv_diff)) +}) + +## -- G.3 Sequential-Parallel Equivalence: CFE, all_units ---------- + +test_that("G.3: parallel CV matches sequential — CFE, all_units", { + + skip_on_cran() + + dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) + + set.seed(123) + result_seq <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "cfe", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + + set.seed(123) + result_par <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "cfe", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE, + parallel = TRUE, + cores = 2 + ) + )) + + expect_identical(result_seq$r.cv, result_par$r.cv) + + cv_diff <- max(abs(result_seq$CV.out - result_par$CV.out)) + expect_true(cv_diff < 1e-10, + info = sprintf("CV.out max diff = %.2e (tolerance = 1e-10)", cv_diff)) +}) + +## -- G.4 Sequential-Parallel Equivalence: CFE, treated_units ------ + +test_that("G.4: parallel CV matches sequential — CFE, treated_units", { + + skip_on_cran() + + dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) + + set.seed(123) + result_seq <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "cfe", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "treated_units", + se = FALSE, + parallel = FALSE + ) + )) + + set.seed(123) + result_par <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "cfe", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "treated_units", + se = FALSE, + parallel = TRUE, + cores = 2 + ) + )) + + expect_identical(result_seq$r.cv, result_par$r.cv) + + cv_diff <- max(abs(result_seq$CV.out - result_par$CV.out)) + expect_true(cv_diff < 1e-10, + info = sprintf("CV.out max diff = %.2e (tolerance = 1e-10)", cv_diff)) +}) + +## -- G.5 Reproducibility Under Parallelism ------------------------ + +test_that("G.5: parallel CV is reproducible with same seed", { + + skip_on_cran() + + dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) + + set.seed(123) + result_par1 <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE, + parallel = TRUE, + cores = 2, + seed = 12345 + ) + )) + + set.seed(123) + result_par2 <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE, + parallel = TRUE, + cores = 2, + seed = 12345 + ) + )) + + expect_identical(result_par1$r.cv, result_par2$r.cv) + expect_identical(result_par1$CV.out, result_par2$CV.out) +}) + +## -- G.6 Default Behavior Unchanged ------------------------------- + +test_that("G.6: default (no parallel arg) behaves as sequential", { + + skip_on_cran() + + dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) + + ## Call without specifying parallel or cores — should default to sequential + set.seed(123) + result_default <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE + ) + )) + + set.seed(123) + result_seq <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + + expect_identical(result_default$r.cv, result_seq$r.cv) + expect_identical(result_default$CV.out, result_seq$CV.out) +}) + +## -- G.7 LOO Path Unaffected -------------------------------------- + +test_that("G.7: LOO path is unaffected by parallel flag", { + + skip_on_cran() + + dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) + + set.seed(123) + result_loo_seq <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "loo", + se = FALSE, + parallel = FALSE + ) + )) + + set.seed(123) + result_loo_par <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + cv.method = "loo", + se = FALSE, + parallel = TRUE, + cores = 2 + ) + )) + + ## LOO should produce identical results regardless of parallel flag + expect_identical(result_loo_seq$r.cv, result_loo_par$r.cv) + expect_identical(result_loo_seq$CV.out, result_loo_par$CV.out) +}) + +## -- G.8 Edge Case: k = 1 ---------------------------------------- + +test_that("G.8: edge case — k = 1 with parallel=TRUE runs without error", { + + skip_on_cran() + + dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) + + set.seed(123) + result_par <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 1, + cv.method = "all_units", + se = FALSE, + parallel = TRUE, + cores = 2 + ) + )) + + set.seed(123) + result_seq <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 1, + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + + expect_identical(result_par$r.cv, result_seq$r.cv) +}) + +## -- G.9 Edge Case: cores = 1 ------------------------------------ + +test_that("G.9: edge case — cores = 1 behaves as sequential", { + + skip_on_cran() + + dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) + + set.seed(123) + result_c1 <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE, + parallel = TRUE, + cores = 1 + ) + )) + + set.seed(123) + result_seq <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + + cv_diff <- max(abs(result_c1$CV.out - result_seq$CV.out)) + expect_true(cv_diff < 1e-10, + info = sprintf("CV.out max diff = %.2e (tolerance = 1e-10)", cv_diff)) +}) + +## -- G.10 Edge Case: cores = NULL (auto-detect) ------------------ + +test_that("G.10: edge case — cores = NULL auto-detects and runs", { + + skip_on_cran() + + dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) + + set.seed(123) + result_auto <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE, + parallel = TRUE, + cores = NULL + ) + )) + + set.seed(123) + result_seq <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + + cv_diff <- max(abs(result_auto$CV.out - result_seq$CV.out)) + expect_true(cv_diff < 1e-10, + info = sprintf("CV.out max diff = %.2e (tolerance = 1e-10)", cv_diff)) +}) + +## -- G.11 Edge Case: parallel=FALSE with cores specified ---------- + +test_that("G.11: edge case — parallel=FALSE ignores cores", { + + skip_on_cran() + + dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) + + set.seed(123) + result_no_par <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE, + parallel = FALSE, + cores = 4 + ) + )) + + set.seed(123) + result_seq <- suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + + expect_identical(result_no_par$r.cv, result_seq$r.cv) + expect_identical(result_no_par$CV.out, result_seq$CV.out) +}) + +## -- G.12 Timing Benchmark: Parallel vs Sequential ---------------- +## This is an informational benchmark; we report speedup but do not +## hard-fail on specific speedup thresholds (per test-spec.md: +## "Not a pass/fail test, but auditor should measure and report"). + +test_that("G.12: timing benchmark — parallel vs sequential with 10 cores", { + + skip_on_cran() + + ## Larger dataset for meaningful timing differences + dat <- make_factor_data(N = 100, TT = 30, Ntr = 25, r = 2, seed = 99) + + cat("\n=== Parallel CV Timing Benchmark ===\n") + + ## --- IFE, all_units --- + set.seed(123) + t_seq_ife_au <- system.time( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 5), + k = 10, + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + ) + + set.seed(123) + t_par_ife_au <- system.time( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 5), + k = 10, + cv.method = "all_units", + se = FALSE, + parallel = TRUE, + cores = 10 + ) + )) + ) + + cat(sprintf(" IFE all_units sequential: %6.2f sec\n", t_seq_ife_au["elapsed"])) + cat(sprintf(" IFE all_units parallel: %6.2f sec (10 cores)\n", t_par_ife_au["elapsed"])) + speedup_ife_au <- t_seq_ife_au["elapsed"] / max(t_par_ife_au["elapsed"], 0.001) + cat(sprintf(" Speedup: %.2fx\n\n", speedup_ife_au)) + + ## --- IFE, treated_units --- + set.seed(123) + t_seq_ife_tu <- system.time( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 5), + k = 10, + cv.method = "treated_units", + se = FALSE, + parallel = FALSE + ) + )) + ) + + set.seed(123) + t_par_ife_tu <- system.time( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 5), + k = 10, + cv.method = "treated_units", + se = FALSE, + parallel = TRUE, + cores = 10 + ) + )) + ) + + cat(sprintf(" IFE treated_units sequential: %6.2f sec\n", t_seq_ife_tu["elapsed"])) + cat(sprintf(" IFE treated_units parallel: %6.2f sec (10 cores)\n", t_par_ife_tu["elapsed"])) + speedup_ife_tu <- t_seq_ife_tu["elapsed"] / max(t_par_ife_tu["elapsed"], 0.001) + cat(sprintf(" Speedup: %.2fx\n\n", speedup_ife_tu)) + + ## --- CFE, all_units --- + set.seed(123) + t_seq_cfe_au <- system.time( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "cfe", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 5), + k = 10, + cv.method = "all_units", + se = FALSE, + parallel = FALSE + ) + )) + ) + + set.seed(123) + t_par_cfe_au <- system.time( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "cfe", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 5), + k = 10, + cv.method = "all_units", + se = FALSE, + parallel = TRUE, + cores = 10 + ) + )) + ) + + cat(sprintf(" CFE all_units sequential: %6.2f sec\n", t_seq_cfe_au["elapsed"])) + cat(sprintf(" CFE all_units parallel: %6.2f sec (10 cores)\n", t_par_cfe_au["elapsed"])) + speedup_cfe_au <- t_seq_cfe_au["elapsed"] / max(t_par_cfe_au["elapsed"], 0.001) + cat(sprintf(" Speedup: %.2fx\n\n", speedup_cfe_au)) + + ## --- CFE, treated_units --- + set.seed(123) + t_seq_cfe_tu <- system.time( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "cfe", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 5), + k = 10, + cv.method = "treated_units", + se = FALSE, + parallel = FALSE + ) + )) + ) + + set.seed(123) + t_par_cfe_tu <- system.time( + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "cfe", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 5), + k = 10, + cv.method = "treated_units", + se = FALSE, + parallel = TRUE, + cores = 10 + ) + )) + ) + + cat(sprintf(" CFE treated_units sequential: %6.2f sec\n", t_seq_cfe_tu["elapsed"])) + cat(sprintf(" CFE treated_units parallel: %6.2f sec (10 cores)\n", t_par_cfe_tu["elapsed"])) + speedup_cfe_tu <- t_seq_cfe_tu["elapsed"] / max(t_par_cfe_tu["elapsed"], 0.001) + cat(sprintf(" Speedup: %.2fx\n\n", speedup_cfe_tu)) + + cat("=== End Parallel CV Timing Benchmark ===\n") + + ## Informational — always passes; speedup is reported in test output + expect_true(TRUE) +}) + +## -- G.13 Property: Backend Cleanup After Parallel CV ------------- + +test_that("G.13: parallel backend is restored after fect() returns", { + + skip_on_cran() + + dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) + + old_plan <- future::plan() + + set.seed(123) + suppressWarnings(suppressMessages( + fect::fect( + Y ~ D, + data = dat, + index = c("id", "time"), + method = "ife", + force = "two-way", + time.component.from = "nevertreated", + CV = TRUE, + r = c(0, 3), + k = 5, + cv.method = "all_units", + se = FALSE, + parallel = TRUE, + cores = 2 + ) + )) + + new_plan <- future::plan() + + ## The future plan class should be restored + expect_identical(class(old_plan), class(new_plan)) +}) diff --git a/tests/testthat/test-score-residuals.R b/tests/testthat/test-score-residuals.R new file mode 100644 index 00000000..9a11adef --- /dev/null +++ b/tests/testthat/test-score-residuals.R @@ -0,0 +1,267 @@ +## --------------------------------------------------------------- +## Tests for .score_residuals() unit behavior + property-based +## invariants + edge cases. +## +## Originally Section S1 + Property + Edge of test-score-unify.R; +## split out 2026-05-03 for progress visibility under reporter = "summary". +## Shared fixtures (make_factor_data, ntdata, out_base) live in +## helper-score-unify.R. +## --------------------------------------------------------------- + +## ================================================================= +## S1: .score_residuals() unit tests with known inputs +## ================================================================= + +test_that("S1.1: Basic unweighted scoring", { + + skip_on_cran() + score_fn <- tryCatch( + getFromNamespace(".score_residuals", "fect"), + error = function(e) NULL + ) + skip_if(is.null(score_fn), ".score_residuals() not yet implemented") + + resid <- c(1.0, -2.0, 3.0, -1.0, 2.0) + result <- score_fn(resid) + + # MSPE = mean(resid^2) = (1+4+9+1+4)/5 = 3.8 + expect_equal(result[["MSPE"]], 3.8, tolerance = 1e-10) + + # GMSPE = exp(mean(log(resid^2))) + expected_gmspe <- exp(mean(log(c(1, 4, 9, 1, 4)))) + expect_equal(result[["GMSPE"]], expected_gmspe, tolerance = 1e-10) + + # MAD = median(|e2 - median(e2)|) where e2=c(1,4,9,1,4), median=4 + # deviations = c(3,0,5,3,0), MAD = 3 + expect_equal(result[["MAD"]], 3.0, tolerance = 1e-10) + + # RMSE = sqrt(3.8) + expect_equal(result[["RMSE"]], sqrt(3.8), tolerance = 1e-10) + + # Bias = mean(resid) = 0.6 + expect_equal(result[["Bias"]], 0.6, tolerance = 1e-10) + + # Moment and GMoment = NA (no time_index) + expect_true(is.na(result[["Moment"]])) + expect_true(is.na(result[["GMoment"]])) + + # WMSPE = MSPE with uniform weights = 3.8 + expect_equal(result[["WMSPE"]], 3.8, tolerance = 1e-10) + + # WGMSPE = GMSPE with uniform weights + expect_equal(result[["WGMSPE"]], expected_gmspe, tolerance = 1e-10) +}) + +test_that("S1.2: With observation weights", { + + skip_on_cran() + score_fn <- tryCatch( + getFromNamespace(".score_residuals", "fect"), + error = function(e) NULL + ) + skip_if(is.null(score_fn), ".score_residuals() not yet implemented") + + resid <- c(1.0, -2.0, 3.0) + obs_weights <- c(0.5, 1.0, 0.5) + result <- score_fn(resid, obs_weights = obs_weights) + + # MSPE = (0.5*1 + 1.0*4 + 0.5*9) / (0.5+1.0+0.5) = 9/2 = 4.5 + expect_equal(result[["MSPE"]], 4.5, tolerance = 1e-10) + + # RMSE = sqrt(4.5) + expect_equal(result[["RMSE"]], sqrt(4.5), tolerance = 1e-10) + + # Bias = mean(resid) = 2/3 + expect_equal(result[["Bias"]], 2 / 3, tolerance = 1e-10) +}) + +test_that("S1.3: With time_index and count_weights (Moment/GMoment)", { + + skip_on_cran() + score_fn <- tryCatch( + getFromNamespace(".score_residuals", "fect"), + error = function(e) NULL + ) + skip_if(is.null(score_fn), ".score_residuals() not yet implemented") + + resid <- c(1.0, -1.0, 2.0, -3.0, 0.5, -0.5) + time_index <- c("-2", "-2", "-1", "-1", "Control", "Control") + count_weights <- c("-2" = 1.5, "-1" = 2.0, "Control" = 1.0) + + result <- score_fn(resid, time_index = time_index, + count_weights = count_weights) + + # Moment: + # resid_mean per group: "-2"->0, "-1"->-0.5, "Control"->0 + # abs: c(0, 0.5, 0) + # Moment = (1.5*0 + 2.0*0.5 + 1.0*0) / (1.5+2.0+1.0) = 1.0/4.5 + expected_moment <- 1.0 / 4.5 + expect_equal(result[["Moment"]], expected_moment, tolerance = 1e-10) + + # GMoment: + # geometric mean of abs(resid) per group: + # "-2" -> exp((log(1)+log(1))/2) = 1.0 + # "-1" -> exp((log(2)+log(3))/2) = sqrt(6) + # "Control" -> exp((log(0.5)+log(0.5))/2) = 0.5 + # GMoment = (1.5*1.0 + 2.0*sqrt(6) + 1.0*0.5) / (1.5+2.0+1.0) + expected_gmoment <- (1.5 * 1.0 + 2.0 * sqrt(6) + 1.0 * 0.5) / 4.5 + expect_equal(result[["GMoment"]], expected_gmoment, tolerance = 1e-10) +}) + +test_that("S1.4: With norm.para", { + + skip_on_cran() + score_fn <- tryCatch( + getFromNamespace(".score_residuals", "fect"), + error = function(e) NULL + ) + skip_if(is.null(score_fn), ".score_residuals() not yet implemented") + + resid <- c(1.0, -2.0, 3.0, -1.0, 2.0) + result <- score_fn(resid, norm.para = c(2.0)) + + # All 7 scores multiplied by 4.0 (norm.para[1]^2) + expect_equal(result[["MSPE"]], 3.8 * 4.0, tolerance = 1e-10) + expect_equal(result[["RMSE"]], sqrt(3.8 * 4.0), tolerance = 1e-10) + + # Bias unchanged + expect_equal(result[["Bias"]], 0.6, tolerance = 1e-10) +}) + +test_that("S1.5: Edge case - single residual", { + + skip_on_cran() + score_fn <- tryCatch( + getFromNamespace(".score_residuals", "fect"), + error = function(e) NULL + ) + skip_if(is.null(score_fn), ".score_residuals() not yet implemented") + + result <- score_fn(c(2.5)) + + expect_equal(result[["MSPE"]], 6.25, tolerance = 1e-10) + expect_equal(result[["RMSE"]], 2.5, tolerance = 1e-10) + expect_equal(result[["Bias"]], 2.5, tolerance = 1e-10) + expect_equal(result[["MAD"]], 0.0, tolerance = 1e-10) + expect_equal(result[["GMSPE"]], 6.25, tolerance = 1e-10) +}) + +test_that("S1.6: Edge case - zero residual", { + + skip_on_cran() + score_fn <- tryCatch( + getFromNamespace(".score_residuals", "fect"), + error = function(e) NULL + ) + skip_if(is.null(score_fn), ".score_residuals() not yet implemented") + + resid <- c(0.0, 1.0, -1.0) + result <- score_fn(resid) + + # MSPE = 2/3 + expect_equal(result[["MSPE"]], 2 / 3, tolerance = 1e-10) + + # GMSPE = exp(mean(log(c(0,1,1)))) = exp(-Inf) = 0 + expect_true(result[["GMSPE"]] <= 1e-300 || !is.finite(log(result[["GMSPE"]]))) + + # WGMSPE: zero filtered out, only c(1,1) remain. WGMSPE = 1.0 + expect_equal(result[["WGMSPE"]], 1.0, tolerance = 1e-10) +}) + +test_that("S1.7: Edge case - empty residuals", { + + skip_on_cran() + score_fn <- tryCatch( + getFromNamespace(".score_residuals", "fect"), + error = function(e) NULL + ) + skip_if(is.null(score_fn), ".score_residuals() not yet implemented") + + expect_error(score_fn(numeric(0)), "No residuals") +}) + + +## ================================================================= +## Property-based invariants (updated for Phase 2) +## ================================================================= + +test_that("P1: RMSE = sqrt(MSPE) invariant", { + + skip_on_cran() + res <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, criterion = "mspe") + )) + if ("MSPE" %in% names(res$summary)) { + expect_equal(res$summary$RMSE, sqrt(res$summary$MSPE), tolerance = 1e-10) + } +}) + +test_that("P2: MSPE >= 0", { + + skip_on_cran() + res <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42, criterion = "mspe") + )) + if ("MSPE" %in% names(res$summary)) { + expect_true(all(res$summary$MSPE >= 0)) + } +}) + +test_that("P5: Moment = 0 when all per-group mean residuals are 0", { + + skip_on_cran() + score_fn <- tryCatch( + getFromNamespace(".score_residuals", "fect"), + error = function(e) NULL + ) + skip_if(is.null(score_fn), ".score_residuals() not yet implemented") + + # Construct residuals where each group mean is exactly 0 + resid <- c(1, -1, 2, -2) + time_index <- c("A", "A", "B", "B") + count_weights <- c("A" = 1.0, "B" = 1.0) + + result <- score_fn(resid, time_index = time_index, + count_weights = count_weights) + expect_equal(result[["Moment"]], 0.0, tolerance = 1e-10) +}) + +test_that("P7: Seed reproducibility", { + + skip_on_cran() + r1 <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42) + )) + r2 <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42) + )) + expect_identical(r1$summary, r2$summary) +}) + + +## ================================================================= +## Edge cases (updated for Phase 2) +## ================================================================= + +test_that("E3: Single model in fect_mspe (not a list)", { + + skip_on_cran() + res <- suppressWarnings(suppressMessages( + fect_mspe(out_base, seed = 42) + )) + expect_equal(nrow(res$summary), 1) + expect_true(res$summary$RMSE > 0) +}) + +test_that("E4: Multiple models in fect_mspe", { + + skip_on_cran() + multi <- suppressWarnings(suppressMessages( + fect_mspe(list(m1 = out_base, m2 = out_base), + seed = 42) + )) + expect_equal(nrow(multi$summary), 2) + expect_true(all(c("m1", "m2") %in% multi$summary$Model)) +}) + + diff --git a/tests/testthat/test-score-unify.R b/tests/testthat/test-score-unify.R deleted file mode 100644 index 6ad69947..00000000 --- a/tests/testthat/test-score-unify.R +++ /dev/null @@ -1,2631 +0,0 @@ -## --------------------------------------------------------------- -## Tests for score unification: .score_residuals(), fect_cv -## regression, fect_mspe criterion/masking/weights extensions, -## cv.method unification (Phase 2). -## -## Follows test-spec.md for REQ-cv-method-phase2. -## --------------------------------------------------------------- - -## Shared fixture — fitted once, reused across blocks. -suppressWarnings(data("simdata", package = "fect")) - -## DGP with factor structure and sufficient never-treated units for CV. -## N=50, TT=20, Ntr=15 => 35 never-treated units with 20 pre-treatment -## periods — plenty for cross-validation with r up to 3. -make_factor_data <- function(N = 50, TT = 20, Ntr = 15, tau = 3.0, - r = 2, seed = 42) { - set.seed(seed) - F_mat <- matrix(rnorm(TT * r), TT, r) - L_mat <- matrix(rnorm(N * r), N, r) - alpha_i <- rnorm(N, 0, 1) - xi_t <- rnorm(TT, 0, 0.5) - - T0_vec <- rep(Inf, N) - if (Ntr > 0) { - T0_vec[1:Ntr] <- sample(round(TT * 0.4):round(TT * 0.7), Ntr, - replace = TRUE) - } - - Y_vec <- D_vec <- numeric(N * TT) - id_vec <- time_vec <- integer(N * TT) - idx <- 1 - for (i in 1:N) { - for (t in 1:TT) { - treated <- (t >= T0_vec[i]) - D_vec[idx] <- as.integer(treated) - Y_vec[idx] <- alpha_i[i] + xi_t[t] + - sum(F_mat[t, ] * L_mat[i, ]) + - tau * D_vec[idx] + rnorm(1, 0, 0.5) - id_vec[idx] <- i - time_vec[idx] <- t - idx <- idx + 1 - } - } - - data.frame(id = id_vec, time = time_vec, Y = Y_vec, D = D_vec) -} - -## Shared never-treated fixture for Section C, E, F tests -ntdata <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) - -out_base <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D + X1 + X2, - data = simdata, - index = c("id", "time"), - method = "ife", - r = 2, - CV = FALSE, - se = FALSE, - parallel = FALSE - ) -)) - -## ================================================================= -## S1: .score_residuals() unit tests with known inputs -## ================================================================= - -test_that("S1.1: Basic unweighted scoring", { - - skip_on_cran() - score_fn <- tryCatch( - getFromNamespace(".score_residuals", "fect"), - error = function(e) NULL - ) - skip_if(is.null(score_fn), ".score_residuals() not yet implemented") - - resid <- c(1.0, -2.0, 3.0, -1.0, 2.0) - result <- score_fn(resid) - - # MSPE = mean(resid^2) = (1+4+9+1+4)/5 = 3.8 - expect_equal(result[["MSPE"]], 3.8, tolerance = 1e-10) - - # GMSPE = exp(mean(log(resid^2))) - expected_gmspe <- exp(mean(log(c(1, 4, 9, 1, 4)))) - expect_equal(result[["GMSPE"]], expected_gmspe, tolerance = 1e-10) - - # MAD = median(|e2 - median(e2)|) where e2=c(1,4,9,1,4), median=4 - # deviations = c(3,0,5,3,0), MAD = 3 - expect_equal(result[["MAD"]], 3.0, tolerance = 1e-10) - - # RMSE = sqrt(3.8) - expect_equal(result[["RMSE"]], sqrt(3.8), tolerance = 1e-10) - - # Bias = mean(resid) = 0.6 - expect_equal(result[["Bias"]], 0.6, tolerance = 1e-10) - - # Moment and GMoment = NA (no time_index) - expect_true(is.na(result[["Moment"]])) - expect_true(is.na(result[["GMoment"]])) - - # WMSPE = MSPE with uniform weights = 3.8 - expect_equal(result[["WMSPE"]], 3.8, tolerance = 1e-10) - - # WGMSPE = GMSPE with uniform weights - expect_equal(result[["WGMSPE"]], expected_gmspe, tolerance = 1e-10) -}) - -test_that("S1.2: With observation weights", { - - skip_on_cran() - score_fn <- tryCatch( - getFromNamespace(".score_residuals", "fect"), - error = function(e) NULL - ) - skip_if(is.null(score_fn), ".score_residuals() not yet implemented") - - resid <- c(1.0, -2.0, 3.0) - obs_weights <- c(0.5, 1.0, 0.5) - result <- score_fn(resid, obs_weights = obs_weights) - - # MSPE = (0.5*1 + 1.0*4 + 0.5*9) / (0.5+1.0+0.5) = 9/2 = 4.5 - expect_equal(result[["MSPE"]], 4.5, tolerance = 1e-10) - - # RMSE = sqrt(4.5) - expect_equal(result[["RMSE"]], sqrt(4.5), tolerance = 1e-10) - - # Bias = mean(resid) = 2/3 - expect_equal(result[["Bias"]], 2 / 3, tolerance = 1e-10) -}) - -test_that("S1.3: With time_index and count_weights (Moment/GMoment)", { - - skip_on_cran() - score_fn <- tryCatch( - getFromNamespace(".score_residuals", "fect"), - error = function(e) NULL - ) - skip_if(is.null(score_fn), ".score_residuals() not yet implemented") - - resid <- c(1.0, -1.0, 2.0, -3.0, 0.5, -0.5) - time_index <- c("-2", "-2", "-1", "-1", "Control", "Control") - count_weights <- c("-2" = 1.5, "-1" = 2.0, "Control" = 1.0) - - result <- score_fn(resid, time_index = time_index, - count_weights = count_weights) - - # Moment: - # resid_mean per group: "-2"->0, "-1"->-0.5, "Control"->0 - # abs: c(0, 0.5, 0) - # Moment = (1.5*0 + 2.0*0.5 + 1.0*0) / (1.5+2.0+1.0) = 1.0/4.5 - expected_moment <- 1.0 / 4.5 - expect_equal(result[["Moment"]], expected_moment, tolerance = 1e-10) - - # GMoment: - # geometric mean of abs(resid) per group: - # "-2" -> exp((log(1)+log(1))/2) = 1.0 - # "-1" -> exp((log(2)+log(3))/2) = sqrt(6) - # "Control" -> exp((log(0.5)+log(0.5))/2) = 0.5 - # GMoment = (1.5*1.0 + 2.0*sqrt(6) + 1.0*0.5) / (1.5+2.0+1.0) - expected_gmoment <- (1.5 * 1.0 + 2.0 * sqrt(6) + 1.0 * 0.5) / 4.5 - expect_equal(result[["GMoment"]], expected_gmoment, tolerance = 1e-10) -}) - -test_that("S1.4: With norm.para", { - - skip_on_cran() - score_fn <- tryCatch( - getFromNamespace(".score_residuals", "fect"), - error = function(e) NULL - ) - skip_if(is.null(score_fn), ".score_residuals() not yet implemented") - - resid <- c(1.0, -2.0, 3.0, -1.0, 2.0) - result <- score_fn(resid, norm.para = c(2.0)) - - # All 7 scores multiplied by 4.0 (norm.para[1]^2) - expect_equal(result[["MSPE"]], 3.8 * 4.0, tolerance = 1e-10) - expect_equal(result[["RMSE"]], sqrt(3.8 * 4.0), tolerance = 1e-10) - - # Bias unchanged - expect_equal(result[["Bias"]], 0.6, tolerance = 1e-10) -}) - -test_that("S1.5: Edge case - single residual", { - - skip_on_cran() - score_fn <- tryCatch( - getFromNamespace(".score_residuals", "fect"), - error = function(e) NULL - ) - skip_if(is.null(score_fn), ".score_residuals() not yet implemented") - - result <- score_fn(c(2.5)) - - expect_equal(result[["MSPE"]], 6.25, tolerance = 1e-10) - expect_equal(result[["RMSE"]], 2.5, tolerance = 1e-10) - expect_equal(result[["Bias"]], 2.5, tolerance = 1e-10) - expect_equal(result[["MAD"]], 0.0, tolerance = 1e-10) - expect_equal(result[["GMSPE"]], 6.25, tolerance = 1e-10) -}) - -test_that("S1.6: Edge case - zero residual", { - - skip_on_cran() - score_fn <- tryCatch( - getFromNamespace(".score_residuals", "fect"), - error = function(e) NULL - ) - skip_if(is.null(score_fn), ".score_residuals() not yet implemented") - - resid <- c(0.0, 1.0, -1.0) - result <- score_fn(resid) - - # MSPE = 2/3 - expect_equal(result[["MSPE"]], 2 / 3, tolerance = 1e-10) - - # GMSPE = exp(mean(log(c(0,1,1)))) = exp(-Inf) = 0 - expect_true(result[["GMSPE"]] <= 1e-300 || !is.finite(log(result[["GMSPE"]]))) - - # WGMSPE: zero filtered out, only c(1,1) remain. WGMSPE = 1.0 - expect_equal(result[["WGMSPE"]], 1.0, tolerance = 1e-10) -}) - -test_that("S1.7: Edge case - empty residuals", { - - skip_on_cran() - score_fn <- tryCatch( - getFromNamespace(".score_residuals", "fect"), - error = function(e) NULL - ) - skip_if(is.null(score_fn), ".score_residuals() not yet implemented") - - expect_error(score_fn(numeric(0)), "No residuals") -}) - - -## ================================================================= -## S2: fect_cv regression test (before vs after refactor) -## ================================================================= - -test_that("S2.1: IFE method CV - r.cv and CV.out snapshot", { - - skip_on_cran() - cv_out <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D + X1 + X2, - data = simdata, - index = c("id", "time"), - method = "ife", - CV = TRUE, - r = c(0, 3), - criterion = "mspe", - se = FALSE, - parallel = FALSE - ) - )) - # r.cv should be a non-negative integer in [0, 3] - expect_true(cv_out$r.cv >= 0 && cv_out$r.cv <= 3) - - # CV.out should exist and have MSPE column with finite positive values - expect_true(!is.null(cv_out$CV.out)) - mspe_col <- cv_out$CV.out[, "MSPE"] - # At least some entries should be less than 1e20 (the init value) - expect_true(any(mspe_col < 1e19)) - expect_true(all(is.finite(mspe_col[mspe_col < 1e19]))) - expect_true(all(mspe_col[mspe_col < 1e19] > 0)) -}) - -test_that("S2.2: MC method CV - lambda.cv selection", { - - skip_on_cran() - cv_mc <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D + X1 + X2, - data = simdata, - index = c("id", "time"), - method = "mc", - CV = TRUE, - criterion = "mspe", - se = FALSE, - parallel = FALSE - ) - )) - # lambda.cv should be selected - expect_true(!is.null(cv_mc$lambda.cv) || !is.null(cv_mc$r.cv)) - expect_true(!is.null(cv_mc$CV.out)) -}) - -test_that("S2.3: GMoment column correctly populated (IFE)", { - - skip_on_cran() - cv_out <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D + X1 + X2, - data = simdata, - index = c("id", "time"), - method = "ife", - CV = TRUE, - r = c(0, 3), - criterion = "mspe", - se = FALSE, - parallel = FALSE - ) - )) - - # GMoment values should be finite and positive where computed - gm_col <- cv_out$CV.out[, "GMoment"] - computed <- gm_col[gm_col < 1e19] - if (length(computed) > 0) { - expect_true(all(is.finite(computed))) - expect_true(all(computed > 0)) - - # GMoment should generally differ from MSPTATT - msptatt_col <- cv_out$CV.out[, "MSPTATT"] - msptatt_computed <- msptatt_col[gm_col < 1e19] - if (length(msptatt_computed) > 0) { - if (length(computed) > 1) { - expect_false( - all(abs(computed - msptatt_computed) < 1e-15), - info = "GMoment should not be identical to MSPTATT for all r values" - ) - } - } - } -}) - - -## ================================================================= -## S3: fect_mspe criterion support (updated for Phase 2) -## ================================================================= - -test_that("S3.1: Default criterion='mspe' matches old RMSE", { - - skip_on_cran() - res_new <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 123, criterion = "mspe") - )) - - # RMSE = sqrt(MSPE) invariant (P1) - if ("MSPE" %in% names(res_new$summary)) { - expect_equal(res_new$summary$RMSE, sqrt(res_new$summary$MSPE), - tolerance = 1e-10) - } -}) - -test_that("S3.2: All 7 criteria produce finite, positive scores", { - - skip_on_cran() - for (crit in c("mspe", "wmspe", "gmspe", "wgmspe", "mad", - "moment", "gmoment")) { - res <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 123, criterion = crit) - )) - crit_upper <- toupper(crit) - if (crit_upper %in% names(res$summary)) { - expect_true(all(is.finite(res$summary[[crit_upper]])), - info = paste("Criterion", crit, "should be finite")) - expect_true(all(res$summary[[crit_upper]] > 0), - info = paste("Criterion", crit, "should be positive")) - } - } -}) - - -## ================================================================= -## S4: fect_mspe with cv.method (Phase 2 — replaces mask.method) -## ================================================================= - -test_that("S4.1: cv.method='treated_units' masking runs without error", { - - skip_on_cran() - res <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, cv.method = "treated_units", - k = 3, cv.prop = 0.1, - cv.nobs = 3, cv.donut = 1, min.T0 = 3, - criterion = "mspe") - )) - expect_true("summary" %in% names(res)) - if ("MSPE" %in% names(res$summary)) { - expect_true(all(is.finite(res$summary$MSPE))) - expect_true(all(res$summary$MSPE > 0)) - } - expect_true(res$summary$RMSE > 0) -}) - -test_that("S4.2: cv.method='all_units' masking runs without error", { - - skip_on_cran() - res_cv <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, cv.method = "all_units", - k = 3, criterion = "mspe") - )) - expect_true("summary" %in% names(res_cv)) - expect_true(res_cv$summary$RMSE > 0) -}) - -test_that("S4.3: cv.method='treated_units' with k=1 (single fold)", { - - skip_on_cran() - res <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, cv.method = "treated_units", - k = 1, criterion = "mspe") - )) - expect_true(res$summary$RMSE > 0) -}) - - -## ================================================================= -## S6: fect_mspe with observation weights (W) — updated for Phase 2 -## ================================================================= - -test_that("S6.1: W parameter produces different scores than unweighted", { - - skip_on_cran() - TT <- nrow(out_base$Y.dat) - NN <- ncol(out_base$Y.dat) - set.seed(7) - W_mat <- matrix(runif(TT * NN, 0.5, 1.5), nrow = TT, ncol = NN) - res_unw <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, criterion = "mspe", - W = NULL) - )) - res_w <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, criterion = "mspe", - W = W_mat) - )) - expect_false(identical(res_unw$summary$RMSE, res_w$summary$RMSE)) -}) - -test_that("S6.2: Uniform W equals unweighted", { - - skip_on_cran() - TT <- nrow(out_base$Y.dat) - NN <- ncol(out_base$Y.dat) - W_uniform <- matrix(1, nrow = TT, ncol = NN) - res_u <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, criterion = "mspe", - W = W_uniform) - )) - res_n <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, criterion = "mspe", - W = NULL) - )) - if ("MSPE" %in% names(res_u$summary) && "MSPE" %in% names(res_n$summary)) { - expect_equal(res_u$summary$MSPE, res_n$summary$MSPE, tolerance = 1e-10) - } -}) - - -## ================================================================= -## S7: fect_mspe with norm.para — updated for Phase 2 -## ================================================================= - -test_that("S7.1: norm.para scales scores", { - - skip_on_cran() - np <- c(2.0, 0.0) - res_raw <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, criterion = "mspe") - )) - res_norm <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, criterion = "mspe", - norm.para = np) - )) - if ("MSPE" %in% names(res_raw$summary) && - "MSPE" %in% names(res_norm$summary)) { - expect_equal(res_norm$summary$MSPE, res_raw$summary$MSPE * 4.0, - tolerance = 1e-10) - } -}) - - -## ================================================================= -## S8: Return structure (updated for Phase 2 — hide_mask removed) -## ================================================================= - -test_that("S8.3: Return structure has summary and records", { - - skip_on_cran() - res <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42) - )) - expect_true("summary" %in% names(res)) - expect_true("records" %in% names(res)) - expect_true("fits" %in% names(res)) - expect_true("RMSE" %in% names(res$summary)) - expect_true("Bias" %in% names(res$summary)) -}) - - -## ================================================================= -## S9: Input validation (updated for Phase 2) -## ================================================================= - -test_that("S9.1: Invalid criterion rejected", { - - skip_on_cran() - invalid_result <- tryCatch({ - suppressWarnings(suppressMessages( - fect_mspe(out_base, criterion = "invalid", seed = 42) - )) - "no_error" - }, error = function(e) "error_thrown") - - expect_equal(invalid_result, "error_thrown", - info = paste("fect_mspe(criterion='invalid') should throw an error,", - "but it completed without error. Builder must add", - "criterion validation.")) -}) - -test_that("S9.2: Invalid cv.method rejected by fect_mspe", { - - skip_on_cran() - expect_error( - fect_mspe(out_base, cv.method = "invalid"), - "cv.method|arg" - ) -}) - -test_that("S9.3: W wrong dimensions", { - - skip_on_cran() - W_bad <- matrix(1, nrow = 5, ncol = 5) - expect_error( - fect_mspe(out_base, W = W_bad), - "dimension|W" - ) -}) - -test_that("S9.5: .score_residuals() empty input", { - - skip_on_cran() - score_fn <- tryCatch( - getFromNamespace(".score_residuals", "fect"), - error = function(e) NULL - ) - skip_if(is.null(score_fn), ".score_residuals() not yet implemented") - - expect_error(score_fn(numeric(0)), "No residuals") -}) - - -## ================================================================= -## Property-based invariants (updated for Phase 2) -## ================================================================= - -test_that("P1: RMSE = sqrt(MSPE) invariant", { - - skip_on_cran() - res <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, criterion = "mspe") - )) - if ("MSPE" %in% names(res$summary)) { - expect_equal(res$summary$RMSE, sqrt(res$summary$MSPE), tolerance = 1e-10) - } -}) - -test_that("P2: MSPE >= 0", { - - skip_on_cran() - res <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, criterion = "mspe") - )) - if ("MSPE" %in% names(res$summary)) { - expect_true(all(res$summary$MSPE >= 0)) - } -}) - -test_that("P5: Moment = 0 when all per-group mean residuals are 0", { - - skip_on_cran() - score_fn <- tryCatch( - getFromNamespace(".score_residuals", "fect"), - error = function(e) NULL - ) - skip_if(is.null(score_fn), ".score_residuals() not yet implemented") - - # Construct residuals where each group mean is exactly 0 - resid <- c(1, -1, 2, -2) - time_index <- c("A", "A", "B", "B") - count_weights <- c("A" = 1.0, "B" = 1.0) - - result <- score_fn(resid, time_index = time_index, - count_weights = count_weights) - expect_equal(result[["Moment"]], 0.0, tolerance = 1e-10) -}) - -test_that("P7: Seed reproducibility", { - - skip_on_cran() - r1 <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42) - )) - r2 <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42) - )) - expect_identical(r1$summary, r2$summary) -}) - - -## ================================================================= -## Edge cases (updated for Phase 2) -## ================================================================= - -test_that("E3: Single model in fect_mspe (not a list)", { - - skip_on_cran() - res <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42) - )) - expect_equal(nrow(res$summary), 1) - expect_true(res$summary$RMSE > 0) -}) - -test_that("E4: Multiple models in fect_mspe", { - - skip_on_cran() - multi <- suppressWarnings(suppressMessages( - fect_mspe(list(m1 = out_base, m2 = out_base), - seed = 42) - )) - expect_equal(nrow(multi$summary), 2) - expect_true(all(c("m1", "m2") %in% multi$summary$Model)) -}) - - -## ================================================================= -## Section B: cv.method in fect_cv (NEW for Phase 2) -## ================================================================= - -test_that("CV1: cv.method='all_units' selects r.cv", { - - skip_on_cran() - cv_out <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D + X1 + X2, - data = simdata, - index = c("id", "time"), - method = "ife", - CV = TRUE, - r = c(0, 3), - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - # r.cv is integer in [0, 3] - expect_true(cv_out$r.cv >= 0 && cv_out$r.cv <= 3) - # CV.out exists with MSPE column - expect_true(!is.null(cv_out$CV.out)) - mspe_col <- cv_out$CV.out[, "MSPE"] - computed <- mspe_col[mspe_col < 1e19] - expect_true(all(is.finite(computed))) - expect_true(all(computed > 0)) -}) - -test_that("CV2: cv.method='treated_units' selects r.cv", { - - skip_on_cran() - cv_out <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D + X1 + X2, - data = simdata, - index = c("id", "time"), - method = "ife", - CV = TRUE, - r = c(0, 3), - cv.method = "treated_units", - se = FALSE, - parallel = FALSE - ) - )) - # r.cv is integer in [0, 3] - expect_true(cv_out$r.cv >= 0 && cv_out$r.cv <= 3) - # CV.out exists - expect_true(!is.null(cv_out$CV.out)) - mspe_col <- cv_out$CV.out[, "MSPE"] - computed <- mspe_col[mspe_col < 1e19] - expect_true(all(is.finite(computed))) - expect_true(all(computed > 0)) -}) - -test_that("CV3: Invalid cv.method rejected", { - - skip_on_cran() - expect_error( - fect::fect( - Y ~ D + X1 + X2, - data = simdata, - index = c("id", "time"), - method = "ife", - CV = TRUE, - cv.method = "invalid" - ), - "cv.method|arg" - ) -}) - - -## ================================================================= -## Section C: cv.method in fect_nevertreated (NEW for Phase 2) -## ================================================================= - -test_that("NT1: fect_nevertreated cv.method='loo' selects r.cv (IFE)", { - - skip_on_cran() - nt_out <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "loo", - se = FALSE, - parallel = FALSE - ) - )) - expect_true(nt_out$r.cv >= 0 && nt_out$r.cv <= 3) - expect_true(!is.null(nt_out$CV.out)) - mspe_col <- nt_out$CV.out[, "MSPE"] - computed <- mspe_col[mspe_col < 1e19] - if (length(computed) > 0) { - expect_true(all(is.finite(computed))) - } - expect_true(!is.null(nt_out$Y.ct)) -}) - -test_that("NT2: fect_nevertreated cv.method='treated_units' selects r.cv (IFE)", { - - skip_on_cran() - nt_out <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "treated_units", - se = FALSE, - parallel = FALSE - ) - )) - expect_true(nt_out$r.cv >= 0 && nt_out$r.cv <= 3) - expect_true(!is.null(nt_out$CV.out)) -}) - -test_that("NT3: fect_nevertreated cv.method='all_units' selects r.cv (IFE)", { - - skip_on_cran() - nt_out <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - expect_true(nt_out$r.cv >= 0 && nt_out$r.cv <= 3) - expect_true(!is.null(nt_out$CV.out)) -}) - -test_that("NT4: fect_nevertreated cv.method='loo' selects r.cv (CFE)", { - - skip_on_cran() - nt_cfe <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "cfe", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "loo", - se = FALSE, - parallel = FALSE - ) - )) - expect_true(nt_cfe$r.cv >= 0 && nt_cfe$r.cv <= 3) - expect_true(!is.null(nt_cfe$CV.out)) -}) - -test_that("NT5: fect_nevertreated cv.method='treated_units' selects r.cv (CFE)", { - - skip_on_cran() - nt_cfe <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "cfe", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "treated_units", - se = FALSE, - parallel = FALSE - ) - )) - expect_true(nt_cfe$r.cv >= 0 && nt_cfe$r.cv <= 3) - expect_true(!is.null(nt_cfe$CV.out)) -}) - -test_that("NT6: fect_nevertreated default cv.method is treated_units", { - - skip_on_cran() - nt_default <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - se = FALSE, - parallel = FALSE - ) - )) - - nt_explicit <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "treated_units", - se = FALSE, - parallel = FALSE - ) - )) - - expect_equal(nt_default$r.cv, nt_explicit$r.cv) -}) - -test_that("NT7: Invalid cv.method rejected for nevertreated", { - - skip_on_cran() - expect_error( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - time.component.from = "nevertreated", - CV = TRUE, - cv.method = "invalid" - ), - "cv.method|arg" - ) -}) - - -## ================================================================= -## Section D: fect_mspe simplification (NEW for Phase 2) -## ================================================================= - -test_that("MSPE1: Simplified fect_mspe with cv.method='all_units'", { - - skip_on_cran() - res <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, cv.method = "all_units", criterion = "mspe") - )) - expect_true("summary" %in% names(res)) - expect_true("records" %in% names(res)) - expect_true("MSPE" %in% names(res$summary)) - expect_true("RMSE" %in% names(res$summary)) - expect_true("Bias" %in% names(res$summary)) - expect_true(res$summary$RMSE > 0) - expect_equal(res$summary$RMSE, sqrt(res$summary$MSPE), tolerance = 1e-10) -}) - -test_that("MSPE2: Simplified fect_mspe with cv.method='treated_units'", { - - skip_on_cran() - res <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, cv.method = "treated_units", - criterion = "mspe") - )) - expect_true("summary" %in% names(res)) - expect_true("records" %in% names(res)) - expect_true(res$summary$RMSE > 0) -}) - -test_that("MSPE3: Removed parameters rejected", { - - skip_on_cran() - expect_error(fect_mspe(out_base, mask.method = "random")) - expect_error(fect_mspe(out_base, hide_mask = matrix(TRUE, 10, 10))) - expect_error(fect_mspe(out_base, n_rep = 3)) - expect_error(fect_mspe(out_base, pre.trend = TRUE)) - expect_error(fect_mspe(out_base, actual = out_base$Y.ct.full)) - expect_error(fect_mspe(out_base, control.only = FALSE)) - expect_error(fect_mspe(out_base, hide_n = 20)) -}) - -test_that("MSPE4: Invalid cv.method rejected", { - - skip_on_cran() - expect_error( - fect_mspe(out_base, cv.method = "loo"), - "cv.method|arg" - ) -}) - -test_that("MSPE5: Multi-model comparison with cv.method", { - - skip_on_cran() - res <- suppressWarnings(suppressMessages( - fect_mspe(list(m1 = out_base, m2 = out_base), - seed = 42, cv.method = "all_units") - )) - expect_equal(nrow(res$summary), 2) - expect_true(all(c("m1", "m2") %in% res$summary$Model)) -}) - -test_that("MSPE6: Seed reproducibility", { - - skip_on_cran() - r1 <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, cv.method = "all_units") - )) - r2 <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, cv.method = "all_units") - )) - expect_identical(r1$summary, r2$summary) -}) - -test_that("MSPE7: fect_mspe with observation weights", { - - skip_on_cran() - TT <- nrow(out_base$Y.dat) - NN <- ncol(out_base$Y.dat) - W_mat <- matrix(1, nrow = TT, ncol = NN) - res <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, cv.method = "all_units", W = W_mat) - )) - if ("MSPE" %in% names(res$summary)) { - expect_true(all(is.finite(res$summary$MSPE))) - expect_true(all(res$summary$MSPE > 0)) - } -}) - -test_that("MSPE8: fect_mspe with norm.para", { - - skip_on_cran() - res_raw <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, cv.method = "all_units") - )) - res_norm <- suppressWarnings(suppressMessages( - fect_mspe(out_base, seed = 42, cv.method = "all_units", - norm.para = c(2.0)) - )) - if ("MSPE" %in% names(res_raw$summary) && - "MSPE" %in% names(res_norm$summary)) { - # With norm.para, MSPE scaled by norm.para[1]^2 = 4.0 - expect_equal(res_norm$summary$MSPE, res_raw$summary$MSPE * 4.0, - tolerance = 1e-10) - } -}) - - -## ================================================================= -## Section E: 1% Selection Rule Verification (NEW for Phase 2) -## ================================================================= - -test_that("SEL1: 1% selection rule in IFE nevertreated", { - - skip_on_cran() - # Large tol should NOT affect the 1% rule - nt_bigtol <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - se = FALSE, - parallel = FALSE, - tol = 0.5 - ) - )) - nt_smalltol <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - se = FALSE, - parallel = FALSE, - tol = 1e-3 - ) - )) - expect_equal(nt_bigtol$r.cv, nt_smalltol$r.cv) -}) - -test_that("SEL2: 1% selection rule in CFE nevertreated", { - - skip_on_cran() - nt_bigtol <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "cfe", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - se = FALSE, - parallel = FALSE, - tol = 0.5 - ) - )) - nt_smalltol <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "cfe", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - se = FALSE, - parallel = FALSE, - tol = 1e-3 - ) - )) - expect_equal(nt_bigtol$r.cv, nt_smalltol$r.cv) -}) - - -## ================================================================= -## Section F: W and count.T.cv in fect_nevertreated (NEW for Phase 2) -## ================================================================= - -test_that("WT1: W weights flow through nevertreated LOO scoring", { - - skip_on_cran() - # W in fect() is a column name, not a matrix. Add a weight column to ntdata. - ntdata_w <- ntdata - ntdata_w$wt <- 1.0 # uniform weights - - nt_w <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata_w, - index = c("id", "time"), - method = "ife", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - W = "wt", - se = FALSE, - parallel = FALSE - ) - )) - expect_true(nt_w$r.cv >= 0 && nt_w$r.cv <= 3) - - # With uniform weights, r.cv should match unweighted result - nt_nw <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - se = FALSE, - parallel = FALSE - ) - )) - expect_equal(nt_w$r.cv, nt_nw$r.cv) -}) - -test_that("WT2: Non-uniform W may change r selection", { - - skip_on_cran() - # W in fect() is a column name. Add non-uniform weight column. - ntdata_w <- ntdata - set.seed(99) - ntdata_w$wt <- runif(nrow(ntdata), 0.5, 2.0) - - nt_w <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata_w, - index = c("id", "time"), - method = "ife", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - W = "wt", - se = FALSE, - parallel = FALSE - ) - )) - # Should not crash, r.cv should be valid - expect_true(nt_w$r.cv >= 0 && nt_w$r.cv <= 3) -}) - - -## ================================================================= -## Section G: Integration Tests (NEW for Phase 2) -## ================================================================= - -test_that("INT1: End-to-end cv.method pipeline", { - - skip_on_cran() - ## Use CV=FALSE for the fit since fect_mspe performs its own - - ## cross-validation masking; what matters is that the fit object - ## has valid Y.dat/Y.ct for fect_mspe to score. - ## NOTE: fect_mspe errors on CV=TRUE fits ("No valid residuals") — - ## that is a separate source-code issue tracked for builder. - fit_result <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - CV = FALSE, - r = 2, - se = FALSE, - parallel = FALSE - ) - )) - mspe_result <- suppressWarnings(suppressMessages( - fect_mspe(fit_result, seed = 42, cv.method = "all_units") - )) - expect_true("summary" %in% names(mspe_result)) - expect_true(mspe_result$summary$RMSE > 0) - if ("MSPE" %in% names(mspe_result$summary)) { - expect_true(mspe_result$summary$MSPE > 0) - } -}) - -test_that("INT2: IFE CV respects cv.method='treated_units'", { - - skip_on_cran() - ## Original test used method="gsynth" + cv.method="loo", but simdata has - ## treatment reversals which gsynth rejects. We test that cv.method is - ## respected by using cv.method="treated_units" (non-default) with method="ife". - ife_out <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D + X1 + X2, - data = simdata, - index = c("id", "time"), - method = "ife", - CV = TRUE, - r = c(0, 3), - cv.method = "treated_units", - se = FALSE, - parallel = FALSE - ) - )) - expect_true(ife_out$r.cv >= 0 && ife_out$r.cv <= 3) -}) - - -## ================================================================= -## Section H: cv.sample k-fold CV in fect_nevertreated (NEW) -## Tests for actual cv.sample-based cross-validation branches -## when cv.method="all_units" or "treated_units" in nevertreated. -## ================================================================= - -## ---- H.1: IFE smoke tests ---- ## - -test_that("NTCV1: cv.method='all_units' IFE produces valid output", { - - skip_on_cran() - set.seed(42) - out_au <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - # r.cv is integer in [0, 3] - expect_true(out_au$r.cv >= 0 && out_au$r.cv <= 3) - # att.avg is finite - expect_true(is.finite(out_au$att.avg)) - # est.att has no all-NA columns - if (!is.null(out_au$est.att)) { - na_cols <- apply(out_au$est.att, 2, function(x) all(is.na(x))) - expect_false(all(na_cols), - info = "est.att should not have all columns be NA") - } - # CV.out exists with proper structure - expect_true(!is.null(out_au$CV.out)) - mspe_col <- out_au$CV.out[, "MSPE"] - computed <- mspe_col[mspe_col < 1e19] - if (length(computed) > 0) { - expect_true(all(is.finite(computed))) - expect_true(all(computed > 0)) - } -}) - -test_that("NTCV2: cv.method='treated_units' IFE produces valid output", { - - skip_on_cran() - set.seed(42) - out_tu <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "treated_units", - se = FALSE, - parallel = FALSE - ) - )) - expect_true(out_tu$r.cv >= 0 && out_tu$r.cv <= 3) - expect_true(is.finite(out_tu$att.avg)) - if (!is.null(out_tu$est.att)) { - na_cols <- apply(out_tu$est.att, 2, function(x) all(is.na(x))) - expect_false(all(na_cols)) - } - expect_true(!is.null(out_tu$CV.out)) -}) - -## ---- H.2: CFE smoke tests ---- ## - -test_that("NTCV3: cv.method='all_units' CFE produces valid output", { - - skip_on_cran() - set.seed(42) - out_au_cfe <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "cfe", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - expect_true(out_au_cfe$r.cv >= 0 && out_au_cfe$r.cv <= 3) - expect_true(is.finite(out_au_cfe$att.avg)) - expect_true(!is.null(out_au_cfe$CV.out)) -}) - -test_that("NTCV4: cv.method='treated_units' CFE produces valid output", { - - skip_on_cran() - set.seed(42) - out_tu_cfe <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "cfe", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "treated_units", - se = FALSE, - parallel = FALSE - ) - )) - expect_true(out_tu_cfe$r.cv >= 0 && out_tu_cfe$r.cv <= 3) - expect_true(is.finite(out_tu_cfe$att.avg)) - expect_true(!is.null(out_tu_cfe$CV.out)) -}) - -## ---- H.3: LOO backward compatibility ---- ## - -test_that("NTCV5: cv.method='loo' IFE backward compatibility", { - - skip_on_cran() - set.seed(1234) - out_loo <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "loo", - se = FALSE, - parallel = FALSE - ) - )) - expect_true(out_loo$r.cv >= 0 && out_loo$r.cv <= 3) - expect_true(is.finite(out_loo$att.avg)) - expect_true(!is.null(out_loo$CV.out)) - - # LOO is deterministic: re-running should produce identical r.cv - set.seed(1234) - out_loo2 <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "loo", - se = FALSE, - parallel = FALSE - ) - )) - expect_equal(out_loo$r.cv, out_loo2$r.cv) -}) - -## ---- H.4: r-selection and ATT checks ---- ## - -test_that("NTCV6: r-selection validity across all cv.methods (IFE)", { - - skip_on_cran() - r_start <- 0 - r_end <- 3 - - methods_list <- c("loo", "all_units", "treated_units") - for (cm in methods_list) { - set.seed(42) - out <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(r_start, r_end), - cv.method = cm, - se = FALSE, - parallel = FALSE - ) - )) - - # r.cv in valid range - expect_true(out$r.cv >= r_start && out$r.cv <= r_end, - info = paste("cv.method =", cm, ": r.cv out of range")) - - # CV.out has correct number of rows - expect_equal(nrow(out$CV.out), r_end - r_start + 1, - info = paste("cv.method =", cm, ": CV.out row count wrong")) - - # Score columns in CV.out: check MSPE for evaluated rows - mspe_col <- out$CV.out[, "MSPE"] - computed <- mspe_col[mspe_col < 1e19] - if (length(computed) > 0) { - expect_true(all(is.finite(computed)), - info = paste("cv.method =", cm, ": non-finite MSPE")) - expect_true(all(computed >= 0), - info = paste("cv.method =", cm, ": negative MSPE")) - } - } -}) - -test_that("NTCV7: ATT consistency across cv.methods (IFE)", { - - skip_on_cran() - att_vals <- numeric(3) - methods_list <- c("loo", "all_units", "treated_units") - for (i in seq_along(methods_list)) { - set.seed(42) - out <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = methods_list[i], - se = FALSE, - parallel = FALSE - ) - )) - att_vals[i] <- out$att.avg - expect_true(is.finite(out$att.avg), - info = paste("cv.method =", methods_list[i], ": att.avg not finite")) - } - - # Sanity check: all ATT values should be in the same ballpark. - # The true ATT is ~3.0 for this DGP. - # Allow wide tolerance since different r.cv selections produce different ATTs. - att_range <- max(att_vals) - min(att_vals) - expect_true(att_range < 5.0, - info = paste("ATT values too spread:", - paste(round(att_vals, 3), collapse = ", "))) -}) - -## ---- H.5: Edge cases ---- ## - -test_that("NTCV-Edge1: r=c(0,0) with all cv.methods", { - - skip_on_cran() - for (cm in c("loo", "all_units", "treated_units")) { - set.seed(42) - out <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 0), - cv.method = cm, - se = FALSE, - parallel = FALSE - ) - )) - expect_equal(out$r.cv, 0, - info = paste("cv.method =", cm, ": r.cv should be 0 when r=c(0,0)")) - # Scores should still be finite - mspe_col <- out$CV.out[, "MSPE"] - computed <- mspe_col[mspe_col < 1e19] - if (length(computed) > 0) { - expect_true(all(is.finite(computed)), - info = paste("cv.method =", cm, ": non-finite MSPE with r=0")) - } - } -}) - -test_that("NTCV-Edge2: Small panel with all cv.methods", { - - skip_on_cran() - # Create data with few pre-treatment periods for treated units - small_data <- make_factor_data(N = 30, TT = 10, Ntr = 8, r = 1, seed = 99) - - for (cm in c("loo", "all_units", "treated_units")) { - set.seed(42) - out <- tryCatch( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = small_data, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 2), - cv.method = cm, - se = FALSE, - parallel = FALSE - ) - )), - error = function(e) e - ) - # Should either succeed with valid r.cv or produce informative error - if (!inherits(out, "error")) { - expect_true(out$r.cv >= 0 && out$r.cv <= 2, - info = paste("cv.method =", cm, ": r.cv out of range (small panel)")) - expect_true(is.finite(out$att.avg), - info = paste("cv.method =", cm, ": att.avg not finite (small panel)")) - } else { - # If it errors, the message should be informative (not a cryptic crash) - expect_true(nchar(conditionMessage(out)) > 0, - info = paste("cv.method =", cm, ": error should be informative")) - } - } -}) - -test_that("NTCV-Edge3: Single treated unit", { - - skip_on_cran() - single_tr_data <- make_factor_data(N = 30, TT = 15, Ntr = 1, r = 1, seed = 77) - - for (cm in c("loo", "all_units", "treated_units")) { - set.seed(42) - out <- tryCatch( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = single_tr_data, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 2), - cv.method = cm, - se = FALSE, - parallel = FALSE - ) - )), - error = function(e) e - ) - if (!inherits(out, "error")) { - expect_true(out$r.cv >= 0 && out$r.cv <= 2, - info = paste("cv.method =", cm, ": r.cv invalid (single treated)")) - } - # If it errors, that's acceptable for single treated unit edge case - } -}) - -## ---- H.6: Property-based invariants for cv.sample ---- ## - -test_that("NTCV-P1: Score non-negativity in CV.out", { - - skip_on_cran() - for (cm in c("all_units", "treated_units")) { - set.seed(42) - out <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = cm, - se = FALSE, - parallel = FALSE - ) - )) - - # All score columns should be non-negative - score_cols <- c("MSPE", "WMSPE", "GMSPE", "WGMSPE", "MAD") - for (sc in score_cols) { - if (sc %in% colnames(out$CV.out)) { - vals <- out$CV.out[, sc] - computed <- vals[vals < 1e19] - if (length(computed) > 0) { - expect_true(all(computed >= 0), - info = paste("cv.method =", cm, ", score =", sc, ": negative value")) - } - } - } - } -}) - -test_that("NTCV-P4: LOO determinism", { - - skip_on_cran() - set.seed(42) - out1 <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "loo", - se = FALSE, - parallel = FALSE - ) - )) - - set.seed(999) # different seed should not affect LOO - out2 <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "loo", - se = FALSE, - parallel = FALSE - ) - )) - - expect_equal(out1$r.cv, out2$r.cv) - # CV.out scores should be identical - expect_equal(out1$CV.out, out2$CV.out, tolerance = 1e-10) -}) - -test_that("NTCV-P5: cv.sample reproducibility with set.seed", { - - skip_on_cran() - for (cm in c("all_units", "treated_units")) { - set.seed(42) - out1 <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = cm, - se = FALSE, - parallel = FALSE - ) - )) - - set.seed(42) - out2 <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = cm, - se = FALSE, - parallel = FALSE - ) - )) - - expect_equal(out1$r.cv, out2$r.cv, - info = paste("cv.method =", cm, ": r.cv not reproducible")) - expect_equal(out1$CV.out, out2$CV.out, tolerance = 1e-10, - info = paste("cv.method =", cm, ": CV.out not reproducible")) - } -}) - - -## ================================================================= -## Section I: Runtime Benchmarks (cv.method timing comparison) -## Informational only — skip on CRAN -## ================================================================= - -test_that("BENCH1: IFE timing comparison (loo vs all_units vs treated_units)", { - - skip_on_cran() - - cat("\n=== Runtime Benchmark: IFE nevertreated cv.method timing ===\n") - - set.seed(42) - t_loo <- system.time( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "loo", - se = FALSE, - parallel = FALSE - ) - )) - ) - cat(sprintf(" IFE loo: %6.2f sec (elapsed)\n", t_loo["elapsed"])) - - set.seed(42) - t_au <- system.time( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - ) - cat(sprintf(" IFE all_units: %6.2f sec (elapsed)\n", t_au["elapsed"])) - - set.seed(42) - t_tu <- system.time( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "treated_units", - se = FALSE, - parallel = FALSE - ) - )) - ) - cat(sprintf(" IFE treated_units: %6.2f sec (elapsed)\n", t_tu["elapsed"])) - - cat(sprintf(" Speedup (loo/all_units): %.2fx\n", - t_loo["elapsed"] / max(t_au["elapsed"], 0.001))) - cat(sprintf(" Speedup (loo/treated_units): %.2fx\n", - t_loo["elapsed"] / max(t_tu["elapsed"], 0.001))) - cat("=== End IFE Benchmark ===\n") - - # All three must complete — that's the real test - expect_true(TRUE) -}) - -test_that("BENCH2: CFE timing comparison (loo vs all_units vs treated_units)", { - - skip_on_cran() - - cat("\n=== Runtime Benchmark: CFE nevertreated cv.method timing ===\n") - - set.seed(42) - t_loo <- system.time( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "cfe", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "loo", - se = FALSE, - parallel = FALSE - ) - )) - ) - cat(sprintf(" CFE loo: %6.2f sec (elapsed)\n", t_loo["elapsed"])) - - set.seed(42) - t_au <- system.time( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "cfe", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - ) - cat(sprintf(" CFE all_units: %6.2f sec (elapsed)\n", t_au["elapsed"])) - - set.seed(42) - t_tu <- system.time( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = ntdata, - index = c("id", "time"), - method = "cfe", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "treated_units", - se = FALSE, - parallel = FALSE - ) - )) - ) - cat(sprintf(" CFE treated_units: %6.2f sec (elapsed)\n", t_tu["elapsed"])) - - cat(sprintf(" Speedup (loo/all_units): %.2fx\n", - t_loo["elapsed"] / max(t_au["elapsed"], 0.001))) - cat(sprintf(" Speedup (loo/treated_units): %.2fx\n", - t_loo["elapsed"] / max(t_tu["elapsed"], 0.001))) - cat("=== End CFE Benchmark ===\n") - - expect_true(TRUE) -}) - -## --------------------------------------------------------------- -## Section G: Parallel CV Folds in fect_nevertreated -## -## Tests for REQ-parallel-cv: verifies that parallel=TRUE produces -## identical results to parallel=FALSE (sequential), that -## reproducibility holds under parallelism with fixed seeds, that -## default behavior is unchanged, that the LOO path is unaffected, -## and that edge cases work correctly. -## -## Follows test-spec.md for REQ-parallel-cv. -## Tolerances: 1e-10 for CV score differences (per test-spec.md). -## --------------------------------------------------------------- - -## -- G.1 Sequential-Parallel Equivalence: IFE, all_units ---------- - -test_that("G.1: parallel CV matches sequential — IFE, all_units", { - - skip_on_cran() - - dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) - - set.seed(123) - result_seq <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - - set.seed(123) - result_par <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE, - parallel = TRUE, - cores = 2 - ) - )) - - ## r.cv must be identical - expect_identical(result_seq$r.cv, result_par$r.cv) - - ## CV.out matrix must match within tolerance 1e-10 - cv_diff <- max(abs(result_seq$CV.out - result_par$CV.out)) - expect_true(cv_diff < 1e-10, - info = sprintf("CV.out max diff = %.2e (tolerance = 1e-10)", cv_diff)) -}) - -## -- G.2 Sequential-Parallel Equivalence: IFE, treated_units ------ - -test_that("G.2: parallel CV matches sequential — IFE, treated_units", { - - skip_on_cran() - - dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) - - set.seed(123) - result_seq <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "treated_units", - se = FALSE, - parallel = FALSE - ) - )) - - set.seed(123) - result_par <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "treated_units", - se = FALSE, - parallel = TRUE, - cores = 2 - ) - )) - - expect_identical(result_seq$r.cv, result_par$r.cv) - - cv_diff <- max(abs(result_seq$CV.out - result_par$CV.out)) - expect_true(cv_diff < 1e-10, - info = sprintf("CV.out max diff = %.2e (tolerance = 1e-10)", cv_diff)) -}) - -## -- G.3 Sequential-Parallel Equivalence: CFE, all_units ---------- - -test_that("G.3: parallel CV matches sequential — CFE, all_units", { - - skip_on_cran() - - dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) - - set.seed(123) - result_seq <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "cfe", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - - set.seed(123) - result_par <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "cfe", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE, - parallel = TRUE, - cores = 2 - ) - )) - - expect_identical(result_seq$r.cv, result_par$r.cv) - - cv_diff <- max(abs(result_seq$CV.out - result_par$CV.out)) - expect_true(cv_diff < 1e-10, - info = sprintf("CV.out max diff = %.2e (tolerance = 1e-10)", cv_diff)) -}) - -## -- G.4 Sequential-Parallel Equivalence: CFE, treated_units ------ - -test_that("G.4: parallel CV matches sequential — CFE, treated_units", { - - skip_on_cran() - - dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) - - set.seed(123) - result_seq <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "cfe", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "treated_units", - se = FALSE, - parallel = FALSE - ) - )) - - set.seed(123) - result_par <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "cfe", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "treated_units", - se = FALSE, - parallel = TRUE, - cores = 2 - ) - )) - - expect_identical(result_seq$r.cv, result_par$r.cv) - - cv_diff <- max(abs(result_seq$CV.out - result_par$CV.out)) - expect_true(cv_diff < 1e-10, - info = sprintf("CV.out max diff = %.2e (tolerance = 1e-10)", cv_diff)) -}) - -## -- G.5 Reproducibility Under Parallelism ------------------------ - -test_that("G.5: parallel CV is reproducible with same seed", { - - skip_on_cran() - - dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) - - set.seed(123) - result_par1 <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE, - parallel = TRUE, - cores = 2, - seed = 12345 - ) - )) - - set.seed(123) - result_par2 <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE, - parallel = TRUE, - cores = 2, - seed = 12345 - ) - )) - - expect_identical(result_par1$r.cv, result_par2$r.cv) - expect_identical(result_par1$CV.out, result_par2$CV.out) -}) - -## -- G.6 Default Behavior Unchanged ------------------------------- - -test_that("G.6: default (no parallel arg) behaves as sequential", { - - skip_on_cran() - - dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) - - ## Call without specifying parallel or cores — should default to sequential - set.seed(123) - result_default <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE - ) - )) - - set.seed(123) - result_seq <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - - expect_identical(result_default$r.cv, result_seq$r.cv) - expect_identical(result_default$CV.out, result_seq$CV.out) -}) - -## -- G.7 LOO Path Unaffected -------------------------------------- - -test_that("G.7: LOO path is unaffected by parallel flag", { - - skip_on_cran() - - dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) - - set.seed(123) - result_loo_seq <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "loo", - se = FALSE, - parallel = FALSE - ) - )) - - set.seed(123) - result_loo_par <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - cv.method = "loo", - se = FALSE, - parallel = TRUE, - cores = 2 - ) - )) - - ## LOO should produce identical results regardless of parallel flag - expect_identical(result_loo_seq$r.cv, result_loo_par$r.cv) - expect_identical(result_loo_seq$CV.out, result_loo_par$CV.out) -}) - -## -- G.8 Edge Case: k = 1 ---------------------------------------- - -test_that("G.8: edge case — k = 1 with parallel=TRUE runs without error", { - - skip_on_cran() - - dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) - - set.seed(123) - result_par <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 1, - cv.method = "all_units", - se = FALSE, - parallel = TRUE, - cores = 2 - ) - )) - - set.seed(123) - result_seq <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 1, - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - - expect_identical(result_par$r.cv, result_seq$r.cv) -}) - -## -- G.9 Edge Case: cores = 1 ------------------------------------ - -test_that("G.9: edge case — cores = 1 behaves as sequential", { - - skip_on_cran() - - dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) - - set.seed(123) - result_c1 <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE, - parallel = TRUE, - cores = 1 - ) - )) - - set.seed(123) - result_seq <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - - cv_diff <- max(abs(result_c1$CV.out - result_seq$CV.out)) - expect_true(cv_diff < 1e-10, - info = sprintf("CV.out max diff = %.2e (tolerance = 1e-10)", cv_diff)) -}) - -## -- G.10 Edge Case: cores = NULL (auto-detect) ------------------ - -test_that("G.10: edge case — cores = NULL auto-detects and runs", { - - skip_on_cran() - - dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) - - set.seed(123) - result_auto <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE, - parallel = TRUE, - cores = NULL - ) - )) - - set.seed(123) - result_seq <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - - cv_diff <- max(abs(result_auto$CV.out - result_seq$CV.out)) - expect_true(cv_diff < 1e-10, - info = sprintf("CV.out max diff = %.2e (tolerance = 1e-10)", cv_diff)) -}) - -## -- G.11 Edge Case: parallel=FALSE with cores specified ---------- - -test_that("G.11: edge case — parallel=FALSE ignores cores", { - - skip_on_cran() - - dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) - - set.seed(123) - result_no_par <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE, - parallel = FALSE, - cores = 4 - ) - )) - - set.seed(123) - result_seq <- suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - - expect_identical(result_no_par$r.cv, result_seq$r.cv) - expect_identical(result_no_par$CV.out, result_seq$CV.out) -}) - -## -- G.12 Timing Benchmark: Parallel vs Sequential ---------------- -## This is an informational benchmark; we report speedup but do not -## hard-fail on specific speedup thresholds (per test-spec.md: -## "Not a pass/fail test, but auditor should measure and report"). - -test_that("G.12: timing benchmark — parallel vs sequential with 10 cores", { - - skip_on_cran() - - ## Larger dataset for meaningful timing differences - dat <- make_factor_data(N = 100, TT = 30, Ntr = 25, r = 2, seed = 99) - - cat("\n=== Parallel CV Timing Benchmark ===\n") - - ## --- IFE, all_units --- - set.seed(123) - t_seq_ife_au <- system.time( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 5), - k = 10, - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - ) - - set.seed(123) - t_par_ife_au <- system.time( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 5), - k = 10, - cv.method = "all_units", - se = FALSE, - parallel = TRUE, - cores = 10 - ) - )) - ) - - cat(sprintf(" IFE all_units sequential: %6.2f sec\n", t_seq_ife_au["elapsed"])) - cat(sprintf(" IFE all_units parallel: %6.2f sec (10 cores)\n", t_par_ife_au["elapsed"])) - speedup_ife_au <- t_seq_ife_au["elapsed"] / max(t_par_ife_au["elapsed"], 0.001) - cat(sprintf(" Speedup: %.2fx\n\n", speedup_ife_au)) - - ## --- IFE, treated_units --- - set.seed(123) - t_seq_ife_tu <- system.time( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 5), - k = 10, - cv.method = "treated_units", - se = FALSE, - parallel = FALSE - ) - )) - ) - - set.seed(123) - t_par_ife_tu <- system.time( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 5), - k = 10, - cv.method = "treated_units", - se = FALSE, - parallel = TRUE, - cores = 10 - ) - )) - ) - - cat(sprintf(" IFE treated_units sequential: %6.2f sec\n", t_seq_ife_tu["elapsed"])) - cat(sprintf(" IFE treated_units parallel: %6.2f sec (10 cores)\n", t_par_ife_tu["elapsed"])) - speedup_ife_tu <- t_seq_ife_tu["elapsed"] / max(t_par_ife_tu["elapsed"], 0.001) - cat(sprintf(" Speedup: %.2fx\n\n", speedup_ife_tu)) - - ## --- CFE, all_units --- - set.seed(123) - t_seq_cfe_au <- system.time( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "cfe", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 5), - k = 10, - cv.method = "all_units", - se = FALSE, - parallel = FALSE - ) - )) - ) - - set.seed(123) - t_par_cfe_au <- system.time( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "cfe", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 5), - k = 10, - cv.method = "all_units", - se = FALSE, - parallel = TRUE, - cores = 10 - ) - )) - ) - - cat(sprintf(" CFE all_units sequential: %6.2f sec\n", t_seq_cfe_au["elapsed"])) - cat(sprintf(" CFE all_units parallel: %6.2f sec (10 cores)\n", t_par_cfe_au["elapsed"])) - speedup_cfe_au <- t_seq_cfe_au["elapsed"] / max(t_par_cfe_au["elapsed"], 0.001) - cat(sprintf(" Speedup: %.2fx\n\n", speedup_cfe_au)) - - ## --- CFE, treated_units --- - set.seed(123) - t_seq_cfe_tu <- system.time( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "cfe", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 5), - k = 10, - cv.method = "treated_units", - se = FALSE, - parallel = FALSE - ) - )) - ) - - set.seed(123) - t_par_cfe_tu <- system.time( - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "cfe", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 5), - k = 10, - cv.method = "treated_units", - se = FALSE, - parallel = TRUE, - cores = 10 - ) - )) - ) - - cat(sprintf(" CFE treated_units sequential: %6.2f sec\n", t_seq_cfe_tu["elapsed"])) - cat(sprintf(" CFE treated_units parallel: %6.2f sec (10 cores)\n", t_par_cfe_tu["elapsed"])) - speedup_cfe_tu <- t_seq_cfe_tu["elapsed"] / max(t_par_cfe_tu["elapsed"], 0.001) - cat(sprintf(" Speedup: %.2fx\n\n", speedup_cfe_tu)) - - cat("=== End Parallel CV Timing Benchmark ===\n") - - ## Informational — always passes; speedup is reported in test output - expect_true(TRUE) -}) - -## -- G.13 Property: Backend Cleanup After Parallel CV ------------- - -test_that("G.13: parallel backend is restored after fect() returns", { - - skip_on_cran() - - dat <- make_factor_data(N = 50, TT = 20, Ntr = 15, r = 2, seed = 42) - - old_plan <- future::plan() - - set.seed(123) - suppressWarnings(suppressMessages( - fect::fect( - Y ~ D, - data = dat, - index = c("id", "time"), - method = "ife", - force = "two-way", - time.component.from = "nevertreated", - CV = TRUE, - r = c(0, 3), - k = 5, - cv.method = "all_units", - se = FALSE, - parallel = TRUE, - cores = 2 - ) - )) - - new_plan <- future::plan() - - ## The future plan class should be restored - expect_identical(class(old_plan), class(new_plan)) -}) diff --git a/vignettes/01-start.Rmd b/vignettes/01-start.Rmd index b656f562..2f7cfbc0 100644 --- a/vignettes/01-start.Rmd +++ b/vignettes/01-start.Rmd @@ -12,45 +12,36 @@ rm(list = ls()) ## Installation -To install **fect** from CRAN, run the code chunk below: +| Source | Version | Date | Features | +|--------|---------|------|----------| +| CRAN | 2.4.5 | 2026-05-30 | Default release | +| GitHub (`master`) | 2.4.5 | 2026-05-30 | Same as CRAN | +| GitHub (`dev`) | 2.4.5 | 2026-05-30 | Same as CRAN | + +To install **fect** from CRAN: ```{r install-cran, eval = FALSE, message = FALSE, warning = FALSE} install.packages("fect") ``` -We recommend users to install the most up-to-date, stable version of **fect** from Github using: +For the most up-to-date stable version on GitHub: -```{r install-github-main, eval = FALSE, message = FALSE, warning = FALSE, cache = FALSE,} +```{r install-github-main, eval = FALSE, message = FALSE, warning = FALSE, cache = FALSE} devtools::install_github("xuyiqing/fect") ``` -We fix bugs in the `dev` branch before merging into the main branch; therefore, it is often more up to date. +Bug fixes land on the `dev` branch first, so it is often ahead of `master`: -```{r install-github-dev, eval = FALSE, message = FALSE, warning = FALSE, cache = FALSE,} +```{r install-github-dev, eval = FALSE, message = FALSE, warning = FALSE, cache = FALSE} devtools::install_github("xuyiqing/fect@dev") ``` -After installation, check **fect** version to make sure the package is up-to-date. +Check the installed version: ```{r check-version} installed.packages()["fect", "Version"] ``` -For reference, here are the latest **CRAN release** and **`dev` branch** versions (queried live): - -```{r check-latest-versions, message = FALSE, warning = FALSE, cache = FALSE} -cran_ver <- tryCatch( - available.packages(repos = "https://cloud.r-project.org")["fect", "Version"], - error = function(e) "" -) -dev_ver <- tryCatch({ - desc <- readLines("https://raw.githubusercontent.com/xuyiqing/fect/dev/DESCRIPTION") - sub("^Version: ", "", desc[grep("^Version: ", desc)]) -}, error = function(e) "") -cat(sprintf("CRAN release: %s\n", cran_ver)) -cat(sprintf("Dev branch: %s\n", dev_ver)) -``` - **panelView** for panel data visualization is highly recommended and will be used in the tutorial: ```{r install-panelview, eval=FALSE} @@ -116,5 +107,5 @@ The scripts that generate simulated datasets are in `data-raw/`. ### Empirical datasets - `turnout`: Based on @Xu2017. Used in [Chapter @sec-gsynth] alongside `sim_gsynth`. -- `gs2020`: Based on @GS2020, who examine the effect of minority candidate presence on the proportion of coethnic donations in U.S. House elections. Used in [Chapter @sec-plots] and [Chapter @sec-panel]. -- `hh2019`: Based on @HH2019, who study the effect of indirect versus direct democracy on naturalization rates in Switzerland. Used in [Chapter @sec-plots], [Chapter @sec-panel], and [Chapter @sec-panel-sens]. +- `gs2020`: Based on @GS2020, who examine the effect of minority candidate presence on the proportion of coethnic donations in U.S. House elections. Used in [Chapter @sec-panel] and [Chapter @sec-plots]. +- `hh2019`: Based on @HH2019, who study the effect of indirect versus direct democracy on naturalization rates in Switzerland. Used in [Chapter @sec-panel], [Chapter @sec-panel-sens], and [Chapter @sec-plots]. diff --git a/vignettes/02-fect.Rmd b/vignettes/02-fect.Rmd index 56e3224d..0b72eae1 100644 --- a/vignettes/02-fect.Rmd +++ b/vignettes/02-fect.Rmd @@ -73,13 +73,9 @@ In the gap plot, pre-treatment estimates appear in gray (in-sample) while post-t ### Inference -The package can produce uncertainty estimates when `se = TRUE`. The default is the non-parametric cluster-bootstrap (`vartype = "bootstrap"`), which works well when the number of units is relatively large and many units experience the treatment condition. The number of bootstrap runs can be set by `nboots`. +The package can produce uncertainty estimates when `se = TRUE`. The default is the non-parametric cluster-bootstrap (`vartype = "bootstrap"`), which works well when the number of units is relatively large and many units experience the treatment condition. Switch to `vartype = "jackknife"` (leave-one-unit-out) when the number of treated units is small (single digits). The number of bootstrap runs is set by `nboots` and the clustering variable by `cl` (default `"id"`). -::: {.callout-tip appearance="simple"} -### Inference parameters - -The key parameters that control **uncertainty estimation** are: `se` (enable standard errors), `vartype` (`"bootstrap"`, `"jackknife"`, or `"parametric"`), `nboots` (number of bootstrap replications), and `cl` (clustering variable). These parameters do not affect point estimates. `"parametric"` is only available in the Synth setting, i.e., when `time.component.from = "nevertreated"`. -::: +A third option, `vartype = "parametric"`, is intended for the synthetic-control regime where the number of treated units is small and the nonparametric bootstrap is unreliable; it has its own assumptions and gates. That setting and the deeper discussion of bootstrap-distribution semantics, confidence-interval methods (`ci.method`), p-values, and an empirical coverage study live in [Chapter @sec-inference]. ::: {.callout-note appearance="simple"} **Parallel computing** will speed up both cross-validation and uncertainty estimation significantly. We recommend that users manually set the number of cores using the `cores` option. If this is not supplied or is `NULL`, we will automatically select the smaller of `8` and the number of usable system cores minus `2`, to prevent excessive use of system resources. @@ -101,51 +97,10 @@ When `parallel = TRUE`, CV parallelism auto-engages only on panels above a metho **Clustering.** - By default, `fect()` uses cluster-bootstrap at the `unit` level when `se = TRUE`, that is `vartype = "bootstrap"`. The uncertainty estimates thus account for arbitrary serial correlation within a unit over time---commonly understood as being "clustered" at the unit level. In the example above, the unit is `id`, hence, by default, `cl = "id"`. -- Alternatively, users can obtain uncertainty estimates using the cluster-jackknife method by specifying `vartype = "jackknife"`, also at the unit level. In this case, the algorithm calculates standard errors by iteratively dropping one unit (i.e., the entire time series) from the dataset. This can be particularly useful when the number of treated units is small. - To cluster standard errors at a different, usually higher, level, users can specify the clustering variable using the `cl` option. +- Alternatively, users can obtain uncertainty estimates using the cluster-jackknife method by specifying `vartype = "jackknife"`, also at the unit level (`cl`, if different from `unit`, will be ignored). In this case, the algorithm calculates standard errors by iteratively dropping one unit (i.e., the entire time series) from the dataset. This can be particularly useful when the number of treated units is small. ::: -### Parametric bootstrap: valid regimes {#sec-parametric-regimes} - -The parametric bootstrap (`vartype = "parametric"`) uses a two-stage pseudo-treated resampling procedure to produce uncertainty estimates. It is well-suited for the synthetic control setting, where the number of treated units is small and nonparametric bootstrap is unreliable. However, the procedure rests on two key assumptions: (a) the time components (factors and loadings) are estimated from a **never-treated** control pool that is independent of the treated units' data, and (b) the model residuals on control units accurately reflect the true error distribution. When either assumption is violated, the parametric bootstrap underestimates standard errors and produces confidence intervals that are too narrow. - -To prevent users from invoking the parametric bootstrap in settings where these assumptions fail, the package enforces three hard restrictions: - -::: {.callout-important appearance="simple"} -### Three-gate system - -| Gate | Condition | What it blocks | -|---|---|---| -| A | `method %in% c("mc", "both")` + `vartype = "parametric"` | MC + parametric | -| B | treatment reversal present + `vartype = "parametric"` | reversal + parametric | -| C | `time.component.from = "notyettreated"` + `vartype = "parametric"` | notyettreated + parametric | - -In all three cases the package raises an informative error pointing to the valid alternatives. -::: - -The motivation for Gate C comes from both theory and evidence. The `notyettreated` path uses EM imputation to estimate factors jointly across all not-yet-treated observations, including the treated units' pre-period data. EM enlarges the effective factor space by imputing masked treated-post cells, which deflates the observed-cell residuals that the parametric bootstrap feeds into its covariance estimator. In a Monte Carlo study (N = 50, T = 20, r = 2 factors, 500 replications), the blocked `ife + notyettreated + parametric` combination produced **80.6% coverage at nominal 95%** (SE ratio ≈ 0.67). In contrast, all tested nevertreated paths produced near-nominal coverage (0.93–0.96, SE ratio ≈ 1.0). The architectural details of all three gates are documented in `ARCHITECTURE.md`. - -If your current code uses `vartype = "parametric"` with the default `time.component.from = "notyettreated"`, migrate as follows: - -```r -# Before (now raises an error under Gate C): -fect(data, Y = "Y", D = "D", index = c("id", "time"), - method = "ife", se = TRUE, vartype = "parametric") - -# After — option 1: switch to nevertreated imputation -# (requires that never-treated control units exist in the data) -fect(data, Y = "Y", D = "D", index = c("id", "time"), - method = "ife", time.component.from = "nevertreated", - se = TRUE, vartype = "parametric") - -# After — option 2: use nonparametric bootstrap (safe default) -fect(data, Y = "Y", D = "D", index = c("id", "time"), - method = "ife", - se = TRUE, vartype = "bootstrap") -``` - -Option 1 switches to the gsynth-style estimation regime and keeps parametric bootstrap. This is appropriate when never-treated control units exist and the treatment does not reverse. Option 2 leaves the estimator unchanged and uses cluster-bootstrap, which is appropriate when the number of treated units is moderate to large. See [Chapter @sec-gsynth] for guidance. - ```{r simdata_fect, eval=TRUE, cache = TRUE, message = FALSE, results = 'hide'} out.fect <- fect(Y ~ D + X1 + X2, data = sim_base, index = c("id","time"), method = "fe", force = "two-way", se = TRUE, @@ -283,17 +238,17 @@ The event study plot utilizing leave-one-out for pretreatment estimates is shown plot(out.fect.loo,main = "Estimated ATT (FEct) -- LOO") ``` + ------------------------------------------------------------------------ -## Cumulative effects +## Other estimands -Cumulative treatment effects through each event time, and over a specified window, are computed via the unified post-hoc estimand interface introduced in v2.4.0. Both the per-event-time series and the overall window form are one-line calls. See [Chapter @sec-estimands] for the full surface, worked examples, and the migration table from the legacy `effect()` and `att.cumu()` functions. +Beyond the standard ATT, **fect** supports several estimand variants: the **cumulative effects**, the **balanced treated sample** ATT (estimated only on treated units with complete data in a specified window), the **average cohort treatment effect** (estimated separately for each cohort of treatment adoption), and **user-supplied weighted ATTs** (where a user-provided weight column is applied to the across-treated-obs aggregation). ------------------------------------------------------------------------- +### Cumulative effects -## Other estimands +Cumulative treatment effects through each event time, and over a specified window, are computed via the unified post-hoc estimand interface introduced in v2.4.0. Both the per-event-time series and the overall window form are one-line calls. See [Chapter @sec-estimands] for the full surface, worked examples, and the migration table from the legacy `effect()` and `att.cumu()` functions. -Beyond the standard ATT, **fect** supports several estimand variants: the **balanced treated sample** ATT (estimated only on treated units with complete data in a specified window), the **average cohort treatment effect** (estimated separately for each cohort of treatment adoption), and **user-supplied weighted ATTs** (where a user-provided weight column is applied to the across-treated-obs aggregation). ### Balanced treated sample @@ -379,6 +334,83 @@ For finer control --- separating the weight that enters the outcome-model fit (` The fit object exposes the full imputed counterfactual surface, so users can compute estimands beyond the default level-scale ATT directly from the fit. **fect** v2.4.0 ships a typed dispatcher `estimand()` for the common cases — APTT [@chen2024logs], log-scale ATT, cumulative ATT, window-restricted ATT — plus a low-level accessor `imputed_outcomes()` for custom estimands the dispatcher does not ship. See [Chapter @sec-estimands] for the full chapter with worked examples and the migration table from `effect()` / `att.cumu()`. +## Higher-level FE: `group.fe` for sub-group treatment + +When units are nested inside groups and treatment varies at the group level --- counties in states with a state policy, students in schools with a school-wide intervention --- the unit FE $\alpha_i$ is often too granular and absorbs the very dynamics the user wants to study. The natural alternative is to absorb FE at the group level instead, while keeping the individual rows for any individual-level covariates and residual degrees of freedom. + +::: {.callout-note appearance="simple"} +`index = c("id", "time")` must still uniquely identify each row. `group.fe` is a *coarsening* of `index[1]` (each unit belongs to one group), not a replacement. +::: + +The `group.fe` argument (v2.4.5+) names this pattern. The implied model is: + +$$Y_{it}^{0} = \xi_t + \omega_{g(i)} + e_{it}$$ + +with $\omega_{g(i)}$ the state FE and `force = "time"` skipping the county FE. + +### Worked example + +```{r fect-group-fe-data, eval = TRUE, message = FALSE} +set.seed(42) +N <- 40; TT <- 10 +df_county <- expand.grid(id = 1:N, time = 1:TT) +df_county$state <- paste0("S", (df_county$id - 1) %% 4 + 1) +df_county$D <- as.integer(df_county$state %in% c("S1", "S2") & + df_county$time >= 6) +df_county$Y <- 1 + 0.5 * df_county$D + rnorm(nrow(df_county), sd = 0.5) + +fit_gfe <- fect(Y ~ D, data = df_county, + index = c("id", "time"), + group.fe = "state", + force = "time", # no county FE + se = TRUE, nboots = 200, parallel = FALSE) +``` + +```{r fect-group-fe-print, eval = TRUE} +print(fit_gfe) +``` + +The header surfaces three facts: `Estimator: fe` (no factors), `Fixed effects: time (time) + state` (state, not county), `Cluster SE: state` (auto-defaulted). + +### Cluster SE + +When `group.fe` is a single column, `cl` auto-defaults to it. This matches the standard recommendation to cluster at the treatment-assignment level (Bertrand, Duflo & Mullainathan 2004): the effective $n$ for the treatment SE is the number of states, not counties. Override by passing `cl` explicitly to any other column --- e.g., `cl = "id"` for unit-level clustering, or `cl = "region"` for a different group level. Note that fect's case bootstrap always resamples units regardless of `cl`; the `cl` argument only sets the *cluster identity* over which resampling happens, never to "no clustering." + +### Method auto-routing + +`method = "fe"` (default) is silently routed to `method = "cfe"`. Only the CFE solver has the C++ machinery for additive FE that span multiple columns (`extra_FE_index_cache` in `src/cfe_sub.cpp`); the standard FE solver's demean loop is hard-wired to demean by unit and time only. The route is safe because FE is a strict subset of CFE at `r=0`, and all wrapper code paths (CV, plot, bootstrap) branch on the value of `r`, not on `method`. `method = "ife"`/`"mc"`/`"both"`/`"gsynth"` hard-error with `group.fe` --- those wrappers *do* branch on method. For free latent factors with group-level FE, use `method = "cfe"` with the `r` argument set explicitly (e.g., `r=2`). + +### Multiple groupings, nesting check + +`group.fe = c("state", "region")` absorbs each as an additive simple FE (multi-column requires explicit `cl`). Each grouping column must be constant within `index[1]`; fect hard-errors at fit time with the offending units listed if not. (The legacy `index = c("unit", "time", "extra")` form does *not* enforce this check because it has historically also supported cell-level interactions like `region_time` that vary within unit by design. See [Chapter @sec-cfe] for the legacy CFE syntax.) + +### Manual aggregation: when it gives the same answer, when it doesn't + +A common workaround is to pre-aggregate to the (group, time) level: + +```{r fect-group-fe-aggregate, eval = TRUE, message = FALSE, warning = FALSE, results = 'hide'} +df_state <- aggregate(cbind(Y, D) ~ state + time, data = df_county, FUN = mean) +fit_agg <- fect(Y ~ D, data = df_state, index = c("state", "time"), + force = "two-way", + se = TRUE, nboots = 200, parallel = FALSE) +``` + +```{r fect-group-fe-aggregate-print, eval = TRUE} +c(group.fe = unname(fit_gfe$att.avg), + aggregate = unname(fit_agg$att.avg)) +``` + +On a balanced panel with no individual-level covariates, the two estimates coincide up to EM tolerance. The equivalence **breaks down** when: + +- **Groups are unbalanced.** `group.fe` runs OLS on individual rows: a state with 25 counties contributes 25 rows per period and dominates the fit. If treatment effects vary across treated states, `group.fe` returns a *county-weighted* ATT (bigger states dominate); `aggregate` returns a *state-weighted* ATT. Neither is wrong --- they target different estimands. For a *unit-equally-weighted* average on an unbalanced panel, pass explicit weights via the `W` argument. +- **Individual-level covariates $X_{it}$ vary within group-time.** Aggregation collapses $X$ to the cell mean and loses the variation that identifies $\beta$; `group.fe` keeps it. + +`group.fe` is also preferred for residual df from the individual rows, or simply to skip the aggregation step. + +::: {.callout-tip appearance="simple"} +The older syntax `index = c("unit", "time", "extra1", ...)` does the same thing under the hood; `group.fe` is just easier to spot when reading code. New code should prefer `group.fe`. +::: + ## Additional notes 1. By default, the program will drop the units that have no larger than 5 observations under control, which is the reason why sometimes there are less available units in the placebo test or carryover test than in the original estimation. We can specify a preferred criterion in the option `min.T0` (default to 5). As a rule of thumb for the IFE estimator, the minimum number of observations under control for a unit should be larger than the specified number of factor `r`. diff --git a/vignettes/03-estimands.Rmd b/vignettes/03-estimands.Rmd index c1c6e286..37a1d686 100644 --- a/vignettes/03-estimands.Rmd +++ b/vignettes/03-estimands.Rmd @@ -1,21 +1,26 @@ # Alternative Estimands {#sec-estimands} -The default output of `fect()` is the per-event-time average treatment effect on the treated (ATT). This chapter introduces the unified post-hoc estimand interface in v2.4.0. It comprises a typed dispatcher, `estimand()`, which computes alternative estimands directly from a fitted model, and a low-level accessor, `imputed_outcomes()`, which exposes the cell-level potential-outcome surface for users who want to compose estimands the dispatcher does not ship. +The default output of `fect()` is the per-event-time average treatment effect on the treated (ATT). This chapter introduces the estimand interface added in v2.4.0. It has two functions: `estimand()`, which computes alternative summaries directly from a fitted model, and `imputed_outcomes()`, which returns the cell-level imputed potential outcomes so you can build summaries that `estimand()` does not include. -The dispatcher handles the four common alternative-estimand requests as one-line calls: cumulative ATT, average proportional treatment effect on the treated [APTT, @chen2024logs], log-scale ATT, and the level ATT restricted to a window of event times. Each returns a tidy data frame ready for direct plotting via fect's `esplot()`. Anything beyond those is a few lines of standard data wrangling against the long-form data the accessor returns. +`estimand()` covers four common requests in one line each: cumulative ATT, average proportional treatment effect on the treated [APTT, @chen2024logs], log-scale ATT, and ATT restricted to a window of event times. Each call returns a data frame ready for plotting with fect's `esplot()`. For anything else, `imputed_outcomes()` returns the cell-level data in long format and the rest is standard data manipulation. + +R script used in this chapter can be downloaded [here](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/03-estimands.R). ## Beyond the default ATT -Reach for the dispatcher when you want any of the following: the default per-event-time level ATT in a tidy data frame instead of the legacy matrix shape; the cumulative ATT through each event time, or summed over a fixed window; the average proportional treatment effect on the treated [APTT, @chen2024logs]; the log-scale ATT; or a level ATT restricted to a window of event times --- say, the first five post-treatment periods. +Use `estimand()` when you want any of the following: the per-event-time level ATT as a data frame (instead of the legacy matrix); the cumulative ATT through each event time, or summed over a fixed window; APTT [@chen2024logs]; log-scale ATT; or a level ATT restricted to a window of event times --- say, the first five post-treatment periods. -For estimands the dispatcher does not ship, the accessor returns the cell-level data in long form and aggregation is up to you. +For summaries that `estimand()` does not cover, `imputed_outcomes()` returns the cell-level data in long format and you do the aggregation yourself. ## Setup -The examples below use a small synthetic panel with positive outcomes so that log-scale calculations are well defined. The fit sets `keep.sims = TRUE` so that the per-cell bootstrap counterfactual surface is retained on the fit object. That surface is what the dispatcher needs to recompute non-linear functionals such as APTT and log-scale ATT inside each bootstrap replicate. For the default per-event-time level ATT and for cumulative ATT, the pre-aggregated bootstrap is enough and the default for `keep.sims` is fine. +```{r .common, include = FALSE} +source("_common.R") +``` + +The examples below use a small synthetic panel with positive outcomes so that log-scale calculations are well defined. The fit sets `keep.sims = TRUE` so that the cell-level imputed counterfactuals from each bootstrap replicate are saved on the fit object. APTT and log-scale ATT need these saved values to recompute their non-linear formulas inside each replicate. The level ATT and cumulative ATT use the pre-aggregated bootstrap that fect always keeps, so the default `keep.sims` is fine for those. ```{r setup-estimand, eval = TRUE, message = FALSE, results = 'hide'} -library(fect) library(dplyr) set.seed(1) @@ -24,11 +29,14 @@ df <- expand.grid(id = 1:N, time = 1:TT) treat_start <- sample(c(NA, 8:18), N, replace = TRUE) df$D <- ifelse(is.na(treat_start[df$id]) | df$time < treat_start[df$id], 0, 1) -df$Y <- exp(0.5 + 0.05 * df$time + 0.3 * df$D + rnorm(nrow(df), sd = 0.2)) +## Higher intercept (2.0) and smaller noise (sd = 0.1) keep Y safely +## positive throughout, so the v2.4.2+ cell-drop hard-error in +## log.att / aptt does not fire on benign bootstrap noise. +df$Y <- exp(2.0 + 0.05 * df$time + 0.3 * df$D + rnorm(nrow(df), sd = 0.1)) fit <- fect(Y ~ D, data = df, index = c("id", "time"), method = "fe", force = "two-way", - se = TRUE, nboots = 200, parallel = FALSE, + se = TRUE, nboots = 1000, parallel = FALSE, keep.sims = TRUE) ``` @@ -39,7 +47,7 @@ estimand(fit, "att", "event.time") |> head(8) ``` -Each row is one event time. The columns hold the point estimate, the standard error, the bounds of the confidence interval, the number of treated cells that contributed at that event time, and the variance type used for inference. The numbers match the legacy slot `fit$est.att` to all decimals. The only difference is the tidy shape, which composes naturally with downstream plotting and aggregation tools --- including fect's own `esplot()`: +Each row is one event time. The columns hold the point estimate, the standard error, the bounds of the confidence interval, the number of treated cells that contributed at that event time, and the variance type used for inference. The numbers match the legacy `fit$est.att` exactly. The only difference is the data-frame format, which works directly with downstream plotting and aggregation tools --- including fect's own `esplot()`: ```{r plot-att-event-time, eval = TRUE, fig.width = 6, fig.height = 4.5} est <- estimand(fit, "att", "event.time") @@ -56,7 +64,7 @@ estimand(fit, "att.cumu", "event.time") |> head(8) ``` -The cumulative ATT through each event time. Each row reports the running sum of the per-period average effect, computed cell-by-cell per the canonical formula. This call replaces the legacy `effect()` function and produces identical numbers. +The cumulative ATT through each event time. Each row reports the running sum of the per-period average effect, computed cell by cell. This call replaces the legacy `effect()` function and produces identical numbers. ```{r plot-cumu-event-time, eval = TRUE, fig.width = 6, fig.height = 4.5} cumu <- estimand(fit, "att.cumu", "event.time") @@ -88,7 +96,7 @@ $$ \text{APTT}_t \;=\; \frac{\mathbb{E}[\,Y - \widehat{Y}(0) \mid D = 1, t\,]}{\mathbb{E}[\,\widehat{Y}(0) \mid D = 1, t\,]}. $$ -Inside the bootstrap loop, both the numerator and the denominator are recomputed at each replicate and the ratio is taken inside the replicate. The bootstrap distribution of the estimand is therefore a distribution of ratios, not a ratio of distributions of means. Computing this requires the per-cell counterfactual surface, which is why APTT needs `keep.sims = TRUE` at fit time. +Inside each bootstrap replicate, both the numerator and the denominator are recomputed and then divided. The bootstrap distribution is therefore a distribution of ratios, not a ratio of two distributions of means. This requires the cell-level imputed counterfactuals, which is why APTT needs `keep.sims = TRUE` at fit time. ```{r plot-aptt-event-time, eval = TRUE, fig.width = 6, fig.height = 4.5} aptt <- estimand(fit, "aptt", "event.time") @@ -106,7 +114,9 @@ estimand(fit, "log.att", "event.time") |> head(8) ``` -The mean log-scale treatment effect: at each event time, the average over treated cells of $\log Y_{it} - \log \widehat{Y}_{it}(0)$. Cells where either the observed outcome or the imputed counterfactual is non-positive are dropped from the aggregation, since the logarithm is undefined there. A single warning per call reports how many cells were excluded. +The mean log-scale treatment effect: at each event time, the average over treated cells of $\log Y_{it} - \log \widehat{Y}_{it}(0)$. Cells where either the observed outcome or the imputed counterfactual is non-positive are dropped from the point estimate, since the logarithm is undefined there. + +When a cell used in the point estimate has $\widehat{Y}_{it}(0)_b \le 0$ in more than 5% of bootstrap replicates, `estimand("log.att", ...)` errors with guidance on what to do (filter the unstable cells, transform the outcome, or use a different estimand). The example data above uses an exponential-link outcome with an intercept high enough that no cell's bootstrap distribution crosses zero. ```{r plot-log-att-event-time, eval = TRUE, fig.width = 6, fig.height = 4.5} log_att <- estimand(fit, "log.att", "event.time") @@ -117,33 +127,127 @@ esplot(log_att, Period = "event.time", ylab = "Mean log(Y) − log(Y0)") ``` +## Placebo tests + +Starting in v2.4.2, `estimand()` takes a `test = c("none", "placebo", "carryover")` argument that lets you compute placebo and carryover versions of any alternative estimand, not just the default `att.placebo` / `att.carryover` scalars (see issue #131). The placebo case requires a fit produced with `placeboTest = TRUE` and a placebo period. + +```{r setup-placebo, eval = TRUE, message = FALSE, results = 'hide'} +## Re-fit with placeboTest = TRUE so that estimand() can recompute +## APTT / log-ATT at the placebo cells. +fit_placebo <- fect(Y ~ D, data = df, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, nboots = 200, parallel = FALSE, + keep.sims = TRUE, + placeboTest = TRUE, placebo.period = c(-2, 0)) +``` + +The placebo APTT series should be statistically indistinguishable from zero across the placebo window if the parallel-counterfactual assumption holds; non-zero placebo estimates are evidence against identification. + +```{r plot-aptt-placebo, eval = TRUE, fig.width = 6, fig.height = 4.5} +aptt_placebo <- estimand(fit_placebo, "aptt", "event.time", + test = "placebo") +esplot(aptt_placebo, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + Count = "n_cells", + main = "APTT placebo (pre-treatment)", + ylab = "Average Proportional TE on the Treated") +``` + +The call gives a warning that BCa confidence intervals with `nboots = 200` may be noisy at the endpoints. This is a caution, not an error. BCa uses the 2.5% and 97.5% quantiles of the bootstrap distribution to form the CI, and these tail quantiles can vary with only 200 bootstrap runs. Efron (1987) and DiCiccio and Efron (1996) recommend at least 1000 runs for publication-quality tail CIs. The point estimate and standard error are not affected by `nboots`. This example uses 200 to keep the chapter fast. For more stable CIs in your own analysis, refit with `fect(..., nboots = 1000)`. + +The same logic carries over to log-scale ATT under placebo: + +```{r plot-log-att-placebo, eval = TRUE, fig.width = 6, fig.height = 4.5} +log_att_placebo <- estimand(fit_placebo, "log.att", "event.time", + test = "placebo") +esplot(log_att_placebo, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + Count = "n_cells", + main = "Log-ATT placebo (pre-treatment)", + ylab = "Mean log(Y) − log(Y0)") +``` + +## Carryover tests + +The carryover case requires `carryoverTest = TRUE` and a panel with treatment reversals. The carryover series uses cells in `fit$carryover.period`---the early post-reversal window where, if the treatment effect dissipates immediately, estimates should be zero. Non-zero carryover estimates suggest the effect persists past treatment removal. We first build a panel with treatment reversals (each treated unit's spell ends after a uniformly-drawn 5--10 periods) and visualize the on/off pattern with `panelview()`: + +```{r setup-carryover, eval = TRUE, message = FALSE, results = 'hide'} +## Build a panel with treatment reversals for the carryover demo. +set.seed(2) +df_rev <- df +treat_end <- pmin(treat_start[df_rev$id] + sample(5:10, N, replace = TRUE), + TT + 1L) +df_rev$D <- ifelse(is.na(treat_start[df_rev$id]) | + df_rev$time < treat_start[df_rev$id] | + df_rev$time >= treat_end[df_rev$id], + 0, 1) +df_rev$Y <- exp(2.0 + 0.05 * df_rev$time + 0.3 * df_rev$D + + rnorm(nrow(df_rev), sd = 0.1)) +``` + +```{r panelview-carryover, eval = TRUE, fig.width = 7, fig.height = 4.5} +panelView::panelview(Y ~ D, data = df_rev, index = c("id", "time"), + by.timing = TRUE, axis.lab = "time", + main = "Treatment-reversal panel for carryover demo") +``` + +```{r fit-carryover, eval = TRUE, message = FALSE, results = 'hide'} +fit_carry <- fect(Y ~ D, data = df_rev, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, nboots = 1000, parallel = FALSE, + keep.sims = TRUE, + carryoverTest = TRUE, carryover.period = c(1, 2)) +``` + +```{r plot-aptt-carryover, eval = TRUE, fig.width = 6, fig.height = 4.5} +aptt_carry <- estimand(fit_carry, "aptt", "event.time", + test = "carryover") +esplot(aptt_carry, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + Count = "n_cells", + main = "APTT carryover (post-reversal)", + ylab = "Average Proportional TE on the Treated") +``` + +```{r plot-log-att-carryover, eval = TRUE, fig.width = 6, fig.height = 4.5} +log_att_carry <- estimand(fit_carry, "log.att", "event.time", + test = "carryover") +esplot(log_att_carry, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + Count = "n_cells", + main = "Log-ATT carryover (post-reversal)", + ylab = "Mean log(Y) − log(Y0)") +``` + +`type = "att.cumu"` is rejected with a clear error when `test != "none"`. Cumulative ATT is defined relative to treatment onset, so it has no meaning at placebo or post-reversal cells. + ## Window-restricted ATT -Pass a window argument to focus on a subset of event times. The dispatcher reads it as a filter on the underlying cell set --- keep cells whose event time falls inside the closed interval. +Pass a `window` argument to focus on a subset of event times. The function keeps cells whose event time falls inside the closed interval and computes the requested estimand over them. ```{r est-window-overall, eval = TRUE} estimand(fit, "att", "overall", window = c(1, 5)) ``` -The result is a single overall ATT averaged over treated cells with event time between one and five. This is the right call when the question is "what is the average ATT for the first five post-treatment years?" and a per-event-time series is not needed. Because the answer is one scalar with one confidence interval, no series plot is appropriate; if multiple windows are of interest, build a small data frame of `(window_label, estimate, ci.lo, ci.hi)` and pass it to `esplot()` with `Period = "window_label"`. +The result is a single overall ATT averaged over treated cells with event time between one and five. Use this when the question is "what is the average ATT for the first five post-treatment years?" and you do not need a per-event-time series. The answer is one number with one confidence interval, so a series plot is not relevant; if you want to compare multiple windows, build a small data frame of `(window_label, estimate, ci.lo, ci.hi)` and pass it to `esplot()` with `Period = "window_label"`. ## Custom estimands -If the functional you need is not on the dispatcher's list, the underlying long-form data is one call away. +If the summary you need is not one of the four built-in types, you can compute it yourself from the cell-level data: ```{r imp-out-glance, eval = TRUE} po <- imputed_outcomes(fit) head(po) ``` -Each row is one treated cell. The columns hold the panel coordinates, the observed outcome, the imputed counterfactual, the cell-level score (the cell's contribution to the ATT estimator), and the aggregation weight. Setting `replicates = TRUE` expands the data by bootstrap replicate, one row per cell per replicate. +Each row is one treated cell. The columns are the unit and time coordinates, the observed outcome, the imputed counterfactual, the cell-level effect (the cell's contribution to the ATT estimator), and the aggregation weight. Setting `replicates = TRUE` expands the data so there is one row per cell per bootstrap replicate. ```{r imp-out-rep, eval = TRUE} po_rep <- imputed_outcomes(fit, replicates = TRUE) nrow(po_rep) == nrow(po) * 200 # one row per (cell, replicate) ``` -A custom example: the per-event-time standard deviation of the cell-level treatment effect, a simple heterogeneity diagnostic. +An example: the per-event-time standard deviation of the cell-level treatment effect, a simple heterogeneity diagnostic. ```{r custom-estimand, eval = TRUE} po |> @@ -154,13 +258,13 @@ po |> head(8) ``` -For a custom functional with bootstrap confidence intervals, group the replicate-expanded data by event time and replicate, compute the functional inside each group, then take the appropriate quantiles across replicates. The accessor does not block any composition. ggplot2 is the most flexible path for custom plots; the tidy schema keeps the plot code as short as the aggregation code. +To get bootstrap confidence intervals for a custom summary, group the replicate-expanded data by event time and replicate, compute the summary inside each group, then take the appropriate quantiles across replicates. ggplot2 is the most flexible option for plotting; the data-frame format keeps the plot code as short as the aggregation code. ## Save bootstrap runs -Setting `keep.sims = TRUE` at fit time saves the full per-cell bootstrap counterfactual surface on the fit object --- a three-dimensional array of dimension $T \times N \times \text{nboots}$. Some estimands need it, others do not. +Setting `keep.sims = TRUE` at fit time saves the cell-level imputed counterfactuals from every bootstrap replicate on the fit object --- a three-dimensional array of dimension $T \times N \times \text{nboots}$. Some estimands need it, others do not. -The level ATT and the cumulative ATT (over either the event-time axis or an overall window) work without it because they read the pre-aggregated bootstrap that fect always retains. The other shipped types --- APTT, log-scale ATT, and any path that filters cells or groups by something other than event time --- recompute aggregations over the per-cell surface and therefore need the saved runs. +The level ATT and the cumulative ATT (over either the event-time axis or an overall window) work without it, because they read the pre-aggregated bootstrap that fect always keeps. The other types --- APTT, log-scale ATT, and any call that filters cells or groups by something other than event time --- recompute their aggregations over the cell-level array and therefore need the saved runs. A back-of-envelope memory cost: @@ -172,7 +276,7 @@ A back-of-envelope memory cost: | 50,000 | 500 | 200 MB | | 200,000 | 500 | 800 MB | -If you fit without saving the bootstrap surface and then call an estimand that needs it, the dispatcher errors with a clear pointer back to the option. +If you fit without `keep.sims = TRUE` and then call an estimand that needs it, the function errors with a message pointing back to the option. ```{r keep-sims-error, eval = FALSE} # No bootstrap/jackknife results available. Choose keep.sims = TRUE in fect(). @@ -182,17 +286,20 @@ If you fit without saving the bootstrap surface and then call an estimand that n Parametric bootstrap (`vartype = "parametric"`) is one of fect's fit-time variance options alongside `"bootstrap"` (the default) and -`"jackknife"`. The parametric path resamples residuals from a fitted -factor model rather than resampling units; it is restricted to -`time.component.from = "nevertreated"` (gates A/B/C, see -@sec-cfe). - -The unified estimand API treats parametric replicates the same as -bootstrap or jackknife replicates: they live in `fit$eff.boot` and -all four `type` values consume them through the same code path. The -only addition in v2.4.1 is that `estimand()`'s `vartype` argument now -accepts `"parametric"` explicitly, so callers can name the method -they expect. +`"jackknife"`. The parametric option resamples residuals from a +fitted factor model rather than resampling units; it requires +`time.component.from = "nevertreated"` (see +[Section @sec-parametric-regimes]). + +`estimand()` treats parametric replicates the same as bootstrap or +jackknife replicates: they are stored in `fit$eff.boot` and all four +`type` values use them through the same code. In v2.4.1, the +`vartype` argument of `estimand()` accepts `"parametric"` explicitly +so callers can name the method they expect. + +For details on how `vartype`, `ci.method`, and the parametric `para.error` +sub-option combine to form the bootstrap distribution, see +[Chapter @sec-inference]. ```{r parametric-att, eval = FALSE} fit_para <- fect(Y ~ D, data = sim_linear, index = c("id", "time"), @@ -212,23 +319,23 @@ head(est) ``` The `vartype` column reports `"parametric"` --- the method actually -used at fit time --- regardless of what the user passes as the -`vartype` argument. The argument is informational; it does not -re-aggregate replicates. The estimand output is byte-identical to -`fit_para$est.att` for the per-event-time path. - -For non-fast paths (`"att.cumu"`, `"aptt"`, `"log.att"`, and -`"att" + "overall"`), `estimand()` aggregates over `fit$eff.boot` -quantiles. Under parametric the simulated distribution is centered -on the parametric DGP's mean rather than on the deterministic point; -quantile-based confidence intervals therefore reflect the parametric -sampling distribution, not a reflection around the deterministic -point. This matches how `fit$est.att` reports SE/CI under parametric -and is consistent with the slot contract. +used at fit time --- regardless of what you pass as the `vartype` +argument. The argument is informational; it does not re-aggregate +replicates. The output matches `fit_para$est.att` exactly for the +per-event-time path. + +For the other types (`"att.cumu"`, `"aptt"`, `"log.att"`, and +`"att"` with `by = "overall"`), `estimand()` aggregates quantiles +over `fit$eff.boot`. Under parametric, the simulated distribution is +centered on the parametric DGP's mean rather than on the point +estimate, so quantile-based confidence intervals reflect the +parametric sampling distribution rather than a reflection around the +point estimate. This matches what `fit$est.att` reports under +parametric. ## Migration -The legacy functions `effect()` and `att.cumu()` continue to work byte-identically and now emit a one-time-per-session deprecation message pointing here. The direct migration table: +The legacy functions `effect()` and `att.cumu()` still work and produce identical results, but now emit a one-time-per-session deprecation message pointing here. Direct replacements: | Today | Replacement | | --- | --- | @@ -236,4 +343,4 @@ The legacy functions `effect()` and `att.cumu()` continue to work byte-identical | `effect(fit, cumu = FALSE)` | `estimand(fit, "att", "event.time")` | | `att.cumu(fit, period = c(L, R))` | `estimand(fit, "att.cumu", "overall", window = c(L, R))` | -Outputs from the dispatcher and the legacy functions match to all decimals, asserted by package tests. The user-facing difference is purely the tidy shape. +Outputs from `estimand()` and the legacy functions match to all decimals (verified by package tests). The only user-facing difference is that `estimand()` returns a data frame instead of the legacy matrix. diff --git a/vignettes/04-ife-mc.Rmd b/vignettes/04-ife-mc.Rmd index 8d67887f..68eea70e 100644 --- a/vignettes/04-ife-mc.Rmd +++ b/vignettes/04-ife-mc.Rmd @@ -9,7 +9,7 @@ set.seed(1234) data(simdata) ``` -When the parallel trends assumption is violated due to latent common factors with heterogeneous loadings, the FE estimator from [Chapter @sec-fect] is biased. This chapter introduces two methods that account for such latent factors: the **interactive fixed effects** (IFE) method, which explicitly models unit-specific factor loadings, and the **matrix completion** (MC) method, which uses nuclear-norm regularization to recover the low-rank structure of the untreated potential outcomes. The [R script for this chapter](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/03-ife-mc.R) is available for download. +When the parallel trends assumption is violated due to latent common factors with heterogeneous loadings, the FE estimator from [Chapter @sec-fect] is biased. This chapter introduces two methods that account for such latent factors: the **interactive fixed effects** (IFE) method, which explicitly models unit-specific factor loadings, and the **matrix completion** (MC) method, which uses nuclear-norm regularization to recover the low-rank structure of the untreated potential outcomes. R script used in this chapter can be downloaded [here](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/04-ife-mc.R). We use `simdata`, which includes two latent factors ($r = 2$). The FE estimator is biased on this dataset, while IFE and MC recover the correct ATT. @@ -38,7 +38,7 @@ panelview(Y ~ D, data = simdata, index = c("id", "time"), In addition to FEct, **fect** supports the interactive fixed effects counterfactual (IFEct) method proposed by @Gobillon2016 and @Xu2017 and the matrix completion (MC) method proposed by @Athey2021---`method = "ife"` and `method = "mc"`, respectively. The EM algorithm is used to impute the counterfactuals of treated observations. -For the IFE approach, we need to specify the number of factors using option `r`. By default, the algorithm will select an optimal hyper-parameter via a built-in cross-validation procedure (see the Cross-validation section below). +For the IFE approach, we need to specify the number of factors using option `r`. By default, the algorithm will select an optimal hyper-parameter via a built-in cross-validation procedure (see the **Cross-validation** section below). We specify an interval of candidate number of unobserved factors in option `r` like `r=c(0,5)`. When cross-validation is switched off, the first element in `r` will be set as the number of factors. Below we use the MSPE criterion and search the number of factors from 0 to 5. @@ -73,7 +73,7 @@ The companion plot type `type = "loading.overlap"` visualizes whether treated-un plot(out.ife, type = "loading.overlap") ``` -The treated loadings extend well beyond the controls' convex hull, which is **expected for this dataset and consistent with the DGP**. `simdata` is built for the DID/TWFE regime: 200 units total, but only 50 are pure controls --- the remaining 150 receive treatment at some point, with reversals allowed. With three times more treated than control units in the panel, treated factor loadings naturally span a wider range than the controls' joint distribution. For the default `time.component.from = "notyettreated"` regime, this non-overlap is less concerning because factors are estimated from pre-treatment observations of *all* units (treated and control), not from the controls alone. The diagnostic is informative but not actionable here. +The treated loadings extend well beyond the controls' convex hull, which is expected for this dataset and consistent with the DGP. `simdata` is built for the DID/TWFE regime: 200 units total, but only 50 are pure controls --- the remaining 150 receive treatment at some point, with reversals allowed. With three times more treated than control units in the panel, treated factor loadings naturally span a wider range than the controls' joint distribution. For the default `time.component.from = "notyettreated"` regime, this non-overlap is less concerning because factors are estimated from pre-treatment observations of *all* units (treated and control), not from the controls alone. The diagnostic is informative but not actionable here. ::: {.callout-note appearance="simple"} @@ -227,15 +227,15 @@ Below these thresholds, the CV runs serially even with `parallel = TRUE`. To for #### What runs in parallel -The unit of parallel work is the (rank, fold) pair (or (lambda, fold) for MC), dispatched flat across workers via `future_lapply`. This gives near-linear speedup up to the number of total tasks: e.g., with `r=c(0,5)` and `k=20`, there are 120 tasks per CV invocation. The `"loo"` method (and the legacy `"treated_units"` value) are always sequential, because their per-fold computations depend on rank-specific quantities that cannot be batched. +Parallel work is organized over each (rank, fold) pair, or each (lambda, fold) pair for MC. These tasks are distributed to workers using `future_lapply`. This can lead to large speed gains when there are many tasks. For example, with `r=c(0,5)` and `k=20`, each CV run has 120 tasks. The `"loo"` method, including the older `"treated_units"` option, always runs sequentially because each fold depends on results computed for a given rank. -#### MC-specific note: `break_check` short-circuit +#### MC-specific note: early stop -For MC cross-validation in serial mode, the lambda search short-circuits via the `break_check` rule once MSPE stops improving. In parallel mode, **all candidate lambdas are computed**: the search is dispatched up-front, so there is no opportunity to terminate early. On well-conditioned problems where the optimal lambda is in the first few values, parallel mode performs slightly more work than serial; the wall-time is still much lower in absolute terms when many CV folds are dispatched together. In pathological cases where the search would have terminated early, serial mode (`parallel = FALSE`) is the better choice. +For MC cross-validation in serial mode, the lambda search can stop early using the `break_check` rule once MSPE stops improving. In parallel mode, all candidate lambdas are evaluated because tasks are sent out at the start. As a result, when the best lambda is among the first few values, parallel mode may do more total work than serial mode. It can still be faster in wall-clock time because many folds run at once. When early stopping would apply, `parallel = FALSE` may be preferable. #### CV vs. bootstrap, independent control -The single `parallel` argument controls both CV and bootstrap parallelism. To enable one but not the other — for example, to keep the bootstrap serial during a debugging session while keeping CV parallel — use the string forms `parallel = "cv"` or `parallel = "boot"`. See the parallel-computing callout in [Chapter @sec-fect] for the full table. +The `parallel` argument controls parallel computing for both CV and the bootstrap. To enable one but not the other, use `parallel = "cv"` or `parallel = "boot"`. For example, during debugging, you may keep the bootstrap serial while running CV in parallel. See the parallel-computing callout in [Chapter @sec-fect] for the full table. ------------------------------------------------------------------------ @@ -247,11 +247,14 @@ We provide three types of diagnostic tests: (1) a placebo test, (2) a joint test We provide a placebo test for a settled model---hence, cross-validation is not allowed---by setting `placeboTest = TRUE`. We specify a range of pre-treatment periods as "placebo periods" in option `placebo.period` to remove observations in the specified range for model fitting, and then test whether the estimated ATT in this range is significantly different from zero. Below, we set `c(-2, 0)` as the placebo periods. +We set `max.iteration = 20000` to allow full convergence of the IFE model with `tol = 1e-5`. + ```{r placebo_ife, eval = TRUE, cache = TRUE, message = FALSE, results='hide'} out.ife.p <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), force = "two-way", method = "ife", r = 2, CV = 0, parallel = TRUE, cores = 16, se = TRUE, - nboots = 200, placeboTest = TRUE, placebo.period = c(-2, 0)) + nboots = 200, placeboTest = TRUE, placebo.period = c(-2, 0), + max.iteration = 20000) out.mc.p <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), force = "two-way", method = "mc", lambda = out.mc$lambda.cv, @@ -259,6 +262,8 @@ out.mc.p <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), nboots = 200, placeboTest = TRUE, placebo.period = c(-2, 0)) ``` +The IFE call sets `max.iteration = 20000`. Placebo and carryover tests drop a window of cells from the IFE estimation, which slows EM convergence below the default cap of 5000 iterations. With the smaller effective sample, EM here converges around iteration 8500. The same argument is used in the carryover and `carryover.rm` calls below. The MC fits do not need it, since matrix completion does not run the same EM loop. + The placebo test conducts two types of tests: **t test.** If t-test p-value is smaller than a pre-specified threshold (e.g. 5%), we reject the null of no-differences. Hence, the placebo test is deemed failed. @@ -334,7 +339,8 @@ Below, we set `carryover.period = c(1, 3)`. As we deduct the treatment effect fr out.ife.c <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), force = "two-way", method = "ife", r = 2, CV = 0, parallel = TRUE, cores = 16, se = TRUE, - nboots = 200, carryoverTest = TRUE, carryover.period = c(1, 3)) + nboots = 200, carryoverTest = TRUE, carryover.period = c(1, 3), + max.iteration = 20000) out.mc.c <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), force = "two-way", method = "mc", lambda = out.mc$lambda.cv, @@ -363,7 +369,8 @@ Using real-world data, researchers will likely find that carryover effects exist out.ife.rm.test <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), force = "two-way", method = "ife", r = 2, CV = 0, parallel = TRUE, cores = 16, se = TRUE, carryover.rm = 3, - nboots = 200, carryoverTest = TRUE, carryover.period = c(1, 3))# remove three periods + nboots = 200, carryoverTest = TRUE, carryover.period = c(1, 3), + max.iteration = 20000)# remove three periods ``` ```{r carryover_rm, eval = TRUE, fig.width = 6, fig.height = 4.5} diff --git a/vignettes/05-cfe.Rmd b/vignettes/05-cfe.Rmd index b1cc5263..cd046320 100644 --- a/vignettes/05-cfe.Rmd +++ b/vignettes/05-cfe.Rmd @@ -1,6 +1,6 @@ # Complex Fixed Effects {#sec-cfe} -The **Complex Fixed Effects (CFE)** estimator extends the standard two-way fixed effects counterfactual by incorporating additional model components: extra additive fixed effects, time-invariant covariates with time-varying coefficients, unit-specific loadings on known time trends, and interactive fixed effects (latent factors). Each component helps to relax specific assumptions about the data-generating process, and this chapter introduces them one at a time. R script used in this chapter can be downloaded [here](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/04-cfe.R). +The **Complex Fixed Effects (CFE)** estimator extends the standard two-way fixed effects counterfactual by incorporating additional model components: extra additive fixed effects, time-invariant covariates with time-varying coefficients, unit-specific loadings on known time trends, and interactive fixed effects (latent factors). Each component helps to relax specific assumptions about the data-generating process, and this chapter introduces them one at a time. R script used in this chapter can be downloaded [here](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/05-cfe.R). In [Chapter @sec-ife-mc], we introduced factor-based methods (IFE and MC) that model latent common factors. CFE generalizes this framework by allowing researchers to incorporate additional observed structure alongside latent factors. @@ -138,8 +138,6 @@ The placebo test now passes (high p-value), confirming that the region×time fix In the `index` argument, elements beyond the first two (unit, time) are treated as additional fixed-effect grouping variables. You can include multiple additional groupings: `index = c("id", "time", "region_time", "sector_time")`. ::: ------------------------------------------------------------------------- - ## Time-invariant covariates with time-varying coefficients When time-invariant unit characteristics $Z_i$ (e.g., baseline GDP, initial population) have effects that change over time, a simple additive control is insufficient. The CFE model allows $Z_i'\gamma_{g(t)}$, where $\gamma$ varies by time group, capturing the time-varying nature of these effects. @@ -323,23 +321,23 @@ out.cfe.z.only <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), method = "cfe", force = "two-way", Z = "L1", gamma = "gamma_t", - se = FALSE) + se = FALSE, max.iteration = 20000) # Model 3: CFE with Z = L1 + 1 factor out.cfe.z.f1 <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), method = "cfe", force = "two-way", Z = "L1", gamma = "gamma_t", - r = 1, se = FALSE) + r = 1, se = FALSE, max.iteration = 20000) # Model 4: IFE with 2 factors out.ife.r2 <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), method = "ife", force = "two-way", - r = 2, se = FALSE) + r = 2, se = FALSE, max.iteration = 20000) ``` -```{r cfe-45-mspe, eval = TRUE, cache = TRUE} +```{r cfe-45-mspe, eval = TRUE, cache = FALSE} mspe.out <- fect_mspe(list(FE = out.fe, CFE_Z = out.cfe.z.only, CFE_Z_F1 = out.cfe.z.f1, diff --git a/vignettes/08-gsynth.Rmd b/vignettes/06-gsynth.Rmd similarity index 91% rename from vignettes/08-gsynth.Rmd rename to vignettes/06-gsynth.Rmd index a332440d..53b59b70 100644 --- a/vignettes/08-gsynth.Rmd +++ b/vignettes/06-gsynth.Rmd @@ -4,7 +4,7 @@ source("_common.R") ``` -This chapter demonstrates the generalized synthetic control method, or Gsynth, proposed in @Xu2017 \[Paper\]. +This chapter demonstrates the generalized synthetic control method, or Gsynth, proposed in @Xu2017 \[Paper\]. R script used in this chapter can be downloaded [here](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/06-gsynth.R). ::: {.callout-tip appearance="simple"} The **gsynth** package as a standalone package still exists, but algorithmically is a wrapper of the **fect** package. Click [here](https://yiqingxu.org/packages/gsynth/) if you want to use the old syntax. @@ -16,9 +16,9 @@ The **gsynth** package as a standalone package still exists, but algorithmically Two new defaults are strongly recommended for the Synth setting: -**1. Use rolling-window CV (now the default) for rank selection.** Gsynth applications typically span macro panels with persistent residual shocks. Pre-v2.3.0 block CV suffered from AR leakage across the train/test boundary, systematically over-selecting `r` (often pegging at `r.max`). Rolling CV (`cv.method = "rolling"`) closes the future-side leakage by construction. On a Xu (2017) DGP with $r_{\text{true}} = 2$ and AR(1) $\rho = 0.8$ (K = 200 reps), rolling CV recovers the truth in 56% vs block CV's 15% (mean `r.cv` 1.58 vs 3.34). Use it whenever residuals are temporally correlated (post-fit residual AR(1) above ~0.4); under approximately i.i.d. residuals it agrees closely with block CV (`cv.method = "block"`, also available). +**1. Use rolling-window CV for rank selection.** This is now the default. Gsynth applications often use macro panels, where residual shocks are persistent over time. Before v2.3.0, block CV could leak information across the train/test boundary and over-select `r`, often choosing `r.max`. Rolling CV (`cv.method = "rolling"`) prevents this future-side leakage by design. -**2. Bound treated loadings via `loading.bound = "simplex"`.** This constrains each treated unit's factor loading to a non-negative convex combination of control loadings, recovering the synthetic-control intuition that the imputed counterfactual should sit *inside* the support of the donor pool. The default `loading.bound = "none"` preserves the original Xu (2017) behavior --- an unconstrained least-squares projection. Activating the simplex bound is opt-in but generally preferable, especially when the donor pool is small or convex-hull overlap is uncertain. See the **Bounded factor loadings** section below and the companion `loading.overlap` diagnostic ([Chapter @sec-loading-overlap]). +**2. Bound treated loadings with `loading.bound = "simplex"`.** This restricts each treated unit's factor loading to a non-negative weighted average of the control loadings. In other words, the imputed counterfactual is kept inside the support of the donor pool, matching the usual synthetic-control intuition. The default, `loading.bound = "none"`, preserves the original Xu (2017) behavior: an unconstrained least-squares projection. The simplex bound is opt-in, but it is generally preferable, especially when the donor pool is small or overlap with the donor pool is uncertain. See the **Bounded factor loadings** section below and the companion `loading.overlap` diagnostic. ::: @@ -28,7 +28,7 @@ Gsynth was originally implemented in the **gsynth** package but has now been ful - Gsynth is particularly suited for the Synth setting, where the number of treated units is small, including scenarios with only one treated unit. By setting `vartype = "parametric"`, we can use a two-stage parametric bootstrapping procedure to produce uncertainty estimates. In contrast, other methods rely on large samples, particularly a large number of treated units, to obtain reliable standard errors and confidence intervals using `"bootstrap"` or `"jackknife"`. - Compared with IFEct (`method = "ife"`), Gsynth *does not* rely on pre-treatment data from the treated units to estimate time components (e.g., factors). Hence, `time.component.from = "nevertreated"`. This approach speeds up computation, improves stability, and is more suitable for predictive inference based on row exchangeability. -Therefore, we recommend setting `method = "gsynth"` in **fect** for the synthetic control setting, where the treatment does not reverse (or is coded accordingly) and the number of treated units is small. The [R script for this chapter](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/07-gsynth.R) is available for download. +Therefore, we recommend setting `method = "gsynth"` in **fect** for the synthetic control setting, where the treatment does not reverse (or is coded accordingly) and the number of treated units is small. ::: {.callout-important appearance="simple"} @@ -156,7 +156,7 @@ out2 <- fect(Y ~ D + X1 + X2, data = sim_gsynth, index = c("id","time"), The legacy values `"all_units"` (now `"block"`) and `"treated_units"` (block masking restricted to treated pre-treatment cells) are still accepted but emit a deprecation message; both will be replaced by the unified `(cv.method, cv.units)` API in v2.4.0. See the [cheatsheet](aa-cheatsheet.html#sec-cheatsheet-cv) for the deprecation plan. -### Rolling-window CV via `cv.method = "rolling"` +### Rolling-window CV Set `cv.method = "rolling"` in the main `fect()` CV dispatcher to use rolling-window CV (the recommended default for serially correlated panels --- see the recommended-changes callout at the top of this chapter for the empirical motivation, and [Chapter @sec-ife-mc] for the design and the side-by-side figure). @@ -276,24 +276,6 @@ In the plot below, the points represent the ATTs by calendar time. The blue curv plot(out,type = "calendar") ``` -Lastly, `type = "equiv"` helps visualize the average pre-treatment residuals with equivalence confidence intervals. - -```{r sim-equiv, cache = FALSE, fig.height=5, fig.width=7} -plot(out, type = "equiv", ylim = c(-5, 5)) -``` - -The floating legend displaying the F-test p-value and Equivalence test p-value can be removed by setting `show.stats = FALSE`. - -```{r sim-equiv-no-stats, cache = FALSE, fig.height=5, fig.width=7} -plot(out, type = "equiv", show.stats = FALSE) -``` - -Alternatively, it can be repositioned by providing coordinates to `stats.pos`. - -```{r sim-equiv-reposition, cache = FALSE, fig.height=5, fig.width=7} -plot(out, type = "equiv", stats.pos = c(-19, 4.5), ylim = c(-5, 5)) -``` - ------------------------------------------------------------------------ @@ -634,13 +616,15 @@ ggplot(df.w, aes(x = unbounded, y = bounded)) + theme(panel.grid.minor = element_blank()) ``` -Three behavioural patterns to look for: +Three patterns are worth checking: + +1. **Many weights near $y = 0$.** Bounded weights are sparse: most (treated, control) pairs receive zero weight, and only a small set of donors receives meaningful weight for each treated unit. This sparsity comes from the *simplex constraint*, not from the regularizer. Non-negative least squares on a probability simplex has an active-set property: at the optimum, many constraints $w_j = 0$ are active, and only a few donors have positive weight. The entropy regularizer pushes weights toward uniform $(1/N_{co})$, so it works against sparsity. With moderate $\gamma$, the constraint dominates; as $\gamma \to 0$, weights converge to uniform. Unbounded weights, by contrast, spread non-zero mass across the donor pool because the pseudo-inverse has no non-negativity constraint and no preference for sparsity. + +2. **Negative unbounded weights become zero.** Points with $x < 0$ sit at $y = 0$, or close to it. The simplex projection cannot use negative weights, so it removes those donors from the counterfactual. This matches the synthetic-control intuition: a counterfactual should not be a negative combination of donors. -1. **Mass concentration near $y = 0$.** Bounded weights are sparse: most (treated, control) pairs get weight zero, with only a handful of donors getting meaningful weight per treated unit. The sparsity comes from the **simplex constraint**, not the regularizer --- non-negative least-squares on a probability simplex has an active-set property: at the optimum, many constraints $w_j = 0$ are active and only a small subset of donors carries positive weight. The entropy regularizer actually pulls weights *toward* uniform $(1/N_{co})$ and so works *against* sparsity; with moderate $\gamma$ the constraint dominates, and as $\gamma \to 0$ weights converge to uniform. Unbounded weights, in contrast, spread non-zero mass across the entire donor pool because the pseudo-inverse has no non-negativity constraint and no preference for sparsity. -2. **Negative unbounded weights collapse to zero.** Points with $x < 0$ all sit at $y = 0$ (or near it). The simplex projection cannot represent negative weights --- it simply removes those donors from the pool. This is exactly the synthetic-control intuition: a counterfactual cannot be a *negative* combination of donors. -3. **Bounded weights cap at one.** Points with $x > 1$ collapse to $y \leq 1$. When pseudo-inverse over-extrapolates a single donor, the simplex caps it; the rest of the row redistributes among other donors. +3. **Bounded weights cannot exceed one.** Points with $x > 1$ move to $y \leq 1$. When the pseudo-inverse puts too much weight on one donor, the simplex caps that weight and redistributes the rest across other donors. -The result is a fundamentally different counterfactual representation. Pseudo-inverse: dense, possibly extrapolating, sometimes counterintuitive. Simplex: sparse, interpolating-only, every weight has a synthetic-control interpretation. +The result is a different counterfactual representation. The pseudo-inverse is dense and can extrapolate. The simplex is sparse, uses interpolation only, and gives each weight a synthetic-control interpretation. #### Reading the comparison @@ -684,19 +668,20 @@ Both approaches share the same estimation regime (never-treated controls only), # Model 1: gsynth (pure IFE, r = 2) out.gsynth.comp <- fect(Y ~ D + X1 + X2, data = sim_gsynth, index = c("id","time"), method = "gsynth", force = "two-way", - r = 2, se = FALSE, CV = FALSE) + r = 2, se = FALSE, CV = FALSE, max.iteration = 20000) # Model 2: CFE + nevertreated with r = 2 only (equivalent to gsynth) out.cfe.nt.comp <- fect(Y ~ D + X1 + X2, data = sim_gsynth, index = c("id","time"), method = "cfe", force = "two-way", time.component.from = "nevertreated", - r = 2, se = FALSE, CV = FALSE) + r = 2, se = FALSE, CV = FALSE, max.iteration = 20000) # Model 3: CFE + nevertreated with r = 2 and linear trend (overspecified) out.cfe.nt.lin <- fect(Y ~ D + X1 + X2, data = sim_gsynth, index = c("id","time"), method = "cfe", force = "two-way", time.component.from = "nevertreated", - Q.type = "linear", r = 2, se = FALSE, CV = FALSE) + Q.type = "linear", r = 2, se = FALSE, CV = FALSE, + max.iteration = 20000) ``` ```{r cfe_nt_mspe, eval=TRUE, cache=TRUE} @@ -709,6 +694,11 @@ print(mspe.comp$summary[, c("Model", "MSPE", "RMSE", "MAD")]) Since `sim_gsynth` follows a pure IFE data generating process with two factors, Models 1 and 2 should produce identical MSPE --- confirming that CFE with `time.component.from = "nevertreated"` and no additional structure is numerically equivalent to gsynth. Model 3, which adds unnecessary linear trends, should produce similar or slightly worse MSPE because the extra parameters add noise without benefit when the true DGP has no unit-specific trends. +## Inference + +The default `vartype` for the gsynth-style regime is `"parametric"` --- a two-stage pseudo-treated bootstrap that targets the conditional variance $V_t = \mathrm{Var}(\widehat{\mathrm{ATT}}_t - \mathrm{ATT}_t \mid \Lambda, F, X, D)$ on small-$N_{\text{tr}}$ panels where the standard nonparametric bootstrap is unreliable. The `para.error` argument (introduced in v2.4.2) chooses how the residual error process is resampled: `"auto"` (default, resolves to `"empirical"` on a fully-observed panel and `"ar"` on a missing-data panel), `"ar"` (the v2.4.1 behavior), `"empirical"`, or `"wild"`. The (`vartype` × `ci.method` × `para.error`) interaction, parametric-bootstrap mechanics, and an empirical coverage study live in [Chapter @sec-inference], which is the natural next read after this chapter. + + ## Additional Notes 1. **Unbalanced Panels**: Running Gsynth within **fect** on unbalanced panels will take significantly more time compared to balanced panels, often by a factor of 100:1 or more. This is because the EM algorithm, which fills in missing values (implemented in C++), requires many more iterations to converge. To reduce run-time, users can remove units or time periods with extensive missing values. Understanding the data structure before running any regressions is always helpful. Note that this approach differs from setting `method = "ife"`, as no pre-treatment data from the treated units is used to impute $\hat{Y}(0)$. diff --git a/vignettes/07-inference.Rmd b/vignettes/07-inference.Rmd new file mode 100644 index 00000000..7070918a --- /dev/null +++ b/vignettes/07-inference.Rmd @@ -0,0 +1,291 @@ +# Inference {#sec-inference} + +```{r .common, include = FALSE} +source("_common.R") +``` + +This chapter explains inference in `fect`. Read it when you need to justify a particular (`vartype`, `ci.method`) choice in a paper, or when you want to understand why log-scale and ratio estimands use `bca` by default. + +The chapter is organized around three choices: + +1. `vartype` --- where the bootstrap distribution comes from: unit-level cluster bootstrap, jackknife, or parametric bootstrap. +2. `ci.method` --- how the CI is built from that distribution: basic, percentile, bc, bca, or normal. +3. `para.error` --- which residual-error model the parametric path uses: auto, ar, empirical, or wild. This option applies only when `vartype = "parametric"` and is ignored when `vartype` is `"bootstrap"` or `"jackknife"`. + +For each combination, `fect` also reports a corresponding $p$-value by test inversion and a recommended minimum number of bootstrap replicates, `nboots`, based on the classic literature. We summarize these choices and report the empirical coverage of each combination on a clean DGP. Below, we use $\hat\theta$ to denote a point estimate. + +## The 3 × 5 inference matrix + +A `fect()` fit with `se = TRUE` stores bootstrap estimates in `fit$eff.boot`, a $T \times N \times B$ array. For `vartype = "jackknife"`, it stores a $T \times (N-1) \times N$ array instead. Two functions use this array: + +- **`fect()`** fills the `fit$est.att` and `fit$est.avg` slots during the original fit. These give per-event-time and overall estimates. The CI method is set by the `ci.method` argument in `fect()`, which accepts two values: `"normal"` (the default; Wald) and `"basic"`. + +- **`estimand()`** is used after fitting. It aggregates `fit$eff.boot` into a one-dimensional bootstrap distribution for the requested estimand: `att`, `att.cumu`, `aptt`, or `log.att`. It then builds a CI using the selected `ci.method`. Five values are accepted: `"normal"`, `"basic"`, `"percentile"`, `"bc"`, and `"bca"`. + +The two paths give byte-identical results where they overlap, namely for `"normal"` and `"basic"` CIs at the overall and per-event-time levels. The additional methods, `"percentile"`, `"bc"`, and `"bca"`, are available only through `estimand()`. This is also where the estimand-specific defaults are defined: `att.cumu → "basic"`, `aptt → "bca"`, and `log.att → "bca"`. + +**vartype** controls the distribution semantics: + +| vartype | construction | distribution centered at | preserves within-unit dependence? | +|---|---|---|---| +| `"bootstrap"` (unit-level) | resample units with replacement, refit per replicate | $\hat\theta$ | yes (whole units stay intact) | +| `"jackknife"` | leave one unit out, refit, repeat for all $N$ units | $\hat\theta$ via Tukey | yes | +| `"parametric"` | simulate errors on `D=0` cells (model selected by `para.error`), refit | $0$ internally; shifted to $\hat\theta$ in `estimand()` | yes (preserved per `para.error` mode) | + +**ci.method** controls how the (post-shift) bootstrap distribution is mapped into a CI. Let $B$ be the bootstrap sample of $\hat\theta$, $q_\alpha$ the $\alpha$-quantile of $B$, $\hat\theta$ the point estimate, $\mathrm{SE} = \mathrm{sd}(B)$, $z_\alpha = \Phi^{-1}(\alpha)$, $\alpha = 0.025$ for a 95% CI: + +| ci.method | CI formula | symmetry around $\hat\theta$ | bias-aware | skew-aware | +|---|---|---|---|---| +| `"normal"` | $\hat\theta \pm z_{1-\alpha} \cdot \mathrm{SE}$ | symmetric | ✗ | ✗ | +| `"basic"` | $[2\hat\theta - q_{1-\alpha},\ 2\hat\theta - q_\alpha]$ | symmetric (reflection) | ✗ | ✗ | +| `"percentile"` | $[q_\alpha,\ q_{1-\alpha}]$ | reflects bootstrap | ✗ | ✗ | +| `"bc"` | bias-shifted percentile, with $z_0 = \Phi^{-1}(P(B < \hat\theta))$ | adapts | ✓ | ✗ | +| `"bca"` | bias + acceleration $a$ from cell-level jackknife | adapts | ✓ | ✓ | + +The default `ci.method` depends on the estimand: `att` → `"normal"`, `att.cumu` → `"basic"`, `aptt` → `"bca"`, and `log.att` → `"bca"`. These defaults follow the meaning of each estimand, not performance on any specific DGP. See the coverage results below for the full comparison. + +**On `"basic"` vs `"percentile"`.** The two rely on different ideas. The `"basic"` interval inverts the pivot $T = \hat\theta - \theta$ and gives $[2\hat\theta - q_{1-\alpha},\ 2\hat\theta - q_\alpha]$. The `"percentile"` interval uses the bootstrap quantiles directly, $[q_\alpha,\ q_{1-\alpha}]$. Davison and Hinkley (1997, §5.2.1) recommend `"basic"` as the default, and this is what `boot::boot.ci(type = "basic")` returns. The `"percentile"` interval requires an additional symmetry condition on the bootstrap distribution to be valid [@hesterberg2014]. When the distribution is symmetric, the two intervals coincide; when it is skewed, `"basic"` is usually more reliable. + +If you want a percentile-style CI in routine use, prefer `"basic"`. It is the standard choice in R via the `boot` package. The raw `"percentile"` option is kept mainly for reproducing older results and for parity with `boot::boot.ci(type = "perc")`. + +## Inferential methods in depth + +### Unit-level (block) bootstrap + +The default is `"bootstrap"`. It resamples whole units with replacement, drawing treated and control units separately. It uses rejection sampling to make sure every period is covered. Each replicate is therefore a cluster bootstrap, with the unit as the cluster. The full model is refit for each replicate. The array `fit$eff.boot[, , b]` stores the per-cell treatment effect estimate from replicate $b$. + +This is the most general option. It captures both unit-level variation, since treated units may have different effects, and within-unit residual variation, since each unit's outcome path has noise. For most applied work, this is the recommended choice. + +**Caveat.** When there are few treated units, for example $N_\mathrm{tr} < 10$, the unit-level bootstrap can become unstable. Some replicates may draw the same treated unit many times, which leaves little between-unit variation. In this setting, use `vartype = "jackknife"`. + +### Leave-one-unit-out jackknife + +For each unit $i \in 1..N$, the model is refit after dropping that unit. The per-cell treatment effect is then recorded. The standard error is computed using the Tukey jackknife formula, $\sqrt{\frac{N-1}{N} \sum_i \left(\widehat{\mathrm{eff}}_i - \overline{\mathrm{eff}}\right)^2}$. The stored array has dimension $T \times (N-1) \times N$, since each leave-one-out fit drops one column. + +Use the jackknife when (i) $N_\mathrm{tr}$ is small enough that the bootstrap is unstable, or (ii) you want a deterministic SE estimate without sampling noise from bootstrap draws. Under regularity conditions, the jackknife SE is asymptotically equivalent to a parametric Wald SE and is often stable in practice. + +**Note:** As of v2.4.2, `estimand()` accepts jackknife fits but allows only `ci.method = "normal"`. The other four CI methods return a clear error. The jackknife gives an SE estimate using the Tukey pseudo-value formula. It does not give exchangeable draws from the sampling distribution of $\hat\theta$. Thus, `"basic"` and `"percentile"` are not appropriate, and `"bc"` and `"bca"` require a bootstrap distribution to compute the bias correction $z_0$. Use `ci.method = "normal"` for the Wald-style interval $\hat\theta \pm z \cdot \mathrm{SE}_\mathrm{jack}$, or refit with `vartype = "bootstrap"` if you need the full set of CI methods. + +### Model-based parametric bootstrap +The `"parametric"` path resamples the residual error process and refits the model for each replicate. On treated cells, it stores `fit$eff.boot[, , b] = Y.boot - Y0_hat_b`. Three residual-error models are available through `para.error`, which applies only when `vartype = "parametric"`: + +| `para.error` | Residual draw | Panel shape | Notes | +|--------------|---------------|-------------|-------| +| `"auto"` (default) | Chosen at fit time | Any | Uses `"empirical"` for a fully observed panel and `"ar"` for a panel with missing cells; `fit$para.error` stores the chosen label | +| `"ar"` | Draws from MVN with AR-vcov estimated from Loop-1 control residuals | Any | The v2.4.1 behavior; works as the fallback | +| `"empirical"` | i.i.d. column resample from main-fit control residuals | Fully observed only | Returns an error if any cell is missing | +| `"wild"` | Unit-level Rademacher sign flips over the empirical residual pool [@liu1988; @mammen1993; @cameron_gelbach_miller2008] | Fully observed only | Preserves the marginal residual distribution and within-unit dependence; returns an error if any cell is missing | + +The parametric path is the default in the gsynth-style setting: `time.component.from = "nevertreated"`, no treatment reversal, and a factor-augmented method. + +**Caveat.** The simulation is run under $H_0$, with no treatment effect added back to treated cells. As a result, `fit$eff.boot` is centered at zero. The legacy `fit$est.avg` output and `get.pvalue()` use this $H_0$ centering to test $H_0: \mathrm{ATT} = 0$. In the current implementation, `estimand()` applies a post-hoc location shift for parametric fits: `att_b <- att_b - mean(att_b) + estimate`. This centers the bootstrap distribution at the point estimate while preserving its spread, since `sd()` is unchanged by a shift. The `"normal"` CI is unchanged by this fix; the other four CI methods now produce correctly centered CIs. + +**Conditional-variance target.** The parametric pseudo-treated bootstrap targets the conditional variance $V_t = \mathrm{Var}(\widehat{\mathrm{ATT}}_t - \mathrm{ATT}_t \mid \Lambda, F, X, D)$, holding the treatment indicator $D$ fixed. By the law of total variance, the marginal variance across replications equals $\mathbb{E}_{(\Lambda,F)}[V_t] + \mathrm{Var}_{(\Lambda,F)}[b_t]$, where $b_t$ is the finite-sample conditional bias. Coverage simulations for the parametric path therefore hold $D$ fixed. Re-randomizing $D$ across replications would add a $\mathrm{Var}_D[b_t]$ term that the bootstrap does not estimate, which would make measured coverage too low. + +### Parametric bootstrap: valid regimes {#sec-parametric-regimes} + +The parametric bootstrap relies on two assumptions: (a) the time components, including factors and loadings, are estimated from a **never-treated** control pool that is independent of the treated units' data; and (b) the control-unit residuals approximate the true error distribution. If either assumption fails, the parametric bootstrap can understate standard errors and produce confidence intervals that are too narrow. + +To prevent users from invoking the parametric bootstrap in settings where these assumptions fail, the package enforces three hard restrictions: + +::: {.callout-important appearance="simple"} +### Three-gate system + +| Gate | Condition | What it blocks | +|---|---|---| +| A | `method %in% c("mc", "both")` + `vartype = "parametric"` | matrix completion + parametric | +| B | treatment reversal present + `vartype = "parametric"` | reversal + parametric | +| C | `time.component.from = "notyettreated"` + `vartype = "parametric"` | notyettreated + parametric | + +In all three cases the package raises an informative error pointing to the valid alternatives. +::: + +Gate C is motivated by both theory and simulation evidence. The `notyettreated` path uses EM imputation to estimate factors from all not-yet-treated observations, including the treated units' pre-period data. This expands the effective factor space by imputing masked treated-post cells, which reduces the observed-cell residuals used by the parametric bootstrap covariance estimator. In a Monte Carlo study with N = 50, T = 20, r = 2 factors, and 500 replications, the blocked `ife + notyettreated + parametric` combination produced 80.6% coverage at nominal 95% coverage, with an SE ratio of about 0.67. By contrast, all tested `nevertreated` paths produced near-nominal coverage, with coverage between 0.93 and 0.96 and an SE ratio of about 1.0. The details of all three gates are documented in `ARCHITECTURE.md`. + +If your current code uses `vartype = "parametric"` with the default `time.component.from = "notyettreated"`, migrate as follows: + +```r +# Before (now raises an error under Gate C): +fect(data, Y = "Y", D = "D", index = c("id", "time"), + method = "ife", se = TRUE, vartype = "parametric") + +# After --- option 1: switch to nevertreated imputation +# (requires that never-treated control units exist in the data) +fect(data, Y = "Y", D = "D", index = c("id", "time"), + method = "ife", time.component.from = "nevertreated", + se = TRUE, vartype = "parametric") + +# After --- option 2: use nonparametric bootstrap (safe default) +fect(data, Y = "Y", D = "D", index = c("id", "time"), + method = "ife", se = TRUE, vartype = "bootstrap") +``` + +Option 1 switches to the gsynth-style estimation regime and keeps parametric bootstrap. This is appropriate when never-treated control units exist and the treatment does not reverse. Option 2 leaves the estimator unchanged and uses cluster-bootstrap, which is appropriate when the number of treated units is moderate to large. See [Chapter @sec-gsynth] for guidance. + +## ci.method choices + +`ci.method` controls how the bootstrap distribution is turned into a confidence interval. It is available in two places. `fect()` offers two options for the CIs stored in `fit$est.att`, `fit$est.avg`, and the placebo, carryover, calendar, cohort, and subgroup slots. `estimand()` offers the full five-option set and works after fitting, using `fit$eff.boot` and `fit$att.avg.unit.boot`. + +Use `fect()` for the standard `att` workflow. Use `estimand()` for alternative estimands, including `att.cumu`, `aptt`, and `log.att`. + +### `fect()` — `ci.method = c("normal", "basic")` + +```r +fect(..., ci.method = "normal") # default; Wald: theta_hat +- z * SE +fect(..., ci.method = "basic") # reflected pivot: 2 * theta_hat - quantile(boot, ...) +``` +The `"basic"` interval is the reflected (pivot) CI of @davison_hinkley1997 §5.2.1. It is the standard "percentile" CI in the literature and is what `boot::boot.ci(type = "basic")` returns in R. The default is `"normal"`. The `est.att` (per-event-time) and `est.avg` (overall) slots returned by `fect()` use the requested method and match `estimand(fit, "att", ci.method)` exactly on the same fit. + +**Parametric fits get a location shift.** When `vartype = "parametric"`, `eff.boot` is centered at $0$ under $H_0$, so the $H_0: \theta = 0$ test is correctly calibrated. For `ci.method = "basic"`, the reflected pivot would otherwise be centered around $2\hat\theta$. To avoid this, `fect()` applies a variance-preserving location shift, `eff.boot.ci <- eff.boot - mean(eff.boot) + theta_hat`, as in `estimand()` (`R/po-estimands.R`). This shift is used only for the CI; the SE and the $H_0$-based $p$-value are unchanged. + +**Jackknife rejects basic.** Using `ci.method = "basic"` with `vartype = "jackknife"` returns an error. Use `ci.method = "normal"` instead, which gives $\hat\theta \pm z \cdot \mathrm{SE}_\mathrm{jack}$, or refit with `vartype = "bootstrap"`. Jackknife pseudo-values are leave-one-out quantities, not exchangeable draws from the sampling distribution [@efron_tibshirani1993 ch11; @davison_hinkley1997 §3.2.1]. + +**nboots warning.** The `"basic"` interval uses the 2.5th and 97.5th order statistics of the bootstrap distribution. These tail quantiles can be unstable when `nboots` is small. `fect()` issues a warning when `ci.method = "basic"` is used with `nboots < 1000`, and recommends refitting with `nboots = 1000` for publication-quality CIs [@efron1987 §3; @diciccio_efron1996 §4]. + +**Other slots.** The location-shift fix is applied only to `est.att` and `est.avg`. If your workflow uses other `fect()` slots, such as `est.calendar`, `est.cohort.att`, `est.subgroup.att`, balanced-sample, by-W, placebo, or carryover, and you use `vartype = "parametric"` with `ci.method = "basic"`, those slots still use the legacy reflected formula on the raw $H_0$-centered bootstrap. Their CIs may not be correctly centered. Until these slots are updated, use `estimand(fit, type, by, ci.method = "basic")` for the estimand you need. + +The legacy `quantile.CI` argument is **soft-deprecated** as of v2.4.2. Setting `quantile.CI = FALSE` is equivalent to `ci.method = "normal"`, and `quantile.CI = TRUE` is equivalent to `ci.method = "basic"`. Both remain available but issue a one-time deprecation warning. + +### `estimand()` — `ci.method = c("normal", "basic", "percentile", "bc", "bca")` + +`estimand()` offers the full five-method set for building CIs after the model is fit. These methods do not add per-replicate cost because they use the already stored `eff.boot` array. The `bca` method adds a low-cost cell-level jackknife, but it does not refit the model. + +| `ci.method` | Formula | When to prefer | +|-------------|---------|----------------| +| `"normal"` | $\hat\theta \pm z \cdot \mathrm{SE}$ (Wald) | Symmetric distributions; the per-type default for `att` | +| `"basic"` | $(2\hat\theta - q_{1-\alpha/2},\ 2\hat\theta - q_{\alpha/2})$ | Reflected pivot CI [@davison_hinkley1997 §5.2.1; `boot::boot.ci(type = "basic")`]; the per-type default for `att.cumu` | +| `"percentile"` | $(q_{\alpha/2},\ q_{1-\alpha/2})$ | Raw bootstrap quantiles; preserved for replication and `boot::boot.ci(type = "perc")` parity --- prefer `"basic"` for routine work | +| `"bc"` | Bias-corrected percentile [@efron1987 minus acceleration]; cutoffs shifted by $2 z_0$ | Skewed distributions where the bootstrap median is biased | +| `"bca"` (new in v2.4.2) | Bias-corrected accelerated [@efron1987 in full]; adds an acceleration parameter via cell-level jackknife | Skewed *and* heavy-tailed; the per-type default for `aptt` and `log.att` | + +In `estimand()`, `ci.method = NULL` uses an estimand-specific default: `att` → `"normal"`, `att.cumu` → `"basic"`, `aptt` → `"bca"`, and `log.att` → `"bca"`. Pass an explicit value to override the default. + +For methods based on tail quantiles, `"basic"`, `"percentile"`, `"bc"`, and `"bca"`, `estimand()` warns when the fit has fewer than 1000 bootstrap replicates. It recommends refitting with `nboots = 1000` for more stable tail estimates [@efron1987 §3; @diciccio_efron1996 §4]. + +### When the two surfaces overlap + +`fect(ci.method = "normal")` and `estimand(fit, type = "att", ci.method = "normal")` give the same estimates for the average effect. They are identical up to RNG noise from independent fits, and byte-identical when they use the same `fit$eff.boot`. The same is true for `"basic"`. + +The two interfaces serve different purposes. `fect()` fills the `est.*` slots at fit time, so users get a CI in the printed output without calling `estimand()` separately. The two options, `"normal"` and `"basic"`, cover the routine `att` workflow. `estimand()` provides the full five-method set for alternative estimands, including `att.cumu`, `aptt`, and `log.att`, where the bootstrap distribution can be skewed and bias correction can change the CI. + +To use `bca` for the standard `att` estimand, fit the model with the default `ci.method` and then call `estimand(fit, type = "att", ci.method = "bca")`. `fect()` rejects `ci.method = "bca"`, `"bc"`, and `"percentile"` with an error that points users to `estimand()`. + +## $p$-values via test inversion + +Each `ci.method` has a corresponding $p$-value obtained by inverting the CI rule. For a two-sided test of $H_0: \theta = \theta_0$, the $p$-value is the smallest $\alpha$ at which the $(1 - \alpha)$ CI excludes $\theta_0$. + +For the standard no-effect null, $H_0: \theta = 0$: + +| `ci.method` | $p$-value | +|---|---| +| `"normal"` | $2 (1 - \Phi(|\hat\theta| / \mathrm{SE}))$ | +| `"percentile"` | $2 \min(P(B \le 0),\ P(B \ge 0))$ | +| `"basic"` | $2 \min(P(B \ge 2\hat\theta),\ P(B \le 2\hat\theta))$ | +| `"bc"` | $2 \Phi\!\left(z_0 - |\Phi^{-1}(P(B \le 0)) - z_0|\right)$, where $z_0 = \Phi^{-1}(P(B < \hat\theta))$ | +| `"bca"` | BCa formula using $z_0$ and acceleration $a$ | + +The legacy `fit$est.avg` $p$-value, stored in the `p.value` column of `fit$est.att`, uses the `"normal"` formula by default. When `quantile.CI = TRUE`, it uses the `"percentile"` formula. The current `estimand()` API does not yet return a `p.value` column. Users who need a non-`"normal"` $p$-value can compute it from `fit$eff.boot` using the formulas above. A `p.value` column is planned for a future release. + +For `vartype = "parametric"`, `get.pvalue()` computes the two-sided $p$-value from the $H_0$-centered bootstrap distribution, not from the shifted distribution used for CIs. This is correct because the $p$-value tests $H_0: \mathrm{ATT} = 0$, and the $H_0$ simulation answers that test directly. For this reason, the location-shift fix in `estimand()` does not apply to `get.pvalue()`. + +## How many bootstrap replicates? + +The classic literature gives different recommendations by `ci.method`, because each method uses a different part of the bootstrap distribution: + +| `ci.method` | Quantity needed | $B$ minimum | $B$ preferred | Reference | +|---|---|---|---|---| +| `"normal"` | $\mathrm{sd}(B)$ | 50 | 200 | @efron_tibshirani1993 §12 | +| `"percentile"` | Tail quantiles $q_{2.5}, q_{97.5}$ | 1,000 | 2,000 | @efron_tibshirani1993 §13.3; @davison_hinkley1997 §5.3.1 | +| `"basic"` | Tail quantiles | 1,000 | 2,000 | Same | +| `"bc"` | Quantiles and bias correction $z_0$ | 1,000 | 2,000 | @efron1987 | +| `"bca"` | Quantiles, $z_0$, and acceleration $a$ | 1,000 | 2,000+ | @diciccio_efron1996; @hesterberg2014 | + +The `fect` default is `nboots = 200`. This is calibrated for the SE-based normal CI, which is the default for `att`, the most common estimand. The simulation results below show that 200 replicates are enough for nominal coverage on `att` across all four scenarios under `ci.method = "normal"`. The SE stabilizes faster than the tail quantiles. + +For tail-quantile methods, `"basic"`, `"percentile"`, `"bc"`, and `"bca"`, the literature minimum of 1,000 is safer. In the simulation below, the small-$N_\mathrm{tr}$ cluster bootstrap in Scenario C1 gives tail-CI coverage of 0.92--0.93 at `nboots = 200`, improving to 0.94--0.945 at `nboots = 1000`. For BCa CIs used as the main inferential output in a paper, `nboots = 2000` is the standard recommendation. + +The `estimand()` warning gate, `.check_tail_ci_replicates`, fires when a tail-CI method is requested from a fit with `nboots < 1000`. The warning cites the literature and recommends refitting with `nboots = 1000`. + +## Empirical coverage + +We conduct a minimal coverage test using $K = 200$ replications in three scenarios: + +- **A** --- Factor model with $r = 2$, IID errors, and `vartype = "parametric"`. $N_{tr} = 5$, $N_{co} = 50$, $T = 30$, and $T_0 = 20$. +- **B** --- Same DGP and estimator as A, but with AR(1) errors and $\rho = 0.8$. +- **C** --- Additive TWFE model with $r = 0$, AR(1) errors with $\rho = 0.5$, $N_{tr} = 20$, and $N_{co} = 80$. **C₁** uses `vartype = "bootstrap"`; **C₂** uses `vartype = "jackknife"`. + +The full DGP and estimator settings are in [`tests/coverage-study/results/README.md`](https://github.com/xuyiqing/fect/blob/main/tests/coverage-study/results/README.md). The coverage target is the realized average treated-post effect within each replication for A and B, and the population $\mathrm{ATT} = 3$ for C. + +### `fect()` ci.method surface + +`fit$est.avg` coverage at $K = 200$, $\mathrm{nboots} = 200$: + +| scenario | ci.method | coverage | Monte Carlo SE | mean width | +|---|---|---:|---:|---:| +| A | normal | 0.960 | 0.014 | 0.800 | +| A | basic | 0.960 | 0.014 | 0.780 | +| B | normal | 0.960 | 0.014 | 1.724 | +| B | basic | 0.950 | 0.015 | 1.690 | +| C₁ | normal | 0.945 | 0.016 | 0.583 | +| C₁ | basic | 0.935 | 0.017 | 0.571 | +| C₂ | normal | 0.930 | 0.018 | 0.605 | + +All cells nominal within Monte Carlo noise. + +### `estimand()` ci.method surface + +Same fits, post-hoc `estimand(fit, "att", "overall", ci.method)` at $\mathrm{nboots} = 200$: + +| scenario | ci.method | coverage | Monte Carlo SE | mean width | +|---|---|---:|---:|---:| +| A | normal | 0.960 | 0.014 | 0.800 | +| A | basic | 0.960 | 0.014 | 0.780 | +| A | percentile | 0.935 | 0.017 | 0.780 | +| A | bc | 0.935 | 0.017 | 0.786 | +| A | bca | 0.940 | 0.017 | 0.786 | +| B | normal | 0.960 | 0.014 | 1.724 | +| B | basic | 0.950 | 0.015 | 1.690 | +| B | percentile | 0.960 | 0.014 | 1.690 | +| B | bc | 0.960 | 0.014 | 1.694 | +| B | bca | 0.960 | 0.014 | 1.694 | +| C₁ | normal | 0.945 | 0.016 | 0.583 | +| C₁ | basic | 0.935 | 0.017 | 0.571 | +| C₁ | percentile | 0.925 | 0.019 | 0.571 | +| C₁ | bc | 0.920 | 0.019 | 0.568 | +| C₁ | bca | 0.920 | 0.019 | 0.568 | +| C₂ | normal | 0.930 | 0.018 | 0.605 | + +A, B, and C₂ are at nominal across all ci.methods. In C₁, the tail-quantile methods (`basic`, `percentile`, `bc`, `bca`) come in at 0.92-0.935 at $\mathrm{nboots} = 200$; at $\mathrm{nboots} = 1000$ they recover to 0.94-0.945, the operating point @efron1987 §3 and @diciccio_efron1996 §4 recommend. + +### Calibration + +Calibration ratios (mean SE divided by empirical SD across replications) are: A = 1.05, B = 1.04, C₁ = 1.01, and C₂ = 1.05. In all cases, variance is calibrated within about 5%. Any remaining coverage gap is a finite-sample issue and shrinks as $K$ or $B$ increases. + +## Decision tree + +A practical default when picking a (`vartype`, `ci.method`, `para.error`) combination: + +```text +Is the design factor-augmented with never-treated controls, no +reversal, and using `method` in {"gsynth", "ife", "cfe"}? + +├── Yes: vartype = "parametric", para.error = "auto" +│ para.error = "auto" resolves to "empirical" on a fully- +│ observed panel and to "ar" when missing-data cells exist +│ Override para.error to "wild" or "empirical" only when you +│ have a fully-observed panel and a reason to bypass the +│ resolved default +│ Use normal for att, bca for aptt / log.att + +└── No: choose between bootstrap and jackknife by treated-unit count + + ├── Ntr small (< 10): vartype = "jackknife" + │ ci.method = "normal" (the only ci.method jackknife accepts) + │ Wald-style interval theta-hat ± z * SE_jack + + └── Ntr >= 10: vartype = "bootstrap" (unit-level cluster bootstrap) + Use normal for att, bca for aptt / log.att + Bump nboots to 1000+ when using a tail-quantile + ci.method (basic / percentile / bc / bca) +``` + diff --git a/vignettes/06-hte.Rmd b/vignettes/08-hte.Rmd similarity index 99% rename from vignettes/06-hte.Rmd rename to vignettes/08-hte.Rmd index 99409115..d5d52a3d 100644 --- a/vignettes/06-hte.Rmd +++ b/vignettes/08-hte.Rmd @@ -9,7 +9,7 @@ set.seed(1234) data(sim_base) ``` -We provide several methods for researchers to explore heterogeneous treatment effects (HTE). These methods help distinguish between *effect modification* --- how the treatment effect varies across subpopulations --- and *causal moderation* --- whether changing the moderator causally alters the treatment effect. This chapter demonstrates both descriptive HTE tools and the formal causal moderation framework. R script used in this chapter can be downloaded [here](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/05-hte.R). +We provide several methods for researchers to explore heterogeneous treatment effects (HTE). These methods help distinguish between *effect modification* --- how the treatment effect varies across subpopulations --- and *causal moderation* --- whether changing the moderator causally alters the treatment effect. This chapter demonstrates both descriptive HTE tools and the formal causal moderation framework. R script used in this chapter can be downloaded [here](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/08-hte.R). ## Basic HTE Visualization diff --git a/vignettes/09-panel.Rmd b/vignettes/09-panel.Rmd index d2d4575d..d3c3ad08 100644 --- a/vignettes/09-panel.Rmd +++ b/vignettes/09-panel.Rmd @@ -11,7 +11,7 @@ source("_common.R") ``` This chapter, authored by Ziyi Liu and Yiqing Xu, complements @CLLX2026 ([paper](https://yiqingxu.org/papers/english/2023_panel/CLLX.pdf), [slides](https://yiqingxu.org/papers/english/2023_panel/CLLX_slides.pdf)). -Rivka Lipkovitz also contributes to this tutorial. R script used in this chapter can be downloaded [here](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/08-panel.R). +Rivka Lipkovitz also contributes to this tutorial. R script used in this chapter can be downloaded [here](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/09-panel.R). ------------------------------------------------------------------------ diff --git a/vignettes/10-sens.Rmd b/vignettes/10-sens.Rmd index 2531e089..8d3a9aa9 100644 --- a/vignettes/10-sens.Rmd +++ b/vignettes/10-sens.Rmd @@ -10,7 +10,7 @@ source("_common.R") The key intuition is that if an event study demonstrates strong post-treatment effects yet only minor parallel trends deviations before treatment, any post-treatment departure large enough to reverse these findings must be substantially larger than those observed in the pre-treatment period. Consequently, this approach quantifies how sensitive the estimated dynamic treatment effects are to possible parallel trends violations, using pretrend estimates as the benchmark. -Below, we illustrate how to apply this sensitivity analysis with **fect**. We focus on two restrictions from @rambachan2023more: the relative magnitude (RM) restriction and the smoothness restriction, both of which connect pre-treatment parallel trends violations to potential post-treatment counterfactual deviations. R script used in this chapter can be downloaded [here](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/09-sens.R). +Below, we illustrate how to apply this sensitivity analysis with **fect**. We focus on two restrictions from @rambachan2023more: the relative magnitude (RM) restriction and the smoothness restriction, both of which connect pre-treatment parallel trends violations to potential post-treatment counterfactual deviations. R script used in this chapter can be downloaded [here](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/10-sens.R). ## Install Packages diff --git a/vignettes/07-plots.Rmd b/vignettes/11-plots.Rmd similarity index 93% rename from vignettes/07-plots.Rmd rename to vignettes/11-plots.Rmd index c418a4b7..e5ee229a 100644 --- a/vignettes/07-plots.Rmd +++ b/vignettes/11-plots.Rmd @@ -14,7 +14,7 @@ In this chapter, we explore visualization options available in the **fect** pack - special-purpose displays (`status`, `factors`, and `loadings`) - standalone `esplot()` -We begin with shared parameter conventions and then work through each plot type in turn. `plot.fect` is an S3 method that accepts a fitted `fect` object and a `type` argument. All customization parameters---axis limits, colors, text sizes, reference lines---are passed as additional arguments. Some parameters apply universally; others are type-specific. A parameter applicability table appears at the end of this chapter. R script used in this chapter can be downloaded [here](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/06-plots.R). +We begin with shared parameter conventions and then work through each plot type in turn. `plot.fect` is an S3 method that accepts a fitted `fect` object and a `type` argument. All customization parameters---axis limits, colors, text sizes, reference lines---are passed as additional arguments. Some parameters apply universally; others are type-specific. A parameter applicability table appears at the end of this chapter. R script used in this chapter can be downloaded [here](https://raw.githubusercontent.com/xuyiqing/fect/dev/vignettes/rscript/11-plots.R). ------------------------------------------------------------------------ @@ -28,6 +28,7 @@ library(ggplot2) library(panelView) data(gs2020) data(hh2019) +data(simdata) ls() ``` @@ -547,14 +548,14 @@ Note: most styling parameters (`connected`, `plot.ci`, `pre.color`/`post.color`, ### Factors and loadings plots -These plot types are available when the model is estimated with interactive fixed effects (`method = "ife"` or `method = "gsynth"`). We first fit an IFE model with two factors: +These plot types are available when the model is estimated with interactive fixed effects (`method = "ife"` or `method = "gsynth"`). We use `simdata` here because its data-generating process has two latent factors ($r = 2$), so the estimated factors and loadings reflect real structure rather than numerical artifacts. We fit an IFE model with two factors: ```{r est-ife, cache = TRUE} -out_ife <- fect(nat_rate_ord ~ indirect, - data = hh2019, - index = c("bfs", "year"), - method = "ife", r = 2, - se = TRUE, parallel = TRUE, cores = 16, nboots = 1000) +out_ife <- fect(Y ~ D + X1 + X2, data = simdata, + index = c("id", "time"), + method = "ife", r = 2, force = "two-way", + se = TRUE, parallel = TRUE, cores = 16, + nboots = 200) ``` The **factors** plot displays the estimated latent time factors. It uses the Okabe-Ito colorblind-safe palette with thinner lines for a clean, publication-ready appearance. Factor 0 (fixed effects, shown when `include.FE = TRUE`) appears in gray; subsequent factors appear in orange, blue, green, and so on. Use `nfactors` to limit the number of displayed factors. @@ -601,8 +602,9 @@ For $r > 2$ the plot still shows only factors 1 and 2; the hull and overlap meas For $r = 1$, the same diagnostic is rendered as a **mirror histogram**: treated counts above the axis, control counts flipped below, with a vertical band marking the range of control loadings. The 1D analog of "outside the hull" is "outside the band." ```{r loading-overlap-r1-fit, cache = TRUE, message = FALSE, warning = FALSE} -out_ife_r1 <- fect(nat_rate_ord ~ indirect, data = hh2019, - index = c("bfs", "year"), method = "ife", r = 1, +out_ife_r1 <- fect(Y ~ D + X1 + X2, data = simdata, + index = c("id", "time"), method = "ife", r = 1, + force = "two-way", se = TRUE, parallel = TRUE, cores = 16, nboots = 500) ``` @@ -737,6 +739,52 @@ The table below summarizes which parameters apply to each plot type. Parameters +## Estimation sample via panelView {#sec-sample} + +Every fect fit returns a logical matrix `$sample` indicating which +cells the estimator actually consumed. The matrix is the same shape as +the panel; a cell is true when it entered the main fit, a placebo or +carryover test, or a balance check, and false when it was missing, +dropped, or excluded by `carryover.rm`. **panelView** consumes this +matrix directly via its `panelview(fit)` entry-point, so visualizing +the estimation sample takes one call: + +```{r sample-fect-fit, message=FALSE, warning=FALSE} +library(fect); library(panelView) +data(hh2019, package = "fect") + +fit <- fect(nat_rate_ord ~ indirect, data = hh2019, + index = c("bfs", "year"), + method = "ife", r = 0, se = FALSE, CV = FALSE, + min.T0 = 2) +``` + +```{r sample-fect-plot, fig.width=12, fig.height=8, out.width="100%"} +panelview(fit, type = "treat", by.timing = TRUE, + axis.lab = "off", display.all = TRUE, + gridOff = TRUE, xlab = "", ylab = "") +``` + +The figure splits into three bands. At the top sits a dark-grey block +of roughly 285 municipalities that were already treated when the panel +begins; they have no pre-treatment period and fect drops them +silently. Without the sample overlay these dropped municipalities +would be invisible. Below that is a dark-blue staircase of the units +fect actually fits, ordered by treatment onset. The broad light-blue +band at the bottom is the never-treated controls. + +For a layout that puts the in-sample band on top instead, pair +`sample.sort = TRUE` with `by.timing = TRUE`: in-sample units rise to +the top, ordered by treatment timing within, and the dropped band +falls to the bottom. + +The same fit can be passed to `sample =` inside the explicit-data +signature if you prefer to control the data argument yourself. The +**panelView** manual chapter on Treatment Status covers the full +surface, including the sample-alignment rules, the four +sample-sort × by-timing combinations, and the named-slot syntax for +fine-grained palette overrides. + ## How to Cite If you find these methods and visualization tools helpful, you can cite @LWX2024. diff --git a/vignettes/_quarto.yml b/vignettes/_quarto.yml index 4870f58e..94b6546d 100644 --- a/vignettes/_quarto.yml +++ b/vignettes/_quarto.yml @@ -13,21 +13,21 @@ book: - 03-estimands.Rmd - 04-ife-mc.Rmd - 05-cfe.Rmd - - 06-hte.Rmd - - 07-plots.Rmd - - 08-gsynth.Rmd + - 06-gsynth.Rmd + - 07-inference.Rmd + - 08-hte.Rmd - 09-panel.Rmd - 10-sens.Rmd + - 11-plots.Rmd - aa-cheatsheet.Rmd - - references.qmd - bb-updates.Rmd + - cc-references.qmd bibliography: references.bib -nocite: | - @* - suppress-bibliography: true +link-citations: true +link-bibliography: true format: html: @@ -35,6 +35,9 @@ format: code-fold: false code-tools: true code-link: true + link-citations: true + link-bibliography: true + citations-hover: true toc-depth: 3 # Default rendered figure dimensions for HTML output. Tuned so that the # PNG width at retina dpi is close to the cosmo theme's content-column diff --git a/vignettes/aa-cheatsheet.Rmd b/vignettes/aa-cheatsheet.Rmd index c01fc625..22d1d3ae 100644 --- a/vignettes/aa-cheatsheet.Rmd +++ b/vignettes/aa-cheatsheet.Rmd @@ -60,8 +60,8 @@ A check mark (✓) indicates that the method requires or accepts the input. | `X` (covariates) | ✓ | ✓ | ✓ | ✓ | ✓ | | `data` | ✓ | ✓ | ✓ | ✓ | ✓ | | `index` (unit & time IDs) | ✓ | ✓ | ✓ | ✓ | ✓ | -| `sfe` (simple additive FEs) | – | – | – | – | ✓ | -| `cfe` (complex FEs) | – | – | – | – | ✓ | +| `group.fe` (additional additive FEs; auto-routes `fe` → `cfe`) | ✓ | – | – | – | ✓ | +| `cfe` (complex / interactive FEs) | – | – | – | – | ✓ | | `Z` (time-invariant covariates) | – | – | – | – | ✓ | | `Q` (known time trends) | – | – | – | – | ✓ | | `Q.type` (auto time trends) | – | – | – | – | ✓ | diff --git a/vignettes/bb-updates.Rmd b/vignettes/bb-updates.Rmd index 163ebe1c..45ddfccb 100644 --- a/vignettes/bb-updates.Rmd +++ b/vignettes/bb-updates.Rmd @@ -1,4 +1,64 @@ -# Changelog {#sec-changelog .unnumbered} +# Changelog {.unnumbered} + +## v2.4.5 + +(2026-05-30) CRAN release. + +* New `group.fe` argument on `fect()`: absorb additive fixed effects at a coarsening of the unit identifier (e.g., state FE on county-level data when treatment varies at the state level). +* Fix: `method = "cfe"` with `force = "time"` / `"unit"` previously errored with `Index out of bounds: [index='alpha']` / `[index='xi']`. +* Removed the vestigial public `sfe` argument and the orphan internal `R/polynomial.R` (no live code reached either). + +## v2.4.4 + +(2026-05-19) + +* `fect()` now returns `$sample`, a logical `T x N` matrix (same dims as + `$Y.dat`) marking cells the estimator used in any part of the + procedure (main fit, placebo / carryover / balance tests). Compatible + with `panelView::panelview(sample = ...)`. + +## v2.4.3 + +(2026-05-14) + +* Fix `future.globals.maxSize` overrun in parallel bootstrap: `quiet_nonpara` + wrapper no longer captures `fect_boot()`'s full frame. +* Raise `future.globals.maxSize` to 2 GiB locally inside the parallel block. + +## v2.4.2 + +(2026-05-02) + +* New `test = c("none", "placebo", "carryover")` argument on `estimand()` + closes issue #131. +* New `ci.method = c("normal", "basic")` argument on `fect()`. Default + `"normal"` is byte-equivalent to the v2.4.1 default. `"basic"` is the + reflected pivot CI (Davison-Hinkley 1997 §5.2.1; `boot::boot.ci(type = "basic")`). + All CIs in fect's `est.*` slots use the requested method uniformly. + Legacy `quantile.CI` is soft-deprecated --- both legacy values still + work (mapped to `ci.method` with a one-time warning). +* New `ci.method` values `"bc"`, `"bca"`, `"normal"` on `estimand()`; + per-type defaults updated. `att.cumu` default is `"basic"` (the + reflected pivot CI recommended by Davison-Hinkley 1997 §5.2.1 and used + by `boot::boot.ci(type = "basic")`); the raw-quantile `"percentile"` + option is preserved for replication. The full 5-method surface lives + on `estimand()`; fect's built-in CI machinery covers normal / basic + only. +* New `para.error` argument for `vartype = "parametric"` selects the + residual-error model: `"auto"`, `"ar"`, `"empirical"`, `"wild"`. +* Tighter EM convergence defaults: `tol` from `1e-3` to `1e-5`, + `max.iteration` from `1000` to `5000`, plus a `warning()` when EM + hits `max.iteration` without converging. IFE/CFE point estimates + shift a few percent (up to 40% on factor-heavy CFE) closer to the + EM's converged minimum. Pass `tol = 1e-3, max.iteration = 1000` + explicitly to reproduce pre-v2.4.2 numerical output. +* `estimand()` warns when a tail-quantile CI method (`"basic"`, + `"percentile"`, `"bc"`, `"bca"`) is requested on a fit with + fewer than 1000 bootstrap replicates, recommending refit at + `nboots = 1000`. +* `vartype = "jackknife"` with `Nco > 1000` emits a fit-time + warning recommending `vartype = "bootstrap"` for tractability. +* Various bug fixes. ## v2.4.1 @@ -7,8 +67,7 @@ **Enhancement.** `estimand()`'s `vartype` argument now accepts `"parametric"` in addition to `"bootstrap"`, `"jackknife"`, and `"none"`. Works for all four `type` values when the fit was produced -with `fect(..., vartype = "parametric", keep.sims = TRUE)`. See -@sec-estimands for a worked example. +with `fect(..., vartype = "parametric", keep.sims = TRUE)`. **Bug fix.** `estimand(fit, "att.cumu", ...)` now populates `n_cells` on both event-time and overall paths, so @@ -39,8 +98,8 @@ dedicated chapter in the user manual. event-time-window case. * `direction = c("on", "off")` selects the event-time grid for reversal panels. -* New chapter [@sec-estimands] in the user manual walks through all six - worked examples plus the migration table. +* New chapter on post-hoc estimands in the user manual walks through + all six worked examples plus the migration table. **Soft-deprecation.** `effect()` and `att.cumu()` emit a one-time-per-session message pointing at `estimand()`. They continue @@ -83,7 +142,7 @@ breaking the long-form schema. **Consistent ATT surface when `W` is supplied.** `fit$est.att`, `fit$est.avg`, `plot(fit)`, and `print(fit)` now all report the same W-weighted aggregation. The redundant `*.W` parallel slots are no longer attached to the fit object. To see the unweighted view, refit with `W = NULL`. -**New `W.est` and `W.agg` arguments.** Both default to `NULL` and fall back to `W`. Use `W.est` alone when the weight should enter the outcome-model fit only, or `W.agg` alone when it should enter the aggregation only. See [Chapter @sec-ife-mc] §3.5 for details. A clean fect-internal solution for inverse-probability weights for confounding adjustment is under development for v3.0. +**New `W.est` and `W.agg` arguments.** Both default to `NULL` and fall back to `W`. Use `W.est` alone when the weight should enter the outcome-model fit only, or `W.agg` alone when it should enter the aggregation only. A clean fect-internal solution for inverse-probability weights for confounding adjustment is under development for v3.0. **Deprecations.** The `weight` argument to `plot.fect()` is now a no-op (the canonical slots are already W-weighted when `W` is supplied). It emits a one-time warning and is slated for removal in v2.5.0. @@ -91,7 +150,7 @@ breaking the long-form schema. (2026-04-25) -**Rolling-window cross-validation** ([Chapter @sec-ife-mc], [Chapter @sec-gsynth]): +**Rolling-window cross-validation**: * New `cv.method = "rolling"` in the main `fect()` CV dispatcher (also exposed as standalone `r.cv.rolling()`) implements the standard time-series rolling-window CV design adapted to panel data. Recommended default for serially correlated panels; closes the AR-leakage channel that causes block CV to over-select `r` (often pegging at `r.max`). Supports `method` in {`"ife"`, `"gsynth"`, `"cfe"`, `"mc"`, `"both"`}. New parameter `cv.buffer` (default 1, past-side buffer). Empirical validation: on a Xu (2017) DGP with $r_{\text{true}} = 2$ and AR(1) $\rho = 0.8$ (K = 200 reps), rolling CV recovers truth in 56% vs block CV's 15% (mean `r.cv` = 1.58 vs 3.34). @@ -100,11 +159,11 @@ breaking the long-form schema. * `cv.rule = "1se"` (default) picks the smallest `r` within one fold-SE of the minimum-CV-error `r`. Legacy `cv.rule = "1pct"` remains available for byte-identical reproducibility of pre-2.3.0 fits. * Default flip: existing `CV = TRUE` calls will produce different `r.cv` on the same data. Set `cv.rule = "1pct"` to recover prior behavior. -**Bounded factor loadings for GSC** (see [Chapter @sec-gsynth]): +**Bounded factor loadings for GSC**: * New `loading.bound = "simplex"` (default `"none"`) constrains treated-unit loadings to the convex hull of control loadings via an entropy-regularized simplex projection. Companion arguments: `gamma.loading` (regularization strength; `NULL` triggers 5-fold CV) and `gamma.loading.grid`. Diagnostic outputs: `wgt.implied` (row-stochastic simplex weights), `loading.proj.resid` (extrapolation flag per treated unit). Currently `method = "ife"`/`"gsynth"` with `time.component.from = "nevertreated"` only. * Caveat: percentile-bootstrap intervals may under-cover when the constraint binds; boundary-corrected inference is deferred. -* Companion plot: `plot(..., type = "loading.overlap")` shows treated loadings vs the control convex hull ($r \geq 2$) or mirror histogram with control-range band ($r = 1$). See [Chapter @sec-loading-overlap]. +* Companion plot: `plot(..., type = "loading.overlap")` shows treated loadings vs the control convex hull ($r \geq 2$) or mirror histogram with control-range band ($r = 1$). **Other changes**: diff --git a/vignettes/references.qmd b/vignettes/cc-references.qmd similarity index 55% rename from vignettes/references.qmd rename to vignettes/cc-references.qmd index a0ca0e84..522085fe 100644 --- a/vignettes/references.qmd +++ b/vignettes/cc-references.qmd @@ -1,8 +1,10 @@ --- suppress-bibliography: false +nocite: | + @* --- -# References {.unnumbered} +# Bibliography {.unnumbered} ::: {#refs} ::: diff --git a/vignettes/index.qmd b/vignettes/index.qmd index 5c82ea2a..580af333 100644 --- a/vignettes/index.qmd +++ b/vignettes/index.qmd @@ -83,31 +83,37 @@ Choose based on estimand and inference. If the target is unit-specific and condi ## Organization -The user guide is structured into the following chapters: +The user guide is structured into four parts. Most users only need the **Basics** part to perform a complete analysis with the fixed effects counterfactual estimator; the remaining parts are referenced as needed. + +### Basics - [Chapter @sec-start]\ Installation instructions and datasets. - [Chapter @sec-fect]\ - The fixed effects counterfactual estimator (FEct), including estimation, inference, and diagnostics. + The fixed effects counterfactual estimator (FEct), including estimation, basic inference, and the `group.fe` argument for sub-group treatment (e.g., counties nested in states with a state-level policy). - [Chapter @sec-estimands]\ Alternative estimands and the unified post-hoc estimand interface: cumulative ATT, APTT, log-scale ATT, window-restricted ATT, and the long-form accessor for custom estimands. +### Advanced estimators and inference + - [Chapter @sec-ife-mc]\ Interactive fixed effects (IFE) and matrix completion (MC) methods, cross-validation, and diagnostic tests. - [Chapter @sec-cfe]\ The complex fixed effects (CFE) estimator: multi-level fixed effects, time-invariant covariates with time-varying coefficients, unit-specific time trends, in addition to interactive fixed effects. -- [Chapter @sec-hte]\ - Effect heterogeneity: box plots, calendar-time trends, and covariate-based HTE. Triple difference-in-differences designs (in development). +- [Chapter @sec-gsynth]\ + The Gsynth program --- the synthetic control setting using `time.component.from = "nevertreated"` --- originally developed in the **gsynth** package, with CFE extensions. -- [Chapter @sec-plots]\ - Details of the plotting options and customization. +- [Chapter @sec-inference]\ + Bootstrap inference internals: the `vartype` × `ci.method` × `para.error` matrix, parametric bootstrap mechanics, and the decision tree for choosing an inference path. Most relevant after Chapter @sec-gsynth where parametric bootstrap is the default. -- [Chapter @sec-gsynth]\ - The Gsynth program — the synthetic control setting using `time.component.from = "nevertreated"` — originally developed in the **gsynth** package, with CFE extensions. +### Diagnostics and extensions + +- [Chapter @sec-hte]\ + Effect heterogeneity: box plots, calendar-time trends, and covariate-based HTE. Triple difference-in-differences designs (in development). - [Chapter @sec-panel]\ Application of various "modern" DID estimators. @@ -115,6 +121,11 @@ The user guide is structured into the following chapters: - [Chapter @sec-panel-sens]\ Sensitivity analysis for the counterfactual estimators. +### Reference + +- [Chapter @sec-plots]\ + Detailed reference for plot options and customization, with examples for factor diagnostics, HTE, and modern-DID visualizations. + - [Chapter @sec-cheatsheet]\ Quick reference for methods, parameters, plotting, and diagnostics. @@ -136,14 +147,14 @@ The following individuals (and AI) have contributed to **gsynth** and **fect**, To cite the **fect** package or this user manual, please use: -> Xu, Yiqing, Licheng Liu, Ye Wang, Ziyi Liu, Shijian Liu, Tianzhu Qin, Jinwen Wu, and Rivka Lipkovitz. 2026. *fect: Fixed Effects Counterfactual Estimators --- User Manual (v2.4.1).* +> Xu, Yiqing, Licheng Liu, Ye Wang, Ziyi Liu, Shijian Liu, Tianzhu Qin, Jinwen Wu, and Rivka Lipkovitz. 2026. *fect: Fixed Effects Counterfactual Estimators --- User Manual (v2.4.5).* ``` bibtex @manual{fect2026, title = {fect: Fixed Effects Counterfactual Estimators --- User Manual}, author = {Xu, Yiqing and Liu, Licheng and Wang, Ye and Liu, Ziyi and Liu, Shijian and Qin, Tianzhu and Wu, Jinwen and Lipkovitz, Rivka}, year = {2026}, - note = {R package version 2.4.1}, + note = {R package version 2.4.5}, url = {https://yiqingxu.org/packages/fect/} } ``` diff --git a/vignettes/references.bib b/vignettes/references.bib index 2abed3de..d226315c 100644 --- a/vignettes/references.bib +++ b/vignettes/references.bib @@ -266,4 +266,100 @@ @article{chen2024logs doi={10.1093/qje/qjad054} } +@article{efron1987, + title={Better bootstrap confidence intervals}, + author={Efron, Bradley}, + journal={Journal of the American Statistical Association}, + volume={82}, + number={397}, + pages={171--185}, + year={1987}, + publisher={Taylor \& Francis} +} + +@book{efron_tibshirani1993, + title={An Introduction to the Bootstrap}, + author={Efron, Bradley and Tibshirani, Robert J.}, + year={1993}, + publisher={Chapman and Hall}, + address={New York} +} + +@book{davison_hinkley1997, + title={Bootstrap Methods and their Application}, + author={Davison, A. C. and Hinkley, D. V.}, + year={1997}, + publisher={Cambridge University Press}, + address={Cambridge} +} + +@article{diciccio_efron1996, + title={Bootstrap confidence intervals (with discussion)}, + author={DiCiccio, Thomas J. and Efron, Bradley}, + journal={Statistical Science}, + volume={11}, + number={3}, + pages={189--228}, + year={1996} +} + +@book{hall1992, + title={The Bootstrap and Edgeworth Expansion}, + author={Hall, Peter}, + year={1992}, + publisher={Springer}, + address={New York} +} + +@article{hesterberg2014, + title={What teachers should know about the bootstrap: Resampling in the undergraduate statistics curriculum}, + author={Hesterberg, Tim C.}, + journal={The American Statistician}, + volume={69}, + number={4}, + pages={371--386}, + year={2015}, + publisher={Taylor \& Francis} +} + +@article{liu1988, + title={Bootstrap procedures under some non-i.i.d. models}, + author={Liu, Regina Y.}, + journal={Annals of Statistics}, + volume={16}, + number={4}, + pages={1696--1708}, + year={1988} +} + +@article{mammen1993, + title={Bootstrap and wild bootstrap for high dimensional linear models}, + author={Mammen, Enno}, + journal={Annals of Statistics}, + volume={21}, + number={1}, + pages={255--285}, + year={1993} +} + +@article{cameron_gelbach_miller2008, + title={Bootstrap-based improvements for inference with clustered errors}, + author={Cameron, A. Colin and Gelbach, Jonah B. and Miller, Douglas L.}, + journal={Review of Economics and Statistics}, + volume={90}, + number={3}, + pages={414--427}, + year={2008} +} + +@article{carpenter_bithell2000, + title={Bootstrap confidence intervals: when, which, what? A practical guide for medical statisticians}, + author={Carpenter, James and Bithell, John}, + journal={Statistics in Medicine}, + volume={19}, + number={9}, + pages={1141--1164}, + year={2000} +} + diff --git a/vignettes/rscript/02-fect.R b/vignettes/rscript/02-fect.R index b49e4d23..202a9fb3 100644 --- a/vignettes/rscript/02-fect.R +++ b/vignettes/rscript/02-fect.R @@ -32,8 +32,7 @@ out.fect <- fect(Y ~ D + X1 + X2, data = sim_base, index = c("id","time"), ## ----fect_plot_nose, fig.width = 6, fig.height = 4.5-------------------------- -plot(out.fect, main = "Estimated ATT (FEct)", ylab = "Effect of D on Y", - cex.main = 0.8, cex.lab = 0.8, cex.axis = 0.8) +plot(out.fect, main = "Estimated ATT (FEct)", ylab = "Effect of D on Y") ## ----simdata_fect, eval=TRUE, cache = TRUE, message = FALSE, results = 'hide'---- @@ -44,10 +43,10 @@ out.fect <- fect(Y ~ D + X1 + X2, data = sim_base, index = c("id","time"), ## ----fect_plot_nse, fig.width = 6, fig.height = 4.5--------------------------- plot(out.fect, main = "Estimated ATT (FEct)", ylab = "Effect of D on Y", - cex.main = 0.8, cex.lab = 0.8, cex.axis = 0.8, stats = "F.p") + stats = "F.p") -## ----exit_fect, eval = TRUE, cache = TRUE, warning = FALSE, fig.width = 6, fig.height = 4.5---- +## ----exit_fect, eval = TRUE, warning = FALSE, fig.width = 6, fig.height = 4.5---- plot(out.fect, type = "exit", main = "Exit Plot (FEct)") @@ -65,12 +64,19 @@ print(out.fect) # out.fect$eff.boot -## ----fect_placebo, eval=TRUE, cache=TRUE, message=FALSE, results='hide', fig.width=6, fig.height=4.5---- +## ----fect_placebo_fit, eval=TRUE, cache=TRUE, message=FALSE, results='hide'---- out.fect.placebo <- fect(Y ~ D + X1 + X2, data = sim_base, index = c("id","time"), force = "two-way", method = "fe", se = TRUE, nboots = 1000, parallel = TRUE, cores = 16, placeboTest = TRUE, placebo.period = c(-2, 0)) -plot(out.fect.placebo, cex.text = 0.8) + + +## ----fect_placebo_plot, eval=TRUE, fig.width=6, fig.height=4.5---------------- +plot(out.fect.placebo) + + +## ----fect_placebo_plot_fill, eval=TRUE, fig.width=6, fig.height=4.5----------- +plot(out.fect.placebo, highlight.fill = TRUE) ## ----fect_carryover, eval=TRUE, cache=TRUE, message=FALSE, results='hide'----- @@ -80,8 +86,20 @@ out.fect.carry <- fect(Y ~ D + X1 + X2, data = sim_base, index = c("id","time"), carryoverTest = TRUE, carryover.period = c(1, 3)) -## ----fect_carryover_plot, eval=TRUE, cache=TRUE, warning=FALSE, fig.width=6, fig.height=5---- -plot(out.fect.carry, type = "exit", cex.text = 0.8, main = "Carryover Effects (FEct)") +## ----fect_carryover_plot, eval=TRUE, warning=FALSE, fig.width=6, fig.height=5---- +plot(out.fect.carry, type = "exit", main = "Carryover Effects (FEct)") + + +## ----fect_carryover_plot_fill, eval=TRUE, warning=FALSE, fig.width=6, fig.height=5---- +plot(out.fect.carry, type = "exit", + highlight.fill = TRUE, + main = "Carryover Effects (FEct), with rectangle") + + +## ----fect_carryover_plot_off, eval=TRUE, warning=FALSE, fig.width=6, fig.height=5---- +plot(out.fect.carry, type = "exit", + highlight = FALSE, + main = "Carryover Effects (FEct), no highlight") ## ----fect_loo, eval=TRUE, cache = TRUE, message = FALSE----------------------- @@ -91,46 +109,7 @@ out.fect.loo <- fect(Y ~ D + X1 + X2, data = sim_base, index = c("id","time"), ## ----plot-gap-loo, fig.width = 6, fig.height = 4.5---------------------------- -plot(out.fect.loo,main = "Estimated ATT (FEct) -- LOO", - cex.main = 0.8, cex.lab = 0.8, cex.axis = 0.8) - - -## ----cumu_effect, cache = TRUE------------------------------------------------ -out <- fect(Y ~ D + X1 + X2, data = sim_gsynth, index = c("id","time"), - method = "ife", time.component.from = "nevertreated", - force = "two-way", CV = TRUE, r = c(0, 5), - se = TRUE, nboots = 1000, vartype = 'bootstrap', - parallel = TRUE, cores = 16, keep.sims=TRUE) -cumu.out <- effect(out) - - -## ----cumu_effect_plot, cache = TRUE------------------------------------------- -print(cumu.out) -plot(cumu.out) - - -## ----cumu_effect_byperiod, cache = TRUE--------------------------------------- -effect(out, cumu=FALSE) - - -## ----cumu_effect_subset, cache = TRUE----------------------------------------- -effect(out, cumu=TRUE, id=c(101,102,103), period=c(1,5)) - - -## ----effect-mc, cache = TRUE-------------------------------------------------- -out_mc <- fect(Y ~ D + X1 + X2, data = sim_gsynth, index = c("id","time"), - method = "mc", force = "two-way", CV = TRUE, r = c(0, 5), - se = TRUE, nboots = 1000, vartype = 'bootstrap', - parallel = TRUE, cores = 16, keep.sims=TRUE) -plot(effect(out_mc)) - - -## ----effect-jackknife, cache = TRUE------------------------------------------- -out_jack <- fect(Y ~ D + X1 + X2, data = sim_gsynth, index = c("id","time"), - method = "mc", force = "two-way", CV = TRUE, r = c(0, 5), - se = TRUE, nboots = 1000, vartype = 'jackknife', - parallel = TRUE, cores = 16, keep.sims=TRUE) -plot(effect(out_jack)) +plot(out.fect.loo,main = "Estimated ATT (FEct) -- LOO") ## ----simdata_bal, eval=TRUE, cache = TRUE------------------------------------- @@ -171,7 +150,7 @@ out.fe.g <- fect(Y ~ D + X1 + X2, data = sim_base.cohort, index = c("id","time") se = TRUE, nboots = 1000, parallel = TRUE, cores = 16, group = 'Cohort') -## ----cohort_plot1, eval = TRUE, cache = TRUE, warning = FALSE, fig.width = 6, fig.height = 4.5---- +## ----cohort_plot1, eval = TRUE, warning = FALSE, fig.width = 6, fig.height = 4.5---- plot(out.fe.g, show.group = "Cohort:22", xlim = c(-15, 10), ylim = c(-10, 10)) diff --git a/vignettes/rscript/03-estimands.R b/vignettes/rscript/03-estimands.R new file mode 100644 index 00000000..d42db170 --- /dev/null +++ b/vignettes/rscript/03-estimands.R @@ -0,0 +1,204 @@ +## ----.common, include = FALSE------------------------------------------------- +source("_common.R") + + +## ----setup-estimand, eval = TRUE, message = FALSE, results = 'hide'----------- +library(dplyr) + +set.seed(1) +N <- 60; TT <- 25 +df <- expand.grid(id = 1:N, time = 1:TT) +treat_start <- sample(c(NA, 8:18), N, replace = TRUE) +df$D <- ifelse(is.na(treat_start[df$id]) | df$time < treat_start[df$id], + 0, 1) +## Higher intercept (2.0) and smaller noise (sd = 0.1) keep Y safely +## positive throughout, so the v2.4.2+ cell-drop hard-error in +## log.att / aptt does not fire on benign bootstrap noise. +df$Y <- exp(2.0 + 0.05 * df$time + 0.3 * df$D + rnorm(nrow(df), sd = 0.1)) + +fit <- fect(Y ~ D, data = df, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, nboots = 200, parallel = FALSE, + keep.sims = TRUE) + + +## ----est-att-event-time, eval = TRUE------------------------------------------ +estimand(fit, "att", "event.time") |> + head(8) + + +## ----plot-att-event-time, eval = TRUE, fig.width = 6, fig.height = 4.5-------- +est <- estimand(fit, "att", "event.time") +esplot(est, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + Count = "n_cells", + main = "Per-event-time ATT") + + +## ----est-cumu-event-time, eval = TRUE----------------------------------------- +estimand(fit, "att.cumu", "event.time") |> + head(8) + + +## ----plot-cumu-event-time, eval = TRUE, fig.width = 6, fig.height = 4.5------- +cumu <- estimand(fit, "att.cumu", "event.time") +esplot(cumu, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + Count = "n_cells", + main = "Cumulative ATT", + ylab = "Cumulative Effect") + + +## ----est-cumu-overall, eval = TRUE-------------------------------------------- +estimand(fit, "att.cumu", "overall", window = c(1, 5)) + + +## ----est-aptt, eval = TRUE---------------------------------------------------- +estimand(fit, "aptt", "event.time") |> + head(8) + + +## ----plot-aptt-event-time, eval = TRUE, fig.width = 6, fig.height = 4.5------- +aptt <- estimand(fit, "aptt", "event.time") +esplot(aptt, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + Count = "n_cells", + main = "APTT by event time", + ylab = "Average Proportional TE on the Treated") + + +## ----est-log-att, eval = TRUE------------------------------------------------- +estimand(fit, "log.att", "event.time") |> + head(8) + + +## ----plot-log-att-event-time, eval = TRUE, fig.width = 6, fig.height = 4.5---- +log_att <- estimand(fit, "log.att", "event.time") +esplot(log_att, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + Count = "n_cells", + main = "Log-scale ATT", + ylab = "Mean log(Y) − log(Y0)") + + +## ----setup-placebo, eval = TRUE, message = FALSE, results = 'hide'------------ +## Re-fit on the same DGP with placeboTest = TRUE so that the dispatcher +## can recompute APTT / log-ATT at the placebo cells. +fit_placebo <- fect(Y ~ D, data = df, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, nboots = 200, parallel = FALSE, + keep.sims = TRUE, + placeboTest = TRUE, placebo.period = c(-2, 0)) + + +## ----plot-aptt-placebo, eval = TRUE, fig.width = 6, fig.height = 4.5---------- +aptt_placebo <- estimand(fit_placebo, "aptt", "event.time", + test = "placebo") +esplot(aptt_placebo, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + Count = "n_cells", + main = "APTT placebo (pre-treatment)", + ylab = "Average Proportional TE on the Treated") + + +## ----plot-log-att-placebo, eval = TRUE, fig.width = 6, fig.height = 4.5------- +log_att_placebo <- estimand(fit_placebo, "log.att", "event.time", + test = "placebo") +esplot(log_att_placebo, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + Count = "n_cells", + main = "Log-ATT placebo (pre-treatment)", + ylab = "Mean log(Y) − log(Y0)") + + +## ----setup-carryover, eval = TRUE, message = FALSE, results = 'hide'---------- +## Build a panel with treatment reversals for the carryover demo. +set.seed(2) +df_rev <- df +treat_end <- pmin(treat_start[df_rev$id] + sample(5:10, N, replace = TRUE), + TT + 1L) +df_rev$D <- ifelse(is.na(treat_start[df_rev$id]) | + df_rev$time < treat_start[df_rev$id] | + df_rev$time >= treat_end[df_rev$id], + 0, 1) +df_rev$Y <- exp(2.0 + 0.05 * df_rev$time + 0.3 * df_rev$D + + rnorm(nrow(df_rev), sd = 0.1)) + + +## ----panelview-carryover, eval = TRUE, fig.width = 7, fig.height = 4.5-------- +panelView::panelview(Y ~ D, data = df_rev, index = c("id", "time"), + by.timing = TRUE, axis.lab = "time", + main = "Treatment-reversal panel for carryover demo") + + +## ----fit-carryover, eval = TRUE, message = FALSE, results = 'hide'------------ +fit_carry <- fect(Y ~ D, data = df_rev, index = c("id", "time"), + method = "fe", force = "two-way", + se = TRUE, nboots = 200, parallel = FALSE, + keep.sims = TRUE, + carryoverTest = TRUE, carryover.period = c(1, 2)) + + +## ----plot-aptt-carryover, eval = TRUE, fig.width = 6, fig.height = 4.5-------- +aptt_carry <- estimand(fit_carry, "aptt", "event.time", + test = "carryover") +esplot(aptt_carry, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + Count = "n_cells", + main = "APTT carryover (post-reversal)", + ylab = "Average Proportional TE on the Treated") + + +## ----plot-log-att-carryover, eval = TRUE, fig.width = 6, fig.height = 4.5----- +log_att_carry <- estimand(fit_carry, "log.att", "event.time", + test = "carryover") +esplot(log_att_carry, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + Count = "n_cells", + main = "Log-ATT carryover (post-reversal)", + ylab = "Mean log(Y) − log(Y0)") + + +## ----est-window-overall, eval = TRUE------------------------------------------ +estimand(fit, "att", "overall", window = c(1, 5)) + + +## ----imp-out-glance, eval = TRUE---------------------------------------------- +po <- imputed_outcomes(fit) +head(po) + + +## ----imp-out-rep, eval = TRUE------------------------------------------------- +po_rep <- imputed_outcomes(fit, replicates = TRUE) +nrow(po_rep) == nrow(po) * 200 # one row per (cell, replicate) + + +## ----custom-estimand, eval = TRUE--------------------------------------------- +po |> + group_by(event.time) |> + summarise(sd_eff = sd(eff, na.rm = TRUE), + n = dplyr::n(), + .groups = "drop") |> + head(8) + + +## ----keep-sims-error, eval = FALSE-------------------------------------------- +# # No bootstrap/jackknife results available. Choose keep.sims = TRUE in fect(). + + +## ----parametric-att, eval = FALSE--------------------------------------------- +# fit_para <- fect(Y ~ D, data = sim_linear, index = c("id", "time"), +# method = "ife", force = "two-way", +# r = 2, CV = FALSE, se = TRUE, nboots = 200, +# keep.sims = TRUE, +# vartype = "parametric", +# time.component.from = "nevertreated", +# parallel = FALSE) +# +# est <- estimand(fit_para, "att", "event.time") +# head(est) +# #> event.time estimate se ci.lo ci.hi n_cells vartype +# #> 1 -39 -0.019958112 0.2427538 -0.4957469 0.4558307 80 parametric +# #> 2 -38 -0.006695018 0.1693391 -0.3385935 0.3252035 80 parametric +# #> ... + diff --git a/vignettes/rscript/03-ife-mc.R b/vignettes/rscript/04-ife-mc.R similarity index 51% rename from vignettes/rscript/03-ife-mc.R rename to vignettes/rscript/04-ife-mc.R index f7e20f5e..a1e89959 100644 --- a/vignettes/rscript/03-ife-mc.R +++ b/vignettes/rscript/04-ife-mc.R @@ -7,6 +7,21 @@ set.seed(1234) data(simdata) +## ----panelview-treatment-ifemc, message = FALSE, warning = FALSE, fig.width = 6, fig.height = 4.5---- +library(panelView) +panelview(Y ~ D, data = simdata, index = c("id", "time"), + axis.lab = "time", xlab = "Time", ylab = "Unit", + gridOff = TRUE, by.timing = TRUE, + background = "white", main = "simdata: Treatment Status") + + +## ----panelview-outcome-ifemc, message = FALSE, warning = FALSE, fig.width = 6, fig.height = 4.5---- +panelview(Y ~ D, data = simdata, index = c("id", "time"), + axis.lab = "time", xlab = "Time", ylab = "Outcome", + theme.bw = TRUE, type = "outcome", by.group = FALSE, + main = "simdata: Outcome") + + ## ----simdata_ife, eval=TRUE, cache = TRUE------------------------------------- out.ife <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), force = "two-way", method = "ife", CV = TRUE, r = c(0, 5), @@ -18,6 +33,18 @@ print(out.ife) plot(out.ife, main = "Estimated ATT (IFEct)") +## ----plot-factors-ifemc, fig.width = 6, fig.height = 4------------------------ +plot(out.ife, type = "factors", main = "Estimated Factors") + + +## ----plot-loadings-ifemc, fig.width = 6, fig.height = 5----------------------- +plot(out.ife, type = "loadings", main = "Factor Loadings") + + +## ----plot-loading-overlap-ifemc, fig.width = 6, fig.height = 5---------------- +plot(out.ife, type = "loading.overlap") + + ## ----simdata_mc, eval=TRUE, cache = TRUE-------------------------------------- out.mc <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), force = "two-way", method = "mc", CV = TRUE, @@ -41,18 +68,32 @@ cat("Selected r:", out.cv$r.cv, "\n") ## ----cv_method_compare, eval=TRUE, cache=TRUE, message=FALSE, results='hide'---- -out.all <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), - method = "ife", CV = TRUE, r = c(0, 5), - cv.method = "all_units", se = FALSE, parallel = TRUE, cores = 16) +out.roll <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), + method = "ife", CV = TRUE, r = c(0, 5), + cv.method = "rolling", se = FALSE, parallel = TRUE, cores = 16) -out.tr <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), - method = "ife", CV = TRUE, r = c(0, 5), - cv.method = "treated_units", se = FALSE, parallel = TRUE, cores = 16) +out.block <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), + method = "ife", CV = TRUE, r = c(0, 5), + cv.method = "block", se = FALSE, parallel = TRUE, cores = 16) ## ----print-cv-method-compare-------------------------------------------------- -cat("cv.method = 'all_units': r.cv =", out.all$r.cv, "\n") -cat("cv.method = 'treated_units': r.cv =", out.tr$r.cv, "\n") +cat("cv.method = 'rolling': r.cv =", out.roll$r.cv, "\n") +cat("cv.method = 'block': r.cv =", out.block$r.cv, "\n") + + +## ----cv-strategies-fig, echo=FALSE, out.width='100%', fig.cap='Block CV (left) versus rolling-window CV (right) on a synthetic 40-unit panel with staggered treatment timing. Both panels use the same random missing pattern. Block CV (panel a) drops random anchors and masks contiguous holdouts (red) flanked by donut buffer (orange). Rolling CV (panel b) samples a fraction of eligible units per fold; for each sampled unit it masks a past-side buffer (orange), a scored holdout (red), and drops everything from the holdout onward (purple). Treated post-treatment cells (dark blue) are never masked.'---- +knitr::include_graphics("fig/cv-strategies.png") + + +## ----rcv_dispatcher_demo, eval=FALSE------------------------------------------ +# fit <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), +# method = "ife", force = "two-way", +# CV = TRUE, r = c(0, 5), +# cv.method = "rolling", +# cv.buffer = 1, cv.nobs = 3, k = 20, cv.prop = 0.1, +# cv.rule = "1se", se = TRUE) +# fit$r.cv # selected r ## ----criterion_compare, eval=TRUE, cache=TRUE, message=FALSE, results='hide'---- @@ -82,13 +123,13 @@ out.mc.p <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), nboots = 200, placeboTest = TRUE, placebo.period = c(-2, 0)) -## ----placebo_ife_plot, eval = TRUE, cache = TRUE, warning = FALSE, fig.width = 6, fig.height = 4.5---- +## ----placebo_ife_plot, eval = TRUE, warning = FALSE, fig.width = 6, fig.height = 4.5---- plot(out.ife.p, ylab = "Effect of D on Y", main = "Estimated ATT (IFE)", - cex.text = 0.8, stats = c("placebo.p","equiv.p")) + stats = c("placebo.p","equiv.p")) -## ----placebo_mc_plot, eval = TRUE, cache = TRUE, warning = FALSE, fig.width = 6, fig.height = 4.5---- -plot(out.mc.p, cex.text = 0.8, stats = c("placebo.p","equiv.p"), +## ----placebo_mc_plot, eval = TRUE, warning = FALSE, fig.width = 6, fig.height = 4.5---- +plot(out.mc.p, stats = c("placebo.p","equiv.p"), main = "Estimated ATT (MC)") @@ -99,14 +140,14 @@ out.mc.loo <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id","time"), method = "mc", force = "two-way", se = TRUE, parallel = TRUE, cores = 16, nboots = 200, loo = TRUE) -## ----pretrend_ife, eval = TRUE, cache = TRUE, fig.width = 6, fig.height = 4.5, warning = FALSE---- +## ----pretrend_ife, eval = TRUE, fig.width = 6, fig.height = 4.5, warning = FALSE---- plot(out.ife.loo, type = "equiv", ylim = c(-4,4), loo = TRUE, - cex.legend = 0.6, main = "Testing Pre-Trend (IFEct)", cex.text = 0.8) + main = "Testing Pre-Trend (IFEct)") -## ----pretrend_mc, eval = TRUE, cache = TRUE, fig.width = 6, fig.height = 4.5, warning = FALSE---- +## ----pretrend_mc, eval = TRUE, fig.width = 6, fig.height = 4.5, warning = FALSE---- plot(out.mc.loo, type = "equiv", ylim = c(-4,4), loo = TRUE, - cex.legend = 0.6, main = "Testing Pre-Trend (MC)", cex.text = 0.8) + main = "Testing Pre-Trend (MC)") ## ----carryover_ife, eval = TRUE, cache = TRUE, message = FALSE, results='hide'---- @@ -121,21 +162,37 @@ out.mc.c <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), nboots = 200, carryoverTest = TRUE, carryover.period = c(1, 3)) -## ----carryover_ife_plot, eval = TRUE, cache = TRUE, warning = FALSE, fig.width = 6, fig.height = 5---- -plot(out.ife.c, type = "exit", ylim = c(-2.5,4.5), - cex.text = 0.8, main = "Carryover Effects (IFE)") +## ----carryover_ife_plot, eval = TRUE, warning = FALSE, fig.width = 6, fig.height = 5---- +plot(out.ife.c, type = "exit", main = "Carryover Effects (IFE)") -## ----carryover_mc_plot, eval = TRUE, cache = TRUE, warning = FALSE, fig.width = 6, fig.height = 5---- +## ----carryover_mc_plot, eval = TRUE, warning = FALSE, fig.width = 6, fig.height = 5---- plot(out.mc.c, type = "exit", ylim = c(-2.5,4.5), - cex.text = 0.8, main = "Carryover Effects (MC)") + main = "Carryover Effects (MC)") -## ----carryover_rm, eval = TRUE, cache = TRUE, message = FALSE, results='hide', fig.width = 6, fig.height = 4.5---- +## ----carryover_rm_fit, eval = TRUE, cache = TRUE, message = FALSE, results='hide'---- out.ife.rm.test <- fect(Y ~ D + X1 + X2, data = simdata, index = c("id", "time"), force = "two-way", method = "ife", r = 2, CV = 0, parallel = TRUE, cores = 16, se = TRUE, carryover.rm = 3, nboots = 200, carryoverTest = TRUE, carryover.period = c(1, 3))# remove three periods -plot(out.ife.rm.test, cex.text = 0.8, stats.pos = c(5, 2.5)) + +## ----carryover_rm, eval = TRUE, fig.width = 6, fig.height = 4.5--------------- +plot(out.ife.rm.test) + + +## ----carryover_rm_only_test, eval = TRUE, fig.width = 6, fig.height = 4.5----- +plot(out.ife.rm.test, highlight = "carryover", + main = "Highlight only the carryover-test periods (blue diamonds)") + + +## ----carryover_rm_only_removed, eval = TRUE, fig.width = 6, fig.height = 4.5---- +plot(out.ife.rm.test, highlight = "carryover.rm", + main = "Highlight only the removed periods (orange triangles)") + + +## ----carryover_rm_fill, eval = TRUE, fig.width = 6, fig.height = 4.5---------- +plot(out.ife.rm.test, highlight.fill = TRUE, + main = "Both test types highlighted, with rectangles") diff --git a/vignettes/rscript/04-cfe.R b/vignettes/rscript/05-cfe.R similarity index 83% rename from vignettes/rscript/04-cfe.R rename to vignettes/rscript/05-cfe.R index 94d003c1..5ab48d78 100644 --- a/vignettes/rscript/04-cfe.R +++ b/vignettes/rscript/05-cfe.R @@ -26,10 +26,9 @@ out.fe.only <- fect(Y ~ D, data = sim_region, ## ----cfe-42-fe-only-plot, fig.width = 6, fig.height = 4.5--------------------- -plot(out.fe.only, cex.text = 0.8, +plot(out.fe.only, stats = c("placebo.p", "equiv.p"), - main = "FE Only — Placebo Test", - cex.main = 0.8, cex.lab = 0.8, cex.axis = 0.8) + main = "FE Only — Placebo Test") ## ----cfe-42-with-region, eval = TRUE, cache = TRUE, message = FALSE, warning = FALSE, results = 'hide'---- @@ -41,10 +40,9 @@ out.cfe.region <- fect(Y ~ D, data = sim_region, ## ----cfe-42-with-region-plot, fig.width = 6, fig.height = 4.5----------------- -plot(out.cfe.region, cex.text = 0.8, +plot(out.cfe.region, stats = c("placebo.p", "equiv.p"), - main = "CFE with Region×Time FE — Placebo Test", - cex.main = 0.8, cex.lab = 0.8, cex.axis = 0.8) + main = "CFE with Region×Time FE — Placebo Test") ## ----cfe-43-fe-baseline, eval = TRUE, cache = TRUE, message = FALSE, warning = FALSE, results = 'hide'---- @@ -56,10 +54,9 @@ out.fe.base <- fect(Y ~ D + X1 + X2, data = simdata, ## ----cfe-43-fe-baseline-plot, fig.width = 6, fig.height = 4.5----------------- -plot(out.fe.base, cex.text = 0.8, +plot(out.fe.base, stats = c("placebo.p", "equiv.p"), - main = "FE Only (simdata) — Placebo Test", - cex.main = 0.8, cex.lab = 0.8, cex.axis = 0.8) + main = "FE Only (simdata) — Placebo Test") ## ----cfe-43-gamma-setup, eval = TRUE------------------------------------------ @@ -76,10 +73,9 @@ out.cfe.z <- fect(Y ~ D + X1 + X2, data = simdata, ## ----cfe-43-with-z-plot, fig.width = 6, fig.height = 4.5---------------------- -plot(out.cfe.z, cex.text = 0.8, +plot(out.cfe.z, stats = c("placebo.p", "equiv.p"), - main = "CFE with Z = L1 — Placebo Test", - cex.main = 0.8, cex.lab = 0.8, cex.axis = 0.8) + main = "CFE with Z = L1 — Placebo Test") ## ----cfe-44-linear-load, eval = TRUE------------------------------------------ @@ -95,10 +91,9 @@ out.fe.lin <- fect(Y ~ D, data = sim_linear, ## ----cfe-44-lin-fe-only-plot, fig.width = 6, fig.height = 4.5----------------- -plot(out.fe.lin, cex.text = 0.8, +plot(out.fe.lin, stats = c("placebo.p", "equiv.p"), - main = "FE Only (Linear Trend DGP) — Placebo Test", - cex.main = 0.8, cex.lab = 0.8, cex.axis = 0.8) + main = "FE Only (Linear Trend DGP) — Placebo Test") ## ----cfe-44-lin-cfe, eval = TRUE, cache = TRUE, message = FALSE, warning = FALSE, results = 'hide'---- @@ -111,10 +106,9 @@ out.cfe.lin <- fect(Y ~ D, data = sim_linear, ## ----cfe-44-lin-cfe-plot, fig.width = 6, fig.height = 4.5--------------------- -plot(out.cfe.lin, cex.text = 0.8, +plot(out.cfe.lin, stats = c("placebo.p", "equiv.p"), - main = "CFE with Linear Trend — Placebo Test", - cex.main = 0.8, cex.lab = 0.8, cex.axis = 0.8) + main = "CFE with Linear Trend — Placebo Test") ## ----cfe-44-sin-load, eval = TRUE--------------------------------------------- @@ -130,10 +124,9 @@ out.fe.trend <- fect(Y ~ D, data = sim_trend, ## ----cfe-44-sin-fe-only-plot, fig.width = 6, fig.height = 4.5----------------- -plot(out.fe.trend, cex.text = 0.8, +plot(out.fe.trend, stats = c("placebo.p", "equiv.p"), - main = "FE Only (Sin Trend DGP) — Placebo Test", - cex.main = 0.8, cex.lab = 0.8, cex.axis = 0.8) + main = "FE Only (Sin Trend DGP) — Placebo Test") ## ----cfe-44-sin-bspline, eval = TRUE, cache = TRUE, message = FALSE, warning = FALSE, results = 'hide'---- @@ -146,10 +139,9 @@ out.cfe.bs <- fect(Y ~ D, data = sim_trend, ## ----cfe-44-sin-bspline-plot, fig.width = 6, fig.height = 4.5----------------- -plot(out.cfe.bs, cex.text = 0.8, +plot(out.cfe.bs, stats = c("placebo.p", "equiv.p"), - main = "CFE with B-spline Trend — Placebo Test", - cex.main = 0.8, cex.lab = 0.8, cex.axis = 0.8) + main = "CFE with B-spline Trend — Placebo Test") ## ----cfe-45-gamma-setup, eval = TRUE------------------------------------------ @@ -184,8 +176,7 @@ out.ife.r2 <- fect(Y ~ D + X1 + X2, data = simdata, ## ----cfe-45-mspe, eval = TRUE, cache = TRUE----------------------------------- -mspe.out <- fect_mspe( - list(FE = out.fe, +mspe.out <- fect_mspe(list(FE = out.fe, CFE_Z = out.cfe.z.only, CFE_Z_F1 = out.cfe.z.f1, IFE_r2 = out.ife.r2), @@ -204,10 +195,9 @@ out.cfe.best <- fect(Y ~ D + X1 + X2, data = simdata, ## ----cfe-45-best-placebo-plot, fig.width = 6, fig.height = 4.5---------------- -plot(out.cfe.best, cex.text = 0.8, +plot(out.cfe.best, stats = c("placebo.p", "equiv.p"), - main = "CFE (Z + 1 Factor) — Placebo Test", - cex.main = 0.8, cex.lab = 0.8, cex.axis = 0.8) + main = "CFE (Z + 1 Factor) — Placebo Test") ## ----cfe-46-zparam-example, eval = FALSE-------------------------------------- @@ -220,3 +210,16 @@ plot(out.cfe.best, cex.text = 0.8, # # Z.param = list(decade = "baseline_gdp", # # political_era = "baseline_pop")) + +## ----cfe-cv-dispatcher, eval = FALSE------------------------------------------ +# fit.cfe <- fect(Y ~ D, data = sim_region, +# index = c("id", "time", "region_time"), +# method = "cfe", force = "two-way", +# CV = TRUE, r = c(0, 3), +# cv.method = "rolling", +# cv.buffer = 1, cv.nobs = 3, k = 20, cv.prop = 0.1, +# cv.rule = "1se", +# se = TRUE, parallel = TRUE, cores = 16, nboots = 200 +# ) +# fit.cfe$r.cv # selected r + diff --git a/vignettes/rscript/07-gsynth.R b/vignettes/rscript/06-gsynth.R similarity index 67% rename from vignettes/rscript/07-gsynth.R rename to vignettes/rscript/06-gsynth.R index b861292e..2fc18924 100644 --- a/vignettes/rscript/07-gsynth.R +++ b/vignettes/rscript/06-gsynth.R @@ -55,15 +55,22 @@ out2 <- fect(Y ~ D + X1 + X2, data = sim_gsynth, index = c("id","time"), +## ----rcv_dispatcher_gsc, eval = FALSE----------------------------------------- +# fit <- fect(Y ~ D + X1 + X2, data = sim_gsynth, index = c("id", "time"), +# method = "gsynth", force = "two-way", +# CV = TRUE, r = c(0, 5), +# cv.method = "rolling", +# cv.buffer = 1, cv.nobs = 3, k = 20, cv.prop = 0.1, +# cv.rule = "1se", +# se = TRUE, vartype = "parametric") +# fit$r.cv # selected r --- use this for downstream inference + + ## ----sim_gap1, fig.height=5, fig.width=7-------------------------------------- a <- plot(out) # by default, type = "gap" print(a) -## ----sim_gap1a, fig.height=5, fig.width=7------------------------------------- -plot(out, theme.bw = FALSE) - - ## ----sim-gap-connected, fig.height=5, fig.width=7----------------------------- plot(out, connected = TRUE) @@ -137,8 +144,7 @@ panelview(turnout ~ policy_edr, data = turnout, ## ----turnout-panelview-outcome, cache = FALSE, warning =FALSE, fig.height=5, fig.width=7---- panelview(turnout ~ policy_edr, data = turnout, index = c("abb","year"), type = "outcome", - main = "EDR Reform and Turnout", - by.group = TRUE) + main = "EDR Reform and Turnout") ## ----turnout_did, cache = TRUE------------------------------------------------ @@ -167,7 +173,7 @@ sort(out_turnout$wgt.implied[,8]) ## ----turnout_gap, fig.height=5, fig.width=7----------------------------------- -plot(out_turnout, xlim = c(-10, 5), ylim=c(-15, 10)) +plot(out_turnout, xlim = c(-10, 5), ylim=c(-10, 10)) ## ----turnout-status-plot, fig.height=12, fig.width=7-------------------------- @@ -184,7 +190,7 @@ plot(out_turnout, type = "counterfactual") plot(out_turnout, type = "counterfactual", id = "WI", main = "Wisconsin") -## ----turnout_box, fig.height=4, fig.width=8----------------------------------- +## ----turnout_box, fig.height=5, fig.width=7----------------------------------- plot(out_turnout, type = "box", xticklabels=c("-20", "-15", "-10", "-5","0","5","10")) @@ -201,6 +207,15 @@ plot(out_turnout, type = "factors", xlab = "Year") plot(out_turnout, type = "loadings") +## ----turnout-cumulative, fig.height=5, fig.width=7---------------------------- +cumu.turnout <- estimand(out_turnout, "att.cumu", "event.time") +esplot(cumu.turnout, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + Count = "n_cells", + main = "Cumulative Effect of EDR Reform on Turnout", + ylab = "Cumulative ATT") + + ## ----create-unbalanced-data--------------------------------------------------- set.seed(123456) turnout.ub <- turnout[-c(which(turnout$abb=="WY")[1:15], @@ -214,14 +229,32 @@ panelview(turnout ~ policy_edr + policy_mail_in + policy_motor, ## ----turnout_ub_est, cache = TRUE, message = FALSE---------------------------- -out_ub <- fect(turnout ~ policy_edr + policy_mail_in + policy_motor, - data = turnout.ub, index = c("abb","year"), - se = TRUE, method = "gsynth", - r = c(0, 5), CV = TRUE, force = "two-way", +out_ub <- fect(turnout ~ policy_edr + policy_mail_in + policy_motor, + data = turnout.ub, index = c("abb","year"), + se = TRUE, method = "gsynth", + r = c(0, 5), CV = TRUE, force = "two-way", parallel = TRUE, cores = 16, min.T0 = 8, nboots = 1000, seed = 02139) +## ----turnout_ub_param, cache = TRUE, message = FALSE-------------------------- +out_ub_param <- fect(turnout ~ policy_edr + policy_mail_in + policy_motor, + data = turnout.ub, index = c("abb","year"), + se = TRUE, method = "gsynth", vartype = "parametric", + r = c(0, 5), CV = TRUE, force = "two-way", + parallel = TRUE, cores = 16, min.T0 = 8, + nboots = 1000, seed = 02139) + + +## ----turnout_ub_ci_compare---------------------------------------------------- +ci_width <- function(out) mean(out$est.att[, "CI.upper"] - + out$est.att[, "CI.lower"], na.rm = TRUE) +data.frame( + vartype = c("bootstrap", "parametric"), + CI_width = c(ci_width(out_ub), ci_width(out_ub_param)) +) + + ## ----turnout_ub_panelview_miss2, fig.height=12, fig.width=7------------------- plot(out_ub, type = "status", xticklabels=c(1920, 1928, 1936, 1944, 1952, 1960, @@ -239,7 +272,72 @@ plot(out_ub, type = "status", xlab = "Year", ylab = "State", ## ----turnout_ub_gap, fig.height=5, fig.width=7-------------------------------- -plot(out_ub, type = "gap", ylim = c(-10, 20)) +plot(out_ub, type = "gap", xlim = c(-10, 5), ylim = c(-10, 15)) + + +## ----turnout_ub_gap_param, fig.height=5, fig.width=7-------------------------- +plot(out_ub_param, type = "gap", xlim = c(-10, 5), ylim = c(-10, 15)) + + +## ----bounded-vs-unbounded-fit, eval = TRUE, cache = TRUE, message = FALSE, results = "hide"---- +# Unbounded gsynth (default v2.2.x behavior --- standard Xu 2017 estimator) +out.unbounded <- fect(Y ~ D, data = sim_gsynth, index = c("id", "time"), + method = "gsynth", r = 2, + se = TRUE, vartype = "parametric", nboots = 100, + CV = FALSE, parallel = FALSE) + +# Bounded gsynth (new in v2.3.0 --- simplex projection) +out.bounded <- fect(Y ~ D, data = sim_gsynth, index = c("id", "time"), + method = "gsynth", r = 2, + loading.bound = "simplex", + se = TRUE, vartype = "parametric", nboots = 100, + CV = FALSE, parallel = FALSE) + + +## ----bounded-vs-unbounded-att------------------------------------------------- +cat("Unbounded ATT =", round(out.unbounded$att.avg, 3), "\n") +cat("Bounded ATT =", round(out.bounded$att.avg, 3), "\n") +cat("\ngamma.loading (CV-selected) =", round(out.bounded$gamma.loading, 4), "\n") +cat("\nPer-treated projection residuals (loading.proj.resid):\n") +print(round(out.bounded$loading.proj.resid, 3)) + + +## ----bounded-vs-unbounded-gap, fig.width = 9, fig.height = 4, message = FALSE---- +library(gridExtra) +gap.un <- plot(out.unbounded, type = "gap", main = "Unbounded gsynth") +gap.bd <- plot(out.bounded, type = "gap", main = "Bounded gsynth (simplex)") +grid.arrange(gap.un, gap.bd, ncol = 2) + + +## ----bounded-vs-unbounded-overlap, fig.width = 9, fig.height = 4-------------- +ov.un <- plot(out.unbounded, type = "loading.overlap", + main = "Unbounded loadings") +ov.bd <- plot(out.bounded, type = "loading.overlap", + main = "Bounded loadings (projected)") +grid.arrange(ov.un, ov.bd, ncol = 2) + + +## ----bounded-vs-unbounded-weights, fig.width = 6.5, fig.height = 5, message = FALSE---- +library(ggplot2) +W.un <- as.matrix(out.unbounded$wgt.implied) +W.bd <- as.matrix(out.bounded$wgt.implied) +df.w <- data.frame( + unbounded = as.numeric(W.un), + bounded = as.numeric(W.bd) +) + +ggplot(df.w, aes(x = unbounded, y = bounded)) + + geom_hline(yintercept = 0, color = "grey80", linewidth = 0.4) + + geom_vline(xintercept = 0, color = "grey80", linewidth = 0.4) + + geom_abline(slope = 1, intercept = 0, + color = "grey60", linetype = "dashed", linewidth = 0.4) + + geom_point(alpha = 0.4, size = 1.4, color = "#3F6A99") + + labs(x = "Unbounded weight (Moore-Penrose pseudo-inverse)", + y = "Bounded weight (simplex-projected)", + title = "Implicit donor weights: bounded vs unbounded", + subtitle = "One point per (treated, control) pair; dashed line is y = x") + + theme_bw(base_size = 11) + + theme(panel.grid.minor = element_blank()) ## ----cfe_nt_demo, eval=TRUE, cache=TRUE, message=FALSE, results='hide'-------- diff --git a/vignettes/rscript/05-hte.R b/vignettes/rscript/08-hte.R similarity index 100% rename from vignettes/rscript/05-hte.R rename to vignettes/rscript/08-hte.R diff --git a/vignettes/rscript/08-panel.R b/vignettes/rscript/09-panel.R similarity index 97% rename from vignettes/rscript/08-panel.R rename to vignettes/rscript/09-panel.R index b73cbd19..9016ea73 100644 --- a/vignettes/rscript/08-panel.R +++ b/vignettes/rscript/09-panel.R @@ -122,13 +122,22 @@ p.twfe ## ----hh_twfeplot3, message = FALSE, warning = FALSE, fig.width = 7, fig.height = 5, cache=TRUE---- twfe.output <- as.data.frame(twfe.est$coeftable) -twfe.output$Time <- c(c(-18:-2),c(0:17)) +twfe.output$Time <- c(c(-18:-2),c(0:17)) p.twfe <- esplot(twfe.output, Period = 'Time', - Estimate = 'Estimate', SE = 'Std. Error', + Estimate = 'Estimate', SE = 'Std. Error', xlim = c(-12,10),start0 = TRUE) p.twfe +## ----hh_twfeplot_connected, message = FALSE, warning = FALSE, fig.width = 7, fig.height = 5, cache=TRUE---- +p.twfe.connected <- esplot(twfe.output, Period = 'Time', + Estimate = 'Estimate', SE = 'Std. Error', + xlim = c(-12, 10), start0 = TRUE, + connected = TRUE, + main = "TWFE event study (connected)") +p.twfe.connected + + ## ----hh_st, message = FALSE, warning = FALSE, fig.width = 6, fig.height = 4.5, cache=TRUE---- df.st <- NULL target.cohorts <- setdiff(unique(df.use$Cohort),"Control") diff --git a/vignettes/rscript/09-sens.R b/vignettes/rscript/10-sens.R similarity index 98% rename from vignettes/rscript/09-sens.R rename to vignettes/rscript/10-sens.R index b65c5d33..94f7408f 100644 --- a/vignettes/rscript/09-sens.R +++ b/vignettes/rscript/10-sens.R @@ -31,7 +31,7 @@ data <- hh2019 head(data) -## ----hh_honest_placebo, warning=FALSE, message=FALSE, cache=FALSE------------- +## ----hh_honest_placebo, warning=FALSE, message=FALSE, cache=TRUE-------------- out.fect.placebo <- fect(nat_rate_ord~indirect, data = hh2019, index = c("bfs","year"), method = 'fe', se = TRUE, diff --git a/vignettes/rscript/06-plots.R b/vignettes/rscript/11-plots.R similarity index 85% rename from vignettes/rscript/06-plots.R rename to vignettes/rscript/11-plots.R index b9bfa8f6..28b79140 100644 --- a/vignettes/rscript/06-plots.R +++ b/vignettes/rscript/11-plots.R @@ -116,6 +116,20 @@ plot(out, main = "Text and Theme Customization") +## ----title-bold-centered------------------------------------------------------ +plot(out, main = "Bold Centered Title") + + theme(plot.title = element_text(hjust = 0.5, face = "bold")) + + +## ----title-multi-------------------------------------------------------------- +plot(out, main = "Centered, Bold, Larger") + + theme(plot.title = element_text(hjust = 0.5, face = "bold", size = 14)) + + +## ----legacy-style-default----------------------------------------------------- +plot(out, legacy.style = TRUE) + + ## ----line-bound-customization------------------------------------------------- plot(out, est.lwidth = 1.5, @@ -169,13 +183,15 @@ plot(out, type = "counterfactual", main = "Counterfactual Plot with Custom Colors") -## ----placebo, cache = TRUE---------------------------------------------------- +## ----placebo_fit, cache = TRUE------------------------------------------------ out_fe_placebo <- fect(Y = "general_sharetotal_A_all", D = "cand_A_all", X = c("cand_H_all", "cand_B_all"), data = gs2020, index = c("district_final", "cycle"), force = "two-way", method = "fe", CV = FALSE, parallel = TRUE, cores = 16, se = TRUE, nboots = 1000, placeboTest = TRUE, placebo.period = c(-2, 0)) + +## ----placebo------------------------------------------------------------------ plot(out_fe_placebo) @@ -188,6 +204,11 @@ plot(out_fe_placebo, connected = TRUE, preset = "grayscale", plot(out_fe_placebo, placebo.color = "green4") +## ----plot-placebo-fill-------------------------------------------------------- +plot(out_fe_placebo, highlight.fill = TRUE, + main = "Placebo test with background rectangle") + + ## ----plot-equiv-bound--------------------------------------------------------- plot(out, type = "equiv", bound = "equiv", tost.threshold = 0.1, ylim = c(-0.15, 0.15)) @@ -215,18 +236,24 @@ plot(out, type = "equiv", plot(out_fe_placebo, type = "exit") -## ----carryover, cache = TRUE-------------------------------------------------- +## ----carryover_fit, cache = TRUE---------------------------------------------- out_fe_carryover <- fect(Y = "general_sharetotal_A_all", D = "cand_A_all", X = c("cand_H_all", "cand_B_all"), data = gs2020, index = c("district_final", "cycle"), force = "two-way", parallel = TRUE, cores = 16, se = TRUE, CV = FALSE, nboots = 1000, carryoverTest = TRUE, carryover.period = c(1, 3)) + + +## ----carryover---------------------------------------------------------------- plot(out_fe_carryover) ## ----plot-cumulative-hh------------------------------------------------------- -plot(effect(out.hh), main = "Cumulative Effect of Indirect Democracy", - ylab = "Cumulative Effect on Naturalization Rate") +cumu.hh <- estimand(out.hh, "att.cumu", "event.time") +esplot(cumu.hh, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + main = "Cumulative Effect of Indirect Democracy", + ylab = "Cumulative Effect on Naturalization Rate") ## ----subset-no-reversals------------------------------------------------------ @@ -257,7 +284,10 @@ out_no_reversals <- fect(Y = "general_sharetotal_A_all", ## ----cumulative-effects------------------------------------------------------- -plot(effect(out_no_reversals), xlim = c(1, 2)) +cumu.gs <- estimand(out_no_reversals, "att.cumu", "event.time") +esplot(cumu.gs, Period = "event.time", + Estimate = "estimate", CI.lower = "ci.lo", CI.upper = "ci.hi", + xlim = c(1, 2)) ## ----plot-box-hte------------------------------------------------------------- @@ -315,10 +345,23 @@ plot(out_ife, type = "factors", include.FE = FALSE, plot(out_ife, type = "loadings", main = "Factor Loadings") +## ----plot-loading-overlap, fig.width = 6, fig.height = 5---------------------- +plot(out_ife, type = "loading.overlap") + + +## ----loading-overlap-r1-fit, cache = TRUE, message = FALSE, warning = FALSE---- +out_ife_r1 <- fect(nat_rate_ord ~ indirect, data = hh2019, + index = c("bfs", "year"), method = "ife", r = 1, + se = TRUE, parallel = TRUE, cores = 16, nboots = 500) + + +## ----plot-loading-overlap-r1, fig.width = 6, fig.height = 5, message = FALSE, warning = FALSE---- +plot(out_ife_r1, type = "loading.overlap") + + ## ----esplot-basic, fig.width = 6, fig.height = 4.5---------------------------- # Create example data from a fect result -es_data <- data.frame( - Time = as.numeric(rownames(out$est.att)), +es_data <- data.frame(Time = as.numeric(rownames(out$est.att)), ATT = out$est.att[, "ATT"], CI.lower = out$est.att[, "CI.lower"], CI.upper = out$est.att[, "CI.upper"]