diff --git a/.Rbuildignore b/.Rbuildignore index 4b8e8a2..e753b78 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -21,3 +21,10 @@ ^CRAN-SUBMISSION$ ^debugging$ ^debugger$ +^\.cursor$ +^\.discussion$ +^\.discussions$ +^GEMINI\.md$ +^README.html$ +^R/ddml_to_did\.R$ +^tests/testthat/test-ddml_to_did\.R$ \ No newline at end of file diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 3abf6f0..2ed1ff1 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -29,13 +29,10 @@ jobs: #r-version: '4.1.0' use-public-rspm: true - ## FIX?? - #- name: Install lme4 - # run: Rscript -e "install.packages('lme4')" - uses: r-lib/actions/setup-r-dependencies@v2 with: - extra-packages: any::pkgdown, local::., cran/lme4@1.1-35 + extra-packages: any::pkgdown, local::. needs: website - name: Build site @@ -44,7 +41,7 @@ jobs: - name: Deploy to GitHub pages 🚀 if: github.event_name != 'pull_request' - uses: JamesIves/github-pages-deploy-action@v4.5.0 + uses: JamesIves/github-pages-deploy-action@v4 with: clean: false branch: gh-pages diff --git a/.gitignore b/.gitignore index 168dbaa..f721321 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,10 @@ inst/doc .direnv /debugging/ /debugger +.cursor/ +.discussion/ +.discussions/ +GEMINI.md +README.html +R/ddml_to_did.R +tests/testthat/test-ddml_to_did.R diff --git a/DESCRIPTION b/DESCRIPTION index 3e0ce05..4000cb8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: ddml Title: Double/Debiased Machine Learning -Version: 0.3.1 -Date: 2025-12-10 +Version: 0.9.0 +Date: 2026-03-06 Authors@R: c( person("Achim", "Ahrens", role = "aut"), person("Christian B", "Hansen", role = "aut"), @@ -23,21 +23,26 @@ RoxygenNote: 7.3.3 Depends: R (>= 4.3) Imports: - methods, - stats, - AER, + generics, + glmnet, + graphics, MASS, Matrix, + methods, nnls, + pbapply, quadprog, - glmnet, ranger, + stats, xgboost Suggests: - sandwich, + AER, covr, - testthat (>= 3.0.0), + CVXR, knitr, - rmarkdown + parallel, + rmarkdown, + sandwich, + testthat (>= 3.0.0) Config/testthat/edition: 3 VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index 0d4a62e..eb7f493 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,34 +1,88 @@ # Generated by roxygen2: do not edit by hand +S3method("[",summary.ddml) +S3method("[[",ral_rep) +S3method(as.list,ddml) +S3method(as.list,ddml_rep) +S3method(as.list,ral) +S3method(as.list,ral_rep) +S3method(coef,ral) +S3method(coef,ral_rep) +S3method(confint,ral) +S3method(confint,ral_rep) +S3method(glance,ddml) +S3method(glance,ddml_rep) +S3method(glance,ral) +S3method(glance,ral_rep) +S3method(hatvalues,ral) +S3method(length,ral_rep) +S3method(lincom,ddml) +S3method(lincom,ddml_rep) +S3method(nobs,ral) +S3method(nobs,ral_rep) +S3method(plot,ral) +S3method(plot,ral_rep) S3method(predict,ensemble) +S3method(predict,mdl_bigGlm) S3method(predict,mdl_glm) S3method(predict,mdl_glmnet) S3method(predict,mdl_ranger) S3method(predict,mdl_xgboost) S3method(predict,ols) -S3method(print,summary.ddml_ate) -S3method(print,summary.ddml_att) -S3method(print,summary.ddml_fpliv) -S3method(print,summary.ddml_late) -S3method(print,summary.ddml_pliv) -S3method(print,summary.ddml_plm) -S3method(summary,ddml_ate) -S3method(summary,ddml_att) -S3method(summary,ddml_fpliv) -S3method(summary,ddml_late) -S3method(summary,ddml_pliv) -S3method(summary,ddml_plm) +S3method(print,ddml_diagnostics) +S3method(print,ddml_rep) +S3method(print,lincom) +S3method(print,lincom_rep) +S3method(print,ral_rep) +S3method(print,summary.ddml) +S3method(print,summary.ddml_rep) +S3method(print,summary.ral) +S3method(print,summary.ral_rep) +S3method(summary,ddml) +S3method(summary,ddml_rep) +S3method(summary,ral) +S3method(summary,ral_rep) +S3method(tidy,ddml) +S3method(tidy,ddml_diagnostics) +S3method(tidy,ddml_rep) +S3method(tidy,ral) +S3method(tidy,ral_rep) +S3method(vcov,ral) +S3method(vcov,ral_rep) export(crosspred) export(crossval) +export(ddml) +export(ddml_apo) export(ddml_ate) export(ddml_att) +export(ddml_attgt) export(ddml_fpliv) export(ddml_late) export(ddml_pliv) export(ddml_plm) +export(ddml_rep) +export(ddml_replicate) +export(diagnostics) +export(ensemble) +export(ensemble_weights) +export(glance) +export(lincom) +export(lincom_weights_did) +export(mdl_bigGlm) export(mdl_glm) export(mdl_glmnet) export(mdl_ranger) export(mdl_xgboost) export(ols) +export(ral) +export(ral_rep) export(shortstacking) +export(tidy) +importFrom(generics,glance) +importFrom(generics,tidy) +importFrom(graphics,plot) +importFrom(stats,coef) +importFrom(stats,confint) +importFrom(stats,hatvalues) +importFrom(stats,nobs) +importFrom(stats,vcov) diff --git a/NEWS.md b/NEWS.md index 1abb319..03cc072 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,9 +1,24 @@ -# ddml 0.3.1 - -* Updates internals of ``ddml::mdl_xgboost()`` with new ``xgboost`` syntax. -* Fixes ``ddml::ddml_fpliv()`` with custom weights. -* Allows for stacking with no positive stacking weights. -* Fixes ``ddml::mdl_glmnet`` predictions for binomial regression. +# ddml 0.9.0 + +* Adds `ddml_attgt()` for staggered DiD and `ddml_apo()` for average potential outcomes. +* Adds `ddml()` constructor for custom DML estimators with user-supplied scores. +* Adds `lincom()` and `lincom_weights_did()` for inference on linear combinations. +* Influence-function-based inference via the `ral` class; all estimators now inherit from `ral`. +* Adds `ddml_rep()` and `ddml_replicate()` for repeated cross-fitting with median, mean, or spectral-norm aggregation. +* Adds `diagnostics()` for MSPE, R-squared, stacking weights, and CVC tests. +* Adds `fitted`/`splits` pass-through to all `ddml_*()` estimators. +* New S3 methods: `plot()`, `as.list()`, `hatvalues()`, `nobs()`, multi-ensemble `tidy()`/`glance()`. +* Adds uniform confidence bands via multiplier bootstrap (`confint(uniform = TRUE)`). +* Adds HC0/HC3 variance estimators, parallel computation, stratified cross-fitting, cluster-aware splitting, and input validation. +* Adds `broom` compatibility. +* Fixes `ddml_fpliv()` with custom weights. +* Breaking changes: + - Inference internals use `$inf_func` instead of `$scores`/`$J`/`$psi_a`/`$psi_b`. + - Utility functions (`crosspred`, `crossval`, `ensemble`, `ensemble_weights`, `shortstacking`) no longer accept `Z`/`newZ`. Pre-concatenate instruments with covariates (e.g., `cbind(X, Z)`). + - `crosspred()` and `shortstacking()` drop `compute_insample_predictions` and `insample_fitted` output. + - `ddml_fpliv()` drops the `enforce_LIE` argument. + - `shortstacking()` drops `shortstack_y`. + - `ddml_*()` estimators drop `subsamples`, `cv_subsamples`, `subsamples_byD`, `cv_subsamples_byD`. Use the new `splits` parameter instead. # ddml 0.3.0 diff --git a/R/AE98.R b/R/AE98.R index 55864c6..97e408a 100644 --- a/R/AE98.R +++ b/R/AE98.R @@ -1,6 +1,6 @@ -#' Random subsample from the data of Angrist & Evans (1991). +#' Random Subsample from the Data of Angrist & Evans (1998) #' -#' @description Random subsample from the data of Angrist & Evans (1991). +#' @description Random subsample from the data of Angrist & Evans (1998). #' #' @format A data frame with 5,000 rows and 13 variables. #' \describe{ diff --git a/R/crosspred.R b/R/crosspred.R index 761ee2d..7ca3ec3 100644 --- a/R/crosspred.R +++ b/R/crosspred.R @@ -1,97 +1,90 @@ -#' Cross-Predictions using Stacking. +#' Cross-Fitted Predictions Using Stacking #' #' @family utilities #' -#' @description Cross-predictions using stacking. +#' @description Cross-fitted predictions using stacking. +#' +#' @details \code{crosspred} implements the cross-fitting step of the +#' Double/Debiased Machine Learning procedure combined with +#' stacking. It produces the cross-fitted nuisance estimates +#' \eqn{\hat{\eta}(X_i)} used in the Neyman orthogonal scores of +#' all \code{ddml_*} estimators. +#' +#' Let \eqn{\{I_1, \ldots, I_S\}} be an \eqn{S}-fold partition of +#' \eqn{\{1, \ldots, n\}}, and denote the training set for fold +#' \eqn{s} by +#' \eqn{\mathcal{T}_s = \{1, \ldots, n\} \setminus I_s}. +#' Given \eqn{J} base learners, the procedure operates on each +#' cross-fitting fold \eqn{s} in three steps: +#' +#' \strong{Step 1 (Stacking weights).} +#' Run \eqn{K}-fold cross-validation on \eqn{\mathcal{T}_s} +#' (via \code{\link{crossval}}) to estimate the MSPE of each +#' base learner, and solve for fold-specific stacking weights +#' \eqn{\hat{w}_s = (\hat{w}_{1,s}, \ldots, \hat{w}_{J,s})'}. +#' +#' \strong{Step 2 (Fit).} +#' Fit each base learner \eqn{j} on the full training set +#' \eqn{\mathcal{T}_s}, yielding \eqn{\hat{f}_{j,s}(\cdot)}. +#' +#' \strong{Step 3 (Predict).} +#' For each \eqn{i \in I_s}, compute the ensemble cross-fitted +#' prediction +#' +#' \eqn{\hat{\eta}(X_i) = \sum_{j=1}^{J} \hat{w}_{j,s} \hat{f}_{j,s}(X_i).} +#' +#' Since every observation belongs to exactly one fold, the result is +#' a complete \eqn{n}-vector of out-of-sample predictions. +#' Crucially, both the stacking weights \eqn{\hat{w}_s} and the +#' base learner fits \eqn{\hat{f}_{j,s}} depend only on +#' \eqn{\mathcal{T}_s}, which does not contain observation +#' \eqn{i}. +#' +#' When a single learner is used (\eqn{J = 1}), no stacking or inner +#' cross-validation is performed: the learner is simply fitted on +#' \eqn{\mathcal{T}_s} and predictions are made for \eqn{I_s}. #' #' @inheritParams crossval -#' @param learners May take one of two forms, depending on whether a single -#' learner or stacking with multiple learners is used for estimation of the -#' predictor. -#' If a single learner is used, \code{learners} is a list with two named -#' elements: -#' \itemize{ -#' \item{\code{what} The base learner function. The function must be -#' such that it predicts a named input \code{y} using a named input -#' \code{X}.} -#' \item{\code{args} Optional arguments to be passed to \code{what}.} -#' } -#' If stacking with multiple learners is used, \code{learners} is a list of -#' lists, each containing four named elements: -#' \itemize{ -#' \item{\code{fun} The base learner function. The function must be -#' such that it predicts a named input \code{y} using a named input -#' \code{X}.} -#' \item{\code{args} Optional arguments to be passed to \code{fun}.} -#' \item{\code{assign_X} An optional vector of column indices -#' corresponding to predictive variables in \code{X} that are passed to -#' the base learner.} -#' \item{\code{assign_Z} An optional vector of column indices -#' corresponding to predictive in \code{Z} that are passed to the -#' base learner.} -#' } -#' Omission of the \code{args} element results in default arguments being -#' used in \code{fun}. Omission of \code{assign_X} (and/or \code{assign_Z}) -#' results in inclusion of all variables in \code{X} (and/or \code{Z}). -#' @param sample_folds Number of cross-fitting folds. -#' @param ensemble_type Ensemble method to combine base learners into final -#' estimate of the conditional expectation functions. Possible values are: -#' \itemize{ -#' \item{\code{"nnls"} Non-negative least squares.} -#' \item{\code{"nnls1"} Non-negative least squares with the constraint -#' that all weights sum to one.} -#' \item{\code{"singlebest"} Select base learner with minimum MSPE.} -#' \item{\code{"ols"} Ordinary least squares.} -#' \item{\code{"average"} Simple average over base learners.} -#' } -#' Multiple ensemble types may be passed as a vector of strings. -#' @param cv_folds Number of folds used for cross-validation in ensemble -#' construction. -#' @param custom_ensemble_weights A numerical matrix with user-specified -#' ensemble weights. Each column corresponds to a custom ensemble -#' specification, each row corresponds to a base learner in \code{learners} -#' (in chronological order). Optional column names are used to name the -#' estimation results corresponding the custom ensemble specification. -#' @param compute_insample_predictions Indicator equal to 1 if in-sample -#' predictions should also be computed. -#' @param compute_predictions_bylearner Indicator equal to 1 if in-sample -#' predictions should also be computed for each learner (rather than the -#' entire ensemble). +#' @inheritParams ddml-intro #' @param subsamples List of vectors with sample indices for cross-fitting. -#' @param cv_subsamples_list List of lists, each corresponding to a subsample +#' @param cv_subsamples List of lists, each corresponding to a subsample #' containing vectors with subsample indices for cross-validation. +#' @param cv_subsamples_list Deprecated; use \code{cv_subsamples} instead. #' @param auxiliary_X An optional list of matrices of length #' \code{sample_folds}, each containing additional observations to calculate #' predictions for. #' #' @return \code{crosspred} returns a list containing the following components: #' \describe{ -#' \item{\code{oos_fitted}}{A matrix of out-of-sample predictions, +#' \item{\code{cf_fitted}}{A matrix of out-of-sample predictions, #' each column corresponding to an ensemble type (in chronological #' order).} #' \item{\code{weights}}{An array, providing the weight #' assigned to each base learner (in chronological order) by the #' ensemble procedures.} -#' \item{\code{is_fitted}}{When \code{compute_insample_predictions = T}. -#' a list of matrices with in-sample predictions by sample fold.} +#' \item{\code{mspe}}{A numeric vector of per-learner out-of-sample +#' MSPEs, computed from cross-fitted residuals.} +#' \item{\code{r2}}{A numeric vector of per-learner out-of-sample +#' R-squared values.} +#' \item{\code{cv_resid_byfold}}{A list (length \code{sample_folds}) +#' of inner cross-validation residual matrices used for ensemble +#' weight estimation. \code{NULL} when a single learner is used.} #' \item{\code{auxiliary_fitted}}{When \code{auxiliary_X} is not #' \code{NULL}, a list of matrices with additional predictions.} -#' \item{\code{oos_fitted_bylearner}}{When -#' \code{compute_predictions_bylearner = T}, a matrix of -#' out-of-sample predictions, each column corresponding to a base -#' learner (in chronological order).} -#' \item{\code{is_fitted_bylearner}}{When -#' \code{compute_insample_predictions = T} and -#' \code{compute_predictions_bylearner = T}, a list of matrices with -#' in-sample predictions by sample fold.} -#' \item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} is -#' not \code{NULL} and \code{compute_predictions_bylearner = T}, a -#' list of matrices with additional predictions for each learner.} +#' \item{\code{cf_fitted_bylearner}}{A matrix of out-of-sample +#' predictions, each column corresponding to a base learner +#' (in chronological order).} +#' \item{\code{cf_resid_bylearner}}{A matrix of out-of-sample +#' residuals (\code{y - cf_fitted_bylearner}), each column +#' corresponding to a base learner.} +#' \item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} +#' is not \code{NULL}, a list of matrices with additional +#' predictions for each learner.} #' } #' @export #' #' @references -#' Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and +#' Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and #' Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. #' #' Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. @@ -107,191 +100,185 @@ #' # in the unit simplex (ensemble_type = "nnls1"). Predictions for each #' # learner are also calculated. #' crosspred_res <- crosspred(y, X, -#' learners = list(list(fun = ols), -#' list(fun = mdl_glmnet)), +#' learners = list(list(what = ols), +#' list(what = mdl_glmnet)), #' ensemble_type = c("average", #' "nnls1", #' "singlebest"), -#' compute_predictions_bylearner = TRUE, #' sample_folds = 2, #' cv_folds = 2, #' silent = TRUE) -#' dim(crosspred_res$oos_fitted) # = length(y) by length(ensemble_type) -#' dim(crosspred_res$oos_fitted_bylearner) # = length(y) by length(learners) -crosspred <- function(y, X, Z = NULL, +#' dim(crosspred_res$cf_fitted) # = length(y) by length(ensemble_type) +#' dim(crosspred_res$cf_fitted_bylearner) # = length(y) by length(learners) +crosspred <- function(y, X, learners, - sample_folds = 2, + sample_folds = 10, ensemble_type = "average", - cv_folds = 5, + cv_folds = 10, custom_ensemble_weights = NULL, - compute_insample_predictions = FALSE, - compute_predictions_bylearner = FALSE, + cluster_variable = seq_along(y), subsamples = NULL, + cv_subsamples = NULL, cv_subsamples_list = NULL, silent = FALSE, - progress = NULL, - auxiliary_X = NULL) { + auxiliary_X = NULL, + parallel = NULL) { + # Backward compatibility for renamed parameter + if (!is.null(cv_subsamples_list)) { + if (!is.null(cv_subsamples)) + stop("Specify cv_subsamples or cv_subsamples_list, not both.", + call. = FALSE) + message("Note: cv_subsamples_list has been renamed to cv_subsamples.") + cv_subsamples <- cv_subsamples_list + }#IF + # Data parameters nobs <- nrow(X) - nlearners <- length(learners) - calc_ensemble <- !("what" %in% names(learners)) - ncustom <- ncol(custom_ensemble_weights) - ncustom <- ifelse(is.null(ncustom), 0, ncustom) + nlearners <- if (is_single_learner(learners)) 1L + else length(learners) + ncustom <- n_custom(custom_ensemble_weights) nensb <- length(ensemble_type) + ncustom - # Create sample fold tuple - if (is.null(subsamples)) { - subsamples <- generate_subsamples(nobs, sample_folds) - }#IF + + # Create crossfitting and cv tuples + indxs <- get_sample_splits(cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + subsamples = subsamples, + cv_subsamples = cv_subsamples) + subsamples <- indxs$subsamples + cv_subsamples <- indxs$cv_subsamples sample_folds <- length(subsamples) + cv_folds <- if (!is.null(cv_subsamples)) + length(cv_subsamples[[1]]) else 0L + if (cv_folds == 0L) + cv_subsamples <- rep(list(NULL), sample_folds) - # Create cv-subsamples tuple - if (is.null(cv_subsamples_list)) { - cv_subsamples_list <- rep(list(NULL), sample_folds) - for (k in 1:sample_folds) { - nobs_k <- nobs - length(subsamples[[k]]) - cv_subsamples_list[[k]] <- generate_subsamples(nobs_k, cv_folds) - }# FOR - }#IF - cv_folds <- length(cv_subsamples_list[[1]]) + # Dispatch fold computation + fold_fun <- function(k) { + crosspred_compute_fold( + k = k, y = y, X = X, + learners = learners, + subsamples = subsamples, + cv_subsamples_k = cv_subsamples[[k]], + ensemble_type = ensemble_type, + cv_folds = cv_folds, + custom_ensemble_weights = custom_ensemble_weights, + nensb = nensb, nlearners = nlearners, + auxiliary_X = auxiliary_X) + }#FOLD_FUN + + fold_results <- with_parallel(sample_folds, fold_fun, + parallel, silent) - # Initialize output matrices - oos_fitted <- matrix(0, nobs, nensb^(calc_ensemble)) - oos_fitted_bylearner <- matrix(0, nobs, nlearners) - is_fitted <- rep(list(NULL), sample_folds) - is_fitted_bylearner <- rep(list(NULL), sample_folds) + # Assemble results from fold_results list + cf_fitted <- matrix(0, nobs, nensb) + cf_fitted_bylearner <- matrix(0, nobs, nlearners) auxiliary_fitted <- rep(list(NULL), sample_folds) auxiliary_fitted_bylearner <- rep(list(NULL), sample_folds) - mspe <- matrix(0, nlearners^(calc_ensemble), sample_folds) - colnames(mspe) <- paste("sample fold ", 1:sample_folds) weights <- array(0, dim = c(nlearners, nensb, sample_folds)) - # Loop over training samples - for (k in 1:sample_folds) { - # Compute fit on training data. Check whether a single model or an ensemble - # should be computed. Check whether the user-supplied response is - # training-sample specific. - if (!calc_ensemble) { - # When a single model should be fitted, call the constructor function. - # Begin with assigning features and response to model arguments. - # Note: this is effectively copying the data -- improvement needed. - learners$args$X <- cbind(X[-subsamples[[k]], ], - Z[-subsamples[[k]], ]) - if ("list" %in% class(y)) { - learners$args$y <- y[[k]] - } else { - learners$args$y <- y[-subsamples[[k]]] - }#IFELSE - # Compute learner - mdl_fit <- do.call(do.call, learners) - # Compute out-of-sample predictions - oos_fitted[subsamples[[k]], ] <- - as.numeric(stats::predict(mdl_fit, cbind(X[subsamples[[k]], ], - Z[subsamples[[k]], ]))) - # Print progress - if (!silent) { - cat(paste0("\r", progress, " sample fold ", k, "/", sample_folds)) - }#IF - } else if (calc_ensemble) { - # When multiple learners are passed, fit an ensemble on the training data. - if ("list" %in% class(y)) { - y_ <- y[[k]] - } else { - y_ <- y[-subsamples[[k]]] - }#IFELSE + cv_resid_byfold <- rep(list(NULL), sample_folds) + for (res in fold_results) { + k <- res$k + cf_fitted[res$test_indices, ] <- res$cf_fitted_rows + if (!is.null(res$weights_k)) weights[, , k] <- res$weights_k + cv_resid_byfold[[k]] <- res$cv_resid_byfold_k + auxiliary_fitted[[k]] <- res$auxiliary_fitted_k + cf_fitted_bylearner[res$test_indices, ] <- + res$cf_fitted_bylearner_rows + auxiliary_fitted_bylearner[[k]] <- res$auxiliary_fitted_bylearner_k + }#FOR - # Compile progress-preamble - if (!silent) { - progress_k = paste0(progress, - "sample fold ", k, - "/", sample_folds) - # Print immediately if no cv is needed - cv_stacking <- c("stacking", "stacking_nn", - "stacking_01", "stacking_best") - if (!any(cv_stacking %in% ensemble_type)) cat(paste0("\r", progress_k)) - }#IF + # Assign dimnames to weights and cf_fitted + wnames <- fold_results[[1]]$weight_colnames + dimnames(weights) <- list( + NULL, wnames, + paste("sample fold ", seq_len(sample_folds))) + colnames(cf_fitted) <- wnames - # Compute ensemble - mdl_fit <- ensemble(y_, X[-subsamples[[k]], , drop = F], - Z[-subsamples[[k]], , drop = F], - ensemble_type, learners, - cv_folds, cv_subsamples_list[[k]], - custom_weights = custom_ensemble_weights, - silent = silent, - progress = paste0(progress_k, ", ")) - # Compute out-of-sample predictions - oos_fitted[subsamples[[k]], ] <- - as.numeric(predict.ensemble(mdl_fit, - newdata = X[subsamples[[k]], , - drop = F], - newZ = Z[subsamples[[k]], , - drop = F])) + # Compute per-learner OOS residuals + cf_resid_bylearner <- drop(y) - cf_fitted_bylearner - # Record ensemble weights - weights[, , k] <- mdl_fit$weights - # Record model MSPEs when weights were computed via cross validation - if (!is.null(mdl_fit$cv_res)) { - mspe[,k] <- mdl_fit$cv_res$mspe - }#IF - }#IFELSE - # Assign names to weights - dimnames(weights) <- list(NULL, colnames(mdl_fit$weights), - paste("sample fold ", 1:sample_folds)) - # Compute in-sample predictions (optional) - if (compute_insample_predictions) { - if (!calc_ensemble) { - is_fitted[[k]] <- stats::predict(mdl_fit, cbind(X[-subsamples[[k]], ], - Z[-subsamples[[k]], ])) - } else if (calc_ensemble) { - is_fitted[[k]] <- predict.ensemble(mdl_fit, - newdata = X[-subsamples[[k]], ,drop = F], - newZ = Z[-subsamples[[k]], , drop = F]) - }#IFELSE - }#IF - # Compute auxilliary predictions (optional) - if (!is.null(auxiliary_X)) { - auxiliary_fitted[[k]] <- stats::predict(mdl_fit, - auxiliary_X[[k]]) - }#if - # Compute out-of-sample predictions for each learner (optional) - if (compute_predictions_bylearner) { - # Adjust ensemble weights - mdl_fit$weights <- diag(1, nlearners) - oos_fitted_bylearner[subsamples[[k]], ] <- - as.numeric(predict.ensemble(mdl_fit, - newdata = X[subsamples[[k]], , drop = F], - newZ = Z[subsamples[[k]], , drop = F])) - # Compute in-sample predictions (optional) - if (compute_insample_predictions) { - is_fitted_bylearner[[k]] <- - predict.ensemble(mdl_fit, newdata = X[-subsamples[[k]], ,drop = F], - newZ = Z[-subsamples[[k]], , drop = F]) - }#IF - # Compute auxilliary predictions by learner (optional) - if (!is.null(auxiliary_X)) { - auxiliary_fitted_bylearner[[k]] <- stats::predict(mdl_fit, - auxiliary_X[[k]]) - }#if - }#IF - }#FOR - # When multiple ensembles are computed, need to reorganize is_fitted - if (compute_insample_predictions & calc_ensemble & nensb > 1) { - # Loop over each ensemble type to creat list of is_fitted's - new_is_fitted <- rep(list(rep(list(1), sample_folds)), nensb) - for (i in 1:nensb) { - for (k in 1:sample_folds) { - new_is_fitted[[i]][[k]] <- is_fitted[[k]][, i, drop = F] - }#FOR - }#FOR - is_fitted <- new_is_fitted + # Per-learner OOS mspe and r-squared (always available) + oos_stats <- compute_mspe_r2(cf_resid_bylearner, y) + mspe <- oos_stats$mspe + r2 <- oos_stats$r2 + + if (nlearners > 1) { + # Ensemble OOS mspe and r-squared + cf_resid_ens <- drop(y) - cf_fitted + oos_stats_ens <- compute_mspe_r2(cf_resid_ens, y) + + mspe <- c(mspe, oos_stats_ens$mspe) + r2 <- c(r2, oos_stats_ens$r2) + names(mspe) <- names(r2) <- c(paste0("learner_", seq_len(nlearners)), + wnames) }#IF + # Organize and return output - if (!calc_ensemble) weights <- mspe <- NULL - output <- list(oos_fitted = oos_fitted, - weights = weights, mspe = mspe, - is_fitted = is_fitted, + output <- list(cf_fitted = cf_fitted, + weights = weights, mspe = mspe, r2 = r2, + cv_resid_byfold = cv_resid_byfold, auxiliary_fitted = auxiliary_fitted, - oos_fitted_bylearner = oos_fitted_bylearner, - is_fitted_bylearner = is_fitted_bylearner, + cf_fitted_bylearner = cf_fitted_bylearner, + cf_resid_bylearner = cf_resid_bylearner, auxiliary_fitted_bylearner = auxiliary_fitted_bylearner) return(output) }#CROSSPRED + +crosspred_compute_fold <- function( + k, y, X, learners, subsamples, cv_subsamples_k, + ensemble_type, cv_folds, custom_ensemble_weights, + nensb, nlearners, auxiliary_X) { + + test_idx <- subsamples[[k]] + train_idx <- -test_idx + + # Always route through ensemble() (handles J=1 trivially) + mdl_fit <- ensemble(y[train_idx], + X[train_idx, , drop = FALSE], + ensemble_type, learners, + cv_folds, cv_subsamples_k, + custom_weights = custom_ensemble_weights, + silent = TRUE) + cf_fitted_rows <- + as.numeric(stats::predict(mdl_fit, + newdata = X[test_idx, + , drop = FALSE])) + + # Ensemble metadata + weights_k <- mdl_fit$weights + cv_resid_byfold_k <- if (!is.null(mdl_fit$cv_results)) { + mdl_fit$cv_results$cv_resid + } + weight_colnames <- colnames(mdl_fit$weights) + + # Auxiliary predictions (optional) + auxiliary_fitted_k <- NULL + if (!is.null(auxiliary_X)) { + auxiliary_fitted_k <- stats::predict(mdl_fit, + auxiliary_X[[k]]) + }#IF + + # By-learner predictions + cf_fitted_bylearner_rows <- stats::predict( + mdl_fit, newdata = X[test_idx, , drop = FALSE], + type = "bylearner") + auxiliary_fitted_bylearner_k <- NULL + if (!is.null(auxiliary_X)) { + auxiliary_fitted_bylearner_k <- stats::predict( + mdl_fit, auxiliary_X[[k]], type = "bylearner") + }#IF + + list( + k = k, + test_indices = test_idx, + cf_fitted_rows = cf_fitted_rows, + weights_k = weights_k, + cv_resid_byfold_k = cv_resid_byfold_k, + weight_colnames = weight_colnames, + auxiliary_fitted_k = auxiliary_fitted_k, + cf_fitted_bylearner_rows = cf_fitted_bylearner_rows, + auxiliary_fitted_bylearner_k = auxiliary_fitted_bylearner_k + ) +}#CROSSPRED_COMPUTE_FOLD diff --git a/R/crossval.R b/R/crossval.R index 9c1b41a..3d95613 100644 --- a/R/crossval.R +++ b/R/crossval.R @@ -1,46 +1,84 @@ -#' Estimator of the Mean Squared Prediction Error using Cross-Validation. +#' Estimator of the Mean Squared Prediction Error Using Cross-Validation #' #' @family utilities #' #' @description Estimator of the mean squared prediction error of #' different learners using cross-validation. #' +#' @details \code{crossval} estimates the mean squared prediction error +#' (MSPE) of \eqn{J} base learners via \eqn{K}-fold +#' cross-validation. It is the inner workhorse of the stacking +#' machinery used by \code{\link{ensemble_weights}} to determine +#' ensemble weights. +#' +#' Given a generic conditional expectation function \eqn{f_0(\cdot)} +#' (e.g., \eqn{E[Y\vert X]}, \eqn{E[D\vert X]}), let +#' \eqn{\{I_1, \ldots, I_K\}} be a \eqn{K}-fold partition of +#' \eqn{\{1, \ldots, n\}} and let \eqn{\hat{f}_j^{(-k)}} denote +#' learner \eqn{j} trained on all observations outside fold +#' \eqn{I_k}. The out-of-sample residual for observation +#' \eqn{i \in I_k} is +#' +#' \eqn{\hat{e}_{i,j} = y_i - \hat{f}_j^{(-k)}(X_i).} +#' +#' Since every observation belongs to exactly one fold, this yields a +#' complete \eqn{n \times J} residual matrix. The cross-validated +#' MSPE for learner \eqn{j} is +#' +#' \eqn{\widehat{\textrm{MSPE}}_j = n^{-1} \sum_{i=1}^{n} \hat{e}_{i,j}^2,} +#' +#' and the cross-validated \eqn{R^2} is +#' +#' \eqn{\hat{R}^2_j = 1 - \widehat{\textrm{MSPE}}_j \,/\, \hat{\sigma}^2_y,} +#' +#' where \eqn{\hat{\sigma}^2_y} is the sample variance of \eqn{y}. +#' #' @inheritParams ddml_plm #' @param y The outcome variable. #' @param X A (sparse) matrix of predictive variables. -#' @param Z Optional additional (sparse) matrix of predictive variables. -#' @param learners \code{learners} is a list of lists, each containing four +#' @param learners \code{learners} is a list of lists, each containing three #' named elements: #' \itemize{ -#' \item{\code{fun} The base learner function. The function must be +#' \item{\code{what} The base learner function. The function must be #' such that it predicts a named input \code{y} using a named input #' \code{X}.} -#' \item{\code{args} Optional arguments to be passed to \code{fun}.} +#' \item{\code{args} Optional arguments to be passed to \code{what}.} #' \item{\code{assign_X} An optional vector of column indices #' corresponding to variables in \code{X} that are passed to #' the base learner.} -#' \item{\code{assign_Z} An optional vector of column indices -#' corresponding to variables in \code{Z} that are passed to the -#' base learner.} #' } #' Omission of the \code{args} element results in default arguments being -#' used in \code{fun}. Omission of \code{assign_X} (and/or \code{assign_Z}) -#' results in inclusion of all predictive variables in \code{X} (and/or -#' \code{Z}). +#' used in \code{what}. Omission of \code{assign_X} +#' results in inclusion of all predictive variables in \code{X}. #' @param cv_folds Number of folds used for cross-validation. #' @param cv_subsamples List of vectors with sample indices for #' cross-validation. -#' @param progress String to print before learner and cv fold progress. +#' @param parallel An optional named list with parallel processing +#' options. When \code{NULL} (the default), computation is +#' sequential. Supported fields: +#' \describe{ +#' \item{\code{cores}}{Number of cores to use.} +#' \item{\code{export}}{Character vector of object names to +#' export to parallel workers (for custom learners that +#' reference global objects).} +#' \item{\code{packages}}{Character vector of additional +#' package names to load on workers (for custom learners +#' that use packages not imported by \code{ddml}).} +#' } #' #' @return \code{crossval} returns a list containing the following components: #' \describe{ #' \item{\code{mspe}}{A vector of MSPE estimates, -#' each corresponding to a base learners (in chronological order).} -#' \item{\code{oos_resid}}{A matrix of out-of-sample prediction errors, -#' each column corresponding to a base learners (in chronological +#' each corresponding to a base learner (in chronological #' order).} -#' \item{\code{cv_subsamples}}{Pass-through of \code{cv_subsamples}. -#' See above.} +#' \item{\code{r2}}{A vector of cross-validated \eqn{R^2} +#' values, each corresponding to a base learner (in +#' chronological order).} +#' \item{\code{cv_resid}}{A matrix of out-of-sample residuals, +#' each column corresponding to a base learner (in +#' chronological order).} +#' \item{\code{cv_subsamples}}{Pass-through of +#' \code{cv_subsamples}. See above.} #' } #' @export #' @@ -51,88 +89,82 @@ #' #' # Compare ols, lasso, and ridge using 4-fold cross-validation #' cv_res <- crossval(y, X, -#' learners = list(list(fun = ols), -#' list(fun = mdl_glmnet), -#' list(fun = mdl_glmnet, +#' learners = list(list(what = ols), +#' list(what = mdl_glmnet), +#' list(what = mdl_glmnet, #' args = list(alpha = 0))), #' cv_folds = 4, #' silent = TRUE) #' cv_res$mspe -crossval <- function(y, X, Z = NULL, +crossval <- function(y, X, learners, - cv_folds = 5, + cv_folds = 10, + cluster_variable = seq_along(y), cv_subsamples = NULL, silent = FALSE, - progress = NULL) { + parallel = NULL) { + # Normalize learner specs before parallel dispatch + learners <- normalize_learners(learners) + + # Validate inputs + validate_inputs(y = y, X = X, learners = learners, + cv_folds = cv_folds) + # Data parameters nobs <- length(y) nlearners <- length(learners) - # Create cv sample fold tuple - if (is.null(cv_subsamples)) { - cv_subsamples <- generate_subsamples(nobs, cv_folds) - }#IF + # Get cv subsample tuple + indx <- get_crossfit_indices(cluster_variable, + sample_folds = cv_folds, + subsamples = cv_subsamples) + cv_subsamples <- indx$subsamples cv_folds <- length(cv_subsamples) nobs <- length(unlist(cv_subsamples)) # In case subsamples are user-provided - # Compute out-of-sample errors - cv_res <- sapply(1:(cv_folds * nlearners), function(x) { - # Select model and cv-fold for this job - j <- ceiling(x / cv_folds) # jth model - i <- x - cv_folds * (ceiling(x / cv_folds) - 1) # ith CV fold + # Define the computation function + cv_fun <- function(x) { + j <- (x - 1) %/% cv_folds + 1 + i <- (x - 1) %% cv_folds + 1 fold_x <- cv_subsamples[[i]] - # Print progress - if (!silent) { - cat(paste0("\r", progress, - "learner ", j, "/", nlearners, - ", cv fold ", i, "/", cv_folds)) - }#IF - # Compute model for this fold crossval_compute(test_sample = fold_x, learner = learners[[j]], - y, X, Z) - })#SAPPLY + y, X) + }#CV_FUN + + # Compute out-of-sample errors + njobs <- cv_folds * nlearners + cv_res <- with_parallel(njobs, cv_fun, parallel, silent) # Compile residual matrix - oos_resid <- unlist(cv_res) - oos_resid <- matrix(oos_resid, nobs, nlearners) - oos_resid <- oos_resid[order(unlist(cv_subsamples)), , drop = FALSE] + cv_resid <- unlist(cv_res) + cv_resid <- matrix(cv_resid, nobs, nlearners) + cv_resid <- cv_resid[order(unlist(cv_subsamples)), , drop = FALSE] - # Compute MSPE by learner - mspe <- colMeans(oos_resid^2) + # Compute MSPE and R-squared by learner + cv_stats <- compute_mspe_r2(cv_resid, y) + mspe <- cv_stats$mspe + r2 <- cv_stats$r2 # Organize and return output - output <- list(mspe = mspe, - oos_resid = oos_resid, + output <- list(mspe = mspe, r2 = r2, + cv_resid = cv_resid, cv_subsamples = cv_subsamples) return(output) }#CROSSVAL # Complementary functions ====================================================== crossval_compute <- function(test_sample, learner, - y, X, Z = NULL) { - # Check whether X, Z assignment has been specified. If not, include all. - if (is.null(learner$assign_X)) learner$assign_X <- 1:ncol(X) - if (is.null(learner$assign_Z) & !is.null(Z)) learner$assign_Z <- 1:ncol(Z) - - # Extract model arguments - mdl_fun <- list(what = learner$fun, args = learner$args) - assign_X <- learner$assign_X - assign_Z <- learner$assign_Z - - # Compute model for this fold - # Note: this is effectively copying the data -- improvement needed. - mdl_fun$args$y <- y[-test_sample] - mdl_fun$args$X <- cbind(X[-test_sample, assign_X, drop = F], - Z[-test_sample, assign_Z, drop = F]) - mdl_fit <- do.call(do.call, mdl_fun) - - # Compute out of sample residuals - oos_fitted <- stats::predict(mdl_fit, - cbind(X[test_sample, assign_X, drop = F], - Z[test_sample, assign_Z, drop = F])) - oos_resid <- y[test_sample] - methods::as(oos_fitted, "matrix") - - # Return residuals and cv_Z - return(oos_resid) + y, X) { + assign_X <- if (is.null(learner$assign_X)) seq_len(ncol(X)) + else learner$assign_X + mdl_fit <- fit_learner(learner, + y[-test_sample], + X[-test_sample, , drop = FALSE]) + cv_fitted <- stats::predict(mdl_fit, + X[test_sample, assign_X, + drop = FALSE]) + if (!is.matrix(cv_fitted)) cv_fitted <- as.matrix(cv_fitted) + cv_resid <- y[test_sample] - cv_fitted + return(cv_resid) }#CROSSVAL_COMPUTE diff --git a/R/ddml-package.R b/R/ddml-package.R new file mode 100644 index 0000000..6cfff95 --- /dev/null +++ b/R/ddml-package.R @@ -0,0 +1,28 @@ +#' ddml: Double/Debiased Machine Learning +#' +#' @description Estimate common causal parameters using +#' double/debiased machine learning as proposed by +#' Chernozhukov et al. (2018). \pkg{ddml} simplifies +#' estimation based on (short-)stacking as discussed in +#' Ahrens et al. (2024), which leverages multiple base +#' learners to increase robustness to the underlying +#' data generating process. +#' +#' @references +#' Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). +#' "Model Averaging and Double Machine Learning." Journal +#' of Applied Econometrics, 40(3), 249-269. +#' +#' Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, +#' Schaffer M E, Wiemann T (2026). "An Introduction to +#' Double/Debiased Machine Learning." Journal of +#' Economic Literature, forthcoming. +#' +#' Chernozhukov V, Chetverikov D, Demirer M, Duflo E, +#' Hansen C B, Newey W, Robins J (2018). +#' "Double/debiased machine learning for treatment and +#' structural parameters." The Econometrics Journal, +#' 21(1), C1-C68. +#' +#' @keywords internal +"_PACKAGE" diff --git a/R/ddml.R b/R/ddml.R index d8051dc..67a37d2 100644 --- a/R/ddml.R +++ b/R/ddml.R @@ -1,15 +1,692 @@ -#' ddml: Double/Debiased Machine Learning in R +#' Intro to Double/Debiased Machine Learning #' -#' @description Estimate common causal parameters using double/debiased machine -#' learning as proposed by Chernozhukov et al. (2018). -#' 'ddml' simplifies estimation based on (short-)stacking, which leverages -#' multiple base learners to increase robustness to the underlying -#' data generating process. +#' @name ddml-intro +#' +#' @description All \code{ddml_*} estimators (\code{\link{ddml_plm}}, +#' \code{\link{ddml_pliv}}, \code{\link{ddml_fpliv}}, +#' \code{\link{ddml_ate}}, \code{\link{ddml_att}}, +#' \code{\link{ddml_late}}, \code{\link{ddml_apo}}) return +#' objects that inherit from S3 class \code{"ddml"}. +#' +#' Each object is a list containing the components described below. +#' Estimator-specific fields (e.g., pass-through learner +#' arguments) are documented on the individual estimator pages. +#' +#' The \code{ddml()} constructor can also be used directly to build +#' a \code{"ddml"} object from user-supplied score components, +#' enabling implementation of custom DML estimators that inherit +#' all S3 methods. +#' +#' @details All \code{ddml_*} estimators target a low-dimensional +#' parameter \eqn{\theta_0} identified by a moment condition +#' +#' \deqn{E[m(W; \theta_0, \eta_0)] = 0,} +#' +#' where \eqn{W} denotes observed random variables and +#' \eqn{\eta_0} is a (potentially high-dimensional) nuisance +#' parameter. Throughout, the score \eqn{m} is assumed to be +#' \emph{Neyman orthogonal}. +#' +#' Estimation proceeds via cross-fitting: the sample is randomly +#' partitioned into \eqn{K} folds \eqn{\{I_k\}_{k=1}^K}. For +#' each fold \eqn{k}, nuisance parameters are estimated on the +#' complementary folds (\eqn{\hat\eta_{-k}}) and the scores are +#' evaluated on fold \eqn{k}. The DML estimator +#' \eqn{\hat\theta} solves +#' +#' \deqn{\frac{1}{n} \sum_{k=1}^{K} \sum_{i \in I_k} +#' m(W_i; \hat\theta, \hat\eta_{-k}) = 0.} +#' +#' Inference is based on the influence function. Define the Jacobian +#' +#' \deqn{J(\theta, \eta) = E\!\left[ +#' \frac{\partial m(W; \theta, \eta)} +#' {\partial \theta'}\right]} +#' +#' and the influence function +#' +#' \deqn{\phi_\theta(W_i; \theta, \eta, J) +#' = -J^{-1}\,m(W_i; \theta, \eta).} +#' +#' The variance of \eqn{\hat\theta} is then estimated by +#' +#' \deqn{\hat{V} = \frac{1}{n^2} \sum_i +#' \phi_\theta(W_i; \hat\theta, \hat\eta_{-k(i)}, +#' \hat{J})\,\phi_\theta(W_i; \hat\theta, +#' \hat\eta_{-k(i)}, \hat{J})'}, +#' +#' where \eqn{\hat{J}} is the sample analog of the Jacobian: +#' +#' \deqn{\hat{J} = \frac{1}{n} \sum_i +#' \frac{\partial m(W_i; \hat\theta, \hat\eta_{-k(i)})} +#' {\partial \theta'}.} +#' +#' HC1 and HC3 variance estimators are described in +#' \code{\link{vcov.ral}}. The leverage +#' (see \code{\link{hatvalues.ral}}) for the DML estimator +#' is +#' +#' \deqn{h_\theta(W_i; \theta, \eta, J) +#' = \mathrm{tr}\!\left( +#' -J^{-1} \frac{1}{n} +#' \frac{\partial m(W_i; \theta, \eta)} +#' {\partial \theta'}\right),} +#' +#' and its sample analog is +#' \eqn{\hat{h}_{\theta,i} = h_\theta(W_i; \hat\theta, +#' \hat\eta_{-k(i)}, \hat{J})}, stored in +#' \code{dinf_dtheta}. +#' +#' Under regularity conditions and sufficient convergence of +#' \eqn{\hat\eta}, the DML estimator is asymptotically normal: +#' +#' \deqn{\sqrt{n}\,\hat{V}^{-1/2}(\hat\theta - \theta_0) +#' \overset{d}{\to} N(0, I).} +#' +#' Further details and regularity conditions are given in +#' Chernozhukov et al. (2018). The specific forms of the +#' score \eqn{m} and Jacobian \eqn{J} for each estimator +#' are documented on their respective help pages (e.g., +#' \code{\link{ddml_plm}}, \code{\link{ddml_ate}}). #' #' @references -#' Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C B, Newey W, -#' Robins J (2018). "Double/debiased machine learning for treatment and -#' structural parameters." The Econometrics Journal, 21(1), C1-C68. +#' Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, +#' Wiemann T (2026). "An Introduction to Double/Debiased Machine +#' Learning." Journal of Economic Literature, forthcoming. +#' +#' Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C B, +#' Newey W, Robins J (2018). "Double/debiased machine learning +#' for treatment and structural parameters." The Econometrics +#' Journal, 21(1), C1-C68. +#' +#' @section Common output components: +#' \describe{ +#' \item{\code{coefficients}}{A matrix of estimated target +#' parameters: rows correspond to components of +#' \eqn{\theta}, columns to ensemble types.} +#' \item{\code{ensemble_weights}}{A named list. Each element +#' is a weight matrix (or 3D array when +#' \code{shortstack = TRUE}) showing the weight assigned +#' to each base learner by the ensemble procedure for +#' the corresponding nuisance equation.} +#' \item{\code{mspe}}{A named list of numeric vectors +#' containing per-learner out-of-sample MSPEs, computed +#' from cross-fitted residuals.} +#' \item{\code{r2}}{A named list of numeric vectors +#' containing per-learner out-of-sample R-squared values.} +#' \item{\code{inf_func}}{A 3D array of evaluated influence +#' functions (\code{n x p x nensb}).} +#' \item{\code{dinf_dtheta}}{An optional 4D array of dimension +#' \code{(n x p x p x nensb)} containing the derivatives of the +#' influence functions with respect to \eqn{\theta}. Used +#' internally by \code{\link{hatvalues.ral}} for HC3 +#' inference.} +#' \item{\code{scores}}{A 3D array of evaluated Neyman +#' orthogonal scores (\code{n x p x nensb}).} +#' \item{\code{J}}{A 3D array of evaluated Jacobians +#' (\code{p x p x nensb}).} +#' \item{\code{fitted}}{A named list of per-equation +#' cross-fitted prediction objects. Can be passed back +#' via the \code{fitted} argument together with +#' \code{splits} to skip cross-fitting on +#' re-estimation.} +#' \item{\code{splits}}{The data splitting structure +#' (subsamples, CV subsamples, and any stratification +#' indices).} +#' \item{\code{ensemble_type}}{Character vector of ensemble +#' types used.} +#' \item{\code{cluster_variable}}{The cluster variable +#' vector used for sample splitting and inference.} +#' \item{\code{nobs}}{Number of observations.} +#' \item{\code{sample_folds}}{Number of cross-fitting folds.} +#' \item{\code{shortstack}}{Logical indicating whether +#' short-stacking was used.} +#' \item{\code{call}}{The matched call.} +#' \item{\code{coef_names}}{Character vector of coefficient +#' names.} +#' \item{\code{estimator_name}}{Character string identifying +#' the estimator (e.g., \code{"Partially Linear Model"}).} +#' } +#' +#' @section S3 methods: +#' The following generic methods are available for all +#' \code{ddml} objects: \code{\link{summary.ddml}}, +#' \code{\link{coef.ral}}, \code{\link{vcov.ral}}, +#' \code{\link{confint.ral}}, \code{\link{hatvalues.ral}}, +#' \code{\link{nobs.ral}}, \code{\link{tidy.ddml}}, +#' \code{\link{glance.ddml}}, and +#' \code{\link{diagnostics}}. +#' +#' @param y The outcome variable. +#' @param D A matrix of endogenous variables. +#' @param X A (sparse) matrix of control variables. +#' @param learners May take one of two forms, depending on whether a +#' single learner or stacking with multiple learners is used for +#' estimation of the conditional expectation functions. +#' If a single learner is used, \code{learners} is a list with +#' two named elements: +#' \itemize{ +#' \item{\code{what} The base learner function. The function +#' must be such that it predicts a named input \code{y} +#' using a named input \code{X}.} +#' \item{\code{args} Optional arguments to be passed to +#' \code{what}.} +#' } +#' If stacking with multiple learners is used, \code{learners} is +#' a list of lists, each containing three named elements: +#' \itemize{ +#' \item{\code{what} The base learner function. The function +#' must be such that it predicts a named input \code{y} +#' using a named input \code{X}.} +#' \item{\code{args} Optional arguments to be passed to +#' \code{what}.} +#' \item{\code{assign_X} An optional vector of column indices +#' corresponding to control variables in \code{X} that +#' are passed to the base learner.} +#' } +#' Omission of the \code{args} element results in default +#' arguments being used in \code{what}. Omission of +#' \code{assign_X} results in inclusion of all variables in +#' \code{X}. +#' @param sample_folds Number of cross-fitting folds. +#' @param ensemble_type Ensemble method to combine base learners into +#' final estimate of the conditional expectation functions. +#' Possible values are: +#' \itemize{ +#' \item{\code{"nnls"} Non-negative least squares.} +#' \item{\code{"nnls1"} Non-negative least squares with the +#' constraint that all weights sum to one.} +#' \item{\code{"singlebest"} Select base learner with minimum +#' MSPE.} +#' \item{\code{"ols"} Ordinary least squares.} +#' \item{\code{"average"} Simple average over base learners.} +#' } +#' Multiple ensemble types may be passed as a vector of strings. +#' @param shortstack Boolean to use short-stacking. +#' @param cv_folds Number of folds used for cross-validation in +#' ensemble construction. +#' @param custom_ensemble_weights A numerical matrix with +#' user-specified ensemble weights. Each column corresponds to a +#' custom ensemble specification, each row corresponds to a base +#' learner in \code{learners} (in chronological order). Optional +#' column names are used to name the estimation results +#' corresponding the custom ensemble specification. +#' @param cluster_variable A vector of cluster indices. +#' @param silent Boolean to silence estimation updates. +#' @param parallel An optional named list with parallel processing +#' options. When \code{NULL} (the default), computation is +#' sequential. Supported fields: +#' \describe{ +#' \item{\code{cores}}{Number of cores to use.} +#' \item{\code{export}}{Character vector of object names to +#' export to parallel workers (for custom learners that +#' reference global objects).} +#' \item{\code{packages}}{Character vector of additional +#' package names to load on workers (for custom learners +#' that use packages not imported by \code{ddml}).} +#' } +#' @param fitted An optional named list of per-equation cross-fitted +#' predictions, typically obtained from a previous fit via +#' \code{fit$fitted}. When supplied (together with \code{splits}), +#' base learners are not re-fitted; only ensemble weights are +#' recomputed. This allows fast re-estimation with a different +#' \code{ensemble_type}. See \code{\link{ddml_plm}} for +#' an example. +#' @param splits An optional list of sample split objects, typically +#' obtained from a previous fit via \code{fit$splits}. Must be +#' supplied when \code{fitted} is provided. Can also be used +#' standalone to provide pre-computed sample folds. +#' @param save_crossval Logical indicating whether to store the inner +#' cross-validation residuals used for ensemble weight +#' computation. Default \code{TRUE}. When \code{TRUE}, subsequent +#' pass-through calls with data-driven ensembles (e.g., +#' \code{"nnls"}) reproduce per-fold weights exactly. Set to +#' \code{FALSE} to reduce object size at the cost of approximate +#' weight recomputation. +#' @param ... Additional arguments passed to internal methods. +#' +#' @family ddml estimators +NULL + +#' Construct a \code{ddml} Object. +#' +#' @family utilities +#' +#' @description Build a \code{"ddml"} object from user-supplied score +#' components. The resulting object inherits all S3 methods +#' available for \code{ddml} objects, including +#' \code{\link{summary.ddml}}, \code{\link{confint.ral}}, +#' \code{\link{vcov.ral}}, and \code{\link{tidy.ddml}}. #' +#' @param coefficients A \code{(p x nensb)} matrix of estimated +#' target parameters. Rows correspond to components of +#' \eqn{\theta}, columns to ensemble types. +#' @param scores A 3D array of evaluated Neyman orthogonal scores +#' with dimensions \code{(n x p x nensb)}. +#' @param J A 3D array of evaluated Jacobians with dimensions +#' \code{(p x p x nensb)}. +#' @param inf_func A 3D array of evaluated influence functions +#' with dimensions \code{(n x p x nensb)}. +#' @param nobs Number of observations. +#' @param coef_names Character vector of coefficient names +#' (length \code{p}). +#' @param estimator_name Character string identifying the estimator +#' (e.g., \code{"My Custom Estimator"}). +#' @param ensemble_type Character vector of ensemble types. Defaults +#' to \code{colnames(coefficients)}. +#' @param cluster_variable A vector of cluster indices. Defaults to +#' \code{seq_len(nobs)}. +#' @param sample_folds Number of cross-fitting folds used. Optional. +#' @param cv_folds Number of cross-validation folds used. Optional. +#' @param shortstack Logical indicating whether short-stacking was +#' used. Default \code{FALSE}. +#' @param ensemble_weights A named list of ensemble weight matrices. +#' Optional. +#' @param mspe A named list of per-learner MSPEs. Optional. +#' @param r2 A named list of per-learner R-squared values. Optional. +#' @param fitted A named list of per-equation cross-fitted prediction +#' objects. Optional. +#' @param splits A list of sample split objects. Optional. +#' @param call The matched call. Defaults to \code{match.call()}. +#' @param subclass Optional character string for a subclass name. If +#' provided, the object will have class +#' \code{c(subclass, "ddml")}. +#' @param dinf_dtheta An optional 4D array of dimensions \code{(nobs x p x p x nensb)} +#' containing the derivatives of the influence functions. +#' @param ... Additional named components to include in the object. +#' +#' @return An object of S3 class \code{"ddml"} (or +#' \code{c(subclass, "ddml")} if \code{subclass} is specified). +#' See \code{\link{ddml-intro}} for the output structure. +#' +#' @export +#' +#' @examples +#' # A minimal example: construct a ddml object from pre-computed +#' # score components for a simple mean estimator. +#' n <- 100 +#' y <- rnorm(n) +#' theta <- mean(y) +#' +#' scores <- array(y - theta, dim = c(n, 1, 1)) +#' J <- array(-1, dim = c(1, 1, 1)) +#' psi_b <- list(matrix(y, ncol = 1)) +#' psi_a <- list(array(-1, dim = c(n, 1, 1))) +#' inf_func <- array(y - theta, dim = c(n, 1, 1)) +#' dinf_dtheta <- array(1, dim = c(n, 1, 1, 1)) +#' coef <- matrix(theta, 1, 1, dimnames = list("mean", "custom")) +#' +#' fit <- ddml(coefficients = coef, scores = scores, J = J, +#' inf_func = inf_func, nobs = n, coef_names = "mean", +#' dinf_dtheta = dinf_dtheta, +#' estimator_name = "Sample Mean") +#' summary(fit) +ddml <- function(coefficients, scores, J, inf_func, + nobs, coef_names, estimator_name, + ensemble_type = colnames(coefficients), + cluster_variable = seq_len(nobs), + sample_folds = NULL, + cv_folds = NULL, + shortstack = FALSE, + ensemble_weights = NULL, + mspe = NULL, r2 = NULL, + fitted = NULL, splits = NULL, + call = match.call(), + subclass = NULL, + dinf_dtheta = NULL, + ...) { + # Validate required fields + if (!is.matrix(coefficients)) { + stop("'coefficients' must be a matrix.", call. = FALSE) + }#IF + if (length(dim(scores)) != 3) { + stop("'scores' must be a 3D array.", call. = FALSE) + }#IF + if (length(dim(J)) != 3) { + stop("'J' must be a 3D array.", call. = FALSE) + }#IF + if (!is.numeric(inf_func) || length(dim(inf_func)) != 3) { + stop("'inf_func' must be a 3D numeric array.", call. = FALSE) + }#IF + if (!is.null(dinf_dtheta) && !is.array(dinf_dtheta)) { + stop("'dinf_dtheta' must be a 4D array or NULL.", call. = FALSE) + }#IF + + # Dimension consistency + p <- nrow(coefficients) + nensb <- ncol(coefficients) + if (dim(scores)[1] != nobs || dim(scores)[2] != p || + dim(scores)[3] != nensb) { + stop("'scores' dimensions must be (nobs x p x nensb).", + call. = FALSE) + }#IF + if (dim(J)[1] != p || dim(J)[2] != p || + dim(J)[3] != nensb) { + stop("'J' dimensions must be (p x p x nensb).", call. = FALSE) + }#IF + if (dim(inf_func)[1] != nobs || dim(inf_func)[2] != p || + dim(inf_func)[3] != nensb) { + stop("'inf_func' dimensions must be (nobs x p x nensb).", call. = FALSE) + }#IF + if (!is.null(dinf_dtheta)) { + if (length(dim(dinf_dtheta)) != 4 || + dim(dinf_dtheta)[1] != nobs || dim(dinf_dtheta)[2] != p || + dim(dinf_dtheta)[3] != p || dim(dinf_dtheta)[4] != nensb) { + stop("'dinf_dtheta' dimensions must be (nobs x p x p x nensb).", call. = FALSE) + }#IF + }#IF + + # Assemble the object + obj <- c(list( + coefficients = coefficients, + ensemble_weights = ensemble_weights, + mspe = mspe, + r2 = r2, + inf_func = inf_func, + dinf_dtheta = dinf_dtheta, + scores = scores, J = J, + coef_names = coef_names, + estimator_name = estimator_name, + ensemble_type = ensemble_type, + nobs = nobs, + nfit = ncol(coefficients), + fit_labels = colnames(coefficients), + sample_folds = sample_folds, + cv_folds = cv_folds, + shortstack = shortstack, + cluster_variable = cluster_variable, + fitted = fitted, + splits = splits, + call = call), list(...)) + + cls <- if (!is.null(subclass)) c(subclass, "ddml", "ral") else + c("ddml", "ral") + class(obj) <- cls + obj +}#DDML + +# S3 methods ================================================================ +# Inference methods (coef, nobs, vcov, confint, hatvalues, tidy, glance) +# are inherited from the "ral" superclass in ral.R. + +#' Subscript a summary.ddml object (deprecated). +#' @param x An object of class \code{summary.ddml}. +#' @param ... Indices passed to \code{[}. #' @keywords internal -"_PACKAGE" +#' @export +`[.summary.ddml` <- function(x, ...) { + message("Note: subscripting a summary.ddml object with ", + "'[' is deprecated. Use x$coefficients[...] instead.") + x$coefficients[...] +}#`[.SUMMARY.DDML` + +#' Summary for DDML Estimators +#' +#' @description Computes a coefficient table with estimates, +#' standard errors, z-values, and p-values for all +#' ensemble types. Standard errors are based on a +#' heteroskedasticity-robust sandwich variance; see +#' \code{\link{vcov.ral}} for the HC0/HC1/HC3 formulas. +#' +#' @param object An object of class \code{ddml}. +#' @param type Character. HC type (\code{"HC0"}, +#' \code{"HC1"}, or \code{"HC3"}). Default +#' \code{"HC1"}. +#' @param ... Currently unused. +#' +#' @return An object of class \code{summary.ddml} with: +#' \describe{ +#' \item{\code{coefficients}}{A 3-dimensional array +#' (\eqn{p \times 4 \times}{p x 4 x} nensb) of estimates, standard +#' errors, z-values, and p-values.} +#' \item{\code{type}}{The HC type used.} +#' \item{\code{nobs}}{Number of observations.} +#' \item{\code{sample_folds}}{Number of cross-fitting +#' folds.} +#' \item{\code{ensemble_type}}{Ensemble type labels.} +#' } +#' +#' @examples +#' \donttest{ +#' y = AE98[, "worked"] +#' D = AE98[, "morekids"] +#' X = AE98[, c("age","agefst","black","hisp","othrace")] +#' plm_fit = ddml_plm(y, D, X, +#' learners = list(what = ols), +#' sample_folds = 2, silent = TRUE) +#' summary(plm_fit) +#' summary(plm_fit, type = "HC3") +#' } +#' +#' @seealso \code{\link{vcov.ral}} +#' +#' @family ddml inference +#' @method summary ddml +#' @export +summary.ddml <- function(object, type = "HC1", ...) { + type <- match.arg(type, c("HC0", "HC1", "HC3")) + + # DML-specific fit labels + single_learner <- is_single_learner(object$learners) + ens_type <- if (single_learner) "single base learner" else + object$ensemble_type + object$fit_labels <- ens_type + + # Delegate table computation to ral + result <- summary.ral(object, type = type, ...) + + # Attach DML-specific fields + result$model_type <- class(object)[1] + result$sample_folds <- object$sample_folds + result$shortstack <- object$shortstack + result$ensemble_type <- ens_type + + class(result) <- c( + paste0("summary.", class(object)[1]), + "summary.ddml") + result +}#SUMMARY.DDML + +#' @rdname summary.ddml +#' +#' @param x An object of class \code{summary.ddml}. +#' @param digits Number of significant digits. Default 3. +#' +#' @method print summary.ddml +#' @export +print.summary.ddml <- function(x, digits = 3, ...) { + model_name <- x$estimator_name + if (is.null(model_name)) model_name <- x$model_type + + cat("DDML estimation:", model_name, "\n") + cat("Obs:", x$nobs, + " Folds:", x$sample_folds) + if (!is.null(x$shortstack) && x$shortstack) { + cat(" Stacking: short-stack") + }#IF + if (!is.null(x$type) && x$type != "HC1") { + cat(" SE:", x$type) + }#IF + cat("\n\n") + + print_coef_tables(x$coefficients, fit_label = "Ensemble type", + digits = digits) + + invisible(x) +}#PRINT.SUMMARY.DDML + +#' @importFrom generics tidy +#' @export +generics::tidy + +#' @importFrom generics glance +#' @export +generics::glance + +#' Tidy a DDML Object +#' +#' DML-specific tidy method. Adds \code{ensemble_type} +#' column labeling based on the estimator's learner/ensemble +#' configuration. Delegates to \code{tidy.ral} for the base +#' table computation. +#' +#' @param x A \code{ddml} object. +#' @param ensemble_idx Integer index of the ensemble type to +#' report. Defaults to 1. Set to \code{NULL} for all. +#' @param conf.int Logical. Include confidence intervals? +#' Default \code{FALSE}. +#' @param conf.level Confidence level. Default 0.95. +#' @param type Character. HC type. Default \code{"HC1"}. +#' @param uniform Logical. Uniform CIs? Default \code{FALSE}. +#' @param bootstraps Integer. Bootstrap draws. Default 999. +#' @param ... Currently unused. +#' +#' @return A \code{data.frame} with columns \code{term}, +#' \code{estimate}, \code{std.error}, \code{statistic}, +#' \code{p.value}, and \code{ensemble_type}. +#' +#' @examples +#' \donttest{ +#' y = AE98[, "worked"] +#' D = AE98[, "morekids"] +#' X = AE98[, c("age","agefst","black","hisp","othrace")] +#' plm_fit = ddml_plm(y, D, X, +#' learners = list(what = ols), +#' sample_folds = 2, silent = TRUE) +#' tidy(plm_fit) +#' tidy(plm_fit, conf.int = TRUE) +#' } +#' +#' @export +#' @method tidy ddml +tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, + conf.level = 0.95, + type = "HC1", + uniform = FALSE, + bootstraps = 999L, ...) { + res <- tidy.ral(x, fit_idx = ensemble_idx, + conf.int = conf.int, + conf.level = conf.level, + type = type, uniform = uniform, + bootstraps = bootstraps) + # Rename fit_label -> ensemble_type for DML compatibility + names(res)[names(res) == "fit_label"] <- "ensemble_type" + res +}#TIDY.DDML + +#' Glance at a DDML Object +#' +#' DML-specific glance method. Includes DML fields like +#' \code{sample_folds}, \code{shortstack}, and +#' \code{model_type}. +#' +#' @param x A \code{ddml} object. +#' @param ... Currently unused. +#' +#' @return A one-row \code{data.frame}. +#' +#' @examples +#' \donttest{ +#' y = AE98[, "worked"] +#' D = AE98[, "morekids"] +#' X = AE98[, c("age","agefst","black","hisp","othrace")] +#' plm_fit = ddml_plm(y, D, X, +#' learners = list(what = ols), +#' sample_folds = 2, silent = TRUE) +#' glance(plm_fit) +#' } +#' +#' @export +#' @method glance ddml +glance.ddml <- function(x, ...) { + data.frame( + nobs = x$nobs, + sample_folds = x$sample_folds, + shortstack = if (is.null(x$shortstack)) FALSE else + x$shortstack, + ensemble_type = paste(x$ensemble_type, collapse = ", "), + model_type = class(x)[1], + estimator_name = if (is.null(x$estimator_name)) { + class(x)[1] + } else { + x$estimator_name + }, + stringsAsFactors = FALSE + ) +}#GLANCE.DDML + +# List conversion ============================================================= + +#' Split a DDML Object by Ensemble Type +#' +#' Returns a named list of single-ensemble \code{ddml} +#' objects. Each element retains all S3 methods +#' (\code{summary}, \code{tidy}, \code{glance}, +#' \code{confint}, \code{vcov}). +#' +#' @param x An object inheriting from class \code{ddml}. +#' @param ... Currently unused. +#' +#' @return A named list of length \code{nfit}. +#' +#' @examples +#' \donttest{ +#' y = AE98[, "worked"] +#' D = AE98[, "morekids"] +#' X = AE98[, c("age","agefst","black","hisp","othrace")] +#' fit = ddml_plm(y, D, X, +#' learners = list( +#' list(what = ols), +#' list(what = mdl_glmnet)), +#' ensemble_type = c("nnls", "singlebest"), +#' sample_folds = 2, silent = TRUE) +#' as.list(fit) +#' } +#' +#' @method as.list ddml +#' @export +as.list.ddml <- function(x, ...) { + nfit <- ncol(x$coefficients) + labels <- x$fit_labels + if (is.null(labels)) labels <- x$ensemble_type + if (is.null(labels)) labels <- paste0("fit", seq_len(nfit)) + + sub <- setdiff(class(x), c("ddml", "ral"))[1] + + out <- vector("list", nfit) + names(out) <- labels + for (j in seq_len(nfit)) { + dinf_j <- if (!is.null(x$dinf_dtheta)) { + x$dinf_dtheta[, , , j, drop = FALSE] + }#IF + obj <- ddml( + coefficients = x$coefficients[, j, drop = FALSE], + scores = x$scores[, , j, drop = FALSE], + J = x$J[, , j, drop = FALSE], + inf_func = x$inf_func[, , j, drop = FALSE], + dinf_dtheta = dinf_j, + nobs = x$nobs, + coef_names = x$coef_names, + estimator_name = x$estimator_name, + ensemble_type = labels[j], + cluster_variable = x$cluster_variable, + sample_folds = x$sample_folds, + cv_folds = x$cv_folds, + shortstack = x$shortstack, + ensemble_weights = x$ensemble_weights, + mspe = x$mspe, + r2 = x$r2, + fitted = x$fitted, + splits = x$splits, + call = x$call, + subclass = sub) + # Carry through estimator-specific fields + for (nm in c("learners", "learners_DX", "learners_qX", + "cell_info", "G", "control_group", + "anticipation")) { + if (!is.null(x[[nm]])) obj[[nm]] <- x[[nm]] + }#FOR + out[[j]] <- obj + }#FOR + out +}#AS.LIST.DDML diff --git a/R/ddml_apo.R b/R/ddml_apo.R new file mode 100644 index 0000000..71844a7 --- /dev/null +++ b/R/ddml_apo.R @@ -0,0 +1,259 @@ +#' Estimator for the Average Potential Outcome +#' +#' @family ddml estimators +#' +#' @description Estimator for the average potential outcome, allowing for +#' custom weights \eqn{\omega(X)}. +#' +#' @details +#' \strong{Parameter of Interest:} \code{ddml_apo} provides a +#' Double/Debiased Machine Learning estimator for the average potential +#' outcome. Under conditional unconfoundedness and overlap, the parameter +#' is identified by the following reduced form conditional expectation: +#' +#' \deqn{\theta_0^{\textrm{APO}} = E[\omega(X) E[Y|D=d, X]],} +#' +#' where \eqn{W \equiv (Y, D, X)} is the observed random vector and +#' \eqn{\omega(X)} is a known weighting function. If \eqn{\omega(X) = 1}, +#' this parameter corresponds to the average potential outcome +#' at treatment level \eqn{d}. +#' +#' \strong{Nuisance Parameters:} The nuisance parameters are +#' \eqn{\eta = (\ell, r)} taking true values \eqn{\ell_0(X) = E[Y|D=d, X]} and +#' \eqn{r_0(X) = \Pr(D=d|X)}. +#' +#' \strong{Neyman Orthogonal Score / Moment Equation:} The Neyman orthogonal score is: +#' +#' \deqn{m(W; \theta, \eta) = \left( \frac{\mathbf{1}\{D=d\} (Y - \ell(X))}{r(X)} + \ell(X) \right) \omega(X) - \theta} +#' +#' \strong{Jacobian:} +#' +#' \deqn{J = -1} +#' +#' See \code{\link{ddml-intro}} for how the influence function +#' and inference are derived from these components. +#' +#' @inheritParams ddml-intro +#' @inheritParams ddml_plm +#' @param D The endogenous variable of interest. Can be discrete or continuous. +#' @param d The treatment level of interest. The default is \code{d = 1}. +#' @param weights A numeric vector of length \code{nobs} specifying the weights +#' \eqn{\omega(X)}. If \code{weights = NULL} (the default), a vector of 1s +#' is used, which estimates the Average Potential Outcome (APO). +#' @param stratify Boolean for stratified cross-fitting: if \code{TRUE}, +#' subsamples are constructed to be balanced across treatment levels. +#' @param trim Number in (0, 1) for trimming the estimated propensity scores at +#' \code{trim} and \code{1-trim}. +#' @param splits An optional list of sample split objects. For +#' \code{ddml_apo}, this must be a list with elements \code{subsamples} and +#' \code{cv_subsamples} (and optionally \code{subsamples_byD} and +#' \code{cv_subsamples_byD} for stratified splitting). Typically +#' obtained from a previous fit via \code{fit$splits}. +#' @param ... Additional arguments passed to internal methods. +#' +#' @return \code{ddml_apo} returns an object of S3 class +#' \code{ddml_apo} and \code{ddml}. See \code{\link{ddml-intro}} +#' for the common output structure. Additional pass-through +#' fields: \code{learners}, \code{learners_DX}. +#' +#' @export +#' +#' @examples +#' # Construct variables from the included Angrist & Evans (1998) data +#' y = AE98[, "worked"] +#' D = AE98[, "morekids"] +#' X = AE98[, c("age","agefst","black","hisp","othrace","educ")] +#' +#' # Estimate the APO for d = 1 using a single base learner, ridge. +#' apo_fit <- ddml_apo(y, D, X, +#' learners = list(what = mdl_glmnet), +#' sample_folds = 2, +#' silent = TRUE) +#' summary(apo_fit) +#' +ddml_apo <- function(y, D, X, + d = 1, + weights = NULL, + learners, + learners_DX = learners, + sample_folds = 10, + ensemble_type = "nnls", + shortstack = FALSE, + cv_folds = 10, + custom_ensemble_weights = NULL, + custom_ensemble_weights_DX = custom_ensemble_weights, + cluster_variable = seq_along(y), + stratify = TRUE, + trim = 0.01, + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ...) { + cl <- match.call() + + # Preliminaries -------------------------------------------------------------- + + dots <- list(...) + messages <- resolve_messages(dots, "ddml_apo", list( + y_X = paste0("E[Y|D=", d, ",X]"), + D_X = paste0("P(D=", d, "|X)"))) + + D_ind <- 1 * (D == d) + + validate_inputs(y = y, D = D_ind, X = X, + learners = learners, + sample_folds = sample_folds, + cv_folds = cv_folds, + ensemble_type = ensemble_type, trim = trim, + weights = weights, + cluster_variable = cluster_variable, + require_binary_D = TRUE) + validate_custom_weights(custom_ensemble_weights, learners) + validate_custom_weights(custom_ensemble_weights_DX, learners_DX) + + nobs <- length(y) + is_d <- which(D == d) + if (is.null(weights)) weights <- rep(1, nobs) + + # Construct sample splits for cross-fitting and cross-validation + validate_fitted_splits_pair(fitted, splits) + indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + D = D_ind, stratify = stratify, + subsamples = splits$D_X$subsamples, + cv_subsamples = splits$D_X$cv_subsamples) + check_subsamples(indxs$subsamples, indxs$subsamples_byD, + stratify, D_ind) + + t0 <- proc.time()[3] + announce_start(messages, parallel, silent) + + # Reduced-form estimation ---------------------------------------------------- + + # P(D = d | X) + D_X_res <- get_CEF(D_ind, X, + learners = learners_DX, + ensemble_type = ensemble_type, + shortstack = shortstack, + custom_ensemble_weights = + custom_ensemble_weights_DX, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, + silent = silent, label = messages$D_X, + parallel = parallel, + fitted = fitted$D_X) + + # E[Y | D = d, X] (subsamples_byD[[2]] = D_ind == 1) + y_X_res <- get_CEF(y[is_d], X[is_d, , drop = FALSE], + learners = learners, + ensemble_type = ensemble_type, + shortstack = shortstack, + custom_ensemble_weights = + custom_ensemble_weights, + subsamples = indxs$subsamples_byD[[2]], + cv_subsamples = + indxs$cv_subsamples_byD[[2]], + silent = silent, label = messages$y_X, + auxiliary_X = get_auxiliary_X( + indxs$aux_indx[[2]], X), + parallel = parallel, + fitted = fitted$y_X) + + ensemble_type <- y_X_res$ensemble_type + nensb <- if (is.null(ensemble_type)) 1L + else length(ensemble_type) + + # Score construction --------------------------------------------------------- + + # Extrapolate E[Y|D=d,X] to full sample. aux_indx is indexed by + # sorted D_ind levels {0, 1}: [[2]] holds positions of {D_ind=0} + # observations per fold, where the D_ind=1 model must extrapolate. + g_X <- extrapolate_CEF( + D = D_ind, + CEF_res_byD = list(list( + fit = list( + cf_fitted = y_X_res$cf_fitted, + auxiliary_fitted = y_X_res$auxiliary_fitted), + d = 1)), + aux_indx = indxs$aux_indx[2])[, , 1] + m_X <- D_X_res$cf_fitted + is_internal <- is.null(messages$start) || + messages$start == "" + m_X_tr <- trim_propensity_scores(m_X, trim, ensemble_type, + silent = is_internal) + + weights_mat <- matrix(weights, nobs, nensb) + D_ind_mat <- matrix(D_ind, nobs, nensb) + y_mat <- matrix(y, nobs, nensb) + + psi_b_mat <- (D_ind_mat * (y_mat - g_X) / m_X_tr + g_X) * weights_mat + + # Target parameter & influence function -------------------------------------- + + apo <- colMeans(psi_b_mat) + + scores <- array(NA_real_, dim = c(nobs, 1, nensb)) + J <- array(NA_real_, dim = c(1, 1, nensb)) + inf_func <- array(NA_real_, dim = c(nobs, 1, nensb)) + dinf_dtheta <- array(NA_real_, dim = c(nobs, 1, 1, nensb)) + for (j in seq_len(nensb)) { + scores[, 1, j] <- -apo[j] + psi_b_mat[, j] + J[1, 1, j] <- -1 + + J_inv <- csolve(matrix(J[, , j], 1, 1)) + inf_func[, 1, j] <- matrix(scores[, 1, j], nobs, 1) %*% t(J_inv) + dinf_dtheta[, 1, 1, j] <- -J_inv[1, 1] + }#FOR + + coef_names <- "APO" + coef <- matrix(apo, nrow = 1, ncol = nensb) + rownames(coef) <- coef_names + colnames(coef) <- ensemble_type + + # Output --------------------------------------------------------------------- + + announce_finish(t0, messages, silent) + + ddml( + coefficients = coef, + ensemble_weights = list(y_X = y_X_res$weights, + D_X = D_X_res$weights), + mspe = list(y_X = y_X_res$mspe, + D_X = D_X_res$mspe), + r2 = list(y_X = y_X_res$r2, + D_X = D_X_res$r2), + inf_func = inf_func, dinf_dtheta = dinf_dtheta, + scores = scores, J = J, + coef_names = coef_names, + estimator_name = "Average Potential Outcome", + ensemble_type = ensemble_type, + nobs = nobs, + sample_folds = sample_folds, + cv_folds = if (shortstack) NULL else cv_folds, + shortstack = shortstack, + cluster_variable = cluster_variable, + fitted = list( + y_X = build_fitted_entry(y_X_res, save_crossval, + include_auxiliary = TRUE), + D_X = build_fitted_entry(D_X_res, save_crossval)), + splits = list( + y_X = list( + subsamples = indxs$subsamples_byD[[2]], + cv_subsamples = indxs$cv_subsamples_byD[[2]]), + D_X = list( + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples)), + call = cl, + subclass = "ddml_apo", + # ddml_apo-specific fields + d = d, + weights = weights, + learners = learners, + learners_DX = learners_DX + ) +}#DDML_APO + diff --git a/R/ddml_ate.R b/R/ddml_ate.R index 3555b80..acd3ddd 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -1,76 +1,58 @@ -#' Estimators of Average Treatment Effects. +#' Estimator for the Average Treatment Effect #' -#' @family ddml +#' @family ddml estimators #' -#' @seealso [ddml::summary.ddml_ate()], [ddml::summary.ddml_att()] -#' -#' @description Estimators of the average treatment effect and the average +#' @description Estimator for the average treatment effect and the average #' treatment effect on the treated. #' -#' @details \code{ddml_ate} and \code{ddml_att} provide double/debiased machine -#' learning estimators for the average treatment effect and the average -#' treatment effect on the treated, respectively, in the interactive model -#' given by +#' @details +#' \strong{Parameter of Interest:} \code{ddml_ate} and \code{ddml_att} provide +#' Double/Debiased Machine Learning estimators for the average treatment +#' effect and the average treatment effect on the treated, respectively. +#' Under conditional unconfoundedness and overlap, the parameters +#' are identified by the following reduced form parameters: #' -#' \eqn{Y = g_0(D, X) + U,} +#' \deqn{\theta_0^{\textrm{ATE}} = E[E[Y|D=1, X] - E[Y|D=0, X]]} #' -#' where \eqn{(Y, D, X, U)} is a random vector such that -#' \eqn{\operatorname{supp} D = \{0,1\}}, \eqn{E[U\vert D, X] = 0}, and -#' \eqn{\Pr(D=1\vert X) \in (0, 1)} with probability 1, -#' and \eqn{g_0} is an unknown nuisance function. +#' and the average treatment effect on the treated (ATT) is defined as #' -#' In this model, the average treatment effect is defined as +#' \deqn{\theta_0^{\textrm{ATT}} = E[Y|D=1] - E[E[Y|D=0, X]|D = 1].} #' -#' \eqn{\theta_0^{\textrm{ATE}} \equiv E[g_0(1, X) - g_0(0, X)]}. +#' where \eqn{W \equiv (Y, D, X)} is the observed random vector. #' -#' and the average treatment effect on the treated is defined as +#' \strong{Neyman Orthogonal Score:} The Neyman orthogonal scores are: #' -#' \eqn{\theta_0^{\textrm{ATT}} \equiv E[g_0(1, X) - g_0(0, X)\vert D = 1]}. +#' \deqn{m^{\textrm{ATE}}(W; \theta, \eta) = \frac{D(Y - \ell_1(X))}{r(X)} - \frac{(1-D)(Y-\ell_0(X))}{1-r(X)} + \ell_1(X) - \ell_0(X) - \theta} #' -#' @inheritParams ddml_plm -#' @param D The binary endogenous variable of interest. -#' @param subsamples_byD List of two lists corresponding to the two treatment -#' levels. Each list contains vectors with sample indices for -#' cross-fitting. -#' @param cv_subsamples_byD List of two lists, each corresponding to one of the -#' two treatment levels. Each of the two lists contains lists, each -#' corresponding to a subsample and contains vectors with subsample indices -#' for cross-validation. -#' @param trim Number in (0, 1) for trimming the estimated propensity scores at -#' \code{trim} and \code{1-trim}. +#' \deqn{m^{\textrm{ATT}}(W; \theta, \eta) = \frac{D(Y - \ell_0(X))}{\pi} - \frac{r(X)(1-D)(Y-\ell_0(X))}{\pi(1-r(X))} - \frac{D}{\pi}\theta} #' -#' @return \code{ddml_ate} and \code{ddml_att} return an object of S3 class -#' \code{ddml_ate} and \code{ddml_att}, respectively. An object of class -#' \code{ddml_ate} or \code{ddml_att} is a list containing -#' the following components: -#' \describe{ -#' \item{\code{ate} / \code{att}}{A vector with the average treatment -#' effect / average treatment effect on the treated estimates.} -#' \item{\code{weights}}{A list of matrices, providing the weight -#' assigned to each base learner (in chronological order) by the -#' ensemble procedure.} -#' \item{\code{mspe}}{A list of matrices, providing the MSPE of each -#' base learner (in chronological order) computed by the -#' cross-validation step in the ensemble construction.} -#' \item{\code{psi_a}, \code{psi_b}}{Matrices needed for the computation -#' of scores. Used in [ddml::summary.ddml_ate()] or -#' [ddml::summary.ddml_att()].} -#' \item{\code{oos_pred}}{List of matrices, providing the reduced form -#' predicted values.} -#' \item{\code{learners},\code{learners_DX},\code{cluster_variable}, -#' \code{subsamples_D0},\code{subsamples_D1}, -#' \code{cv_subsamples_list_D0},\code{cv_subsamples_list_D1}, -#' \code{ensemble_type}}{Pass-through of -#' selected user-provided arguments. See above.} -#' } -#' @export +#' where the nuisance parameters are \eqn{\eta = (\ell_0, \ell_1, r, \pi)} taking true values +#' \eqn{\ell_{d,0}(X) = E[Y|D=d, X]}, \eqn{r_0(X) = \Pr(D=1|X)}, and \eqn{\pi_0 = \Pr(D=1)}. +#' +#' \strong{Jacobian:} #' -#' @references -#' Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C B, Newey W, -#' Robins J (2018). "Double/debiased machine learning for treatment and -#' structural parameters." The Econometrics Journal, 21(1), C1-C68. +#' \deqn{J^{\textrm{ATE}} = -1} #' -#' Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. +#' \deqn{J^{\textrm{ATT}} = -1} +#' +#' See \code{\link{ddml-intro}} for how the influence function +#' and inference are derived from these components. +#' +#' @inheritParams ddml-intro +#' @inheritParams ddml_apo +#' @param D The binary endogenous variable of interest. +#' @param splits An optional list of sample split objects. For +#' \code{ddml_ate}/\code{ddml_att}, recommended keys are +#' \code{subsamples}, \code{subsamples_byD}, \code{cv_subsamples}, +#' and \code{cv_subsamples_byD}. +#' @param ... Additional arguments passed to internal methods. +#' +#' @return \code{ddml_ate} and \code{ddml_att} return objects of S3 +#' class \code{ddml_ate}/\code{ddml_att} and \code{ddml}. See +#' \code{\link{ddml-intro}} for the common output structure. +#' Additional pass-through fields: \code{learners}, +#' \code{learners_DX}. +#' @export #' #' @examples #' # Construct variables from the included Angrist & Evans (1998) data @@ -92,9 +74,9 @@ #' weights_everylearner <- diag(1, 3) #' colnames(weights_everylearner) <- c("mdl:ols", "mdl:lasso", "mdl:ridge") #' ate_fit <- ddml_ate(y, D, X, -#' learners = list(list(fun = ols), -#' list(fun = mdl_glmnet), -#' list(fun = mdl_glmnet, +#' learners = list(list(what = ols), +#' list(what = mdl_glmnet), +#' list(what = mdl_glmnet, #' args = list(alpha = 0))), #' ensemble_type = 'nnls', #' custom_ensemble_weights = weights_everylearner, @@ -112,194 +94,171 @@ ddml_ate <- function(y, D, X, custom_ensemble_weights = NULL, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples_byD = NULL, - cv_subsamples_byD = NULL, + stratify = TRUE, trim = 0.01, - silent = FALSE) { - # Data parameters - nobs <- length(y) - is_D0 <- which(D == 0) + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ...) { + cl <- match.call() - # Create sample and cv-fold tuples - cf_indxs <- get_crossfit_indices(cluster_variable = cluster_variable, D = D, - sample_folds = sample_folds, - cv_folds = cv_folds, - subsamples_byD = subsamples_byD, - cv_subsamples_byD = cv_subsamples_byD) + # Preliminaries -------------------------------------------------------------- - # Create tuple for extrapolated fitted values - aux_indxs <- get_auxiliary_indx(cf_indxs$subsamples_byD, D) + dots <- list(...) + messages <- resolve_messages(dots, "ddml_ate", list( + y_D0 = "E[Y|D=0,X]", + y_D1 = "E[Y|D=1,X]", + D_X = "E[D|X]")) - # Print to progress to console - if (!silent) cat("DDML estimation in progress. \n") + validate_inputs(y = y, D = D, X = X, learners = learners, + sample_folds = sample_folds, + cv_folds = cv_folds, + ensemble_type = ensemble_type, trim = trim, + cluster_variable = cluster_variable, + require_binary_D = TRUE) + validate_custom_weights(custom_ensemble_weights, learners) + validate_custom_weights(custom_ensemble_weights_DX, learners_DX) - # Compute estimates of E[y|D=0,X] - y_X_D0_res <- get_CEF(y[is_D0], X[is_D0, , drop = F], - learners = learners, ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights, - subsamples = cf_indxs$subsamples_byD[[1]], - cv_subsamples_list = cf_indxs$cv_subsamples_byD[[1]], - silent = silent, progress = "E[Y|D=0,X]: ", - auxiliary_X = get_auxiliary_X(aux_indxs[[1]], X)) - - # Compute estimates of E[y|D=1,X] - y_X_D1_res <- get_CEF(y[-is_D0], X[-is_D0, , drop = F], - learners = learners, ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights, - subsamples = cf_indxs$subsamples_byD[[2]], - cv_subsamples_list = cf_indxs$cv_subsamples_byD[[2]], - silent = silent, progress = "E[Y|D=1,X]: ", - auxiliary_X = get_auxiliary_X(aux_indxs[[2]], X)) + nobs <- length(y) - # Compute estimates of E[D|X] - D_X_res <- get_CEF(D, X, - learners = learners_DX, ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights_DX, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, - silent = silent, progress = "E[D|X]: ") + validate_fitted_splits_pair(fitted, splits) - # Update ensemble type to account for (optional) custom weights - ensemble_type <- dimnames(y_X_D0_res$weights)[[2]] - nensb <- ifelse(is.null(ensemble_type), 1, length(ensemble_type)) + indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + D = D, stratify = stratify, + subsamples = splits$D_X$subsamples, + subsamples_byD = list( + splits$y_X_D0$subsamples, + splits$y_X_D1$subsamples), + cv_subsamples = splits$D_X$cv_subsamples, + cv_subsamples_byD = list( + splits$y_X_D0$cv_subsamples, + splits$y_X_D1$cv_subsamples)) + check_subsamples(indxs$subsamples, indxs$subsamples_byD, + stratify, D) - # Check whether multiple ensembles are computed simultaneously - multiple_ensembles <- nensb > 1 + t0 <- proc.time()[3] + announce_start(messages, parallel, silent) - # Construct reduced form variables - g_X_byD <- extrapolate_CEF(D = D, - CEF_res_byD = list(list(y_X_D0_res, d=0), - list(y_X_D1_res, d=1)), - aux_indxs = aux_indxs) - m_X <- D_X_res$oos_fitted + # Reduced-form estimation ---------------------------------------------------- - # Trim propensity scores, return warnings - m_X_tr <- trim_propensity_scores(m_X, trim, ensemble_type) + shared_splits <- list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples) + apo_splits_1 <- list( + y_X = list(subsamples = indxs$subsamples_byD[[2]], + cv_subsamples = indxs$cv_subsamples_byD[[2]]), + D_X = shared_splits) + apo_splits_0 <- list( + y_X = list(subsamples = indxs$subsamples_byD[[1]], + cv_subsamples = indxs$cv_subsamples_byD[[1]]), + D_X = shared_splits) - # Compute the ATE using the constructed variables - y_copy <- matrix(rep(y, nensb), nobs, nensb) - D_copy <- matrix(rep(D, nensb), nobs, nensb) - psi_b <- D_copy * (y_copy - g_X_byD[, , 2]) / m_X_tr - - (1 - D_copy) * (y_copy - g_X_byD[, , 1]) / (1 - m_X_tr) + - g_X_byD[, , 2] - g_X_byD[, , 1] - ate <- colMeans(psi_b) - names(ate) <- ensemble_type + # E[g(1,X)] via ddml_apo (also estimates P(D=1|X) internally) + apo_1 <- ddml_apo( + y = y, D = D, X = X, d = 1, weights = NULL, + learners = learners, learners_DX = learners_DX, + sample_folds = sample_folds, cv_folds = cv_folds, + custom_ensemble_weights = custom_ensemble_weights, + custom_ensemble_weights_DX = custom_ensemble_weights_DX, + cluster_variable = cluster_variable, + ensemble_type = ensemble_type, shortstack = shortstack, + trim = trim, parallel = parallel, silent = silent, + splits = apo_splits_1, + fitted = list(y_X = fitted$y_X_D1, + D_X = fitted$D_X), + messages = list(start = "", finish = "", + y_X = messages$y_D1, + D_X = messages$D_X)) - # Also set psi_a scores for easier computation of summary.ddml_ate - psi_a <- matrix(-1, nobs, nensb) + # Flip propensity: P(D=0|X) = 1 - P(D=1|X). + fitted_D_X_0 <- list(cf_fitted = 1 - apo_1$fitted$D_X$cf_fitted) - # Organize complementary ensemble output - weights <- list(y_X_D0 = y_X_D0_res$weights, - y_X_D1 = y_X_D1_res$weights, - D_X = D_X_res$weights) + # E[g(0,X)] via ddml_apo + apo_0 <- ddml_apo( + y = y, D = D, X = X, d = 0, weights = NULL, + learners = learners, learners_DX = learners_DX, + sample_folds = sample_folds, cv_folds = cv_folds, + custom_ensemble_weights = custom_ensemble_weights, + custom_ensemble_weights_DX = custom_ensemble_weights_DX, + cluster_variable = cluster_variable, + ensemble_type = ensemble_type, shortstack = shortstack, + trim = trim, parallel = parallel, silent = silent, + splits = apo_splits_0, + fitted = list(y_X = fitted$y_X_D0, + D_X = fitted_D_X_0), + messages = list(start = "", finish = "", + y_X = messages$y_D0, D_X = "")) - # Store complementary ensemble output - mspe <- list(y_X_D0 = y_X_D0_res$mspe, - y_X_D1 = y_X_D1_res$mspe, - D_X = D_X_res$mspe) + ensemble_type <- apo_1$ensemble_type + nensb <- ncol(apo_1$coefficients) - # Organize reduced form predicted values - oos_pred <- list(EY_D0_X = g_X_byD[, , 1], - EY_D1_X = g_X_byD[, , 2], - ED_X = m_X) + # Target parameter & influence function -------------------------------------- - # Organize output - ddml_fit <- list(ate = ate, weights = weights, mspe = mspe, - psi_a = psi_a, psi_b = psi_b, - oos_pred = oos_pred, - learners = learners, - learners_DX = learners_DX, - cluster_variable = cluster_variable, - subsamples_byD = subsamples_byD, - cv_subsamples_byD = cv_subsamples_byD, - ensemble_type = ensemble_type) + ate <- as.vector(apo_1$coefficients) - as.vector(apo_0$coefficients) - # Print estimation progress - if (!silent) cat("DDML estimation completed. \n") + scores <- array(NA_real_, dim = c(nobs, 1, nensb)) + J <- array(NA_real_, dim = c(1, 1, nensb)) + inf_func <- array(NA_real_, dim = c(nobs, 1, nensb)) + dinf_dtheta <- array(NA_real_, dim = c(nobs, 1, 1, nensb)) + for (j in seq_len(nensb)) { + inf_func[, 1, j] <- apo_1$inf_func[, 1, j] - apo_0$inf_func[, 1, j] + scores[, 1, j] <- -inf_func[, 1, j] + J[1, 1, j] <- -1 + dinf_dtheta[, 1, 1, j] <- 1 + }#FOR + coef_names <- "ATE" + coef <- matrix(ate, nrow = 1, ncol = nensb) + rownames(coef) <- coef_names + colnames(coef) <- ensemble_type - # Amend class and return - class(ddml_fit) <- "ddml_ate" - return(ddml_fit) -}#DDML_ATE + # Output --------------------------------------------------------------------- -#' Inference Methods for Treatment Effect Estimators. -#' -#' @description Inference methods for treatment effect estimators. By default, -#' standard errors are heteroskedasiticty-robust. If the \code{ddml} -#' estimator was computed using a \code{cluster_variable}, the standard -#' errors are also cluster-robust by default. -#' -#' @param object An object of class \code{ddml_ate}, \code{ddml_att}, and -#' \code{ddml_late}, as fitted by [ddml::ddml_ate()], [ddml::ddml_att()], -#' and [ddml::ddml_late()], respectively. -#' @param ... Currently unused. -#' -#' @return A matrix with inference results. -#' -#' @export -#' -#' @examples -#' # Construct variables from the included Angrist & Evans (1998) data -#' y = AE98[, "worked"] -#' D = AE98[, "morekids"] -#' X = AE98[, c("age","agefst","black","hisp","othrace","educ")] -#' -#' # Estimate the average treatment effect using a single base learner, ridge. -#' ate_fit <- ddml_ate(y, D, X, -#' learners = list(what = mdl_glmnet, -#' args = list(alpha = 0)), -#' sample_folds = 2, -#' silent = TRUE) -#' summary(ate_fit) -summary.ddml_ate <- function(object, ...) { - # Check whether stacking was used, replace ensemble type if TRUE - single_learner <- ("what" %in% names(object$learners)) - if (single_learner) object$ensemble_type <- " " - # Compute and return inference results - coefficients <- organize_interactive_inf_results(coef = object$ate, - psi_a = object$psi_a, - psi_b = object$psi_b, - ensemble_type = - object$ensemble_type, - cluster_variable = - object$cluster_variable) - class(coefficients) <- c("summary.ddml_ate", class(coefficients)) - coefficients -}#SUMMARY.DDML_ATE + announce_finish(t0, messages, silent) -#' Print Methods for Treatment Effect Estimators. -#' -#' @description Print methods for treatment effect estimators. -#' -#' @param x An object of class \code{summary.ddml_ate}, -#' \code{summary.ddml_att}, and \code{ddml_late}, as returned by -#' [ddml::summary.ddml_ate()], [ddml::summary.ddml_att()], and -#' [ddml::summary.ddml_late()], respectively. -#' @param digits The number of significant digits used for printing. -#' @param ... Currently unused. -#' -#' @return NULL. -#' -#' @export -#' -#' @examples -#' # Construct variables from the included Angrist & Evans (1998) data -#' y = AE98[, "worked"] -#' D = AE98[, "morekids"] -#' X = AE98[, c("age","agefst","black","hisp","othrace","educ")] -#' -#' # Estimate the average treatment effect using a single base learner, ridge. -#' ate_fit <- ddml_ate(y, D, X, -#' learners = list(what = mdl_glmnet, -#' args = list(alpha = 0)), -#' sample_folds = 2, -#' silent = TRUE) -#' summary(ate_fit) -print.summary.ddml_ate <- function(x, digits = 3, ...) { - cat("ATE estimation results: \n \n") - class(x) <- class(x)[-1] - print(x, digits = digits) -}#PRINT.SUMMARY.DDML_ATE + ddml( + coefficients = coef, + ensemble_weights = list( + y_X_D0 = apo_0$ensemble_weights$y_X, + y_X_D1 = apo_1$ensemble_weights$y_X, + D_X = apo_1$ensemble_weights$D_X), + mspe = list(y_X_D0 = apo_0$mspe$y_X, + y_X_D1 = apo_1$mspe$y_X, + D_X = apo_1$mspe$D_X), + r2 = list(y_X_D0 = apo_0$r2$y_X, + y_X_D1 = apo_1$r2$y_X, + D_X = apo_1$r2$D_X), + inf_func = inf_func, dinf_dtheta = dinf_dtheta, + scores = scores, J = J, + coef_names = coef_names, + estimator_name = "Average Treatment Effect", + ensemble_type = ensemble_type, + nobs = nobs, + sample_folds = sample_folds, + cv_folds = if (shortstack) NULL else cv_folds, + shortstack = shortstack, + cluster_variable = cluster_variable, + fitted = list( + y_X_D0 = apo_0$fitted$y_X, + y_X_D1 = apo_1$fitted$y_X, + D_X = apo_1$fitted$D_X), + splits = list( + y_X_D0 = list( + subsamples = indxs$subsamples_byD[[1]], + cv_subsamples = indxs$cv_subsamples_byD[[1]]), + y_X_D1 = list( + subsamples = indxs$subsamples_byD[[2]], + cv_subsamples = indxs$cv_subsamples_byD[[2]]), + D_X = list( + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples)), + call = cl, + subclass = "ddml_ate", + # ddml_ate-specific fields + learners = learners, + learners_DX = learners_DX + ) +}#DDML_ATE diff --git a/R/ddml_att.R b/R/ddml_att.R index 69e0b44..08b0df0 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -11,135 +11,199 @@ ddml_att <- function(y, D, X, custom_ensemble_weights = NULL, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples_byD = NULL, - cv_subsamples_byD = NULL, + stratify = TRUE, trim = 0.01, - silent = FALSE) { - # Data parameters + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ...) { + cl <- match.call() + + # Preliminaries -------------------------------------------------------------- + + dots <- list(...) + messages <- resolve_messages(dots, "ddml_att", list( + y_D0 = "E[Y|D=0,X]", + D_X = "E[D|X]", + D = "E[D]")) + + validate_inputs(y = y, D = D, X = X, learners = learners, + sample_folds = sample_folds, + cv_folds = cv_folds, + ensemble_type = ensemble_type, trim = trim, + cluster_variable = cluster_variable, + require_binary_D = TRUE) + validate_custom_weights(custom_ensemble_weights, learners) + validate_custom_weights(custom_ensemble_weights_DX, + learners_DX) + nobs <- length(y) - is_D0 <- which(D == 0) - - # Create sample and cv-fold tuples - cf_indxs <- get_crossfit_indices(cluster_variable = cluster_variable, D = D, - sample_folds = sample_folds, - cv_folds = cv_folds, - subsamples_byD = subsamples_byD, - cv_subsamples_byD = cv_subsamples_byD) - - # Create tuple for extrapolated fitted values - aux_indxs <- get_auxiliary_indx(cf_indxs$subsamples_byD, D) - - # Print to progress to console - if (!silent) cat("DDML estimation in progress. \n") - - # Compute estimates of E[y|D=0,X] - y_X_D0_res <- get_CEF(y[is_D0], X[is_D0, , drop = F], - learners = learners, ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights, - subsamples = cf_indxs$subsamples_byD[[1]], - cv_subsamples_list = cf_indxs$cv_subsamples_byD[[1]], - silent = silent, progress = "E[Y|D=0,X]: ", - auxiliary_X = get_auxiliary_X(aux_indxs[[1]], X)) - - # Compute estimates of E[D|X] + + validate_fitted_splits_pair(fitted, splits) + + indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + D = D, stratify = stratify, + subsamples = splits$D_X$subsamples, + subsamples_byD = list( + splits$y_X_D0$subsamples, + splits$y_X_D1$subsamples), + cv_subsamples = splits$D_X$cv_subsamples, + cv_subsamples_byD = list( + splits$y_X_D0$cv_subsamples, + splits$y_X_D1$cv_subsamples)) + check_subsamples(indxs$subsamples, indxs$subsamples_byD, + stratify, D) + + t0 <- proc.time()[3] + announce_start(messages, parallel, silent) + + # Reduced-form estimation ---------------------------------------------------- + + # E[D|X] D_X_res <- get_CEF(D, X, - learners = learners_DX, ensemble_type = ensemble_type, + learners = learners_DX, + ensemble_type = ensemble_type, shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights_DX, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, - silent = silent, progress = "E[D|X]: ") - - # Compute estimates of E[D] -- simple computation of averages here + custom_ensemble_weights = + custom_ensemble_weights_DX, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, + silent = silent, label = messages$D_X, + parallel = parallel, + fitted = fitted$D_X) + + # E[D] (unconditional treatment probability, cross-fitted) D_res <- get_CEF(D, matrix(1, nobs, 1), - learners = list(what = ols), + learners = list(what = ols, + args = list(const = FALSE)), ensemble_type = "average", shortstack = FALSE, - cv_subsamples_list = NULL, - subsamples = cf_indxs$subsamples, - silent = TRUE) - - # Update ensemble type to account for (optional) custom weights - ensemble_type <- dimnames(y_X_D0_res$weights)[[2]] - nensb <- ifelse(is.null(ensemble_type), 1, length(ensemble_type)) - - # Check whether multiple ensembles are computed simultaneously - multiple_ensembles <- nensb > 1 - - # Construct reduced form variables - g_X_D0<- extrapolate_CEF(D = D, - CEF_res_byD = list(list(fit = y_X_D0_res, d = 0)), - aux_indxs = aux_indxs)[, , 1] - m_X <- D_X_res$oos_fitted - - # Trim propensity scores, return warnings + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, + silent = silent, label = messages$D, + fitted = fitted$D) + + # E[Y|D=0,X] + is_d0 <- which(D == 0) + y_X_D0_res <- get_CEF(y[is_d0], X[is_d0, , drop = FALSE], + learners = learners, + ensemble_type = ensemble_type, + shortstack = shortstack, + custom_ensemble_weights = + custom_ensemble_weights, + subsamples = indxs$subsamples_byD[[1]], + cv_subsamples = + indxs$cv_subsamples_byD[[1]], + silent = silent, + label = messages$y_D0, + auxiliary_X = get_auxiliary_X( + indxs$aux_indx[[1]], X), + parallel = parallel, + fitted = fitted$y_X_D0) + + ensemble_type <- y_X_D0_res$ensemble_type + nensb <- if (is.null(ensemble_type)) 1L + else length(ensemble_type) + + # Score construction --------------------------------------------------------- + + # Extrapolate E[Y|D=0,X] to full sample. aux_indx is indexed by + # sorted D levels {0, 1}: [[1]] holds positions of {D=1} + # observations per fold, where the D=0 model must extrapolate. + g_X_D0 <- extrapolate_CEF( + D = D, + CEF_res_byD = list(list(fit = y_X_D0_res, d = 0)), + aux_indx = indxs$aux_indx)[, , 1] + + m_X <- D_X_res$cf_fitted m_X_tr <- trim_propensity_scores(m_X, trim, ensemble_type) - - # Compute the ATT using the constructed variables - y_copy <- matrix(rep(y, nensb), nobs, nensb) - D_copy <- matrix(rep(D, nensb), nobs, nensb) - p_copy <- matrix(rep(D_res$oos_fitted, nensb), nobs, nensb) - psi_b <- D_copy * (y_copy - g_X_D0) / p_copy - - m_X_tr * (1 - D_copy) * (y_copy - g_X_D0) / (p_copy * (1 - m_X_tr)) - psi_a <- -D_copy / p_copy - att <- -colMeans(psi_b) / colMeans(psi_a) - names(att) <- ensemble_type - - # Organize complementary ensemble output - weights <- list(y_X_D0 = y_X_D0_res$weights, - D_X = D_X_res$weights) - - # Store complementary ensemble output - mspe <- list(y_X_D0 = y_X_D0_res$mspe, - D_X = D_X_res$mspe) - - # Organize reduced form predicted values - oos_pred <- list(EY_D0_X = g_X_D0, ED_X = m_X, ED = D_res$oos_fitted) - - # Organize output - ddml_fit <- list(att = att, weights = weights, mspe = mspe, - psi_a = psi_a, psi_b = psi_b, - oos_pred = oos_pred, - learners = learners, - learners_DX = learners_DX, - cluster_variable = cluster_variable, - subsamples = cf_indxs$subsamples_byD, - cv_subsamples_list = cf_indxs$cv_subsamples_byD, - ensemble_type = ensemble_type) - - # Print estimation progress - if (!silent) cat("DDML estimation completed. \n") - - # Amend class and return - class(ddml_fit) <- "ddml_att" - return(ddml_fit) + p <- D_res$cf_fitted[, 1] + + D_mat <- matrix(D, nobs, nensb) + y_mat <- matrix(y, nobs, nensb) + p_mat <- matrix(p, nobs, nensb) + + psi_b_mat <- D_mat * (y_mat - g_X_D0) / p_mat - + m_X_tr * (1 - D_mat) * (y_mat - g_X_D0) / (p_mat * (1 - m_X_tr)) + psi_a_vec <- -D / p + + # Target parameter & influence function -------------------------------------- + + att <- -colMeans(psi_b_mat) / mean(psi_a_vec) + + scores <- array(NA_real_, dim = c(nobs, 1, nensb)) + J <- array(NA_real_, dim = c(1, 1, nensb)) + inf_func <- array(NA_real_, dim = c(nobs, 1, nensb)) + dinf_dtheta <- array(NA_real_, dim = c(nobs, 1, 1, nensb)) + for (j in seq_len(nensb)) { + scores[, 1, j] <- psi_a_vec * att[j] + psi_b_mat[, j] + J[1, 1, j] <- mean(psi_a_vec) + + J_inv <- csolve(matrix(J[, , j], 1, 1)) + inf_func[, 1, j] <- matrix(scores[, 1, j], nobs, 1) %*% t(J_inv) + dinf_dtheta[, 1, 1, j] <- psi_a_vec * J_inv[1, 1] + }#FOR + + coef_names <- "ATT" + coef <- matrix(att, nrow = 1, ncol = nensb) + rownames(coef) <- coef_names + colnames(coef) <- ensemble_type + + # Output --------------------------------------------------------------------- + + announce_finish(t0, messages, silent) + + ddml( + coefficients = coef, + ensemble_weights = list( + y_X_D0 = y_X_D0_res$weights, + D_X = D_X_res$weights, + D = D_res$weights), + mspe = list(y_X_D0 = y_X_D0_res$mspe, + D_X = D_X_res$mspe, + D = D_res$mspe), + r2 = list(y_X_D0 = y_X_D0_res$r2, + D_X = D_X_res$r2, + D = D_res$r2), + inf_func = inf_func, dinf_dtheta = dinf_dtheta, + scores = scores, J = J, + coef_names = coef_names, + estimator_name = + "Average Treatment Effect on the Treated", + ensemble_type = ensemble_type, + nobs = nobs, + sample_folds = sample_folds, + cv_folds = if (shortstack) NULL else cv_folds, + shortstack = shortstack, + cluster_variable = cluster_variable, + fitted = list( + y_X_D0 = build_fitted_entry(y_X_D0_res, + save_crossval, + include_auxiliary = TRUE), + D_X = build_fitted_entry(D_X_res, save_crossval), + D = build_fitted_entry(D_res, save_crossval)), + splits = list( + y_X_D0 = list( + subsamples = indxs$subsamples_byD[[1]], + cv_subsamples = indxs$cv_subsamples_byD[[1]]), + y_X_D1 = list( + subsamples = indxs$subsamples_byD[[2]], + cv_subsamples = indxs$cv_subsamples_byD[[2]]), + D_X = list( + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples), + D = list( + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples)), + call = cl, + subclass = "ddml_att", + # ddml_att-specific fields + learners = learners, + learners_DX = learners_DX + ) }#DDML_ATT - -#' @rdname summary.ddml_ate -#' -#' @export -summary.ddml_att <- function(object, ...) { - # Check whether stacking was used, replace ensemble type if TRUE - single_learner <- ("what" %in% names(object$learners)) - if (single_learner) object$ensemble_type <- " " - # Compute and print inference results - coefficients <- organize_interactive_inf_results(coef = object$att, - psi_a = object$psi_a, - psi_b = object$psi_b, - ensemble_type = - object$ensemble_type, - cluster_variable = - object$cluster_variable) - class(coefficients) <- c("summary.ddml_att", class(coefficients)) - coefficients -}#SUMMARY.DDML_ATT - -#' @rdname print.summary.ddml_ate -#' -#' @export -print.summary.ddml_att <- function(x, digits = 3, ...) { - cat("ATT estimation results: \n \n") - class(x) <- class(x)[-1] - print(x, digits = digits) -}#PRINT.SUMMARY.DDML_ATT diff --git a/R/ddml_attgt.R b/R/ddml_attgt.R new file mode 100644 index 0000000..67653bb --- /dev/null +++ b/R/ddml_attgt.R @@ -0,0 +1,473 @@ +#' Estimator for Group-Time Average Treatment Effects +#' +#' @family ddml estimators +#' +#' @description Estimator for group-time average treatment effects +#' on the treated (GT-ATT) in staggered Difference-in-Differences +#' designs. +#' +#' @details +#' \strong{Parameter of Interest:} \code{ddml_attgt} provides a +#' Double/Debiased Machine Learning estimator for the group-time +#' average treatment effects on the treated (GT-ATT) in the +#' staggered adoption model. For each group \eqn{g} and time +#' period \eqn{t}, define the differenced outcome +#' \eqn{\Delta_g Y_{i,t} = Y_{i,t} - Y_{i,g^*}} where +#' \eqn{g^*} is the universal base period. The GT-ATT is: +#' +#' \deqn{\theta_0^{(g,t)} = E[\Delta_g Y_{i,t} | G_i = g] +#' - E[E[\Delta_g Y_{i,t} | X_i, G_i \ne g, G_i > t] | G_i = g]} +#' +#' where \eqn{W_i \equiv (Y_{i,1}, \dots, Y_{i,T}, G_i, X_i)} is the +#' observed random vector. +#' +#' \strong{Neyman Orthogonal Score:} The Neyman orthogonal score +#' is: +#' +#' \deqn{m^{(g,t)}(W_i; \theta, \eta) = +#' \frac{\mathbf{1}\{G_i = g\} (\Delta_g Y_{i,t} +#' - \ell^{(g,t)}(X_i))}{\pi^g} +#' - \frac{q^{(g,t)}(X_i) \mathbf{1}\{G_i \ne g\} +#' \mathbf{1}\{G_i > t\} (\Delta_g Y_{i,t} +#' - \ell^{(g,t)}(X_i))}{\pi^g (1 - q^{(g,t)}(X_i))} +#' - \frac{\mathbf{1}\{G_i = g\}}{\pi^g} \theta} +#' +#' where the nuisance parameters are +#' \eqn{\eta = (\ell, q, \pi)} taking true values +#' \eqn{\ell_0^{(g,t)}(X) = E[\Delta_g Y_{i,t} \mid +#' G_i \ne g, G_i > t, X_i]}, +#' \eqn{q_0^{(g,t)}(X) = \Pr(G_i = g \mid X_i, +#' \{G_i = g\} \cup \{G_i > t\})}, +#' and \eqn{\pi_0^g = \Pr(G_i = g)}. +#' +#' \strong{Jacobian:} +#' +#' \deqn{J^{(g,t)} = -1} +#' +#' See \code{\link{ddml-intro}} for how the influence function +#' and inference are derived from these components. +#' +#' @inheritParams ddml-intro +#' @param y An \eqn{n \times T} numeric matrix of outcomes. +#' Row \eqn{i} corresponds to unit \eqn{i}, column \eqn{j} +#' to time period \code{t[j]}. +#' @param X An \eqn{n \times p} matrix of time-invariant covariates, +#' or \code{NULL}. +#' @param t A numeric vector of length \eqn{T} giving the time +#' period labels (must match columns of \code{y}). +#' @param G A numeric vector of length \eqn{n}. Entry \eqn{i} is the +#' first treatment period for unit \eqn{i}. Use \code{0} or +#' \code{Inf} for never-treated units. +#' @param learners_qX Optional argument to allow for different +#' estimators of the cell-level propensity score +#' \eqn{q^{(g,t)}(X)}. Setup is identical to +#' \code{learners}. +#' @param custom_ensemble_weights_qX Optional argument to allow for +#' different custom ensemble weights for \code{learners_qX}. +#' Setup is identical to \code{custom_ensemble_weights}. +#' @param trim Number in (0, 1) for trimming the estimated +#' propensity scores at \code{trim} and \code{1-trim}. +#' @param control_group Character. \code{"notyettreated"} (default) +#' uses never-treated and not-yet-treated units as controls. +#' \code{"nevertreated"} uses only never-treated units. +#' @param anticipation Non-negative integer. Number of periods before +#' treatment where anticipation effects may occur. Default 0. +#' +#' @return \code{ddml_attgt} returns an object of S3 class +#' \code{ddml_attgt} and \code{ddml}. See \code{\link{ddml-intro}} +#' for the common output structure. Additional pass-through +#' fields: \code{learners}, \code{learners_qX}, +#' \code{cell_info}, \code{control_group}, \code{anticipation}. +#' +#' @references +#' Callaway B, Sant'Anna P H C (2021). "Difference-in-Differences +#' with multiple time periods." Journal of Econometrics, +#' 225(2), 200-230. +#' +#' Chang N-C (2020). "Double/debiased machine learning for +#' difference-in-differences models." Econometrics Journal, +#' 23(2), 177-191. +#' +#' Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, +#' Wiemann T (2026). "An Introduction to Double/Debiased Machine +#' Learning." Journal of Economic Literature, forthcoming. +#' +#' @export +#' +#' @examples +#' \donttest{ +#' set.seed(42) +#' n <- 200; T_ <- 4 +#' X <- matrix(rnorm(n * 2), n, 2) +#' G <- sample(c(3, 4, Inf), n, replace = TRUE, +#' prob = c(0.3, 0.3, 0.4)) +#' y <- matrix(rnorm(n * T_), n, T_) +#' # Add treatment effect for treated units +#' for (i in seq_len(n)) { +#' if (is.finite(G[i])) { +#' for (j in seq_len(T_)) { +#' if (j >= G[i]) y[i, j] <- y[i, j] + 1 +#' } +#' } +#' } +#' fit <- ddml_attgt(y, X, t = 1:T_, G = G, +#' learners = list(what = ols), +#' sample_folds = 2, +#' silent = TRUE) +#' summary(fit) +#' } +ddml_attgt <- function(y, X = NULL, t, G, + learners, + learners_qX = learners, + sample_folds = 10, + ensemble_type = "nnls", + shortstack = FALSE, + cv_folds = 10, + custom_ensemble_weights = NULL, + custom_ensemble_weights_qX = + custom_ensemble_weights, + cluster_variable = seq_len(nrow(as.matrix(y))), + trim = 0.01, + control_group = c("notyettreated", + "nevertreated"), + anticipation = 0, + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ...) { + cl <- match.call() + + # Preliminaries -------------------------------------------------------------- + + control_group <- match.arg(control_group) + y <- as.matrix(y) + n <- nrow(y) + T_ <- ncol(y) + stopifnot(length(t) == T_, length(G) == n) + if (!is.null(X)) { + X <- as.matrix(X) + stopifnot(nrow(X) == n) + }#IF + + dots <- list(...) + messages <- resolve_messages(dots, "ddml_attgt", list()) + + validate_inputs(learners = learners, + sample_folds = sample_folds, + cv_folds = cv_folds, + ensemble_type = ensemble_type, + trim = trim, + cluster_variable = cluster_variable) + validate_inputs(learners = learners_qX) + validate_custom_weights(custom_ensemble_weights, learners) + validate_custom_weights(custom_ensemble_weights_qX, learners_qX) + validate_fitted_splits_pair(fitted, splits) + + t0 <- proc.time()[3] + announce_start(messages, parallel = parallel, silent = silent) + + # Global fold assignment ----------------------------------------------------- + + never_treated <- (G == 0 | is.infinite(G) | G > max(t)) + ever_treated <- as.integer(!never_treated) + + # On re-entry (pass-through): recover global subsamples from the + # dedicated "global" key stored by the previous fit. + global_subsamples_init <- if (!is.null(splits)) splits[["global"]]$subsamples + + global_indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + D = G, stratify = TRUE, + subsamples = global_subsamples_init) + global_subsamples <- global_indxs$subsamples + global_cv_subsamples <- global_indxs$cv_subsamples + + # Convert to fold-vector for fast projection + global_fold_vec <- integer(n) + for (k in seq_len(sample_folds)) global_fold_vec[global_subsamples[[k]]] <- k + + # Enumerate (g, t) pairs ----------------------------------------------------- + + groups <- sort(unique(G[!never_treated])) + times <- sort(t) + gt_list <- list() + for (g_val in groups) { + # Universal base period: last time before g - anticipation + eligible_base <- times[times < g_val - anticipation] + if (length(eligible_base) == 0) next + base_t <- max(eligible_base) + base_col <- match(base_t, t) + for (tt in times) { + if (tt == base_t) next + # Check control pool size before adding the cell + if (control_group == "nevertreated") { + n_ctrl <- sum(never_treated) + } else { + cutoff <- max(tt, base_t + anticipation) + n_ctrl <- sum((never_treated | (G > cutoff)) & G != g_val) + }#IFELSE + n_treat <- sum(G == g_val) + if (n_ctrl == 0 || n_treat == 0) next + gt_list <- c(gt_list, list(list( + g = g_val, t = tt, + base_t = base_t, + base_col = base_col, + tt_col = match(tt, t)))) + }#FOR + }#FOR + C <- length(gt_list) + if (C == 0) { + stop("No valid (g,t) cells found. Check that 'G' and ", + "'t' define at least one post-treatment period.", call. = FALSE) + }#IF + + # Reduced-form estimation ---------------------------------------------------- + + # Cross-fit global pi^g = Pr(G_i = g) per group + pi_g_fitted <- list() + for (g_val in groups) { + g_key <- as.character(g_val) + D_g <- as.integer(G == g_val) + pi_fitted_init <- if (!is.null(fitted)) fitted[[paste0("pi_g:", g_key)]] + pi_g_res <- get_CEF(D_g, matrix(1, n, 1), + learners = list(what = ols, args = list(const = FALSE)), + ensemble_type = "average", + shortstack = FALSE, + subsamples = global_subsamples, + cv_subsamples = global_cv_subsamples, + silent = TRUE, + label = paste0("pi(G=", g_key, ")"), + fitted = pi_fitted_init) + pi_g_fitted[[g_key]] <- pi_g_res + }#FOR + + # Pre-allocate output arrays + nensb <- NULL + coef <- NULL + scores <- NULL + J <- NULL + + ensemble_weights <- list() + mspe <- list() + r2 <- list() + fitted_list <- list() + splits_list <- list() + cell_info <- data.frame( + group = integer(C), time = integer(C), + base_period = integer(C), + n_treated = integer(C), n_control = integer(C)) + + # Store global pi^g fitted entries for pass-through + for (g_key in names(pi_g_fitted)) { + fitted_list[[paste0("pi_g:", g_key)]] <- + build_fitted_entry(pi_g_fitted[[g_key]], save_crossval) + }#FOR + splits_list[["global"]] <- list(subsamples = global_subsamples) + + # Per-cell reduced-form estimation and score construction + for (idx in seq_len(C)) { + gtp <- gt_list[[idx]] + g_val <- gtp$g; tt <- gtp$t + cell_prefix <- paste0("ATT(", g_val, ",", tt, ")") + g_key <- as.character(g_val) + + # Cell membership --------------------------------------------------------- + + treated <- (G == g_val) + if (control_group == "nevertreated") { + control <- never_treated + } else { + cutoff <- max(tt, gtp$base_t + anticipation) + control <- never_treated | (G > cutoff) + }#IFELSE + keep <- which(treated | control) + n_cell <- length(keep) + cell_info[idx, ] <- list( + g_val, tt, gtp$base_t, + sum(treated[keep]), + sum(!treated[keep])) + + info_msg(sprintf( + " Cell (%s,%s): n_treat=%d, n_ctrl=%d [%d/%d]", + g_val, tt, cell_info$n_treated[idx], + cell_info$n_control[idx], idx, C), + silent = silent) + + # Difference outcomes + delta_y <- y[keep, gtp$tt_col] - y[keep, gtp$base_col] + D_cell <- as.integer(treated[keep]) + X_cell <- if (!is.null(X)) { + X[keep, , drop = FALSE] + } else { + matrix(1, nrow = n_cell, ncol = 1) + }#IFELSE + + # Project global folds to cell subset + cell_fold_vec <- global_fold_vec[keep] + active_folds <- sort(unique(cell_fold_vec)) + cell_subsamples <- lapply(active_folds, function(k) { + which(cell_fold_vec == k) + }) + + # Reconstruct per-cell fitted/splits on re-entry + cell_fitted <- if (!is.null(fitted)) { + list( + y_X_D0 = fitted[[paste0(cell_prefix, ":y_X_D0")]], + D_X = fitted[[paste0(cell_prefix, ":D_X")]], + D = fitted[[paste0(cell_prefix, ":D")]]) + }#IF + cell_splits <- if (!is.null(splits)) { + list( + y_X_D0 = splits[[paste0(cell_prefix, ":y_X_D0")]], + y_X_D1 = splits[[paste0(cell_prefix, ":y_X_D1")]], + D_X = splits[[paste0(cell_prefix, ":D_X")]], + D = splits[[paste0(cell_prefix, ":D")]]) + } else { + list(D_X = list(subsamples = cell_subsamples)) + }#IFELSE + + # Cell-level reduced forms via ddml_att ------------------------------------ + + fit <- ddml_att( + y = delta_y, D = D_cell, X = X_cell, + learners = learners, learners_DX = learners_qX, + sample_folds = length(cell_subsamples), + ensemble_type = ensemble_type, + shortstack = shortstack, cv_folds = cv_folds, + custom_ensemble_weights = custom_ensemble_weights, + custom_ensemble_weights_DX = custom_ensemble_weights_qX, + cluster_variable = cluster_variable[keep], + trim = trim, silent = TRUE, parallel = parallel, + save_crossval = save_crossval, + fitted = cell_fitted, + splits = cell_splits, + ...) + + # Collect per-cell diagnostics (flat keying) + for (eq in names(fit$ensemble_weights)) { + key <- paste0(cell_prefix, ":", eq) + ensemble_weights[[key]] <- fit$ensemble_weights[[eq]] + mspe[[key]] <- fit$mspe[[eq]] + r2[[key]] <- fit$r2[[eq]] + }#FOR + for (eq in names(fit$fitted)) { + key <- paste0(cell_prefix, ":", eq) + fitted_list[[key]] <- fit$fitted[[eq]] + }#FOR + for (eq in names(fit$splits)) { + key <- paste0(cell_prefix, ":", eq) + splits_list[[key]] <- fit$splits[[eq]] + }#FOR + + # Determine nensb from first fit and allocate + if (is.null(nensb)) { + nensb <- ncol(fit$coefficients) + ens_type <- colnames(fit$coefficients) + if (is.null(ens_type)) ens_type <- fit$ensemble_type + coef <- matrix(NA_real_, C, nensb) + psi_a_arr <- array(0, dim = c(n, C)) + psi_b_arr <- array(0, dim = c(n, C, nensb)) + scores <- array(0, dim = c(n, C, nensb)) + J <- array(0, dim = c(C, C, nensb)) + inf_func <- array(0, dim = c(n, C, nensb)) + dinf_dtheta <- array(0, dim = c(n, C, C, nensb)) + }#IF + + # Score construction ------------------------------------------------------- + # Extract nuisance estimates from ddml_att fitted entry and construct + # population-level scores. + + # E[DeltaY | D=0, X] extrapolated to all cell units + y_X_D0_entry <- fit$fitted$y_X_D0 + g_X_D0 <- matrix(NA_real_, n_cell, nensb) + g_X_D0[D_cell == 0, ] <- as.matrix(y_X_D0_entry$cf_fitted) + for (k in seq_along(cell_subsamples)) { + fold_k <- cell_subsamples[[k]] + d1_in_k <- fold_k[D_cell[fold_k] == 1] + if (length(d1_in_k) > 0) { + g_X_D0[d1_in_k, ] <- as.matrix( + y_X_D0_entry$auxiliary_fitted[[k]]) + }#IF + }#FOR + + # E[D|X] trimmed propensity + m_X <- as.matrix(fit$fitted$D_X$cf_fitted) + m_X_tr <- trim_propensity_scores(m_X, trim, ens_type) + + # Global pi^g = Pr(G_i = g) + pi_g_cell <- pi_g_fitted[[g_key]]$cf_fitted[keep, 1] + + # Score components + D_cell_mat <- matrix(D_cell, n_cell, nensb) + delta_y_mat <- matrix(delta_y, n_cell, nensb) + pi_g_mat <- matrix(pi_g_cell, n_cell, nensb) + + psi_b_arr[keep, idx, ] <- D_cell_mat * + (delta_y_mat - g_X_D0) / pi_g_mat - + m_X_tr * (1 - D_cell_mat) * (delta_y_mat - g_X_D0) / + (pi_g_mat * (1 - m_X_tr)) + psi_a_arr[keep, idx] <- -D_cell / pi_g_cell + }#FOR + + # Target parameter & influence function -------------------------------------- + + mean_psi_a <- colMeans(psi_a_arr) # C-vector (= J diagonal) + J_inv_vec <- 1 / mean_psi_a # C-vector + + # J and dinf_dtheta are ensemble-independent, they only depend on constants... + J_diag_idx <- cbind(seq_len(C), seq_len(C)) + dinf_dtheta_common <- t(t(psi_a_arr) * J_inv_vec) + for (j in seq_len(nensb)) { + J[, , j][J_diag_idx] <- mean_psi_a + dinf_dtheta[, , , j] <- dinf_dtheta_common + }#FOR + + for (j in seq_len(nensb)) { + coef[, j] <- -colMeans(psi_b_arr[, , j]) / mean_psi_a + + scores[, , j] <- t(t(psi_a_arr) * coef[, j]) + psi_b_arr[, , j] + inf_func[, , j] <- t(t(scores[, , j]) * J_inv_vec) + }#FOR + + coef_names <- paste0("ATT(", cell_info$group, ",", cell_info$time, ")") + rownames(coef) <- coef_names + colnames(coef) <- ens_type + + # Output --------------------------------------------------------------------- + + announce_finish(t0, messages, silent) + + ddml( + coefficients = coef, + ensemble_weights = ensemble_weights, + mspe = mspe, + r2 = r2, + scores = scores, + J = J, + inf_func = inf_func, + dinf_dtheta = dinf_dtheta, + nobs = n, + coef_names = coef_names, + estimator_name = "Group-Time Average Treatment Effects on the Treated", + ensemble_type = ens_type, + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = if (shortstack) NULL else cv_folds, + shortstack = shortstack, + fitted = fitted_list, + splits = splits_list, + call = cl, + subclass = "ddml_attgt", + # ddml_attgt-specific fields + learners = learners, + learners_qX = learners_qX, + cell_info = cell_info, + G = G, + control_group = control_group, + anticipation = anticipation + ) +}#DDML_ATTGT diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index 57f26f7..03df9d3 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -1,25 +1,38 @@ -#' Estimator for the Flexible Partially Linear IV Model. +#' Estimator for the Flexible Partially Linear IV Coefficient #' -#' @family ddml +#' @family ddml estimators #' -#' @seealso [ddml::summary.ddml_fpliv()], [AER::ivreg()] +#' @description Estimator for the flexible partially linear IV coefficient. #' -#' @description Estimator for the flexible partially linear IV model. +#' @details +#' \strong{Parameter of Interest:} \code{ddml_fpliv} provides a Double/Debiased +#' Machine Learning estimator for the flexible partially linear instrumental +#' variable (IV) coefficient \eqn{\theta_0}, defined by the partially linear +#' IV model: #' -#' @details \code{ddml_fpliv} provides a double/debiased machine learning -#' estimator for the parameter of interest \eqn{\theta_0} in the partially -#' linear IV model given by +#' \deqn{Y = \theta_0 D + g_0(X) + \varepsilon, \quad E[\varepsilon|X, Z] = 0,} #' -#' \eqn{Y = \theta_0D + g_0(X) + U,} +#' where \eqn{W \equiv (Y, D, X, Z, \varepsilon)} is a random vector such that +#' \eqn{E[Var(E[D|X, Z]|X)] \neq 0}, and \eqn{g_0(X)} is an unknown nuisance function. +#' +#' \strong{Neyman Orthogonal Score:} The Neyman orthogonal score is: #' -#' where \eqn{(Y, D, X, Z, U)} is a random vector such that -#' \eqn{E[U\vert X, Z] = 0} and \eqn{E[Var(E[D\vert X, Z]\vert X)] \neq 0}, -#' and \eqn{g_0} is an unknown nuisance function. +#' \deqn{m(W; \theta, \eta) = [(Y - \ell(X)) - \theta(D - r(X))](v(X, Z) - r(X))} #' -#' @inheritParams ddml_pliv +#' where the nuisance parameters are \eqn{\eta = (\ell, r, v)} taking +#' true values \eqn{\ell_0(X) = E[Y|X]}, \eqn{r_0(X) = E[D|X]}, and \eqn{v_0(X, Z) = E[D|X, Z]}. +#' +#' \strong{Jacobian:} +#' +#' \deqn{J = -E[(D - r(X))(v(X, Z) - r(X))^\top]} +#' +#' See \code{\link{ddml-intro}} for how the influence function +#' and inference are derived from these components. +#' +#' @inheritParams ddml-intro #' @param Z A (sparse) matrix of instruments. #' @param learners_DXZ,learners_DX Optional arguments to allow for different -#' estimators of \eqn{E[D \vert X, Z]}, \eqn{E[D \vert X]}. Setup is +#' base learners for estimation of \eqn{E[D \vert X, Z]}, \eqn{E[D \vert X]}. Setup is #' identical to \code{learners}. #' @param custom_ensemble_weights_DXZ,custom_ensemble_weights_DX Optional #' arguments to allow for different @@ -28,41 +41,14 @@ #' \code{custom_ensemble_weights} and #' \code{custom_ensemble_weights_DXZ},\code{custom_ensemble_weights_DX} must #' have the same number of columns. -#' @param enforce_LIE Indicator equal to 1 if the law of iterated expectations -#' is enforced in the first stage. #' #' @return \code{ddml_fpliv} returns an object of S3 class -#' \code{ddml_fpliv}. An object of class \code{ddml_fpliv} is a list -#' containing the following components: -#' \describe{ -#' \item{\code{coef}}{A vector with the \eqn{\theta_0} estimates.} -#' \item{\code{weights}}{A list of matrices, providing the weight -#' assigned to each base learner (in chronological order) by the -#' ensemble procedure.} -#' \item{\code{mspe}}{A list of matrices, providing the MSPE of each -#' base learner (in chronological order) computed by the -#' cross-validation step in the ensemble construction.} -#' \item{\code{iv_fit}}{Object of class \code{ivreg} from the IV -#' regression of \eqn{Y - \hat{E}[Y\vert X]} on -#' \eqn{D - \hat{E}[D\vert X]} using -#' \eqn{\hat{E}[D\vert X,Z] - \hat{E}[D\vert X]} as the instrument.} -#' \item{\code{learners},\code{learners_DX},\code{learners_DXZ}, -#' \code{cluster_variable},\code{subsamples}, -#' \code{cv_subsamples_list},\code{ensemble_type}}{Pass-through of -#' selected user-provided arguments. See above.} -#' } +#' \code{ddml_fpliv} and \code{ddml}. See +#' \code{\link{ddml-intro}} for the common output structure. +#' Additional pass-through fields: \code{learners}, +#' \code{learners_DXZ}, \code{learners_DX}. #' @export #' -#' @references -#' Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and -#' Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. -#' -#' Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C B, Newey W, -#' Robins J (2018). "Double/debiased machine learning for treatment and -#' structural parameters." The Econometrics Journal, 21(1), C1-C68. -#' -#' Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. -#' #' @examples #' # Construct variables from the included Angrist & Evans (1998) data #' y = AE98[, "worked"] @@ -70,7 +56,7 @@ #' Z = AE98[, "samesex", drop = FALSE] #' X = AE98[, c("age","agefst","black","hisp","othrace","educ")] #' -#' # Estimate the partially linear IV model using a single base learner: Ridge. +#' # Estimate the partially linear IV model using a single base learner, ridge. #' fpliv_fit <- ddml_fpliv(y, D, Z, X, #' learners = list(what = mdl_glmnet, #' args = list(alpha = 0)), @@ -85,267 +71,225 @@ ddml_fpliv <- function(y, D, Z, X, ensemble_type = "nnls", shortstack = FALSE, cv_folds = 10, - enforce_LIE = TRUE, custom_ensemble_weights = NULL, custom_ensemble_weights_DXZ = custom_ensemble_weights, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples = NULL, - cv_subsamples_list = NULL, - silent = FALSE) { - # Data parameters - nobs <- length(y) - nensb_raw <- length(ensemble_type) # number of ensembles w/o custom weights + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ...) { + cl <- match.call() - # Check for multivariate endogenous variables + # Preliminaries -------------------------------------------------------------- + + dots <- list(...) + messages <- resolve_messages(dots, "ddml_fpliv", list( + y_X = "E[Y|X]")) + + validate_inputs(y = y, D = D, X = X, Z = Z, + learners = learners, + sample_folds = sample_folds, + cv_folds = cv_folds, + ensemble_type = ensemble_type, + cluster_variable = cluster_variable) + validate_custom_weights(custom_ensemble_weights, learners) + validate_custom_weights(custom_ensemble_weights_DXZ, + learners_DXZ) + validate_custom_weights(custom_ensemble_weights_DX, + learners_DX) + + nobs <- length(y) D <- as.matrix(D) nD <- ncol(D) - # Create sample and cv-fold tuples - cf_indxs <- get_crossfit_indices(cluster_variable = cluster_variable, - sample_folds = sample_folds, - cv_folds = cv_folds, - subsamples = subsamples, - cv_subsamples_list = cv_subsamples_list) - - # Print to progress to console - if (!silent) cat("DDML estimation in progress. \n") + validate_fitted_splits_pair(fitted, splits) - # Compute estimates of E[y|X] - y_X_res <- get_CEF(y, X, Z = NULL, - learners = learners, ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, - compute_insample_predictions = F, - silent = silent, progress = "E[Y|X]: ") + indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + subsamples = splits[[1]]$subsamples, + cv_subsamples = splits[[1]]$cv_subsamples) + check_subsamples(indxs$subsamples, NULL, stratify = FALSE) - # Compute estimates of E[D|X,Z]. Also calculate in-sample predictions when - # the LIE is enforced. - D_XZ_res_list <- list() - for (k in 1:nD) { - D_XZ_res_list[[k]] <- get_CEF(D[, k, drop = F], X, Z, - learners = learners_DXZ, - ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = - custom_ensemble_weights_DXZ, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = - cf_indxs$cv_subsamples_list, - compute_insample_predictions = enforce_LIE, - silent = silent, - progress = paste0("E[D", k, "|X,Z]: ")) - }#FOR + t0 <- proc.time()[3] + announce_start(messages, parallel, silent) - # When the LIE is not enforced, estimating E[D|X] is straightforward. - if (!enforce_LIE) { - D_X_res_list <- list() - for (k in 1:nD) { - D_X_res_list[[k]] <- get_CEF(D[, k, drop = F], X, Z = NULL, - learners = learners_DX, - ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = - custom_ensemble_weights_DX, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = - cf_indxs$cv_subsamples_list, - compute_insample_predictions = F, - silent = silent, - progress = paste0("E[D", k, "|X]: ")) - }#FOR - }#IF + # Reduced-form estimation ---------------------------------------------------- - # Update ensemble type to account for (optional) custom weights - ensemble_type <- dimnames(y_X_res$weights)[[2]] - nensb <- length(ensemble_type) + # E[Y|X] + y_X_res <- get_CEF(y, X, + learners = learners, + ensemble_type = ensemble_type, + shortstack = shortstack, + custom_ensemble_weights = + custom_ensemble_weights, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, + silent = silent, label = messages$y_X, + parallel = parallel, + fitted = fitted$y_X) - # Check whether multiple ensembles are computed simultaneously - multiple_ensembles <- nensb > 1 + # E[D|X,Z] — merge X and Z, translate assign_Z to assign_X offsets + nX <- ncol(X) + nZ <- ncol(Z) + XZ <- cbind(X, Z) + if (!is_single_learner(learners_DXZ)) { + learners_DXZ <- lapply(learners_DXZ, function(l) { + az <- l$assign_Z + if (is.null(az)) az <- seq_len(nZ) + ax <- l$assign_X + if (is.null(ax)) ax <- seq_len(nX) + l$assign_X <- c(ax, nX + az) + l$assign_Z <- NULL + l + })#LAPPLY + }#IF + # E[D|X,Z] + D_XZ_res_list <- vector("list", nD) + for (k in seq_len(nD)) { + D_XZ_res_list[[k]] <- get_CEF( + D[, k, drop = FALSE], XZ, + learners = learners_DXZ, + ensemble_type = ensemble_type, + shortstack = shortstack, + custom_ensemble_weights = custom_ensemble_weights_DXZ, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, + silent = silent, + label = paste0("E[D", k, "|X,Z]"), + parallel = parallel, + fitted = fitted[[paste0("D", k, "_XZ")]]) + }#FOR - # If a single ensemble is calculated, no loops are required. - if (!multiple_ensembles) { - # Check whether the law of iterated expectations (LIE) should be enforced. - # When the LIE is enforced (recommended), the estimates of E[D|X,Z] are - # used for the calculation of the estimates of E[D|X]. - if (enforce_LIE) { - D_X_res_list <- list() - for (k in 1:nD) { - D_X_res_list[[k]] <- - get_CEF(D_XZ_res_list[[k]]$is_fitted, X, Z = NULL, - learners = learners_DX, - ensemble_type = ensemble_type, - shortstack = shortstack, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, - compute_insample_predictions = F, - silent = silent, - progress = paste0("E[D", k, "|X]: "), - shortstack_y = D_XZ_res_list[[k]]$oos_fitted) - }#FOR - }#IFELSE + # E[D|X] + D_X_res_list <- vector("list", nD) + for (k in seq_len(nD)) { + D_X_res_list[[k]] <- get_CEF( + D[, k, drop = FALSE], X, + learners = learners_DX, + ensemble_type = ensemble_type, + shortstack = shortstack, + custom_ensemble_weights = custom_ensemble_weights_DX, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, + silent = silent, + label = paste0("E[D", k, "|X]"), + parallel = parallel, + fitted = fitted[[paste0("D", k, "_X")]]) + }#FOR - # Residualize - y_r <- y - y_X_res$oos_fitted - D_r <- D - get_oosfitted(D_X_res_list) - V_r <- get_oosfitted(D_XZ_res_list) - get_oosfitted(D_X_res_list) + ensemble_type <- y_X_res$ensemble_type + nensb <- if (is.null(ensemble_type)) 1L + else length(ensemble_type) - # Compute IV estimate with constructed variables - iv_fit <- AER::ivreg(y_r ~ D_r | V_r) + # Target parameter & influence function -------------------------------------- - # Organize complementary ensemble output - coef <- stats::coef(iv_fit)[-1] - }#IF + coef <- matrix(0, nD + 1, nensb) + scores <- array(NA_real_, dim = c(nobs, nD + 1, nensb)) + J <- array(NA_real_, dim = c(nD + 1, nD + 1, nensb)) + inf_func <- array(NA_real_, dim = c(nobs, nD + 1, nensb)) + dinf_dtheta <- array(NA_real_, dim = c(nobs, nD + 1, nD + 1, nensb)) - # If multiple ensembles are calculated, iterate over each type. - if (multiple_ensembles) { - # Iterate over ensemble type. Compute DDML IV estimate for each. - coef <- matrix(0, nD, nensb) - iv_fit <- rep(list(1), nensb) - nlearners <- length(learners) - nlearners_DX <- length(learners_DX); nlearners_DXZ <- length(learners_DXZ) - # Assign names for more legible output - colnames(coef) <- names(iv_fit) <- ensemble_type + cn_weights <- dimnames(y_X_res$weights)[[2]] + colnames(coef) <- if (is.null(cn_weights)) ensemble_type else cn_weights - # Create intermediate weight matrices for enforce_LIE = TRUE - if (enforce_LIE) { - # weights - weights_DX <- array(0, dim = c(nlearners_DX, nensb, sample_folds)) - dimnames(weights_DX) <- dimnames(y_X_res$weights) - weights_DX <- replicate(nD, weights_DX, simplify = FALSE) - }#IF + for (j in seq_len(nensb)) { + D_r <- D - get_cf_fitted(D_X_res_list, j) + V_r <- get_cf_fitted(D_XZ_res_list, j) - + get_cf_fitted(D_X_res_list, j) + y_r <- y - cbind(y_X_res$cf_fitted)[, j] - # Compute coefficients for each ensemble - for (j in 1:nensb) { - # When the LIE is enforced, compute LIE-conform estimates of E[D|X]. - # Otherwise use the previously calculated estimates of E[D|X]. - if (enforce_LIE) { - D_X_res_list <- list() - for (k in 1:nD) { - progress_jk <- paste0("E[D", k, "|X] (", ensemble_type[j], "): ") + D_r_mat <- as.matrix(D_r) + V_r_mat <- as.matrix(V_r) + + D_fit <- cbind(D_r_mat, 1) + V_fit <- cbind(V_r_mat, 1) + + # 2SLS: First stage projection + pi_hat <- qr.solve(V_fit, D_fit) + D_hat <- V_fit %*% pi_hat - # Check whether j is a custom ensemble specification. Necessary to - # assign correct corresponding custom_weights vector. - if (j <= nensb_raw) { # j is not a custom specification - D_X_res_list[[k]] <- - get_CEF(D_XZ_res_list[[k]]$is_fitted[[j]], X, Z = NULL, - learners = learners_DX, - ensemble_type = ensemble_type[j], - shortstack = shortstack, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, - compute_insample_predictions = F, - silent = silent, - progress = progress_jk, - shortstack_y = D_XZ_res_list[[k]]$oos_fitted[, j]) - } else { # j is a custom specification - D_X_res_list[[k]] <- - get_CEF(D_XZ_res_list[[k]]$is_fitted[[j]], X, Z = NULL, - learners = learners_DX, - ensemble_type = "average", - shortstack = shortstack, - custom_ensemble_weights = - custom_ensemble_weights_DX[, j - nensb_raw, drop = F], - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, - compute_insample_predictions = F, - silent = silent, - progress = progress_jk, - shortstack_y = D_XZ_res_list[[k]]$oos_fitted[, j]) - # Remove "average" oos_fitted and weights - D_X_res_list[[k]]$oos_fitted <- D_X_res_list[[k]]$oos_fitted[, -1] - D_X_res_list[[k]]$weights <- D_X_res_list[[k]]$weights[, -1, , - drop = F] - }#IFELSE + # 2SLS: Second stage fit + coef_iv_j <- as.vector(qr.solve(D_hat, y_r)) + coef[, j] <- coef_iv_j + X_hat <- D_hat + X_full <- D_fit + e_j <- as.vector(y_r - X_full %*% coef_iv_j) - }#FOR - }#IF + scores[, , j] <- X_hat * e_j + J[, , j] <- -crossprod(X_hat, X_full) / nobs - # Residualize - if (enforce_LIE) { - D_r <- D - get_oosfitted(D_X_res_list) - V_r <- get_oosfitted(D_XZ_res_list, j) - get_oosfitted(D_X_res_list) - } else { - D_r <- D - get_oosfitted(D_X_res_list, j) - V_r <- get_oosfitted(D_XZ_res_list, j) - get_oosfitted(D_X_res_list, j) - }#IFELSE + J_inv <- csolve(matrix(J[, , j], nD + 1, nD + 1)) + inf_func[, , j] <- matrix(scores[, , j], nobs, nD + 1) %*% t(J_inv) + + U <- X_hat %*% t(J_inv) + dinf_dtheta[, , , j] <- sapply(seq_len(nD + 1), function(k) { + -X_full[, k] * U + }, simplify = "array") + }#FOR - # Residualize y - y_r <- y - y_X_res$oos_fitted[, j] - # Compute IV estimate with constructed variables - iv_fit_j <- AER::ivreg(y_r ~ D_r | V_r) + cn_j <- colnames(D) + if (is.null(cn_j)) cn_j <- paste0("D", seq_len(nD)) + rownames(coef) <- c(cn_j, "(Intercept)") + coef_names <- rownames(coef) - # Organize complementary ensemble output - coef[, j] <- stats::coef(iv_fit_j)[-1] - iv_fit[[j]] <- iv_fit_j - if (enforce_LIE) { - for (k in 1:nD) weights_DX[[k]][, j, ] <- D_X_res_list[[k]]$weights - }#IF - }#FOR - }#IF + # Output --------------------------------------------------------------------- - # Store complementary ensemble output - weights <- list(y_X = y_X_res$weights) + ensemble_weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) - for (k in 1:nD){ - if (enforce_LIE & multiple_ensembles) { - weights[[paste0("D", k, "_X")]] <- weights_DX[[k]] - } else { - weights[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$weights - }#IFELSE - #mspe[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$mspe + r2 <- list(y_X = y_X_res$r2) + for (k in seq_len(nD)) { + eq <- paste0("D", k, "_X") + ensemble_weights[[eq]] <- D_X_res_list[[k]]$weights + mspe[[eq]] <- D_X_res_list[[k]]$mspe + r2[[eq]] <- D_X_res_list[[k]]$r2 }#FOR - for (k in 1:nD){ - weights[[paste0("D", k, "_XZ")]] <- D_XZ_res_list[[k]]$weights - mspe[[paste0("D", k, "_XZ")]] <- D_XZ_res_list[[k]]$mspe + for (k in seq_len(nD)) { + eq <- paste0("D", k, "_XZ") + ensemble_weights[[eq]] <- D_XZ_res_list[[k]]$weights + mspe[[eq]] <- D_XZ_res_list[[k]]$mspe + r2[[eq]] <- D_XZ_res_list[[k]]$r2 }#FOR - # Organize output - ddml_fit <- list(coef = coef, weights = weights, mspe = mspe, - learners = learners, - learners_DXZ = learners_DXZ, - learners_DX = learners_DX, - iv_fit = iv_fit, - cluster_variable = cluster_variable, - subsamples = subsamples, - cv_subsamples_list = cv_subsamples_list, - ensemble_type = ensemble_type, - enforce_LIE = enforce_LIE) - - # Print estimation progress - if (!silent) cat("DDML estimation completed. \n") + announce_finish(t0, messages, silent) - # Amend class and return - class(ddml_fit) <- "ddml_fpliv" - return(ddml_fit) + ddml( + coefficients = coef, + ensemble_weights = ensemble_weights, + mspe = mspe, + r2 = r2, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, + scores = scores, J = J, + coef_names = coef_names, + estimator_name = "Flexible Partially Linear IV Model", + ensemble_type = ensemble_type, + nobs = nobs, + sample_folds = sample_folds, + cv_folds = if (shortstack) NULL else cv_folds, + shortstack = shortstack, + cluster_variable = cluster_variable, + fitted = c( + list(y_X = build_fitted_entry(y_X_res, save_crossval)), + build_fitted_flat(D_XZ_res_list, save_crossval, + "D", "_XZ"), + build_fitted_flat(D_X_res_list, save_crossval, + "D", "_X")), + splits = stats::setNames( + rep(list(list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples)), + length(ensemble_weights)), + names(ensemble_weights)), + call = cl, + subclass = "ddml_fpliv", + # ddml_fpliv-specific fields + learners = learners, + learners_DXZ = learners_DXZ, + learners_DX = learners_DX + ) }#DDML_FPLIV - -#' @rdname summary.ddml_plm -#' -#' @export -summary.ddml_fpliv <- function(object, ...) { - # Check whether stacking was used, replace ensemble type if TRUE - single_learner <- ("what" %in% names(object$learners)) - if (single_learner) object$ensemble_type <- "single base learner" - # Compute and print inference results - coefficients <- organize_inf_results(fit_obj_list = object$iv_fit, - ensemble_type = object$ensemble_type, - cluster_variable = - object$cluster_variable, - ...) - class(coefficients) <- c("summary.ddml_fpliv", class(coefficients)) - coefficients -}#SUMMARY.DDML_FPLIV - -#' @rdname print.summary.ddml_plm -#' -#' @export -print.summary.ddml_fpliv <- function(x, digits = 3, ...) { - cat("FPLIV estimation results: \n \n") - class(x) <- class(x)[-1] - print(x, digits = digits) -}#PRINT.SUMMARY.DDML_FPLIV diff --git a/R/ddml_late.R b/R/ddml_late.R index a49544e..70353fd 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -1,62 +1,43 @@ -#' Estimator of the Local Average Treatment Effect. +#' Estimator for the Local Average Treatment Effect #' -#' @family ddml +#' @family ddml estimators #' -#' @seealso [ddml::summary.ddml_late()] +#' @description Estimator for the local average treatment effect. #' -#' @description Estimator of the local average treatment effect. +#' @details +#' \strong{Parameter of Interest:} \code{ddml_late} provides a +#' Double/Debiased Machine Learning estimator for the local average +#' treatment effect. Under the standard instrumental variable assumptions +#' (conditional independence, exclusion restriction, relevance, and +#' monotonicity) with a binary instrument \eqn{Z} and a binary treatment +#' \eqn{D}, the parameter is identified by the following reduced form +#' parameter: #' -#' @details \code{ddml_late} provides a double/debiased machine learning -#' estimator for the local average treatment effect in the interactive model -#' given by +#' \deqn{\theta_0^{\textrm{LATE}} = \frac{E[E[Y|Z=1, X] - E[Y|Z=0, X]]}{E[E[D|Z=1, X] - E[D|Z=0, X]]}} #' -#' \eqn{Y = g_0(D, X) + U,} +#' where \eqn{W \equiv (Y, D, X, Z)} is the observed random vector. #' -#' where \eqn{(Y, D, X, Z, U)} is a random vector such that -#' \eqn{\operatorname{supp} D = \operatorname{supp} Z = \{0,1\}}, -#' \eqn{E[U\vert X, Z] = 0}, \eqn{E[Var(E[D\vert X, Z]\vert X)] \neq 0}, -#' \eqn{\Pr(Z=1\vert X) \in (0, 1)} with probability 1, -#' \eqn{p_0(1, X) \geq p_0(0, X)} with probability 1 where -#' \eqn{p_0(Z, X) \equiv \Pr(D=1\vert Z, X)}, and -#' \eqn{g_0} is an unknown nuisance function. +#' \strong{Nuisance Parameters:} The nuisance parameters are +#' \eqn{\eta = (\ell_0, \ell_1, r_0, r_1, p)} taking true values +#' \eqn{\ell_{z,0}(X) = E[Y|Z=z, X]}, \eqn{r_{z,0}(X) = E[D|Z=z, X]}, +#' and \eqn{p_0(X) = \Pr(Z=1|X)}. #' -#' In this model, the local average treatment effect is defined as +#' \strong{Neyman Orthogonal Score / Moment Equation:} The Neyman orthogonal score is: #' -#' \eqn{\theta_0^{\textrm{LATE}} \equiv -#' E[g_0(1, X) - g_0(0, X)\vert p_0(1, X) > p(0, X)]}. +#' \deqn{m(W; \theta, \eta) = \frac{Z(Y - \ell_1(X))}{p(X)} - \frac{(1-Z)(Y-\ell_0(X))}{1-p(X)} + \ell_1(X) - \ell_0(X) - \theta\left(\frac{Z(D - r_1(X))}{p(X)} - \frac{(1-Z)(D-r_0(X))}{1-p(X)} + r_1(X) - r_0(X)\right)} #' -#' @inheritParams ddml_ate +#' \strong{Jacobian:} +#' +#' \deqn{J = -E[r_1(X) - r_0(X)]} +#' +#' See \code{\link{ddml-intro}} for how the influence function +#' and inference are derived from these components. +#' +#' @inheritParams ddml-intro +#' @inheritParams ddml_apo #' @param Z Binary instrumental variable. -#' @param learners May take one of two forms, depending on whether a single -#' learner or stacking with multiple learners is used for estimation of the -#' conditional expectation functions. -#' If a single learner is used, \code{learners} is a list with two named -#' elements: -#' \itemize{ -#' \item{\code{what} The base learner function. The function must be -#' such that it predicts a named input \code{y} using a named input -#' \code{X}.} -#' \item{\code{args} Optional arguments to be passed to \code{what}.} -#' } -#' If stacking with multiple learners is used, \code{learners} is a list of -#' lists, each containing four named elements: -#' \itemize{ -#' \item{\code{fun} The base learner function. The function must be -#' such that it predicts a named input \code{y} using a named input -#' \code{X}.} -#' \item{\code{args} Optional arguments to be passed to \code{fun}.} -#' \item{\code{assign_X} An optional vector of column indices -#' corresponding to control variables in \code{X} that are passed to -#' the base learner.} -#' \item{\code{assign_Z} An optional vector of column indices -#' corresponding to instruments in \code{Z} that are passed to the -#' base learner.} -#' } -#' Omission of the \code{args} element results in default arguments being -#' used in \code{fun}. Omission of \code{assign_X} (and/or \code{assign_Z}) -#' results in inclusion of all variables in \code{X} (and/or \code{Z}). #' @param learners_DXZ,learners_ZX Optional arguments to allow for different -#' estimators of \eqn{E[D \vert X, Z]}, \eqn{E[Z \vert X]}. Setup is +#' base learners for estimation of \eqn{E[D \vert X, Z]}, \eqn{E[Z \vert X]}. Setup is #' identical to \code{learners}. #' @param custom_ensemble_weights_DXZ,custom_ensemble_weights_ZX Optional #' arguments to allow for different @@ -65,51 +46,23 @@ #' \code{custom_ensemble_weights} and #' \code{custom_ensemble_weights_DXZ},\code{custom_ensemble_weights_ZX} must #' have the same number of columns. -#' @param subsamples_byZ List of two lists corresponding to the two instrument -#' levels. Each list contains vectors with sample indices for -#' cross-fitting. -#' @param cv_subsamples_byZ List of two lists, each corresponding to one of the -#' two instrument levels. Each of the two lists contains lists, each -#' corresponding to a subsample and contains vectors with subsample indices -#' for cross-validation. +#' @param splits An optional list of sample split objects. For +#' \code{ddml_late}, recommended keys are \code{subsamples}, +#' \code{subsamples_byZ}, \code{cv_subsamples}, and +#' \code{cv_subsamples_byZ}. +#' @param ... Additional arguments passed to internal methods. #' #' @return \code{ddml_late} returns an object of S3 class -#' \code{ddml_late}. An object of class \code{ddml_late} is a list -#' containing the following components: -#' \describe{ -#' \item{\code{late}}{A vector with the average treatment effect -#' estimates.} -#' \item{\code{weights}}{A list of matrices, providing the weight -#' assigned to each base learner (in chronological order) by the -#' ensemble procedure.} -#' \item{\code{mspe}}{A list of matrices, providing the MSPE of each -#' base learner (in chronological order) computed by the -#' cross-validation step in the ensemble construction.} -#' \item{\code{psi_a}, \code{psi_b}}{Matrices needed for the computation -#' of scores. Used in [ddml::summary.ddml_late()].} -#' \item{\code{oos_pred}}{List of matrices, providing the reduced form -#' predicted values.} -#' \item{\code{learners},\code{learners_DXZ},\code{learners_ZX}, -#' \code{cluster_variable},\code{subsamples_Z0}, -#' \code{subsamples_Z1},\code{cv_subsamples_list_Z0}, -#' \code{cv_subsamples_list_Z1},\code{ensemble_type}}{Pass-through -#' of selected user-provided arguments. See above.} -#' } +#' \code{ddml_late} and \code{ddml}. See +#' \code{\link{ddml-intro}} for the common output structure. +#' Additional pass-through fields: \code{learners}, +#' \code{learners_DXZ}, \code{learners_ZX}. #' @export #' #' @references -#' Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and -#' Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. -#' -#' Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C B, Newey W, -#' Robins J (2018). "Double/debiased machine learning for treatment and -#' structural parameters." The Econometrics Journal, 21(1), C1-C68. -#' -#' Imbens G, Angrist J (1004). "Identification and Estimation of Local Average +#' Imbens G, Angrist J (1994). "Identification and Estimation of Local Average #' Treatment Effects." Econometrica, 62(2), 467-475. #' -#' Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. -#' #' @examples #' # Construct variables from the included Angrist & Evans (1998) data #' y = AE98[, "worked"] @@ -126,15 +79,16 @@ #' silent = TRUE) #' summary(late_fit) #' +#' \donttest{ #' # Estimate the local average treatment effect using short-stacking with base #' # learners ols, lasso, and ridge. We can also use custom_ensemble_weights -#' # to estimate the ATE using every individual base learner. +#' # to estimate the LATE using every individual base learner. #' weights_everylearner <- diag(1, 3) #' colnames(weights_everylearner) <- c("mdl:ols", "mdl:lasso", "mdl:ridge") #' late_fit <- ddml_late(y, D, Z, X, -#' learners = list(list(fun = ols), -#' list(fun = mdl_glmnet), -#' list(fun = mdl_glmnet, +#' learners = list(list(what = ols), +#' list(what = mdl_glmnet), +#' list(what = mdl_glmnet, #' args = list(alpha = 0))), #' ensemble_type = 'nnls', #' custom_ensemble_weights = weights_everylearner, @@ -142,6 +96,7 @@ #' sample_folds = 2, #' silent = TRUE) #' summary(late_fit) +#' } ddml_late <- function(y, D, Z, X, learners, learners_DXZ = learners, @@ -154,199 +109,180 @@ ddml_late <- function(y, D, Z, X, custom_ensemble_weights_DXZ = custom_ensemble_weights, custom_ensemble_weights_ZX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples_byZ = NULL, - cv_subsamples_byZ = NULL, + stratify = TRUE, trim = 0.01, - silent = FALSE) { - # Data parameters - nobs <- length(y) - is_Z0 <- which(Z == 0) - - # Create sample and cv-fold tuples - cf_indxs <- get_crossfit_indices(cluster_variable = cluster_variable, D = Z, - sample_folds = sample_folds, - cv_folds = cv_folds, - subsamples_byD = subsamples_byZ, - cv_subsamples_byD = cv_subsamples_byZ) + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ...) { + cl <- match.call() - # Create tuple for extrapolated fitted values - aux_indxs <- get_auxiliary_indx(cf_indxs$subsamples_byD, Z) + # Preliminaries -------------------------------------------------------------- - # Print to progress to console - if (!silent) cat("DDML estimation in progress. \n") + dots <- list(...) + messages <- resolve_messages(dots, "ddml_late", list( + y_Z0 = "E[Y|Z=0,X]", + y_Z1 = "E[Y|Z=1,X]", + D_Z0 = "E[D|Z=0,X]", + D_Z1 = "E[D|Z=1,X]", + Z_X = "E[Z|X]")) - # Compute estimates of E[y|Z=0,X] - y_X_Z0_res <- get_CEF(y[is_Z0], X[is_Z0, , drop = F], - learners = learners, ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights, - subsamples = cf_indxs$subsamples_byD[[1]], - cv_subsamples_list = cf_indxs$cv_subsamples_byD[[1]], - silent = silent, progress = "E[Y|Z=0,X]: ", - auxiliary_X = get_auxiliary_X(aux_indxs[[1]], X)) + validate_inputs(y = y, D = D, X = X, Z = Z, + learners = learners, + sample_folds = sample_folds, + cv_folds = cv_folds, + ensemble_type = ensemble_type, trim = trim, + cluster_variable = cluster_variable, + require_binary_D = FALSE) + validate_custom_weights(custom_ensemble_weights, learners) + validate_custom_weights(custom_ensemble_weights_DXZ, + learners_DXZ) + validate_custom_weights(custom_ensemble_weights_ZX, + learners_ZX) - # Compute estimates of E[y|Z=1,X] - y_X_Z1_res <- get_CEF(y[-is_Z0], X[-is_Z0, , drop = F], - learners = learners, ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights, - subsamples = cf_indxs$subsamples_byD[[2]], - cv_subsamples_list = cf_indxs$cv_subsamples_byD[[2]], - silent = silent, progress = "E[Y|Z=1,X]: ", - auxiliary_X = get_auxiliary_X(aux_indxs[[2]], X)) + nobs <- length(y) - # Check for perfect non-compliance - if (all(D[Z==0] == 0)) { - # Artificially construct values for subsample with Z=0 - D_X_Z0_res <- list(NULL) - D_X_Z0_res$oos_fitted <- rep(0, length(is_Z0)) - D_X_Z0_res$auxiliary_fitted <- - lapply(y_X_Z0_res$auxiliary_fitted, function (x) {x * 0}) - if (!silent) cat("E[D|Z=0,X]: perfect non-compliance -- Done! \n") - } else { - # Compute estimates of E[D|Z=0,X] - D_X_Z0_res <- get_CEF(D[is_Z0], X[is_Z0, , drop = F], - learners = learners_DXZ, - ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights_DXZ, - subsamples = cf_indxs$subsamples_byD[[1]], - cv_subsamples_list = cf_indxs$cv_subsamples_byD[[1]], - silent = silent, progress = "E[Y|Z=0,X]: ", - auxiliary_X = get_auxiliary_X(aux_indxs[[1]], X)) - }#IFELSE + validate_fitted_splits_pair(fitted, splits) - # Check for perfect compliance - if (all(D[Z==1] == 1)) { - # Artificially construct values for subsample with Z=0 - D_X_Z1_res <- list(NULL) - D_X_Z1_res$oos_fitted <- rep(0, nobs - length(is_Z0)) - D_X_Z1_res$auxiliary_fitted <- - lapply(y_X_Z1_res$auxiliary_fitted, function (x) {x * 0}) - if (!silent) cat("E[D|Z=1,X]: perfect compliance -- Done! \n") - } else { - # Compute estimates of E[D|Z=1,X] - D_X_Z1_res <- get_CEF(D[-is_Z0], X[-is_Z0, , drop = F], - learners = learners_DXZ, - ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights_DXZ, - subsamples = cf_indxs$subsamples_byD[[2]], - cv_subsamples_list = cf_indxs$cv_subsamples_byD[[2]], - silent = silent, progress = "E[Y|Z=0,X]: ", - auxiliary_X = get_auxiliary_X(aux_indxs[[2]], X)) - }#IFELSE + t0 <- proc.time()[3] + announce_start(messages, parallel, silent) - # Compute estimates of E[Z|X] - Z_X_res <- get_CEF(Z, X, - learners = learners_ZX, ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights_ZX, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, - compute_insample_predictions = F, - silent = silent, progress = "E[Z|X]: ") + # Reduced-form estimation ---------------------------------------------------- - # Update ensemble type to account for (optional) custom weights - ensemble_type <- dimnames(y_X_Z0_res$weights)[[2]] - nensb <- ifelse(is.null(ensemble_type), 1, length(ensemble_type)) + # Map LATE splits/fitted to ATE's expected format. + ate_splits <- if (!is.null(splits)) list( + y_X_D0 = splits$y_X_Z0, + y_X_D1 = splits$y_X_Z1, + D_X = splits$Z_X) + ate_fitted_rf <- if (!is.null(fitted)) list( + y_X_D0 = fitted$y_X_Z0, + y_X_D1 = fitted$y_X_Z1, + D_X = fitted$Z_X) - # Check whether multiple ensembles are computed simultaneously - multiple_ensembles <- nensb > 1 + # Reduced form: Y ~ Z via ddml_ate + ate_rf <- ddml_ate( + y = y, D = Z, X = X, + learners = learners, learners_DX = learners_ZX, + sample_folds = sample_folds, cv_folds = cv_folds, + custom_ensemble_weights = custom_ensemble_weights, + custom_ensemble_weights_DX = custom_ensemble_weights_ZX, + cluster_variable = cluster_variable, + ensemble_type = ensemble_type, shortstack = shortstack, + stratify = stratify, + trim = trim, parallel = parallel, silent = silent, + splits = ate_splits, + fitted = ate_fitted_rf, + save_crossval = save_crossval, + messages = list(start = "", finish = "", + y_D1 = messages$y_Z1, + y_D0 = messages$y_Z0, + D_X = messages$Z_X)) - # Construct reduced form variables - l_X_byZ <- extrapolate_CEF(D = Z, - CEF_res_byD = list(list(y_X_Z0_res, d=0), - list(y_X_Z1_res, d=1)), - aux_indxs = aux_indxs) - p_X_byZ <- extrapolate_CEF(D = Z, - CEF_res_byD = list(list(D_X_Z0_res, d=0), - list(D_X_Z1_res, d=1)), - aux_indxs = aux_indxs) - r_X <- Z_X_res$oos_fitted + # First stage: D ~ Z via ddml_ate (reuses splits + propensity) + ate_fs <- ddml_ate( + y = D, D = Z, X = X, + learners = learners_DXZ, learners_DX = learners_ZX, + sample_folds = sample_folds, cv_folds = cv_folds, + custom_ensemble_weights = custom_ensemble_weights_DXZ, + custom_ensemble_weights_DX = custom_ensemble_weights_ZX, + cluster_variable = cluster_variable, + ensemble_type = ensemble_type, shortstack = shortstack, + stratify = stratify, + trim = trim, parallel = parallel, silent = silent, + splits = ate_rf$splits, + fitted = list(y_X_D0 = fitted$D_X_Z0, + y_X_D1 = fitted$D_X_Z1, + D_X = ate_rf$fitted$D_X), + save_crossval = save_crossval, + messages = list(start = "", finish = "", + y_D1 = messages$D_Z1, + y_D0 = messages$D_Z0, D_X = "")) - # Trim propensity scores, return warnings - r_X_tr <- trim_propensity_scores(r_X, trim, ensemble_type) + ensemble_type <- ate_rf$ensemble_type + nensb <- ncol(ate_rf$coefficients) - # Compute the ATE using the constructed variables - y_copy <- matrix(rep(y, nensb), nobs, nensb) - D_copy <- matrix(rep(D, nensb), nobs, nensb) - Z_copy <- matrix(rep(Z, nensb), nobs, nensb) - psi_b <- Z_copy * (y_copy - l_X_byZ[, , 2]) / r_X_tr - - (1 - Z_copy) * (y_copy - l_X_byZ[, , 1]) / (1 - r_X_tr) + - l_X_byZ[, , 2] - l_X_byZ[, , 1] - psi_a <- -(Z_copy * (D_copy - p_X_byZ[, , 2]) / r_X_tr - - (1 - Z_copy) * (D_copy - p_X_byZ[, , 1]) / (1 - r_X_tr) + - p_X_byZ[, , 2] - p_X_byZ[, , 1]) - numerator <- colMeans(psi_b) - denominator <- colMeans(psi_a) - late <- -numerator / denominator - names(late) <- ensemble_type + # Target parameter & influence function -------------------------------------- - # Organize complementary ensemble output - weights <- list(y_X_Z0 = y_X_Z0_res$weights, - y_X_Z1 = y_X_Z1_res$weights, - D_X_Z0 = D_X_Z0_res$weights, - D_X_Z1 = D_X_Z1_res$weights, - Z_X = Z_X_res$weights) + late <- as.vector(ate_rf$coefficients) / as.vector(ate_fs$coefficients) - # Store complementary ensemble output - mspe <- list(y_X_Z0 = y_X_Z0_res$mspe, - y_X_Z1 = y_X_Z1_res$mspe, - D_X_Z0 = D_X_Z0_res$mspe, - D_X_Z1 = D_X_Z1_res$mspe, - Z_X = Z_X_res$mspe) + scores <- array(NA_real_, dim = c(nobs, 1, nensb)) + J <- array(NA_real_, dim = c(1, 1, nensb)) + inf_func <- array(NA_real_, dim = c(nobs, 1, nensb)) + dinf_dtheta <- array(NA_real_, dim = c(nobs, 1, 1, nensb)) + + for (j in seq_len(nensb)) { + theta_fs <- ate_fs$coefficients[, j] + phi_rf <- ate_rf$inf_func[, 1, j] + phi_fs <- ate_fs$inf_func[, 1, j] + + scores[, 1, j] <- phi_fs * late[j] - phi_rf + J[1, 1, j] <- -theta_fs + + J_inv <- csolve(matrix(J[, , j], 1, 1)) + inf_func[, 1, j] <- matrix(scores[, 1, j], nobs, 1) %*% t(J_inv) + + psi_a_vec <- -(theta_fs - phi_fs) + dinf_dtheta[, 1, 1, j] <- psi_a_vec * J_inv[1, 1] + }#FOR - # Organize reduced form predicted values - oos_pred <- list(EY_Z0_X = l_X_byZ[, , 1], EY_Z1_X = l_X_byZ[, , 2], - ED_Z0_X = p_X_byZ[, , 1], ED_Z1_X = p_X_byZ[, , 2], - EZ_X = r_X) + coef_names <- "LATE" + coef <- matrix(late, nrow = 1, ncol = nensb) + rownames(coef) <- coef_names + colnames(coef) <- ensemble_type - # Organize output - ddml_fit <- list(late = late, weights = weights, mspe = mspe, - psi_a = psi_a, psi_b = psi_b, - oos_pred = oos_pred, - learners = learners, - learners_DXZ = learners_DXZ, - learners_ZX = learners_ZX, - cluster_variable = cluster_variable, - subsamples_byZ = subsamples_byZ, - cv_subsamples_byZ = cv_subsamples_byZ, - ensemble_type = ensemble_type) + # Output --------------------------------------------------------------------- - # Print estimation progress - if (!silent) cat("DDML estimation completed. \n") + announce_finish(t0, messages, silent) - # Amend class and return - class(ddml_fit) <- "ddml_late" - return(ddml_fit) + ddml( + coefficients = coef, + ensemble_weights = list( + y_X_Z0 = ate_rf$ensemble_weights$y_X_D0, + y_X_Z1 = ate_rf$ensemble_weights$y_X_D1, + D_X_Z0 = ate_fs$ensemble_weights$y_X_D0, + D_X_Z1 = ate_fs$ensemble_weights$y_X_D1, + Z_X = ate_rf$ensemble_weights$D_X), + mspe = list( + y_X_Z0 = ate_rf$mspe$y_X_D0, + y_X_Z1 = ate_rf$mspe$y_X_D1, + D_X_Z0 = ate_fs$mspe$y_X_D0, + D_X_Z1 = ate_fs$mspe$y_X_D1, + Z_X = ate_rf$mspe$D_X), + r2 = list( + y_X_Z0 = ate_rf$r2$y_X_D0, + y_X_Z1 = ate_rf$r2$y_X_D1, + D_X_Z0 = ate_fs$r2$y_X_D0, + D_X_Z1 = ate_fs$r2$y_X_D1, + Z_X = ate_rf$r2$D_X), + inf_func = inf_func, dinf_dtheta = dinf_dtheta, + scores = scores, J = J, + coef_names = coef_names, + estimator_name = "Local Average Treatment Effect", + ensemble_type = ensemble_type, + nobs = nobs, + sample_folds = sample_folds, + cv_folds = if (shortstack) NULL else cv_folds, + shortstack = shortstack, + cluster_variable = cluster_variable, + fitted = list( + y_X_Z0 = ate_rf$fitted$y_X_D0, + y_X_Z1 = ate_rf$fitted$y_X_D1, + D_X_Z0 = ate_fs$fitted$y_X_D0, + D_X_Z1 = ate_fs$fitted$y_X_D1, + Z_X = ate_rf$fitted$D_X), + splits = list( + y_X_Z0 = ate_rf$splits$y_X_D0, + y_X_Z1 = ate_rf$splits$y_X_D1, + D_X_Z0 = ate_fs$splits$y_X_D0, + D_X_Z1 = ate_fs$splits$y_X_D1, + Z_X = ate_rf$splits$D_X), + call = cl, + subclass = "ddml_late", + # ddml_late-specific fields + learners = learners, + learners_DXZ = learners_DXZ, + learners_ZX = learners_ZX + ) }#DDML_LATE - -#' @rdname summary.ddml_ate -#' -#' @export -summary.ddml_late <- function(object, ...) { - # Check whether stacking was used, replace ensemble type if TRUE - single_learner <- ("what" %in% names(object$learners)) - if (single_learner) object$ensemble_type <- " " - # Compute and print inference results - coefficients <- organize_interactive_inf_results(coef = object$late, - psi_a = object$psi_a, - psi_b = object$psi_b, - ensemble_type = - object$ensemble_type, - cluster_variable = - object$cluster_variable) - class(coefficients) <- c("summary.ddml_late", class(coefficients)) - coefficients -}#SUMMARY.DDML_LATE - -#' @rdname print.summary.ddml_ate -#' -#' @export -print.summary.ddml_late <- function(x, digits = 3, ...) { - cat("LATE estimation results: \n \n") - class(x) <- class(x)[-1] - print(x, digits = digits) -}#PRINT.SUMMARY.DDML_LATE - diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index 3fcff09..4c77e68 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -1,51 +1,35 @@ -#' Estimator for the Partially Linear IV Model. +#' Estimator for the Partially Linear IV Coefficient #' -#' @family ddml +#' @family ddml estimators #' -#' @seealso [ddml::summary.ddml_pliv()], [AER::ivreg()] +#' @description Estimator for the partially linear IV coefficient. #' -#' @description Estimator for the partially linear IV model. +#' @details +#' \strong{Parameter of Interest:} \code{ddml_pliv} provides a Double/Debiased +#' Machine Learning estimator for the partially linear instrumental variable +#' (IV) coefficient \eqn{\theta_0}, defined by the partially linear IV model: #' -#' @details \code{ddml_pliv} provides a double/debiased machine learning -#' estimator for the parameter of interest \eqn{\theta_0} in the partially -#' linear IV model given by +#' \deqn{Y = \theta_0 D + g_0(X) + \varepsilon, \quad E[Z\varepsilon] = 0, \quad E[\varepsilon|X] = 0,} #' -#' \eqn{Y = \theta_0D + g_0(X) + U,} +#' where \eqn{W \equiv (Y, D, X, Z, \varepsilon)} is a random vector such that +#' \eqn{E[Cov(D, Z|X)] \neq 0}, and \eqn{g_0(X)} is an unknown nuisance function. #' -#' where \eqn{(Y, D, X, Z, U)} is a random vector such that -#' \eqn{E[Cov(U, Z\vert X)] = 0} and \eqn{E[Cov(D, Z\vert X)] \neq 0}, and -#' \eqn{g_0} is an unknown nuisance function. +#' \strong{Neyman Orthogonal Score:} The Neyman orthogonal score is: #' -#' @inheritParams ddml_plm +#' \deqn{m(W; \theta, \eta) = [(Y - \ell(X)) - \theta(D - r_D(X))](Z - r_Z(X))} +#' +#' where the nuisance parameters are \eqn{\eta = (\ell, r_D, r_Z)} taking +#' true values \eqn{\ell_0(X) = E[Y|X]}, \eqn{r_{D,0}(X) = E[D|X]}, and \eqn{r_{Z,0}(X) = E[Z|X]}. +#' +#' \strong{Jacobian:} +#' +#' \deqn{J = -E[(D - r_D(X))(Z - r_Z(X))^\top]} +#' +#' See \code{\link{ddml-intro}} for how the influence function +#' and inference are derived from these components. +#' +#' @inheritParams ddml-intro #' @param Z A matrix of instruments. -#' @param learners May take one of two forms, depending on whether a single -#' learner or stacking with multiple learners is used for estimation of the -#' conditional expectation functions. -#' If a single learner is used, \code{learners} is a list with two named -#' elements: -#' \itemize{ -#' \item{\code{what} The base learner function. The function must be -#' such that it predicts a named input \code{y} using a named input -#' \code{X}.} -#' \item{\code{args} Optional arguments to be passed to \code{what}.} -#' } -#' If stacking with multiple learners is used, \code{learners} is a list of -#' lists, each containing four named elements: -#' \itemize{ -#' \item{\code{fun} The base learner function. The function must be -#' such that it predicts a named input \code{y} using a named input -#' \code{X}.} -#' \item{\code{args} Optional arguments to be passed to \code{fun}.} -#' \item{\code{assign_X} An optional vector of column indices -#' corresponding to control variables in \code{X} that are passed to -#' the base learner.} -#' \item{\code{assign_Z} An optional vector of column indices -#' corresponding to instruments in \code{Z} that are passed to the -#' base learner.} -#' } -#' Omission of the \code{args} element results in default arguments being -#' used in \code{fun}. Omission of \code{assign_X} (and/or \code{assign_Z}) -#' results in inclusion of all variables in \code{X} (and/or \code{Z}). #' @param learners_DX,learners_ZX Optional arguments to allow for different #' base learners for estimation of \eqn{E[D|X]}, \eqn{E[Z|X]}. Setup is #' identical to \code{learners}. @@ -58,40 +42,12 @@ #' have the same number of columns. #' #' @return \code{ddml_pliv} returns an object of S3 class -#' \code{ddml_pliv}. An object of class \code{ddml_pliv} is a list -#' containing the following components: -#' \describe{ -#' \item{\code{coef}}{A vector with the \eqn{\theta_0} estimates.} -#' \item{\code{weights}}{A list of matrices, providing the weight -#' assigned to each base learner (in chronological order) by the -#' ensemble procedure.} -#' \item{\code{mspe}}{A list of matrices, providing the MSPE of each -#' base learner (in chronological order) computed by the -#' cross-validation step in the ensemble construction.} -#' \item{\code{iv_fit}}{Object of class \code{ivreg} from the IV -#' regression of \eqn{Y - \hat{E}[Y\vert X]} on -#' \eqn{D - \hat{E}[D\vert X]} using \eqn{Z - \hat{E}[Z\vert X]} as -#' the instrument. See also [AER::ivreg()] for details.} -#' \item{\code{learners},\code{learners_DX},\code{learners_ZX}, -#' \code{cluster_variable}, \code{subsamples}, -#' \code{cv_subsamples_list},\code{ensemble_type}}{Pass-through of -#' selected user-provided arguments. See above.} -#' } +#' \code{ddml_pliv} and \code{ddml}. See \code{\link{ddml-intro}} +#' for the common output structure. Additional pass-through +#' fields: \code{learners}, \code{learners_DX}, +#' \code{learners_ZX}. #' @export #' -#' @references -#' Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and -#' Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. -#' -#' Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C B, Newey W, -#' Robins J (2018). "Double/debiased machine learning for treatment and -#' structural parameters." The Econometrics Journal, 21(1), C1-C68. -#' -#' Kleiber C, Zeileis A (2008). Applied Econometrics with R. Springer-Verlag, -#' New York. -#' -#' Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. -#' #' @examples #' # Construct variables from the included Angrist & Evans (1998) data #' y = AE98[, "worked"] @@ -118,170 +74,203 @@ ddml_pliv <- function(y, D, Z, X, custom_ensemble_weights_DX = custom_ensemble_weights, custom_ensemble_weights_ZX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples = NULL, - cv_subsamples_list = NULL, - silent = FALSE) { - # Data parameters - nobs <- length(y) - nlearners <- length(learners) - ncustom <- ncol(custom_ensemble_weights) - ncustom <- ifelse(is.null(ncustom), 0, ncustom) + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ...) { + cl <- match.call() + + # Preliminaries -------------------------------------------------------------- + + dots <- list(...) + messages <- resolve_messages(dots, "ddml_pliv", list( + y_X = "E[Y|X]")) + + validate_inputs(y = y, D = D, X = X, Z = Z, + learners = learners, + sample_folds = sample_folds, + cv_folds = cv_folds, + ensemble_type = ensemble_type, + cluster_variable = cluster_variable) + validate_custom_weights(custom_ensemble_weights, learners) + validate_custom_weights(custom_ensemble_weights_DX, + learners_DX) + validate_custom_weights(custom_ensemble_weights_ZX, + learners_ZX) - # Check for multivariate endogenous variables + nobs <- length(y) D <- as.matrix(D) nD <- ncol(D) - - # Check for multivariate instruments Z <- as.matrix(Z) nZ <- ncol(Z) - # Create sample and cv-fold tuples - cf_indxs <- get_crossfit_indices(cluster_variable = cluster_variable, - sample_folds = sample_folds, - cv_folds = cv_folds, - subsamples = subsamples, - cv_subsamples_list = cv_subsamples_list) + validate_fitted_splits_pair(fitted, splits) + + indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + subsamples = splits[[1]]$subsamples, + cv_subsamples = splits[[1]]$cv_subsamples) + check_subsamples(indxs$subsamples, NULL, stratify = FALSE) + + t0 <- proc.time()[3] + announce_start(messages, parallel, silent) - # Compute estimates of E[y|X] + # Reduced-form estimation ---------------------------------------------------- + + # E[Y|X] y_X_res <- get_CEF(y, X, - learners = learners, ensemble_type = ensemble_type, + learners = learners, + ensemble_type = ensemble_type, shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, - silent = silent, progress = "E[Y|X]: ") + custom_ensemble_weights = + custom_ensemble_weights, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, + silent = silent, label = messages$y_X, + parallel = parallel, + fitted = fitted$y_X) - # Compute estimates of E[Z|X], loop through instruments - Z_X_res_list <- list() - for (k in 1:nZ) { - Z_X_res_list[[k]] <- get_CEF(Z[, k, drop = F], X, - learners = learners_ZX, - ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = - custom_ensemble_weights_ZX, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = - cf_indxs$cv_subsamples_list, - silent = silent, - progress = paste0("E[Z", k, "|X]: ")) + # E[Z|X] + Z_X_res_list <- vector("list", nZ) + for (k in seq_len(nZ)) { + Z_X_res_list[[k]] <- get_CEF( + Z[, k, drop = FALSE], X, + learners = learners_ZX, + ensemble_type = ensemble_type, + shortstack = shortstack, + custom_ensemble_weights = custom_ensemble_weights_ZX, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, + silent = silent, + label = paste0("E[Z", k, "|X]"), + parallel = parallel, + fitted = fitted[[paste0("Z", k, "_X")]]) }#FOR - # Compute estimates of E[D|X], loop through endogenous variables - D_X_res_list <- list() - for (k in 1:nD) { - D_X_res_list[[k]] <- get_CEF(D[, k, drop = F], X, - learners = learners_DX, - ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = - custom_ensemble_weights_DX, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = - cf_indxs$cv_subsamples_list, - silent = silent, - progress = paste0("E[D", k, "|X]: ")) + # E[D|X] + D_X_res_list <- vector("list", nD) + for (k in seq_len(nD)) { + D_X_res_list[[k]] <- get_CEF( + D[, k, drop = FALSE], X, + learners = learners_DX, + ensemble_type = ensemble_type, + shortstack = shortstack, + custom_ensemble_weights = custom_ensemble_weights_DX, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, + silent = silent, + label = paste0("E[D", k, "|X]"), + parallel = parallel, + fitted = fitted[[paste0("D", k, "_X")]]) }#FOR - # Update ensemble type to account for (optional) custom weights - ensemble_type <- dimnames(y_X_res$weights)[[2]] - nensb <- length(ensemble_type) - - # Check whether multiple ensembles are computed simultaneously - multiple_ensembles <- nensb > 1 + ensemble_type <- y_X_res$ensemble_type + nensb <- if (is.null(ensemble_type)) 1L + else length(ensemble_type) - # If a single ensemble is calculated, no loops are required. - if (!multiple_ensembles) { + # Target parameter & influence function -------------------------------------- - # Residualize - y_r <- y - y_X_res$oos_fitted - D_r <- D - get_oosfitted(D_X_res_list) - V_r <- Z - get_oosfitted(Z_X_res_list) + coef <- matrix(0, nD + 1, nensb) + scores <- array(NA_real_, dim = c(nobs, nD + 1, nensb)) + J <- array(NA_real_, dim = c(nD + 1, nD + 1, nensb)) + inf_func <- array(NA_real_, dim = c(nobs, nD + 1, nensb)) + dinf_dtheta <- array(NA_real_, dim = c(nobs, nD + 1, nD + 1, nensb)) + for (j in seq_len(nensb)) { + y_r <- y - cbind(y_X_res$cf_fitted)[, j] + D_r <- D - get_cf_fitted(D_X_res_list, j) + V_r <- Z - get_cf_fitted(Z_X_res_list, j) - # Compute IV estimate with constructed variables - iv_fit <- AER::ivreg(y_r ~ D_r | V_r) + D_r_mat <- as.matrix(D_r) + V_r_mat <- as.matrix(V_r) + + D_fit <- cbind(D_r_mat, 1) + V_fit <- cbind(V_r_mat, 1) + + # 2SLS + pi_hat <- qr.solve(V_fit, D_fit) + D_hat <- V_fit %*% pi_hat + coef_iv_j <- as.vector(qr.solve(D_hat, y_r)) + coef[, j] <- coef_iv_j - # Organize complementary ensemble output - coef <- stats::coef(iv_fit)[-1] - }#IF + X_hat <- D_hat + X_full <- D_fit + e_j <- as.vector(y_r - X_full %*% coef_iv_j) + + scores[, , j] <- X_hat * e_j + J[, , j] <- -crossprod(X_hat, X_full) / nobs - # If multiple ensembles are calculated, iterate over each type. - if (multiple_ensembles) { - # Iterate over ensemble type. Compute DDML IV estimate for each. - coef <- matrix(0, nD, nensb) - iv_fit <- rep(list(1), nensb) - nlearners <- length(learners) - nlearners_DX <- length(learners_DX); nlearners_ZX <- length(learners_ZX) + J_inv <- csolve(matrix(J[, , j], nD + 1, nD + 1)) + inf_func[, , j] <- matrix(scores[, , j], nobs, nD + 1) %*% t(J_inv) + + U <- X_hat %*% t(J_inv) + dinf_dtheta[, , , j] <- sapply(seq_len(nD + 1), function(k) { + -X_full[, k] * U + }, simplify = "array") + }#FOR - # Compute coefficients for each ensemble - for (j in 1:nensb) { - # Residualize - y_r <- y - y_X_res$oos_fitted[, j] - D_r <- D - get_oosfitted(D_X_res_list, j) - V_r <- Z - get_oosfitted(Z_X_res_list, j) - # Compute IV estimate with constructed variables - iv_fit_j <- AER::ivreg(y_r ~ D_r | V_r) + cn_weights <- dimnames(y_X_res$weights)[[2]] + colnames(coef) <- if (is.null(cn_weights)) ensemble_type else cn_weights + cn_j <- colnames(D) + if (is.null(cn_j)) cn_j <- paste0("D", seq_len(nD)) + rownames(coef) <- c(cn_j, "(Intercept)") + coef_names <- rownames(coef) - # Organize complementary ensemble output - coef[, j] <- stats::coef(iv_fit_j)[-1] - iv_fit[[j]] <- iv_fit_j - }#FOR - # Assign names for more legible output - colnames(coef) <- names(iv_fit) <- ensemble_type - rownames(coef) <- names(iv_fit_j$coefficients)[-1] - }#IF + # Output --------------------------------------------------------------------- - # Store complementary ensemble output - weights <- list(y_X = y_X_res$weights) + ensemble_weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) - for (k in 1:nD){ - weights[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$weights - mspe[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$mspe + r2 <- list(y_X = y_X_res$r2) + for (k in seq_len(nD)) { + eq <- paste0("D", k, "_X") + ensemble_weights[[eq]] <- D_X_res_list[[k]]$weights + mspe[[eq]] <- D_X_res_list[[k]]$mspe + r2[[eq]] <- D_X_res_list[[k]]$r2 }#FOR - for (k in 1:nZ){ - weights[[paste0("Z", k, "_X")]] <- Z_X_res_list[[k]]$weights - mspe[[paste0("Z", k, "_X")]] <- Z_X_res_list[[k]]$mspe + for (k in seq_len(nZ)) { + eq <- paste0("Z", k, "_X") + ensemble_weights[[eq]] <- Z_X_res_list[[k]]$weights + mspe[[eq]] <- Z_X_res_list[[k]]$mspe + r2[[eq]] <- Z_X_res_list[[k]]$r2 }#FOR - # Organize output - ddml_fit <- list(coef = coef, weights = weights, mspe = mspe, - learners = learners, - learners_ZX = learners_ZX, - learners_DX = learners_DX, - iv_fit = iv_fit, - cluster_variable = cluster_variable, - subsamples = subsamples, - cv_subsamples_list = cv_subsamples_list, - ensemble_type = ensemble_type) + announce_finish(t0, messages, silent) - # Amend class and return - class(ddml_fit) <- "ddml_pliv" - return(ddml_fit) + ddml( + coefficients = coef, + ensemble_weights = ensemble_weights, + mspe = mspe, + r2 = r2, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, + scores = scores, J = J, + coef_names = coef_names, + estimator_name = "Partially Linear IV Model", + ensemble_type = ensemble_type, + nobs = nobs, + sample_folds = sample_folds, + cv_folds = if (shortstack) NULL else cv_folds, + shortstack = shortstack, + cluster_variable = cluster_variable, + fitted = c( + list(y_X = build_fitted_entry(y_X_res, save_crossval)), + build_fitted_flat(D_X_res_list, save_crossval, + "D", "_X"), + build_fitted_flat(Z_X_res_list, save_crossval, + "Z", "_X")), + splits = stats::setNames( + rep(list(list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples)), + length(ensemble_weights)), + names(ensemble_weights)), + call = cl, + subclass = "ddml_pliv", + # ddml_pliv-specific fields + learners = learners, + learners_DX = learners_DX, + learners_ZX = learners_ZX + ) }#DDML_PLIV - -#' @rdname summary.ddml_plm -#' -#' @export -summary.ddml_pliv <- function(object, ...) { - # Check whether stacking was used, replace ensemble type if TRUE - single_learner <- ("what" %in% names(object$learners)) - if (single_learner) object$ensemble_type <- "single base learner" - # Compute and print inference results - coefficients <- organize_inf_results(fit_obj_list = object$iv_fit, - ensemble_type = object$ensemble_type, - cluster_variable = - object$cluster_variable, - ...) - class(coefficients) <- c("summary.ddml_pliv", class(coefficients)) - coefficients -}#SUMMARY.DDML_PLIV - -#' @rdname print.summary.ddml_plm -#' -#' @export -print.summary.ddml_pliv <- function(x, digits = 3, ...) { - cat("PLIV estimation results: \n \n") - class(x) <- class(x)[-1] - print(x, digits = digits) -}#PRINT.SUMMARY.DDML_PLIV diff --git a/R/ddml_plm.R b/R/ddml_plm.R index e3530d4..85f3890 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -1,112 +1,48 @@ -#' Estimator for the Partially Linear Model. +#' Estimator for the Partially Linear Regression Coefficient #' -#' @family ddml +#' @family ddml estimators #' -#' @seealso [ddml::summary.ddml_plm()] +#' @description Estimator for the partially linear regression coefficient. #' -#' @description Estimator for the partially linear model. +#' @details +#' \strong{Parameter of Interest:} \code{ddml_plm} provides a Double/Debiased +#' Machine Learning estimator for the partially linear regression +#' coefficient \eqn{\theta_0}, defined by the partially linear regression +#' model: #' -#' @details \code{ddml_plm} provides a double/debiased machine learning -#' estimator for the parameter of interest \eqn{\theta_0} in the partially -#' linear model given by +#' \deqn{Y = \theta_0 D + g_0(X) + \varepsilon, \quad E[D\varepsilon] = 0, \quad E[\varepsilon|X] = 0,} #' -#' \eqn{Y = \theta_0D + g_0(X) + U,} +#' where \eqn{W\equiv(Y, D, X, \varepsilon)} is a random vector such that +#' \eqn{E[Var(D|X)] \neq 0}, and \eqn{g_0(X)} is an unknown nuisance function. #' -#' where \eqn{(Y, D, X, U)} is a random vector such that -#' \eqn{E[Cov(U, D\vert X)] = 0} and \eqn{E[Var(D\vert X)] \neq 0}, and -#' \eqn{g_0} is an unknown nuisance function. +#' \strong{Neyman Orthogonal Score:} The Neyman orthogonal score is: #' -#' @param y The outcome variable. -#' @param D A matrix of endogenous variables. -#' @param X A (sparse) matrix of control variables. -#' @param learners May take one of two forms, depending on whether a single -#' learner or stacking with multiple learners is used for estimation of the -#' conditional expectation functions. -#' If a single learner is used, \code{learners} is a list with two named -#' elements: -#' \itemize{ -#' \item{\code{what} The base learner function. The function must be -#' such that it predicts a named input \code{y} using a named input -#' \code{X}.} -#' \item{\code{args} Optional arguments to be passed to \code{what}.} -#' } -#' If stacking with multiple learners is used, \code{learners} is a list of -#' lists, each containing four named elements: -#' \itemize{ -#' \item{\code{fun} The base learner function. The function must be -#' such that it predicts a named input \code{y} using a named input -#' \code{X}.} -#' \item{\code{args} Optional arguments to be passed to \code{fun}.} -#' \item{\code{assign_X} An optional vector of column indices -#' corresponding to control variables in \code{X} that are passed to -#' the base learner.} -#' } -#' Omission of the \code{args} element results in default arguments being -#' used in \code{fun}. Omission of \code{assign_X} results in inclusion of -#' all variables in \code{X}. +#' \deqn{m(W; \theta, \eta) = [(Y - \ell(X)) - \theta(D - r(X))](D - r(X))} +#' +#' where the nuisance parameters are \eqn{\eta = (\ell, r)} taking +#' true values \eqn{\ell_0(X) = E[Y|X]} and \eqn{r_0(X) = E[D|X]}. +#' +#' \strong{Jacobian:} +#' +#' \deqn{J = -E[(D - r_0(X))(D - r_0(X))^\top]} +#' +#' See \code{\link{ddml-intro}} for how the influence function +#' and inference are derived from these components. +#' +#' @inheritParams ddml-intro #' @param learners_DX Optional argument to allow for different estimators of #' \eqn{E[D|X]}. Setup is identical to \code{learners}. -#' @param sample_folds Number of cross-fitting folds. -#' @param ensemble_type Ensemble method to combine base learners into final -#' estimate of the conditional expectation functions. Possible values are: -#' \itemize{ -#' \item{\code{"nnls"} Non-negative least squares.} -#' \item{\code{"nnls1"} Non-negative least squares with the constraint -#' that all weights sum to one.} -#' \item{\code{"singlebest"} Select base learner with minimum MSPE.} -#' \item{\code{"ols"} Ordinary least squares.} -#' \item{\code{"average"} Simple average over base learners.} -#' } -#' Multiple ensemble types may be passed as a vector of strings. -#' @param shortstack Boolean to use short-stacking. -#' @param cv_folds Number of folds used for cross-validation in ensemble -#' construction. -#' @param custom_ensemble_weights A numerical matrix with user-specified -#' ensemble weights. Each column corresponds to a custom ensemble -#' specification, each row corresponds to a base learner in \code{learners} -#' (in chronological order). Optional column names are used to name the -#' estimation results corresponding the custom ensemble specification. #' @param custom_ensemble_weights_DX Optional argument to allow for different #' custom ensemble weights for \code{learners_DX}. Setup is identical to #' \code{custom_ensemble_weights}. Note: \code{custom_ensemble_weights} and #' \code{custom_ensemble_weights_DX} must have the same number of columns. -#' @param cluster_variable A vector of cluster indices. -#' @param subsamples List of vectors with sample indices for cross-fitting. -#' @param cv_subsamples_list List of lists, each corresponding to a subsample -#' containing vectors with subsample indices for cross-validation. -#' @param silent Boolean to silence estimation updates. #' #' @return \code{ddml_plm} returns an object of S3 class -#' \code{ddml_plm}. An object of class \code{ddml_plm} is a list containing -#' the following components: -#' \describe{ -#' \item{\code{coef}}{A vector with the \eqn{\theta_0} estimates.} -#' \item{\code{weights}}{A list of matrices, providing the weight -#' assigned to each base learner (in chronological order) by the -#' ensemble procedure.} -#' \item{\code{mspe}}{A list of matrices, providing the MSPE of each -#' base learner (in chronological order) computed by the -#' cross-validation step in the ensemble construction.} -#' \item{\code{ols_fit}}{Object of class \code{lm} from the second -#' stage regression of \eqn{Y - \hat{E}[Y|X]} on -#' \eqn{D - \hat{E}[D|X]}.} -#' \item{\code{learners},\code{learners_DX},\code{cluster_variable}, -#' \code{subsamples}, \code{cv_subsamples_list}, -#' \code{ensemble_type}}{Pass-through of selected user-provided -#' arguments. See above.} -#' } +#' \code{ddml_plm} and \code{ddml}. See \code{\link{ddml-intro}} +#' for the common output structure. Additional pass-through +#' fields: \code{learners}, \code{learners_DX}. #' @export #' -#' @references -#' Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and -#' Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. -#' -#' Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C B, Newey W, -#' Robins J (2018). "Double/debiased machine learning for treatment and -#' structural parameters." The Econometrics Journal, 21(1), C1-C68. -#' -#' Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. -#' #' @examples #' # Construct variables from the included Angrist & Evans (1998) data #' y = AE98[, "worked"] @@ -127,9 +63,9 @@ #' weights_everylearner <- diag(1, 3) #' colnames(weights_everylearner) <- c("mdl:ols", "mdl:lasso", "mdl:ridge") #' plm_fit <- ddml_plm(y, D, X, -#' learners = list(list(fun = ols), -#' list(fun = mdl_glmnet), -#' list(fun = mdl_glmnet, +#' learners = list(list(what = ols), +#' list(what = mdl_glmnet), +#' list(what = mdl_glmnet, #' args = list(alpha = 0))), #' ensemble_type = 'nnls', #' custom_ensemble_weights = weights_everylearner, @@ -137,6 +73,23 @@ #' sample_folds = 2, #' silent = TRUE) #' summary(plm_fit) +#' +#' \donttest{ +#' # Re-estimate with a different ensemble type using pass-through +#' # (skips cross-fitting, only recomputes ensemble weights). +#' plm_fit2 <- ddml_plm(y, D, X, +#' learners = list(list(what = ols), +#' list(what = mdl_glmnet), +#' list(what = mdl_glmnet, +#' args = list(alpha = 0))), +#' ensemble_type = 'average', +#' shortstack = TRUE, +#' sample_folds = 2, +#' silent = TRUE, +#' fitted = plm_fit$fitted, +#' splits = plm_fit$splits) +#' summary(plm_fit2) +#' } ddml_plm <- function(y, D, X, learners, learners_DX = learners, @@ -147,219 +100,163 @@ ddml_plm <- function(y, D, X, custom_ensemble_weights = NULL, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples = NULL, - cv_subsamples_list = NULL, - silent = FALSE) { - # Data parameters - nobs <- length(y) - ncustom <- ncol(custom_ensemble_weights) - ncustom <- ifelse(is.null(ncustom), 0, ncustom) - nensb <- length(ensemble_type) + ncustom + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ...) { + cl <- match.call() + + # Preliminaries -------------------------------------------------------------- + + dots <- list(...) + messages <- resolve_messages(dots, "ddml_plm", list( + y_X = "E[Y|X]")) + + validate_inputs(y = y, D = D, X = X, learners = learners, + sample_folds = sample_folds, + cv_folds = cv_folds, + ensemble_type = ensemble_type, + cluster_variable = cluster_variable) + validate_custom_weights(custom_ensemble_weights, learners) + validate_custom_weights(custom_ensemble_weights_DX, + learners_DX) - # Check for multivariate endogenous variables + nobs <- length(y) D <- as.matrix(D) nD <- ncol(D) - # Create sample and cv-fold tuples - cf_indxs <- get_crossfit_indices(cluster_variable = cluster_variable, - sample_folds = sample_folds, - cv_folds = cv_folds, - subsamples = subsamples, - cv_subsamples_list = cv_subsamples_list) + validate_fitted_splits_pair(fitted, splits) + + indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + subsamples = splits[[1]]$subsamples, + cv_subsamples = splits[[1]]$cv_subsamples) + check_subsamples(indxs$subsamples, NULL, stratify = FALSE) - # Print to progress to console - if (!silent) cat("DDML estimation in progress. \n") + t0 <- proc.time()[3] + announce_start(messages, parallel, silent) - # Compute estimates of E[y|X] + # Reduced-form estimation ---------------------------------------------------- + + # E[Y|X] y_X_res <- get_CEF(y, X, learners = learners, ensemble_type = ensemble_type, shortstack = shortstack, custom_ensemble_weights = custom_ensemble_weights, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, - silent = silent, progress = "E[Y|X]: ") + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, + silent = silent, label = messages$y_X, + parallel = parallel, + fitted = fitted$y_X) - # Compute estimates of E[D|X], loop through endogenous variables - D_X_res_list <- list() - for (k in 1:nD) { - D_X_res_list[[k]] <- get_CEF(D[, k, drop = F], X, - learners = learners_DX, - ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = - custom_ensemble_weights_DX, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = - cf_indxs$cv_subsamples_list, - silent = silent, - progress = paste0("E[D", k, "|X]: ")) + # E[D|X] + D_X_res_list <- vector("list", nD) + for (k in seq_len(nD)) { + D_X_res_list[[k]] <- get_CEF( + D[, k, drop = FALSE], X, + learners = learners_DX, + ensemble_type = ensemble_type, + shortstack = shortstack, + custom_ensemble_weights = custom_ensemble_weights_DX, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, + silent = silent, + label = paste0("E[D", k, "|X]"), + parallel = parallel, + fitted = fitted[[paste0("D", k, "_X")]]) }#FOR - # Update ensemble type to account for (optional) custom weights - ensemble_type <- dimnames(y_X_res$weights)[[2]] - nensb <- length(ensemble_type) - - # Check whether multiple ensembles are computed simultaneously - multiple_ensembles <- nensb > 1 + ensemble_type <- y_X_res$ensemble_type + nensb <- if (is.null(ensemble_type)) 1L + else length(ensemble_type) - # If a single ensemble is calculated, no loops are required. - if (!multiple_ensembles) { + # Target parameter & influence function -------------------------------------- - # Residualize - y_r <- y - y_X_res$oos_fitted - D_r <- D - get_oosfitted(D_X_res_list) + coef <- matrix(0, nD + 1, nensb) + scores <- array(NA_real_, dim = c(nobs, nD + 1, nensb)) + J <- array(NA_real_, dim = c(nD + 1, nD + 1, nensb)) + inf_func <- array(NA_real_, dim = c(nobs, nD + 1, nensb)) + dinf_dtheta <- array(NA_real_, dim = c(nobs, nD + 1, nD + 1, nensb)) + for (j in seq_len(nensb)) { + D_r <- D - get_cf_fitted(D_X_res_list, j) + y_r <- y - cbind(y_X_res$cf_fitted)[, j] - # Compute OLS estimate with constructed variables - ols_fit <- stats::lm(y_r ~ D_r) + D_r_mat <- as.matrix(D_r) + X_full <- cbind(D_r_mat, 1) + + coef_ols_j <- as.vector(qr.solve(X_full, y_r)) + coef[, j] <- coef_ols_j + e_j <- as.vector(y_r - X_full %*% coef_ols_j) + + scores[, , j] <- X_full * e_j + J[, , j] <- -crossprod(X_full) / nobs - # Organize complementary ensemble output - coef <- stats::coef(ols_fit)[-1] - }#IF - - # If multiple ensembles are calculated, iterate over each type. - if (multiple_ensembles) { - # Iterate over ensemble type. Compute DDML estimate for each. - coef <- matrix(0, nD, nensb) - mspe <- ols_fit <- rep(list(1), nensb) - nlearners <- length(learners); nlearners_DX <- length(learners_DX) - - # Compute coefficients for each ensemble - for (j in 1:nensb) { - # Residualize - D_r <- D - get_oosfitted(D_X_res_list, j) - - # Residualize y - y_r <- y - y_X_res$oos_fitted[, j] - - # Compute OLS estimate with constructed variables - ols_fit_j <- stats::lm(y_r ~ D_r) + # Influence function + J_inv <- csolve(matrix(J[, , j], nD + 1, nD + 1)) + inf_func[, , j] <- matrix(scores[, , j], nobs, nD + 1) %*% t(J_inv) + + # Derivative of the influence function with respect to theta + U <- X_full %*% t(J_inv) + dinf_dtheta[, , , j] <- sapply(seq_len(nD + 1), function(k) { + -X_full[, k] * U + }, simplify = "array") + }#FOR - # Organize complementary ensemble output - coef[, j] <- stats::coef(ols_fit_j)[-1] - ols_fit[[j]] <- ols_fit_j - }#FOR + cn_weights <- dimnames(y_X_res$weights)[[2]] + colnames(coef) <- if (is.null(cn_weights)) ensemble_type else cn_weights + cn_j <- colnames(D) + if (is.null(cn_j)) cn_j <- paste0("D", seq_len(nD)) + rownames(coef) <- c(cn_j, "(Intercept)") + coef_names <- rownames(coef) - # Assign names for more legible output - colnames(coef) <- names(ols_fit) <- dimnames(y_X_res$weights)[[2]] - rownames(coef) <- names(ols_fit_j$coefficients)[-1] - }#IF + # Output --------------------------------------------------------------------- - # Store complementary ensemble output - weights <- list(y_X = y_X_res$weights) + # Ensemble metrics + ensemble_weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) - for (k in 1:nD){ - weights[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$weights - mspe[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$mspe + r2 <- list(y_X = y_X_res$r2) + for (k in seq_len(nD)) { + eq <- paste0("D", k, "_X") + ensemble_weights[[eq]] <- D_X_res_list[[k]]$weights + mspe[[eq]] <- D_X_res_list[[k]]$mspe + r2[[eq]] <- D_X_res_list[[k]]$r2 }#FOR - # Organize output - ddml_fit <- list(coef = coef, weights = weights, mspe = mspe, - learners = learners, - learners_DX = learners_DX, - ols_fit = ols_fit, - cluster_variable = cluster_variable, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, - ensemble_type = ensemble_type) + announce_finish(t0, messages, silent) - # Print estimation progress - if (!silent) cat("DDML estimation completed. \n") - - # Amend class and return - class(ddml_fit) <- "ddml_plm" - return(ddml_fit) + ddml( + coefficients = coef, + ensemble_weights = ensemble_weights, + mspe = mspe, + r2 = r2, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, + scores = scores, J = J, + coef_names = coef_names, + estimator_name = "Partially Linear Model", + ensemble_type = ensemble_type, + nobs = nobs, + sample_folds = sample_folds, + cv_folds = if (shortstack) NULL else cv_folds, + shortstack = shortstack, + cluster_variable = cluster_variable, + fitted = c( + list(y_X = build_fitted_entry(y_X_res, save_crossval)), + build_fitted_flat(D_X_res_list, save_crossval, + "D", "_X")), + splits = stats::setNames( + rep(list(list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples)), + length(ensemble_weights)), + names(ensemble_weights)), + call = cl, + subclass = "ddml_plm", + # ddml_plm-specific fields + learners = learners, + learners_DX = learners_DX + ) }#DDML_PLM - -#' Inference Methods for Partially Linear Estimators. -#' -#' @seealso [sandwich::vcovHC()], [sandwich::vcovCL()] -#' -#' @description Inference methods for partially linear estimators. Simple -#' wrapper for [sandwich::vcovHC()] and [sandwich::vcovCL()]. Default -#' standard errors are heteroskedasiticty-robust. If the \code{ddml} -#' estimator was computed using a \code{cluster_variable}, the standard -#' errors are also cluster-robust by default. -#' -#' @param object An object of class \code{ddml_plm}, \code{ddml_pliv}, or -#' \code{ddml_fpliv} as fitted by [ddml::ddml_plm()], [ddml::ddml_pliv()], -#' and [ddml::ddml_fpliv()], respectively. -#' @param ... Additional arguments passed to \code{vcovHC} and \code{vcovCL}. -#' See [sandwich::vcovHC()] and [sandwich::vcovCL()] for a complete list of -#' arguments. -#' -#' @return An array with inference results for each \code{ensemble_type}. -#' -#' @references -#' Zeileis A (2004). "Econometric Computing with HC and HAC Covariance Matrix -#' Estimators.” Journal of Statistical Software, 11(10), 1-17. -#' -#' Zeileis A (2006). “Object-Oriented Computation of Sandwich Estimators.” -#' Journal of Statistical Software, 16(9), 1-16. -#' -#' Zeileis A, Köll S, Graham N (2020). “Various Versatile Variances: An -#' Object-Oriented Implementation of Clustered Covariances in R.” Journal of -#' Statistical Software, 95(1), 1-36. -#' -#' @export -#' -#' @examples -#' # Construct variables from the included Angrist & Evans (1998) data -#' y = AE98[, "worked"] -#' D = AE98[, "morekids"] -#' X = AE98[, c("age","agefst","black","hisp","othrace","educ")] -#' -#' # Estimate the partially linear model using a single base learner, ridge. -#' plm_fit <- ddml_plm(y, D, X, -#' learners = list(what = mdl_glmnet, -#' args = list(alpha = 0)), -#' sample_folds = 2, -#' silent = TRUE) -#' summary(plm_fit) -summary.ddml_plm <- function(object, ...) { - # Check whether stacking was used, replace ensemble type if TRUE - single_learner <- ("what" %in% names(object$learners)) - if (single_learner) object$ensemble_type <- "single base learner" - # Compute and print inference results - coefficients <- organize_inf_results(fit_obj_list = object$ols_fit, - ensemble_type = object$ensemble_type, - cluster_variable = - object$cluster_variable, - ...) - class(coefficients) <- c("summary.ddml_plm", class(coefficients)) - coefficients -}#SUMMARY.DDML_PLM - -#' Print Methods for Treatment Effect Estimators. -#' -#' @description Print methods for treatment effect estimators. -#' -#' @param x An object of class \code{summary.ddml_plm}, -#' \code{summary.ddml_pliv}, and \code{summary.ddml_fpliv}, as -#' returned by [ddml::summary.ddml_plm()], [ddml::summary.ddml_pliv()], -#' and [ddml::summary.ddml_fpliv()], respectively. -#' @param digits Number of significant digits used for priniting. -#' @param ... Currently unused. -#' -#' @return NULL. -#' -#' @export -#' -#' @examples -#' # Construct variables from the included Angrist & Evans (1998) data -#' y = AE98[, "worked"] -#' D = AE98[, "morekids"] -#' X = AE98[, c("age","agefst","black","hisp","othrace","educ")] -#' -#' # Estimate the partially linear model using a single base learner, ridge. -#' plm_fit <- ddml_plm(y, D, X, -#' learners = list(what = mdl_glmnet, -#' args = list(alpha = 0)), -#' sample_folds = 2, -#' silent = TRUE) -#' summary(plm_fit) -print.summary.ddml_plm <- function(x, digits = 3, ...) { - cat("PLM estimation results: \n \n") - class(x) <- class(x)[-1] - print(x, digits = digits) -}#PRINT.SUMMARY.DDML_PLM diff --git a/R/ddml_rep.R b/R/ddml_rep.R new file mode 100644 index 0000000..ceaed86 --- /dev/null +++ b/R/ddml_rep.R @@ -0,0 +1,415 @@ +# ddml_rep: DML-specific replicated inference =================================== +# +# Class hierarchy: +# ddml_rep > ral_rep — adds DML-specific fields and display +# +# Inference methods (coef, vcov, confint, tidy, glance) are +# inherited from ral_rep in ral_rep.R. + +# Exported functions =========================================================== + +#' Construct a Multi-Resample DDML Object +#' +#' Validates a list of \code{ddml} fits and stamps class +#' \code{"ddml_rep"} for multi-resample aggregation. +#' +#' @param fits A list of at least 2 objects inheriting from +#' class \code{"ddml"}. All fits must share the same +#' primary class, coefficient names, ensemble type, and +#' number of observations. +#' +#' @return An object of class \code{c("ddml_rep", "ral_rep")} +#' with fields: +#' \describe{ +#' \item{fits}{List of \code{ddml} objects.} +#' \item{nresamples}{Number of resamples.} +#' \item{model_type}{Primary class of the fits.} +#' \item{coef_names}{Coefficient names.} +#' \item{ensemble_type}{Ensemble types.} +#' \item{nobs}{Number of observations.} +#' \item{sample_folds}{Number of cross-fitting folds.} +#' \item{shortstack}{Logical, whether short-stacking was used.} +#' } +#' +#' @examples +#' \donttest{ +#' y = AE98[, "worked"] +#' D = AE98[, "morekids"] +#' X = AE98[, c("age","agefst","black","hisp","othrace")] +#' fits = lapply(1:3, function(r) { +#' ddml_plm(y, D, X, +#' learners = list(what = ols), +#' sample_folds = 2, silent = TRUE) +#' }) +#' reps = ddml_rep(fits) +#' summary(reps) +#' } +#' +#' @family ddml replication +#' @seealso [ddml_replicate()] +#' @export +ddml_rep <- function(fits) { + # Input validation + if (!is.list(fits) || length(fits) < 2) { + stop("'fits' must be a list of at least 2 ddml objects.", + call. = FALSE) + }#IF + for (i in seq_along(fits)) { + if (!inherits(fits[[i]], "ddml")) { + stop("Element ", i, + " does not inherit from class 'ddml'.", + call. = FALSE) + }#IF + }#FOR + primary <- vapply(fits, function(f) class(f)[1], + character(1)) + if (length(unique(primary)) != 1) { + stop("All fits must have the same primary class. ", + "Found: ", + paste(unique(primary), collapse = ", "), + call. = FALSE) + }#IF + ref <- fits[[1]] + for (i in seq_along(fits)[-1]) { + if (!identical(fits[[i]]$coef_names, ref$coef_names)) { + stop("Fit ", i, " has different 'coef_names' ", + "than fit 1.", call. = FALSE) + }#IF + if (!identical(fits[[i]]$ensemble_type, + ref$ensemble_type)) { + stop("Fit ", i, " has different 'ensemble_type' ", + "than fit 1.", call. = FALSE) + }#IF + if (!identical(fits[[i]]$nobs, ref$nobs)) { + stop("Fit ", i, " has different 'nobs' than fit 1.", + call. = FALSE) + }#IF + }#FOR + + # Build via ral_rep, then layer DML fields + ens_type <- ref$ensemble_type + if (is.null(ens_type)) ens_type <- "single base learner" + + obj <- ral_rep(fits, subclass = "ddml_rep") + obj$model_type <- primary[1] + obj$ensemble_type <- ens_type + obj$fit_labels <- ens_type + obj$sample_folds <- ref$sample_folds + obj$shortstack <- ref$shortstack + obj +}#DDML_REP + +#' Replicate a DDML Estimator Across Multiple Resamples +#' +#' Convenience wrapper that calls a \code{ddml_*} estimator +#' function multiple times with independent sample splits +#' and returns a \code{ddml_rep} object for aggregated +#' inference. +#' +#' @param fn A \code{ddml_*} estimator function +#' (e.g., \code{ddml_plm}). +#' @param ... Arguments passed to \code{fn}. +#' @param resamples Integer number of independent resamples. +#' Must be >= 2. Default 5. +#' @param silent Logical. If \code{TRUE}, suppresses all +#' output at both the resample level and within each +#' estimator call. Default \code{FALSE}. +#' +#' @return An object of class \code{"ddml_rep"}. +#' +#' @examples +#' \donttest{ +#' y = AE98[, "worked"] +#' D = AE98[, "morekids"] +#' X = AE98[, c("age","agefst","black","hisp","othrace")] +#' reps = ddml_replicate(ddml_plm, y = y, D = D, X = X, +#' learners = list(what = ols), +#' sample_folds = 2, +#' resamples = 3, silent = TRUE) +#' summary(reps) +#' } +#' +#' @family ddml replication +#' @seealso [ddml_rep()] +#' @export +ddml_replicate <- function(fn, ..., resamples = 5, + silent = FALSE) { + dots <- list(...) + dots$silent <- silent + # Suppress inner start/finish messages + if (is.null(dots$messages)) { + dots$messages <- list(start = "", finish = "") + } else { + dots$messages$start <- "" + dots$messages$finish <- "" + }#IFELSE + fits <- vector("list", resamples) + for (r in seq_len(resamples)) { + if (!silent) message("[Resample ", r, "/", resamples, "]") + fits[[r]] <- do.call(fn, dots) + }#FOR + ddml_rep(fits) +}#DDML_REPLICATE + +# DML-specific S3 methods ===================================================== +# Inference methods (coef, nobs, vcov, confint, [[, length) +# are inherited from ral_rep in ral_rep.R. + +#' @rdname ddml_rep +#' +#' @param x A \code{ddml_rep} object. +#' @param ... Currently unused. +#' +#' @export +#' @method print ddml_rep +print.ddml_rep <- function(x, ...) { + cat("DDML replicated fits:", x$estimator_name, "\n") + cat(" Resamples:", x$nresamples, + " Obs:", x$nobs, + " Folds:", x$sample_folds, "\n\n") + cat("Use summary() for aggregated inference.\n") + cat("Use x[[i]] to access individual fits.\n") + invisible(x) +}#PRINT.DDML_REP + +#' Summary for ddml_rep Objects +#' +#' DML-specific summary override. Adds ensemble type labels, +#' folds, shortstack status to the base \code{ral_rep} +#' summary. +#' +#' @details +#' See \code{\link{summary.ral_rep}} for the aggregation +#' formulas. +#' +#' @references +#' Chernozhukov V, Chetverikov D, Demirer M, Duflo E, +#' Hansen C B, Newey W, Robins J (2018). +#' "Double/debiased machine learning for treatment +#' and structural parameters." The Econometrics +#' Journal, 21(1), C1-C68. +#' +#' @param object A \code{ddml_rep} object. +#' @param aggregation Character string: \code{"median"} +#' (default), \code{"mean"}, or \code{"spectral"}. +#' @param type Character. HC type. Default \code{"HC1"}. +#' @param ... Currently unused. +#' +#' @return An object of class \code{"summary.ddml_rep"}. +#' +#' @examples +#' \donttest{ +#' y = AE98[, "worked"] +#' D = AE98[, "morekids"] +#' X = AE98[, c("age","agefst","black","hisp","othrace")] +#' reps = ddml_replicate(ddml_plm, y = y, D = D, X = X, +#' learners = list(what = ols), +#' sample_folds = 2, +#' resamples = 3, silent = TRUE) +#' summary(reps) +#' summary(reps, aggregation = "mean") +#' } +#' +#' @export +#' @method summary ddml_rep +summary.ddml_rep <- function(object, + aggregation = c("median", "mean", + "spectral"), + type = "HC1", ...) { + aggregation <- match.arg(aggregation) + type <- match.arg(type, c("HC0", "HC1", "HC3")) + + # DML-specific fit labels + object$fit_labels <- object$ensemble_type + + # Delegate table computation to ral_rep + result <- summary.ral_rep(object, + aggregation = aggregation, + type = type, ...) + + # Attach DML-specific fields + result$model_type <- object$model_type + result$sample_folds <- object$sample_folds + result$shortstack <- object$shortstack + result$ensemble_type <- object$ensemble_type + + class(result) <- "summary.ddml_rep" + result +}#SUMMARY.DDML_REP + +#' @rdname summary.ddml_rep +#' +#' @param x An object of class \code{summary.ddml_rep}. +#' @param digits Number of significant digits. Default 3. +#' +#' @export +#' @method print summary.ddml_rep +print.summary.ddml_rep <- function(x, digits = 3, ...) { + cat("DDML estimation:", x$estimator_name, "\n") + cat("Obs:", x$nobs, + " Folds:", x$sample_folds, + " Resamples:", x$nresamples, + " Aggregation:", x$aggregation) + if (!is.null(x$shortstack) && x$shortstack) { + cat(" Stacking: short-stack") + }#IF + if (!is.null(x$type) && x$type != "HC1") { + cat(" SE:", x$type) + }#IF + cat("\n\n") + + print_coef_tables(x$coefficients, + fit_label = "Ensemble type", + digits = digits) + + invisible(x) +}#PRINT.SUMMARY.DDML_REP + +#' Tidy a ddml_rep Object +#' +#' DML-specific tidy method. Adds \code{ensemble_type} and +#' \code{aggregation} columns. Delegates to +#' \code{tidy.ral_rep} for the base table computation. +#' +#' @param x A \code{ddml_rep} object. +#' @param ensemble_idx Integer index of the ensemble type +#' to report. Defaults to 1. Set to \code{NULL} for +#' all ensemble types. +#' @param aggregation Character string. Aggregation method. +#' @param type Character. HC type. Default \code{"HC1"}. +#' @param conf.int Logical. Include CIs? Default +#' \code{FALSE}. +#' @param conf.level Confidence level. Default 0.95. +#' @param uniform Logical. Uniform CIs? Default +#' \code{FALSE}. +#' @param bootstraps Integer. Bootstrap draws. Default 999. +#' @param ... Currently unused. +#' +#' @return A \code{data.frame} with columns \code{term}, +#' \code{estimate}, \code{std.error}, \code{statistic}, +#' \code{p.value}, \code{ensemble_type}, and +#' \code{aggregation}. +#' +#' @examples +#' \donttest{ +#' y = AE98[, "worked"] +#' D = AE98[, "morekids"] +#' X = AE98[, c("age","agefst","black","hisp","othrace")] +#' reps = ddml_replicate(ddml_plm, y = y, D = D, X = X, +#' learners = list(what = ols), +#' sample_folds = 2, +#' resamples = 3, silent = TRUE) +#' tidy(reps) +#' tidy(reps, conf.int = TRUE) +#' } +#' +#' @seealso \code{\link{summary.ddml_rep}} for the +#' aggregation equations. +#' +#' @export +#' @method tidy ddml_rep +tidy.ddml_rep <- function(x, ensemble_idx = 1, + aggregation = c("median", "mean", + "spectral"), + type = "HC1", + conf.int = FALSE, + conf.level = 0.95, + uniform = FALSE, + bootstraps = 999L, ...) { + aggregation <- match.arg(aggregation) + res <- tidy.ral_rep(x, fit_idx = ensemble_idx, + aggregation = aggregation, + type = type, + conf.int = conf.int, + conf.level = conf.level, + uniform = uniform, + bootstraps = bootstraps) + # Rename fit_label -> ensemble_type for DML compatibility + names(res)[names(res) == "fit_label"] <- "ensemble_type" + res +}#TIDY.DDML_REP + +#' Glance at a ddml_rep Object +#' +#' DML-specific glance method. Includes DML fields. +#' +#' @param x A \code{ddml_rep} object. +#' @param ... Currently unused. +#' +#' @return A one-row \code{data.frame}. +#' +#' @examples +#' \donttest{ +#' y = AE98[, "worked"] +#' D = AE98[, "morekids"] +#' X = AE98[, c("age","agefst","black","hisp","othrace")] +#' reps = ddml_replicate(ddml_plm, y = y, D = D, X = X, +#' learners = list(what = ols), +#' sample_folds = 2, +#' resamples = 3, silent = TRUE) +#' glance(reps) +#' } +#' +#' @export +#' @method glance ddml_rep +glance.ddml_rep <- function(x, ...) { + data.frame( + nobs = x$nobs, + sample_folds = x$sample_folds, + shortstack = x$shortstack, + ensemble_type = paste(x$ensemble_type, + collapse = ", "), + model_type = x$model_type, + estimator_name = x$estimator_name, + nresamples = x$nresamples, + stringsAsFactors = FALSE + ) +}#GLANCE.DDML_REP + +# List conversion ============================================================= + +#' Split a ddml_rep Object by Ensemble Type +#' +#' Returns a named list of single-ensemble +#' \code{ddml_rep} objects. +#' +#' @param x A \code{ddml_rep} object. +#' @param ... Currently unused. +#' +#' @return A named list of \code{ddml_rep} objects. +#' +#' @examples +#' \donttest{ +#' y = AE98[, "worked"] +#' D = AE98[, "morekids"] +#' X = AE98[, c("age","agefst","black","hisp","othrace")] +#' reps = ddml_replicate(ddml_plm, y = y, D = D, X = X, +#' learners = list(what = ols), +#' resamples = 3, +#' sample_folds = 2, +#' silent = TRUE) +#' as.list(reps) +#' } +#' +#' @method as.list ddml_rep +#' @export +as.list.ddml_rep <- function(x, ...) { + nfit <- x$nfit + labels <- x$ensemble_type + if (is.null(labels)) labels <- x$fit_labels + if (is.null(labels)) labels <- paste0("fit", seq_len(nfit)) + + out <- vector("list", nfit) + names(out) <- labels + for (j in seq_len(nfit)) { + fits_j <- lapply(x$fits, function(f) as.list(f)[[j]]) + obj <- ral_rep(fits_j, subclass = "ddml_rep") + obj$model_type <- x$model_type + obj$ensemble_type <- labels[j] + obj$fit_labels <- labels[j] + obj$sample_folds <- x$sample_folds + obj$shortstack <- x$shortstack + out[[j]] <- obj + }#FOR + out +}#AS.LIST.DDML_REP diff --git a/R/diagnostics.R b/R/diagnostics.R new file mode 100644 index 0000000..ded9bcb --- /dev/null +++ b/R/diagnostics.R @@ -0,0 +1,297 @@ +#' Stacking Diagnostics for DDML Estimators +#' +#' Computes per-learner diagnostics including MSPE, R-squared, +#' ensemble weights, and optionally cross-validation comparison +#' (CVC) p-values for each nuisance equation. +#' +#' @param object An object of class \code{ddml}. +#' @param cvc Logical. Compute CVC p-values via multiplier +#' bootstrap? Default \code{FALSE}. CVC tests whether each +#' learner is significantly outperformed by the others. +#' @param bootnum Number of bootstrap replications for CVC. +#' Default 500. Ignored when \code{cvc = FALSE}. +#' @param ... Currently unused. +#' +#' @return An object of class \code{ddml_diagnostics} containing per-equation +#' learner diagnostics. Use \code{print()} for formatted output or +#' \code{tidy()} for a flat data.frame. +#' +#' @examples +#' \donttest{ +#' y = AE98[, "worked"] +#' D = AE98[, "morekids"] +#' X = AE98[, c("age","agefst","black","hisp","othrace")] +#' learners = list(list(what = ols), +#' list(what = mdl_glmnet)) +#' plm_fit = ddml_plm(y, D, X, +#' learners = learners, +#' sample_folds = 2, silent = TRUE) +#' diagnostics(plm_fit, cvc = TRUE) +#' tidy(diagnostics(plm_fit, cvc = TRUE)) +#' } +#' +#' @references +#' Lei J (2020). "Cross-Validation With Confidence." Journal of the American +#' Statistical Association, 115(532), 1978-1997. +#' +#' @family utilities +#' @export +diagnostics <- function(object, cvc = FALSE, + bootnum = 500, + ...) { + if (!inherits(object, "ddml")) { + stop("object must be of class 'ddml'.", call. = FALSE) + }#IF + + eq_names <- names(object$ensemble_weights) + single_learner <- is_single_learner(object$learners) + tables <- list() + + for (eq in eq_names) { + w <- object$ensemble_weights[[eq]] + m <- object$mspe[[eq]] + r <- object$r2[[eq]] + + # Build per-learner table + nlearners <- if (single_learner) 1L else nrow(w) + + # Per-learner (and per-ensemble) OOS mspe and r2 + m_vec <- if (is.null(m) || length(m) == 0) rep(NA_real_, nlearners) else as.numeric(m) + r_vec <- if (is.null(r) || length(r) == 0) rep(NA_real_, nlearners) else as.numeric(r) + n_total <- length(m_vec) + + # Use names assigned upstream, or fallback to default + if (!is.null(names(m))) { + learner_names <- names(m) + } else { + learner_names <- if (single_learner) "single" else paste0("learner_", seq_len(n_total)) + }#IFELSE + + tbl <- data.frame( + learner = learner_names, + mspe = m_vec, + r2 = r_vec, + stringsAsFactors = FALSE, + row.names = NULL) + + if (single_learner) { + tbl$weight <- 1 + } else { + # Weights: average across folds if 3D array + if (length(dim(w)) == 3) { + w_avg <- apply(w, c(1, 2), mean) + } else { + w_avg <- as.matrix(w) + }#IFELSE + + ens_names <- colnames(w_avg) + if (is.null(ens_names)) { + ens_names <- paste0("weight_", seq_len(ncol(w_avg))) + }#IF + + for (j in seq_len(ncol(w_avg))) { + col_name <- paste0("weight_", ens_names[j]) + # Pad with NA for ensemble rows + w_col <- c(w_avg[, j], rep(NA_real_, n_total - nlearners)) + tbl[[col_name]] <- w_col + }#FOR + }#IFELSE + + # CVC p-values (opt-in) + if (cvc && !single_learner) { + cvc_pvals <- cvc_pvalues(object$fitted, object$splits, eq, bootnum) + tbl$cvc_pval <- c(cvc_pvals, rep(NA_real_, n_total - length(cvc_pvals))) + }#IF + + tables[[eq]] <- tbl + }#FOR + + result <- list( + tables = tables, + model_type = class(object)[1], + estimator_name = object$estimator_name, + nobs = object$nobs, + shortstack = object$shortstack, + cvc = cvc) + class(result) <- "ddml_diagnostics" + result +}#DIAGNOSTICS + +# Cross-validation comparison p-values (Lei, 2020). +# +# For each learner, tests whether it is significantly outperformed +# by any other learner using a sup-type multiplier bootstrap on +# the squared-residual differences. +# +# @param fitted Named list of per-equation cross-fitted objects. +# @param splits The splits structure from a ddml object. +# @param eq Character name of the nuisance equation. +# @param bootnum Number of bootstrap replications. +# +# @return Numeric vector of p-values (length = nlearners), +# or NA_real_ vector if residuals are unavailable. +cvc_pvalues <- function(fitted, splits, eq, bootnum = 500) { + entry <- fitted[[eq]] + resid <- if (!is.null(entry)) entry$cf_resid_bylearner else NULL + subs <- splits[[eq]]$subsamples + if (is.null(resid) || is.null(subs) || ncol(resid) < 2) { + nL <- if (!is.null(resid)) ncol(resid) else 1L + return(rep(NA_real_, nL)) + }#IF + + # Derive fold IDs from subsamples + n <- nrow(resid) + fid <- integer(n) + for (k in seq_along(subs)) { + fid[subs[[k]]] <- k + }#FOR + + nlearners <- ncol(resid) + pvalues <- numeric(nlearners) + for (i in seq_len(nlearners)) { + pvalues[i] <- cvc_one_vs_many( + resid[, i], resid[, -i, drop = FALSE], fid, bootnum) + }#FOR + pvalues +}#CVC_PVALUES + +# One-vs-many cross-validation comparison test. +# +# Tests whether learner i is dominated by any learner in the +# comparison set. Uses a sup-type statistic with multiplier +# bootstrap. +# +# Reference: Lei J (2020). "Cross-Validation With Confidence." +# Journal of the American Statistical Association, +# 115(532), 1978-1997. +# +# @param resid_base Numeric vector of OOS residuals from the +# base learner being tested. +# @param resid_others Matrix (n x K) of OOS residuals from +# the comparison learners. +# @param fid Integer vector of fold IDs. +# @param bootnum Number of bootstrap replications. +# +# @return P-value. Large p-value means the base learner is +# not significantly worse than the best alternative. +cvc_one_vs_many <- function(resid_base, resid_others, fid, + bootnum = 500) { + n <- length(resid_base) + K <- ncol(resid_others) + resid_base_mat <- matrix(resid_base, n, K) + + zeta <- resid_base_mat^2 - resid_others^2 + + # Demean by fold + fid_unique <- unique(fid) + zeta_til <- zeta + for (k in fid_unique) { + sel <- which(fid == k) + fold_means <- colMeans(zeta[sel, , drop = FALSE]) + zeta_til[sel, ] <- sweep( + zeta[sel, , drop = FALSE], 2, fold_means) + }#FOR + + zeta_m <- colMeans(zeta) + zeta_sd <- apply(zeta_til, 2, stats::sd) + zeta_sd[zeta_sd < .Machine$double.eps] <- Inf + + # Sup-type test statistic + Tx <- max(sqrt(n) * zeta_m / zeta_sd) + + # Multiplier bootstrap + zeta_scaled <- sweep(zeta_til, 2, zeta_sd, FUN = "/") + W <- matrix(stats::rnorm(n * bootnum), n, bootnum) + boot_stats <- crossprod(zeta_scaled, W) / sqrt(n) # K × bootnum + Txb <- apply(boot_stats, 2, max) + + mean(Txb > Tx) +}#CVC_ONE_VS_MANY + +#' Print Stacking Diagnostics +#' +#' @param x An object of class \code{ddml_diagnostics}. +#' @param digits Number of significant digits. Default 4. +#' @param ... Currently unused. +#' +#' @return \code{x}, invisibly. +#' +#' @export +print.ddml_diagnostics <- function(x, digits = 4, ...) { + model_name <- x$estimator_name + if (is.null(model_name)) model_name <- x$model_type + + cat("Stacking diagnostics:", model_name, "\n") + cat("Obs:", x$nobs, "\n\n") + + for (eq in names(x$tables)) { + tbl <- x$tables[[eq]] + cat(" ", eq, ":\n", sep = "") + + # Format numeric columns + display <- tbl + num_cols <- c("mspe", "r2", "cvc_pval", + grep("^weight_", names(display), value = TRUE)) + for (col in num_cols) { + if (col %in% names(display)) { + display[[col]] <- round(display[[col]], digits) + }#IF + }#FOR + + print(display, row.names = FALSE, right = TRUE) + cat("\n") + }#FOR + + if (!is.null(x$shortstack) && x$shortstack) { + if (x$cvc) cat("Note: CVC compares individual base learners.\n", + " Shortstacked ensemble CVC is not available.\n") + cat("Note: Ensemble MSPE and R2 for short-stacking rely on full-sample weights\n", + " and represent in-sample fit over cross-fitted base predictions.\n") + }#IF + + invisible(x) +}#PRINT.DDML_DIAGNOSTICS + +#' Tidy Stacking Diagnostics +#' +#' Returns a flat data.frame of per-learner stacking +#' diagnostics for all nuisance equations. Suitable for +#' table creation with \code{kable()}, \code{gt()}, or +#' \code{modelsummary::datasummary()}. +#' +#' @param x An object of class \code{ddml_diagnostics}. +#' @param ... Currently unused. +#' +#' @return A \code{data.frame} with columns \code{equation}, \code{learner}, +#' \code{mspe}, \code{r2}, \code{weight}, and optionally \code{cvc_pval}. +#' +#' @examples +#' \donttest{ +#' y = AE98[, "worked"] +#' D = AE98[, "morekids"] +#' X = AE98[, c("age","agefst","black","hisp","othrace")] +#' learners = list(list(what = ols), +#' list(what = mdl_glmnet)) +#' plm_fit = ddml_plm(y, D, X, +#' learners = learners, +#' sample_folds = 2, silent = TRUE) +#' tidy(diagnostics(plm_fit, cvc = TRUE)) +#' } +#' +#' @export +#' @method tidy ddml_diagnostics +tidy.ddml_diagnostics <- function(x, ...) { + rows <- list() + for (eq in names(x$tables)) { + tbl <- x$tables[[eq]] + tbl$equation <- eq + rows[[length(rows) + 1]] <- tbl + }#FOR + out <- do.call(rbind, rows) + # Reorder: equation first + eq_col <- which(names(out) == "equation") + out <- out[, c(eq_col, seq_along(out)[-eq_col]), + drop = FALSE] + rownames(out) <- NULL + out +}#TIDY.DDML_DIAGNOSTICS diff --git a/R/ensemble.R b/R/ensemble.R index 327981d..6a6cc60 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -1,66 +1,114 @@ -# Stacking estimator using combinations of base learners. -ensemble <- function(y, X, Z = NULL, +#' Stacking Estimator Using Combinations of Base Learners +#' +#' @family utilities +#' +#' @description Computes an ensemble of learners based on the specified +#' aggregation type and computes cross-validated out-of-sample +#' predictions to inform the weights. +#' +#' @param y The outcome variable. +#' @param X The feature matrix. +#' @param type A character string indicating the type of ensemble to compute. +#' Default is \code{"average"}. +#' @param learners A list of base learners. See +#' \code{\link{ddml-intro}} for the full specification. +#' @param cv_folds Number of cross-validation folds. +#' @param cv_subsamples Optional list of subsamples for cross-validation. +#' @param cv_results Optional pre-computed cross-validation results. +#' @param custom_weights Optional custom weights matrix. +#' @param silent A boolean indicating whether to suppress progress messages. +#' +#' @return An object of class \code{ensemble} containing: +#' \describe{ +#' \item{\code{mdl_fits}}{List of fitted base learners.} +#' \item{\code{weights}}{Computed ensemble weights.} +#' \item{\code{learners}}{The base learners used.} +#' \item{\code{cv_results}}{Cross-validation results if +#' computed.} +#' \item{\code{mean_y}}{Mean of the outcome variable.} +#' \item{\code{constant_y}}{Boolean indicating if y is +#' constant.} +#' } +#' @export +#' +#' @examples +#' \donttest{ +#' # Construct variables from the included Angrist & Evans (1998) data +#' y = AE98[, "worked"] +#' X = AE98[, c("age","agefst","black","hisp","othrace")] +#' +#' # Fit an ensemble of ols, lasso, and ridge +#' ens_fit = ensemble(y, X, +#' type = "nnls", +#' learners = list(list(what = ols), +#' list(what = mdl_glmnet), +#' list(what = mdl_glmnet, +#' args = list(alpha = 0))), +#' cv_folds = 5, +#' silent = TRUE) +#' ens_fit$weights +#' predict(ens_fit, newdata = X)[1:5] +#' } +ensemble <- function(y, X, type = "average", learners, cv_folds = 5, cv_subsamples = NULL, cv_results = NULL, custom_weights = NULL, - silent = FALSE, - progress = NULL) { + silent = FALSE) { + # Normalize learner specs + learners <- normalize_learners(learners) + + # Wrap single-learner spec into a 1-element list + if (is_single_learner(learners)) { + learners <- list(learners) + }#IF + # Data parameters nlearners <- length(learners) - # Check if y is constant + + # Constant-y: return trivial average weights of correct shape if (length(unique(y)) == 1) { - warning(paste("Outcome variable y is constant. Ensemble will return", - "mean(y) for all predictions.")) - # Return minimal output needed for predictions + warning(paste("Outcome variable y is constant. Ensemble will", + "return mean(y) for all predictions."), + call. = FALSE) + nensb <- length(type) + n_custom(custom_weights) + weights <- matrix(1 / nlearners, nlearners, nensb) + colnames(weights) <- c(type, colnames(custom_weights)) output <- list( mdl_fits = NULL, - weights = NULL, + weights = weights, learners = learners, cv_results = NULL, mean_y = mean(y), - constant_y = TRUE - ) + constant_y = TRUE) class(output) <- "ensemble" return(output) }#IF + # Compute ensemble weights - ens_w_res <- ensemble_weights(y, X, Z, + ens_w_res <- ensemble_weights(y, X, type = type, learners = learners, cv_folds = cv_folds, cv_subsamples = cv_subsamples, cv_results = cv_results, custom_weights = custom_weights, - silent = silent, progress = progress) + silent = silent) weights <- ens_w_res$weights cv_results <- ens_w_res$cv_results - # Check for excluded learners - mdl_include <- which(rowSums(abs(weights)) > 0) - if (length(mdl_include) == 0) { - warning("None of the learners are assigned positive stacking weights.") + # Warn if all learner weights are zero across ensemble columns + if (!any(rowSums(abs(weights)) > 0)) { + warning("None of the learners are assigned positive stacking ", + "weights.", call. = FALSE) }#IF - # Compute fit for each included model + + # Fit all base learners mdl_fits <- rep(list(NULL), nlearners) - for (m in 1:nlearners) { - # Skip model if not assigned positive weight - if (!(m %in% mdl_include)) next - # Check whether X, Z assignment has been specified. If not, include all. + for (m in seq_len(nlearners)) { if (is.null(learners[[m]]$assign_X)) - learners[[m]]$assign_X <- 1:ncol(X) - if (is.null(learners[[m]]$assign_Z) & !is.null(Z)) - learners[[m]]$assign_Z <- 1:ncol(Z) - # Else fit on data. Begin by selecting the model constructor and the - # variable assignment. - mdl_fun <- list(what = learners[[m]]$fun, args = learners[[m]]$args) - assign_X <- learners[[m]]$assign_X - assign_Z <- learners[[m]]$assign_Z - # Then fit the model - mdl_fun$args$y <- y - mdl_fun$args$X <- cbind(X[, assign_X], - Z[, assign_Z]) - mdl_fits[[m]] <- do.call(do.call, mdl_fun) + learners[[m]]$assign_X <- seq_len(ncol(X)) + mdl_fits[[m]] <- fit_learner(learners[[m]], y, X) }#FOR # Organize and return output @@ -73,120 +121,196 @@ ensemble <- function(y, X, Z = NULL, # Complementary methods ======================================================== +#' Predict Method for \code{ensemble} Objects +#' +#' @param object A fitted \code{ensemble} object. +#' @param newdata A feature matrix for prediction. +#' @param ... Currently unused. +#' @param type Character; \code{"ensemble"} (default) returns +#' weighted ensemble predictions, \code{"bylearner"} returns +#' the raw per-learner prediction matrix. +#' +#' @return A matrix of predictions. When \code{type = "ensemble"}, +#' one column per ensemble type; when \code{type = "bylearner"}, +#' one column per base learner. +#' #' @exportS3Method -predict.ensemble <- function(object, newdata, newZ = NULL, ...){ - # Data parameters +predict.ensemble <- function(object, newdata, ..., + type = "ensemble") { + type <- match.arg(type, c("ensemble", "bylearner")) nlearners <- length(object$learners) - # If y was constant, return mean_y for all observations + # Constant-y: return mean_y with the correct number of columns if (!is.null(object$constant_y) && object$constant_y) { - return(matrix(object$mean_y, nrow(newdata), nlearners)) - }#IF - # Check for excluded learners - mdl_include <- which(rowSums(abs(object$weights)) > 0) - if (length(mdl_include) == 0) { - fitted_ens <- matrix(object$mean_y, nrow(newdata), 1) - #warning("None of the learners are assigned positive stacking weights.") + ncols <- if (type == "bylearner") nlearners + else ncol(object$weights) + return(matrix(object$mean_y, nrow(newdata), ncols)) }#IF - # Calculate fitted values for each model - first_fit <- T - for (m in 1:nlearners) { - # Skip model if not assigned positive weight - if (!(m %in% mdl_include)) next - # Get assign_X and assing_Z + # Calculate fitted values for each learner + fitted_mat <- matrix(0, nrow(newdata), nlearners) + for (m in seq_len(nlearners)) { assign_X <- object$learners[[m]]$assign_X - assign_Z <- object$learners[[m]]$assign_Z - # Compute predictions fitted <- stats::predict(object$mdl_fits[[m]], - newdata = cbind(newdata[, assign_X], - newZ[, assign_Z])) - - # Initialize matrix of fitted values - if (first_fit) { - fitted_mat <- matrix(0, length(fitted), nlearners) - first_fit <- F - }#IF + newdata = newdata[, assign_X, + drop = FALSE]) fitted_mat[, m] <- methods::as(fitted, "matrix") }#FOR - # Compute matrix of fitted values by ensemble type and return - if (length(mdl_include) > 0) fitted_ens <- fitted_mat %*% object$weights - return(fitted_ens) + if (type == "bylearner") return(fitted_mat) + fitted_mat %*% object$weights }#PREDICT.ENSEMBLE # Complementary functions ====================================================== -ensemble_weights <- function(y, X, Z = NULL, + +#' Compute Stacking Weights for Base Learners +#' +#' @family utilities +#' +#' @description Computes the stacking weights for an ensemble of base learners +#' using cross-validated out-of-sample predictions. +#' +#' @param y The outcome variable. +#' @param X The feature matrix. +#' @param type A character string or vector indicating the type(s) of ensemble +#' weights to compute. Default is \code{"average"}. +#' @param learners Optional list of base learners. +#' Required when \code{cv_results} is not supplied (learners are +#' needed to run cross-validation). When \code{cv_results} is +#' supplied, \code{learners} may be omitted; the number of +#' learners is inferred from the cross-validation residuals. +#' See \code{\link{ddml-intro}} for the full specification. +#' @param cv_folds Number of cross-validation folds. +#' @param cv_subsamples Optional list of subsamples for cross-validation. +#' @param cv_results Optional pre-computed cross-validation results. +#' @param custom_weights Optional custom weights matrix. +#' @param silent A boolean indicating whether to suppress progress messages. +#' +#' @return A list containing: +#' \describe{ +#' \item{\code{weights}}{A matrix of computed ensemble +#' weights.} +#' \item{\code{cv_results}}{Cross-validation results used +#' for computing weights.} +#' } +#' @export +#' +#' @examples +#' \donttest{ +#' y = AE98[, "worked"] +#' X = AE98[, c("age","agefst","black","hisp","othrace")] +#' +#' # Compute stacking weights via NNLS +#' ew = ensemble_weights(y, X, +#' type = "nnls", +#' learners = list(list(what = ols), +#' list(what = mdl_glmnet)), +#' cv_folds = 5, +#' silent = TRUE) +#' ew$weights +#' } +ensemble_weights <- function(y, X, type = "average", - learners, + learners = NULL, cv_folds = 5, cv_subsamples = NULL, cv_results = NULL, custom_weights = NULL, - silent = FALSE, - progress = NULL) { + silent = FALSE) { # Data parameters - nlearners <- length(learners) - ncustom <- ncol(custom_weights) - ncustom <- ifelse(is.null(ncustom), 0, ncustom) + nlearners <- if (!is.null(cv_results)) { + ncol(cv_results$cv_resid) + } else { + length(learners) + }#IFELSE + ncustom <- n_custom(custom_weights) ntype <- length(type) - # Check whether out-of-sample residuals should be calculated to inform the - # ensemble weights, and whether previous results are available. + # Single learner: trivial weight of 1, skip cross-validation + if (nlearners == 1) { + weights <- matrix(1, 1, ntype + ncustom) + if (ncustom > 0) + weights[, (ntype + 1):(ntype + ncustom)] <- custom_weights + if (ncustom > 0 && is.null(colnames(custom_weights))) + colnames(custom_weights) <- paste0("custom_", seq_len(ncustom)) + colnames(weights) <- c(type, colnames(custom_weights)) + return(list(weights = weights, cv_results = NULL)) + }#IF + + # Check whether cross-validation is needed for data-driven weights cv_stacking <- c("ols", "nnls", "nnls1", "singlebest") - if (any(cv_stacking %in% type) & is.null(cv_results)) { - # Run crossvalidation procedure - cv_results <- crossval(y, X, Z, + if (any(cv_stacking %in% type) && is.null(cv_results)) { + cv_results <- crossval(y, X, learners = learners, cv_folds = cv_folds, cv_subsamples = cv_subsamples, - silent = silent, progress = progress) + silent = silent) }#IF - # Compute weights for each ensemble type + + # Compute weights for each ensemble type via dispatch weights <- matrix(0, nlearners, ntype + ncustom) - for (k in 1:ntype) { - if (type[k] == "average") { - # Assign 1 to all included learners and normalize - weights[, k] <- 1 - weights[, k] <- weights[, k] / sum(weights[, k]) - } else if (type[k] == "nnls1") { - # For stacking with weights constrained between 0 and 1: |w|_1 = 1, solve - # the quadratic programming problem. - sq_resid <- Matrix::crossprod(cv_results$oos_resid) - A <- cbind(matrix(1, nlearners, 1), diag(1, nlearners)) - # Calculate solution - # Note: quadprog only solves for pos.def matrices. nearPD finds nearest - # pos.def matrix as a workaround. - r <- quadprog::solve.QP(Dmat = Matrix::nearPD(sq_resid)$mat, - dvec = matrix(0, nlearners, 1), - Amat = A, - bvec = c(1, rep(0, nlearners))) - weights[, k] <- r$solution - } else if (type[k] == "nnls") { - # Reconstruct out of sample fitted values - oos_fitted <- as.numeric(y) - cv_results$oos_resid - # For non-negative stacking, calculate the non-negatuve ols coefficients - weights[, k] <- nnls::nnls(oos_fitted, y)$x - } else if (type[k] == "ols") { - # Reconstruct out of sample fitted values - oos_fitted <- as.numeric(y) - cv_results$oos_resid - # For unconstrained stacking, simply calculate the ols coefficients - weights[, k] <- ols(y, oos_fitted, const = FALSE)$coef - } else if (type[k] == "singlebest") { - # Find MSPE-minimizing model - mdl_min <- which.min(Matrix::colMeans(cv_results$oos_resid^2)[, drop = F]) - mdl_min <- (1:nlearners)[mdl_min] - # Assign unit weight to the best model - weights[mdl_min, k] <- 1 - }#IFELSE + for (k in seq_len(ntype)) { + weights[, k] <- compute_w(type[k], nlearners, + cv_results, y) }#FOR - # Append weights with custom weights - if (!(ncustom == 0)) { + + # Append custom weights + if (ncustom > 0) { weights[, (ntype + 1):(ntype + ncustom)] <- custom_weights }#IF - # Assign ensemble types to columns - if (!(ncustom == 0) && is.null(colnames(custom_weights))) { - colnames(custom_weights) <- paste0("custom_", 1:ncustom) + if (ncustom > 0 && is.null(colnames(custom_weights))) { + colnames(custom_weights) <- paste0("custom_", seq_len(ncustom)) }#IF colnames(weights) <- c(type, colnames(custom_weights)) - # Organize and return output - output <- list(weights = weights, cv_results = cv_results) - return(output) + + list(weights = weights, cv_results = cv_results) }#ENSEMBLE_WEIGHTS + +# Weight-type dispatch: maps a type string to a weight vector. +compute_w <- function(type, nlearners, cv_results, y) { + switch(type, + average = rep(1 / nlearners, nlearners), + nnls1 = compute_w_nnls1(nlearners, cv_results), + nnls = compute_w_nnls(cv_results, y), + ols = compute_w_ols(cv_results, y), + singlebest = compute_w_singlebest(nlearners, cv_results)) +}#COMPUTE_W + +compute_w_nnls1 <- function(nlearners, cv_results) { + # QP solver requires a positive-definite matrix. Empirical + # cross-products of CV residuals can be PSD (not PD) when + # learners are collinear. nearPD finds the nearest PD matrix. + sq_resid <- Matrix::crossprod(cv_results$cv_resid) + A <- cbind(matrix(1, nlearners, 1), diag(1, nlearners)) + r <- tryCatch( + quadprog::solve.QP(Dmat = Matrix::nearPD(sq_resid)$mat, + dvec = matrix(0, nlearners, 1), + Amat = A, + bvec = c(1, rep(0, nlearners))), + error = function(e) { + warning("nnls1 weight optimization failed: ", + conditionMessage(e), + ". Falling back to equal weights.", + call. = FALSE) + NULL + }) + if (!is.null(r)) r$solution + else rep(1 / nlearners, nlearners) +}#COMPUTE_W_NNLS1 + +# Unconstrained non-negative least squares (Wolpert-style). +# Unlike nnls1, weights are NOT normalized to sum to 1. +compute_w_nnls <- function(cv_results, y) { + cv_fitted <- as.numeric(y) - cv_results$cv_resid + nnls::nnls(cv_fitted, y)$x +}#COMPUTE_W_NNLS + +compute_w_ols <- function(cv_results, y) { + cv_fitted <- as.numeric(y) - cv_results$cv_resid + ols(y, cv_fitted, const = FALSE)$coef +}#COMPUTE_W_OLS + +compute_w_singlebest <- function(nlearners, cv_results) { + mdl_min <- which.min(Matrix::colMeans(cv_results$cv_resid^2)) + mdl_min <- (seq_len(nlearners))[mdl_min] + w <- rep(0, nlearners) + w[mdl_min] <- 1 + w +}#COMPUTE_W_SINGLEBEST diff --git a/R/get_CEF.R b/R/get_CEF.R index f2e851c..254beaf 100644 --- a/R/get_CEF.R +++ b/R/get_CEF.R @@ -1,72 +1,175 @@ -# Wrapper for [ddml::crosspred()] and [ddml::shortstacking()]. -get_CEF <- function(y, X, Z = NULL, +# Estimate a conditional expectation function via cross-fitting. +# +# Dispatches to crosspred() (standard stacking) or shortstacking() +# depending on the shortstack flag. Returns out-of-sample fitted +# values, ensemble weights, and MSPE. +# +# @param y Outcome vector. +# @param X Feature matrix (may be sparse). +# @param learners List of base learner specifications. +# @param ensemble_type Character vector of ensemble types. +# @param shortstack Logical; use short-stacking if TRUE. +# @param subsamples List of sample fold indices. +# @param cv_subsamples List of cross-validation fold indices. +# @param parallel Optional list with parallel config. +get_CEF <- function(y, X, learners, ensemble_type, shortstack, custom_ensemble_weights = NULL, - compute_insample_predictions = FALSE, - compute_predictions_bylearner = FALSE, subsamples, - cv_subsamples_list, + cv_subsamples, silent = FALSE, - progress = NULL, + label = NULL, auxiliary_X = NULL, - shortstack_y = y) { - # Compute CEF + parallel = NULL, + fitted = NULL) { + # Normalize learner specs once at the entry gate + learners <- normalize_learners(learners) + + # Use pre-computed predictions if supplied + if (!is.null(fitted)) { + if (!is.null(label)) { + info_msg(" Estimating ", label, "...", silent = silent) + }#IF + if (!is.null(fitted$cf_fitted_bylearner)) { + # Rule 2: recompute ensemble from per-learner predictions + if (!is.null(auxiliary_X) && + is.null(fitted$auxiliary_fitted_bylearner)) { + stop(paste("When auxiliary predictions are required,", + "fitted objects must contain", + "'auxiliary_fitted_bylearner'."), call. = FALSE) + }#IF + res <- build_CEF_from_crossfit( + y, fitted$cf_fitted_bylearner, + ensemble_type, custom_ensemble_weights, + cv_resid_byfold = fitted$cv_resid_byfold, + subsamples = subsamples, + auxiliary_fitted_bylearner = fitted$auxiliary_fitted_bylearner) + return(res) + }#IF + if (!is.null(fitted$cf_fitted)) { + # Rule 1: pre-ensembled predictions, use directly + res <- list(cf_fitted = fitted$cf_fitted, + weights = NULL, + ensemble_type = colnames( + as.matrix(fitted$cf_fitted)), + mspe = NULL, r2 = NULL, + auxiliary_fitted = NULL, + cf_fitted_bylearner = NULL, + cf_resid_bylearner = NULL, + cv_resid_byfold = NULL) + return(res) + }#IF + }#IF + + # Constant or empty y: return trivial predictions. + # This is the first layer of constant-y defense. ensemble() + # handles per-fold constant y via constant_y = TRUE (layer 2), + # and predict.ensemble() returns correctly-shaped predictions + # for constant-y ensembles (layer 3). + if (length(unique(y)) <= 1) { + constant_val <- if (length(y) > 0) y[1] else 0 + nlearners <- if (is_single_learner(learners)) 1L + else length(learners) + ncustom <- n_custom(custom_ensemble_weights) + nensb <- length(ensemble_type) + ncustom + n <- length(y) + + aux_fitted <- aux_fitted_bl <- NULL + if (!is.null(auxiliary_X)) { + aux_fitted <- lapply(auxiliary_X, function(ax) + matrix(constant_val, nrow(ax), nensb)) + aux_fitted_bl <- lapply(auxiliary_X, function(ax) + matrix(constant_val, nrow(ax), nlearners)) + }#IF + + if (!is.null(label) && label != "") { + info_msg(" ", label, " .......... skipped (constant outcome)", + silent = silent) + }#IF + + return(list( + cf_fitted = matrix(constant_val, n, nensb), + weights = NULL, + ensemble_type = ensemble_type, + mspe = NULL, r2 = NULL, + cf_fitted_bylearner = matrix(constant_val, n, nlearners), + cf_resid_bylearner = matrix(0, n, nlearners), + cv_resid_byfold = NULL, + auxiliary_fitted = aux_fitted, + auxiliary_fitted_bylearner = aux_fitted_bl)) + }#IF + + # Compute CEF via cross-fitting + if (!is.null(label)) { + info_msg(" Estimating ", label, "...", silent = silent) + }#IF if (shortstack) { - res <- shortstacking(y, X, Z, + res <- shortstacking(y, X, learners = learners, ensemble_type = ensemble_type, - custom_ensemble_weights = custom_ensemble_weights, - compute_insample_predictions = - compute_insample_predictions, + custom_ensemble_weights = + custom_ensemble_weights, subsamples = subsamples, - silent = silent, progress = progress, + silent = silent, auxiliary_X = auxiliary_X, - shortstack_y = shortstack_y) + parallel = parallel) } else { - res <- crosspred(y, X, Z, + res <- crosspred(y, X, learners = learners, ensemble_type = ensemble_type, - custom_ensemble_weights = custom_ensemble_weights, - compute_insample_predictions = - compute_insample_predictions, - compute_predictions_bylearner = - compute_predictions_bylearner, + custom_ensemble_weights = + custom_ensemble_weights, subsamples = subsamples, - cv_subsamples_list = cv_subsamples_list, - silent = silent, progress = progress, - auxiliary_X = auxiliary_X) + cv_subsamples = cv_subsamples, + silent = silent, + auxiliary_X = auxiliary_X, + parallel = parallel) }#IFELSE - update_progress(silent) - # Return estimates - return(res) -}#GET_CEF + # Attach ensemble_type derived from weights + if (is.null(res$ensemble_type)) { + res$ensemble_type <- if (!is.null(res$weights)) { + dimnames(res$weights)[[2]] + } else { + colnames(as.matrix(res$cf_fitted)) + } + }#IF -# Utility to print progress to console -update_progress <- function(silent) { - if (!silent) cat(" -- Done! \n") -}#UPDATE_PROGRESS + res +}#GET_CEF -# Construct CEF from auxiliary_X -extrapolate_CEF <- function(D, CEF_res_byD, aux_indxs) { +# Extrapolate CEF predictions across treatment levels. +# +# For each level d of D, populates out-of-sample and auxiliary +# predictions into an (nobs x nensb x nlevels) array. +# +# @param D Treatment vector. +# @param CEF_res_byD List (length nlevels) of lists, each with +# elements \code{$fit} (containing \code{$cf_fitted} and +# \code{$auxiliary_fitted}) and \code{$d} (the treatment level). +# @param aux_indx Auxiliary sample indices for extrapolation. +extrapolate_CEF <- function(D, CEF_res_byD, aux_indx) { # Data parameters nCEF <- length(CEF_res_byD) nobs <- length(D) D_levels <- lapply(CEF_res_byD, function(x) x$d) is_D <- rep(list(NULL), nCEF) - for (d in 1:nCEF) is_D[[d]] <- which(D == D_levels[d]) - nensb <- ncol(as.matrix(CEF_res_byD[[1]][[1]]$oos_fitted)) - sample_folds <- length(CEF_res_byD[[1]][[1]]$auxiliary_fitted) + for (d in seq_len(nCEF)) is_D[[d]] <- which(D == D_levels[d]) + nensb <- ncol(as.matrix( + CEF_res_byD[[1]]$fit$cf_fitted)) + sample_folds <- length( + CEF_res_byD[[1]]$fit$auxiliary_fitted) # Populate CEF g_X_byD <- array(0, dim = c(nobs, nensb, nCEF)) - for (d in 1:nCEF) { - g_X_byD[is_D[[d]], , d] <- CEF_res_byD[[d]][[1]]$oos_fitted - for (k in 1:sample_folds) { - g_X_byD[aux_indxs[[d]][[k]], , d] <- - CEF_res_byD[[d]][[1]]$auxiliary_fitted[[k]] + for (d in seq_len(nCEF)) { + g_X_byD[is_D[[d]], , d] <- + CEF_res_byD[[d]]$fit$cf_fitted + for (k in seq_len(sample_folds)) { + g_X_byD[aux_indx[[d]][[k]], , d] <- + CEF_res_byD[[d]]$fit$auxiliary_fitted[[k]] }#FOR }#FOR diff --git a/R/help_functions.R b/R/help_functions.R index 51622f8..a89f190 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -1,5 +1,49 @@ # Collection of small internal functions +# Resolve estimator progress messages. +# +# Merges user-supplied message overrides (passed via dots by +# internal callers like ddml_ate) with estimator defaults. +# Standard start/finish templates are derived from `name`. +# +# @param dots The `list(...)` captured in the estimator. +# @param name Estimator name, e.g. "ddml_apo". +# @param labels Named list of equation-specific labels, +# e.g. list(y_X = "E[Y|D=1,X]", D_X = "P(D=1|X)"). +# @return A named list of message strings. +resolve_messages <- function(dots, name, labels = list()) { + defaults <- c( + list(start = paste0(name, ": estimating (%s)"), + finish = paste0(name, ": completed in %s s")), + labels) + user <- dots[["messages"]] + if (is.null(user)) return(defaults) + c(user, defaults[setdiff(names(defaults), names(user))]) +}#RESOLVE_MESSAGES + +# Emit the estimator start message with mode info. +announce_start <- function(messages, parallel, silent) { + mode_str <- if (!is.null(parallel)) { + p <- parse_parallel(parallel) + paste0("parallel, ", p$num_cores, " cores") + } else { + "sequential" + }#IFELSE + if (!is.null(messages$start) && messages$start != "") { + info_msg(sprintf(messages$start, mode_str), + silent = silent) + }#IF +}#ANNOUNCE_START + +# Emit the estimator finish message with elapsed time. +announce_finish <- function(t0, messages, silent) { + elapsed <- round(proc.time()[3] - t0, 1) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) + }#IF +}#ANNOUNCE_FINISH + # Simple generalized inverse wrapper. csolve <- function(X) { # Attempt inversion @@ -12,35 +56,37 @@ csolve <- function(X) { X_inv }#CSOLVE -# Function to pull oosresid from get_CEF results -get_oosfitted <- function(res_list, j = NULL) { +# Extract ensemble cross-fitted predictions from a CEF result list. +get_cf_fitted <- function(res_list, j = NULL) { if (is.null(j)) { - vapply(res_list, function (x) x$oos_fitted, - FUN.VALUE = c(res_list[[1]]$oos_fitted)) + vapply(res_list, function (x) x$cf_fitted, + FUN.VALUE = c(res_list[[1]]$cf_fitted)) } else { - vapply(res_list, function (x) x$oos_fitted[, j], - FUN.VALUE = res_list[[1]]$oos_fitted[, 1]) + vapply(res_list, function (x) x$cf_fitted[, j], + FUN.VALUE = res_list[[1]]$cf_fitted[, 1]) }#IFELSE -}#GET_OOSRESID +}#GET_CF_FITTED # Function to trim propensity scores and warn user -trim_propensity_scores <- function(m_X, trim, ensemble_type) { - # Data parameter +trim_propensity_scores <- function(m_X, trim, ensemble_type, + silent = FALSE) { nensb <- length(ensemble_type) - # Trim by ensemble type - for (j in length(nensb)) { + for (j in seq_len(nensb)) { indx_trim_0 <- which(m_X[, j] <= trim) indx_trim_1 <- which(m_X[, j] >= 1 - trim) ntrim <- length(c(indx_trim_0, indx_trim_1)) if (ntrim > 0) { - # Warn user - if (nensb == 1) { - warning(paste0(ntrim, " propensity scores were trimmed.")) - } else { - warning(paste0(ensemble_type[j], ": ", ntrim, - " propensity scores were trimmed.")) - }#IFELSE - # Replace scores by constant + if (!silent) { + if (nensb == 1) { + warning(paste0(ntrim, + " propensity scores were trimmed."), + call. = FALSE) + } else { + warning(paste0(ensemble_type[j], ": ", ntrim, + " propensity scores were trimmed."), + call. = FALSE) + }#IFELSE + }#IF m_X[indx_trim_0, j] <- trim m_X[indx_trim_1, j] <- 1 - trim }#IF @@ -48,3 +94,360 @@ trim_propensity_scores <- function(m_X, trim, ensemble_type) { # Return trimmed scores m_X }#TRIM_PROPENSITY_SCORES + +# Detect whether learners is a single-learner spec or stacking. +# Single: list(what = fn, args = ...) — first element is not a list. +# Stacking: list(list(what = fn), list(what = fn2)) — first element is a list. +is_single_learner <- function(learners) { + is.list(learners) && !is.list(learners[[1]]) +}#IS_SINGLE_LEARNER + +# Ensure all learner specs have $what set. +# Accepts $fun as deprecated alias. Removes $fun after resolving. +normalize_learners <- function(learners) { + resolve <- function(l) { + if (!is.null(l$what)) return(l$what) + if (!is.null(l$fun)) { + message("Note: 'fun' in learner specifications ", + "is deprecated. Use 'what' instead.") + return(l$fun) + }#IF + stop("Learner must have a 'what' element.", + call. = FALSE) + }#RESOLVE + + if (is_single_learner(learners)) { + learners$what <- resolve(learners) + learners$fun <- NULL + return(learners) + }#IF + for (i in seq_along(learners)) { + learners[[i]]$what <- resolve(learners[[i]]) + learners[[i]]$fun <- NULL + }#FOR + learners +}#NORMALIZE_LEARNERS + +# Compute MSPE and R-squared from a residual matrix and outcome. +compute_mspe_r2 <- function(resid, y) { + mspe <- colMeans(resid^2) + y_var <- as.numeric(stats::var(y)) + r2 <- if (y_var > 0) 1 - mspe / y_var else + rep(NA_real_, length(mspe)) + list(mspe = mspe, r2 = r2) +}#COMPUTE_MSPE_R2 + +# Fit a single base learner to y and X, with tryCatch wrapping. +fit_learner <- function(learner, y, X) { + if (is.null(learner$assign_X)) + learner$assign_X <- seq_len(ncol(X)) + mdl_fun <- list(what = learner$what, args = learner$args) + mdl_fun$args$y <- y + mdl_fun$args$X <- X[, learner$assign_X, drop = FALSE] + tryCatch( + do.call(do.call, mdl_fun), + error = function(e) { + stop("Learner fitting failed: ", conditionMessage(e), + call. = FALSE) + }) +}#FIT_LEARNER + +# Count custom ensemble weight columns (0L when NULL). +n_custom <- function(custom_weights) { + if (is.null(custom_weights)) 0L else ncol(custom_weights) +}#N_CUSTOM + +# Build a CEF-like result from pre-computed per-learner predictions. +# When cv_resid_byfold + subsamples are available, recomputes +# per-fold weights from inner-CV residuals (exact). Otherwise +# uses sample-fold residuals (approximate, exact for shortstacking). +build_CEF_from_crossfit <- function(y, cf_fitted_bylearner_eq, + ensemble_type, + custom_ensemble_weights, + cv_resid_byfold = NULL, + subsamples = NULL, + auxiliary_fitted_bylearner = NULL) { + nobs <- length(y) + cf <- as.matrix(cf_fitted_bylearner_eq) + + cf_resid_bylearner <- drop(y) - cf + mspe_bylearner <- colMeans(cf_resid_bylearner^2) + + # Two weight-computation paths: + # Per-fold: uses inner-CV residuals from the training fold to + # compute fold-specific weights (exact stacking). + # Pooled: uses OOS cross-fitted residuals from the full sample + # to compute a single set of weights (approximate; exact for + # short-stacking where OOS residuals ARE the stacking residuals). + if (!is.null(cv_resid_byfold) && !is.null(cv_resid_byfold[[1]]) && + !is.null(subsamples)) { + K <- length(subsamples) + ncustom <- n_custom(custom_ensemble_weights) + nensb <- length(ensemble_type) + ncustom + cf_fitted <- matrix(0, nobs, nensb) + all_weights <- vector("list", K) + for (k in seq_len(K)) { + train_idx <- setdiff(seq_len(nobs), subsamples[[k]]) + fakecv_k <- list( + cv_resid = cv_resid_byfold[[k]], + mspe = colMeans(cv_resid_byfold[[k]]^2)) + ew_k <- ensemble_weights( + y[train_idx], cf[train_idx, ], + type = ensemble_type, + cv_results = fakecv_k, + custom_weights = custom_ensemble_weights, + silent = TRUE) + all_weights[[k]] <- ew_k$weights + cf_fitted[subsamples[[k]], ] <- cf[subsamples[[k]], ] %*% + ew_k$weights + }#FOR + weights <- array(0, dim = c(ncol(cf), nensb, K)) + for (k in seq_len(K)) weights[, , k] <- all_weights[[k]] + dimnames(weights) <- list(NULL, colnames(all_weights[[1]]), + paste("sample fold ", seq_len(K))) + } else { + fakecv <- list(cv_resid = cf_resid_bylearner, + mspe = mspe_bylearner) + ew <- ensemble_weights( + y, cf, type = ensemble_type, + cv_results = fakecv, + custom_weights = custom_ensemble_weights, + silent = TRUE) + weights <- ew$weights + cf_fitted <- cf %*% weights + }#IFELSE + + ens_names <- colnames(weights) + if (!is.null(ens_names)) colnames(cf_fitted) <- ens_names + + auxiliary_fitted <- extrapolate_auxiliary( + auxiliary_fitted_bylearner, weights) + + oos_stats <- compute_mspe_r2(cf_resid_bylearner, y) + mspe <- oos_stats$mspe + r2 <- oos_stats$r2 + + nlearners <- ncol(cf) + if (nlearners > 1) { + # Ensemble OOS mspe and r-squared + cf_resid_ens <- drop(y) - cf_fitted + oos_stats_ens <- compute_mspe_r2(cf_resid_ens, y) + + mspe <- c(mspe, oos_stats_ens$mspe) + r2 <- c(r2, oos_stats_ens$r2) + names(mspe) <- names(r2) <- c(paste0("learner_", seq_len(nlearners)), + ens_names) + }#IF + + list(cf_fitted = cf_fitted, + weights = weights, + ensemble_type = ens_names, + mspe = mspe, + r2 = r2, + auxiliary_fitted = auxiliary_fitted, + cf_fitted_bylearner = cf, + cf_resid_bylearner = cf_resid_bylearner, + cv_resid_byfold = cv_resid_byfold) +}#BUILD_CEF_FROM_CROSSFIT + +# Apply ensemble weights to per-learner auxiliary predictions. +extrapolate_auxiliary <- function(auxiliary_fitted_bylearner, + weights) { + if (is.null(auxiliary_fitted_bylearner)) return(NULL) + K <- length(auxiliary_fitted_bylearner) + per_fold <- length(dim(weights)) == 3 + auxiliary_fitted <- vector("list", K) + for (k in seq_len(K)) { + w_k <- if (per_fold) weights[, , k] else weights + auxiliary_fitted[[k]] <- + as.matrix(auxiliary_fitted_bylearner[[k]]) %*% w_k + }#FOR + auxiliary_fitted +}#EXTRAPOLATE_AUXILIARY + +validate_fitted_splits_pair <- function(fitted, splits) { + if (is.null(fitted)) return(invisible(NULL)) + if (is.null(splits)) { + stop("'splits' must be supplied when 'fitted' is ", + "supplied.", call. = FALSE) + }#IF +}#VALIDATE_FITTED_SPLITS_PAIR + +build_fitted_entry <- function(res, save_crossval, + include_auxiliary = FALSE) { + entry <- list(cf_fitted = res$cf_fitted, + cf_fitted_bylearner = res$cf_fitted_bylearner, + cf_resid_bylearner = res$cf_resid_bylearner) + if (save_crossval) { + entry$cv_resid_byfold <- res$cv_resid_byfold + }#IF + if (include_auxiliary) { + entry$auxiliary_fitted <- res$auxiliary_fitted + entry$auxiliary_fitted_bylearner <- + res$auxiliary_fitted_bylearner + }#IF + entry +}#BUILD_FITTED_ENTRY + +build_fitted_flat <- function(res_list, save_crossval, + key_prefix, key_suffix) { + out <- list() + for (k in seq_along(res_list)) { + key <- paste0(key_prefix, k, key_suffix) + out[[key]] <- build_fitted_entry(res_list[[k]], + save_crossval) + }#FOR + out +}#BUILD_FITTED_FLAT + +# Input validation checks for DDML estimators +validate_inputs <- function(y = NULL, D = NULL, X = NULL, Z = NULL, + learners = NULL, + sample_folds = NULL, cv_folds = NULL, + ensemble_type = NULL, trim = NULL, + weights = NULL, + cluster_variable = NULL, + require_binary_D = FALSE) { + nobs <- length(y) + if (!is.null(y)) { + if (!is.numeric(y) || anyNA(y) || nobs == 0) { + stop("y must be a numeric vector with no NAs.", + call. = FALSE) + } + } + + if (!is.null(D) && !is.null(y)) { + D_mat <- as.matrix(D) + if (!is.numeric(D_mat) || anyNA(D_mat)) { + stop("D must be numeric with no NAs.", call. = FALSE) + } + if (nrow(D_mat) != nobs) { + stop("Length/number of rows of D must match length of y.", + call. = FALSE) + } + if (require_binary_D) { + if (!all(D_mat %in% c(0, 1))) { + stop("D must be binary (0 or 1).", call. = FALSE) + } + } + } + + if (!is.null(X) && !is.null(y)) { + if (NROW(X) != nobs) { + stop("Number of rows of X must match length of y.", + call. = FALSE) + } + } + + if (!is.null(Z) && !is.null(y)) { + if (NROW(Z) != nobs) { + stop("Number of rows of Z must match length of y.", + call. = FALSE) + } + } + + if (!is.null(learners)) { + if (!is.list(learners)) { + stop("learners must be a list.", call. = FALSE) + } else { + is_single <- is_single_learner(learners) + if (!is_single) { + for (l in learners) { + if (!is.list(l) || + (is.null(l$what) && is.null(l$fun))) { + stop("Each stacking learner must have a ", + "'what' element.", + call. = FALSE) + }#IF + }#FOR + }#IF + } + } + + if (!is.null(sample_folds)) { + if (!is.numeric(sample_folds) || length(sample_folds) > 1 || + sample_folds < 1 || sample_folds %% 1 != 0) { + stop("sample_folds must be a positive integer.", + call. = FALSE) + } + } + + if (!is.null(cv_folds)) { + if (!is.numeric(cv_folds) || length(cv_folds) > 1 || + cv_folds < 1 || cv_folds %% 1 != 0) { + stop("cv_folds must be a positive integer.", + call. = FALSE) + } + } + + if (!is.null(ensemble_type)) { + allowed_types <- c("nnls", "nnls1", "singlebest", "ols", "average") + if (!is.character(ensemble_type) || + any(!ensemble_type %in% allowed_types)) { + stop("ensemble_type must be one or more of: ", + "nnls, nnls1, singlebest, ols, average.", + call. = FALSE) + } + } + + if (!is.null(trim)) { + if (!is.numeric(trim) || length(trim) > 1 || + trim <= 0 || trim >= 0.5) { + stop("trim must be a numeric value strictly ", + "between 0 and 0.5.", call. = FALSE) + } + } + + if (!is.null(weights) && !is.null(y)) { + if (!is.numeric(weights) || anyNA(weights)) { + stop("weights must be a numeric vector with no NAs.", + call. = FALSE) + } + if (length(weights) != nobs) { + stop("weights must have the same length as y.", + call. = FALSE) + } + } + + if (!is.null(cluster_variable)) { + if (anyNA(cluster_variable)) { + stop("cluster_variable must not contain NAs.", + call. = FALSE) + } + } +}#VALIDATE_INPUTS + +validate_custom_weights <- function(custom_weights, learners) { + if (is.null(custom_weights)) return(invisible(NULL)) + if (!is.numeric(custom_weights)) { + stop("custom_ensemble_weights must be numeric.", + call. = FALSE) + } + custom_weights <- as.matrix(custom_weights) + n_learners <- if (is_single_learner(learners)) 1 else length(learners) + if (nrow(custom_weights) != n_learners) { + stop("Number of rows in custom_ensemble_weights must match ", + "the number of base learners.", call. = FALSE) + } +}#VALIDATE_CUSTOM_WEIGHTS + +# print a 3D coefficient array. +# Used by print.summary.ral, print.summary.ddml, and their +# _rep counterparts. +print_coef_tables <- function(coefficients, fit_label = "Fit", digits = 3) { + nfit <- dim(coefficients)[3] + for (j in seq_len(nfit)) { + if (nfit > 1) { + cat(fit_label, ": ", dimnames(coefficients)[[3]][j], "\n", sep = "") + }#IF + tbl <- coefficients[, , j] + if (!is.matrix(tbl)) { + tbl <- matrix(tbl, nrow = 1, dimnames = list( + dimnames(coefficients)[[1]], + dimnames(coefficients)[[2]])) + }#IF + stats::printCoefmat(tbl, digits = digits, has.Pvalue = TRUE, + signif.stars = TRUE) + if (j < nfit) cat("\n") + }#FOR +}#PRINT_COEF_TABLES diff --git a/R/inference_functions.R b/R/inference_functions.R deleted file mode 100644 index 6e5fd68..0000000 --- a/R/inference_functions.R +++ /dev/null @@ -1,103 +0,0 @@ -# Function to organize inference results for plm, pliv, and fpliv. -organize_inf_results <- function(fit_obj_list, ensemble_type, cluster_variable, - ...) { - # Check whether a single or multiple ensemble_types were computed - if (!methods::is(fit_obj_list, "list")) { - # Compute standard errors, t-vals, and p-vals - inf_results <- compute_inf_results_by_ensemble(fit_obj_list, - cluster_variable, ...) - coef_names <- names(fit_obj_list$coefficients) - } else { - # Compute output for each ensemble_type - ncoef <- length(fit_obj_list[[1]]$coefficients) - nens <- length(ensemble_type) - inf_results <- array(0, dim = c(ncoef, 4, nens)) - for (ens in 1:nens) { - inf_results[, , ens] <- - compute_inf_results_by_ensemble(fit_obj_list[[ens]], cluster_variable, - ...) - }#FOR - coef_names <- names(fit_obj_list[[1]]$coefficients) - }#IFELSE - # Name array dimensions - dimnames(inf_results) <- list(coef_names, - c("Estimate", "Std. Error", - "t value", "Pr(>|t|)"), - ensemble_type) - # Return inference results - inf_results -}#COMPUTE_INF_RESULTS - -# Function to compute std. errors, t-vals, and p-vals for plm, pliv, and fpliv. -compute_inf_results_by_ensemble <- function(fit_obj, cluster_variable, ...) { - # Data parameters - ncoef <- length(fit_obj$coefficients) - cluster <- !identical(seq_along(fit_obj$residuals), cluster_variable) - # Compute standard error, t-values, and p-vales - if (cluster) { - Sigma <- sandwich::vcovCL(fit_obj, cluster = cluster_variable, ...) - } else { - Sigma <- sandwich::vcovHC(fit_obj, ...) - }#IFELSE - std_errors <- sqrt(diag(Sigma)) - t_values <- fit_obj$coefficients / std_errors - p_values <- 2 * vapply(abs(t_values), stats::pnorm, - FUN.VALUE = 1, lower.tail = F) - - # Store results in a matrix - inf_results <- array(0, dim = c(ncoef, 4, 1)) - inf_results[, 1, 1] <- fit_obj$coefficients - inf_results[, 2, 1] <- std_errors - inf_results[, 3, 1] <- t_values - inf_results[, 4, 1] <- p_values - # Return results - inf_results -}#COMPUTE_INF_RESULTS_BY_ENSEMBLE - -# Function to organize inference results for ate and late. -organize_interactive_inf_results <- function(coef, psi_a, psi_b, - ensemble_type, cluster_variable) { - # Data parameters - nens <- length(ensemble_type) - # Compute inference results by ensemble type - inf_results <- matrix(0, nens, 4) - for (ens in 1:nens) { - inf_results[ens, ] <- - compute_interactive_inf_results_by_ensemble(coef = coef[ens], - psi_a = psi_a[, ens], - psi_b = psi_b[, ens], - cluster_variable) - }#FOR - # Name and return output - dimnames(inf_results) <- list(ensemble_type, - c("Estimate", "Std. Error", - "t value", "Pr(>|t|)")) - inf_results -}#ORGANIZE_INTERACTIVE_INF_RESULTS - -# Function to compute std. errors, t-vals, and p-vals for ate and late. -compute_interactive_inf_results_by_ensemble <- function(coef, psi_a, psi_b, - cluster_variable) { - # Data parameters - nobs <- length(psi_a) - cluster <- !identical(1:nobs, cluster_variable) - # Compute scores - scores <- psi_a * coef + psi_b - # Compute standard error, t-values, and p-vales - if (cluster) { - # Aggregate scores to cluster level for clustered standard errors - scores <- stats::aggregate(scores, by = list(cluster_variable), - FUN = sum)[, 2] - psi_a <- stats::aggregate(psi_a, by = list(cluster_variable), - FUN = sum)[, 2] - nobs <- length(scores) - }#IF - std_error <- sqrt(mean(scores^2) / nobs) / abs(mean(psi_a)) - t_values <- coef / std_error - p_value <- 2 * vapply(abs(t_values), stats::pnorm, - FUN.VALUE = 1, lower.tail = F) - # Store results in a matrix - inf_results <- c(coef, std_error, t_values, p_value) - # Return results - inf_results -}#COMPUTE_INTERACTIVE_INF_RESULTS_BY_ENSEMBLE diff --git a/R/lincom.R b/R/lincom.R new file mode 100644 index 0000000..da0e1d8 --- /dev/null +++ b/R/lincom.R @@ -0,0 +1,303 @@ +#' Linear Combinations of DDML Coefficients +#' +#' @family ddml inference +#' @importFrom stats coef confint +#' +#' @description Computes linear combinations \eqn{R'\hat\theta} +#' of DDML coefficient estimates. +#' +#' @details +#' For a \eqn{p}-dimensional coefficient vector +#' \eqn{\hat\theta} and a \eqn{(p \times q)}{p x q} contrast +#' matrix \eqn{R}, the linear combination is +#' \eqn{\gamma = R'\hat\theta}. +#' +#' The influence function for \eqn{\gamma} is +#' +#' \deqn{\phi_\gamma(W_i; \theta, R) +#' = R'\, \phi_\theta(W_i; \theta) +#' + \Phi_{R}(W_i)\, \theta,} +#' +#' where \eqn{\phi_\theta} is the influence function of +#' \eqn{\hat\theta} (see \code{\link{ral}} and +#' \code{\link{ddml-intro}}), +#' \eqn{\Phi_R(W_i)} is the \eqn{(p \times q)}{p x q} +#' matrix of influence functions for the contrast matrix +#' \eqn{R} (the \eqn{i}-th slice of \code{inf_func_R}), +#' and the second term vanishes when \eqn{R} is fixed. +#' The estimated influence function is +#' +#' \deqn{\hat\phi_{\gamma,i} +#' = R'\, \hat\phi_{\theta,i} +#' + \hat\Phi_{R,i}\, \hat\theta.} +#' +#' The leverage for \eqn{\gamma} is +#' +#' \deqn{h_\gamma(W_i; \theta, R) +#' = \mathrm{tr}\! \left( +#' R'\,h_\theta(W_i; \theta)\,R +#' + h_R(W_i)\right),} +#' +#' where \eqn{h_\theta} is the structural leverage from +#' the parent estimator (see \code{\link{hatvalues.ral}}) +#' and \eqn{h_R} is the weighting leverage. The sample +#' analog is +#' +#' \deqn{\hat{h}_{\gamma,i} +#' = \mathrm{tr}\! \left( +#' R'\,\hat{h}_{\theta,i}\,R +#' + \hat{h}_{R,i}\right),} +#' +#' where \eqn{\hat{h}_{\theta,i}} is mapped from the +#' parent's \code{dinf_dtheta} and \eqn{\hat{h}_{R,i}} +#' from the optional \code{dinf_dR} argument. +#' +#' The resulting \code{lincom} object inherits from +#' \code{ral} and supports all standard inference methods: +#' \code{vcov}, \code{confint}, \code{summary}, \code{tidy}, +#' and \code{hatvalues}. For \code{ddml_rep} objects, +#' \code{lincom} returns a \code{lincom_rep} inheriting +#' from \code{ral_rep}. +#' +#' Note that \code{inf_func_R} is needed for inference when +#' \eqn{R} is estimated. Leverage computation further requires +#' \code{dinf_dR}. See \code{\link{vcov.ral}} and +#' \code{\link{hatvalues.ral}} for more details. +#' + +#' @param fit A \code{ddml} or \code{ddml_rep} object. +#' @param R A \eqn{(p \times q)}{p x q} contrast matrix. +#' Each column defines one linear combination. +#' @param fit_idx Integer index of the fit to use, or +#' \code{NULL} (default) for all ensemble types. +#' When \code{NULL}, the output carries all ensembles +#' from the parent fit. +#' @param labels Optional character vector of length \eqn{q} +#' naming the linear combinations. Defaults to column +#' names of \code{R}, or \code{"lc1"}, \code{"lc2"}, etc. +#' @param inf_func_R An optional \eqn{(n \times p \times q)} +#' {n x p x q} array of influence functions +#' \eqn{\Phi_{R,i}} for the contrast matrix \eqn{R}. +#' Slice \code{[,,k]} contains the IFs for column +#' \eqn{k} of \eqn{R}. When supplied, a delta-method +#' correction is applied to the variance. When +#' \code{NULL} (default), \eqn{R} is treated as fixed +#' and only the first term contributes. +#' @param dinf_dR An optional \eqn{(n \times q \times q)}{n x q x q} +#' array of observation-level derivatives +#' \eqn{-n^{-1} \partial \phi_{R,i} / \partial R}, +#' representing the Weighting Leverage. When supplied, +#' it is added to the Structural Leverage to form the +#' total leverage used by HC3. +#' @param ... Currently unused. +#' +#' @return An object of class \code{"lincom"} (inheriting +#' from \code{"ral"}) for \code{ddml} input, or +#' \code{"lincom_rep"} (inheriting from \code{"ral_rep"}) +#' for \code{ddml_rep} input. +#' +#' @seealso \code{\link{lincom_weights_did}} for constructing +#' DiD aggregation weights. +#' +#' @references +#' Chernozhukov V, Chetverikov D, Demirer M, Duflo E, +#' Hansen C B, Newey W, Robins J (2018). +#' "Double/debiased machine learning for treatment +#' and structural parameters." The Econometrics +#' Journal, 21(1), C1-C68. +#' +#' @examples +#' \donttest{ +#' set.seed(42) +#' n <- 200; T_ <- 4 +#' X <- matrix(rnorm(n * 2), n, 2) +#' G <- sample(c(3, 4, Inf), n, replace = TRUE, +#' prob = c(0.3, 0.3, 0.4)) +#' y <- matrix(rnorm(n * T_), n, T_) +#' for (i in seq_len(n)) { +#' if (is.finite(G[i])) { +#' for (j in seq_len(T_)) { +#' if (j >= G[i]) y[i, j] <- y[i, j] + 1 +#' } +#' } +#' } +#' fit <- ddml_attgt(y, X, t = 1:T_, G = G, +#' learners = list(what = ols), +#' sample_folds = 2, +#' silent = TRUE) +#' # Simple contrast: first cell minus second +#' p <- nrow(fit$coefficients) +#' R <- matrix(0, p, 1) +#' R[1, 1] <- 1; R[2, 1] <- -1 +#' lc <- lincom(fit, R = R, labels = "ATT1-ATT2") +#' summary(lc) +#' } +#' +#' @export +lincom <- function(fit, R, ...) { + UseMethod("lincom") +}#LINCOM + +#' @rdname lincom +#' @export +#' @method lincom ddml +lincom.ddml <- function(fit, R, + fit_idx = NULL, + labels = NULL, + inf_func_R = NULL, + dinf_dR = NULL, + ...) { + R <- as.matrix(R) + p <- nrow(fit$coefficients) + q <- ncol(R) + n <- fit$nobs + stopifnot(nrow(R) == p) + + # Resolve ensemble indices + nensb <- ncol(fit$coefficients) + if (is.null(fit_idx)) { + j_seq <- seq_len(nensb) + } else { + j_seq <- fit_idx + }#IFELSE + nfit <- length(j_seq) + + # Validate inf_func_R dimensions (ensemble-invariant) + if (!is.null(inf_func_R)) { + stopifnot(length(dim(inf_func_R)) == 3, + dim(inf_func_R)[1] == n, + dim(inf_func_R)[2] == p, + dim(inf_func_R)[3] == q) + }#IF + + # Allocate output arrays + coef_mat <- matrix(NA_real_, q, nfit) + lincom_if <- array(0, dim = c(n, q, nfit)) + dinf_dtheta <- NULL + + for (jj in seq_along(j_seq)) { + j <- j_seq[jj] + + # Point estimate: R'theta_j + theta <- fit$coefficients[, j] + coef_mat[, jj] <- as.numeric(crossprod(R, theta)) + + # Unit-level IF: R' phi_i^theta_j + theta_if <- fit$inf_func[, , j, drop = FALSE] + dim(theta_if) <- dim(theta_if)[1:2] + lincom_if[, , jj] <- theta_if %*% R + + # Delta-method correction (when R estimated) + if (!is.null(inf_func_R)) { + for (k in seq_len(q)) { + lincom_if[, k, jj] <- lincom_if[, k, jj] + inf_func_R[, , k] %*% theta + }#FOR + }#IF + + # Map Structural Leverage + if (!is.null(fit$dinf_dtheta)) { + if (is.null(dinf_dtheta)) { + dinf_dtheta <- array(NA_real_, dim = c(n, q, q, nfit)) + }#IF + dinf_j <- fit$dinf_dtheta[, , , j, drop = FALSE] + for (i in seq_len(n)) { + dinf_i <- matrix(dinf_j[i, , , 1], p, p) + dinf_dtheta[i, , , jj] <- t(R) %*% dinf_i %*% R + }#FOR + + # Add weighting leverage + if (!is.null(dinf_dR)) { + if (length(dim(dinf_dR)) == 3) { + # 3D dinf_dR: broadcast to current ensemble + dinf_dtheta[, , , jj] <- dinf_dtheta[, , , jj] + + dinf_dR + } else { + # 4D dinf_dR: per-ensemble slice + dinf_dtheta[, , , jj] <- dinf_dtheta[, , , jj] + + dinf_dR[, , , jj] + }#IFELSE + }#IF + }#IF + }#FOR + + # Labels + if (is.null(labels)) labels <- colnames(R) + if (is.null(labels)) labels <- paste0("lc", seq_len(q)) + + # Fit labels (ensemble type names) + fit_labels <- colnames(fit$coefficients)[j_seq] + if (is.null(fit_labels)) { + fit_labels <- if (!is.null(fit$fit_labels)) { + fit$fit_labels[j_seq] + } else { + paste0("lincom", seq_len(nfit)) + }#IFELSE + }#IF + + rownames(coef_mat) <- labels + colnames(coef_mat) <- fit_labels + + ral(coefficients = coef_mat, + inf_func = lincom_if, + dinf_dtheta = dinf_dtheta, + nobs = n, + coef_names = labels, + cluster_variable = fit$cluster_variable, + estimator_name = "Linear Combination", + subclass = "lincom", + fixed_R = is.null(inf_func_R)) +}#LINCOM.DDML + +# lincom.ddml_rep ============================================================== + +#' @rdname lincom +#' @export +#' @method lincom ddml_rep +lincom.ddml_rep <- function(fit, R, inf_func_R = NULL, + dinf_dR = NULL, + fit_idx = NULL, + labels = NULL, ...) { + # Apply lincom.ddml to each rep + lc_fits <- lapply(fit$fits, function(f) { + lincom(f, R = R, inf_func_R = inf_func_R, + dinf_dR = dinf_dR, fit_idx = fit_idx, + labels = labels, ...) + }) + + ral_rep(lc_fits, subclass = "lincom_rep", + fixed_R = is.null(inf_func_R)) +}#LINCOM.DDML_REP + +# Print methods ================================================================ + +#' @rdname lincom +#' @param x A \code{lincom} or \code{lincom_rep} object. +#' @export +#' @method print lincom +print.lincom <- function(x, ...) { + cat("Linear Combination\n") + cat("Obs:", x$nobs) + nfit <- ncol(x$coefficients) + if (nfit > 1) cat(" Ensembles:", nfit) + if (!x$fixed_R) cat(" (delta-method)") + cat("\n\n") + cat("Use summary() for inference.\n") + invisible(x) +}#PRINT.LINCOM + +#' @rdname lincom +#' @export +#' @method print lincom_rep +print.lincom_rep <- function(x, ...) { + cat("Linear Combination (replicated)\n") + cat("Obs:", x$nobs, + " Resamples:", x$nresamples) + nfit <- x$nfit + if (!is.null(nfit) && nfit > 1) cat(" Ensembles:", nfit) + if (!is.null(x$fixed_R) && !x$fixed_R) { + cat(" (delta-method)") + }#IF + cat("\n\n") + cat("Use summary() for aggregated inference.\n") + invisible(x) +}#PRINT.LINCOM_REP diff --git a/R/lincom_weights.R b/R/lincom_weights.R new file mode 100644 index 0000000..62f3ad6 --- /dev/null +++ b/R/lincom_weights.R @@ -0,0 +1,238 @@ +#' Difference-in-Differences Aggregation Weights for lincom +#' +#' @description Constructs the contrast matrix \eqn{R} and +#' its influence function matrix \code{inf_func_R} for +#' standard DiD aggregation types. The output is +#' designed to be passed directly to +#' \code{\link{lincom}}. +#' +#' @details Let \eqn{\theta^{(g,t)}_0} denote the GT-ATT +#' from \code{\link{ddml_attgt}}. Each aggregation type +#' defines a summary parameter as a weighted average of +#' GT-ATTs over a subset of post-treatment cells +#' (\eqn{t \geq g}). +#' +#' \strong{Dynamic} (\code{type = "dynamic"}): aggregates +#' by event time \eqn{e = t - g} (Callaway and Sant'Anna, +#' 2021, eq. 9). For each \eqn{e}: +#' +#' \deqn{\tau_0(e) = \sum_{g \in \mathcal{G}} +#' \mathbf{1}\{g + e \leq T\}\, +#' \Pr(G = g \mid G + e \leq T)\, +#' \theta^{(g,\, g+e)}_0.} +#' +#' \strong{Group} (\code{type = "group"}): aggregates by +#' cohort \eqn{g}. For each \eqn{g}: +#' +#' \deqn{\theta(g) = \frac{1}{|\mathcal{T}_g|} +#' \sum_{t \in \mathcal{T}_g} +#' \theta^{(g,t)}_0,} +#' +#' where \eqn{\mathcal{T}_g = \{t : t \geq g\}} and the +#' weights reduce to uniform within each cohort. +#' +#' \strong{Calendar} (\code{type = "calendar"}): aggregates +#' by time period \eqn{t}. For each \eqn{t}: +#' +#' \deqn{\theta(t) = \sum_{g:\, g \leq t} +#' \frac{P(G = g)}{\sum_{g':\, g' \leq t} P(G = g')}\, +#' \theta^{(g,t)}_0.} +#' +#' \strong{Simple} (\code{type = "simple"}): a single +#' weighted average across all post-treatment cells: +#' +#' \deqn{\theta_{ATT} = \sum_{(g,t):\, t \geq g} +#' \frac{P(G = g)}{\sum_{(g',t'):\, t' \geq g'} +#' P(G = g')}\, \theta^{(g,t)}_0.} +#' +#' The influence function for the estimated weights is +#' derived via the quotient rule and passed to +#' \code{\link{lincom}} as \code{inf_func_R}. +#' +#' @param fit A \code{ddml_attgt} or \code{ddml_rep} object +#' whose underlying fits are \code{ddml_attgt}. +#' @param type Aggregation type: \code{"dynamic"} (default), +#' \code{"group"}, \code{"simple"}, or \code{"calendar"}. +#' @param min_e,max_e Event-time range filter (dynamic only). +#' Cells with event time outside \code{[min_e, max_e]} +#' are excluded. +#' @param fit_idx Integer index of the fit (ensemble type) +#' to use for computing the weighting leverage, or +#' \code{NULL} (default) for all ensemble types. +#' When \code{NULL}, \code{dinf_dR} is a 4D array. +#' +#' @return A list with elements: +#' \describe{ +#' \item{\code{R}}{A \eqn{(C \times q)}{C x q} contrast +#' matrix where \eqn{C} is the number of GT cells.} +#' \item{\code{inf_func_R}}{An \eqn{(n \times C \times q)} +#' {n x C x q} array of influence functions for +#' the contrast matrix \eqn{R}. Slice \code{[,,k]} +#' contains the IFs for column \eqn{k} of \eqn{R}.} +#' \item{\code{dinf_dR}}{An \eqn{(n \times q \times q)} +#' {n x q x q} array of weighting leverage. Each +#' slice is the constant matrix \eqn{V'V} where +#' \eqn{V_{g,k} = \sum_{c \in \mathcal{K}_k,\, +#' g_c = g} (\theta_c - \gamma_k) / S_k}. See +#' D89 §5.3.} +#' \item{\code{labels}}{Character vector of length +#' \eqn{q} naming the aggregated quantities.} +#' } +#' +#' @seealso \code{\link{lincom}} +#' +#' @examples +#' \donttest{ +#' set.seed(42) +#' n <- 200; T_ <- 4 +#' X <- matrix(rnorm(n * 2), n, 2) +#' G <- sample(c(3, 4, Inf), n, replace = TRUE, +#' prob = c(0.3, 0.3, 0.4)) +#' y <- matrix(rnorm(n * T_), n, T_) +#' fit <- ddml_attgt(y, X, t = 1:T_, G = G, +#' learners = list(what = ols), +#' sample_folds = 2, +#' silent = TRUE) +#' w <- lincom_weights_did(fit, type = "dynamic") +#' dyn <- lincom(fit, R = w$R, +#' inf_func_R = w$inf_func_R, +#' dinf_dR = w$dinf_dR, +#' labels = w$labels) +#' summary(dyn) +#' } +#' +#' @references +#' Callaway B, Sant'Anna P H C (2021). "Difference-in-Differences +#' with multiple time periods." Journal of Econometrics, +#' 225(2), 200-230. +#' +#' @export +lincom_weights_did <- function(fit, + type = c("dynamic", "group", + "simple", "calendar"), + min_e = -Inf, max_e = Inf, + fit_idx = NULL) { + type <- match.arg(type) + ref <- if (inherits(fit, "ddml_rep")) { + fit[[1]] + } else { + fit + }#IFELSE + if (!inherits(ref, "ddml_attgt")) { + stop("'fit' must be a ddml_attgt or ddml_rep object.", call. = FALSE) + }#IF + + cell_info <- ref$cell_info + group <- cell_info$group + time <- cell_info$time + C <- length(group) + G <- ref$G + n <- ref$nobs + + # Group probabilities + glist <- sort(unique(group)) + pg_by_group <- sapply(glist, function(g) mean(G == g)) + pg <- pg_by_group[match(group, glist)] + + # Post-treatment cells + post <- which(group <= time) + + # Build aggregation groups + agg <- switch(type, + dynamic = { + et <- time - group + all_et <- sort(unique(et)) + all_et <- all_et[all_et >= min_e & all_et <= max_e] + lapply(all_et, function(e) { + list(keepers = which(et == e), label = paste0("e=", e)) + }) + }, + group = { + lapply(glist, function(g) { + list(keepers = which(group == g & seq_len(C) %in% post), + label = paste0("g=", g)) + }) + }, + calendar = { + tlist <- sort(unique(time[post])) + lapply(tlist, function(t1) { + list(keepers = which(time == t1 & seq_len(C) %in% post), + label = paste0("t=", t1)) + }) + }, + simple = list(list(keepers = post, label = "ATT")) + ) + + q <- length(agg) + labels <- vapply(agg, `[[`, character(1), "label") + R <- matrix(0, C, q) + inf_func_R <- array(0, dim = c(n, C, q)) + + for (k in seq_len(q)) { + keepers <- agg[[k]]$keepers + if (length(keepers) == 0L) next # reference period + w_norm <- pg[keepers] / sum(pg[keepers]) + R[keepers, k] <- w_norm + + # Weight IF via quotient rule: + # w_c = pg_c / S, S = sum(pg[keepers]) + # phi_i^{w_c} = (1{G==g_c} - pg_c) / S + # - w_c * sum_{c'}(1{G==g_{c'}} - pg_{c'}) / S + S <- sum(pg[keepers]) + if1 <- sapply(keepers, function(kk) { + (as.numeric(G == group[kk]) - pg[kk]) / S + }) + if2 <- rowSums(if1) %*% t(w_norm) + wif_k <- if1 - if2 + for (j in seq_along(keepers)) { + inf_func_R[, keepers[j], k] <- wif_k[, j] + }#FOR + }#FOR + + # Weighting leverage: dinf_dR = V'V (constant across i) ---- + # V_{g,k} = sum_{c in K_k, gc=g} (theta_c - gamma_k) / S_k + nensb <- ncol(ref$coefficients) + nG <- length(glist) + if (is.null(fit_idx)) { + j_seq <- seq_len(nensb) + } else { + j_seq <- fit_idx + }#IFELSE + + # Helper: compute VtV for a single ensemble column + compute_VtV <- function(jj) { + theta <- ref$coefficients[, jj] + gamma <- as.numeric(crossprod(R, theta)) + V <- matrix(0, nG, q) + for (k in seq_len(q)) { + keepers <- agg[[k]]$keepers + if (length(keepers) == 0L) next + S_k <- sum(pg[keepers]) + for (gg in seq_len(nG)) { + cells_gk <- keepers[group[keepers] == glist[gg]] + if (length(cells_gk) > 0L) { + V[gg, k] <- sum(theta[cells_gk] - gamma[k]) / S_k + }#IF + }#FOR + }#FOR + crossprod(V) + }#COMPUTE_VTV + + if (length(j_seq) == 1L) { + # Single ensemble -> 3D output (backward compatible) + VtV <- compute_VtV(j_seq) + dinf_dR <- array(rep(VtV, each = n), dim = c(n, q, q)) + } else { + # Multi-ensemble -> 4D output + dinf_dR <- array(0, dim = c(n, q, q, length(j_seq))) + for (jj in seq_along(j_seq)) { + VtV <- compute_VtV(j_seq[jj]) + dinf_dR[, , , jj] <- array(rep(VtV, each = n), + dim = c(n, q, q)) + }#FOR + }#IFELSE + + colnames(R) <- labels + list(R = R, inf_func_R = inf_func_R, + dinf_dR = dinf_dR, labels = labels) +}#LINCOM_WEIGHTS_DID diff --git a/R/ml_wrappers.R b/R/ml_wrappers.R index 8259580..df6d328 100644 --- a/R/ml_wrappers.R +++ b/R/ml_wrappers.R @@ -1,6 +1,6 @@ # glmnet ======================================================================= -#' Wrapper for [glmnet::glmnet()]. +#' Wrapper for glmnet::glmnet() #' #' @family ml_wrapper #' @@ -23,11 +23,11 @@ #' @references #' Friedman J, Hastie T, Tibshirani R (2010). "Regularization Paths for #' Generalized Linear Models via Coordinate Descent." Journal of Statistical -#' Software, 33(1), 1–22. +#' Software, 33(1), 1-22. #' #' Simon N, Friedman J, Hastie T, Tibshirani R (2011). "Regularization Paths for #' Cox's Proportional Hazards Model via Coordinate Descent." Journal of -#' Statistical Software, 39(5), 1–13. +#' Statistical Software, 39(5), 1-13. #' #' @examples #' glmnet_fit <- mdl_glmnet(rnorm(100), matrix(rnorm(1000), 100, 10)) @@ -47,10 +47,19 @@ mdl_glmnet <- function(y, X, return(mdl_fit) }#MDL_GLMNET +#' Predict Method for mdl_glmnet Objects +#' +#' @param object A fitted \code{mdl_glmnet} object. +#' @param newdata A (sparse) feature matrix for prediction. +#' @param ... Additional arguments passed to +#' \code{\link[glmnet:predict.glmnet]{predict.glmnet}}. +#' +#' @return A numeric vector of predicted values. +#' #' @exportS3Method predict.mdl_glmnet <- function(object, newdata = NULL, ...){ # Check whether cv.glmnet was run - cv <- "cv.glmnet" %in% class(object) + cv <- inherits(object, "cv.glmnet") class(object) <- class(object)[-1] # Compute predictions if (cv) { @@ -74,7 +83,7 @@ predict.mdl_glmnet <- function(object, newdata = NULL, ...){ # xgboost ====================================================================== -#' Wrapper for [xgboost::xgboost()]. +#' Wrapper for xgboost::xgboost() #' #' @family ml_wrapper #' @@ -96,7 +105,7 @@ predict.mdl_glmnet <- function(object, newdata = NULL, ...){ #' @references #' Chen T, Guestrin C (2011). "Xgboost: A Scalable Tree Boosting System." #' Proceedings of the 22nd ACM SIGKDD International Conference on Knowledge -#' Discovery and Data Mining, 785–794. +#' Discovery and Data Mining, 785-794. #' #' @examples #' xgboost_fit <- mdl_xgboost(rnorm(50), matrix(rnorm(150), 50, 3), @@ -106,14 +115,28 @@ mdl_xgboost <- function(y, X, nrounds = 500, verbosity = 0, ...){ # Compute xgboost - mdl_fit <- xgboost::xgboost(x = X, y = y, - nrounds = nrounds, - verbosity = verbosity, ...) + dots <- list(...) + if (is.null(dots$params$objective) && is.null(dots$objective) && + is.factor(y) && length(levels(y)) == 2) { + dots$objective <- "binary:logistic" + }#IF + mdl_fit <- do.call(xgboost::xgboost, + c(list(x = X, y = y, nrounds = nrounds, + verbosity = verbosity), dots)) # Set custom S3 class class(mdl_fit) <- c("mdl_xgboost", class(mdl_fit)) return(mdl_fit) }#MDL_XGBOOST +#' Predict Method for mdl_xgboost Objects +#' +#' @param object A fitted \code{mdl_xgboost} object. +#' @param newdata A feature matrix for prediction. +#' @param ... Additional arguments passed to +#' \code{\link[xgboost:predict.xgb.Booster]{predict.xgb.Booster}}. +#' +#' @return A numeric vector of predicted values. +#' #' @exportS3Method predict.mdl_xgboost <- function(object, newdata = NULL, ...){ # Predict using xgb.Booster prediction method. @@ -123,7 +146,7 @@ predict.mdl_xgboost <- function(object, newdata = NULL, ...){ # ranger ======================================================================= -#' Wrapper for [ranger::ranger()]. +#' Wrapper for ranger::ranger() #' #' @family ml_wrapper #' @@ -161,29 +184,38 @@ mdl_ranger <- function(y, X, ...){ return(mdl_fit) }#MDL_RANGER +#' Predict Method for mdl_ranger Objects +#' +#' @param object A fitted \code{mdl_ranger} object. +#' @param newdata A feature matrix for prediction. +#' @param ... Additional arguments passed to +#' \code{\link[ranger:predict.ranger]{predict.ranger}}. +#' +#' @return A numeric vector of predicted values (probabilities for +#' probability forests, point predictions for regression forests). +#' #' @exportS3Method predict.mdl_ranger <- function(object, newdata = NULL, ...){ # Assign column names to newdata if none are given if (is.null(colnames(newdata))) { colnames(newdata) <- seq(dim(newdata)[2]) }#IF - class(object) <- class(object)[2] + class(object) <- class(object)[-1] # Predict using randomForest prediction method if (object$treetype == "Probability estimation") { - #stats::predict(object, data = newdata, ...)$predictions[, 2] stats::predict(object, data = newdata, ...)$predictions[, 2] } else if (object$treetype == "Regression") { - #stats::predict(object, data = newdata, ...)$predictions stats::predict(object, data = newdata, ...)$predictions } else { - warning("mdl_ranger is only designed for regression and probability forests") + warning("mdl_ranger is only designed for regression and probability forests", + call. = FALSE) stats::predict(object, data = newdata, ...)$predictions }#IFELSE }#PREDICT.MDL_RANGER # glm ========================================================================== -#' Wrapper for [stats::glm()]. +#' Wrapper for stats::glm() #' #' @family ml_wrapper #' @@ -211,8 +243,60 @@ mdl_glm <- function(y, X, ...) { return(glm_fit) # return fitted glm object }#MDL_GLM +#' Predict Method for mdl_glm Objects +#' +#' @param object A fitted \code{mdl_glm} object. +#' @param newdata A feature matrix for prediction. +#' @param ... Additional arguments passed to +#' \code{\link[stats:predict.glm]{predict.glm}}. +#' +#' @return A numeric vector of predicted response values. +#' #' @exportS3Method predict.mdl_glm <- function(object, newdata, ...) { df <- data.frame(newdata) # transform data from matrices to data.frame stats::predict.glm(object, df, type = "response", ...) }#PREDICT.MDL_GLM + +# bigGlm ======================================================================= + +#' Wrapper for glmnet::bigGlm() +#' +#' @family ml_wrapper +#' +#' @seealso [glmnet::bigGlm()] +#' +#' @description Simple wrapper for [glmnet::bigGlm()], designed for sparse matrices. +#' +#' @param y The outcome variable. +#' @param X The (sparse) feature matrix. +#' @param ... Additional arguments passed to \code{bigGlm}. See +#' [glmnet::bigGlm()] for a complete list of arguments. +#' +#' @return \code{mdl_bigGlm} returns an object of S3 class \code{mdl_bigGlm}. +#' @export +#' +#' @examples +#' bigglm_fit <- mdl_bigGlm(rnorm(100), matrix(rnorm(1000), 100, 10)) +#' class(bigglm_fit) +mdl_bigGlm <- function(y, X, ...) { + mdl_fit <- glmnet::bigGlm(x = X, y = y, ...) + mdl_fit <- list(fitted_coef = stats::coef(mdl_fit)) + class(mdl_fit) <- c("mdl_bigGlm", class(mdl_fit)) + return(mdl_fit) +}#MDL_BIGGLM + +#' Predict Method for mdl_bigGlm Objects +#' +#' @param object A fitted \code{mdl_bigGlm} object. +#' @param newdata A (sparse) feature matrix for prediction. +#' @param ... Currently unused. +#' +#' @return A numeric vector of predicted values. +#' +#' @exportS3Method +predict.mdl_bigGlm <- function(object, newdata = NULL, ...) { + beta <- object$fitted_coef + fitted <- newdata %*% beta[2:nrow(beta), , drop = FALSE] + beta[1, 1] + fitted[, 1] +}#PREDICT.MDL_BIGGLM diff --git a/R/ols.R b/R/ols.R index 5f2a233..c90363f 100644 --- a/R/ols.R +++ b/R/ols.R @@ -1,4 +1,4 @@ -#' Ordinary least squares. +#' Ordinary Least Squares #' #' @family ml_wrapper #' @@ -43,7 +43,7 @@ ols <- function(y, X, }#IFELSE # Return estimate coef <- as.matrix(coef) - try(rownames(coef) <- colnames(X)) # assign coefficient names + if (!is.null(colnames(X))) rownames(coef) <- colnames(X) output <- list(coef = coef, y = y, X = X, const = const, w = w) class(output) <- "ols" # define S3 class @@ -52,6 +52,15 @@ ols <- function(y, X, # Complementary methods ======================================================== +#' Predict Method for ols Objects +#' +#' @param object A fitted \code{ols} object. +#' @param newdata A feature matrix for prediction. If \code{NULL}, +#' returns fitted values from the training data. +#' @param ... Currently unused. +#' +#' @return A numeric vector of predicted values. +#' #' @exportS3Method predict.ols <- function(object, newdata = NULL, ...){ # Obtain datamatrix diff --git a/R/parallel.R b/R/parallel.R new file mode 100644 index 0000000..ad2a15e --- /dev/null +++ b/R/parallel.R @@ -0,0 +1,75 @@ +# Internal helper for parallel cluster setup. +setup_parallel_cluster <- function(num_cores, + parallel_export = NULL, + parallel_packages = NULL) { + cl <- parallel::makeCluster(num_cores, type = "PSOCK") + parallel::clusterEvalQ(cl, library(ddml)) + if (!is.null(parallel_export)) { + parallel::clusterExport(cl, varlist = parallel_export, + envir = globalenv()) + }#IF + if (!is.null(parallel_packages)) { + for (pkg in parallel_packages) { + parallel::clusterCall(cl, library, pkg, + character.only = TRUE) + }#FOR + }#IF + + # Ensure reproducible parallel random number generation (L'Ecuyer-CMRG) + parallel::clusterSetRNGStream(cl) + + cl +}#SETUP_PARALLEL_CLUSTER + +# Internal helper to unpack the parallel list argument. +parse_parallel <- function(parallel) { + if (is.null(parallel)) { + return(list(num_cores = 1, export = NULL, + packages = NULL)) + }#IF + if (!is.list(parallel)) { + stop("'parallel' must be a list or NULL.", + call. = FALSE) + }#IF + list( + num_cores = if (!is.null(parallel$cores)) { + parallel$cores + } else { + 1 + }, + export = parallel$export, + packages = parallel$packages + ) +}#PARSE_PARALLEL + +# Run a function over seq_len(njobs) with optional parallel cluster. +# Encapsulates parsing, cluster lifecycle, fallback, and pbapply. +with_parallel <- function(njobs, fun, parallel, silent) { + p <- parse_parallel(parallel) + cl <- NULL + if (p$num_cores > 1) { + cl <- tryCatch( + setup_parallel_cluster(p$num_cores, p$export, + p$packages), + error = function(e) { + warning("Parallel setup failed: ", + conditionMessage(e), + ". Falling back to sequential.", + call. = FALSE) + NULL + }) + }#IF + on.exit({ + if (!is.null(cl)) parallel::stopCluster(cl) + }, add = TRUE) + if (silent) { + op <- pbapply::pboptions(type = "none") + on.exit(pbapply::pboptions(op), add = TRUE) + }#IF + pbapply::pblapply(seq_len(njobs), fun, cl = cl) +}#WITH_PARALLEL + +# Internal helper for silent-aware messages. +info_msg <- function(..., silent = FALSE) { + if (!silent) message(...) +}#INFO_MSG diff --git a/R/ral.R b/R/ral.R new file mode 100644 index 0000000..41ebaec --- /dev/null +++ b/R/ral.R @@ -0,0 +1,751 @@ +# RAL: Regular Asymptotically Linear =========================================== +# +# Base class for influence-function-based inference. Estimator-agnostic: +# consumes pre-computed influence functions, does not compute them. +# +# Class hierarchy: +# ral — single-fit inference base +# ddml > ral — adds DML-specific fields (scores, J, ensemble weights) +# lincom > ral — linear combination of parameters +# +# See ral_rep.R for the replicated-fit counterpart. + +# Constructor ================================================================== + +#' Construct a RAL Inference Object +#' +#' @description Creates a regular asymptotically linear (RAL) +#' inference object from pre-computed influence functions. +#' This is the base class for all influence-function-based +#' inference in \pkg{ddml}. +#' +#' @details A regular asymptotically linear (RAL) estimator +#' \eqn{\hat\theta} satisfies +#' +#' \deqn{\hat\theta - \theta_0 = \frac{1}{n} \sum_{i=1}^{n} +#' \phi(W_i; \theta_0) + o_p(n^{-1/2}),} +#' +#' where \eqn{\phi(W_i; \theta_0)} is the \emph{influence +#' function}. This package stores the estimated influence +#' function \eqn{\hat\phi_i \equiv \phi(W_i; \hat\theta)} +#' in the \code{inf_func} slot. +#' +#' When an observation-level derivative +#' \eqn{-n^{-1}\,\partial \hat\phi_i / \partial \theta} +#' is available (stored in \code{dinf_dtheta}), the estimator +#' supports HC3 inference via leverage; see +#' \code{\link{hatvalues.ral}}. +#' +#' The RAL framework is estimator-agnostic: it consumes +#' pre-computed influence functions and does not prescribe how +#' they are obtained. For the specific construction under +#' cross-fitting and Neyman-orthogonal scores, see +#' \code{\link{ddml-intro}}. For linear combinations of +#' \code{ddml} estimators, see \code{\link{lincom}}. +#' +#' @param coefficients A \eqn{p \times}{p x} \code{nfit} matrix +#' of estimated coefficients. Rows are parameters, columns +#' are fits (e.g., ensemble types). +#' @param inf_func A 3D array of dimension +#' \eqn{n \times p \times}{n x p x} \code{nfit}. The +#' influence function evaluated at each observation. +#' @param dinf_dtheta Optional 4D array of dimension +#' \eqn{n \times p \times p \times}{n x p x p x} +#' \code{nfit}. The derivative of the influence function +#' with respect to \eqn{\theta}, used for HC3 leverage. +#' If \code{NULL}, HC3 is unavailable. +#' @param nobs Integer number of observations. +#' @param coef_names Character vector of parameter names (length \eqn{p}). +#' @param cluster_variable Optional vector of cluster identifiers (length \eqn{n}). +#' If non-\code{NULL}, cluster-robust inference is used. +#' @param estimator_name Character string for display. +#' @param subclass Optional character string prepended to the class vector. +#' @param ... Additional named elements stored in the object. +#' +#' @return An object of class \code{ral} (or \code{c(subclass, "ral")}). +#' +#' @export +ral <- function(coefficients, + inf_func, + dinf_dtheta = NULL, + nobs, + coef_names, + cluster_variable = NULL, + estimator_name = "RAL estimator", + subclass = NULL, ...) { + # Validate inputs ------------------------------------------------------------ + coefficients <- as.matrix(coefficients) + p <- nrow(coefficients) + nfit <- ncol(coefficients) + + if (!is.numeric(inf_func) || length(dim(inf_func)) != 3) { + stop("'inf_func' must be a 3D numeric array.", call. = FALSE) + }#IF + if (dim(inf_func)[1] != nobs || dim(inf_func)[2] != p || + dim(inf_func)[3] != nfit) { + stop("'inf_func' dimensions must be (nobs x p x nfit).", call. = FALSE) + }#IF + if (!is.null(dinf_dtheta)) { + if (!is.numeric(dinf_dtheta) || length(dim(dinf_dtheta)) != 4) { + stop("'dinf_dtheta' must be a 4D array or NULL.", call. = FALSE) + }#IF + if (dim(dinf_dtheta)[1] != nobs || + dim(dinf_dtheta)[2] != p || + dim(dinf_dtheta)[3] != p || + dim(dinf_dtheta)[4] != nfit) { + stop("'dinf_dtheta' dimensions must be (nobs x p x p x nfit).", + call. = FALSE) + }#IF + }#IF + + # Assemble the object -------------------------------------------------------- + obj <- c(list( + coefficients = coefficients, + inf_func = inf_func, + dinf_dtheta = dinf_dtheta, + nobs = nobs, + nfit = nfit, + coef_names = coef_names, + fit_labels = colnames(coefficients), + cluster_variable = cluster_variable, + estimator_name = estimator_name), list(...)) + + cls <- if (!is.null(subclass)) c(subclass, "ral") else "ral" + class(obj) <- cls + obj +}#RAL + +# Internal helpers ============================================================= + +# Validate fit_idx argument for S3 methods. +# Returns validated type invisibly. +validate_fit_idx <- function(object, fit_idx = NULL, + type = NULL) { + if (!is.null(type)) { + type <- match.arg(type, c("HC0", "HC1", "HC3")) + }#IF + if (!is.null(fit_idx)) { + nfit <- dim(object$inf_func)[3] + if (is.null(nfit)) nfit <- 1L + if (fit_idx < 1 || fit_idx > nfit) { + stop("fit_idx must be between 1 and ", nfit, ".", call. = FALSE) + }#IF + }#IF + invisible(type) +}#VALIDATE_FIT_IDX + +# S3 methods =================================================================== + +#' Extract Coefficients from a RAL Object +#' +#' @param object An object inheriting from class \code{ral}. +#' @param ... Currently unused. +#' +#' @return Named vector (single fit) or matrix (multiple fits). +#' +#' @method coef ral +#' @export +coef.ral <- function(object, ...) { + cf <- object$coefficients + if (is.matrix(cf) && ncol(cf) == 1) { + nm <- rownames(cf) + cf <- as.vector(cf) + names(cf) <- nm + }#IF + cf +}#COEF.RAL + +#' Number of Observations in a RAL Object +#' +#' @param object An object inheriting from class \code{ral}. +#' @param ... Currently unused. +#' +#' @return Integer. +#' +#' @method nobs ral +#' @importFrom stats nobs +#' @export +nobs.ral <- function(object, ...) { + object$nobs +}#NOBS.RAL + +#' Extract leverage (Hat Values) +#' +#' @description Computes the leverage (hat values) +#' for a RAL estimator. Used internally for HC3 standard +#' errors. +#' +#' @details The leverage for observation \eqn{i} +#' is +#' +#' \deqn{h_i(\theta) +#' = \mathrm{tr}\!\left( +#' \frac{1}{n} +#' \frac{\partial \phi_i(\theta)} +#' {\partial \theta} +#' \right).} +#' +#' The sample analog replaces \eqn{\phi_i(\theta)} with its +#' estimate \eqn{\hat\phi_i}: \eqn{\hat{h}_i = h_i(\hat\theta).} +#' +#' The derivative \eqn{\partial \hat\phi_i / \partial \theta} +#' is stored in the \code{dinf_dtheta} slot. For the specific +#' form of this derivative in the DML context, see +#' \code{\link{ddml-intro}}. For the leverage of linear +#' combinations, see \code{\link{lincom}}. +#' +#' @param model An object inheriting from class \code{ral}. +#' @param fit_idx Integer index of the fit to extract leverage +#' values for. Defaults to 1. +#' @param ... Currently unused. +#' +#' @return A numeric vector of leverage values. +#' +#' @importFrom stats hatvalues +#' @method hatvalues ral +#' @export +hatvalues.ral <- function(model, fit_idx = 1, ...) { + validate_fit_idx(model, fit_idx = fit_idx) + if (is.null(model$dinf_dtheta)) { + warning("hatvalues: dinf_dtheta not available; returning NA", + call. = FALSE) + return(rep(NA_real_, nobs(model))) + }#IF + + n <- model$nobs + p <- nrow(model$coefficients) + dinf_j <- model$dinf_dtheta[, , , fit_idx, drop = FALSE] + + h <- rep(0, n) + for (k in seq_len(p)) h <- h + dinf_j[, k, k, 1] + h <- h / n + + as.vector(h) +}#HATVALUES.RAL + +#' Variance-Covariance Matrix for RAL Estimators +#' +#' @description Computes a heteroskedasticity-robust +#' variance-covariance matrix. +#' +#' @details Let \eqn{\hat\phi_i} denote the estimated +#' influence function at observation \eqn{i}. Three +#' variance estimators are available: +#' +#' \strong{HC0}: +#' \deqn{V_{\mathrm{HC0}} = \frac{1}{n^2}\sum_i +#' \hat\phi_i\,\hat\phi_i'} +#' +#' \strong{HC1} (default): +#' \deqn{V_{\mathrm{HC1}} = V_{\mathrm{HC0}} +#' \times \frac{n}{n - p}} +#' +#' \strong{HC3}: +#' \deqn{V_{\mathrm{HC3}} = \frac{1}{n^2}\sum_i +#' \frac{\hat\phi_i\,\hat\phi_i'} +#' {(1 - \hat{h}_{\theta,i})^2}} +#' +#' where \eqn{\hat{h}_{\theta,i}} is the leverage; +#' see \code{\link{hatvalues.ral}}. +#' +#' \strong{Cluster-robust inference.} When +#' \code{cluster_variable} is non-\code{NULL} and identifies +#' fewer groups than observations, the observation-level +#' influence functions are aggregated to cluster-level +#' influence functions +#' +#' \deqn{\hat\Phi_g = \frac{G}{n} \sum_{i \in C_g} \hat\phi_i} +#' +#' and the variance is computed as +#' +#' \deqn{V_{\mathrm{HC0}} = \frac{1}{G^2} \sum_{g=1}^{G} +#' \hat\Phi_g\,\hat\Phi_g'.} +#' +#' @param object An object inheriting from class \code{ral}. +#' @param fit_idx Integer index of the fit. Defaults to 1. +#' @param type Character. One of \code{"HC1"} (default), +#' \code{"HC0"}, or \code{"HC3"}. +#' @param ... Currently unused. +#' +#' @return A \eqn{p \times p}{p x p} variance-covariance +#' matrix. +#' +#' @seealso \code{\link{hatvalues.ral}}, +#' \code{\link{confint.ral}} +#' +#' @method vcov ral +#' @importFrom stats vcov +#' @export +vcov.ral <- function(object, fit_idx = 1, + type = "HC1", ...) { + type <- validate_fit_idx(object, fit_idx = fit_idx, + type = type) + + if_j <- object$inf_func[, , fit_idx, drop = FALSE] + dim(if_j) <- dim(if_j)[1:2] + p <- ncol(if_j) + n <- nrow(if_j) + + # Cluster aggregation: rescale to cluster-level influence functions + clustered <- !is.null(object$cluster_variable) && + length(unique(object$cluster_variable)) < n + if (clustered) { + if_j <- rowsum(if_j, object$cluster_variable) + if_j <- if_j * (nrow(if_j) / n) + } + n_eff <- nrow(if_j) + + if (type == "HC3") { + h <- stats::hatvalues(object, fit_idx = fit_idx) + if (clustered) h <- as.vector(tapply(h, object$cluster_variable, sum)) + if_j <- if_j / (1 - h) + }#IF + + V <- crossprod(if_j) / n_eff^2 + + # HC1 degrees-of-freedom correction + if (type == "HC1") V <- V * n_eff / (n_eff - p) + + rownames(V) <- colnames(V) <- object$coef_names + V +}#VCOV.RAL + +#' Confidence Intervals for RAL Estimators +#' +#' @description Computes confidence intervals for one or more +#' parameters. +#' +#' @param object An object inheriting from class \code{ral}. +#' @param parm A specification of which parameters are to be +#' given confidence intervals, either a vector of numbers +#' or a vector of names. If missing, all parameters are +#' considered. +#' @param level Confidence level. Default 0.95. +#' @param fit_idx Integer index of the fit. Defaults to 1. +#' @param type Character. HC type. Default \code{"HC1"}. +#' @param uniform Logical. If \code{TRUE}, computes uniform +#' confidence bands using the multiplier bootstrap. +#' Default \code{FALSE}. +#' @param bootstraps Integer number of bootstrap draws. +#' Only used when \code{uniform = TRUE}. Default 999. +#' @param ... Currently unused. +#' +#' @return A matrix with columns for lower and upper bounds. +#' When \code{uniform = TRUE}, the attribute +#' \code{"crit_val"} contains the critical value. +#' +#' @references +#' Chernozhukov V, Chetverikov D, Kato K (2013). "Gaussian +#' approximations and multiplier bootstrap for maxima of sums +#' of high-dimensional random vectors." Annals of Statistics, +#' 41(6), 2786-2819. +#' +#' @seealso \code{\link{vcov.ral}} +#' +#' @method confint ral +#' @export +confint.ral <- function(object, parm = NULL, level = 0.95, + fit_idx = 1, + type = "HC1", + uniform = FALSE, + bootstraps = 999L, ...) { + validate_fit_idx(object, fit_idx = fit_idx) + cf <- object$coefficients[, fit_idx] + cf_names <- object$coef_names + names(cf) <- cf_names + + if (is.null(parm)) { + parm <- cf_names + } else if (is.numeric(parm)) { + parm <- cf_names[parm] + } else { + parm <- intersect(parm, cf_names) + if (length(parm) == 0) { + stop("None of the specified 'parm' were found in ", + "the model coefficients.", call. = FALSE) + }#IF + }#IFELSE + + cf <- cf[parm] + + V <- vcov(object, fit_idx = fit_idx, type = type) + se_all <- sqrt(diag(V)) + se <- se_all[parm] + + if (uniform) { + # Multiplier bootstrap + inf_func <- object$inf_func[, , fit_idx, drop = FALSE] + dim(inf_func) <- dim(inf_func)[1:2] + cl <- object$cluster_variable + n <- nrow(inf_func) + if (!is.null(cl) && length(unique(cl)) < n) { + inf_func <- rowsum(inf_func, cl) + inf_func <- inf_func * (nrow(inf_func) / n) + }#IF + n_eff <- nrow(inf_func) + parm_idx <- match(parm, cf_names) + xi <- matrix(stats::rnorm(bootstraps * n_eff), bootstraps, n_eff) + bres <- xi %*% inf_func[, parm_idx, drop = FALSE] / sqrt(n_eff) + sigma <- se_all[parm_idx] * sqrt(n_eff) + # Exclude degenerate components (sigma=0, e.g., reference period) + active <- which(sigma > 0) + if (length(active) == 0) { + bT <- rep(0, bootstraps) + } else { + bT <- apply(bres[, active, drop = FALSE], 1, + function(b) max(abs(b / sigma[active]))) + }#IFELSE + z <- as.numeric(stats::quantile(bT, level, type = 1, names = FALSE)) + } else { + z <- stats::qnorm((1 + level) / 2) + }#IFELSE + ci <- cbind(cf - z * se, cf + z * se) + pct <- c((1 - level) / 2, (1 + level) / 2) * 100 + colnames(ci) <- paste0(format(pct, digits = 3), " %") + rownames(ci) <- parm + attr(ci, "crit_val") <- z + ci +}#CONFINT.RAL + +#' Summary for RAL Estimators +#' +#' @description Computes a coefficient table with estimates, +#' standard errors, z-values, and p-values. +#' +#' @param object An object inheriting from class \code{ral}. +#' @param type Character. HC type. Default \code{"HC1"}. +#' @param ... Currently unused. +#' +#' @return An object of class \code{summary.ral} with: +#' \describe{ +#' \item{\code{coefficients}}{A 3-dimensional array +#' (\eqn{p \times 4 \times}{p x 4 x} nfit).} +#' \item{\code{type}}{The HC type used.} +#' \item{\code{nobs}}{Number of observations.} +#' } +#' +#' @method summary ral +#' @export +summary.ral <- function(object, type = "HC1", ...) { + type <- match.arg(type, c("HC0", "HC1", "HC3")) + + fit_labels <- object$fit_labels + if (is.null(fit_labels)) { + fit_labels <- paste0("fit", seq_len(object$nfit)) + }#IF + + nfit <- length(fit_labels) + p <- nrow(object$coefficients) + inf <- array(0, dim = c(p, 4, nfit)) + for (j in seq_len(nfit)) { + theta_j <- object$coefficients[, j] + + V <- stats::vcov(object, fit_idx = j, type = type) + se <- sqrt(diag(V)) + z_val <- theta_j / se + p_val <- 2 * stats::pnorm(abs(z_val), lower.tail = FALSE) + + inf[, 1, j] <- theta_j + inf[, 2, j] <- se + inf[, 3, j] <- z_val + inf[, 4, j] <- p_val + }#FOR + + dimnames(inf) <- list( + object$coef_names, + c("Estimate", "Std. Error", "z value", "Pr(>|z|)"), + fit_labels + ) + + result <- list( + coefficients = inf, + type = type, + estimator_name = object$estimator_name, + nobs = object$nobs, + fit_labels = fit_labels) + class(result) <- "summary.ral" + result +}#SUMMARY.RAL + +#' @rdname summary.ral +#' +#' @param x An object of class \code{summary.ral}. +#' @param digits Number of significant digits. Default 3. +#' +#' @method print summary.ral +#' @export +print.summary.ral <- function(x, digits = 3, ...) { + name <- x$estimator_name + if (is.null(name)) name <- "RAL estimator" + + cat("RAL estimation:", name, "\n") + cat("Obs:", x$nobs) + if (!is.null(x$type) && x$type != "HC1") cat(" SE:", x$type) + cat("\n\n") + + print_coef_tables(x$coefficients, fit_label = "Fit", digits = digits) + + invisible(x) +}#PRINT.SUMMARY.RAL + +#' Tidy a RAL Object +#' +#' Extracts coefficient estimates, standard errors, test +#' statistics, and p-values in a tidy data frame. +#' +#' @param x An object inheriting from class \code{ral}. +#' @param fit_idx Integer index of the fit to report. +#' Defaults to 1. Set to \code{NULL} for all fits. +#' @param conf.int Logical. Include confidence intervals? +#' Default \code{FALSE}. +#' @param conf.level Confidence level. Default 0.95. +#' @param type Character. HC type. Default \code{"HC1"}. +#' @param uniform Logical. Uniform confidence bands? +#' Default \code{FALSE}. +#' @param bootstraps Integer. Bootstrap draws. Default 999. +#' @param ... Currently unused. +#' +#' @return A \code{data.frame} with columns \code{term}, +#' \code{estimate}, \code{std.error}, \code{statistic}, +#' \code{p.value}, and \code{fit_label}. +#' +#' @references +#' Chernozhukov V, Chetverikov D, Kato K (2013). "Gaussian +#' approximations and multiplier bootstrap for maxima of sums +#' of high-dimensional random vectors." Annals of Statistics, +#' 41(6), 2786-2819. +#' +#' @export +#' @method tidy ral +tidy.ral <- function(x, fit_idx = 1, conf.int = FALSE, + conf.level = 0.95, + type = "HC1", + uniform = FALSE, + bootstraps = 999L, ...) { + type <- match.arg(type, c("HC1", "HC0", "HC3")) + + s <- summary(x, type = type) + inf <- s$coefficients + nfit <- dim(inf)[3] + p <- dim(inf)[1] + + if (is.null(fit_idx)) { + j_seq <- seq_len(nfit) + } else { + if (any(fit_idx < 1) || any(fit_idx > nfit)) { + stop(sprintf("fit_idx must be between 1 and %d", nfit), call. = FALSE) + }#IF + j_seq <- fit_idx + }#IFELSE + + # Build tidy output + n_rows <- length(j_seq) * p + term <- rep(dimnames(inf)[[1]], length(j_seq)) + fit_label <- rep(dimnames(inf)[[3]][j_seq], each = p) + estimate <- std.error <- statistic <- p.value <- numeric(n_rows) + idx <- 1 + for (j in j_seq) { + for (k in seq_len(p)) { + estimate[idx] <- inf[k, 1, j] + std.error[idx] <- inf[k, 2, j] + statistic[idx] <- inf[k, 3, j] + p.value[idx] <- inf[k, 4, j] + idx <- idx + 1 + }#FOR + }#FOR + + res <- data.frame( + term = term, + estimate = estimate, + std.error = std.error, + statistic = statistic, + p.value = p.value, + fit_label = fit_label, + stringsAsFactors = FALSE + ) + + if (conf.int) { + ci_list <- lapply(j_seq, function(j) { + stats::confint(x, fit_idx = j, level = conf.level, + type = type, uniform = uniform, + bootstraps = bootstraps) + }) + ci_mat <- do.call(rbind, ci_list) + res$conf.low <- as.numeric(ci_mat[, 1]) + res$conf.high <- as.numeric(ci_mat[, 2]) + }#IF + + res +}#TIDY.RAL + +#' Glance at a RAL Object +#' +#' Returns a one-row summary of model-level statistics. +#' +#' @param x An object inheriting from class \code{ral}. +#' @param ... Currently unused. +#' +#' @return A one-row \code{data.frame} with columns +#' \code{nobs} and \code{estimator_name}. +#' +#' @export +#' @method glance ral +glance.ral <- function(x, ...) { + data.frame( + nobs = x$nobs, + estimator_name = if (is.null(x$estimator_name)) { + class(x)[1] + } else { + x$estimator_name + }, + stringsAsFactors = FALSE + ) +}#GLANCE.RAL + +# Plot methods ================================================================ + +#' Plot Coefficients from a RAL Estimator +#' +#' @description Plots point estimates with confidence intervals +#' from an object inheriting from class \code{ral}. +#' +#' @param x An object inheriting from class \code{ral}. +#' @param parm A specification of which parameters to plot. +#' Either a vector of names or indices. Default: all. +#' @param level Numeric. Confidence level. Default \code{0.95}. +#' @param uniform Logical. If \code{TRUE}, uses uniform +#' confidence bands via the multiplier bootstrap. Default +#' \code{TRUE}. +#' @param fit_idx Integer. Which fit to plot (column index of +#' \code{coefficients}). Default \code{1}. +#' @param type Character. HC type for standard errors. +#' Default \code{"HC1"}. +#' @param xlab Character. Label for the x-axis. +#' @param ylab Character. Label for the y-axis. +#' @param main Character. Title for the plot. +#' @param col Color for points and segments. +#' Default \code{"black"}. +#' @param pch Point character. Default \code{19} (solid dot). +#' @param lwd Line width for confidence interval segments. +#' Default \code{1.5}. +#' @param ... Additional arguments passed to +#' \code{\link[graphics]{plot.default}}. +#' +#' @return Invisibly returns a list with components +#' \code{coefficients}, \code{ci}, and \code{labels}. +#' +#' @examples +#' # Simulate a simple example +#' n <- 200 +#' X <- cbind(1, stats::rnorm(n)) +#' theta <- c(0.5, -0.3) +#' inf <- matrix(stats::rnorm(n * 2), n, 2) +#' obj <- ral(matrix(theta, 2, 1), +#' array(inf, c(n, 2, 1)), +#' nobs = n, +#' coef_names = c("b1", "b2")) +#' plot(obj) +#' +#' @seealso \code{\link{confint.ral}}, \code{\link{summary.ral}} +#' +#' @importFrom graphics plot +#' @method plot ral +#' @export +plot.ral <- function(x, parm = NULL, level = 0.95, + uniform = TRUE, + fit_idx = 1, + type = "HC1", + xlab = NULL, ylab = NULL, + main = NULL, + col = "black", pch = 19, lwd = 1.5, + ...) { + # Get coefficients and confidence intervals + ci <- confint(x, parm = parm, level = level, fit_idx = fit_idx, + type = type, uniform = uniform) + cf <- x$coefficients[, fit_idx] + labels <- rownames(ci) + cf <- cf[labels] + + # Set up plot coordinates + p <- length(cf) + idx <- seq_len(p) + + # Default labels + if (is.null(xlab)) xlab <- "" + if (is.null(ylab)) ylab <- "Estimate" + if (is.null(main)) { + ci_type <- if (uniform) "uniform" else "pointwise" + main <- paste0(format(level * 100, digits = 3), "% ", ci_type, " CI") + }#IF + + # Plot + ylim <- range(ci) + graphics::plot.default( + idx, cf, type = "n", + xlim = c(0.5, p + 0.5), ylim = ylim, + xaxt = "n", xlab = xlab, ylab = ylab, + main = main, ...) + graphics::abline(h = 0, lty = 2, col = "grey50") + graphics::segments(idx, ci[, 1], idx, ci[, 2], col = col, lwd = lwd) + graphics::points(idx, cf, pch = pch, col = col) + graphics::axis(1, at = idx, labels = labels, las = 2) + + invisible(list(coefficients = cf, ci = ci, labels = labels)) +}#PLOT.RAL + +# List conversion ============================================================= + +#' Split a RAL Object by Fit +#' +#' Returns a named list of single-fit \code{ral} objects, +#' one per column of \code{coefficients}. This is the +#' primary mechanism for passing multi-ensemble results +#' to \pkg{modelsummary}. +#' +#' @param x An object inheriting from class \code{ral}. +#' @param ... Currently unused. +#' +#' @return A named list of \code{ral} objects, each with +#' \code{nfit = 1}. +#' +#' @seealso \code{\link{ral}}, \code{\link{lincom}} +#' +#' @method as.list ral +#' @export +as.list.ral <- function(x, ...) { + nfit <- ncol(x$coefficients) + labels <- x$fit_labels + if (is.null(labels)) labels <- paste0("fit", seq_len(nfit)) + + # Known ral fields to slice or skip + slice_fields <- c("coefficients", "inf_func", "dinf_dtheta") + skip_fields <- c("nfit", "fit_labels") + + out <- vector("list", nfit) + names(out) <- labels + for (j in seq_len(nfit)) { + dinf_j <- if (!is.null(x$dinf_dtheta)) { + x$dinf_dtheta[, , , j, drop = FALSE] + }#IF + obj <- ral( + coefficients = x$coefficients[, j, drop = FALSE], + inf_func = x$inf_func[, , j, drop = FALSE], + dinf_dtheta = dinf_j, + nobs = x$nobs, + coef_names = x$coef_names, + cluster_variable = x$cluster_variable, + estimator_name = x$estimator_name, + subclass = setdiff(class(x), "ral")[1]) + # Carry through extra fields + extras <- setdiff(names(x), + c(slice_fields, skip_fields, + "nobs", "coef_names", + "cluster_variable", + "estimator_name")) + for (nm in extras) { + if (is.null(obj[[nm]])) obj[[nm]] <- x[[nm]] + }#FOR + out[[j]] <- obj + }#FOR + out +}#AS.LIST.RAL diff --git a/R/ral_rep.R b/R/ral_rep.R new file mode 100644 index 0000000..1270db3 --- /dev/null +++ b/R/ral_rep.R @@ -0,0 +1,615 @@ +# RAL_REP: Replicated RAL Inference ============================================ +# +# Base class for multi-resample inference. Wraps a list of ral objects +# and aggregates coefficients/covariance via inflate-then-median (or +# mean, spectral). Estimator-agnostic. +# +# Class hierarchy: +# ral_rep — replicated inference base +# ddml_rep > ral_rep — adds DML-specific display +# lincom_rep > ral_rep — adds lincom-specific display + +# Internal helpers ============================================================= + +# Spectral-norm median of PSD matrices via SDP (CVXR). +# +# Finds V* = argmin_{V >= 0} sum_r ||V - V_r||_op where +# ||.||_op is the spectral norm (largest singular value). +# For p = 1 this reduces to the standard scalar median. +spectral_median_psd <- function(matrices) { + p <- nrow(matrices[[1]]) + R <- length(matrices) + + if (p == 1) { + vals <- vapply(matrices, function(m) m[1, 1], numeric(1)) + return(matrix(stats::median(vals), 1, 1)) + }#IF + + if (!requireNamespace("CVXR", quietly = TRUE)) { + stop("Package 'CVXR' is required for spectral ", + "aggregation. Install it with:\n", + " install.packages('CVXR')", call. = FALSE) + }#IF + + V <- CVXR::Variable(c(p, p), PSD = TRUE) + obj <- 0 + for (r in seq_len(R)) obj <- obj + CVXR::norm(V - matrices[[r]], "2") + + prob <- CVXR::Problem(CVXR::Minimize(obj)) + result <- CVXR::psolve(prob) + + # CVXR 1.8.x (S7): psolve may return a plain numeric (optimal value) + # CVXR < 1.8 (S4): psolve returns an object with $status and $getValue + if (is.atomic(result)) { + # S7: variable value populated after solve + V_sol <- tryCatch(CVXR::value(V), error = function(e) V@value) + } else { + status <- if (is.list(result)) result$status else result@status + if (!identical(status, "optimal")) { + stop("SDP solver returned status '", status, "'.", call. = FALSE) + }#IF + V_sol <- if (is.list(result)) result$getValue(V) else result@getValue(V) + }#IFELSE + (V_sol + t(V_sol)) / 2 +}#SPECTRAL_MEDIAN_PSD + +# Core aggregation workhorse. +# +# For each replication r the inflated covariance is +# V_r = Sigma_r + (theta_r - theta_tilde)(theta_r - theta_tilde)' +# where theta_tilde is the aggregated coefficient vector. +# The three aggregation rules differ only in how they +# summarise {V_1, ..., V_R} into a single matrix. +aggregate_reps <- function(object, aggregation = "median", type = "HC1") { + aggregation <- match.arg(aggregation, c("median", "mean", "spectral")) + R <- object$nresamples + nfit <- object$nfit + p <- length(object$coef_names) + + # Collect per-replication estimates + coef_array <- array(0, dim = c(p, nfit, R)) + vcov_array <- array(0, dim = c(p, p, nfit, R)) + for (r in seq_len(R)) { + fit <- object$fits[[r]] + coef_array[, , r] <- fit$coefficients + for (j in seq_len(nfit)) { + vcov_array[, , j, r] <- stats::vcov(fit, fit_idx = j, type = type) + }#FOR + }#FOR + + # Aggregate coefficients + if (aggregation == "mean") { + agg_coef <- apply(coef_array, c(1, 2), mean) + } else { + agg_coef <- apply(coef_array, c(1, 2), stats::median) + }#IFELSE + + # Inflate & aggregate covariance + agg_vcov <- array(0, dim = c(p, p, nfit)) + for (j in seq_len(nfit)) { + V_list <- vector("list", R) + for (r in seq_len(R)) { + bdiff <- coef_array[, j, r] - agg_coef[, j] + Sigma_r <- matrix(vcov_array[, , j, r], p, p) + V_list[[r]] <- Sigma_r + tcrossprod(bdiff) + }#FOR + + if (aggregation == "mean") { + V_sum <- Reduce(`+`, V_list) + agg_vcov[, , j] <- V_sum / R + } else if (aggregation == "spectral") { + agg_vcov[, , j] <- spectral_median_psd(V_list) + } else { + V_arr <- array(unlist(lapply(V_list, as.vector)), dim = c(p, p, R)) + agg_vcov[, , j] <- apply(V_arr, c(1, 2), stats::median) + }#IFELSE + }#FOR + + # Standard errors + agg_se <- matrix(0, nrow = p, ncol = nfit) + for (j in seq_len(nfit)) { + V_j <- matrix(agg_vcov[, , j, drop = FALSE], nrow = p, ncol = p) + agg_se[, j] <- sqrt(diag(V_j)) + }#FOR + + list(coefficients = agg_coef, se = agg_se, + vcov = agg_vcov, coef_array = coef_array, + vcov_array = vcov_array) +}#AGGREGATE_REPS + +# Constructor ================================================================== + +#' Construct a Replicated RAL Inference Object +#' +#' @description Creates a replicated RAL inference object +#' from a list of \code{ral} objects. Provides +#' cross-resample aggregation for coefficients and +#' covariance matrices. +#' +#' @param fits A list of at least 2 objects inheriting from +#' class \code{"ral"}. All fits must share the same +#' coefficient names and number of observations. +#' @param subclass Optional character string prepended to +#' the class vector. +#' @param ... Additional named elements stored in the object. +#' +#' @return An object of class \code{"ral_rep"} (or +#' \code{c(subclass, "ral_rep")}). +#' +#' @export +ral_rep <- function(fits, subclass = NULL, ...) { + # Input validation + if (!is.list(fits) || length(fits) < 2) { + stop("'fits' must be a list of at least 2 ral objects.", call. = FALSE) + }#IF + for (i in seq_along(fits)) { + if (!inherits(fits[[i]], "ral")) { + stop("Element ", i, " does not inherit from class 'ral'.", call. = FALSE) + }#IF + }#FOR + + ref <- fits[[1]] + for (i in seq_along(fits)[-1]) { + if (!identical(fits[[i]]$coef_names, ref$coef_names)) { + stop("Fit ", i, " has different 'coef_names' than fit 1.", call. = FALSE) + }#IF + if (!identical(fits[[i]]$nobs, ref$nobs)) { + stop("Fit ", i, " has different 'nobs' than fit 1.", call. = FALSE) + }#IF + }#FOR + + obj <- c(list( + fits = fits, + nresamples = length(fits), + nfit = ref$nfit, + coef_names = ref$coef_names, + fit_labels = ref$fit_labels, + estimator_name = ref$estimator_name, + nobs = ref$nobs), list(...)) + + cls <- if (!is.null(subclass)) { + c(subclass, "ral_rep") + } else { + "ral_rep" + }#IFELSE + class(obj) <- cls + obj +}#RAL_REP + +# S3 methods =================================================================== + +#' @method [[ ral_rep +#' @export +`[[.ral_rep` <- function(x, i) x$fits[[i]] + +#' @method length ral_rep +#' @export +length.ral_rep <- function(x) x$nresamples + +#' @method nobs ral_rep +#' @importFrom stats nobs +#' @export +nobs.ral_rep <- function(object, ...) object$nobs + +#' @method print ral_rep +#' @export +print.ral_rep <- function(x, ...) { + cat("RAL replicated fits:", x$estimator_name, "\n") + cat(" Resamples:", x$nresamples, " Obs:", x$nobs, "\n\n") + cat("Use summary() for aggregated inference.\n") + cat("Use x[[i]] to access individual fits.\n") + invisible(x) +}#PRINT.RAL_REP + +#' Extract Aggregated Coefficients +#' +#' @param object An object inheriting from class +#' \code{ral_rep}. +#' @param aggregation Character string: \code{"median"} +#' (default), \code{"mean"}, or \code{"spectral"}. +#' @param ... Currently unused. +#' +#' @return Named vector (single fit) or matrix (multiple). +#' +#' @method coef ral_rep +#' @export +coef.ral_rep <- function(object, + aggregation = c("median", "mean", + "spectral"), + ...) { + aggregation <- match.arg(aggregation) + agg <- aggregate_reps(object, aggregation = aggregation) + cf <- agg$coefficients + rownames(cf) <- object$coef_names + colnames(cf) <- object$fit_labels + if (ncol(cf) == 1) cf <- drop(cf) + cf +}#COEF.RAL_REP + +#' Variance-Covariance Matrix for RAL Rep Objects +#' +#' @param object An object inheriting from class +#' \code{ral_rep}. +#' @param fit_idx Integer index of the fit. Defaults to 1. +#' @param aggregation Character string. Aggregation rule. +#' @param type Character. HC type. Default \code{"HC1"}. +#' @param ... Currently unused. +#' +#' @return A \eqn{p \times p}{p x p} variance-covariance +#' matrix. +#' +#' @method vcov ral_rep +#' @importFrom stats vcov +#' @export +vcov.ral_rep <- function(object, fit_idx = 1, + aggregation = c("median", "mean", "spectral"), + type = "HC1", ...) { + type <- match.arg(type, c("HC0", "HC1", "HC3")) + aggregation <- match.arg(aggregation) + agg <- aggregate_reps(object, aggregation = aggregation, type = type) + V <- agg$vcov[, , fit_idx] + p <- length(object$coef_names) + if (!is.matrix(V)) V <- matrix(V, nrow = p, ncol = p) + rownames(V) <- colnames(V) <- object$coef_names + V +}#VCOV.RAL_REP + +#' Confidence Intervals for RAL Rep Objects +#' +#' @param object An object inheriting from class +#' \code{ral_rep}. +#' @param parm Parameter specification (names or indices). +#' @param level Confidence level. Default 0.95. +#' @param fit_idx Integer index of the fit. Defaults to 1. +#' @param aggregation Character string. Aggregation rule. +#' @param type Character. HC type. Default \code{"HC1"}. +#' @param uniform Logical. Uniform bands via multiplier +#' bootstrap? Default \code{FALSE}. +#' @param bootstraps Integer. Bootstrap draws. Default 999. +#' @param ... Currently unused. +#' +#' @return A matrix with columns for lower and upper bounds. +#' When \code{uniform = TRUE}, the attribute +#' \code{"crit_val"} contains the aggregated critical +#' value. +#' +#' @references +#' Chernozhukov V, Chetverikov D, Kato K (2013). "Gaussian +#' approximations and multiplier bootstrap for maxima of sums +#' of high-dimensional random vectors." Annals of Statistics, +#' 41(6), 2786-2819. +#' +#' @importFrom stats confint coef +#' @method confint ral_rep +#' @export +confint.ral_rep <- function(object, parm = NULL, + level = 0.95, + fit_idx = 1, + aggregation = c("median", "mean", + "spectral"), + type = "HC1", + uniform = FALSE, + bootstraps = 999L, ...) { + aggregation <- match.arg(aggregation) + agg <- aggregate_reps(object, aggregation = aggregation, type = type) + cf <- agg$coefficients[, fit_idx] + se <- agg$se[, fit_idx] + cf_names <- object$coef_names + names(cf) <- cf_names + names(se) <- cf_names + + # Select parameters + if (is.null(parm)) { + parm <- cf_names + } else if (is.numeric(parm)) { + parm <- cf_names[parm] + } else { + parm <- intersect(parm, cf_names) + if (length(parm) == 0) { + stop("None of the specified 'parm' were found ", + "in the model coefficients.", call. = FALSE) + }#IF + }#IFELSE + cf <- cf[parm] + se <- se[parm] + + # Construct confidence intervals + if (uniform) { + R <- object$nresamples + crit_vals <- vapply(seq_len(R), function(r) { + ci_r <- confint(object$fits[[r]], + level = level, + fit_idx = fit_idx, + type = type, + uniform = TRUE, + bootstraps = bootstraps) + attr(ci_r, "crit_val") + }, numeric(1)) + agg_fn <- if (aggregation == "mean") mean else stats::median + z <- agg_fn(crit_vals) + } else { + z <- stats::qnorm((1 + level) / 2) + }#IFELSE + ci <- cbind(cf - z * se, cf + z * se) + pct <- c((1 - level) / 2, (1 + level) / 2) * 100 + colnames(ci) <- paste0(format(pct, digits = 3), " %") + rownames(ci) <- parm + attr(ci, "crit_val") <- z + ci +}#CONFINT.RAL_REP + +#' Summary for RAL Rep Objects +#' +#' Aggregates coefficient estimates and covariance matrices +#' across independent replications. +#' +#' @details +#' Let \eqn{\hat\theta_s} and \eqn{\hat\Sigma_s} denote +#' the coefficient vector and sandwich covariance matrix +#' from replication \eqn{s}. +#' +#' \strong{Coefficient aggregation.} +#' For \code{"mean"}: +#' \eqn{\tilde\theta = S^{-1} \sum_{s=1}^{S} \hat\theta_s}. +#' For \code{"median"} and \code{"spectral"}: +#' \eqn{\tilde\theta_j = \mathrm{median}_{s}(\hat\theta_{s,j})}. +#' +#' \strong{Covariance aggregation.} +#' Define the inflated per-replication covariance as +#' \deqn{V_s = \hat\Sigma_s + (\hat\theta_s - \tilde\theta) +#' (\hat\theta_s - \tilde\theta)^\top.} +#' For \code{"mean"}: +#' \eqn{\tilde\Sigma = S^{-1} \sum_{s=1}^{S} V_s}. +#' For \code{"median"}: +#' \eqn{\tilde\Sigma_{s,ij} = \mathrm{median}_{s}(V_{s,ij})}. +#' For \code{"spectral"}: +#' solved via \pkg{CVXR}, guaranteeing PSD. +#' +#' @references +#' Chernozhukov V, Chetverikov D, Demirer M, Duflo E, +#' Hansen C B, Newey W, Robins J (2018). +#' "Double/debiased machine learning for treatment +#' and structural parameters." The Econometrics +#' Journal, 21(1), C1-C68. +#' +#' @param object An object inheriting from class +#' \code{ral_rep}. +#' @param aggregation Character string. Aggregation rule. +#' @param type Character. HC type. Default \code{"HC1"}. +#' @param ... Currently unused. +#' +#' @return An object of class \code{"summary.ral_rep"}. +#' +#' @method summary ral_rep +#' @export +summary.ral_rep <- function(object, + aggregation = c("median", "mean", "spectral"), + type = "HC1", ...) { + aggregation <- match.arg(aggregation) + type <- match.arg(type, c("HC0", "HC1", "HC3")) + agg <- aggregate_reps(object, aggregation = aggregation, type = type) + + p <- length(object$coef_names) + nfit <- object$nfit + fit_labels <- object$fit_labels + if (is.null(fit_labels)) fit_labels <- paste0("fit", seq_len(nfit)) + + inf_results <- array(0, dim = c(p, 4, nfit)) + for (j in seq_len(nfit)) { + theta_j <- agg$coefficients[, j] + se_j <- agg$se[, j] + t_val <- theta_j / se_j + p_val <- 2 * stats::pnorm(abs(t_val), lower.tail = FALSE) + inf_results[, 1, j] <- theta_j + inf_results[, 2, j] <- se_j + inf_results[, 3, j] <- t_val + inf_results[, 4, j] <- p_val + }#FOR + dimnames(inf_results) <- list( + object$coef_names, + c("Estimate", "Std. Error", "z value", "Pr(>|z|)"), + fit_labels) + + result <- list( + coefficients = inf_results, + type = type, + estimator_name = object$estimator_name, + nobs = object$nobs, + fit_labels = fit_labels, + nresamples = object$nresamples, + aggregation = aggregation) + class(result) <- "summary.ral_rep" + result +}#SUMMARY.RAL_REP + +#' @rdname summary.ral_rep +#' +#' @param x An object of class \code{summary.ral_rep}. +#' @param digits Number of significant digits. Default 3. +#' +#' @method print summary.ral_rep +#' @export +print.summary.ral_rep <- function(x, digits = 3, ...) { + cat("RAL estimation:", x$estimator_name, "\n") + cat("Obs:", x$nobs, + " Resamples:", x$nresamples, + " Aggregation:", x$aggregation) + if (!is.null(x$type) && x$type != "HC1") cat(" SE:", x$type) + cat("\n\n") + + print_coef_tables(x$coefficients, fit_label = "Fit", digits = digits) + + invisible(x) +}#PRINT.SUMMARY.RAL_REP + +#' Tidy a RAL Rep Object +#' +#' @param x An object inheriting from class \code{ral_rep}. +#' @param fit_idx Integer index of the fit. Defaults to 1. +#' Set to \code{NULL} for all fits. +#' @param aggregation Character string. Aggregation rule. +#' @param type Character. HC type. Default \code{"HC1"}. +#' @param conf.int Logical. Include CIs? Default +#' \code{FALSE}. +#' @param conf.level Confidence level. Default 0.95. +#' @param uniform Logical. Uniform CIs? Default +#' \code{FALSE}. +#' @param bootstraps Integer. Bootstrap draws. Default 999. +#' @param ... Currently unused. +#' +#' @return A \code{data.frame} with columns \code{term}, +#' \code{estimate}, \code{std.error}, \code{statistic}, +#' \code{p.value}, \code{fit_label}, and +#' \code{aggregation}. +#' +#' @method tidy ral_rep +#' @export +tidy.ral_rep <- function(x, fit_idx = 1, + aggregation = c("median", "mean", "spectral"), + type = "HC1", + conf.int = FALSE, + conf.level = 0.95, + uniform = FALSE, + bootstraps = 999L, ...) { + aggregation <- match.arg(aggregation) + s <- summary(x, aggregation = aggregation, type = type) + inf <- s$coefficients + nfit <- dim(inf)[3] + p <- dim(inf)[1] + + if (is.null(fit_idx)) { + j_seq <- seq_len(nfit) + } else { + j_seq <- fit_idx + }#IFELSE + + rows <- list() + for (j in j_seq) { + for (k in seq_len(p)) { + row <- data.frame( + term = dimnames(inf)[[1]][k], + estimate = inf[k, 1, j], + std.error = inf[k, 2, j], + statistic = inf[k, 3, j], + p.value = inf[k, 4, j], + fit_label = dimnames(inf)[[3]][j], + aggregation = aggregation, + stringsAsFactors = FALSE + ) + rows[[length(rows) + 1]] <- row + }#FOR + }#FOR + + res <- do.call(rbind, rows) + if (conf.int) { + ci_list <- lapply(j_seq, function(j) { + confint(x, level = conf.level, fit_idx = j, + aggregation = aggregation, type = type, + uniform = uniform, bootstraps = bootstraps) + }) + ci_mat <- do.call(rbind, ci_list) + res$conf.low <- as.numeric(ci_mat[, 1]) + res$conf.high <- as.numeric(ci_mat[, 2]) + }#IF + res +}#TIDY.RAL_REP + +#' Glance at a RAL Rep Object +#' +#' @param x An object inheriting from class \code{ral_rep}. +#' @param ... Currently unused. +#' +#' @return A one-row \code{data.frame} with columns +#' \code{nobs}, \code{nresamples}, and +#' \code{estimator_name}. +#' +#' @method glance ral_rep +#' @export +glance.ral_rep <- function(x, ...) { + data.frame( + nobs = x$nobs, + nresamples = x$nresamples, + estimator_name = if (is.null(x$estimator_name)) { + class(x)[1] + } else { + x$estimator_name + }, + stringsAsFactors = FALSE + ) +}#GLANCE.RAL_REP + +# Plot methods ================================================================ + +#' @rdname plot.ral +#' @method plot ral_rep +#' @export +plot.ral_rep <- function(x, parm = NULL, level = 0.95, + uniform = TRUE, + type = "HC1", + xlab = NULL, ylab = NULL, + main = NULL, + col = "black", pch = 19, lwd = 1.5, + ...) { + # Compute CIs using ral_rep method (aggregates across reps) + ci <- confint(x, parm = parm, level = level, type = type, uniform = uniform) + cf <- coef(x) + labels <- rownames(ci) + cf <- cf[labels] + + # Set up plot coordinates + p <- length(cf) + idx <- seq_len(p) + + # Default labels + if (is.null(xlab)) xlab <- "" + if (is.null(ylab)) ylab <- "Estimate" + if (is.null(main)) { + ci_type <- if (uniform) "uniform" else "pointwise" + main <- paste0(format(level * 100, digits = 3), "% ", ci_type, " CI") + }#IF + + # Plot + ylim <- range(ci) + graphics::plot.default( + idx, cf, type = "n", + xlim = c(0.5, p + 0.5), ylim = ylim, + xaxt = "n", xlab = xlab, ylab = ylab, + main = main, ...) + graphics::abline(h = 0, lty = 2, col = "grey50") + graphics::segments(idx, ci[, 1], idx, ci[, 2], col = col, lwd = lwd) + graphics::points(idx, cf, pch = pch, col = col) + graphics::axis(1, at = idx, labels = labels, las = 2) + + invisible(list(coefficients = cf, ci = ci, labels = labels)) +}#PLOT.RAL_REP + +# List conversion ============================================================= + +#' Split a RAL Rep Object by Fit +#' +#' Returns a named list of single-fit \code{ral_rep} +#' objects. Each element aggregates across resamples +#' for a single ensemble type. +#' +#' @param x An object inheriting from class \code{ral_rep}. +#' @param ... Currently unused. +#' +#' @return A named list of \code{ral_rep} objects. +#' +#' @method as.list ral_rep +#' @export +as.list.ral_rep <- function(x, ...) { + nfit <- x$nfit + labels <- x$fit_labels + if (is.null(labels)) labels <- paste0("fit", seq_len(nfit)) + + sub <- setdiff(class(x), "ral_rep")[1] + + out <- vector("list", nfit) + names(out) <- labels + for (j in seq_len(nfit)) { + fits_j <- lapply(x$fits, function(f) as.list(f)[[j]]) + out[[j]] <- ral_rep(fits_j, subclass = sub) + }#FOR + out +}#AS.LIST.RAL_REP diff --git a/R/shortstacking.R b/R/shortstacking.R index edce6ab..d7c2e53 100644 --- a/R/shortstacking.R +++ b/R/shortstacking.R @@ -1,35 +1,34 @@ -#' Predictions using Short-Stacking. +#' Predictions using Short-Stacking #' #' @family utilities #' #' @description Predictions using short-stacking. #' #' @inheritParams crosspred -#' @param shortstack_y Optional vector of the outcome variable to form -#' short-stacking predictions for. Base learners are always trained on -#' \code{y}. +#' @inheritParams ddml-intro #' #' @return \code{shortstack} returns a list containing the following components: #' \describe{ -#' \item{\code{oos_fitted}}{A matrix of out-of-sample predictions, +#' \item{\code{cf_fitted}}{A matrix of out-of-sample predictions, #' each column corresponding to an ensemble type (in chronological #' order).} #' \item{\code{weights}}{An array, providing the weight #' assigned to each base learner (in chronological order) by the #' ensemble procedures.} -#' \item{\code{is_fitted}}{When \code{compute_insample_predictions = T}. -#' a list of matrices with in-sample predictions by sample fold.} +#' \item{\code{mspe}}{A numeric vector of per-learner out-of-sample +#' MSPEs, computed from cross-fitted residuals.} +#' \item{\code{r2}}{A numeric vector of per-learner out-of-sample +#' R-squared values.} #' \item{\code{auxiliary_fitted}}{When \code{auxiliary_X} is not #' \code{NULL}, a list of matrices with additional predictions.} -#' \item{\code{oos_fitted_bylearner}}{A matrix of -#' out-of-sample predictions, each column corresponding to a base -#' learner (in chronological order).} -#' \item{\code{is_fitted_bylearner}}{When -#' \code{compute_insample_predictions = T}, a list of matrices with -#' in-sample predictions by sample fold.} +#' \item{\code{cf_fitted_bylearner}}{A matrix of out-of-sample +#' predictions, each column corresponding to a base learner (in +#' chronological order).} +#' \item{\code{cf_resid_bylearner}}{A matrix of per-learner +#' out-of-sample residuals used for weight estimation.} #' \item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} is -#' not \code{NULL}, a -#' list of matrices with additional predictions for each learner.} +#' not \code{NULL}, a list of matrices with additional predictions +#' for each learner.} #' } #' Note that unlike \code{crosspred}, \code{shortstack} always computes #' out-of-sample predictions for each base learner (at no additional @@ -53,116 +52,95 @@ #' # in the unit simplex (ensemble_type = "nnls1"). Predictions for each #' # learner are also calculated. #' shortstack_res <- shortstacking(y, X, -#' learners = list(list(fun = ols), -#' list(fun = mdl_glmnet)), +#' learners = list(list(what = ols), +#' list(what = mdl_glmnet)), #' ensemble_type = c("average", #' "nnls1", #' "singlebest"), #' sample_folds = 2, #' silent = TRUE) -#' dim(shortstack_res$oos_fitted) # = length(y) by length(ensemble_type) -#' dim(shortstack_res$oos_fitted_bylearner) # = length(y) by length(learners) -shortstacking <- function (y, X, Z = NULL, - learners, - sample_folds = 2, - ensemble_type = "average", - custom_ensemble_weights = NULL, - compute_insample_predictions = FALSE, - subsamples = NULL, - silent = FALSE, - progress = NULL, - auxiliary_X = NULL, - shortstack_y = y) { - +#' dim(shortstack_res$cf_fitted) # = length(y) by length(ensemble_type) +#' dim(shortstack_res$cf_fitted_bylearner) # = length(y) by length(learners) +shortstacking <- function(y, X, + learners, + sample_folds = 2, + ensemble_type = "average", + custom_ensemble_weights = NULL, + cluster_variable = seq_along(y), + subsamples = NULL, + silent = FALSE, + auxiliary_X = NULL, + parallel = NULL) { # Data parameters nobs <- nrow(X) nlearners <- length(learners) - # Throw error if no ensemble is estimated - calc_ensemble <- !("what" %in% names(learners)) - if (!calc_ensemble) { + if (is_single_learner(learners)) { stop("shortstacking cannot be estimated with a single learner.") }#IF - # Create sample fold tuple - if (is.null(subsamples)) { - subsamples <- generate_subsamples(nobs, sample_folds) - }#IF + # Create crossfitting tuples + indxs <- get_sample_splits(cluster_variable, + sample_folds = sample_folds, + subsamples = subsamples) + subsamples <- indxs$subsamples sample_folds <- length(subsamples) - ncustom <- ncol(custom_ensemble_weights) - ncustom <- ifelse(is.null(ncustom), 0, ncustom) - nensb <- length(ensemble_type) + ncustom - # Compute out-of-sample predictions for each learner - res <- crosspred(y, X, Z, + # Compute out-of-sample predictions for each learner. + # Pass cv_folds = NULL to skip unnecessary CV subsample creation + # since shortstacking computes its own weights from OOS residuals. + res <- crosspred(y, X, learners = learners, ensemble_type = "average", - compute_insample_predictions = compute_insample_predictions, - compute_predictions_bylearner = TRUE, + cv_folds = NULL, subsamples = subsamples, - silent = silent, progress = progress, - auxiliary_X = auxiliary_X) + silent = silent, + auxiliary_X = auxiliary_X, + parallel = parallel) # Compute ensemble weights via subsample cross-fitted residual fakecv <- list() - fakecv$oos_resid <- kronecker(shortstack_y, t(rep(1, nlearners))) - - res$oos_fitted_bylearner - weights <- ensemble_weights(shortstack_y, X, learners = learners, + fakecv$cv_resid <- matrix(y, nobs, nlearners) - + res$cf_fitted_bylearner + weights <- ensemble_weights(y, X, learners = learners, type = ensemble_type, custom_weights = custom_ensemble_weights, cv_results = fakecv)$weights # Compute predictions - oos_fitted <- res$oos_fitted_bylearner %*% weights + cf_fitted <- res$cf_fitted_bylearner %*% weights - # Compute auxilliary predictions (optional) + # Compute auxiliary predictions (optional) auxiliary_fitted <- rep(list(NULL), sample_folds) if (!is.null(auxiliary_X)) { - for (k in 1:sample_folds) { + for (k in seq_len(sample_folds)) { auxiliary_fitted[[k]] <- res$auxiliary_fitted_bylearner[[k]] %*% weights }#FOR - }#if + }#IF - # Compute in-sample predictions (optional) - is_fitted <- rep(list(NULL), sample_folds) - fakecv_k <- list() - if (compute_insample_predictions) { - for (k in 1:sample_folds) { - # Compute shortstacking weights in-sample - fakecv_k$oos_resid <- kronecker(y[-subsamples[[k]]], t(rep(1, nlearners))) - - res$is_fitted_bylearner[[k]] - weights_k <- ensemble_weights(y[-subsamples[[k]]], X[-subsamples[[k]], ], - learners = learners, - type = ensemble_type, - custom_weights = custom_ensemble_weights, - cv_results = fakecv_k)$weights - # Combine base learners - is_fitted[[k]] <- res$is_fitted_bylearner[[k]] %*% weights_k - }#FOR + # Per-learner OOS mspe and r-squared + cf_resid_bylearner <- as.matrix(fakecv$cv_resid) + oos_stats <- compute_mspe_r2(cf_resid_bylearner, y) + mspe <- oos_stats$mspe + r2 <- oos_stats$r2 - # When multiple ensembles are computed, need to reorganize is_fitted - if (nensb > 1) { - # Loop over each ensemble type to creat list of is_fitted's - new_is_fitted <- rep(list(rep(list(1), sample_folds)), nensb) - for (i in 1:nensb) { - for (k in 1:sample_folds) { - new_is_fitted[[i]][[k]] <- is_fitted[[k]][, i, drop = F] - }#FOR - }#FOR - is_fitted <- new_is_fitted - }#IF + if (nlearners > 1) { + # Ensemble OOS mspe and r-squared + cf_resid_ens <- drop(y) - cf_fitted + oos_stats_ens <- compute_mspe_r2(cf_resid_ens, y) + + mspe <- c(mspe, oos_stats_ens$mspe) + r2 <- c(r2, oos_stats_ens$r2) + names(mspe) <- names(r2) <- c(paste0("learner_", seq_len(nlearners)), + colnames(weights)) }#IF - # Compute mspe - mspe <- colMeans((kronecker(shortstack_y, t(rep(1, nensb))) - oos_fitted)^2) - # return shortstacking output - output <- list(oos_fitted = oos_fitted, - weights = weights, mspe = mspe, - is_fitted = is_fitted, + output <- list(cf_fitted = cf_fitted, + weights = weights, mspe = mspe, r2 = r2, auxiliary_fitted = auxiliary_fitted, - oos_fitted_bylearner = res$oos_fitted_bylearner, - is_fitted_bylearner = res$is_fitted_bylearner, + cf_fitted_bylearner = res$cf_fitted_bylearner, + cf_resid_bylearner = cf_resid_bylearner, auxiliary_fitted_bylearner = res$auxiliary_fitted_bylearner) return(output) }#SHORTSTACKING diff --git a/R/subsample_functions.R b/R/subsample_functions.R index 6d2e584..4a34973 100644 --- a/R/subsample_functions.R +++ b/R/subsample_functions.R @@ -1,208 +1,477 @@ # Collection of subsampling functions + +# Main entry point for constructing all sample-splitting indices. +get_sample_splits <- function(cluster_variable, + sample_folds = 10, + cv_folds = NULL, + D = NULL, + stratify = !is.null(D), + subsamples = NULL, + subsamples_byD = NULL, + cv_subsamples = NULL, + cv_subsamples_byD = NULL) { + by_D <- !is.null(D) + + # Normalize list(NULL, NULL) to NULL (from per-eq inline access) + if (!is.null(subsamples_byD) && + all(vapply(subsamples_byD, is.null, logical(1)))) + subsamples_byD <- NULL + if (!is.null(cv_subsamples_byD) && + all(vapply(cv_subsamples_byD, is.null, logical(1)))) + cv_subsamples_byD <- NULL + + # Auto-merge subsamples_byD into subsamples when only byD is given + if (is.null(subsamples) && !is.null(subsamples_byD)) { + if (!by_D) stop("subsamples_byD requires D to be specified.", call. = FALSE) + subsamples <- merge_subsamples_byD(subsamples_byD, D) + }#IF + + # Get crossfitting indices + cf_indx <- get_crossfit_indices( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + D = D, by_D = by_D, + stratify = stratify, + subsamples = subsamples, + subsamples_byD = subsamples_byD) + subsamples <- cf_indx$subsamples + subsamples_byD <- cf_indx$subsamples_byD + + # Build CV indices if requested + if (!is.null(cv_folds) && is.null(cv_subsamples)) { + n_sf <- length(subsamples) + cv_subsamples <- rep(list(NULL), n_sf) + cv_byD_raw <- if (by_D) rep(list(NULL), n_sf) + + for (k in seq_len(n_sf)) { + cl_k <- cluster_variable[-subsamples[[k]]] + if (by_D) { + D_k <- D[-subsamples[[k]]] + cv_tmp <- get_crossfit_indices( + cl_k, sample_folds = cv_folds, + D = D_k, by_D = TRUE, stratify = FALSE) + cv_subsamples[[k]] <- cv_tmp$subsamples + cv_byD_raw[[k]] <- cv_tmp$subsamples_byD + } else { + cv_tmp <- get_crossfit_indices( + cl_k, sample_folds = cv_folds) + cv_subsamples[[k]] <- cv_tmp$subsamples + }#IFELSE + }#FOR + + if (by_D && is.null(cv_subsamples_byD)) { + cv_subsamples_byD <- switch_list_levels(cv_byD_raw) + }#IF + }#IF + + # Derive cv_subsamples_byD when cv_subsamples is provided + # but cv_subsamples_byD is not (e.g., per-eq pass-through). + if (by_D && !is.null(cv_subsamples) && + is.null(cv_subsamples_byD)) { + n_sf <- length(subsamples) + cv_byD_raw <- rep(list(NULL), n_sf) + for (k in seq_len(n_sf)) { + D_k <- D[-subsamples[[k]]] + cv_byD_raw[[k]] <- derive_subsamples_byD( + cv_subsamples[[k]], D_k) + }#FOR + cv_subsamples_byD <- switch_list_levels(cv_byD_raw) + }#IF + + # Build auxiliary indices when D is given + aux_indx <- NULL + if (by_D) { + aux_indx <- get_auxiliary_indx(subsamples_byD, D) + }#IF + + # Clean up: return NULL (not list-of-NULLs) when not applicable + if (!by_D) { + subsamples_byD <- NULL + cv_subsamples_byD <- NULL + }#IF + + # Return output as list + list(subsamples = subsamples, + subsamples_byD = subsamples_byD, + cv_subsamples = cv_subsamples, + cv_subsamples_byD = cv_subsamples_byD, + aux_indx = aux_indx) +}#GET_SAMPLE_SPLITS + +# Internal: merge by-D subsamples into full-sample subsamples +merge_subsamples_byD <- function(subsamples_byD, D) { + D_levels <- sort(unique(D)) + nD_levels <- length(D_levels) + nobs <- length(D) + is_D <- lapply(seq_len(nD_levels), + function(d) which(D == D_levels[d])) + sample_folds <- length(subsamples_byD[[1]]) + + subsamples <- rep(list(NULL), sample_folds) + for (k in seq_len(sample_folds)) { + for (d in seq_len(nD_levels)) { + subsamples[[k]] <- c(subsamples[[k]], + is_D[[d]][subsamples_byD[[d]][[k]]]) + }#FOR + subsamples[[k]] <- sort(subsamples[[k]]) + }#FOR + subsamples +}#MERGE_SUBSAMPLES_BYD + +# Derive within-stratum fold indices from full-sample folds and D. +derive_subsamples_byD <- function(subsamples, D) { + D_levels <- sort(unique(D)) + nD_levels <- length(D_levels) + nobs <- length(D) + sample_folds <- length(subsamples) + subsamples_byD <- rep(list(NULL), nD_levels) + for (d in seq_len(nD_levels)) { + is_Dd <- which(D == D_levels[d]) + tmp_indx <- rep(NA_integer_, nobs) + tmp_indx[is_Dd] <- seq_along(is_Dd) + subsamples_byD[[d]] <- rep(list(NULL), sample_folds) + for (k in seq_len(sample_folds)) { + tmp_indx_k <- tmp_indx[subsamples[[k]]] + subsamples_byD[[d]][[k]] <- + tmp_indx_k[!is.na(tmp_indx_k)] + }#FOR + }#FOR + subsamples_byD +}#DERIVE_SUBSAMPLES_BYD + +# Internal: dispatcher for crossfit index construction get_crossfit_indices <- function(cluster_variable, - sample_folds = 10, cv_folds = 10, + sample_folds = 10, D = NULL, + by_D = !is.null(D), + stratify = by_D, subsamples = NULL, - cv_subsamples_list = NULL, - subsamples_byD = NULL, - cv_subsamples_byD = NULL) { + subsamples_byD = NULL) { + + # Check whether subsamples need to be constructed + compute_cf <- FALSE + if (is.null(subsamples) && is.null(subsamples_byD)) { + compute_cf <- TRUE + } else if (is.null(subsamples) && !is.null(subsamples_byD)) { + stop(paste0("``subsamples`` must also be set when setting ", + "``subsamples_byD``."), call. = FALSE) + } else if (!is.null(subsamples) && is.null(subsamples_byD) && by_D) { + subsamples_byD <- derive_subsamples_byD(subsamples, D) + }#IF + + # Compute crossfit indices + if (compute_cf) { + if (stratify) { + if (!by_D) + stop("Stratified sampling only works when ``by_D=TRUE``.", + call. = FALSE) + cl_folds <- get_cf_indices_stratified( + cluster_variable = cluster_variable, + sample_folds = sample_folds, D = D) + } else { + cl_folds <- get_cf_indices_simple( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + by_D = by_D, D = D) + }#IFELSE + subsamples <- cl_folds$subsamples + subsamples_byD <- cl_folds$subsamples_byD + }#IF + + # Return list of NULLs if by_D is FALSE + if (!by_D) subsamples_byD <- rep(list(NULL), sample_folds) + + # Return output as list + list(subsamples = subsamples, subsamples_byD = subsamples_byD) +}#GET_CROSSFIT_INDICES + +# Checks size of crossfitting subsamples +check_subsamples <- function(subsamples, subsamples_byD, stratify, + D = NULL, cv = FALSE) { + by_D <- !is.null(subsamples_byD) + + if (!cv) { + type <- "crossfitting" + fold_arg <- "``sample_folds``" + } else { + type <- "crossvalidation" + fold_arg <- "``sample_folds`` and/or ``cv_folds``" + }#IFELSE + + # Compute fold counts to check for balance + sample_folds <- length(subsamples) + fold_counts <- lengths(subsamples) + names(fold_counts) <- paste("Fold", seq_len(sample_folds)) + fold_counts_byD <- NULL + if (by_D) { + D_levels <- sort(unique(D)) + fold_counts_byD <- do.call(rbind, lapply(subsamples_byD, lengths)) + colnames(fold_counts_byD) <- paste("Fold", seq_len(sample_folds)) + rownames(fold_counts_byD) <- paste0("D=", as.character(D_levels)) + }#IF + + # Throw a warning if the smallest training set uses less than 100 obs + training_counts <- sum(fold_counts) - fold_counts + throw_warning <- FALSE + if (min(training_counts) < 100) throw_warning <- TRUE + training_counts_byD <- NULL + if (by_D) { + training_counts_byD <- sweep(fold_counts_byD, 1, + rowSums(fold_counts_byD), + FUN = function(x, y) y - x) + if (min(training_counts_byD) < 100) throw_warning <- TRUE + }#IF + if (throw_warning && !by_D) { + warning_text <- paste0( + "One of the ", type, " subsamples only uses ", + min(training_counts), " observations for training. Consider ", + "increasing ", fold_arg, " if possible.") + } else if (throw_warning && by_D && !stratify) { + warning_text <- paste0( + "One of the ", type, " subsamples only uses ", + min(training_counts_byD), " observations for training. Consider ", + "setting ``stratify=TRUE`` and/or increasing ", fold_arg, + " if possible.") + } else if (throw_warning && by_D && stratify) { + warning_text <- paste0( + "One of the ", type, " subsamples only uses ", + min(training_counts_byD), " observations for training. Consider ", + "increasing ", fold_arg, " if possible.") + }#IFELSE + if (throw_warning) warning(warning_text, call. = FALSE) + + # Return training counts (invisible) + invisible(list(training_counts = training_counts, + training_counts_byD = training_counts_byD)) +}#CHECK_SUBSAMPLES + +# Stratified crossfit indices construction +get_cf_indices_stratified <- function(cluster_variable, sample_folds, + D) { # Data parameters nobs <- length(cluster_variable) - cluster <- !identical(cluster_variable, 1:nobs) + D_levels <- sort(unique(D)) + nD_levels <- length(D_levels) + is_D <- rep(list(NULL), nD_levels) + nobs_byD <- rep(0, nD_levels) + nclusters_byD <- rep(0, nD_levels) + for (d in seq_len(nD_levels)) { + is_D[[d]] <- which(D == D_levels[d]) + nobs_byD[[d]] <- length(is_D[[d]]) + nclusters_byD[d] <- length(unique(cluster_variable[is_D[[d]]])) + }#FOR - # Check whether indices should be constructed by D - by_D <- !is.null(D) + # Error if number of clusters is smaller than the number of sample folds + if (min(nclusters_byD) < sample_folds) + stop(paste0("Number of clusters for at least one treatment level is ", + "smaller than the number of sample folds."), call. = FALSE) - if (by_D) { + # Check for clustering + cluster <- (length(unique(cluster_variable)) != nobs) - # Argument check - if (!is.null(subsamples) & is.null(subsamples_byD)) - stop("Must also supply subsamples_byD if supplying subsamples.") - if (!is.null(cv_subsamples_byD) & is.null(subsamples_byD)) - stop("Must also supply subsamples_byD if supplying cv_subsamples_byD.") - if (!is.null(cv_subsamples_list) & is.null(cv_subsamples_byD)) - stop("Must also supply cv_subsamples_byD if supplying cv_subsamples_list") + if (cluster) { - # Data parameters - D_levels <- sort(unique(D)) - n_D_levels <- length(D_levels) - is_D <- rep(list(NULL), n_D_levels) - nobs_byD <- rep(0, n_D_levels) - for (d in 1:n_D_levels) { - is_D[[d]] <- which(D == D_levels[d]) - nobs_byD[[d]] <- length(is_D[[d]]) + clusters <- unique(cluster_variable) + nclusters <- length(clusters) + + if (nclusters > 10000) + warning(paste0( + "Stratified subsample construction can take a long time", + " when there are many clusters. Check whether", + " stratification is necessary if you're short on time."), + call. = FALSE) + + # Map cluster ids to indices in cluster_variable + cl_indx_list <- split(seq_along(cluster_variable), + cluster_variable) + cl_indx_list_byD <- rep(list(NULL), nD_levels) + for (d in seq_len(nD_levels)) { + cluster_variable_d <- cluster_variable[D == D_levels[d]] + cl_indx_list_byD[[d]] <- + split(seq_along(cluster_variable_d), cluster_variable_d) }#FOR - if (is.null(subsamples_byD)) { - # Create sample fold tuple by treatment levels - subsamples_byD <- rep(list(NULL), n_D_levels) - for (d in 1:n_D_levels) { - if (cluster) { - # Create temp cluster variable to efficiently map clusters to sample indices - tmp_cl <- get_temp_cluster(cluster_variable[D==D_levels[d]]) - subsamples_temp <- generate_subsamples(tmp_cl$n_cluster, - sample_folds) - subsamples_byD[[d]] <- lapply(subsamples_temp, function (x) { - unname(unlist(tmp_cl$cluster_map[x])) - })#LAPPLY - } else { - subsamples_byD[[d]] <- generate_subsamples(nobs_byD[d], sample_folds) - }#IFELSE - }#FOR - }#IF - sample_folds <- length(subsamples_byD[[1]]) + # Calculate total D counts across clusters + cluster_D_values <- lapply(clusters, function(cl) { + unique(D[cl_indx_list[[as.character(cl)]]]) + })#LAPPLY + names(cluster_D_values) <- clusters + total_D_counts <- table(factor(unlist(cluster_D_values), + levels = D_levels)) + + # Calculate D counts per cluster (binary: is D level present?) + cluster_D_counts <- lapply(clusters, function(cl) { + D_values <- unique(D[cl_indx_list[[as.character(cl)]]]) + counts <- as.numeric(D_levels %in% D_values) + names(counts) <- as.character(D_levels) + counts + }) + names(cluster_D_counts) <- clusters + + # Create a data frame with clusters and their D counts + cluster_info <- data.frame( + cluster = clusters, + total_observations = lengths(cl_indx_list)[as.character(clusters)], + stringsAsFactors = FALSE) + cluster_counts_matrix <- do.call(rbind, cluster_D_counts) + cluster_info <- cbind(cluster_info, cluster_counts_matrix) + cluster_info <- cluster_info[ + order(-cluster_info$total_observations), ] + + # Assign clusters to folds to balance D counts + fold_counts_byD <- matrix(0, nrow = nD_levels, + ncol = sample_folds) + rownames(fold_counts_byD) <- as.character(D_levels) + fold_assign <- integer(nclusters) + names(fold_assign) <- as.character(clusters) + D_folds_list <- list() + for (D_value in D_levels) { + D_folds_list[[as.character(D_value)]] <- + vector("list", sample_folds) + }#FOR + for (i in seq_len(nrow(cluster_info))) { + cl <- cluster_info$cluster[i] + D_counts <- as.numeric(cluster_info[i, -(1:2)]) + names(D_counts) <- colnames(cluster_info)[-(1:2)] + imbalance <- vapply(seq_len(sample_folds), function(k) { + new_fold_counts_byD <- fold_counts_byD + new_fold_counts_byD[, k] <- + new_fold_counts_byD[, k] + D_counts + range_per_D <- apply(new_fold_counts_byD, 1, + function(x) max(x) - min(x)) + sum(range_per_D) + }, FUN.VALUE = numeric(1))#VAPPLY + best_fold <- which.min(imbalance) + fold_assign[as.character(cl)] <- best_fold + fold_counts_byD[, best_fold] <- + fold_counts_byD[, best_fold] + D_counts + }#FOR + + # Create subsamples from fold assignments + subsamples <- rep(list(NULL), sample_folds) + subsamples_byD <- rep(list(NULL), nD_levels) + for (k in seq_len(sample_folds)) { + subsamples[[k]] <- + unlist(unname( + cl_indx_list[names(which(fold_assign == k))])) + for (d in seq_len(nD_levels)) { + subsamples_byD[[d]][[k]] <- + unlist(unname( + cl_indx_list_byD[[d]][names(which(fold_assign == k))])) + }#FOR + }#FOR + + } else { + + # Non-clustered: create random subsamples by treatment level + is_D <- rep(list(NULL), nD_levels) + nobs_byD <- rep(0, nD_levels) + subsamples_byD <- rep(list(NULL), nD_levels) + for (d in seq_len(nD_levels)) { + is_D[[d]] <- which(D == D_levels[d]) + nobs_byD[[d]] <- length(is_D[[d]]) + subsamples_byD[[d]] <- generate_subsamples(nobs_byD[d], + sample_folds) + }#FOR # Merge subsamples across treatment levels subsamples <- rep(list(NULL), sample_folds) - for (k in 1:sample_folds) { - # Sample folds - for (d in 1:n_D_levels) { + for (k in seq_len(sample_folds)) { + for (d in seq_len(nD_levels)) { subsamples[[k]] <- c(subsamples[[k]], - (1:nobs)[is_D[[d]]][subsamples_byD[[d]][[k]]]) + seq_len(nobs)[is_D[[d]]][subsamples_byD[[d]][[k]]]) }#FOR subsamples[[k]] <- sort(subsamples[[k]]) }#FOR + }#IFELSE - # Warning: CV subsample creation currently ignores dependence! - - # Create CV subsamples by treatment level - if (is.null(cv_subsamples_byD)) { - cv_subsamples_byD <- rep(list(NULL), n_D_levels) - for (d in 1:n_D_levels) { - cv_subsamples_byD[[d]] <- rep(list(NULL), sample_folds) - for (k in 1:sample_folds) { - nobs_d_k <- nobs_byD[[d]] - length(subsamples_byD[[d]][[k]]) - cv_subsamples_byD[[d]][[k]] <- - generate_subsamples(nobs_d_k, cv_folds) - }# FOR - }#FOR - }#IF - cv_folds <- length(cv_subsamples_byD[[1]][[1]]) - - # Merge cv_subsamples across treatment levels - cv_subsamples_list <- rep(list(NULL), sample_folds) - for (k in 1:sample_folds) { - # CV folds - cv_subsamples_list[[k]] <- rep(list(NULL), cv_folds) - for (d in 1:n_D_levels) { - is_d_k <- which(D[-subsamples[[k]]] == D_levels[d]) - for (j in 1:cv_folds) { - cv_subsamples_list[[k]][[j]] <- - c(cv_subsamples_list[[k]][[j]], - is_d_k[cv_subsamples_byD[[d]][[k]][[j]]]) - }#FOR - }#FOR - for (d in 1:n_D_levels) { - cv_subsamples_list[[k]][[j]] <- sort(cv_subsamples_list[[k]][[j]]) - }#FOR - }#FOR + list(subsamples = subsamples, + subsamples_byD = subsamples_byD) +}#GET_CF_INDICES_STRATIFIED - } else { +# Simple (non-stratified) crossfit indices construction +get_cf_indices_simple <- function(cluster_variable, sample_folds, + by_D = FALSE, D = NULL) { - # Argument check - if (!is.null(cv_subsamples_list) & is.null(subsamples)) - stop("Must also supply subsamples. if supplying cv_subsamples_list") - - # Create sample fold tuple - if (is.null(subsamples)) { - if (cluster) { - # Create temp cluster variable to efficiently map clusters to sample indices - tmp_cl <- get_temp_cluster(cluster_variable) - subsamples_temp <- generate_subsamples(tmp_cl$n_cluster, - sample_folds) - subsamples <- lapply(subsamples_temp, function (x) { - unname(unlist(tmp_cl$cluster_map[x])) - })#LAPPLY - } else { - subsamples <- generate_subsamples(nobs, sample_folds) - }#IFELSE - }#IF - sample_folds <- length(subsamples) + nobs <- length(cluster_variable) + cluster <- (length(unique(cluster_variable)) != nobs) - # Warning: CV subsample creation currently ignores dependence! + if (cluster) { + tmp_cluster <- as.numeric(factor(cluster_variable)) + cluster_map <- split(seq_along(tmp_cluster), tmp_cluster) + subsamples_temp <- generate_subsamples( + length(unique(tmp_cluster)), sample_folds) + subsamples <- lapply(subsamples_temp, function(x) { + unname(unlist(cluster_map[x])) + })#LAPPLY + } else { + subsamples <- generate_subsamples(nobs, sample_folds) + }#IFELSE - # Create cv-subsamples tuple - if (is.null(cv_subsamples_list)) { - cv_subsamples_list <- rep(list(NULL), sample_folds) - for (k in 1:sample_folds) { - nobs_k <- nobs - length(subsamples[[k]]) - cv_subsamples_list[[k]] <- generate_subsamples(nobs_k, cv_folds) - }# FOR - }#IF - cv_folds <- length(cv_subsamples_list[[1]]) + subsamples_byD <- if (by_D) { + derive_subsamples_byD(subsamples, D) + }#IF - # Create NULL values for unconstructed objects - cv_subsamples_byD <- subsamples_byD <- NULL - }#IFELSE + list(subsamples = subsamples, + subsamples_byD = subsamples_byD) +}#GET_CF_INDICES_SIMPLE - # Return output as list - output <- list(subsamples = subsamples, - cv_subsamples_list = cv_subsamples_list, - subsamples_byD = subsamples_byD, - cv_subsamples_byD = cv_subsamples_byD, - sample_folds = sample_folds, - cv_folds = cv_folds) -}#GET_CROSSFIT_INDICES +# Simple function to generate subsamples. +generate_subsamples <- function(nobs, sample_folds) { + sampleframe <- rep(seq_len(sample_folds), + ceiling(nobs / sample_folds)) + sample_groups <- sample(sampleframe, size = nobs, replace = FALSE) + vapply(seq_len(sample_folds), + function(x) list(which(sample_groups == x)), + FUN.VALUE = list(1)) +}#GENERATE_SUBSAMPLES + +# Utility to swap nesting levels of a nested list +switch_list_levels <- function(lst) { + if (all(vapply(lst, is.null, FUN.VALUE = logical(1)))) { + return(lst) + }#IF + K <- length(lst[[1]]) + result <- vector("list", K) + for (i in seq_len(K)) { + result[[i]] <- lapply(lst, `[[`, i) + }#FOR + return(result) +}#SWITCH_LIST_LEVELS # Function to create indices for auxiliary X get_auxiliary_indx <- function(subsamples_byD, D) { - # Data parameters - nobs <- length(D) - D_levels <- sort(unique(D)) - n_D_levels <- length(D_levels) - is_D <- rep(list(NULL), n_D_levels) - for (d in 1:n_D_levels) is_D[[d]] <- which(D == D_levels[d]) - sample_folds <- length(subsamples_byD[[1]]) - - #auxiliary_X_list <- rep(list(NULL), n_D_levels) - auxiliary_indx_list <- rep(list(NULL), n_D_levels) - for (d in 1:n_D_levels) { - auxiliary_indx_list[[d]] <- rep(list(NULL), sample_folds) - for (k in 1:sample_folds) { - for (h in setdiff((1:n_D_levels), d)) { - auxiliary_indx_list[[d]][[k]] <- - c(auxiliary_indx_list[[d]][[k]], - (1:nobs)[is_D[[h]]][subsamples_byD[[h]][[k]]]) - }#FOR + nobs <- length(D) + D_levels <- sort(unique(D)) + nD_levels <- length(D_levels) + is_D <- rep(list(NULL), nD_levels) + for (d in seq_len(nD_levels)) is_D[[d]] <- which(D == D_levels[d]) + sample_folds <- length(subsamples_byD[[1]]) + + auxiliary_indx_list <- rep(list(NULL), nD_levels) + for (d in seq_len(nD_levels)) { + auxiliary_indx_list[[d]] <- rep(list(NULL), sample_folds) + for (k in seq_len(sample_folds)) { + for (h in setdiff(seq_len(nD_levels), d)) { + auxiliary_indx_list[[d]][[k]] <- + c(auxiliary_indx_list[[d]][[k]], + seq_len(nobs)[is_D[[h]]][subsamples_byD[[h]][[k]]]) }#FOR }#FOR - - # Return output + }#FOR auxiliary_indx_list }#GET_AUXILIARY_INDX +# Function to get X for corresponding auxiliary subsample get_auxiliary_X <- function(auxiliary_indx_d, X) { - # Data parameters sample_folds <- length(auxiliary_indx_d) - - # Populate auxiliary X list auxiliary_X <- rep(list(NULL), sample_folds) - for (k in 1:sample_folds) { + for (k in seq_len(sample_folds)) { auxiliary_X[[k]] <- X[auxiliary_indx_d[[k]], , drop = FALSE] }#FOR - - # return output auxiliary_X }#GET_AUXILIARY_X - -# Simple function to generate subsamples. -generate_subsamples <- function(nobs, sample_folds) { - sampleframe <- rep(1:sample_folds, ceiling(nobs/sample_folds)) - sample_groups <- sample(sampleframe, size=nobs, replace=F) - subsamples <- sapply(1:sample_folds, - function(x) {which(sample_groups == x)}, - simplify = F) - subsamples -}#GENERATE_SUBSAMPLES - -# Simple function to create a temp cluster variable for more efficient mapping -get_temp_cluster <- function(cluster_variable) { - tmp_cluster <- as.numeric(factor(cluster_variable)) - cluster_map <- split(seq_along(tmp_cluster), tmp_cluster) - list(tmp_cluster = tmp_cluster, cluster_map = cluster_map, - n_cluster = length(unique(tmp_cluster))) -}#GET_TEMP_CLUSTER diff --git a/README.Rmd b/README.Rmd index efbdb0a..1cbe10b 100644 --- a/README.Rmd +++ b/README.Rmd @@ -4,10 +4,13 @@ output: github_document -```{r, echo = FALSE} +```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, - comment = "#>" + comment = "#>", + eval = TRUE, + warning = FALSE, + message = FALSE ) ``` @@ -66,11 +69,11 @@ X = AE98[, c("age","agefst","black","hisp","othrace","educ")] ```{r, eval = TRUE} # Estimate the local average treatment effect using short-stacking with base -# learners ols, rlasso, and xgboost. +# learners ols, lasso, and xgboost. late_fit_short <- ddml_late(y, D, Z, X, - learners = list(list(fun = ols), - list(fun = mdl_glmnet), - list(fun = mdl_xgboost, + learners = list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_xgboost, args = list(nrounds = 100, max_depth = 1))), ensemble_type = 'nnls1', @@ -86,9 +89,12 @@ Check out our articles to learn more: - ``vignette("ddml")`` is a more detailed introduction to ``ddml`` - ``vignette("stacking")`` discusses computational benefits of short-stacking +- ``vignette("stacking_diagnostics")`` shows how to evaluate base learners and perform inference on learner performance +- ``vignette("repeated_resampling")`` demonstrates robust inference via repeated cross-fitting +- ``vignette("modelsummary_integration")`` illustrates integration with ``broom`` and ``modelsummary`` - ``vignette("new_ml_wrapper")`` shows how to write user-provided base learners - ``vignette("sparse")`` illustrates support of sparse matrices (see ``?Matrix``) -- ``vignette("did")`` discusses integration with the diff-in-diff package [``did``](https://bcallaway11.github.io/did/) +- ``vignette("did")`` covers DiD estimation, aggregation, and inference in staggered adoption designs For additional applied examples, see our case studies: @@ -97,10 +103,16 @@ For additional applied examples, see our case studies: ## Other Double/Debiased Machine Learning Packages -``ddml`` is built to easily (and quickly) estimate common causal parameters with multiple machine learners. With its support for short-stacking, sparse matrices, and easy-to-learn syntax, we hope ``ddml`` is a useful complement to [``DoubleML``](https://docs.doubleml.org/stable/index.html), the expansive R and Python package. [``DoubleML``](https://docs.doubleml.org/stable/index.html) supports many advanced features such as [multiway clustering](https://docs.doubleml.org/stable/examples/R_double_ml_multiway_cluster.html) and [stacking](https://docs.doubleml.org/stable/examples/R_double_ml_pipeline.html). +``ddml`` is built to easily (and quickly) estimate common causal parameters with multiple machine learners. With its support for short-stacking, sparse matrices, and easy-to-learn syntax, we hope ``ddml`` is a useful complement to [``DoubleML``](https://docs.doubleml.org/stable/index.html), the expansive R and Python package. [``DoubleML``](https://docs.doubleml.org/stable/index.html) supports many advanced features such as [multiway clustering](https://docs.doubleml.org/stable/examples/R_double_ml_multiway_cluster.html) and [stacking](https://docs.doubleml.org/stable/examples/R_double_ml_pipeline.html). + +## AI Disclosure + +Portions of this package's code, documentation, and tests were developed with the assistance of AI tools. We reviewed, tested, and edited all AI-generated content. All errors are our own. ## References +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, Wiemann T (2026). "An Introduction to Double/Debiased Machine Learning." Journal of Economic Literature, forthcoming. + Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024a). “ddml: Double/debiased machine learning in Stata.” Stata Journal, 24(1): 3-45. diff --git a/README.md b/README.md index 6cd4acd..1c871d1 100644 --- a/README.md +++ b/README.md @@ -82,11 +82,11 @@ learners: ``` r # Estimate the local average treatment effect using short-stacking with base -# learners ols, rlasso, and xgboost. +# learners ols, lasso, and xgboost. late_fit_short <- ddml_late(y, D, Z, X, - learners = list(list(fun = ols), - list(fun = mdl_glmnet), - list(fun = mdl_xgboost, + learners = list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_xgboost, args = list(nrounds = 100, max_depth = 1))), ensemble_type = 'nnls1', @@ -94,10 +94,11 @@ late_fit_short <- ddml_late(y, D, Z, X, sample_folds = 10, silent = TRUE) summary(late_fit_short) -#> LATE estimation results: -#> -#> Estimate Std. Error t value Pr(>|t|) -#> nnls1 -0.221 0.187 -1.18 0.236 +#> DDML estimation: Local Average Treatment Effect +#> Obs: 5000 Folds: 10 Stacking: short-stack +#> +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.220 0.187 -1.18 0.24 ``` ## Learn More about `ddml` @@ -107,12 +108,18 @@ Check out our articles to learn more: - `vignette("ddml")` is a more detailed introduction to `ddml` - `vignette("stacking")` discusses computational benefits of short-stacking +- `vignette("stacking_diagnostics")` shows how to evaluate base learners + and perform inference on learner performance +- `vignette("repeated_resampling")` demonstrates robust inference via + repeated cross-fitting +- `vignette("modelsummary_integration")` illustrates integration with + `broom` and `modelsummary` - `vignette("new_ml_wrapper")` shows how to write user-provided base learners - `vignette("sparse")` illustrates support of sparse matrices (see `?Matrix`) -- `vignette("did")` discusses integration with the diff-in-diff package - [`did`](https://bcallaway11.github.io/did/) +- `vignette("did")` covers DiD estimation, aggregation, and inference in + staggered adoption designs For additional applied examples, see our case studies: @@ -135,13 +142,24 @@ clustering](https://docs.doubleml.org/stable/examples/R_double_ml_multiway_clust and [stacking](https://docs.doubleml.org/stable/examples/R_double_ml_pipeline.html). +## AI Disclosure + +Portions of this package’s code, documentation, and tests were developed +with the assistance of AI tools. We reviewed, tested, and edited all +AI-generated content. All errors are our own. + ## References +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, Wiemann T +(2026). “An Introduction to Double/Debiased Machine Learning.” Journal +of Economic Literature, forthcoming. + Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024a). “ddml: Double/debiased machine learning in Stata.” Stata Journal, 24(1): 3-45. Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024b). “Model averaging -and double machine learning.” Journal of Applied Econometrics, 40(3): 249-269. +and double machine learning.” Journal of Applied Econometrics, 40(3): +249-269. Angrist J, Evans W, (1998). “Children and Their Parents’ Labor Supply: Evidence from Exogenous Variation in Family Size.” American Economic diff --git a/_pkgdown.yml b/_pkgdown.yml index 438a994..902f80a 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -3,6 +3,13 @@ url: https://www.thomaswiemann.com/ddml template: bootstrap: 5 +# Exclude AI-tooling artifacts from the site +exclude: + - GEMINI.md + - .cursor + - .discussion + - .discussions + home: title: Double/Debiased Machine Learning in R description: Estimate common causal parameters using double/debiased machine @@ -30,19 +37,26 @@ navbar: - github reference: -- title: internal - contents: - - ddml - - matches("print") - - matches("summary") -- title: Supported Models +- title: Supported DDML Estimators contents: - ddml_plm - - ddml_ate - - ddml_att - ddml_pliv - ddml_fpliv + - ddml_ate + - ddml_att - ddml_late + - ddml_apo + - ddml_attgt + +- title: Repeated Resampling + contents: + - ddml_replicate + +- title: Linear Combinations and Aggregation + contents: + - lincom + - lincom_weights_did + - title: Wrappers for Common (Machine) Learners contents: - ols @@ -50,25 +64,56 @@ reference: - mdl_glmnet - mdl_ranger - mdl_xgboost + - mdl_bigGlm + - title: Utilities contents: - crossval - crosspred - shortstacking + - ensemble + - diagnostics + - title: Dataset contents: - AE98 +- title: internal + contents: + - ddml-package + - ddml-intro + - ddml + - ddml_rep + - ral + - ral_rep + - matches("summary") + - matches("print") + - matches("sub-") + - matches("coef") + - matches("vcov") + - matches("confint") + - matches("hatvalues") + - matches("nobs") + - matches("plot") + - matches("tidy") + - matches("glance") + - matches("predict") + - matches("as.list") + - ensemble_weights + - reexports + articles: - title: Key Features navbar: ~ contents: - ddml - articles/stacking + - articles/stacking_diagnostics + - articles/repeated_resampling + - articles/modelsummary_integration - articles/new_ml_wrapper - articles/sparse - articles/did - title: Case Studies contents: - starts_with("articles/example") - diff --git a/man/AE98.Rd b/man/AE98.Rd index 38bac52..78d0a63 100644 --- a/man/AE98.Rd +++ b/man/AE98.Rd @@ -3,7 +3,7 @@ \docType{data} \name{AE98} \alias{AE98} -\title{Random subsample from the data of Angrist & Evans (1991).} +\title{Random Subsample from the Data of Angrist & Evans (1998)} \format{ A data frame with 5,000 rows and 13 variables. \describe{ @@ -31,7 +31,7 @@ Hispanic.} AE98 } \description{ -Random subsample from the data of Angrist & Evans (1991). +Random subsample from the data of Angrist & Evans (1998). } \references{ Angrist J, Evans W (1998). "Children and Their Parents' Labor Supply: diff --git a/man/as.list.ddml.Rd b/man/as.list.ddml.Rd new file mode 100644 index 0000000..2ab0db3 --- /dev/null +++ b/man/as.list.ddml.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml.R +\name{as.list.ddml} +\alias{as.list.ddml} +\title{Split a DDML Object by Ensemble Type} +\usage{ +\method{as.list}{ddml}(x, ...) +} +\arguments{ +\item{x}{An object inheriting from class \code{ddml}.} + +\item{...}{Currently unused.} +} +\value{ +A named list of length \code{nfit}. +} +\description{ +Returns a named list of single-ensemble \code{ddml} +objects. Each element retains all S3 methods +(\code{summary}, \code{tidy}, \code{glance}, +\code{confint}, \code{vcov}). +} +\examples{ +\donttest{ +y = AE98[, "worked"] +D = AE98[, "morekids"] +X = AE98[, c("age","agefst","black","hisp","othrace")] +fit = ddml_plm(y, D, X, + learners = list( + list(what = ols), + list(what = mdl_glmnet)), + ensemble_type = c("nnls", "singlebest"), + sample_folds = 2, silent = TRUE) +as.list(fit) +} + +} diff --git a/man/as.list.ddml_rep.Rd b/man/as.list.ddml_rep.Rd new file mode 100644 index 0000000..274cde9 --- /dev/null +++ b/man/as.list.ddml_rep.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{as.list.ddml_rep} +\alias{as.list.ddml_rep} +\title{Split a ddml_rep Object by Ensemble Type} +\usage{ +\method{as.list}{ddml_rep}(x, ...) +} +\arguments{ +\item{x}{A \code{ddml_rep} object.} + +\item{...}{Currently unused.} +} +\value{ +A named list of \code{ddml_rep} objects. +} +\description{ +Returns a named list of single-ensemble +\code{ddml_rep} objects. +} +\examples{ +\donttest{ +y = AE98[, "worked"] +D = AE98[, "morekids"] +X = AE98[, c("age","agefst","black","hisp","othrace")] +reps = ddml_replicate(ddml_plm, y = y, D = D, X = X, + learners = list(what = ols), + resamples = 3, + sample_folds = 2, + silent = TRUE) +as.list(reps) +} + +} diff --git a/man/as.list.ral.Rd b/man/as.list.ral.Rd new file mode 100644 index 0000000..a0788e3 --- /dev/null +++ b/man/as.list.ral.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral.R +\name{as.list.ral} +\alias{as.list.ral} +\title{Split a RAL Object by Fit} +\usage{ +\method{as.list}{ral}(x, ...) +} +\arguments{ +\item{x}{An object inheriting from class \code{ral}.} + +\item{...}{Currently unused.} +} +\value{ +A named list of \code{ral} objects, each with +\code{nfit = 1}. +} +\description{ +Returns a named list of single-fit \code{ral} objects, +one per column of \code{coefficients}. This is the +primary mechanism for passing multi-ensemble results +to \pkg{modelsummary}. +} +\seealso{ +\code{\link{ral}}, \code{\link{lincom}} +} diff --git a/man/as.list.ral_rep.Rd b/man/as.list.ral_rep.Rd new file mode 100644 index 0000000..c8e112b --- /dev/null +++ b/man/as.list.ral_rep.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral_rep.R +\name{as.list.ral_rep} +\alias{as.list.ral_rep} +\title{Split a RAL Rep Object by Fit} +\usage{ +\method{as.list}{ral_rep}(x, ...) +} +\arguments{ +\item{x}{An object inheriting from class \code{ral_rep}.} + +\item{...}{Currently unused.} +} +\value{ +A named list of \code{ral_rep} objects. +} +\description{ +Returns a named list of single-fit \code{ral_rep} +objects. Each element aggregates across resamples +for a single ensemble type. +} diff --git a/man/coef.ral.Rd b/man/coef.ral.Rd new file mode 100644 index 0000000..c230484 --- /dev/null +++ b/man/coef.ral.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral.R +\name{coef.ral} +\alias{coef.ral} +\title{Extract Coefficients from a RAL Object} +\usage{ +\method{coef}{ral}(object, ...) +} +\arguments{ +\item{object}{An object inheriting from class \code{ral}.} + +\item{...}{Currently unused.} +} +\value{ +Named vector (single fit) or matrix (multiple fits). +} +\description{ +Extract Coefficients from a RAL Object +} diff --git a/man/coef.ral_rep.Rd b/man/coef.ral_rep.Rd new file mode 100644 index 0000000..07c1e32 --- /dev/null +++ b/man/coef.ral_rep.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral_rep.R +\name{coef.ral_rep} +\alias{coef.ral_rep} +\title{Extract Aggregated Coefficients} +\usage{ +\method{coef}{ral_rep}(object, aggregation = c("median", "mean", "spectral"), ...) +} +\arguments{ +\item{object}{An object inheriting from class +\code{ral_rep}.} + +\item{aggregation}{Character string: \code{"median"} +(default), \code{"mean"}, or \code{"spectral"}.} + +\item{...}{Currently unused.} +} +\value{ +Named vector (single fit) or matrix (multiple). +} +\description{ +Extract Aggregated Coefficients +} diff --git a/man/confint.ral.Rd b/man/confint.ral.Rd new file mode 100644 index 0000000..e9dabe4 --- /dev/null +++ b/man/confint.ral.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral.R +\name{confint.ral} +\alias{confint.ral} +\title{Confidence Intervals for RAL Estimators} +\usage{ +\method{confint}{ral}( + object, + parm = NULL, + level = 0.95, + fit_idx = 1, + type = "HC1", + uniform = FALSE, + bootstraps = 999L, + ... +) +} +\arguments{ +\item{object}{An object inheriting from class \code{ral}.} + +\item{parm}{A specification of which parameters are to be +given confidence intervals, either a vector of numbers +or a vector of names. If missing, all parameters are +considered.} + +\item{level}{Confidence level. Default 0.95.} + +\item{fit_idx}{Integer index of the fit. Defaults to 1.} + +\item{type}{Character. HC type. Default \code{"HC1"}.} + +\item{uniform}{Logical. If \code{TRUE}, computes uniform +confidence bands using the multiplier bootstrap. +Default \code{FALSE}.} + +\item{bootstraps}{Integer number of bootstrap draws. +Only used when \code{uniform = TRUE}. Default 999.} + +\item{...}{Currently unused.} +} +\value{ +A matrix with columns for lower and upper bounds. +When \code{uniform = TRUE}, the attribute +\code{"crit_val"} contains the critical value. +} +\description{ +Computes confidence intervals for one or more +parameters. +} +\references{ +Chernozhukov V, Chetverikov D, Kato K (2013). "Gaussian +approximations and multiplier bootstrap for maxima of sums +of high-dimensional random vectors." Annals of Statistics, +41(6), 2786-2819. +} +\seealso{ +\code{\link{vcov.ral}} +} diff --git a/man/confint.ral_rep.Rd b/man/confint.ral_rep.Rd new file mode 100644 index 0000000..27c173f --- /dev/null +++ b/man/confint.ral_rep.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral_rep.R +\name{confint.ral_rep} +\alias{confint.ral_rep} +\title{Confidence Intervals for RAL Rep Objects} +\usage{ +\method{confint}{ral_rep}( + object, + parm = NULL, + level = 0.95, + fit_idx = 1, + aggregation = c("median", "mean", "spectral"), + type = "HC1", + uniform = FALSE, + bootstraps = 999L, + ... +) +} +\arguments{ +\item{object}{An object inheriting from class +\code{ral_rep}.} + +\item{parm}{Parameter specification (names or indices).} + +\item{level}{Confidence level. Default 0.95.} + +\item{fit_idx}{Integer index of the fit. Defaults to 1.} + +\item{aggregation}{Character string. Aggregation rule.} + +\item{type}{Character. HC type. Default \code{"HC1"}.} + +\item{uniform}{Logical. Uniform bands via multiplier +bootstrap? Default \code{FALSE}.} + +\item{bootstraps}{Integer. Bootstrap draws. Default 999.} + +\item{...}{Currently unused.} +} +\value{ +A matrix with columns for lower and upper bounds. +When \code{uniform = TRUE}, the attribute +\code{"crit_val"} contains the aggregated critical +value. +} +\description{ +Confidence Intervals for RAL Rep Objects +} +\references{ +Chernozhukov V, Chetverikov D, Kato K (2013). "Gaussian +approximations and multiplier bootstrap for maxima of sums +of high-dimensional random vectors." Annals of Statistics, +41(6), 2786-2819. +} diff --git a/man/crosspred.Rd b/man/crosspred.Rd index 4b8c21c..f44bed1 100644 --- a/man/crosspred.Rd +++ b/man/crosspred.Rd @@ -2,24 +2,23 @@ % Please edit documentation in R/crosspred.R \name{crosspred} \alias{crosspred} -\title{Cross-Predictions using Stacking.} +\title{Cross-Fitted Predictions Using Stacking} \usage{ crosspred( y, X, - Z = NULL, learners, - sample_folds = 2, + sample_folds = 10, ensemble_type = "average", - cv_folds = 5, + cv_folds = 10, custom_ensemble_weights = NULL, - compute_insample_predictions = FALSE, - compute_predictions_bylearner = FALSE, + cluster_variable = seq_along(y), subsamples = NULL, + cv_subsamples = NULL, cv_subsamples_list = NULL, silent = FALSE, - progress = NULL, - auxiliary_X = NULL + auxiliary_X = NULL, + parallel = NULL ) } \arguments{ @@ -27,108 +26,146 @@ crosspred( \item{X}{A (sparse) matrix of predictive variables.} -\item{Z}{Optional additional (sparse) matrix of predictive variables.} - -\item{learners}{May take one of two forms, depending on whether a single -learner or stacking with multiple learners is used for estimation of the -predictor. -If a single learner is used, \code{learners} is a list with two named -elements: +\item{learners}{\code{learners} is a list of lists, each containing three +named elements: \itemize{ \item{\code{what} The base learner function. The function must be such that it predicts a named input \code{y} using a named input \code{X}.} \item{\code{args} Optional arguments to be passed to \code{what}.} -} -If stacking with multiple learners is used, \code{learners} is a list of -lists, each containing four named elements: -\itemize{ -\item{\code{fun} The base learner function. The function must be -such that it predicts a named input \code{y} using a named input -\code{X}.} -\item{\code{args} Optional arguments to be passed to \code{fun}.} \item{\code{assign_X} An optional vector of column indices -corresponding to predictive variables in \code{X} that are passed to +corresponding to variables in \code{X} that are passed to the base learner.} -\item{\code{assign_Z} An optional vector of column indices -corresponding to predictive in \code{Z} that are passed to the -base learner.} } Omission of the \code{args} element results in default arguments being -used in \code{fun}. Omission of \code{assign_X} (and/or \code{assign_Z}) -results in inclusion of all variables in \code{X} (and/or \code{Z}).} +used in \code{what}. Omission of \code{assign_X} +results in inclusion of all predictive variables in \code{X}.} \item{sample_folds}{Number of cross-fitting folds.} -\item{ensemble_type}{Ensemble method to combine base learners into final -estimate of the conditional expectation functions. Possible values are: +\item{ensemble_type}{Ensemble method to combine base learners into +final estimate of the conditional expectation functions. +Possible values are: \itemize{ \item{\code{"nnls"} Non-negative least squares.} -\item{\code{"nnls1"} Non-negative least squares with the constraint -that all weights sum to one.} -\item{\code{"singlebest"} Select base learner with minimum MSPE.} +\item{\code{"nnls1"} Non-negative least squares with the +constraint that all weights sum to one.} +\item{\code{"singlebest"} Select base learner with minimum +MSPE.} \item{\code{"ols"} Ordinary least squares.} \item{\code{"average"} Simple average over base learners.} } Multiple ensemble types may be passed as a vector of strings.} -\item{cv_folds}{Number of folds used for cross-validation in ensemble -construction.} - -\item{custom_ensemble_weights}{A numerical matrix with user-specified -ensemble weights. Each column corresponds to a custom ensemble -specification, each row corresponds to a base learner in \code{learners} -(in chronological order). Optional column names are used to name the -estimation results corresponding the custom ensemble specification.} +\item{cv_folds}{Number of folds used for cross-validation.} -\item{compute_insample_predictions}{Indicator equal to 1 if in-sample -predictions should also be computed.} +\item{custom_ensemble_weights}{A numerical matrix with +user-specified ensemble weights. Each column corresponds to a +custom ensemble specification, each row corresponds to a base +learner in \code{learners} (in chronological order). Optional +column names are used to name the estimation results +corresponding the custom ensemble specification.} -\item{compute_predictions_bylearner}{Indicator equal to 1 if in-sample -predictions should also be computed for each learner (rather than the -entire ensemble).} +\item{cluster_variable}{A vector of cluster indices.} \item{subsamples}{List of vectors with sample indices for cross-fitting.} -\item{cv_subsamples_list}{List of lists, each corresponding to a subsample +\item{cv_subsamples}{List of lists, each corresponding to a subsample containing vectors with subsample indices for cross-validation.} -\item{silent}{Boolean to silence estimation updates.} +\item{cv_subsamples_list}{Deprecated; use \code{cv_subsamples} instead.} -\item{progress}{String to print before learner and cv fold progress.} +\item{silent}{Boolean to silence estimation updates.} \item{auxiliary_X}{An optional list of matrices of length \code{sample_folds}, each containing additional observations to calculate predictions for.} + +\item{parallel}{An optional named list with parallel processing +options. When \code{NULL} (the default), computation is +sequential. Supported fields: +\describe{ +\item{\code{cores}}{Number of cores to use.} +\item{\code{export}}{Character vector of object names to +export to parallel workers (for custom learners that +reference global objects).} +\item{\code{packages}}{Character vector of additional +package names to load on workers (for custom learners +that use packages not imported by \code{ddml}).} +}} } \value{ \code{crosspred} returns a list containing the following components: \describe{ -\item{\code{oos_fitted}}{A matrix of out-of-sample predictions, +\item{\code{cf_fitted}}{A matrix of out-of-sample predictions, each column corresponding to an ensemble type (in chronological order).} \item{\code{weights}}{An array, providing the weight assigned to each base learner (in chronological order) by the ensemble procedures.} -\item{\code{is_fitted}}{When \code{compute_insample_predictions = T}. -a list of matrices with in-sample predictions by sample fold.} +\item{\code{mspe}}{A numeric vector of per-learner out-of-sample +MSPEs, computed from cross-fitted residuals.} +\item{\code{r2}}{A numeric vector of per-learner out-of-sample +R-squared values.} +\item{\code{cv_resid_byfold}}{A list (length \code{sample_folds}) +of inner cross-validation residual matrices used for ensemble +weight estimation. \code{NULL} when a single learner is used.} \item{\code{auxiliary_fitted}}{When \code{auxiliary_X} is not \code{NULL}, a list of matrices with additional predictions.} -\item{\code{oos_fitted_bylearner}}{When -\code{compute_predictions_bylearner = T}, a matrix of -out-of-sample predictions, each column corresponding to a base -learner (in chronological order).} -\item{\code{is_fitted_bylearner}}{When -\code{compute_insample_predictions = T} and -\code{compute_predictions_bylearner = T}, a list of matrices with -in-sample predictions by sample fold.} -\item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} is -not \code{NULL} and \code{compute_predictions_bylearner = T}, a -list of matrices with additional predictions for each learner.} +\item{\code{cf_fitted_bylearner}}{A matrix of out-of-sample +predictions, each column corresponding to a base learner +(in chronological order).} +\item{\code{cf_resid_bylearner}}{A matrix of out-of-sample +residuals (\code{y - cf_fitted_bylearner}), each column +corresponding to a base learner.} +\item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} +is not \code{NULL}, a list of matrices with additional +predictions for each learner.} } } \description{ -Cross-predictions using stacking. +Cross-fitted predictions using stacking. +} +\details{ +\code{crosspred} implements the cross-fitting step of the +Double/Debiased Machine Learning procedure combined with +stacking. It produces the cross-fitted nuisance estimates +\eqn{\hat{\eta}(X_i)} used in the Neyman orthogonal scores of +all \code{ddml_*} estimators. + +Let \eqn{\{I_1, \ldots, I_S\}} be an \eqn{S}-fold partition of +\eqn{\{1, \ldots, n\}}, and denote the training set for fold +\eqn{s} by +\eqn{\mathcal{T}_s = \{1, \ldots, n\} \setminus I_s}. +Given \eqn{J} base learners, the procedure operates on each +cross-fitting fold \eqn{s} in three steps: + +\strong{Step 1 (Stacking weights).} +Run \eqn{K}-fold cross-validation on \eqn{\mathcal{T}_s} +(via \code{\link{crossval}}) to estimate the MSPE of each +base learner, and solve for fold-specific stacking weights +\eqn{\hat{w}_s = (\hat{w}_{1,s}, \ldots, \hat{w}_{J,s})'}. + +\strong{Step 2 (Fit).} +Fit each base learner \eqn{j} on the full training set +\eqn{\mathcal{T}_s}, yielding \eqn{\hat{f}_{j,s}(\cdot)}. + +\strong{Step 3 (Predict).} +For each \eqn{i \in I_s}, compute the ensemble cross-fitted +prediction + +\eqn{\hat{\eta}(X_i) = \sum_{j=1}^{J} \hat{w}_{j,s} \hat{f}_{j,s}(X_i).} + +Since every observation belongs to exactly one fold, the result is +a complete \eqn{n}-vector of out-of-sample predictions. +Crucially, both the stacking weights \eqn{\hat{w}_s} and the +base learner fits \eqn{\hat{f}_{j,s}} depend only on +\eqn{\mathcal{T}_s}, which does not contain observation +\eqn{i}. + +When a single learner is used (\eqn{J = 1}), no stacking or inner +cross-validation is performed: the learner is simply fitted on +\eqn{\mathcal{T}_s} and predictions are made for \eqn{I_s}. } \examples{ # Construct variables from the included Angrist & Evans (1998) data @@ -141,17 +178,16 @@ X = AE98[, c("morekids", "age","agefst","black","hisp","othrace","educ")] # in the unit simplex (ensemble_type = "nnls1"). Predictions for each # learner are also calculated. crosspred_res <- crosspred(y, X, - learners = list(list(fun = ols), - list(fun = mdl_glmnet)), + learners = list(list(what = ols), + list(what = mdl_glmnet)), ensemble_type = c("average", "nnls1", "singlebest"), - compute_predictions_bylearner = TRUE, sample_folds = 2, cv_folds = 2, silent = TRUE) -dim(crosspred_res$oos_fitted) # = length(y) by length(ensemble_type) -dim(crosspred_res$oos_fitted_bylearner) # = length(y) by length(learners) +dim(crosspred_res$cf_fitted) # = length(y) by length(ensemble_type) +dim(crosspred_res$cf_fitted_bylearner) # = length(y) by length(learners) } \references{ Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and @@ -162,6 +198,10 @@ Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. \seealso{ Other utilities: \code{\link{crossval}()}, +\code{\link{ddml}()}, +\code{\link{diagnostics}()}, +\code{\link{ensemble}()}, +\code{\link{ensemble_weights}()}, \code{\link{shortstacking}()} } \concept{utilities} diff --git a/man/crossval.Rd b/man/crossval.Rd index ee03624..8578a83 100644 --- a/man/crossval.Rd +++ b/man/crossval.Rd @@ -2,17 +2,17 @@ % Please edit documentation in R/crossval.R \name{crossval} \alias{crossval} -\title{Estimator of the Mean Squared Prediction Error using Cross-Validation.} +\title{Estimator of the Mean Squared Prediction Error Using Cross-Validation} \usage{ crossval( y, X, - Z = NULL, learners, - cv_folds = 5, + cv_folds = 10, + cluster_variable = seq_along(y), cv_subsamples = NULL, silent = FALSE, - progress = NULL + parallel = NULL ) } \arguments{ @@ -20,52 +20,92 @@ crossval( \item{X}{A (sparse) matrix of predictive variables.} -\item{Z}{Optional additional (sparse) matrix of predictive variables.} - -\item{learners}{\code{learners} is a list of lists, each containing four +\item{learners}{\code{learners} is a list of lists, each containing three named elements: \itemize{ -\item{\code{fun} The base learner function. The function must be +\item{\code{what} The base learner function. The function must be such that it predicts a named input \code{y} using a named input \code{X}.} -\item{\code{args} Optional arguments to be passed to \code{fun}.} +\item{\code{args} Optional arguments to be passed to \code{what}.} \item{\code{assign_X} An optional vector of column indices corresponding to variables in \code{X} that are passed to the base learner.} -\item{\code{assign_Z} An optional vector of column indices -corresponding to variables in \code{Z} that are passed to the -base learner.} } Omission of the \code{args} element results in default arguments being -used in \code{fun}. Omission of \code{assign_X} (and/or \code{assign_Z}) -results in inclusion of all predictive variables in \code{X} (and/or -\code{Z}).} +used in \code{what}. Omission of \code{assign_X} +results in inclusion of all predictive variables in \code{X}.} \item{cv_folds}{Number of folds used for cross-validation.} +\item{cluster_variable}{A vector of cluster indices.} + \item{cv_subsamples}{List of vectors with sample indices for cross-validation.} \item{silent}{Boolean to silence estimation updates.} -\item{progress}{String to print before learner and cv fold progress.} +\item{parallel}{An optional named list with parallel processing +options. When \code{NULL} (the default), computation is +sequential. Supported fields: +\describe{ +\item{\code{cores}}{Number of cores to use.} +\item{\code{export}}{Character vector of object names to +export to parallel workers (for custom learners that +reference global objects).} +\item{\code{packages}}{Character vector of additional +package names to load on workers (for custom learners +that use packages not imported by \code{ddml}).} +}} } \value{ \code{crossval} returns a list containing the following components: \describe{ \item{\code{mspe}}{A vector of MSPE estimates, -each corresponding to a base learners (in chronological order).} -\item{\code{oos_resid}}{A matrix of out-of-sample prediction errors, -each column corresponding to a base learners (in chronological +each corresponding to a base learner (in chronological order).} -\item{\code{cv_subsamples}}{Pass-through of \code{cv_subsamples}. -See above.} +\item{\code{r2}}{A vector of cross-validated \eqn{R^2} +values, each corresponding to a base learner (in +chronological order).} +\item{\code{cv_resid}}{A matrix of out-of-sample residuals, +each column corresponding to a base learner (in +chronological order).} +\item{\code{cv_subsamples}}{Pass-through of +\code{cv_subsamples}. See above.} } } \description{ Estimator of the mean squared prediction error of different learners using cross-validation. } +\details{ +\code{crossval} estimates the mean squared prediction error +(MSPE) of \eqn{J} base learners via \eqn{K}-fold +cross-validation. It is the inner workhorse of the stacking +machinery used by \code{\link{ensemble_weights}} to determine +ensemble weights. + +Given a generic conditional expectation function \eqn{f_0(\cdot)} +(e.g., \eqn{E[Y\vert X]}, \eqn{E[D\vert X]}), let +\eqn{\{I_1, \ldots, I_K\}} be a \eqn{K}-fold partition of +\eqn{\{1, \ldots, n\}} and let \eqn{\hat{f}_j^{(-k)}} denote +learner \eqn{j} trained on all observations outside fold +\eqn{I_k}. The out-of-sample residual for observation +\eqn{i \in I_k} is + +\eqn{\hat{e}_{i,j} = y_i - \hat{f}_j^{(-k)}(X_i).} + +Since every observation belongs to exactly one fold, this yields a +complete \eqn{n \times J} residual matrix. The cross-validated +MSPE for learner \eqn{j} is + +\eqn{\widehat{\textrm{MSPE}}_j = n^{-1} \sum_{i=1}^{n} \hat{e}_{i,j}^2,} + +and the cross-validated \eqn{R^2} is + +\eqn{\hat{R}^2_j = 1 - \widehat{\textrm{MSPE}}_j \,/\, \hat{\sigma}^2_y,} + +where \eqn{\hat{\sigma}^2_y} is the sample variance of \eqn{y}. +} \examples{ # Construct variables from the included Angrist & Evans (1998) data y = AE98[, "worked"] @@ -73,9 +113,9 @@ X = AE98[, c("morekids", "age","agefst","black","hisp","othrace","educ")] # Compare ols, lasso, and ridge using 4-fold cross-validation cv_res <- crossval(y, X, - learners = list(list(fun = ols), - list(fun = mdl_glmnet), - list(fun = mdl_glmnet, + learners = list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_glmnet, args = list(alpha = 0))), cv_folds = 4, silent = TRUE) @@ -84,6 +124,10 @@ cv_res$mspe \seealso{ Other utilities: \code{\link{crosspred}()}, +\code{\link{ddml}()}, +\code{\link{diagnostics}()}, +\code{\link{ensemble}()}, +\code{\link{ensemble_weights}()}, \code{\link{shortstacking}()} } \concept{utilities} diff --git a/man/ddml-intro.Rd b/man/ddml-intro.Rd new file mode 100644 index 0000000..44047cf --- /dev/null +++ b/man/ddml-intro.Rd @@ -0,0 +1,281 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml.R +\name{ddml-intro} +\alias{ddml-intro} +\title{Intro to Double/Debiased Machine Learning} +\arguments{ +\item{y}{The outcome variable.} + +\item{D}{A matrix of endogenous variables.} + +\item{X}{A (sparse) matrix of control variables.} + +\item{learners}{May take one of two forms, depending on whether a +single learner or stacking with multiple learners is used for +estimation of the conditional expectation functions. +If a single learner is used, \code{learners} is a list with +two named elements: +\itemize{ +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} +} +If stacking with multiple learners is used, \code{learners} is +a list of lists, each containing three named elements: +\itemize{ +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} +\item{\code{assign_X} An optional vector of column indices +corresponding to control variables in \code{X} that +are passed to the base learner.} +} +Omission of the \code{args} element results in default +arguments being used in \code{what}. Omission of +\code{assign_X} results in inclusion of all variables in +\code{X}.} + +\item{sample_folds}{Number of cross-fitting folds.} + +\item{ensemble_type}{Ensemble method to combine base learners into +final estimate of the conditional expectation functions. +Possible values are: +\itemize{ +\item{\code{"nnls"} Non-negative least squares.} +\item{\code{"nnls1"} Non-negative least squares with the +constraint that all weights sum to one.} +\item{\code{"singlebest"} Select base learner with minimum +MSPE.} +\item{\code{"ols"} Ordinary least squares.} +\item{\code{"average"} Simple average over base learners.} +} +Multiple ensemble types may be passed as a vector of strings.} + +\item{shortstack}{Boolean to use short-stacking.} + +\item{cv_folds}{Number of folds used for cross-validation in +ensemble construction.} + +\item{custom_ensemble_weights}{A numerical matrix with +user-specified ensemble weights. Each column corresponds to a +custom ensemble specification, each row corresponds to a base +learner in \code{learners} (in chronological order). Optional +column names are used to name the estimation results +corresponding the custom ensemble specification.} + +\item{cluster_variable}{A vector of cluster indices.} + +\item{silent}{Boolean to silence estimation updates.} + +\item{parallel}{An optional named list with parallel processing +options. When \code{NULL} (the default), computation is +sequential. Supported fields: +\describe{ +\item{\code{cores}}{Number of cores to use.} +\item{\code{export}}{Character vector of object names to +export to parallel workers (for custom learners that +reference global objects).} +\item{\code{packages}}{Character vector of additional +package names to load on workers (for custom learners +that use packages not imported by \code{ddml}).} +}} + +\item{fitted}{An optional named list of per-equation cross-fitted +predictions, typically obtained from a previous fit via +\code{fit$fitted}. When supplied (together with \code{splits}), +base learners are not re-fitted; only ensemble weights are +recomputed. This allows fast re-estimation with a different +\code{ensemble_type}. See \code{\link{ddml_plm}} for +an example.} + +\item{splits}{An optional list of sample split objects, typically +obtained from a previous fit via \code{fit$splits}. Must be +supplied when \code{fitted} is provided. Can also be used +standalone to provide pre-computed sample folds.} + +\item{save_crossval}{Logical indicating whether to store the inner +cross-validation residuals used for ensemble weight +computation. Default \code{TRUE}. When \code{TRUE}, subsequent +pass-through calls with data-driven ensembles (e.g., +\code{"nnls"}) reproduce per-fold weights exactly. Set to +\code{FALSE} to reduce object size at the cost of approximate +weight recomputation.} + +\item{...}{Additional arguments passed to internal methods.} +} +\description{ +All \code{ddml_*} estimators (\code{\link{ddml_plm}}, +\code{\link{ddml_pliv}}, \code{\link{ddml_fpliv}}, +\code{\link{ddml_ate}}, \code{\link{ddml_att}}, +\code{\link{ddml_late}}, \code{\link{ddml_apo}}) return +objects that inherit from S3 class \code{"ddml"}. + +Each object is a list containing the components described below. +Estimator-specific fields (e.g., pass-through learner +arguments) are documented on the individual estimator pages. + +The \code{ddml()} constructor can also be used directly to build +a \code{"ddml"} object from user-supplied score components, +enabling implementation of custom DML estimators that inherit +all S3 methods. +} +\details{ +All \code{ddml_*} estimators target a low-dimensional +parameter \eqn{\theta_0} identified by a moment condition + +\deqn{E[m(W; \theta_0, \eta_0)] = 0,} + +where \eqn{W} denotes observed random variables and +\eqn{\eta_0} is a (potentially high-dimensional) nuisance +parameter. Throughout, the score \eqn{m} is assumed to be +\emph{Neyman orthogonal}. + +Estimation proceeds via cross-fitting: the sample is randomly +partitioned into \eqn{K} folds \eqn{\{I_k\}_{k=1}^K}. For +each fold \eqn{k}, nuisance parameters are estimated on the +complementary folds (\eqn{\hat\eta_{-k}}) and the scores are +evaluated on fold \eqn{k}. The DML estimator +\eqn{\hat\theta} solves + +\deqn{\frac{1}{n} \sum_{k=1}^{K} \sum_{i \in I_k} +m(W_i; \hat\theta, \hat\eta_{-k}) = 0.} + +Inference is based on the influence function. Define the Jacobian + +\deqn{J(\theta, \eta) = E\!\left[ + \frac{\partial m(W; \theta, \eta)} + {\partial \theta'}\right]} + +and the influence function + +\deqn{\phi_\theta(W_i; \theta, \eta, J) + = -J^{-1}\,m(W_i; \theta, \eta).} + +The variance of \eqn{\hat\theta} is then estimated by + +\deqn{\hat{V} = \frac{1}{n^2} \sum_i + \phi_\theta(W_i; \hat\theta, \hat\eta_{-k(i)}, + \hat{J})\,\phi_\theta(W_i; \hat\theta, + \hat\eta_{-k(i)}, \hat{J})'}, + +where \eqn{\hat{J}} is the sample analog of the Jacobian: + +\deqn{\hat{J} = \frac{1}{n} \sum_i + \frac{\partial m(W_i; \hat\theta, \hat\eta_{-k(i)})} + {\partial \theta'}.} + +HC1 and HC3 variance estimators are described in +\code{\link{vcov.ral}}. The leverage +(see \code{\link{hatvalues.ral}}) for the DML estimator +is + +\deqn{h_\theta(W_i; \theta, \eta, J) + = \mathrm{tr}\!\left( + -J^{-1} \frac{1}{n} + \frac{\partial m(W_i; \theta, \eta)} + {\partial \theta'}\right),} + +and its sample analog is +\eqn{\hat{h}_{\theta,i} = h_\theta(W_i; \hat\theta, +\hat\eta_{-k(i)}, \hat{J})}, stored in +\code{dinf_dtheta}. + +Under regularity conditions and sufficient convergence of +\eqn{\hat\eta}, the DML estimator is asymptotically normal: + +\deqn{\sqrt{n}\,\hat{V}^{-1/2}(\hat\theta - \theta_0) +\overset{d}{\to} N(0, I).} + +Further details and regularity conditions are given in +Chernozhukov et al. (2018). The specific forms of the +score \eqn{m} and Jacobian \eqn{J} for each estimator +are documented on their respective help pages (e.g., +\code{\link{ddml_plm}}, \code{\link{ddml_ate}}). +} +\section{Common output components}{ + +\describe{ +\item{\code{coefficients}}{A matrix of estimated target +parameters: rows correspond to components of +\eqn{\theta}, columns to ensemble types.} +\item{\code{ensemble_weights}}{A named list. Each element +is a weight matrix (or 3D array when +\code{shortstack = TRUE}) showing the weight assigned +to each base learner by the ensemble procedure for +the corresponding nuisance equation.} +\item{\code{mspe}}{A named list of numeric vectors +containing per-learner out-of-sample MSPEs, computed +from cross-fitted residuals.} +\item{\code{r2}}{A named list of numeric vectors +containing per-learner out-of-sample R-squared values.} +\item{\code{inf_func}}{A 3D array of evaluated influence +functions (\code{n x p x nensb}).} +\item{\code{dinf_dtheta}}{An optional 4D array of dimension +\code{(n x p x p x nensb)} containing the derivatives of the +influence functions with respect to \eqn{\theta}. Used +internally by \code{\link{hatvalues.ral}} for HC3 +inference.} +\item{\code{scores}}{A 3D array of evaluated Neyman +orthogonal scores (\code{n x p x nensb}).} +\item{\code{J}}{A 3D array of evaluated Jacobians +(\code{p x p x nensb}).} +\item{\code{fitted}}{A named list of per-equation +cross-fitted prediction objects. Can be passed back +via the \code{fitted} argument together with +\code{splits} to skip cross-fitting on +re-estimation.} +\item{\code{splits}}{The data splitting structure +(subsamples, CV subsamples, and any stratification +indices).} +\item{\code{ensemble_type}}{Character vector of ensemble +types used.} +\item{\code{cluster_variable}}{The cluster variable +vector used for sample splitting and inference.} +\item{\code{nobs}}{Number of observations.} +\item{\code{sample_folds}}{Number of cross-fitting folds.} +\item{\code{shortstack}}{Logical indicating whether +short-stacking was used.} +\item{\code{call}}{The matched call.} +\item{\code{coef_names}}{Character vector of coefficient +names.} +\item{\code{estimator_name}}{Character string identifying +the estimator (e.g., \code{"Partially Linear Model"}).} +} +} + +\section{S3 methods}{ + +The following generic methods are available for all +\code{ddml} objects: \code{\link{summary.ddml}}, +\code{\link{coef.ral}}, \code{\link{vcov.ral}}, +\code{\link{confint.ral}}, \code{\link{hatvalues.ral}}, +\code{\link{nobs.ral}}, \code{\link{tidy.ddml}}, +\code{\link{glance.ddml}}, and +\code{\link{diagnostics}}. +} + +\references{ +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, +Wiemann T (2026). "An Introduction to Double/Debiased Machine +Learning." Journal of Economic Literature, forthcoming. + +Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C B, +Newey W, Robins J (2018). "Double/debiased machine learning +for treatment and structural parameters." The Econometrics +Journal, 21(1), C1-C68. +} +\seealso{ +Other ddml estimators: +\code{\link{ddml_apo}()}, +\code{\link{ddml_ate}()}, +\code{\link{ddml_attgt}()}, +\code{\link{ddml_fpliv}()}, +\code{\link{ddml_late}()}, +\code{\link{ddml_pliv}()}, +\code{\link{ddml_plm}()} +} +\concept{ddml estimators} diff --git a/man/ddml-package.Rd b/man/ddml-package.Rd index 68284c8..2f9ce01 100644 --- a/man/ddml-package.Rd +++ b/man/ddml-package.Rd @@ -1,21 +1,33 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml.R +% Please edit documentation in R/ddml-package.R \docType{package} \name{ddml-package} -\alias{ddml} \alias{ddml-package} -\title{ddml: Double/Debiased Machine Learning in R} +\title{ddml: Double/Debiased Machine Learning} \description{ -Estimate common causal parameters using double/debiased machine -learning as proposed by Chernozhukov et al. (2018). -'ddml' simplifies estimation based on (short-)stacking, which leverages -multiple base learners to increase robustness to the underlying +Estimate common causal parameters using +double/debiased machine learning as proposed by +Chernozhukov et al. (2018). \pkg{ddml} simplifies +estimation based on (short-)stacking as discussed in +Ahrens et al. (2024), which leverages multiple base +learners to increase robustness to the underlying data generating process. } \references{ -Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C B, Newey W, -Robins J (2018). "Double/debiased machine learning for treatment and -structural parameters." The Econometrics Journal, 21(1), C1-C68. +Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). +"Model Averaging and Double Machine Learning." Journal +of Applied Econometrics, 40(3), 249-269. + +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, +Schaffer M E, Wiemann T (2026). "An Introduction to +Double/Debiased Machine Learning." Journal of +Economic Literature, forthcoming. + +Chernozhukov V, Chetverikov D, Demirer M, Duflo E, +Hansen C B, Newey W, Robins J (2018). +"Double/debiased machine learning for treatment and +structural parameters." The Econometrics Journal, +21(1), C1-C68. } \seealso{ Useful links: diff --git a/man/ddml.Rd b/man/ddml.Rd new file mode 100644 index 0000000..35d2733 --- /dev/null +++ b/man/ddml.Rd @@ -0,0 +1,131 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml.R +\name{ddml} +\alias{ddml} +\title{Construct a \code{ddml} Object.} +\usage{ +ddml( + coefficients, + scores, + J, + inf_func, + nobs, + coef_names, + estimator_name, + ensemble_type = colnames(coefficients), + cluster_variable = seq_len(nobs), + sample_folds = NULL, + cv_folds = NULL, + shortstack = FALSE, + ensemble_weights = NULL, + mspe = NULL, + r2 = NULL, + fitted = NULL, + splits = NULL, + call = match.call(), + subclass = NULL, + dinf_dtheta = NULL, + ... +) +} +\arguments{ +\item{coefficients}{A \code{(p x nensb)} matrix of estimated +target parameters. Rows correspond to components of +\eqn{\theta}, columns to ensemble types.} + +\item{scores}{A 3D array of evaluated Neyman orthogonal scores +with dimensions \code{(n x p x nensb)}.} + +\item{J}{A 3D array of evaluated Jacobians with dimensions +\code{(p x p x nensb)}.} + +\item{inf_func}{A 3D array of evaluated influence functions +with dimensions \code{(n x p x nensb)}.} + +\item{nobs}{Number of observations.} + +\item{coef_names}{Character vector of coefficient names +(length \code{p}).} + +\item{estimator_name}{Character string identifying the estimator +(e.g., \code{"My Custom Estimator"}).} + +\item{ensemble_type}{Character vector of ensemble types. Defaults +to \code{colnames(coefficients)}.} + +\item{cluster_variable}{A vector of cluster indices. Defaults to +\code{seq_len(nobs)}.} + +\item{sample_folds}{Number of cross-fitting folds used. Optional.} + +\item{cv_folds}{Number of cross-validation folds used. Optional.} + +\item{shortstack}{Logical indicating whether short-stacking was +used. Default \code{FALSE}.} + +\item{ensemble_weights}{A named list of ensemble weight matrices. +Optional.} + +\item{mspe}{A named list of per-learner MSPEs. Optional.} + +\item{r2}{A named list of per-learner R-squared values. Optional.} + +\item{fitted}{A named list of per-equation cross-fitted prediction +objects. Optional.} + +\item{splits}{A list of sample split objects. Optional.} + +\item{call}{The matched call. Defaults to \code{match.call()}.} + +\item{subclass}{Optional character string for a subclass name. If +provided, the object will have class +\code{c(subclass, "ddml")}.} + +\item{dinf_dtheta}{An optional 4D array of dimensions \code{(nobs x p x p x nensb)} +containing the derivatives of the influence functions.} + +\item{...}{Additional named components to include in the object.} +} +\value{ +An object of S3 class \code{"ddml"} (or +\code{c(subclass, "ddml")} if \code{subclass} is specified). +See \code{\link{ddml-intro}} for the output structure. +} +\description{ +Build a \code{"ddml"} object from user-supplied score +components. The resulting object inherits all S3 methods +available for \code{ddml} objects, including +\code{\link{summary.ddml}}, \code{\link{confint.ral}}, +\code{\link{vcov.ral}}, and \code{\link{tidy.ddml}}. +} +\examples{ +# A minimal example: construct a ddml object from pre-computed +# score components for a simple mean estimator. +n <- 100 +y <- rnorm(n) +theta <- mean(y) + +scores <- array(y - theta, dim = c(n, 1, 1)) +J <- array(-1, dim = c(1, 1, 1)) +psi_b <- list(matrix(y, ncol = 1)) +psi_a <- list(array(-1, dim = c(n, 1, 1))) +inf_func <- array(y - theta, dim = c(n, 1, 1)) +dinf_dtheta <- array(1, dim = c(n, 1, 1, 1)) +coef <- matrix(theta, 1, 1, dimnames = list("mean", "custom")) + +fit <- ddml(coefficients = coef, scores = scores, J = J, + inf_func = inf_func, nobs = n, coef_names = "mean", + dinf_dtheta = dinf_dtheta, + estimator_name = "Sample Mean") +summary(fit) +} +\seealso{ +Other utilities: +\code{\link{crosspred}()}, +\code{\link{crossval}()}, +\code{\link{diagnostics}()}, +\code{\link{ensemble}()}, +\code{\link{ensemble_weights}()}, +\code{\link{shortstacking}()} +} +\concept{utilities} diff --git a/man/ddml_apo.Rd b/man/ddml_apo.Rd new file mode 100644 index 0000000..1cf188a --- /dev/null +++ b/man/ddml_apo.Rd @@ -0,0 +1,219 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_apo.R +\name{ddml_apo} +\alias{ddml_apo} +\title{Estimator for the Average Potential Outcome} +\usage{ +ddml_apo( + y, + D, + X, + d = 1, + weights = NULL, + learners, + learners_DX = learners, + sample_folds = 10, + ensemble_type = "nnls", + shortstack = FALSE, + cv_folds = 10, + custom_ensemble_weights = NULL, + custom_ensemble_weights_DX = custom_ensemble_weights, + cluster_variable = seq_along(y), + stratify = TRUE, + trim = 0.01, + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ... +) +} +\arguments{ +\item{y}{The outcome variable.} + +\item{D}{The endogenous variable of interest. Can be discrete or continuous.} + +\item{X}{A (sparse) matrix of control variables.} + +\item{d}{The treatment level of interest. The default is \code{d = 1}.} + +\item{weights}{A numeric vector of length \code{nobs} specifying the weights +\eqn{\omega(X)}. If \code{weights = NULL} (the default), a vector of 1s +is used, which estimates the Average Potential Outcome (APO).} + +\item{learners}{May take one of two forms, depending on whether a +single learner or stacking with multiple learners is used for +estimation of the conditional expectation functions. +If a single learner is used, \code{learners} is a list with +two named elements: +\itemize{ +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} +} +If stacking with multiple learners is used, \code{learners} is +a list of lists, each containing three named elements: +\itemize{ +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} +\item{\code{assign_X} An optional vector of column indices +corresponding to control variables in \code{X} that +are passed to the base learner.} +} +Omission of the \code{args} element results in default +arguments being used in \code{what}. Omission of +\code{assign_X} results in inclusion of all variables in +\code{X}.} + +\item{learners_DX}{Optional argument to allow for different estimators of +\eqn{E[D|X]}. Setup is identical to \code{learners}.} + +\item{sample_folds}{Number of cross-fitting folds.} + +\item{ensemble_type}{Ensemble method to combine base learners into +final estimate of the conditional expectation functions. +Possible values are: +\itemize{ +\item{\code{"nnls"} Non-negative least squares.} +\item{\code{"nnls1"} Non-negative least squares with the +constraint that all weights sum to one.} +\item{\code{"singlebest"} Select base learner with minimum +MSPE.} +\item{\code{"ols"} Ordinary least squares.} +\item{\code{"average"} Simple average over base learners.} +} +Multiple ensemble types may be passed as a vector of strings.} + +\item{shortstack}{Boolean to use short-stacking.} + +\item{cv_folds}{Number of folds used for cross-validation in +ensemble construction.} + +\item{custom_ensemble_weights}{A numerical matrix with +user-specified ensemble weights. Each column corresponds to a +custom ensemble specification, each row corresponds to a base +learner in \code{learners} (in chronological order). Optional +column names are used to name the estimation results +corresponding the custom ensemble specification.} + +\item{custom_ensemble_weights_DX}{Optional argument to allow for different +custom ensemble weights for \code{learners_DX}. Setup is identical to +\code{custom_ensemble_weights}. Note: \code{custom_ensemble_weights} and +\code{custom_ensemble_weights_DX} must have the same number of columns.} + +\item{cluster_variable}{A vector of cluster indices.} + +\item{stratify}{Boolean for stratified cross-fitting: if \code{TRUE}, +subsamples are constructed to be balanced across treatment levels.} + +\item{trim}{Number in (0, 1) for trimming the estimated propensity scores at +\code{trim} and \code{1-trim}.} + +\item{silent}{Boolean to silence estimation updates.} + +\item{parallel}{An optional named list with parallel processing +options. When \code{NULL} (the default), computation is +sequential. Supported fields: +\describe{ +\item{\code{cores}}{Number of cores to use.} +\item{\code{export}}{Character vector of object names to +export to parallel workers (for custom learners that +reference global objects).} +\item{\code{packages}}{Character vector of additional +package names to load on workers (for custom learners +that use packages not imported by \code{ddml}).} +}} + +\item{fitted}{An optional named list of per-equation cross-fitted +predictions, typically obtained from a previous fit via +\code{fit$fitted}. When supplied (together with \code{splits}), +base learners are not re-fitted; only ensemble weights are +recomputed. This allows fast re-estimation with a different +\code{ensemble_type}. See \code{\link{ddml_plm}} for +an example.} + +\item{splits}{An optional list of sample split objects. For +\code{ddml_apo}, this must be a list with elements \code{subsamples} and +\code{cv_subsamples} (and optionally \code{subsamples_byD} and +\code{cv_subsamples_byD} for stratified splitting). Typically +obtained from a previous fit via \code{fit$splits}.} + +\item{save_crossval}{Logical indicating whether to store the inner +cross-validation residuals used for ensemble weight +computation. Default \code{TRUE}. When \code{TRUE}, subsequent +pass-through calls with data-driven ensembles (e.g., +\code{"nnls"}) reproduce per-fold weights exactly. Set to +\code{FALSE} to reduce object size at the cost of approximate +weight recomputation.} + +\item{...}{Additional arguments passed to internal methods.} +} +\value{ +\code{ddml_apo} returns an object of S3 class +\code{ddml_apo} and \code{ddml}. See \code{\link{ddml-intro}} +for the common output structure. Additional pass-through +fields: \code{learners}, \code{learners_DX}. +} +\description{ +Estimator for the average potential outcome, allowing for +custom weights \eqn{\omega(X)}. +} +\details{ +\strong{Parameter of Interest:} \code{ddml_apo} provides a +Double/Debiased Machine Learning estimator for the average potential +outcome. Under conditional unconfoundedness and overlap, the parameter +is identified by the following reduced form conditional expectation: + +\deqn{\theta_0^{\textrm{APO}} = E[\omega(X) E[Y|D=d, X]],} + +where \eqn{W \equiv (Y, D, X)} is the observed random vector and +\eqn{\omega(X)} is a known weighting function. If \eqn{\omega(X) = 1}, +this parameter corresponds to the average potential outcome +at treatment level \eqn{d}. + +\strong{Nuisance Parameters:} The nuisance parameters are +\eqn{\eta = (\ell, r)} taking true values \eqn{\ell_0(X) = E[Y|D=d, X]} and +\eqn{r_0(X) = \Pr(D=d|X)}. + +\strong{Neyman Orthogonal Score / Moment Equation:} The Neyman orthogonal score is: + +\deqn{m(W; \theta, \eta) = \left( \frac{\mathbf{1}\{D=d\} (Y - \ell(X))}{r(X)} + \ell(X) \right) \omega(X) - \theta} + +\strong{Jacobian:} + +\deqn{J = -1} + +See \code{\link{ddml-intro}} for how the influence function +and inference are derived from these components. +} +\examples{ +# Construct variables from the included Angrist & Evans (1998) data +y = AE98[, "worked"] +D = AE98[, "morekids"] +X = AE98[, c("age","agefst","black","hisp","othrace","educ")] + +# Estimate the APO for d = 1 using a single base learner, ridge. +apo_fit <- ddml_apo(y, D, X, + learners = list(what = mdl_glmnet), + sample_folds = 2, + silent = TRUE) +summary(apo_fit) + +} +\seealso{ +Other ddml estimators: +\code{\link{ddml-intro}}, +\code{\link{ddml_ate}()}, +\code{\link{ddml_attgt}()}, +\code{\link{ddml_fpliv}()}, +\code{\link{ddml_late}()}, +\code{\link{ddml_pliv}()}, +\code{\link{ddml_plm}()} +} +\concept{ddml estimators} diff --git a/man/ddml_ate.Rd b/man/ddml_ate.Rd index c32e3a3..56a9f4e 100644 --- a/man/ddml_ate.Rd +++ b/man/ddml_ate.Rd @@ -3,7 +3,7 @@ \name{ddml_ate} \alias{ddml_ate} \alias{ddml_att} -\title{Estimators of Average Treatment Effects.} +\title{Estimator for the Average Treatment Effect} \usage{ ddml_ate( y, @@ -18,10 +18,14 @@ ddml_ate( custom_ensemble_weights = NULL, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples_byD = NULL, - cv_subsamples_byD = NULL, + stratify = TRUE, trim = 0.01, - silent = FALSE + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ... ) ddml_att( @@ -37,10 +41,14 @@ ddml_att( custom_ensemble_weights = NULL, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples_byD = NULL, - cv_subsamples_byD = NULL, + stratify = TRUE, trim = 0.01, - silent = FALSE + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ... ) } \arguments{ @@ -50,44 +58,49 @@ ddml_att( \item{X}{A (sparse) matrix of control variables.} -\item{learners}{May take one of two forms, depending on whether a single -learner or stacking with multiple learners is used for estimation of the -conditional expectation functions. -If a single learner is used, \code{learners} is a list with two named -elements: +\item{learners}{May take one of two forms, depending on whether a +single learner or stacking with multiple learners is used for +estimation of the conditional expectation functions. +If a single learner is used, \code{learners} is a list with +two named elements: \itemize{ -\item{\code{what} The base learner function. The function must be -such that it predicts a named input \code{y} using a named input -\code{X}.} -\item{\code{args} Optional arguments to be passed to \code{what}.} +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} } -If stacking with multiple learners is used, \code{learners} is a list of -lists, each containing four named elements: +If stacking with multiple learners is used, \code{learners} is +a list of lists, each containing three named elements: \itemize{ -\item{\code{fun} The base learner function. The function must be -such that it predicts a named input \code{y} using a named input -\code{X}.} -\item{\code{args} Optional arguments to be passed to \code{fun}.} +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} \item{\code{assign_X} An optional vector of column indices -corresponding to control variables in \code{X} that are passed to -the base learner.} +corresponding to control variables in \code{X} that +are passed to the base learner.} } -Omission of the \code{args} element results in default arguments being -used in \code{fun}. Omission of \code{assign_X} results in inclusion of -all variables in \code{X}.} +Omission of the \code{args} element results in default +arguments being used in \code{what}. Omission of +\code{assign_X} results in inclusion of all variables in +\code{X}.} \item{learners_DX}{Optional argument to allow for different estimators of \eqn{E[D|X]}. Setup is identical to \code{learners}.} \item{sample_folds}{Number of cross-fitting folds.} -\item{ensemble_type}{Ensemble method to combine base learners into final -estimate of the conditional expectation functions. Possible values are: +\item{ensemble_type}{Ensemble method to combine base learners into +final estimate of the conditional expectation functions. +Possible values are: \itemize{ \item{\code{"nnls"} Non-negative least squares.} -\item{\code{"nnls1"} Non-negative least squares with the constraint -that all weights sum to one.} -\item{\code{"singlebest"} Select base learner with minimum MSPE.} +\item{\code{"nnls1"} Non-negative least squares with the +constraint that all weights sum to one.} +\item{\code{"singlebest"} Select base learner with minimum +MSPE.} \item{\code{"ols"} Ordinary least squares.} \item{\code{"average"} Simple average over base learners.} } @@ -95,14 +108,15 @@ Multiple ensemble types may be passed as a vector of strings.} \item{shortstack}{Boolean to use short-stacking.} -\item{cv_folds}{Number of folds used for cross-validation in ensemble -construction.} +\item{cv_folds}{Number of folds used for cross-validation in +ensemble construction.} -\item{custom_ensemble_weights}{A numerical matrix with user-specified -ensemble weights. Each column corresponds to a custom ensemble -specification, each row corresponds to a base learner in \code{learners} -(in chronological order). Optional column names are used to name the -estimation results corresponding the custom ensemble specification.} +\item{custom_ensemble_weights}{A numerical matrix with +user-specified ensemble weights. Each column corresponds to a +custom ensemble specification, each row corresponds to a base +learner in \code{learners} (in chronological order). Optional +column names are used to name the estimation results +corresponding the custom ensemble specification.} \item{custom_ensemble_weights_DX}{Optional argument to allow for different custom ensemble weights for \code{learners_DX}. Setup is identical to @@ -111,70 +125,93 @@ custom ensemble weights for \code{learners_DX}. Setup is identical to \item{cluster_variable}{A vector of cluster indices.} -\item{subsamples_byD}{List of two lists corresponding to the two treatment -levels. Each list contains vectors with sample indices for -cross-fitting.} - -\item{cv_subsamples_byD}{List of two lists, each corresponding to one of the -two treatment levels. Each of the two lists contains lists, each -corresponding to a subsample and contains vectors with subsample indices -for cross-validation.} +\item{stratify}{Boolean for stratified cross-fitting: if \code{TRUE}, +subsamples are constructed to be balanced across treatment levels.} \item{trim}{Number in (0, 1) for trimming the estimated propensity scores at \code{trim} and \code{1-trim}.} \item{silent}{Boolean to silence estimation updates.} -} -\value{ -\code{ddml_ate} and \code{ddml_att} return an object of S3 class -\code{ddml_ate} and \code{ddml_att}, respectively. An object of class -\code{ddml_ate} or \code{ddml_att} is a list containing -the following components: + +\item{parallel}{An optional named list with parallel processing +options. When \code{NULL} (the default), computation is +sequential. Supported fields: \describe{ -\item{\code{ate} / \code{att}}{A vector with the average treatment -effect / average treatment effect on the treated estimates.} -\item{\code{weights}}{A list of matrices, providing the weight -assigned to each base learner (in chronological order) by the -ensemble procedure.} -\item{\code{mspe}}{A list of matrices, providing the MSPE of each -base learner (in chronological order) computed by the -cross-validation step in the ensemble construction.} -\item{\code{psi_a}, \code{psi_b}}{Matrices needed for the computation -of scores. Used in \code{\link[=summary.ddml_ate]{summary.ddml_ate()}} or -\code{\link[=summary.ddml_att]{summary.ddml_att()}}.} -\item{\code{oos_pred}}{List of matrices, providing the reduced form -predicted values.} -\item{\code{learners},\code{learners_DX},\code{cluster_variable}, -\code{subsamples_D0},\code{subsamples_D1}, -\code{cv_subsamples_list_D0},\code{cv_subsamples_list_D1}, -\code{ensemble_type}}{Pass-through of -selected user-provided arguments. See above.} +\item{\code{cores}}{Number of cores to use.} +\item{\code{export}}{Character vector of object names to +export to parallel workers (for custom learners that +reference global objects).} +\item{\code{packages}}{Character vector of additional +package names to load on workers (for custom learners +that use packages not imported by \code{ddml}).} +}} + +\item{fitted}{An optional named list of per-equation cross-fitted +predictions, typically obtained from a previous fit via +\code{fit$fitted}. When supplied (together with \code{splits}), +base learners are not re-fitted; only ensemble weights are +recomputed. This allows fast re-estimation with a different +\code{ensemble_type}. See \code{\link{ddml_plm}} for +an example.} + +\item{splits}{An optional list of sample split objects. For +\code{ddml_ate}/\code{ddml_att}, recommended keys are +\code{subsamples}, \code{subsamples_byD}, \code{cv_subsamples}, +and \code{cv_subsamples_byD}.} + +\item{save_crossval}{Logical indicating whether to store the inner +cross-validation residuals used for ensemble weight +computation. Default \code{TRUE}. When \code{TRUE}, subsequent +pass-through calls with data-driven ensembles (e.g., +\code{"nnls"}) reproduce per-fold weights exactly. Set to +\code{FALSE} to reduce object size at the cost of approximate +weight recomputation.} + +\item{...}{Additional arguments passed to internal methods.} } +\value{ +\code{ddml_ate} and \code{ddml_att} return objects of S3 +class \code{ddml_ate}/\code{ddml_att} and \code{ddml}. See +\code{\link{ddml-intro}} for the common output structure. +Additional pass-through fields: \code{learners}, +\code{learners_DX}. } \description{ -Estimators of the average treatment effect and the average +Estimator for the average treatment effect and the average treatment effect on the treated. } \details{ -\code{ddml_ate} and \code{ddml_att} provide double/debiased machine -learning estimators for the average treatment effect and the average -treatment effect on the treated, respectively, in the interactive model -given by +\strong{Parameter of Interest:} \code{ddml_ate} and \code{ddml_att} provide +Double/Debiased Machine Learning estimators for the average treatment +effect and the average treatment effect on the treated, respectively. +Under conditional unconfoundedness and overlap, the parameters +are identified by the following reduced form parameters: + +\deqn{\theta_0^{\textrm{ATE}} = E[E[Y|D=1, X] - E[Y|D=0, X]]} + +and the average treatment effect on the treated (ATT) is defined as + +\deqn{\theta_0^{\textrm{ATT}} = E[Y|D=1] - E[E[Y|D=0, X]|D = 1].} + +where \eqn{W \equiv (Y, D, X)} is the observed random vector. -\eqn{Y = g_0(D, X) + U,} +\strong{Neyman Orthogonal Score:} The Neyman orthogonal scores are: -where \eqn{(Y, D, X, U)} is a random vector such that -\eqn{\operatorname{supp} D = \{0,1\}}, \eqn{E[U\vert D, X] = 0}, and -\eqn{\Pr(D=1\vert X) \in (0, 1)} with probability 1, -and \eqn{g_0} is an unknown nuisance function. +\deqn{m^{\textrm{ATE}}(W; \theta, \eta) = \frac{D(Y - \ell_1(X))}{r(X)} - \frac{(1-D)(Y-\ell_0(X))}{1-r(X)} + \ell_1(X) - \ell_0(X) - \theta} -In this model, the average treatment effect is defined as +\deqn{m^{\textrm{ATT}}(W; \theta, \eta) = \frac{D(Y - \ell_0(X))}{\pi} - \frac{r(X)(1-D)(Y-\ell_0(X))}{\pi(1-r(X))} - \frac{D}{\pi}\theta} -\eqn{\theta_0^{\textrm{ATE}} \equiv E[g_0(1, X) - g_0(0, X)]}. +where the nuisance parameters are \eqn{\eta = (\ell_0, \ell_1, r, \pi)} taking true values +\eqn{\ell_{d,0}(X) = E[Y|D=d, X]}, \eqn{r_0(X) = \Pr(D=1|X)}, and \eqn{\pi_0 = \Pr(D=1)}. -and the average treatment effect on the treated is defined as +\strong{Jacobian:} -\eqn{\theta_0^{\textrm{ATT}} \equiv E[g_0(1, X) - g_0(0, X)\vert D = 1]}. +\deqn{J^{\textrm{ATE}} = -1} + +\deqn{J^{\textrm{ATT}} = -1} + +See \code{\link{ddml-intro}} for how the influence function +and inference are derived from these components. } \examples{ # Construct variables from the included Angrist & Evans (1998) data @@ -196,9 +233,9 @@ summary(ate_fit) weights_everylearner <- diag(1, 3) colnames(weights_everylearner) <- c("mdl:ols", "mdl:lasso", "mdl:ridge") ate_fit <- ddml_ate(y, D, X, - learners = list(list(fun = ols), - list(fun = mdl_glmnet), - list(fun = mdl_glmnet, + learners = list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_glmnet, args = list(alpha = 0))), ensemble_type = 'nnls', custom_ensemble_weights = weights_everylearner, @@ -207,20 +244,14 @@ ate_fit <- ddml_ate(y, D, X, silent = TRUE) summary(ate_fit) } -\references{ -Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C B, Newey W, -Robins J (2018). "Double/debiased machine learning for treatment and -structural parameters." The Econometrics Journal, 21(1), C1-C68. - -Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. -} \seealso{ -\code{\link[=summary.ddml_ate]{summary.ddml_ate()}}, \code{\link[=summary.ddml_att]{summary.ddml_att()}} - -Other ddml: +Other ddml estimators: +\code{\link{ddml-intro}}, +\code{\link{ddml_apo}()}, +\code{\link{ddml_attgt}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, \code{\link{ddml_plm}()} } -\concept{ddml} +\concept{ddml estimators} diff --git a/man/ddml_attgt.Rd b/man/ddml_attgt.Rd new file mode 100644 index 0000000..a1b2978 --- /dev/null +++ b/man/ddml_attgt.Rd @@ -0,0 +1,262 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_attgt.R +\name{ddml_attgt} +\alias{ddml_attgt} +\title{Estimator for Group-Time Average Treatment Effects} +\usage{ +ddml_attgt( + y, + X = NULL, + t, + G, + learners, + learners_qX = learners, + sample_folds = 10, + ensemble_type = "nnls", + shortstack = FALSE, + cv_folds = 10, + custom_ensemble_weights = NULL, + custom_ensemble_weights_qX = custom_ensemble_weights, + cluster_variable = seq_len(nrow(as.matrix(y))), + trim = 0.01, + control_group = c("notyettreated", "nevertreated"), + anticipation = 0, + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ... +) +} +\arguments{ +\item{y}{An \eqn{n \times T} numeric matrix of outcomes. +Row \eqn{i} corresponds to unit \eqn{i}, column \eqn{j} +to time period \code{t[j]}.} + +\item{X}{An \eqn{n \times p} matrix of time-invariant covariates, +or \code{NULL}.} + +\item{t}{A numeric vector of length \eqn{T} giving the time +period labels (must match columns of \code{y}).} + +\item{G}{A numeric vector of length \eqn{n}. Entry \eqn{i} is the +first treatment period for unit \eqn{i}. Use \code{0} or +\code{Inf} for never-treated units.} + +\item{learners}{May take one of two forms, depending on whether a +single learner or stacking with multiple learners is used for +estimation of the conditional expectation functions. +If a single learner is used, \code{learners} is a list with +two named elements: +\itemize{ +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} +} +If stacking with multiple learners is used, \code{learners} is +a list of lists, each containing three named elements: +\itemize{ +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} +\item{\code{assign_X} An optional vector of column indices +corresponding to control variables in \code{X} that +are passed to the base learner.} +} +Omission of the \code{args} element results in default +arguments being used in \code{what}. Omission of +\code{assign_X} results in inclusion of all variables in +\code{X}.} + +\item{learners_qX}{Optional argument to allow for different +estimators of the cell-level propensity score +\eqn{q^{(g,t)}(X)}. Setup is identical to +\code{learners}.} + +\item{sample_folds}{Number of cross-fitting folds.} + +\item{ensemble_type}{Ensemble method to combine base learners into +final estimate of the conditional expectation functions. +Possible values are: +\itemize{ +\item{\code{"nnls"} Non-negative least squares.} +\item{\code{"nnls1"} Non-negative least squares with the +constraint that all weights sum to one.} +\item{\code{"singlebest"} Select base learner with minimum +MSPE.} +\item{\code{"ols"} Ordinary least squares.} +\item{\code{"average"} Simple average over base learners.} +} +Multiple ensemble types may be passed as a vector of strings.} + +\item{shortstack}{Boolean to use short-stacking.} + +\item{cv_folds}{Number of folds used for cross-validation in +ensemble construction.} + +\item{custom_ensemble_weights}{A numerical matrix with +user-specified ensemble weights. Each column corresponds to a +custom ensemble specification, each row corresponds to a base +learner in \code{learners} (in chronological order). Optional +column names are used to name the estimation results +corresponding the custom ensemble specification.} + +\item{custom_ensemble_weights_qX}{Optional argument to allow for +different custom ensemble weights for \code{learners_qX}. +Setup is identical to \code{custom_ensemble_weights}.} + +\item{cluster_variable}{A vector of cluster indices.} + +\item{trim}{Number in (0, 1) for trimming the estimated +propensity scores at \code{trim} and \code{1-trim}.} + +\item{control_group}{Character. \code{"notyettreated"} (default) +uses never-treated and not-yet-treated units as controls. +\code{"nevertreated"} uses only never-treated units.} + +\item{anticipation}{Non-negative integer. Number of periods before +treatment where anticipation effects may occur. Default 0.} + +\item{silent}{Boolean to silence estimation updates.} + +\item{parallel}{An optional named list with parallel processing +options. When \code{NULL} (the default), computation is +sequential. Supported fields: +\describe{ +\item{\code{cores}}{Number of cores to use.} +\item{\code{export}}{Character vector of object names to +export to parallel workers (for custom learners that +reference global objects).} +\item{\code{packages}}{Character vector of additional +package names to load on workers (for custom learners +that use packages not imported by \code{ddml}).} +}} + +\item{fitted}{An optional named list of per-equation cross-fitted +predictions, typically obtained from a previous fit via +\code{fit$fitted}. When supplied (together with \code{splits}), +base learners are not re-fitted; only ensemble weights are +recomputed. This allows fast re-estimation with a different +\code{ensemble_type}. See \code{\link{ddml_plm}} for +an example.} + +\item{splits}{An optional list of sample split objects, typically +obtained from a previous fit via \code{fit$splits}. Must be +supplied when \code{fitted} is provided. Can also be used +standalone to provide pre-computed sample folds.} + +\item{save_crossval}{Logical indicating whether to store the inner +cross-validation residuals used for ensemble weight +computation. Default \code{TRUE}. When \code{TRUE}, subsequent +pass-through calls with data-driven ensembles (e.g., +\code{"nnls"}) reproduce per-fold weights exactly. Set to +\code{FALSE} to reduce object size at the cost of approximate +weight recomputation.} + +\item{...}{Additional arguments passed to internal methods.} +} +\value{ +\code{ddml_attgt} returns an object of S3 class +\code{ddml_attgt} and \code{ddml}. See \code{\link{ddml-intro}} +for the common output structure. Additional pass-through +fields: \code{learners}, \code{learners_qX}, +\code{cell_info}, \code{control_group}, \code{anticipation}. +} +\description{ +Estimator for group-time average treatment effects +on the treated (GT-ATT) in staggered Difference-in-Differences +designs. +} +\details{ +\strong{Parameter of Interest:} \code{ddml_attgt} provides a +Double/Debiased Machine Learning estimator for the group-time +average treatment effects on the treated (GT-ATT) in the +staggered adoption model. For each group \eqn{g} and time +period \eqn{t}, define the differenced outcome +\eqn{\Delta_g Y_{i,t} = Y_{i,t} - Y_{i,g^*}} where +\eqn{g^*} is the universal base period. The GT-ATT is: + +\deqn{\theta_0^{(g,t)} = E[\Delta_g Y_{i,t} | G_i = g] + - E[E[\Delta_g Y_{i,t} | X_i, G_i \ne g, G_i > t] | G_i = g]} + +where \eqn{W_i \equiv (Y_{i,1}, \dots, Y_{i,T}, G_i, X_i)} is the +observed random vector. + +\strong{Neyman Orthogonal Score:} The Neyman orthogonal score +is: + +\deqn{m^{(g,t)}(W_i; \theta, \eta) = + \frac{\mathbf{1}\{G_i = g\} (\Delta_g Y_{i,t} + - \ell^{(g,t)}(X_i))}{\pi^g} + - \frac{q^{(g,t)}(X_i) \mathbf{1}\{G_i \ne g\} + \mathbf{1}\{G_i > t\} (\Delta_g Y_{i,t} + - \ell^{(g,t)}(X_i))}{\pi^g (1 - q^{(g,t)}(X_i))} + - \frac{\mathbf{1}\{G_i = g\}}{\pi^g} \theta} + +where the nuisance parameters are +\eqn{\eta = (\ell, q, \pi)} taking true values +\eqn{\ell_0^{(g,t)}(X) = E[\Delta_g Y_{i,t} \mid + G_i \ne g, G_i > t, X_i]}, +\eqn{q_0^{(g,t)}(X) = \Pr(G_i = g \mid X_i, + \{G_i = g\} \cup \{G_i > t\})}, +and \eqn{\pi_0^g = \Pr(G_i = g)}. + +\strong{Jacobian:} + +\deqn{J^{(g,t)} = -1} + +See \code{\link{ddml-intro}} for how the influence function +and inference are derived from these components. +} +\examples{ +\donttest{ +set.seed(42) +n <- 200; T_ <- 4 +X <- matrix(rnorm(n * 2), n, 2) +G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) +y <- matrix(rnorm(n * T_), n, T_) +# Add treatment effect for treated units +for (i in seq_len(n)) { + if (is.finite(G[i])) { + for (j in seq_len(T_)) { + if (j >= G[i]) y[i, j] <- y[i, j] + 1 + } + } +} +fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) +summary(fit) +} +} +\references{ +Callaway B, Sant'Anna P H C (2021). "Difference-in-Differences +with multiple time periods." Journal of Econometrics, +225(2), 200-230. + +Chang N-C (2020). "Double/debiased machine learning for +difference-in-differences models." Econometrics Journal, +23(2), 177-191. + +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, +Wiemann T (2026). "An Introduction to Double/Debiased Machine +Learning." Journal of Economic Literature, forthcoming. +} +\seealso{ +Other ddml estimators: +\code{\link{ddml-intro}}, +\code{\link{ddml_apo}()}, +\code{\link{ddml_ate}()}, +\code{\link{ddml_fpliv}()}, +\code{\link{ddml_late}()}, +\code{\link{ddml_pliv}()}, +\code{\link{ddml_plm}()} +} +\concept{ddml estimators} diff --git a/man/ddml_fpliv.Rd b/man/ddml_fpliv.Rd index 32fdac0..153409e 100644 --- a/man/ddml_fpliv.Rd +++ b/man/ddml_fpliv.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ddml_fpliv.R \name{ddml_fpliv} \alias{ddml_fpliv} -\title{Estimator for the Flexible Partially Linear IV Model.} +\title{Estimator for the Flexible Partially Linear IV Coefficient} \usage{ ddml_fpliv( y, @@ -16,14 +16,16 @@ ddml_fpliv( ensemble_type = "nnls", shortstack = FALSE, cv_folds = 10, - enforce_LIE = TRUE, custom_ensemble_weights = NULL, custom_ensemble_weights_DXZ = custom_ensemble_weights, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples = NULL, - cv_subsamples_list = NULL, - silent = FALSE + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ... ) } \arguments{ @@ -35,48 +37,50 @@ ddml_fpliv( \item{X}{A (sparse) matrix of control variables.} -\item{learners}{May take one of two forms, depending on whether a single -learner or stacking with multiple learners is used for estimation of the -conditional expectation functions. -If a single learner is used, \code{learners} is a list with two named -elements: +\item{learners}{May take one of two forms, depending on whether a +single learner or stacking with multiple learners is used for +estimation of the conditional expectation functions. +If a single learner is used, \code{learners} is a list with +two named elements: \itemize{ -\item{\code{what} The base learner function. The function must be -such that it predicts a named input \code{y} using a named input -\code{X}.} -\item{\code{args} Optional arguments to be passed to \code{what}.} +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} } -If stacking with multiple learners is used, \code{learners} is a list of -lists, each containing four named elements: +If stacking with multiple learners is used, \code{learners} is +a list of lists, each containing three named elements: \itemize{ -\item{\code{fun} The base learner function. The function must be -such that it predicts a named input \code{y} using a named input -\code{X}.} -\item{\code{args} Optional arguments to be passed to \code{fun}.} +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} \item{\code{assign_X} An optional vector of column indices -corresponding to control variables in \code{X} that are passed to -the base learner.} -\item{\code{assign_Z} An optional vector of column indices -corresponding to instruments in \code{Z} that are passed to the -base learner.} +corresponding to control variables in \code{X} that +are passed to the base learner.} } -Omission of the \code{args} element results in default arguments being -used in \code{fun}. Omission of \code{assign_X} (and/or \code{assign_Z}) -results in inclusion of all variables in \code{X} (and/or \code{Z}).} +Omission of the \code{args} element results in default +arguments being used in \code{what}. Omission of +\code{assign_X} results in inclusion of all variables in +\code{X}.} \item{learners_DXZ, learners_DX}{Optional arguments to allow for different -estimators of \eqn{E[D \vert X, Z]}, \eqn{E[D \vert X]}. Setup is +base learners for estimation of \eqn{E[D \vert X, Z]}, \eqn{E[D \vert X]}. Setup is identical to \code{learners}.} \item{sample_folds}{Number of cross-fitting folds.} -\item{ensemble_type}{Ensemble method to combine base learners into final -estimate of the conditional expectation functions. Possible values are: +\item{ensemble_type}{Ensemble method to combine base learners into +final estimate of the conditional expectation functions. +Possible values are: \itemize{ \item{\code{"nnls"} Non-negative least squares.} -\item{\code{"nnls1"} Non-negative least squares with the constraint -that all weights sum to one.} -\item{\code{"singlebest"} Select base learner with minimum MSPE.} +\item{\code{"nnls1"} Non-negative least squares with the +constraint that all weights sum to one.} +\item{\code{"singlebest"} Select base learner with minimum +MSPE.} \item{\code{"ols"} Ordinary least squares.} \item{\code{"average"} Simple average over base learners.} } @@ -84,17 +88,15 @@ Multiple ensemble types may be passed as a vector of strings.} \item{shortstack}{Boolean to use short-stacking.} -\item{cv_folds}{Number of folds used for cross-validation in ensemble -construction.} +\item{cv_folds}{Number of folds used for cross-validation in +ensemble construction.} -\item{enforce_LIE}{Indicator equal to 1 if the law of iterated expectations -is enforced in the first stage.} - -\item{custom_ensemble_weights}{A numerical matrix with user-specified -ensemble weights. Each column corresponds to a custom ensemble -specification, each row corresponds to a base learner in \code{learners} -(in chronological order). Optional column names are used to name the -estimation results corresponding the custom ensemble specification.} +\item{custom_ensemble_weights}{A numerical matrix with +user-specified ensemble weights. Each column corresponds to a +custom ensemble specification, each row corresponds to a base +learner in \code{learners} (in chronological order). Optional +column names are used to name the estimation results +corresponding the custom ensemble specification.} \item{custom_ensemble_weights_DXZ, custom_ensemble_weights_DX}{Optional arguments to allow for different @@ -106,48 +108,78 @@ have the same number of columns.} \item{cluster_variable}{A vector of cluster indices.} -\item{subsamples}{List of vectors with sample indices for cross-fitting.} - -\item{cv_subsamples_list}{List of lists, each corresponding to a subsample -containing vectors with subsample indices for cross-validation.} - \item{silent}{Boolean to silence estimation updates.} + +\item{parallel}{An optional named list with parallel processing +options. When \code{NULL} (the default), computation is +sequential. Supported fields: +\describe{ +\item{\code{cores}}{Number of cores to use.} +\item{\code{export}}{Character vector of object names to +export to parallel workers (for custom learners that +reference global objects).} +\item{\code{packages}}{Character vector of additional +package names to load on workers (for custom learners +that use packages not imported by \code{ddml}).} +}} + +\item{fitted}{An optional named list of per-equation cross-fitted +predictions, typically obtained from a previous fit via +\code{fit$fitted}. When supplied (together with \code{splits}), +base learners are not re-fitted; only ensemble weights are +recomputed. This allows fast re-estimation with a different +\code{ensemble_type}. See \code{\link{ddml_plm}} for +an example.} + +\item{splits}{An optional list of sample split objects, typically +obtained from a previous fit via \code{fit$splits}. Must be +supplied when \code{fitted} is provided. Can also be used +standalone to provide pre-computed sample folds.} + +\item{save_crossval}{Logical indicating whether to store the inner +cross-validation residuals used for ensemble weight +computation. Default \code{TRUE}. When \code{TRUE}, subsequent +pass-through calls with data-driven ensembles (e.g., +\code{"nnls"}) reproduce per-fold weights exactly. Set to +\code{FALSE} to reduce object size at the cost of approximate +weight recomputation.} + +\item{...}{Additional arguments passed to internal methods.} } \value{ \code{ddml_fpliv} returns an object of S3 class -\code{ddml_fpliv}. An object of class \code{ddml_fpliv} is a list -containing the following components: -\describe{ -\item{\code{coef}}{A vector with the \eqn{\theta_0} estimates.} -\item{\code{weights}}{A list of matrices, providing the weight -assigned to each base learner (in chronological order) by the -ensemble procedure.} -\item{\code{mspe}}{A list of matrices, providing the MSPE of each -base learner (in chronological order) computed by the -cross-validation step in the ensemble construction.} -\item{\code{iv_fit}}{Object of class \code{ivreg} from the IV -regression of \eqn{Y - \hat{E}[Y\vert X]} on -\eqn{D - \hat{E}[D\vert X]} using -\eqn{\hat{E}[D\vert X,Z] - \hat{E}[D\vert X]} as the instrument.} -\item{\code{learners},\code{learners_DX},\code{learners_DXZ}, -\code{cluster_variable},\code{subsamples}, -\code{cv_subsamples_list},\code{ensemble_type}}{Pass-through of -selected user-provided arguments. See above.} -} +\code{ddml_fpliv} and \code{ddml}. See +\code{\link{ddml-intro}} for the common output structure. +Additional pass-through fields: \code{learners}, +\code{learners_DXZ}, \code{learners_DX}. } \description{ -Estimator for the flexible partially linear IV model. +Estimator for the flexible partially linear IV coefficient. } \details{ -\code{ddml_fpliv} provides a double/debiased machine learning -estimator for the parameter of interest \eqn{\theta_0} in the partially -linear IV model given by +\strong{Parameter of Interest:} \code{ddml_fpliv} provides a Double/Debiased +Machine Learning estimator for the flexible partially linear instrumental +variable (IV) coefficient \eqn{\theta_0}, defined by the partially linear +IV model: -\eqn{Y = \theta_0D + g_0(X) + U,} +\deqn{Y = \theta_0 D + g_0(X) + \varepsilon, \quad E[\varepsilon|X, Z] = 0,} -where \eqn{(Y, D, X, Z, U)} is a random vector such that -\eqn{E[U\vert X, Z] = 0} and \eqn{E[Var(E[D\vert X, Z]\vert X)] \neq 0}, -and \eqn{g_0} is an unknown nuisance function. +where \eqn{W \equiv (Y, D, X, Z, \varepsilon)} is a random vector such that +\eqn{E[Var(E[D|X, Z]|X)] \neq 0}, and \eqn{g_0(X)} is an unknown nuisance function. + +\strong{Neyman Orthogonal Score:} The Neyman orthogonal score is: + +\deqn{m(W; \theta, \eta) = [(Y - \ell(X)) - \theta(D - r(X))](v(X, Z) - r(X))} + +where the nuisance parameters are \eqn{\eta = (\ell, r, v)} taking +true values \eqn{\ell_0(X) = E[Y|X]}, \eqn{r_0(X) = E[D|X]}, and \eqn{v_0(X, Z) = E[D|X, Z]}. + +\strong{Jacobian:} + +\deqn{J = -E[(D - r(X))(v(X, Z) - r(X))^\top]} + +See \code{\link{ddml-intro}} for how the influence function +and inference are derived from these components. } \examples{ # Construct variables from the included Angrist & Evans (1998) data @@ -156,7 +188,7 @@ D = AE98[, "morekids"] Z = AE98[, "samesex", drop = FALSE] X = AE98[, c("age","agefst","black","hisp","othrace","educ")] -# Estimate the partially linear IV model using a single base learner: Ridge. +# Estimate the partially linear IV model using a single base learner, ridge. fpliv_fit <- ddml_fpliv(y, D, Z, X, learners = list(what = mdl_glmnet, args = list(alpha = 0)), @@ -164,23 +196,14 @@ fpliv_fit <- ddml_fpliv(y, D, Z, X, silent = TRUE) summary(fpliv_fit) } -\references{ -Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and -Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. - -Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C B, Newey W, -Robins J (2018). "Double/debiased machine learning for treatment and -structural parameters." The Econometrics Journal, 21(1), C1-C68. - -Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. -} \seealso{ -\code{\link[=summary.ddml_fpliv]{summary.ddml_fpliv()}}, \code{\link[AER:ivreg]{AER::ivreg()}} - -Other ddml: +Other ddml estimators: +\code{\link{ddml-intro}}, +\code{\link{ddml_apo}()}, \code{\link{ddml_ate}()}, +\code{\link{ddml_attgt}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, \code{\link{ddml_plm}()} } -\concept{ddml} +\concept{ddml estimators} diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index b507811..e3ccaea 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ddml_late.R \name{ddml_late} \alias{ddml_late} -\title{Estimator of the Local Average Treatment Effect.} +\title{Estimator for the Local Average Treatment Effect} \usage{ ddml_late( y, @@ -20,63 +20,69 @@ ddml_late( custom_ensemble_weights_DXZ = custom_ensemble_weights, custom_ensemble_weights_ZX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples_byZ = NULL, - cv_subsamples_byZ = NULL, + stratify = TRUE, trim = 0.01, - silent = FALSE + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ... ) } \arguments{ \item{y}{The outcome variable.} -\item{D}{The binary endogenous variable of interest.} +\item{D}{A matrix of endogenous variables.} \item{Z}{Binary instrumental variable.} \item{X}{A (sparse) matrix of control variables.} -\item{learners}{May take one of two forms, depending on whether a single -learner or stacking with multiple learners is used for estimation of the -conditional expectation functions. -If a single learner is used, \code{learners} is a list with two named -elements: +\item{learners}{May take one of two forms, depending on whether a +single learner or stacking with multiple learners is used for +estimation of the conditional expectation functions. +If a single learner is used, \code{learners} is a list with +two named elements: \itemize{ -\item{\code{what} The base learner function. The function must be -such that it predicts a named input \code{y} using a named input -\code{X}.} -\item{\code{args} Optional arguments to be passed to \code{what}.} +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} } -If stacking with multiple learners is used, \code{learners} is a list of -lists, each containing four named elements: +If stacking with multiple learners is used, \code{learners} is +a list of lists, each containing three named elements: \itemize{ -\item{\code{fun} The base learner function. The function must be -such that it predicts a named input \code{y} using a named input -\code{X}.} -\item{\code{args} Optional arguments to be passed to \code{fun}.} +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} \item{\code{assign_X} An optional vector of column indices -corresponding to control variables in \code{X} that are passed to -the base learner.} -\item{\code{assign_Z} An optional vector of column indices -corresponding to instruments in \code{Z} that are passed to the -base learner.} +corresponding to control variables in \code{X} that +are passed to the base learner.} } -Omission of the \code{args} element results in default arguments being -used in \code{fun}. Omission of \code{assign_X} (and/or \code{assign_Z}) -results in inclusion of all variables in \code{X} (and/or \code{Z}).} +Omission of the \code{args} element results in default +arguments being used in \code{what}. Omission of +\code{assign_X} results in inclusion of all variables in +\code{X}.} \item{learners_DXZ, learners_ZX}{Optional arguments to allow for different -estimators of \eqn{E[D \vert X, Z]}, \eqn{E[Z \vert X]}. Setup is +base learners for estimation of \eqn{E[D \vert X, Z]}, \eqn{E[Z \vert X]}. Setup is identical to \code{learners}.} \item{sample_folds}{Number of cross-fitting folds.} -\item{ensemble_type}{Ensemble method to combine base learners into final -estimate of the conditional expectation functions. Possible values are: +\item{ensemble_type}{Ensemble method to combine base learners into +final estimate of the conditional expectation functions. +Possible values are: \itemize{ \item{\code{"nnls"} Non-negative least squares.} -\item{\code{"nnls1"} Non-negative least squares with the constraint -that all weights sum to one.} -\item{\code{"singlebest"} Select base learner with minimum MSPE.} +\item{\code{"nnls1"} Non-negative least squares with the +constraint that all weights sum to one.} +\item{\code{"singlebest"} Select base learner with minimum +MSPE.} \item{\code{"ols"} Ordinary least squares.} \item{\code{"average"} Simple average over base learners.} } @@ -84,14 +90,15 @@ Multiple ensemble types may be passed as a vector of strings.} \item{shortstack}{Boolean to use short-stacking.} -\item{cv_folds}{Number of folds used for cross-validation in ensemble -construction.} +\item{cv_folds}{Number of folds used for cross-validation in +ensemble construction.} -\item{custom_ensemble_weights}{A numerical matrix with user-specified -ensemble weights. Each column corresponds to a custom ensemble -specification, each row corresponds to a base learner in \code{learners} -(in chronological order). Optional column names are used to name the -estimation results corresponding the custom ensemble specification.} +\item{custom_ensemble_weights}{A numerical matrix with +user-specified ensemble weights. Each column corresponds to a +custom ensemble specification, each row corresponds to a base +learner in \code{learners} (in chronological order). Optional +column names are used to name the estimation results +corresponding the custom ensemble specification.} \item{custom_ensemble_weights_DXZ, custom_ensemble_weights_ZX}{Optional arguments to allow for different @@ -103,66 +110,88 @@ have the same number of columns.} \item{cluster_variable}{A vector of cluster indices.} -\item{subsamples_byZ}{List of two lists corresponding to the two instrument -levels. Each list contains vectors with sample indices for -cross-fitting.} - -\item{cv_subsamples_byZ}{List of two lists, each corresponding to one of the -two instrument levels. Each of the two lists contains lists, each -corresponding to a subsample and contains vectors with subsample indices -for cross-validation.} +\item{stratify}{Boolean for stratified cross-fitting: if \code{TRUE}, +subsamples are constructed to be balanced across treatment levels.} \item{trim}{Number in (0, 1) for trimming the estimated propensity scores at \code{trim} and \code{1-trim}.} \item{silent}{Boolean to silence estimation updates.} + +\item{parallel}{An optional named list with parallel processing +options. When \code{NULL} (the default), computation is +sequential. Supported fields: +\describe{ +\item{\code{cores}}{Number of cores to use.} +\item{\code{export}}{Character vector of object names to +export to parallel workers (for custom learners that +reference global objects).} +\item{\code{packages}}{Character vector of additional +package names to load on workers (for custom learners +that use packages not imported by \code{ddml}).} +}} + +\item{fitted}{An optional named list of per-equation cross-fitted +predictions, typically obtained from a previous fit via +\code{fit$fitted}. When supplied (together with \code{splits}), +base learners are not re-fitted; only ensemble weights are +recomputed. This allows fast re-estimation with a different +\code{ensemble_type}. See \code{\link{ddml_plm}} for +an example.} + +\item{splits}{An optional list of sample split objects. For +\code{ddml_late}, recommended keys are \code{subsamples}, +\code{subsamples_byZ}, \code{cv_subsamples}, and +\code{cv_subsamples_byZ}.} + +\item{save_crossval}{Logical indicating whether to store the inner +cross-validation residuals used for ensemble weight +computation. Default \code{TRUE}. When \code{TRUE}, subsequent +pass-through calls with data-driven ensembles (e.g., +\code{"nnls"}) reproduce per-fold weights exactly. Set to +\code{FALSE} to reduce object size at the cost of approximate +weight recomputation.} + +\item{...}{Additional arguments passed to internal methods.} } \value{ \code{ddml_late} returns an object of S3 class -\code{ddml_late}. An object of class \code{ddml_late} is a list -containing the following components: -\describe{ -\item{\code{late}}{A vector with the average treatment effect -estimates.} -\item{\code{weights}}{A list of matrices, providing the weight -assigned to each base learner (in chronological order) by the -ensemble procedure.} -\item{\code{mspe}}{A list of matrices, providing the MSPE of each -base learner (in chronological order) computed by the -cross-validation step in the ensemble construction.} -\item{\code{psi_a}, \code{psi_b}}{Matrices needed for the computation -of scores. Used in \code{\link[=summary.ddml_late]{summary.ddml_late()}}.} -\item{\code{oos_pred}}{List of matrices, providing the reduced form -predicted values.} -\item{\code{learners},\code{learners_DXZ},\code{learners_ZX}, -\code{cluster_variable},\code{subsamples_Z0}, -\code{subsamples_Z1},\code{cv_subsamples_list_Z0}, -\code{cv_subsamples_list_Z1},\code{ensemble_type}}{Pass-through -of selected user-provided arguments. See above.} -} +\code{ddml_late} and \code{ddml}. See +\code{\link{ddml-intro}} for the common output structure. +Additional pass-through fields: \code{learners}, +\code{learners_DXZ}, \code{learners_ZX}. } \description{ -Estimator of the local average treatment effect. +Estimator for the local average treatment effect. } \details{ -\code{ddml_late} provides a double/debiased machine learning -estimator for the local average treatment effect in the interactive model -given by +\strong{Parameter of Interest:} \code{ddml_late} provides a +Double/Debiased Machine Learning estimator for the local average +treatment effect. Under the standard instrumental variable assumptions +(conditional independence, exclusion restriction, relevance, and +monotonicity) with a binary instrument \eqn{Z} and a binary treatment +\eqn{D}, the parameter is identified by the following reduced form +parameter: + +\deqn{\theta_0^{\textrm{LATE}} = \frac{E[E[Y|Z=1, X] - E[Y|Z=0, X]]}{E[E[D|Z=1, X] - E[D|Z=0, X]]}} -\eqn{Y = g_0(D, X) + U,} +where \eqn{W \equiv (Y, D, X, Z)} is the observed random vector. -where \eqn{(Y, D, X, Z, U)} is a random vector such that -\eqn{\operatorname{supp} D = \operatorname{supp} Z = \{0,1\}}, -\eqn{E[U\vert X, Z] = 0}, \eqn{E[Var(E[D\vert X, Z]\vert X)] \neq 0}, -\eqn{\Pr(Z=1\vert X) \in (0, 1)} with probability 1, -\eqn{p_0(1, X) \geq p_0(0, X)} with probability 1 where -\eqn{p_0(Z, X) \equiv \Pr(D=1\vert Z, X)}, and -\eqn{g_0} is an unknown nuisance function. +\strong{Nuisance Parameters:} The nuisance parameters are +\eqn{\eta = (\ell_0, \ell_1, r_0, r_1, p)} taking true values +\eqn{\ell_{z,0}(X) = E[Y|Z=z, X]}, \eqn{r_{z,0}(X) = E[D|Z=z, X]}, +and \eqn{p_0(X) = \Pr(Z=1|X)}. -In this model, the local average treatment effect is defined as +\strong{Neyman Orthogonal Score / Moment Equation:} The Neyman orthogonal score is: -\eqn{\theta_0^{\textrm{LATE}} \equiv - E[g_0(1, X) - g_0(0, X)\vert p_0(1, X) > p(0, X)]}. +\deqn{m(W; \theta, \eta) = \frac{Z(Y - \ell_1(X))}{p(X)} - \frac{(1-Z)(Y-\ell_0(X))}{1-p(X)} + \ell_1(X) - \ell_0(X) - \theta\left(\frac{Z(D - r_1(X))}{p(X)} - \frac{(1-Z)(D-r_0(X))}{1-p(X)} + r_1(X) - r_0(X)\right)} + +\strong{Jacobian:} + +\deqn{J = -E[r_1(X) - r_0(X)]} + +See \code{\link{ddml-intro}} for how the influence function +and inference are derived from these components. } \examples{ # Construct variables from the included Angrist & Evans (1998) data @@ -180,15 +209,16 @@ late_fit <- ddml_late(y, D, Z, X, silent = TRUE) summary(late_fit) +\donttest{ # Estimate the local average treatment effect using short-stacking with base # learners ols, lasso, and ridge. We can also use custom_ensemble_weights -# to estimate the ATE using every individual base learner. +# to estimate the LATE using every individual base learner. weights_everylearner <- diag(1, 3) colnames(weights_everylearner) <- c("mdl:ols", "mdl:lasso", "mdl:ridge") late_fit <- ddml_late(y, D, Z, X, - learners = list(list(fun = ols), - list(fun = mdl_glmnet), - list(fun = mdl_glmnet, + learners = list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_glmnet, args = list(alpha = 0))), ensemble_type = 'nnls', custom_ensemble_weights = weights_everylearner, @@ -197,26 +227,19 @@ late_fit <- ddml_late(y, D, Z, X, silent = TRUE) summary(late_fit) } +} \references{ -Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and -Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. - -Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C B, Newey W, -Robins J (2018). "Double/debiased machine learning for treatment and -structural parameters." The Econometrics Journal, 21(1), C1-C68. - -Imbens G, Angrist J (1004). "Identification and Estimation of Local Average +Imbens G, Angrist J (1994). "Identification and Estimation of Local Average Treatment Effects." Econometrica, 62(2), 467-475. - -Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. } \seealso{ -\code{\link[=summary.ddml_late]{summary.ddml_late()}} - -Other ddml: +Other ddml estimators: +\code{\link{ddml-intro}}, +\code{\link{ddml_apo}()}, \code{\link{ddml_ate}()}, +\code{\link{ddml_attgt}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_pliv}()}, \code{\link{ddml_plm}()} } -\concept{ddml} +\concept{ddml estimators} diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index e7c4f0c..d5ec65c 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ddml_pliv.R \name{ddml_pliv} \alias{ddml_pliv} -\title{Estimator for the Partially Linear IV Model.} +\title{Estimator for the Partially Linear IV Coefficient} \usage{ ddml_pliv( y, @@ -20,9 +20,12 @@ ddml_pliv( custom_ensemble_weights_DX = custom_ensemble_weights, custom_ensemble_weights_ZX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples = NULL, - cv_subsamples_list = NULL, - silent = FALSE + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ... ) } \arguments{ @@ -34,34 +37,34 @@ ddml_pliv( \item{X}{A (sparse) matrix of control variables.} -\item{learners}{May take one of two forms, depending on whether a single -learner or stacking with multiple learners is used for estimation of the -conditional expectation functions. -If a single learner is used, \code{learners} is a list with two named -elements: +\item{learners}{May take one of two forms, depending on whether a +single learner or stacking with multiple learners is used for +estimation of the conditional expectation functions. +If a single learner is used, \code{learners} is a list with +two named elements: \itemize{ -\item{\code{what} The base learner function. The function must be -such that it predicts a named input \code{y} using a named input -\code{X}.} -\item{\code{args} Optional arguments to be passed to \code{what}.} +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} } -If stacking with multiple learners is used, \code{learners} is a list of -lists, each containing four named elements: +If stacking with multiple learners is used, \code{learners} is +a list of lists, each containing three named elements: \itemize{ -\item{\code{fun} The base learner function. The function must be -such that it predicts a named input \code{y} using a named input -\code{X}.} -\item{\code{args} Optional arguments to be passed to \code{fun}.} +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} \item{\code{assign_X} An optional vector of column indices -corresponding to control variables in \code{X} that are passed to -the base learner.} -\item{\code{assign_Z} An optional vector of column indices -corresponding to instruments in \code{Z} that are passed to the -base learner.} +corresponding to control variables in \code{X} that +are passed to the base learner.} } -Omission of the \code{args} element results in default arguments being -used in \code{fun}. Omission of \code{assign_X} (and/or \code{assign_Z}) -results in inclusion of all variables in \code{X} (and/or \code{Z}).} +Omission of the \code{args} element results in default +arguments being used in \code{what}. Omission of +\code{assign_X} results in inclusion of all variables in +\code{X}.} \item{learners_DX, learners_ZX}{Optional arguments to allow for different base learners for estimation of \eqn{E[D|X]}, \eqn{E[Z|X]}. Setup is @@ -69,13 +72,15 @@ identical to \code{learners}.} \item{sample_folds}{Number of cross-fitting folds.} -\item{ensemble_type}{Ensemble method to combine base learners into final -estimate of the conditional expectation functions. Possible values are: +\item{ensemble_type}{Ensemble method to combine base learners into +final estimate of the conditional expectation functions. +Possible values are: \itemize{ \item{\code{"nnls"} Non-negative least squares.} -\item{\code{"nnls1"} Non-negative least squares with the constraint -that all weights sum to one.} -\item{\code{"singlebest"} Select base learner with minimum MSPE.} +\item{\code{"nnls1"} Non-negative least squares with the +constraint that all weights sum to one.} +\item{\code{"singlebest"} Select base learner with minimum +MSPE.} \item{\code{"ols"} Ordinary least squares.} \item{\code{"average"} Simple average over base learners.} } @@ -83,14 +88,15 @@ Multiple ensemble types may be passed as a vector of strings.} \item{shortstack}{Boolean to use short-stacking.} -\item{cv_folds}{Number of folds used for cross-validation in ensemble -construction.} +\item{cv_folds}{Number of folds used for cross-validation in +ensemble construction.} -\item{custom_ensemble_weights}{A numerical matrix with user-specified -ensemble weights. Each column corresponds to a custom ensemble -specification, each row corresponds to a base learner in \code{learners} -(in chronological order). Optional column names are used to name the -estimation results corresponding the custom ensemble specification.} +\item{custom_ensemble_weights}{A numerical matrix with +user-specified ensemble weights. Each column corresponds to a +custom ensemble specification, each row corresponds to a base +learner in \code{learners} (in chronological order). Optional +column names are used to name the estimation results +corresponding the custom ensemble specification.} \item{custom_ensemble_weights_DX, custom_ensemble_weights_ZX}{Optional arguments to allow for different @@ -102,48 +108,77 @@ have the same number of columns.} \item{cluster_variable}{A vector of cluster indices.} -\item{subsamples}{List of vectors with sample indices for cross-fitting.} - -\item{cv_subsamples_list}{List of lists, each corresponding to a subsample -containing vectors with subsample indices for cross-validation.} - \item{silent}{Boolean to silence estimation updates.} + +\item{parallel}{An optional named list with parallel processing +options. When \code{NULL} (the default), computation is +sequential. Supported fields: +\describe{ +\item{\code{cores}}{Number of cores to use.} +\item{\code{export}}{Character vector of object names to +export to parallel workers (for custom learners that +reference global objects).} +\item{\code{packages}}{Character vector of additional +package names to load on workers (for custom learners +that use packages not imported by \code{ddml}).} +}} + +\item{fitted}{An optional named list of per-equation cross-fitted +predictions, typically obtained from a previous fit via +\code{fit$fitted}. When supplied (together with \code{splits}), +base learners are not re-fitted; only ensemble weights are +recomputed. This allows fast re-estimation with a different +\code{ensemble_type}. See \code{\link{ddml_plm}} for +an example.} + +\item{splits}{An optional list of sample split objects, typically +obtained from a previous fit via \code{fit$splits}. Must be +supplied when \code{fitted} is provided. Can also be used +standalone to provide pre-computed sample folds.} + +\item{save_crossval}{Logical indicating whether to store the inner +cross-validation residuals used for ensemble weight +computation. Default \code{TRUE}. When \code{TRUE}, subsequent +pass-through calls with data-driven ensembles (e.g., +\code{"nnls"}) reproduce per-fold weights exactly. Set to +\code{FALSE} to reduce object size at the cost of approximate +weight recomputation.} + +\item{...}{Additional arguments passed to internal methods.} } \value{ \code{ddml_pliv} returns an object of S3 class -\code{ddml_pliv}. An object of class \code{ddml_pliv} is a list -containing the following components: -\describe{ -\item{\code{coef}}{A vector with the \eqn{\theta_0} estimates.} -\item{\code{weights}}{A list of matrices, providing the weight -assigned to each base learner (in chronological order) by the -ensemble procedure.} -\item{\code{mspe}}{A list of matrices, providing the MSPE of each -base learner (in chronological order) computed by the -cross-validation step in the ensemble construction.} -\item{\code{iv_fit}}{Object of class \code{ivreg} from the IV -regression of \eqn{Y - \hat{E}[Y\vert X]} on -\eqn{D - \hat{E}[D\vert X]} using \eqn{Z - \hat{E}[Z\vert X]} as -the instrument. See also \code{\link[AER:ivreg]{AER::ivreg()}} for details.} -\item{\code{learners},\code{learners_DX},\code{learners_ZX}, -\code{cluster_variable}, \code{subsamples}, -\code{cv_subsamples_list},\code{ensemble_type}}{Pass-through of -selected user-provided arguments. See above.} -} +\code{ddml_pliv} and \code{ddml}. See \code{\link{ddml-intro}} +for the common output structure. Additional pass-through +fields: \code{learners}, \code{learners_DX}, +\code{learners_ZX}. } \description{ -Estimator for the partially linear IV model. +Estimator for the partially linear IV coefficient. } \details{ -\code{ddml_pliv} provides a double/debiased machine learning -estimator for the parameter of interest \eqn{\theta_0} in the partially -linear IV model given by +\strong{Parameter of Interest:} \code{ddml_pliv} provides a Double/Debiased +Machine Learning estimator for the partially linear instrumental variable +(IV) coefficient \eqn{\theta_0}, defined by the partially linear IV model: + +\deqn{Y = \theta_0 D + g_0(X) + \varepsilon, \quad E[Z\varepsilon] = 0, \quad E[\varepsilon|X] = 0,} -\eqn{Y = \theta_0D + g_0(X) + U,} +where \eqn{W \equiv (Y, D, X, Z, \varepsilon)} is a random vector such that +\eqn{E[Cov(D, Z|X)] \neq 0}, and \eqn{g_0(X)} is an unknown nuisance function. -where \eqn{(Y, D, X, Z, U)} is a random vector such that -\eqn{E[Cov(U, Z\vert X)] = 0} and \eqn{E[Cov(D, Z\vert X)] \neq 0}, and -\eqn{g_0} is an unknown nuisance function. +\strong{Neyman Orthogonal Score:} The Neyman orthogonal score is: + +\deqn{m(W; \theta, \eta) = [(Y - \ell(X)) - \theta(D - r_D(X))](Z - r_Z(X))} + +where the nuisance parameters are \eqn{\eta = (\ell, r_D, r_Z)} taking +true values \eqn{\ell_0(X) = E[Y|X]}, \eqn{r_{D,0}(X) = E[D|X]}, and \eqn{r_{Z,0}(X) = E[Z|X]}. + +\strong{Jacobian:} + +\deqn{J = -E[(D - r_D(X))(Z - r_Z(X))^\top]} + +See \code{\link{ddml-intro}} for how the influence function +and inference are derived from these components. } \examples{ # Construct variables from the included Angrist & Evans (1998) data @@ -160,26 +195,14 @@ pliv_fit <- ddml_pliv(y, D, Z, X, silent = TRUE) summary(pliv_fit) } -\references{ -Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and -Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. - -Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C B, Newey W, -Robins J (2018). "Double/debiased machine learning for treatment and -structural parameters." The Econometrics Journal, 21(1), C1-C68. - -Kleiber C, Zeileis A (2008). Applied Econometrics with R. Springer-Verlag, -New York. - -Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. -} \seealso{ -\code{\link[=summary.ddml_pliv]{summary.ddml_pliv()}}, \code{\link[AER:ivreg]{AER::ivreg()}} - -Other ddml: +Other ddml estimators: +\code{\link{ddml-intro}}, +\code{\link{ddml_apo}()}, \code{\link{ddml_ate}()}, +\code{\link{ddml_attgt}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, \code{\link{ddml_plm}()} } -\concept{ddml} +\concept{ddml estimators} diff --git a/man/ddml_plm.Rd b/man/ddml_plm.Rd index 185cb05..65972a0 100644 --- a/man/ddml_plm.Rd +++ b/man/ddml_plm.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ddml_plm.R \name{ddml_plm} \alias{ddml_plm} -\title{Estimator for the Partially Linear Model.} +\title{Estimator for the Partially Linear Regression Coefficient} \usage{ ddml_plm( y, @@ -17,9 +17,12 @@ ddml_plm( custom_ensemble_weights = NULL, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples = NULL, - cv_subsamples_list = NULL, - silent = FALSE + silent = FALSE, + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ... ) } \arguments{ @@ -29,44 +32,49 @@ ddml_plm( \item{X}{A (sparse) matrix of control variables.} -\item{learners}{May take one of two forms, depending on whether a single -learner or stacking with multiple learners is used for estimation of the -conditional expectation functions. -If a single learner is used, \code{learners} is a list with two named -elements: +\item{learners}{May take one of two forms, depending on whether a +single learner or stacking with multiple learners is used for +estimation of the conditional expectation functions. +If a single learner is used, \code{learners} is a list with +two named elements: \itemize{ -\item{\code{what} The base learner function. The function must be -such that it predicts a named input \code{y} using a named input -\code{X}.} -\item{\code{args} Optional arguments to be passed to \code{what}.} +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} } -If stacking with multiple learners is used, \code{learners} is a list of -lists, each containing four named elements: +If stacking with multiple learners is used, \code{learners} is +a list of lists, each containing three named elements: \itemize{ -\item{\code{fun} The base learner function. The function must be -such that it predicts a named input \code{y} using a named input -\code{X}.} -\item{\code{args} Optional arguments to be passed to \code{fun}.} +\item{\code{what} The base learner function. The function +must be such that it predicts a named input \code{y} +using a named input \code{X}.} +\item{\code{args} Optional arguments to be passed to +\code{what}.} \item{\code{assign_X} An optional vector of column indices -corresponding to control variables in \code{X} that are passed to -the base learner.} +corresponding to control variables in \code{X} that +are passed to the base learner.} } -Omission of the \code{args} element results in default arguments being -used in \code{fun}. Omission of \code{assign_X} results in inclusion of -all variables in \code{X}.} +Omission of the \code{args} element results in default +arguments being used in \code{what}. Omission of +\code{assign_X} results in inclusion of all variables in +\code{X}.} \item{learners_DX}{Optional argument to allow for different estimators of \eqn{E[D|X]}. Setup is identical to \code{learners}.} \item{sample_folds}{Number of cross-fitting folds.} -\item{ensemble_type}{Ensemble method to combine base learners into final -estimate of the conditional expectation functions. Possible values are: +\item{ensemble_type}{Ensemble method to combine base learners into +final estimate of the conditional expectation functions. +Possible values are: \itemize{ \item{\code{"nnls"} Non-negative least squares.} -\item{\code{"nnls1"} Non-negative least squares with the constraint -that all weights sum to one.} -\item{\code{"singlebest"} Select base learner with minimum MSPE.} +\item{\code{"nnls1"} Non-negative least squares with the +constraint that all weights sum to one.} +\item{\code{"singlebest"} Select base learner with minimum +MSPE.} \item{\code{"ols"} Ordinary least squares.} \item{\code{"average"} Simple average over base learners.} } @@ -74,14 +82,15 @@ Multiple ensemble types may be passed as a vector of strings.} \item{shortstack}{Boolean to use short-stacking.} -\item{cv_folds}{Number of folds used for cross-validation in ensemble -construction.} +\item{cv_folds}{Number of folds used for cross-validation in +ensemble construction.} -\item{custom_ensemble_weights}{A numerical matrix with user-specified -ensemble weights. Each column corresponds to a custom ensemble -specification, each row corresponds to a base learner in \code{learners} -(in chronological order). Optional column names are used to name the -estimation results corresponding the custom ensemble specification.} +\item{custom_ensemble_weights}{A numerical matrix with +user-specified ensemble weights. Each column corresponds to a +custom ensemble specification, each row corresponds to a base +learner in \code{learners} (in chronological order). Optional +column names are used to name the estimation results +corresponding the custom ensemble specification.} \item{custom_ensemble_weights_DX}{Optional argument to allow for different custom ensemble weights for \code{learners_DX}. Setup is identical to @@ -90,47 +99,77 @@ custom ensemble weights for \code{learners_DX}. Setup is identical to \item{cluster_variable}{A vector of cluster indices.} -\item{subsamples}{List of vectors with sample indices for cross-fitting.} - -\item{cv_subsamples_list}{List of lists, each corresponding to a subsample -containing vectors with subsample indices for cross-validation.} - \item{silent}{Boolean to silence estimation updates.} + +\item{parallel}{An optional named list with parallel processing +options. When \code{NULL} (the default), computation is +sequential. Supported fields: +\describe{ +\item{\code{cores}}{Number of cores to use.} +\item{\code{export}}{Character vector of object names to +export to parallel workers (for custom learners that +reference global objects).} +\item{\code{packages}}{Character vector of additional +package names to load on workers (for custom learners +that use packages not imported by \code{ddml}).} +}} + +\item{fitted}{An optional named list of per-equation cross-fitted +predictions, typically obtained from a previous fit via +\code{fit$fitted}. When supplied (together with \code{splits}), +base learners are not re-fitted; only ensemble weights are +recomputed. This allows fast re-estimation with a different +\code{ensemble_type}. See \code{\link{ddml_plm}} for +an example.} + +\item{splits}{An optional list of sample split objects, typically +obtained from a previous fit via \code{fit$splits}. Must be +supplied when \code{fitted} is provided. Can also be used +standalone to provide pre-computed sample folds.} + +\item{save_crossval}{Logical indicating whether to store the inner +cross-validation residuals used for ensemble weight +computation. Default \code{TRUE}. When \code{TRUE}, subsequent +pass-through calls with data-driven ensembles (e.g., +\code{"nnls"}) reproduce per-fold weights exactly. Set to +\code{FALSE} to reduce object size at the cost of approximate +weight recomputation.} + +\item{...}{Additional arguments passed to internal methods.} } \value{ \code{ddml_plm} returns an object of S3 class -\code{ddml_plm}. An object of class \code{ddml_plm} is a list containing -the following components: -\describe{ -\item{\code{coef}}{A vector with the \eqn{\theta_0} estimates.} -\item{\code{weights}}{A list of matrices, providing the weight -assigned to each base learner (in chronological order) by the -ensemble procedure.} -\item{\code{mspe}}{A list of matrices, providing the MSPE of each -base learner (in chronological order) computed by the -cross-validation step in the ensemble construction.} -\item{\code{ols_fit}}{Object of class \code{lm} from the second -stage regression of \eqn{Y - \hat{E}[Y|X]} on -\eqn{D - \hat{E}[D|X]}.} -\item{\code{learners},\code{learners_DX},\code{cluster_variable}, -\code{subsamples}, \code{cv_subsamples_list}, -\code{ensemble_type}}{Pass-through of selected user-provided -arguments. See above.} -} +\code{ddml_plm} and \code{ddml}. See \code{\link{ddml-intro}} +for the common output structure. Additional pass-through +fields: \code{learners}, \code{learners_DX}. } \description{ -Estimator for the partially linear model. +Estimator for the partially linear regression coefficient. } \details{ -\code{ddml_plm} provides a double/debiased machine learning -estimator for the parameter of interest \eqn{\theta_0} in the partially -linear model given by +\strong{Parameter of Interest:} \code{ddml_plm} provides a Double/Debiased +Machine Learning estimator for the partially linear regression +coefficient \eqn{\theta_0}, defined by the partially linear regression +model: + +\deqn{Y = \theta_0 D + g_0(X) + \varepsilon, \quad E[D\varepsilon] = 0, \quad E[\varepsilon|X] = 0,} -\eqn{Y = \theta_0D + g_0(X) + U,} +where \eqn{W\equiv(Y, D, X, \varepsilon)} is a random vector such that +\eqn{E[Var(D|X)] \neq 0}, and \eqn{g_0(X)} is an unknown nuisance function. -where \eqn{(Y, D, X, U)} is a random vector such that -\eqn{E[Cov(U, D\vert X)] = 0} and \eqn{E[Var(D\vert X)] \neq 0}, and -\eqn{g_0} is an unknown nuisance function. +\strong{Neyman Orthogonal Score:} The Neyman orthogonal score is: + +\deqn{m(W; \theta, \eta) = [(Y - \ell(X)) - \theta(D - r(X))](D - r(X))} + +where the nuisance parameters are \eqn{\eta = (\ell, r)} taking +true values \eqn{\ell_0(X) = E[Y|X]} and \eqn{r_0(X) = E[D|X]}. + +\strong{Jacobian:} + +\deqn{J = -E[(D - r_0(X))(D - r_0(X))^\top]} + +See \code{\link{ddml-intro}} for how the influence function +and inference are derived from these components. } \examples{ # Construct variables from the included Angrist & Evans (1998) data @@ -152,9 +191,9 @@ summary(plm_fit) weights_everylearner <- diag(1, 3) colnames(weights_everylearner) <- c("mdl:ols", "mdl:lasso", "mdl:ridge") plm_fit <- ddml_plm(y, D, X, - learners = list(list(fun = ols), - list(fun = mdl_glmnet), - list(fun = mdl_glmnet, + learners = list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_glmnet, args = list(alpha = 0))), ensemble_type = 'nnls', custom_ensemble_weights = weights_everylearner, @@ -162,24 +201,32 @@ plm_fit <- ddml_plm(y, D, X, sample_folds = 2, silent = TRUE) summary(plm_fit) -} -\references{ -Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and -Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. - -Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C B, Newey W, -Robins J (2018). "Double/debiased machine learning for treatment and -structural parameters." The Econometrics Journal, 21(1), C1-C68. -Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. +\donttest{ +# Re-estimate with a different ensemble type using pass-through +# (skips cross-fitting, only recomputes ensemble weights). +plm_fit2 <- ddml_plm(y, D, X, + learners = list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_glmnet, + args = list(alpha = 0))), + ensemble_type = 'average', + shortstack = TRUE, + sample_folds = 2, + silent = TRUE, + fitted = plm_fit$fitted, + splits = plm_fit$splits) +summary(plm_fit2) +} } \seealso{ -\code{\link[=summary.ddml_plm]{summary.ddml_plm()}} - -Other ddml: +Other ddml estimators: +\code{\link{ddml-intro}}, +\code{\link{ddml_apo}()}, \code{\link{ddml_ate}()}, +\code{\link{ddml_attgt}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()} } -\concept{ddml} +\concept{ddml estimators} diff --git a/man/ddml_rep.Rd b/man/ddml_rep.Rd new file mode 100644 index 0000000..48a8d4f --- /dev/null +++ b/man/ddml_rep.Rd @@ -0,0 +1,61 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{ddml_rep} +\alias{ddml_rep} +\alias{print.ddml_rep} +\title{Construct a Multi-Resample DDML Object} +\usage{ +ddml_rep(fits) + +\method{print}{ddml_rep}(x, ...) +} +\arguments{ +\item{fits}{A list of at least 2 objects inheriting from +class \code{"ddml"}. All fits must share the same +primary class, coefficient names, ensemble type, and +number of observations.} + +\item{x}{A \code{ddml_rep} object.} + +\item{...}{Currently unused.} +} +\value{ +An object of class \code{c("ddml_rep", "ral_rep")} +with fields: +\describe{ +\item{fits}{List of \code{ddml} objects.} +\item{nresamples}{Number of resamples.} +\item{model_type}{Primary class of the fits.} +\item{coef_names}{Coefficient names.} +\item{ensemble_type}{Ensemble types.} +\item{nobs}{Number of observations.} +\item{sample_folds}{Number of cross-fitting folds.} +\item{shortstack}{Logical, whether short-stacking was used.} +} +} +\description{ +Validates a list of \code{ddml} fits and stamps class +\code{"ddml_rep"} for multi-resample aggregation. +} +\examples{ +\donttest{ +y = AE98[, "worked"] +D = AE98[, "morekids"] +X = AE98[, c("age","agefst","black","hisp","othrace")] +fits = lapply(1:3, function(r) { + ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, silent = TRUE) +}) +reps = ddml_rep(fits) +summary(reps) +} + +} +\seealso{ +\code{\link[=ddml_replicate]{ddml_replicate()}} + +Other ddml replication: +\code{\link{ddml_replicate}()} +} +\concept{ddml replication} diff --git a/man/ddml_replicate.Rd b/man/ddml_replicate.Rd new file mode 100644 index 0000000..c5cf666 --- /dev/null +++ b/man/ddml_replicate.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{ddml_replicate} +\alias{ddml_replicate} +\title{Replicate a DDML Estimator Across Multiple Resamples} +\usage{ +ddml_replicate(fn, ..., resamples = 5, silent = FALSE) +} +\arguments{ +\item{fn}{A \code{ddml_*} estimator function +(e.g., \code{ddml_plm}).} + +\item{...}{Arguments passed to \code{fn}.} + +\item{resamples}{Integer number of independent resamples. +Must be >= 2. Default 5.} + +\item{silent}{Logical. If \code{TRUE}, suppresses all +output at both the resample level and within each +estimator call. Default \code{FALSE}.} +} +\value{ +An object of class \code{"ddml_rep"}. +} +\description{ +Convenience wrapper that calls a \code{ddml_*} estimator +function multiple times with independent sample splits +and returns a \code{ddml_rep} object for aggregated +inference. +} +\examples{ +\donttest{ +y = AE98[, "worked"] +D = AE98[, "morekids"] +X = AE98[, c("age","agefst","black","hisp","othrace")] +reps = ddml_replicate(ddml_plm, y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, silent = TRUE) +summary(reps) +} + +} +\seealso{ +\code{\link[=ddml_rep]{ddml_rep()}} + +Other ddml replication: +\code{\link{ddml_rep}()} +} +\concept{ddml replication} diff --git a/man/diagnostics.Rd b/man/diagnostics.Rd new file mode 100644 index 0000000..1ef29fe --- /dev/null +++ b/man/diagnostics.Rd @@ -0,0 +1,59 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/diagnostics.R +\name{diagnostics} +\alias{diagnostics} +\title{Stacking Diagnostics for DDML Estimators} +\usage{ +diagnostics(object, cvc = FALSE, bootnum = 500, ...) +} +\arguments{ +\item{object}{An object of class \code{ddml}.} + +\item{cvc}{Logical. Compute CVC p-values via multiplier +bootstrap? Default \code{FALSE}. CVC tests whether each +learner is significantly outperformed by the others.} + +\item{bootnum}{Number of bootstrap replications for CVC. +Default 500. Ignored when \code{cvc = FALSE}.} + +\item{...}{Currently unused.} +} +\value{ +An object of class \code{ddml_diagnostics} containing per-equation +learner diagnostics. Use \code{print()} for formatted output or +\code{tidy()} for a flat data.frame. +} +\description{ +Computes per-learner diagnostics including MSPE, R-squared, +ensemble weights, and optionally cross-validation comparison +(CVC) p-values for each nuisance equation. +} +\examples{ +\donttest{ +y = AE98[, "worked"] +D = AE98[, "morekids"] +X = AE98[, c("age","agefst","black","hisp","othrace")] +learners = list(list(what = ols), + list(what = mdl_glmnet)) +plm_fit = ddml_plm(y, D, X, + learners = learners, + sample_folds = 2, silent = TRUE) +diagnostics(plm_fit, cvc = TRUE) +tidy(diagnostics(plm_fit, cvc = TRUE)) +} + +} +\references{ +Lei J (2020). "Cross-Validation With Confidence." Journal of the American +Statistical Association, 115(532), 1978-1997. +} +\seealso{ +Other utilities: +\code{\link{crosspred}()}, +\code{\link{crossval}()}, +\code{\link{ddml}()}, +\code{\link{ensemble}()}, +\code{\link{ensemble_weights}()}, +\code{\link{shortstacking}()} +} +\concept{utilities} diff --git a/man/ensemble.Rd b/man/ensemble.Rd new file mode 100644 index 0000000..36d9693 --- /dev/null +++ b/man/ensemble.Rd @@ -0,0 +1,86 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ensemble.R +\name{ensemble} +\alias{ensemble} +\title{Stacking Estimator Using Combinations of Base Learners} +\usage{ +ensemble( + y, + X, + type = "average", + learners, + cv_folds = 5, + cv_subsamples = NULL, + cv_results = NULL, + custom_weights = NULL, + silent = FALSE +) +} +\arguments{ +\item{y}{The outcome variable.} + +\item{X}{The feature matrix.} + +\item{type}{A character string indicating the type of ensemble to compute. +Default is \code{"average"}.} + +\item{learners}{A list of base learners. See +\code{\link{ddml-intro}} for the full specification.} + +\item{cv_folds}{Number of cross-validation folds.} + +\item{cv_subsamples}{Optional list of subsamples for cross-validation.} + +\item{cv_results}{Optional pre-computed cross-validation results.} + +\item{custom_weights}{Optional custom weights matrix.} + +\item{silent}{A boolean indicating whether to suppress progress messages.} +} +\value{ +An object of class \code{ensemble} containing: +\describe{ +\item{\code{mdl_fits}}{List of fitted base learners.} +\item{\code{weights}}{Computed ensemble weights.} +\item{\code{learners}}{The base learners used.} +\item{\code{cv_results}}{Cross-validation results if +computed.} +\item{\code{mean_y}}{Mean of the outcome variable.} +\item{\code{constant_y}}{Boolean indicating if y is +constant.} +} +} +\description{ +Computes an ensemble of learners based on the specified +aggregation type and computes cross-validated out-of-sample +predictions to inform the weights. +} +\examples{ +\donttest{ +# Construct variables from the included Angrist & Evans (1998) data +y = AE98[, "worked"] +X = AE98[, c("age","agefst","black","hisp","othrace")] + +# Fit an ensemble of ols, lasso, and ridge +ens_fit = ensemble(y, X, + type = "nnls", + learners = list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_glmnet, + args = list(alpha = 0))), + cv_folds = 5, + silent = TRUE) +ens_fit$weights +predict(ens_fit, newdata = X)[1:5] +} +} +\seealso{ +Other utilities: +\code{\link{crosspred}()}, +\code{\link{crossval}()}, +\code{\link{ddml}()}, +\code{\link{diagnostics}()}, +\code{\link{ensemble_weights}()}, +\code{\link{shortstacking}()} +} +\concept{utilities} diff --git a/man/ensemble_weights.Rd b/man/ensemble_weights.Rd new file mode 100644 index 0000000..7260a0d --- /dev/null +++ b/man/ensemble_weights.Rd @@ -0,0 +1,81 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ensemble.R +\name{ensemble_weights} +\alias{ensemble_weights} +\title{Compute Stacking Weights for Base Learners} +\usage{ +ensemble_weights( + y, + X, + type = "average", + learners = NULL, + cv_folds = 5, + cv_subsamples = NULL, + cv_results = NULL, + custom_weights = NULL, + silent = FALSE +) +} +\arguments{ +\item{y}{The outcome variable.} + +\item{X}{The feature matrix.} + +\item{type}{A character string or vector indicating the type(s) of ensemble +weights to compute. Default is \code{"average"}.} + +\item{learners}{Optional list of base learners. +Required when \code{cv_results} is not supplied (learners are +needed to run cross-validation). When \code{cv_results} is +supplied, \code{learners} may be omitted; the number of +learners is inferred from the cross-validation residuals. +See \code{\link{ddml-intro}} for the full specification.} + +\item{cv_folds}{Number of cross-validation folds.} + +\item{cv_subsamples}{Optional list of subsamples for cross-validation.} + +\item{cv_results}{Optional pre-computed cross-validation results.} + +\item{custom_weights}{Optional custom weights matrix.} + +\item{silent}{A boolean indicating whether to suppress progress messages.} +} +\value{ +A list containing: +\describe{ +\item{\code{weights}}{A matrix of computed ensemble +weights.} +\item{\code{cv_results}}{Cross-validation results used +for computing weights.} +} +} +\description{ +Computes the stacking weights for an ensemble of base learners +using cross-validated out-of-sample predictions. +} +\examples{ +\donttest{ +y = AE98[, "worked"] +X = AE98[, c("age","agefst","black","hisp","othrace")] + +# Compute stacking weights via NNLS +ew = ensemble_weights(y, X, + type = "nnls", + learners = list(list(what = ols), + list(what = mdl_glmnet)), + cv_folds = 5, + silent = TRUE) +ew$weights +} +} +\seealso{ +Other utilities: +\code{\link{crosspred}()}, +\code{\link{crossval}()}, +\code{\link{ddml}()}, +\code{\link{diagnostics}()}, +\code{\link{ensemble}()}, +\code{\link{shortstacking}()} +} +\concept{utilities} diff --git a/man/glance.ddml.Rd b/man/glance.ddml.Rd new file mode 100644 index 0000000..5cecb5e --- /dev/null +++ b/man/glance.ddml.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml.R +\name{glance.ddml} +\alias{glance.ddml} +\title{Glance at a DDML Object} +\usage{ +\method{glance}{ddml}(x, ...) +} +\arguments{ +\item{x}{A \code{ddml} object.} + +\item{...}{Currently unused.} +} +\value{ +A one-row \code{data.frame}. +} +\description{ +DML-specific glance method. Includes DML fields like +\code{sample_folds}, \code{shortstack}, and +\code{model_type}. +} +\examples{ +\donttest{ +y = AE98[, "worked"] +D = AE98[, "morekids"] +X = AE98[, c("age","agefst","black","hisp","othrace")] +plm_fit = ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, silent = TRUE) +glance(plm_fit) +} + +} diff --git a/man/glance.ddml_rep.Rd b/man/glance.ddml_rep.Rd new file mode 100644 index 0000000..ce848b5 --- /dev/null +++ b/man/glance.ddml_rep.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{glance.ddml_rep} +\alias{glance.ddml_rep} +\title{Glance at a ddml_rep Object} +\usage{ +\method{glance}{ddml_rep}(x, ...) +} +\arguments{ +\item{x}{A \code{ddml_rep} object.} + +\item{...}{Currently unused.} +} +\value{ +A one-row \code{data.frame}. +} +\description{ +DML-specific glance method. Includes DML fields. +} +\examples{ +\donttest{ +y = AE98[, "worked"] +D = AE98[, "morekids"] +X = AE98[, c("age","agefst","black","hisp","othrace")] +reps = ddml_replicate(ddml_plm, y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, silent = TRUE) +glance(reps) +} + +} diff --git a/man/glance.ral.Rd b/man/glance.ral.Rd new file mode 100644 index 0000000..f0dd297 --- /dev/null +++ b/man/glance.ral.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral.R +\name{glance.ral} +\alias{glance.ral} +\title{Glance at a RAL Object} +\usage{ +\method{glance}{ral}(x, ...) +} +\arguments{ +\item{x}{An object inheriting from class \code{ral}.} + +\item{...}{Currently unused.} +} +\value{ +A one-row \code{data.frame} with columns +\code{nobs} and \code{estimator_name}. +} +\description{ +Returns a one-row summary of model-level statistics. +} diff --git a/man/glance.ral_rep.Rd b/man/glance.ral_rep.Rd new file mode 100644 index 0000000..a66087f --- /dev/null +++ b/man/glance.ral_rep.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral_rep.R +\name{glance.ral_rep} +\alias{glance.ral_rep} +\title{Glance at a RAL Rep Object} +\usage{ +\method{glance}{ral_rep}(x, ...) +} +\arguments{ +\item{x}{An object inheriting from class \code{ral_rep}.} + +\item{...}{Currently unused.} +} +\value{ +A one-row \code{data.frame} with columns +\code{nobs}, \code{nresamples}, and +\code{estimator_name}. +} +\description{ +Glance at a RAL Rep Object +} diff --git a/man/hatvalues.ral.Rd b/man/hatvalues.ral.Rd new file mode 100644 index 0000000..8c05e90 --- /dev/null +++ b/man/hatvalues.ral.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral.R +\name{hatvalues.ral} +\alias{hatvalues.ral} +\title{Extract leverage (Hat Values)} +\usage{ +\method{hatvalues}{ral}(model, fit_idx = 1, ...) +} +\arguments{ +\item{model}{An object inheriting from class \code{ral}.} + +\item{fit_idx}{Integer index of the fit to extract leverage +values for. Defaults to 1.} + +\item{...}{Currently unused.} +} +\value{ +A numeric vector of leverage values. +} +\description{ +Computes the leverage (hat values) +for a RAL estimator. Used internally for HC3 standard +errors. +} +\details{ +The leverage for observation \eqn{i} +is + +\deqn{h_i(\theta) + = \mathrm{tr}\!\left( + \frac{1}{n} + \frac{\partial \phi_i(\theta)} + {\partial \theta} +\right).} + +The sample analog replaces \eqn{\phi_i(\theta)} with its +estimate \eqn{\hat\phi_i}: \eqn{\hat{h}_i = h_i(\hat\theta).} + +The derivative \eqn{\partial \hat\phi_i / \partial \theta} +is stored in the \code{dinf_dtheta} slot. For the specific +form of this derivative in the DML context, see +\code{\link{ddml-intro}}. For the leverage of linear +combinations, see \code{\link{lincom}}. +} diff --git a/man/lincom.Rd b/man/lincom.Rd new file mode 100644 index 0000000..c54976f --- /dev/null +++ b/man/lincom.Rd @@ -0,0 +1,182 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lincom.R +\name{lincom} +\alias{lincom} +\alias{lincom.ddml} +\alias{lincom.ddml_rep} +\alias{print.lincom} +\alias{print.lincom_rep} +\title{Linear Combinations of DDML Coefficients} +\usage{ +lincom(fit, R, ...) + +\method{lincom}{ddml}( + fit, + R, + fit_idx = NULL, + labels = NULL, + inf_func_R = NULL, + dinf_dR = NULL, + ... +) + +\method{lincom}{ddml_rep}( + fit, + R, + inf_func_R = NULL, + dinf_dR = NULL, + fit_idx = NULL, + labels = NULL, + ... +) + +\method{print}{lincom}(x, ...) + +\method{print}{lincom_rep}(x, ...) +} +\arguments{ +\item{fit}{A \code{ddml} or \code{ddml_rep} object.} + +\item{R}{A \eqn{(p \times q)}{p x q} contrast matrix. +Each column defines one linear combination.} + +\item{...}{Currently unused.} + +\item{fit_idx}{Integer index of the fit to use, or +\code{NULL} (default) for all ensemble types. +When \code{NULL}, the output carries all ensembles +from the parent fit.} + +\item{labels}{Optional character vector of length \eqn{q} +naming the linear combinations. Defaults to column +names of \code{R}, or \code{"lc1"}, \code{"lc2"}, etc.} + +\item{inf_func_R}{An optional \eqn{(n \times p \times q)} +{n x p x q} array of influence functions +\eqn{\Phi_{R,i}} for the contrast matrix \eqn{R}. +Slice \code{[,,k]} contains the IFs for column +\eqn{k} of \eqn{R}. When supplied, a delta-method +correction is applied to the variance. When +\code{NULL} (default), \eqn{R} is treated as fixed +and only the first term contributes.} + +\item{dinf_dR}{An optional \eqn{(n \times q \times q)}{n x q x q} +array of observation-level derivatives +\eqn{-n^{-1} \partial \phi_{R,i} / \partial R}, +representing the Weighting Leverage. When supplied, +it is added to the Structural Leverage to form the +total leverage used by HC3.} + +\item{x}{A \code{lincom} or \code{lincom_rep} object.} +} +\value{ +An object of class \code{"lincom"} (inheriting +from \code{"ral"}) for \code{ddml} input, or +\code{"lincom_rep"} (inheriting from \code{"ral_rep"}) +for \code{ddml_rep} input. +} +\description{ +Computes linear combinations \eqn{R'\hat\theta} +of DDML coefficient estimates. +} +\details{ +For a \eqn{p}-dimensional coefficient vector +\eqn{\hat\theta} and a \eqn{(p \times q)}{p x q} contrast +matrix \eqn{R}, the linear combination is +\eqn{\gamma = R'\hat\theta}. + +The influence function for \eqn{\gamma} is + +\deqn{\phi_\gamma(W_i; \theta, R) + = R'\, \phi_\theta(W_i; \theta) + + \Phi_{R}(W_i)\, \theta,} + +where \eqn{\phi_\theta} is the influence function of +\eqn{\hat\theta} (see \code{\link{ral}} and +\code{\link{ddml-intro}}), +\eqn{\Phi_R(W_i)} is the \eqn{(p \times q)}{p x q} +matrix of influence functions for the contrast matrix +\eqn{R} (the \eqn{i}-th slice of \code{inf_func_R}), +and the second term vanishes when \eqn{R} is fixed. +The estimated influence function is + +\deqn{\hat\phi_{\gamma,i} + = R'\, \hat\phi_{\theta,i} + + \hat\Phi_{R,i}\, \hat\theta.} + +The leverage for \eqn{\gamma} is + +\deqn{h_\gamma(W_i; \theta, R) + = \mathrm{tr}\! \left( + R'\,h_\theta(W_i; \theta)\,R + + h_R(W_i)\right),} + +where \eqn{h_\theta} is the structural leverage from +the parent estimator (see \code{\link{hatvalues.ral}}) +and \eqn{h_R} is the weighting leverage. The sample +analog is + +\deqn{\hat{h}_{\gamma,i} + = \mathrm{tr}\! \left( + R'\,\hat{h}_{\theta,i}\,R + + \hat{h}_{R,i}\right),} + +where \eqn{\hat{h}_{\theta,i}} is mapped from the +parent's \code{dinf_dtheta} and \eqn{\hat{h}_{R,i}} +from the optional \code{dinf_dR} argument. + +The resulting \code{lincom} object inherits from +\code{ral} and supports all standard inference methods: +\code{vcov}, \code{confint}, \code{summary}, \code{tidy}, +and \code{hatvalues}. For \code{ddml_rep} objects, +\code{lincom} returns a \code{lincom_rep} inheriting +from \code{ral_rep}. + +Note that \code{inf_func_R} is needed for inference when +\eqn{R} is estimated. Leverage computation further requires +\code{dinf_dR}. See \code{\link{vcov.ral}} and +\code{\link{hatvalues.ral}} for more details. +} +\examples{ +\donttest{ +set.seed(42) +n <- 200; T_ <- 4 +X <- matrix(rnorm(n * 2), n, 2) +G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) +y <- matrix(rnorm(n * T_), n, T_) +for (i in seq_len(n)) { + if (is.finite(G[i])) { + for (j in seq_len(T_)) { + if (j >= G[i]) y[i, j] <- y[i, j] + 1 + } + } +} +fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) +# Simple contrast: first cell minus second +p <- nrow(fit$coefficients) +R <- matrix(0, p, 1) +R[1, 1] <- 1; R[2, 1] <- -1 +lc <- lincom(fit, R = R, labels = "ATT1-ATT2") +summary(lc) +} + +} +\references{ +Chernozhukov V, Chetverikov D, Demirer M, Duflo E, +Hansen C B, Newey W, Robins J (2018). +"Double/debiased machine learning for treatment +and structural parameters." The Econometrics +Journal, 21(1), C1-C68. +} +\seealso{ +\code{\link{lincom_weights_did}} for constructing +DiD aggregation weights. + +Other ddml inference: +\code{\link{summary.ddml}()} +} +\concept{ddml inference} diff --git a/man/lincom_weights_did.Rd b/man/lincom_weights_did.Rd new file mode 100644 index 0000000..d132a97 --- /dev/null +++ b/man/lincom_weights_did.Rd @@ -0,0 +1,129 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lincom_weights.R +\name{lincom_weights_did} +\alias{lincom_weights_did} +\title{Difference-in-Differences Aggregation Weights for lincom} +\usage{ +lincom_weights_did( + fit, + type = c("dynamic", "group", "simple", "calendar"), + min_e = -Inf, + max_e = Inf, + fit_idx = NULL +) +} +\arguments{ +\item{fit}{A \code{ddml_attgt} or \code{ddml_rep} object +whose underlying fits are \code{ddml_attgt}.} + +\item{type}{Aggregation type: \code{"dynamic"} (default), +\code{"group"}, \code{"simple"}, or \code{"calendar"}.} + +\item{min_e, max_e}{Event-time range filter (dynamic only). +Cells with event time outside \code{[min_e, max_e]} +are excluded.} + +\item{fit_idx}{Integer index of the fit (ensemble type) +to use for computing the weighting leverage, or +\code{NULL} (default) for all ensemble types. +When \code{NULL}, \code{dinf_dR} is a 4D array.} +} +\value{ +A list with elements: +\describe{ +\item{\code{R}}{A \eqn{(C \times q)}{C x q} contrast +matrix where \eqn{C} is the number of GT cells.} +\item{\code{inf_func_R}}{An \eqn{(n \times C \times q)} +{n x C x q} array of influence functions for +the contrast matrix \eqn{R}. Slice \code{[,,k]} +contains the IFs for column \eqn{k} of \eqn{R}.} +\item{\code{dinf_dR}}{An \eqn{(n \times q \times q)} +{n x q x q} array of weighting leverage. Each +slice is the constant matrix \eqn{V'V} where +\eqn{V_{g,k} = \sum_{c \in \mathcal{K}_k,\, + g_c = g} (\theta_c - \gamma_k) / S_k}. See +D89 §5.3.} +\item{\code{labels}}{Character vector of length +\eqn{q} naming the aggregated quantities.} +} +} +\description{ +Constructs the contrast matrix \eqn{R} and +its influence function matrix \code{inf_func_R} for +standard DiD aggregation types. The output is +designed to be passed directly to +\code{\link{lincom}}. +} +\details{ +Let \eqn{\theta^{(g,t)}_0} denote the GT-ATT +from \code{\link{ddml_attgt}}. Each aggregation type +defines a summary parameter as a weighted average of +GT-ATTs over a subset of post-treatment cells +(\eqn{t \geq g}). + +\strong{Dynamic} (\code{type = "dynamic"}): aggregates +by event time \eqn{e = t - g} (Callaway and Sant'Anna, +2021, eq. 9). For each \eqn{e}: + +\deqn{\tau_0(e) = \sum_{g \in \mathcal{G}} + \mathbf{1}\{g + e \leq T\}\, + \Pr(G = g \mid G + e \leq T)\, + \theta^{(g,\, g+e)}_0.} + +\strong{Group} (\code{type = "group"}): aggregates by +cohort \eqn{g}. For each \eqn{g}: + +\deqn{\theta(g) = \frac{1}{|\mathcal{T}_g|} + \sum_{t \in \mathcal{T}_g} + \theta^{(g,t)}_0,} + +where \eqn{\mathcal{T}_g = \{t : t \geq g\}} and the +weights reduce to uniform within each cohort. + +\strong{Calendar} (\code{type = "calendar"}): aggregates +by time period \eqn{t}. For each \eqn{t}: + +\deqn{\theta(t) = \sum_{g:\, g \leq t} + \frac{P(G = g)}{\sum_{g':\, g' \leq t} P(G = g')}\, + \theta^{(g,t)}_0.} + +\strong{Simple} (\code{type = "simple"}): a single +weighted average across all post-treatment cells: + +\deqn{\theta_{ATT} = \sum_{(g,t):\, t \geq g} + \frac{P(G = g)}{\sum_{(g',t'):\, t' \geq g'} + P(G = g')}\, \theta^{(g,t)}_0.} + +The influence function for the estimated weights is +derived via the quotient rule and passed to +\code{\link{lincom}} as \code{inf_func_R}. +} +\examples{ +\donttest{ +set.seed(42) +n <- 200; T_ <- 4 +X <- matrix(rnorm(n * 2), n, 2) +G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) +y <- matrix(rnorm(n * T_), n, T_) +fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) +w <- lincom_weights_did(fit, type = "dynamic") +dyn <- lincom(fit, R = w$R, + inf_func_R = w$inf_func_R, + dinf_dR = w$dinf_dR, + labels = w$labels) +summary(dyn) +} + +} +\references{ +Callaway B, Sant'Anna P H C (2021). "Difference-in-Differences +with multiple time periods." Journal of Econometrics, +225(2), 200-230. +} +\seealso{ +\code{\link{lincom}} +} diff --git a/man/mdl_bigGLM.Rd b/man/mdl_bigGLM.Rd new file mode 100644 index 0000000..8fac4a5 --- /dev/null +++ b/man/mdl_bigGLM.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ml_wrappers.R +\name{mdl_bigGlm} +\alias{mdl_bigGlm} +\title{Wrapper for glmnet::bigGlm()} +\usage{ +mdl_bigGlm(y, X, ...) +} +\arguments{ +\item{y}{The outcome variable.} + +\item{X}{The (sparse) feature matrix.} + +\item{...}{Additional arguments passed to \code{bigGlm}. See +\code{\link[glmnet:bigGlm]{glmnet::bigGlm()}} for a complete list of arguments.} +} +\value{ +\code{mdl_bigGlm} returns an object of S3 class \code{mdl_bigGlm}. +} +\description{ +Simple wrapper for \code{\link[glmnet:bigGlm]{glmnet::bigGlm()}}, designed for sparse matrices. +} +\examples{ +bigglm_fit <- mdl_bigGlm(rnorm(100), matrix(rnorm(1000), 100, 10)) +class(bigglm_fit) +} +\seealso{ +\code{\link[glmnet:bigGlm]{glmnet::bigGlm()}} + +Other ml_wrapper: +\code{\link{mdl_glm}()}, +\code{\link{mdl_glmnet}()}, +\code{\link{mdl_ranger}()}, +\code{\link{mdl_xgboost}()}, +\code{\link{ols}()} +} +\concept{ml_wrapper} diff --git a/man/mdl_glm.Rd b/man/mdl_glm.Rd index d1757e2..778366e 100644 --- a/man/mdl_glm.Rd +++ b/man/mdl_glm.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ml_wrappers.R \name{mdl_glm} \alias{mdl_glm} -\title{Wrapper for \code{\link[stats:glm]{stats::glm()}}.} +\title{Wrapper for stats::glm()} \usage{ mdl_glm(y, X, ...) } @@ -30,6 +30,7 @@ class(glm_fit) \code{\link[stats:glm]{stats::glm()}} Other ml_wrapper: +\code{\link{mdl_bigGlm}()}, \code{\link{mdl_glmnet}()}, \code{\link{mdl_ranger}()}, \code{\link{mdl_xgboost}()}, diff --git a/man/mdl_glmnet.Rd b/man/mdl_glmnet.Rd index 324d3f6..ea7ef98 100644 --- a/man/mdl_glmnet.Rd +++ b/man/mdl_glmnet.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ml_wrappers.R \name{mdl_glmnet} \alias{mdl_glmnet} -\title{Wrapper for \code{\link[glmnet:glmnet]{glmnet::glmnet()}}.} +\title{Wrapper for glmnet::glmnet()} \usage{ mdl_glmnet(y, X, cv = TRUE, ...) } @@ -32,16 +32,17 @@ class(glmnet_fit) \references{ Friedman J, Hastie T, Tibshirani R (2010). "Regularization Paths for Generalized Linear Models via Coordinate Descent." Journal of Statistical -Software, 33(1), 1–22. +Software, 33(1), 1-22. Simon N, Friedman J, Hastie T, Tibshirani R (2011). "Regularization Paths for Cox's Proportional Hazards Model via Coordinate Descent." Journal of -Statistical Software, 39(5), 1–13. +Statistical Software, 39(5), 1-13. } \seealso{ \code{\link[glmnet:glmnet]{glmnet::glmnet()}},\code{\link[glmnet:cv.glmnet]{glmnet::cv.glmnet()}} Other ml_wrapper: +\code{\link{mdl_bigGlm}()}, \code{\link{mdl_glm}()}, \code{\link{mdl_ranger}()}, \code{\link{mdl_xgboost}()}, diff --git a/man/mdl_ranger.Rd b/man/mdl_ranger.Rd index 33f521b..1103ee0 100644 --- a/man/mdl_ranger.Rd +++ b/man/mdl_ranger.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ml_wrappers.R \name{mdl_ranger} \alias{mdl_ranger} -\title{Wrapper for \code{\link[ranger:ranger]{ranger::ranger()}}.} +\title{Wrapper for ranger::ranger()} \usage{ mdl_ranger(y, X, ...) } @@ -35,6 +35,7 @@ Software 77(1), 1-17. \code{\link[ranger:ranger]{ranger::ranger()}} Other ml_wrapper: +\code{\link{mdl_bigGlm}()}, \code{\link{mdl_glm}()}, \code{\link{mdl_glmnet}()}, \code{\link{mdl_xgboost}()}, diff --git a/man/mdl_xgboost.Rd b/man/mdl_xgboost.Rd index e0fde6c..1abc15a 100644 --- a/man/mdl_xgboost.Rd +++ b/man/mdl_xgboost.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ml_wrappers.R \name{mdl_xgboost} \alias{mdl_xgboost} -\title{Wrapper for \code{\link[xgboost:xgboost]{xgboost::xgboost()}}.} +\title{Wrapper for xgboost::xgboost()} \usage{ mdl_xgboost(y, X, nrounds = 500, verbosity = 0, ...) } @@ -38,12 +38,13 @@ class(xgboost_fit) \references{ Chen T, Guestrin C (2011). "Xgboost: A Scalable Tree Boosting System." Proceedings of the 22nd ACM SIGKDD International Conference on Knowledge -Discovery and Data Mining, 785–794. +Discovery and Data Mining, 785-794. } \seealso{ \code{\link[xgboost:xgboost]{xgboost::xgboost()}} Other ml_wrapper: +\code{\link{mdl_bigGlm}()}, \code{\link{mdl_glm}()}, \code{\link{mdl_glmnet}()}, \code{\link{mdl_ranger}()}, diff --git a/man/nobs.ral.Rd b/man/nobs.ral.Rd new file mode 100644 index 0000000..c94d309 --- /dev/null +++ b/man/nobs.ral.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral.R +\name{nobs.ral} +\alias{nobs.ral} +\title{Number of Observations in a RAL Object} +\usage{ +\method{nobs}{ral}(object, ...) +} +\arguments{ +\item{object}{An object inheriting from class \code{ral}.} + +\item{...}{Currently unused.} +} +\value{ +Integer. +} +\description{ +Number of Observations in a RAL Object +} diff --git a/man/ols.Rd b/man/ols.Rd index b34aaba..863c406 100644 --- a/man/ols.Rd +++ b/man/ols.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ols.R \name{ols} \alias{ols} -\title{Ordinary least squares.} +\title{Ordinary Least Squares} \usage{ ols(y, X, const = TRUE, w = NULL) } @@ -35,6 +35,7 @@ ols_fit$coef } \seealso{ Other ml_wrapper: +\code{\link{mdl_bigGlm}()}, \code{\link{mdl_glm}()}, \code{\link{mdl_glmnet}()}, \code{\link{mdl_ranger}()}, diff --git a/man/plot.ral.Rd b/man/plot.ral.Rd new file mode 100644 index 0000000..0bc475e --- /dev/null +++ b/man/plot.ral.Rd @@ -0,0 +1,97 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral.R, R/ral_rep.R +\name{plot.ral} +\alias{plot.ral} +\alias{plot.ral_rep} +\title{Plot Coefficients from a RAL Estimator} +\usage{ +\method{plot}{ral}( + x, + parm = NULL, + level = 0.95, + uniform = TRUE, + fit_idx = 1, + type = "HC1", + xlab = NULL, + ylab = NULL, + main = NULL, + col = "black", + pch = 19, + lwd = 1.5, + ... +) + +\method{plot}{ral_rep}( + x, + parm = NULL, + level = 0.95, + uniform = TRUE, + type = "HC1", + xlab = NULL, + ylab = NULL, + main = NULL, + col = "black", + pch = 19, + lwd = 1.5, + ... +) +} +\arguments{ +\item{x}{An object inheriting from class \code{ral}.} + +\item{parm}{A specification of which parameters to plot. +Either a vector of names or indices. Default: all.} + +\item{level}{Numeric. Confidence level. Default \code{0.95}.} + +\item{uniform}{Logical. If \code{TRUE}, uses uniform +confidence bands via the multiplier bootstrap. Default +\code{TRUE}.} + +\item{fit_idx}{Integer. Which fit to plot (column index of +\code{coefficients}). Default \code{1}.} + +\item{type}{Character. HC type for standard errors. +Default \code{"HC1"}.} + +\item{xlab}{Character. Label for the x-axis.} + +\item{ylab}{Character. Label for the y-axis.} + +\item{main}{Character. Title for the plot.} + +\item{col}{Color for points and segments. +Default \code{"black"}.} + +\item{pch}{Point character. Default \code{19} (solid dot).} + +\item{lwd}{Line width for confidence interval segments. +Default \code{1.5}.} + +\item{...}{Additional arguments passed to +\code{\link[graphics]{plot.default}}.} +} +\value{ +Invisibly returns a list with components +\code{coefficients}, \code{ci}, and \code{labels}. +} +\description{ +Plots point estimates with confidence intervals +from an object inheriting from class \code{ral}. +} +\examples{ +# Simulate a simple example +n <- 200 +X <- cbind(1, stats::rnorm(n)) +theta <- c(0.5, -0.3) +inf <- matrix(stats::rnorm(n * 2), n, 2) +obj <- ral(matrix(theta, 2, 1), + array(inf, c(n, 2, 1)), + nobs = n, + coef_names = c("b1", "b2")) +plot(obj) + +} +\seealso{ +\code{\link{confint.ral}}, \code{\link{summary.ral}} +} diff --git a/man/predict.ensemble.Rd b/man/predict.ensemble.Rd new file mode 100644 index 0000000..cd20f90 --- /dev/null +++ b/man/predict.ensemble.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ensemble.R +\name{predict.ensemble} +\alias{predict.ensemble} +\title{Predict Method for \code{ensemble} Objects} +\usage{ +\method{predict}{ensemble}(object, newdata, ..., type = "ensemble") +} +\arguments{ +\item{object}{A fitted \code{ensemble} object.} + +\item{newdata}{A feature matrix for prediction.} + +\item{...}{Currently unused.} + +\item{type}{Character; \code{"ensemble"} (default) returns +weighted ensemble predictions, \code{"bylearner"} returns +the raw per-learner prediction matrix.} +} +\value{ +A matrix of predictions. When \code{type = "ensemble"}, +one column per ensemble type; when \code{type = "bylearner"}, +one column per base learner. +} +\description{ +Predict Method for \code{ensemble} Objects +} diff --git a/man/predict.mdl_bigGLM.Rd b/man/predict.mdl_bigGLM.Rd new file mode 100644 index 0000000..74714c9 --- /dev/null +++ b/man/predict.mdl_bigGLM.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ml_wrappers.R +\name{predict.mdl_bigGlm} +\alias{predict.mdl_bigGlm} +\title{Predict Method for mdl_bigGlm Objects} +\usage{ +\method{predict}{mdl_bigGlm}(object, newdata = NULL, ...) +} +\arguments{ +\item{object}{A fitted \code{mdl_bigGlm} object.} + +\item{newdata}{A (sparse) feature matrix for prediction.} + +\item{...}{Currently unused.} +} +\value{ +A numeric vector of predicted values. +} +\description{ +Predict Method for mdl_bigGlm Objects +} diff --git a/man/predict.mdl_glm.Rd b/man/predict.mdl_glm.Rd new file mode 100644 index 0000000..83b6585 --- /dev/null +++ b/man/predict.mdl_glm.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ml_wrappers.R +\name{predict.mdl_glm} +\alias{predict.mdl_glm} +\title{Predict Method for mdl_glm Objects} +\usage{ +\method{predict}{mdl_glm}(object, newdata, ...) +} +\arguments{ +\item{object}{A fitted \code{mdl_glm} object.} + +\item{newdata}{A feature matrix for prediction.} + +\item{...}{Additional arguments passed to +\code{\link[stats:predict.glm]{predict.glm}}.} +} +\value{ +A numeric vector of predicted response values. +} +\description{ +Predict Method for mdl_glm Objects +} diff --git a/man/predict.mdl_glmnet.Rd b/man/predict.mdl_glmnet.Rd new file mode 100644 index 0000000..f0e00f5 --- /dev/null +++ b/man/predict.mdl_glmnet.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ml_wrappers.R +\name{predict.mdl_glmnet} +\alias{predict.mdl_glmnet} +\title{Predict Method for mdl_glmnet Objects} +\usage{ +\method{predict}{mdl_glmnet}(object, newdata = NULL, ...) +} +\arguments{ +\item{object}{A fitted \code{mdl_glmnet} object.} + +\item{newdata}{A (sparse) feature matrix for prediction.} + +\item{...}{Additional arguments passed to +\code{\link[glmnet:predict.glmnet]{predict.glmnet}}.} +} +\value{ +A numeric vector of predicted values. +} +\description{ +Predict Method for mdl_glmnet Objects +} diff --git a/man/predict.mdl_ranger.Rd b/man/predict.mdl_ranger.Rd new file mode 100644 index 0000000..868a179 --- /dev/null +++ b/man/predict.mdl_ranger.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ml_wrappers.R +\name{predict.mdl_ranger} +\alias{predict.mdl_ranger} +\title{Predict Method for mdl_ranger Objects} +\usage{ +\method{predict}{mdl_ranger}(object, newdata = NULL, ...) +} +\arguments{ +\item{object}{A fitted \code{mdl_ranger} object.} + +\item{newdata}{A feature matrix for prediction.} + +\item{...}{Additional arguments passed to +\code{\link[ranger:predict.ranger]{predict.ranger}}.} +} +\value{ +A numeric vector of predicted values (probabilities for +probability forests, point predictions for regression forests). +} +\description{ +Predict Method for mdl_ranger Objects +} diff --git a/man/predict.mdl_xgboost.Rd b/man/predict.mdl_xgboost.Rd new file mode 100644 index 0000000..34585f4 --- /dev/null +++ b/man/predict.mdl_xgboost.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ml_wrappers.R +\name{predict.mdl_xgboost} +\alias{predict.mdl_xgboost} +\title{Predict Method for mdl_xgboost Objects} +\usage{ +\method{predict}{mdl_xgboost}(object, newdata = NULL, ...) +} +\arguments{ +\item{object}{A fitted \code{mdl_xgboost} object.} + +\item{newdata}{A feature matrix for prediction.} + +\item{...}{Additional arguments passed to +\code{\link[xgboost:predict.xgb.Booster]{predict.xgb.Booster}}.} +} +\value{ +A numeric vector of predicted values. +} +\description{ +Predict Method for mdl_xgboost Objects +} diff --git a/man/predict.ols.Rd b/man/predict.ols.Rd new file mode 100644 index 0000000..998b2e2 --- /dev/null +++ b/man/predict.ols.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ols.R +\name{predict.ols} +\alias{predict.ols} +\title{Predict Method for ols Objects} +\usage{ +\method{predict}{ols}(object, newdata = NULL, ...) +} +\arguments{ +\item{object}{A fitted \code{ols} object.} + +\item{newdata}{A feature matrix for prediction. If \code{NULL}, +returns fitted values from the training data.} + +\item{...}{Currently unused.} +} +\value{ +A numeric vector of predicted values. +} +\description{ +Predict Method for ols Objects +} diff --git a/man/print.ddml_diagnostics.Rd b/man/print.ddml_diagnostics.Rd new file mode 100644 index 0000000..1756348 --- /dev/null +++ b/man/print.ddml_diagnostics.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/diagnostics.R +\name{print.ddml_diagnostics} +\alias{print.ddml_diagnostics} +\title{Print Stacking Diagnostics} +\usage{ +\method{print}{ddml_diagnostics}(x, digits = 4, ...) +} +\arguments{ +\item{x}{An object of class \code{ddml_diagnostics}.} + +\item{digits}{Number of significant digits. Default 4.} + +\item{...}{Currently unused.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Print Stacking Diagnostics +} diff --git a/man/print.summary.ddml_ate.Rd b/man/print.summary.ddml_ate.Rd deleted file mode 100644 index 533cfc9..0000000 --- a/man/print.summary.ddml_ate.Rd +++ /dev/null @@ -1,44 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml_ate.R, R/ddml_att.R, R/ddml_late.R -\name{print.summary.ddml_ate} -\alias{print.summary.ddml_ate} -\alias{print.summary.ddml_att} -\alias{print.summary.ddml_late} -\title{Print Methods for Treatment Effect Estimators.} -\usage{ -\method{print}{summary.ddml_ate}(x, digits = 3, ...) - -\method{print}{summary.ddml_att}(x, digits = 3, ...) - -\method{print}{summary.ddml_late}(x, digits = 3, ...) -} -\arguments{ -\item{x}{An object of class \code{summary.ddml_ate}, -\code{summary.ddml_att}, and \code{ddml_late}, as returned by -\code{\link[=summary.ddml_ate]{summary.ddml_ate()}}, \code{\link[=summary.ddml_att]{summary.ddml_att()}}, and -\code{\link[=summary.ddml_late]{summary.ddml_late()}}, respectively.} - -\item{digits}{The number of significant digits used for printing.} - -\item{...}{Currently unused.} -} -\value{ -NULL. -} -\description{ -Print methods for treatment effect estimators. -} -\examples{ -# Construct variables from the included Angrist & Evans (1998) data -y = AE98[, "worked"] -D = AE98[, "morekids"] -X = AE98[, c("age","agefst","black","hisp","othrace","educ")] - -# Estimate the average treatment effect using a single base learner, ridge. -ate_fit <- ddml_ate(y, D, X, - learners = list(what = mdl_glmnet, - args = list(alpha = 0)), - sample_folds = 2, - silent = TRUE) -summary(ate_fit) -} diff --git a/man/print.summary.ddml_plm.Rd b/man/print.summary.ddml_plm.Rd deleted file mode 100644 index 3f8ca5a..0000000 --- a/man/print.summary.ddml_plm.Rd +++ /dev/null @@ -1,44 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml_fpliv.R, R/ddml_pliv.R, R/ddml_plm.R -\name{print.summary.ddml_fpliv} -\alias{print.summary.ddml_fpliv} -\alias{print.summary.ddml_pliv} -\alias{print.summary.ddml_plm} -\title{Print Methods for Treatment Effect Estimators.} -\usage{ -\method{print}{summary.ddml_fpliv}(x, digits = 3, ...) - -\method{print}{summary.ddml_pliv}(x, digits = 3, ...) - -\method{print}{summary.ddml_plm}(x, digits = 3, ...) -} -\arguments{ -\item{x}{An object of class \code{summary.ddml_plm}, -\code{summary.ddml_pliv}, and \code{summary.ddml_fpliv}, as -returned by \code{\link[=summary.ddml_plm]{summary.ddml_plm()}}, \code{\link[=summary.ddml_pliv]{summary.ddml_pliv()}}, -and \code{\link[=summary.ddml_fpliv]{summary.ddml_fpliv()}}, respectively.} - -\item{digits}{Number of significant digits used for priniting.} - -\item{...}{Currently unused.} -} -\value{ -NULL. -} -\description{ -Print methods for treatment effect estimators. -} -\examples{ -# Construct variables from the included Angrist & Evans (1998) data -y = AE98[, "worked"] -D = AE98[, "morekids"] -X = AE98[, c("age","agefst","black","hisp","othrace","educ")] - -# Estimate the partially linear model using a single base learner, ridge. -plm_fit <- ddml_plm(y, D, X, - learners = list(what = mdl_glmnet, - args = list(alpha = 0)), - sample_folds = 2, - silent = TRUE) -summary(plm_fit) -} diff --git a/man/ral.Rd b/man/ral.Rd new file mode 100644 index 0000000..b7feed1 --- /dev/null +++ b/man/ral.Rd @@ -0,0 +1,80 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral.R +\name{ral} +\alias{ral} +\title{Construct a RAL Inference Object} +\usage{ +ral( + coefficients, + inf_func, + dinf_dtheta = NULL, + nobs, + coef_names, + cluster_variable = NULL, + estimator_name = "RAL estimator", + subclass = NULL, + ... +) +} +\arguments{ +\item{coefficients}{A \eqn{p \times}{p x} \code{nfit} matrix +of estimated coefficients. Rows are parameters, columns +are fits (e.g., ensemble types).} + +\item{inf_func}{A 3D array of dimension +\eqn{n \times p \times}{n x p x} \code{nfit}. The +influence function evaluated at each observation.} + +\item{dinf_dtheta}{Optional 4D array of dimension +\eqn{n \times p \times p \times}{n x p x p x} +\code{nfit}. The derivative of the influence function +with respect to \eqn{\theta}, used for HC3 leverage. +If \code{NULL}, HC3 is unavailable.} + +\item{nobs}{Integer number of observations.} + +\item{coef_names}{Character vector of parameter names (length \eqn{p}).} + +\item{cluster_variable}{Optional vector of cluster identifiers (length \eqn{n}). +If non-\code{NULL}, cluster-robust inference is used.} + +\item{estimator_name}{Character string for display.} + +\item{subclass}{Optional character string prepended to the class vector.} + +\item{...}{Additional named elements stored in the object.} +} +\value{ +An object of class \code{ral} (or \code{c(subclass, "ral")}). +} +\description{ +Creates a regular asymptotically linear (RAL) +inference object from pre-computed influence functions. +This is the base class for all influence-function-based +inference in \pkg{ddml}. +} +\details{ +A regular asymptotically linear (RAL) estimator +\eqn{\hat\theta} satisfies + +\deqn{\hat\theta - \theta_0 = \frac{1}{n} \sum_{i=1}^{n} + \phi(W_i; \theta_0) + o_p(n^{-1/2}),} + +where \eqn{\phi(W_i; \theta_0)} is the \emph{influence +function}. This package stores the estimated influence +function \eqn{\hat\phi_i \equiv \phi(W_i; \hat\theta)} +in the \code{inf_func} slot. + +When an observation-level derivative +\eqn{-n^{-1}\,\partial \hat\phi_i / \partial \theta} +is available (stored in \code{dinf_dtheta}), the estimator +supports HC3 inference via leverage; see +\code{\link{hatvalues.ral}}. + +The RAL framework is estimator-agnostic: it consumes +pre-computed influence functions and does not prescribe how +they are obtained. For the specific construction under +cross-fitting and Neyman-orthogonal scores, see +\code{\link{ddml-intro}}. For linear combinations of +\code{ddml} estimators, see \code{\link{lincom}}. +} diff --git a/man/ral_rep.Rd b/man/ral_rep.Rd new file mode 100644 index 0000000..167bfdb --- /dev/null +++ b/man/ral_rep.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral_rep.R +\name{ral_rep} +\alias{ral_rep} +\title{Construct a Replicated RAL Inference Object} +\usage{ +ral_rep(fits, subclass = NULL, ...) +} +\arguments{ +\item{fits}{A list of at least 2 objects inheriting from +class \code{"ral"}. All fits must share the same +coefficient names and number of observations.} + +\item{subclass}{Optional character string prepended to +the class vector.} + +\item{...}{Additional named elements stored in the object.} +} +\value{ +An object of class \code{"ral_rep"} (or +\code{c(subclass, "ral_rep")}). +} +\description{ +Creates a replicated RAL inference object +from a list of \code{ral} objects. Provides +cross-resample aggregation for coefficients and +covariance matrices. +} diff --git a/man/reexports.Rd b/man/reexports.Rd new file mode 100644 index 0000000..15a4c72 --- /dev/null +++ b/man/reexports.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml.R +\docType{import} +\name{reexports} +\alias{reexports} +\alias{tidy} +\alias{glance} +\title{Objects exported from other packages} +\keyword{internal} +\description{ +These objects are imported from other packages. Follow the links +below to see their documentation. + +\describe{ + \item{generics}{\code{\link[generics]{glance}}, \code{\link[generics]{tidy}}} +}} + diff --git a/man/shortstacking.Rd b/man/shortstacking.Rd index 64fd04b..6ca7dbc 100644 --- a/man/shortstacking.Rd +++ b/man/shortstacking.Rd @@ -2,22 +2,20 @@ % Please edit documentation in R/shortstacking.R \name{shortstacking} \alias{shortstacking} -\title{Predictions using Short-Stacking.} +\title{Predictions using Short-Stacking} \usage{ shortstacking( y, X, - Z = NULL, learners, sample_folds = 2, ensemble_type = "average", custom_ensemble_weights = NULL, - compute_insample_predictions = FALSE, + cluster_variable = seq_along(y), subsamples = NULL, silent = FALSE, - progress = NULL, auxiliary_X = NULL, - shortstack_y = y + parallel = NULL ) } \arguments{ @@ -25,96 +23,90 @@ shortstacking( \item{X}{A (sparse) matrix of predictive variables.} -\item{Z}{Optional additional (sparse) matrix of predictive variables.} - -\item{learners}{May take one of two forms, depending on whether a single -learner or stacking with multiple learners is used for estimation of the -predictor. -If a single learner is used, \code{learners} is a list with two named -elements: +\item{learners}{\code{learners} is a list of lists, each containing three +named elements: \itemize{ \item{\code{what} The base learner function. The function must be such that it predicts a named input \code{y} using a named input \code{X}.} \item{\code{args} Optional arguments to be passed to \code{what}.} -} -If stacking with multiple learners is used, \code{learners} is a list of -lists, each containing four named elements: -\itemize{ -\item{\code{fun} The base learner function. The function must be -such that it predicts a named input \code{y} using a named input -\code{X}.} -\item{\code{args} Optional arguments to be passed to \code{fun}.} \item{\code{assign_X} An optional vector of column indices -corresponding to predictive variables in \code{X} that are passed to +corresponding to variables in \code{X} that are passed to the base learner.} -\item{\code{assign_Z} An optional vector of column indices -corresponding to predictive in \code{Z} that are passed to the -base learner.} } Omission of the \code{args} element results in default arguments being -used in \code{fun}. Omission of \code{assign_X} (and/or \code{assign_Z}) -results in inclusion of all variables in \code{X} (and/or \code{Z}).} +used in \code{what}. Omission of \code{assign_X} +results in inclusion of all predictive variables in \code{X}.} \item{sample_folds}{Number of cross-fitting folds.} -\item{ensemble_type}{Ensemble method to combine base learners into final -estimate of the conditional expectation functions. Possible values are: +\item{ensemble_type}{Ensemble method to combine base learners into +final estimate of the conditional expectation functions. +Possible values are: \itemize{ \item{\code{"nnls"} Non-negative least squares.} -\item{\code{"nnls1"} Non-negative least squares with the constraint -that all weights sum to one.} -\item{\code{"singlebest"} Select base learner with minimum MSPE.} +\item{\code{"nnls1"} Non-negative least squares with the +constraint that all weights sum to one.} +\item{\code{"singlebest"} Select base learner with minimum +MSPE.} \item{\code{"ols"} Ordinary least squares.} \item{\code{"average"} Simple average over base learners.} } Multiple ensemble types may be passed as a vector of strings.} -\item{custom_ensemble_weights}{A numerical matrix with user-specified -ensemble weights. Each column corresponds to a custom ensemble -specification, each row corresponds to a base learner in \code{learners} -(in chronological order). Optional column names are used to name the -estimation results corresponding the custom ensemble specification.} +\item{custom_ensemble_weights}{A numerical matrix with +user-specified ensemble weights. Each column corresponds to a +custom ensemble specification, each row corresponds to a base +learner in \code{learners} (in chronological order). Optional +column names are used to name the estimation results +corresponding the custom ensemble specification.} -\item{compute_insample_predictions}{Indicator equal to 1 if in-sample -predictions should also be computed.} +\item{cluster_variable}{A vector of cluster indices.} \item{subsamples}{List of vectors with sample indices for cross-fitting.} \item{silent}{Boolean to silence estimation updates.} -\item{progress}{String to print before learner and cv fold progress.} - \item{auxiliary_X}{An optional list of matrices of length \code{sample_folds}, each containing additional observations to calculate predictions for.} -\item{shortstack_y}{Optional vector of the outcome variable to form -short-stacking predictions for. Base learners are always trained on -\code{y}.} +\item{parallel}{An optional named list with parallel processing +options. When \code{NULL} (the default), computation is +sequential. Supported fields: +\describe{ +\item{\code{cores}}{Number of cores to use.} +\item{\code{export}}{Character vector of object names to +export to parallel workers (for custom learners that +reference global objects).} +\item{\code{packages}}{Character vector of additional +package names to load on workers (for custom learners +that use packages not imported by \code{ddml}).} +}} } \value{ \code{shortstack} returns a list containing the following components: \describe{ -\item{\code{oos_fitted}}{A matrix of out-of-sample predictions, +\item{\code{cf_fitted}}{A matrix of out-of-sample predictions, each column corresponding to an ensemble type (in chronological order).} \item{\code{weights}}{An array, providing the weight assigned to each base learner (in chronological order) by the ensemble procedures.} -\item{\code{is_fitted}}{When \code{compute_insample_predictions = T}. -a list of matrices with in-sample predictions by sample fold.} +\item{\code{mspe}}{A numeric vector of per-learner out-of-sample +MSPEs, computed from cross-fitted residuals.} +\item{\code{r2}}{A numeric vector of per-learner out-of-sample +R-squared values.} \item{\code{auxiliary_fitted}}{When \code{auxiliary_X} is not \code{NULL}, a list of matrices with additional predictions.} -\item{\code{oos_fitted_bylearner}}{A matrix of -out-of-sample predictions, each column corresponding to a base -learner (in chronological order).} -\item{\code{is_fitted_bylearner}}{When -\code{compute_insample_predictions = T}, a list of matrices with -in-sample predictions by sample fold.} +\item{\code{cf_fitted_bylearner}}{A matrix of out-of-sample +predictions, each column corresponding to a base learner (in +chronological order).} +\item{\code{cf_resid_bylearner}}{A matrix of per-learner +out-of-sample residuals used for weight estimation.} \item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} is -not \code{NULL}, a -list of matrices with additional predictions for each learner.} +not \code{NULL}, a list of matrices with additional predictions +for each learner.} } Note that unlike \code{crosspred}, \code{shortstack} always computes out-of-sample predictions for each base learner (at no additional @@ -134,15 +126,15 @@ X = AE98[, c("morekids", "age","agefst","black","hisp","othrace","educ")] # in the unit simplex (ensemble_type = "nnls1"). Predictions for each # learner are also calculated. shortstack_res <- shortstacking(y, X, - learners = list(list(fun = ols), - list(fun = mdl_glmnet)), + learners = list(list(what = ols), + list(what = mdl_glmnet)), ensemble_type = c("average", "nnls1", "singlebest"), sample_folds = 2, silent = TRUE) -dim(shortstack_res$oos_fitted) # = length(y) by length(ensemble_type) -dim(shortstack_res$oos_fitted_bylearner) # = length(y) by length(learners) +dim(shortstack_res$cf_fitted) # = length(y) by length(ensemble_type) +dim(shortstack_res$cf_fitted_bylearner) # = length(y) by length(learners) } \references{ Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and @@ -153,6 +145,10 @@ Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. \seealso{ Other utilities: \code{\link{crosspred}()}, -\code{\link{crossval}()} +\code{\link{crossval}()}, +\code{\link{ddml}()}, +\code{\link{diagnostics}()}, +\code{\link{ensemble}()}, +\code{\link{ensemble_weights}()} } \concept{utilities} diff --git a/man/sub-.summary.ddml.Rd b/man/sub-.summary.ddml.Rd new file mode 100644 index 0000000..429baf5 --- /dev/null +++ b/man/sub-.summary.ddml.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml.R +\name{[.summary.ddml} +\alias{[.summary.ddml} +\title{Subscript a summary.ddml object (deprecated).} +\usage{ +\method{[}{summary.ddml}(x, ...) +} +\arguments{ +\item{x}{An object of class \code{summary.ddml}.} + +\item{...}{Indices passed to \code{[}.} +} +\description{ +Subscript a summary.ddml object (deprecated). +} +\keyword{internal} diff --git a/man/summary.ddml.Rd b/man/summary.ddml.Rd new file mode 100644 index 0000000..664c13f --- /dev/null +++ b/man/summary.ddml.Rd @@ -0,0 +1,64 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml.R +\name{summary.ddml} +\alias{summary.ddml} +\alias{print.summary.ddml} +\title{Summary for DDML Estimators} +\usage{ +\method{summary}{ddml}(object, type = "HC1", ...) + +\method{print}{summary.ddml}(x, digits = 3, ...) +} +\arguments{ +\item{object}{An object of class \code{ddml}.} + +\item{type}{Character. HC type (\code{"HC0"}, +\code{"HC1"}, or \code{"HC3"}). Default +\code{"HC1"}.} + +\item{...}{Currently unused.} + +\item{x}{An object of class \code{summary.ddml}.} + +\item{digits}{Number of significant digits. Default 3.} +} +\value{ +An object of class \code{summary.ddml} with: +\describe{ +\item{\code{coefficients}}{A 3-dimensional array +(\eqn{p \times 4 \times}{p x 4 x} nensb) of estimates, standard +errors, z-values, and p-values.} +\item{\code{type}}{The HC type used.} +\item{\code{nobs}}{Number of observations.} +\item{\code{sample_folds}}{Number of cross-fitting +folds.} +\item{\code{ensemble_type}}{Ensemble type labels.} +} +} +\description{ +Computes a coefficient table with estimates, +standard errors, z-values, and p-values for all +ensemble types. Standard errors are based on a +heteroskedasticity-robust sandwich variance; see +\code{\link{vcov.ral}} for the HC0/HC1/HC3 formulas. +} +\examples{ +\donttest{ +y = AE98[, "worked"] +D = AE98[, "morekids"] +X = AE98[, c("age","agefst","black","hisp","othrace")] +plm_fit = ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, silent = TRUE) +summary(plm_fit) +summary(plm_fit, type = "HC3") +} + +} +\seealso{ +\code{\link{vcov.ral}} + +Other ddml inference: +\code{\link{lincom}()} +} +\concept{ddml inference} diff --git a/man/summary.ddml_ate.Rd b/man/summary.ddml_ate.Rd deleted file mode 100644 index bb7c0e3..0000000 --- a/man/summary.ddml_ate.Rd +++ /dev/null @@ -1,44 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml_ate.R, R/ddml_att.R, R/ddml_late.R -\name{summary.ddml_ate} -\alias{summary.ddml_ate} -\alias{summary.ddml_att} -\alias{summary.ddml_late} -\title{Inference Methods for Treatment Effect Estimators.} -\usage{ -\method{summary}{ddml_ate}(object, ...) - -\method{summary}{ddml_att}(object, ...) - -\method{summary}{ddml_late}(object, ...) -} -\arguments{ -\item{object}{An object of class \code{ddml_ate}, \code{ddml_att}, and -\code{ddml_late}, as fitted by \code{\link[=ddml_ate]{ddml_ate()}}, \code{\link[=ddml_att]{ddml_att()}}, -and \code{\link[=ddml_late]{ddml_late()}}, respectively.} - -\item{...}{Currently unused.} -} -\value{ -A matrix with inference results. -} -\description{ -Inference methods for treatment effect estimators. By default, -standard errors are heteroskedasiticty-robust. If the \code{ddml} -estimator was computed using a \code{cluster_variable}, the standard -errors are also cluster-robust by default. -} -\examples{ -# Construct variables from the included Angrist & Evans (1998) data -y = AE98[, "worked"] -D = AE98[, "morekids"] -X = AE98[, c("age","agefst","black","hisp","othrace","educ")] - -# Estimate the average treatment effect using a single base learner, ridge. -ate_fit <- ddml_ate(y, D, X, - learners = list(what = mdl_glmnet, - args = list(alpha = 0)), - sample_folds = 2, - silent = TRUE) -summary(ate_fit) -} diff --git a/man/summary.ddml_plm.Rd b/man/summary.ddml_plm.Rd deleted file mode 100644 index 37e967c..0000000 --- a/man/summary.ddml_plm.Rd +++ /dev/null @@ -1,61 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml_fpliv.R, R/ddml_pliv.R, R/ddml_plm.R -\name{summary.ddml_fpliv} -\alias{summary.ddml_fpliv} -\alias{summary.ddml_pliv} -\alias{summary.ddml_plm} -\title{Inference Methods for Partially Linear Estimators.} -\usage{ -\method{summary}{ddml_fpliv}(object, ...) - -\method{summary}{ddml_pliv}(object, ...) - -\method{summary}{ddml_plm}(object, ...) -} -\arguments{ -\item{object}{An object of class \code{ddml_plm}, \code{ddml_pliv}, or -\code{ddml_fpliv} as fitted by \code{\link[=ddml_plm]{ddml_plm()}}, \code{\link[=ddml_pliv]{ddml_pliv()}}, -and \code{\link[=ddml_fpliv]{ddml_fpliv()}}, respectively.} - -\item{...}{Additional arguments passed to \code{vcovHC} and \code{vcovCL}. -See \code{\link[sandwich:vcovHC]{sandwich::vcovHC()}} and \code{\link[sandwich:vcovCL]{sandwich::vcovCL()}} for a complete list of -arguments.} -} -\value{ -An array with inference results for each \code{ensemble_type}. -} -\description{ -Inference methods for partially linear estimators. Simple -wrapper for \code{\link[sandwich:vcovHC]{sandwich::vcovHC()}} and \code{\link[sandwich:vcovCL]{sandwich::vcovCL()}}. Default -standard errors are heteroskedasiticty-robust. If the \code{ddml} -estimator was computed using a \code{cluster_variable}, the standard -errors are also cluster-robust by default. -} -\examples{ -# Construct variables from the included Angrist & Evans (1998) data -y = AE98[, "worked"] -D = AE98[, "morekids"] -X = AE98[, c("age","agefst","black","hisp","othrace","educ")] - -# Estimate the partially linear model using a single base learner, ridge. -plm_fit <- ddml_plm(y, D, X, - learners = list(what = mdl_glmnet, - args = list(alpha = 0)), - sample_folds = 2, - silent = TRUE) -summary(plm_fit) -} -\references{ -Zeileis A (2004). "Econometric Computing with HC and HAC Covariance Matrix -Estimators.” Journal of Statistical Software, 11(10), 1-17. - -Zeileis A (2006). “Object-Oriented Computation of Sandwich Estimators.” -Journal of Statistical Software, 16(9), 1-16. - -Zeileis A, Köll S, Graham N (2020). “Various Versatile Variances: An -Object-Oriented Implementation of Clustered Covariances in R.” Journal of -Statistical Software, 95(1), 1-36. -} -\seealso{ -\code{\link[sandwich:vcovHC]{sandwich::vcovHC()}}, \code{\link[sandwich:vcovCL]{sandwich::vcovCL()}} -} diff --git a/man/summary.ddml_rep.Rd b/man/summary.ddml_rep.Rd new file mode 100644 index 0000000..a11a7b5 --- /dev/null +++ b/man/summary.ddml_rep.Rd @@ -0,0 +1,63 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{summary.ddml_rep} +\alias{summary.ddml_rep} +\alias{print.summary.ddml_rep} +\title{Summary for ddml_rep Objects} +\usage{ +\method{summary}{ddml_rep}( + object, + aggregation = c("median", "mean", "spectral"), + type = "HC1", + ... +) + +\method{print}{summary.ddml_rep}(x, digits = 3, ...) +} +\arguments{ +\item{object}{A \code{ddml_rep} object.} + +\item{aggregation}{Character string: \code{"median"} +(default), \code{"mean"}, or \code{"spectral"}.} + +\item{type}{Character. HC type. Default \code{"HC1"}.} + +\item{...}{Currently unused.} + +\item{x}{An object of class \code{summary.ddml_rep}.} + +\item{digits}{Number of significant digits. Default 3.} +} +\value{ +An object of class \code{"summary.ddml_rep"}. +} +\description{ +DML-specific summary override. Adds ensemble type labels, +folds, shortstack status to the base \code{ral_rep} +summary. +} +\details{ +See \code{\link{summary.ral_rep}} for the aggregation +formulas. +} +\examples{ +\donttest{ +y = AE98[, "worked"] +D = AE98[, "morekids"] +X = AE98[, c("age","agefst","black","hisp","othrace")] +reps = ddml_replicate(ddml_plm, y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, silent = TRUE) +summary(reps) +summary(reps, aggregation = "mean") +} + +} +\references{ +Chernozhukov V, Chetverikov D, Demirer M, Duflo E, +Hansen C B, Newey W, Robins J (2018). +"Double/debiased machine learning for treatment +and structural parameters." The Econometrics +Journal, 21(1), C1-C68. +} diff --git a/man/summary.ral.Rd b/man/summary.ral.Rd new file mode 100644 index 0000000..6e6ab08 --- /dev/null +++ b/man/summary.ral.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral.R +\name{summary.ral} +\alias{summary.ral} +\alias{print.summary.ral} +\title{Summary for RAL Estimators} +\usage{ +\method{summary}{ral}(object, type = "HC1", ...) + +\method{print}{summary.ral}(x, digits = 3, ...) +} +\arguments{ +\item{object}{An object inheriting from class \code{ral}.} + +\item{type}{Character. HC type. Default \code{"HC1"}.} + +\item{...}{Currently unused.} + +\item{x}{An object of class \code{summary.ral}.} + +\item{digits}{Number of significant digits. Default 3.} +} +\value{ +An object of class \code{summary.ral} with: +\describe{ +\item{\code{coefficients}}{A 3-dimensional array +(\eqn{p \times 4 \times}{p x 4 x} nfit).} +\item{\code{type}}{The HC type used.} +\item{\code{nobs}}{Number of observations.} +} +} +\description{ +Computes a coefficient table with estimates, +standard errors, z-values, and p-values. +} diff --git a/man/summary.ral_rep.Rd b/man/summary.ral_rep.Rd new file mode 100644 index 0000000..15c22c1 --- /dev/null +++ b/man/summary.ral_rep.Rd @@ -0,0 +1,66 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral_rep.R +\name{summary.ral_rep} +\alias{summary.ral_rep} +\alias{print.summary.ral_rep} +\title{Summary for RAL Rep Objects} +\usage{ +\method{summary}{ral_rep}( + object, + aggregation = c("median", "mean", "spectral"), + type = "HC1", + ... +) + +\method{print}{summary.ral_rep}(x, digits = 3, ...) +} +\arguments{ +\item{object}{An object inheriting from class +\code{ral_rep}.} + +\item{aggregation}{Character string. Aggregation rule.} + +\item{type}{Character. HC type. Default \code{"HC1"}.} + +\item{...}{Currently unused.} + +\item{x}{An object of class \code{summary.ral_rep}.} + +\item{digits}{Number of significant digits. Default 3.} +} +\value{ +An object of class \code{"summary.ral_rep"}. +} +\description{ +Aggregates coefficient estimates and covariance matrices +across independent replications. +} +\details{ +Let \eqn{\hat\theta_s} and \eqn{\hat\Sigma_s} denote +the coefficient vector and sandwich covariance matrix +from replication \eqn{s}. + +\strong{Coefficient aggregation.} +For \code{"mean"}: +\eqn{\tilde\theta = S^{-1} \sum_{s=1}^{S} \hat\theta_s}. +For \code{"median"} and \code{"spectral"}: +\eqn{\tilde\theta_j = \mathrm{median}_{s}(\hat\theta_{s,j})}. + +\strong{Covariance aggregation.} +Define the inflated per-replication covariance as +\deqn{V_s = \hat\Sigma_s + (\hat\theta_s - \tilde\theta) + (\hat\theta_s - \tilde\theta)^\top.} +For \code{"mean"}: +\eqn{\tilde\Sigma = S^{-1} \sum_{s=1}^{S} V_s}. +For \code{"median"}: +\eqn{\tilde\Sigma_{s,ij} = \mathrm{median}_{s}(V_{s,ij})}. +For \code{"spectral"}: +solved via \pkg{CVXR}, guaranteeing PSD. +} +\references{ +Chernozhukov V, Chetverikov D, Demirer M, Duflo E, +Hansen C B, Newey W, Robins J (2018). +"Double/debiased machine learning for treatment +and structural parameters." The Econometrics +Journal, 21(1), C1-C68. +} diff --git a/man/tidy.ddml.Rd b/man/tidy.ddml.Rd new file mode 100644 index 0000000..6c63d29 --- /dev/null +++ b/man/tidy.ddml.Rd @@ -0,0 +1,60 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml.R +\name{tidy.ddml} +\alias{tidy.ddml} +\title{Tidy a DDML Object} +\usage{ +\method{tidy}{ddml}( + x, + ensemble_idx = 1, + conf.int = FALSE, + conf.level = 0.95, + type = "HC1", + uniform = FALSE, + bootstraps = 999L, + ... +) +} +\arguments{ +\item{x}{A \code{ddml} object.} + +\item{ensemble_idx}{Integer index of the ensemble type to +report. Defaults to 1. Set to \code{NULL} for all.} + +\item{conf.int}{Logical. Include confidence intervals? +Default \code{FALSE}.} + +\item{conf.level}{Confidence level. Default 0.95.} + +\item{type}{Character. HC type. Default \code{"HC1"}.} + +\item{uniform}{Logical. Uniform CIs? Default \code{FALSE}.} + +\item{bootstraps}{Integer. Bootstrap draws. Default 999.} + +\item{...}{Currently unused.} +} +\value{ +A \code{data.frame} with columns \code{term}, +\code{estimate}, \code{std.error}, \code{statistic}, +\code{p.value}, and \code{ensemble_type}. +} +\description{ +DML-specific tidy method. Adds \code{ensemble_type} +column labeling based on the estimator's learner/ensemble +configuration. Delegates to \code{tidy.ral} for the base +table computation. +} +\examples{ +\donttest{ +y = AE98[, "worked"] +D = AE98[, "morekids"] +X = AE98[, c("age","agefst","black","hisp","othrace")] +plm_fit = ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, silent = TRUE) +tidy(plm_fit) +tidy(plm_fit, conf.int = TRUE) +} + +} diff --git a/man/tidy.ddml_diagnostics.Rd b/man/tidy.ddml_diagnostics.Rd new file mode 100644 index 0000000..8bb8977 --- /dev/null +++ b/man/tidy.ddml_diagnostics.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/diagnostics.R +\name{tidy.ddml_diagnostics} +\alias{tidy.ddml_diagnostics} +\title{Tidy Stacking Diagnostics} +\usage{ +\method{tidy}{ddml_diagnostics}(x, ...) +} +\arguments{ +\item{x}{An object of class \code{ddml_diagnostics}.} + +\item{...}{Currently unused.} +} +\value{ +A \code{data.frame} with columns \code{equation}, \code{learner}, +\code{mspe}, \code{r2}, \code{weight}, and optionally \code{cvc_pval}. +} +\description{ +Returns a flat data.frame of per-learner stacking +diagnostics for all nuisance equations. Suitable for +table creation with \code{kable()}, \code{gt()}, or +\code{modelsummary::datasummary()}. +} +\examples{ +\donttest{ +y = AE98[, "worked"] +D = AE98[, "morekids"] +X = AE98[, c("age","agefst","black","hisp","othrace")] +learners = list(list(what = ols), + list(what = mdl_glmnet)) +plm_fit = ddml_plm(y, D, X, + learners = learners, + sample_folds = 2, silent = TRUE) +tidy(diagnostics(plm_fit, cvc = TRUE)) +} + +} diff --git a/man/tidy.ddml_rep.Rd b/man/tidy.ddml_rep.Rd new file mode 100644 index 0000000..90801e1 --- /dev/null +++ b/man/tidy.ddml_rep.Rd @@ -0,0 +1,70 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{tidy.ddml_rep} +\alias{tidy.ddml_rep} +\title{Tidy a ddml_rep Object} +\usage{ +\method{tidy}{ddml_rep}( + x, + ensemble_idx = 1, + aggregation = c("median", "mean", "spectral"), + type = "HC1", + conf.int = FALSE, + conf.level = 0.95, + uniform = FALSE, + bootstraps = 999L, + ... +) +} +\arguments{ +\item{x}{A \code{ddml_rep} object.} + +\item{ensemble_idx}{Integer index of the ensemble type +to report. Defaults to 1. Set to \code{NULL} for +all ensemble types.} + +\item{aggregation}{Character string. Aggregation method.} + +\item{type}{Character. HC type. Default \code{"HC1"}.} + +\item{conf.int}{Logical. Include CIs? Default +\code{FALSE}.} + +\item{conf.level}{Confidence level. Default 0.95.} + +\item{uniform}{Logical. Uniform CIs? Default +\code{FALSE}.} + +\item{bootstraps}{Integer. Bootstrap draws. Default 999.} + +\item{...}{Currently unused.} +} +\value{ +A \code{data.frame} with columns \code{term}, +\code{estimate}, \code{std.error}, \code{statistic}, +\code{p.value}, \code{ensemble_type}, and +\code{aggregation}. +} +\description{ +DML-specific tidy method. Adds \code{ensemble_type} and +\code{aggregation} columns. Delegates to +\code{tidy.ral_rep} for the base table computation. +} +\examples{ +\donttest{ +y = AE98[, "worked"] +D = AE98[, "morekids"] +X = AE98[, c("age","agefst","black","hisp","othrace")] +reps = ddml_replicate(ddml_plm, y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, silent = TRUE) +tidy(reps) +tidy(reps, conf.int = TRUE) +} + +} +\seealso{ +\code{\link{summary.ddml_rep}} for the +aggregation equations. +} diff --git a/man/tidy.ral.Rd b/man/tidy.ral.Rd new file mode 100644 index 0000000..224276d --- /dev/null +++ b/man/tidy.ral.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral.R +\name{tidy.ral} +\alias{tidy.ral} +\title{Tidy a RAL Object} +\usage{ +\method{tidy}{ral}( + x, + fit_idx = 1, + conf.int = FALSE, + conf.level = 0.95, + type = "HC1", + uniform = FALSE, + bootstraps = 999L, + ... +) +} +\arguments{ +\item{x}{An object inheriting from class \code{ral}.} + +\item{fit_idx}{Integer index of the fit to report. +Defaults to 1. Set to \code{NULL} for all fits.} + +\item{conf.int}{Logical. Include confidence intervals? +Default \code{FALSE}.} + +\item{conf.level}{Confidence level. Default 0.95.} + +\item{type}{Character. HC type. Default \code{"HC1"}.} + +\item{uniform}{Logical. Uniform confidence bands? +Default \code{FALSE}.} + +\item{bootstraps}{Integer. Bootstrap draws. Default 999.} + +\item{...}{Currently unused.} +} +\value{ +A \code{data.frame} with columns \code{term}, +\code{estimate}, \code{std.error}, \code{statistic}, +\code{p.value}, and \code{fit_label}. +} +\description{ +Extracts coefficient estimates, standard errors, test +statistics, and p-values in a tidy data frame. +} +\references{ +Chernozhukov V, Chetverikov D, Kato K (2013). "Gaussian +approximations and multiplier bootstrap for maxima of sums +of high-dimensional random vectors." Annals of Statistics, +41(6), 2786-2819. +} diff --git a/man/tidy.ral_rep.Rd b/man/tidy.ral_rep.Rd new file mode 100644 index 0000000..05ee42e --- /dev/null +++ b/man/tidy.ral_rep.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral_rep.R +\name{tidy.ral_rep} +\alias{tidy.ral_rep} +\title{Tidy a RAL Rep Object} +\usage{ +\method{tidy}{ral_rep}( + x, + fit_idx = 1, + aggregation = c("median", "mean", "spectral"), + type = "HC1", + conf.int = FALSE, + conf.level = 0.95, + uniform = FALSE, + bootstraps = 999L, + ... +) +} +\arguments{ +\item{x}{An object inheriting from class \code{ral_rep}.} + +\item{fit_idx}{Integer index of the fit. Defaults to 1. +Set to \code{NULL} for all fits.} + +\item{aggregation}{Character string. Aggregation rule.} + +\item{type}{Character. HC type. Default \code{"HC1"}.} + +\item{conf.int}{Logical. Include CIs? Default +\code{FALSE}.} + +\item{conf.level}{Confidence level. Default 0.95.} + +\item{uniform}{Logical. Uniform CIs? Default +\code{FALSE}.} + +\item{bootstraps}{Integer. Bootstrap draws. Default 999.} + +\item{...}{Currently unused.} +} +\value{ +A \code{data.frame} with columns \code{term}, +\code{estimate}, \code{std.error}, \code{statistic}, +\code{p.value}, \code{fit_label}, and +\code{aggregation}. +} +\description{ +Tidy a RAL Rep Object +} diff --git a/man/vcov.ral.Rd b/man/vcov.ral.Rd new file mode 100644 index 0000000..d7c0b3f --- /dev/null +++ b/man/vcov.ral.Rd @@ -0,0 +1,64 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral.R +\name{vcov.ral} +\alias{vcov.ral} +\title{Variance-Covariance Matrix for RAL Estimators} +\usage{ +\method{vcov}{ral}(object, fit_idx = 1, type = "HC1", ...) +} +\arguments{ +\item{object}{An object inheriting from class \code{ral}.} + +\item{fit_idx}{Integer index of the fit. Defaults to 1.} + +\item{type}{Character. One of \code{"HC1"} (default), +\code{"HC0"}, or \code{"HC3"}.} + +\item{...}{Currently unused.} +} +\value{ +A \eqn{p \times p}{p x p} variance-covariance +matrix. +} +\description{ +Computes a heteroskedasticity-robust +variance-covariance matrix. +} +\details{ +Let \eqn{\hat\phi_i} denote the estimated +influence function at observation \eqn{i}. Three +variance estimators are available: + +\strong{HC0}: +\deqn{V_{\mathrm{HC0}} = \frac{1}{n^2}\sum_i + \hat\phi_i\,\hat\phi_i'} + +\strong{HC1} (default): +\deqn{V_{\mathrm{HC1}} = V_{\mathrm{HC0}} + \times \frac{n}{n - p}} + +\strong{HC3}: +\deqn{V_{\mathrm{HC3}} = \frac{1}{n^2}\sum_i + \frac{\hat\phi_i\,\hat\phi_i'} + {(1 - \hat{h}_{\theta,i})^2}} + +where \eqn{\hat{h}_{\theta,i}} is the leverage; +see \code{\link{hatvalues.ral}}. + +\strong{Cluster-robust inference.} When +\code{cluster_variable} is non-\code{NULL} and identifies +fewer groups than observations, the observation-level +influence functions are aggregated to cluster-level +influence functions + +\deqn{\hat\Phi_g = \frac{G}{n} \sum_{i \in C_g} \hat\phi_i} + +and the variance is computed as + +\deqn{V_{\mathrm{HC0}} = \frac{1}{G^2} \sum_{g=1}^{G} + \hat\Phi_g\,\hat\Phi_g'.} +} +\seealso{ +\code{\link{hatvalues.ral}}, +\code{\link{confint.ral}} +} diff --git a/man/vcov.ral_rep.Rd b/man/vcov.ral_rep.Rd new file mode 100644 index 0000000..17e7a7f --- /dev/null +++ b/man/vcov.ral_rep.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ral_rep.R +\name{vcov.ral_rep} +\alias{vcov.ral_rep} +\title{Variance-Covariance Matrix for RAL Rep Objects} +\usage{ +\method{vcov}{ral_rep}( + object, + fit_idx = 1, + aggregation = c("median", "mean", "spectral"), + type = "HC1", + ... +) +} +\arguments{ +\item{object}{An object inheriting from class +\code{ral_rep}.} + +\item{fit_idx}{Integer index of the fit. Defaults to 1.} + +\item{aggregation}{Character string. Aggregation rule.} + +\item{type}{Character. HC type. Default \code{"HC1"}.} + +\item{...}{Currently unused.} +} +\value{ +A \eqn{p \times p}{p x p} variance-covariance +matrix. +} +\description{ +Variance-Covariance Matrix for RAL Rep Objects +} diff --git a/tests/testthat/test-crosspred.R b/tests/testthat/test-crosspred.R index bbde427..8e496b4 100644 --- a/tests/testthat/test-crosspred.R +++ b/tests/testthat/test-crosspred.R @@ -1,73 +1,17 @@ -sim_dat <- function(nobs) { - # generate test data - nobs <- 100 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z <- matrix(rnorm(nobs*10), nobs, 10) # overidentified - y <- X %*% runif(40) + Z %*% c(1, runif(9)) + rnorm(nobs) - # Organize and return output - output <- list(D = D, Z = Z, X = X) - return(output) -}#SIM_DAT - -test_that("crosspred computes with a single model", { - # generate test data - nobs <- 100 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z <- matrix(rnorm(nobs*10), nobs, 10) # overidentified - y <- X %*% runif(40) + Z %*% c(1, runif(9)) + rnorm(nobs) - # Define arguments - learners <- list(what = ols) - # Compute cross-sample predictions - crosspred_res <- crosspred(y, X, Z, - learners, - sample_folds = 3, - compute_insample_predictions = T, - silent = T) - # Check output with expectations - expect_equal(length(crosspred_res$oos_fitted), length(y)) - expect_equal(length(crosspred_res$is_fitted), 3) -})#TEST_THAT - -test_that("crosspred computes with ensemble procedures", { - # generate test data - nobs <- 100 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z <- matrix(rnorm(nobs*10), nobs, 10) # overidentified - y <- X %*% runif(40) + Z %*% c(1, runif(9)) + rnorm(nobs) - # Define arguments - learners <- list(list(fun = ols), - list(fun = ols), - list(fun = ols)) - # Compute cross-sample predictions - crosspred_res <- crosspred(y, X, Z, - learners, - ensemble_type = c("average", "ols", - "nnls1", "nnls", - "singlebest"), - cv_folds = 3, - sample_folds = 3, - compute_insample_predictions = T, - silent = T) - # Check output with expectations - expect_equal(dim(crosspred_res$oos_fitted), c(length(y), 5)) - expect_equal(length(crosspred_res$is_fitted), 5) -})#TEST_THAT - test_that("crosspred computes with ensemble procedures & custom weights", { # generate test data nobs <- 100 X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z <- matrix(rnorm(nobs*10), nobs, 10) # overidentified - y <- X %*% runif(40) + Z %*% c(1, runif(9)) + rnorm(nobs) + y <- X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols), + list(what = ols)) # Define custom weights custom_ensemble_weights <- diag(1, length(learners)) colnames(custom_ensemble_weights) <- c("mdl_ols1", "mdl_ols2", "mdl_ols3") # Compute cross-sample predictions - crosspred_res <- crosspred(y, X, Z, + crosspred_res <- crosspred(y, X, learners, ensemble_type = c("average", "ols", "nnls1", "nnls", @@ -75,47 +19,41 @@ test_that("crosspred computes with ensemble procedures & custom weights", { cv_folds = 3, sample_folds = 3, custom_ensemble_weights = custom_ensemble_weights, - compute_insample_predictions = T, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(dim(crosspred_res$oos_fitted), c(length(y), 8)) - expect_equal(length(crosspred_res$is_fitted), 8) + expect_equal(dim(crosspred_res$cf_fitted), c(length(y), 8)) })#TEST_THAT test_that("crosspred computes with ensemble procedures and sparse matrices", { # generate test data nobs <- 100 X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z <- matrix(rnorm(nobs*10), nobs, 10) # overidentified - y <- X %*% runif(40) + Z %*% c(1, runif(9)) + rnorm(nobs) + y <- X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute cross-sample predictions crosspred_res <- crosspred(y, as(X, "sparseMatrix"), - as(Z, "sparseMatrix"), learners, ensemble_type = c("average", "ols", "nnls1", "nnls", "singlebest"), cv_folds = 3, sample_folds = 3, - compute_insample_predictions = T, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(dim(crosspred_res$oos_fitted), c(length(y), 5)) - expect_equal(length(crosspred_res$is_fitted), 5) + expect_equal(dim(crosspred_res$cf_fitted), c(length(y), 5)) })#TEST_THAT test_that("crosspred computes auxilliary predictions", { # generate test data nobs <- 100 X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - y <- X %*% runif(40) + rnorm(nobs) + y <- X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols), + list(what = ols)) # Compute cross-sample and auxilliary predictions crosspred_res <- crosspred(y, X, learners = learners, @@ -124,8 +62,38 @@ test_that("crosspred computes auxilliary predictions", { "singlebest"), cv_folds = 3, sample_folds = 3, - silent = T, + silent = TRUE, auxiliary_X = list(X, X, X)) # Check output with expectations expect_equal(dim(crosspred_res$auxiliary_fitted[[1]]), c(length(y), 5)) })#TEST_THAT + +test_that("crosspred returns identical results with parallel", { + skip_on_cran() + skip_if_not_installed("parallel") + set.seed(42) + nobs <- 100 + X <- cbind(1, matrix(rnorm(nobs * 39), nobs, 39)) + y <- X %*% runif(40) + rnorm(nobs) + learners <- list(list(what = ols), + list(what = ols)) + splits <- get_sample_splits(seq_len(nobs), + sample_folds = 3, cv_folds = 3) + # Sequential + res_seq <- crosspred(y, X, learners = learners, + ensemble_type = "average", + sample_folds = 3, cv_folds = 3, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE) + # Parallel + res_par <- crosspred(y, X, learners = learners, + ensemble_type = "average", + sample_folds = 3, cv_folds = 3, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE, + parallel = list(cores = 2)) + expect_equal(res_par$cf_fitted, res_seq$cf_fitted) + expect_equal(res_par$weights, res_seq$weights) +})#TEST_THAT diff --git a/tests/testthat/test-crossval.R b/tests/testthat/test-crossval.R index ffd2fce..e440212 100644 --- a/tests/testthat/test-crossval.R +++ b/tests/testthat/test-crossval.R @@ -1,34 +1,34 @@ -test_that("crossval_compute returns residuals (w/o instruments)", { +test_that("crossval_compute returns residuals", { # Simulate small dataset X <- matrix(rnorm(100*100), 100, 100) # Simulate features y <- 1 + X %*% (10*runif(100) * (runif(100) < 0.05)) + rnorm(100) # Define arguments test_sample <- sample(1:length(y), 33) - learner <- list(fun = ols) + learner <- list(what = ols) # Compute cross-validation instance - oos_resid <- crossval_compute(test_sample, learner, - y, X, Z = NULL) + cv_resid <- crossval_compute(test_sample, learner, + y, X) # Check output with expectations - expect_equal(length(oos_resid), 33) + expect_equal(length(cv_resid), 33) })#TEST_THAT -test_that("crossval returns residuals by learner (w/o instruments)", { +test_that("crossval returns residuals by learner", { # Simulate small dataset X <- cbind(1, matrix(rnorm(100*99), 100, 99)) # Simulate features nonzero_X <- (runif(100) < 0.05) y <- X %*% (10*runif(100) * nonzero_X) + rnorm(100) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols), - list(fun = ols, + learners <- list(list(what = ols), + list(what = ols), + list(what = ols, assign_X = which(nonzero_X))) # Compute cross-validation instance - cv_res <- crossval(y, X, Z = NULL, + cv_res <- crossval(y, X, learners, cv_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(dim(cv_res$oos_resid), c(length(y), length(learners))) + expect_equal(dim(cv_res$cv_resid), c(length(y), length(learners))) })#TEST_THAT test_that("crossval returns residuals by learner in correct order", { @@ -38,47 +38,49 @@ test_that("crossval returns residuals by learner in correct order", { y <- rowSums(X[, 1:3]) + rnorm(n) # split data to two folds and compute residuals manually subsample_list <- generate_subsamples(n, 2) - oos_res_cv <- matrix(0, n, 2) + cv_resid_manual <- matrix(0, n, 2) for(i in seq_along(subsample_list)) { idx_i <- subsample_list[[i]] # ols 1 ols_fit <- ols(y[-idx_i], X[-idx_i, 1:5]) - oos_res_cv[idx_i, 1] <- y[idx_i] - + cv_resid_manual[idx_i, 1] <- y[idx_i] - ddml:::predict.ols(ols_fit, X[idx_i, 1:5]) # ols 1 ols_fit <- ols(y[-idx_i], X[-idx_i, 1:10]) - oos_res_cv[idx_i, 2] <- y[idx_i] - + cv_resid_manual[idx_i, 2] <- y[idx_i] - ddml:::predict.ols(ols_fit, X[idx_i, 1:10]) }#FOR # Compute cross-validation with crossval using the same subsamples cv_res <- crossval(y, X, - learners = list(list(fun = ols, + learners = list(list(what = ols, assign_X = 1:5), - list(fun = ols, + list(what = ols, assign_X = 1:10)), cv_subsamples = subsample_list, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(round(cv_res$oos_resid[, 1], 3), round(oos_res_cv[, 1], 3)) - expect_equal(round(cv_res$oos_resid[, 2], 3), round(oos_res_cv[, 2], 3)) + expect_equal(round(cv_res$cv_resid[, 1], 3), round(cv_resid_manual[, 1], 3)) + expect_equal(round(cv_res$cv_resid[, 2], 3), round(cv_resid_manual[, 2], 3)) })#TEST_THAT -test_that("crossval returns residuals by learner (w/ instruments)", { - # Simulate small dataset - X <- cbind(1, matrix(rnorm(100*39), 100, 39)) - Z <- matrix(rnorm(100*10), 100, 10) - D <- X %*% runif(40) + Z %*% c(1, runif(9)) + rnorm(100) - # Define arguments - learners <- list(list(fun = ols), - list(fun = ols), - list(fun = mdl_glmnet)) - # Compute cross-validation instance - cv_res <- crossval(D, X, Z, - learners, - cv_folds = 3, - silent = T) - # Check output with expectations - expect_equal(all(round(cv_res$oos_resid[, 1], 3) == - round(cv_res$oos_resid[, 2], 3)), TRUE) +test_that("crossval returns identical results with parallel", { + skip_on_cran() + skip_if_not_installed("parallel") + set.seed(42) + nobs <- 100 + X <- cbind(1, matrix(rnorm(nobs * 39), nobs, 39)) + y <- X %*% runif(40) + rnorm(nobs) + learners <- list(list(what = ols), + list(what = ols)) + cv_subs <- generate_subsamples(nobs, 3) + # Sequential + res_seq <- crossval(y, X, learners = learners, + cv_subsamples = cv_subs, silent = TRUE) + # Parallel + res_par <- crossval(y, X, learners = learners, + cv_subsamples = cv_subs, silent = TRUE, + parallel = list(cores = 2)) + expect_equal(res_par$mspe, res_seq$mspe) + expect_equal(res_par$cv_resid, res_seq$cv_resid) })#TEST_THAT diff --git a/tests/testthat/test-ddml.R b/tests/testthat/test-ddml.R new file mode 100644 index 0000000..738058c --- /dev/null +++ b/tests/testthat/test-ddml.R @@ -0,0 +1,644 @@ +test_that("ddml() constructs a valid ddml object", { + # Minimal valid inputs + n <- 50 + y <- rnorm(n) + theta <- mean(y) + + coef <- matrix(theta, 1, 1, dimnames = list("mean", "custom")) + scores <- array(y - theta, dim = c(n, 1, 1)) + J <- array(-1, dim = c(1, 1, 1)) + inf_func <- array(y - theta, dim = c(n, 1, 1)) + dinf_dtheta <- array(1, dim = c(n, 1, 1, 1)) + + fit <- ddml( + coefficients = coef, scores = scores, J = J, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, + nobs = n, coef_names = "mean", + estimator_name = "Sample Mean", + sample_folds = 5, + ensemble_weights = list(y = matrix(1, 1, 1, + dimnames = list("learner1", "custom")))) + + # Class + + expect_s3_class(fit, "ddml") + + # S3 methods work + expect_no_error(summary(fit)) + expect_no_error(confint(fit)) + expect_no_error(coef(fit)) + expect_no_error(vcov(fit)) + expect_no_error(nobs(fit)) + expect_no_error(tidy(fit)) + expect_no_error(glance(fit)) +}) + +test_that("ddml() with subclass", { + n <- 30 + coef <- matrix(1.5, 1, 1, dimnames = list("param", "ens")) + scores <- array(rnorm(n), dim = c(n, 1, 1)) + J <- array(-1, dim = c(1, 1, 1)) + inf_func <- array(rnorm(n), dim = c(n, 1, 1)) + dinf_dtheta <- array(1, dim = c(n, 1, 1, 1)) + + fit <- ddml( + coefficients = coef, scores = scores, J = J, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, + nobs = n, coef_names = "param", + estimator_name = "My Custom", + subclass = "my_custom") + + expect_s3_class(fit, "my_custom") + expect_s3_class(fit, "ddml") + expect_equal(class(fit), c("my_custom", "ddml", "ral")) +}) + +test_that("ddml() passes extra args via ...", { + n <- 30 + coef <- matrix(1, 1, 1, dimnames = list("x", "ens")) + scores <- array(rnorm(n), dim = c(n, 1, 1)) + J <- array(-1, dim = c(1, 1, 1)) + inf_func <- array(rnorm(n), dim = c(n, 1, 1)) + dinf_dtheta <- array(1, dim = c(n, 1, 1, 1)) + + fit <- ddml( + coefficients = coef, scores = scores, J = J, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, + nobs = n, coef_names = "x", + estimator_name = "Test", + my_extra = "hello", + learners = list(what = ols)) + + expect_equal(fit$my_extra, "hello") + expect_equal(fit$learners$what, ols) +}) + +test_that("ddml() rejects bad inputs", { + n <- 20 + + # coefficients not a matrix + expect_error( + ddml(coefficients = 1:3, scores = array(1, c(n, 3, 1)), + J = array(1, c(3, 3, 1)), + inf_func = array(1, c(n, 3, 1)), + nobs = n, coef_names = "x", + estimator_name = "Bad"), + "matrix") + + # scores not 3D + expect_error( + ddml(coefficients = matrix(1, 1, 1), + scores = matrix(1, n, 1), + J = array(1, c(1, 1, 1)), + inf_func = array(1, c(n, 1, 1)), + nobs = n, coef_names = "x", + estimator_name = "Bad"), + "3D array") + + # J not 3D + expect_error( + ddml(coefficients = matrix(1, 1, 1), + scores = array(1, c(n, 1, 1)), + J = matrix(1, 1, 1), + inf_func = array(1, c(n, 1, 1)), + nobs = n, coef_names = "x", + estimator_name = "Bad"), + "3D array") + + # inf_func not 3D + expect_error( + ddml(coefficients = matrix(1, 1, 1), + scores = array(1, c(n, 1, 1)), + J = array(1, c(1, 1, 1)), + inf_func = matrix(1, n, 1), + nobs = n, coef_names = "x", + estimator_name = "Bad"), + "3D numeric array") + + # dinf_dtheta not 4D array + expect_error( + ddml(coefficients = matrix(1, 1, 1), + scores = array(1, c(n, 1, 1)), + J = array(1, c(1, 1, 1)), + inf_func = array(1, c(n, 1, 1)), + dinf_dtheta = 123, + nobs = n, coef_names = "x", + estimator_name = "Bad"), + "dinf_dtheta.*4D array") + + # Dimension mismatch: scores wrong nobs + expect_error( + ddml(coefficients = matrix(1, 1, 1), + scores = array(1, c(n + 5, 1, 1)), + J = array(1, c(1, 1, 1)), + inf_func = array(1, c(n, 1, 1)), + nobs = n, coef_names = "x", + estimator_name = "Bad"), + "nobs x p x nensb") + + # Dimension mismatch: J wrong shape + expect_error( + ddml(coefficients = matrix(1, 2, 1), + scores = array(1, c(n, 2, 1)), + J = array(1, c(1, 1, 1)), + inf_func = array(1, c(n, 2, 1)), + nobs = n, coef_names = c("a", "b"), + estimator_name = "Bad"), + "p x p x nensb") + + # Dimension mismatch: inf_func wrong wrong length/shape + expect_error( + ddml(coefficients = matrix(1, 1, 2), + scores = array(1, c(n, 1, 2)), + J = array(1, c(1, 1, 2)), + inf_func = array(1, c(n, 1, 1)), + nobs = n, coef_names = "x", + estimator_name = "Bad"), + "nobs x p x nensb") + + # Dimension mismatch: dinf_dtheta wrong dims + expect_error( + ddml(coefficients = matrix(1, 1, 2), + scores = array(1, c(n, 1, 2)), + J = array(1, c(1, 1, 2)), + inf_func = array(1, c(n, 1, 2)), + dinf_dtheta = array(1, dim = c(n, 1, 1, 3)), + nobs = n, coef_names = "x", + estimator_name = "Bad"), + "'dinf_dtheta' dimensions must be") +}) + +test_that("standard S3 generic methods work correctly", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_ate(y, D, X, + learners = learners, + ensemble_type = c("ols", "nnls"), + cv_folds = 2, + sample_folds = 2, + silent = TRUE) + + # coef + cf <- coef(fit) + expect_true(is.numeric(cf)) + expect_length(cf, 2) + + # vcov + V <- vcov(fit, fit_idx = 2) + expect_true(is.matrix(V)) + expect_equal(dim(V), c(1, 1)) + + # confint + ci <- confint(fit, fit_idx = 1) + expect_true(is.matrix(ci)) + expect_equal(dim(ci), c(1, 2)) + expect_identical(colnames(ci), c(" 2.5 %", "97.5 %")) + + # summary + s <- summary(fit) + expect_s3_class(s, "summary.ddml") + expect_equal(s$nobs, nobs) + + # nobs + expect_equal(nobs(fit), nobs) + + # call + expect_false(is.null(fit$call)) + + # print.summary + out <- capture_output(print(s)) + expect_true(grepl("DDML estimation", out)) + expect_true(grepl("Average Treatment Effect", out)) +}) + +test_that("type argument threads through S3 methods", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_ate(y, D, X, + learners = learners, + ensemble_type = c("ols", "nnls"), + cv_folds = 2, + sample_folds = 2, + silent = TRUE) + + # vcov with all three types + V_hc0 <- vcov(fit, type = "HC0") + V_hc1 <- vcov(fit, type = "HC1") + V_hc3 <- vcov(fit, type = "HC3") + expect_true(V_hc1[1, 1] > V_hc0[1, 1]) + + # summary stores type + s0 <- summary(fit, type = "HC0") + s1 <- summary(fit, type = "HC1") + s3 <- summary(fit, type = "HC3") + expect_equal(s0$type, "HC0") + expect_equal(s1$type, "HC1") + expect_equal(s3$type, "HC3") + + # HC0 SEs < HC1 SEs (dof correction) + se_hc0 <- s0$coefficients[1, 2, 1] + se_hc1 <- s1$coefficients[1, 2, 1] + expect_true(se_hc1 > se_hc0) + + # Coefficients are identical across vcov types + expect_equal(s0$coefficients[, 1, ], s1$coefficients[, 1, ]) + expect_equal(s0$coefficients[, 1, ], s3$coefficients[, 1, ]) + + # confint with HC3 + ci_hc1 <- confint(fit, type = "HC1") + ci_hc3 <- confint(fit, type = "HC3") + expect_true(is.matrix(ci_hc3)) + expect_equal(dim(ci_hc3), c(1, 2)) + + # HC3 print shows SE type + out <- capture_output(print(s3)) + expect_true(grepl("HC3", out)) + + # HC1 print does not show SE type (default) + out1 <- capture_output(print(s1)) + expect_false(grepl("HC1", out1)) +}) + +test_that("type works with PLM estimator", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X %*% c(1, 0.5, 0) + rnorm(nobs) + y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) + + fit <- ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) + + V_hc0 <- vcov(fit, type = "HC0") + V_hc1 <- vcov(fit, type = "HC1") + V_hc3 <- vcov(fit, type = "HC3") + + expect_true(is.matrix(V_hc3)) + expect_equal(dim(V_hc3), c(2, 2)) + expect_true(V_hc1[1, 1] > V_hc0[1, 1]) +}) + +test_that("vcov rejects invalid type", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- 1 * (rnorm(nobs) > 0) + y <- D + rnorm(nobs) + + fit <- ddml_ate(y, D, X, + learners = list(what = ols), + sample_folds = 2, silent = TRUE) + + expect_error(vcov(fit, type = "HC2")) + expect_error(vcov(fit, type = "hc1")) +}) + +test_that("confint parm subsetting works", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- cbind(D1 = rnorm(nobs), D2 = rnorm(nobs)) + y <- D[, 1] + D[, 2] + rnorm(nobs) + + fit <- ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) + + ci_all <- confint(fit) + expect_equal(nrow(ci_all), 3) + + ci_d1 <- confint(fit, parm = "D1") + expect_equal(nrow(ci_d1), 1) + expect_equal(rownames(ci_d1), "D1") + + ci_num <- confint(fit, parm = 1:2) + expect_equal(nrow(ci_num), 2) + + expect_error(confint(fit, parm = "nonexistent")) +}) + +test_that("hatvalues returns correct length", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- 1 * (rnorm(nobs) > 0) + y <- D + rnorm(nobs) + + fit <- ddml_ate(y, D, X, + learners = list(what = ols), + sample_folds = 2, silent = TRUE) + + h <- hatvalues(fit) + expect_length(h, nobs) + expect_true(is.numeric(h)) + expect_true(all(is.finite(h))) +}) + +test_that("hatvalues works for multi-parameter estimator", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X %*% c(1, 0.5, 0) + rnorm(nobs) + y <- 2 * D + rnorm(nobs) + + fit <- ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) + + h <- hatvalues(fit) + expect_length(h, nobs) + expect_true(all(is.finite(h))) +}) + +test_that("fit_idx out of range errors", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- 1 * (rnorm(nobs) > 0) + y <- D + rnorm(nobs) + + fit <- ddml_ate(y, D, X, + learners = list(what = ols), + sample_folds = 2, silent = TRUE) + + expect_error(vcov(fit, fit_idx = 99)) + expect_error(hatvalues(fit, fit_idx = 0)) +}) + +test_that("tidy and glance broom formatters work correctly", { + # Generate a minimal fitted object to test the plumbing + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_ate(y, D, X, + learners = learners, + ensemble_type = c("ols", "nnls"), + cv_folds = 2, + sample_folds = 2, + silent = TRUE) + + # tidy for a single ensemble + td1 <- tidy(fit, ensemble_idx = 1) + expect_s3_class(td1, "data.frame") + expect_true(all(c("term", "estimate", "std.error", "statistic", "p.value", "ensemble_type") %in% colnames(td1))) + expect_equal(nrow(td1), 1) + expect_equal(td1$ensemble_type, "ols") + + # tidy for all ensembles + td_all <- tidy(fit, ensemble_idx = NULL) + expect_s3_class(td_all, "data.frame") + expect_equal(nrow(td_all), 2) + + # tidy with confidence intervals + td_ci <- tidy(fit, ensemble_idx = 2, conf.int = TRUE) + expect_s3_class(td_ci, "data.frame") + expect_true(all(c("conf.low", "conf.high") %in% colnames(td_ci))) + expect_true(td_ci$conf.low < td_ci$conf.high) + expect_equal(td_ci$ensemble_type, "nnls") + + # glance + gl <- glance(fit) + expect_s3_class(gl, "data.frame") + expect_equal(nrow(gl), 1) + expect_true(all(c("nobs", "sample_folds", "shortstack", "ensemble_type", "model_type") %in% colnames(gl))) +}) + +test_that("tidy respects type argument", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_ate(y, D, X, + learners = learners, + ensemble_type = c("ols"), + cv_folds = 2, + sample_folds = 2, + silent = TRUE) + + td_hc0 <- tidy(fit, type = "HC0") + td_hc1 <- tidy(fit, type = "HC1") + td_hc3 <- tidy(fit, type = "HC3") + + # Estimates are identical across HC types + expect_equal(td_hc0$estimate, td_hc1$estimate) + expect_equal(td_hc0$estimate, td_hc3$estimate) + + # HC1 SE > HC0 SE (dof correction) + expect_true(td_hc1$std.error > td_hc0$std.error) + + # Confidence intervals widen with HC3 + ci_hc1 <- tidy(fit, type = "HC1", conf.int = TRUE) + ci_hc3 <- tidy(fit, type = "HC3", conf.int = TRUE) + width_hc1 <- ci_hc1$conf.high - ci_hc1$conf.low + width_hc3 <- ci_hc3$conf.high - ci_hc3$conf.low + expect_true(width_hc3 >= width_hc1) +}) + +test_that("tidy works with PLM (multi-covariate D)", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X %*% c(1, 0.5, 0) + rnorm(nobs) + y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) + + fit <- ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) + + td <- tidy(fit) + expect_s3_class(td, "data.frame") + expect_equal(nrow(td), 2) + expect_true("term" %in% colnames(td)) + + gl <- glance(fit) + expect_equal(gl$model_type, "ddml_plm") + expect_equal(gl$nobs, nobs) +}) + +test_that("confint uniform produces wider bands", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- cbind(D1 = rnorm(nobs), D2 = rnorm(nobs)) + y <- D[, 1] + D[, 2] + rnorm(nobs) + + fit <- ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) + + ci_pw <- confint(fit) + + set.seed(1) + ci_uf <- confint(fit, uniform = TRUE, + bootstraps = 499) + + # Uniform bands are wider (p > 1) + width_pw <- ci_pw[, 2] - ci_pw[, 1] + width_uf <- ci_uf[, 2] - ci_uf[, 1] + expect_true(all(width_uf >= width_pw)) + + # Critical value attribute + expect_false(is.null(attr(ci_uf, "crit_val"))) + expect_true(attr(ci_uf, "crit_val") > qnorm(0.975)) + + # Pointwise has Gaussian quantile + expect_equal(attr(ci_pw, "crit_val"), qnorm(0.975), tolerance = 1e-6) +}) + +test_that("confint uniform with scalar estimator", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X %*% c(1, 0.5, 0) + rnorm(nobs) + y <- 2 * D + rnorm(nobs) + + fit <- ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) + + ci_pw <- confint(fit) + set.seed(1) + ci_uf <- confint(fit, uniform = TRUE, + bootstraps = 499) + + # For p=1, uniform ~ pointwise (within tolerance) + width_pw <- as.numeric(ci_pw[, 2] - ci_pw[, 1]) + width_uf <- as.numeric(ci_uf[, 2] - ci_uf[, 1]) + expect_true(all(abs(width_uf - width_pw) / width_pw + < 0.25)) +}) + +test_that("tidy uniform produces wider conf.int", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- cbind(D1 = rnorm(nobs), D2 = rnorm(nobs)) + y <- D[, 1] + D[, 2] + rnorm(nobs) + + fit <- ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) + + td_pw <- tidy(fit, conf.int = TRUE) + + set.seed(1) + td_uf <- tidy(fit, conf.int = TRUE, + uniform = TRUE, bootstraps = 499) + + # Uniform conf intervals are wider + width_pw <- td_pw$conf.high - td_pw$conf.low + width_uf <- td_uf$conf.high - td_uf$conf.low + expect_true(all(width_uf >= width_pw)) +}) + +test_that("confint uniform produces wider bands for ddml_rep", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- cbind(D1 = rnorm(nobs), D2 = rnorm(nobs)) + y <- D[, 1] + D[, 2] + rnorm(nobs) + + reps <- ddml_replicate(ddml_plm, y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, silent = TRUE) + + ci_pw <- confint(reps) + + set.seed(1) + ci_uf <- confint(reps, uniform = TRUE, bootstraps = 499) + + # Uniform bands are wider (p > 1) + width_pw <- ci_pw[, 2] - ci_pw[, 1] + width_uf <- ci_uf[, 2] - ci_uf[, 1] + expect_true(all(width_uf >= width_pw)) + + # Critical value attribute + expect_false(is.null(attr(ci_uf, "crit_val"))) + expect_true(attr(ci_uf, "crit_val") > qnorm(0.975)) + + # Pointwise has Gaussian quantile + expect_equal(attr(ci_pw, "crit_val"), qnorm(0.975), tolerance = 1e-6) +}) + +test_that("hatvalues warns and returns NA if dinf_dtheta is missing", { + fit <- ddml( + coefficients = matrix(0, 1, 1, dimnames = list("ATE", "nnls")), + scores = array(0, dim = c(10, 1, 1)), + J = array(1, dim = c(1, 1, 1)), + inf_func = array(runif(10), dim = c(10, 1, 1)), + dinf_dtheta = NULL, + nobs = 10, + coef_names = "ATE", + estimator_name = "test", + ensemble_type = "nnls", + cluster_variable = seq_len(10) + ) + + expect_warning( + expect_equal(hatvalues(fit), rep(NA_real_, 10)), + "dinf_dtheta not available", + ignore.case = TRUE + ) +}) + +# as.list.ddml ================================================================ + +test_that("as.list.ddml splits by ensemble", { + set.seed(42) + y <- AE98[1:500, "worked"] + D <- AE98[1:500, "morekids"] + X <- AE98[1:500, c("age", "agefst", "black")] + + fit <- ddml_plm(y, D, X, + learners = list( + list(what = ols), + list(what = ols, args = list(const = FALSE))), + ensemble_type = c("nnls", "singlebest"), + sample_folds = 2, silent = TRUE) + + L <- as.list(fit) + expect_length(L, 2) + expect_equal(names(L), c("nnls", "singlebest")) + for (j in 1:2) { + expect_s3_class(L[[j]], "ddml") + expect_equal(ncol(L[[j]]$coefficients), 1L) + # tidy and glance work + expect_true(is.data.frame(tidy(L[[j]]))) + expect_true(is.data.frame(glance(L[[j]]))) + } + # coef values match parent + expect_equal(L[[1]]$coefficients[, 1], + fit$coefficients[, 1], tolerance = 1e-10) + expect_equal(L[[2]]$coefficients[, 1], + fit$coefficients[, 2], tolerance = 1e-10) +})#TEST_THAT diff --git a/tests/testthat/test-ddml_apo.R b/tests/testthat/test-ddml_apo.R new file mode 100644 index 0000000..aca09b9 --- /dev/null +++ b/tests/testthat/test-ddml_apo.R @@ -0,0 +1,253 @@ +test_that("ddml_apo computes with a single model", { + # Simulate small dataset + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + # Define arguments + learners <- list(what = ols) + ddml_apo_fit <- ddml_apo(y, D, X, + d = 1, + learners = learners, + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + # Check output with expectations + expect_equal(length(coef(ddml_apo_fit)), 1) +})#TEST_THAT + +test_that("ddml_apo computes with weights", { + # Simulate small dataset + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + weights <- runif(nobs) + # Define arguments + learners <- list(what = ols) + ddml_apo_fit <- ddml_apo(y, D, X, + d = 0, + weights = weights, + learners = learners, + stratify = FALSE, + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + # Check output with expectations + expect_equal(length(coef(ddml_apo_fit)), 1) +})#TEST_THAT + +test_that("ddml_apo computes with a single model and dependence", { + set.seed(1) + n_cluster <- 200 + nobs <- 500 + X <- matrix(rnorm(n_cluster * 5), n_cluster, 5) + D_tld <- 0.1 * X[, 1] + rnorm(n_cluster) + D <- 1 * (D_tld > 0) + cluster_variable <- sample(seq_len(n_cluster), nobs, + replace = TRUE) + D <- D[cluster_variable] + X <- X[cluster_variable, , drop = FALSE] + y <- D + 0.1 * X[, 1] + rnorm(nobs) + # Define arguments + learners <- list(what = ols) + ddml_apo_fit <- ddml_apo(y, D, X, + d = 1, + learners = learners, + cluster_variable = cluster_variable, + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + # Check output with expectations + expect_equal(length(coef(ddml_apo_fit)), 1) +})#TEST_THAT + +test_that("ddml_apo computes with an ensemble procedure", { + # Simulate small dataset + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + # Define arguments + learners <- list(list(what = ols), + list(what = ols)) + # Compute DDML PLM estimator + ddml_apo_fit <- ddml_apo(y, D, X, + d = 1, + learners = learners, + ensemble_type = "ols", + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + # Check output with expectations + expect_equal(length(coef(ddml_apo_fit)), 1) +})#TEST_THAT + +test_that("ddml_apo computes w/ multiple ensembles + custom weights", { + # Simulate small dataset + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + # Define arguments + learners <- list(list(what = ols), + list(what = ols)) + # Compute DDML PLM estimator + ddml_apo_fit <- ddml_apo(y, D, X, + d = 0, + weights = rep(1, nobs), + learners = learners, + ensemble_type = c("ols", "nnls", + "singlebest", "average"), + cv_folds = 3, + custom_ensemble_weights = diag(1, 2), + sample_folds = 3, + silent = TRUE) + # Check output with expectations + expect_equal(length(coef(ddml_apo_fit)), 6) +})#TEST_THAT + +test_that("ddml_apo computes with multiple ensemble procedures & shortstack", { + # Simulate small dataset + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + # Define arguments + learners <- list(list(what = ols)) + # Compute DDML PLM estimator + ddml_apo_fit <- ddml_apo(y, D, X, + d = 1, + learners = learners, + ensemble_type = c("ols", "nnls", + "singlebest", "average"), + shortstack = TRUE, + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + # Check output with expectations + expect_equal(length(coef(ddml_apo_fit)), 4) +})#TEST_THAT + +test_that("summary.ddml_apo computes with a single model", { + # Simulate small dataset + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + # Define arguments + learners <- list(what = ols) + ddml_apo_fit <- ddml_apo(y, D, X, + d = 1, + learners = learners, + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + # Compute inference results & test print + inf_res <- summary(ddml_apo_fit) + capture_output({print(inf_res)}, print = FALSE) + # Check output with expectations + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) +})#TEST_THAT + +test_that("summary.ddml_apo computes with a single model and dependence", { + # Simulate small dataset + n_cluster <- 200 + nobs <- 500 + X <- matrix(rnorm(n_cluster * 5), n_cluster, 5) + D_tld <- 0.1 * X[, 1] + rnorm(n_cluster) + D <- 1 * (D_tld > 0) + cluster_variable <- sample(seq_len(n_cluster), nobs, + replace = TRUE) + D <- D[cluster_variable] + X <- X[cluster_variable, , drop = FALSE] + y <- D + 0.1 * X[, 1] + rnorm(nobs) + # Define arguments + learners <- list(what = ols) + ddml_apo_fit <- ddml_apo(y, D, X, + d = 1, + learners = learners, + cluster_variable = cluster_variable, + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + # Compute inference results & test print + inf_res <- summary(ddml_apo_fit) + capture_output({print(inf_res)}, print = FALSE) + # Check output with expectations + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) +})#TEST_THAT + +test_that("summary.ddml_apo computes with multiple ensemble procedures", { + # Simulate small dataset + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + # Define arguments + learners <- list(list(what = ols)) + # Compute DDML PLM estimator + ddml_apo_fit <- ddml_apo(y, D, X, + d = 1, + learners = learners, + ensemble_type = c("ols", "nnls", + "singlebest", "average"), + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + # Compute inference results & test print + inf_res <- summary(ddml_apo_fit) + capture_output({print(inf_res)}, print = FALSE) + # Check output with expectations + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(1, 4, 4)) +})#TEST_THAT + +test_that("ddml_apo fitted pass-through works", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_apo(y, D, X, + d = 1, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE) + + # Pass-through with average ensemble reproduces exactly + fit2 <- ddml_apo(y, D, X, + d = 1, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted, + splits = fit$splits) + expect_equal(coef(fit2), coef(fit), tolerance = 1e-6) + + expect_error( + ddml_apo(y, D, X, + d = 1, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted), + "must be supplied when 'fitted' is supplied" + ) +}) + diff --git a/tests/testthat/test-ddml_ate.R b/tests/testthat/test-ddml_ate.R index 204c758..c99aa14 100644 --- a/tests/testthat/test-ddml_ate.R +++ b/tests/testthat/test-ddml_ate.R @@ -1,195 +1,309 @@ test_that("ddml_ate computes with a single model", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - D_tld <- X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + # Define arguments + learners <- list(what = ols) + ddml_ate_fit <- ddml_ate(y, D, X, + learners = learners, + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + # Check output with expectations + expect_equal(length(coef(ddml_ate_fit)), 1) +})#TEST_THAT + +test_that("ddml_ate computes with stratify = FALSE", { + # Simulate small dataset + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ - ddml_ate_fit <- ddml_ate(y, D, X, + ddml_ate_fit <- ddml_ate(y, D, X, learners = learners, + stratify = FALSE, cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_ate_fit$ate), 1) + expect_equal(length(coef(ddml_ate_fit)), 1) })#TEST_THAT test_that("ddml_ate computes with a single model and dependence", { # Simulate small dataset n_cluster <- 200 nobs <- 500 - X <- cbind(1, matrix(rnorm(n_cluster*39), n_cluster, 39)) - D_tld <- X %*% runif(40) + rnorm(n_cluster) - fun <- stepfun(quantile(D_tld, probs = 0.5), c(0, 1)) - D <- fun(D_tld) - cluster_variable <- sample(1:n_cluster, nobs, replace = TRUE) - D <- D[cluster_variable, drop = F] - X <- X[cluster_variable, , drop = F] - y <- D + X %*% runif(40) + rnorm(nobs) + X <- matrix(rnorm(n_cluster * 5), n_cluster, 5) + D_tld <- 0.1 * X[, 1] + rnorm(n_cluster) + D <- 1 * (D_tld > 0) + cluster_variable <- sample(seq_len(n_cluster), nobs, + replace = TRUE) + D <- D[cluster_variable] + X <- X[cluster_variable, , drop = FALSE] + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ - ddml_ate_fit <- ddml_ate(y, D, X, + ddml_ate_fit <- ddml_ate(y, D, X, learners = learners, cluster_variable = cluster_variable, cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_ate_fit$ate), 1) + expect_equal(length(coef(ddml_ate_fit)), 1) })#TEST_THAT test_that("ddml_ate computes with an ensemble procedure", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - D_tld <- X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute DDML PLM estimator - expect_warning({ - ddml_ate_fit <- ddml_ate(y, D, X, + ddml_ate_fit <- ddml_ate(y, D, X, learners = learners, ensemble_type = "ols", cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_ate_fit$ate), 1) + expect_equal(length(coef(ddml_ate_fit)), 1) })#TEST_THAT test_that("ddml_ate computes w/ multiple ensembles + custom weights", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - D_tld <- X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute DDML PLM estimator - expect_warning({ - ddml_ate_fit <- ddml_ate(y, D, X, + ddml_ate_fit <- ddml_ate(y, D, X, learners, ensemble_type = c("ols", "nnls", "singlebest", "average"), cv_folds = 3, custom_ensemble_weights = diag(1, 2), sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_ate_fit$ate), 6) + expect_equal(length(coef(ddml_ate_fit)), 6) })#TEST_THAT test_that("ddml_ate computes with multiple ensemble procedures & shortstack", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - D_tld <- X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols)) + learners <- list(list(what = ols)) # Compute DDML PLM estimator - expect_warning({ - ddml_ate_fit <- ddml_ate(y, D, X, + ddml_ate_fit <- ddml_ate(y, D, X, learners, ensemble_type = c("ols", "nnls", "singlebest", "average"), shortstack = TRUE, cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_ate_fit$ate), 4) + expect_equal(length(coef(ddml_ate_fit)), 4) })#TEST_THAT test_that("summary.ddml_ate computes with a single model", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - D_tld <- X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ - ddml_ate_fit <- ddml_ate(y, D, X, + ddml_ate_fit <- ddml_ate(y, D, X, learners = learners, cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Compute inference results & test print inf_res <- summary(ddml_ate_fit) capture_output({print(inf_res)}, print = FALSE) # Check output with expectations - expect_equal(length(inf_res), 4) + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_ate computes with a single model and dependence", { # Simulate small dataset n_cluster <- 200 nobs <- 500 - X <- cbind(1, matrix(rnorm(n_cluster*39), n_cluster, 39)) - D_tld <- X %*% runif(40) + rnorm(n_cluster) - fun <- stepfun(quantile(D_tld, probs = 0.5), c(0, 1)) - D <- fun(D_tld) - cluster_variable <- sample(1:n_cluster, nobs, replace = TRUE) - D <- D[cluster_variable, drop = F] - X <- X[cluster_variable, , drop = F] - y <- D + X %*% runif(40) + rnorm(nobs) + X <- matrix(rnorm(n_cluster * 5), n_cluster, 5) + D_tld <- 0.1 * X[, 1] + rnorm(n_cluster) + D <- 1 * (D_tld > 0) + cluster_variable <- sample(seq_len(n_cluster), nobs, + replace = TRUE) + D <- D[cluster_variable] + X <- X[cluster_variable, , drop = FALSE] + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ - ddml_ate_fit <- ddml_ate(y, D, X, + ddml_ate_fit <- ddml_ate(y, D, X, learners = learners, cluster_variable = cluster_variable, cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Compute inference results & test print inf_res <- summary(ddml_ate_fit) capture_output({print(inf_res)}, print = FALSE) # Check output with expectations - expect_equal(length(inf_res), 4) + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_ate computes with multiple ensemble procedures", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - D_tld <- X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols)) + learners <- list(list(what = ols)) # Compute DDML PLM estimator - expect_warning({ - ddml_ate_fit <- ddml_ate(y, D, X, + ddml_ate_fit <- ddml_ate(y, D, X, learners, ensemble_type = c("ols", "nnls", "singlebest", "average"), cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Compute inference results & test print inf_res <- summary(ddml_ate_fit) capture_output({print(inf_res)}, print = FALSE) # Check output with expectations - expect_equal(length(inf_res), 16) + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(1, 4, 4)) +})#TEST_THAT + +test_that("ddml_ate fitted pass-through works", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_ate(y, D, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE) + + # Pass-through with average ensemble reproduces exactly + fit2 <- ddml_ate(y, D, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted, + splits = fit$splits) + expect_equal(coef(fit2), coef(fit), tolerance = 1e-6) + + expect_error( + ddml_ate(y, D, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted), + "must be supplied when 'fitted' is supplied" + ) +}) + +test_that("ddml_ate scores are mean-zero", { + nobs <- 500 + set.seed(42) + X <- matrix(rnorm(nobs * 3), nobs, 3) + D_tld <- 0.2 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + fit <- ddml_ate(y, D, X, + learners = list(what = ols), + sample_folds = 3, silent = TRUE) + score_mean <- mean(fit$scores[, , 1]) + expect_true(abs(score_mean) < 0.01, + label = paste("score mean =", round(score_mean, 6))) +}) + +test_that("ddml_ate point estimate is close to true ATE", { + nobs <- 2000 + set.seed(123) + X <- matrix(rnorm(nobs * 3), nobs, 3) + D_tld <- 0.5 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- 1.0 * D + 0.3 * X[, 1] + rnorm(nobs) + fit <- ddml_ate(y, D, X, + learners = list(what = ols), + sample_folds = 5, silent = TRUE) + expect_equal(coef(fit), c(ATE = 1.0), tolerance = 0.3) +}) + +test_that("ddml_ate computes with sparse matrices", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + learners <- list(list(what = ols), list(what = ols)) + ddml_ate_fit <- ddml_ate(y, D, as(X, "sparseMatrix"), + learners = learners, + ensemble_type = "ols", + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + expect_equal(length(coef(ddml_ate_fit)), 1) +})#TEST_THAT + +test_that("ddml_ate computes with parallel", { + skip_on_cran() + skip_if_not_installed("parallel") + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + learners <- list(what = ols) + # Sequential + res_seq <- ddml_ate(y, D, X, + learners = learners, + sample_folds = 3, + stratify = FALSE, + silent = TRUE) + # Parallel with same splits + res_par <- ddml_ate(y, D, X, + learners = learners, + sample_folds = 3, + stratify = FALSE, + splits = res_seq$splits, + silent = TRUE, + parallel = list(cores = 2)) + expect_equal(coef(res_par), coef(res_seq)) })#TEST_THAT diff --git a/tests/testthat/test-ddml_att.R b/tests/testthat/test-ddml_att.R index 43a8b04..a448638 100644 --- a/tests/testthat/test-ddml_att.R +++ b/tests/testthat/test-ddml_att.R @@ -1,196 +1,237 @@ test_that("ddml_att computes with a single model", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - D_tld <- X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ - ddml_att_fit <- ddml_att(y, D, X, + ddml_att_fit <- ddml_att(y, D, X, learners = learners, cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_att_fit$att), 1) + expect_equal(length(coef(ddml_att_fit)), 1) })#TEST_THAT -test_that("ddml_att computes with a single model and dependence", { +test_that("ddml_att computes with stratify = FALSE", { # Simulate small dataset + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + # Define arguments + learners <- list(what = ols) + ddml_att_fit <- ddml_att(y, D, X, + learners = learners, + stratify = FALSE, + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + # Check output with expectations + expect_equal(length(coef(ddml_att_fit)), 1) +})#TEST_THAT + +test_that("ddml_att computes with a single model and dependence", { + set.seed(13) + # Simulate small clustered dataset n_cluster <- 200 nobs <- 500 - X <- cbind(1, matrix(rnorm(n_cluster*39), n_cluster, 39)) - D_tld <- X %*% runif(40) + rnorm(n_cluster) - fun <- stepfun(quantile(D_tld, probs = 0.5), c(0, 1)) - D <- fun(D_tld) + X <- matrix(rnorm(n_cluster * 5), n_cluster, 5) + D_tld <- 0.1 * X[, 1] + rnorm(n_cluster) + D <- 1 * (D_tld > 0) cluster_variable <- sample(1:n_cluster, nobs, replace = TRUE) - D <- D[cluster_variable, drop = F] - X <- X[cluster_variable, , drop = F] - y <- D + X %*% runif(40) + rnorm(nobs) + D <- D[cluster_variable] + X <- X[cluster_variable, , drop = FALSE] + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ - ddml_att_fit <- ddml_att(y, D, X, + ddml_att_fit <- ddml_att(y, D, X, learners = learners, cluster_variable = cluster_variable, cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_att_fit$att), 1) + expect_equal(length(coef(ddml_att_fit)), 1) })#TEST_THAT test_that("ddml_att computes with an ensemble procedure", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - D_tld <- X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute DDML PLM estimator - expect_warning({ - ddml_att_fit <- ddml_att(y, D, X, + ddml_att_fit <- ddml_att(y, D, X, learners = learners, ensemble_type = "ols", cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_att_fit$att), 1) + expect_equal(length(coef(ddml_att_fit)), 1) })#TEST_THAT test_that("ddml_att computes w/ multiple ensembles + custom weights", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - D_tld <- X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute DDML PLM estimator - expect_warning({ - ddml_att_fit <- ddml_att(y, D, X, + ddml_att_fit <- ddml_att(y, D, X, learners, ensemble_type = c("ols", "nnls", "singlebest", "average"), cv_folds = 3, custom_ensemble_weights = diag(1, 2), sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_att_fit$att), 6) + expect_equal(length(coef(ddml_att_fit)), 6) })#TEST_THAT test_that("ddml_att computes w/ multp ensembles, custom weights + shortstack", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - D_tld <- X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute DDML PLM estimator - expect_warning({ - ddml_att_fit <- ddml_att(y, D, X, + ddml_att_fit <- ddml_att(y, D, X, learners, ensemble_type = c("ols", "average"), shortstack = TRUE, cv_folds = 3, custom_ensemble_weights = diag(1, 2), sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_att_fit$att), 4) + expect_equal(length(coef(ddml_att_fit)), 4) })#TEST_THAT test_that("summary.ddml_att computes with a single model", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - D_tld <- X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ - ddml_att_fit <- ddml_att(y, D, X, + ddml_att_fit <- ddml_att(y, D, X, learners = learners, cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Compute inference results & test print inf_res <- summary(ddml_att_fit) capture_output({print(inf_res)}, print = FALSE) # Check output with expectations - expect_equal(length(inf_res), 4) + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_att computes with a single model and dependence", { - # Simulate small dataset + set.seed(13) + # Simulate small clustered dataset n_cluster <- 200 nobs <- 500 - X <- cbind(1, matrix(rnorm(n_cluster*39), n_cluster, 39)) - D_tld <- X %*% runif(40) + rnorm(n_cluster) - fun <- stepfun(quantile(D_tld, probs = 0.5), c(0, 1)) - D <- fun(D_tld) + X <- matrix(rnorm(n_cluster * 5), n_cluster, 5) + D_tld <- 0.1 * X[, 1] + rnorm(n_cluster) + D <- 1 * (D_tld > 0) cluster_variable <- sample(1:n_cluster, nobs, replace = TRUE) - D <- D[cluster_variable, drop = F] - X <- X[cluster_variable, , drop = F] - y <- D + X %*% runif(40) + rnorm(nobs) + D <- D[cluster_variable] + X <- X[cluster_variable, , drop = FALSE] + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ - ddml_att_fit <- ddml_att(y, D, X, + ddml_att_fit <- ddml_att(y, D, X, learners = learners, cluster_variable = cluster_variable, cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Compute inference results & test print inf_res <- summary(ddml_att_fit) capture_output({print(inf_res)}, print = FALSE) # Check output with expectations - expect_equal(length(inf_res), 4) + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_att computes with multiple ensemble procedures", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - D_tld <- X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols)) + learners <- list(list(what = ols)) # Compute DDML PLM estimator - expect_warning({ - ddml_att_fit <- ddml_att(y, D, X, + ddml_att_fit <- ddml_att(y, D, X, learners, ensemble_type = c("ols", "nnls", "singlebest", "average"), cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Compute inference results & test print inf_res <- summary(ddml_att_fit) capture_output({print(inf_res)}, print = FALSE) # Check output with expectations - expect_equal(length(inf_res), 16) + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(1, 4, 4)) +})#TEST_THAT + +test_that("ddml_att fitted pass-through works", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_att(y, D, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE) + + fit2 <- ddml_att(y, D, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted, + splits = fit$splits) + expect_equal(coef(fit2), coef(fit), tolerance = 1e-6) + + expect_error( + ddml_att(y, D, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted), + "must be supplied when 'fitted' is supplied" + ) })#TEST_THAT diff --git a/tests/testthat/test-ddml_attgt.R b/tests/testthat/test-ddml_attgt.R new file mode 100644 index 0000000..98b14bc --- /dev/null +++ b/tests/testthat/test-ddml_attgt.R @@ -0,0 +1,294 @@ +# Tests for ddml_attgt ------------------------------------------------------- +# Follows the exact pattern from test-ddml_att.R + +test_that("ddml_attgt computes with a single learner", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + for (i in seq_len(n)) { + if (is.finite(G[i])) { + for (tt in seq_len(T_)) { + if (tt >= G[i]) y[i, tt] <- y[i, tt] + 1 + } + } + } + + fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 3, cv_folds = 3, + silent = TRUE) + + # Class and structure + expect_s3_class(fit, "ddml_attgt") + expect_s3_class(fit, "ddml") + + # Coefficient count = number of (g,t) cells + expect_true(length(coef(fit)) > 0) + + # All cell info populated + expect_equal(nrow(fit$cell_info), length(coef(fit))) + expect_true(all(fit$cell_info$n_treated > 0)) + expect_true(all(fit$cell_info$n_control > 0)) + + # Post-treatment cells: true effect is 1.0 + post <- fit$cell_info$time >= fit$cell_info$group + expect_true(all(abs(coef(fit)[post] - 1) < 0.5)) + # Pre-treatment cells: placebo, true effect is 0 + if (any(!post)) { + expect_true(all(abs(coef(fit)[!post]) < 0.5)) + }#IF +})#TEST_THAT + +test_that("ddml_attgt computes with multiple ensemble types", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + + fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(list(what = ols), + list(what = ols)), + ensemble_type = c("ols", "average"), + sample_folds = 2, cv_folds = 3, + silent = TRUE) + + # Multiple ensembles: coefficients is a matrix + expect_true(is.matrix(fit$coefficients)) + expect_equal(ncol(fit$coefficients), 2) +})#TEST_THAT + +test_that("summary.ddml works for ddml_attgt", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, Inf), n, replace = TRUE, + prob = c(0.4, 0.6)) + y <- matrix(rnorm(n * T_), n, T_) + + fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, cv_folds = 3, + silent = TRUE) + + inf_res <- summary(fit) + capture_output({print(inf_res)}, print = FALSE) + expect_s3_class(inf_res, "summary.ddml") + # Rows = number of cells, cols = 4 (est, se, z, p) + expect_equal(dim(inf_res$coefficients)[2], 4) +})#TEST_THAT + +test_that("vcov.ddml returns correct dimensions for ddml_attgt", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + + fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, cv_folds = 3, + silent = TRUE) + + V <- vcov(fit) + C_ <- length(coef(fit)) + expect_equal(dim(V), c(C_, C_)) + # Diagonal must be positive + expect_true(all(diag(V) > 0)) +})#TEST_THAT + +test_that("ddml_attgt control_group = 'nevertreated' works", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + + fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(what = ols), + control_group = "nevertreated", + sample_folds = 2, cv_folds = 3, + silent = TRUE) + + expect_s3_class(fit, "ddml_attgt") + # All control counts must equal number of never-treated + n_never <- sum(is.infinite(G)) + for (idx in seq_len(nrow(fit$cell_info))) { + expect_equal(fit$cell_info$n_control[idx], n_never) + } +})#TEST_THAT + +test_that("ddml_attgt cross-fitting consistency across cells", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + + fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 3, cv_folds = 3, + silent = TRUE) + + # Structure: cell_info has right dimensions + expect_equal(nrow(fit$cell_info), length(coef(fit))) + expect_true(all(fit$cell_info$n_treated > 0)) +})#TEST_THAT + +test_that("ddml_attgt with X = NULL works", { + set.seed(42) + n <- 800; T_ <- 4 + G <- sample(c(3, Inf), n, replace = TRUE, + prob = c(0.4, 0.6)) + y <- matrix(rnorm(n * T_), n, T_) + + fit <- ddml_attgt(y, X = NULL, t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, cv_folds = 3, + silent = TRUE) + + expect_s3_class(fit, "ddml_attgt") +})#TEST_THAT + +test_that("ddml_attgt diagnostics works", { + set.seed(42) + n <- 800; T_ <- 3 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(2, Inf), n, replace = TRUE, + prob = c(0.4, 0.6)) + y <- matrix(rnorm(n * T_), n, T_) + + fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(list(what = ols), + list(what = ols)), + ensemble_type = "ols", + sample_folds = 2, cv_folds = 3, + silent = TRUE) + + d <- diagnostics(fit) + expect_s3_class(d, "ddml_diagnostics") + # Should have 3 equations (y_X_D0, D_X, D) per cell + C_ <- nrow(fit$cell_info) + expect_equal(length(d$tables), 3 * C_) + # All equation names follow the cell:eq pattern + expect_true(all(grepl("^ATT\\(", names(d$tables)))) + capture_output({print(d)}, print = FALSE) +})#TEST_THAT + +test_that("ddml_attgt fitted pass-through works", { + set.seed(42) + n <- 800; T_ <- 3 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(2, Inf), n, replace = TRUE, + prob = c(0.4, 0.6)) + y <- matrix(rnorm(n * T_), n, T_) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE) + + fit2 <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted, + splits = fit$splits) + expect_equal(coef(fit2), coef(fit), tolerance = 1e-6) + + # Error when fitted provided without splits + expect_error( + ddml_attgt(y, X, t = 1:T_, G = G, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted), + "must be supplied when 'fitted' is supplied" + ) +})#TEST_THAT + +test_that("confint.ddml works for ddml_attgt", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, Inf), n, replace = TRUE, + prob = c(0.4, 0.6)) + y <- matrix(rnorm(n * T_), n, T_) + + fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, cv_folds = 3, + silent = TRUE) + + ci <- confint(fit) + expect_equal(nrow(ci), length(coef(fit))) + expect_equal(ncol(ci), 2) + # Lower < upper + expect_true(all(ci[, 1] < ci[, 2])) +})#TEST_THAT + +test_that("confint uniform produces wider bands for ddml_attgt", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + + fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, cv_folds = 3, + silent = TRUE) + + ci_pw <- confint(fit) + + set.seed(1) + ci_uf <- confint(fit, uniform = TRUE, + bootstraps = 499) + + # Uniform bands are wider (multiple cells -> p > 1) + width_pw <- ci_pw[, 2] - ci_pw[, 1] + width_uf <- ci_uf[, 2] - ci_uf[, 1] + expect_true(all(width_uf >= width_pw)) + + # Critical value attribute + expect_false(is.null(attr(ci_uf, "crit_val"))) + expect_true(attr(ci_uf, "crit_val") > qnorm(0.975)) + + # Pointwise has Gaussian quantile + expect_equal(attr(ci_pw, "crit_val"), qnorm(0.975), tolerance = 1e-6) +})#TEST_THAT + +test_that("ddml_attgt skips cells with empty control pool", { + set.seed(42) + n <- 2000; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + # All units treated at period 2, 3, or 4 — no never-treated. + # With notyettreated, the last period will have no controls. + G <- sample(c(2, 3, 4), n, replace = TRUE, + prob = c(0.3, 0.4, 0.3)) + y <- matrix(rnorm(n * T_), n, T_) + + # Should not error — empty-control cells are skipped + fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(what = ols), + control_group = "notyettreated", + sample_folds = 2, cv_folds = 3, + silent = TRUE) + + expect_s3_class(fit, "ddml_attgt") + # All retained cells must have positive control counts + expect_true(all(fit$cell_info$n_control > 0)) + expect_true(length(coef(fit)) > 0) +})#TEST_THAT diff --git a/tests/testthat/test-ddml_fpliv.R b/tests/testthat/test-ddml_fpliv.R index ffaed0b..4956c51 100644 --- a/tests/testthat/test-ddml_fpliv.R +++ b/tests/testthat/test-ddml_fpliv.R @@ -7,13 +7,13 @@ test_that("ddml_fpliv computes with a single model", { D <- X %*% runif(40) + Z %*% c(1, runif(9)) + UV[, 1] y <- D + X %*% runif(40) + UV[, 2] # Define arguments - learners <- list(list(fun = ols)) + learners <- list(list(what = ols)) ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 1) + expect_equal(length(coef(ddml_fpliv_fit)), 2) })#TEST_THAT test_that("ddml_fpliv computes with a single model and dependence", { @@ -31,14 +31,14 @@ test_that("ddml_fpliv computes with a single model and dependence", { D <- Z + X %*% runif(40) + eps y <- D + X %*% runif(40) + 0.1 * eps + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols)) + learners <- list(list(what = ols)) ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, cluster_variable = cluster_variable, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 1) + expect_equal(length(coef(ddml_fpliv_fit)), 2) })#TEST_THAT test_that("ddml_fpliv computes with an ensemble procedure", { @@ -50,40 +50,17 @@ test_that("ddml_fpliv computes with an ensemble procedure", { D <- X %*% runif(40) + Z %*% c(1, runif(9)) + UV[, 1] y <- D + X %*% runif(40) + UV[, 2] # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) - # Compute LIE-conform DDML IV estimator + learners <- list(list(what = ols), + list(what = ols)) + # Compute DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, ensemble_type = "ols", cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 1) -})#TEST_THAT - -test_that("ddml_fpliv computes with stacking w/o enforcing the LIE", { - # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z <- matrix(rnorm(nobs*10), nobs, 10) - UV <- matrix(rnorm(2*nobs), nobs, 2) %*% chol(matrix(c(1, 0.7, 0.7, 1), 2, 2)) - D <- X %*% runif(40) + Z %*% c(1, runif(9)) + UV[, 1] - y <- D + X %*% runif(40) + UV[, 2] - # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) - # Compute LIE-conform DDML IV estimator - ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, - learners, - ensemble_type = "ols", - sample_folds = 3, - cv_folds = 3, - enforce_LIE = FALSE, - silent = T) - # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 1) + expect_equal(length(coef(ddml_fpliv_fit)), 2) })#TEST_THAT test_that("ddml_fpliv computes with multiple ensemble procedures", { @@ -95,19 +72,19 @@ test_that("ddml_fpliv computes with multiple ensemble procedures", { D <- X %*% runif(40) + Z %*% c(1, runif(9)) + UV[, 1] y <- D + X %*% runif(40) + UV[, 2] # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) - # Compute LIE-conform DDML IV estimator + learners <- list(list(what = ols), + list(what = ols)) + # Compute DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, ensemble_type = c("ols", "nnls", "singlebest", "average"), cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 4) + expect_equal(length(coef(ddml_fpliv_fit)), 8) })#TEST_THAT test_that("ddml_fpliv computes with custom weights", { @@ -119,43 +96,19 @@ test_that("ddml_fpliv computes with custom weights", { D <- X %*% runif(40) + Z %*% c(1, runif(9)) + UV[, 1] y <- D + X %*% runif(40) + UV[, 2] # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) - # Compute LIE-conform DDML IV estimator + learners <- list(list(what = ols), + list(what = ols)) + # Compute DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, ensemble_type = c("average"), cv_folds = 3, custom_ensemble_weights = diag(1, 2), sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 3) -})#TEST_THAT - -test_that("ddml_fpliv computes with multiple ensembles w/o the LIE", { - # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z <- matrix(rnorm(nobs*10), nobs, 10) - UV <- matrix(rnorm(2*nobs), nobs, 2) %*% chol(matrix(c(1, 0.7, 0.7, 1), 2, 2)) - D <- X %*% runif(40) + Z %*% c(1, runif(9)) + UV[, 1] - y <- D + X %*% runif(40) + UV[, 2] - # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) - # Compute LIE-conform DDML IV estimator - ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, - learners, - ensemble_type = c("ols", "nnls", - "singlebest", "average"), - cv_folds = 3, - sample_folds = 3, - enforce_LIE = FALSE, - silent = T) - # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 4) + expect_equal(length(coef(ddml_fpliv_fit)), 6) })#TEST_THAT test_that("ddml_fpliv computes with multiple ensembles and sparse matrices", { @@ -167,9 +120,9 @@ test_that("ddml_fpliv computes with multiple ensembles and sparse matrices", { D <- X %*% runif(40) + Z %*% c(1, runif(9)) + UV[, 1] y <- D + X %*% runif(40) + UV[, 2] # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) - # Compute LIE-conform DDML IV estimator + learners <- list(list(what = ols), + list(what = ols)) + # Compute DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z = as(Z, "sparseMatrix"), X = as(X, "sparseMatrix"), @@ -178,9 +131,9 @@ test_that("ddml_fpliv computes with multiple ensembles and sparse matrices", { "singlebest", "average"), cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 4) + expect_equal(length(coef(ddml_fpliv_fit)), 8) })#TEST_THAT test_that("ddml_fpliv computes with different sets of learners", { @@ -192,14 +145,14 @@ test_that("ddml_fpliv computes with different sets of learners", { D <- X %*% runif(40) + Z %*% c(1, runif(9)) + UV[, 1] y <- D + X %*% runif(40) + UV[, 2] # Define arguments - learners <- list(list(fun = ols), - list(fun = ols), - list(fun = ols)) - learners_DXZ <- list(list(fun = ols), - list(fun = ols)) - learners_DX <- list(list(fun = ols), - list(fun = ols)) - # Compute LIE-conform DDML IV estimator + learners <- list(list(what = ols), + list(what = ols), + list(what = ols)) + learners_DXZ <- list(list(what = ols), + list(what = ols)) + learners_DX <- list(list(what = ols), + list(what = ols)) + # Compute DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, learners_DXZ = learners_DXZ, @@ -208,10 +161,10 @@ test_that("ddml_fpliv computes with different sets of learners", { "singlebest", "average"), cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 4) + expect_equal(length(coef(ddml_fpliv_fit)), 8) })#TEST_THAT test_that("ddml_fpliv computes w/ ensembles & shortstack", { @@ -223,45 +176,23 @@ test_that("ddml_fpliv computes w/ ensembles & shortstack", { D <- X %*% runif(40) + Z %*% c(1, runif(9)) + UV[, 1] y <- D + X %*% runif(40) + UV[, 2] # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) - # Compute LIE-conform DDML IV estimator + learners <- list(list(what = ols), + list(what = ols)) + # Compute DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, ensemble_type = c("ols", "nnls", "singlebest", "average"), - shortstack = T, + shortstack = TRUE, cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 4) + expect_equal(length(coef(ddml_fpliv_fit)), 8) })#TEST_THAT -test_that("ddml_fpliv computes w/ ensembles & shortstack but w/o the LIE ", { - # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z <- matrix(rnorm(nobs*10), nobs, 10) - UV <- matrix(rnorm(2*nobs), nobs, 2) %*% chol(matrix(c(1, 0.7, 0.7, 1), 2, 2)) - D <- X %*% runif(40) + Z %*% c(1, runif(9)) + UV[, 1] - y <- D + X %*% runif(40) + UV[, 2] - # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) - # Compute LIE-conform DDML IV estimator - ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, - learners, - ensemble_type = c("ols", "nnls", - "singlebest", "average"), - cv_folds = 3, - sample_folds = 3, - enforce_LIE = FALSE, - silent = T) - # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 4) -})#TEST_THAT + test_that("summary.ddml_fpliv computes with a single model", { # Simulate small dataset @@ -276,11 +207,12 @@ test_that("summary.ddml_fpliv computes with a single model", { ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, sample_folds = 3, - silent = T) - inf_res <- summary(ddml_fpliv_fit, type = "HC1") + silent = TRUE) + inf_res <- summary(ddml_fpliv_fit) capture_output(print(inf_res), print = FALSE) # Check output with expectations - expect_equal(length(inf_res), 8) + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(2, 4, 1)) })#TEST_THAT test_that("ddml_fpliv computes with an ensemble procedure, multi D", { @@ -292,86 +224,122 @@ test_that("ddml_fpliv computes with an ensemble procedure, multi D", { D <- cbind(X %*% runif(40) + Z %*% c(1, runif(9)) + UV[, 1], rnorm(nobs)) y <- rowSums(D) + X %*% runif(40) + UV[, 2] # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) - # Compute LIE-conform DDML IV estimator - ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, - learners, - ensemble_type = "ols", - cv_folds = 3, - sample_folds = 3, - silent = T) - # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 2) -})#TEST_THAT - -test_that("ddml_fpliv computes with an ensemble procedure w/o LIE, multi D", { - # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z <- matrix(rnorm(nobs*10), nobs, 10) - UV <- matrix(rnorm(2*nobs), nobs, 2) %*% chol(matrix(c(1, 0.7, 0.7, 1), 2, 2)) - D <- cbind(X %*% runif(40) + Z %*% c(1, runif(9)) + UV[, 1], rnorm(nobs)) - y <- rowSums(D) + X %*% runif(40) + UV[, 2] - # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) - # Compute LIE-conform DDML IV estimator + learners <- list(list(what = ols), + list(what = ols)) + # Compute DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, ensemble_type = "ols", cv_folds = 3, sample_folds = 3, - enforce_LIE = F, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 2) + expect_equal(length(coef(ddml_fpliv_fit)), 3) })#TEST_THAT test_that("ddml_fpliv computes with multiple ensemble procedures, multi D", { # Simulate small dataset - nobs <- 100 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z <- matrix(rnorm(nobs*10), nobs, 10) - UV <- matrix(rnorm(2*nobs), nobs, 2) %*% chol(matrix(c(1, 0.7, 0.7, 1), 2, 2)) - D <- cbind(X %*% runif(40) + Z %*% c(1, runif(9)) + UV[, 1], - X %*% runif(40) + Z %*% c(1, runif(9)) + rnorm(nobs)) - y <- rowSums(D) + X %*% runif(40) + UV[, 2] + set.seed(51) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + Z <- matrix(rnorm(nobs * 3), nobs, 3) + UV <- matrix(rnorm(2 * nobs), nobs, 2) %*% + chol(matrix(c(1, 0.7, 0.7, 1), 2, 2)) + D <- cbind(0.3 * X[, 1] + Z %*% c(0.5, 0.3, 0.1) + UV[, 1], + 0.2 * X[, 2] + Z %*% c(0.2, 0.4, 0.1) + rnorm(nobs)) + y <- rowSums(D) + 0.3 * X[, 1] + UV[, 2] # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) - # Compute LIE-conform DDML IV estimator + learners <- list(list(what = ols), + list(what = ols)) + # Compute DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, ensemble_type = c("ols", "nnls", "singlebest", "average"), cv_folds = 3, sample_folds = 5, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 8) - })#TEST_THAT + expect_equal(length(coef(ddml_fpliv_fit)), 12) +})#TEST_THAT -test_that("ddml_fpliv computes with ensemble procedures w/o LIE, multi D", { - # Simulate small dataset +test_that("ddml_fpliv HC0/HC1 SEs close to sandwich::vcovHC on iv_fit", { + skip_if_not_installed("sandwich") + skip_if_not_installed("AER") + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + Z <- matrix(rnorm(nobs * 2), nobs, 2) + UV <- matrix(rnorm(2 * nobs), nobs, 2) %*% + chol(matrix(c(1, 0.7, 0.7, 1), 2, 2)) + D <- X %*% c(1, 0.5, 0, 0, 0) + + Z %*% c(0.5, 0.3) + UV[, 1] + y <- 2 * D + X %*% c(0, 1, 0.5, 0.3, 0) + UV[, 2] + + fit <- ddml_fpliv(y, D, Z, X, + learners = list(what = ols), + sample_folds = 5, + silent = TRUE) + + # Reconstruct the final partialing-out regression since iv_fit is removed: + y_r <- as.vector(y - fit$fitted$y_X$cf_fitted_bylearner[, 1]) + D_r <- as.matrix(D - fit$fitted$D1_X$cf_fitted_bylearner[, 1]) + V_r <- as.matrix(fit$fitted$D1_XZ$cf_fitted_bylearner[, 1] - fit$fitted$D1_X$cf_fitted_bylearner[, 1]) + colnames(D_r) <- colnames(D) + colnames(V_r) <- colnames(D) + iv_fit <- AER::ivreg(y_r ~ D_r | V_r, x = TRUE) + + for (type in c("HC0", "HC1")) { + V_ddml <- vcov(fit, type = type) + V_sw <- sandwich::vcovHC(iv_fit, type = type) + idx <- c(seq_len(nrow(V_sw))[-1], 1) + V_sw_reord <- V_sw[idx, idx, drop = FALSE] + expect_equal(as.numeric(V_ddml), + as.numeric(V_sw_reord), + tolerance = 1e-8, + info = paste("FPLIV", type)) + } + # HC3: regressor-based leverage matches sandwich exactly + V_ddml <- vcov(fit, type = "HC3") + V_sw <- sandwich::vcovHC(iv_fit, type = "HC3") + idx <- c(seq_len(nrow(V_sw))[-1], 1) + V_sw_reord <- V_sw[idx, idx, drop = FALSE] + expect_equal(as.numeric(V_ddml), + as.numeric(V_sw_reord), + tolerance = 1e-8, + info = "FPLIV HC3") +})#TEST_THAT + +test_that("ddml_fpliv fitted pass-through works", { + set.seed(42) nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z <- matrix(rnorm(nobs*10), nobs, 10) - UV <- matrix(rnorm(2*nobs), nobs, 2) %*% chol(matrix(c(1, 0.7, 0.7, 1), 2, 2)) - D <- cbind(X %*% runif(40) + Z %*% c(1, runif(9)) + UV[, 1], rnorm(nobs)) - y <- rowSums(D) + X %*% runif(40) + UV[, 2] - # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) - # Compute LIE-conform DDML IV estimator - ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, - learners, - ensemble_type = c("ols", "nnls", - "singlebest", "average"), - cv_folds = 3, - sample_folds = 3, - enforce_LIE = F, - silent = T) - # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 8) + X <- matrix(rnorm(nobs * 3), nobs, 3) + Z <- matrix(rnorm(nobs * 2), nobs, 2) + D <- X %*% c(1, 0.5, 0) + Z %*% c(0.5, 0.3) + rnorm(nobs) + y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_fpliv(y, D, Z, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE) + fit2 <- ddml_fpliv(y, D, Z, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted, + splits = fit$splits) + expect_equal(coef(fit2), coef(fit), tolerance = 1e-6) + + # Error when fitted supplied without splits + expect_error( + ddml_fpliv(y, D, Z, X, + learners = learners, + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted), + "must be supplied when 'fitted' is supplied" + ) })#TEST_THAT diff --git a/tests/testthat/test-ddml_late.R b/tests/testthat/test-ddml_late.R index d3d2f6b..08d8603 100644 --- a/tests/testthat/test-ddml_late.R +++ b/tests/testthat/test-ddml_late.R @@ -1,116 +1,128 @@ test_that("ddml_late computes with a single model", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z_tld <- X %*% runif(40) + rnorm(nobs) - Z <- 1 * (Z_tld > mean(Z_tld)) - D_tld <- 0.5 * (1 - 2 * Z) + 0.2 * X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + Z_tld <- 0.1 * X[, 1] + rnorm(nobs) + Z <- 1 * (Z_tld > 0) + D_tld <- 0.2 * Z + 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ - ddml_late_fit <- ddml_late(y, D, Z, X, + ddml_late_fit <- ddml_late(y, D, Z, X, learners = learners, cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_late_fit$late), 1) + expect_equal(length(coef(ddml_late_fit)), 1) +})#TEST_THAT + +test_that("ddml_late computes with stratify = FALSE", { + # Simulate small dataset + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + Z_tld <- 0.1 * X[, 1] + rnorm(nobs) + Z <- 1 * (Z_tld > 0) + D_tld <- 0.2 * Z + 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + # Define arguments + learners <- list(what = ols) + ddml_late_fit <- ddml_late(y, D, Z, X, + learners = learners, + stratify = FALSE, + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + # Check output with expectations + expect_equal(length(coef(ddml_late_fit)), 1) })#TEST_THAT test_that("ddml_late computes with a single model and dependence", { # Simulate small dataset n_cluster <- 250 nobs <- 500 - X <- cbind(1, matrix(rnorm(n_cluster*39), n_cluster, 39)) - Z_tld <- X %*% runif(40) + rnorm(n_cluster) - fun <- stepfun(quantile(Z_tld, probs = 0.5), c(0, 1)) - Z <- fun(Z_tld) - cluster_variable <- sample(1:n_cluster, nobs, replace = TRUE) - Z <- Z[cluster_variable, drop = F] - X <- X[cluster_variable, , drop = F] + X <- matrix(rnorm(n_cluster * 5), n_cluster, 5) + Z_tld <- 0.1 * X[, 1] + rnorm(n_cluster) + Z <- 1 * (Z_tld > 0) + cluster_variable <- sample(seq_len(n_cluster), nobs, + replace = TRUE) + Z <- Z[cluster_variable] + X <- X[cluster_variable, , drop = FALSE] eps <- rnorm(nobs) - D <- Z + X %*% runif(40) + eps - y <- D + X %*% runif(40) + 0.1 * eps + rnorm(nobs) + D <- Z + 0.1 * X[, 1] + eps + y <- D + 0.1 * X[, 1] + 0.1 * eps + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ - ddml_late_fit <- ddml_late(y, D, Z, X, + ddml_late_fit <- ddml_late(y, D, Z, X, learners = learners, cluster_variable = cluster_variable, cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_late_fit$late), 1) + expect_equal(length(coef(ddml_late_fit)), 1) })#TEST_THAT test_that("ddml_late computes with a single model & perfect non-compliance", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z_tld <- X %*% runif(40) + rnorm(nobs) - Z <- 1 * (Z_tld > mean(Z_tld)) - D_tld <- 0.5 * (1 - 2 * Z) + 0.2 * X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + Z_tld <- 0.1 * X[, 1] + rnorm(nobs) + Z <- 1 * (Z_tld > 0) + D_tld <- 0.5 * Z + 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) D[Z == 0] <- 0 - y <- D + X %*% runif(40) + rnorm(nobs) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ - ddml_late_fit <- ddml_late(y, D, Z, X, + ddml_late_fit <- ddml_late(y, D, Z, X, learners = learners, cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_late_fit$late), 1) + expect_equal(length(coef(ddml_late_fit)), 1) })#TEST_THAT test_that("ddml_late computes with an ensemble procedure", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z_tld <- X %*% runif(40) + rnorm(nobs) - Z <- 1 * (Z_tld > mean(Z_tld)) - D_tld <- 0.25 * (1 - 2 * Z) + 0.2 * X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + Z_tld <- 0.1 * X[, 1] + rnorm(nobs) + Z <- 1 * (Z_tld > 0) + D_tld <- 0.2 * Z + 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute DDML PLM estimator - expect_warning({ - ddml_late_fit <- ddml_late(y, D, Z, X, + ddml_late_fit <- ddml_late(y, D, Z, X, learners = learners, ensemble_type = "ols", cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_late_fit$late), 1) + expect_equal(length(coef(ddml_late_fit)), 1) })#TEST_THAT test_that("ddml_late computes w/ multiple ensembles & custom weights", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z_tld <- X %*% runif(40) + rnorm(nobs) - Z <- 1 * (Z_tld > mean(Z_tld)) - D_tld <- 0.25 * (1 - 2 * Z) + 0.2 * X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + Z_tld <- 0.1 * X[, 1] + rnorm(nobs) + Z <- 1 * (Z_tld > 0) + D_tld <- 0.2 * Z + 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute DDML PLM estimator - expect_warning({ - ddml_late_fit <- ddml_late(y, D, Z, X, + ddml_late_fit <- ddml_late(y, D, Z, X, learners, ensemble_type = c("ols", "nnls", "nnls1", @@ -118,55 +130,51 @@ test_that("ddml_late computes w/ multiple ensembles & custom weights", { cv_folds = 3, custom_ensemble_weights = diag(1, 2), sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_late_fit$late), 7) + expect_equal(length(coef(ddml_late_fit)), 7) })#TEST_THAT test_that("ddml_late computes with multiple ensemble procedures + perfect compliance", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z_tld <- X %*% runif(40) + rnorm(nobs) - Z <- 1 * (Z_tld > mean(Z_tld)) - D_tld <- 0.25 * (1 - 2 * Z) + 0.2 * X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + Z_tld <- 0.1 * X[, 1] + rnorm(nobs) + Z <- 1 * (Z_tld > 0) + D_tld <- 0.2 * Z + 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) D[Z == 1] <- 1 # perfect compliance - y <- D + X %*% runif(40) + rnorm(nobs) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute DDML PLM estimator - expect_warning({ - ddml_late_fit <- ddml_late(y, D, Z, X, + ddml_late_fit <- ddml_late(y, D, Z, X, learners, ensemble_type = c("ols", "nnls", "nnls1", "singlebest", "average"), cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_late_fit$late), 5) + expect_equal(length(coef(ddml_late_fit)), 5) })#TEST_THAT test_that("ddml_late computes w/ mult ensembles, custom weights, & shortstack", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z_tld <- X %*% runif(40) + rnorm(nobs) - Z <- 1 * (Z_tld > mean(Z_tld)) - D_tld <- 0.25 * (1 - 2 * Z) + 0.2 * X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + Z_tld <- 0.1 * X[, 1] + rnorm(nobs) + Z <- 1 * (Z_tld > 0) + D_tld <- 0.2 * Z + 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute DDML PLM estimator - expect_warning({ - ddml_late_fit <- ddml_late(y, D, Z, X, + ddml_late_fit <- ddml_late(y, D, Z, X, learners, ensemble_type = c("ols", "nnls", "nnls1", @@ -175,64 +183,136 @@ test_that("ddml_late computes w/ mult ensembles, custom weights, & shortstack", cv_folds = 3, custom_ensemble_weights = diag(1, 2), sample_folds = 3, - silent = T) - }) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_late_fit$late), 7) + expect_equal(length(coef(ddml_late_fit)), 7) })#TEST_THAT test_that("summary.ddml_late computes with a single model", { # Simulate small dataset - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z_tld <- X %*% runif(40) + rnorm(nobs) - Z <- 1 * (Z_tld > mean(Z_tld)) - D_tld <- 0.5 * (1 - 2 * Z) + 0.2 * X %*% runif(40) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(40) + rnorm(nobs) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + Z_tld <- 0.1 * X[, 1] + rnorm(nobs) + Z <- 1 * (Z_tld > 0) + D_tld <- 0.2 * Z + 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ - ddml_late_fit <- ddml_late(y, D, Z, X, + ddml_late_fit <- ddml_late(y, D, Z, X, learners = learners, cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Compute inference results & test print inf_res <- summary(ddml_late_fit) capture_output({print(inf_res)}, print = FALSE) # Check output with expectations - expect_equal(length(inf_res), 4) + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_late computes with a single model and dependence", { # Simulate small dataset n_cluster <- 250 nobs <- 500 - X <- cbind(1, matrix(rnorm(n_cluster*39), n_cluster, 39)) - Z_tld <- X %*% runif(40) + rnorm(n_cluster) - fun <- stepfun(quantile(Z_tld, probs = 0.5), c(0, 1)) - Z <- fun(Z_tld) - cluster_variable <- sample(1:n_cluster, nobs, replace = TRUE) - Z <- Z[cluster_variable, drop = F] - X <- X[cluster_variable, , drop = F] + X <- matrix(rnorm(n_cluster * 5), n_cluster, 5) + Z_tld <- 0.1 * X[, 1] + rnorm(n_cluster) + Z <- 1 * (Z_tld > 0) + cluster_variable <- sample(seq_len(n_cluster), nobs, + replace = TRUE) + Z <- Z[cluster_variable] + X <- X[cluster_variable, , drop = FALSE] eps <- rnorm(nobs) - D <- Z + X %*% runif(40) + eps - y <- D + X %*% runif(40) + 0.1 * eps + rnorm(nobs) + D <- Z + 0.1 * X[, 1] + eps + y <- D + 0.1 * X[, 1] + 0.1 * eps + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ - ddml_late_fit <- ddml_late(y, D, Z, X, + ddml_late_fit <- ddml_late(y, D, Z, X, learners = learners, cluster_variable = cluster_variable, cv_folds = 3, sample_folds = 3, - silent = T) - }) + silent = TRUE) # Compute inference results & test print inf_res <- summary(ddml_late_fit) capture_output({print(inf_res)}, print = FALSE) # Check output with expectations - expect_equal(length(inf_res), 4) + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) })#TEST_THAT + +test_that("ddml_late fitted pass-through works", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + Z_tld <- 0.1 * X[, 1] + rnorm(nobs) + Z <- 1 * (Z_tld > 0) + D_tld <- 0.2 * Z + 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_late(y, D, Z, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE) + + fit2 <- ddml_late(y, D, Z, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted, + splits = fit$splits) + expect_equal(coef(fit2), coef(fit), tolerance = 1e-6) + + expect_error( + ddml_late(y, D, Z, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted), + "must be supplied when 'fitted' is supplied" + ) +})#TEST_THAT + +test_that("ddml_late scores are mean-zero", { + nobs <- 500 + set.seed(42) + X <- matrix(rnorm(nobs * 3), nobs, 3) + Z_tld <- 0.2 * X[, 1] + rnorm(nobs) + Z <- 1 * (Z_tld > 0) + D_tld <- 0.3 * Z + 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + fit <- ddml_late(y, D, Z, X, + learners = list(what = ols), + sample_folds = 3, silent = TRUE) + score_mean <- mean(fit$scores[, , 1]) + expect_true(abs(score_mean) < 0.05, + label = paste("score mean =", round(score_mean, 6))) +}) + +test_that("ddml_late has correct sign (matches Wald estimator)", { + nobs <- 2000 + set.seed(123) + X <- matrix(rnorm(nobs * 3), nobs, 3) + Z_tld <- 0.5 * X[, 1] + rnorm(nobs) + Z <- 1 * (Z_tld > 0) + D_tld <- 0.6 * Z + 0.2 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- 1.0 * D + 0.3 * X[, 1] + rnorm(nobs) + fit <- ddml_late(y, D, Z, X, + learners = list(what = ols), + sample_folds = 5, silent = TRUE) + # Wald estimator: cov(y,Z)/cov(D,Z) + wald <- as.numeric(stats::cov(y, Z) / stats::cov(D, Z)) + late_hat <- as.numeric(coef(fit)) + # LATE should have the same sign as Wald + expect_true(sign(late_hat) == sign(wald)) + # And be in a reasonable range + expect_equal(late_hat, wald, tolerance = 0.5) +}) diff --git a/tests/testthat/test-ddml_pliv.R b/tests/testthat/test-ddml_pliv.R index a77ee9a..c12d177 100644 --- a/tests/testthat/test-ddml_pliv.R +++ b/tests/testthat/test-ddml_pliv.R @@ -12,9 +12,9 @@ test_that("ddml_pliv computes with a single model", { ddml_pliv_fit <- ddml_pliv(y, D, Z, X, learners, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_pliv_fit$coef), 1) + expect_equal(length(coef(ddml_pliv_fit)), 2) })#TEST_THAT test_that("ddml_pliv computes with a single model and dependence", { @@ -37,9 +37,9 @@ test_that("ddml_pliv computes with a single model and dependence", { ddml_pliv_fit <- ddml_pliv(y, D, Z, X, learners, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_pliv_fit$coef), 1) + expect_equal(length(coef(ddml_pliv_fit)), 2) })#TEST_THAT test_that("ddml_pliv computes with an ensemble procedure", { @@ -51,17 +51,17 @@ test_that("ddml_pliv computes with an ensemble procedure", { D <- X %*% runif(40) + Z %*% (1 + runif(1)) + UV[, 1] y <- D + X %*% runif(40) + UV[, 2] # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_pliv_fit <- ddml_pliv(y, D, Z, X, learners, ensemble_type = "ols", cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_pliv_fit$coef), 1) + expect_equal(length(coef(ddml_pliv_fit)), 2) })#TEST_THAT test_that("ddml_pliv computes with multiple ensemble procedures", { @@ -73,8 +73,8 @@ test_that("ddml_pliv computes with multiple ensemble procedures", { D <- X %*% runif(40) + Z %*% (1 + runif(1)) + UV[, 1] y <- D + X %*% runif(40) + UV[, 2] # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_pliv_fit <- ddml_pliv(y, D, Z, X, learners, @@ -83,9 +83,9 @@ test_that("ddml_pliv computes with multiple ensemble procedures", { "singlebest", "average"), cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_pliv_fit$coef), 5) + expect_equal(length(coef(ddml_pliv_fit)), 10) })#TEST_THAT @@ -98,14 +98,14 @@ test_that("ddml_pliv computes with different sets of learners", { D <- X %*% runif(40) + Z %*% (1 + runif(1)) + UV[, 1] y <- D + X %*% runif(40) + UV[, 2] # Define arguments - learners <- list(list(fun = ols), - list(fun = ols), - list(fun = ols)) - learners_ZX <- list(list(fun = ols), - list(fun = ols)) - learners_DX <- list(list(fun = ols), - list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols), + list(what = ols)) + learners_ZX <- list(list(what = ols), + list(what = ols)) + learners_DX <- list(list(what = ols), + list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_pliv_fit <- ddml_pliv(y, D, Z, X, learners, @@ -116,9 +116,9 @@ test_that("ddml_pliv computes with different sets of learners", { "singlebest", "average"), cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_pliv_fit$coef), 5) + expect_equal(length(coef(ddml_pliv_fit)), 10) })#TEST_THAT test_that("ddml_pliv computes with different sets of learners & shortstack", { @@ -130,14 +130,14 @@ test_that("ddml_pliv computes with different sets of learners & shortstack", { D <- X %*% runif(40) + Z %*% (1 + runif(1)) + UV[, 1] y <- D + X %*% runif(40) + UV[, 2] # Define arguments - learners <- list(list(fun = ols), - list(fun = ols), - list(fun = ols)) - learners_ZX <- list(list(fun = ols), - list(fun = ols)) - learners_DX <- list(list(fun = ols), - list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols), + list(what = ols)) + learners_ZX <- list(list(what = ols), + list(what = ols)) + learners_DX <- list(list(what = ols), + list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_pliv_fit <- ddml_pliv(y, D, Z, X, learners, @@ -146,12 +146,12 @@ test_that("ddml_pliv computes with different sets of learners & shortstack", { ensemble_type = c("ols", "nnls", "nnls1", "singlebest", "average"), - shortstack = T, + shortstack = TRUE, cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_pliv_fit$coef), 5) + expect_equal(length(coef(ddml_pliv_fit)), 10) })#TEST_THAT test_that("summary.ddml_pliv computes with a single model", { @@ -168,11 +168,11 @@ test_that("summary.ddml_pliv computes with a single model", { ddml_pliv_fit <- ddml_pliv(y, D, Z, X, learners, sample_folds = 3, - silent = T) + silent = TRUE) inf_res <- summary(ddml_pliv_fit, type = "HC1") capture_output(print(inf_res), print = FALSE) # Check output with expectations - expect_equal(length(ddml_pliv_fit$coef), 1) + expect_equal(length(coef(ddml_pliv_fit)), 2) })#TEST_THAT @@ -185,18 +185,18 @@ test_that("summary.ddml_pliv computes with custom ensemble weights", { D <- X %*% runif(40) + Z %*% (1 + runif(1)) + UV[, 1] y <- D + X %*% runif(40) + UV[, 2] # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute DDML PLIV estimator ddml_pliv_fit <- ddml_pliv(y, D, Z, X, learners, sample_folds = 3, custom_ensemble_weights = diag(1, 2), - silent = T) + silent = TRUE) inf_res <- summary(ddml_pliv_fit, type = "HC1") capture_output(print(inf_res), print = FALSE) # Check output with expectations - expect_equal(length(ddml_pliv_fit$coef), 3) + expect_equal(length(coef(ddml_pliv_fit)), 6) })#TEST_THAT test_that("ddml_pliv computes with a single model and multivariate D,Z", { @@ -215,9 +215,9 @@ test_that("ddml_pliv computes with a single model and multivariate D,Z", { ddml_pliv_fit <- ddml_pliv(y, D, Z, X, learners, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_pliv_fit$coef), 2) + expect_equal(length(coef(ddml_pliv_fit)), 3) })#TEST_THAT test_that("ddml_pliv computes with different ensembles and multivariate D,Z", { @@ -230,8 +230,8 @@ test_that("ddml_pliv computes with different ensembles and multivariate D,Z", { Z <- cbind(Z, rnorm(nobs)) y <- rowSums(D) + X %*% runif(40) + UV[, 2] # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_pliv_fit <- ddml_pliv(y, D, Z, X, learners, @@ -240,7 +240,89 @@ test_that("ddml_pliv computes with different ensembles and multivariate D,Z", { "singlebest", "average"), cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_pliv_fit$coef), 10) + expect_equal(length(coef(ddml_pliv_fit)), 15) +})#TEST_THAT + +test_that("ddml_pliv HC0/HC1 SEs close to sandwich::vcovHC on iv_fit", { + skip_if_not_installed("sandwich") + skip_if_not_installed("AER") + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + Z <- matrix(rnorm(nobs), nobs, 1) + UV <- matrix(rnorm(2 * nobs), nobs, 2) %*% + chol(matrix(c(1, 0.7, 0.7, 1), 2, 2)) + D <- X %*% c(1, 0.5, 0, 0, 0) + + Z %*% 1.5 + UV[, 1] + y <- 2 * D + X %*% c(0, 1, 0.5, 0.3, 0) + UV[, 2] + + fit <- ddml_pliv(y, D, Z, X, + learners = list(what = ols), + sample_folds = 5, + silent = TRUE) + + # Reconstruct the final partialing-out regression since iv_fit is removed: + y_r <- as.vector(y - fit$fitted$y_X$cf_fitted_bylearner[, 1]) + D_r <- as.matrix(D - fit$fitted$D1_X$cf_fitted_bylearner[, 1]) + V_r <- as.matrix(Z - fit$fitted$Z1_X$cf_fitted_bylearner[, 1]) + colnames(D_r) <- colnames(D) + colnames(V_r) <- colnames(Z) + iv_fit <- AER::ivreg(y_r ~ D_r | V_r, x = TRUE) + + for (type in c("HC0", "HC1")) { + V_ddml <- vcov(fit, type = type) + V_sw <- sandwich::vcovHC(iv_fit, type = type) + idx <- c(seq_len(nrow(V_sw))[-1], 1) + V_sw_reord <- V_sw[idx, idx, drop = FALSE] + expect_equal(as.numeric(V_ddml), + as.numeric(V_sw_reord), + tolerance = 1e-8, + info = paste("PLIV", type)) + } + # HC3: regressor-based leverage matches sandwich exactly + V_ddml <- vcov(fit, type = "HC3") + V_sw <- sandwich::vcovHC(iv_fit, type = "HC3") + idx <- c(seq_len(nrow(V_sw))[-1], 1) + V_sw_reord <- V_sw[idx, idx, drop = FALSE] + expect_equal(as.numeric(V_ddml), + as.numeric(V_sw_reord), + tolerance = 1e-8, + info = "PLIV HC3") +})#TEST_THAT + +test_that("ddml_pliv fitted pass-through works", { + set.seed(42) + nobs <- 200 + X <- matrix(rnorm(nobs * 3), nobs, 3) + Z <- matrix(rnorm(nobs * 2), nobs, 2) + D <- X %*% c(1, 0.5, 0) + Z %*% c(0.5, 0.3) + rnorm(nobs) + y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_pliv(y, D, Z, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE) + + fit2 <- ddml_pliv(y, D, Z, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted, + splits = fit$splits) + expect_equal(coef(fit2), coef(fit), tolerance = 1e-6) + + expect_error( + ddml_pliv(y, D, Z, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted), + "must be supplied when 'fitted' is supplied" + ) })#TEST_THAT diff --git a/tests/testthat/test-ddml_plm.R b/tests/testthat/test-ddml_plm.R index c32c6b9..c990925 100644 --- a/tests/testthat/test-ddml_plm.R +++ b/tests/testthat/test-ddml_plm.R @@ -12,9 +12,9 @@ test_that("ddml_plm computes with a single model", { learners = learners, cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_plm_fit$coef), 1) + expect_equal(length(coef(ddml_plm_fit)), 2) })#TEST_THAT test_that("ddml_plm computes with clustered observations", { @@ -24,7 +24,7 @@ test_that("ddml_plm computes with clustered observations", { D_tld <- X %*% runif(40) + rnorm(nobs) D <- 1 * (D_tld > mean(D_tld)) y <- D + X %*% runif(40) + rnorm(nobs) - cluster_variable <- sample(1:100, nobs, replace = T) + cluster_variable <- sample(1:100, nobs, replace = TRUE) # Define arguments learners <- list(what = mdl_glmnet, args = list(alpha = 0.5)) @@ -33,9 +33,9 @@ test_that("ddml_plm computes with clustered observations", { cv_folds = 3, sample_folds = 3, cluster_variable = cluster_variable, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_plm_fit$coef), 1) + expect_equal(length(coef(ddml_plm_fit)), 2) })#TEST_THAT test_that("ddml_plm computes with an ensemble procedure", { @@ -45,9 +45,9 @@ test_that("ddml_plm computes with an ensemble procedure", { D <- X %*% runif(40) + rnorm(nobs) y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = mdl_glmnet, + learners <- list(list(what = mdl_glmnet, args = list(alpha = 0.5)), - list(fun = ols)) + list(what = ols)) # Compute DDML PLM estimator ddml_plm_fit <- ddml_plm(y, D, X, learners = learners, @@ -55,9 +55,9 @@ test_that("ddml_plm computes with an ensemble procedure", { shortstack = FALSE, cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_plm_fit$coef), 1) + expect_equal(length(coef(ddml_plm_fit)), 2) })#TEST_THAT test_that("ddml_plm computes with multiple ensemble procedures", { @@ -67,9 +67,9 @@ test_that("ddml_plm computes with multiple ensemble procedures", { D <- X %*% runif(40) + rnorm(nobs) y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = mdl_glmnet, + learners <- list(list(what = mdl_glmnet, args = list(alpha = 0.5)), - list(fun = ols)) + list(what = ols)) # Compute DDML PLM estimator ddml_plm_fit <- ddml_plm(y, D, X, learners, @@ -79,9 +79,9 @@ test_that("ddml_plm computes with multiple ensemble procedures", { shortstack = FALSE, cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_plm_fit$coef), 5) + expect_equal(length(coef(ddml_plm_fit)), 10) })#TEST_THAT test_that("ddml_plm computes with multiple ensemble procedures & sparse mats", { @@ -91,9 +91,9 @@ test_that("ddml_plm computes with multiple ensemble procedures & sparse mats", { D <- X %*% runif(40) + rnorm(nobs) y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = mdl_glmnet, + learners <- list(list(what = mdl_glmnet, args = list(alpha = 0.5)), - list(fun = ols)) + list(what = ols)) # Compute DDML PLM estimator ddml_plm_fit <- ddml_plm(y, D, as(X, "sparseMatrix"), learners, @@ -103,9 +103,9 @@ test_that("ddml_plm computes with multiple ensemble procedures & sparse mats", { shortstack = FALSE, cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_plm_fit$coef), 5) + expect_equal(length(coef(ddml_plm_fit)), 10) })#TEST_THAT test_that("ddml_plm computes w/ an ensemble procedure & shortstacking", { # Simulate small dataset @@ -114,9 +114,9 @@ test_that("ddml_plm computes w/ an ensemble procedure & shortstacking", { D <- X %*% runif(40) + rnorm(nobs) y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = mdl_glmnet, + learners <- list(list(what = mdl_glmnet, args = list(alpha = 0.5)), - list(fun = ols)) + list(what = ols)) # Compute DDML PLM estimator ddml_plm_fit <- ddml_plm(y, D, X, learners = learners, @@ -124,9 +124,9 @@ test_that("ddml_plm computes w/ an ensemble procedure & shortstacking", { shortstack = TRUE, cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_plm_fit$coef), 1) + expect_equal(length(coef(ddml_plm_fit)), 2) })#TEST_THAT test_that("ddml_plm computes w/ multiple ensemble procedures & shortstacking", { @@ -136,9 +136,9 @@ test_that("ddml_plm computes w/ multiple ensemble procedures & shortstacking", { D <- X %*% runif(40) + rnorm(nobs) y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = mdl_glmnet, + learners <- list(list(what = mdl_glmnet, args = list(alpha = 0.5)), - list(fun = ols)) + list(what = ols)) # Compute DDML PLM estimator ddml_plm_fit <- ddml_plm(y, D, X, learners, @@ -148,9 +148,9 @@ test_that("ddml_plm computes w/ multiple ensemble procedures & shortstacking", { shortstack = TRUE, cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_plm_fit$coef), 5) + expect_equal(length(coef(ddml_plm_fit)), 10) })#TEST_THAT test_that("ddml_plm computes w/ ensemble procedures & custom weights", { @@ -160,8 +160,8 @@ test_that("ddml_plm computes w/ ensemble procedures & custom weights", { D <- X %*% runif(40) + rnorm(nobs) y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) # Compute DDML PLM estimator ddml_plm_fit <- ddml_plm(y, D, X, learners, @@ -172,9 +172,9 @@ test_that("ddml_plm computes w/ ensemble procedures & custom weights", { cv_folds = 3, custom_ensemble_weights = diag(1, length(learners)), sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_plm_fit$coef), 7) + expect_equal(length(coef(ddml_plm_fit)), 14) })#TEST_THAT test_that("summary.ddml_plm computes with a single model", { @@ -191,11 +191,12 @@ test_that("summary.ddml_plm computes with a single model", { learners = learners, cv_folds = 3, sample_folds = 3, - silent = T) - inf_res <- summary(ddml_plm_fit, type = "HC1") + silent = TRUE) + inf_res <- summary(ddml_plm_fit) capture_output(print(inf_res), print = FALSE) # Check output with expectations - expect_equal(length(inf_res), 8) + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(2, 4, 1)) })#TEST_THAT test_that("summary.ddml_plm computes with a single model and dependence", { @@ -205,7 +206,7 @@ test_that("summary.ddml_plm computes with a single model and dependence", { D_tld <- X %*% runif(40) + rnorm(nobs) D <- 1 * (D_tld > mean(D_tld)) y <- D + X %*% runif(40) + rnorm(nobs) - cluster_variable <- sample(1:100, nobs, replace = T) + cluster_variable <- sample(1:100, nobs, replace = TRUE) # Define arguments learners <- list(what = mdl_glmnet, args = list(alpha = 0.5)) @@ -214,11 +215,12 @@ test_that("summary.ddml_plm computes with a single model and dependence", { cv_folds = 3, sample_folds = 3, cluster_variable = cluster_variable, - silent = T) + silent = TRUE) inf_res <- summary(ddml_plm_fit) capture_output(print(inf_res), print = FALSE) # Check output with expectations - expect_equal(length(inf_res), 8) + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(2, 4, 1)) })#TEST_THAT test_that("summary.ddml_plm computes with multiple ensemble procedures", { @@ -228,9 +230,9 @@ test_that("summary.ddml_plm computes with multiple ensemble procedures", { D <- X %*% runif(40) + rnorm(nobs) y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = mdl_glmnet, + learners <- list(list(what = mdl_glmnet, args = list(alpha = 0.5)), - list(fun = ols)) + list(what = ols)) # Compute DDML PLM estimator ddml_plm_fit <- ddml_plm(y, D, X, learners, @@ -241,11 +243,12 @@ test_that("summary.ddml_plm computes with multiple ensemble procedures", { cv_folds = 3, custom_ensemble_weights = diag(1, length(learners)), sample_folds = 3, - silent = T) - inf_res <- summary(ddml_plm_fit, type = "HC1") + silent = TRUE) + inf_res <- summary(ddml_plm_fit) capture_output(print(inf_res), print = FALSE) # Check output with expectations - expect_equal(length(inf_res), 8 * 7) + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(2, 4, 7)) })#TEST_THAT test_that("ddml_plm computes with an ensemble procedure and multivariate D", { @@ -255,9 +258,9 @@ test_that("ddml_plm computes with an ensemble procedure and multivariate D", { D <- cbind(X %*% runif(40) + rnorm(nobs), rnorm(nobs)) y <- rowSums(D) + X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = mdl_glmnet, + learners <- list(list(what = mdl_glmnet, args = list(alpha = 0.5)), - list(fun = ols)) + list(what = ols)) # Compute DDML PLM estimator ddml_plm_fit <- ddml_plm(y, D, X, learners = learners, @@ -265,9 +268,9 @@ test_that("ddml_plm computes with an ensemble procedure and multivariate D", { shortstack = FALSE, cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_plm_fit$coef), 2) + expect_equal(length(coef(ddml_plm_fit)), 3) })#TEST_THAT test_that("ddml_plm computes with multiple ensemble types and multivariate D", { @@ -277,9 +280,9 @@ test_that("ddml_plm computes with multiple ensemble types and multivariate D", { D <- cbind(X %*% runif(40) + rnorm(nobs), rnorm(nobs)) y <- rowSums(D) + X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = mdl_glmnet, + learners <- list(list(what = mdl_glmnet, args = list(alpha = 0.5)), - list(fun = ols)) + list(what = ols)) # Compute DDML PLM estimator ddml_plm_fit <- ddml_plm(y, D, X, learners, @@ -289,7 +292,238 @@ test_that("ddml_plm computes with multiple ensemble types and multivariate D", { shortstack = FALSE, cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_plm_fit$coef), 10) + expect_equal(length(coef(ddml_plm_fit)), 15) +})#TEST_THAT + +test_that("ddml_plm computes with parallel", { + skip_on_cran() + skip_if_not_installed("parallel") + set.seed(42) + nobs <- 200 + X <- cbind(1, matrix(rnorm(nobs * 39), nobs, 39)) + D <- X %*% runif(40) + rnorm(nobs) + y <- D + X %*% runif(40) + rnorm(nobs) + learners <- list(what = ols) + splits <- get_sample_splits(seq_len(nobs), sample_folds = 3) + # Sequential + res_seq <- ddml_plm(y, D, X, + learners = learners, + sample_folds = 3, + splits = list( + y_X = list(subsamples = splits$subsamples)), + silent = TRUE) + # Parallel + res_par <- ddml_plm(y, D, X, + learners = learners, + sample_folds = 3, + splits = list( + y_X = list(subsamples = splits$subsamples)), + silent = TRUE, + parallel = list(cores = 2)) + expect_equal(coef(res_par), coef(res_seq)) })#TEST_THAT + +test_that("ddml_plm fitted pass-through works", { + set.seed(42) + nobs <- 200 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X %*% c(1, 0.5, 0) + rnorm(nobs) + y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + presplits <- get_sample_splits(seq_len(nobs), + sample_folds = 2, + cv_folds = 2) + fit <- ddml_plm(y, D, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + splits = list( + y_X = list( + subsamples = presplits$subsamples, + cv_subsamples = presplits$cv_subsamples)), + silent = TRUE) + + # fitted should be stored with per-equation crossfit data + expect_true(!is.null(fit$fitted)) + expect_true(!is.null(fit$fitted$y_X$cf_fitted_bylearner)) + expect_true(!is.null(fit$fitted$y_X$cf_resid_bylearner)) + + # Pass-through with average ensemble reproduces exactly + fit2 <- ddml_plm(y, D, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted, + splits = fit$splits) + expect_equal(coef(fit2), coef(fit), tolerance = 1e-6) + + # Pass-through with different ensemble gives valid result + fit_nnls <- ddml_plm(y, D, X, + learners = learners, + ensemble_type = "nnls1", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted, + splits = fit$splits) + expect_s3_class(fit_nnls, "ddml") + expect_true(is.numeric(coef(fit_nnls))) + + expect_error( + ddml_plm(y, D, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted), + "must be supplied when 'fitted' is supplied" + ) +}) + +test_that("ddml_plm pass-through with nnls/nnls1 reproduces exactly via cv_resid_byfold", { + set.seed(42) + nobs <- 200 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X %*% c(1, 0.5, 0) + rnorm(nobs) + y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + presplits <- get_sample_splits(seq_len(nobs), + sample_folds = 2, + cv_folds = 2) + shared <- list(subsamples = presplits$subsamples, + cv_subsamples = presplits$cv_subsamples) + splits <- list(y_X = shared, D1_X = shared) + + for (ens in c("nnls", "nnls1")) { + fit_fresh <- ddml_plm(y, D, X, + learners = learners, + ensemble_type = ens, + sample_folds = 2, + splits = splits, + silent = TRUE) + + # cv_resid_byfold must be stored for exact reproduction + expect_true( + !is.null(fit_fresh$fitted$y_X$cv_resid_byfold), + info = paste(ens, "y_X cv_resid_byfold")) + + # Pass-through with same ensemble reproduces exactly + fit_pt <- ddml_plm(y, D, X, + learners = learners, + ensemble_type = ens, + sample_folds = 2, + splits = splits, + silent = TRUE, + fitted = fit_fresh$fitted) + expect_equal(coef(fit_pt), coef(fit_fresh), + tolerance = 1e-10, + info = paste(ens, "exact reproduction")) + } +}) + +test_that("ddml_plm pass-through with save_crossval = FALSE uses approximate path", { + set.seed(42) + nobs <- 200 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X %*% c(1, 0.5, 0) + rnorm(nobs) + y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + presplits <- get_sample_splits(seq_len(nobs), + sample_folds = 2, + cv_folds = 2) + shared <- list(subsamples = presplits$subsamples, + cv_subsamples = presplits$cv_subsamples) + splits <- list(y_X = shared, D1_X = shared) + + # Fit with save_crossval = FALSE strips cv_resid_byfold + fit_no_cv <- ddml_plm(y, D, X, + learners = learners, + ensemble_type = "nnls1", + sample_folds = 2, + splits = splits, + save_crossval = FALSE, + silent = TRUE) + expect_null(fit_no_cv$fitted$y_X$cv_resid_byfold) + + # average ensemble: still exact without cv_resid_byfold + fit_avg <- ddml_plm(y, D, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + splits = splits, + silent = TRUE) + fit_avg_pt <- ddml_plm(y, D, X, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + splits = splits, + silent = TRUE, + fitted = fit_no_cv$fitted) + expect_equal(coef(fit_avg_pt), coef(fit_avg), + tolerance = 1e-10) + + # nnls1 ensemble: approximate (close but not identical) + fit_nnls_fresh <- ddml_plm(y, D, X, + learners = learners, + ensemble_type = "nnls1", + sample_folds = 2, + splits = splits, + silent = TRUE) + fit_nnls_pt <- ddml_plm(y, D, X, + learners = learners, + ensemble_type = "nnls1", + sample_folds = 2, + splits = splits, + silent = TRUE, + fitted = fit_no_cv$fitted) + expect_true(is.numeric(coef(fit_nnls_pt))) + expect_equal(coef(fit_nnls_pt), coef(fit_nnls_fresh), + tolerance = 0.5) +}) + +test_that("ddml_plm HC0/HC1/HC3 SEs close to sandwich::vcovHC on ols_fit", { + skip_if_not_installed("sandwich") + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D <- X %*% c(1, 0.5, 0, 0, 0) + rnorm(nobs) + y <- 2 * D + X %*% c(0, 1, 0.5, 0.3, 0) + rnorm(nobs) + + fit <- ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 5, + silent = TRUE) + + # Reconstruct the final partialing-out regression since ols_fit is removed: + y_r <- as.vector(y - fit$fitted$y_X$cf_fitted_bylearner[, 1]) + D_r <- as.matrix(D - fit$fitted$D1_X$cf_fitted_bylearner[, 1]) + colnames(D_r) <- colnames(D) + ols_fit <- stats::lm(y_r ~ D_r) + + for (type in c("HC0", "HC1")) { + V_ddml <- vcov(fit, type = type) + V_sw <- sandwich::vcovHC(ols_fit, type = type) + # Reorder sandwich: intercept first -> last + idx <- c(seq_len(nrow(V_sw))[-1], 1) + V_sw_reord <- V_sw[idx, idx, drop = FALSE] + expect_equal(as.numeric(V_ddml), + as.numeric(V_sw_reord), + tolerance = 1e-8, + info = paste("PLM", type)) + } + # HC3: regressor-based leverage matches sandwich exactly + V_ddml <- vcov(fit, type = "HC3") + V_sw <- sandwich::vcovHC(ols_fit, type = "HC3") + idx <- c(seq_len(nrow(V_sw))[-1], 1) + V_sw_reord <- V_sw[idx, idx, drop = FALSE] + expect_equal(as.numeric(V_ddml), + as.numeric(V_sw_reord), + tolerance = 1e-8, + info = "PLM HC3") +})#TEST_THAT + diff --git a/tests/testthat/test-ddml_rep.R b/tests/testthat/test-ddml_rep.R new file mode 100644 index 0000000..e135427 --- /dev/null +++ b/tests/testthat/test-ddml_rep.R @@ -0,0 +1,496 @@ +test_that("ddml_rep validates inputs correctly", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X[, 1] + rnorm(nobs) + y <- 2 * D + X[, 2] + rnorm(nobs) + + fits <- lapply(1:3, function(r) { + ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) + }) + + # Valid construction works + reps <- ddml_rep(fits) + expect_s3_class(reps, "ddml_rep") + expect_false(inherits(reps, "ddml")) + expect_equal(reps$nresamples, 3) + expect_equal(reps$model_type, "ddml_plm") + expect_equal(reps$nobs, nobs) + + # List of length 1 fails + expect_error(ddml_rep(fits[1])) + + # Non-ddml object fails + expect_error(ddml_rep(list(fits[[1]], "not_ddml"))) + + # Mismatched nobs fails + fits_bad <- fits + fits_bad[[2]]$nobs <- 999 + expect_error(ddml_rep(fits_bad)) + + # Mismatched coef_names fails + fits_bad2 <- fits + fits_bad2[[2]]$coef_names <- "wrong_name" + expect_error(ddml_rep(fits_bad2)) +}) + +test_that("ddml_replicate produces valid ddml_rep object", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X[, 1] + rnorm(nobs) + y <- 2 * D + X[, 2] + rnorm(nobs) + + reps <- ddml_replicate(ddml_plm, + y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, + silent = TRUE) + + expect_s3_class(reps, "ddml_rep") + expect_equal(reps$nresamples, 3) + expect_equal(reps$nobs, nobs) + + # Individual fits are accessible + expect_s3_class(reps[[1]], "ddml") + expect_s3_class(reps[[2]], "ddml_plm") + expect_equal(length(reps), 3) + + # Different resamples produce different coefficients + expect_false(identical(coef(reps[[1]]), coef(reps[[2]]))) +}) + +test_that("ddml_replicate is reproducible with set.seed", { + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X[, 1] + rnorm(nobs) + y <- 2 * D + X[, 2] + rnorm(nobs) + + set.seed(123) + reps1 <- ddml_replicate(ddml_plm, + y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, + silent = TRUE) + + set.seed(123) + reps2 <- ddml_replicate(ddml_plm, + y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, + silent = TRUE) + + expect_equal(coef(reps1), coef(reps2)) + expect_equal(coef(reps1[[1]]), coef(reps2[[1]])) +}) + +test_that("coef, vcov, confint work on ddml_rep", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X[, 1] + rnorm(nobs) + y <- 2 * D + X[, 2] + rnorm(nobs) + + reps <- ddml_replicate(ddml_plm, + y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, + silent = TRUE) + + # coef (D + intercept = 2 elements) + cf <- coef(reps) + expect_true(is.numeric(cf)) + expect_length(cf, 2) + + # coef with mean aggregation differs from median + cf_mean <- coef(reps, aggregation = "mean") + expect_true(is.numeric(cf_mean)) + + # Aggregated D coef is within range of per-resample D coefs + per_rep_coefs <- sapply(seq_len(3), + function(i) coef(reps[[i]])[1]) + expect_true(cf[1] >= min(per_rep_coefs) - 0.01) + expect_true(cf[1] <= max(per_rep_coefs) + 0.01) + + # vcov + V <- vcov(reps) + expect_true(is.matrix(V)) + expect_equal(dim(V), c(2, 2)) + expect_true(V[1, 1] > 0) + + # vcov names + expect_equal(rownames(V), reps$coef_names) + expect_equal(colnames(V), reps$coef_names) + + # confint + ci <- confint(reps) + expect_true(is.matrix(ci)) + expect_equal(dim(ci), c(2, 2)) + expect_identical(colnames(ci), c(" 2.5 %", "97.5 %")) + expect_true(ci[1, 1] < ci[1, 2]) + + # confint at different level + ci90 <- confint(reps, level = 0.90) + expect_true((ci90[1, 2] - ci90[1, 1]) < + (ci[1, 2] - ci[1, 1])) +}) + +test_that("summary and print work on ddml_rep", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + + reps <- ddml_replicate(ddml_ate, + y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, + silent = TRUE) + + # summary + s <- summary(reps) + expect_s3_class(s, "summary.ddml_rep") + expect_false(inherits(s, "summary.ddml")) + expect_equal(s$nobs, nobs) + expect_equal(s$nresamples, 3) + expect_equal(s$aggregation, "median") + expect_true(is.array(s$coefficients)) + expect_equal(dim(s$coefficients)[2], 4) + + # summary with mean aggregation + s_mean <- summary(reps, aggregation = "mean") + expect_equal(s_mean$aggregation, "mean") + + # summary with HC3 + s_hc3 <- summary(reps, type = "HC3") + expect_equal(s_hc3$type, "HC3") + + # print.summary + out <- capture_output(print(s)) + expect_true(grepl("DDML estimation", out)) + expect_true(grepl("Average Treatment Effect", out)) + expect_true(grepl("Resamples: 3", out)) + expect_true(grepl("median", out, ignore.case = TRUE)) + + # print.ddml_rep + out2 <- capture_output(print(reps)) + expect_true(grepl("replicated fits", out2, + ignore.case = TRUE)) + expect_true(grepl("Resamples: 3", out2)) +}) + +test_that("tidy and glance work on ddml_rep", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + reps <- ddml_replicate(ddml_ate, + y = y, D = D, X = X, + learners = learners, + ensemble_type = c("ols", "nnls"), + cv_folds = 2, + sample_folds = 2, + resamples = 3, + silent = TRUE) + + # tidy single ensemble + td <- tidy(reps, ensemble_idx = 1) + expect_s3_class(td, "data.frame") + expect_true(all(c("term", "estimate", "std.error", + "statistic", "p.value", "ensemble_type", + "aggregation") %in% colnames(td))) + expect_equal(nrow(td), 1) + expect_equal(td$aggregation, "median") + + # tidy all ensembles + td_all <- tidy(reps, ensemble_idx = NULL) + expect_equal(nrow(td_all), 2) + + # tidy with confidence intervals + td_ci <- tidy(reps, conf.int = TRUE) + expect_true(all(c("conf.low", "conf.high") + %in% colnames(td_ci))) + expect_true(td_ci$conf.low < td_ci$conf.high) + + # tidy with mean aggregation + td_mean <- tidy(reps, aggregation = "mean") + expect_s3_class(td_mean, "data.frame") + expect_equal(td_mean$aggregation, "mean") + + # glance + gl <- glance(reps) + expect_s3_class(gl, "data.frame") + expect_equal(nrow(gl), 1) + expect_true("nresamples" %in% colnames(gl)) + expect_equal(gl$nresamples, 3) + expect_equal(gl$model_type, "ddml_ate") +}) + +test_that("median aggregation formula is correct", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X[, 1] + rnorm(nobs) + y <- 2 * D + X[, 2] + rnorm(nobs) + + R <- 5 + reps <- ddml_replicate(ddml_plm, + y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = R, + silent = TRUE) + + coefs <- sapply(seq_len(R), + function(i) coef(reps[[i]])) + vcovs <- lapply(seq_len(R), + function(i) vcov(reps[[i]])) + p <- nrow(coefs) + + # theta_tilde = coordinate-wise median + expected_coef <- apply(coefs, 1, median) + + # V_r = Sigma_r + (theta_r - theta_tilde)(...)^T + V_list <- lapply(seq_len(R), function(r) { + bdiff <- coefs[, r] - expected_coef + vcovs[[r]] + tcrossprod(bdiff) + }) + + # tilde_Sigma_ij = median_r(V_r_ij) + V_arr <- array(unlist(V_list), dim = c(p, p, R)) + expected_vcov <- apply(V_arr, c(1, 2), median) + expected_se <- sqrt(diag(expected_vcov)) + + actual_coef <- coef(reps, aggregation = "median") + actual_vcov <- vcov(reps, aggregation = "median") + s <- summary(reps, aggregation = "median") + actual_se <- s$coefficients[, 2, 1] + + expect_equal(unname(actual_coef), + unname(expected_coef), + tolerance = 1e-10) + expect_equal(unname(actual_vcov), + unname(expected_vcov), + tolerance = 1e-10) + expect_equal(unname(actual_se), + unname(expected_se), + tolerance = 1e-10) +}) + +test_that("mean aggregation formula is correct", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X[, 1] + rnorm(nobs) + y <- 2 * D + X[, 2] + rnorm(nobs) + + R <- 5 + reps <- ddml_replicate(ddml_plm, + y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = R, + silent = TRUE) + + coefs <- sapply(seq_len(R), + function(i) coef(reps[[i]])) + vcovs <- lapply(seq_len(R), + function(i) vcov(reps[[i]])) + p <- nrow(coefs) + + # theta_tilde = arithmetic mean + expected_coef <- rowMeans(coefs) + + # V_r = Sigma_r + (theta_r - theta_tilde)(...)^T + V_list <- lapply(seq_len(R), function(r) { + bdiff <- coefs[, r] - expected_coef + vcovs[[r]] + tcrossprod(bdiff) + }) + + # tilde_Sigma = (1/R) sum_r V_r + expected_vcov <- Reduce(`+`, V_list) / R + expected_se <- sqrt(diag(expected_vcov)) + + actual_coef <- coef(reps, aggregation = "mean") + actual_vcov <- vcov(reps, aggregation = "mean") + s <- summary(reps, aggregation = "mean") + actual_se <- s$coefficients[, 2, 1] + + expect_equal(unname(actual_coef), + unname(expected_coef), + tolerance = 1e-10) + expect_equal(unname(actual_vcov), + unname(expected_vcov), + tolerance = 1e-10) + expect_equal(unname(actual_se), + unname(expected_se), + tolerance = 1e-10) +}) + +test_that("spectral aggregation works and equals median for p=1", { + skip_if_not_installed("CVXR") + skip_on_ci() + + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + + reps <- ddml_replicate(ddml_ate, + y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, + silent = TRUE) + + # For p = 1, spectral reduces to scalar median + cf_spec <- coef(reps, aggregation = "spectral") + cf_med <- coef(reps, aggregation = "median") + expect_equal(cf_spec, cf_med, tolerance = 1e-10) + + V_spec <- vcov(reps, aggregation = "spectral") + V_med <- vcov(reps, aggregation = "median") + expect_equal(V_spec, V_med, tolerance = 1e-10) + + s <- summary(reps, aggregation = "spectral") + expect_equal(s$aggregation, "spectral") +}) + +test_that("spectral aggregation gives PSD matrix for p>1", { + skip_if_not_installed("CVXR") + skip_on_ci() + + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X[, 1] + rnorm(nobs) + y <- 2 * D + X[, 2] + rnorm(nobs) + + reps <- ddml_replicate(ddml_plm, + y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 5, + silent = TRUE) + + V <- vcov(reps, aggregation = "spectral") + expect_true(is.matrix(V)) + expect_equal(dim(V), c(2, 2)) + + # PSD: all eigenvalues >= 0 + eigs <- eigen(V, symmetric = TRUE, only.values = TRUE) + expect_true(all(eigs$values >= -1e-10)) + + # Symmetric + expect_equal(V, t(V), tolerance = 1e-10) + + # Positive diagonal + expect_true(all(diag(V) > 0)) +}) + +test_that("ddml_rep works with ddml_ate", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + + reps <- ddml_replicate(ddml_ate, + y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, + silent = TRUE) + + expect_s3_class(reps, "ddml_rep") + expect_equal(reps$model_type, "ddml_ate") + + cf <- coef(reps) + expect_length(cf, 1) + + s <- summary(reps) + expect_s3_class(s, "summary.ddml_rep") +}) + +test_that("type argument threads through ddml_rep methods", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X[, 1] + rnorm(nobs) + y <- 2 * D + X[, 2] + rnorm(nobs) + + reps <- ddml_replicate(ddml_plm, + y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, + silent = TRUE) + + V_hc0 <- vcov(reps, type = "HC0") + V_hc1 <- vcov(reps, type = "HC1") + V_hc3 <- vcov(reps, type = "HC3") + + # All positive + expect_true(V_hc0[1, 1] > 0) + expect_true(V_hc1[1, 1] > 0) + expect_true(V_hc3[1, 1] > 0) + + # Coefficients identical across HC types + expect_equal(coef(reps), coef(reps)) + + # Summary stores type + s3 <- summary(reps, type = "HC3") + expect_equal(s3$type, "HC3") + + # HC3 shows in print + out <- capture_output(print(s3)) + expect_true(grepl("HC3", out)) +}) + +# as.list.ddml_rep ============================================================= + +test_that("as.list.ddml_rep splits by ensemble", { + set.seed(42) + y <- AE98[1:500, "worked"] + D <- AE98[1:500, "morekids"] + X <- AE98[1:500, c("age", "agefst", "black")] + + reps <- ddml_replicate(ddml_plm, y = y, D = D, X = X, + learners = list( + list(what = ols), + list(what = ols, + args = list(const = FALSE))), + ensemble_type = c("nnls", "singlebest"), + sample_folds = 2, + resamples = 3, silent = TRUE) + + L <- as.list(reps) + expect_length(L, 2) + expect_equal(names(L), c("nnls", "singlebest")) + for (j in 1:2) { + expect_s3_class(L[[j]], "ddml_rep") + expect_equal(L[[j]]$nfit, 1L) + # summary, tidy, glance work + expect_true(is.data.frame(tidy(L[[j]]))) + expect_true(is.data.frame(glance(L[[j]]))) + s <- summary(L[[j]]) + expect_true(inherits(s, "summary.ddml_rep")) + } +})#TEST_THAT diff --git a/tests/testthat/test-diagnostics.R b/tests/testthat/test-diagnostics.R new file mode 100644 index 0000000..128bb44 --- /dev/null +++ b/tests/testthat/test-diagnostics.R @@ -0,0 +1,187 @@ +test_that("diagnostics works with PLM single learner", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X %*% c(1, 0.5, 0) + rnorm(nobs) + y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) + + fit <- ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) + + diag <- diagnostics(fit) + + expect_s3_class(diag, "ddml_diagnostics") + expect_true("y_X" %in% names(diag$tables)) + # Should have at least one equation table + expect_true(length(diag$tables) >= 1) + + # print should run without error + out <- capture_output(print(diag)) + expect_true(grepl("Stacking diagnostics", out)) +}) + +test_that("diagnostics works with PLM multiple learners", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X %*% c(1, 0.5, 0) + rnorm(nobs) + y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_plm(y, D, X, + learners = learners, + ensemble_type = c("nnls1"), + sample_folds = 2, + silent = TRUE) + + diag <- diagnostics(fit) + + # Should have 2 learners + ensemble per equation + for (eq in names(diag$tables)) { + expect_true(nrow(diag$tables[[eq]]) >= 3) + } + + # Weights should sum to ~1 + for (eq in names(diag$tables)) { + expect_equal(sum(diag$tables[[eq]]$weight, na.rm = TRUE), 1, + tolerance = 1e-4) + } +}) + +test_that("tidy.ddml_diagnostics returns flat data.frame", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X %*% c(1, 0.5, 0) + rnorm(nobs) + y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) + + fit <- ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) + + td <- tidy(diagnostics(fit)) + + expect_s3_class(td, "data.frame") + expect_true(all(c("equation", "learner", "mspe", "r2", + "weight") %in% colnames(td))) + expect_true(nrow(td) >= 1) +}) + +test_that("diagnostics with CVC", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X %*% c(1, 0.5, 0) + rnorm(nobs) + y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_plm(y, D, X, + learners = learners, + ensemble_type = c("nnls1"), + sample_folds = 2, + silent = TRUE) + + diag <- diagnostics(fit, cvc = TRUE, bootnum = 100) + + # CVC column should be present + for (eq in names(diag$tables)) { + expect_true("cvc_pval" %in% colnames(diag$tables[[eq]])) + } + + # in_conf_set should NOT be present + for (eq in names(diag$tables)) { + expect_false("in_conf_set" %in% + colnames(diag$tables[[eq]])) + } + + # tidy should include CVC column + td <- tidy(diag) + expect_true("cvc_pval" %in% colnames(td)) + expect_false("in_conf_set" %in% colnames(td)) +}) + +test_that("diagnostics works with ATE", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) + + fit <- ddml_ate(y, D, X, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) + + diag <- diagnostics(fit) + + expect_s3_class(diag, "ddml_diagnostics") + expect_true(length(diag$tables) >= 2) + out <- capture_output(print(diag)) + expect_true(grepl("Average Treatment Effect", out)) +}) + +test_that("diagnostics r2 matches manual calculation", { + set.seed(42) + nobs <- 300 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X %*% c(1, 0.5, 0) + rnorm(nobs) + y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_plm(y, D, X, + learners = learners, + ensemble_type = "nnls1", + sample_folds = 2, + silent = TRUE) + + # R2 per learner per fold from crossval: 1 - mspe / var(y) + # Check that r2 is stored and non-NULL + expect_false(is.null(fit$r2$y_X)) + expect_true(all(fit$r2$y_X <= 1)) +}) + +test_that("diagnostics rejects non-ddml objects", { + expect_error(diagnostics(lm(1:10 ~ rnorm(10))), + "class") +}) + +test_that("cvc_one_vs_many detects a dominant learner", { + set.seed(42) + n <- 500 + resid_best <- rnorm(n, sd = 0.5) + resid_others <- cbind(rnorm(n, sd = 1.5), rnorm(n, sd = 2.0)) + fid <- rep(seq_len(5), each = n / 5) + + # Best learner: should NOT be rejected (large p-value) + pval <- cvc_one_vs_many(resid_best, resid_others, fid, + bootnum = 500) + expect_true(pval > 0.5) +}) + +test_that("cvc_one_vs_many rejects a weak learner", { + set.seed(42) + n <- 500 + resid_weak <- rnorm(n, sd = 2.0) + resid_others <- cbind(rnorm(n, sd = 0.5), rnorm(n, sd = 0.5)) + fid <- rep(seq_len(5), each = n / 5) + + # Weak learner: should be rejected (small p-value) + pval <- cvc_one_vs_many(resid_weak, resid_others, fid, + bootnum = 500) + expect_true(pval < 0.1) +}) + +test_that("cvc_pvalues returns NA for single learner", { + # Mock a fitted object with single learner residuals + fitted <- list(y_X = list( + cf_resid_bylearner = matrix(rnorm(100), ncol = 1))) + splits <- list(subsamples = list(1:50, 51:100)) + pvals <- cvc_pvalues(fitted, splits, "y_X", bootnum = 50) + expect_length(pvals, 1) + expect_true(is.na(pvals)) +}) + diff --git a/tests/testthat/test-ensemble.R b/tests/testthat/test-ensemble.R index c934de0..c58b509 100644 --- a/tests/testthat/test-ensemble.R +++ b/tests/testthat/test-ensemble.R @@ -1,84 +1,63 @@ test_that("ensemble_weights returns a weight matrix", { # Simulate small dataset X <- cbind(1, matrix(rnorm(100*39), 100, 39)) - Z <- matrix(rnorm(100*10), 100, 10) - D <- X %*% runif(40) + Z %*% c(1, runif(9)) + rnorm(100) + y <- X %*% runif(40) + rnorm(100) # Define arguments - learners <- list(list(fun = mdl_glmnet), - list(fun = ols)) + learners <- list(list(what = mdl_glmnet), + list(what = ols)) # Compute ensemble weights with and without passthrough ensemble_types = c("average", "singlebest", "ols", "nnls", "nnls1") - ens_w_res <- ensemble_weights(D, X, Z, + ens_w_res <- ensemble_weights(y, X, type = ensemble_types, learners, cv_folds = 3, - silent = T) - ens_w_res_pt <- ensemble_weights(D, X, Z, + silent = TRUE) + ens_w_res_pt <- ensemble_weights(y, X, type = ensemble_types, learners, cv_folds = 3, cv_results = ens_w_res$cv_results, - silent = T) + silent = TRUE) # Check output with expectations expect_equal(dim(ens_w_res$weights), c(length(learners), 5)) expect_equal(dim(ens_w_res_pt$weights), c(length(learners), 5)) })#TEST_THAT -test_that("ensemble returns a list of fitted learners", { - # Simulate small dataset - X <- cbind(1, matrix(rnorm(100*39), 100, 39)) - Z <- matrix(rnorm(100*10), 100, 10) - D <- X %*% runif(40) + Z %*% c(1, runif(9)) + rnorm(100) - # Define arguments - learners <- list(list(fun = mdl_glmnet), - list(fun = ols)) - # Compute ensemble - ens_fit <- ensemble(D, X, Z, - type = c("average", "ols", "singlebest"), - learners, - cv_folds = 3, - silent = T) - # Check output with expectations - expect_equal(length(ens_fit$mdl_fits), length(learners)) -})#TEST_THAT - test_that("prediction with ensemble learners returns fitted values", { # Simulate small dataset X <- cbind(1, matrix(rnorm(100*39), 100, 39)) - Z <- matrix(rnorm(100*10), 100, 10) - D <- X %*% runif(40) + Z %*% c(1, runif(9)) + rnorm(100) + y <- X %*% runif(40) + rnorm(100) # Define arguments - learners <- list(list(fun = mdl_glmnet), - list(fun = ols)) + learners <- list(list(what = mdl_glmnet), + list(what = ols)) # Compute ensemble - ens_fit <- ensemble(D, X, Z, + ens_fit <- ensemble(y, X, type = c("average", "ols", "singlebest"), learners, cv_folds = 3, - silent = T) - ens_fitted <- predict(ens_fit, newdata = X, newZ = Z) + silent = TRUE) + ens_fitted <- predict(ens_fit, newdata = X) # Check output with expectations - expect_equal(dim(ens_fitted), c(length(D), 3)) + expect_equal(dim(ens_fitted), c(length(y), 3)) })#TEST_THAT test_that("ensemble_weights returns a weight matrix w/ custom weights", { # Simulate small dataset X <- cbind(1, matrix(rnorm(100*39), 100, 39)) - Z <- matrix(rnorm(100*10), 100, 10) - D <- X %*% runif(40) + Z %*% c(1, runif(9)) + rnorm(100) + y <- X %*% runif(40) + rnorm(100) # Define arguments - learners <- list(list(fun = mdl_glmnet), - list(fun = ols)) + learners <- list(list(what = mdl_glmnet), + list(what = ols)) # Define custom weights weights_DX <- diag(length(learners)) # Compute ensemble weights ensemble_types = c("average", "singlebest", "ols", "nnls", "nnls1") - ens_w_res <- ensemble_weights(D, X, Z, + ens_w_res <- ensemble_weights(y, X, type = ensemble_types, learners, cv_folds = 3, custom_weights = weights_DX, - silent = T) + silent = TRUE) # Check output with expectations expect_equal(dim(ens_w_res$weights), c(length(learners), 7)) })#TEST_THAT @@ -86,50 +65,55 @@ test_that("ensemble_weights returns a weight matrix w/ custom weights", { test_that("prediction w/ ensembles returns fitted values w/ custom weights", { # Simulate small dataset X <- cbind(1, matrix(rnorm(100*39), 100, 39)) - Z <- matrix(rnorm(100*10), 100, 10) - D <- X %*% runif(40) + Z %*% c(1, runif(9)) + rnorm(100) + y <- X %*% runif(40) + rnorm(100) # Define arguments - learners <- list(list(fun = mdl_glmnet), - list(fun = ols)) + learners <- list(list(what = mdl_glmnet), + list(what = ols)) # Define custom weights weights_DX <- diag(length(learners)) # Compute ensemble - ens_fit <- ensemble(D, X, Z, + ens_fit <- ensemble(y, X, type = c("average", "ols", "singlebest"), learners, cv_folds = 3, custom_weights = weights_DX, - silent = T) - ens_fitted <- predict(ens_fit, newdata = X, newZ = Z) + silent = TRUE) + ens_fitted <- predict(ens_fit, newdata = X) # Check output with expectations - expect_equal(dim(ens_fitted), c(length(D), 5)) + expect_equal(dim(ens_fitted), c(length(y), 5)) })#TEST_THAT test_that("ensemble returns mean_y for constant outcomes", { # Simulate dataset with constant y X <- cbind(1, matrix(rnorm(100*39), 100, 39)) - Z <- matrix(rnorm(100*10), 100, 10) y <- rep(42, 100) # Constant outcome # Define arguments - learners <- list(list(fun = mdl_glmnet), - list(fun = ols)) + learners <- list(list(what = mdl_glmnet), + list(what = ols)) # Compute ensemble and expect warning expect_warning({ - ens_fit <- ensemble(y, X, Z, + ens_fit <- ensemble(y, X, type = c("average", "ols", "singlebest"), learners = learners, cv_folds = 3, - silent = T) + silent = TRUE) }, "Outcome variable y is constant") # Check predictions - ens_fitted <- predict.ensemble(ens_fit, newdata = X, newZ = Z) + ens_fitted <- predict.ensemble(ens_fit, newdata = X) - # Check output matches expectations - expect_equal(dim(ens_fitted), c(nrow(X), length(learners))) + # Check output matches expectations (nensb = 3 ensemble types) + expect_equal(dim(ens_fitted), c(nrow(X), 3)) expect_true(all(ens_fitted == 42)) expect_true(ens_fit$constant_y) expect_null(ens_fit$mdl_fits) + expect_equal(dim(ens_fit$weights), c(length(learners), 3)) + + # bylearner prediction returns nlearners columns + ens_bylearner <- predict.ensemble(ens_fit, newdata = X, + type = "bylearner") + expect_equal(dim(ens_bylearner), c(nrow(X), length(learners))) + expect_true(all(ens_bylearner == 42)) }) diff --git a/tests/testthat/test-get_CEF.R b/tests/testthat/test-get_CEF.R new file mode 100644 index 0000000..78d13e8 --- /dev/null +++ b/tests/testthat/test-get_CEF.R @@ -0,0 +1,254 @@ +test_that("get_CEF dispatches to crosspred for standard stacking", { + set.seed(42) + nobs <- 200 + X <- matrix(rnorm(nobs * 3), nobs, 3) + y <- X %*% c(1, 0.5, 0) + rnorm(nobs) + learners <- list(list(what = ols), list(what = ols)) + splits <- get_sample_splits(seq_len(nobs), + sample_folds = 2, + cv_folds = 2) + res <- get_CEF(y, X, + learners = learners, + ensemble_type = "ols", + shortstack = FALSE, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE) + # Check standard output components + expect_true(is.matrix(res$cf_fitted)) + expect_equal(nrow(res$cf_fitted), nobs) + expect_true(!is.null(res$weights)) + expect_true(!is.null(res$mspe)) +})#TEST_THAT + +test_that("get_CEF dispatches to shortstacking", { + set.seed(42) + nobs <- 200 + X <- matrix(rnorm(nobs * 3), nobs, 3) + y <- X %*% c(1, 0.5, 0) + rnorm(nobs) + learners <- list(list(what = ols), list(what = ols)) + splits <- get_sample_splits(seq_len(nobs), sample_folds = 2) + res <- get_CEF(y, X, + learners = learners, + ensemble_type = "ols", + shortstack = TRUE, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE) + expect_true(is.matrix(res$cf_fitted)) + expect_equal(nrow(res$cf_fitted), nobs) + expect_true(!is.null(res$cf_resid_bylearner)) +})#TEST_THAT + +test_that("get_CEF handles constant y gracefully", { + nobs <- 100 + X <- matrix(rnorm(nobs * 3), nobs, 3) + y <- rep(5, nobs) + learners <- list(list(what = ols), list(what = ols)) + splits <- get_sample_splits(seq_len(nobs), + sample_folds = 2, + cv_folds = 2) + res <- get_CEF(y, X, + learners = learners, + ensemble_type = "ols", + shortstack = FALSE, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE) + # All predictions should be the constant value + expect_true(all(res$cf_fitted == 5)) + expect_true(all(res$cf_resid_bylearner == 0)) +})#TEST_THAT + +test_that("get_CEF pass-through with pre-computed fitted works", { + set.seed(42) + nobs <- 200 + X <- matrix(rnorm(nobs * 3), nobs, 3) + y <- X %*% c(1, 0.5, 0) + rnorm(nobs) + learners <- list(list(what = ols), list(what = ols)) + splits <- get_sample_splits(seq_len(nobs), + sample_folds = 2, + cv_folds = 2) + # First call: compute from scratch + res1 <- get_CEF(y, X, + learners = learners, + ensemble_type = "ols", + shortstack = FALSE, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE) + # Pass-through: Rule 1 path with pre-ensembled cf_fitted + fitted_preens <- list(cf_fitted = res1$cf_fitted) + res2 <- get_CEF(y, X, + learners = learners, + ensemble_type = "ols", + shortstack = FALSE, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE, + fitted = fitted_preens) + expect_equal(res2$cf_fitted, res1$cf_fitted) + expect_null(res2$weights) +})#TEST_THAT + +test_that("get_CEF pass-through with pre-ensembled fitted uses Rule 1", { + set.seed(42) + nobs <- 100 + X <- matrix(rnorm(nobs * 3), nobs, 3) + y <- X %*% c(1, 0.5, 0) + rnorm(nobs) + learners <- list(what = ols) + splits <- get_sample_splits(seq_len(nobs), + sample_folds = 2, + cv_folds = 2) + # Single-learner call: no cf_fitted_bylearner + res <- get_CEF(y, X, + learners = learners, + ensemble_type = "ols", + shortstack = FALSE, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE) + # Pass-through with pre-ensembled cf_fitted (Rule 1) + fitted_preensembled <- list(cf_fitted = res$cf_fitted) + res2 <- get_CEF(y, X, + learners = learners, + ensemble_type = "ols", + shortstack = FALSE, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE, + fitted = fitted_preensembled) + expect_equal(res2$cf_fitted, res$cf_fitted) + expect_null(res2$weights) +})#TEST_THAT + +test_that("get_CEF Rule 2 with cv_resid_byfold reproduces stacking exactly", { + set.seed(42) + nobs <- 200 + X <- matrix(rnorm(nobs * 3), nobs, 3) + y <- X %*% c(1, 0.5, 0) + rnorm(nobs) + learners <- list(list(what = ols), list(what = ols)) + splits <- get_sample_splits(seq_len(nobs), + sample_folds = 2, + cv_folds = 2) + + for (ens in c("nnls", "nnls1")) { + res_fresh <- get_CEF(y, X, + learners = learners, + ensemble_type = ens, + shortstack = FALSE, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE) + expect_true(!is.null(res_fresh$cv_resid_byfold), + info = paste(ens, "cv_resid_byfold stored")) + + fitted_r2 <- list( + cf_fitted_bylearner = res_fresh$cf_fitted_bylearner, + cv_resid_byfold = res_fresh$cv_resid_byfold) + res_pt <- get_CEF(y, X, + learners = learners, + ensemble_type = ens, + shortstack = FALSE, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE, + fitted = fitted_r2) + expect_equal(res_pt$cf_fitted, res_fresh$cf_fitted, + tolerance = 1e-10, + info = paste(ens, "exact reproduction")) + expect_true(!is.null(res_pt$weights), + info = paste(ens, "weights returned")) + } +})#TEST_THAT + +test_that("get_CEF Rule 2 without cv_resid_byfold uses approximate path", { + set.seed(42) + nobs <- 200 + X <- matrix(rnorm(nobs * 3), nobs, 3) + y <- X %*% c(1, 0.5, 0) + rnorm(nobs) + learners <- list(list(what = ols), list(what = ols)) + splits <- get_sample_splits(seq_len(nobs), + sample_folds = 2, + cv_folds = 2) + + # average: exact even without cv_resid_byfold + res_avg <- get_CEF(y, X, + learners = learners, + ensemble_type = "average", + shortstack = FALSE, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE) + fitted_no_cv <- list( + cf_fitted_bylearner = res_avg$cf_fitted_bylearner) + res_avg_pt <- get_CEF(y, X, + learners = learners, + ensemble_type = "average", + shortstack = FALSE, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE, + fitted = fitted_no_cv) + expect_equal(res_avg_pt$cf_fitted, res_avg$cf_fitted, + tolerance = 1e-10) + # Branch B produces 2D weights (not per-fold 3D) + expect_equal(length(dim(res_avg_pt$weights)), 2) + + # nnls1: valid output but approximate (no inner-CV residuals) + res_nnls <- get_CEF(y, X, + learners = learners, + ensemble_type = "nnls1", + shortstack = FALSE, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE) + fitted_nnls_no_cv <- list( + cf_fitted_bylearner = res_nnls$cf_fitted_bylearner) + res_nnls_pt <- get_CEF(y, X, + learners = learners, + ensemble_type = "nnls1", + shortstack = FALSE, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE, + fitted = fitted_nnls_no_cv) + expect_equal(nrow(res_nnls_pt$cf_fitted), nobs) + expect_true(is.numeric(res_nnls_pt$cf_fitted)) + expect_equal(length(dim(res_nnls_pt$weights)), 2) +})#TEST_THAT + +test_that("get_CEF Rule 2 reproduces shortstacking exactly", { + set.seed(42) + nobs <- 200 + X <- matrix(rnorm(nobs * 3), nobs, 3) + y <- X %*% c(1, 0.5, 0) + rnorm(nobs) + learners <- list(list(what = ols), list(what = ols)) + splits <- get_sample_splits(seq_len(nobs), sample_folds = 2) + + for (ens in c("average", "nnls1")) { + res_fresh <- get_CEF(y, X, + learners = learners, + ensemble_type = ens, + shortstack = TRUE, + subsamples = splits$subsamples, + cv_subsamples = NULL, + silent = TRUE) + expect_null(res_fresh$cv_resid_byfold, + info = paste(ens, "no cv_resid_byfold")) + + fitted_ss <- list( + cf_fitted_bylearner = res_fresh$cf_fitted_bylearner) + res_pt <- get_CEF(y, X, + learners = learners, + ensemble_type = ens, + shortstack = TRUE, + subsamples = splits$subsamples, + cv_subsamples = NULL, + silent = TRUE, + fitted = fitted_ss) + expect_equal(res_pt$cf_fitted, res_fresh$cf_fitted, + tolerance = 1e-10, + info = paste(ens, "exact reproduction")) + } +})#TEST_THAT diff --git a/tests/testthat/test-help_functions.R b/tests/testthat/test-help_functions.R index 0be765b..d9da1ff 100644 --- a/tests/testthat/test-help_functions.R +++ b/tests/testthat/test-help_functions.R @@ -7,3 +7,75 @@ test_that("csolve returns a (generalized) inverse", { expect_equal(csolve(X) %*% X, diag(1, 30)) expect_equal((csolve(X_sing) %*% X_sing) %*% X_sing, X_sing) })#TEST_THAT + +test_that("is_single_learner detects correctly", { + expect_true(is_single_learner(list(what = ols))) + expect_true(is_single_learner(list(what = ols, + args = list()))) + expect_false(is_single_learner( + list(list(what = ols), list(what = ols)))) + expect_false(is_single_learner( + list(list(fun = ols)))) +}) + +test_that("normalize_learners resolves what and fun", { + # what works + l <- normalize_learners(list(what = ols)) + expect_identical(l$what, ols) + + # fun triggers deprecation; reset the flag first + options(ddml.fun_deprecated_warned = NULL) + expect_message( + normalize_learners(list(list(fun = ols))), + "deprecated") + + # what takes precedence over fun + options(ddml.fun_deprecated_warned = NULL) + l <- suppressMessages( + normalize_learners(list(list(what = ols, fun = mdl_glmnet)))) + expect_identical(l[[1]]$what, ols) + + # neither → error + expect_error( + normalize_learners(list(list(args = list()))), + "'what' element") + + # reset flag + options(ddml.fun_deprecated_warned = NULL) +}) + +test_that("ddml_plm works with list(fun=) for backward compat", { + set.seed(42) + nobs <- 100 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- X %*% c(1, 0.5, 0) + rnorm(nobs) + y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) + + # Reset deprecation flag + options(ddml.fun_deprecated_warned = NULL) + suppressWarnings(suppressMessages({ + fit <- ddml_plm(y, D, X, + learners = list(list(fun = ols), + list(fun = ols)), + ensemble_type = "nnls1", + sample_folds = 2, + silent = TRUE) + })) + expect_s3_class(fit, "ddml") + expect_true(!is.null(coef(fit))) + options(ddml.fun_deprecated_warned = NULL) +}) + +test_that("validate_fitted_splits_pair checks null splits", { + expect_no_error( + validate_fitted_splits_pair(NULL, NULL)) + expect_error( + validate_fitted_splits_pair( + fitted = list(y_X = list(cf_fitted = 1)), + splits = NULL), + "splits") + expect_no_error( + validate_fitted_splits_pair( + fitted = list(y_X = list(cf_fitted = 1)), + splits = list(subsamples = list(1:50)))) +}) diff --git a/tests/testthat/test-lincom.R b/tests/testthat/test-lincom.R new file mode 100644 index 0000000..cef8fb1 --- /dev/null +++ b/tests/testthat/test-lincom.R @@ -0,0 +1,459 @@ +# Tests for lincom ============================================================= + +# Shared DGP: ddml_attgt fit with known structure +make_attgt_fit <- function(seed = 42, n = 800, T_ = 4) { + set.seed(seed) + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + for (i in seq_len(n)) { + if (is.finite(G[i])) { + for (tt in seq_len(T_)) { + if (tt >= G[i]) y[i, tt] <- y[i, tt] + 1 + } + } + } + ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, cv_folds = 3, + silent = TRUE) +}#MAKE_ATTGT_FIT + +# lincom ====================================================================== + +test_that("lincom identity R recovers original", { + fit <- make_attgt_fit() + p <- nrow(fit$coefficients) + R <- diag(p) + lc <- lincom(fit, R = R) + + # Class: lincom > ral + expect_s3_class(lc, "lincom") + expect_true(inherits(lc, "ral")) + + # Coefficients match + expect_equal(as.numeric(coef(lc)), + as.numeric(coef(fit)), + tolerance = 1e-10) + + # Vcov match (dimnames differ, use unname) + V_lc <- vcov(lc) + V_fit <- vcov(fit) + expect_equal(unname(V_lc), unname(V_fit), + tolerance = 1e-8) + + # nobs + expect_equal(lc$nobs, fit$nobs) + + # fixed_R = TRUE (no delta-method) + expect_true(lc$fixed_R) +})#TEST_THAT + +test_that("lincom scalar contrast works", { + fit <- make_attgt_fit() + p <- nrow(fit$coefficients) + + # Contrast: first cell minus second + R <- matrix(0, p, 1) + R[1, 1] <- 1 + R[2, 1] <- -1 + lc <- lincom(fit, R = R, labels = "ATT1-ATT2") + + expect_length(coef(lc), 1) + expect_equal(names(coef(lc)), "ATT1-ATT2") + + # Point estimate = difference of first two coefs + expected <- coef(fit)[1] - coef(fit)[2] + expect_equal(as.numeric(coef(lc)), + as.numeric(expected), + tolerance = 1e-10) + + # Vcov is 1x1, positive + V <- vcov(lc) + expect_equal(dim(V), c(1, 1)) + expect_true(V[1, 1] > 0) +})#TEST_THAT + +test_that("vcov of lincom is PSD with positive diagonal", { + fit <- make_attgt_fit() + p <- nrow(fit$coefficients) + R <- diag(p) + lc <- lincom(fit, R = R) + + V <- vcov(lc) + expect_true(all(diag(V) > 0)) + + # PSD: eigenvalues >= 0 + evals <- eigen(V, only.values = TRUE)$values + expect_true(all(evals >= -1e-10)) +})#TEST_THAT + +test_that("confint lower < upper", { + fit <- make_attgt_fit() + p <- nrow(fit$coefficients) + R <- diag(p) + lc <- lincom(fit, R = R) + + ci <- confint(lc) + expect_equal(ncol(ci), 2) + expect_equal(nrow(ci), p) + expect_true(all(ci[, 1] < ci[, 2])) + + # Pointwise has Gaussian quantile + expect_equal(attr(ci, "crit_val"), qnorm(0.975), tolerance = 1e-6) +})#TEST_THAT + +test_that("confint uniform wider than pointwise", { + fit <- make_attgt_fit() + p <- nrow(fit$coefficients) + R <- diag(p) + lc <- lincom(fit, R = R) + + ci_pw <- confint(lc) + + set.seed(1) + ci_uf <- confint(lc, uniform = TRUE, bootstraps = 499) + + # Uniform bands >= pointwise (p > 1) + width_pw <- ci_pw[, 2] - ci_pw[, 1] + width_uf <- ci_uf[, 2] - ci_uf[, 1] + expect_true(all(width_uf >= width_pw)) + + # Critical value attribute + expect_false(is.null(attr(ci_uf, "crit_val"))) + expect_true(attr(ci_uf, "crit_val") > + qnorm(0.975)) +})#TEST_THAT + +test_that("lincom dimension mismatch errors", { + fit <- make_attgt_fit() + p <- nrow(fit$coefficients) + + # Wrong number of rows + R_bad <- matrix(1, p + 1, 1) + expect_error(lincom(fit, R = R_bad)) + + # inf_func_R wrong dimensions + R <- diag(p) + inf_func_R_bad <- matrix(0, fit$nobs, p + 1) + expect_error(lincom(fit, R = R, + inf_func_R = inf_func_R_bad)) +})#TEST_THAT + +test_that("summary returns summary.ddml via inheritance", { + fit <- make_attgt_fit() + p <- nrow(fit$coefficients) + R <- diag(p) + lc <- lincom(fit, R = R) + + s <- summary(lc) + # Returns summary.ral via inheritance + expect_true(inherits(s, "summary.ral")) + expect_true(is.array(s$coefficients)) + expect_equal(s$nobs, fit$nobs) + + # Print does not error + capture_output({print(s)}, print = FALSE) +})#TEST_THAT + +test_that("hatvalues with dinf_dtheta works for lincom", { + fit <- make_attgt_fit() + p <- nrow(fit$coefficients) + R <- diag(p) + lc <- lincom(fit, R = R) + + # hatvalues should work (dinf_dtheta computed in lincom) + h <- hatvalues(lc) + expect_length(h, fit$nobs) +})#TEST_THAT + +test_that("tidy works via inheritance", { + fit <- make_attgt_fit() + p <- nrow(fit$coefficients) + R <- diag(p) + lc <- lincom(fit, R = R) + + td <- tidy(lc) + expect_true(is.data.frame(td)) + expect_equal(nrow(td), p) + expect_true("estimate" %in% names(td)) + expect_true("std.error" %in% names(td)) +})#TEST_THAT + +test_that("print.lincom works", { + fit <- make_attgt_fit() + p <- nrow(fit$coefficients) + R <- diag(p) + lc <- lincom(fit, R = R) + + out <- capture_output({print(lc)}, print = FALSE) + expect_true(grepl("Linear Combination", out)) + expect_true(grepl("Obs:", out)) +})#TEST_THAT + +# lincom_rep =================================================================== + +test_that("lincom_rep inherits from ral_rep", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + for (i in seq_len(n)) { + if (is.finite(G[i])) { + for (tt in seq_len(T_)) { + if (tt >= G[i]) y[i, tt] <- y[i, tt] + 1 + } + } + } + + reps <- ddml_replicate( + ddml_attgt, y = y, X = X, + t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, silent = TRUE) + + p <- nrow(reps$fits[[1]]$coefficients) + R <- diag(p) + lc <- lincom(reps, R = R) + + # Class hierarchy + expect_s3_class(lc, "lincom_rep") + expect_true(inherits(lc, "ral_rep")) + expect_equal(lc$nresamples, 3) + + expect_s3_class(lc$fits[[1]], "lincom") + expect_true(inherits(lc$fits[[1]], "ral")) + + # coef, vcov, confint via inheritance + expect_length(coef(lc), p) + V <- vcov(lc) + expect_equal(dim(V), c(p, p)) + expect_true(all(diag(V) > 0)) + + ci <- confint(lc) + expect_equal(nrow(ci), p) + expect_true(all(ci[, 1] < ci[, 2])) +})#TEST_THAT + +test_that("rep vcov matches inflate-then-median", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + + reps <- ddml_replicate( + ddml_attgt, y = y, X = X, + t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, silent = TRUE) + + p <- nrow(reps$fits[[1]]$coefficients) + R <- diag(p) + lc <- lincom(reps, R = R) + + # Manual inflate-then-median + agg_coef <- coef(lc) + V_arr <- array(NA, dim = c(p, p, 3)) + for (r in seq_len(3)) { + Sigma_r <- vcov(lc$fits[[r]]) + bdiff <- coef(lc$fits[[r]]) - agg_coef + V_arr[, , r] <- Sigma_r + tcrossprod(bdiff) + } + V_manual <- apply(V_arr, c(1, 2), median) + dimnames(V_manual) <- dimnames(vcov(lc)) + + expect_equal(vcov(lc), V_manual, tolerance = 1e-10) +})#TEST_THAT + +test_that("uniform CI for lincom_rep", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + + reps <- ddml_replicate( + ddml_attgt, y = y, X = X, + t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, silent = TRUE) + + p <- nrow(reps$fits[[1]]$coefficients) + R <- diag(p) + lc <- lincom(reps, R = R) + + ci_pw <- confint(lc) + + set.seed(1) + ci_uf <- confint(lc, uniform = TRUE, bootstraps = 499) + + width_pw <- ci_pw[, 2] - ci_pw[, 1] + width_uf <- ci_uf[, 2] - ci_uf[, 1] + expect_true(all(width_uf >= width_pw)) + + expect_false(is.null(attr(ci_uf, "crit_val"))) +})#TEST_THAT + +test_that("summary/print for rep via inheritance", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + + reps <- ddml_replicate( + ddml_attgt, y = y, X = X, + t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, silent = TRUE) + + p <- nrow(reps$fits[[1]]$coefficients) + R <- diag(p) + lc <- lincom(reps, R = R) + + s <- summary(lc) + expect_true(inherits(s, "summary.ral_rep")) + + out <- capture_output({print(lc)}, print = FALSE) + expect_true(grepl("Resamples:", out)) + + capture_output({print(s)}, print = FALSE) +})#TEST_THAT + +test_that("lincom.ddml_rep rejects non-rep fit", { + fit <- make_attgt_fit() + R <- diag(nrow(fit$coefficients)) + expect_error(lincom(fit, R = R), NA) # ddml works +})#TEST_THAT + +test_that("lincom_rep HC3 vcov works now", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + + reps <- ddml_replicate( + ddml_attgt, y = y, X = X, + t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, + resamples = 3, silent = TRUE) + + p <- nrow(reps$fits[[1]]$coefficients) + R <- diag(p) + lc <- lincom(reps, R = R) + + # HC3 should now work for lincom via ral + V_hc3 <- vcov(lc, type = "HC3") + expect_equal(dim(V_hc3), c(p, p)) + expect_true(all(diag(V_hc3) > 0)) +})#TEST_THAT + +# Multi-ensemble lincom ====================================================== + +test_that("lincom all ensembles with fit_idx = NULL", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + for (i in seq_len(n)) { + if (is.finite(G[i])) { + for (tt in seq_len(T_)) { + if (tt >= G[i]) y[i, tt] <- y[i, tt] + 1 + } + } + } + fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list( + list(what = ols), + list(what = ols, + args = list(const = FALSE))), + ensemble_type = c("nnls", "singlebest"), + sample_folds = 2, cv_folds = 3, + silent = TRUE) + + p <- nrow(fit$coefficients) + nensb <- ncol(fit$coefficients) + R <- diag(p) + + # Default fit_idx = NULL -> all ensembles + lc <- lincom(fit, R = R) + expect_equal(ncol(lc$coefficients), nensb) + expect_equal(dim(lc$inf_func)[3], nensb) + + # Each ensemble matches single-ensemble lincom + for (j in seq_len(nensb)) { + lc_j <- lincom(fit, R = R, fit_idx = j) + expect_equal(lc$coefficients[, j], + lc_j$coefficients[, 1], + tolerance = 1e-10) + } + + # summary works with multiple ensembles + s <- summary(lc) + expect_equal(dim(s$coefficients)[3], nensb) +})#TEST_THAT + +test_that("lincom_weights_did multi-ensemble dinf_dR", { + fit <- make_attgt_fit() + + # Single-ensemble fit: only 1 ensemble, dinf_dR is 3D + w <- lincom_weights_did(fit, type = "dynamic") + expect_equal(length(dim(w$dinf_dR)), 3L) + q <- ncol(w$R) + expect_equal(dim(w$dinf_dR), c(fit$nobs, q, q)) + + # Explicit fit_idx = 1: same shape + w1 <- lincom_weights_did(fit, type = "dynamic", fit_idx = 1) + expect_equal(dim(w1$dinf_dR), c(fit$nobs, q, q)) + expect_equal(w$dinf_dR, w1$dinf_dR, tolerance = 1e-12) +})#TEST_THAT + +test_that("as.list on lincom with multi-ensemble", { + set.seed(42) + n <- 800; T_ <- 4 + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + for (i in seq_len(n)) { + if (is.finite(G[i])) { + for (tt in seq_len(T_)) { + if (tt >= G[i]) y[i, tt] <- y[i, tt] + 1 + } + } + } + fit <- ddml_attgt(y, X, t = 1:T_, G = G, + learners = list( + list(what = ols), + list(what = ols, + args = list(const = FALSE))), + ensemble_type = c("nnls", "singlebest"), + sample_folds = 2, cv_folds = 3, + silent = TRUE) + + p <- nrow(fit$coefficients) + lc <- lincom(fit, R = diag(p)) + + L <- as.list(lc) + expect_length(L, 2) + for (j in 1:2) { + expect_s3_class(L[[j]], "lincom") + expect_equal(ncol(L[[j]]$coefficients), 1L) + } +})#TEST_THAT diff --git a/tests/testthat/test-lincom_weights.R b/tests/testthat/test-lincom_weights.R new file mode 100644 index 0000000..1228d13 --- /dev/null +++ b/tests/testthat/test-lincom_weights.R @@ -0,0 +1,246 @@ +# Tests for lincom_weights_did --------------------------------------------- + +# Shared DGP +make_attgt_fit <- function(seed = 42, n = 800, T_ = 4) { + set.seed(seed) + X <- matrix(rnorm(n * 2), n, 2) + G <- sample(c(3, 4, Inf), n, replace = TRUE, + prob = c(0.3, 0.3, 0.4)) + y <- matrix(rnorm(n * T_), n, T_) + for (i in seq_len(n)) { + if (is.finite(G[i])) { + for (tt in seq_len(T_)) { + if (tt >= G[i]) y[i, tt] <- y[i, tt] + 1 + } + } + } + ddml_attgt(y, X, t = 1:T_, G = G, + learners = list(what = ols), + sample_folds = 2, cv_folds = 3, + silent = TRUE) +}#MAKE_ATTGT_FIT + +test_that("did_weights dynamic structure", { + fit <- make_attgt_fit() + w <- lincom_weights_did(fit, type = "dynamic") + + C <- nrow(fit$coefficients) + n <- fit$nobs + + # R is C x q + expect_equal(nrow(w$R), C) + expect_true(ncol(w$R) > 0) + + # inf_func_R is n x C x q + q <- ncol(w$R) + expect_equal(dim(w$inf_func_R), c(n, C, q)) + + # Labels exist and match R columns + expect_equal(length(w$labels), ncol(w$R)) + expect_equal(colnames(w$R), w$labels) + + # Columns of R sum to 1 (or 0 for excluded) + col_sums <- colSums(w$R) + for (s in col_sums) { + expect_true(abs(s - 1) < 1e-10 || abs(s) < 1e-10) + } + + # Labels start with "e=" + expect_true(all(grepl("^e=", w$labels))) +})#TEST_THAT + +test_that("did_weights group structure", { + fit <- make_attgt_fit() + w <- lincom_weights_did(fit, type = "group") + + # Labels start with "g=" + expect_true(all(grepl("^g=", w$labels))) + + # Columns of R sum to 1 + col_sums <- colSums(w$R) + expect_true(all(abs(col_sums - 1) < 1e-10 | + abs(col_sums) < 1e-10)) +})#TEST_THAT + +test_that("did_weights calendar structure", { + fit <- make_attgt_fit() + w <- lincom_weights_did(fit, type = "calendar") + + # Labels start with "t=" + expect_true(all(grepl("^t=", w$labels))) +})#TEST_THAT + +test_that("did_weights simple structure", { + fit <- make_attgt_fit() + w <- lincom_weights_did(fit, type = "simple") + + # Single column + expect_equal(ncol(w$R), 1) + expect_equal(w$labels, "ATT") + + # Weights sum to 1 + expect_equal(sum(w$R), 1, tolerance = 1e-10) +})#TEST_THAT + +test_that("did_weights min_e/max_e filter", { + fit <- make_attgt_fit() + w_all <- lincom_weights_did(fit, type = "dynamic") + w_sub <- lincom_weights_did(fit, type = "dynamic", + min_e = 0, max_e = 1) + + # Filtered has fewer columns + expect_true(ncol(w_sub$R) <= ncol(w_all$R)) + + # All e= labels within range + evals <- as.numeric(sub("^e=", "", w_sub$labels)) + expect_true(all(evals >= 0)) + expect_true(all(evals <= 1)) +})#TEST_THAT + +test_that("did_weights rejects non-attgt fit", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- 1 * (rnorm(nobs) > 0) + y <- D + rnorm(nobs) + + fit <- ddml_ate(y, D, X, + learners = list(what = ols), + sample_folds = 2, silent = TRUE) + + expect_error(lincom_weights_did(fit), + "ddml_attgt") +})#TEST_THAT + +test_that("did_weights dynamic point estimates match manual", { + fit <- make_attgt_fit() + w <- lincom_weights_did(fit, type = "dynamic") + lc <- lincom(fit, R = w$R, + inf_func_R = w$inf_func_R, + labels = w$labels) + + # Manual: R'theta + manual <- as.numeric(crossprod(w$R, coef(fit))) + expect_equal(as.numeric(coef(lc)), manual, + tolerance = 1e-10) + + # delta-method was applied + expect_false(lc$fixed_R) +})#TEST_THAT + +test_that("delta method matters for SEs", { + fit <- make_attgt_fit() + w <- lincom_weights_did(fit, type = "dynamic") + + # With delta-method correction + lc_dm <- lincom(fit, R = w$R, + inf_func_R = w$inf_func_R, + labels = w$labels) + + # Without delta-method (fixed R) + lc_fixed <- lincom(fit, R = w$R, + labels = w$labels) + + # SEs should differ (delta-method adds weight IF) + se_dm <- sqrt(diag(vcov(lc_dm))) + se_fixed <- sqrt(diag(vcov(lc_fixed))) + expect_false(all(abs(se_dm - se_fixed) < 1e-10)) +})#TEST_THAT + +test_that("simple aggregation equals group-share weighted average", { + fit <- make_attgt_fit() + + # Native + w <- lincom_weights_did(fit, type = "simple") + lc <- lincom(fit, R = w$R, + inf_func_R = w$inf_func_R, + labels = w$labels) + + # Manual: group-share weighted average of GT-ATTs + ci <- fit$cell_info + post <- which(ci$time >= ci$group) + pg <- ci$n_treated[post] / sum(ci$n_treated[post]) + theta <- coef(fit)[post] + manual_att <- sum(pg * theta) + + expect_equal(as.numeric(coef(lc)), manual_att, tolerance = 1e-10) +})#TEST_THAT + +test_that("dinf_dR has correct dimensions", { + fit <- make_attgt_fit() + w <- lincom_weights_did(fit, type = "dynamic") + + n <- fit$nobs + q <- ncol(w$R) + expect_equal(dim(w$dinf_dR), c(n, q, q)) + + # Constant across observations + for (i in 2:min(5, n)) { + expect_equal(w$dinf_dR[i, , ], w$dinf_dR[1, , ], + tolerance = 1e-12) + } +})#TEST_THAT + +test_that("dinf_dR is zero for group aggregation", { + fit <- make_attgt_fit() + w <- lincom_weights_did(fit, type = "group") + + expect_equal(max(abs(w$dinf_dR)), 0, tolerance = 1e-12) +})#TEST_THAT + +test_that("dinf_dR matches manual V'V computation", { + fit <- make_attgt_fit() + w <- lincom_weights_did(fit, type = "dynamic") + + ci <- fit$cell_info + theta <- coef(fit) + gamma <- as.numeric(crossprod(w$R, theta)) + q <- ncol(w$R) + + glist <- sort(unique(ci$group)) + nG <- length(glist) + pg <- sapply(glist, function(g) mean(fit$G == g)) + + et <- ci$time - ci$group + all_et <- sort(unique(et)) + V_manual <- matrix(0, nG, q) + for (k in seq_along(all_et)) { + e <- all_et[k] + keepers <- which(et == e) + S_k <- sum(pg[match(ci$group[keepers], glist)]) + for (j in seq_len(nG)) { + g <- glist[j] + cells <- keepers[ci$group[keepers] == g] + if (length(cells) > 0) { + V_manual[j, k] <- sum(theta[cells] - gamma[k]) / S_k + } + } + } + VtV_manual <- crossprod(V_manual) + + expect_equal(w$dinf_dR[1, , ], VtV_manual, tolerance = 1e-10) +})#TEST_THAT + +test_that("HC3 with dinf_dR differs from HC3 without", { + fit <- make_attgt_fit() + w <- lincom_weights_did(fit, type = "dynamic") + + lc_with <- lincom(fit, R = w$R, + inf_func_R = w$inf_func_R, + dinf_dR = w$dinf_dR, + labels = w$labels) + lc_without <- lincom(fit, R = w$R, + inf_func_R = w$inf_func_R, + labels = w$labels) + + se_with <- sqrt(diag(vcov(lc_with, type = "HC3"))) + se_without <- sqrt(diag(vcov(lc_without, type = "HC3"))) + + # Should differ for dynamic (V'V != 0) + expect_false(all(abs(se_with - se_without) < 1e-10)) + + # With dinf_dR should give larger hat values (more leverage) + h_with <- hatvalues(lc_with) + h_without <- hatvalues(lc_without) + expect_true(all(h_with >= h_without - 1e-10)) +})#TEST_THAT diff --git a/tests/testthat/test-ols.R b/tests/testthat/test-ols.R index 3685c45..334cdcc 100644 --- a/tests/testthat/test-ols.R +++ b/tests/testthat/test-ols.R @@ -3,7 +3,7 @@ test_that("ols returns output of correct types", { # Simulate small dataset and fit ols X <- matrix(rnorm(100*3), 100, 3) y <- 1 + X %*% c(-1, 1, 0) + rnorm(100) - mdl_fit <- ols(y, X, const = T) + mdl_fit <- ols(y, X, const = TRUE) # Check output with expectations expect_equal(dim(mdl_fit$coef), c(1+ncol(X), 1)) # Return a vector })#TEST_THAT diff --git a/tests/testthat/test-parallel.R b/tests/testthat/test-parallel.R new file mode 100644 index 0000000..6c2cc9e --- /dev/null +++ b/tests/testthat/test-parallel.R @@ -0,0 +1,20 @@ +test_that("parse_parallel handles NULL inputs safely", { + res <- parse_parallel(NULL) + expect_equal(res$num_cores, 1) + expect_null(res$export) + expect_null(res$packages) +}) + +test_that("parse_parallel extracts list structures correctly", { + pl <- list(cores = 4, export = c("var1"), packages = c("utils")) + res <- parse_parallel(pl) + + expect_equal(res$num_cores, 4) + expect_equal(res$export, "var1") + expect_equal(res$packages, "utils") +}) + +test_that("parse_parallel catches malformed arguments", { + expect_error(parse_parallel(4), "'parallel' must be a list or NULL") + expect_error(parse_parallel(TRUE), "'parallel' must be a list or NULL") +}) diff --git a/tests/testthat/test-ral.R b/tests/testthat/test-ral.R new file mode 100644 index 0000000..25b7d75 --- /dev/null +++ b/tests/testthat/test-ral.R @@ -0,0 +1,474 @@ +# Tests for ral base class ===================================================== + +test_that("ral() constructs a valid object", { + n <- 50 + p <- 2 + + coefficients <- matrix(c(1.5, -0.3), p, 1, + dimnames = list(c("a", "b"), "fit1")) + inf_func <- array(rnorm(n * p), dim = c(n, p, 1)) + dinf_dtheta <- array(1, dim = c(n, p, p, 1)) + + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + dinf_dtheta = dinf_dtheta, + nobs = n, + coef_names = c("a", "b"), + estimator_name = "Test RAL") + + expect_s3_class(obj, "ral") + expect_equal(class(obj), "ral") + expect_equal(obj$nobs, n) + expect_equal(obj$nfit, 1) + expect_equal(obj$coef_names, c("a", "b")) + expect_equal(obj$fit_labels, "fit1") + expect_equal(obj$estimator_name, "Test RAL") +})#TEST_THAT + +test_that("ral() with subclass", { + n <- 30 + coefficients <- matrix(1.5, 1, 1, + dimnames = list("x", "e1")) + inf_func <- array(rnorm(n), dim = c(n, 1, 1)) + + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, + coef_names = "x", + subclass = "my_ral") + + expect_s3_class(obj, "my_ral") + expect_s3_class(obj, "ral") + expect_equal(class(obj), c("my_ral", "ral")) +})#TEST_THAT + +test_that("ral() stores extra ... args", { + n <- 30 + coefficients <- matrix(1, 1, 1, + dimnames = list("x", "e1")) + inf_func <- array(rnorm(n), dim = c(n, 1, 1)) + + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = "x", + custom_field = "hello", + fixed_R = TRUE) + + expect_equal(obj$custom_field, "hello") + expect_true(obj$fixed_R) +})#TEST_THAT + +test_that("ral() validates inf_func dimensions", { + n <- 30 + coefficients <- matrix(1, 2, 1) + inf_func_bad <- array(rnorm(n * 3), dim = c(n, 3, 1)) + + expect_error(ral(coefficients = coefficients, + inf_func = inf_func_bad, + nobs = n, coef_names = c("a", "b")), + "inf_func") +})#TEST_THAT + +test_that("ral() validates dinf_dtheta dimensions", { + n <- 30 + coefficients <- matrix(1, 1, 1) + inf_func <- array(rnorm(n), dim = c(n, 1, 1)) + dinf_bad <- array(1, dim = c(n, 2, 2, 1)) + + expect_error(ral(coefficients = coefficients, + inf_func = inf_func, + dinf_dtheta = dinf_bad, + nobs = n, coef_names = "x"), + "dinf_dtheta") +})#TEST_THAT + +# coef.ral ===================================================================== + +test_that("coef.ral returns named vector for single fit", { + n <- 50 + coefficients <- matrix(c(1.5, -0.3), 2, 1, + dimnames = list(c("a", "b"), "e1")) + inf_func <- array(rnorm(n * 2), dim = c(n, 2, 1)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = c("a", "b")) + + cf <- coef(obj) + expect_true(is.numeric(cf)) + expect_length(cf, 2) + expect_equal(names(cf), c("a", "b")) + expect_equal(cf[[1]], 1.5, tolerance = 1e-12) +})#TEST_THAT + +test_that("coef.ral returns matrix for multiple fits", { + n <- 50 + coefficients <- matrix(c(1, 2, 3, 4), 2, 2, + dimnames = list(c("a", "b"), + c("e1", "e2"))) + inf_func <- array(rnorm(n * 2 * 2), + dim = c(n, 2, 2)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = c("a", "b")) + + cf <- coef(obj) + expect_true(is.matrix(cf)) + expect_equal(dim(cf), c(2, 2)) +})#TEST_THAT + +# nobs.ral ===================================================================== + +test_that("nobs.ral returns correct count", { + n <- 42 + coefficients <- matrix(1, 1, 1) + inf_func <- array(rnorm(n), dim = c(n, 1, 1)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = "x") + + expect_equal(nobs(obj), 42) +})#TEST_THAT + +# hatvalues.ral ================================================================ + +test_that("hatvalues.ral returns leverage when dinf_dtheta present", { + n <- 50 + coefficients <- matrix(1, 1, 1) + inf_func <- array(rnorm(n), dim = c(n, 1, 1)) + dinf_dtheta <- array(runif(n, 0.5, 1.5), + dim = c(n, 1, 1, 1)) + + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + dinf_dtheta = dinf_dtheta, + nobs = n, coef_names = "x") + + h <- hatvalues(obj) + expect_length(h, n) + expect_true(all(is.finite(h))) +})#TEST_THAT + +test_that("hatvalues.ral warns when dinf_dtheta is NULL", { + n <- 50 + coefficients <- matrix(1, 1, 1) + inf_func <- array(rnorm(n), dim = c(n, 1, 1)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = "x") + + expect_warning(hatvalues(obj), "dinf_dtheta") +})#TEST_THAT + +# vcov.ral ===================================================================== + +test_that("vcov.ral produces valid covariance matrix", { + n <- 200 + p <- 2 + coefficients <- matrix(c(1, 2), p, 1, + dimnames = list(c("a", "b"), "e1")) + inf_func <- array(rnorm(n * p), dim = c(n, p, 1)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = c("a", "b")) + + V <- vcov(obj) + expect_true(is.matrix(V)) + expect_equal(dim(V), c(p, p)) + expect_true(all(diag(V) > 0)) + expect_equal(rownames(V), c("a", "b")) + expect_equal(colnames(V), c("a", "b")) + + # PSD + evals <- eigen(V, only.values = TRUE)$values + expect_true(all(evals >= -1e-10)) +})#TEST_THAT + +test_that("vcov.ral HC0 vs HC1 differ by dof correction", { + n <- 100 + coefficients <- matrix(1, 1, 1) + inf_func <- array(rnorm(n), dim = c(n, 1, 1)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = "x") + + V0 <- vcov(obj, type = "HC0") + V1 <- vcov(obj, type = "HC1") + expect_equal(V1[1, 1], V0[1, 1] * n / (n - 1), + tolerance = 1e-10) +})#TEST_THAT + +test_that("vcov.ral HC3 uses leverage correction", { + n <- 100 + coefficients <- matrix(1, 1, 1) + inf_func <- array(rnorm(n), dim = c(n, 1, 1)) + dinf_dtheta <- array(1, dim = c(n, 1, 1, 1)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + dinf_dtheta = dinf_dtheta, + nobs = n, coef_names = "x") + + V3 <- vcov(obj, type = "HC3") + V0 <- vcov(obj, type = "HC0") + # HC3 >= HC0 in general + expect_true(V3[1, 1] >= V0[1, 1] - 1e-12) +})#TEST_THAT + +# validate_fit_idx ============================================================= + +test_that("fit_idx out of range errors", { + n <- 50 + coefficients <- matrix(1, 1, 1) + inf_func <- array(rnorm(n), dim = c(n, 1, 1)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = "x") + + expect_error(vcov(obj, fit_idx = 0), "fit_idx") + expect_error(vcov(obj, fit_idx = 2), "fit_idx") + expect_error(vcov(obj, fit_idx = 99), "fit_idx") + expect_error(confint(obj, fit_idx = 99), "fit_idx") +})#TEST_THAT + +# confint.ral ================================================================== + +test_that("confint.ral returns valid intervals", { + n <- 200 + coefficients <- matrix(c(1, 2), 2, 1, + dimnames = list(c("a", "b"), "e1")) + inf_func <- array(rnorm(n * 2), dim = c(n, 2, 1)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = c("a", "b")) + + ci <- confint(obj) + expect_equal(nrow(ci), 2) + expect_equal(ncol(ci), 2) + expect_true(all(ci[, 1] < ci[, 2])) + expect_identical(colnames(ci), c(" 2.5 %", "97.5 %")) + expect_equal(attr(ci, "crit_val"), qnorm(0.975), + tolerance = 1e-6) +})#TEST_THAT + +test_that("confint.ral parm subsetting works", { + n <- 200 + coefficients <- matrix(c(1, 2, 3), 3, 1, + dimnames = list(c("a", "b", "c"), + "e1")) + inf_func <- array(rnorm(n * 3), dim = c(n, 3, 1)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = c("a", "b", "c")) + + # By name + ci_ab <- confint(obj, parm = c("a", "b")) + expect_equal(nrow(ci_ab), 2) + expect_equal(rownames(ci_ab), c("a", "b")) + + # By index + ci_2 <- confint(obj, parm = 2) + expect_equal(nrow(ci_2), 1) + expect_equal(rownames(ci_2), "b") +})#TEST_THAT + +test_that("confint.ral uniform wider than pointwise", { + set.seed(42) + n <- 200 + p <- 3 + coefficients <- matrix(rep(0, p), p, 1, + dimnames = list(letters[1:p], "e1")) + inf_func <- array(rnorm(n * p), dim = c(n, p, 1)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, + coef_names = letters[1:p]) + + ci_pw <- confint(obj) + set.seed(1) + ci_uf <- confint(obj, uniform = TRUE, bootstraps = 499) + + width_pw <- ci_pw[, 2] - ci_pw[, 1] + width_uf <- ci_uf[, 2] - ci_uf[, 1] + expect_true(all(width_uf >= width_pw)) + expect_true(attr(ci_uf, "crit_val") > qnorm(0.975)) +})#TEST_THAT + +# summary.ral ================================================================= + +test_that("summary.ral produces valid output", { + n <- 200 + coefficients <- matrix(c(1, 2), 2, 1, + dimnames = list(c("a", "b"), "e1")) + inf_func <- array(rnorm(n * 2), dim = c(n, 2, 1)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = c("a", "b")) + + s <- summary(obj) + expect_s3_class(s, "summary.ral") + expect_true(is.array(s$coefficients)) + expect_equal(dim(s$coefficients), c(2, 4, 1)) + expect_equal(s$nobs, n) + expect_equal(s$type, "HC1") + + # Print does not error + out <- capture_output(print(s)) + expect_true(grepl("RAL estimation", out)) + expect_true(grepl("Obs:", out)) +})#TEST_THAT + +# tidy.ral ===================================================================== + +test_that("tidy.ral returns valid data.frame", { + n <- 200 + coefficients <- matrix(c(1, 2), 2, 1, + dimnames = list(c("a", "b"), "e1")) + inf_func <- array(rnorm(n * 2), dim = c(n, 2, 1)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = c("a", "b")) + + td <- tidy(obj) + expect_s3_class(td, "data.frame") + expect_equal(nrow(td), 2) + expect_true(all(c("term", "estimate", "std.error", + "statistic", "p.value", + "fit_label") %in% names(td))) + expect_equal(td$term, c("a", "b")) +})#TEST_THAT + +test_that("tidy.ral with conf.int", { + n <- 200 + coefficients <- matrix(c(1, 2), 2, 1, + dimnames = list(c("a", "b"), "e1")) + inf_func <- array(rnorm(n * 2), dim = c(n, 2, 1)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = c("a", "b")) + + td <- tidy(obj, conf.int = TRUE) + expect_true(all(c("conf.low", "conf.high") %in% + names(td))) + expect_true(all(td$conf.low < td$conf.high)) +})#TEST_THAT + +test_that("tidy.ral fit_idx=NULL returns all fits", { + n <- 50 + coefficients <- matrix(c(1, 2, 3, 4), 2, 2, + dimnames = list(c("a", "b"), + c("e1", "e2"))) + inf_func <- array(rnorm(n * 2 * 2), + dim = c(n, 2, 2)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = c("a", "b")) + + td_all <- tidy(obj, fit_idx = NULL) + expect_equal(nrow(td_all), 4) # 2 params x 2 fits +})#TEST_THAT + +# glance.ral ================================================================== + +test_that("glance.ral returns one-row data.frame", { + n <- 50 + coefficients <- matrix(1, 1, 1) + inf_func <- array(rnorm(n), dim = c(n, 1, 1)) + obj <- ral(coefficients = coefficients, + inf_func = inf_func, + nobs = n, coef_names = "x", + estimator_name = "Test") + + gl <- glance(obj) + expect_s3_class(gl, "data.frame") + expect_equal(nrow(gl), 1) + expect_equal(gl$nobs, n) + expect_equal(gl$estimator_name, "Test") +})#TEST_THAT + +# plot.ral ===================================================================== + +test_that("plot.ral produces a plot without error", { + n <- 100 + p <- 3 + inf <- array(stats::rnorm(n * p), c(n, p, 1)) + theta <- matrix(c(0.5, -0.3, 0.1), p, 1) + obj <- ral(theta, inf, nobs = n, + coef_names = c("b1", "b2", "b3")) + + # Plot should run without error + pdf(file = NULL) + on.exit(dev.off(), add = TRUE) + res <- plot(obj) + + expect_type(res, "list") + expect_named(res, c("coefficients", "ci", "labels")) + expect_equal(length(res$coefficients), p) + expect_equal(nrow(res$ci), p) +})#TEST_THAT + +test_that("plot.ral with uniform = TRUE produces wider bands", { + set.seed(123) + n <- 200 + p <- 3 + inf <- array(stats::rnorm(n * p), c(n, p, 1)) + theta <- matrix(c(0.5, -0.3, 0.1), p, 1) + obj <- ral(theta, inf, nobs = n, + coef_names = c("b1", "b2", "b3")) + + pdf(file = NULL) + on.exit(dev.off(), add = TRUE) + + res_pw <- plot(obj, uniform = FALSE) + res_uf <- plot(obj, uniform = TRUE) + + # Uniform bands should be at least as wide as pointwise + width_pw <- res_pw$ci[, 2] - res_pw$ci[, 1] + width_uf <- res_uf$ci[, 2] - res_uf$ci[, 1] + expect_true(all(width_uf >= width_pw - 1e-10)) +})#TEST_THAT + +test_that("plot.ral with parm selects subset", { + n <- 100 + p <- 3 + inf <- array(stats::rnorm(n * p), c(n, p, 1)) + theta <- matrix(c(0.5, -0.3, 0.1), p, 1) + obj <- ral(theta, inf, nobs = n, + coef_names = c("b1", "b2", "b3")) + + pdf(file = NULL) + on.exit(dev.off(), add = TRUE) + res <- plot(obj, parm = c("b1", "b3")) + + expect_equal(length(res$coefficients), 2) + expect_equal(res$labels, c("b1", "b3")) +})#TEST_THAT + +# as.list.ral ================================================================== + +test_that("as.list.ral splits by fit", { + n <- 100; p <- 2; nfit <- 3 + coef <- matrix(rnorm(p * nfit), p, nfit, + dimnames = list(c("a", "b"), + c("f1", "f2", "f3"))) + inf <- array(rnorm(n * p * nfit), dim = c(n, p, nfit)) + obj <- ral(coef, inf, nobs = n, + coef_names = c("a", "b")) + + L <- as.list(obj) + expect_length(L, nfit) + expect_equal(names(L), c("f1", "f2", "f3")) + for (j in seq_len(nfit)) { + expect_s3_class(L[[j]], "ral") + expect_equal(ncol(L[[j]]$coefficients), 1L) + expect_equal(L[[j]]$coefficients[, 1], coef[, j]) + } +})#TEST_THAT + +test_that("as.list.ral single-fit returns length-1 list", { + n <- 50; p <- 1 + obj <- ral(matrix(1, 1, 1, dimnames = list("x", "fit1")), + array(rnorm(n), dim = c(n, 1, 1)), + nobs = n, coef_names = "x") + L <- as.list(obj) + expect_length(L, 1) + expect_s3_class(L[[1]], "ral") +})#TEST_THAT diff --git a/tests/testthat/test-ral_rep.R b/tests/testthat/test-ral_rep.R new file mode 100644 index 0000000..717dfdb --- /dev/null +++ b/tests/testthat/test-ral_rep.R @@ -0,0 +1,250 @@ +# Tests for ral_rep base class ================================================= + +# Helper: construct a minimal ral_rep from synthetic data. +make_ral_rep <- function(n = 200, p = 2, R = 3) { + fits <- lapply(seq_len(R), function(r) { + set.seed(r * 100) + coefficients <- matrix(rnorm(p), p, 1, + dimnames = list(paste0("x", 1:p), + "fit1")) + inf_func <- array(rnorm(n * p), dim = c(n, p, 1)) + dinf_dtheta <- array(1, dim = c(n, p, p, 1)) + ral(coefficients = coefficients, + inf_func = inf_func, + dinf_dtheta = dinf_dtheta, + nobs = n, + coef_names = paste0("x", 1:p), + estimator_name = "Test RAL") + }) + ral_rep(fits) +}#MAKE_RAL_REP + +# Constructor ================================================================== + +test_that("ral_rep() constructs valid object", { + rr <- make_ral_rep() + + expect_s3_class(rr, "ral_rep") + expect_equal(rr$nresamples, 3) + expect_equal(rr$nobs, 200) + expect_equal(rr$nfit, 1) + expect_equal(rr$coef_names, c("x1", "x2")) +})#TEST_THAT + +test_that("ral_rep() with subclass", { + fits <- lapply(1:2, function(r) { + set.seed(r) + ral(coefficients = matrix(1, 1, 1), + inf_func = array(rnorm(50), dim = c(50, 1, 1)), + nobs = 50, coef_names = "x") + }) + + rr <- ral_rep(fits, subclass = "my_rep", + custom_field = "hello") + + expect_equal(class(rr), c("my_rep", "ral_rep")) + expect_s3_class(rr, "my_rep") + expect_s3_class(rr, "ral_rep") + expect_equal(rr$custom_field, "hello") +})#TEST_THAT + +test_that("ral_rep() validates inputs", { + n <- 50 + fit1 <- ral(coefficients = matrix(1, 1, 1), + inf_func = array(rnorm(n), dim = c(n, 1, 1)), + nobs = n, coef_names = "x") + fit2 <- ral(coefficients = matrix(1, 1, 1), + inf_func = array(rnorm(n), dim = c(n, 1, 1)), + nobs = n, coef_names = "x") + + # Valid + expect_no_error(ral_rep(list(fit1, fit2))) + + # < 2 fits + expect_error(ral_rep(list(fit1)), "at least 2") + + # Non-ral element + expect_error(ral_rep(list(fit1, "bad")), + "does not inherit") + + # Mismatched nobs + fit3 <- ral(coefficients = matrix(1, 1, 1), + inf_func = array(rnorm(100), dim = c(100, 1, 1)), + nobs = 100, coef_names = "x") + expect_error(ral_rep(list(fit1, fit3)), + "different 'nobs'") + + # Mismatched coef_names + fit4 <- ral(coefficients = matrix(1, 1, 1), + inf_func = array(rnorm(n), dim = c(n, 1, 1)), + nobs = n, coef_names = "y") + expect_error(ral_rep(list(fit1, fit4)), + "different 'coef_names'") +})#TEST_THAT + +# Accessors ==================================================================== + +test_that("[[ and length work", { + rr <- make_ral_rep() + + expect_equal(length(rr), 3) + expect_s3_class(rr[[1]], "ral") + expect_s3_class(rr[[2]], "ral") +})#TEST_THAT + +test_that("nobs.ral_rep works", { + rr <- make_ral_rep() + expect_equal(nobs(rr), 200) +})#TEST_THAT + +# coef.ral_rep ================================================================= + +test_that("coef.ral_rep with median aggregation", { + rr <- make_ral_rep() + cf <- coef(rr) + expect_true(is.numeric(cf)) + expect_length(cf, 2) + + # Median of per-rep coefs + per_rep <- sapply(rr$fits, function(f) + f$coefficients[, 1]) + expected <- apply(per_rep, 1, median) + expect_equal(unname(cf), unname(expected), + tolerance = 1e-10) +})#TEST_THAT + +test_that("coef.ral_rep with mean aggregation", { + rr <- make_ral_rep() + cf <- coef(rr, aggregation = "mean") + per_rep <- sapply(rr$fits, function(f) + f$coefficients[, 1]) + expected <- apply(per_rep, 1, mean) + expect_equal(unname(cf), unname(expected), + tolerance = 1e-10) +})#TEST_THAT + +# vcov.ral_rep ================================================================= + +test_that("vcov.ral_rep produces valid matrix", { + rr <- make_ral_rep() + + V <- vcov(rr) + expect_true(is.matrix(V)) + expect_equal(dim(V), c(2, 2)) + expect_true(all(diag(V) > 0)) + expect_equal(rownames(V), c("x1", "x2")) +})#TEST_THAT + +test_that("vcov.ral_rep median matches manual computation", { + rr <- make_ral_rep() + R <- rr$nresamples + p <- 2 + + agg_coef <- coef(rr) + V_arr <- array(NA, dim = c(p, p, R)) + for (r in seq_len(R)) { + Sigma_r <- vcov(rr$fits[[r]]) + bdiff <- coef(rr$fits[[r]]) - agg_coef + V_arr[, , r] <- Sigma_r + tcrossprod(bdiff) + }#FOR + V_manual <- apply(V_arr, c(1, 2), median) + dimnames(V_manual) <- dimnames(vcov(rr)) + + expect_equal(vcov(rr), V_manual, tolerance = 1e-10) +})#TEST_THAT + +# confint.ral_rep ============================================================== + +test_that("confint.ral_rep returns valid intervals", { + rr <- make_ral_rep() + + ci <- confint(rr) + expect_equal(nrow(ci), 2) + expect_equal(ncol(ci), 2) + expect_true(all(ci[, 1] < ci[, 2])) + expect_identical(colnames(ci), c(" 2.5 %", "97.5 %")) +})#TEST_THAT + +test_that("confint.ral_rep uniform wider than pointwise", { + rr <- make_ral_rep() + + ci_pw <- confint(rr) + set.seed(1) + ci_uf <- confint(rr, uniform = TRUE, bootstraps = 499) + + width_pw <- ci_pw[, 2] - ci_pw[, 1] + width_uf <- ci_uf[, 2] - ci_uf[, 1] + expect_true(all(width_uf >= width_pw)) + expect_false(is.null(attr(ci_uf, "crit_val"))) +})#TEST_THAT + +# summary.ral_rep ============================================================= + +test_that("summary.ral_rep works", { + rr <- make_ral_rep() + + s <- summary(rr) + expect_s3_class(s, "summary.ral_rep") + expect_true(is.array(s$coefficients)) + expect_equal(dim(s$coefficients), c(2, 4, 1)) + expect_equal(s$nobs, 200) + expect_equal(s$nresamples, 3) + expect_equal(s$aggregation, "median") + + # Print does not error + out <- capture_output(print(s)) + expect_true(grepl("RAL estimation", out)) + expect_true(grepl("Resamples:", out)) + expect_true(grepl("median", out, ignore.case = TRUE)) +})#TEST_THAT + +test_that("summary.ral_rep with mean aggregation", { + rr <- make_ral_rep() + s <- summary(rr, aggregation = "mean") + expect_equal(s$aggregation, "mean") +})#TEST_THAT + +# tidy.ral_rep ================================================================= + +test_that("tidy.ral_rep returns valid data.frame", { + rr <- make_ral_rep() + + td <- tidy(rr) + expect_s3_class(td, "data.frame") + expect_equal(nrow(td), 2) + expect_true(all(c("term", "estimate", "std.error", + "statistic", "p.value", + "fit_label", "aggregation") + %in% names(td))) + expect_equal(td$aggregation[1], "median") +})#TEST_THAT + +test_that("tidy.ral_rep with conf.int", { + rr <- make_ral_rep() + td <- tidy(rr, conf.int = TRUE) + + expect_true(all(c("conf.low", "conf.high") + %in% names(td))) + expect_true(all(td$conf.low < td$conf.high)) +})#TEST_THAT + +# glance.ral_rep =============================================================== + +test_that("glance.ral_rep returns one-row df", { + rr <- make_ral_rep() + gl <- glance(rr) + + expect_s3_class(gl, "data.frame") + expect_equal(nrow(gl), 1) + expect_equal(gl$nobs, 200) + expect_equal(gl$nresamples, 3) +})#TEST_THAT + +# print.ral_rep ================================================================ + +test_that("print.ral_rep works", { + rr <- make_ral_rep() + out <- capture_output(print(rr)) + expect_true(grepl("RAL replicated fits", out)) + expect_true(grepl("Resamples:", out)) +})#TEST_THAT diff --git a/tests/testthat/test-shortstacking.R b/tests/testthat/test-shortstacking.R index a03f805..f21a6ab 100644 --- a/tests/testthat/test-shortstacking.R +++ b/tests/testthat/test-shortstacking.R @@ -2,23 +2,20 @@ test_that("shortstacking computes with ensemble procedures & custom weights", { # generate test data nobs <- 100 X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - Z <- matrix(rnorm(nobs*10), nobs, 10) # overidentified - y <- X %*% runif(40) + Z %*% c(1, runif(9)) + rnorm(nobs) + y <- X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols), - list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols), + list(what = ols)) # Compute cross-sample predictions - shortstacking_res <- shortstacking(y, X, Z, + shortstacking_res <- shortstacking(y, X, learners, ensemble_type = c("average", "ols", "nnls1", "nnls", "singlebest"), custom_ensemble_weights = diag(1, 3), sample_folds = 3, - compute_insample_predictions = T, - silent = F) + silent = FALSE) # Check output with expectations - expect_equal(dim(shortstacking_res$oos_fitted), c(length(y), 8)) - expect_equal(length(shortstacking_res$is_fitted), 8) + expect_equal(dim(shortstacking_res$cf_fitted), c(length(y), 8)) })#TEST_THAT diff --git a/tests/testthat/test-subsample_functions.R b/tests/testthat/test-subsample_functions.R index 327f332..c732a89 100644 --- a/tests/testthat/test-subsample_functions.R +++ b/tests/testthat/test-subsample_functions.R @@ -1,108 +1,224 @@ -test_that("subsample construction works with multi-valued D", { - # Simulate small dataset +# --- get_sample_splits: basic (no D) --- + +test_that("get_sample_splits returns correct structure without D", { + nobs <- 200 + cl <- seq_len(nobs) + + # Without CV + res <- get_sample_splits(cl, sample_folds = 5) + expect_equal(length(res$subsamples), 5) + expect_equal(length(unlist(res$subsamples)), nobs) + expect_null(res$cv_subsamples) + expect_null(res$subsamples_byD) + expect_null(res$cv_subsamples_byD) + expect_null(res$aux_indx) + + # With CV + res_cv <- get_sample_splits(cl, sample_folds = 5, cv_folds = 3) + expect_equal(length(res_cv$subsamples), 5) + expect_equal(length(res_cv$cv_subsamples), 5) + expect_equal(length(res_cv$cv_subsamples[[1]]), 3) + # CV fold sizes should sum to training set size + expect_equal( + length(unlist(res_cv$cv_subsamples[[1]])), + nobs - length(res_cv$subsamples[[1]])) +})#TEST_THAT + +# --- get_sample_splits: with D --- + +test_that("get_sample_splits returns correct structure with D", { + nobs <- 200 + cl <- seq_len(nobs) + D <- rep(c(0, 1), each = nobs / 2) + + res <- get_sample_splits(cl, sample_folds = 5, cv_folds = 3, D = D) + + # Basic structure + expect_equal(length(res$subsamples), 5) + expect_equal(length(res$subsamples_byD), 2) + expect_equal(length(res$subsamples_byD[[1]]), 5) + expect_equal(length(res$cv_subsamples), 5) + expect_equal(length(res$cv_subsamples_byD), 2) + expect_false(is.null(res$aux_indx)) + expect_equal(length(res$aux_indx), 2) + + # CV fold sizes match training set for D=0 subsample + n_D0 <- sum(D == 0) + n_D0_fold1 <- length(res$subsamples_byD[[1]][[1]]) + expect_equal( + length(unlist(res$cv_subsamples_byD[[1]][[1]])), + n_D0 - n_D0_fold1) +})#TEST_THAT + +# --- get_sample_splits: multi-valued D --- + +test_that("get_sample_splits works with multi-valued D", { nobs <- 500 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - D_tld <- X %*% runif(40) + rnorm(nobs) - fun <- stepfun(quantile(D_tld, probs = c(0.25, 0.5, 0.75)), c(1, 2, 3, 4)) + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- X %*% runif(5) + rnorm(nobs) + fun <- stepfun(quantile(D_tld, probs = c(0.25, 0.5, 0.75)), + c(1, 2, 3, 4)) D <- fun(D_tld) - y <- D + X %*% runif(40) + rnorm(nobs) - - # Compute crossfit indices w/o splitting by D - crossfit_indices_1 <- get_crossfit_indices(cluster_variable = 1:500, - sample_folds = 5, cv_folds = 3, - D = NULL) - - # Compute crossfit indices w/ splitting by D - crossfit_indices_2 <- get_crossfit_indices(cluster_variable = 1:500, - sample_folds = 5, cv_folds = 3, - D = D) - - # Check that subsamples and cv subsamples are of matching size - expect_equal(nobs - length(crossfit_indices_1$subsamples[[1]]), - length(unlist(crossfit_indices_1$cv_subsamples_list[[1]]))) - expect_equal(nobs - length(crossfit_indices_2$subsamples[[1]]), - length(unlist(crossfit_indices_2$cv_subsamples_list[[1]]))) - expect_equal(sum(D==1) - length(crossfit_indices_2$subsamples_byD[[1]][[1]]), - length(unlist(crossfit_indices_2$cv_subsamples_byD[[1]][[1]]))) + + res <- get_sample_splits(seq_len(nobs), sample_folds = 5, + cv_folds = 3, D = D) + + # 4 treatment levels + expect_equal(length(res$subsamples_byD), 4) + expect_equal(length(res$cv_subsamples_byD), 4) + expect_equal(length(res$aux_indx), 4) + + # Subsamples partition 1:nobs + all_indx <- sort(unlist(res$subsamples)) + expect_equal(all_indx, seq_len(nobs)) })#TEST_THAT -test_that("subsample construction works with multi-valued D and dependence", { - # Simulate small dataset - n_cluster <- 200 +# --- get_sample_splits: clustered --- + +test_that("get_sample_splits respects clusters", { nobs <- 500 - X <- cbind(1, matrix(rnorm(n_cluster*39), n_cluster, 39)) - D_tld <- X %*% runif(40) + rnorm(n_cluster) - fun <- stepfun(quantile(D_tld, probs = c(0.25, 0.5, 0.75)), c(1, 2, 3, 4)) - D <- fun(D_tld) - cluster_variable <- sample(1:n_cluster, nobs, replace = TRUE) - D <- D[cluster_variable] - X <- X[cluster_variable, ] - y <- D + X %*% runif(40) + rnorm(nobs) - - # Compute crossfit indices w/o splitting by D - crossfit_indices_1 <- get_crossfit_indices(cluster_variable = - cluster_variable, - sample_folds = 5, cv_folds = 3, - D = NULL) - expect_identical( - setdiff(unique(cluster_variable[crossfit_indices_1$subsamples[[1]]]), - unique(cluster_variable[crossfit_indices_1$subsamples[[2]]])), - unique(cluster_variable[crossfit_indices_1$subsamples[[1]]])) - - # Compute crossfit indices w/ splitting by D - crossfit_indices_2 <- get_crossfit_indices(cluster_variable = - cluster_variable, - sample_folds = 5, cv_folds = 3, - D = D) - - # Check that cluster variables are unique across folds - expect_identical( - setdiff(cluster_variable[D==1][crossfit_indices_2$subsamples_byD[[1]][[1]]], - cluster_variable[D==1][crossfit_indices_2$subsamples_byD[[1]][[2]]]), - unique(cluster_variable[D==1][crossfit_indices_2$subsamples_byD[[1]][[1]]])) - expect_identical( - setdiff(cluster_variable[D==2][crossfit_indices_2$subsamples_byD[[2]][[1]]], - cluster_variable[D==2][crossfit_indices_2$subsamples_byD[[2]][[2]]]), - unique(cluster_variable[D==2][crossfit_indices_2$subsamples_byD[[2]][[1]]])) - expect_identical( - setdiff(unique(cluster_variable[crossfit_indices_2$subsamples[[1]]]), - unique(cluster_variable[crossfit_indices_2$subsamples[[2]]])), - unique(cluster_variable[crossfit_indices_2$subsamples[[1]]])) - - # Check that subsamples and cv subsamples are of matching size - expect_equal(nobs - length(crossfit_indices_1$subsamples[[1]]), - length(unlist(crossfit_indices_1$cv_subsamples_list[[1]]))) - expect_equal(nobs - length(crossfit_indices_2$subsamples[[1]]), - length(unlist(crossfit_indices_2$cv_subsamples_list[[1]]))) - expect_equal(sum(D==1) - length(crossfit_indices_2$subsamples_byD[[1]][[1]]), - length(unlist(crossfit_indices_2$cv_subsamples_byD[[1]][[1]]))) + n_cluster <- 100 + cluster_variable <- sample(seq_len(n_cluster), nobs, replace = TRUE) + D <- ifelse(rnorm(nobs) > 0, 1, 0) + + res <- get_sample_splits(cluster_variable, sample_folds = 5, + cv_folds = 3, D = D) + + # Clusters should be unique across folds + cl_fold1 <- unique(cluster_variable[res$subsamples[[1]]]) + cl_fold2 <- unique(cluster_variable[res$subsamples[[2]]]) + expect_equal(length(intersect(cl_fold1, cl_fold2)), 0) +})#TEST_THAT + +# --- get_sample_splits: pre-specified subsamples pass through --- + +test_that("pre-specified subsamples pass through unchanged", { + nobs <- 100 + cl <- seq_len(nobs) + my_subsamples <- list(1:25, 26:50, 51:75, 76:100) + + res <- get_sample_splits(cl, subsamples = my_subsamples) + + for (k in seq_along(my_subsamples)) { + expect_equal(res$subsamples[[k]], my_subsamples[[k]]) + }#FOR +})#TEST_THAT + +# --- get_sample_splits: auto-merge subsamples_byD --- + +test_that("subsamples_byD without subsamples auto-merges", { + nobs <- 100 + D <- rep(c(0, 1), each = 50) + cl <- seq_len(nobs) + + # Create by-D subsamples manually + byD <- list( + list(1:25, 26:50), # D=0 folds (indices within D=0 subsample) + list(1:25, 26:50) # D=1 folds + ) + + res <- get_sample_splits(cl, D = D, subsamples_byD = byD) + + # subsamples should have been auto-merged + expect_equal(length(res$subsamples), 2) + all_indx <- sort(unlist(res$subsamples)) + expect_equal(all_indx, seq_len(nobs)) +})#TEST_THAT + +# --- get_cf_indices_stratified: balance --- + +test_that("stratified folds have balanced treatment counts", { + nobs <- 500 + D <- c(rep(0, 400), rep(1, 100)) + cl <- seq_len(nobs) + + res <- get_sample_splits(cl, sample_folds = 5, D = D, + stratify = TRUE) + + # Count D=1 observations in each fold + d1_per_fold <- vapply(res$subsamples, function(idx) { + sum(D[idx] == 1) + }, FUN.VALUE = integer(1)) + + # Folds should be roughly balanced (max - min <= 1 for integer rounding) + expect_lte(max(d1_per_fold) - min(d1_per_fold), 1) +})#TEST_THAT + +# --- check_subsamples: warning for small training sets --- + +test_that("check_subsamples warns for small training sets", { + # 50 obs split into 5 folds = 10 obs per fold = 40 training + small_subsamples <- split(seq_len(50), rep(1:5, each = 10)) + names(small_subsamples) <- NULL + + expect_warning( + check_subsamples(small_subsamples, NULL, stratify = FALSE), + "only uses") })#TEST_THAT +test_that("check_subsamples does not warn for large training sets", { + large_subsamples <- split(seq_len(500), rep(1:5, each = 100)) + names(large_subsamples) <- NULL + + expect_silent( + check_subsamples(large_subsamples, NULL, stratify = FALSE)) +})#TEST_THAT + +# --- auxiliary_X construction --- + test_that("auxiliary_X construction works with multi-valued D", { - # Simulate small dataset nobs <- 500 - X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) - D_tld <- X %*% runif(40) + rnorm(nobs) - fun <- stepfun(quantile(D_tld, probs = c(0.25, 0.5, 0.75)), c(1, 2, 3, 4)) + X <- matrix(rnorm(nobs * 5), nobs, 5) + D_tld <- X %*% runif(5) + rnorm(nobs) + fun <- stepfun(quantile(D_tld, probs = c(0.25, 0.5, 0.75)), + c(1, 2, 3, 4)) D <- fun(D_tld) - y <- D + X %*% runif(40) + rnorm(nobs) - # Compute crossfit indices w/ splitting by D - crossfit_indices <- get_crossfit_indices(cluster_variable = 1:500, - sample_folds = 5, cv_folds = 3, - D = D) + res <- get_sample_splits(seq_len(nobs), sample_folds = 5, D = D) - # Get auxiliary_indx - auxiliary_indx <- get_auxiliary_indx(crossfit_indices$subsamples_byD, D) + # Get auxiliary_X for first treatment level + auxiliary_X_d <- get_auxiliary_X(res$aux_indx[[1]], X) - # Get auxiliary_X for first sample_folds - auxiliary_X_d <- get_auxiliary_X(auxiliary_indx[[1]], X) + # Check sizes + expect_equal( + length(unlist(res$aux_indx[[1]])), + nobs - length(res$subsamples[[1]]) - + length(res$subsamples_byD[[1]][[1]])) + expect_equal(dim(auxiliary_X_d[[1]])[1], + length(res$aux_indx[[1]][[1]])) +})#TEST_THAT - # Check that auxiliary X is of correct size - expect_equal(length(unlist(auxiliary_indx[[1]])), - nobs - length(crossfit_indices$subsamples[[1]]) - - length(crossfit_indices$subsamples_byD[[1]][[1]])) - expect_equal(dim(auxiliary_X_d[[1]])[1], length(auxiliary_indx[[1]][[1]])) +# --- derive_subsamples_byD round-trip --- + +test_that("derive_subsamples_byD matches get_sample_splits", { + set.seed(42) + nobs <- 200 + D <- rep(c(0, 1), each = nobs / 2) + cl <- seq_len(nobs) + + ref <- get_sample_splits( + cluster_variable = cl, sample_folds = 3, + cv_folds = 3, D = D, stratify = TRUE) + + derived <- derive_subsamples_byD(ref$subsamples, D) + expect_equal(derived, ref$subsamples_byD) })#TEST_THAT +test_that("get_sample_splits derives subsamples_byD when missing", { + set.seed(42) + nobs <- 200 + D <- rep(c(0, 1), each = nobs / 2) + cl <- seq_len(nobs) + ref <- get_sample_splits( + cluster_variable = cl, sample_folds = 3, + cv_folds = 3, D = D, stratify = TRUE) + + derived <- get_sample_splits( + cluster_variable = cl, sample_folds = 3, + cv_folds = 3, D = D, stratify = TRUE, + subsamples = ref$subsamples) + + expect_equal(derived$subsamples, ref$subsamples) + expect_equal(derived$subsamples_byD, ref$subsamples_byD) +})#TEST_THAT diff --git a/vignettes/articles/did.Rmd b/vignettes/articles/did.Rmd index 4a6a0c9..1fd01d6 100644 --- a/vignettes/articles/did.Rmd +++ b/vignettes/articles/did.Rmd @@ -1,9 +1,9 @@ --- -title: "Diff-in-Diff with Double/Debiased Machine Learning" -description: "Tutorial on difference-in-difference estimation with double/debiased machine learning." +title: "Diff-in-Diff Estimation and Aggregation" +description: "Tutorial on DiD estimation with ddml_attgt, lincom aggregation, and uniform inference." output: rmarkdown::html_vignette vignette: > - %\VignetteIndexEntry{Diff-in-Diff with Double/Debiased Machine Learning} + %\VignetteIndexEntry{Diff-in-Diff Estimation and Aggregation} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- @@ -12,92 +12,71 @@ vignette: > # Introduction -This article illustrates how ``ddml`` can complement the highly popular [``did``](https://bcallaway11.github.io/did/index.html) package to compute group-time average treatment effects under a _conditional_ parallel trends assumption. The result is a doubly-robust difference-in-difference estimator for staggered treatment adoption designs that leverages machine learning and (short-)stacking to flexibly control for covariates -- or: difference-in-difference with machine learning. +This article illustrates how ``ddml`` provides a fully self-contained pipeline for difference-in-differences estimation in staggered adoption designs. The workflow consists of four steps: -For an excellent introduction to differences-in-differences with multiple time periods, see also [this article](https://bcallaway11.github.io/did/articles/multi-period-did.html). For a detailed discussion of the relevant asymptotic theory for double/debiased machine learning difference-in-difference estimators see Chang (2020). +1. **Estimation** of group-time average treatment effects (GT-ATTs) via ``ddml_attgt``. +2. **Aggregation** into dynamic event-study parameters via ``lincom_weights_did`` and ``lincom``. +3. **Diagnostics** to inspect stacking weights and learner performance. +4. **Inference** including uniform confidence bands via the multiplier bootstrap, and event-study plots via ``plot``. -# Estimation using ``did``'s Default Estimator +This pipeline does not require the ``did`` package for inference or plotting. However, we begin by computing baseline estimates with ``did::att_gt`` for comparison. -For illustration, consider the data of Callaway and Sant'Anna (2020) on county-level teen employment rates from 2003-2007 for additional details. We are interested in the effect of treatment on the log-employment rate ``lemp`` and assume that parallel trends holds conditional on county population (``lpop`` is the log of county population). + +# Data + +We use the dataset of Callaway and Sant'Anna (2021) on county-level teen employment rates from 2003--2007. The outcome is log-employment (``lemp``) and we assume parallel trends hold conditional on log county population (``lpop``). ```r -# Load the did package +library(ddml) library(did) set.seed(588239) -# Print the data +# Load data data(mpdta) -head(mpdta) -#> year countyreal lpop lemp first.treat treat -#> 866 2003 8001 5.896761 8.461469 2007 1 -#> 841 2004 8001 5.896761 8.336870 2007 1 -#> 842 2005 8001 5.896761 8.340217 2007 1 -#> 819 2006 8001 5.896761 8.378161 2007 1 -#> 827 2007 8001 5.896761 8.487352 2007 1 -#> 937 2003 8019 2.232377 4.997212 2007 1 ``` -By default, the group-time average treatment effect estimator of the ``did`` package controls _linearly_ for additional covariates. (In particular, the propensity score is estimated using [logistic regression](https://github.com/pedrohcgs/DRDID/blob/master/R/drdid_panel.R#L96) and the outcome reduced form is estimated via [linear regression](https://github.com/pedrohcgs/DRDID/blob/master/R/drdid_panel.R#L107)). The below code snippet runs the default linear specification (similar to [this article](https://bcallaway11.github.io/did/articles/did-basics.html#an-example-with-real-data)). +``ddml_attgt`` takes data in wide format: an $n \times T$ outcome matrix, a time-invariant covariate matrix, and a group vector: ```r -# Estimate group-time average treatment effects with covariates -attgt_lm <- att_gt(yname = "lemp", - gname = "first.treat", - idname = "countyreal", - tname = "year", - xformla = ~lpop, - data = mpdta) - -# summarize the results -summary(attgt_lm) -#> -#> Call: -#> att_gt(yname = "lemp", tname = "year", idname = "countyreal", -#> gname = "first.treat", xformla = ~lpop, data = mpdta) -#> -#> Reference: Callaway, Brantly and Pedro H.C. Sant'Anna. "Difference-in-Differences with Multiple Time Periods." Journal of Econometrics, Vol. 225, No. 2, pp. 200-230, 2021. , -#> -#> Group-Time Average Treatment Effects: -#> Group Time ATT(g,t) Std. Error [95% Simult. Conf. Band] -#> 2004 2004 -0.0145 0.0231 -0.0757 0.0467 -#> 2004 2005 -0.0764 0.0295 -0.1544 0.0016 -#> 2004 2006 -0.1404 0.0382 -0.2417 -0.0392 * -#> 2004 2007 -0.1069 0.0338 -0.1963 -0.0175 * -#> 2006 2004 -0.0005 0.0226 -0.0603 0.0593 -#> 2006 2005 -0.0062 0.0190 -0.0565 0.0441 -#> 2006 2006 0.0010 0.0199 -0.0518 0.0537 -#> 2006 2007 -0.0413 0.0207 -0.0962 0.0136 -#> 2007 2004 0.0267 0.0145 -0.0116 0.0651 -#> 2007 2005 -0.0046 0.0151 -0.0444 0.0353 -#> 2007 2006 -0.0284 0.0177 -0.0752 0.0183 -#> 2007 2007 -0.0288 0.0154 -0.0696 0.0121 -#> --- -#> Signif. codes: `*' confidence band does not cover 0 -#> -#> P-value for pre-test of parallel trends assumption: 0.23267 -#> Control Group: Never Treated, Anticipation Periods: 0 -#> Estimation Method: Doubly Robust +# Reshape to wide format +ids <- sort(unique(mpdta$countyreal)) +times <- sort(unique(mpdta$year)) +n <- length(ids) +T_ <- length(times) + +# Build outcome matrix (n x T_) +y <- matrix(NA_real_, n, T_) +for (j in seq_along(times)) { + sub <- mpdta[mpdta$year == times[j], ] + y[match(sub$countyreal, ids), j] <- sub$lemp +} + +# Extract time-invariant covariates and group membership +first_obs <- mpdta[match(ids, mpdta$countyreal), ] +G <- first_obs$first.treat +G[G == 0] <- Inf # ddml convention for never-treated +X <- as.matrix(first_obs[, "lpop", drop = FALSE]) + +cat("Units:", n, " Periods:", T_, " Groups:", length(unique(G))) +#> Units: 500 Periods: 5 Groups: 4 ``` -The ``did`` package offers visualization methods using ``gglpot2``: - -```r -ggdid(attgt_lm, ylim = c(-.4, .4)) -``` +# Baseline: ``did`` Package -
-Diff-in-Diff Estimates. -

Diff-in-Diff Estimates.

-
- -Further, the group-time average treatment effects can easily be aggregated, for example, to estimate dynamic average treatment effects: +For comparison, we first estimate the GT-ATTs using the ``did`` package with linear controls. We set ``base_period = "universal"`` to match the base period convention used by ``ddml_attgt``: ```r -# aggregate the group-time average treatment effects +attgt_lm <- att_gt(yname = "lemp", + gname = "first.treat", + idname = "countyreal", + tname = "year", + xformla = ~lpop, + base_period = "universal", + data = mpdta) dyn_lm <- aggte(attgt_lm, type = "dynamic") summary(dyn_lm) #> @@ -109,364 +88,329 @@ summary(dyn_lm) #> #> Overall summary of ATT's based on event-study/dynamic aggregation: #> ATT Std. Error [ 95% Conf. Int.] -#> -0.0804 0.0195 -0.1187 -0.042 * +#> -0.0804 0.0209 -0.1213 -0.0394 * #> #> #> Dynamic Effects: #> Event time Estimate Std. Error [95% Simult. Conf. Band] -#> -3 0.0267 0.0135 -0.0085 0.0619 -#> -2 -0.0036 0.0130 -0.0373 0.0301 -#> -1 -0.0232 0.0151 -0.0624 0.0160 -#> 0 -0.0211 0.0120 -0.0523 0.0102 -#> 1 -0.0530 0.0166 -0.0961 -0.0099 * -#> 2 -0.1404 0.0371 -0.2368 -0.0441 * -#> 3 -0.1069 0.0352 -0.1982 -0.0156 * +#> -4 0.0063 0.0234 -0.0517 0.0643 +#> -3 0.0269 0.0183 -0.0186 0.0724 +#> -2 0.0232 0.0150 -0.0140 0.0605 +#> -1 0.0000 NA NA NA +#> 0 -0.0211 0.0124 -0.0518 0.0096 +#> 1 -0.0530 0.0163 -0.0935 -0.0125 * +#> 2 -0.1404 0.0393 -0.2379 -0.0430 * +#> 3 -0.1069 0.0355 -0.1950 -0.0188 * #> --- #> Signif. codes: `*' confidence band does not cover 0 #> #> Control Group: Never Treated, Anticipation Periods: 0 #> Estimation Method: Doubly Robust -ggdid(dyn_lm, ylim = c(-.4, .4)) ``` -
-Dynamic Treatment Effect Estimates. -

Dynamic Treatment Effect Estimates.

-
-# Contructing a ``xgboost``-based Diff-in-Diff Estimator +# GT-ATT Estimation with ``ddml_attgt`` -Without additional _parametric_ functional form assumptions on the reduced form equations, it is _not_ guaranteed that the default ``att_gt`` estimator returns a convex combination of causal effects. This is because linear predictors do not necessarily correspond to the conditional expectation functions arising in the doubly-robust score of the group-time average treatment effect. The resulting misspecification error can then lead to negative weights in the aggregation of individual-level treatment effects. +We estimate GT-ATTs using ``ddml_attgt``. To validate against the ``did`` baseline, we start with OLS: -Fortunately, a convex combination of causal effects can be guaranteed (without parametric functional form assumptions) when using machine learning (nonparametric) reduced form estimators. -``ddml`` facilitates the use of a large set of machine learning reduced form estimators, including simultaneous considerations of multiple estimators via (short-)stacking. +```r +fit_ols <- ddml_attgt(y, X, t = times, G = G, + learners = list(what = ols), + learners_qX = list(what = mdl_glm), + sample_folds = 10, + silent = TRUE) +summary(fit_ols) +#> DDML estimation: Group-Time Average Treatment Effects on the Treated +#> Obs: 500 Folds: 10 +#> +#> Estimate Std. Error z value Pr(>|z|) +#> ATT(2004,2004) -0.02329 0.02200 -1.06 0.2899 +#> ATT(2004,2005) -0.08196 0.02871 -2.85 0.0043 ** +#> ATT(2004,2006) -0.14114 0.03434 -4.11 4e-05 *** +#> ATT(2004,2007) -0.10817 0.03346 -3.23 0.0012 ** +#> ATT(2006,2003) 0.01463 0.03026 0.48 0.6286 +#> ATT(2006,2004) 0.00572 0.01818 0.31 0.7531 +#> ATT(2006,2006) 0.00913 0.01716 0.53 0.5949 +#> ATT(2006,2007) -0.04021 0.01993 -2.02 0.0436 * +#> ATT(2007,2003) 0.00527 0.02499 0.21 0.8331 +#> ATT(2007,2004) 0.03271 0.02152 1.52 0.1284 +#> ATT(2007,2005) 0.02758 0.01855 1.49 0.1370 +#> ATT(2007,2007) -0.02853 0.01647 -1.73 0.0831 . +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +``` -To use ``ddml`` estimators with the ``did`` package, we can make use of the ``est_method`` argument of the ``att_gt`` function (see also ``?did::att_gt``). It is useful to construct this method in two steps: -1. A simple wrapper for ``ddml_att`` that returns the objects needed by ``att_gt`` -2. A second wrapper that hard-codes arguments passed to ``ddml_att`` +# Dynamic Aggregation via ``lincom`` -This two-step approach allows for cleaner code when considering multiple ddml-based estimators (as we do in this article). +The ``lincom_weights_did`` function constructs the contrast matrix $R$ and the influence function for the estimated weights. The output is passed directly to ``lincom`` for inference. For the dynamic type, both pre-treatment (placebo) and post-treatment event times are included: -The below code-snippet constructs a simple estimation method following step 1: ```r -# load the ddml package -library(ddml) - -# write a general wrapper for ddml_att -ddml_did_method <- function(y1, y0, D, covariates, ...) { - # Compute difference in outcomes - delta_y <- y1 - y0 - # Compute the ATT - att_fit <- ddml_att(y = delta_y, D = D, X = covariates, ...) - # Return results - inf.func <- att_fit$psi_b + att_fit$att * att_fit$psi_a - output <- list(ATT = att_fit$att, att.inf.func = inf.func) - return(output) -}#DDML_DID_METHOD +w_dyn <- lincom_weights_did(fit_ols, type = "dynamic") +lc_dyn <- lincom(fit_ols, R = w_dyn$R, + inf_func_R = w_dyn$inf_func_R, + labels = w_dyn$labels) +summary(lc_dyn) +#> RAL estimation: Linear Combination +#> Obs: 500 +#> +#> Estimate Std. Error z value Pr(>|z|) +#> e=-4 0.00527 0.02487 0.21 0.8323 +#> e=-3 0.02848 0.01783 1.60 0.1102 +#> e=-2 0.02247 0.01479 1.52 0.1287 +#> e=0 -0.02010 0.01172 -1.71 0.0865 . +#> e=1 -0.05413 0.01652 -3.28 0.0011 ** +#> e=2 -0.14114 0.03417 -4.13 3.6e-05 *** +#> e=3 -0.10817 0.03329 -3.25 0.0012 ** +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` -A potentially suitable machine learning reduced form estimator is gradient tree boosting (see also ``?mdl_xgboost``). The below code snippet completes the second wrapper by hard-coding both the learner and its arguments. Here, we consider 10-fold cross-fitting with a gradient tree boosting estimator (``eta`` is the learning rate, see also ``?mdl_xgboost``). +Pre-treatment event times (e < 0) serve as placebo tests: under the parallel trends assumption, these should be close to zero. + +The ``plot`` method produces an event-study style coefficient plot: ```r -my_did_xgboost <- function(y1, y0, D, covariates, ...) { - # Hard-code learners - learners = list(what = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 3), - early_stopping_rounds = 1)) - learners_DX = learners - - # Call the general ddml_did method w/ additional hard-coded arguments - ddml_did_method(y1, y0, D, covariates, - learners = learners, - learners_DX = learners_DX, - sample_folds = 10, - silent = TRUE) -}#MY_DID_XGBOOST +plot(lc_dyn, uniform = TRUE, ylab = "ATT", main = "Dynamic ATT (OLS)") ``` -We can now use the reduced form estimator ``my_did_xgboost`` and pass it via the ``est_method`` argument: +
+Dynamic Treatment Effect Estimates (OLS). +

Dynamic Treatment Effect Estimates (OLS).

+
+ + + +# Stacking-based Estimation + +We next leverage (short-)stacking to combine multiple base learners. Including OLS and logit ensures that the simpler specifications are never spuriously discarded: ```r -# estimate group-time average treatment effects with ddml -attgt_xgboost <- att_gt(yname = "lemp", - gname = "first.treat", - idname = "countyreal", - tname = "year", - xformla = ~lpop, - data = mpdta, - est_method = my_did_xgboost) -#> Warning in trim_propensity_scores(m_X, trim, ensemble_type): : 207 propensity -#> scores were trimmed. -#> Warning in trim_propensity_scores(m_X, trim, ensemble_type): : 220 propensity -#> scores were trimmed. -#> Warning in trim_propensity_scores(m_X, trim, ensemble_type): : 208 propensity -#> scores were trimmed. -#> Warning in trim_propensity_scores(m_X, trim, ensemble_type): : 202 propensity -#> scores were trimmed. -#> Warning in trim_propensity_scores(m_X, trim, ensemble_type): : 48 propensity -#> scores were trimmed. -#> Warning in trim_propensity_scores(m_X, trim, ensemble_type): : 44 propensity -#> scores were trimmed. -#> Warning in trim_propensity_scores(m_X, trim, ensemble_type): : 49 propensity -#> scores were trimmed. -#> Warning in trim_propensity_scores(m_X, trim, ensemble_type): : 48 propensity -#> scores were trimmed. - -# summarize the results -summary(attgt_xgboost) -#> -#> Call: -#> att_gt(yname = "lemp", tname = "year", idname = "countyreal", -#> gname = "first.treat", xformla = ~lpop, data = mpdta, est_method = my_did_xgboost) -#> -#> Reference: Callaway, Brantly and Pedro H.C. Sant'Anna. "Difference-in-Differences with Multiple Time Periods." Journal of Econometrics, Vol. 225, No. 2, pp. 200-230, 2021. , -#> -#> Group-Time Average Treatment Effects: -#> Group Time ATT(g,t) Std. Error [95% Simult. Conf. Band] -#> 2004 2004 0.1412 0.1138 -0.1427 0.4251 -#> 2004 2005 0.1658 0.2354 -0.4213 0.7529 -#> 2004 2006 -0.1373 0.3049 -0.8979 0.6232 -#> 2004 2007 -0.1872 0.2251 -0.7486 0.3743 -#> 2006 2004 0.0018 0.0519 -0.1276 0.1312 -#> 2006 2005 -0.0162 0.0463 -0.1316 0.0993 -#> 2006 2006 -0.0031 0.0431 -0.1105 0.1043 -#> 2006 2007 0.0132 0.0661 -0.1517 0.1781 -#> 2007 2004 -0.0648 0.1000 -0.3142 0.1847 -#> 2007 2005 0.0458 0.0763 -0.1445 0.2362 -#> 2007 2006 0.0381 0.1430 -0.3184 0.3947 -#> 2007 2007 -0.0970 0.1165 -0.3876 0.1936 +# Outcome learners +learners_y <- list( + list(what = ols), + list(what = mdl_xgboost, + args = list(nrounds = 50, + params = list(eta = 0.1, max_depth = 1), + early_stopping_rounds = 1)), + list(what = mdl_xgboost, + args = list(nrounds = 50, + params = list(eta = 0.1, max_depth = 3), + early_stopping_rounds = 1)), + list(what = mdl_ranger, + args = list(num.trees = 100, max.depth = 5)), + list(what = mdl_ranger, + args = list(num.trees = 100, max.depth = 10))) + +# Propensity score learners +learners_ps <- list( + list(what = mdl_glm), + list(what = mdl_xgboost, + args = list(nrounds = 50, + params = list(eta = 0.1, max_depth = 1), + early_stopping_rounds = 1)), + list(what = mdl_xgboost, + args = list(nrounds = 50, + params = list(eta = 0.1, max_depth = 3), + early_stopping_rounds = 1)), + list(what = mdl_ranger, + args = list(num.trees = 100, max.depth = 5)), + list(what = mdl_ranger, + args = list(num.trees = 100, max.depth = 10))) + +# Estimate with short-stacking +fit_stack <- ddml_attgt(y, X, t = times, G = G, + learners = learners_y, + learners_qX = learners_ps, + sample_folds = 5, + ensemble_type = "nnls", + shortstack = TRUE, + silent = TRUE) +``` + + +```r +w_dyn_s <- lincom_weights_did(fit_stack, type = "dynamic") +lc_dyn_s <- lincom(fit_stack, R = w_dyn_s$R, + inf_func_R = w_dyn_s$inf_func_R, + labels = w_dyn_s$labels) +summary(lc_dyn_s) +#> RAL estimation: Linear Combination +#> Obs: 500 +#> +#> Estimate Std. Error z value Pr(>|z|) +#> e=-4 0.00588 0.02457 0.24 0.8110 +#> e=-3 0.02752 0.01779 1.55 0.1218 +#> e=-2 0.02371 0.01457 1.63 0.1036 +#> e=0 -0.02131 0.01180 -1.81 0.0708 . +#> e=1 -0.05714 0.01613 -3.54 0.0004 *** +#> e=2 -0.14076 0.03499 -4.02 5.7e-05 *** +#> e=3 -0.10395 0.03332 -3.12 0.0018 ** #> --- -#> Signif. codes: `*' confidence band does not cover 0 -#> -#> P-value for pre-test of parallel trends assumption: 0.97672 -#> Control Group: Never Treated, Anticipation Periods: 0 +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +``` -# plot the coefficients -ggdid(attgt_xgboost, ylim = c(-.4, .4)) + +```r +plot(lc_dyn_s, uniform = TRUE, ylab = "ATT", main = "Dynamic ATT (Stacking)") ```
-xgboost-based Diff-in-Diff Estimates. -

xgboost-based Diff-in-Diff Estimates.

+Dynamic Treatment Effect Estimates (Stacking). +

Dynamic Treatment Effect Estimates (Stacking).

-Of course, use of the ``ddml``-based reduced form estimator still allows us to leverage the various other methods of the ``did`` package, including the construction (and visualization of) dynamic average treatment effects: + +# Learner Diagnostics + +The stacking weights reveal which learners contribute to the final estimates. We summarize the NNLS weights across all group-time cells for both the outcome and propensity score reduced forms: ```r -# aggregate the group-time average treatment effects -dyn_xgboost <- aggte(attgt_xgboost, type = "dynamic") -summary(dyn_xgboost) -#> -#> Call: -#> aggte(MP = attgt_xgboost, type = "dynamic") -#> -#> Reference: Callaway, Brantly and Pedro H.C. Sant'Anna. "Difference-in-Differences with Multiple Time Periods." Journal of Econometrics, Vol. 225, No. 2, pp. 200-230, 2021. , -#> -#> -#> Overall summary of ATT's based on event-study/dynamic aggregation: -#> ATT Std. Error [ 95% Conf. Int.] -#> -0.0782 0.1306 -0.3343 0.1779 -#> -#> -#> Dynamic Effects: -#> Event time Estimate Std. Error [95% Simult. Conf. Band] -#> -3 -0.0648 0.1032 -0.2931 0.1635 -#> -2 0.0355 0.0620 -0.1016 0.1727 -#> -1 0.0254 0.1065 -0.2101 0.2610 -#> 0 -0.0524 0.0841 -0.2384 0.1336 -#> 1 0.0641 0.0854 -0.1247 0.2528 -#> 2 -0.1373 0.3137 -0.8310 0.5564 -#> 3 -0.1872 0.2189 -0.6711 0.2968 -#> --- -#> Signif. codes: `*' confidence band does not cover 0 -#> -#> Control Group: Never Treated, Anticipation Periods: 0 -ggdid(dyn_xgboost, ylim = c(-.4, .4)) +# Extract diagnostics +diag_stack <- diagnostics(fit_stack) + +# Helper: summarize stacking weights across (g,t) cells +summarize_weights <- function(diag, pattern) { + eqs <- grep(pattern, names(diag$tables), value = TRUE) + w_col <- grep("^weight_", names(diag$tables[[eqs[1]]]), + value = TRUE)[1] + w_mat <- sapply(eqs, function(eq) diag$tables[[eq]][[w_col]]) + learner_names <- diag$tables[[eqs[1]]]$learner + data.frame( + learner = learner_names, + min = round(apply(w_mat, 1, min), 4), + mean = round(apply(w_mat, 1, mean), 4), + max = round(apply(w_mat, 1, max), 4), + row.names = NULL) +} + +cat("Outcome reduced form---stacking weights:\n") +#> Outcome reduced form---stacking weights: +print(summarize_weights(diag_stack, ":y_X_D0$"), row.names = FALSE) +#> learner min mean max +#> learner_1 0.1962 0.6213 0.9516 +#> learner_2 0.0000 0.0330 0.1629 +#> learner_3 0.0000 0.0000 0.0000 +#> learner_4 0.0000 0.0036 0.0434 +#> learner_5 0.0000 0.0118 0.1030 + +cat("\nPropensity score---stacking weights:\n") +#> +#> Propensity score---stacking weights: +print(summarize_weights(diag_stack, ":D_X$"), row.names = FALSE) +#> learner min mean max +#> learner_1 0.8434 0.9128 0.9516 +#> learner_2 0.0000 0.0475 0.1071 +#> learner_3 0.0000 0.0000 0.0000 +#> learner_4 0.0000 0.0004 0.0045 +#> learner_5 0.0000 0.0046 0.0551 ``` -
-xgboost-based Dynamic Treatment Effect Estimates. -

xgboost-based Dynamic Treatment Effect Estimates.

-
+In this application with a single covariate, the parametric learners (OLS/logit) receive the vast majority of the stacking weight---reassuring us that the default linear estimator is adequate here. -The gradient tree boosting-based ATT estimate is only slightly different from the ATT estimate using the linear estimator of the ``did`` package, however, it is statistically insignificant. -Given these two coefficients, is there a good reason to choose one over the other? +# Comparing Results -It is ex-ante difficult to trade-off the potential bias from misspecification that the linear estimator suffers from with the potential bias from estimation error that the gradient tree boosting estimator may suffer from. ``ddml`` allows to resolve this conflict in a data-driven manner by simultaneous consideration of multiple machine learners via (short-)stacking. We turn to this in the next section. +We compare the dynamic treatment effects from the OLS, stacking, and ``did`` baseline estimators: -# Contructing a Shortstacking-based Diff-in-Diff Estimator -Instead of considering just a single machine learner -- that may or may not be suitable for the given application -- we can leverage (short-)stacking and simultaneously consider multiple machine learners. As in other settings, this substantially increases robustness to the underlying structure of the data. +```r +# Build comparison with all event times; base period e=-1 is 0 by definition +ols_full <- setNames(rep(0, length(dyn_lm$egt)), paste0("e=", dyn_lm$egt)) +ols_full[w_dyn$labels] <- coef(lc_dyn) +stack_full <- setNames(rep(0, length(dyn_lm$egt)), paste0("e=", dyn_lm$egt)) +stack_full[w_dyn_s$labels] <- coef(lc_dyn_s) +comparison <- data.frame( + event_time = paste0("e=", dyn_lm$egt), + did = round(dyn_lm$att.egt, 4), + ols = round(ols_full, 4), + stacking = round(stack_full, 4) +) +comparison$did[is.na(comparison$did)] <- 0 +print(comparison, row.names = FALSE) +#> event_time did ols stacking +#> e=-4 0.0063 0.0053 0.0059 +#> e=-3 0.0269 0.0285 0.0275 +#> e=-2 0.0232 0.0225 0.0237 +#> e=-1 0.0000 0.0000 0.0000 +#> e=0 -0.0211 -0.0201 -0.0213 +#> e=1 -0.0530 -0.0541 -0.0571 +#> e=2 -0.1404 -0.1411 -0.1408 +#> e=3 -0.1069 -0.1082 -0.1040 +``` -We construct a new wrapper for our ``ddml_did_method`` that hard-codes different reduced form estimators: -- linear or logistic regression -- gradient tree boosting with more and less regularization -- random forests with more and less regularization +# Repeated Resampling with Uniform Inference -The reduced form estimators are then optimally combined via non-negative least squares. Note that this specification also includes the linear control specifications considered by the default ``did`` learner, ensuring that machine learners are not spuriously selected. We leverage shortstacking to reduce computational time (see also `vignette("stacking")`). +To account for sample-splitting variability, we can repeat cross-fitting several times and aggregate results. The ``ddml_replicate`` function provides this functionality. Combined with ``lincom``, we obtain aggregated dynamic treatment effects with uniform confidence bands: ```r -my_did_stacking <- function(y1, y0, D, covariates, ...) { - # Hard-code learners for outcome reduced-form - learners = list(list(fun = ols), - list(fun = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 1), - early_stopping_rounds = 1)), - list(fun = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 3), - early_stopping_rounds = 1)), - list(fun = mdl_ranger, - args = list(num.trees = 1000, - max.depth = 1)), - list(fun = mdl_ranger, - args = list(num.trees = 1000, - max.depth = 20))) - # Hard-code learners for treatment reduced-form - learners_DX = list(list(fun = mdl_glm), - list(fun = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 1), - early_stopping_rounds = 1)), - list(fun = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 3), - early_stopping_rounds = 1)), - list(fun = mdl_ranger, - args = list(num.trees = 1000, - max.depth = 1)), - list(fun = mdl_ranger, - args = list(num.trees = 1000, - max.depth = 20))) - # Call the general ddml_did method w/ additional hard-coded arguments - ddml_did_method(y1, y0, D, covariates, - learners = learners, - learners_DX = learners_DX, - sample_folds = 10, - ensemble_type = "nnls", - shortstack = TRUE, - silent = TRUE) -}#MY_DID_STACKING +fit_rep <- ddml_replicate( + ddml_attgt, + y = y, X = X, t = times, G = G, + learners = learners_y, + learners_qX = learners_ps, + sample_folds = 5, + ensemble_type = "nnls", + shortstack = TRUE, + resamples = 5, + silent = TRUE +) ``` -Finally, we recompute the group-time average treatment effects using our shortstacking estimator: - ```r -# estimate group-time average treatment effects with ddml -attgt_stacking <- att_gt(yname = "lemp", - gname = "first.treat", - idname = "countyreal", - tname = "year", - xformla = ~lpop , - data = mpdta, - est_method = my_did_stacking) -#> Warning in trim_propensity_scores(m_X, trim, ensemble_type): 2 propensity -#> scores were trimmed. -#> Warning in trim_propensity_scores(m_X, trim, ensemble_type): 1 propensity -#> scores were trimmed. -#> Warning in trim_propensity_scores(m_X, trim, ensemble_type): 2 propensity -#> scores were trimmed. -#> Warning in trim_propensity_scores(m_X, trim, ensemble_type): 2 propensity -#> scores were trimmed. - -# summarize the results -summary(attgt_stacking) -#> -#> Call: -#> att_gt(yname = "lemp", tname = "year", idname = "countyreal", -#> gname = "first.treat", xformla = ~lpop, data = mpdta, est_method = my_did_stacking) -#> -#> Reference: Callaway, Brantly and Pedro H.C. Sant'Anna. "Difference-in-Differences with Multiple Time Periods." Journal of Econometrics, Vol. 225, No. 2, pp. 200-230, 2021. , -#> -#> Group-Time Average Treatment Effects: -#> Group Time ATT(g,t) Std. Error [95% Simult. Conf. Band] -#> 2004 2004 -0.0143 0.0224 -0.0748 0.0461 -#> 2004 2005 -0.0761 0.0296 -0.1558 0.0036 -#> 2004 2006 -0.1372 0.0371 -0.2370 -0.0374 * -#> 2004 2007 -0.1062 0.0318 -0.1918 -0.0205 * -#> 2006 2004 -0.0020 0.0214 -0.0595 0.0554 -#> 2006 2005 -0.0061 0.0199 -0.0596 0.0475 -#> 2006 2006 0.0016 0.0184 -0.0478 0.0510 -#> 2006 2007 -0.0432 0.0203 -0.0978 0.0113 -#> 2007 2004 0.0263 0.0145 -0.0127 0.0653 -#> 2007 2005 -0.0036 0.0162 -0.0474 0.0401 -#> 2007 2006 -0.0276 0.0193 -0.0794 0.0243 -#> 2007 2007 -0.0275 0.0173 -0.0740 0.0189 +# lincom on replicated fits +w_dyn_r <- lincom_weights_did(fit_rep, type = "dynamic") +lc_dyn_r <- lincom(fit_rep, R = w_dyn_r$R, + inf_func_R = w_dyn_r$inf_func_R, + labels = w_dyn_r$labels) +summary(lc_dyn_r) +#> RAL estimation: Linear Combination +#> Obs: 500 Resamples: 5 Aggregation: median +#> +#> Estimate Std. Error z value Pr(>|z|) +#> e=-4 0.00713 0.02429 0.29 0.76917 +#> e=-3 0.02957 0.01761 1.68 0.09317 . +#> e=-2 0.02405 0.01448 1.66 0.09662 . +#> e=0 -0.01985 0.01167 -1.70 0.08898 . +#> e=1 -0.05498 0.01642 -3.35 0.00081 *** +#> e=2 -0.14143 0.03446 -4.10 4.1e-05 *** +#> e=3 -0.10858 0.03288 -3.30 0.00096 *** #> --- -#> Signif. codes: `*' confidence band does not cover 0 -#> -#> P-value for pre-test of parallel trends assumption: 0.24863 -#> Control Group: Never Treated, Anticipation Periods: 0 - -# plot the coefficients -ggdid(attgt_stacking, ylim = c(-.4, .4)) +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` -
-Stacking-based Diff-in-Diff Estimates. -

Stacking-based Diff-in-Diff Estimates.

-
-The results are largely similar to those of the default linear estimator of the ``did`` package, suggesting that the linear approximation of the reduced forms is sufficiently accurate. (Of course we didn't know that before -- now, at least, we can sleep easy!) - -Other settings, in particular settings with multiple control variables, may show starker difference in the final estimates. +The plot method for replicated objects displays median-aggregated estimates with confidence bands. We can request uniform bands via ``uniform = TRUE``: ```r -# aggregate the group-time average treatment effects -dyn_stacking <- aggte(attgt_stacking, type = "dynamic") -summary(dyn_stacking) -#> -#> Call: -#> aggte(MP = attgt_stacking, type = "dynamic") -#> -#> Reference: Callaway, Brantly and Pedro H.C. Sant'Anna. "Difference-in-Differences with Multiple Time Periods." Journal of Econometrics, Vol. 225, No. 2, pp. 200-230, 2021. , -#> -#> -#> Overall summary of ATT's based on event-study/dynamic aggregation: -#> ATT Std. Error [ 95% Conf. Int.] -#> -0.0794 0.0202 -0.1189 -0.0399 * -#> -#> -#> Dynamic Effects: -#> Event time Estimate Std. Error [95% Simult. Conf. Band] -#> -3 0.0263 0.0144 -0.0111 0.0638 -#> -2 -0.0033 0.0132 -0.0375 0.0310 -#> -1 -0.0225 0.0148 -0.0611 0.0160 -#> 0 -0.0200 0.0110 -0.0487 0.0086 -#> 1 -0.0542 0.0164 -0.0969 -0.0114 * -#> 2 -0.1372 0.0402 -0.2419 -0.0325 * -#> 3 -0.1062 0.0341 -0.1949 -0.0175 * -#> --- -#> Signif. codes: `*' confidence band does not cover 0 -#> -#> Control Group: Never Treated, Anticipation Periods: 0 -ggdid(dyn_stacking, ylim = c(-.4, .4)) +plot(lc_dyn_r, uniform = TRUE, + ylab = "ATT", main = "Dynamic ATT (Median, Uniform CI)") ```
-Stacking-based Dynamic Treatment Effect Estimates. -

Stacking-based Dynamic Treatment Effect Estimates.

+Dynamic ATT with Uniform Confidence Bands. +

Dynamic ATT with Uniform Confidence Bands.

+The uniform bands are wider than pointwise intervals, providing simultaneous coverage over all event times. Pointwise intervals are available for reference via ``uniform = FALSE`` (the default). # References -Callaway B, Sant'Anna P (2021). “Difference-in-differences with multiple time periods.” Journal of Econometrics, 200-230. +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, Wiemann T (2026). "An Introduction to Double/Debiased Machine Learning." Journal of Economic Literature, forthcoming. + +Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. -Callaway B, Sant'Anna P (2021). “did: Difference in Differences.” R package version 2.1.2, https://bcallaway11.github.io/did/. +Callaway B, Sant'Anna P (2021). "Difference-in-differences with multiple time periods." Journal of Econometrics, 225(2), 200-230. -Chang NC (2020). "Double/debiased machine learning for difference-in-difference models." The Econometrics Journal, 177-191. +Chang N-C (2020). "Double/debiased machine learning for difference-in-difference models." The Econometrics Journal, 23(2), 177-191. +Chernozhukov V, Chetverikov D, Kato K (2013). "Gaussian approximations and multiplier bootstrap for maxima of sums of high-dimensional random vectors." Annals of Statistics, 41(6), 2786-2819. diff --git a/vignettes/articles/did.Rmd.txt b/vignettes/articles/did.Rmd.txt index 1033a4f..6a5f010 100644 --- a/vignettes/articles/did.Rmd.txt +++ b/vignettes/articles/did.Rmd.txt @@ -1,9 +1,9 @@ --- -title: "Diff-in-Diff with Double/Debiased Machine Learning" -description: "Tutorial on difference-in-difference estimation with double/debiased machine learning." +title: "Diff-in-Diff Estimation and Aggregation" +description: "Tutorial on DiD estimation with ddml_attgt, lincom aggregation, and uniform inference." output: rmarkdown::html_vignette vignette: > - %\VignetteIndexEntry{Diff-in-Diff with Double/Debiased Machine Learning} + %\VignetteIndexEntry{Diff-in-Diff Estimation and Aggregation} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- @@ -12,243 +12,276 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, comment = "#>", - fig.path = "figures/", - eval = TRUE + fig.path = "figures/did-", + eval = TRUE, + warning = FALSE, + message = FALSE ) ``` # Introduction -This article illustrates how ``ddml`` can complement the highly popular [``did``](https://bcallaway11.github.io/did/index.html) package to compute group-time average treatment effects under a _conditional_ parallel trends assumption. The result is a doubly-robust difference-in-difference estimator for staggered treatment adoption designs that leverages machine learning and (short-)stacking to flexibly control for covariates -- or: difference-in-difference with machine learning. +This article illustrates how ``ddml`` provides a fully self-contained pipeline for difference-in-differences estimation in staggered adoption designs. The workflow consists of four steps: -For an excellent introduction to differences-in-differences with multiple time periods, see also [this article](https://bcallaway11.github.io/did/articles/multi-period-did.html). For a detailed discussion of the relevant asymptotic theory for double/debiased machine learning difference-in-difference estimators see Chang (2020). +1. **Estimation** of group-time average treatment effects (GT-ATTs) via ``ddml_attgt``. +2. **Aggregation** into dynamic event-study parameters via ``lincom_weights_did`` and ``lincom``. +3. **Diagnostics** to inspect stacking weights and learner performance. +4. **Inference** including uniform confidence bands via the multiplier bootstrap, and event-study plots via ``plot``. -# Estimation using ``did``'s Default Estimator +This pipeline does not require the ``did`` package for inference or plotting. However, we begin by computing baseline estimates with ``did::att_gt`` for comparison. -For illustration, consider the data of Callaway and Sant'Anna (2020) on county-level teen employment rates from 2003-2007 for additional details. We are interested in the effect of treatment on the log-employment rate ``lemp`` and assume that parallel trends holds conditional on county population (``lpop`` is the log of county population). + +# Data + +We use the dataset of Callaway and Sant'Anna (2021) on county-level teen employment rates from 2003--2007. The outcome is log-employment (``lemp``) and we assume parallel trends hold conditional on log county population (``lpop``). ```{r} -# Load the did package +library(ddml) library(did) set.seed(588239) -# Print the data +# Load data data(mpdta) -head(mpdta) ``` -By default, the group-time average treatment effect estimator of the ``did`` package controls _linearly_ for additional covariates. (In particular, the propensity score is estimated using [logistic regression](https://github.com/pedrohcgs/DRDID/blob/master/R/drdid_panel.R#L96) and the outcome reduced form is estimated via [linear regression](https://github.com/pedrohcgs/DRDID/blob/master/R/drdid_panel.R#L107)). The below code snippet runs the default linear specification (similar to [this article](https://bcallaway11.github.io/did/articles/did-basics.html#an-example-with-real-data)). +``ddml_attgt`` takes data in wide format: an $n \times T$ outcome matrix, a time-invariant covariate matrix, and a group vector: + +```{r} +# Reshape to wide format +ids <- sort(unique(mpdta$countyreal)) +times <- sort(unique(mpdta$year)) +n <- length(ids) +T_ <- length(times) + +# Build outcome matrix (n x T_) +y <- matrix(NA_real_, n, T_) +for (j in seq_along(times)) { + sub <- mpdta[mpdta$year == times[j], ] + y[match(sub$countyreal, ids), j] <- sub$lemp +} + +# Extract time-invariant covariates and group membership +first_obs <- mpdta[match(ids, mpdta$countyreal), ] +G <- first_obs$first.treat +G[G == 0] <- Inf # ddml convention for never-treated +X <- as.matrix(first_obs[, "lpop", drop = FALSE]) + +cat("Units:", n, " Periods:", T_, " Groups:", length(unique(G))) +``` + + +# Baseline: ``did`` Package + +For comparison, we first estimate the GT-ATTs using the ``did`` package with linear controls. We set ``base_period = "universal"`` to match the base period convention used by ``ddml_attgt``: ```{r} -# Estimate group-time average treatment effects with covariates attgt_lm <- att_gt(yname = "lemp", gname = "first.treat", idname = "countyreal", tname = "year", xformla = ~lpop, + base_period = "universal", data = mpdta) - -# summarize the results -summary(attgt_lm) -``` - -The ``did`` package offers visualization methods using ``gglpot2``: - -```{r, fig.width=8, fig.height=10, fig.align='center', out.width="90%", dpi = 200, fig.cap="Diff-in-Diff Estimates."} -ggdid(attgt_lm, ylim = c(-.4, .4)) -``` - -Further, the group-time average treatment effects can easily be aggregated, for example, to estimate dynamic average treatment effects: - -```{r, fig.width=8,fig.height=5, fig.align='center', out.width="90%", dpi = 200, fig.cap="Dynamic Treatment Effect Estimates."} -# aggregate the group-time average treatment effects dyn_lm <- aggte(attgt_lm, type = "dynamic") summary(dyn_lm) -ggdid(dyn_lm, ylim = c(-.4, .4)) ``` -# Contructing a ``xgboost``-based Diff-in-Diff Estimator -Without additional _parametric_ functional form assumptions on the reduced form equations, it is _not_ guaranteed that the default ``att_gt`` estimator returns a convex combination of causal effects. This is because linear predictors do not necessarily correspond to the conditional expectation functions arising in the doubly-robust score of the group-time average treatment effect. The resulting misspecification error can then lead to negative weights in the aggregation of individual-level treatment effects. +# GT-ATT Estimation with ``ddml_attgt`` -Fortunately, a convex combination of causal effects can be guaranteed (without parametric functional form assumptions) when using machine learning (nonparametric) reduced form estimators. +We estimate GT-ATTs using ``ddml_attgt``. To validate against the ``did`` baseline, we start with OLS: -``ddml`` facilitates the use of a large set of machine learning reduced form estimators, including simultaneous considerations of multiple estimators via (short-)stacking. +```{r} +fit_ols <- ddml_attgt(y, X, t = times, G = G, + learners = list(what = ols), + learners_qX = list(what = mdl_glm), + sample_folds = 10, + silent = TRUE) +summary(fit_ols) +``` -To use ``ddml`` estimators with the ``did`` package, we can make use of the ``est_method`` argument of the ``att_gt`` function (see also ``?did::att_gt``). It is useful to construct this method in two steps: -1. A simple wrapper for ``ddml_att`` that returns the objects needed by ``att_gt`` -2. A second wrapper that hard-codes arguments passed to ``ddml_att`` +# Dynamic Aggregation via ``lincom`` -This two-step approach allows for cleaner code when considering multiple ddml-based estimators (as we do in this article). +The ``lincom_weights_did`` function constructs the contrast matrix $R$ and the influence function for the estimated weights. The output is passed directly to ``lincom`` for inference. For the dynamic type, both pre-treatment (placebo) and post-treatment event times are included: -The below code-snippet constructs a simple estimation method following step 1: ```{r} -# load the ddml package -library(ddml) - -# write a general wrapper for ddml_att -ddml_did_method <- function(y1, y0, D, covariates, ...) { - # Compute difference in outcomes - delta_y <- y1 - y0 - # Compute the ATT - att_fit <- ddml_att(y = delta_y, D = D, X = covariates, ...) - # Return results - inf.func <- att_fit$psi_b + att_fit$att * att_fit$psi_a - output <- list(ATT = att_fit$att, att.inf.func = inf.func) - return(output) -}#DDML_DID_METHOD +w_dyn <- lincom_weights_did(fit_ols, type = "dynamic") +lc_dyn <- lincom(fit_ols, R = w_dyn$R, + inf_func_R = w_dyn$inf_func_R, + labels = w_dyn$labels) +summary(lc_dyn) ``` -A potentially suitable machine learning reduced form estimator is gradient tree boosting (see also ``?mdl_xgboost``). The below code snippet completes the second wrapper by hard-coding both the learner and its arguments. Here, we consider 10-fold cross-fitting with a gradient tree boosting estimator (``eta`` is the learning rate, see also ``?mdl_xgboost``). +Pre-treatment event times (e < 0) serve as placebo tests: under the parallel trends assumption, these should be close to zero. -```{r} -my_did_xgboost <- function(y1, y0, D, covariates, ...) { - # Hard-code learners - learners = list(what = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 3), - early_stopping_rounds = 1)) - learners_DX = learners - - # Call the general ddml_did method w/ additional hard-coded arguments - ddml_did_method(y1, y0, D, covariates, - learners = learners, - learners_DX = learners_DX, - sample_folds = 10, - silent = TRUE) -}#MY_DID_XGBOOST +The ``plot`` method produces an event-study style coefficient plot: + +```{r, fig.width=7, fig.height=5, fig.align='center', out.width="90%", dpi = 200, fig.cap="Dynamic Treatment Effect Estimates (OLS)."} +plot(lc_dyn, uniform = TRUE, ylab = "ATT", main = "Dynamic ATT (OLS)") ``` -We can now use the reduced form estimator ``my_did_xgboost`` and pass it via the ``est_method`` argument: -```{r, fig.width=8, fig.height=10, fig.align='center', out.width="90%", dpi = 200, fig.cap="xgboost-based Diff-in-Diff Estimates."} -# estimate group-time average treatment effects with ddml -attgt_xgboost <- att_gt(yname = "lemp", - gname = "first.treat", - idname = "countyreal", - tname = "year", - xformla = ~lpop, - data = mpdta, - est_method = my_did_xgboost) -# summarize the results -summary(attgt_xgboost) +# Stacking-based Estimation -# plot the coefficients -ggdid(attgt_xgboost, ylim = c(-.4, .4)) -``` +We next leverage (short-)stacking to combine multiple base learners. Including OLS and logit ensures that the simpler specifications are never spuriously discarded: -Of course, use of the ``ddml``-based reduced form estimator still allows us to leverage the various other methods of the ``did`` package, including the construction (and visualization of) dynamic average treatment effects: +```{r} +# Outcome learners +learners_y <- list( + list(what = ols), + list(what = mdl_xgboost, + args = list(nrounds = 50, + params = list(eta = 0.1, max_depth = 1), + early_stopping_rounds = 1)), + list(what = mdl_xgboost, + args = list(nrounds = 50, + params = list(eta = 0.1, max_depth = 3), + early_stopping_rounds = 1)), + list(what = mdl_ranger, + args = list(num.trees = 100, max.depth = 5)), + list(what = mdl_ranger, + args = list(num.trees = 100, max.depth = 10))) + +# Propensity score learners +learners_ps <- list( + list(what = mdl_glm), + list(what = mdl_xgboost, + args = list(nrounds = 50, + params = list(eta = 0.1, max_depth = 1), + early_stopping_rounds = 1)), + list(what = mdl_xgboost, + args = list(nrounds = 50, + params = list(eta = 0.1, max_depth = 3), + early_stopping_rounds = 1)), + list(what = mdl_ranger, + args = list(num.trees = 100, max.depth = 5)), + list(what = mdl_ranger, + args = list(num.trees = 100, max.depth = 10))) + +# Estimate with short-stacking +fit_stack <- ddml_attgt(y, X, t = times, G = G, + learners = learners_y, + learners_qX = learners_ps, + sample_folds = 5, + ensemble_type = "nnls", + shortstack = TRUE, + silent = TRUE) +``` -```{r, fig.width=8,fig.height=5, fig.align='center', out.width="90%", dpi = 200, fig.cap="xgboost-based Dynamic Treatment Effect Estimates."} -# aggregate the group-time average treatment effects -dyn_xgboost <- aggte(attgt_xgboost, type = "dynamic") -summary(dyn_xgboost) -ggdid(dyn_xgboost, ylim = c(-.4, .4)) +```{r} +w_dyn_s <- lincom_weights_did(fit_stack, type = "dynamic") +lc_dyn_s <- lincom(fit_stack, R = w_dyn_s$R, + inf_func_R = w_dyn_s$inf_func_R, + labels = w_dyn_s$labels) +summary(lc_dyn_s) +``` +```{r, fig.width=7, fig.height=5, fig.align='center', out.width="90%", dpi = 200, fig.cap="Dynamic Treatment Effect Estimates (Stacking)."} +plot(lc_dyn_s, uniform = TRUE, ylab = "ATT", main = "Dynamic ATT (Stacking)") ``` -The gradient tree boosting-based ATT estimate is only slightly different from the ATT estimate using the linear estimator of the ``did`` package, however, it is statistically insignificant. -Given these two coefficients, is there a good reason to choose one over the other? +# Learner Diagnostics -It is ex-ante difficult to trade-off the potential bias from misspecification that the linear estimator suffers from with the potential bias from estimation error that the gradient tree boosting estimator may suffer from. ``ddml`` allows to resolve this conflict in a data-driven manner by simultaneous consideration of multiple machine learners via (short-)stacking. We turn to this in the next section. +The stacking weights reveal which learners contribute to the final estimates. We summarize the NNLS weights across all group-time cells for both the outcome and propensity score reduced forms: -# Contructing a Shortstacking-based Diff-in-Diff Estimator +```{r} +# Extract diagnostics +diag_stack <- diagnostics(fit_stack) + +# Helper: summarize stacking weights across (g,t) cells +summarize_weights <- function(diag, pattern) { + eqs <- grep(pattern, names(diag$tables), value = TRUE) + w_col <- grep("^weight_", names(diag$tables[[eqs[1]]]), + value = TRUE)[1] + w_mat <- sapply(eqs, function(eq) diag$tables[[eq]][[w_col]]) + learner_names <- diag$tables[[eqs[1]]]$learner + data.frame( + learner = learner_names, + min = round(apply(w_mat, 1, min), 4), + mean = round(apply(w_mat, 1, mean), 4), + max = round(apply(w_mat, 1, max), 4), + row.names = NULL) +} + +cat("Outcome reduced form---stacking weights:\n") +print(summarize_weights(diag_stack, ":y_X_D0$"), row.names = FALSE) + +cat("\nPropensity score---stacking weights:\n") +print(summarize_weights(diag_stack, ":D_X$"), row.names = FALSE) +``` -Instead of considering just a single machine learner -- that may or may not be suitable for the given application -- we can leverage (short-)stacking and simultaneously consider multiple machine learners. As in other settings, this substantially increases robustness to the underlying structure of the data. +In this application with a single covariate, the parametric learners (OLS/logit) receive the vast majority of the stacking weight---reassuring us that the default linear estimator is adequate here. -We construct a new wrapper for our ``ddml_did_method`` that hard-codes different reduced form estimators: -- linear or logistic regression -- gradient tree boosting with more and less regularization -- random forests with more and less regularization +# Comparing Results -The reduced form estimators are then optimally combined via non-negative least squares. Note that this specification also includes the linear control specifications considered by the default ``did`` learner, ensuring that machine learners are not spuriously selected. We leverage shortstacking to reduce computational time (see also `vignette("stacking")`). +We compare the dynamic treatment effects from the OLS, stacking, and ``did`` baseline estimators: ```{r} -my_did_stacking <- function(y1, y0, D, covariates, ...) { - # Hard-code learners for outcome reduced-form - learners = list(list(fun = ols), - list(fun = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 1), - early_stopping_rounds = 1)), - list(fun = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 3), - early_stopping_rounds = 1)), - list(fun = mdl_ranger, - args = list(num.trees = 1000, - max.depth = 1)), - list(fun = mdl_ranger, - args = list(num.trees = 1000, - max.depth = 20))) - # Hard-code learners for treatment reduced-form - learners_DX = list(list(fun = mdl_glm), - list(fun = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 1), - early_stopping_rounds = 1)), - list(fun = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 3), - early_stopping_rounds = 1)), - list(fun = mdl_ranger, - args = list(num.trees = 1000, - max.depth = 1)), - list(fun = mdl_ranger, - args = list(num.trees = 1000, - max.depth = 20))) - # Call the general ddml_did method w/ additional hard-coded arguments - ddml_did_method(y1, y0, D, covariates, - learners = learners, - learners_DX = learners_DX, - sample_folds = 10, - ensemble_type = "nnls", - shortstack = TRUE, - silent = TRUE) -}#MY_DID_STACKING +# Build comparison with all event times; base period e=-1 is 0 by definition +ols_full <- setNames(rep(0, length(dyn_lm$egt)), paste0("e=", dyn_lm$egt)) +ols_full[w_dyn$labels] <- coef(lc_dyn) +stack_full <- setNames(rep(0, length(dyn_lm$egt)), paste0("e=", dyn_lm$egt)) +stack_full[w_dyn_s$labels] <- coef(lc_dyn_s) +comparison <- data.frame( + event_time = paste0("e=", dyn_lm$egt), + did = round(dyn_lm$att.egt, 4), + ols = round(ols_full, 4), + stacking = round(stack_full, 4) +) +comparison$did[is.na(comparison$did)] <- 0 +print(comparison, row.names = FALSE) ``` -Finally, we recompute the group-time average treatment effects using our shortstacking estimator: -```{r, fig.width=8, fig.height=10, fig.align='center', out.width="90%", dpi = 200, fig.cap="Stacking-based Diff-in-Diff Estimates."} -# estimate group-time average treatment effects with ddml -attgt_stacking <- att_gt(yname = "lemp", - gname = "first.treat", - idname = "countyreal", - tname = "year", - xformla = ~lpop , - data = mpdta, - est_method = my_did_stacking) +# Repeated Resampling with Uniform Inference -# summarize the results -summary(attgt_stacking) +To account for sample-splitting variability, we can repeat cross-fitting several times and aggregate results. The ``ddml_replicate`` function provides this functionality. Combined with ``lincom``, we obtain aggregated dynamic treatment effects with uniform confidence bands: -# plot the coefficients -ggdid(attgt_stacking, ylim = c(-.4, .4)) +```{r} +fit_rep <- ddml_replicate( + ddml_attgt, + y = y, X = X, t = times, G = G, + learners = learners_y, + learners_qX = learners_ps, + sample_folds = 5, + ensemble_type = "nnls", + shortstack = TRUE, + resamples = 5, + silent = TRUE +) ``` -The results are largely similar to those of the default linear estimator of the ``did`` package, suggesting that the linear approximation of the reduced forms is sufficiently accurate. (Of course we didn't know that before -- now, at least, we can sleep easy!) -Other settings, in particular settings with multiple control variables, may show starker difference in the final estimates. +```{r} +# lincom on replicated fits +w_dyn_r <- lincom_weights_did(fit_rep, type = "dynamic") +lc_dyn_r <- lincom(fit_rep, R = w_dyn_r$R, + inf_func_R = w_dyn_r$inf_func_R, + labels = w_dyn_r$labels) +summary(lc_dyn_r) +``` -```{r, fig.width=8,fig.height=5, fig.align='center', out.width="90%", dpi = 200, fig.cap="Stacking-based Dynamic Treatment Effect Estimates."} -# aggregate the group-time average treatment effects -dyn_stacking <- aggte(attgt_stacking, type = "dynamic") -summary(dyn_stacking) -ggdid(dyn_stacking, ylim = c(-.4, .4)) +The plot method for replicated objects displays median-aggregated estimates with confidence bands. We can request uniform bands via ``uniform = TRUE``: +```{r, fig.width=7, fig.height=5, fig.align='center', out.width="90%", dpi = 200, fig.cap="Dynamic ATT with Uniform Confidence Bands."} +plot(lc_dyn_r, uniform = TRUE, + ylab = "ATT", main = "Dynamic ATT (Median, Uniform CI)") ``` +The uniform bands are wider than pointwise intervals, providing simultaneous coverage over all event times. Pointwise intervals are available for reference via ``uniform = FALSE`` (the default). # References -Callaway B, Sant'Anna P (2021). “Difference-in-differences with multiple time periods.” Journal of Econometrics, 200-230. +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, Wiemann T (2026). "An Introduction to Double/Debiased Machine Learning." Journal of Economic Literature, forthcoming. + +Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. -Callaway B, Sant'Anna P (2021). “did: Difference in Differences.” R package version 2.1.2, https://bcallaway11.github.io/did/. +Callaway B, Sant'Anna P (2021). "Difference-in-differences with multiple time periods." Journal of Econometrics, 225(2), 200-230. -Chang NC (2020). "Double/debiased machine learning for difference-in-difference models." The Econometrics Journal, 177-191. +Chang N-C (2020). "Double/debiased machine learning for difference-in-difference models." The Econometrics Journal, 23(2), 177-191. +Chernozhukov V, Chetverikov D, Kato K (2013). "Gaussian approximations and multiplier bootstrap for maxima of sums of high-dimensional random vectors." Annals of Statistics, 41(6), 2786-2819. diff --git a/vignettes/articles/example_401k.Rmd b/vignettes/articles/example_401k.Rmd index 10ab396..18598b0 100644 --- a/vignettes/articles/example_401k.Rmd +++ b/vignettes/articles/example_401k.Rmd @@ -27,7 +27,7 @@ library(ddml) set.seed(2410072) ``` -# Data construction +# Data Construction The 401K data considered here is from the Survey of Income and Program Participation (SIPP) from the year 1991. We use the data taken from the application in [Chernozhukov et al. (2018)](https://academic.oup.com/ectj/article/21/1/C1/5056401s}). @@ -50,7 +50,7 @@ X <- as.matrix(SIPP91[, c("age", "inc", "educ", "fsize", # Estimation using a Single Machine Learner -The simplest double/debiased machine learning estimator for the causal effect of 401k participation on financial assets considers a single machine learner to (nonparametrically) control for individual characteristics. We consider gradient boosting in the code snippet below (see ``?ddml_plm`` and ``?mdl_xgboost`` for details). +The simplest Double/Debiased Machine Learning estimator for the causal effect of 401k participation on financial assets considers a single machine learner to (nonparametrically) control for individual characteristics. We consider gradient boosting in the code snippet below (see ``?ddml_plm`` and ``?mdl_xgboost`` for details). A comparison with a simple multiple linear regression estimate indicates a difference in the point estimates of about one standard deviation, suggesting that there are at least some non-linearities present in the data. @@ -59,23 +59,49 @@ A comparison with a simple multiple linear regression estimate indicates a diffe # PLM with gradient boosting xgboost_fit <- ddml_plm(y = y, D = D, X = X, learners = list(what = mdl_xgboost, - args = list(nrounds = 300)), - sample_folds = 10, - silent = T) + args = list(nrounds = 50)), + sample_folds = 5, + silent = TRUE) summary(xgboost_fit) -#> PLM estimation results: -#> -#> , , single base learner +#> DDML estimation: Partially Linear Model +#> Obs: 9915 Folds: 5 #> -#> Estimate Std. Error t value Pr(>|t|) -#> (Intercept) -224 626 -0.357 7.21e-01 -#> D_r 13916 1604 8.678 4.03e-18 +#> Estimate Std. Error z value Pr(>|z|) +#> D1 13916 1544 9.01 <2e-16 *** +#> (Intercept) -541 636 -0.85 0.4 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 # Comparison to multiple linear regression lm_fit <- lm(y ~ D + X) summary(lm_fit) -#> Estimate Std. Error t value Pr(>|t|) -#> 1.160089e+04 1.345117e+03 8.624444e+00 7.428141e-18 +#> +#> Call: +#> lm(formula = y ~ D + X) +#> +#> Residuals: +#> Min 1Q Median 3Q Max +#> -507235 -17014 -2134 10406 1430000 +#> +#> Coefficients: +#> Estimate Std. Error t value Pr(>|t|) +#> (Intercept) -3.343e+04 4.265e+03 -7.837 5.1e-15 *** +#> D 1.160e+04 1.345e+03 8.624 < 2e-16 *** +#> Xage 6.351e+02 5.938e+01 10.696 < 2e-16 *** +#> Xinc 9.143e-01 3.015e-02 30.330 < 2e-16 *** +#> Xeduc -6.190e+02 2.278e+02 -2.717 0.006597 ** +#> Xfsize -1.007e+03 4.487e+02 -2.245 0.024776 * +#> Xmarr 9.172e+02 1.791e+03 0.512 0.608532 +#> Xtwoearn -1.936e+04 1.572e+03 -12.312 < 2e-16 *** +#> Xdb -4.915e+03 1.335e+03 -3.683 0.000232 *** +#> Xpira 2.892e+04 1.464e+03 19.748 < 2e-16 *** +#> Xhown 8.830e+02 1.320e+03 0.669 0.503420 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +#> +#> Residual standard error: 55580 on 9904 degrees of freedom +#> Multiple R-squared: 0.2352, Adjusted R-squared: 0.2344 +#> F-statistic: 304.6 on 10 and 9904 DF, p-value: < 2.2e-16 ``` # Estimation using Multiple Machine Learners @@ -87,47 +113,61 @@ The estimate is nearly identical to the estimate using just gradient boosting. ```r # Specify set of learners -learners <- list(list(fun = ols), - list(fun = mdl_glmnet), - list(fun = mdl_ranger, - args = list(num.trees = 250, +learners <- list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_ranger, + args = list(num.trees = 100, max.depth = 4)), - list(fun = mdl_ranger, - args = list(num.trees = 250, - max.depth = 12)), - list(fun = mdl_xgboost, - args = list(nrounds = 100)), - list(fun = mdl_xgboost, - args = list(nrounds = 300))) + list(what = mdl_ranger, + args = list(num.trees = 100, + max.depth = 8)), + list(what = mdl_xgboost, + args = list(nrounds = 50)), + list(what = mdl_xgboost, + args = list(nrounds = 150))) # PLM with short-stacking stacking_fit <- ddml_plm(y = y, D = D, X = X, learners = learners, ensemble_type = "nnls", - sample_folds = 10, - shortstack = T, - silent = T) + sample_folds = 5, + shortstack = TRUE, + silent = TRUE) summary(stacking_fit) -#> PLM estimation results: -#> -#> , , nnls +#> DDML estimation: Partially Linear Model +#> Obs: 9915 Folds: 5 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> (Intercept) -1627 538 -3.03 2.48e-03 -#> D_r 13636 1526 8.94 4.04e-19 +#> Estimate Std. Error z value Pr(>|z|) +#> D1 13769 1516 9.08 <2e-16 *** +#> (Intercept) -1194 537 -2.22 0.026 * +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` -To better understand which machine learners contribute to the final estimate, we can take a look at the assigned stacking weights. Each row corresponds to a base-learner (in chronological order) while the columns indicate the corresponding reduced form. The weights show that the two random forest estimators contribute the most in both reduced forms, followed by the lasso estimator. Neither gradient boosting nor linear regression are assigned substantial weight. +To better understand which machine learners contribute to the final estimate, we can inspect the stacking diagnostics. The weights show that the two random forest estimators contribute the most in both reduced forms, followed by the lasso estimator. Neither gradient boosting nor linear regression are assigned substantial weight. ```r -sapply(stacking_fit$weights, round, 4) -#> y_X D1_X -#> [1,] 0.0048 0.0197 -#> [2,] 0.2113 0.2817 -#> [3,] 0.2973 0.3400 -#> [4,] 0.5770 0.3504 -#> [5,] 0.0000 0.0000 -#> [6,] 0.0000 0.0238 +diagnostics(stacking_fit) +#> Stacking diagnostics: Partially Linear Model +#> Obs: 9915 +#> +#> y_X: +#> learner mspe r2 weight_nnls +#> learner_1 3125114171 0.2255 0.1926 +#> learner_2 3126016675 0.2253 0.0000 +#> learner_3 3045999690 0.2451 0.0000 +#> learner_4 2910378985 0.2787 0.7992 +#> learner_5 3435902221 0.1485 0.0824 +#> learner_6 3716930203 0.0789 0.0000 +#> +#> D1_X: +#> learner mspe r2 weight_nnls +#> learner_1 0.1725 0.1072 0.2333 +#> learner_2 0.1725 0.1071 0.0000 +#> learner_3 0.1717 0.1112 0.1916 +#> learner_4 0.1711 0.1144 0.5891 +#> learner_5 0.1860 0.0371 0.0000 +#> learner_6 0.2045 -0.0588 0.0000 ``` # Estimation with Different Sets of Control Variables @@ -152,90 +192,105 @@ X_extended <- 5:dim(X_c)[2] # indicators & series expansion ```r # Specify base learners with different sets of controls -learners <- list(list(fun = ols, +learners <- list(list(what = ols, assign_X = X_baseline), - list(fun = ols, + list(what = ols, assign_X = X_extended), - list(fun = mdl_glmnet, + list(what = mdl_glmnet, assign_X = X_extended), - list(fun = mdl_ranger, - args = list(num.trees = 250, + list(what = mdl_ranger, + args = list(num.trees = 100, max.depth = 4), assign_X = X_baseline), - list(fun = mdl_ranger, - args = list(num.trees = 250, - max.depth = 12), + list(what = mdl_ranger, + args = list(num.trees = 100, + max.depth = 8), assign_X = X_baseline), - list(fun = mdl_xgboost, - args = list(nrounds = 100), + list(what = mdl_xgboost, + args = list(nrounds = 50), assign_X = X_baseline), - list(fun = mdl_xgboost, - args = list(nrounds = 300), + list(what = mdl_xgboost, + args = list(nrounds = 150), assign_X = X_baseline)) # PLM with short-stacking stacking_fit <- ddml_plm(y = y, D = D, X = X_c, learners = learners, ensemble_type = "nnls", - sample_folds = 10, - shortstack = T, - silent = T) + sample_folds = 5, + shortstack = TRUE, + silent = TRUE) summary(stacking_fit) -#> PLM estimation results: -#> -#> , , nnls +#> DDML estimation: Partially Linear Model +#> Obs: 9915 Folds: 5 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> (Intercept) -512 533 -0.961 3.37e-01 -#> D_r 14363 1500 9.575 1.02e-21 +#> Estimate Std. Error z value Pr(>|z|) +#> D1 14120 1500 9.42 <2e-16 *** +#> (Intercept) -960 532 -1.80 0.071 . +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` -To assess whether the additional effort in expanding the control variables had an effect on the composition of the reduced form estimates, we can again inspect the stacking weights. Indeed, the new base learner that combines lasso with the polynomial expansion of the controls is assigned the largest weight, followed by the random forest estimators. +To assess whether the additional effort in expanding the control variables had an effect on the composition of the reduced form estimates, we can again inspect the stacking diagnostics. Indeed, the new base learner that combines lasso with the polynomial expansion of the controls is assigned the largest weight, followed by the random forest estimators. ```r -sapply(stacking_fit$weights, round, 4) -#> y_X D1_X -#> [1,] 0.0176 0.0000 -#> [2,] 0.0000 0.1219 -#> [3,] 0.7368 0.4056 -#> [4,] 0.0000 0.1693 -#> [5,] 0.2702 0.2613 -#> [6,] 0.0022 0.0522 -#> [7,] 0.0000 0.0048 +diagnostics(stacking_fit) +#> Stacking diagnostics: Partially Linear Model +#> Obs: 9915 +#> +#> y_X: +#> learner mspe r2 weight_nnls +#> learner_1 3125864729 0.2253 0.0000 +#> learner_2 2877766026 0.2868 0.0000 +#> learner_3 2858270329 0.2916 0.7204 +#> learner_4 3021160887 0.2513 0.0000 +#> learner_5 2926909974 0.2746 0.3365 +#> learner_6 4121257708 -0.0213 0.0000 +#> learner_7 4614176089 -0.1435 0.0000 +#> +#> D1_X: +#> learner mspe r2 weight_nnls +#> learner_1 0.1727 0.1062 0.0123 +#> learner_2 0.1719 0.1104 0.0370 +#> learner_3 0.1714 0.1130 0.3921 +#> learner_4 0.1718 0.1106 0.0773 +#> learner_5 0.1710 0.1147 0.3848 +#> learner_6 0.1825 0.0554 0.1035 +#> learner_7 0.2001 -0.0360 0.0038 ``` # Estimation with Continious and Binary Outcome and Treatment Variables Thus far, we have considered the same set of base learners for the reduced form of the outcome on controls and the reduced form of the endogenous variable on the controls. In contrast to net financial assets which is (approximately) continuous, participating in a 401k is a binary indicator. It may thus sensible to consider reduced form estimators with support on the unit-interval for the latter reduced form. For example, we could consider logistic regression instead of linear regression. -Equipped with the included ``mdl_glm`` wrapper for generalized linear models (see also ``?mdl_glm``), we now specify a second set of base-learners for the reduced form of the binary endogenous variable of interest on the controls. As in the previous section, we consider different sets of control variables as well. When estimating the double/debiased machine learning estimator, we pass the second set of base learners via the ``learners_DX`` argument. +Equipped with the included ``mdl_glm`` wrapper for generalized linear models (see also ``?mdl_glm``), we now specify a second set of base-learners for the reduced form of the binary endogenous variable of interest on the controls. As in the previous section, we consider different sets of control variables as well. When estimating the Double/Debiased Machine Learning estimator, we pass the second set of base learners via the ``learners_DX`` argument. ```r # Specify an additional set of learners for the reduced form E[D|X] -learners_DX <- list(list(fun = mdl_glm, +learners_DX <- list(list(what = mdl_glm, args = list(family = "binomial"), assign_X = X_baseline), - list(fun = mdl_glm, + list(what = mdl_glm, args = list(family = "binomial"), assign_X = X_extended), - list(fun = mdl_glmnet, + list(what = mdl_glmnet, args = list(family = "binomial"), assign_X = X_extended), - list(fun = mdl_ranger, - args = list(num.trees = 250, + list(what = mdl_ranger, + args = list(num.trees = 100, max.depth = 4), assign_X = X_baseline), - list(fun = mdl_ranger, - args = list(num.trees = 250, - max.depth = 12), + list(what = mdl_ranger, + args = list(num.trees = 100, + max.depth = 8), assign_X = X_baseline), - list(fun = mdl_xgboost, - args = list(nrounds = 100), + list(what = mdl_xgboost, + args = list(nrounds = 50), assign_X = X_baseline), - list(fun = mdl_xgboost, - args = list(nrounds = 300), + list(what = mdl_xgboost, + args = list(nrounds = 150), assign_X = X_baseline)) # PLM with short-stacking and different sets of learners @@ -243,33 +298,80 @@ stacking_fit <- ddml_plm(y = y, D = D, X = X_c, learners = learners, learners_DX = learners_DX, ensemble_type = "nnls", - sample_folds = 10, - shortstack = T, - silent = T) + sample_folds = 5, + shortstack = TRUE, + silent = TRUE) summary(stacking_fit) -#> PLM estimation results: -#> -#> , , nnls +#> DDML estimation: Partially Linear Model +#> Obs: 9915 Folds: 5 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> (Intercept) -487 535 -0.91 3.63e-01 -#> D_r 14097 1484 9.50 2.07e-21 +#> Estimate Std. Error z value Pr(>|z|) +#> D1 14025 1490 9.41 <2e-16 *** +#> (Intercept) -387 534 -0.72 0.47 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` -The weights associated with the new base learners are now slightly larger: +The diagnostics associated with the new base learners show slightly larger weights: ```r -sapply(stacking_fit$weights, round, 4) -#> y_X D1_X -#> [1,] 0.0132 0.0627 -#> [2,] 0.0000 0.2663 -#> [3,] 0.7411 0.0086 -#> [4,] 0.0000 0.4221 -#> [5,] 0.2690 0.2552 -#> [6,] 0.0000 0.0000 -#> [7,] 0.0000 0.0302 +diagnostics(stacking_fit) +#> Stacking diagnostics: Partially Linear Model +#> Obs: 9915 +#> +#> y_X: +#> learner mspe r2 weight_nnls +#> learner_1 3118730135 0.2271 0.0652 +#> learner_2 2902039913 0.2808 0.0000 +#> learner_3 2871909268 0.2883 0.8547 +#> learner_4 3089111001 0.2344 0.0000 +#> learner_5 3026275768 0.2500 0.0347 +#> learner_6 3906568364 0.0319 0.0656 +#> learner_7 4253407158 -0.0541 0.0000 +#> +#> D1_X: +#> learner mspe r2 weight_nnls +#> learner_1 0.1735 0.1020 0.0673 +#> learner_2 0.1717 0.1114 0.3660 +#> learner_3 0.1715 0.1125 0.0000 +#> learner_4 0.1718 0.1106 0.1588 +#> learner_5 0.1714 0.1127 0.3949 +#> learner_6 0.1856 0.0394 0.0203 +#> learner_7 0.2037 -0.0544 0.0000 +``` + +# Advanced: Rapid Refits with the Passthrough API + +Estimating multiple machine learners via cross-fitting can be computationally expensive. Suppose that, after inspecting ``stacking_fit`` above, you decide you additionally want to see the results if you had used the ``singlebest`` ensemble type instead of ``nnls``. + +Rather than waiting for all base learners to be refit from scratch, ``ddml`` allows you to extract the out-of-sample predictions from the initial fit and pass them directly into a new ``ddml_plm`` call via the ``fitted`` argument. + +Because ``stacking_fit`` already contains the cross-fitted predictions and sample splits in its ``fitted`` component, we can bypass the estimation step entirely. + + +```r +# Recompute the structural parameter instantly using 'singlebest' +stacking_refit <- ddml_plm( + y = y, D = D, X = X_c, + learners = learners, + learners_DX = learners_DX, + ensemble_type = "singlebest", + sample_folds = 5, + fitted = stacking_fit$fitted, # Pass the predictions directly + splits = stacking_fit$splits, # Pass the splits used directly + silent = TRUE +) +summary(stacking_refit) +#> DDML estimation: Partially Linear Model +#> Obs: 9915 Folds: 5 +#> +#> Estimate Std. Error z value Pr(>|z|) +#> D1 13963.03 1492.40 9.36 <2e-16 *** +#> (Intercept) -5.36 535.14 -0.01 0.99 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` # Bonus: Instrumental Variable Estimation @@ -289,28 +391,57 @@ stacking_IV_fit <- ddml_pliv(y = y, D = D, Z = Z, X = X_c, learners_DX = learners_DX, learners_ZX = learners_DX, ensemble_type = "nnls", - sample_folds = 10, - shortstack = T, - silent = T) + sample_folds = 5, + shortstack = TRUE, + silent = TRUE) summary(stacking_IV_fit) -#> PLIV estimation results: -#> -#> , , nnls +#> DDML estimation: Partially Linear IV Model +#> Obs: 9915 Folds: 5 Stacking: short-stack +#> +#> Estimate Std. Error z value Pr(>|z|) +#> D1 13151 1888 6.96 3.3e-12 *** +#> (Intercept) -966 530 -1.83 0.068 . +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +``` + +The stacking diagnostics for the IV model: + + +```r +diagnostics(stacking_IV_fit) +#> Stacking diagnostics: Partially Linear IV Model +#> Obs: 9915 +#> +#> y_X: +#> learner mspe r2 weight_nnls +#> learner_1 3120947021 0.2266 0.0000 +#> learner_2 2864489352 0.2901 0.0000 +#> learner_3 2836320542 0.2971 0.7226 +#> learner_4 3061626328 0.2413 0.0000 +#> learner_5 2914205541 0.2778 0.2624 +#> learner_6 3518126794 0.1281 0.0626 +#> learner_7 3808805316 0.0561 0.0099 +#> +#> D1_X: +#> learner mspe r2 weight_nnls +#> learner_1 0.1736 0.1013 0.0370 +#> learner_2 0.1718 0.1110 0.2420 +#> learner_3 0.1714 0.1126 0.1068 +#> learner_4 0.1719 0.1102 0.0433 +#> learner_5 0.1709 0.1152 0.5302 +#> learner_6 0.1840 0.0478 0.0469 +#> learner_7 0.2024 -0.0475 0.0000 #> -#> Estimate Std. Error t value Pr(>|t|) -#> (Intercept) -776 531 -1.46 1.44e-01 -#> D_r 12987 1872 6.94 3.97e-12 - -# Stacking weights associated with each base learner -sapply(stacking_IV_fit$weights, round, 4) -#> y_X D1_X Z1_X -#> [1,] 0.0000 0.0647 0.0000 -#> [2,] 0.0000 0.2271 0.2414 -#> [3,] 0.7474 0.0080 0.0157 -#> [4,] 0.0000 0.4030 0.5337 -#> [5,] 0.2953 0.3036 0.2501 -#> [6,] 0.0000 0.0351 0.0000 -#> [7,] 0.0000 0.0000 0.0000 +#> Z1_X: +#> learner mspe r2 weight_nnls +#> learner_1 0.2014 0.1375 0.0000 +#> learner_2 0.1973 0.1550 0.3248 +#> learner_3 0.1972 0.1555 0.0000 +#> learner_4 0.1977 0.1533 0.0235 +#> learner_5 0.1959 0.1608 0.6553 +#> learner_6 0.2121 0.0916 0.0000 +#> learner_7 0.2313 0.0092 0.0000 ``` diff --git a/vignettes/articles/example_401k.Rmd.txt b/vignettes/articles/example_401k.Rmd.txt index 8237bbf..ee08555 100644 --- a/vignettes/articles/example_401k.Rmd.txt +++ b/vignettes/articles/example_401k.Rmd.txt @@ -11,7 +11,9 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, comment = "#>", - eval = TRUE + eval = TRUE, + warning = FALSE, + message = FALSE ) ``` @@ -32,7 +34,7 @@ library(ddml) set.seed(2410072) ``` -# Data construction +# Data Construction The 401K data considered here is from the Survey of Income and Program Participation (SIPP) from the year 1991. We use the data taken from the application in [Chernozhukov et al. (2018)](https://academic.oup.com/ectj/article/21/1/C1/5056401s}). @@ -53,7 +55,7 @@ X <- as.matrix(SIPP91[, c("age", "inc", "educ", "fsize", # Estimation using a Single Machine Learner -The simplest double/debiased machine learning estimator for the causal effect of 401k participation on financial assets considers a single machine learner to (nonparametrically) control for individual characteristics. We consider gradient boosting in the code snippet below (see ``?ddml_plm`` and ``?mdl_xgboost`` for details). +The simplest Double/Debiased Machine Learning estimator for the causal effect of 401k participation on financial assets considers a single machine learner to (nonparametrically) control for individual characteristics. We consider gradient boosting in the code snippet below (see ``?ddml_plm`` and ``?mdl_xgboost`` for details). A comparison with a simple multiple linear regression estimate indicates a difference in the point estimates of about one standard deviation, suggesting that there are at least some non-linearities present in the data. @@ -61,9 +63,9 @@ A comparison with a simple multiple linear regression estimate indicates a diffe # PLM with gradient boosting xgboost_fit <- ddml_plm(y = y, D = D, X = X, learners = list(what = mdl_xgboost, - args = list(nrounds = 300)), - sample_folds = 10, - silent = T) + args = list(nrounds = 50)), + sample_folds = 5, + silent = TRUE) summary(xgboost_fit) # Comparison to multiple linear regression @@ -79,32 +81,32 @@ The estimate is nearly identical to the estimate using just gradient boosting. ```{r} # Specify set of learners -learners <- list(list(fun = ols), - list(fun = mdl_glmnet), - list(fun = mdl_ranger, - args = list(num.trees = 250, +learners <- list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_ranger, + args = list(num.trees = 100, max.depth = 4)), - list(fun = mdl_ranger, - args = list(num.trees = 250, - max.depth = 12)), - list(fun = mdl_xgboost, - args = list(nrounds = 100)), - list(fun = mdl_xgboost, - args = list(nrounds = 300))) + list(what = mdl_ranger, + args = list(num.trees = 100, + max.depth = 8)), + list(what = mdl_xgboost, + args = list(nrounds = 50)), + list(what = mdl_xgboost, + args = list(nrounds = 150))) # PLM with short-stacking stacking_fit <- ddml_plm(y = y, D = D, X = X, learners = learners, ensemble_type = "nnls", - sample_folds = 10, - shortstack = T, - silent = T) + sample_folds = 5, + shortstack = TRUE, + silent = TRUE) summary(stacking_fit) ``` -To better understand which machine learners contribute to the final estimate, we can take a look at the assigned stacking weights. Each row corresponds to a base-learner (in chronological order) while the columns indicate the corresponding reduced form. The weights show that the two random forest estimators contribute the most in both reduced forms, followed by the lasso estimator. Neither gradient boosting nor linear regression are assigned substantial weight. +To better understand which machine learners contribute to the final estimate, we can inspect the stacking diagnostics. The weights show that the two random forest estimators contribute the most in both reduced forms, followed by the lasso estimator. Neither gradient boosting nor linear regression are assigned substantial weight. ```{r} -sapply(stacking_fit$weights, round, 4) +diagnostics(stacking_fit) ``` # Estimation with Different Sets of Control Variables @@ -127,73 +129,73 @@ X_extended <- 5:dim(X_c)[2] # indicators & series expansion ```{r} # Specify base learners with different sets of controls -learners <- list(list(fun = ols, +learners <- list(list(what = ols, assign_X = X_baseline), - list(fun = ols, + list(what = ols, assign_X = X_extended), - list(fun = mdl_glmnet, + list(what = mdl_glmnet, assign_X = X_extended), - list(fun = mdl_ranger, - args = list(num.trees = 250, + list(what = mdl_ranger, + args = list(num.trees = 100, max.depth = 4), assign_X = X_baseline), - list(fun = mdl_ranger, - args = list(num.trees = 250, - max.depth = 12), + list(what = mdl_ranger, + args = list(num.trees = 100, + max.depth = 8), assign_X = X_baseline), - list(fun = mdl_xgboost, - args = list(nrounds = 100), + list(what = mdl_xgboost, + args = list(nrounds = 50), assign_X = X_baseline), - list(fun = mdl_xgboost, - args = list(nrounds = 300), + list(what = mdl_xgboost, + args = list(nrounds = 150), assign_X = X_baseline)) # PLM with short-stacking stacking_fit <- ddml_plm(y = y, D = D, X = X_c, learners = learners, ensemble_type = "nnls", - sample_folds = 10, - shortstack = T, - silent = T) + sample_folds = 5, + shortstack = TRUE, + silent = TRUE) summary(stacking_fit) ``` -To assess whether the additional effort in expanding the control variables had an effect on the composition of the reduced form estimates, we can again inspect the stacking weights. Indeed, the new base learner that combines lasso with the polynomial expansion of the controls is assigned the largest weight, followed by the random forest estimators. +To assess whether the additional effort in expanding the control variables had an effect on the composition of the reduced form estimates, we can again inspect the stacking diagnostics. Indeed, the new base learner that combines lasso with the polynomial expansion of the controls is assigned the largest weight, followed by the random forest estimators. ```{r} -sapply(stacking_fit$weights, round, 4) +diagnostics(stacking_fit) ``` # Estimation with Continious and Binary Outcome and Treatment Variables Thus far, we have considered the same set of base learners for the reduced form of the outcome on controls and the reduced form of the endogenous variable on the controls. In contrast to net financial assets which is (approximately) continuous, participating in a 401k is a binary indicator. It may thus sensible to consider reduced form estimators with support on the unit-interval for the latter reduced form. For example, we could consider logistic regression instead of linear regression. -Equipped with the included ``mdl_glm`` wrapper for generalized linear models (see also ``?mdl_glm``), we now specify a second set of base-learners for the reduced form of the binary endogenous variable of interest on the controls. As in the previous section, we consider different sets of control variables as well. When estimating the double/debiased machine learning estimator, we pass the second set of base learners via the ``learners_DX`` argument. +Equipped with the included ``mdl_glm`` wrapper for generalized linear models (see also ``?mdl_glm``), we now specify a second set of base-learners for the reduced form of the binary endogenous variable of interest on the controls. As in the previous section, we consider different sets of control variables as well. When estimating the Double/Debiased Machine Learning estimator, we pass the second set of base learners via the ``learners_DX`` argument. ```{r} # Specify an additional set of learners for the reduced form E[D|X] -learners_DX <- list(list(fun = mdl_glm, +learners_DX <- list(list(what = mdl_glm, args = list(family = "binomial"), assign_X = X_baseline), - list(fun = mdl_glm, + list(what = mdl_glm, args = list(family = "binomial"), assign_X = X_extended), - list(fun = mdl_glmnet, + list(what = mdl_glmnet, args = list(family = "binomial"), assign_X = X_extended), - list(fun = mdl_ranger, - args = list(num.trees = 250, + list(what = mdl_ranger, + args = list(num.trees = 100, max.depth = 4), assign_X = X_baseline), - list(fun = mdl_ranger, - args = list(num.trees = 250, - max.depth = 12), + list(what = mdl_ranger, + args = list(num.trees = 100, + max.depth = 8), assign_X = X_baseline), - list(fun = mdl_xgboost, - args = list(nrounds = 100), + list(what = mdl_xgboost, + args = list(nrounds = 50), assign_X = X_baseline), - list(fun = mdl_xgboost, - args = list(nrounds = 300), + list(what = mdl_xgboost, + args = list(nrounds = 150), assign_X = X_baseline)) # PLM with short-stacking and different sets of learners @@ -201,17 +203,40 @@ stacking_fit <- ddml_plm(y = y, D = D, X = X_c, learners = learners, learners_DX = learners_DX, ensemble_type = "nnls", - sample_folds = 10, - shortstack = T, - silent = T) + sample_folds = 5, + shortstack = TRUE, + silent = TRUE) summary(stacking_fit) ``` -The weights associated with the new base learners are now slightly larger: +The diagnostics associated with the new base learners show slightly larger weights: ```{r} -sapply(stacking_fit$weights, round, 4) +diagnostics(stacking_fit) +``` + +# Advanced: Rapid Refits with the Passthrough API + +Estimating multiple machine learners via cross-fitting can be computationally expensive. Suppose that, after inspecting ``stacking_fit`` above, you decide you additionally want to see the results if you had used the ``singlebest`` ensemble type instead of ``nnls``. + +Rather than waiting for all base learners to be refit from scratch, ``ddml`` allows you to extract the out-of-sample predictions from the initial fit and pass them directly into a new ``ddml_plm`` call via the ``fitted`` argument. + +Because ``stacking_fit`` already contains the cross-fitted predictions and sample splits in its ``fitted`` component, we can bypass the estimation step entirely. + +```{r} +# Recompute the structural parameter instantly using 'singlebest' +stacking_refit <- ddml_plm( + y = y, D = D, X = X_c, + learners = learners, + learners_DX = learners_DX, + ensemble_type = "singlebest", + sample_folds = 5, + fitted = stacking_fit$fitted, # Pass the predictions directly + splits = stacking_fit$splits, # Pass the splits used directly + silent = TRUE +) +summary(stacking_refit) ``` # Bonus: Instrumental Variable Estimation @@ -230,13 +255,16 @@ stacking_IV_fit <- ddml_pliv(y = y, D = D, Z = Z, X = X_c, learners_DX = learners_DX, learners_ZX = learners_DX, ensemble_type = "nnls", - sample_folds = 10, - shortstack = T, - silent = T) + sample_folds = 5, + shortstack = TRUE, + silent = TRUE) summary(stacking_IV_fit) +``` -# Stacking weights associated with each base learner -sapply(stacking_IV_fit$weights, round, 4) +The stacking diagnostics for the IV model: + +```{r} +diagnostics(stacking_IV_fit) ``` diff --git a/vignettes/articles/example_BLP95.Rmd b/vignettes/articles/example_BLP95.Rmd index 469cad9..410eeff 100644 --- a/vignettes/articles/example_BLP95.Rmd +++ b/vignettes/articles/example_BLP95.Rmd @@ -17,7 +17,7 @@ This article revisits the empirical example of Chernozhukov, Hansen, and Spindle (CHS2015, hereafter), which extends the instruments of Berry, Levinsohn, and Pakes (1995) (BLP1995, hereafter) and applies an instrument selection procedure based on the lasso. We consider the same instrument extension -and apply double/debiased machine learning with short-stacking that combines conventional +and apply Double/Debiased Machine Learning with short-stacking that combines conventional linear estimators with computational alternatives including lasso-based approaches, random forests, and gradient boosting. @@ -137,7 +137,7 @@ round(summary(tsls_L_fit)$coefficients[2, ], 4) # Estimating the Flexible Partially Linear IV Model with CV-Lasso -Given the large set of controls and instruments in the expanded set relative to the moderate sample size, it is reasonable to consider regularized estimators. A frequent choice with many variables are lasso-based estimators. Below, we combine double/debiased machine learning with lasso selection of instruments and controls. (See ``?mdl_glmnet`` and ``?ddml_fpliv`` for details.) +Given the large set of controls and instruments in the expanded set relative to the moderate sample size, it is reasonable to consider regularized estimators. A frequent choice with many variables are lasso-based estimators. Below, we combine Double/Debiased Machine Learning with lasso selection of instruments and controls. (See ``?mdl_glmnet`` and ``?ddml_fpliv`` for details.) ```r @@ -148,11 +148,17 @@ learner <- list(what = mdl_glmnet) lasso_fit <- ddml_fpliv(y, D = D, Z = ZL, X = XL, learners = learner, - sample_folds = 10, - silent = T) -round(summary(lasso_fit)[2, , 1], 4) -#> Estimate Std. Error t value Pr(>|t|) -#> -0.1473 0.0090 -16.3142 0.0000 + sample_folds = 5, + silent = TRUE) +summary(lasso_fit) +#> DDML estimation: Flexible Partially Linear IV Model +#> Obs: 2217 Folds: 5 +#> +#> Estimate Std. Error z value Pr(>|z|) +#> price -0.144870 0.008810 -16.44 <2e-16 *** +#> (Intercept) 0.000712 0.022806 0.03 0.98 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` # Estimating the Flexible Partially Linear IV Model with Multiple Learners @@ -170,27 +176,27 @@ set_X <- 1:ncol(X); set_XL <- setdiff(c(1:ncol(X_c)), set_X) set_Z <- 1:ncol(Z); set_ZL <- setdiff(c(1:ncol(Z_c)), set_Z) # Base learners -learners <- list(list(fun = ols, # ols with the baseline set +learners <- list(list(what = ols, # ols with the baseline set assign_X = set_X, assign_Z = set_Z), - list(fun = ols, # ols with the extended set + list(what = ols, # ols with the extended set assign_X = set_XL, assign_Z = set_ZL), - list(fun = mdl_glmnet, # lasso with the extended set + list(what = mdl_glmnet, # lasso with the extended set args = list(alpha = 1), assign_X = set_XL, assign_Z = set_ZL), - list(fun = mdl_glmnet, # ridge with the extended set + list(what = mdl_glmnet, # ridge with the extended set args = list(alpha = 0), assign_X = set_XL, assign_Z = set_ZL), - list(fun = mdl_ranger, # random forests with the baseline set - args = list(num.trees = 1000, + list(what = mdl_ranger, # random forests with the baseline set + args = list(num.trees = 100, min.node.size = 10), assign_X = set_X, assign_Z = set_Z), - list(fun = mdl_xgboost, # boosted trees with the baseline set - args = list(nrounds = 300), + list(what = mdl_xgboost, # boosted trees with the baseline set + args = list(nrounds = 50), assign_X = set_X, assign_Z = set_Z)) @@ -199,27 +205,55 @@ stacking_fit <- ddml_fpliv(y, D = D, Z = Z_c, X = X_c, learners = learners, ensemble_type = c("nnls1"), - shortstack = T, - sample_folds = 10, - silent = T) -t(round(summary(stacking_fit), 4)[2, , ]) -#> Estimate Std. Error t value Pr(>|t|) -#> [1,] -0.0982 0.0092 -10.7008 0 + shortstack = TRUE, + sample_folds = 5, + silent = TRUE) +summary(stacking_fit) +#> DDML estimation: Flexible Partially Linear IV Model +#> Obs: 2217 Folds: 5 Stacking: short-stack +#> +#> Estimate Std. Error z value Pr(>|z|) +#> price -0.09812 0.00967 -10.15 <2e-16 *** +#> (Intercept) 0.00223 0.02035 0.11 0.91 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` Interestingly, the coefficient is closer to the OLS estimates than to the TSLS estimates (with or without lasso)! -To better understand the composition of the final estimator, it is often useful to inspect the stacking weights. These may readily be retrieved from the fitted object. Here, we see that the boosted trees and the random forest learners have been assigned the most weight in the cross validation informed ensemble procedures. The linear methods -- ols, lasso, and ridge -- do not contribute substantially to the final estimates, suggesting that the user-defined expansions of the controls and instruments does little to improve bias and precision. +To better understand the composition of the final estimator, it is often useful to inspect the stacking diagnostics. Here, we see that the boosted trees and the random forest learners have been assigned the most weight. The linear methods -- ols, lasso, and ridge -- do not contribute substantially to the final estimates, suggesting that the user-defined expansions of the controls and instruments does little to improve bias and precision. ```r -sapply(stacking_fit$weights, round, 4) -#> y_X D1_X D1_XZ -#> [1,] 0.0000 0.00 0.0000 -#> [2,] 0.0000 0.00 0.0000 -#> [3,] 0.0000 0.00 0.0000 -#> [4,] 0.0000 0.00 0.0000 -#> [5,] 0.4394 0.45 0.3804 -#> [6,] 0.5606 0.55 0.6196 +diagnostics(stacking_fit) +#> Stacking diagnostics: Flexible Partially Linear IV Model +#> Obs: 2217 +#> +#> y_X: +#> learner mspe r2 weight_nnls1 +#> learner_1 1.4341 0.2488 0.0000 +#> learner_2 1.3458 0.2950 0.0000 +#> learner_3 1.3543 0.2905 0.0000 +#> learner_4 1.3850 0.2744 0.0000 +#> learner_5 1.1000 0.4237 0.3525 +#> learner_6 1.0350 0.4578 0.6475 +#> +#> D1_X: +#> learner mspe r2 weight_nnls1 +#> learner_1 32.8790 0.5599 0.0000 +#> learner_2 25.9267 0.6530 0.0000 +#> learner_3 25.9418 0.6528 0.0553 +#> learner_4 28.2471 0.6219 0.0000 +#> learner_5 16.9611 0.7730 0.1252 +#> learner_6 13.4904 0.8194 0.8195 +#> +#> D1_XZ: +#> learner mspe r2 weight_nnls1 +#> learner_1 28.1808 0.6228 0.0000 +#> learner_2 20.3428 0.7277 0.0000 +#> learner_3 18.3504 0.7544 0.0080 +#> learner_4 23.9814 0.6790 0.0000 +#> learner_5 10.2051 0.8634 0.3372 +#> learner_6 8.9730 0.8799 0.6548 ``` # Elasticities @@ -249,16 +283,16 @@ compute_inelastic_demand(tsls_fit$coef[2]) compute_inelastic_demand(tsls_L_fit$coef[2]) #> [1] 896 ``` -Double/debiased machine learning estimates using only a single lasso base learner suggest the smallest number of inelastic products. In stark contrast, the estimates based on multiple machine learners suggest a number closer to the intial OLS estimates. +Double/Debiased Machine Learning estimates using only a single lasso base learner suggest the smallest number of inelastic products. In stark contrast, the estimates based on multiple machine learners suggest a number closer to the initial OLS estimates. ```r # ddml-lasso implied number of products with inelastic demand -compute_inelastic_demand(lasso_fit$coef) -#> [1] 596 +compute_inelastic_demand(coef(lasso_fit)) +#> [1] 1416 # ddml-stacking implied number of products with inelastic demand -compute_inelastic_demand(stacking_fit$coef) -#> [1] 1417 +compute_inelastic_demand(coef(stacking_fit)) +#> [1] 1829 ``` # Bonus: Post-Lasso Estimates without Sample-Splitting @@ -281,7 +315,7 @@ summary(rlassoIV_fit) #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` -The coefficient is drastically different from previous estimates, including the double/debaised machine learning estimates that included lasso-based approaches. +The coefficient is drastically different from previous estimates, including the Double/Debiased Machine Learning estimates that included lasso-based approaches. To gain some insight into potential causes for these differences, we check which instruments and controls were selected by the lasso procedure. Not surprisingly, lasso with a plug-in penalty selects only very few instruments and controls. @@ -294,39 +328,59 @@ Xr_ <- XL[, which(rlassoIV_fit$selected[49:length(rlassoIV_fit$selected)])] dim(Xr_)[2] #> [1] 6 ``` -From the stacking weights above, we know that the double/debaised machine learning estimator assigns most weight to boosted trees. In contrast to lasso-based estimates, boosted trees adaptively create interactions from their input variables, allowing for rich non-linearities in the final predictions. It thus makes sense to check whether the stark differences between the rlasso-based IV estimates above and the stacking estimates is primarily due to potential non-linearities as opposed to the specific instrument and control variables that were selected. The below code snippet re-estimates the stacking learner with the pre-selected set of controls and instruments. +From the stacking weights above, we know that the Double/Debiased Machine Learning estimator assigns most weight to boosted trees. In contrast to lasso-based estimates, boosted trees adaptively create interactions from their input variables, allowing for rich non-linearities in the final predictions. It thus makes sense to check whether the stark differences between the rlasso-based IV estimates above and the stacking estimates is primarily due to potential non-linearities as opposed to the specific instrument and control variables that were selected. The below code snippet re-estimates the stacking learner with the pre-selected set of controls and instruments. ```r # Base learner -learner <- list(list(fun = ols), - list(fun = mdl_xgboost, - args = list(nrounds = 300))) +learner <- list(list(what = ols), + list(what = mdl_xgboost, + args = list(nrounds = 50))) # Compute short-stacked IV estimate stacking_r_fit <- ddml_fpliv(y, D = D, Z = Zr_, X = Xr_, learners = learner, ensemble_type = c("nnls1"), - shortstack = T, - sample_folds = 10, - silent = T) -round(summary(stacking_r_fit)[2, , 1], 4) -#> Estimate Std. Error t value Pr(>|t|) -#> -0.1044 0.0128 -8.1682 0.0000 + shortstack = TRUE, + sample_folds = 5, + silent = TRUE) +summary(stacking_r_fit) +#> DDML estimation: Flexible Partially Linear IV Model +#> Obs: 2217 Folds: 5 Stacking: short-stack +#> +#> Estimate Std. Error z value Pr(>|z|) +#> price -0.10628 0.01316 -8.08 6.5e-16 *** +#> (Intercept) 0.00425 0.02189 0.19 0.85 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` -The similarity of the coefficient estimates to the initial stacking estimates suggest seems that adaptively created interactions are indeed the key driver between the coefficient differences. This is further confirmed by the stacking weights, which again place substantial weight on the boosted trees. +The similarity of the coefficient estimates to the initial stacking estimates suggests that adaptively created interactions are indeed the key driver between the coefficient differences. This is further confirmed by the stacking diagnostics, which again place substantial weight on the boosted trees. ```r -sapply(stacking_r_fit$weights, round, 4) -#> y_X D1_X D1_XZ -#> [1,] 0.08 0.1287 0.0439 -#> [2,] 0.92 0.8713 0.9561 +diagnostics(stacking_r_fit) +#> Stacking diagnostics: Flexible Partially Linear IV Model +#> Obs: 2217 +#> +#> y_X: +#> learner mspe r2 weight_nnls1 +#> learner_1 1.4843 0.2224 0.2298 +#> learner_2 1.1869 0.3782 0.7702 +#> +#> D1_X: +#> learner mspe r2 weight_nnls1 +#> learner_1 29.7015 0.6025 0.1121 +#> learner_2 14.2630 0.8091 0.8879 +#> +#> D1_XZ: +#> learner mspe r2 weight_nnls1 +#> learner_1 28.2924 0.6213 0.0725 +#> learner_2 10.4439 0.8602 0.9275 ``` -The example thus highlights the importance of considering multiple machine learners for robustness and illustrates the usefulness of double/debiased machine learning with stacking as a practical solution. +The example thus highlights the importance of considering multiple machine learners for robustness and illustrates the usefulness of Double/Debiased Machine Learning with stacking as a practical solution. # References diff --git a/vignettes/articles/example_BLP95.Rmd.txt b/vignettes/articles/example_BLP95.Rmd.txt index c4a7778..6962363 100644 --- a/vignettes/articles/example_BLP95.Rmd.txt +++ b/vignettes/articles/example_BLP95.Rmd.txt @@ -12,7 +12,9 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, comment = "#>", - eval = TRUE + eval = TRUE, + warning = FALSE, + message = FALSE ) ``` @@ -23,7 +25,7 @@ This article revisits the empirical example of Chernozhukov, Hansen, and Spindle (CHS2015, hereafter), which extends the instruments of Berry, Levinsohn, and Pakes (1995) (BLP1995, hereafter) and applies an instrument selection procedure based on the lasso. We consider the same instrument extension -and apply double/debiased machine learning with short-stacking that combines conventional +and apply Double/Debiased Machine Learning with short-stacking that combines conventional linear estimators with computational alternatives including lasso-based approaches, random forests, and gradient boosting. @@ -125,7 +127,7 @@ round(summary(tsls_L_fit)$coefficients[2, ], 4) # Estimating the Flexible Partially Linear IV Model with CV-Lasso -Given the large set of controls and instruments in the expanded set relative to the moderate sample size, it is reasonable to consider regularized estimators. A frequent choice with many variables are lasso-based estimators. Below, we combine double/debiased machine learning with lasso selection of instruments and controls. (See ``?mdl_glmnet`` and ``?ddml_fpliv`` for details.) +Given the large set of controls and instruments in the expanded set relative to the moderate sample size, it is reasonable to consider regularized estimators. A frequent choice with many variables are lasso-based estimators. Below, we combine Double/Debiased Machine Learning with lasso selection of instruments and controls. (See ``?mdl_glmnet`` and ``?ddml_fpliv`` for details.) ```{r} # Base learner @@ -135,9 +137,9 @@ learner <- list(what = mdl_glmnet) lasso_fit <- ddml_fpliv(y, D = D, Z = ZL, X = XL, learners = learner, - sample_folds = 10, - silent = T) -round(summary(lasso_fit)[2, , 1], 4) + sample_folds = 5, + silent = TRUE) +summary(lasso_fit) ``` # Estimating the Flexible Partially Linear IV Model with Multiple Learners @@ -154,27 +156,27 @@ set_X <- 1:ncol(X); set_XL <- setdiff(c(1:ncol(X_c)), set_X) set_Z <- 1:ncol(Z); set_ZL <- setdiff(c(1:ncol(Z_c)), set_Z) # Base learners -learners <- list(list(fun = ols, # ols with the baseline set +learners <- list(list(what = ols, # ols with the baseline set assign_X = set_X, assign_Z = set_Z), - list(fun = ols, # ols with the extended set + list(what = ols, # ols with the extended set assign_X = set_XL, assign_Z = set_ZL), - list(fun = mdl_glmnet, # lasso with the extended set + list(what = mdl_glmnet, # lasso with the extended set args = list(alpha = 1), assign_X = set_XL, assign_Z = set_ZL), - list(fun = mdl_glmnet, # ridge with the extended set + list(what = mdl_glmnet, # ridge with the extended set args = list(alpha = 0), assign_X = set_XL, assign_Z = set_ZL), - list(fun = mdl_ranger, # random forests with the baseline set - args = list(num.trees = 1000, + list(what = mdl_ranger, # random forests with the baseline set + args = list(num.trees = 100, min.node.size = 10), assign_X = set_X, assign_Z = set_Z), - list(fun = mdl_xgboost, # boosted trees with the baseline set - args = list(nrounds = 300), + list(what = mdl_xgboost, # boosted trees with the baseline set + args = list(nrounds = 50), assign_X = set_X, assign_Z = set_Z)) @@ -183,17 +185,17 @@ stacking_fit <- ddml_fpliv(y, D = D, Z = Z_c, X = X_c, learners = learners, ensemble_type = c("nnls1"), - shortstack = T, - sample_folds = 10, - silent = T) -t(round(summary(stacking_fit), 4)[2, , ]) + shortstack = TRUE, + sample_folds = 5, + silent = TRUE) +summary(stacking_fit) ``` Interestingly, the coefficient is closer to the OLS estimates than to the TSLS estimates (with or without lasso)! -To better understand the composition of the final estimator, it is often useful to inspect the stacking weights. These may readily be retrieved from the fitted object. Here, we see that the boosted trees and the random forest learners have been assigned the most weight in the cross validation informed ensemble procedures. The linear methods -- ols, lasso, and ridge -- do not contribute substantially to the final estimates, suggesting that the user-defined expansions of the controls and instruments does little to improve bias and precision. +To better understand the composition of the final estimator, it is often useful to inspect the stacking diagnostics. Here, we see that the boosted trees and the random forest learners have been assigned the most weight. The linear methods -- ols, lasso, and ridge -- do not contribute substantially to the final estimates, suggesting that the user-defined expansions of the controls and instruments does little to improve bias and precision. ```{r} -sapply(stacking_fit$weights, round, 4) +diagnostics(stacking_fit) ``` # Elasticities @@ -217,13 +219,13 @@ compute_inelastic_demand(ols_L_fit$coef[2]) compute_inelastic_demand(tsls_fit$coef[2]) compute_inelastic_demand(tsls_L_fit$coef[2]) ``` -Double/debiased machine learning estimates using only a single lasso base learner suggest the smallest number of inelastic products. In stark contrast, the estimates based on multiple machine learners suggest a number closer to the intial OLS estimates. +Double/Debiased Machine Learning estimates using only a single lasso base learner suggest the smallest number of inelastic products. In stark contrast, the estimates based on multiple machine learners suggest a number closer to the initial OLS estimates. ```{r} # ddml-lasso implied number of products with inelastic demand -compute_inelastic_demand(lasso_fit$coef) +compute_inelastic_demand(coef(lasso_fit)) # ddml-stacking implied number of products with inelastic demand -compute_inelastic_demand(stacking_fit$coef) +compute_inelastic_demand(coef(stacking_fit)) ``` # Bonus: Post-Lasso Estimates without Sample-Splitting @@ -240,7 +242,7 @@ rlassoIV_fit <- rlassoIV(x = XL, d = D, y = y, z = ZL, summary(rlassoIV_fit) ``` -The coefficient is drastically different from previous estimates, including the double/debaised machine learning estimates that included lasso-based approaches. +The coefficient is drastically different from previous estimates, including the Double/Debiased Machine Learning estimates that included lasso-based approaches. To gain some insight into potential causes for these differences, we check which instruments and controls were selected by the lasso procedure. Not surprisingly, lasso with a plug-in penalty selects only very few instruments and controls. @@ -250,32 +252,32 @@ dim(Zr_)[2] Xr_ <- XL[, which(rlassoIV_fit$selected[49:length(rlassoIV_fit$selected)])] dim(Xr_)[2] ``` -From the stacking weights above, we know that the double/debaised machine learning estimator assigns most weight to boosted trees. In contrast to lasso-based estimates, boosted trees adaptively create interactions from their input variables, allowing for rich non-linearities in the final predictions. It thus makes sense to check whether the stark differences between the rlasso-based IV estimates above and the stacking estimates is primarily due to potential non-linearities as opposed to the specific instrument and control variables that were selected. The below code snippet re-estimates the stacking learner with the pre-selected set of controls and instruments. +From the stacking weights above, we know that the Double/Debiased Machine Learning estimator assigns most weight to boosted trees. In contrast to lasso-based estimates, boosted trees adaptively create interactions from their input variables, allowing for rich non-linearities in the final predictions. It thus makes sense to check whether the stark differences between the rlasso-based IV estimates above and the stacking estimates is primarily due to potential non-linearities as opposed to the specific instrument and control variables that were selected. The below code snippet re-estimates the stacking learner with the pre-selected set of controls and instruments. ```{r} # Base learner -learner <- list(list(fun = ols), - list(fun = mdl_xgboost, - args = list(nrounds = 300))) +learner <- list(list(what = ols), + list(what = mdl_xgboost, + args = list(nrounds = 50))) # Compute short-stacked IV estimate stacking_r_fit <- ddml_fpliv(y, D = D, Z = Zr_, X = Xr_, learners = learner, ensemble_type = c("nnls1"), - shortstack = T, - sample_folds = 10, - silent = T) -round(summary(stacking_r_fit)[2, , 1], 4) + shortstack = TRUE, + sample_folds = 5, + silent = TRUE) +summary(stacking_r_fit) ``` -The similarity of the coefficient estimates to the initial stacking estimates suggest seems that adaptively created interactions are indeed the key driver between the coefficient differences. This is further confirmed by the stacking weights, which again place substantial weight on the boosted trees. +The similarity of the coefficient estimates to the initial stacking estimates suggests that adaptively created interactions are indeed the key driver between the coefficient differences. This is further confirmed by the stacking diagnostics, which again place substantial weight on the boosted trees. ```{r} -sapply(stacking_r_fit$weights, round, 4) +diagnostics(stacking_r_fit) ``` -The example thus highlights the importance of considering multiple machine learners for robustness and illustrates the usefulness of double/debiased machine learning with stacking as a practical solution. +The example thus highlights the importance of considering multiple machine learners for robustness and illustrates the usefulness of Double/Debiased Machine Learning with stacking as a practical solution. # References diff --git a/vignettes/articles/figures/did-unnamed-chunk-10-1.png b/vignettes/articles/figures/did-unnamed-chunk-10-1.png new file mode 100644 index 0000000..1c7a1ee Binary files /dev/null and b/vignettes/articles/figures/did-unnamed-chunk-10-1.png differ diff --git a/vignettes/articles/figures/did-unnamed-chunk-15-1.png b/vignettes/articles/figures/did-unnamed-chunk-15-1.png new file mode 100644 index 0000000..696568c Binary files /dev/null and b/vignettes/articles/figures/did-unnamed-chunk-15-1.png differ diff --git a/vignettes/articles/figures/did-unnamed-chunk-7-1.png b/vignettes/articles/figures/did-unnamed-chunk-7-1.png new file mode 100644 index 0000000..7ffe444 Binary files /dev/null and b/vignettes/articles/figures/did-unnamed-chunk-7-1.png differ diff --git a/vignettes/articles/figures/unnamed-chunk-11-1.png b/vignettes/articles/figures/unnamed-chunk-11-1.png deleted file mode 100644 index 7c29411..0000000 Binary files a/vignettes/articles/figures/unnamed-chunk-11-1.png and /dev/null differ diff --git a/vignettes/articles/figures/unnamed-chunk-12-1.png b/vignettes/articles/figures/unnamed-chunk-12-1.png deleted file mode 100644 index 46026b1..0000000 Binary files a/vignettes/articles/figures/unnamed-chunk-12-1.png and /dev/null differ diff --git a/vignettes/articles/figures/unnamed-chunk-13-1.png b/vignettes/articles/figures/unnamed-chunk-13-1.png deleted file mode 100644 index b2a4040..0000000 Binary files a/vignettes/articles/figures/unnamed-chunk-13-1.png and /dev/null differ diff --git a/vignettes/articles/figures/unnamed-chunk-16-1.png b/vignettes/articles/figures/unnamed-chunk-16-1.png deleted file mode 100644 index d782142..0000000 Binary files a/vignettes/articles/figures/unnamed-chunk-16-1.png and /dev/null differ diff --git a/vignettes/articles/figures/unnamed-chunk-17-1.png b/vignettes/articles/figures/unnamed-chunk-17-1.png deleted file mode 100644 index 6be246a..0000000 Binary files a/vignettes/articles/figures/unnamed-chunk-17-1.png and /dev/null differ diff --git a/vignettes/articles/figures/unnamed-chunk-20-1.png b/vignettes/articles/figures/unnamed-chunk-20-1.png deleted file mode 100644 index 8b28bf6..0000000 Binary files a/vignettes/articles/figures/unnamed-chunk-20-1.png and /dev/null differ diff --git a/vignettes/articles/figures/unnamed-chunk-21-1.png b/vignettes/articles/figures/unnamed-chunk-21-1.png deleted file mode 100644 index 2645f8a..0000000 Binary files a/vignettes/articles/figures/unnamed-chunk-21-1.png and /dev/null differ diff --git a/vignettes/articles/figures/unnamed-chunk-23-1.png b/vignettes/articles/figures/unnamed-chunk-23-1.png deleted file mode 100644 index 7c29411..0000000 Binary files a/vignettes/articles/figures/unnamed-chunk-23-1.png and /dev/null differ diff --git a/vignettes/articles/figures/unnamed-chunk-24-1.png b/vignettes/articles/figures/unnamed-chunk-24-1.png deleted file mode 100644 index 46026b1..0000000 Binary files a/vignettes/articles/figures/unnamed-chunk-24-1.png and /dev/null differ diff --git a/vignettes/articles/figures/unnamed-chunk-4-1.png b/vignettes/articles/figures/unnamed-chunk-4-1.png deleted file mode 100644 index d782142..0000000 Binary files a/vignettes/articles/figures/unnamed-chunk-4-1.png and /dev/null differ diff --git a/vignettes/articles/figures/unnamed-chunk-5-1.png b/vignettes/articles/figures/unnamed-chunk-5-1.png deleted file mode 100644 index 6be246a..0000000 Binary files a/vignettes/articles/figures/unnamed-chunk-5-1.png and /dev/null differ diff --git a/vignettes/articles/figures/unnamed-chunk-8-1.png b/vignettes/articles/figures/unnamed-chunk-8-1.png deleted file mode 100644 index 8b28bf6..0000000 Binary files a/vignettes/articles/figures/unnamed-chunk-8-1.png and /dev/null differ diff --git a/vignettes/articles/figures/unnamed-chunk-9-1.png b/vignettes/articles/figures/unnamed-chunk-9-1.png deleted file mode 100644 index 2645f8a..0000000 Binary files a/vignettes/articles/figures/unnamed-chunk-9-1.png and /dev/null differ diff --git a/vignettes/articles/modelsummary_integration.Rmd b/vignettes/articles/modelsummary_integration.Rmd new file mode 100644 index 0000000..900f9e6 --- /dev/null +++ b/vignettes/articles/modelsummary_integration.Rmd @@ -0,0 +1,289 @@ +--- +title: "Integration with modelsummary and broom" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Integration with modelsummary and broom} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + + + +# Introduction + +When estimating structural parameters with ``ddml``, you will eventually want to extract the results programmatically or present them in a publication-ready format. ``ddml`` provides full integration with the ``broom`` package ecosystem via ``tidy()`` and ``glance()`` methods, and by extension, creates seamless compatibility with powerful table-generating packages like ``modelsummary``. + +This article demonstrates how to extract model statistics easily and create professional tables comparing traditional and machine-learning-based estimators. + + +```r +library(ddml) +# Also load modelsummary if it is installed +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { + library(modelsummary) +} +set.seed(351789) +``` + +# Setup: Estimating a Basic Model + +We will construct a simple setup using a subsample of the ``AE98`` data, comparing a traditional Ordinary Least Squares (OLS) model with a Partially Linear Model (``ddml_plm``) solved via ``ddml``. + + +```r +# Use a subset of data for this example +sub_idx = sample(1:nrow(AE98), 1000) +y = AE98[sub_idx, "worked"] +D = AE98[sub_idx, "morekids"] +X = AE98[sub_idx, c("age", "agefst", "black", "hisp", "othrace", "educ")] + +# Standard Linear Regression +ols_fit <- lm(y ~ D + X) + +# DDML Partially Linear Model +ddml_fit <- ddml_plm( + y = y, D = D, X = X, + learners = list( + list(what = ols), + list(what = mdl_glmnet) + ), + ensemble_type = c("nnls", "singlebest"), + shortstack = TRUE, + sample_folds = 5, + silent = TRUE +) +``` + +# Using ``broom``: ``tidy`` and ``glance`` + +The ``broom`` package provides a standardized way to extract information from models. ``ddml`` objects fully support these generics without requiring the user to manually parse the object list structure. + +## ``tidy()`` for Coefficients + +The ``tidy`` method extracts coefficient estimates, standard errors, test statistics, and p-values into a standard ``data.frame``. + + +```r +library(broom) + +# Tidy the OLS model +tidy(ols_fit) +#> # A tibble: 8 × 5 +#> term estimate std.error statistic p.value +#> +#> 1 (Intercept) 0.108 0.150 0.719 0.472 +#> 2 D -0.189 0.0326 -5.79 0.00000000965 +#> 3 Xage 0.0280 0.00493 5.67 0.0000000186 +#> 4 Xagefst -0.0285 0.00642 -4.44 0.0000101 +#> 5 Xblack 0.256 0.0629 4.08 0.0000495 +#> 6 Xhisp 0.0679 0.0992 0.684 0.494 +#> 7 Xothrace 0.127 0.0910 1.40 0.162 +#> 8 Xeduc 0.0187 0.00685 2.73 0.00651 + +# Tidy the DDML model +# By default, it extracts the results for the first ensemble type. +tidy(ddml_fit) +#> term estimate std.error statistic p.value ensemble_type +#> 1 D1 -0.185140138 0.03225458 -5.7399638 9.469678e-09 nnls +#> 2 (Intercept) 0.003821463 0.01530043 0.2497617 8.027716e-01 nnls +``` + +If you computed multiple ensembles simultaneously, you can specify ``ensemble_idx`` to retrieve the results for another aggregate ensemble. You can also request confidence intervals. + + +```r +# Extract the second ensemble type (e.g., 'singlebest') with confidence intervals +tidy(ddml_fit, ensemble_idx = 2, conf.int = TRUE) +#> term estimate std.error statistic p.value ensemble_type +#> 1 D1 -0.1846309958 0.03225331 -5.72440526 1.037967e-08 singlebest +#> 2 (Intercept) -0.0008189899 0.01530667 -0.05350544 9.573292e-01 singlebest +#> conf.low conf.high +#> 1 -0.24784631 -0.12141568 +#> 2 -0.03081951 0.02918153 +``` + +## ``glance()`` for Model Statistics + +To grab a single-row summary of the estimator statistics (number of observations, sample folds, cross-validation settings, ensemble methods), use ``glance()``. + + +```r +glance(ddml_fit) +#> nobs sample_folds shortstack ensemble_type model_type +#> 1 1000 5 TRUE nnls, singlebest ddml_plm +#> estimator_name +#> 1 Partially Linear Model +``` + +# Producing Tables with ``modelsummary`` + +Because ``ddml`` objects support ``tidy`` and ``glance``, they can be passed directly into ``modelsummary`` alongside other models (like ``lm``, ``glm``, ``AER::ivreg``, etc.). + + +```r +# Create a list of models to compare +model_list <- list( + "OLS" = ols_fit, + "DDML (NNLS)" = ddml_fit +) + +# Render a simple comparison table if modelsummary is available +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { + msummary(model_list, + stars = TRUE, + coef_rename = c("D" = "Treatment (D)"), + gof_omit = "AIC|BIC|Log.Lik.|F|RMSE") +} +``` + +Notice how ``modelsummary`` automatically pulled the custom goodness-of-fit metrics from ``glance.ddml()`` (e.g., ``sample_folds``, ``shortstack``, ``ensemble_type``). + +## Comparing Ensemble Types with ``as.list()`` + +When multiple ensemble types are computed simultaneously (as in our fit above), it is often useful to display each ensemble as its own column in a regression table. The ``as.list()`` method splits a ``ddml`` object into a named list of single-ensemble objects — one per ensemble type — that can be passed directly to ``modelsummary``. + + +```r +# Split by ensemble type +ensemble_list <- as.list(ddml_fit) +names(ensemble_list) +#> [1] "coefficients" "ensemble_weights" "mspe" "r2" +#> [5] "inf_func" "dinf_dtheta" "scores" "J" +#> [9] "coef_names" "estimator_name" "ensemble_type" "nobs" +#> [13] "nfit" "fit_labels" "sample_folds" "cv_folds" +#> [17] "shortstack" "cluster_variable" "fitted" "splits" +#> [21] "call" "learners" "learners_DX" + +# Each element is a standalone ddml object with full S3 support +tidy(ensemble_list[["nnls"]]) +#> # A tibble: 0 × 0 +tidy(ensemble_list[["singlebest"]]) +#> # A tibble: 0 × 0 +``` + +This makes multi-column ensemble comparison tables straightforward: + + +```r +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { + msummary( + c(list("OLS" = ols_fit), as.list(ddml_fit)), + stars = TRUE, + coef_rename = c("D" = "Treatment (D)"), + gof_omit = "AIC|BIC|Log.Lik.|F|RMSE" + ) +} +``` + +Note that each column retains its own ``glance()`` statistics, so ``modelsummary`` can display goodness-of-fit rows for every ensemble type automatically. + +# Tidy Support for Repeated Resampling + +Stata uses repeated cross-fitting by default (where the user averages coefficients over multiple splits to reduce variance dependent on sample splits). In R, you can do this by running ``ddml_replicate()`` or putting a list of ``ddml`` objects into ``ddml_rep()``. + +These aggregated ``ddml_rep`` classes have their own ``tidy`` and ``glance`` methods mimicking their base equivalents. + + +```r +# Compute a replicated DDML object with multiple ensembles +repl_fit <- ddml_replicate( + ddml_plm, + y = y, D = D, X = X, + learners = list( + list(what = ols), + list(what = mdl_glmnet) + ), + ensemble_type = c("nnls", "singlebest"), + shortstack = TRUE, + resamples = 3, + sample_folds = 5, + silent = TRUE +) + +# Extract aggregated coefficients +tidy(repl_fit) +#> term estimate std.error statistic p.value ensemble_type +#> 1 D1 -0.1865294 0.03218377 -5.795760 6.801254e-09 nnls +#> 2 (Intercept) 0.0035929 0.01525744 0.235485 8.138323e-01 nnls +#> aggregation +#> 1 median +#> 2 median + +# Combine standard fit and averaged fit in a table +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { + msummary(list("Single Split" = ddml_fit, "Repeated 3x" = repl_fit), + stars = TRUE) +} +``` + +The ``as.list()`` method also works on ``ddml_rep`` objects. This is useful when a replicated fit was computed with multiple ensemble types and you want each ensemble as a separate column: + + +```r +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { + msummary(as.list(repl_fit), stars = TRUE) +} +``` + +# Diagnostics Integration + +For tracking model performance beneath the structural estimate hood, the Stacking Diagnostics object (returned by ``diagnostics()``) also has ``print`` and ``tidy`` functions matching this same design language. + + +```r +# Extract stacking diagnostics for the structural DDML fit +# This details out-of-sample MSPE, R², and weights for the base learners +diag_fit <- diagnostics(ddml_fit) + +# Tidy output generates a data.frame +head(tidy(diag_fit), 5) +#> equation learner mspe r2 weight_nnls weight_singlebest +#> 1 y_X learner_1 0.2413624 0.02728268 0.5657648 1 +#> 2 y_X learner_2 0.2413952 0.02715058 0.4264064 0 +#> 3 D1_X learner_1 0.2206689 0.05321582 0.8069033 1 +#> 4 D1_X learner_2 0.2209438 0.05203664 0.1852464 0 +``` + +Because ``tidy(diagnostics(fit))`` evaluates exactly to a standard ``data.frame``, we can append it directly to any output artifact, knit it nicely with ``knitr::kable()``, or integrate it directly into supplementary appendix tables in an academic paper. + +# LaTeX Output + +All ``modelsummary`` tables can be rendered as LaTeX by setting ``output = "latex"``. This produces a complete ``tabular`` environment ready for inclusion in a paper: + + +```r +# Render a LaTeX table comparing OLS and DDML +msummary(list("OLS" = ols_fit, "DDML (NNLS)" = ddml_fit), + output = "latex", + stars = TRUE, + title = "Treatment Effect Estimates", + gof_omit = "AIC|BIC|Log.Lik.|F|RMSE") +``` + +To write the table directly to a ``.tex`` file, replace ``output = "latex"`` with a file path: + + +```r +msummary(list("OLS" = ols_fit, "DDML" = ddml_fit), + output = "tables/estimates.tex", + stars = TRUE) +``` + +For diagnostics tables, pipe ``tidy(diagnostics())`` through ``kableExtra``: + + +```r +library(kableExtra) +tidy(diagnostics(ddml_fit)) |> + kbl(format = "latex", booktabs = TRUE, digits = 4, + caption = "Base Learner Performance") |> + kable_styling(latex_options = "hold_position") |> + save_kable("tables/diagnostics.tex") +``` + +# References + +Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. + +Arel-Bundock V (2022). "modelsummary: Data and Model Summaries in R." Journal of Statistical Software, 103(1), 1-23. + diff --git a/vignettes/articles/modelsummary_integration.Rmd.txt b/vignettes/articles/modelsummary_integration.Rmd.txt new file mode 100644 index 0000000..6341a34 --- /dev/null +++ b/vignettes/articles/modelsummary_integration.Rmd.txt @@ -0,0 +1,240 @@ +--- +title: "Integration with modelsummary and broom" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Integration with modelsummary and broom} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + eval = TRUE, + warning = FALSE, + message = FALSE +) +``` + +# Introduction + +When estimating structural parameters with ``ddml``, you will eventually want to extract the results programmatically or present them in a publication-ready format. ``ddml`` provides full integration with the ``broom`` package ecosystem via ``tidy()`` and ``glance()`` methods, and by extension, creates seamless compatibility with powerful table-generating packages like ``modelsummary``. + +This article demonstrates how to extract model statistics easily and create professional tables comparing traditional and machine-learning-based estimators. + +```{r setup} +library(ddml) +# Also load modelsummary if it is installed +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { + library(modelsummary) +} +set.seed(351789) +``` + +# Setup: Estimating a Basic Model + +We will construct a simple setup using a subsample of the ``AE98`` data, comparing a traditional Ordinary Least Squares (OLS) model with a Partially Linear Model (``ddml_plm``) solved via ``ddml``. + +```{r} +# Use a subset of data for this example +sub_idx = sample(1:nrow(AE98), 1000) +y = AE98[sub_idx, "worked"] +D = AE98[sub_idx, "morekids"] +X = AE98[sub_idx, c("age", "agefst", "black", "hisp", "othrace", "educ")] + +# Standard Linear Regression +ols_fit <- lm(y ~ D + X) + +# DDML Partially Linear Model +ddml_fit <- ddml_plm( + y = y, D = D, X = X, + learners = list( + list(what = ols), + list(what = mdl_glmnet) + ), + ensemble_type = c("nnls", "singlebest"), + shortstack = TRUE, + sample_folds = 5, + silent = TRUE +) +``` + +# Using ``broom``: ``tidy`` and ``glance`` + +The ``broom`` package provides a standardized way to extract information from models. ``ddml`` objects fully support these generics without requiring the user to manually parse the object list structure. + +## ``tidy()`` for Coefficients + +The ``tidy`` method extracts coefficient estimates, standard errors, test statistics, and p-values into a standard ``data.frame``. + +```{r} +library(broom) + +# Tidy the OLS model +tidy(ols_fit) + +# Tidy the DDML model +# By default, it extracts the results for the first ensemble type. +tidy(ddml_fit) +``` + +If you computed multiple ensembles simultaneously, you can specify ``ensemble_idx`` to retrieve the results for another aggregate ensemble. You can also request confidence intervals. + +```{r} +# Extract the second ensemble type (e.g., 'singlebest') with confidence intervals +tidy(ddml_fit, ensemble_idx = 2, conf.int = TRUE) +``` + +## ``glance()`` for Model Statistics + +To grab a single-row summary of the estimator statistics (number of observations, sample folds, cross-validation settings, ensemble methods), use ``glance()``. + +```{r} +glance(ddml_fit) +``` + +# Producing Tables with ``modelsummary`` + +Because ``ddml`` objects support ``tidy`` and ``glance``, they can be passed directly into ``modelsummary`` alongside other models (like ``lm``, ``glm``, ``AER::ivreg``, etc.). + +```{r} +# Create a list of models to compare +model_list <- list( + "OLS" = ols_fit, + "DDML (NNLS)" = ddml_fit +) + +# Render a simple comparison table if modelsummary is available +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { + msummary(model_list, + stars = TRUE, + coef_rename = c("D" = "Treatment (D)"), + gof_omit = "AIC|BIC|Log.Lik.|F|RMSE") +} +``` + +Notice how ``modelsummary`` automatically pulled the custom goodness-of-fit metrics from ``glance.ddml()`` (e.g., ``sample_folds``, ``shortstack``, ``ensemble_type``). + +## Comparing Ensemble Types with ``as.list()`` + +When multiple ensemble types are computed simultaneously (as in our fit above), it is often useful to display each ensemble as its own column in a regression table. The ``as.list()`` method splits a ``ddml`` object into a named list of single-ensemble objects — one per ensemble type — that can be passed directly to ``modelsummary``. + +```{r} +# Split by ensemble type +ensemble_list <- as.list(ddml_fit) +names(ensemble_list) + +# Each element is a standalone ddml object with full S3 support +tidy(ensemble_list[["nnls"]]) +tidy(ensemble_list[["singlebest"]]) +``` + +This makes multi-column ensemble comparison tables straightforward: + +```{r} +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { + msummary( + c(list("OLS" = ols_fit), as.list(ddml_fit)), + stars = TRUE, + coef_rename = c("D" = "Treatment (D)"), + gof_omit = "AIC|BIC|Log.Lik.|F|RMSE" + ) +} +``` + +Note that each column retains its own ``glance()`` statistics, so ``modelsummary`` can display goodness-of-fit rows for every ensemble type automatically. + +# Tidy Support for Repeated Resampling + +Stata uses repeated cross-fitting by default (where the user averages coefficients over multiple splits to reduce variance dependent on sample splits). In R, you can do this by running ``ddml_replicate()`` or putting a list of ``ddml`` objects into ``ddml_rep()``. + +These aggregated ``ddml_rep`` classes have their own ``tidy`` and ``glance`` methods mimicking their base equivalents. + +```{r} +# Compute a replicated DDML object with multiple ensembles +repl_fit <- ddml_replicate( + ddml_plm, + y = y, D = D, X = X, + learners = list( + list(what = ols), + list(what = mdl_glmnet) + ), + ensemble_type = c("nnls", "singlebest"), + shortstack = TRUE, + resamples = 3, + sample_folds = 5, + silent = TRUE +) + +# Extract aggregated coefficients +tidy(repl_fit) + +# Combine standard fit and averaged fit in a table +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { + msummary(list("Single Split" = ddml_fit, "Repeated 3x" = repl_fit), + stars = TRUE) +} +``` + +The ``as.list()`` method also works on ``ddml_rep`` objects. This is useful when a replicated fit was computed with multiple ensemble types and you want each ensemble as a separate column: + +```{r} +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { + msummary(as.list(repl_fit), stars = TRUE) +} +``` + +# Diagnostics Integration + +For tracking model performance beneath the structural estimate hood, the Stacking Diagnostics object (returned by ``diagnostics()``) also has ``print`` and ``tidy`` functions matching this same design language. + +```{r} +# Extract stacking diagnostics for the structural DDML fit +# This details out-of-sample MSPE, R², and weights for the base learners +diag_fit <- diagnostics(ddml_fit) + +# Tidy output generates a data.frame +head(tidy(diag_fit), 5) +``` + +Because ``tidy(diagnostics(fit))`` evaluates exactly to a standard ``data.frame``, we can append it directly to any output artifact, knit it nicely with ``knitr::kable()``, or integrate it directly into supplementary appendix tables in an academic paper. + +# LaTeX Output + +All ``modelsummary`` tables can be rendered as LaTeX by setting ``output = "latex"``. This produces a complete ``tabular`` environment ready for inclusion in a paper: + +```{r, eval = FALSE} +# Render a LaTeX table comparing OLS and DDML +msummary(list("OLS" = ols_fit, "DDML (NNLS)" = ddml_fit), + output = "latex", + stars = TRUE, + title = "Treatment Effect Estimates", + gof_omit = "AIC|BIC|Log.Lik.|F|RMSE") +``` + +To write the table directly to a ``.tex`` file, replace ``output = "latex"`` with a file path: + +```{r, eval = FALSE} +msummary(list("OLS" = ols_fit, "DDML" = ddml_fit), + output = "tables/estimates.tex", + stars = TRUE) +``` + +For diagnostics tables, pipe ``tidy(diagnostics())`` through ``kableExtra``: + +```{r, eval = FALSE} +library(kableExtra) +tidy(diagnostics(ddml_fit)) |> + kbl(format = "latex", booktabs = TRUE, digits = 4, + caption = "Base Learner Performance") |> + kable_styling(latex_options = "hold_position") |> + save_kable("tables/diagnostics.tex") +``` + +# References + +Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. + +Arel-Bundock V (2022). "modelsummary: Data and Model Summaries in R." Journal of Statistical Software, 103(1), 1-23. + diff --git a/vignettes/articles/new_ml_wrapper.Rmd b/vignettes/articles/new_ml_wrapper.Rmd index 1e9c046..58b379d 100644 --- a/vignettes/articles/new_ml_wrapper.Rmd +++ b/vignettes/articles/new_ml_wrapper.Rmd @@ -78,9 +78,7 @@ gbm_fit <- mdl_gbm(y, X, fitted_values <- predict(gbm_fit, X) # Check class class(gbm_fit) -#> [1] "mdl_gbm" "gbm" class(fitted_values) -#> [1] "numeric" ``` The classes are what we expected. The wrapper should now be compatible with the ``ddml`` machinery. As a final test, we estimate the local average treatment effect. (Computation can take a while, feel free to set ``n.trees`` or ``interaction.depth`` to a smaller value for this test.) @@ -99,10 +97,6 @@ late_fit <- ddml_late(y, D, Z, X, sample_folds = 10, silent = TRUE) summary(late_fit) -#> LATE estimation results: -#> -#> Estimate Std. Error t value Pr(>|t|) -#> -0.236 0.19 -1.24 0.214 ``` All works well! @@ -148,10 +142,10 @@ mdl_keras <- function(y, X, std_y <- c(mean(y), sd(y)) std_X <- apply(X, 2, function(x) c(mean(x), max(sd(x), 1e-3))) y <- (y - std_y[1])/std_y[2] - X <- X - matrix(replicate(nobs, std_X[1, , drop = F]), - nrow = nobs, byrow = T) - X <- X / matrix(replicate(nobs, std_X[2, , drop = F]), - nrow = nobs, byrow = T) + X <- X - matrix(replicate(nobs, std_X[1, , drop = FALSE]), + nrow = nobs, byrow = TRUE) + X <- X / matrix(replicate(nobs, std_X[2, , drop = FALSE]), + nrow = nobs, byrow = TRUE) # =============================================== # ADJUST THIS PART FOR DIFFERENT ARCHITECTURES == @@ -160,11 +154,11 @@ mdl_keras <- function(y, X, nnet <- keras_model_sequential() for (k in 1:nhidden) { nnet <- nnet %>% - layer_dense(units = units, use_bias = T, + layer_dense(units = units, use_bias = TRUE, activation = "relu") }#FOR nnet <- nnet %>% - layer_dense(units = 1, use_bias = T) + layer_dense(units = 1, use_bias = TRUE) # =============================================== # =============================================== @@ -202,10 +196,10 @@ The prediction method for our fitted object ensures the predictions are returned predict.mdl_keras <- function(object, newdata){ # Standardize newdata nobs <- nrow(newdata) - newdata <- newdata - matrix(replicate(nobs, object$std_X[1, , drop = F]), - nrow = nobs, byrow = T) - newdata <- newdata / matrix(replicate(nobs, object$std_X[2, , drop = F]), - nrow = nobs, byrow = T) + newdata <- newdata - matrix(replicate(nobs, object$std_X[1, , drop = FALSE]), + nrow = nobs, byrow = TRUE) + newdata <- newdata / matrix(replicate(nobs, object$std_X[2, , drop = FALSE]), + nrow = nobs, byrow = TRUE) # Predict data and output as matrix class(object) <- class(object)[-1] # Not a pretty solution... fitted <- as.numeric(predict(object, newdata)) @@ -222,17 +216,17 @@ To test the wrapper, we again estimate the local average treatment effect. In ad # Specify callbacks callbacks_list <- list(callback_early_stopping(monitor = "val_loss", patience = 15, - restore_best_weights = T), + restore_best_weights = TRUE), callback_reduce_lr_on_plateau(monitor = "val_loss", factor = 1/10, patience = 10, - verbose = F)) + verbose = FALSE)) # Use the neural network base learner learner_keras = list(what = mdl_keras, args = list(units = 10, nhidden = 1, epochs = 100, - verbose = F, + verbose = FALSE, validation_split = 0.1, callbacks = callbacks_list)) @@ -240,14 +234,8 @@ learner_keras = list(what = mdl_keras, late_fit <- ddml_late(y, D, Z, X, learners = learner_keras, sample_folds = 10, - silent = T) -#> Warning in trim_propensity_scores(r_X, trim, ensemble_type): : 2 propensity -#> scores were trimmed. + silent = TRUE) summary(late_fit) -#> LATE estimation results: -#> -#> Estimate Std. Error t value Pr(>|t|) -#> -0.187 0.189 -0.989 0.322 ``` All works well! diff --git a/vignettes/articles/new_ml_wrapper.Rmd.txt b/vignettes/articles/new_ml_wrapper.Rmd.txt index 1f248da..68eb285 100644 --- a/vignettes/articles/new_ml_wrapper.Rmd.txt +++ b/vignettes/articles/new_ml_wrapper.Rmd.txt @@ -12,7 +12,9 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, comment = "#>", - eval = requireNamespace("keras") + eval = requireNamespace("keras", quietly = TRUE) && keras::is_keras_available(), + warning = FALSE, + message = FALSE ) ``` @@ -141,10 +143,10 @@ mdl_keras <- function(y, X, std_y <- c(mean(y), sd(y)) std_X <- apply(X, 2, function(x) c(mean(x), max(sd(x), 1e-3))) y <- (y - std_y[1])/std_y[2] - X <- X - matrix(replicate(nobs, std_X[1, , drop = F]), - nrow = nobs, byrow = T) - X <- X / matrix(replicate(nobs, std_X[2, , drop = F]), - nrow = nobs, byrow = T) + X <- X - matrix(replicate(nobs, std_X[1, , drop = FALSE]), + nrow = nobs, byrow = TRUE) + X <- X / matrix(replicate(nobs, std_X[2, , drop = FALSE]), + nrow = nobs, byrow = TRUE) # =============================================== # ADJUST THIS PART FOR DIFFERENT ARCHITECTURES == @@ -153,11 +155,11 @@ mdl_keras <- function(y, X, nnet <- keras_model_sequential() for (k in 1:nhidden) { nnet <- nnet %>% - layer_dense(units = units, use_bias = T, + layer_dense(units = units, use_bias = TRUE, activation = "relu") }#FOR nnet <- nnet %>% - layer_dense(units = 1, use_bias = T) + layer_dense(units = 1, use_bias = TRUE) # =============================================== # =============================================== @@ -194,10 +196,10 @@ The prediction method for our fitted object ensures the predictions are returned predict.mdl_keras <- function(object, newdata){ # Standardize newdata nobs <- nrow(newdata) - newdata <- newdata - matrix(replicate(nobs, object$std_X[1, , drop = F]), - nrow = nobs, byrow = T) - newdata <- newdata / matrix(replicate(nobs, object$std_X[2, , drop = F]), - nrow = nobs, byrow = T) + newdata <- newdata - matrix(replicate(nobs, object$std_X[1, , drop = FALSE]), + nrow = nobs, byrow = TRUE) + newdata <- newdata / matrix(replicate(nobs, object$std_X[2, , drop = FALSE]), + nrow = nobs, byrow = TRUE) # Predict data and output as matrix class(object) <- class(object)[-1] # Not a pretty solution... fitted <- as.numeric(predict(object, newdata)) @@ -213,17 +215,17 @@ To test the wrapper, we again estimate the local average treatment effect. In ad # Specify callbacks callbacks_list <- list(callback_early_stopping(monitor = "val_loss", patience = 15, - restore_best_weights = T), + restore_best_weights = TRUE), callback_reduce_lr_on_plateau(monitor = "val_loss", factor = 1/10, patience = 10, - verbose = F)) + verbose = FALSE)) # Use the neural network base learner learner_keras = list(what = mdl_keras, args = list(units = 10, nhidden = 1, epochs = 100, - verbose = F, + verbose = FALSE, validation_split = 0.1, callbacks = callbacks_list)) @@ -231,7 +233,7 @@ learner_keras = list(what = mdl_keras, late_fit <- ddml_late(y, D, Z, X, learners = learner_keras, sample_folds = 10, - silent = T) + silent = TRUE) summary(late_fit) ``` diff --git a/vignettes/articles/repeated_resampling.Rmd b/vignettes/articles/repeated_resampling.Rmd new file mode 100644 index 0000000..f47fe10 --- /dev/null +++ b/vignettes/articles/repeated_resampling.Rmd @@ -0,0 +1,265 @@ +--- +title: "Robust Inference and Repeated Resampling" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Robust Inference and Repeated Resampling} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + + + +# Introduction + +Double/Debiased Machine Learning revolves around the use of **cross-fitting** (sample splitting) to estimate nuisance parameters and structural effects without inducing severe over-fitting bias. + +Because cross-fitting relies on random sample splits, structural estimates inherently contain *splitting variance*. If you run a ``ddml`` estimator twice with two different random seeds, you will likely get two slightly different point estimates. + +To stabilize these estimates and eliminate the influence of a "lucky" or "unlucky" sample split, researchers recommend repeating the cross-fitting split multiple times and aggregating the results (see Chernozhukov et al. 2018 and Ahrens et al. 2024). + +``ddml`` introduces dedicated functionality for repeated resampling via ``ddml_replicate()`` and the ``ddml_rep`` class. + + +```r +library(ddml) +set.seed(847291) +``` + +# Single vs. Repeated Fits + +Let's use a subsample of the ``AE98`` dataset to show how a single fit compares to a repeated fit. + + +```r +# Use a subset of data +sub_idx = sample(1:nrow(AE98), 1000) +y = AE98[sub_idx, "worked"] +D = AE98[sub_idx, "morekids"] +X = AE98[sub_idx, c("age", "agefst", "black", "hisp", "othrace", "educ")] + +# Define a simple learner list +learners <- list( + list(what = ols), + list(what = mdl_glmnet) +) +``` + +First, let's look at the result of a *single* ``ddml_plm`` fit: + + +```r +# Single fit +fit_single <- ddml_plm( + y = y, D = D, X = X, + learners = learners, + shortstack = TRUE, + sample_folds = 5, + silent = TRUE +) + +summary(fit_single) +#> DDML estimation: Partially Linear Model +#> Obs: 1000 Folds: 5 Stacking: short-stack +#> +#> Estimate Std. Error z value Pr(>|z|) +#> D1 -0.11986 0.03306 -3.63 0.00029 *** +#> (Intercept) 0.00422 0.01541 0.27 0.78425 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +``` + +Next, let's use the ``ddml_replicate()`` wrapper. We pass it the target estimator (``ddml_plm``) and the desired number of independent resamples. + +*Note: Repeated resampling takes proportionally longer to compute, as the estimator is run entirely to completion ``resamples`` times in sequence.* + + +```r +# Replicated fit (e.g., 5 independent cross-fitting splits) +fit_rep <- ddml_replicate( + ddml_plm, + y = y, D = D, X = X, + learners = learners, + shortstack = TRUE, + sample_folds = 5, + resamples = 5, + silent = TRUE +) + +# Observe the class of the returned object +class(fit_rep) +#> [1] "ddml_rep" "ral_rep" +``` + +# Interacting with ``ddml_rep`` Objects + +``ddml_replicate()`` returns an object of class ``ddml_rep``. This object natively supports all the standard generics you would expect from a single ``ddml`` model. + +When summary statistics or coefficients are requested, ``ddml_rep`` automatically aggregates the results from all individual fits. By default, it applies the **median** aggregation approach (Chernozhukov et al., 2018), which computes the median of the parameter estimates across all splits and suitably inflates the standard errors to account for between-split variation. + + +```r +# Print the object details +fit_rep +#> DDML replicated fits: Partially Linear Model +#> Resamples: 5 Obs: 1000 Folds: 5 +#> +#> Use summary() for aggregated inference. +#> Use x[[i]] to access individual fits. + +# Aggregate inference (Median Aggregation) +summary(fit_rep) +#> DDML estimation: Partially Linear Model +#> Obs: 1000 Folds: 5 Resamples: 5 Aggregation: median Stacking: short-stack +#> +#> Estimate Std. Error z value Pr(>|z|) +#> D1 -0.11409 0.03318 -3.44 0.00058 *** +#> (Intercept) 0.00384 0.01544 0.25 0.80372 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 + +# Extract only the coefficients +coef(fit_rep) +#> D1 (Intercept) +#> -0.114085768 0.003836949 + +# Extract confidence intervals (with HC3 standard errors passed to the VCoV estimator) +confint(fit_rep, type = "HC3") +#> 2.5 % 97.5 % +#> D1 -0.17920978 -0.04896176 +#> (Intercept) -0.02645093 0.03412483 +#> attr(,"crit_val") +#> [1] 1.959964 +``` + +You can alternatively switch to **mean** aggregation (Ahrens et al., 2024), which computes the empirical mean across split estimates: + + +```r +summary(fit_rep, aggregation = "mean") +#> DDML estimation: Partially Linear Model +#> Obs: 1000 Folds: 5 Resamples: 5 Aggregation: mean Stacking: short-stack +#> +#> Estimate Std. Error z value Pr(>|z|) +#> D1 -0.11553 0.03323 -3.48 0.00051 *** +#> (Intercept) 0.00415 0.01548 0.27 0.78843 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +``` + +## Visualizing Splitting Variance + +We can inspect the exact variation across the five sample splits by extracting the point estimates from the underlying list of fits in the ``ddml_rep`` object: + + +```r +# Individual point estimates for the primary ensemble across the 5 independent splits +split_estimates <- vapply(fit_rep$fits, function(fit) coef(fit)[1], numeric(1)) +print(split_estimates) +#> [1] -0.1117597 -0.1187530 -0.1133071 -0.1197519 -0.1140858 + +# Variance of the point estimates across splits +var(split_estimates) +#> [1] 1.23637e-05 +``` + +## Multiple Treatment Variables and Joint Variance + +If your model includes multiple treatment variables, ``ddml_rep`` seamlessly aggregates the full, joint variance-covariance matrix across all the sample splits, preserving the covariance between different parameter estimates. + + +```r +# Fit a model with two treatments: 'morekids' and 'boy2nd' +fit_rep_multi <- ddml_replicate( + ddml_plm, + y = y, + D = AE98[sub_idx, c("morekids", "boy2nd")], + X = X, + learners = learners, + shortstack = TRUE, + sample_folds = 5, + resamples = 5, + silent = TRUE +) + +# Extract the full aggregated Variance-Covariance matrix +vcov(fit_rep_multi) +#> morekids boy2nd (Intercept) +#> morekids 1.090179e-03 -2.156755e-05 -7.584066e-06 +#> boy2nd -2.156755e-05 9.450183e-04 1.153763e-05 +#> (Intercept) -7.584066e-06 1.153763e-05 2.368640e-04 +``` + +## Extracting Individual Fits + +Because a ``ddml_rep`` object is essentially a structured list of pure ``ddml`` outputs, you can always extract the specific estimates and diagnostics of any single resample using double brackets ``[[ ]]``: + + +```r +# Extract the 3rd replicate fit +run_3 <- fit_rep[[3]] +class(run_3) +#> [1] "ddml_plm" "ddml" "ral" + +# View its specific diagnostics +diagnostics(run_3) +#> Stacking diagnostics: Partially Linear Model +#> Obs: 1000 +#> +#> y_X: +#> learner mspe r2 weight_nnls +#> learner_1 0.2402 0.0394 0.0000 +#> learner_2 0.2396 0.0415 0.9986 +#> +#> D1_X: +#> learner mspe r2 weight_nnls +#> learner_1 0.2205 0.0659 0.0000 +#> learner_2 0.2202 0.0671 0.9926 +``` + +# Manual Construction and HPC Compatibility + +``ddml_replicate()`` computes sequential cross-fits using a simple ``for`` loop. + +If you are running very large regressions (e.g., millions of observations or complex machine learners), you might want to parallelize these resamples across a high-performance computing (HPC) cluster. + +Because ``ddml`` fits are completely independent of one another, you can easily compute them in parallel (using ``mclapply``, ``future``, or job arrays) and combine the raw list of returned objects using the structural ``ddml_rep()`` constructor. + + +```r +# 1. Generate an independent list of 3 ddml fits (this could be from parallel::mclapply) +fits_list <- lapply(1:3, function(r) { + ddml_plm( + y = y, D = D, X = X, + learners = learners, + shortstack = TRUE, + sample_folds = 5, + silent = TRUE + ) +}) + +# 2. Combine them into a ddml_rep object +manual_rep <- ddml_rep(fits_list) +class(manual_rep) +#> [1] "ddml_rep" "ral_rep" + +# 3. Aggregate results +summary(manual_rep) +#> DDML estimation: Partially Linear Model +#> Obs: 1000 Folds: 5 Resamples: 3 Aggregation: median Stacking: short-stack +#> +#> Estimate Std. Error z value Pr(>|z|) +#> D1 -0.11819 0.03308 -3.57 0.00035 *** +#> (Intercept) 0.00309 0.01543 0.20 0.84144 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +``` + +This flexibility allows ``ddml`` to scale efficiently from local laptops to massive distributed compute environments, ensuring robust inference no matter your hardware setup. + +# References + +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, Wiemann T (2026). "An Introduction to Double/Debiased Machine Learning." *Journal of Economic Literature*, forthcoming. + +Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). “Model Averaging and Double Machine Learning.” *Journal of Applied Econometrics*, 40(3): 249-269. + +Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C, Newey W, Robins J (2018). "Double/debiased machine learning for treatment and structural parameters." *The Econometrics Journal*, 21(1), C1-C68. diff --git a/vignettes/articles/repeated_resampling.Rmd.txt b/vignettes/articles/repeated_resampling.Rmd.txt new file mode 100644 index 0000000..1414a2d --- /dev/null +++ b/vignettes/articles/repeated_resampling.Rmd.txt @@ -0,0 +1,198 @@ +--- +title: "Robust Inference and Repeated Resampling" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Robust Inference and Repeated Resampling} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + eval = TRUE, + warning = FALSE, + message = FALSE +) +``` + +# Introduction + +Double/Debiased Machine Learning revolves around the use of **cross-fitting** (sample splitting) to estimate nuisance parameters and structural effects without inducing severe over-fitting bias. + +Because cross-fitting relies on random sample splits, structural estimates inherently contain *splitting variance*. If you run a ``ddml`` estimator twice with two different random seeds, you will likely get two slightly different point estimates. + +To stabilize these estimates and eliminate the influence of a "lucky" or "unlucky" sample split, researchers recommend repeating the cross-fitting split multiple times and aggregating the results (see Chernozhukov et al. 2018 and Ahrens et al. 2024). + +``ddml`` introduces dedicated functionality for repeated resampling via ``ddml_replicate()`` and the ``ddml_rep`` class. + +```{r setup} +library(ddml) +set.seed(847291) +``` + +# Single vs. Repeated Fits + +Let's use a subsample of the ``AE98`` dataset to show how a single fit compares to a repeated fit. + +```{r} +# Use a subset of data +sub_idx = sample(1:nrow(AE98), 1000) +y = AE98[sub_idx, "worked"] +D = AE98[sub_idx, "morekids"] +X = AE98[sub_idx, c("age", "agefst", "black", "hisp", "othrace", "educ")] + +# Define a simple learner list +learners <- list( + list(what = ols), + list(what = mdl_glmnet) +) +``` + +First, let's look at the result of a *single* ``ddml_plm`` fit: + +```{r} +# Single fit +fit_single <- ddml_plm( + y = y, D = D, X = X, + learners = learners, + shortstack = TRUE, + sample_folds = 5, + silent = TRUE +) + +summary(fit_single) +``` + +Next, let's use the ``ddml_replicate()`` wrapper. We pass it the target estimator (``ddml_plm``) and the desired number of independent resamples. + +*Note: Repeated resampling takes proportionally longer to compute, as the estimator is run entirely to completion ``resamples`` times in sequence.* + +```{r} +# Replicated fit (e.g., 5 independent cross-fitting splits) +fit_rep <- ddml_replicate( + ddml_plm, + y = y, D = D, X = X, + learners = learners, + shortstack = TRUE, + sample_folds = 5, + resamples = 5, + silent = TRUE +) + +# Observe the class of the returned object +class(fit_rep) +``` + +# Interacting with ``ddml_rep`` Objects + +``ddml_replicate()`` returns an object of class ``ddml_rep``. This object natively supports all the standard generics you would expect from a single ``ddml`` model. + +When summary statistics or coefficients are requested, ``ddml_rep`` automatically aggregates the results from all individual fits. By default, it applies the **median** aggregation approach (Chernozhukov et al., 2018), which computes the median of the parameter estimates across all splits and suitably inflates the standard errors to account for between-split variation. + +```{r} +# Print the object details +fit_rep + +# Aggregate inference (Median Aggregation) +summary(fit_rep) + +# Extract only the coefficients +coef(fit_rep) + +# Extract confidence intervals (with HC3 standard errors passed to the VCoV estimator) +confint(fit_rep, type = "HC3") +``` + +You can alternatively switch to **mean** aggregation (Ahrens et al., 2024), which computes the empirical mean across split estimates: + +```{r} +summary(fit_rep, aggregation = "mean") +``` + +## Visualizing Splitting Variance + +We can inspect the exact variation across the five sample splits by extracting the point estimates from the underlying list of fits in the ``ddml_rep`` object: + +```{r} +# Individual point estimates for the primary ensemble across the 5 independent splits +split_estimates <- vapply(fit_rep$fits, function(fit) coef(fit)[1], numeric(1)) +print(split_estimates) + +# Variance of the point estimates across splits +var(split_estimates) +``` + +## Multiple Treatment Variables and Joint Variance + +If your model includes multiple treatment variables, ``ddml_rep`` seamlessly aggregates the full, joint variance-covariance matrix across all the sample splits, preserving the covariance between different parameter estimates. + +```{r} +# Fit a model with two treatments: 'morekids' and 'boy2nd' +fit_rep_multi <- ddml_replicate( + ddml_plm, + y = y, + D = AE98[sub_idx, c("morekids", "boy2nd")], + X = X, + learners = learners, + shortstack = TRUE, + sample_folds = 5, + resamples = 5, + silent = TRUE +) + +# Extract the full aggregated Variance-Covariance matrix +vcov(fit_rep_multi) +``` + +## Extracting Individual Fits + +Because a ``ddml_rep`` object is essentially a structured list of pure ``ddml`` outputs, you can always extract the specific estimates and diagnostics of any single resample using double brackets ``[[ ]]``: + +```{r} +# Extract the 3rd replicate fit +run_3 <- fit_rep[[3]] +class(run_3) + +# View its specific diagnostics +diagnostics(run_3) +``` + +# Manual Construction and HPC Compatibility + +``ddml_replicate()`` computes sequential cross-fits using a simple ``for`` loop. + +If you are running very large regressions (e.g., millions of observations or complex machine learners), you might want to parallelize these resamples across a high-performance computing (HPC) cluster. + +Because ``ddml`` fits are completely independent of one another, you can easily compute them in parallel (using ``mclapply``, ``future``, or job arrays) and combine the raw list of returned objects using the structural ``ddml_rep()`` constructor. + +```{r} +# 1. Generate an independent list of 3 ddml fits (this could be from parallel::mclapply) +fits_list <- lapply(1:3, function(r) { + ddml_plm( + y = y, D = D, X = X, + learners = learners, + shortstack = TRUE, + sample_folds = 5, + silent = TRUE + ) +}) + +# 2. Combine them into a ddml_rep object +manual_rep <- ddml_rep(fits_list) +class(manual_rep) + +# 3. Aggregate results +summary(manual_rep) +``` + +This flexibility allows ``ddml`` to scale efficiently from local laptops to massive distributed compute environments, ensuring robust inference no matter your hardware setup. + +# References + +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, Wiemann T (2026). "An Introduction to Double/Debiased Machine Learning." *Journal of Economic Literature*, forthcoming. + +Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). “Model Averaging and Double Machine Learning.” *Journal of Applied Econometrics*, 40(3): 249-269. + +Chernozhukov V, Chetverikov D, Demirer M, Duflo E, Hansen C, Newey W, Robins J (2018). "Double/debiased machine learning for treatment and structural parameters." *The Econometrics Journal*, 21(1), C1-C68. diff --git a/vignettes/articles/sparse.Rmd b/vignettes/articles/sparse.Rmd index a347844..607e1e1 100644 --- a/vignettes/articles/sparse.Rmd +++ b/vignettes/articles/sparse.Rmd @@ -12,7 +12,7 @@ vignette: > # Introduction -``ddml`` supports sparse matrices from the ``Matrix`` package by default. This article illustrates double/debiased machine learning estimation with sparse matrices using the prominent study of Angrist and Krueger (1991) (AK91, hereafter) on returns to education. +``ddml`` supports sparse matrices from the ``Matrix`` package by default. This article illustrates Double/Debiased Machine Learning estimation with sparse matrices using the prominent study of Angrist and Krueger (1991) (AK91, hereafter) on returns to education. ```r @@ -56,8 +56,6 @@ format(object.size(X), units = "Mb") # Memory needed for the dense control matrix format(object.size(as.matrix(X)), units = "Mb") -#> Warning in asMethod(object): sparse->dense coercion: allocating vector of size -#> 1.3 GiB #> [1] "1302.3 Mb" ``` # Estimation with Sparse Matrices @@ -68,58 +66,58 @@ We begin with estimating the returns to schooling using the set of 180 instrumen ```r -learners_XZ <- list(list(fun = ols), - list(fun = mdl_glmnet, +learners_XZ <- list(list(what = ols), + list(what = mdl_glmnet, args = list(cv = FALSE, penalty.factor = c(rep(0, 510), rep(1, 180))))) stacking_180IV_fit <- ddml_fpliv(y = AK91$LWKLYWGE, D = AK91$EDUC, Z = Z_IV180, X = X, - learners = list(list(fun = ols)), - learners_DX = list(list(fun = ols)), + learners = list(list(what = ols)), + learners_DX = list(list(what = ols)), learners_DXZ = learners_XZ, ensemble_type = c("nnls1"), - shortstack = T, + shortstack = TRUE, sample_folds = 2, - silent = T) -summary(stacking_180IV_fit, type = 'HC1') -#> FPLIV estimation results: -#> -#> , , nnls1 + silent = TRUE) +summary(stacking_180IV_fit) +#> DDML estimation: Flexible Partially Linear IV Model +#> Obs: 329509 Folds: 2 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> (Intercept) -6.14e-05 0.00113 -0.0542 9.57e-01 -#> D_r 1.12e-01 0.02145 5.2258 1.73e-07 +#> Estimate Std. Error z value Pr(>|z|) +#> D1 1.12e-01 2.15e-02 5.23 1.7e-07 *** +#> (Intercept) -6.14e-05 1.13e-03 -0.05 0.96 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` The exercise can be repeated with the larger set of 1530 instruments as well. Without support for sparse matrices, this estimation step would not be possible without very large memory. ```r -learners_XZ <- list(list(fun = ols), - list(fun = mdl_glmnet, +learners_XZ <- list(list(what = ols), + list(what = mdl_glmnet, args = list(cv = FALSE, penalty.factor = c(rep(0, 510), rep(1, 1530))))) stacking_1530IV_fit <- ddml_fpliv(y = AK91$LWKLYWGE, D = AK91$EDUC, Z = Z_IV1530, X = X, - learners = list(list(fun = ols)), - learners_DX = list(list(fun = ols)), + learners = list(list(what = ols)), + learners_DX = list(list(what = ols)), learners_DXZ = learners_XZ, ensemble_type = c("nnls1"), - shortstack = T, + shortstack = TRUE, sample_folds = 2, - silent = T) -summary(stacking_1530IV_fit, type = 'HC1') -#> FPLIV estimation results: -#> -#> , , nnls1 + silent = TRUE) +summary(stacking_1530IV_fit) +#> DDML estimation: Flexible Partially Linear IV Model +#> Obs: 329509 Folds: 2 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> (Intercept) 4.98e-05 0.00111 0.045 0.9641 -#> D_r 6.30e-02 0.03574 1.764 0.0778 +#> Estimate Std. Error z value Pr(>|z|) +#> D1 0.046151 0.051943 0.89 0.37 +#> (Intercept) 0.000064 0.001112 0.06 0.95 ``` The coefficients corresponding to the two sets of instruments are quite different. Leveraging the ``ddml`` functionality that allows for specification of different sets of input variables, we construct a stacking estimator that considers both first stage regressions simultaneously. @@ -130,49 +128,62 @@ The coefficients corresponding to the two sets of instruments are quite differen Z_c <- cbind(Z_IV180, Z_IV1530); colnames(Z_c) <- 1:(180 + 1530) set_IV180 <- 1:180; set_IV1530 <- 181:(180 + 1530) -learners_XZ <- list(list(fun = ols, +learners_XZ <- list(list(what = ols, assign_Z = set_IV180), - list(fun = ols, + list(what = ols, assign_Z = set_IV1530), - list(fun = mdl_glmnet, + list(what = mdl_glmnet, args = list(cv = FALSE, penalty.factor = c(rep(0, 510), rep(1, 180))), assign_Z = set_IV180), - list(fun = mdl_glmnet, + list(what = mdl_glmnet, args = list(cv = FALSE, penalty.factor = c(rep(0, 510), rep(1, 1530))), assign_Z = set_IV1530)) stacking_fit <- ddml_fpliv(y = AK91$LWKLYWGE, D = AK91$EDUC, Z = Z_c, X = X, - learners = list(list(fun = ols)), - learners_DX = list(list(fun = ols)), + learners = list(list(what = ols)), + learners_DX = list(list(what = ols)), learners_DXZ = learners_XZ, ensemble_type = c("nnls1"), - shortstack = T, + shortstack = TRUE, sample_folds = 2, - silent = T) -summary(stacking_fit, type = 'HC1') -#> FPLIV estimation results: -#> -#> , , nnls1 + silent = TRUE) +summary(stacking_fit) +#> DDML estimation: Flexible Partially Linear IV Model +#> Obs: 329509 Folds: 2 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> (Intercept) 0.000143 0.00115 0.124 9.01e-01 -#> D_r 0.124080 0.02012 6.167 6.97e-10 +#> Estimate Std. Error z value Pr(>|z|) +#> D1 0.105040 0.015673 6.70 2.1e-11 *** +#> (Intercept) -0.000196 0.001125 -0.17 0.86 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` -The resulting coefficient is close to the coefficient based on 180 instruments. The stacking weights confirm that the first stage estimators with 180 instruments contribute almost exclusively to the final estimate, suggesting that the expansion to 1530 instrument has little benefit for the ols or lasso-based first stage fits. +The resulting coefficient is close to the coefficient based on 180 instruments. The stacking diagnostics confirm that the first stage estimators with 180 instruments contribute almost exclusively to the final estimate, suggesting that the expansion to 1530 instruments has little benefit for the ols or lasso-based first stage fits. ```r -round(stacking_fit$weights$D1_XZ, 4) -#> nnls1 -#> [1,] 0.7000 -#> [2,] 0.0000 -#> [3,] 0.2925 -#> [4,] 0.0075 +diagnostics(stacking_fit) +#> Stacking diagnostics: Flexible Partially Linear IV Model +#> Obs: 329509 +#> +#> y_X: +#> learner mspe r2 weight_nnls1 +#> learner_1 0.4489 0.0258 1 +#> +#> D1_X: +#> learner mspe r2 weight_nnls1 +#> learner_1 10.187 0.0538 1 +#> +#> D1_XZ: +#> learner mspe r2 weight_nnls1 +#> learner_1 10.1851 0.0540 0.5874 +#> learner_2 10.2699 0.0461 0.0000 +#> learner_3 10.1852 0.0540 0.4126 +#> learner_4 10.2673 0.0464 0.0000 ``` # References diff --git a/vignettes/articles/sparse.Rmd.txt b/vignettes/articles/sparse.Rmd.txt index f87e699..7c08aec 100644 --- a/vignettes/articles/sparse.Rmd.txt +++ b/vignettes/articles/sparse.Rmd.txt @@ -12,13 +12,15 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, comment = "#>", - eval = requireNamespace("Matrix") + eval = requireNamespace("Matrix"), + warning = FALSE, + message = FALSE ) ``` # Introduction -``ddml`` supports sparse matrices from the ``Matrix`` package by default. This article illustrates double/debiased machine learning estimation with sparse matrices using the prominent study of Angrist and Krueger (1991) (AK91, hereafter) on returns to education. +``ddml`` supports sparse matrices from the ``Matrix`` package by default. This article illustrates Double/Debiased Machine Learning estimation with sparse matrices using the prominent study of Angrist and Krueger (1991) (AK91, hereafter) on returns to education. ```{r} library(ddml) @@ -66,43 +68,43 @@ The syntax for estimation with sparse matrices in ``ddml`` is _exactly_ the same We begin with estimating the returns to schooling using the set of 180 instruments. Following the convention of the returns to education-literature, our estimator selects only among the instruments but does regularize the coefficients corresponding to the control variables. This is achieved by formulating different base learners for the first and second stage reduced forms (see ``?ddml_fpliv``), and by setting the ``penalty.factor`` of the control variables to zero (see ``?mdl_glmnet``). ```{r} -learners_XZ <- list(list(fun = ols), - list(fun = mdl_glmnet, +learners_XZ <- list(list(what = ols), + list(what = mdl_glmnet, args = list(cv = FALSE, penalty.factor = c(rep(0, 510), rep(1, 180))))) stacking_180IV_fit <- ddml_fpliv(y = AK91$LWKLYWGE, D = AK91$EDUC, Z = Z_IV180, X = X, - learners = list(list(fun = ols)), - learners_DX = list(list(fun = ols)), + learners = list(list(what = ols)), + learners_DX = list(list(what = ols)), learners_DXZ = learners_XZ, ensemble_type = c("nnls1"), - shortstack = T, + shortstack = TRUE, sample_folds = 2, - silent = T) -summary(stacking_180IV_fit, type = 'HC1') + silent = TRUE) +summary(stacking_180IV_fit) ``` The exercise can be repeated with the larger set of 1530 instruments as well. Without support for sparse matrices, this estimation step would not be possible without very large memory. ```{r} -learners_XZ <- list(list(fun = ols), - list(fun = mdl_glmnet, +learners_XZ <- list(list(what = ols), + list(what = mdl_glmnet, args = list(cv = FALSE, penalty.factor = c(rep(0, 510), rep(1, 1530))))) stacking_1530IV_fit <- ddml_fpliv(y = AK91$LWKLYWGE, D = AK91$EDUC, Z = Z_IV1530, X = X, - learners = list(list(fun = ols)), - learners_DX = list(list(fun = ols)), + learners = list(list(what = ols)), + learners_DX = list(list(what = ols)), learners_DXZ = learners_XZ, ensemble_type = c("nnls1"), - shortstack = T, + shortstack = TRUE, sample_folds = 2, - silent = T) -summary(stacking_1530IV_fit, type = 'HC1') + silent = TRUE) +summary(stacking_1530IV_fit) ``` The coefficients corresponding to the two sets of instruments are quite different. Leveraging the ``ddml`` functionality that allows for specification of different sets of input variables, we construct a stacking estimator that considers both first stage regressions simultaneously. @@ -112,36 +114,36 @@ The coefficients corresponding to the two sets of instruments are quite differen Z_c <- cbind(Z_IV180, Z_IV1530); colnames(Z_c) <- 1:(180 + 1530) set_IV180 <- 1:180; set_IV1530 <- 181:(180 + 1530) -learners_XZ <- list(list(fun = ols, +learners_XZ <- list(list(what = ols, assign_Z = set_IV180), - list(fun = ols, + list(what = ols, assign_Z = set_IV1530), - list(fun = mdl_glmnet, + list(what = mdl_glmnet, args = list(cv = FALSE, penalty.factor = c(rep(0, 510), rep(1, 180))), assign_Z = set_IV180), - list(fun = mdl_glmnet, + list(what = mdl_glmnet, args = list(cv = FALSE, penalty.factor = c(rep(0, 510), rep(1, 1530))), assign_Z = set_IV1530)) stacking_fit <- ddml_fpliv(y = AK91$LWKLYWGE, D = AK91$EDUC, Z = Z_c, X = X, - learners = list(list(fun = ols)), - learners_DX = list(list(fun = ols)), + learners = list(list(what = ols)), + learners_DX = list(list(what = ols)), learners_DXZ = learners_XZ, ensemble_type = c("nnls1"), - shortstack = T, + shortstack = TRUE, sample_folds = 2, - silent = T) -summary(stacking_fit, type = 'HC1') + silent = TRUE) +summary(stacking_fit) ``` -The resulting coefficient is close to the coefficient based on 180 instruments. The stacking weights confirm that the first stage estimators with 180 instruments contribute almost exclusively to the final estimate, suggesting that the expansion to 1530 instrument has little benefit for the ols or lasso-based first stage fits. +The resulting coefficient is close to the coefficient based on 180 instruments. The stacking diagnostics confirm that the first stage estimators with 180 instruments contribute almost exclusively to the final estimate, suggesting that the expansion to 1530 instruments has little benefit for the ols or lasso-based first stage fits. ```{r} -round(stacking_fit$weights$D1_XZ, 4) +diagnostics(stacking_fit) ``` # References diff --git a/vignettes/articles/stacking.Rmd b/vignettes/articles/stacking.Rmd index 8d8a029..385d623 100644 --- a/vignettes/articles/stacking.Rmd +++ b/vignettes/articles/stacking.Rmd @@ -12,7 +12,7 @@ vignette: > # Introduction -This article illustrates the computational advantages of short-stacking over conventional stacking for estimation of structural parameters using double/debiased machine learning. See also Ahrens et al. ([2024a](https://arxiv.org/abs/2301.09397), [2024b](https://arxiv.org/abs/2401.01645)) for further discussion of short-stacking. +This article illustrates the computational advantages of short-stacking over conventional stacking for estimation of structural parameters using Double/Debiased Machine Learning. See also Ahrens et al. ([2024a](https://arxiv.org/abs/2301.09397), [2024b](https://arxiv.org/abs/2401.01645)) for further discussion of short-stacking. # Estimation with Stacking and Short-Stacking @@ -45,48 +45,48 @@ time_singlelearner <- system.time({ learners = list(what = mdl_xgboost, args = list(nrounds = 100, max_depth = 1)), - sample_folds = 10, + sample_folds = 5, silent = TRUE) })#SYSTEM.TIME time_shortstacking <- system.time({ late_fit <- ddml_late(y, D, Z, X, - learners = list(list(fun = ols), - list(fun = mdl_glmnet), - list(fun = mdl_xgboost, + learners = list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_xgboost, args = list(nrounds = 100, max_depth = 1))), ensemble_type = 'nnls1', shortstack = TRUE, - sample_folds = 10, + sample_folds = 5, silent = TRUE) })#SYSTEM.TIME time_stacking <- system.time({ late_fit <- ddml_late(y, D, Z, X, - learners = list(list(fun = ols), - list(fun = mdl_glmnet), - list(fun = mdl_xgboost, + learners = list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_xgboost, args = list(nrounds = 100, max_depth = 1))), ensemble_type = 'nnls1', shortstack = FALSE, - sample_folds = 10, - cv_folds = 10, + sample_folds = 5, + cv_folds = 5, silent = TRUE) })#SYSTEM.TIME ``` -Both stacking and short-stacking construct weighted averages of the considered base learners to minimize the out-of-sample mean squared prediction error (MSPE). The difference between the two approaches lies in the construction of the MSPE: While stacking runs cross-validation in each cross-fitting sample fold, short-stacking directly uses the out-of-sample predictions arising in the cross-fitting step of double/debiased machine learning estimators. As the run-times below show, this results in a substantially reduced computational burden: +Both stacking and short-stacking construct weighted averages of the considered base learners to minimize the out-of-sample mean squared prediction error (MSPE). The difference between the two approaches lies in the construction of the MSPE: While stacking runs cross-validation in each cross-fitting sample fold, short-stacking directly uses the out-of-sample predictions arising in the cross-fitting step of Double/Debiased Machine Learning estimators. As the run-times below show, this results in a substantially reduced computational burden: ```r cat("Time single learner:", time_singlelearner[1], "\n") -#> Time single learner: 10.39 +#> Time single learner: 2.09 cat("Time short-stacking:", time_shortstacking[1], "\n") -#> Time short-stacking: 12.83 +#> Time short-stacking: 5.75 cat("Time stacking: ", time_stacking[1]) -#> Time stacking: 117.98 +#> Time stacking: 27.11 ``` # References @@ -97,6 +97,6 @@ Double/debiased machine learning in Stata.” Stata Journal, 24(1): Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024b). "Model averaging and double machine learning." -Angrist J, Evans W (1998). "Children and Their Parents' Labor Supply: Evidence +Angrist J, Evans W (1998). "Children and Their Parents' Labor Supply: Evidence from Exogenous Variation in Family Size." American Economic Review, 88(3), 450-477. diff --git a/vignettes/articles/stacking.Rmd.txt b/vignettes/articles/stacking.Rmd.txt index e2ae97c..314dff6 100644 --- a/vignettes/articles/stacking.Rmd.txt +++ b/vignettes/articles/stacking.Rmd.txt @@ -12,13 +12,15 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, comment = "#>", - eval = TRUE + eval = TRUE, + warning = FALSE, + message = FALSE ) ``` # Introduction -This article illustrates the computational advantages of short-stacking over conventional stacking for estimation of structural parameters using double/debiased machine learning. See also Ahrens et al. ([2024a](https://arxiv.org/abs/2301.09397), [2024b](https://arxiv.org/abs/2401.01645)) for further discussion of short-stacking. +This article illustrates the computational advantages of short-stacking over conventional stacking for estimation of structural parameters using Double/Debiased Machine Learning. See also Ahrens et al. ([2024a](https://arxiv.org/abs/2301.09397), [2024b](https://arxiv.org/abs/2401.01645)) for further discussion of short-stacking. # Estimation with Stacking and Short-Stacking @@ -49,39 +51,39 @@ time_singlelearner <- system.time({ learners = list(what = mdl_xgboost, args = list(nrounds = 100, max_depth = 1)), - sample_folds = 10, + sample_folds = 5, silent = TRUE) })#SYSTEM.TIME time_shortstacking <- system.time({ late_fit <- ddml_late(y, D, Z, X, - learners = list(list(fun = ols), - list(fun = mdl_glmnet), - list(fun = mdl_xgboost, + learners = list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_xgboost, args = list(nrounds = 100, max_depth = 1))), ensemble_type = 'nnls1', shortstack = TRUE, - sample_folds = 10, + sample_folds = 5, silent = TRUE) })#SYSTEM.TIME time_stacking <- system.time({ late_fit <- ddml_late(y, D, Z, X, - learners = list(list(fun = ols), - list(fun = mdl_glmnet), - list(fun = mdl_xgboost, + learners = list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_xgboost, args = list(nrounds = 100, max_depth = 1))), ensemble_type = 'nnls1', shortstack = FALSE, - sample_folds = 10, - cv_folds = 10, + sample_folds = 5, + cv_folds = 5, silent = TRUE) })#SYSTEM.TIME ``` -Both stacking and short-stacking construct weighted averages of the considered base learners to minimize the out-of-sample mean squared prediction error (MSPE). The difference between the two approaches lies in the construction of the MSPE: While stacking runs cross-validation in each cross-fitting sample fold, short-stacking directly uses the out-of-sample predictions arising in the cross-fitting step of double/debiased machine learning estimators. As the run-times below show, this results in a substantially reduced computational burden: +Both stacking and short-stacking construct weighted averages of the considered base learners to minimize the out-of-sample mean squared prediction error (MSPE). The difference between the two approaches lies in the construction of the MSPE: While stacking runs cross-validation in each cross-fitting sample fold, short-stacking directly uses the out-of-sample predictions arising in the cross-fitting step of Double/Debiased Machine Learning estimators. As the run-times below show, this results in a substantially reduced computational burden: ```{r} cat("Time single learner:", time_singlelearner[1], "\n") diff --git a/vignettes/articles/stacking_diagnostics.Rmd b/vignettes/articles/stacking_diagnostics.Rmd new file mode 100644 index 0000000..93b9552 --- /dev/null +++ b/vignettes/articles/stacking_diagnostics.Rmd @@ -0,0 +1,194 @@ +--- +title: "Stacking Diagnostics and Cross-Validation Criteria" +description: "How to evaluate base learners, interpret ensemble weights, and perform statistical inference on learner performance." +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Stacking Diagnostics and Cross-Validation Criteria} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + + + +# Introduction + +In Double/Debiased Machine Learning, the estimation of nuisance parameters (conditional expectation functions) can be substantially improved by adaptively combining multiple machine learners via stacking or short-stacking. + +While stacking is primarily used to minimize the out-of-sample mean squared prediction error (MSPE) of the nuisance functions, it is often insightful for researchers to peek under the hood: Which machine learner performs the best? Are the differences in performance statistically significant, or just noise from the random cross-fitting splits? + +This vignette demonstrates how to extract rich diagnostic information from ``ddml`` objects and how to perform statistical inference on base learner performance using Cross-Validation Criteria (CVC) (Ahrens et al., 2024). + +*(Note: If you are interested in the computational benefits of the short-stacking approach used here compared to standard stacking, see ``vignette("stacking")``.)* + +# Setup and Estimation + +For illustration, we use a random subsample of 5,000 observations from the Angrist & Evans (1998) dataset. We will estimate the local average treatment effect (LATE) of having more than two children (``morekids``) on the mother's labor supply (``worked``), using the sex of the first two children (``samesex``) as an instrument. See ``?AE98`` for details. + + +```r +library(ddml) +set.seed(84210) + +# Construct variables +y <- AE98[, "worked"] +D <- AE98[, "morekids"] +Z <- AE98[, "samesex"] +X <- AE98[, c("age", "agefst", "black", "hisp", "othrace", "educ")] +``` + +First, we estimate the LATE using a combination of linear regression, lasso, and gradient boosting. We use the ``ensemble_type = "nnls1"`` scheme, which constructs a convex combination of the base learners (non-negative weights that sum to one) to minimize the MSPE. + + +```r +# Specify multiple base learners +learners <- list( + list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_xgboost, args = list(nrounds = 10, max_depth = 1)), + list(what = mdl_xgboost, args = list(nrounds = 100, max_depth = 2)) +) + +# Estimate LATE with short-stacking +late_fit <- ddml_late( + y, D, Z, X, + learners = learners, + ensemble_type = "nnls1", + shortstack = TRUE, + sample_folds = 5, + silent = TRUE +) +``` + +# Basic Diagnostics + +The ``diagnostics()`` function extracts the out-of-sample performance of each base learner for every conditional expectation function (reduced form) estimated during the procedure. + + +```r +# Extract stacking diagnostics +diag <- diagnostics(late_fit) +print(diag) +#> Stacking diagnostics: Local Average Treatment Effect +#> Obs: 5000 +#> +#> y_X_Z0: +#> learner mspe r2 weight_nnls1 +#> learner_1 0.2408 0.0316 0.000 +#> learner_2 0.2407 0.0319 0.901 +#> learner_3 0.2446 0.0165 0.000 +#> learner_4 0.2470 0.0067 0.099 +#> +#> y_X_Z1: +#> learner mspe r2 weight_nnls1 +#> learner_1 0.2420 0.0309 0.0000 +#> learner_2 0.2419 0.0314 0.8775 +#> learner_3 0.2459 0.0155 0.0874 +#> learner_4 0.2485 0.0049 0.0351 +#> +#> D_X_Z0: +#> learner mspe r2 weight_nnls1 +#> learner_1 0.2095 0.0776 0.6868 +#> learner_2 0.2095 0.0776 0.0000 +#> learner_3 0.2150 0.0533 0.0693 +#> learner_4 0.2130 0.0621 0.2439 +#> +#> D_X_Z1: +#> learner mspe r2 weight_nnls1 +#> learner_1 0.2239 0.0797 0.7212 +#> learner_2 0.2239 0.0797 0.0000 +#> learner_3 0.2297 0.0560 0.1049 +#> learner_4 0.2288 0.0594 0.1739 +#> +#> Z_X: +#> learner mspe r2 weight_nnls1 +#> learner_1 0.2503 -0.0015 0 +#> learner_2 0.2498 0.0002 1 +#> learner_3 0.2501 -0.0010 0 +#> learner_4 0.2551 -0.0209 0 +``` + +For each reduced form equation (e.g., $E[Y|Z=0, X]$), the diagnostics table reports: +- **Learner:** The specific base learner. +- **MSPE:** The out-of-sample mean squared prediction error. +- **R2:** The out-of-sample $R^2$, computed as $1 - \text{MSPE}/\text{Var}(\text{Target})$. +- **Weight:** The weight assigned to the learner by the chosen ``ensemble_type``. + +For workflows integrated with the ``broom`` package, or when preparing publication-ready tables with ``modelsummary``, the ``tidy()`` method converts the rich diagnostic tables into a flat ``data.frame``. + + +```r +head(tidy(diag)) +#> equation learner mspe r2 weight_nnls1 +#> 1 y_X_Z0 learner_1 0.2408175 0.031591434 4.234957e-17 +#> 2 y_X_Z0 learner_2 0.2407379 0.031911480 9.010382e-01 +#> 3 y_X_Z0 learner_3 0.2445764 0.016475863 0.000000e+00 +#> 4 y_X_Z0 learner_4 0.2470071 0.006701109 9.896183e-02 +#> 5 y_X_Z1 learner_1 0.2420426 0.030906416 0.000000e+00 +#> 6 y_X_Z1 learner_2 0.2419307 0.031354272 8.774719e-01 +``` + +# Inference on Base Learners (Cross-Validation Criteria) + +It is common for researchers to wonder if the base learner assigned the highest weight is *statistically significantly* better than the alternatives. Because cross-fitting creates randomly partitioned hold-out sets, differences in MSPE could simply be due to sample splitting noise. + +``ddml`` implements the Cross-Validation Criteria (CVC) methodology to formally test for equal predictive ability across base learners. Setting ``cvc = TRUE`` in the ``diagnostics()`` function engages a multiplier bootstrap on the out-of-sample fold residuals to test whether each learner performs equally well as the single-best learner. + + +```r +# Run diagnostics with Cross-Validation Criteria tests +diag_cvc <- diagnostics(late_fit, cvc = TRUE, bootnum = 1000) +print(diag_cvc) +#> Stacking diagnostics: Local Average Treatment Effect +#> Obs: 5000 +#> +#> y_X_Z0: +#> learner mspe r2 weight_nnls1 cvc_pval +#> learner_1 0.2408 0.0316 0.000 0.505 +#> learner_2 0.2407 0.0319 0.901 0.996 +#> learner_3 0.2446 0.0165 0.000 0.000 +#> learner_4 0.2470 0.0067 0.099 0.001 +#> +#> y_X_Z1: +#> learner mspe r2 weight_nnls1 cvc_pval +#> learner_1 0.2420 0.0309 0.0000 0.221 +#> learner_2 0.2419 0.0314 0.8775 1.000 +#> learner_3 0.2459 0.0155 0.0874 0.004 +#> learner_4 0.2485 0.0049 0.0351 0.000 +#> +#> D_X_Z0: +#> learner mspe r2 weight_nnls1 cvc_pval +#> learner_1 0.2095 0.0776 0.6868 0.833 +#> learner_2 0.2095 0.0776 0.0000 0.875 +#> learner_3 0.2150 0.0533 0.0693 0.000 +#> learner_4 0.2130 0.0621 0.2439 0.018 +#> +#> D_X_Z1: +#> learner mspe r2 weight_nnls1 cvc_pval +#> learner_1 0.2239 0.0797 0.7212 0.879 +#> learner_2 0.2239 0.0797 0.0000 0.809 +#> learner_3 0.2297 0.0560 0.1049 0.000 +#> learner_4 0.2288 0.0594 0.1739 0.006 +#> +#> Z_X: +#> learner mspe r2 weight_nnls1 cvc_pval +#> learner_1 0.2503 -0.0015 0 0.076 +#> learner_2 0.2498 0.0002 1 0.994 +#> learner_3 0.2501 -0.0010 0 0.253 +#> learner_4 0.2551 -0.0209 0 0.000 +#> +#> Note: CVC compares individual base learners. +#> Shortstacked ensemble CVC is not available (weights use all data). +``` + +A new column is added to the table: +- **CVC p-value:** The p-value testing the null hypothesis that the learner has the same true MSPE as the absolute best-performing learner. A small p-value (e.g., $< 0.05$) indicates that the learner performs significantly worse than the best learner. Conversely, a large p-value means the learner belongs to the "model confidence set" of learners whose performance is not statistically distinguishable from the best. + +# References + +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, Wiemann T (2026). "An Introduction to Double/Debiased Machine Learning." *Journal of Economic Literature*, forthcoming. + +Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and Double Machine Learning." *Journal of Applied Econometrics*, 40(3): 249-269. + +Angrist J, Evans W (1998). "Children and Their Parents' Labor Supply: Evidence from Exogenous Variation in Family Size." *American Economic Review*, 88(3), 450-477. + +Lei J (2020). "Cross-Validation With Confidence." *Journal of the American Statistical Association*, 115(532), 1978-1997. diff --git a/vignettes/articles/stacking_diagnostics.Rmd.txt b/vignettes/articles/stacking_diagnostics.Rmd.txt new file mode 100644 index 0000000..d32041b --- /dev/null +++ b/vignettes/articles/stacking_diagnostics.Rmd.txt @@ -0,0 +1,113 @@ +--- +title: "Stacking Diagnostics and Cross-Validation Criteria" +description: "How to evaluate base learners, interpret ensemble weights, and perform statistical inference on learner performance." +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Stacking Diagnostics and Cross-Validation Criteria} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + eval = TRUE, + warning = FALSE, + message = FALSE +) +``` + +# Introduction + +In Double/Debiased Machine Learning, the estimation of nuisance parameters (conditional expectation functions) can be substantially improved by adaptively combining multiple machine learners via stacking or short-stacking. + +While stacking is primarily used to minimize the out-of-sample mean squared prediction error (MSPE) of the nuisance functions, it is often insightful for researchers to peek under the hood: Which machine learner performs the best? Are the differences in performance statistically significant, or just noise from the random cross-fitting splits? + +This vignette demonstrates how to extract rich diagnostic information from ``ddml`` objects and how to perform statistical inference on base learner performance using Cross-Validation Criteria (CVC) (Ahrens et al., 2024). + +*(Note: If you are interested in the computational benefits of the short-stacking approach used here compared to standard stacking, see ``vignette("stacking")``.)* + +# Setup and Estimation + +For illustration, we use a random subsample of 5,000 observations from the Angrist & Evans (1998) dataset. We will estimate the local average treatment effect (LATE) of having more than two children (``morekids``) on the mother's labor supply (``worked``), using the sex of the first two children (``samesex``) as an instrument. See ``?AE98`` for details. + +```{r} +library(ddml) +set.seed(84210) + +# Construct variables +y <- AE98[, "worked"] +D <- AE98[, "morekids"] +Z <- AE98[, "samesex"] +X <- AE98[, c("age", "agefst", "black", "hisp", "othrace", "educ")] +``` + +First, we estimate the LATE using a combination of linear regression, lasso, and gradient boosting. We use the ``ensemble_type = "nnls1"`` scheme, which constructs a convex combination of the base learners (non-negative weights that sum to one) to minimize the MSPE. + +```{r} +# Specify multiple base learners +learners <- list( + list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_xgboost, args = list(nrounds = 10, max_depth = 1)), + list(what = mdl_xgboost, args = list(nrounds = 100, max_depth = 2)) +) + +# Estimate LATE with short-stacking +late_fit <- ddml_late( + y, D, Z, X, + learners = learners, + ensemble_type = "nnls1", + shortstack = TRUE, + sample_folds = 5, + silent = TRUE +) +``` + +# Basic Diagnostics + +The ``diagnostics()`` function extracts the out-of-sample performance of each base learner for every conditional expectation function (reduced form) estimated during the procedure. + +```{r} +# Extract stacking diagnostics +diag <- diagnostics(late_fit) +print(diag) +``` + +For each reduced form equation (e.g., $E[Y|Z=0, X]$), the diagnostics table reports: +- **Learner:** The specific base learner. +- **MSPE:** The out-of-sample mean squared prediction error. +- **R2:** The out-of-sample $R^2$, computed as $1 - \text{MSPE}/\text{Var}(\text{Target})$. +- **Weight:** The weight assigned to the learner by the chosen ``ensemble_type``. + +For workflows integrated with the ``broom`` package, or when preparing publication-ready tables with ``modelsummary``, the ``tidy()`` method converts the rich diagnostic tables into a flat ``data.frame``. + +```{r} +head(tidy(diag)) +``` + +# Inference on Base Learners (Cross-Validation Criteria) + +It is common for researchers to wonder if the base learner assigned the highest weight is *statistically significantly* better than the alternatives. Because cross-fitting creates randomly partitioned hold-out sets, differences in MSPE could simply be due to sample splitting noise. + +``ddml`` implements the Cross-Validation Criteria (CVC) methodology to formally test for equal predictive ability across base learners. Setting ``cvc = TRUE`` in the ``diagnostics()`` function engages a multiplier bootstrap on the out-of-sample fold residuals to test whether each learner performs equally well as the single-best learner. + +```{r} +# Run diagnostics with Cross-Validation Criteria tests +diag_cvc <- diagnostics(late_fit, cvc = TRUE, bootnum = 1000) +print(diag_cvc) +``` + +A new column is added to the table: +- **CVC p-value:** The p-value testing the null hypothesis that the learner has the same true MSPE as the absolute best-performing learner. A small p-value (e.g., $< 0.05$) indicates that the learner performs significantly worse than the best learner. Conversely, a large p-value means the learner belongs to the "model confidence set" of learners whose performance is not statistically distinguishable from the best. + +# References + +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, Wiemann T (2026). "An Introduction to Double/Debiased Machine Learning." *Journal of Economic Literature*, forthcoming. + +Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and Double Machine Learning." *Journal of Applied Econometrics*, 40(3): 249-269. + +Angrist J, Evans W (1998). "Children and Their Parents' Labor Supply: Evidence from Exogenous Variation in Family Size." *American Economic Review*, 88(3), 450-477. + +Lei J (2020). "Cross-Validation With Confidence." *Journal of the American Statistical Association*, 115(532), 1978-1997. diff --git a/vignettes/ddml.Rmd b/vignettes/ddml.Rmd index 4ae5799..ebc8d0d 100644 --- a/vignettes/ddml.Rmd +++ b/vignettes/ddml.Rmd @@ -1,6 +1,6 @@ --- title: "Get Started" -description: "A brief introduction to double/debiased machine learning using (short-)stacking in R." +description: "A brief introduction to Double/Debiased Machine Learning using (short-)stacking in R." output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Get Started} @@ -13,13 +13,14 @@ vignette: > # Introduction -This article is an introduction to double/debiased machine learning using short-stacking in R. Topics discussed below include: +This article is an introduction to Double/Debiased Machine Learning using short-stacking in R. Topics discussed below include: 1. Estimation with a single machine learner 2. Estimation with multiple machine learners & short-stacking -3. Estimation using different types of short-stacking - -See [Articles](index.html) for discussions of more advanced topics. +3. Inspecting learner performance +4. Estimation using different types of short-stacking +5. Generalizing to other causal models +6. Robust inference via repeated resampling # Estimation with a Single Machine Learner @@ -38,7 +39,7 @@ Z = AE98[, "samesex"] X = AE98[, c("age","agefst","black","hisp","othrace","educ")] ``` -``ddml_late`` estimates the local average treatment effect (LATE) using double/debiased machine learning (see ``?ddml_late``). The high-dimensional nuisance parameters arising in the estimate of the LATE are conditional expectation functions of the control variables $X$. In particular, we require first step estimates of the reduced forms $E[Y|Z=z, X], E[D|Z=z, X]$ for $z=0,1$ and $E[Z|X]$. In the absence of functional form assumptions, these conditional expectations need to be estimated nonparametrically. +``ddml_late`` estimates the local average treatment effect (LATE) using Double/Debiased Machine Learning (see ``?ddml_late``). The high-dimensional nuisance parameters arising in the estimate of the LATE are conditional expectation functions of the control variables $X$. In particular, we require first step estimates of the reduced forms $E[Y|Z=z, X], E[D|Z=z, X]$ for $z=0,1$ and $E[Z|X]$. In the absence of functional form assumptions, these conditional expectations need to be estimated nonparametrically. Here, we consider gradient boosting from the popular [xgboost](https://rdrr.io/cran/xgboost/) package to estimate the nuisance parameters. The function ``mdl_xgboost`` is a wrapper for ``xgboost``, allowing to specify all parameters of the original function. See ``?mdl_xgboost`` for details and take a look at ``vignette("new_ml_wrapper")`` to learn how to write a wrapper for a different machine learner yourself. @@ -50,7 +51,7 @@ learners_single <- list(what = mdl_xgboost, max_depth = 1)) ``` -Double/debiased machine learning relies on cross-fitting to avoid large bias from overfitting when estimating the nuisance parameters. The argument ``sample_folds = 3`` implies that 2/3 of the observations -- about 3,333 observations -- are used to train the machine learner in each cross-fitting sample fold. +Double/Debiased Machine Learning relies on cross-fitting to avoid large bias from overfitting when estimating the nuisance parameters. The argument ``sample_folds = 3`` implies that 2/3 of the observations -- about 3,333 observations -- are used to train the machine learner in each cross-fitting sample fold. ```r # Estimate the local average treatment effect using xgboost. @@ -59,10 +60,11 @@ late_fit <- ddml_late(y, D, Z, X, sample_folds = 3, silent = TRUE) summary(late_fit) -#> LATE estimation results: -#> -#> Estimate Std. Error t value Pr(>|t|) -#> -0.244 0.196 -1.25 0.213 +#> DDML estimation: Local Average Treatment Effect +#> Obs: 5000 Folds: 3 +#> +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.244 0.196 -1.25 0.21 ``` (Note that estimation here is based on a random subsample of 5,000 observations. The results can thus not readily be compared to those in Angrist & Evans (1998).) @@ -76,14 +78,14 @@ Since the statistical properties of machine learners depend heavily on the under ```r -learners_multiple <- list(list(fun = ols), - list(fun = mdl_glmnet), - list(fun = mdl_xgboost, +learners_multiple <- list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_xgboost, args = list(nrounds = 10, max_depth = 1))) ``` -Short-stacking is a computationally convenient variant of stacking originally introduced by Wolpert (1992). Stacking constructs linear combinations of base learners to minimize the out-of-sample mean squared error of a particular reduced form (e.g., $E[Z|X]$). Short-stacking uses the out-of-sample predictions that naturally arise in computation of double/debiased machine learning estimates due to cross-fitting, which substantially reduces the computational burden (see ``vignette("stacking")``). +Short-stacking is a computationally convenient variant of stacking originally introduced by Wolpert (1992). Stacking constructs linear combinations of base learners to minimize the out-of-sample mean squared error of a particular reduced form (e.g., $E[Z|X]$). Short-stacking uses the out-of-sample predictions that naturally arise in computation of Double/Debiased Machine Learning estimates due to cross-fitting, which substantially reduces the computational burden (see ``vignette("stacking")``). In finite samples, regularizing the linear combination of base learners as constructed via (short-)stacking can improve statistical properties. This can be specified via the ``ensemble_type`` argument. Below, ``ddml_late`` estimates the nuisance parameters via linear combinations of the four base learners with linear coefficients that are constrained to be non-negative and sum to one. @@ -98,35 +100,62 @@ late_fit <- ddml_late(y, D, Z, X, sample_folds = 3, silent = TRUE) summary(late_fit) -#> LATE estimation results: -#> -#> Estimate Std. Error t value Pr(>|t|) -#> nnls1 -0.212 0.188 -1.12 0.261 +#> DDML estimation: Local Average Treatment Effect +#> Obs: 5000 Folds: 3 Stacking: short-stack +#> +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.235 0.189 -1.24 0.21 ``` -It is often insightful to see which base learners contribute the most to the final reduced form estimates. The below snippet shows the weights for the reduced forms $E[Y|Z=0,X]$ and $E[Y|Z=1,X]$: +# Inspecting Learner Performance + +It is often insightful to see which base learners contribute the most to the final reduced form estimates. The ``diagnostics()`` function provides a compact summary of each learner's out-of-sample mean squared prediction error (MSPE), $R^2$, and the stacking weight assigned by the chosen ensemble type: ```r -cat("Stacking weights for E[Y|Z=0, X]: \n") -#> Stacking weights for E[Y|Z=0, X]: -t(late_fit$weights$y_X_Z0) -#> [,1] [,2] [,3] -#> nnls1 0.228205 0.5782117 0.1935833 - -cat("Stacking weights for E[Y|Z=1, X]: \n") -#> Stacking weights for E[Y|Z=1, X]: -t(late_fit$weights$y_X_Z1) -#> [,1] [,2] [,3] -#> nnls1 0.2389935 0.6920264 0.0689801 +diagnostics(late_fit) +#> Stacking diagnostics: Local Average Treatment Effect +#> Obs: 5000 +#> +#> y_X_Z0: +#> learner mspe r2 weight_nnls1 +#> learner_1 0.2415 0.0289 0.7891 +#> learner_2 0.2416 0.0283 0.0000 +#> learner_3 0.2442 0.0179 0.2109 +#> +#> y_X_Z1: +#> learner mspe r2 weight_nnls1 +#> learner_1 0.2421 0.0305 0.8593 +#> learner_2 0.2421 0.0305 0.0000 +#> learner_3 0.2462 0.0143 0.1407 +#> +#> D_X_Z0: +#> learner mspe r2 weight_nnls1 +#> learner_1 0.2085 0.0820 0.8911 +#> learner_2 0.2085 0.0820 0.0000 +#> learner_3 0.2141 0.0573 0.1089 +#> +#> D_X_Z1: +#> learner mspe r2 weight_nnls1 +#> learner_1 0.2231 0.0828 0.909 +#> learner_2 0.2231 0.0828 0.000 +#> learner_3 0.2297 0.0556 0.091 +#> +#> Z_X: +#> learner mspe r2 weight_nnls1 +#> learner_1 0.2502 -0.0011 0 +#> learner_2 0.2499 0.0001 1 +#> learner_3 0.2503 -0.0015 0 ``` +For formal statistical tests of whether learner performance differences are significant, see ``vignette("stacking_diagnostics")``. + # Estimation using Different Types of Short-Stacking ``ddml`` supports multiple schemes for constructing linear combinations of base learners. Since each of them relies on the out-of-sample predictions of the base learners, it is computationally cheap to compute them simultaneously. The below snippet estimates the LATE using the base learners in four different linear combinations: - ``'nls'`` constraints the coefficients of each base learner to be non-negative - ``'singlebest'`` selects the single MSPE-minimizing base learner -- ``'ols`` constructs unconstrained linear combinations of base learners +- ``'ols'`` constructs unconstrained linear combinations of base learners - ``'average'`` computes an unweighted average of base learners @@ -141,17 +170,106 @@ late_fit <- ddml_late(y, D, Z, X, sample_folds = 3, silent = TRUE) summary(late_fit) -#> LATE estimation results: -#> -#> Estimate Std. Error t value Pr(>|t|) -#> nnls -0.232 0.190 -1.22 0.222 -#> singlebest -0.232 0.190 -1.22 0.223 -#> ols -0.237 0.190 -1.24 0.214 -#> average -0.223 0.188 -1.18 0.237 +#> DDML estimation: Local Average Treatment Effect +#> Obs: 5000 Folds: 3 Stacking: short-stack +#> +#> Ensemble type: nnls +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.231 0.189 -1.22 0.22 +#> +#> Ensemble type: singlebest +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.227 0.188 -1.21 0.23 +#> +#> Ensemble type: ols +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.231 0.189 -1.22 0.22 +#> +#> Ensemble type: average +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.228 0.189 -1.21 0.23 ``` +# Other Causal Models + +The learner interface and stacking workflow are identical across all ``ddml`` estimators. For example, the partially linear model (PLM) estimates the effect of ``D`` on ``y`` while nonparametrically controlling for ``X`` -- without requiring an instrument. The same set of base learners can be reused directly: + + +```r +plm_fit <- ddml_plm(y, D, X, + learners = learners_multiple, + ensemble_type = 'nnls1', + shortstack = TRUE, + sample_folds = 3, + silent = TRUE) +summary(plm_fit) +#> DDML estimation: Partially Linear Model +#> Obs: 5000 Folds: 3 Stacking: short-stack +#> +#> Estimate Std. Error z value Pr(>|z|) +#> D1 -1.46e-01 1.47e-02 -9.94 <2e-16 *** +#> (Intercept) 7.46e-05 6.89e-03 0.01 0.99 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +``` + +Beyond ``ddml_late`` and ``ddml_plm``, the package supports several other causal models: + +- ``ddml_ate`` -- average treatment effect (see ``?ddml_ate``) +- ``ddml_att`` -- average treatment effect on the treated (see ``?ddml_att``) +- ``ddml_pliv`` -- partially linear IV model (see ``?ddml_pliv``) +- ``ddml_fpliv`` -- flexible partially linear IV model (see ``?ddml_fpliv``) + +# Robust Inference via Repeated Resampling + +Because Double/Debiased Machine Learning relies on random sample splits, point estimates contain _splitting variance_. To stabilize results, ``ddml_replicate()`` repeats the cross-fitting procedure multiple times and aggregates the estimates (see Ahrens et al., 2024): + + +```r +plm_rep <- ddml_replicate(ddml_plm, + y = y, D = D, X = X, + learners = learners_multiple, + ensemble_type = 'nnls1', + shortstack = TRUE, + sample_folds = 3, + resamples = 5, + silent = TRUE) +summary(plm_rep) +#> DDML estimation: Partially Linear Model +#> Obs: 5000 Folds: 3 Resamples: 5 Aggregation: median Stacking: short-stack +#> +#> Estimate Std. Error z value Pr(>|z|) +#> D1 -1.48e-01 1.47e-02 -10.1 <2e-16 *** +#> (Intercept) 7.04e-06 6.88e-03 0.0 1 +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +``` + +For a detailed discussion of aggregation methods and the ``ddml_rep`` class, see ``vignette("repeated_resampling")``. + +# Where to Go Next + +Check out the following articles to learn more: + +- ``vignette("stacking")`` discusses computational benefits of short-stacking +- ``vignette("stacking_diagnostics")`` shows how to evaluate base learners and test for equal predictive ability +- ``vignette("repeated_resampling")`` demonstrates robust inference via repeated cross-fitting +- ``vignette("modelsummary_integration")`` illustrates integration with ``broom`` and ``modelsummary`` +- ``vignette("new_ml_wrapper")`` shows how to write user-provided base learners +- ``vignette("sparse")`` illustrates support of sparse matrices (see ``?Matrix``) +- ``vignette("did")`` discusses integration with the diff-in-diff package [``did``](https://bcallaway11.github.io/did/) + +For additional applied examples, see: + +- ``vignette("example_401k")`` on the effect of 401k participation on retirement savings +- ``vignette("example_BLP95")`` on flexible demand estimation with endogenous prices + # References +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, Wiemann T (2026). "An Introduction to Double/Debiased Machine Learning." Journal of Economic Literature, forthcoming. + +Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. + Angrist J, Evans W (1998). "Children and Their Parents' Labor Supply: Evidence from Exogenous Variation in Family Size." American Economic Review, 88(3), 450-477. Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. diff --git a/vignettes/ddml.Rmd.txt b/vignettes/ddml.Rmd.txt index a0d8ed1..42fd515 100644 --- a/vignettes/ddml.Rmd.txt +++ b/vignettes/ddml.Rmd.txt @@ -1,6 +1,6 @@ --- title: "Get Started" -description: "A brief introduction to double/debiased machine learning using (short-)stacking in R." +description: "A brief introduction to Double/Debiased Machine Learning using (short-)stacking in R." output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Get Started} @@ -12,20 +12,23 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, comment = "#>", - eval = TRUE + eval = TRUE, + warning = FALSE, + message = FALSE ) ``` # Introduction -This article is an introduction to double/debiased machine learning using short-stacking in R. Topics discussed below include: +This article is an introduction to Double/Debiased Machine Learning using short-stacking in R. Topics discussed below include: 1. Estimation with a single machine learner 2. Estimation with multiple machine learners & short-stacking -3. Estimation using different types of short-stacking - -See [Articles](index.html) for discussions of more advanced topics. +3. Inspecting learner performance +4. Estimation using different types of short-stacking +5. Generalizing to other causal models +6. Robust inference via repeated resampling # Estimation with a Single Machine Learner @@ -43,7 +46,7 @@ Z = AE98[, "samesex"] X = AE98[, c("age","agefst","black","hisp","othrace","educ")] ``` -``ddml_late`` estimates the local average treatment effect (LATE) using double/debiased machine learning (see ``?ddml_late``). The high-dimensional nuisance parameters arising in the estimate of the LATE are conditional expectation functions of the control variables $X$. In particular, we require first step estimates of the reduced forms $E[Y|Z=z, X], E[D|Z=z, X]$ for $z=0,1$ and $E[Z|X]$. In the absence of functional form assumptions, these conditional expectations need to be estimated nonparametrically. +``ddml_late`` estimates the local average treatment effect (LATE) using Double/Debiased Machine Learning (see ``?ddml_late``). The high-dimensional nuisance parameters arising in the estimate of the LATE are conditional expectation functions of the control variables $X$. In particular, we require first step estimates of the reduced forms $E[Y|Z=z, X], E[D|Z=z, X]$ for $z=0,1$ and $E[Z|X]$. In the absence of functional form assumptions, these conditional expectations need to be estimated nonparametrically. Here, we consider gradient boosting from the popular [xgboost](https://rdrr.io/cran/xgboost/) package to estimate the nuisance parameters. The function ``mdl_xgboost`` is a wrapper for ``xgboost``, allowing to specify all parameters of the original function. See ``?mdl_xgboost`` for details and take a look at ``vignette("new_ml_wrapper")`` to learn how to write a wrapper for a different machine learner yourself. @@ -54,7 +57,7 @@ learners_single <- list(what = mdl_xgboost, max_depth = 1)) ``` -Double/debiased machine learning relies on cross-fitting to avoid large bias from overfitting when estimating the nuisance parameters. The argument ``sample_folds = 3`` implies that 2/3 of the observations -- about 3,333 observations -- are used to train the machine learner in each cross-fitting sample fold. +Double/Debiased Machine Learning relies on cross-fitting to avoid large bias from overfitting when estimating the nuisance parameters. The argument ``sample_folds = 3`` implies that 2/3 of the observations -- about 3,333 observations -- are used to train the machine learner in each cross-fitting sample fold. ```{r} # Estimate the local average treatment effect using xgboost. late_fit <- ddml_late(y, D, Z, X, @@ -74,14 +77,14 @@ Since the statistical properties of machine learners depend heavily on the under - gradient boosting (see ``?mdl_xgboost``) ```{r} -learners_multiple <- list(list(fun = ols), - list(fun = mdl_glmnet), - list(fun = mdl_xgboost, +learners_multiple <- list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_xgboost, args = list(nrounds = 10, max_depth = 1))) ``` -Short-stacking is a computationally convenient variant of stacking originally introduced by Wolpert (1992). Stacking constructs linear combinations of base learners to minimize the out-of-sample mean squared error of a particular reduced form (e.g., $E[Z|X]$). Short-stacking uses the out-of-sample predictions that naturally arise in computation of double/debiased machine learning estimates due to cross-fitting, which substantially reduces the computational burden (see ``vignette("stacking")``). +Short-stacking is a computationally convenient variant of stacking originally introduced by Wolpert (1992). Stacking constructs linear combinations of base learners to minimize the out-of-sample mean squared error of a particular reduced form (e.g., $E[Z|X]$). Short-stacking uses the out-of-sample predictions that naturally arise in computation of Double/Debiased Machine Learning estimates due to cross-fitting, which substantially reduces the computational burden (see ``vignette("stacking")``). In finite samples, regularizing the linear combination of base learners as constructed via (short-)stacking can improve statistical properties. This can be specified via the ``ensemble_type`` argument. Below, ``ddml_late`` estimates the nuisance parameters via linear combinations of the four base learners with linear coefficients that are constrained to be non-negative and sum to one. @@ -97,22 +100,22 @@ late_fit <- ddml_late(y, D, Z, X, summary(late_fit) ``` -It is often insightful to see which base learners contribute the most to the final reduced form estimates. The below snippet shows the weights for the reduced forms $E[Y|Z=0,X]$ and $E[Y|Z=1,X]$: -```{r} -cat("Stacking weights for E[Y|Z=0, X]: \n") -t(late_fit$weights$y_X_Z0) +# Inspecting Learner Performance -cat("Stacking weights for E[Y|Z=1, X]: \n") -t(late_fit$weights$y_X_Z1) +It is often insightful to see which base learners contribute the most to the final reduced form estimates. The ``diagnostics()`` function provides a compact summary of each learner's out-of-sample mean squared prediction error (MSPE), $R^2$, and the stacking weight assigned by the chosen ensemble type: +```{r} +diagnostics(late_fit) ``` +For formal statistical tests of whether learner performance differences are significant, see ``vignette("stacking_diagnostics")``. + # Estimation using Different Types of Short-Stacking ``ddml`` supports multiple schemes for constructing linear combinations of base learners. Since each of them relies on the out-of-sample predictions of the base learners, it is computationally cheap to compute them simultaneously. The below snippet estimates the LATE using the base learners in four different linear combinations: - ``'nls'`` constraints the coefficients of each base learner to be non-negative - ``'singlebest'`` selects the single MSPE-minimizing base learner -- ``'ols`` constructs unconstrained linear combinations of base learners +- ``'ols'`` constructs unconstrained linear combinations of base learners - ``'average'`` computes an unweighted average of base learners ```{r} @@ -128,8 +131,68 @@ late_fit <- ddml_late(y, D, Z, X, summary(late_fit) ``` +# Other Causal Models + +The learner interface and stacking workflow are identical across all ``ddml`` estimators. For example, the partially linear model (PLM) estimates the effect of ``D`` on ``y`` while nonparametrically controlling for ``X`` -- without requiring an instrument. The same set of base learners can be reused directly: + +```{r} +plm_fit <- ddml_plm(y, D, X, + learners = learners_multiple, + ensemble_type = 'nnls1', + shortstack = TRUE, + sample_folds = 3, + silent = TRUE) +summary(plm_fit) +``` + +Beyond ``ddml_late`` and ``ddml_plm``, the package supports several other causal models: + +- ``ddml_ate`` -- average treatment effect (see ``?ddml_ate``) +- ``ddml_att`` -- average treatment effect on the treated (see ``?ddml_att``) +- ``ddml_pliv`` -- partially linear IV model (see ``?ddml_pliv``) +- ``ddml_fpliv`` -- flexible partially linear IV model (see ``?ddml_fpliv``) + +# Robust Inference via Repeated Resampling + +Because Double/Debiased Machine Learning relies on random sample splits, point estimates contain _splitting variance_. To stabilize results, ``ddml_replicate()`` repeats the cross-fitting procedure multiple times and aggregates the estimates (see Ahrens et al., 2024): + +```{r} +plm_rep <- ddml_replicate(ddml_plm, + y = y, D = D, X = X, + learners = learners_multiple, + ensemble_type = 'nnls1', + shortstack = TRUE, + sample_folds = 3, + resamples = 5, + silent = TRUE) +summary(plm_rep) +``` + +For a detailed discussion of aggregation methods and the ``ddml_rep`` class, see ``vignette("repeated_resampling")``. + +# Where to Go Next + +Check out the following articles to learn more: + +- ``vignette("stacking")`` discusses computational benefits of short-stacking +- ``vignette("stacking_diagnostics")`` shows how to evaluate base learners and test for equal predictive ability +- ``vignette("repeated_resampling")`` demonstrates robust inference via repeated cross-fitting +- ``vignette("modelsummary_integration")`` illustrates integration with ``broom`` and ``modelsummary`` +- ``vignette("new_ml_wrapper")`` shows how to write user-provided base learners +- ``vignette("sparse")`` illustrates support of sparse matrices (see ``?Matrix``) +- ``vignette("did")`` discusses integration with the diff-in-diff package [``did``](https://bcallaway11.github.io/did/) + +For additional applied examples, see: + +- ``vignette("example_401k")`` on the effect of 401k participation on retirement savings +- ``vignette("example_BLP95")`` on flexible demand estimation with endogenous prices + # References +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, Wiemann T (2026). "An Introduction to Double/Debiased Machine Learning." Journal of Economic Literature, forthcoming. + +Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and Double Machine Learning." Journal of Applied Econometrics, 40(3): 249-269. + Angrist J, Evans W (1998). "Children and Their Parents' Labor Supply: Evidence from Exogenous Variation in Family Size." American Economic Review, 88(3), 450-477. Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. diff --git a/vignettes/precompile.R b/vignettes/precompile.R index 2a10641..595ff6a 100644 --- a/vignettes/precompile.R +++ b/vignettes/precompile.R @@ -1,31 +1,101 @@ -# Articles that depend on other packages are precompiled +#!/usr/bin/env Rscript +# Precompile vignettes that depend on external packages, large data, +# or long-running computations. +# +# Usage (from package root): +# Rscript vignettes/precompile.R # knit all vignettes +# Rscript vignettes/precompile.R sparse did # knit selected only + library(knitr) +set.seed(54321) -# depends on keras -knit("vignettes/articles/new_ml_wrapper.Rmd.txt", - "vignettes/articles/new_ml_wrapper.Rmd") +VIGNETTES <- list( + list(name = "ddml", + src = "vignettes/ddml.Rmd.txt", + out = "vignettes/ddml.Rmd", + deps = "ddml", + note = "takes too long for CRAN"), + list(name = "example_BLP95", + src = "vignettes/articles/example_BLP95.Rmd.txt", + out = "vignettes/articles/example_BLP95.Rmd", + deps = c("ddml", "AER", "hdm")), + list(name = "example_401k", + src = "vignettes/articles/example_401k.Rmd.txt", + out = "vignettes/articles/example_401k.Rmd", + deps = "ddml"), + list(name = "sparse", + src = "vignettes/articles/sparse.Rmd.txt", + out = "vignettes/articles/sparse.Rmd", + deps = c("ddml", "Matrix")), + list(name = "stacking", + src = "vignettes/articles/stacking.Rmd.txt", + out = "vignettes/articles/stacking.Rmd", + deps = "ddml"), + list(name = "new_ml_wrapper", + src = "vignettes/articles/new_ml_wrapper.Rmd.txt", + out = "vignettes/articles/new_ml_wrapper.Rmd", + deps = c("ddml", "gbm", "keras")), + list(name = "did", + src = "vignettes/articles/did.Rmd.txt", + out = "vignettes/articles/did.Rmd", + deps = c("ddml", "did"), + note = "needs setwd for fig.path"), + list(name = "stacking_diagnostics", + src = "vignettes/articles/stacking_diagnostics.Rmd.txt", + out = "vignettes/articles/stacking_diagnostics.Rmd", + deps = "ddml"), + list(name = "modelsummary_integration", + src = "vignettes/articles/modelsummary_integration.Rmd.txt", + out = "vignettes/articles/modelsummary_integration.Rmd", + deps = "ddml"), + list(name = "repeated_resampling", + src = "vignettes/articles/repeated_resampling.Rmd.txt", + out = "vignettes/articles/repeated_resampling.Rmd", + deps = "ddml") +) -# depends on AER, hdm -knit("vignettes/articles/example_BLP95.Rmd.txt", - "vignettes/articles/example_BLP95.Rmd") +args <- commandArgs(trailingOnly = TRUE) +if (length(args) > 0L) { + VIGNETTES <- Filter(function(v) v$name %in% args, VIGNETTES) + if (length(VIGNETTES) == 0L) { + known <- vapply(VIGNETTES, `[[`, character(1L), "name") + stop("No matching vignettes. Known names: ", + paste(known, collapse = ", ")) + } +} -# depends on SIPP data -knit("vignettes/articles/example_401k.Rmd.txt", - "vignettes/articles/example_401k.Rmd") +message("=== Precompiling ", length(VIGNETTES), " vignette(s) ===\n") -# depends on AK91 data -knit("vignettes/articles/sparse.Rmd.txt", - "vignettes/articles/sparse.Rmd") +for (v in VIGNETTES) { + missing <- vapply(v$deps, function(pkg) { + !requireNamespace(pkg, quietly = TRUE) + }, logical(1L)) + if (any(missing)) { + message("[SKIP] ", v$name, " -- missing: ", + paste(v$deps[missing], collapse = ", ")) + next + } -# -knit("vignettes/articles/stacking.Rmd.txt", - "vignettes/articles/stacking.Rmd") + if (!file.exists(v$src)) { + message("[SKIP] ", v$name, " -- source not found: ", v$src) + next + } + + message("[KNIT] ", v$name, " (", v$src, " -> ", v$out, ")") + t0 <- proc.time() + + if (identical(v$name, "did") || identical(v$name, "did_native")) { + old_wd <- setwd("vignettes/articles") + tryCatch( + knit(basename(v$src), basename(v$out)), + finally = setwd(old_wd)) + } else { + knit(v$src, v$out) + } -# takes too long to run on cran... -knit("vignettes/ddml.Rmd.txt", - "vignettes/ddml.Rmd") + elapsed <- (proc.time() - t0)[["elapsed"]] + message(" done in ", round(elapsed, 1L), "s\n") +} -# depends on did, change wd for figure references... -setwd("vignettes/articles") -knit("did.Rmd.txt", - "did.Rmd") +message("=== Session info ===") +print(utils::sessionInfo())