From d844d8ed567ce6df2bd73d94816273910ae55c5d Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Thu, 19 Feb 2026 14:28:54 -0600 Subject: [PATCH 01/46] cosmetics --- .gitignore | 3 +++ R/crosspred.R | 22 +++++++++++----------- R/crossval.R | 10 +++++----- R/ddml_ate.R | 4 ++-- R/ddml_att.R | 2 +- R/ddml_fpliv.R | 20 ++++++++++---------- R/ddml_late.R | 16 ++++++++-------- R/ddml_pliv.R | 4 ++-- R/ddml_plm.R | 4 ++-- R/ensemble.R | 2 +- R/help_functions.R | 2 +- R/inference_functions.R | 4 ++-- R/shortstacking.R | 2 +- R/subsample_functions.R | 2 +- 14 files changed, 50 insertions(+), 47 deletions(-) diff --git a/.gitignore b/.gitignore index 168dbaa..3005d50 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,6 @@ inst/doc .direnv /debugging/ /debugger +.cursor/ +.discussion/ +GEMINI.md diff --git a/R/crosspred.R b/R/crosspred.R index 761ee2d..85c6b1d 100644 --- a/R/crosspred.R +++ b/R/crosspred.R @@ -211,8 +211,8 @@ crosspred <- function(y, X, Z = NULL, }#IF # Compute ensemble - mdl_fit <- ensemble(y_, X[-subsamples[[k]], , drop = F], - Z[-subsamples[[k]], , drop = F], + mdl_fit <- ensemble(y_, X[-subsamples[[k]], , drop = FALSE], + Z[-subsamples[[k]], , drop = FALSE], ensemble_type, learners, cv_folds, cv_subsamples_list[[k]], custom_weights = custom_ensemble_weights, @@ -222,9 +222,9 @@ crosspred <- function(y, X, Z = NULL, oos_fitted[subsamples[[k]], ] <- as.numeric(predict.ensemble(mdl_fit, newdata = X[subsamples[[k]], , - drop = F], + drop = FALSE], newZ = Z[subsamples[[k]], , - drop = F])) + drop = FALSE])) # Record ensemble weights weights[, , k] <- mdl_fit$weights @@ -243,8 +243,8 @@ crosspred <- function(y, X, Z = NULL, 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]) + newdata = X[-subsamples[[k]], ,drop = FALSE], + newZ = Z[-subsamples[[k]], , drop = FALSE]) }#IFELSE }#IF # Compute auxilliary predictions (optional) @@ -258,13 +258,13 @@ crosspred <- function(y, X, Z = NULL, 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])) + newdata = X[subsamples[[k]], , drop = FALSE], + newZ = Z[subsamples[[k]], , drop = FALSE])) # 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]) + predict.ensemble(mdl_fit, newdata = X[-subsamples[[k]], ,drop = FALSE], + newZ = Z[-subsamples[[k]], , drop = FALSE]) }#IF # Compute auxilliary predictions by learner (optional) if (!is.null(auxiliary_X)) { @@ -279,7 +279,7 @@ crosspred <- function(y, X, Z = NULL, 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] + new_is_fitted[[i]][[k]] <- is_fitted[[k]][, i, drop = FALSE] }#FOR }#FOR is_fitted <- new_is_fitted diff --git a/R/crossval.R b/R/crossval.R index 9c1b41a..6348caf 100644 --- a/R/crossval.R +++ b/R/crossval.R @@ -96,7 +96,7 @@ crossval <- function(y, X, Z = NULL, # 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] + oos_resid <- oos_resid[order(unlist(cv_subsamples)), , drop = FALSEALSE] # Compute MSPE by learner mspe <- colMeans(oos_resid^2) @@ -123,14 +123,14 @@ crossval_compute <- function(test_sample, learner, # 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_fun$args$X <- cbind(X[-test_sample, assign_X, drop = FALSE], + Z[-test_sample, assign_Z, drop = FALSE]) 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])) + cbind(X[test_sample, assign_X, drop = FALSE], + Z[test_sample, assign_Z, drop = FALSE])) oos_resid <- y[test_sample] - methods::as(oos_fitted, "matrix") # Return residuals and cv_Z diff --git a/R/ddml_ate.R b/R/ddml_ate.R index 3555b80..aed5e67 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -134,7 +134,7 @@ ddml_ate <- function(y, D, X, 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], + 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, @@ -144,7 +144,7 @@ ddml_ate <- function(y, D, 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], + y_X_D1_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, diff --git a/R/ddml_att.R b/R/ddml_att.R index 69e0b44..7aa8c94 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -33,7 +33,7 @@ ddml_att <- function(y, D, X, 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], + 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, diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index 57f26f7..e281844 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -67,7 +67,7 @@ #' # Construct variables from the included Angrist & Evans (1998) data #' y = AE98[, "worked"] #' D = AE98[, "morekids"] -#' Z = AE98[, "samesex", drop = FALSE] +#' Z = AE98[, "samesex", drop = FALSEALSE] #' X = AE98[, c("age","agefst","black","hisp","othrace","educ")] #' #' # Estimate the partially linear IV model using a single base learner: Ridge. @@ -118,14 +118,14 @@ ddml_fpliv <- function(y, D, Z, X, custom_ensemble_weights = custom_ensemble_weights, subsamples = cf_indxs$subsamples, cv_subsamples_list = cf_indxs$cv_subsamples_list, - compute_insample_predictions = F, + compute_insample_predictions = FALSE, silent = silent, progress = "E[Y|X]: ") # 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, + D_XZ_res_list[[k]] <- get_CEF(D[, k, drop = FALSE], X, Z, learners = learners_DXZ, ensemble_type = ensemble_type, shortstack = shortstack, @@ -143,7 +143,7 @@ ddml_fpliv <- function(y, D, Z, X, 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, + D_X_res_list[[k]] <- get_CEF(D[, k, drop = FALSE], X, Z = NULL, learners = learners_DX, ensemble_type = ensemble_type, shortstack = shortstack, @@ -152,7 +152,7 @@ ddml_fpliv <- function(y, D, Z, X, subsamples = cf_indxs$subsamples, cv_subsamples_list = cf_indxs$cv_subsamples_list, - compute_insample_predictions = F, + compute_insample_predictions = FALSE, silent = silent, progress = paste0("E[D", k, "|X]: ")) }#FOR @@ -180,7 +180,7 @@ ddml_fpliv <- function(y, D, Z, X, shortstack = shortstack, subsamples = cf_indxs$subsamples, cv_subsamples_list = cf_indxs$cv_subsamples_list, - compute_insample_predictions = F, + compute_insample_predictions = FALSE, silent = silent, progress = paste0("E[D", k, "|X]: "), shortstack_y = D_XZ_res_list[[k]]$oos_fitted) @@ -236,7 +236,7 @@ ddml_fpliv <- function(y, D, Z, X, shortstack = shortstack, subsamples = cf_indxs$subsamples, cv_subsamples_list = cf_indxs$cv_subsamples_list, - compute_insample_predictions = F, + compute_insample_predictions = FALSE, silent = silent, progress = progress_jk, shortstack_y = D_XZ_res_list[[k]]$oos_fitted[, j]) @@ -247,17 +247,17 @@ ddml_fpliv <- function(y, D, Z, X, ensemble_type = "average", shortstack = shortstack, custom_ensemble_weights = - custom_ensemble_weights_DX[, j - nensb_raw, drop = F], + custom_ensemble_weights_DX[, j - nensb_raw, drop = FALSE], subsamples = cf_indxs$subsamples, cv_subsamples_list = cf_indxs$cv_subsamples_list, - compute_insample_predictions = F, + compute_insample_predictions = FALSE, 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] + drop = FALSE] }#IFELSE diff --git a/R/ddml_late.R b/R/ddml_late.R index a49544e..cf7467a 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -105,7 +105,7 @@ #' 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. @@ -176,7 +176,7 @@ ddml_late <- function(y, D, Z, X, if (!silent) cat("DDML estimation in progress. \n") # Compute estimates of E[y|Z=0,X] - y_X_Z0_res <- get_CEF(y[is_Z0], X[is_Z0, , drop = F], + y_X_Z0_res <- get_CEF(y[is_Z0], X[is_Z0, , drop = FALSE], learners = learners, ensemble_type = ensemble_type, shortstack = shortstack, custom_ensemble_weights = custom_ensemble_weights, @@ -186,7 +186,7 @@ ddml_late <- function(y, D, Z, X, auxiliary_X = get_auxiliary_X(aux_indxs[[1]], X)) # Compute estimates of E[y|Z=1,X] - y_X_Z1_res <- get_CEF(y[-is_Z0], X[-is_Z0, , drop = F], + y_X_Z1_res <- get_CEF(y[-is_Z0], X[-is_Z0, , drop = FALSE], learners = learners, ensemble_type = ensemble_type, shortstack = shortstack, custom_ensemble_weights = custom_ensemble_weights, @@ -205,14 +205,14 @@ ddml_late <- function(y, D, Z, X, 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], + D_X_Z0_res <- get_CEF(D[is_Z0], X[is_Z0, , drop = FALSE], 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]: ", + silent = silent, progress = "E[D|Z=0,X]: ", auxiliary_X = get_auxiliary_X(aux_indxs[[1]], X)) }#IFELSE @@ -226,14 +226,14 @@ ddml_late <- function(y, D, Z, X, 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], + D_X_Z1_res <- get_CEF(D[-is_Z0], X[-is_Z0, , drop = FALSE], 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]: ", + silent = silent, progress = "E[D|Z=1,X]: ", auxiliary_X = get_auxiliary_X(aux_indxs[[2]], X)) }#IFELSE @@ -244,7 +244,7 @@ ddml_late <- function(y, D, Z, X, custom_ensemble_weights = custom_ensemble_weights_ZX, subsamples = cf_indxs$subsamples, cv_subsamples_list = cf_indxs$cv_subsamples_list, - compute_insample_predictions = F, + compute_insample_predictions = FALSE, silent = silent, progress = "E[Z|X]: ") # Update ensemble type to account for (optional) custom weights diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index 3fcff09..2654495 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -154,7 +154,7 @@ ddml_pliv <- function(y, D, Z, 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, + Z_X_res_list[[k]] <- get_CEF(Z[, k, drop = FALSE], X, learners = learners_ZX, ensemble_type = ensemble_type, shortstack = shortstack, @@ -170,7 +170,7 @@ ddml_pliv <- function(y, D, Z, 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, + D_X_res_list[[k]] <- get_CEF(D[, k, drop = FALSE], X, learners = learners_DX, ensemble_type = ensemble_type, shortstack = shortstack, diff --git a/R/ddml_plm.R b/R/ddml_plm.R index e3530d4..34aabba 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -183,7 +183,7 @@ ddml_plm <- function(y, D, 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, + D_X_res_list[[k]] <- get_CEF(D[, k, drop = FALSE], X, learners = learners_DX, ensemble_type = ensemble_type, shortstack = shortstack, @@ -338,7 +338,7 @@ summary.ddml_plm <- function(object, ...) { #' \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 digits Number of significant digits used for printing. #' @param ... Currently unused. #' #' @return NULL. diff --git a/R/ensemble.R b/R/ensemble.R index 327981d..f259369 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -171,7 +171,7 @@ ensemble_weights <- function(y, X, Z = NULL, 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 <- which.min(Matrix::colMeans(cv_results$oos_resid^2)[, drop = FALSE]) mdl_min <- (1:nlearners)[mdl_min] # Assign unit weight to the best model weights[mdl_min, k] <- 1 diff --git a/R/help_functions.R b/R/help_functions.R index 51622f8..8d87838 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -28,7 +28,7 @@ trim_propensity_scores <- function(m_X, trim, ensemble_type) { # Data parameter 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)) diff --git a/R/inference_functions.R b/R/inference_functions.R index 6e5fd68..8bfb7cd 100644 --- a/R/inference_functions.R +++ b/R/inference_functions.R @@ -42,7 +42,7 @@ compute_inf_results_by_ensemble <- function(fit_obj, cluster_variable, ...) { 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) + FUN.VALUE = 1, lower.tail = FALSE) # Store results in a matrix inf_results <- array(0, dim = c(ncoef, 4, 1)) @@ -95,7 +95,7 @@ compute_interactive_inf_results_by_ensemble <- function(coef, psi_a, psi_b, 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) + FUN.VALUE = 1, lower.tail = FALSE) # Store results in a matrix inf_results <- c(coef, std_error, t_values, p_value) # Return results diff --git a/R/shortstacking.R b/R/shortstacking.R index edce6ab..a2c9465 100644 --- a/R/shortstacking.R +++ b/R/shortstacking.R @@ -146,7 +146,7 @@ shortstacking <- function (y, X, Z = NULL, 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] + new_is_fitted[[i]][[k]] <- is_fitted[[k]][, i, drop = FALSE] }#FOR }#FOR is_fitted <- new_is_fitted diff --git a/R/subsample_functions.R b/R/subsample_functions.R index 6d2e584..b7aa1ce 100644 --- a/R/subsample_functions.R +++ b/R/subsample_functions.R @@ -195,7 +195,7 @@ generate_subsamples <- function(nobs, sample_folds) { sample_groups <- sample(sampleframe, size=nobs, replace=F) subsamples <- sapply(1:sample_folds, function(x) {which(sample_groups == x)}, - simplify = F) + simplify = FALSE) subsamples }#GENERATE_SUBSAMPLES From 5b6ce6dfbbbcee3c7e7218021c80fdec91394c2a Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Mon, 23 Feb 2026 11:34:15 -0600 Subject: [PATCH 02/46] refactor subsampling functions --- .Rbuildignore | 3 + .github/workflows/pkgdown.yaml | 2 +- NEWS.md | 10 + R/crosspred.R | 56 ++- R/crossval.R | 14 +- R/ddml_ate.R | 53 +- R/ddml_att.R | 48 +- R/ddml_fpliv.R | 61 ++- R/ddml_late.R | 67 +-- R/ddml_pliv.R | 47 +- R/ddml_plm.R | 47 +- R/ensemble.R | 4 +- R/get_CEF.R | 8 +- R/shortstacking.R | 21 +- R/subsample_functions.R | 565 +++++++++++++++------- man/crosspred.Rd | 22 +- man/crossval.Rd | 5 +- man/ddml_ate.Rd | 17 +- man/ddml_fpliv.Rd | 7 +- man/ddml_late.Rd | 18 +- man/ddml_pliv.Rd | 7 +- man/ddml_plm.Rd | 7 +- man/print.summary.ddml_plm.Rd | 2 +- man/shortstacking.Rd | 7 +- tests/testthat/test-ddml_ate.R | 37 +- tests/testthat/test-ddml_att.R | 37 +- tests/testthat/test-ddml_fpliv.R | 18 +- tests/testthat/test-ddml_late.R | 41 +- tests/testthat/test-ddml_plm.R | 21 + tests/testthat/test-subsample_functions.R | 267 ++++++---- 30 files changed, 1038 insertions(+), 481 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index 4b8e8a2..1d75826 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -21,3 +21,6 @@ ^CRAN-SUBMISSION$ ^debugging$ ^debugger$ +^\.cursor$ +^\.discussion$ +^GEMINI\.md$ diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 3abf6f0..98a72d9 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -44,7 +44,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/NEWS.md b/NEWS.md index 1abb319..7e10596 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,15 @@ # ddml 0.3.1 +* Adds stratified cross-fitting to ``ddml_ate()``, ``ddml_att()``, and + ``ddml_late()`` via the ``stratify`` parameter. + Stratified splitting is now the default. +* Adds ``cluster_variable`` to ``crossval()``, ``crosspred()``, and + ``shortstacking()`` for cluster-aware sample splitting. +* Renames ``cv_subsamples_list`` to ``cv_subsamples``. The old name + still works with a deprecation message. +* Replaces internal ``get_all_indx()`` with ``get_sample_splits()``. +* Warns when any cross-fitting training set has fewer than 100 + observations. * 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. diff --git a/R/crosspred.R b/R/crosspred.R index 85c6b1d..3c054b5 100644 --- a/R/crosspred.R +++ b/R/crosspred.R @@ -58,8 +58,9 @@ #' predictions should also be computed for each learner (rather than the #' entire ensemble). #' @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. @@ -72,20 +73,20 @@ #' \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}. +#' \item{\code{is_fitted}}{When \code{compute_insample_predictions = TRUE}. #' a list of matrices with in-sample predictions by sample fold.} #' \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 +#' \code{compute_predictions_bylearner = TRUE}, 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 +#' \code{compute_insample_predictions = TRUE} and +#' \code{compute_predictions_bylearner = TRUE}, 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 +#' not \code{NULL} and \code{compute_predictions_bylearner = TRUE}, a #' list of matrices with additional predictions for each learner.} #' } #' @export @@ -120,17 +121,27 @@ #' dim(crosspred_res$oos_fitted_bylearner) # = length(y) by length(learners) crosspred <- function(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) { + # 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.") + 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) @@ -138,21 +149,20 @@ crosspred <- function(y, X, Z = NULL, ncustom <- ncol(custom_ensemble_weights) ncustom <- ifelse(is.null(ncustom), 0, ncustom) nensb <- length(ensemble_type) + ncustom - # Create sample fold tuple - if (is.null(subsamples)) { - subsamples <- generate_subsamples(nobs, sample_folds) - }#IF - sample_folds <- length(subsamples) + # Check whether ddml uses conventional stacking w/ data driven weights + w_cv <- any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & + (class(learners[[1]]) != "function") - # 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]]) + # Create crossfitting and cv tuples + indxs <- get_sample_splits(cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = if (w_cv) 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 # Initialize output matrices oos_fitted <- matrix(0, nobs, nensb^(calc_ensemble)) @@ -214,7 +224,7 @@ crosspred <- function(y, X, Z = NULL, mdl_fit <- ensemble(y_, X[-subsamples[[k]], , drop = FALSE], Z[-subsamples[[k]], , drop = FALSE], ensemble_type, learners, - cv_folds, cv_subsamples_list[[k]], + cv_folds, cv_subsamples[[k]], custom_weights = custom_ensemble_weights, silent = silent, progress = paste0(progress_k, ", ")) diff --git a/R/crossval.R b/R/crossval.R index 6348caf..18588b7 100644 --- a/R/crossval.R +++ b/R/crossval.R @@ -60,7 +60,8 @@ #' cv_res$mspe crossval <- function(y, X, Z = NULL, learners, - cv_folds = 5, + cv_folds = 10, + cluster_variable = seq_along(y), cv_subsamples = NULL, silent = FALSE, progress = NULL) { @@ -68,10 +69,11 @@ crossval <- function(y, X, Z = NULL, 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 @@ -96,7 +98,7 @@ crossval <- function(y, X, Z = NULL, # Compile residual matrix oos_resid <- unlist(cv_res) oos_resid <- matrix(oos_resid, nobs, nlearners) - oos_resid <- oos_resid[order(unlist(cv_subsamples)), , drop = FALSEALSE] + oos_resid <- oos_resid[order(unlist(cv_subsamples)), , drop = FALSE] # Compute MSPE by learner mspe <- colMeans(oos_resid^2) diff --git a/R/ddml_ate.R b/R/ddml_ate.R index aed5e67..59856ca 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -36,6 +36,8 @@ #' 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 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}. #' @@ -58,8 +60,7 @@ #' \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{subsamples_byD},\code{cv_subsamples_byD}, #' \code{ensemble_type}}{Pass-through of #' selected user-provided arguments. See above.} #' } @@ -112,7 +113,10 @@ ddml_ate <- function(y, D, X, custom_ensemble_weights = NULL, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), + stratify = TRUE, + subsamples = NULL, subsamples_byD = NULL, + cv_subsamples = NULL, cv_subsamples_byD = NULL, trim = 0.01, silent = FALSE) { @@ -120,15 +124,22 @@ ddml_ate <- function(y, D, X, 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) + # Check whether ddml uses conventional stacking w/ data driven weights + w_cv <- !shortstack & + any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & + (class(learners[[1]]) != "function") - # Create tuple for extrapolated fitted values - aux_indxs <- get_auxiliary_indx(cf_indxs$subsamples_byD, D) + # Create crossfitting and cv tuples + indxs <- get_sample_splits(cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = if (w_cv) cv_folds, + D = D, stratify = stratify, + subsamples = subsamples, + subsamples_byD = subsamples_byD, + cv_subsamples = cv_subsamples, + cv_subsamples_byD = cv_subsamples_byD) + check_subsamples(indxs$subsamples, indxs$subsamples_byD, + stratify, D) # Print to progress to console if (!silent) cat("DDML estimation in progress. \n") @@ -138,28 +149,28 @@ ddml_ate <- function(y, D, X, 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]], + subsamples = indxs$subsamples_byD[[1]], + cv_subsamples = indxs$cv_subsamples_byD[[1]], silent = silent, progress = "E[Y|D=0,X]: ", - auxiliary_X = get_auxiliary_X(aux_indxs[[1]], X)) + auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X)) # Compute estimates of E[y|D=1,X] y_X_D1_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 = cf_indxs$subsamples_byD[[2]], - cv_subsamples_list = cf_indxs$cv_subsamples_byD[[2]], + subsamples = indxs$subsamples_byD[[2]], + cv_subsamples = indxs$cv_subsamples_byD[[2]], silent = silent, progress = "E[Y|D=1,X]: ", - auxiliary_X = get_auxiliary_X(aux_indxs[[2]], X)) + auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X)) # 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, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, silent = silent, progress = "E[D|X]: ") # Update ensemble type to account for (optional) custom weights @@ -173,7 +184,7 @@ ddml_ate <- function(y, D, X, 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) + aux_indx = indxs$aux_indx) m_X <- D_X_res$oos_fitted # Trim propensity scores, return warnings @@ -213,8 +224,8 @@ ddml_ate <- function(y, D, X, learners = learners, learners_DX = learners_DX, cluster_variable = cluster_variable, - subsamples_byD = subsamples_byD, - cv_subsamples_byD = cv_subsamples_byD, + subsamples_byD = indxs$subsamples_byD, + cv_subsamples_byD = indxs$cv_subsamples_byD, ensemble_type = ensemble_type) # Print estimation progress diff --git a/R/ddml_att.R b/R/ddml_att.R index 7aa8c94..10530d3 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -11,7 +11,10 @@ ddml_att <- function(y, D, X, custom_ensemble_weights = NULL, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), + stratify = TRUE, + subsamples = NULL, subsamples_byD = NULL, + cv_subsamples = NULL, cv_subsamples_byD = NULL, trim = 0.01, silent = FALSE) { @@ -19,15 +22,22 @@ ddml_att <- function(y, D, X, 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) + # Check whether ddml uses conventional stacking w/ data driven weights + w_cv <- !shortstack & + any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & + (class(learners[[1]]) != "function") + + # Create crossfitting and cv tuples + indxs <- get_sample_splits(cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = if (w_cv) cv_folds, + D = D, stratify = stratify, + subsamples = subsamples, + subsamples_byD = subsamples_byD, + cv_subsamples = cv_subsamples, + cv_subsamples_byD = cv_subsamples_byD) + check_subsamples(indxs$subsamples, indxs$subsamples_byD, + stratify, D) # Print to progress to console if (!silent) cat("DDML estimation in progress. \n") @@ -37,18 +47,18 @@ ddml_att <- function(y, D, X, 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]], + subsamples = indxs$subsamples_byD[[1]], + cv_subsamples = indxs$cv_subsamples_byD[[1]], silent = silent, progress = "E[Y|D=0,X]: ", - auxiliary_X = get_auxiliary_X(aux_indxs[[1]], X)) + auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X)) # 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, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, silent = silent, progress = "E[D|X]: ") # Compute estimates of E[D] -- simple computation of averages here @@ -56,8 +66,8 @@ ddml_att <- function(y, D, X, learners = list(what = ols), ensemble_type = "average", shortstack = FALSE, - cv_subsamples_list = NULL, - subsamples = cf_indxs$subsamples, + cv_subsamples = NULL, + subsamples = indxs$subsamples, silent = TRUE) # Update ensemble type to account for (optional) custom weights @@ -70,7 +80,7 @@ ddml_att <- function(y, D, X, # 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] + aux_indx = indxs$aux_indx)[, , 1] m_X <- D_X_res$oos_fitted # Trim propensity scores, return warnings @@ -104,8 +114,8 @@ ddml_att <- function(y, D, X, learners = learners, learners_DX = learners_DX, cluster_variable = cluster_variable, - subsamples = cf_indxs$subsamples_byD, - cv_subsamples_list = cf_indxs$cv_subsamples_byD, + subsamples_byD = indxs$subsamples_byD, + cv_subsamples_byD = indxs$cv_subsamples_byD, ensemble_type = ensemble_type) # Print estimation progress diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index e281844..ba9fe68 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -48,7 +48,7 @@ #' \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 +#' \code{cv_subsamples},\code{ensemble_type}}{Pass-through of #' selected user-provided arguments. See above.} #' } #' @export @@ -67,7 +67,7 @@ #' # Construct variables from the included Angrist & Evans (1998) data #' y = AE98[, "worked"] #' D = AE98[, "morekids"] -#' Z = AE98[, "samesex", drop = FALSEALSE] +#' 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. @@ -91,8 +91,17 @@ ddml_fpliv <- function(y, D, Z, X, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), subsamples = NULL, + cv_subsamples = NULL, cv_subsamples_list = NULL, silent = FALSE) { + # 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.") + message("Note: cv_subsamples_list has been renamed to cv_subsamples.") + cv_subsamples <- cv_subsamples_list + }#IF + # Data parameters nobs <- length(y) nensb_raw <- length(ensemble_type) # number of ensembles w/o custom weights @@ -101,12 +110,18 @@ ddml_fpliv <- function(y, D, Z, X, 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) + # Check whether ddml uses conventional stacking w/ data driven weights + w_cv <- !shortstack & + any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & + (class(learners[[1]]) != "function") + + # Create crossfitting and cv tuples + indxs <- get_sample_splits(cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = if (w_cv) cv_folds, + subsamples = subsamples, + cv_subsamples = cv_subsamples) + check_subsamples(indxs$subsamples, NULL, stratify = FALSE) # Print to progress to console if (!silent) cat("DDML estimation in progress. \n") @@ -116,8 +131,8 @@ ddml_fpliv <- function(y, D, Z, 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, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, compute_insample_predictions = FALSE, silent = silent, progress = "E[Y|X]: ") @@ -131,9 +146,9 @@ ddml_fpliv <- function(y, D, Z, X, shortstack = shortstack, custom_ensemble_weights = custom_ensemble_weights_DXZ, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = - cf_indxs$cv_subsamples_list, + subsamples = indxs$subsamples, + cv_subsamples = + indxs$cv_subsamples, compute_insample_predictions = enforce_LIE, silent = silent, progress = paste0("E[D", k, "|X,Z]: ")) @@ -149,9 +164,9 @@ ddml_fpliv <- function(y, D, Z, X, shortstack = shortstack, custom_ensemble_weights = custom_ensemble_weights_DX, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = - cf_indxs$cv_subsamples_list, + subsamples = indxs$subsamples, + cv_subsamples = + indxs$cv_subsamples, compute_insample_predictions = FALSE, silent = silent, progress = paste0("E[D", k, "|X]: ")) @@ -178,8 +193,8 @@ ddml_fpliv <- function(y, D, Z, X, learners = learners_DX, ensemble_type = ensemble_type, shortstack = shortstack, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, compute_insample_predictions = FALSE, silent = silent, progress = paste0("E[D", k, "|X]: "), @@ -234,8 +249,8 @@ ddml_fpliv <- function(y, D, Z, X, learners = learners_DX, ensemble_type = ensemble_type[j], shortstack = shortstack, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, compute_insample_predictions = FALSE, silent = silent, progress = progress_jk, @@ -248,8 +263,8 @@ ddml_fpliv <- function(y, D, Z, X, shortstack = shortstack, custom_ensemble_weights = custom_ensemble_weights_DX[, j - nensb_raw, drop = FALSE], - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, compute_insample_predictions = FALSE, silent = silent, progress = progress_jk, @@ -312,7 +327,7 @@ ddml_fpliv <- function(y, D, Z, X, iv_fit = iv_fit, cluster_variable = cluster_variable, subsamples = subsamples, - cv_subsamples_list = cv_subsamples_list, + cv_subsamples = indxs$cv_subsamples, ensemble_type = ensemble_type, enforce_LIE = enforce_LIE) diff --git a/R/ddml_late.R b/R/ddml_late.R index cf7467a..d88fc76 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -90,9 +90,8 @@ #' \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 +#' \code{cluster_variable},\code{subsamples_byZ}, +#' \code{cv_subsamples_byZ},\code{ensemble_type}}{Pass-through #' of selected user-provided arguments. See above.} #' } #' @export @@ -154,7 +153,10 @@ 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), + stratify = TRUE, + subsamples = NULL, subsamples_byZ = NULL, + cv_subsamples = NULL, cv_subsamples_byZ = NULL, trim = 0.01, silent = FALSE) { @@ -162,15 +164,22 @@ ddml_late <- function(y, D, Z, X, 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) + # Check whether ddml uses conventional stacking w/ data driven weights + w_cv <- !shortstack & + any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & + (class(learners[[1]]) != "function") - # Create tuple for extrapolated fitted values - aux_indxs <- get_auxiliary_indx(cf_indxs$subsamples_byD, Z) + # Create crossfitting and cv tuples + indxs <- get_sample_splits(cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = if (w_cv) cv_folds, + D = Z, stratify = stratify, + subsamples = subsamples, + subsamples_byD = subsamples_byZ, + cv_subsamples = cv_subsamples, + cv_subsamples_byD = cv_subsamples_byZ) + check_subsamples(indxs$subsamples, indxs$subsamples_byD, + stratify, Z) # Print to progress to console if (!silent) cat("DDML estimation in progress. \n") @@ -180,20 +189,20 @@ ddml_late <- function(y, D, Z, X, 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]], + subsamples = indxs$subsamples_byD[[1]], + cv_subsamples = indxs$cv_subsamples_byD[[1]], silent = silent, progress = "E[Y|Z=0,X]: ", - auxiliary_X = get_auxiliary_X(aux_indxs[[1]], X)) + auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X)) # Compute estimates of E[y|Z=1,X] y_X_Z1_res <- get_CEF(y[-is_Z0], X[-is_Z0, , drop = FALSE], 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]], + subsamples = indxs$subsamples_byD[[2]], + cv_subsamples = indxs$cv_subsamples_byD[[2]], silent = silent, progress = "E[Y|Z=1,X]: ", - auxiliary_X = get_auxiliary_X(aux_indxs[[2]], X)) + auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X)) # Check for perfect non-compliance if (all(D[Z==0] == 0)) { @@ -210,10 +219,10 @@ ddml_late <- function(y, D, Z, X, 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]], + subsamples = indxs$subsamples_byD[[1]], + cv_subsamples = indxs$cv_subsamples_byD[[1]], silent = silent, progress = "E[D|Z=0,X]: ", - auxiliary_X = get_auxiliary_X(aux_indxs[[1]], X)) + auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X)) }#IFELSE # Check for perfect compliance @@ -231,10 +240,10 @@ ddml_late <- function(y, D, Z, X, 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]], + subsamples = indxs$subsamples_byD[[2]], + cv_subsamples = indxs$cv_subsamples_byD[[2]], silent = silent, progress = "E[D|Z=1,X]: ", - auxiliary_X = get_auxiliary_X(aux_indxs[[2]], X)) + auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X)) }#IFELSE # Compute estimates of E[Z|X] @@ -242,8 +251,8 @@ ddml_late <- function(y, D, 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, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, compute_insample_predictions = FALSE, silent = silent, progress = "E[Z|X]: ") @@ -258,11 +267,11 @@ ddml_late <- function(y, D, Z, X, 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) + aux_indx = indxs$aux_indx) 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) + aux_indx = indxs$aux_indx) r_X <- Z_X_res$oos_fitted # Trim propensity scores, return warnings @@ -310,8 +319,8 @@ ddml_late <- function(y, D, Z, X, learners_DXZ = learners_DXZ, learners_ZX = learners_ZX, cluster_variable = cluster_variable, - subsamples_byZ = subsamples_byZ, - cv_subsamples_byZ = cv_subsamples_byZ, + subsamples_byZ = indxs$subsamples_byD, + cv_subsamples_byZ = indxs$cv_subsamples_byD, ensemble_type = ensemble_type) # Print estimation progress diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index 2654495..bcb2696 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -74,7 +74,7 @@ #' 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 +#' \code{cv_subsamples},\code{ensemble_type}}{Pass-through of #' selected user-provided arguments. See above.} #' } #' @export @@ -119,8 +119,17 @@ ddml_pliv <- function(y, D, Z, X, custom_ensemble_weights_ZX = custom_ensemble_weights, cluster_variable = seq_along(y), subsamples = NULL, + cv_subsamples = NULL, cv_subsamples_list = NULL, silent = FALSE) { + # 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.") + message("Note: cv_subsamples_list has been renamed to cv_subsamples.") + cv_subsamples <- cv_subsamples_list + }#IF + # Data parameters nobs <- length(y) nlearners <- length(learners) @@ -135,20 +144,26 @@ ddml_pliv <- function(y, D, Z, X, 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) + # Check whether ddml uses conventional stacking w/ data driven weights + w_cv <- !shortstack & + any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & + (class(learners[[1]]) != "function") + + # Create crossfitting and cv tuples + indxs <- get_sample_splits(cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = if (w_cv) cv_folds, + subsamples = subsamples, + cv_subsamples = cv_subsamples) + check_subsamples(indxs$subsamples, NULL, stratify = FALSE) # Compute estimates of 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, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, silent = silent, progress = "E[Y|X]: ") # Compute estimates of E[Z|X], loop through instruments @@ -160,9 +175,9 @@ ddml_pliv <- function(y, D, Z, X, shortstack = shortstack, custom_ensemble_weights = custom_ensemble_weights_ZX, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = - cf_indxs$cv_subsamples_list, + subsamples = indxs$subsamples, + cv_subsamples = + indxs$cv_subsamples, silent = silent, progress = paste0("E[Z", k, "|X]: ")) }#FOR @@ -176,9 +191,9 @@ ddml_pliv <- function(y, D, Z, X, shortstack = shortstack, custom_ensemble_weights = custom_ensemble_weights_DX, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = - cf_indxs$cv_subsamples_list, + subsamples = indxs$subsamples, + cv_subsamples = + indxs$cv_subsamples, silent = silent, progress = paste0("E[D", k, "|X]: ")) }#FOR @@ -252,7 +267,7 @@ ddml_pliv <- function(y, D, Z, X, iv_fit = iv_fit, cluster_variable = cluster_variable, subsamples = subsamples, - cv_subsamples_list = cv_subsamples_list, + cv_subsamples = indxs$cv_subsamples, ensemble_type = ensemble_type) # Amend class and return diff --git a/R/ddml_plm.R b/R/ddml_plm.R index 34aabba..cf8b73e 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -72,8 +72,9 @@ #' \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 +#' @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 silent Boolean to silence estimation updates. #' #' @return \code{ddml_plm} returns an object of S3 class @@ -91,7 +92,7 @@ #' 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{subsamples}, \code{cv_subsamples}, #' \code{ensemble_type}}{Pass-through of selected user-provided #' arguments. See above.} #' } @@ -148,8 +149,17 @@ ddml_plm <- function(y, D, X, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), subsamples = NULL, + cv_subsamples = NULL, cv_subsamples_list = NULL, silent = FALSE) { + # 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.") + message("Note: cv_subsamples_list has been renamed to cv_subsamples.") + cv_subsamples <- cv_subsamples_list + }#IF + # Data parameters nobs <- length(y) ncustom <- ncol(custom_ensemble_weights) @@ -160,12 +170,19 @@ ddml_plm <- function(y, D, X, 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) + # Check whether ddml uses conventional stacking w/ data driven weights + w_cv <- !shortstack & + any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & + (class(learners[[1]]) != "function" | + class(learners_DX[[1]]) != "function") + + # Create crossfitting and cv tuples + indxs <- get_sample_splits(cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = if (w_cv) cv_folds, + subsamples = subsamples, + cv_subsamples = cv_subsamples) + check_subsamples(indxs$subsamples, NULL, stratify = FALSE) # Print to progress to console if (!silent) cat("DDML estimation in progress. \n") @@ -176,8 +193,8 @@ ddml_plm <- function(y, D, X, ensemble_type = ensemble_type, shortstack = shortstack, custom_ensemble_weights = custom_ensemble_weights, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, silent = silent, progress = "E[Y|X]: ") # Compute estimates of E[D|X], loop through endogenous variables @@ -189,9 +206,9 @@ ddml_plm <- function(y, D, X, shortstack = shortstack, custom_ensemble_weights = custom_ensemble_weights_DX, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = - cf_indxs$cv_subsamples_list, + subsamples = indxs$subsamples, + cv_subsamples = + indxs$cv_subsamples, silent = silent, progress = paste0("E[D", k, "|X]: ")) }#FOR @@ -259,8 +276,8 @@ ddml_plm <- function(y, D, X, learners_DX = learners_DX, ols_fit = ols_fit, cluster_variable = cluster_variable, - subsamples = cf_indxs$subsamples, - cv_subsamples_list = cf_indxs$cv_subsamples_list, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, ensemble_type = ensemble_type) # Print estimation progress diff --git a/R/ensemble.R b/R/ensemble.R index f259369..df010e2 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -88,7 +88,7 @@ predict.ensemble <- function(object, newdata, newZ = NULL, ...){ #warning("None of the learners are assigned positive stacking weights.") }#IF # Calculate fitted values for each model - first_fit <- T + first_fit <- TRUE for (m in 1:nlearners) { # Skip model if not assigned positive weight if (!(m %in% mdl_include)) next @@ -103,7 +103,7 @@ predict.ensemble <- function(object, newdata, newZ = NULL, ...){ # Initialize matrix of fitted values if (first_fit) { fitted_mat <- matrix(0, length(fitted), nlearners) - first_fit <- F + first_fit <- FALSE }#IF fitted_mat[, m] <- methods::as(fitted, "matrix") }#FOR diff --git a/R/get_CEF.R b/R/get_CEF.R index f2e851c..4b95640 100644 --- a/R/get_CEF.R +++ b/R/get_CEF.R @@ -7,7 +7,7 @@ get_CEF <- function(y, X, Z = NULL, compute_insample_predictions = FALSE, compute_predictions_bylearner = FALSE, subsamples, - cv_subsamples_list, + cv_subsamples, silent = FALSE, progress = NULL, auxiliary_X = NULL, @@ -34,7 +34,7 @@ get_CEF <- function(y, X, Z = NULL, compute_predictions_bylearner = compute_predictions_bylearner, subsamples = subsamples, - cv_subsamples_list = cv_subsamples_list, + cv_subsamples = cv_subsamples, silent = silent, progress = progress, auxiliary_X = auxiliary_X) }#IFELSE @@ -50,7 +50,7 @@ update_progress <- function(silent) { }#UPDATE_PROGRESS # Construct CEF from auxiliary_X -extrapolate_CEF <- function(D, CEF_res_byD, aux_indxs) { +extrapolate_CEF <- function(D, CEF_res_byD, aux_indx) { # Data parameters nCEF <- length(CEF_res_byD) nobs <- length(D) @@ -65,7 +65,7 @@ extrapolate_CEF <- function(D, CEF_res_byD, aux_indxs) { 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] <- + g_X_byD[aux_indx[[d]][[k]], , d] <- CEF_res_byD[[d]][[1]]$auxiliary_fitted[[k]] }#FOR }#FOR diff --git a/R/shortstacking.R b/R/shortstacking.R index a2c9465..0571247 100644 --- a/R/shortstacking.R +++ b/R/shortstacking.R @@ -17,7 +17,7 @@ #' \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}. +#' \item{\code{is_fitted}}{When \code{compute_insample_predictions = TRUE}. #' a list of matrices with in-sample predictions by sample fold.} #' \item{\code{auxiliary_fitted}}{When \code{auxiliary_X} is not #' \code{NULL}, a list of matrices with additional predictions.} @@ -25,7 +25,7 @@ #' 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 +#' \code{compute_insample_predictions = TRUE}, a list of matrices with #' in-sample predictions by sample fold.} #' \item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} is #' not \code{NULL}, a @@ -69,6 +69,7 @@ shortstacking <- function (y, X, Z = NULL, custom_ensemble_weights = NULL, compute_insample_predictions = FALSE, subsamples = NULL, + cluster_variable = seq_along(y), silent = FALSE, progress = NULL, auxiliary_X = NULL, @@ -84,10 +85,11 @@ shortstacking <- function (y, X, Z = NULL, 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) @@ -105,7 +107,7 @@ shortstacking <- function (y, X, Z = NULL, # Compute ensemble weights via subsample cross-fitted residual fakecv <- list() - fakecv$oos_resid <- kronecker(shortstack_y, t(rep(1, nlearners))) - + fakecv$oos_resid <- matrix(shortstack_y, nobs, nlearners) - res$oos_fitted_bylearner weights <- ensemble_weights(shortstack_y, X, learners = learners, type = ensemble_type, @@ -129,7 +131,8 @@ shortstacking <- function (y, X, Z = NULL, 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))) - + nobs_k <- length(y[-subsamples[[k]]]) + fakecv_k$oos_resid <- matrix(y[-subsamples[[k]]], nobs_k, nlearners) - res$is_fitted_bylearner[[k]] weights_k <- ensemble_weights(y[-subsamples[[k]]], X[-subsamples[[k]], ], learners = learners, @@ -154,7 +157,7 @@ shortstacking <- function (y, X, Z = NULL, }#IF # Compute mspe - mspe <- colMeans((kronecker(shortstack_y, t(rep(1, nensb))) - oos_fitted)^2) + mspe <- colMeans((matrix(shortstack_y, nobs, nensb) - oos_fitted)^2) # return shortstacking output output <- list(oos_fitted = oos_fitted, diff --git a/R/subsample_functions.R b/R/subsample_functions.R index b7aa1ce..ffa2e4c 100644 --- a/R/subsample_functions.R +++ b/R/subsample_functions.R @@ -1,208 +1,447 @@ # 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) + + # 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.") + 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 + + # 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 + +# 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``.")) + } else if (!is.null(subsamples) & is.null(subsamples_byD) & by_D) { + stop(paste0("When ``by_D==TRUE``, ``subsamples_byD`` must also be set ", + "when setting ``subsamples``.")) + }#IF + + # Compute crossfit indices + if (compute_cf) { + if (stratify) { + if (!by_D) + stop("Stratified sampling only works when ``by_D=TRUE``.") + 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) + + # 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.")) - 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.")) + + # 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]]) + # Create subsamples_byD (optional) + subsamples_byD <- NULL + if (by_D) { + D_levels <- sort(unique(D)) + nD_levels <- length(D_levels) + subsamples_byD <- rep(list(NULL), nD_levels) + for (d in seq_len(nD_levels)) { + tmp_indx <- rep(NA, nobs) + is_Dd <- which(D == D_levels[d]) + 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 + }#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 = FALSE) - 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/man/crosspred.Rd b/man/crosspred.Rd index 4b8c21c..0219145 100644 --- a/man/crosspred.Rd +++ b/man/crosspred.Rd @@ -9,13 +9,15 @@ crosspred( 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, @@ -88,11 +90,15 @@ predictions should also be computed.} 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{cv_subsamples_list}{Deprecated; use \code{cv_subsamples} instead.} + \item{silent}{Boolean to silence estimation updates.} \item{progress}{String to print before learner and cv fold progress.} @@ -110,20 +116,20 @@ 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}. +\item{\code{is_fitted}}{When \code{compute_insample_predictions = TRUE}. a list of matrices with in-sample predictions by sample fold.} \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 +\code{compute_predictions_bylearner = TRUE}, 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 +\code{compute_insample_predictions = TRUE} and +\code{compute_predictions_bylearner = TRUE}, 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 +not \code{NULL} and \code{compute_predictions_bylearner = TRUE}, a list of matrices with additional predictions for each learner.} } } diff --git a/man/crossval.Rd b/man/crossval.Rd index ee03624..93e2f86 100644 --- a/man/crossval.Rd +++ b/man/crossval.Rd @@ -9,7 +9,8 @@ crossval( X, Z = NULL, learners, - cv_folds = 5, + cv_folds = 10, + cluster_variable = seq_along(y), cv_subsamples = NULL, silent = FALSE, progress = NULL @@ -43,6 +44,8 @@ results in inclusion of all predictive variables in \code{X} (and/or \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.} diff --git a/man/ddml_ate.Rd b/man/ddml_ate.Rd index c32e3a3..627f584 100644 --- a/man/ddml_ate.Rd +++ b/man/ddml_ate.Rd @@ -18,7 +18,10 @@ ddml_ate( custom_ensemble_weights = NULL, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), + stratify = TRUE, + subsamples = NULL, subsamples_byD = NULL, + cv_subsamples = NULL, cv_subsamples_byD = NULL, trim = 0.01, silent = FALSE @@ -37,7 +40,10 @@ ddml_att( custom_ensemble_weights = NULL, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), + stratify = TRUE, + subsamples = NULL, subsamples_byD = NULL, + cv_subsamples = NULL, cv_subsamples_byD = NULL, trim = 0.01, silent = FALSE @@ -111,10 +117,18 @@ custom ensemble weights for \code{learners_DX}. Setup is identical to \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{subsamples}{List of vectors with sample indices for cross-fitting.} + \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}{List of lists, each corresponding to a subsample +containing vectors with subsample indices for cross-validation.} + \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 @@ -145,8 +159,7 @@ of scores. Used in \code{\link[=summary.ddml_ate]{summary.ddml_ate()}} or \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{subsamples_byD},\code{cv_subsamples_byD}, \code{ensemble_type}}{Pass-through of selected user-provided arguments. See above.} } diff --git a/man/ddml_fpliv.Rd b/man/ddml_fpliv.Rd index 32fdac0..fc8dc95 100644 --- a/man/ddml_fpliv.Rd +++ b/man/ddml_fpliv.Rd @@ -22,6 +22,7 @@ ddml_fpliv( custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), subsamples = NULL, + cv_subsamples = NULL, cv_subsamples_list = NULL, silent = FALSE ) @@ -108,9 +109,11 @@ have the same number of columns.} \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{cv_subsamples_list}{Deprecated; use \code{cv_subsamples} instead.} + \item{silent}{Boolean to silence estimation updates.} } \value{ @@ -131,7 +134,7 @@ regression of \eqn{Y - \hat{E}[Y\vert X]} on \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 +\code{cv_subsamples},\code{ensemble_type}}{Pass-through of selected user-provided arguments. See above.} } } diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index b507811..f53f315 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -20,7 +20,10 @@ ddml_late( custom_ensemble_weights_DXZ = custom_ensemble_weights, custom_ensemble_weights_ZX = custom_ensemble_weights, cluster_variable = seq_along(y), + stratify = TRUE, + subsamples = NULL, subsamples_byZ = NULL, + cv_subsamples = NULL, cv_subsamples_byZ = NULL, trim = 0.01, silent = FALSE @@ -103,10 +106,18 @@ 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{subsamples}{List of vectors with sample indices for cross-fitting.} + \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}{List of lists, each corresponding to a subsample +containing vectors with subsample indices for cross-validation.} + \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 @@ -135,9 +146,8 @@ 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 +\code{cluster_variable},\code{subsamples_byZ}, +\code{cv_subsamples_byZ},\code{ensemble_type}}{Pass-through of selected user-provided arguments. See above.} } } @@ -205,7 +215,7 @@ 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. diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index e7c4f0c..74cf1bc 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -21,6 +21,7 @@ ddml_pliv( custom_ensemble_weights_ZX = custom_ensemble_weights, cluster_variable = seq_along(y), subsamples = NULL, + cv_subsamples = NULL, cv_subsamples_list = NULL, silent = FALSE ) @@ -104,9 +105,11 @@ have the same number of columns.} \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{cv_subsamples_list}{Deprecated; use \code{cv_subsamples} instead.} + \item{silent}{Boolean to silence estimation updates.} } \value{ @@ -127,7 +130,7 @@ regression of \eqn{Y - \hat{E}[Y\vert X]} on 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 +\code{cv_subsamples},\code{ensemble_type}}{Pass-through of selected user-provided arguments. See above.} } } diff --git a/man/ddml_plm.Rd b/man/ddml_plm.Rd index 185cb05..a04d5da 100644 --- a/man/ddml_plm.Rd +++ b/man/ddml_plm.Rd @@ -18,6 +18,7 @@ ddml_plm( custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), subsamples = NULL, + cv_subsamples = NULL, cv_subsamples_list = NULL, silent = FALSE ) @@ -92,9 +93,11 @@ custom ensemble weights for \code{learners_DX}. Setup is identical to \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{cv_subsamples_list}{Deprecated; use \code{cv_subsamples} instead.} + \item{silent}{Boolean to silence estimation updates.} } \value{ @@ -113,7 +116,7 @@ cross-validation step in the ensemble construction.} 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{subsamples}, \code{cv_subsamples}, \code{ensemble_type}}{Pass-through of selected user-provided arguments. See above.} } diff --git a/man/print.summary.ddml_plm.Rd b/man/print.summary.ddml_plm.Rd index 3f8ca5a..9429e2a 100644 --- a/man/print.summary.ddml_plm.Rd +++ b/man/print.summary.ddml_plm.Rd @@ -18,7 +18,7 @@ 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{digits}{Number of significant digits used for printing.} \item{...}{Currently unused.} } diff --git a/man/shortstacking.Rd b/man/shortstacking.Rd index 64fd04b..f272cc9 100644 --- a/man/shortstacking.Rd +++ b/man/shortstacking.Rd @@ -14,6 +14,7 @@ shortstacking( custom_ensemble_weights = NULL, compute_insample_predictions = FALSE, subsamples = NULL, + cluster_variable = seq_along(y), silent = FALSE, progress = NULL, auxiliary_X = NULL, @@ -81,6 +82,8 @@ predictions should also be computed.} \item{subsamples}{List of vectors with sample indices for cross-fitting.} +\item{cluster_variable}{A vector of cluster indices.} + \item{silent}{Boolean to silence estimation updates.} \item{progress}{String to print before learner and cv fold progress.} @@ -102,7 +105,7 @@ 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}. +\item{\code{is_fitted}}{When \code{compute_insample_predictions = TRUE}. a list of matrices with in-sample predictions by sample fold.} \item{\code{auxiliary_fitted}}{When \code{auxiliary_X} is not \code{NULL}, a list of matrices with additional predictions.} @@ -110,7 +113,7 @@ a list of matrices with in-sample predictions by sample fold.} 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 +\code{compute_insample_predictions = TRUE}, a list of matrices with in-sample predictions by sample fold.} \item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} is not \code{NULL}, a diff --git a/tests/testthat/test-ddml_ate.R b/tests/testthat/test-ddml_ate.R index 204c758..2f6485e 100644 --- a/tests/testthat/test-ddml_ate.R +++ b/tests/testthat/test-ddml_ate.R @@ -7,7 +7,7 @@ test_that("ddml_ate computes with a single model", { y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ + suppressWarnings({ ddml_ate_fit <- ddml_ate(y, D, X, learners = learners, cv_folds = 3, @@ -18,6 +18,27 @@ test_that("ddml_ate computes with a single model", { expect_equal(length(ddml_ate_fit$ate), 1) })#TEST_THAT +test_that("ddml_ate computes with stratify = FALSE", { + # 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) + # Define arguments + learners <- list(what = ols) + suppressWarnings({ + ddml_ate_fit <- ddml_ate(y, D, X, + learners = learners, + stratify = FALSE, + cv_folds = 3, + sample_folds = 3, + silent = T) + }) + # Check output with expectations + expect_equal(length(ddml_ate_fit$ate), 1) +})#TEST_THAT + test_that("ddml_ate computes with a single model and dependence", { # Simulate small dataset n_cluster <- 200 @@ -32,7 +53,7 @@ test_that("ddml_ate computes with a single model and dependence", { y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ + suppressWarnings({ ddml_ate_fit <- ddml_ate(y, D, X, learners = learners, cluster_variable = cluster_variable, @@ -55,7 +76,7 @@ test_that("ddml_ate computes with an ensemble procedure", { learners <- list(list(fun = ols), list(fun = ols)) # Compute DDML PLM estimator - expect_warning({ + suppressWarnings({ ddml_ate_fit <- ddml_ate(y, D, X, learners = learners, ensemble_type = "ols", @@ -78,7 +99,7 @@ test_that("ddml_ate computes w/ multiple ensembles + custom weights", { learners <- list(list(fun = ols), list(fun = ols)) # Compute DDML PLM estimator - expect_warning({ + suppressWarnings({ ddml_ate_fit <- ddml_ate(y, D, X, learners, ensemble_type = c("ols", "nnls", @@ -102,7 +123,7 @@ test_that("ddml_ate computes with multiple ensemble procedures & shortstack", { # Define arguments learners <- list(list(fun = ols)) # Compute DDML PLM estimator - expect_warning({ + suppressWarnings({ ddml_ate_fit <- ddml_ate(y, D, X, learners, ensemble_type = c("ols", "nnls", @@ -125,7 +146,7 @@ test_that("summary.ddml_ate computes with a single model", { y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ + suppressWarnings({ ddml_ate_fit <- ddml_ate(y, D, X, learners = learners, cv_folds = 3, @@ -153,7 +174,7 @@ test_that("summary.ddml_ate computes with a single model and dependence", { y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ + suppressWarnings({ ddml_ate_fit <- ddml_ate(y, D, X, learners = learners, cluster_variable = cluster_variable, @@ -178,7 +199,7 @@ test_that("summary.ddml_ate computes with multiple ensemble procedures", { # Define arguments learners <- list(list(fun = ols)) # Compute DDML PLM estimator - expect_warning({ + suppressWarnings({ ddml_ate_fit <- ddml_ate(y, D, X, learners, ensemble_type = c("ols", "nnls", diff --git a/tests/testthat/test-ddml_att.R b/tests/testthat/test-ddml_att.R index 43a8b04..8beb0aa 100644 --- a/tests/testthat/test-ddml_att.R +++ b/tests/testthat/test-ddml_att.R @@ -7,7 +7,7 @@ test_that("ddml_att computes with a single model", { y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ + suppressWarnings({ ddml_att_fit <- ddml_att(y, D, X, learners = learners, cv_folds = 3, @@ -18,6 +18,27 @@ test_that("ddml_att computes with a single model", { expect_equal(length(ddml_att_fit$att), 1) })#TEST_THAT +test_that("ddml_att computes with stratify = FALSE", { + # 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) + # Define arguments + learners <- list(what = ols) + suppressWarnings({ + ddml_att_fit <- ddml_att(y, D, X, + learners = learners, + stratify = FALSE, + cv_folds = 3, + sample_folds = 3, + silent = T) + }) + # Check output with expectations + expect_equal(length(ddml_att_fit$att), 1) +})#TEST_THAT + test_that("ddml_att computes with a single model and dependence", { # Simulate small dataset n_cluster <- 200 @@ -32,7 +53,7 @@ test_that("ddml_att computes with a single model and dependence", { y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ + suppressWarnings({ ddml_att_fit <- ddml_att(y, D, X, learners = learners, cluster_variable = cluster_variable, @@ -55,7 +76,7 @@ test_that("ddml_att computes with an ensemble procedure", { learners <- list(list(fun = ols), list(fun = ols)) # Compute DDML PLM estimator - expect_warning({ + suppressWarnings({ ddml_att_fit <- ddml_att(y, D, X, learners = learners, ensemble_type = "ols", @@ -78,7 +99,7 @@ test_that("ddml_att computes w/ multiple ensembles + custom weights", { learners <- list(list(fun = ols), list(fun = ols)) # Compute DDML PLM estimator - expect_warning({ + suppressWarnings({ ddml_att_fit <- ddml_att(y, D, X, learners, ensemble_type = c("ols", "nnls", @@ -103,7 +124,7 @@ test_that("ddml_att computes w/ multp ensembles, custom weights + shortstack", { learners <- list(list(fun = ols), list(fun = ols)) # Compute DDML PLM estimator - expect_warning({ + suppressWarnings({ ddml_att_fit <- ddml_att(y, D, X, learners, ensemble_type = c("ols", "average"), @@ -126,7 +147,7 @@ test_that("summary.ddml_att computes with a single model", { y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ + suppressWarnings({ ddml_att_fit <- ddml_att(y, D, X, learners = learners, cv_folds = 3, @@ -154,7 +175,7 @@ test_that("summary.ddml_att computes with a single model and dependence", { y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ + suppressWarnings({ ddml_att_fit <- ddml_att(y, D, X, learners = learners, cluster_variable = cluster_variable, @@ -179,7 +200,7 @@ test_that("summary.ddml_att computes with multiple ensemble procedures", { # Define arguments learners <- list(list(fun = ols)) # Compute DDML PLM estimator - expect_warning({ + suppressWarnings({ ddml_att_fit <- ddml_att(y, D, X, learners, ensemble_type = c("ols", "nnls", diff --git a/tests/testthat/test-ddml_fpliv.R b/tests/testthat/test-ddml_fpliv.R index ffaed0b..eaa14e5 100644 --- a/tests/testthat/test-ddml_fpliv.R +++ b/tests/testthat/test-ddml_fpliv.R @@ -341,16 +341,18 @@ test_that("ddml_fpliv computes with multiple ensemble procedures, multi D", { 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 = 5, - silent = T) + suppressWarnings({ + 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) + }) # Check output with expectations expect_equal(length(ddml_fpliv_fit$coef), 8) - })#TEST_THAT +})#TEST_THAT test_that("ddml_fpliv computes with ensemble procedures w/o LIE, multi D", { # Simulate small dataset diff --git a/tests/testthat/test-ddml_late.R b/tests/testthat/test-ddml_late.R index d3d2f6b..7939166 100644 --- a/tests/testthat/test-ddml_late.R +++ b/tests/testthat/test-ddml_late.R @@ -9,7 +9,7 @@ test_that("ddml_late computes with a single model", { y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ + suppressWarnings({ ddml_late_fit <- ddml_late(y, D, Z, X, learners = learners, cv_folds = 3, @@ -20,6 +20,29 @@ test_that("ddml_late computes with a single model", { expect_equal(length(ddml_late_fit$late), 1) })#TEST_THAT +test_that("ddml_late computes with stratify = FALSE", { + # 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) + # Define arguments + learners <- list(what = ols) + suppressWarnings({ + ddml_late_fit <- ddml_late(y, D, Z, X, + learners = learners, + stratify = FALSE, + cv_folds = 3, + sample_folds = 3, + silent = T) + }) + # Check output with expectations + expect_equal(length(ddml_late_fit$late), 1) +})#TEST_THAT + test_that("ddml_late computes with a single model and dependence", { # Simulate small dataset n_cluster <- 250 @@ -36,7 +59,7 @@ test_that("ddml_late computes with a single model and dependence", { y <- D + X %*% runif(40) + 0.1 * eps + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ + suppressWarnings({ ddml_late_fit <- ddml_late(y, D, Z, X, learners = learners, cluster_variable = cluster_variable, @@ -60,7 +83,7 @@ test_that("ddml_late computes with a single model & perfect non-compliance", { y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ + suppressWarnings({ ddml_late_fit <- ddml_late(y, D, Z, X, learners = learners, cv_folds = 3, @@ -84,7 +107,7 @@ test_that("ddml_late computes with an ensemble procedure", { learners <- list(list(fun = ols), list(fun = ols)) # Compute DDML PLM estimator - expect_warning({ + suppressWarnings({ ddml_late_fit <- ddml_late(y, D, Z, X, learners = learners, ensemble_type = "ols", @@ -109,7 +132,7 @@ test_that("ddml_late computes w/ multiple ensembles & custom weights", { learners <- list(list(fun = ols), list(fun = ols)) # Compute DDML PLM estimator - expect_warning({ + suppressWarnings({ ddml_late_fit <- ddml_late(y, D, Z, X, learners, ensemble_type = c("ols", "nnls", @@ -138,7 +161,7 @@ test_that("ddml_late computes with multiple ensemble procedures + perfect compli learners <- list(list(fun = ols), list(fun = ols)) # Compute DDML PLM estimator - expect_warning({ + suppressWarnings({ ddml_late_fit <- ddml_late(y, D, Z, X, learners, ensemble_type = c("ols", "nnls", @@ -165,7 +188,7 @@ test_that("ddml_late computes w/ mult ensembles, custom weights, & shortstack", learners <- list(list(fun = ols), list(fun = ols)) # Compute DDML PLM estimator - expect_warning({ + suppressWarnings({ ddml_late_fit <- ddml_late(y, D, Z, X, learners, ensemble_type = c("ols", "nnls", @@ -192,7 +215,7 @@ test_that("summary.ddml_late computes with a single model", { y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ + suppressWarnings({ ddml_late_fit <- ddml_late(y, D, Z, X, learners = learners, cv_folds = 3, @@ -222,7 +245,7 @@ test_that("summary.ddml_late computes with a single model and dependence", { y <- D + X %*% runif(40) + 0.1 * eps + rnorm(nobs) # Define arguments learners <- list(what = ols) - expect_warning({ + suppressWarnings({ ddml_late_fit <- ddml_late(y, D, Z, X, learners = learners, cluster_variable = cluster_variable, diff --git a/tests/testthat/test-ddml_plm.R b/tests/testthat/test-ddml_plm.R index c32c6b9..d3aff3a 100644 --- a/tests/testthat/test-ddml_plm.R +++ b/tests/testthat/test-ddml_plm.R @@ -293,3 +293,24 @@ test_that("ddml_plm computes with multiple ensemble types and multivariate D", { # Check output with expectations expect_equal(length(ddml_plm_fit$coef), 10) })#TEST_THAT + +test_that("ddml_plm backward-compat cv_subsamples_list works with message", { + nobs <- 200 + X <- cbind(1, matrix(rnorm(nobs * 5), nobs, 5)) + D <- rnorm(nobs) + y <- D + X %*% runif(6) + rnorm(nobs) + # Pre-generate splits + splits <- get_sample_splits(seq_len(nobs), + sample_folds = 3, cv_folds = 3) + learners <- list(list(fun = ols), list(fun = ols)) + # Call with deprecated cv_subsamples_list — should emit message + expect_message( + ddml_plm(y, D, X, + learners = learners, + ensemble_type = "ols", + sample_folds = 3, + subsamples = splits$subsamples, + cv_subsamples_list = splits$cv_subsamples, + silent = TRUE), + "cv_subsamples_list has been renamed") +})#TEST_THAT diff --git a/tests/testthat/test-subsample_functions.R b/tests/testthat/test-subsample_functions.R index 327f332..09871f1 100644 --- a/tests/testthat/test-subsample_functions.R +++ b/tests/testthat/test-subsample_functions.R @@ -1,108 +1,189 @@ -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 -test_that("auxiliary_X construction works with multi-valued D", { - # Simulate small dataset +# --- 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 - 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)) - D <- fun(D_tld) - y <- D + X %*% runif(40) + rnorm(nobs) + D <- c(rep(0, 400), rep(1, 100)) + cl <- seq_len(nobs) + + res <- get_sample_splits(cl, sample_folds = 5, D = D, + stratify = TRUE) - # Compute crossfit indices w/ splitting by D - crossfit_indices <- get_crossfit_indices(cluster_variable = 1:500, - sample_folds = 5, cv_folds = 3, - D = D) + # Count D=1 observations in each fold + d1_per_fold <- vapply(res$subsamples, function(idx) { + sum(D[idx] == 1) + }, FUN.VALUE = integer(1)) - # Get auxiliary_indx - auxiliary_indx <- get_auxiliary_indx(crossfit_indices$subsamples_byD, D) + # Folds should be roughly balanced (max - min <= 1 for integer rounding) + expect_lte(max(d1_per_fold) - min(d1_per_fold), 1) +})#TEST_THAT - # Get auxiliary_X for first sample_folds - auxiliary_X_d <- get_auxiliary_X(auxiliary_indx[[1]], X) +# --- check_subsamples: warning for small training sets --- - # 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]])) +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", { + nobs <- 500 + 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) + + res <- get_sample_splits(seq_len(nobs), sample_folds = 5, D = D) + + # Get auxiliary_X for first treatment level + auxiliary_X_d <- get_auxiliary_X(res$aux_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 From 6305a74ce50c459bb337ef40bfef045704ecad55 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Mon, 23 Feb 2026 15:04:39 -0600 Subject: [PATCH 03/46] parallelized crossfitting --- .Rbuildignore | 1 + .gitignore | 1 + DESCRIPTION | 8 +- NEWS.md | 1 + R/crosspred.R | 337 ++++++++++++++++++++------------ R/crossval.R | 92 ++++++--- R/ddml_ate.R | 46 ++++- R/ddml_att.R | 33 +++- R/ddml_fpliv.R | 67 ++++--- R/ddml_late.R | 52 +++-- R/ddml_pliv.R | 34 +++- R/ddml_plm.R | 42 +++- R/ensemble.R | 10 +- R/get_CEF.R | 33 ++-- R/parallel.R | 48 +++++ R/shortstacking.R | 45 +++-- man/crosspred.Rd | 37 ++-- man/crossval.Rd | 15 +- man/ddml_ate.Rd | 19 +- man/ddml_fpliv.Rd | 16 +- man/ddml_late.Rd | 16 +- man/ddml_pliv.Rd | 16 +- man/ddml_plm.Rd | 16 +- man/shortstacking.Rd | 23 ++- tests/testthat/test-crosspred.R | 30 +++ tests/testthat/test-crossval.R | 21 ++ tests/testthat/test-ddml_plm.R | 26 +++ 27 files changed, 795 insertions(+), 290 deletions(-) create mode 100644 R/parallel.R diff --git a/.Rbuildignore b/.Rbuildignore index 1d75826..f07ecf6 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -23,4 +23,5 @@ ^debugger$ ^\.cursor$ ^\.discussion$ +^\.discussions$ ^GEMINI\.md$ diff --git a/.gitignore b/.gitignore index 3005d50..732e3eb 100644 --- a/.gitignore +++ b/.gitignore @@ -11,4 +11,5 @@ inst/doc /debugger .cursor/ .discussion/ +.discussions/ GEMINI.md diff --git a/DESCRIPTION b/DESCRIPTION index 3e0ce05..3fea682 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -29,15 +29,17 @@ Imports: MASS, Matrix, nnls, + pbapply, quadprog, glmnet, ranger, xgboost Suggests: - sandwich, covr, - testthat (>= 3.0.0), knitr, - rmarkdown + parallel, + rmarkdown, + sandwich, + testthat (>= 3.0.0) Config/testthat/edition: 3 VignetteBuilder: knitr diff --git a/NEWS.md b/NEWS.md index 7e10596..681bcff 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # ddml 0.3.1 +* Adds support for parallel computation in `crosspred()`, `crossval()`, and `shortstacking()` via the `parallel` parameter. Updates progress reporting using `pbapply`. * Adds stratified cross-fitting to ``ddml_ate()``, ``ddml_att()``, and ``ddml_late()`` via the ``stratify`` parameter. Stratified splitting is now the default. diff --git a/R/crosspred.R b/R/crosspred.R index 3c054b5..6f071bd 100644 --- a/R/crosspred.R +++ b/R/crosspred.R @@ -24,8 +24,8 @@ #' \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.} +#' 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.} @@ -64,6 +64,18 @@ #' @param auxiliary_X An optional list of matrices of length #' \code{sample_folds}, each containing additional observations to calculate #' predictions for. +#' @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{crosspred} returns a list containing the following components: #' \describe{ @@ -73,7 +85,8 @@ #' \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 = TRUE}. +#' \item{\code{is_fitted}}{When +#' \code{compute_insample_predictions = TRUE}. #' a list of matrices with in-sample predictions by sample fold.} #' \item{\code{auxiliary_fitted}}{When \code{auxiliary_X} is not #' \code{NULL}, a list of matrices with additional predictions.} @@ -83,16 +96,17 @@ #' learner (in chronological order).} #' \item{\code{is_fitted_bylearner}}{When #' \code{compute_insample_predictions = TRUE} and -#' \code{compute_predictions_bylearner = TRUE}, 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 = TRUE}, a -#' list of matrices with additional predictions for each learner.} +#' \code{compute_predictions_bylearner = TRUE}, 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 = TRUE}, 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. @@ -132,8 +146,14 @@ crosspred <- function(y, X, Z = NULL, cv_subsamples = NULL, cv_subsamples_list = NULL, silent = FALSE, - progress = NULL, - auxiliary_X = NULL) { + auxiliary_X = NULL, + parallel = NULL) { + # Unpack parallel options + p <- parse_parallel(parallel) + num_cores <- p$num_cores + parallel_export <- p$export + parallel_packages <- p$packages + # Backward compatibility for renamed parameter if (!is.null(cv_subsamples_list)) { if (!is.null(cv_subsamples)) @@ -164,7 +184,48 @@ crosspred <- function(y, X, Z = NULL, sample_folds <- length(subsamples) cv_folds <- if (!is.null(cv_subsamples)) length(cv_subsamples[[1]]) else 0L - # Initialize output matrices + # Dispatch fold computation + fold_fun <- function(k) { + crosspred_compute_fold( + k = k, y = y, X = X, Z = Z, + learners = learners, + subsamples = subsamples, + cv_subsamples_k = cv_subsamples[[k]], + ensemble_type = ensemble_type, + cv_folds = cv_folds, + custom_ensemble_weights = custom_ensemble_weights, + calc_ensemble = calc_ensemble, + nensb = nensb, nlearners = nlearners, + compute_insample_predictions = compute_insample_predictions, + compute_predictions_bylearner = compute_predictions_bylearner, + auxiliary_X = auxiliary_X) + }#FOLD_FUN + + cl <- NULL + if (num_cores > 1) { + cl <- tryCatch( + setup_parallel_cluster(num_cores, parallel_export, + parallel_packages), + error = function(e) { + warning("Parallel setup failed: ", + conditionMessage(e), + ". Falling back to sequential.", + call. = FALSE) + NULL + } + ) + if (!is.null(cl)) + on.exit(parallel::stopCluster(cl), add = TRUE) + }#IF + + if (silent) { + op <- pbapply::pboptions(type = "none") + on.exit(pbapply::pboptions(op), add = TRUE) + }#IF + fold_results <- pbapply::pblapply(seq_len(sample_folds), + fold_fun, cl = cl) + + # Assemble results from fold_results list oos_fitted <- matrix(0, nobs, nensb^(calc_ensemble)) oos_fitted_bylearner <- matrix(0, nobs, nlearners) is_fitted <- rep(list(NULL), sample_folds) @@ -172,124 +233,39 @@ crosspred <- function(y, X, Z = NULL, 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) + colnames(mspe) <- paste("sample fold ", seq_len(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 - # 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 - - # Compute ensemble - mdl_fit <- ensemble(y_, X[-subsamples[[k]], , drop = FALSE], - Z[-subsamples[[k]], , drop = FALSE], - ensemble_type, learners, - cv_folds, cv_subsamples[[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 = FALSE], - newZ = Z[subsamples[[k]], , - drop = FALSE])) - - # 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 = FALSE], - newZ = Z[-subsamples[[k]], , drop = FALSE]) - }#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 = FALSE], - newZ = Z[subsamples[[k]], , drop = FALSE])) - # Compute in-sample predictions (optional) - if (compute_insample_predictions) { - is_fitted_bylearner[[k]] <- - predict.ensemble(mdl_fit, newdata = X[-subsamples[[k]], ,drop = FALSE], - newZ = Z[-subsamples[[k]], , drop = FALSE]) - }#IF - # Compute auxilliary predictions by learner (optional) - if (!is.null(auxiliary_X)) { - auxiliary_fitted_bylearner[[k]] <- stats::predict(mdl_fit, - auxiliary_X[[k]]) - }#if + for (res in fold_results) { + k <- res$k + oos_fitted[res$oos_indices, ] <- res$oos_fitted_rows + if (!is.null(res$weights_k)) weights[, , k] <- res$weights_k + if (!is.null(res$mspe_k)) mspe[, k] <- res$mspe_k + is_fitted[[k]] <- res$is_fitted_k + auxiliary_fitted[[k]] <- res$auxiliary_fitted_k + if (!is.null(res$oos_fitted_bylearner_rows)) { + oos_fitted_bylearner[res$oos_indices, ] <- + res$oos_fitted_bylearner_rows }#IF + is_fitted_bylearner[[k]] <- res$is_fitted_bylearner_k + auxiliary_fitted_bylearner[[k]] <- res$auxiliary_fitted_bylearner_k }#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 + + # Assign dimnames to weights + if (calc_ensemble) { + wnames <- fold_results[[1]]$weight_colnames + dimnames(weights) <- list( + NULL, wnames, + paste("sample fold ", seq_len(sample_folds))) + }#IF + + # Reorganize is_fitted for multiple ensembles + if (compute_insample_predictions && calc_ensemble && nensb > 1) { 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 = FALSE] + for (i in seq_len(nensb)) { + for (k in seq_len(sample_folds)) { + new_is_fitted[[i]][[k]] <- + is_fitted[[k]][, i, drop = FALSE] }#FOR }#FOR is_fitted <- new_is_fitted @@ -305,3 +281,114 @@ crosspred <- function(y, X, Z = NULL, auxiliary_fitted_bylearner = auxiliary_fitted_bylearner) return(output) }#CROSSPRED + +crosspred_compute_fold <- function( + k, y, X, Z, learners, subsamples, cv_subsamples_k, + ensemble_type, cv_folds, custom_ensemble_weights, + calc_ensemble, nensb, nlearners, + compute_insample_predictions, compute_predictions_bylearner, + auxiliary_X) { + + test_idx <- subsamples[[k]] + train_idx <- -test_idx + + if (!calc_ensemble) { + learners$args$X <- cbind(X[train_idx, ], Z[train_idx, ]) + if ("list" %in% class(y)) { + learners$args$y <- y[[k]] + } else { + learners$args$y <- y[train_idx] + }#IFELSE + mdl_fit <- do.call(do.call, learners) + oos_fitted_rows <- + as.numeric(stats::predict(mdl_fit, + cbind(X[test_idx, ], + Z[test_idx, ]))) + } else { + if ("list" %in% class(y)) { + y_ <- y[[k]] + } else { + y_ <- y[train_idx] + }#IFELSE + mdl_fit <- ensemble(y_, + X[train_idx, , drop = FALSE], + Z[train_idx, , drop = FALSE], + ensemble_type, learners, + cv_folds, cv_subsamples_k, + custom_weights = custom_ensemble_weights, + silent = TRUE) + oos_fitted_rows <- + as.numeric(predict.ensemble(mdl_fit, + newdata = X[test_idx, , drop = FALSE], + newZ = Z[test_idx, , drop = FALSE])) + }#IFELSE + + # Ensemble metadata + weights_k <- if (calc_ensemble) mdl_fit$weights else NULL + mspe_k <- if (calc_ensemble && !is.null(mdl_fit$cv_res)) { + mdl_fit$cv_res$mspe + } else { + NULL + } + weight_colnames <- if (calc_ensemble) { + colnames(mdl_fit$weights) + } else { + NULL + } + + # In-sample predictions (optional) + is_fitted_k <- NULL + if (compute_insample_predictions) { + if (!calc_ensemble) { + is_fitted_k <- stats::predict(mdl_fit, + cbind(X[train_idx, ], + Z[train_idx, ])) + } else { + is_fitted_k <- predict.ensemble(mdl_fit, + newdata = X[train_idx, , drop = FALSE], + newZ = Z[train_idx, , drop = FALSE]) + }#IFELSE + }#IF + + # 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 (optional) + oos_fitted_bylearner_rows <- NULL + is_fitted_bylearner_k <- NULL + auxiliary_fitted_bylearner_k <- NULL + if (compute_predictions_bylearner) { + mdl_fit$weights <- diag(1, nlearners) + oos_fitted_bylearner_rows <- + as.numeric(predict.ensemble(mdl_fit, + newdata = X[test_idx, , drop = FALSE], + newZ = Z[test_idx, , drop = FALSE])) + if (compute_insample_predictions) { + is_fitted_bylearner_k <- + predict.ensemble(mdl_fit, + newdata = X[train_idx, , drop = FALSE], + newZ = Z[train_idx, , drop = FALSE]) + }#IF + if (!is.null(auxiliary_X)) { + auxiliary_fitted_bylearner_k <- + stats::predict(mdl_fit, auxiliary_X[[k]]) + }#IF + }#IF + + list( + k = k, + oos_indices = test_idx, + oos_fitted_rows = oos_fitted_rows, + weights_k = weights_k, + mspe_k = mspe_k, + weight_colnames = weight_colnames, + is_fitted_k = is_fitted_k, + auxiliary_fitted_k = auxiliary_fitted_k, + oos_fitted_bylearner_rows = oos_fitted_bylearner_rows, + is_fitted_bylearner_k = is_fitted_bylearner_k, + auxiliary_fitted_bylearner_k = auxiliary_fitted_bylearner_k + ) +}#CROSSPRED_COMPUTE_FOLD diff --git a/R/crossval.R b/R/crossval.R index 18588b7..eaea90c 100644 --- a/R/crossval.R +++ b/R/crossval.R @@ -30,7 +30,18 @@ #' @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{ @@ -64,7 +75,13 @@ crossval <- function(y, X, Z = NULL, cluster_variable = seq_along(y), cv_subsamples = NULL, silent = FALSE, - progress = NULL) { + parallel = NULL) { + # Unpack parallel options + p <- parse_parallel(parallel) + num_cores <- p$num_cores + parallel_export <- p$export + parallel_packages <- p$packages + # Data parameters nobs <- length(y) nlearners <- length(learners) @@ -77,23 +94,41 @@ crossval <- function(y, X, Z = NULL, 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 <- ceiling(x / cv_folds) + i <- x - cv_folds * (ceiling(x / 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 + }#CV_FUN + + # Compute out-of-sample errors + njobs <- cv_folds * nlearners + cl <- NULL + if (num_cores > 1) { + cl <- tryCatch( + setup_parallel_cluster(num_cores, parallel_export, + parallel_packages), + error = function(e) { + warning("Parallel setup failed: ", + conditionMessage(e), + ". Falling back to sequential.", + call. = FALSE) + NULL + } + ) + if (!is.null(cl)) + on.exit(parallel::stopCluster(cl), add = TRUE) + }#IF + + if (silent) { + op <- pbapply::pboptions(type = "none") + on.exit(pbapply::pboptions(op), add = TRUE) + }#IF + cv_res <- pbapply::pbsapply(seq_len(njobs), cv_fun, + cl = cl) # Compile residual matrix oos_resid <- unlist(cv_res) @@ -113,28 +148,31 @@ crossval <- function(y, X, Z = NULL, # 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) + if (is.null(learner$assign_X)) learner$assign_X <- seq_len(ncol(X)) + if (is.null(learner$assign_Z) && !is.null(Z)) + learner$assign_Z <- seq_len(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 = FALSE], Z[-test_sample, assign_Z, drop = FALSE]) - mdl_fit <- do.call(do.call, mdl_fun) - # Compute out of sample residuals + mdl_fit <- tryCatch( + do.call(do.call, mdl_fun), + error = function(e) { + stop("Learner fitting failed: ", conditionMessage(e), + call. = FALSE) + } + ) + oos_fitted <- stats::predict(mdl_fit, - cbind(X[test_sample, assign_X, drop = FALSE], - Z[test_sample, assign_Z, drop = FALSE])) + cbind(X[test_sample, assign_X, + drop = FALSE], + Z[test_sample, assign_Z, + drop = FALSE])) oos_resid <- y[test_sample] - methods::as(oos_fitted, "matrix") - - # Return residuals and cv_Z return(oos_resid) }#CROSSVAL_COMPUTE diff --git a/R/ddml_ate.R b/R/ddml_ate.R index 59856ca..7f65dbb 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -40,6 +40,18 @@ #' 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 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{ddml_ate} and \code{ddml_att} return an object of S3 class #' \code{ddml_ate} and \code{ddml_att}, respectively. An object of class @@ -119,7 +131,8 @@ ddml_ate <- function(y, D, X, cv_subsamples = NULL, cv_subsamples_byD = NULL, trim = 0.01, - silent = FALSE) { + silent = FALSE, + parallel = NULL) { # Data parameters nobs <- length(y) is_D0 <- which(D == 0) @@ -141,8 +154,16 @@ ddml_ate <- function(y, D, X, check_subsamples(indxs$subsamples, indxs$subsamples_byD, stratify, D) - # Print to progress to console - if (!silent) cat("DDML estimation in progress. \n") + # Estimation start + t0 <- proc.time()[3] + mode_str <- if (!is.null(parallel)) { + p <- parse_parallel(parallel) + paste0("parallel, ", p$num_cores, " cores") + } else { + "sequential" + } + info_msg("ddml_ate: estimating (", mode_str, ")", + silent = silent) # Compute estimates of E[y|D=0,X] y_X_D0_res <- get_CEF(y[is_D0], X[is_D0, , drop = FALSE], @@ -151,8 +172,9 @@ ddml_ate <- function(y, D, X, custom_ensemble_weights = custom_ensemble_weights, subsamples = indxs$subsamples_byD[[1]], cv_subsamples = indxs$cv_subsamples_byD[[1]], - silent = silent, progress = "E[Y|D=0,X]: ", - auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X)) + silent = silent, label = "E[Y|D=0,X]", + auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X), + parallel = parallel) # Compute estimates of E[y|D=1,X] y_X_D1_res <- get_CEF(y[-is_D0], X[-is_D0, , drop = FALSE], @@ -161,8 +183,9 @@ ddml_ate <- function(y, D, X, custom_ensemble_weights = custom_ensemble_weights, subsamples = indxs$subsamples_byD[[2]], cv_subsamples = indxs$cv_subsamples_byD[[2]], - silent = silent, progress = "E[Y|D=1,X]: ", - auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X)) + silent = silent, label = "E[Y|D=1,X]", + auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X), + parallel = parallel) # Compute estimates of E[D|X] D_X_res <- get_CEF(D, X, @@ -171,7 +194,8 @@ ddml_ate <- function(y, D, X, custom_ensemble_weights = custom_ensemble_weights_DX, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, - silent = silent, progress = "E[D|X]: ") + silent = silent, label = "E[D|X]", + parallel = parallel) # Update ensemble type to account for (optional) custom weights ensemble_type <- dimnames(y_X_D0_res$weights)[[2]] @@ -228,8 +252,10 @@ ddml_ate <- function(y, D, X, cv_subsamples_byD = indxs$cv_subsamples_byD, ensemble_type = ensemble_type) - # Print estimation progress - if (!silent) cat("DDML estimation completed. \n") + # Print estimation completion + elapsed <- round(proc.time()[3] - t0, 1) + info_msg("ddml_ate: completed in ", elapsed, "s", + silent = silent) # Amend class and return class(ddml_fit) <- "ddml_ate" diff --git a/R/ddml_att.R b/R/ddml_att.R index 10530d3..7563f87 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -17,7 +17,8 @@ ddml_att <- function(y, D, X, cv_subsamples = NULL, cv_subsamples_byD = NULL, trim = 0.01, - silent = FALSE) { + silent = FALSE, + parallel = NULL) { # Data parameters nobs <- length(y) is_D0 <- which(D == 0) @@ -39,8 +40,16 @@ ddml_att <- function(y, D, X, check_subsamples(indxs$subsamples, indxs$subsamples_byD, stratify, D) - # Print to progress to console - if (!silent) cat("DDML estimation in progress. \n") + # Estimation start + t0 <- proc.time()[3] + mode_str <- if (!is.null(parallel)) { + p <- parse_parallel(parallel) + paste0("parallel, ", p$num_cores, " cores") + } else { + "sequential" + } + info_msg("ddml_att: estimating (", mode_str, ")", + silent = silent) # Compute estimates of E[y|D=0,X] y_X_D0_res <- get_CEF(y[is_D0], X[is_D0, , drop = FALSE], @@ -49,8 +58,9 @@ ddml_att <- function(y, D, X, custom_ensemble_weights = custom_ensemble_weights, subsamples = indxs$subsamples_byD[[1]], cv_subsamples = indxs$cv_subsamples_byD[[1]], - silent = silent, progress = "E[Y|D=0,X]: ", - auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X)) + silent = silent, label = "E[Y|D=0,X]", + auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X), + parallel = parallel) # Compute estimates of E[D|X] D_X_res <- get_CEF(D, X, @@ -59,7 +69,8 @@ ddml_att <- function(y, D, X, custom_ensemble_weights = custom_ensemble_weights_DX, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, - silent = silent, progress = "E[D|X]: ") + silent = silent, label = "E[D|X]", + parallel = parallel) # Compute estimates of E[D] -- simple computation of averages here D_res <- get_CEF(D, matrix(1, nobs, 1), @@ -68,7 +79,9 @@ ddml_att <- function(y, D, X, shortstack = FALSE, cv_subsamples = NULL, subsamples = indxs$subsamples, - silent = TRUE) + silent = TRUE, + label = "E[D]", + parallel = parallel) # Update ensemble type to account for (optional) custom weights ensemble_type <- dimnames(y_X_D0_res$weights)[[2]] @@ -118,8 +131,10 @@ ddml_att <- function(y, D, X, cv_subsamples_byD = indxs$cv_subsamples_byD, ensemble_type = ensemble_type) - # Print estimation progress - if (!silent) cat("DDML estimation completed. \n") + # Print estimation completion + elapsed <- round(proc.time()[3] - t0, 1) + info_msg("ddml_att: completed in ", elapsed, "s", + silent = silent) # Amend class and return class(ddml_fit) <- "ddml_att" diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index ba9fe68..1a457bd 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -93,7 +93,8 @@ ddml_fpliv <- function(y, D, Z, X, subsamples = NULL, cv_subsamples = NULL, cv_subsamples_list = NULL, - silent = FALSE) { + silent = FALSE, + parallel = NULL) { # Backward compatibility for renamed parameter if (!is.null(cv_subsamples_list)) { if (!is.null(cv_subsamples)) @@ -123,8 +124,16 @@ ddml_fpliv <- function(y, D, Z, X, cv_subsamples = cv_subsamples) check_subsamples(indxs$subsamples, NULL, stratify = FALSE) - # Print to progress to console - if (!silent) cat("DDML estimation in progress. \n") + # Estimation start + t0 <- proc.time()[3] + mode_str <- if (!is.null(parallel)) { + p <- parse_parallel(parallel) + paste0("parallel, ", p$num_cores, " cores") + } else { + "sequential" + } + info_msg("ddml_fpliv: estimating (", mode_str, ")", + silent = silent) # Compute estimates of E[y|X] y_X_res <- get_CEF(y, X, Z = NULL, @@ -134,12 +143,13 @@ ddml_fpliv <- function(y, D, Z, X, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, compute_insample_predictions = FALSE, - silent = silent, progress = "E[Y|X]: ") + silent = silent, label = "E[Y|X]", + parallel = parallel) # 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) { + for (k in seq_len(nD)) { D_XZ_res_list[[k]] <- get_CEF(D[, k, drop = FALSE], X, Z, learners = learners_DXZ, ensemble_type = ensemble_type, @@ -149,16 +159,20 @@ ddml_fpliv <- function(y, D, Z, X, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, - compute_insample_predictions = enforce_LIE, + compute_insample_predictions = + enforce_LIE, silent = silent, - progress = paste0("E[D", k, "|X,Z]: ")) + label = paste0("E[D", k, + "|X,Z]"), + parallel = parallel) }#FOR # 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 = FALSE], X, Z = NULL, + for (k in seq_len(nD)) { + D_X_res_list[[k]] <- get_CEF(D[, k, drop = FALSE], X, + Z = NULL, learners = learners_DX, ensemble_type = ensemble_type, shortstack = shortstack, @@ -167,9 +181,12 @@ ddml_fpliv <- function(y, D, Z, X, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, - compute_insample_predictions = FALSE, + compute_insample_predictions = + FALSE, silent = silent, - progress = paste0("E[D", k, "|X]: ")) + label = paste0("E[D", k, + "|X]"), + parallel = parallel) }#FOR }#IF @@ -187,7 +204,7 @@ ddml_fpliv <- function(y, D, Z, X, # used for the calculation of the estimates of E[D|X]. if (enforce_LIE) { D_X_res_list <- list() - for (k in 1:nD) { + for (k in seq_len(nD)) { D_X_res_list[[k]] <- get_CEF(D_XZ_res_list[[k]]$is_fitted, X, Z = NULL, learners = learners_DX, @@ -197,8 +214,9 @@ ddml_fpliv <- function(y, D, Z, X, cv_subsamples = indxs$cv_subsamples, compute_insample_predictions = FALSE, silent = silent, - progress = paste0("E[D", k, "|X]: "), - shortstack_y = D_XZ_res_list[[k]]$oos_fitted) + label = paste0("E[D", k, "|X]"), + shortstack_y = D_XZ_res_list[[k]]$oos_fitted, + parallel = parallel) }#FOR }#IFELSE @@ -238,8 +256,9 @@ ddml_fpliv <- function(y, D, Z, 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], "): ") + for (k in seq_len(nD)) { + label_jk <- paste0("E[D", k, "|X] (", + ensemble_type[j], ")") # Check whether j is a custom ensemble specification. Necessary to # assign correct corresponding custom_weights vector. @@ -253,8 +272,9 @@ ddml_fpliv <- function(y, D, Z, X, cv_subsamples = indxs$cv_subsamples, compute_insample_predictions = FALSE, silent = silent, - progress = progress_jk, - shortstack_y = D_XZ_res_list[[k]]$oos_fitted[, j]) + label = label_jk, + shortstack_y = D_XZ_res_list[[k]]$oos_fitted[, j], + parallel = parallel) } else { # j is a custom specification D_X_res_list[[k]] <- get_CEF(D_XZ_res_list[[k]]$is_fitted[[j]], X, Z = NULL, @@ -267,8 +287,9 @@ ddml_fpliv <- function(y, D, Z, X, cv_subsamples = indxs$cv_subsamples, compute_insample_predictions = FALSE, silent = silent, - progress = progress_jk, - shortstack_y = D_XZ_res_list[[k]]$oos_fitted[, j]) + label = label_jk, + shortstack_y = D_XZ_res_list[[k]]$oos_fitted[, j], + parallel = parallel) # 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, , @@ -331,8 +352,10 @@ ddml_fpliv <- function(y, D, Z, X, ensemble_type = ensemble_type, enforce_LIE = enforce_LIE) - # Print estimation progress - if (!silent) cat("DDML estimation completed. \n") + # Print estimation completion + elapsed <- round(proc.time()[3] - t0, 1) + info_msg("ddml_fpliv: completed in ", elapsed, "s", + silent = silent) # Amend class and return class(ddml_fit) <- "ddml_fpliv" diff --git a/R/ddml_late.R b/R/ddml_late.R index d88fc76..5b4197b 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -159,7 +159,8 @@ ddml_late <- function(y, D, Z, X, cv_subsamples = NULL, cv_subsamples_byZ = NULL, trim = 0.01, - silent = FALSE) { + silent = FALSE, + parallel = NULL) { # Data parameters nobs <- length(y) is_Z0 <- which(Z == 0) @@ -181,8 +182,16 @@ ddml_late <- function(y, D, Z, X, check_subsamples(indxs$subsamples, indxs$subsamples_byD, stratify, Z) - # Print to progress to console - if (!silent) cat("DDML estimation in progress. \n") + # Estimation start + t0 <- proc.time()[3] + mode_str <- if (!is.null(parallel)) { + p <- parse_parallel(parallel) + paste0("parallel, ", p$num_cores, " cores") + } else { + "sequential" + } + info_msg("ddml_late: estimating (", mode_str, ")", + silent = silent) # Compute estimates of E[y|Z=0,X] y_X_Z0_res <- get_CEF(y[is_Z0], X[is_Z0, , drop = FALSE], @@ -191,8 +200,9 @@ ddml_late <- function(y, D, Z, X, custom_ensemble_weights = custom_ensemble_weights, subsamples = indxs$subsamples_byD[[1]], cv_subsamples = indxs$cv_subsamples_byD[[1]], - silent = silent, progress = "E[Y|Z=0,X]: ", - auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X)) + silent = silent, label = "E[Y|Z=0,X]", + auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X), + parallel = parallel) # Compute estimates of E[y|Z=1,X] y_X_Z1_res <- get_CEF(y[-is_Z0], X[-is_Z0, , drop = FALSE], @@ -201,17 +211,18 @@ ddml_late <- function(y, D, Z, X, custom_ensemble_weights = custom_ensemble_weights, subsamples = indxs$subsamples_byD[[2]], cv_subsamples = indxs$cv_subsamples_byD[[2]], - silent = silent, progress = "E[Y|Z=1,X]: ", - auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X)) + silent = silent, label = "E[Y|Z=1,X]", + auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X), + parallel = parallel) # 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") + info_msg(" E[D|Z=0,X] .......... skipped ", + "(perfect non-compliance)", silent = silent) } else { # Compute estimates of E[D|Z=0,X] D_X_Z0_res <- get_CEF(D[is_Z0], X[is_Z0, , drop = FALSE], @@ -221,18 +232,19 @@ ddml_late <- function(y, D, Z, X, custom_ensemble_weights = custom_ensemble_weights_DXZ, subsamples = indxs$subsamples_byD[[1]], cv_subsamples = indxs$cv_subsamples_byD[[1]], - silent = silent, progress = "E[D|Z=0,X]: ", - auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X)) + silent = silent, label = "E[D|Z=0,X]", + auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X), + parallel = parallel) }#IFELSE # 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") + info_msg(" E[D|Z=1,X] .......... skipped ", + "(perfect compliance)", silent = silent) } else { # Compute estimates of E[D|Z=1,X] D_X_Z1_res <- get_CEF(D[-is_Z0], X[-is_Z0, , drop = FALSE], @@ -242,8 +254,9 @@ ddml_late <- function(y, D, Z, X, custom_ensemble_weights = custom_ensemble_weights_DXZ, subsamples = indxs$subsamples_byD[[2]], cv_subsamples = indxs$cv_subsamples_byD[[2]], - silent = silent, progress = "E[D|Z=1,X]: ", - auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X)) + silent = silent, label = "E[D|Z=1,X]", + auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X), + parallel = parallel) }#IFELSE # Compute estimates of E[Z|X] @@ -254,7 +267,8 @@ ddml_late <- function(y, D, Z, X, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, compute_insample_predictions = FALSE, - silent = silent, progress = "E[Z|X]: ") + silent = silent, label = "E[Z|X]", + parallel = parallel) # Update ensemble type to account for (optional) custom weights ensemble_type <- dimnames(y_X_Z0_res$weights)[[2]] @@ -323,8 +337,10 @@ ddml_late <- function(y, D, Z, X, cv_subsamples_byZ = indxs$cv_subsamples_byD, ensemble_type = ensemble_type) - # Print estimation progress - if (!silent) cat("DDML estimation completed. \n") + # Print estimation completion + elapsed <- round(proc.time()[3] - t0, 1) + info_msg("ddml_late: completed in ", elapsed, "s", + silent = silent) # Amend class and return class(ddml_fit) <- "ddml_late" diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index bcb2696..703eb6e 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -121,7 +121,8 @@ ddml_pliv <- function(y, D, Z, X, subsamples = NULL, cv_subsamples = NULL, cv_subsamples_list = NULL, - silent = FALSE) { + silent = FALSE, + parallel = NULL) { # Backward compatibility for renamed parameter if (!is.null(cv_subsamples_list)) { if (!is.null(cv_subsamples)) @@ -157,6 +158,17 @@ ddml_pliv <- function(y, D, Z, X, cv_subsamples = cv_subsamples) check_subsamples(indxs$subsamples, NULL, stratify = FALSE) + # Estimation start + t0 <- proc.time()[3] + mode_str <- if (!is.null(parallel)) { + p <- parse_parallel(parallel) + paste0("parallel, ", p$num_cores, " cores") + } else { + "sequential" + } + info_msg("ddml_pliv: estimating (", mode_str, ")", + silent = silent) + # Compute estimates of E[y|X] y_X_res <- get_CEF(y, X, learners = learners, ensemble_type = ensemble_type, @@ -164,11 +176,12 @@ ddml_pliv <- function(y, D, Z, X, custom_ensemble_weights = custom_ensemble_weights, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, - silent = silent, progress = "E[Y|X]: ") + silent = silent, label = "E[Y|X]", + parallel = parallel) # Compute estimates of E[Z|X], loop through instruments Z_X_res_list <- list() - for (k in 1: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, @@ -179,12 +192,14 @@ ddml_pliv <- function(y, D, Z, X, cv_subsamples = indxs$cv_subsamples, silent = silent, - progress = paste0("E[Z", k, "|X]: ")) + label = paste0("E[Z", k, + "|X]"), + parallel = parallel) }#FOR # Compute estimates of E[D|X], loop through endogenous variables D_X_res_list <- list() - for (k in 1: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, @@ -195,7 +210,9 @@ ddml_pliv <- function(y, D, Z, X, cv_subsamples = indxs$cv_subsamples, silent = silent, - progress = paste0("E[D", k, "|X]: ")) + label = paste0("E[D", k, + "|X]"), + parallel = parallel) }#FOR # Update ensemble type to account for (optional) custom weights @@ -270,6 +287,11 @@ ddml_pliv <- function(y, D, Z, X, cv_subsamples = indxs$cv_subsamples, ensemble_type = ensemble_type) + # Print estimation completion + elapsed <- round(proc.time()[3] - t0, 1) + info_msg("ddml_pliv: completed in ", elapsed, "s", + silent = silent) + # Amend class and return class(ddml_fit) <- "ddml_pliv" return(ddml_fit) diff --git a/R/ddml_plm.R b/R/ddml_plm.R index cf8b73e..c241fa6 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -76,6 +76,18 @@ #' containing vectors with subsample indices for cross-validation. #' @param cv_subsamples_list Deprecated; use \code{cv_subsamples} instead. #' @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}).} +#' } #' #' @return \code{ddml_plm} returns an object of S3 class #' \code{ddml_plm}. An object of class \code{ddml_plm} is a list containing @@ -151,7 +163,8 @@ ddml_plm <- function(y, D, X, subsamples = NULL, cv_subsamples = NULL, cv_subsamples_list = NULL, - silent = FALSE) { + silent = FALSE, + parallel = NULL) { # Backward compatibility for renamed parameter if (!is.null(cv_subsamples_list)) { if (!is.null(cv_subsamples)) @@ -184,8 +197,16 @@ ddml_plm <- function(y, D, X, cv_subsamples = cv_subsamples) check_subsamples(indxs$subsamples, NULL, stratify = FALSE) - # Print to progress to console - if (!silent) cat("DDML estimation in progress. \n") + # Estimation start + t0 <- proc.time()[3] + mode_str <- if (!is.null(parallel)) { + p <- parse_parallel(parallel) + paste0("parallel, ", p$num_cores, " cores") + } else { + "sequential" + } + info_msg("ddml_plm: estimating (", mode_str, ")", + silent = silent) # Compute estimates of E[y|X] y_X_res <- get_CEF(y, X, @@ -195,11 +216,12 @@ ddml_plm <- function(y, D, X, custom_ensemble_weights = custom_ensemble_weights, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, - silent = silent, progress = "E[Y|X]: ") + silent = silent, label = "E[Y|X]", + parallel = parallel) # Compute estimates of E[D|X], loop through endogenous variables D_X_res_list <- list() - for (k in 1: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, @@ -210,7 +232,9 @@ ddml_plm <- function(y, D, X, cv_subsamples = indxs$cv_subsamples, silent = silent, - progress = paste0("E[D", k, "|X]: ")) + label = paste0("E[D", k, + "|X]"), + parallel = parallel) }#FOR # Update ensemble type to account for (optional) custom weights @@ -280,8 +304,10 @@ ddml_plm <- function(y, D, X, cv_subsamples = indxs$cv_subsamples, ensemble_type = ensemble_type) - # Print estimation progress - if (!silent) cat("DDML estimation completed. \n") + # Print estimation completion + elapsed <- round(proc.time()[3] - t0, 1) + info_msg("ddml_plm: completed in ", elapsed, "s", + silent = silent) # Amend class and return class(ddml_fit) <- "ddml_plm" diff --git a/R/ensemble.R b/R/ensemble.R index df010e2..2bc3040 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -6,8 +6,7 @@ ensemble <- function(y, X, Z = NULL, cv_subsamples = NULL, cv_results = NULL, custom_weights = NULL, - silent = FALSE, - progress = NULL) { + silent = FALSE) { # Data parameters nlearners <- length(learners) # Check if y is constant @@ -33,7 +32,7 @@ ensemble <- function(y, X, Z = NULL, 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 @@ -120,8 +119,7 @@ ensemble_weights <- function(y, X, Z = NULL, cv_subsamples = NULL, cv_results = NULL, custom_weights = NULL, - silent = FALSE, - progress = NULL) { + silent = FALSE) { # Data parameters nlearners <- length(learners) ncustom <- ncol(custom_weights) @@ -137,7 +135,7 @@ ensemble_weights <- function(y, X, Z = NULL, learners = learners, cv_folds = cv_folds, cv_subsamples = cv_subsamples, - silent = silent, progress = progress) + silent = silent) }#IF # Compute weights for each ensemble type weights <- matrix(0, nlearners, ntype + ncustom) diff --git a/R/get_CEF.R b/R/get_CEF.R index 4b95640..160a85e 100644 --- a/R/get_CEF.R +++ b/R/get_CEF.R @@ -9,46 +9,51 @@ get_CEF <- function(y, X, Z = NULL, subsamples, cv_subsamples, silent = FALSE, - progress = NULL, + label = NULL, auxiliary_X = NULL, - shortstack_y = y) { + shortstack_y = y, + parallel = NULL) { + t0 <- proc.time()[3] + + if (!is.null(label)) { + info_msg(" Estimating ", label, "...", silent = silent) + }#IF + # Compute CEF if (shortstack) { res <- shortstacking(y, X, Z, learners = learners, ensemble_type = ensemble_type, - custom_ensemble_weights = custom_ensemble_weights, + custom_ensemble_weights = + custom_ensemble_weights, compute_insample_predictions = compute_insample_predictions, subsamples = subsamples, - silent = silent, progress = progress, + silent = silent, auxiliary_X = auxiliary_X, - shortstack_y = shortstack_y) + shortstack_y = shortstack_y, + parallel = parallel) } else { res <- crosspred(y, X, Z, learners = learners, ensemble_type = ensemble_type, - custom_ensemble_weights = custom_ensemble_weights, + custom_ensemble_weights = + custom_ensemble_weights, compute_insample_predictions = compute_insample_predictions, compute_predictions_bylearner = compute_predictions_bylearner, subsamples = subsamples, cv_subsamples = cv_subsamples, - silent = silent, progress = progress, - auxiliary_X = auxiliary_X) + silent = silent, + auxiliary_X = auxiliary_X, + parallel = parallel) }#IFELSE - update_progress(silent) # Return estimates return(res) }#GET_CEF -# Utility to print progress to console -update_progress <- function(silent) { - if (!silent) cat(" -- Done! \n") -}#UPDATE_PROGRESS - # Construct CEF from auxiliary_X extrapolate_CEF <- function(D, CEF_res_byD, aux_indx) { # Data parameters diff --git a/R/parallel.R b/R/parallel.R new file mode 100644 index 0000000..eda4d16 --- /dev/null +++ b/R/parallel.R @@ -0,0 +1,48 @@ +# 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 + +# Internal helper for silent-aware messages. +info_msg <- function(..., silent = FALSE) { + if (!silent) message(...) +}#INFO_MSG diff --git a/R/shortstacking.R b/R/shortstacking.R index 0571247..967dc61 100644 --- a/R/shortstacking.R +++ b/R/shortstacking.R @@ -8,6 +8,18 @@ #' @param shortstack_y Optional vector of the outcome variable to form #' short-stacking predictions for. Base learners are always trained on #' \code{y}. +#' @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{shortstack} returns a list containing the following components: #' \describe{ @@ -62,19 +74,18 @@ #' 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, - cluster_variable = seq_along(y), - silent = FALSE, - progress = NULL, - auxiliary_X = NULL, - shortstack_y = y) { - +shortstacking <- function(y, X, Z = NULL, + learners, + sample_folds = 2, + ensemble_type = "average", + custom_ensemble_weights = NULL, + compute_insample_predictions = FALSE, + subsamples = NULL, + cluster_variable = seq_along(y), + silent = FALSE, + auxiliary_X = NULL, + shortstack_y = y, + parallel = NULL) { # Data parameters nobs <- nrow(X) nlearners <- length(learners) @@ -99,11 +110,13 @@ shortstacking <- function (y, X, Z = NULL, res <- crosspred(y, X, Z, learners = learners, ensemble_type = "average", - compute_insample_predictions = compute_insample_predictions, + compute_insample_predictions = + compute_insample_predictions, compute_predictions_bylearner = TRUE, 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() diff --git a/man/crosspred.Rd b/man/crosspred.Rd index 0219145..9909e35 100644 --- a/man/crosspred.Rd +++ b/man/crosspred.Rd @@ -20,8 +20,8 @@ crosspred( cv_subsamples = NULL, cv_subsamples_list = NULL, silent = FALSE, - progress = NULL, - auxiliary_X = NULL + auxiliary_X = NULL, + parallel = NULL ) } \arguments{ @@ -50,8 +50,8 @@ 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.} +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.} @@ -101,11 +101,22 @@ containing vectors with subsample indices for cross-validation.} \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{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: @@ -116,7 +127,8 @@ 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 = TRUE}. +\item{\code{is_fitted}}{When +\code{compute_insample_predictions = TRUE}. a list of matrices with in-sample predictions by sample fold.} \item{\code{auxiliary_fitted}}{When \code{auxiliary_X} is not \code{NULL}, a list of matrices with additional predictions.} @@ -126,11 +138,12 @@ out-of-sample predictions, each column corresponding to a base learner (in chronological order).} \item{\code{is_fitted_bylearner}}{When \code{compute_insample_predictions = TRUE} and -\code{compute_predictions_bylearner = TRUE}, 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 = TRUE}, a -list of matrices with additional predictions for each learner.} +\code{compute_predictions_bylearner = TRUE}, 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 = TRUE}, a list of +matrices with additional predictions for each learner.} } } \description{ diff --git a/man/crossval.Rd b/man/crossval.Rd index 93e2f86..2a36602 100644 --- a/man/crossval.Rd +++ b/man/crossval.Rd @@ -13,7 +13,7 @@ crossval( cluster_variable = seq_along(y), cv_subsamples = NULL, silent = FALSE, - progress = NULL + parallel = NULL ) } \arguments{ @@ -51,7 +51,18 @@ 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: diff --git a/man/ddml_ate.Rd b/man/ddml_ate.Rd index 627f584..d7dbe91 100644 --- a/man/ddml_ate.Rd +++ b/man/ddml_ate.Rd @@ -24,7 +24,8 @@ ddml_ate( cv_subsamples = NULL, cv_subsamples_byD = NULL, trim = 0.01, - silent = FALSE + silent = FALSE, + parallel = NULL ) ddml_att( @@ -46,7 +47,8 @@ ddml_att( cv_subsamples = NULL, cv_subsamples_byD = NULL, trim = 0.01, - silent = FALSE + silent = FALSE, + parallel = NULL ) } \arguments{ @@ -138,6 +140,19 @@ for cross-validation.} \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}).} +}} } \value{ \code{ddml_ate} and \code{ddml_att} return an object of S3 class diff --git a/man/ddml_fpliv.Rd b/man/ddml_fpliv.Rd index fc8dc95..9b622fa 100644 --- a/man/ddml_fpliv.Rd +++ b/man/ddml_fpliv.Rd @@ -24,7 +24,8 @@ ddml_fpliv( subsamples = NULL, cv_subsamples = NULL, cv_subsamples_list = NULL, - silent = FALSE + silent = FALSE, + parallel = NULL ) } \arguments{ @@ -115,6 +116,19 @@ containing vectors with subsample indices for cross-validation.} \item{cv_subsamples_list}{Deprecated; use \code{cv_subsamples} instead.} \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}).} +}} } \value{ \code{ddml_fpliv} returns an object of S3 class diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index f53f315..1bffd50 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -26,7 +26,8 @@ ddml_late( cv_subsamples = NULL, cv_subsamples_byZ = NULL, trim = 0.01, - silent = FALSE + silent = FALSE, + parallel = NULL ) } \arguments{ @@ -127,6 +128,19 @@ for cross-validation.} \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}).} +}} } \value{ \code{ddml_late} returns an object of S3 class diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index 74cf1bc..ab68425 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -23,7 +23,8 @@ ddml_pliv( subsamples = NULL, cv_subsamples = NULL, cv_subsamples_list = NULL, - silent = FALSE + silent = FALSE, + parallel = NULL ) } \arguments{ @@ -111,6 +112,19 @@ containing vectors with subsample indices for cross-validation.} \item{cv_subsamples_list}{Deprecated; use \code{cv_subsamples} instead.} \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}).} +}} } \value{ \code{ddml_pliv} returns an object of S3 class diff --git a/man/ddml_plm.Rd b/man/ddml_plm.Rd index a04d5da..e0a696b 100644 --- a/man/ddml_plm.Rd +++ b/man/ddml_plm.Rd @@ -20,7 +20,8 @@ ddml_plm( subsamples = NULL, cv_subsamples = NULL, cv_subsamples_list = NULL, - silent = FALSE + silent = FALSE, + parallel = NULL ) } \arguments{ @@ -99,6 +100,19 @@ containing vectors with subsample indices for cross-validation.} \item{cv_subsamples_list}{Deprecated; use \code{cv_subsamples} instead.} \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}).} +}} } \value{ \code{ddml_plm} returns an object of S3 class diff --git a/man/shortstacking.Rd b/man/shortstacking.Rd index f272cc9..34d89de 100644 --- a/man/shortstacking.Rd +++ b/man/shortstacking.Rd @@ -16,9 +16,9 @@ shortstacking( subsamples = NULL, cluster_variable = seq_along(y), silent = FALSE, - progress = NULL, auxiliary_X = NULL, - shortstack_y = y + shortstack_y = y, + parallel = NULL ) } \arguments{ @@ -47,8 +47,8 @@ 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.} +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.} @@ -86,8 +86,6 @@ predictions should also be computed.} \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.} @@ -95,6 +93,19 @@ 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: diff --git a/tests/testthat/test-crosspred.R b/tests/testthat/test-crosspred.R index bbde427..77920a1 100644 --- a/tests/testthat/test-crosspred.R +++ b/tests/testthat/test-crosspred.R @@ -129,3 +129,33 @@ test_that("crosspred computes auxilliary predictions", { # 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(fun = ols), + list(fun = 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 = T) + # 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 = T, + parallel = list(cores = 2)) + expect_equal(res_par$oos_fitted, res_seq$oos_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..d88346d 100644 --- a/tests/testthat/test-crossval.R +++ b/tests/testthat/test-crossval.R @@ -82,3 +82,24 @@ test_that("crossval returns residuals by learner (w/ instruments)", { expect_equal(all(round(cv_res$oos_resid[, 1], 3) == round(cv_res$oos_resid[, 2], 3)), TRUE) })#TEST_THAT + +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(fun = ols), + list(fun = ols)) + cv_subs <- generate_subsamples(nobs, 3) + # Sequential + res_seq <- crossval(y, X, learners = learners, + cv_subsamples = cv_subs, silent = T) + # Parallel + res_par <- crossval(y, X, learners = learners, + cv_subsamples = cv_subs, silent = T, + parallel = list(cores = 2)) + expect_equal(res_par$mspe, res_seq$mspe) + expect_equal(res_par$oos_resid, res_seq$oos_resid) +})#TEST_THAT diff --git a/tests/testthat/test-ddml_plm.R b/tests/testthat/test-ddml_plm.R index d3aff3a..aa841ca 100644 --- a/tests/testthat/test-ddml_plm.R +++ b/tests/testthat/test-ddml_plm.R @@ -314,3 +314,29 @@ test_that("ddml_plm backward-compat cv_subsamples_list works with message", { silent = TRUE), "cv_subsamples_list has been renamed") })#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, + subsamples = splits$subsamples, + silent = T) + # Parallel + res_par <- ddml_plm(y, D, X, + learners = learners, + sample_folds = 3, + subsamples = splits$subsamples, + silent = T, + parallel = list(cores = 2)) + expect_equal(res_par$coef, res_seq$coef) +})#TEST_THAT From bf8b6d956fcc6c91768d960884497b9bd45c7129 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Mon, 23 Feb 2026 17:39:15 -0600 Subject: [PATCH 04/46] refactor inference, support broom+texreg --- DESCRIPTION | 6 +- NAMESPACE | 28 +++--- NEWS.md | 6 +- R/ddml_ate.R | 111 +++++----------------- R/ddml_att.R | 53 +++++------ R/ddml_fpliv.R | 62 ++++++------ R/ddml_late.R | 58 +++++------- R/ddml_pliv.R | 61 ++++++------ R/ddml_plm.R | 123 ++++++------------------ R/ensemble.R | 59 +++++++++++- R/inference_functions.R | 151 +++++++++++------------------- R/methods.R | 156 +++++++++++++++++++++++++++++++ R/ml_wrappers.R | 45 ++++++++- R/tidy.R | 63 +++++++++++++ R/zzz.R | 36 +++++++ man/coef.ddml.Rd | 20 ++++ man/confint.ddml.Rd | 26 ++++++ man/crosspred.Rd | 2 + man/crossval.Rd | 2 + man/ddml_ate.Rd | 5 +- man/ddml_fpliv.Rd | 2 +- man/ddml_late.Rd | 4 +- man/ddml_pliv.Rd | 2 +- man/ddml_plm.Rd | 2 +- man/ensemble.Rd | 66 +++++++++++++ man/ensemble_weights.Rd | 61 ++++++++++++ man/glance.ddml.Rd | 19 ++++ man/mdl_bigGLM.Rd | 37 ++++++++ man/mdl_glm.Rd | 1 + man/mdl_glmnet.Rd | 1 + man/mdl_ranger.Rd | 1 + man/mdl_xgboost.Rd | 1 + man/ols.Rd | 1 + man/print.summary.ddml.Rd | 21 +++++ man/print.summary.ddml_ate.Rd | 44 --------- man/print.summary.ddml_plm.Rd | 44 --------- man/reexports.Rd | 17 ++++ man/shortstacking.Rd | 4 +- man/summary.ddml.Rd | 19 ++++ man/summary.ddml_ate.Rd | 44 --------- man/summary.ddml_plm.Rd | 61 ------------ man/tidy.ddml.Rd | 23 +++++ man/vcov.ddml.Rd | 22 +++++ tests/testthat/test-ddml_ate.R | 9 +- tests/testthat/test-ddml_att.R | 9 +- tests/testthat/test-ddml_fpliv.R | 5 +- tests/testthat/test-ddml_late.R | 6 +- tests/testthat/test-ddml_plm.R | 13 ++- 48 files changed, 975 insertions(+), 637 deletions(-) create mode 100644 R/methods.R create mode 100644 R/tidy.R create mode 100644 R/zzz.R create mode 100644 man/coef.ddml.Rd create mode 100644 man/confint.ddml.Rd create mode 100644 man/ensemble.Rd create mode 100644 man/ensemble_weights.Rd create mode 100644 man/glance.ddml.Rd create mode 100644 man/mdl_bigGLM.Rd create mode 100644 man/print.summary.ddml.Rd delete mode 100644 man/print.summary.ddml_ate.Rd delete mode 100644 man/print.summary.ddml_plm.Rd create mode 100644 man/reexports.Rd create mode 100644 man/summary.ddml.Rd delete mode 100644 man/summary.ddml_ate.Rd delete mode 100644 man/summary.ddml_plm.Rd create mode 100644 man/tidy.ddml.Rd create mode 100644 man/vcov.ddml.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 3fea682..3ba3287 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -33,13 +33,15 @@ Imports: quadprog, glmnet, ranger, - xgboost + xgboost, + generics Suggests: covr, knitr, parallel, rmarkdown, sandwich, - testthat (>= 3.0.0) + testthat (>= 3.0.0), + texreg Config/testthat/edition: 3 VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index 0d4a62e..e9efc0c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,23 +1,19 @@ # Generated by roxygen2: do not edit by hand +S3method(coef,ddml) +S3method(confint,ddml) +S3method(glance,ddml) 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,summary.ddml) +S3method(summary,ddml) +S3method(tidy,ddml) +S3method(vcov,ddml) export(crosspred) export(crossval) export(ddml_ate) @@ -26,9 +22,17 @@ export(ddml_fpliv) export(ddml_late) export(ddml_pliv) export(ddml_plm) +export(ensemble) +export(ensemble_weights) +export(glance) +export(mdl_bigGLM) export(mdl_glm) export(mdl_glmnet) export(mdl_ranger) export(mdl_xgboost) export(ols) export(shortstacking) +export(tidy) +importFrom(generics,glance) +importFrom(generics,tidy) +importFrom(stats,vcov) diff --git a/NEWS.md b/NEWS.md index 681bcff..de35c2e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,13 +8,15 @@ ``shortstacking()`` for cluster-aware sample splitting. * Renames ``cv_subsamples_list`` to ``cv_subsamples``. The old name still works with a deprecation message. -* Replaces internal ``get_all_indx()`` with ``get_sample_splits()``. * Warns when any cross-fitting training set has fewer than 100 observations. * 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. +* Updates inference and generic S3 methods (`coef`, `vcov`, `confint`, `summary`, `print`). +* Adds compatibility with `broom` (`tidy`, `glance`) and `texreg` (`extract.ddml`) for standardizing estimation output tables. +* Adds `mdl_bigGLM` sparse-matrix unpenalized regression wrapper using `glmnet`. +* Fixes `mdl_xgboost` for binary classification with numeric outcomes. # ddml 0.3.0 diff --git a/R/ddml_ate.R b/R/ddml_ate.R index 7f65dbb..bccbeea 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -2,7 +2,7 @@ #' #' @family ddml #' -#' @seealso [ddml::summary.ddml_ate()], [ddml::summary.ddml_att()] +#' @seealso [ddml::summary.ddml()] #' #' @description Estimators of the average treatment effect and the average #' treatment effect on the treated. @@ -67,8 +67,7 @@ #' 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()].} +#' of scores. Used in [ddml::summary.ddml()].} #' \item{\code{oos_pred}}{List of matrices, providing the reduced form #' predicted values.} #' \item{\code{learners},\code{learners_DX},\code{cluster_variable}, @@ -223,9 +222,18 @@ ddml_ate <- function(y, D, X, ate <- colMeans(psi_b) names(ate) <- ensemble_type - # Also set psi_a scores for easier computation of summary.ddml_ate + # Also set psi_a scores for easier computation of summary.ddml psi_a <- matrix(-1, nobs, nensb) + # Compute scores and Jacobian from psi_a/psi_b + scores <- lapply(seq_len(nensb), function(j) { + as.matrix(psi_a[, j] * ate[j] + psi_b[, j]) + }) + J_list <- lapply(seq_len(nensb), function(j) { + as.matrix(mean(psi_a[, j])) + }) + coef_names <- "ATE" + # Organize complementary ensemble output weights <- list(y_X_D0 = y_X_D0_res$weights, y_X_D1 = y_X_D1_res$weights, @@ -249,8 +257,18 @@ ddml_ate <- function(y, D, X, learners_DX = learners_DX, cluster_variable = cluster_variable, subsamples_byD = indxs$subsamples_byD, - cv_subsamples_byD = indxs$cv_subsamples_byD, - ensemble_type = ensemble_type) + cv_subsamples_byD = + indxs$cv_subsamples_byD, + ensemble_type = ensemble_type, + coefficients = ate, + scores = scores, + J = J_list, + coef_names = coef_names, + nobs = nobs, + sample_folds = sample_folds, + cv_folds = if (shortstack) NULL + else cv_folds, + shortstack = shortstack) # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) @@ -258,85 +276,6 @@ ddml_ate <- function(y, D, X, silent = silent) # Amend class and return - class(ddml_fit) <- "ddml_ate" + class(ddml_fit) <- c("ddml_ate", "ddml") return(ddml_fit) }#DDML_ATE - -#' 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 - -#' 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 diff --git a/R/ddml_att.R b/R/ddml_att.R index 7563f87..277ab29 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -109,6 +109,15 @@ ddml_att <- function(y, D, X, att <- -colMeans(psi_b) / colMeans(psi_a) names(att) <- ensemble_type + # Compute scores and Jacobian from psi_a/psi_b + scores <- lapply(seq_len(nensb), function(j) { + as.matrix(psi_a[, j] * att[j] + psi_b[, j]) + }) + J_list <- lapply(seq_len(nensb), function(j) { + as.matrix(mean(psi_a[, j])) + }) + coef_names <- "ATT" + # Organize complementary ensemble output weights <- list(y_X_D0 = y_X_D0_res$weights, D_X = D_X_res$weights) @@ -128,8 +137,18 @@ ddml_att <- function(y, D, X, learners_DX = learners_DX, cluster_variable = cluster_variable, subsamples_byD = indxs$subsamples_byD, - cv_subsamples_byD = indxs$cv_subsamples_byD, - ensemble_type = ensemble_type) + cv_subsamples_byD = + indxs$cv_subsamples_byD, + ensemble_type = ensemble_type, + coefficients = att, + scores = scores, + J = J_list, + coef_names = coef_names, + nobs = nobs, + sample_folds = sample_folds, + cv_folds = if (shortstack) NULL + else cv_folds, + shortstack = shortstack) # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) @@ -137,34 +156,6 @@ ddml_att <- function(y, D, X, silent = silent) # Amend class and return - class(ddml_fit) <- "ddml_att" + class(ddml_fit) <- c("ddml_att", "ddml") return(ddml_fit) }#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_fpliv.R b/R/ddml_fpliv.R index 1a457bd..38de8cc 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -2,7 +2,7 @@ #' #' @family ddml #' -#' @seealso [ddml::summary.ddml_fpliv()], [AER::ivreg()] +#' @seealso [ddml::summary.ddml()], [AER::ivreg()] #' #' @description Estimator for the flexible partially linear IV model. #' @@ -230,6 +230,15 @@ ddml_fpliv <- function(y, D, Z, X, # Organize complementary ensemble output coef <- stats::coef(iv_fit)[-1] + + # Compute scores and Jacobian + D_r_mat <- as.matrix(D_r) + V_r_mat <- as.matrix(V_r) + D_hat <- stats::lm.fit(V_r_mat, D_r_mat)$fitted.values + e <- as.vector(y_r - D_r_mat %*% coef) + scores <- list(D_hat * e) + J_list <- list(-crossprod(D_hat, D_r_mat) / nobs) + coef_names <- names(coef) }#IF # If multiple ensembles are calculated, iterate over each type. @@ -237,6 +246,8 @@ ddml_fpliv <- function(y, D, Z, X, # Iterate over ensemble type. Compute DDML IV estimate for each. coef <- matrix(0, nD, nensb) iv_fit <- rep(list(1), nensb) + scores <- vector("list", nensb) + J_list <- vector("list", nensb) nlearners <- length(learners) nlearners_DX <- length(learners_DX); nlearners_DXZ <- length(learners_DXZ) # Assign names for more legible output @@ -318,10 +329,21 @@ ddml_fpliv <- function(y, D, Z, X, # Organize complementary ensemble output coef[, j] <- stats::coef(iv_fit_j)[-1] iv_fit[[j]] <- iv_fit_j + + # Compute scores and Jacobian + D_r_mat <- as.matrix(D_r) + V_r_mat <- as.matrix(V_r) + D_hat <- stats::lm.fit(V_r_mat, D_r_mat)$fitted.values + e_j <- as.vector(y_r - D_r_mat %*% coef[, j]) + scores[[j]] <- D_hat * e_j + J_list[[j]] <- -crossprod(D_hat, D_r_mat) / nobs + if (enforce_LIE) { for (k in 1:nD) weights_DX[[k]][, j, ] <- D_X_res_list[[k]]$weights }#IF }#FOR + rownames(coef) <- names(iv_fit[[1]]$coefficients)[-1] + coef_names <- rownames(coef) }#IF # Store complementary ensemble output @@ -350,7 +372,16 @@ ddml_fpliv <- function(y, D, Z, X, subsamples = subsamples, cv_subsamples = indxs$cv_subsamples, ensemble_type = ensemble_type, - enforce_LIE = enforce_LIE) + enforce_LIE = enforce_LIE, + coefficients = coef, + scores = scores, + J = J_list, + coef_names = coef_names, + nobs = nobs, + sample_folds = sample_folds, + cv_folds = if (shortstack) NULL + else cv_folds, + shortstack = shortstack) # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) @@ -358,32 +389,7 @@ ddml_fpliv <- function(y, D, Z, X, silent = silent) # Amend class and return - class(ddml_fit) <- "ddml_fpliv" + class(ddml_fit) <- c("ddml_fpliv", "ddml") return(ddml_fit) }#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 5b4197b..4319748 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -2,7 +2,7 @@ #' #' @family ddml #' -#' @seealso [ddml::summary.ddml_late()] +#' @seealso [ddml::summary.ddml()] #' #' @description Estimator of the local average treatment effect. #' @@ -86,7 +86,7 @@ #' 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()].} +#' of scores. Used in [ddml::summary.ddml()].} #' \item{\code{oos_pred}}{List of matrices, providing the reduced form #' predicted values.} #' \item{\code{learners},\code{learners_DXZ},\code{learners_ZX}, @@ -306,6 +306,15 @@ ddml_late <- function(y, D, Z, X, late <- -numerator / denominator names(late) <- ensemble_type + # Compute scores and Jacobian from psi_a/psi_b + scores <- lapply(seq_len(nensb), function(j) { + as.matrix(psi_a[, j] * late[j] + psi_b[, j]) + }) + J_list <- lapply(seq_len(nensb), function(j) { + as.matrix(mean(psi_a[, j])) + }) + coef_names <- "LATE" + # Organize complementary ensemble output weights <- list(y_X_Z0 = y_X_Z0_res$weights, y_X_Z1 = y_X_Z1_res$weights, @@ -334,8 +343,18 @@ ddml_late <- function(y, D, Z, X, learners_ZX = learners_ZX, cluster_variable = cluster_variable, subsamples_byZ = indxs$subsamples_byD, - cv_subsamples_byZ = indxs$cv_subsamples_byD, - ensemble_type = ensemble_type) + cv_subsamples_byZ = + indxs$cv_subsamples_byD, + ensemble_type = ensemble_type, + coefficients = late, + scores = scores, + J = J_list, + coef_names = coef_names, + nobs = nobs, + sample_folds = sample_folds, + cv_folds = if (shortstack) NULL + else cv_folds, + shortstack = shortstack) # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) @@ -343,35 +362,6 @@ ddml_late <- function(y, D, Z, X, silent = silent) # Amend class and return - class(ddml_fit) <- "ddml_late" + class(ddml_fit) <- c("ddml_late", "ddml") return(ddml_fit) }#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 703eb6e..3ba6797 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -2,7 +2,7 @@ #' #' @family ddml #' -#' @seealso [ddml::summary.ddml_pliv()], [AER::ivreg()] +#' @seealso [ddml::summary.ddml()], [AER::ivreg()] #' #' @description Estimator for the partially linear IV model. #' @@ -235,6 +235,15 @@ ddml_pliv <- function(y, D, Z, X, # Organize complementary ensemble output coef <- stats::coef(iv_fit)[-1] + + # Compute scores and Jacobian + D_r_mat <- as.matrix(D_r) + V_r_mat <- as.matrix(V_r) + D_hat <- stats::lm.fit(V_r_mat, D_r_mat)$fitted.values + e <- as.vector(y_r - D_r_mat %*% coef) + scores <- list(D_hat * e) + J_list <- list(-crossprod(D_hat, D_r_mat) / nobs) + coef_names <- names(coef) }#IF # If multiple ensembles are calculated, iterate over each type. @@ -242,6 +251,8 @@ ddml_pliv <- function(y, D, Z, X, # Iterate over ensemble type. Compute DDML IV estimate for each. coef <- matrix(0, nD, nensb) iv_fit <- rep(list(1), nensb) + scores <- vector("list", nensb) + J_list <- vector("list", nensb) nlearners <- length(learners) nlearners_DX <- length(learners_DX); nlearners_ZX <- length(learners_ZX) @@ -258,10 +269,19 @@ ddml_pliv <- function(y, D, Z, X, # Organize complementary ensemble output coef[, j] <- stats::coef(iv_fit_j)[-1] iv_fit[[j]] <- iv_fit_j + + # Compute scores and Jacobian + D_r_mat <- as.matrix(D_r) + V_r_mat <- as.matrix(V_r) + D_hat <- stats::lm.fit(V_r_mat, D_r_mat)$fitted.values + e_j <- as.vector(y_r - D_r_mat %*% coef[, j]) + scores[[j]] <- D_hat * e_j + J_list[[j]] <- -crossprod(D_hat, D_r_mat) / nobs }#FOR # Assign names for more legible output colnames(coef) <- names(iv_fit) <- ensemble_type rownames(coef) <- names(iv_fit_j$coefficients)[-1] + coef_names <- rownames(coef) }#IF # Store complementary ensemble output @@ -285,7 +305,16 @@ ddml_pliv <- function(y, D, Z, X, cluster_variable = cluster_variable, subsamples = subsamples, cv_subsamples = indxs$cv_subsamples, - ensemble_type = ensemble_type) + ensemble_type = ensemble_type, + coefficients = coef, + scores = scores, + J = J_list, + coef_names = coef_names, + nobs = nobs, + sample_folds = sample_folds, + cv_folds = if (shortstack) NULL + else cv_folds, + shortstack = shortstack) # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) @@ -293,32 +322,6 @@ ddml_pliv <- function(y, D, Z, X, silent = silent) # Amend class and return - class(ddml_fit) <- "ddml_pliv" + class(ddml_fit) <- c("ddml_pliv", "ddml") return(ddml_fit) }#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 c241fa6..99a187b 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -2,7 +2,7 @@ #' #' @family ddml #' -#' @seealso [ddml::summary.ddml_plm()] +#' @seealso [ddml::summary.ddml()] #' #' @description Estimator for the partially linear model. #' @@ -256,6 +256,13 @@ ddml_plm <- function(y, D, X, # Organize complementary ensemble output coef <- stats::coef(ols_fit)[-1] + + # Compute scores and Jacobian + D_r_mat <- as.matrix(D_r) + e <- as.vector(y_r - D_r_mat %*% coef) + scores <- list(D_r_mat * e) + J_list <- list(-crossprod(D_r_mat) / nobs) + coef_names <- names(coef) }#IF # If multiple ensembles are calculated, iterate over each type. @@ -263,6 +270,8 @@ ddml_plm <- function(y, D, X, # Iterate over ensemble type. Compute DDML estimate for each. coef <- matrix(0, nD, nensb) mspe <- ols_fit <- rep(list(1), nensb) + scores <- vector("list", nensb) + J_list <- vector("list", nensb) nlearners <- length(learners); nlearners_DX <- length(learners_DX) # Compute coefficients for each ensemble @@ -279,11 +288,18 @@ ddml_plm <- function(y, D, X, # Organize complementary ensemble output coef[, j] <- stats::coef(ols_fit_j)[-1] ols_fit[[j]] <- ols_fit_j + + # Compute scores and Jacobian + D_r_mat <- as.matrix(D_r) + e_j <- as.vector(y_r - D_r_mat %*% coef[, j]) + scores[[j]] <- D_r_mat * e_j + J_list[[j]] <- -crossprod(D_r_mat) / nobs }#FOR # 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] + coef_names <- rownames(coef) }#IF # Store complementary ensemble output @@ -302,7 +318,16 @@ ddml_plm <- function(y, D, X, cluster_variable = cluster_variable, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, - ensemble_type = ensemble_type) + ensemble_type = ensemble_type, + coefficients = coef, + scores = scores, + J = J_list, + coef_names = coef_names, + nobs = nobs, + sample_folds = sample_folds, + cv_folds = if (shortstack) NULL + else cv_folds, + shortstack = shortstack) # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) @@ -310,99 +335,7 @@ ddml_plm <- function(y, D, X, silent = silent) # Amend class and return - class(ddml_fit) <- "ddml_plm" + class(ddml_fit) <- c("ddml_plm", "ddml") return(ddml_fit) }#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 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 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/ensemble.R b/R/ensemble.R index 2bc3040..844465d 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -1,4 +1,34 @@ -# Stacking estimator using combinations of base learners. +#' 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 Z Optional instrumental variables matrix. +#' @param type A character string indicating the type of ensemble to compute. +#' Default is \code{"average"}. +#' @param learners A list of base learners. +#' @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: +#' \item{mdl_fits}{List of fitted base learners.} +#' \item{weights}{Computed ensemble weights.} +#' \item{learners}{The base learners used.} +#' \item{cv_results}{Cross-validation results if computed.} +#' \item{mean_y}{Mean of the outcome variable.} +#' \item{constant_y}{Boolean indicating if y is constant.} +#' @export +#' +#' @examples +#' # Not run ensemble <- function(y, X, Z = NULL, type = "average", learners, @@ -112,6 +142,33 @@ predict.ensemble <- function(object, newdata, newZ = NULL, ...){ }#PREDICT.ENSEMBLE # Complementary functions ====================================================== + +#' 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 Z Optional instrumental variables matrix. +#' @param type A character string or vector indicating the type(s) of ensemble +#' weights to compute. Default is \code{"average"}. +#' @param learners A list of base learners. +#' @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: +#' \item{weights}{A matrix of computed ensemble weights.} +#' \item{cv_results}{Cross-validation results used for computing weights.} +#' @export +#' +#' @examples +#' # Not run ensemble_weights <- function(y, X, Z = NULL, type = "average", learners, diff --git a/R/inference_functions.R b/R/inference_functions.R index 8bfb7cd..559af35 100644 --- a/R/inference_functions.R +++ b/R/inference_functions.R @@ -1,103 +1,60 @@ -# 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 +compute_ddml_variance <- function(scores, J, + cluster_variable = NULL) { + sc <- as.matrix(scores) + J_j <- as.matrix(J) + p <- ncol(sc) -# 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 = FALSE) + # Cluster aggregation: rowsum scores to cluster level + if (!is.null(cluster_variable) && + !identical(seq_len(nrow(sc)), + as.integer(cluster_variable))) { + sc <- rowsum(sc, cluster_variable) + }#IF - # 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 + n_eff <- nrow(sc) + + # HC1 sandwich variance + meat <- crossprod(sc) / n_eff + J_inv <- solve(J_j) + V <- J_inv %*% meat %*% t(J_inv) * + n_eff / (n_eff - p) / n_eff + + V +}#COMPUTE_DDML_VARIANCE + +compute_ddml_inference <- function(coefficients, scores, J, + coef_names = NULL, + ensemble_type, + cluster_variable = NULL) { + nensb <- length(ensemble_type) + p <- NCOL(scores[[1]]) -# 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) + inf_results <- array(0, dim = c(p, 4, nensb)) + + for (j in seq_len(nensb)) { + if (is.matrix(coefficients)) { + theta_j <- coefficients[, j] + } else { + theta_j <- coefficients[j] + }#IFELSE + + V <- compute_ddml_variance(scores[[j]], J[[j]], + cluster_variable) + se <- sqrt(diag(V)) + t_val <- theta_j / se + p_val <- 2 * stats::pnorm(abs(t_val), + lower.tail = FALSE) + + inf_results[, 1, j] <- theta_j + inf_results[, 2, j] <- se + inf_results[, 3, j] <- t_val + inf_results[, 4, j] <- p_val }#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 = FALSE) - # Store results in a matrix - inf_results <- c(coef, std_error, t_values, p_value) - # Return results + dimnames(inf_results) <- list( + coef_names, + c("Estimate", "Std. Error", "t value", "Pr(>|t|)"), + ensemble_type + ) inf_results -}#COMPUTE_INTERACTIVE_INF_RESULTS_BY_ENSEMBLE +}#COMPUTE_DDML_INFERENCE diff --git a/R/methods.R b/R/methods.R new file mode 100644 index 0000000..1a1bc32 --- /dev/null +++ b/R/methods.R @@ -0,0 +1,156 @@ +#' Extract Model Coefficients +#' +#' @param object An object of class \code{ddml}. +#' @param ... Currently unused. +#' +#' @return Named vector (single ensemble) or matrix +#' (multiple ensembles). +#' +#' @export +coef.ddml <- function(object, ...) { + cf <- object$coefficients + if (is.matrix(cf) && ncol(cf) == 1) { + cf <- drop(cf) + }#IF + cf +}#COEF.DDML + +#' Variance-Covariance Matrix for DDML Estimators +#' +#' @param object An object of class \code{ddml}. +#' @param ensemble_idx Integer index of the ensemble type to +#' use. Defaults to 1 (first ensemble type). +#' @param ... Currently unused. +#' +#' @return A p x p variance-covariance matrix. +#' +#' @export +vcov.ddml <- function(object, ensemble_idx = 1, ...) { + V <- compute_ddml_variance( + object$scores[[ensemble_idx]], + object$J[[ensemble_idx]], + object$cluster_variable) + rownames(V) <- colnames(V) <- object$coef_names + V +}#VCOV.DDML + +#' Confidence Intervals for DDML Estimators +#' +#' @param object An object of class \code{ddml}. +#' @param parm Not used (included for generic compatibility). +#' @param level Confidence level. Default 0.95. +#' @param ensemble_idx Integer index of the ensemble type to +#' use. Defaults to 1 (first ensemble type). +#' @param ... Currently unused. +#' +#' @return A matrix with columns for lower and upper bounds. +#' +#' @importFrom stats vcov +#' @export +confint.ddml <- function(object, parm, level = 0.95, + ensemble_idx = 1, ...) { + cf <- object$coefficients + if (is.matrix(cf)) { + cf <- cf[, ensemble_idx] + } else { + cf <- cf[ensemble_idx] + }#IFELSE + + V <- vcov(object, ensemble_idx = ensemble_idx) + se <- sqrt(diag(V)) + z <- stats::qnorm((1 + level) / 2) + 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) <- object$coef_names + ci +}#CONFINT.DDML + +#' Summary for DDML Estimators +#' +#' @param object An object of class \code{ddml}. +#' @param ... Currently unused. +#' +#' @return An object of class \code{summary.ddml}. +#' +#' @export +summary.ddml <- function(object, ...) { + single_learner <- ("what" %in% names(object$learners)) + ens_type <- if (single_learner) { + "single base learner" + } else { + object$ensemble_type + }#IFELSE + + inf <- compute_ddml_inference( + coefficients = object$coefficients, + scores = object$scores, + J = object$J, + coef_names = object$coef_names, + ensemble_type = ens_type, + cluster_variable = object$cluster_variable) + + result <- list( + inf_results = inf, + model_type = class(object)[1], + nobs = object$nobs, + sample_folds = object$sample_folds, + shortstack = object$shortstack, + ensemble_type = ens_type) + class(result) <- c( + paste0("summary.", class(object)[1]), + "summary.ddml") + result +}#SUMMARY.DDML + +#' Print Summary for DDML Estimators +#' +#' @param x An object of class \code{summary.ddml}. +#' @param digits Number of significant digits. Default 3. +#' @param ... Currently unused. +#' +#' @return \code{x}, invisibly. +#' +#' @export +print.summary.ddml <- function(x, digits = 3, ...) { + type_labels <- c( + ddml_plm = "Partially Linear Model", + ddml_pliv = "Partially Linear IV Model", + ddml_fpliv = + "Flexible Partially Linear IV Model", + ddml_ate = "Average Treatment Effect", + ddml_att = + "Average Treatment Effect on the Treated", + ddml_late = "Local Average Treatment Effect") + model_name <- type_labels[x$model_type] + if (is.na(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 + cat("\n\n") + + nensb <- dim(x$inf_results)[3] + for (j in seq_len(nensb)) { + if (nensb > 1) { + cat("Ensemble type:", + dimnames(x$inf_results)[[3]][j], "\n") + }#IF + tbl <- x$inf_results[, , j] + if (!is.matrix(tbl)) { + tbl <- matrix(tbl, nrow = 1, + dimnames = list( + dimnames(x$inf_results)[[1]], + dimnames(x$inf_results)[[2]])) + }#IF + stats::printCoefmat(tbl, digits = digits, + has.Pvalue = TRUE, + signif.stars = TRUE) + if (j < nensb) cat("\n") + }#FOR + + invisible(x) +}#PRINT.SUMMARY.DDML diff --git a/R/ml_wrappers.R b/R/ml_wrappers.R index 8259580..f82499f 100644 --- a/R/ml_wrappers.R +++ b/R/ml_wrappers.R @@ -106,9 +106,13 @@ 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) @@ -216,3 +220,38 @@ 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 + +#' @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/tidy.R b/R/tidy.R new file mode 100644 index 0000000..b106d0c --- /dev/null +++ b/R/tidy.R @@ -0,0 +1,63 @@ +#' @importFrom generics tidy +#' @export +generics::tidy + +#' @importFrom generics glance +#' @export +generics::glance + +#' Tidy a ddml object +#' +#' @param x A `ddml` object. +#' @param conf.int Logical indicating whether or not to include a confidence interval. +#' @param conf.level The confidence level to use. +#' @param ... Additional arguments passed to summary method. +#' +#' @return A data.frame containing tidy coefficients per ensemble type. +#' @export +tidy.ddml <- function(x, conf.int = FALSE, conf.level = 0.95, ...) { + s <- summary(x) + inf <- s$inf_results + nensb <- dim(inf)[3] + p <- dim(inf)[1] + + rows <- list() + for (j in seq_len(nensb)) { + 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], + ensemble_type = dimnames(inf)[[3]][j], + stringsAsFactors = FALSE + ) + if (conf.int) { + z <- stats::qnorm((1 + conf.level) / 2) + row$conf.low <- inf[k, 1, j] - z * inf[k, 2, j] + row$conf.high <- inf[k, 1, j] + z * inf[k, 2, j] + }#IF + rows[[length(rows) + 1]] <- row + }#FOR + }#FOR + do.call(rbind, rows) +}#TIDY.DDML + +#' Glance at a ddml object +#' +#' @param x A `ddml` object. +#' @param ... Additional arguments. +#' +#' @return A one-row data.frame with model metadata. +#' @export +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], + stringsAsFactors = FALSE + ) +}#GLANCE.DDML diff --git a/R/zzz.R b/R/zzz.R new file mode 100644 index 0000000..1b6e475 --- /dev/null +++ b/R/zzz.R @@ -0,0 +1,36 @@ +.onLoad <- function(libname, pkgname) { + if (requireNamespace("texreg", quietly = TRUE)) { + for (cls in c("ddml_plm", "ddml_pliv", "ddml_fpliv", + "ddml_ate", "ddml_att", "ddml_late")) { + methods::setMethod("extract", signature = cls, + definition = extract_ddml, + where = asNamespace(pkgname)) + }#FOR + }#IF +}#.ONLOAD + +# Internal extract function (works for all ddml classes) +extract_ddml <- function(model, ...) { + s <- summary(model) + inf <- s$inf_results + + # Use first ensemble type for texreg + coef_names <- dimnames(inf)[[1]] + co <- inf[, 1, 1] + se <- inf[, 2, 1] + pval <- inf[, 4, 1] + + gof <- c(s$nobs, s$sample_folds) + gof.names <- c("Num. obs.", "Crossfit folds") + gof.decimal <- c(FALSE, FALSE) + + texreg::createTexreg( + coef.names = coef_names, + coef = co, + se = se, + pvalues = pval, + gof.names = gof.names, + gof = gof, + gof.decimal = gof.decimal + ) +}#EXTRACT_DDML diff --git a/man/coef.ddml.Rd b/man/coef.ddml.Rd new file mode 100644 index 0000000..1b27880 --- /dev/null +++ b/man/coef.ddml.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods.R +\name{coef.ddml} +\alias{coef.ddml} +\title{Extract Model Coefficients} +\usage{ +\method{coef}{ddml}(object, ...) +} +\arguments{ +\item{object}{An object of class \code{ddml}.} + +\item{...}{Currently unused.} +} +\value{ +Named vector (single ensemble) or matrix +(multiple ensembles). +} +\description{ +Extract Model Coefficients +} diff --git a/man/confint.ddml.Rd b/man/confint.ddml.Rd new file mode 100644 index 0000000..2d809b8 --- /dev/null +++ b/man/confint.ddml.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods.R +\name{confint.ddml} +\alias{confint.ddml} +\title{Confidence Intervals for DDML Estimators} +\usage{ +\method{confint}{ddml}(object, parm, level = 0.95, ensemble_idx = 1, ...) +} +\arguments{ +\item{object}{An object of class \code{ddml}.} + +\item{parm}{Not used (included for generic compatibility).} + +\item{level}{Confidence level. Default 0.95.} + +\item{ensemble_idx}{Integer index of the ensemble type to +use. Defaults to 1 (first ensemble type).} + +\item{...}{Currently unused.} +} +\value{ +A matrix with columns for lower and upper bounds. +} +\description{ +Confidence Intervals for DDML Estimators +} diff --git a/man/crosspred.Rd b/man/crosspred.Rd index 9909e35..458a575 100644 --- a/man/crosspred.Rd +++ b/man/crosspred.Rd @@ -181,6 +181,8 @@ Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. \seealso{ Other utilities: \code{\link{crossval}()}, +\code{\link{ensemble}()}, +\code{\link{ensemble_weights}()}, \code{\link{shortstacking}()} } \concept{utilities} diff --git a/man/crossval.Rd b/man/crossval.Rd index 2a36602..8419947 100644 --- a/man/crossval.Rd +++ b/man/crossval.Rd @@ -98,6 +98,8 @@ cv_res$mspe \seealso{ Other utilities: \code{\link{crosspred}()}, +\code{\link{ensemble}()}, +\code{\link{ensemble_weights}()}, \code{\link{shortstacking}()} } \concept{utilities} diff --git a/man/ddml_ate.Rd b/man/ddml_ate.Rd index d7dbe91..ff651b2 100644 --- a/man/ddml_ate.Rd +++ b/man/ddml_ate.Rd @@ -169,8 +169,7 @@ ensemble procedure.} 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()}}.} +of scores. Used in \code{\link[=summary.ddml]{summary.ddml()}}.} \item{\code{oos_pred}}{List of matrices, providing the reduced form predicted values.} \item{\code{learners},\code{learners_DX},\code{cluster_variable}, @@ -243,7 +242,7 @@ 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()}} +\code{\link[=summary.ddml]{summary.ddml()}} Other ddml: \code{\link{ddml_fpliv}()}, diff --git a/man/ddml_fpliv.Rd b/man/ddml_fpliv.Rd index 9b622fa..73684ac 100644 --- a/man/ddml_fpliv.Rd +++ b/man/ddml_fpliv.Rd @@ -192,7 +192,7 @@ 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()}} +\code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[AER:ivreg]{AER::ivreg()}} Other ddml: \code{\link{ddml_ate}()}, diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index 1bffd50..2e4f2b5 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -156,7 +156,7 @@ ensemble procedure.} 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()}}.} +of scores. Used in \code{\link[=summary.ddml]{summary.ddml()}}.} \item{\code{oos_pred}}{List of matrices, providing the reduced form predicted values.} \item{\code{learners},\code{learners_DXZ},\code{learners_ZX}, @@ -235,7 +235,7 @@ 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()}} +\code{\link[=summary.ddml]{summary.ddml()}} Other ddml: \code{\link{ddml_ate}()}, diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index ab68425..fb2b7c9 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -191,7 +191,7 @@ 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()}} +\code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[AER:ivreg]{AER::ivreg()}} Other ddml: \code{\link{ddml_ate}()}, diff --git a/man/ddml_plm.Rd b/man/ddml_plm.Rd index e0a696b..dc7c563 100644 --- a/man/ddml_plm.Rd +++ b/man/ddml_plm.Rd @@ -191,7 +191,7 @@ 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_plm]{summary.ddml_plm()}} +\code{\link[=summary.ddml]{summary.ddml()}} Other ddml: \code{\link{ddml_ate}()}, diff --git a/man/ensemble.Rd b/man/ensemble.Rd new file mode 100644 index 0000000..6e90518 --- /dev/null +++ b/man/ensemble.Rd @@ -0,0 +1,66 @@ +% 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, + Z = NULL, + 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{Z}{Optional instrumental variables matrix.} + +\item{type}{A character string indicating the type of ensemble to compute. +Default is \code{"average"}.} + +\item{learners}{A list of base learners.} + +\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: +\item{mdl_fits}{List of fitted base learners.} +\item{weights}{Computed ensemble weights.} +\item{learners}{The base learners used.} +\item{cv_results}{Cross-validation results if computed.} +\item{mean_y}{Mean of the outcome variable.} +\item{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{ +# Not run +} +\seealso{ +Other utilities: +\code{\link{crosspred}()}, +\code{\link{crossval}()}, +\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..7ae4530 --- /dev/null +++ b/man/ensemble_weights.Rd @@ -0,0 +1,61 @@ +% 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, + Z = NULL, + 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{Z}{Optional instrumental variables matrix.} + +\item{type}{A character string or vector indicating the type(s) of ensemble +weights to compute. Default is \code{"average"}.} + +\item{learners}{A list of base learners.} + +\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: +\item{weights}{A matrix of computed ensemble weights.} +\item{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{ +# Not run +} +\seealso{ +Other utilities: +\code{\link{crosspred}()}, +\code{\link{crossval}()}, +\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..040977f --- /dev/null +++ b/man/glance.ddml.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tidy.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{...}{Additional arguments.} +} +\value{ +A one-row data.frame with model metadata. +} +\description{ +Glance at a ddml object +} diff --git a/man/mdl_bigGLM.Rd b/man/mdl_bigGLM.Rd new file mode 100644 index 0000000..8e776bc --- /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 \code{\link[glmnet:bigGlm]{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..6c532ac 100644 --- a/man/mdl_glm.Rd +++ b/man/mdl_glm.Rd @@ -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..e0e0648 100644 --- a/man/mdl_glmnet.Rd +++ b/man/mdl_glmnet.Rd @@ -42,6 +42,7 @@ Statistical Software, 39(5), 1–13. \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..d46972f 100644 --- a/man/mdl_ranger.Rd +++ b/man/mdl_ranger.Rd @@ -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..0943e25 100644 --- a/man/mdl_xgboost.Rd +++ b/man/mdl_xgboost.Rd @@ -44,6 +44,7 @@ Discovery and Data Mining, 785–794. \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/ols.Rd b/man/ols.Rd index b34aaba..2a3d3b2 100644 --- a/man/ols.Rd +++ b/man/ols.Rd @@ -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/print.summary.ddml.Rd b/man/print.summary.ddml.Rd new file mode 100644 index 0000000..4b739d1 --- /dev/null +++ b/man/print.summary.ddml.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods.R +\name{print.summary.ddml} +\alias{print.summary.ddml} +\title{Print Summary for DDML Estimators} +\usage{ +\method{print}{summary.ddml}(x, digits = 3, ...) +} +\arguments{ +\item{x}{An object of class \code{summary.ddml}.} + +\item{digits}{Number of significant digits. Default 3.} + +\item{...}{Currently unused.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Print Summary for DDML Estimators +} 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 9429e2a..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 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 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/reexports.Rd b/man/reexports.Rd new file mode 100644 index 0000000..c7fc9ed --- /dev/null +++ b/man/reexports.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tidy.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 34d89de..6d551e2 100644 --- a/man/shortstacking.Rd +++ b/man/shortstacking.Rd @@ -167,6 +167,8 @@ 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{ensemble}()}, +\code{\link{ensemble_weights}()} } \concept{utilities} diff --git a/man/summary.ddml.Rd b/man/summary.ddml.Rd new file mode 100644 index 0000000..a54db6e --- /dev/null +++ b/man/summary.ddml.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods.R +\name{summary.ddml} +\alias{summary.ddml} +\title{Summary for DDML Estimators} +\usage{ +\method{summary}{ddml}(object, ...) +} +\arguments{ +\item{object}{An object of class \code{ddml}.} + +\item{...}{Currently unused.} +} +\value{ +An object of class \code{summary.ddml}. +} +\description{ +Summary for DDML Estimators +} 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/tidy.ddml.Rd b/man/tidy.ddml.Rd new file mode 100644 index 0000000..f58f3d6 --- /dev/null +++ b/man/tidy.ddml.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tidy.R +\name{tidy.ddml} +\alias{tidy.ddml} +\title{Tidy a ddml object} +\usage{ +\method{tidy}{ddml}(x, conf.int = FALSE, conf.level = 0.95, ...) +} +\arguments{ +\item{x}{A \code{ddml} object.} + +\item{conf.int}{Logical indicating whether or not to include a confidence interval.} + +\item{conf.level}{The confidence level to use.} + +\item{...}{Additional arguments passed to summary method.} +} +\value{ +A data.frame containing tidy coefficients per ensemble type. +} +\description{ +Tidy a ddml object +} diff --git a/man/vcov.ddml.Rd b/man/vcov.ddml.Rd new file mode 100644 index 0000000..117e570 --- /dev/null +++ b/man/vcov.ddml.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods.R +\name{vcov.ddml} +\alias{vcov.ddml} +\title{Variance-Covariance Matrix for DDML Estimators} +\usage{ +\method{vcov}{ddml}(object, ensemble_idx = 1, ...) +} +\arguments{ +\item{object}{An object of class \code{ddml}.} + +\item{ensemble_idx}{Integer index of the ensemble type to +use. Defaults to 1 (first ensemble type).} + +\item{...}{Currently unused.} +} +\value{ +A p x p variance-covariance matrix. +} +\description{ +Variance-Covariance Matrix for DDML Estimators +} diff --git a/tests/testthat/test-ddml_ate.R b/tests/testthat/test-ddml_ate.R index 2f6485e..51cea0d 100644 --- a/tests/testthat/test-ddml_ate.R +++ b/tests/testthat/test-ddml_ate.R @@ -157,7 +157,8 @@ test_that("summary.ddml_ate computes with a single model", { 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$inf_results), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_ate computes with a single model and dependence", { @@ -186,7 +187,8 @@ test_that("summary.ddml_ate computes with a single model and dependence", { 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$inf_results), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_ate computes with multiple ensemble procedures", { @@ -212,5 +214,6 @@ test_that("summary.ddml_ate computes with multiple ensemble procedures", { 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$inf_results), c(1, 4, 4)) })#TEST_THAT diff --git a/tests/testthat/test-ddml_att.R b/tests/testthat/test-ddml_att.R index 8beb0aa..e5c8e5c 100644 --- a/tests/testthat/test-ddml_att.R +++ b/tests/testthat/test-ddml_att.R @@ -158,7 +158,8 @@ test_that("summary.ddml_att computes with a single model", { 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$inf_results), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_att computes with a single model and dependence", { @@ -187,7 +188,8 @@ test_that("summary.ddml_att computes with a single model and dependence", { 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$inf_results), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_att computes with multiple ensemble procedures", { @@ -213,5 +215,6 @@ test_that("summary.ddml_att computes with multiple ensemble procedures", { 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$inf_results), c(1, 4, 4)) })#TEST_THAT diff --git a/tests/testthat/test-ddml_fpliv.R b/tests/testthat/test-ddml_fpliv.R index eaa14e5..8a09375 100644 --- a/tests/testthat/test-ddml_fpliv.R +++ b/tests/testthat/test-ddml_fpliv.R @@ -277,10 +277,11 @@ test_that("summary.ddml_fpliv computes with a single model", { learners, sample_folds = 3, silent = T) - inf_res <- summary(ddml_fpliv_fit, type = "HC1") + 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$inf_results), c(1, 4, 1)) })#TEST_THAT test_that("ddml_fpliv computes with an ensemble procedure, multi D", { diff --git a/tests/testthat/test-ddml_late.R b/tests/testthat/test-ddml_late.R index 7939166..ab5ad34 100644 --- a/tests/testthat/test-ddml_late.R +++ b/tests/testthat/test-ddml_late.R @@ -226,7 +226,8 @@ test_that("summary.ddml_late computes with a single model", { 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$inf_results), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_late computes with a single model and dependence", { @@ -257,5 +258,6 @@ test_that("summary.ddml_late computes with a single model and dependence", { 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$inf_results), c(1, 4, 1)) })#TEST_THAT diff --git a/tests/testthat/test-ddml_plm.R b/tests/testthat/test-ddml_plm.R index aa841ca..59fd32f 100644 --- a/tests/testthat/test-ddml_plm.R +++ b/tests/testthat/test-ddml_plm.R @@ -192,10 +192,11 @@ test_that("summary.ddml_plm computes with a single model", { cv_folds = 3, sample_folds = 3, silent = T) - inf_res <- summary(ddml_plm_fit, type = "HC1") + 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$inf_results), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_plm computes with a single model and dependence", { @@ -218,7 +219,8 @@ test_that("summary.ddml_plm computes with a single model and dependence", { 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$inf_results), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_plm computes with multiple ensemble procedures", { @@ -242,10 +244,11 @@ test_that("summary.ddml_plm computes with multiple ensemble procedures", { custom_ensemble_weights = diag(1, length(learners)), sample_folds = 3, silent = T) - inf_res <- summary(ddml_plm_fit, type = "HC1") + 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$inf_results), c(1, 4, 7)) })#TEST_THAT test_that("ddml_plm computes with an ensemble procedure and multivariate D", { From a029e7fd61c1ee64b4686c8fcbd010deb27a70db Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Tue, 24 Feb 2026 09:09:09 -0600 Subject: [PATCH 05/46] remove texreg, update tidy tests --- DESCRIPTION | 3 +- R/tidy.R | 55 ++++++++++++++++++----- R/zzz.R | 36 --------------- tests/testthat/test-inference_functions.R | 40 +++++++++++++++++ tests/testthat/test-methods.R | 45 +++++++++++++++++++ tests/testthat/test-parallel.R | 20 +++++++++ tests/testthat/test-tidy.R | 44 ++++++++++++++++++ 7 files changed, 193 insertions(+), 50 deletions(-) delete mode 100644 R/zzz.R create mode 100644 tests/testthat/test-inference_functions.R create mode 100644 tests/testthat/test-methods.R create mode 100644 tests/testthat/test-parallel.R create mode 100644 tests/testthat/test-tidy.R diff --git a/DESCRIPTION b/DESCRIPTION index 3ba3287..3336eea 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -41,7 +41,6 @@ Suggests: parallel, rmarkdown, sandwich, - testthat (>= 3.0.0), - texreg + testthat (>= 3.0.0) Config/testthat/edition: 3 VignetteBuilder: knitr diff --git a/R/tidy.R b/R/tidy.R index b106d0c..eb2b5c1 100644 --- a/R/tidy.R +++ b/R/tidy.R @@ -6,23 +6,46 @@ generics::tidy #' @export generics::glance -#' Tidy a ddml object +#' Tidy a ddml Object #' -#' @param x A `ddml` object. -#' @param conf.int Logical indicating whether or not to include a confidence interval. -#' @param conf.level The confidence level to use. -#' @param ... Additional arguments passed to summary method. +#' Extracts coefficient estimates, standard errors, test +#' statistics, and p-values from a \code{ddml} estimator in a +#' format compatible with \pkg{modelsummary} and the +#' \pkg{broom} ecosystem. #' -#' @return A data.frame containing tidy coefficients per ensemble type. +#' @param x A \code{ddml} object. +#' @param ensemble_idx Integer index of the ensemble type to +#' report. Defaults to 1 (first ensemble type). Set to +#' \code{NULL} to return results for all ensemble types. +#' @param conf.int Logical. Include confidence interval +#' columns? Default \code{FALSE}. +#' @param conf.level Confidence level for intervals. +#' Default 0.95. +#' @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}. If +#' \code{conf.int = TRUE}, also \code{conf.low} and +#' \code{conf.high}. +#' +#' @family ddml #' @export -tidy.ddml <- function(x, conf.int = FALSE, conf.level = 0.95, ...) { +tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, + conf.level = 0.95, ...) { s <- summary(x) inf <- s$inf_results nensb <- dim(inf)[3] p <- dim(inf)[1] + if (is.null(ensemble_idx)) { + j_seq <- seq_len(nensb) + } else { + j_seq <- ensemble_idx + }#IFELSE + rows <- list() - for (j in seq_len(nensb)) { + for (j in j_seq) { for (k in seq_len(p)) { row <- data.frame( term = dimnames(inf)[[1]][k], @@ -44,12 +67,20 @@ tidy.ddml <- function(x, conf.int = FALSE, conf.level = 0.95, ...) { do.call(rbind, rows) }#TIDY.DDML -#' Glance at a ddml object +#' Glance at a ddml Object +#' +#' Returns a one-row summary of model-level statistics, +#' compatible with \pkg{modelsummary} and the \pkg{broom} +#' ecosystem. +#' +#' @param x A \code{ddml} object. +#' @param ... Currently unused. #' -#' @param x A `ddml` object. -#' @param ... Additional arguments. +#' @return A one-row \code{data.frame} with columns +#' \code{nobs}, \code{sample_folds}, \code{shortstack}, +#' \code{ensemble_type}, and \code{model_type}. #' -#' @return A one-row data.frame with model metadata. +#' @family ddml #' @export glance.ddml <- function(x, ...) { data.frame( diff --git a/R/zzz.R b/R/zzz.R deleted file mode 100644 index 1b6e475..0000000 --- a/R/zzz.R +++ /dev/null @@ -1,36 +0,0 @@ -.onLoad <- function(libname, pkgname) { - if (requireNamespace("texreg", quietly = TRUE)) { - for (cls in c("ddml_plm", "ddml_pliv", "ddml_fpliv", - "ddml_ate", "ddml_att", "ddml_late")) { - methods::setMethod("extract", signature = cls, - definition = extract_ddml, - where = asNamespace(pkgname)) - }#FOR - }#IF -}#.ONLOAD - -# Internal extract function (works for all ddml classes) -extract_ddml <- function(model, ...) { - s <- summary(model) - inf <- s$inf_results - - # Use first ensemble type for texreg - coef_names <- dimnames(inf)[[1]] - co <- inf[, 1, 1] - se <- inf[, 2, 1] - pval <- inf[, 4, 1] - - gof <- c(s$nobs, s$sample_folds) - gof.names <- c("Num. obs.", "Crossfit folds") - gof.decimal <- c(FALSE, FALSE) - - texreg::createTexreg( - coef.names = coef_names, - coef = co, - se = se, - pvalues = pval, - gof.names = gof.names, - gof = gof, - gof.decimal = gof.decimal - ) -}#EXTRACT_DDML diff --git a/tests/testthat/test-inference_functions.R b/tests/testthat/test-inference_functions.R new file mode 100644 index 0000000..a5f958c --- /dev/null +++ b/tests/testthat/test-inference_functions.R @@ -0,0 +1,40 @@ +test_that("compute_ddml_variance computes HC1 sandwich variance correctly", { + # Mock data + set.seed(42) + nobs <- 100 + p <- 2 + scores <- matrix(rnorm(nobs * p), nobs, p) + J <- diag(2, p) # Simple J matrix + + # Manual computation matching HC1 specification + meat <- crossprod(scores) / nobs + J_inv <- solve(J) + expected_v <- J_inv %*% meat %*% t(J_inv) * nobs / (nobs - p) / nobs + + # Test function output + V <- compute_ddml_variance(scores, J) + + expect_true(is.matrix(V)) + expect_equal(dim(V), c(p, p)) + expect_equal(V, expected_v) +}) + +test_that("compute_ddml_variance handles cluster aggregation correctly", { + set.seed(42) + nobs <- 100 + p <- 2 + scores <- matrix(rnorm(nobs * p), nobs, p) + J <- diag(2, p) + cluster_var <- rep(1:50, each = 2) # 50 clusters + + # By clustering, the scores should be rowsummed to n_eff = 50 + V_clustered <- compute_ddml_variance(scores, J, cluster_variable = cluster_var) + + sc_sum <- rowsum(scores, cluster_var) + n_eff <- 50 + meat <- crossprod(sc_sum) / n_eff + J_inv <- solve(J) + expected_v <- J_inv %*% meat %*% t(J_inv) * n_eff / (n_eff - p) / n_eff + + expect_equal(V_clustered, expected_v) +}) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R new file mode 100644 index 0000000..7f4e3ed --- /dev/null +++ b/tests/testthat/test-methods.R @@ -0,0 +1,45 @@ +test_that("standard S3 generic methods work correctly", { + # Generate a minimal fitted object to test the plumbing + set.seed(42) + nobs <- 100 + X <- cbind(1, matrix(rnorm(nobs * 4), nobs, 4)) + D_tld <- X %*% runif(5) + rnorm(nobs) + D <- 1 * (D_tld > mean(D_tld)) + y <- D + X %*% runif(5) + rnorm(nobs) + + learners <- list(list(fun = ols), list(fun = ols)) + suppressWarnings({ + 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, ensemble_idx = 2) + expect_true(is.matrix(V)) + expect_equal(dim(V), c(1, 1)) + + # confint + ci <- confint(fit, ensemble_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) + + # print.summary + out <- capture_output(print(s)) + expect_true(grepl("DDML estimation", out)) + expect_true(grepl("Average Treatment Effect", out)) +}) 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-tidy.R b/tests/testthat/test-tidy.R new file mode 100644 index 0000000..60f6688 --- /dev/null +++ b/tests/testthat/test-tidy.R @@ -0,0 +1,44 @@ +test_that("tidy and glance broom formatters work correctly", { + # Generate a minimal fitted object to test the plumbing + set.seed(42) + nobs <- 100 + X <- cbind(1, matrix(rnorm(nobs * 4), nobs, 4)) + D_tld <- X %*% runif(5) + rnorm(nobs) + D <- 1 * (D_tld > mean(D_tld)) + y <- D + X %*% runif(5) + rnorm(nobs) + + learners <- list(list(fun = ols), list(fun = ols)) + suppressWarnings({ + 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))) +}) From b8b4d17932acc12ea49fae1c3614f9c4b3ab7ae2 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Tue, 24 Feb 2026 15:04:10 -0600 Subject: [PATCH 06/46] validate inputs, closing #8 --- R/crossval.R | 3 +- R/ddml_ate.R | 47 +++++-- R/ddml_att.R | 46 ++++-- R/ddml_fpliv.R | 84 +++++------ R/ddml_late.R | 60 +++++--- R/ddml_pliv.R | 78 +++++------ R/ddml_plm.R | 49 +++---- R/ensemble.R | 8 +- R/get_CEF.R | 6 +- R/help_functions.R | 140 +++++++++++++++++++ R/inference_functions.R | 33 +++-- R/methods.R | 35 ++++- R/shortstacking.R | 8 +- R/tidy.R | 12 +- man/confint.ddml.Rd | 6 +- man/ddml_ate.Rd | 4 +- man/ddml_fpliv.Rd | 4 +- man/ddml_late.Rd | 4 +- man/ddml_pliv.Rd | 4 +- man/ddml_plm.Rd | 4 +- man/glance.ddml.Rd | 22 ++- man/summary.ddml.Rd | 8 +- man/tidy.ddml.Rd | 48 ++++++- man/vcov.ddml.Rd | 8 +- tests/testthat/test-inference_functions.R | 163 ++++++++++++++++++++-- tests/testthat/test-methods.R | 90 +++++++++++- vignettes/articles/example_401k.Rmd.txt | 18 +-- vignettes/articles/example_BLP95.Rmd.txt | 20 +-- vignettes/articles/new_ml_wrapper.Rmd.txt | 28 ++-- vignettes/articles/sparse.Rmd.txt | 18 +-- vignettes/precompile.R | 100 ++++++++++--- 31 files changed, 863 insertions(+), 295 deletions(-) diff --git a/R/crossval.R b/R/crossval.R index eaea90c..12419d0 100644 --- a/R/crossval.R +++ b/R/crossval.R @@ -173,6 +173,7 @@ crossval_compute <- function(test_sample, learner, drop = FALSE], Z[test_sample, assign_Z, drop = FALSE])) - oos_resid <- y[test_sample] - methods::as(oos_fitted, "matrix") + if (!is.matrix(oos_fitted)) oos_fitted <- as.matrix(oos_fitted) + oos_resid <- y[test_sample] - oos_fitted return(oos_resid) }#CROSSVAL_COMPUTE diff --git a/R/ddml_ate.R b/R/ddml_ate.R index bccbeea..f3c08be 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -132,6 +132,14 @@ ddml_ate <- function(y, D, X, trim = 0.01, silent = FALSE, parallel = NULL) { + # Validate inputs + validate_inputs(y = y, D = D, X = X, learners = learners, + sample_folds = sample_folds, cv_folds = cv_folds, + ensemble_type = ensemble_type, trim = trim, + require_binary_D = TRUE) + validate_custom_weights(custom_ensemble_weights, learners) + validate_custom_weights(custom_ensemble_weights_DX, learners_DX) + # Data parameters nobs <- length(y) is_D0 <- which(D == 0) @@ -197,11 +205,10 @@ ddml_ate <- function(y, D, X, parallel = parallel) # 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 + ensb_info <- update_ensemble_info(y_X_D0_res$weights) + ensemble_type <- ensb_info$ensemble_type + nensb <- ensb_info$nensb + multiple_ensembles <- ensb_info$multiple_ensembles # Construct reduced form variables g_X_byD <- extrapolate_CEF(D = D, @@ -214,16 +221,26 @@ ddml_ate <- function(y, D, X, m_X_tr <- trim_propensity_scores(m_X, trim, ensemble_type) # 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 - - # Also set psi_a scores for easier computation of summary.ddml - psi_a <- matrix(-1, nobs, nensb) + if (!multiple_ensembles) { + g0 <- g_X_byD[, , 1] + g1 <- g_X_byD[, , 2] + m <- as.vector(m_X_tr) + psi_b <- matrix( + D * (y - g1) / m - (1 - D) * (y - g0) / (1 - m) + g1 - g0, + nobs, 1) + ate <- mean(psi_b) + names(ate) <- ensemble_type + psi_a <- matrix(-1, nobs, 1) + } else { + 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 + psi_a <- matrix(-1, nobs, nensb) + }#IFELSE # Compute scores and Jacobian from psi_a/psi_b scores <- lapply(seq_len(nensb), function(j) { diff --git a/R/ddml_att.R b/R/ddml_att.R index 277ab29..7c0eaa4 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -19,6 +19,14 @@ ddml_att <- function(y, D, X, trim = 0.01, silent = FALSE, parallel = NULL) { + # Validate inputs + validate_inputs(y = y, D = D, X = X, learners = learners, + sample_folds = sample_folds, cv_folds = cv_folds, + ensemble_type = ensemble_type, trim = trim, + require_binary_D = TRUE) + validate_custom_weights(custom_ensemble_weights, learners) + validate_custom_weights(custom_ensemble_weights_DX, learners_DX) + # Data parameters nobs <- length(y) is_D0 <- which(D == 0) @@ -84,11 +92,10 @@ ddml_att <- function(y, D, X, parallel = parallel) # 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 + ensb_info <- update_ensemble_info(y_X_D0_res$weights) + ensemble_type <- ensb_info$ensemble_type + nensb <- ensb_info$nensb + multiple_ensembles <- ensb_info$multiple_ensembles # Construct reduced form variables g_X_D0<- extrapolate_CEF(D = D, @@ -100,14 +107,27 @@ ddml_att <- function(y, D, X, 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 + if (!multiple_ensembles) { + p <- as.vector(D_res$oos_fitted) + g0 <- as.vector(g_X_D0) + m <- as.vector(m_X_tr) + psi_b <- matrix( + D * (y - g0) / p - m * (1 - D) * (y - g0) / (p * (1 - m)), + nobs, 1) + psi_a <- matrix(-D / p, nobs, 1) + att <- -mean(psi_b) / mean(psi_a) + names(att) <- ensemble_type + } else { + 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 + }#IFELSE # Compute scores and Jacobian from psi_a/psi_b scores <- lapply(seq_len(nensb), function(j) { diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index 38de8cc..8a58d40 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -95,6 +95,14 @@ ddml_fpliv <- function(y, D, Z, X, cv_subsamples_list = NULL, silent = FALSE, parallel = NULL) { + # Validate inputs + validate_inputs(y = y, D = D, X = X, Z = Z, learners = learners, + sample_folds = sample_folds, cv_folds = cv_folds, + ensemble_type = ensemble_type) + 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) + # Backward compatibility for renamed parameter if (!is.null(cv_subsamples_list)) { if (!is.null(cv_subsamples)) @@ -148,54 +156,38 @@ ddml_fpliv <- function(y, D, Z, X, # 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 seq_len(nD)) { - D_XZ_res_list[[k]] <- get_CEF(D[, k, drop = FALSE], X, Z, - learners = learners_DXZ, - ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = - custom_ensemble_weights_DXZ, - subsamples = indxs$subsamples, - cv_subsamples = - indxs$cv_subsamples, - compute_insample_predictions = - enforce_LIE, - silent = silent, - label = paste0("E[D", k, - "|X,Z]"), - parallel = parallel) - }#FOR + D_XZ_res_list <- compute_CEF_list( + D, X, Z = Z, learners = learners_DXZ, + ensemble_type = ensemble_type, + shortstack = shortstack, + custom_ensemble_weights = custom_ensemble_weights_DXZ, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, + compute_insample_predictions = enforce_LIE, + silent = silent, + label_prefix = "E[D", label_suffix = "|X,Z]", + parallel = parallel) # When the LIE is not enforced, estimating E[D|X] is straightforward. if (!enforce_LIE) { - D_X_res_list <- list() - for (k in seq_len(nD)) { - D_X_res_list[[k]] <- get_CEF(D[, k, drop = FALSE], X, - Z = NULL, - learners = learners_DX, - ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = - custom_ensemble_weights_DX, - subsamples = indxs$subsamples, - cv_subsamples = - indxs$cv_subsamples, - compute_insample_predictions = - FALSE, - silent = silent, - label = paste0("E[D", k, - "|X]"), - parallel = parallel) - }#FOR + D_X_res_list <- compute_CEF_list( + D, X, Z = NULL, learners = learners_DX, + ensemble_type = ensemble_type, + shortstack = shortstack, + custom_ensemble_weights = custom_ensemble_weights_DX, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, + compute_insample_predictions = FALSE, + silent = silent, + label_prefix = "E[D", label_suffix = "|X]", + parallel = parallel) }#IF # 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 + ensb_info <- update_ensemble_info(y_X_res$weights) + ensemble_type <- ensb_info$ensemble_type + nensb <- ensb_info$nensb + multiple_ensembles <- ensb_info$multiple_ensembles # If a single ensemble is calculated, no loops are required. if (!multiple_ensembles) { @@ -262,7 +254,7 @@ ddml_fpliv <- function(y, D, Z, X, }#IF # Compute coefficients for each ensemble - for (j in 1:nensb) { + for (j in seq_len(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) { @@ -339,7 +331,7 @@ ddml_fpliv <- function(y, D, Z, X, J_list[[j]] <- -crossprod(D_hat, D_r_mat) / nobs if (enforce_LIE) { - for (k in 1:nD) weights_DX[[k]][, j, ] <- D_X_res_list[[k]]$weights + for (k in seq_len(nD)) weights_DX[[k]][, j, ] <- D_X_res_list[[k]]$weights }#IF }#FOR rownames(coef) <- names(iv_fit[[1]]$coefficients)[-1] @@ -349,7 +341,7 @@ ddml_fpliv <- function(y, D, Z, X, # Store complementary ensemble output weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) - for (k in 1:nD){ + for (k in seq_len(nD)){ if (enforce_LIE & multiple_ensembles) { weights[[paste0("D", k, "_X")]] <- weights_DX[[k]] } else { @@ -357,7 +349,7 @@ ddml_fpliv <- function(y, D, Z, X, }#IFELSE #mspe[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$mspe }#FOR - for (k in 1:nD){ + for (k in seq_len(nD)){ weights[[paste0("D", k, "_XZ")]] <- D_XZ_res_list[[k]]$weights mspe[[paste0("D", k, "_XZ")]] <- D_XZ_res_list[[k]]$mspe }#FOR diff --git a/R/ddml_late.R b/R/ddml_late.R index 4319748..62e32a5 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -161,6 +161,15 @@ ddml_late <- function(y, D, Z, X, trim = 0.01, silent = FALSE, parallel = NULL) { + # Validate inputs + 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, + 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) + # Data parameters nobs <- length(y) is_Z0 <- which(Z == 0) @@ -271,11 +280,10 @@ ddml_late <- function(y, D, Z, X, parallel = parallel) # 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)) - - # Check whether multiple ensembles are computed simultaneously - multiple_ensembles <- nensb > 1 + ensb_info <- update_ensemble_info(y_X_Z0_res$weights) + ensemble_type <- ensb_info$ensemble_type + nensb <- ensb_info$nensb + multiple_ensembles <- ensb_info$multiple_ensembles # Construct reduced form variables l_X_byZ <- extrapolate_CEF(D = Z, @@ -291,20 +299,34 @@ ddml_late <- function(y, D, Z, X, # Trim propensity scores, return warnings r_X_tr <- trim_propensity_scores(r_X, trim, ensemble_type) - # 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 + # Compute the LATE using the constructed variables + if (!multiple_ensembles) { + l0 <- l_X_byZ[, , 1] + l1 <- l_X_byZ[, , 2] + p0 <- p_X_byZ[, , 1] + p1 <- p_X_byZ[, , 2] + r <- as.vector(r_X_tr) + psi_b <- matrix( + Z * (y - l1) / r - (1 - Z) * (y - l0) / (1 - r) + l1 - l0, + nobs, 1) + psi_a <- matrix( + -(Z * (D - p1) / r - (1 - Z) * (D - p0) / (1 - r) + p1 - p0), + nobs, 1) + late <- -mean(psi_b) / mean(psi_a) + names(late) <- ensemble_type + } else { + 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]) + late <- -colMeans(psi_b) / colMeans(psi_a) + names(late) <- ensemble_type + }#IFELSE # Compute scores and Jacobian from psi_a/psi_b scores <- lapply(seq_len(nensb), function(j) { diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index 3ba6797..dd4bb39 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -123,6 +123,14 @@ ddml_pliv <- function(y, D, Z, X, cv_subsamples_list = NULL, silent = FALSE, parallel = NULL) { + # Validate inputs + validate_inputs(y = y, D = D, X = X, Z = Z, learners = learners, + sample_folds = sample_folds, cv_folds = cv_folds, + ensemble_type = ensemble_type) + 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) + # Backward compatibility for renamed parameter if (!is.null(cv_subsamples_list)) { if (!is.null(cv_subsamples)) @@ -133,9 +141,6 @@ ddml_pliv <- function(y, D, Z, X, # Data parameters nobs <- length(y) - nlearners <- length(learners) - ncustom <- ncol(custom_ensemble_weights) - ncustom <- ifelse(is.null(ncustom), 0, ncustom) # Check for multivariate endogenous variables D <- as.matrix(D) @@ -180,47 +185,34 @@ ddml_pliv <- function(y, D, Z, X, parallel = parallel) # Compute estimates of E[Z|X], loop through instruments - Z_X_res_list <- list() - 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) - }#FOR + Z_X_res_list <- compute_CEF_list( + Z, 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_prefix = "E[Z", label_suffix = "|X]", + parallel = parallel) # Compute estimates of E[D|X], loop through endogenous variables - D_X_res_list <- list() - 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) - }#FOR + D_X_res_list <- compute_CEF_list( + D, 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_prefix = "E[D", label_suffix = "|X]", + parallel = parallel) # 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 + ensb_info <- update_ensemble_info(y_X_res$weights) + ensemble_type <- ensb_info$ensemble_type + nensb <- ensb_info$nensb + multiple_ensembles <- ensb_info$multiple_ensembles # If a single ensemble is calculated, no loops are required. if (!multiple_ensembles) { @@ -257,7 +249,7 @@ ddml_pliv <- function(y, D, Z, X, nlearners_DX <- length(learners_DX); nlearners_ZX <- length(learners_ZX) # Compute coefficients for each ensemble - for (j in 1:nensb) { + for (j in seq_len(nensb)) { # Residualize y_r <- y - y_X_res$oos_fitted[, j] D_r <- D - get_oosfitted(D_X_res_list, j) @@ -287,11 +279,11 @@ ddml_pliv <- function(y, D, Z, X, # Store complementary ensemble output weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) - for (k in 1:nD){ + for (k in seq_len(nD)){ weights[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$weights mspe[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$mspe }#FOR - for (k in 1:nZ){ + for (k in seq_len(nZ)){ weights[[paste0("Z", k, "_X")]] <- Z_X_res_list[[k]]$weights mspe[[paste0("Z", k, "_X")]] <- Z_X_res_list[[k]]$mspe }#FOR diff --git a/R/ddml_plm.R b/R/ddml_plm.R index 99a187b..3dec72d 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -165,6 +165,13 @@ ddml_plm <- function(y, D, X, cv_subsamples_list = NULL, silent = FALSE, parallel = NULL) { + # Validate inputs + validate_inputs(y = y, D = D, X = X, learners = learners, + sample_folds = sample_folds, cv_folds = cv_folds, + ensemble_type = ensemble_type) + validate_custom_weights(custom_ensemble_weights, learners) + validate_custom_weights(custom_ensemble_weights_DX, learners_DX) + # Backward compatibility for renamed parameter if (!is.null(cv_subsamples_list)) { if (!is.null(cv_subsamples)) @@ -175,9 +182,6 @@ ddml_plm <- function(y, D, X, # Data parameters nobs <- length(y) - ncustom <- ncol(custom_ensemble_weights) - ncustom <- ifelse(is.null(ncustom), 0, ncustom) - nensb <- length(ensemble_type) + ncustom # Check for multivariate endogenous variables D <- as.matrix(D) @@ -220,29 +224,22 @@ ddml_plm <- function(y, D, X, parallel = parallel) # Compute estimates of E[D|X], loop through endogenous variables - D_X_res_list <- list() - 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) - }#FOR + D_X_res_list <- compute_CEF_list( + D, 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_prefix = "E[D", label_suffix = "|X]", + parallel = parallel) # 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 + ensb_info <- update_ensemble_info(y_X_res$weights) + ensemble_type <- ensb_info$ensemble_type + nensb <- ensb_info$nensb + multiple_ensembles <- ensb_info$multiple_ensembles # If a single ensemble is calculated, no loops are required. if (!multiple_ensembles) { @@ -275,7 +272,7 @@ ddml_plm <- function(y, D, X, nlearners <- length(learners); nlearners_DX <- length(learners_DX) # Compute coefficients for each ensemble - for (j in 1:nensb) { + for (j in seq_len(nensb)) { # Residualize D_r <- D - get_oosfitted(D_X_res_list, j) @@ -305,7 +302,7 @@ ddml_plm <- function(y, D, X, # Store complementary ensemble output weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) - for (k in 1:nD){ + for (k in seq_len(nD)){ weights[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$weights mspe[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$mspe }#FOR diff --git a/R/ensemble.R b/R/ensemble.R index 844465d..562a867 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -72,7 +72,7 @@ ensemble <- function(y, X, Z = NULL, }#IF # Compute fit for each included model mdl_fits <- rep(list(NULL), nlearners) - for (m in 1:nlearners) { + for (m in seq_len(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. @@ -118,7 +118,7 @@ predict.ensemble <- function(object, newdata, newZ = NULL, ...){ }#IF # Calculate fitted values for each model first_fit <- TRUE - for (m in 1:nlearners) { + for (m in seq_len(nlearners)) { # Skip model if not assigned positive weight if (!(m %in% mdl_include)) next # Get assign_X and assing_Z @@ -196,7 +196,7 @@ ensemble_weights <- function(y, X, Z = NULL, }#IF # Compute weights for each ensemble type weights <- matrix(0, nlearners, ntype + ncustom) - for (k in 1:ntype) { + for (k in seq_len(ntype)) { if (type[k] == "average") { # Assign 1 to all included learners and normalize weights[, k] <- 1 @@ -227,7 +227,7 @@ ensemble_weights <- function(y, X, Z = NULL, } else if (type[k] == "singlebest") { # Find MSPE-minimizing model mdl_min <- which.min(Matrix::colMeans(cv_results$oos_resid^2)[, drop = FALSE]) - mdl_min <- (1:nlearners)[mdl_min] + mdl_min <- (seq_len(nlearners))[mdl_min] # Assign unit weight to the best model weights[mdl_min, k] <- 1 }#IFELSE diff --git a/R/get_CEF.R b/R/get_CEF.R index 160a85e..9858ea4 100644 --- a/R/get_CEF.R +++ b/R/get_CEF.R @@ -61,15 +61,15 @@ extrapolate_CEF <- function(D, CEF_res_byD, aux_indx) { 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]) + for (d in seq_len(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) # Populate CEF g_X_byD <- array(0, dim = c(nobs, nensb, nCEF)) - for (d in 1:nCEF) { + for (d in seq_len(nCEF)) { g_X_byD[is_D[[d]], , d] <- CEF_res_byD[[d]][[1]]$oos_fitted - for (k in 1:sample_folds) { + for (k in seq_len(sample_folds)) { g_X_byD[aux_indx[[d]][[k]], , d] <- CEF_res_byD[[d]][[1]]$auxiliary_fitted[[k]] }#FOR diff --git a/R/help_functions.R b/R/help_functions.R index 8d87838..eb50a3a 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -48,3 +48,143 @@ trim_propensity_scores <- function(m_X, trim, ensemble_type) { # Return trimmed scores m_X }#TRIM_PROPENSITY_SCORES + +# 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, + 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.") + } + } + + 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.") + } + if (nrow(D_mat) != nobs) { + stop("Length/number of rows of D must match length of y.") + } + if (require_binary_D) { + if (!all(D_mat %in% c(0, 1))) { + stop("D must be binary (0 or 1).") + } + } + } + + if (!is.null(X) && !is.null(y)) { + if (NROW(X) != nobs) { + stop("Number of rows of X must match length of y.") + } + } + + if (!is.null(Z) && !is.null(y)) { + if (NROW(Z) != nobs) { + stop("Number of rows of Z must match length of y.") + } + } + + if (!is.null(learners)) { + if (!is.list(learners)) { + stop("learners must be a list.") + } else { + is_single <- "what" %in% names(learners) + if (!is_single) { + for (l in learners) { + if (!is.list(l) || !"fun" %in% names(l)) { + stop("learners structure is invalid.") + } + } + } + } + } + + 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.") + } + } + + 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.") + } + } + + 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.") + } + } + + 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.") + } + } +}#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.") + } + custom_weights <- as.matrix(custom_weights) + n_learners <- if ("what" %in% names(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.") + } +}#VALIDATE_CUSTOM_WEIGHTS + +# Compute ncustom and nensb from ensemble config. +compute_ncustom_nensb <- function(ensemble_type, + custom_ensemble_weights) { + ncustom <- ncol(custom_ensemble_weights) + ncustom <- if (is.null(ncustom)) 0L else ncustom + nensb <- length(ensemble_type) + ncustom + list(ncustom = ncustom, nensb = nensb) +}#COMPUTE_NCUSTOM_NENSB + +# Update ensemble info from CEF result weights. +update_ensemble_info <- function(res_weights) { + ensemble_type <- dimnames(res_weights)[[2]] + nensb <- if (is.null(ensemble_type)) 1L else length(ensemble_type) + multiple_ensembles <- nensb > 1 + list(ensemble_type = ensemble_type, nensb = nensb, + multiple_ensembles = multiple_ensembles) +}#UPDATE_ENSEMBLE_INFO + +# Compute CEF for each column of M, collecting results in a list. +compute_CEF_list <- function(M, X, Z = NULL, + learners, ensemble_type, + shortstack, + custom_ensemble_weights, + subsamples, cv_subsamples, + compute_insample_predictions = FALSE, + silent = FALSE, + label_prefix, label_suffix, + parallel = NULL) { + nM <- ncol(M) + res_list <- vector("list", nM) + for (k in seq_len(nM)) { + res_list[[k]] <- get_CEF( + M[, k, drop = FALSE], X, Z = Z, + learners = learners, + ensemble_type = ensemble_type, + shortstack = shortstack, + custom_ensemble_weights = custom_ensemble_weights, + subsamples = subsamples, + cv_subsamples = cv_subsamples, + compute_insample_predictions = + compute_insample_predictions, + silent = silent, + label = paste0(label_prefix, k, label_suffix), + parallel = parallel) + }#FOR + res_list +}#COMPUTE_CEF_LIST diff --git a/R/inference_functions.R b/R/inference_functions.R index 559af35..a4b9756 100644 --- a/R/inference_functions.R +++ b/R/inference_functions.R @@ -1,5 +1,7 @@ compute_ddml_variance <- function(scores, J, - cluster_variable = NULL) { + cluster_variable = NULL, + type = "HC1") { + type <- match.arg(type, c("HC0", "HC1", "HC3")) sc <- as.matrix(scores) J_j <- as.matrix(J) p <- ncol(sc) @@ -13,11 +15,24 @@ compute_ddml_variance <- function(scores, J, n_eff <- nrow(sc) - # HC1 sandwich variance - meat <- crossprod(sc) / n_eff - J_inv <- solve(J_j) - V <- J_inv %*% meat %*% t(J_inv) * - n_eff / (n_eff - p) / n_eff + if (type == "HC3") { + PtP_inv <- solve(crossprod(sc)) + h <- rowSums((sc %*% PtP_inv) * sc) + sc <- sc / (1 - h) + meat <- crossprod(sc) / n_eff + J_inv <- solve(J_j) + V <- J_inv %*% meat %*% t(J_inv) / n_eff + } else if (type == "HC1") { + meat <- crossprod(sc) / n_eff + J_inv <- solve(J_j) + V <- J_inv %*% meat %*% t(J_inv) * + n_eff / (n_eff - p) / n_eff + } else { + # HC0 + meat <- crossprod(sc) / n_eff + J_inv <- solve(J_j) + V <- J_inv %*% meat %*% t(J_inv) / n_eff + }#IFELSE V }#COMPUTE_DDML_VARIANCE @@ -25,7 +40,8 @@ compute_ddml_variance <- function(scores, J, compute_ddml_inference <- function(coefficients, scores, J, coef_names = NULL, ensemble_type, - cluster_variable = NULL) { + cluster_variable = NULL, + type = "HC1") { nensb <- length(ensemble_type) p <- NCOL(scores[[1]]) @@ -39,7 +55,8 @@ compute_ddml_inference <- function(coefficients, scores, J, }#IFELSE V <- compute_ddml_variance(scores[[j]], J[[j]], - cluster_variable) + cluster_variable, + type = type) se <- sqrt(diag(V)) t_val <- theta_j / se p_val <- 2 * stats::pnorm(abs(t_val), diff --git a/R/methods.R b/R/methods.R index 1a1bc32..e3fa824 100644 --- a/R/methods.R +++ b/R/methods.R @@ -20,16 +20,23 @@ coef.ddml <- function(object, ...) { #' @param object An object of class \code{ddml}. #' @param ensemble_idx Integer index of the ensemble type to #' use. Defaults to 1 (first ensemble type). +#' @param type Character string specifying the +#' variance-covariance estimator. One of \code{"HC1"} +#' (default, degrees-of-freedom corrected), \code{"HC0"} +#' (uncorrected), or \code{"HC3"} (score-based leverage +#' adjustment for finite-sample robustness). #' @param ... Currently unused. #' #' @return A p x p variance-covariance matrix. #' #' @export -vcov.ddml <- function(object, ensemble_idx = 1, ...) { +vcov.ddml <- function(object, ensemble_idx = 1, + type = "HC1", ...) { V <- compute_ddml_variance( object$scores[[ensemble_idx]], object$J[[ensemble_idx]], - object$cluster_variable) + object$cluster_variable, + type = type) rownames(V) <- colnames(V) <- object$coef_names V }#VCOV.DDML @@ -41,6 +48,9 @@ vcov.ddml <- function(object, ensemble_idx = 1, ...) { #' @param level Confidence level. Default 0.95. #' @param ensemble_idx Integer index of the ensemble type to #' use. Defaults to 1 (first ensemble type). +#' @param type Character string specifying the +#' variance-covariance estimator. One of \code{"HC1"} +#' (default), \code{"HC0"}, or \code{"HC3"}. #' @param ... Currently unused. #' #' @return A matrix with columns for lower and upper bounds. @@ -48,7 +58,8 @@ vcov.ddml <- function(object, ensemble_idx = 1, ...) { #' @importFrom stats vcov #' @export confint.ddml <- function(object, parm, level = 0.95, - ensemble_idx = 1, ...) { + ensemble_idx = 1, + type = "HC1", ...) { cf <- object$coefficients if (is.matrix(cf)) { cf <- cf[, ensemble_idx] @@ -56,7 +67,8 @@ confint.ddml <- function(object, parm, level = 0.95, cf <- cf[ensemble_idx] }#IFELSE - V <- vcov(object, ensemble_idx = ensemble_idx) + V <- vcov(object, ensemble_idx = ensemble_idx, + type = type) se <- sqrt(diag(V)) z <- stats::qnorm((1 + level) / 2) ci <- cbind(cf - z * se, cf + z * se) @@ -69,12 +81,18 @@ confint.ddml <- function(object, parm, level = 0.95, #' Summary for DDML Estimators #' #' @param object An object of class \code{ddml}. +#' @param type Character string specifying the +#' variance-covariance estimator. One of \code{"HC1"} +#' (default, degrees-of-freedom corrected), \code{"HC0"} +#' (uncorrected), or \code{"HC3"} (score-based leverage +#' adjustment for finite-sample robustness). #' @param ... Currently unused. #' #' @return An object of class \code{summary.ddml}. #' #' @export -summary.ddml <- function(object, ...) { +summary.ddml <- function(object, type = "HC1", ...) { + type <- match.arg(type, c("HC0", "HC1", "HC3")) single_learner <- ("what" %in% names(object$learners)) ens_type <- if (single_learner) { "single base learner" @@ -88,10 +106,12 @@ summary.ddml <- function(object, ...) { J = object$J, coef_names = object$coef_names, ensemble_type = ens_type, - cluster_variable = object$cluster_variable) + cluster_variable = object$cluster_variable, + type = type) result <- list( inf_results = inf, + type = type, model_type = class(object)[1], nobs = object$nobs, sample_folds = object$sample_folds, @@ -131,6 +151,9 @@ print.summary.ddml <- function(x, digits = 3, ...) { 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") nensb <- dim(x$inf_results)[3] diff --git a/R/shortstacking.R b/R/shortstacking.R index 967dc61..b502240 100644 --- a/R/shortstacking.R +++ b/R/shortstacking.R @@ -133,7 +133,7 @@ shortstacking <- function(y, X, Z = NULL, # Compute auxilliary 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 @@ -142,7 +142,7 @@ shortstacking <- function(y, X, Z = NULL, is_fitted <- rep(list(NULL), sample_folds) fakecv_k <- list() if (compute_insample_predictions) { - for (k in 1:sample_folds) { + for (k in seq_len(sample_folds)) { # Compute shortstacking weights in-sample nobs_k <- length(y[-subsamples[[k]]]) fakecv_k$oos_resid <- matrix(y[-subsamples[[k]]], nobs_k, nlearners) - @@ -160,8 +160,8 @@ shortstacking <- function(y, X, Z = NULL, 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) { + for (i in seq_len(nensb)) { + for (k in seq_len(sample_folds)) { new_is_fitted[[i]][[k]] <- is_fitted[[k]][, i, drop = FALSE] }#FOR }#FOR diff --git a/R/tidy.R b/R/tidy.R index eb2b5c1..466ee82 100644 --- a/R/tidy.R +++ b/R/tidy.R @@ -21,6 +21,9 @@ generics::glance #' columns? Default \code{FALSE}. #' @param conf.level Confidence level for intervals. #' Default 0.95. +#' @param type Character string specifying the +#' variance-covariance estimator. One of \code{"HC1"} +#' (default), \code{"HC0"}, or \code{"HC3"}. #' @param ... Currently unused. #' #' @return A \code{data.frame} with columns \code{term}, @@ -31,9 +34,11 @@ generics::glance #' #' @family ddml #' @export +#' @method tidy ddml tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, - conf.level = 0.95, ...) { - s <- summary(x) + conf.level = 0.95, + type = "HC1", ...) { + s <- summary(x, type = type) inf <- s$inf_results nensb <- dim(inf)[3] p <- dim(inf)[1] @@ -82,6 +87,7 @@ tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, #' #' @family ddml #' @export +#' @method glance ddml glance.ddml <- function(x, ...) { data.frame( nobs = x$nobs, @@ -91,4 +97,4 @@ glance.ddml <- function(x, ...) { model_type = class(x)[1], stringsAsFactors = FALSE ) -}#GLANCE.DDML +}#GLANCE.DDML \ No newline at end of file diff --git a/man/confint.ddml.Rd b/man/confint.ddml.Rd index 2d809b8..88a4c11 100644 --- a/man/confint.ddml.Rd +++ b/man/confint.ddml.Rd @@ -4,7 +4,7 @@ \alias{confint.ddml} \title{Confidence Intervals for DDML Estimators} \usage{ -\method{confint}{ddml}(object, parm, level = 0.95, ensemble_idx = 1, ...) +\method{confint}{ddml}(object, parm, level = 0.95, ensemble_idx = 1, type = "HC1", ...) } \arguments{ \item{object}{An object of class \code{ddml}.} @@ -16,6 +16,10 @@ \item{ensemble_idx}{Integer index of the ensemble type to use. Defaults to 1 (first ensemble type).} +\item{type}{Character string specifying the +variance-covariance estimator. One of \code{"HC1"} +(default), \code{"HC0"}, or \code{"HC3"}.} + \item{...}{Currently unused.} } \value{ diff --git a/man/ddml_ate.Rd b/man/ddml_ate.Rd index ff651b2..73df3f2 100644 --- a/man/ddml_ate.Rd +++ b/man/ddml_ate.Rd @@ -248,6 +248,8 @@ Other ddml: \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()} +\code{\link{ddml_plm}()}, +\code{\link{glance.ddml}()}, +\code{\link{tidy.ddml}()} } \concept{ddml} diff --git a/man/ddml_fpliv.Rd b/man/ddml_fpliv.Rd index 73684ac..d46a4ae 100644 --- a/man/ddml_fpliv.Rd +++ b/man/ddml_fpliv.Rd @@ -198,6 +198,8 @@ Other ddml: \code{\link{ddml_ate}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()} +\code{\link{ddml_plm}()}, +\code{\link{glance.ddml}()}, +\code{\link{tidy.ddml}()} } \concept{ddml} diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index 2e4f2b5..00f600b 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -241,6 +241,8 @@ Other ddml: \code{\link{ddml_ate}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()} +\code{\link{ddml_plm}()}, +\code{\link{glance.ddml}()}, +\code{\link{tidy.ddml}()} } \concept{ddml} diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index fb2b7c9..e161601 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -197,6 +197,8 @@ Other ddml: \code{\link{ddml_ate}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, -\code{\link{ddml_plm}()} +\code{\link{ddml_plm}()}, +\code{\link{glance.ddml}()}, +\code{\link{tidy.ddml}()} } \concept{ddml} diff --git a/man/ddml_plm.Rd b/man/ddml_plm.Rd index dc7c563..e51c88f 100644 --- a/man/ddml_plm.Rd +++ b/man/ddml_plm.Rd @@ -197,6 +197,8 @@ Other ddml: \code{\link{ddml_ate}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, -\code{\link{ddml_pliv}()} +\code{\link{ddml_pliv}()}, +\code{\link{glance.ddml}()}, +\code{\link{tidy.ddml}()} } \concept{ddml} diff --git a/man/glance.ddml.Rd b/man/glance.ddml.Rd index 040977f..8e08cbb 100644 --- a/man/glance.ddml.Rd +++ b/man/glance.ddml.Rd @@ -2,18 +2,32 @@ % Please edit documentation in R/tidy.R \name{glance.ddml} \alias{glance.ddml} -\title{Glance at a ddml object} +\title{Glance at a ddml Object} \usage{ \method{glance}{ddml}(x, ...) } \arguments{ \item{x}{A \code{ddml} object.} -\item{...}{Additional arguments.} +\item{...}{Currently unused.} } \value{ -A one-row data.frame with model metadata. +A one-row \code{data.frame} with columns +\code{nobs}, \code{sample_folds}, \code{shortstack}, +\code{ensemble_type}, and \code{model_type}. } \description{ -Glance at a ddml object +Returns a one-row summary of model-level statistics, +compatible with \pkg{modelsummary} and the \pkg{broom} +ecosystem. } +\seealso{ +Other ddml: +\code{\link{ddml_ate}()}, +\code{\link{ddml_fpliv}()}, +\code{\link{ddml_late}()}, +\code{\link{ddml_pliv}()}, +\code{\link{ddml_plm}()}, +\code{\link{tidy.ddml}()} +} +\concept{ddml} diff --git a/man/summary.ddml.Rd b/man/summary.ddml.Rd index a54db6e..17df6c4 100644 --- a/man/summary.ddml.Rd +++ b/man/summary.ddml.Rd @@ -4,11 +4,17 @@ \alias{summary.ddml} \title{Summary for DDML Estimators} \usage{ -\method{summary}{ddml}(object, ...) +\method{summary}{ddml}(object, type = "HC1", ...) } \arguments{ \item{object}{An object of class \code{ddml}.} +\item{type}{Character string specifying the +variance-covariance estimator. One of \code{"HC1"} +(default, degrees-of-freedom corrected), \code{"HC0"} +(uncorrected), or \code{"HC3"} (score-based leverage +adjustment for finite-sample robustness).} + \item{...}{Currently unused.} } \value{ diff --git a/man/tidy.ddml.Rd b/man/tidy.ddml.Rd index f58f3d6..b048098 100644 --- a/man/tidy.ddml.Rd +++ b/man/tidy.ddml.Rd @@ -2,22 +2,56 @@ % Please edit documentation in R/tidy.R \name{tidy.ddml} \alias{tidy.ddml} -\title{Tidy a ddml object} +\title{Tidy a ddml Object} \usage{ -\method{tidy}{ddml}(x, conf.int = FALSE, conf.level = 0.95, ...) +\method{tidy}{ddml}( + x, + ensemble_idx = 1, + conf.int = FALSE, + conf.level = 0.95, + type = "HC1", + ... +) } \arguments{ \item{x}{A \code{ddml} object.} -\item{conf.int}{Logical indicating whether or not to include a confidence interval.} +\item{ensemble_idx}{Integer index of the ensemble type to +report. Defaults to 1 (first ensemble type). Set to +\code{NULL} to return results for all ensemble types.} -\item{conf.level}{The confidence level to use.} +\item{conf.int}{Logical. Include confidence interval +columns? Default \code{FALSE}.} -\item{...}{Additional arguments passed to summary method.} +\item{conf.level}{Confidence level for intervals. +Default 0.95.} + +\item{type}{Character string specifying the +variance-covariance estimator. One of \code{"HC1"} +(default), \code{"HC0"}, or \code{"HC3"}.} + +\item{...}{Currently unused.} } \value{ -A data.frame containing tidy coefficients per ensemble type. +A \code{data.frame} with columns \code{term}, +\code{estimate}, \code{std.error}, \code{statistic}, +\code{p.value}, and \code{ensemble_type}. If +\code{conf.int = TRUE}, also \code{conf.low} and +\code{conf.high}. } \description{ -Tidy a ddml object +Extracts coefficient estimates, standard errors, test +statistics, and p-values from a \code{ddml} estimator in a +format compatible with \pkg{modelsummary} and the +\pkg{broom} ecosystem. +} +\seealso{ +Other ddml: +\code{\link{ddml_ate}()}, +\code{\link{ddml_fpliv}()}, +\code{\link{ddml_late}()}, +\code{\link{ddml_pliv}()}, +\code{\link{ddml_plm}()}, +\code{\link{glance.ddml}()} } +\concept{ddml} diff --git a/man/vcov.ddml.Rd b/man/vcov.ddml.Rd index 117e570..479471c 100644 --- a/man/vcov.ddml.Rd +++ b/man/vcov.ddml.Rd @@ -4,7 +4,7 @@ \alias{vcov.ddml} \title{Variance-Covariance Matrix for DDML Estimators} \usage{ -\method{vcov}{ddml}(object, ensemble_idx = 1, ...) +\method{vcov}{ddml}(object, ensemble_idx = 1, type = "HC1", ...) } \arguments{ \item{object}{An object of class \code{ddml}.} @@ -12,6 +12,12 @@ \item{ensemble_idx}{Integer index of the ensemble type to use. Defaults to 1 (first ensemble type).} +\item{type}{Character string specifying the +variance-covariance estimator. One of \code{"HC1"} +(default, degrees-of-freedom corrected), \code{"HC0"} +(uncorrected), or \code{"HC3"} (score-based leverage +adjustment for finite-sample robustness).} + \item{...}{Currently unused.} } \value{ diff --git a/tests/testthat/test-inference_functions.R b/tests/testthat/test-inference_functions.R index a5f958c..b023e36 100644 --- a/tests/testthat/test-inference_functions.R +++ b/tests/testthat/test-inference_functions.R @@ -1,19 +1,16 @@ test_that("compute_ddml_variance computes HC1 sandwich variance correctly", { - # Mock data set.seed(42) nobs <- 100 p <- 2 scores <- matrix(rnorm(nobs * p), nobs, p) - J <- diag(2, p) # Simple J matrix - - # Manual computation matching HC1 specification + J <- diag(2, p) + meat <- crossprod(scores) / nobs J_inv <- solve(J) expected_v <- J_inv %*% meat %*% t(J_inv) * nobs / (nobs - p) / nobs - - # Test function output + V <- compute_ddml_variance(scores, J) - + expect_true(is.matrix(V)) expect_equal(dim(V), c(p, p)) expect_equal(V, expected_v) @@ -25,16 +22,154 @@ test_that("compute_ddml_variance handles cluster aggregation correctly", { p <- 2 scores <- matrix(rnorm(nobs * p), nobs, p) J <- diag(2, p) - cluster_var <- rep(1:50, each = 2) # 50 clusters - - # By clustering, the scores should be rowsummed to n_eff = 50 - V_clustered <- compute_ddml_variance(scores, J, cluster_variable = cluster_var) - + cluster_var <- rep(1:50, each = 2) + + V_clustered <- compute_ddml_variance( + scores, J, cluster_variable = cluster_var) + sc_sum <- rowsum(scores, cluster_var) n_eff <- 50 meat <- crossprod(sc_sum) / n_eff J_inv <- solve(J) - expected_v <- J_inv %*% meat %*% t(J_inv) * n_eff / (n_eff - p) / n_eff - + expected_v <- J_inv %*% meat %*% t(J_inv) * + n_eff / (n_eff - p) / n_eff + expect_equal(V_clustered, expected_v) }) + +test_that("compute_ddml_variance computes HC0 correctly", { + set.seed(42) + nobs <- 100 + p <- 2 + scores <- matrix(rnorm(nobs * p), nobs, p) + J <- diag(2, p) + + meat <- crossprod(scores) / nobs + J_inv <- solve(J) + expected_v <- J_inv %*% meat %*% t(J_inv) / nobs + + V <- compute_ddml_variance(scores, J, type = "HC0") + + expect_equal(V, expected_v) +}) + +test_that("HC1 equals HC0 scaled by n/(n-p)", { + set.seed(42) + nobs <- 100 + p <- 2 + scores <- matrix(rnorm(nobs * p), nobs, p) + J <- diag(2, p) + + V_hc0 <- compute_ddml_variance(scores, J, type = "HC0") + V_hc1 <- compute_ddml_variance(scores, J, type = "HC1") + + expect_equal(V_hc1, V_hc0 * nobs / (nobs - p)) +}) + +test_that("compute_ddml_variance computes HC3 correctly", { + set.seed(42) + nobs <- 100 + p <- 2 + scores <- matrix(rnorm(nobs * p), nobs, p) + J <- diag(2, p) + + # Manual HC3 computation + PtP_inv <- solve(crossprod(scores)) + h <- rowSums((scores %*% PtP_inv) * scores) + sc_adj <- scores / (1 - h) + meat <- crossprod(sc_adj) / nobs + J_inv <- solve(J) + expected_v <- J_inv %*% meat %*% t(J_inv) / nobs + + V <- compute_ddml_variance(scores, J, type = "HC3") + + expect_equal(V, expected_v) +}) + +test_that("HC3 leverage has correct properties", { + set.seed(42) + nobs <- 200 + p <- 3 + scores <- matrix(rnorm(nobs * p), nobs, p) + + PtP_inv <- solve(crossprod(scores)) + h <- rowSums((scores %*% PtP_inv) * scores) + + # Sum of leverages equals p + expect_equal(sum(h), p, tolerance = 1e-10) + + # All leverages in [0, 1] + expect_true(all(h >= 0)) + expect_true(all(h < 1)) + + # Average leverage = p/n + expect_equal(mean(h), p / nobs, tolerance = 1e-10) +}) + +test_that("HC3 leverage for scalar scores", { + set.seed(42) + nobs <- 100 + scores <- matrix(rnorm(nobs), nobs, 1) + + PtP_inv <- solve(crossprod(scores)) + h <- rowSums((scores %*% PtP_inv) * scores) + + # For p=1: h_i = psi_i^2 / sum(psi_j^2) + expected_h <- as.vector(scores^2) / sum(scores^2) + expect_equal(h, expected_h, tolerance = 1e-10) + expect_equal(sum(h), 1) +}) + +test_that("HC3 with cluster aggregation", { + set.seed(42) + nobs <- 100 + p <- 2 + scores <- matrix(rnorm(nobs * p), nobs, p) + J <- diag(2, p) + cluster_var <- rep(1:50, each = 2) + + V <- compute_ddml_variance( + scores, J, + cluster_variable = cluster_var, + type = "HC3") + + # Manual: aggregate scores first, then HC3 on aggregated + sc_sum <- rowsum(scores, cluster_var) + n_eff <- 50 + PtP_inv <- solve(crossprod(sc_sum)) + h <- rowSums((sc_sum %*% PtP_inv) * sc_sum) + sc_adj <- sc_sum / (1 - h) + meat <- crossprod(sc_adj) / n_eff + J_inv <- solve(J) + expected_v <- J_inv %*% meat %*% t(J_inv) / n_eff + + expect_equal(V, expected_v) + expect_equal(sum(h), p, tolerance = 1e-10) +}) + +test_that("type rejects invalid values", { + scores <- matrix(rnorm(20), 10, 2) + J <- diag(2) + + expect_error( + compute_ddml_variance(scores, J, type = "HC2"), + "arg") +}) + +test_that("HC3 >= HC1 >= HC0 for typical data", { + set.seed(42) + nobs <- 200 + p <- 1 + scores <- matrix(rnorm(nobs * p), nobs, p) + J <- matrix(-1, 1, 1) + + se_hc0 <- sqrt(diag(compute_ddml_variance( + scores, J, type = "HC0"))) + se_hc1 <- sqrt(diag(compute_ddml_variance( + scores, J, type = "HC1"))) + se_hc3 <- sqrt(diag(compute_ddml_variance( + scores, J, type = "HC3"))) + + expect_true(all(se_hc1 >= se_hc0)) + expect_true(all(se_hc3 >= se_hc0)) +}) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 7f4e3ed..6ee80b2 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -1,12 +1,11 @@ test_that("standard S3 generic methods work correctly", { - # Generate a minimal fitted object to test the plumbing set.seed(42) nobs <- 100 X <- cbind(1, matrix(rnorm(nobs * 4), nobs, 4)) D_tld <- X %*% runif(5) + rnorm(nobs) D <- 1 * (D_tld > mean(D_tld)) y <- D + X %*% runif(5) + rnorm(nobs) - + learners <- list(list(fun = ols), list(fun = ols)) suppressWarnings({ fit <- ddml_ate(y, D, X, @@ -16,30 +15,107 @@ test_that("standard S3 generic methods work correctly", { sample_folds = 2, silent = TRUE) }) - + # coef cf <- coef(fit) expect_true(is.numeric(cf)) expect_length(cf, 2) - + # vcov V <- vcov(fit, ensemble_idx = 2) expect_true(is.matrix(V)) expect_equal(dim(V), c(1, 1)) - + # confint ci <- confint(fit, ensemble_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) - + # 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 <- 100 + X <- cbind(1, matrix(rnorm(nobs * 4), nobs, 4)) + D_tld <- X %*% runif(5) + rnorm(nobs) + D <- 1 * (D_tld > mean(D_tld)) + y <- D + X %*% runif(5) + rnorm(nobs) + + learners <- list(list(fun = ols), list(fun = ols)) + suppressWarnings({ + 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$inf_results[1, 2, 1] + se_hc1 <- s1$inf_results[1, 2, 1] + expect_true(se_hc1 > se_hc0) + + # Coefficients are identical across vcov types + expect_equal(s0$inf_results[, 1, ], s1$inf_results[, 1, ]) + expect_equal(s0$inf_results[, 1, ], s3$inf_results[, 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 <- 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) + + 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(1, 1)) + expect_true(V_hc1[1, 1] > V_hc0[1, 1]) +}) diff --git a/vignettes/articles/example_401k.Rmd.txt b/vignettes/articles/example_401k.Rmd.txt index 8237bbf..62ce5ed 100644 --- a/vignettes/articles/example_401k.Rmd.txt +++ b/vignettes/articles/example_401k.Rmd.txt @@ -63,7 +63,7 @@ xgboost_fit <- ddml_plm(y = y, D = D, X = X, learners = list(what = mdl_xgboost, args = list(nrounds = 300)), sample_folds = 10, - silent = T) + silent = TRUE) summary(xgboost_fit) # Comparison to multiple linear regression @@ -97,8 +97,8 @@ stacking_fit <- ddml_plm(y = y, D = D, X = X, learners = learners, ensemble_type = "nnls", sample_folds = 10, - shortstack = T, - silent = T) + shortstack = TRUE, + silent = TRUE) summary(stacking_fit) ``` @@ -153,8 +153,8 @@ stacking_fit <- ddml_plm(y = y, D = D, X = X_c, learners = learners, ensemble_type = "nnls", sample_folds = 10, - shortstack = T, - silent = T) + shortstack = TRUE, + silent = TRUE) summary(stacking_fit) ``` @@ -202,8 +202,8 @@ stacking_fit <- ddml_plm(y = y, D = D, X = X_c, learners_DX = learners_DX, ensemble_type = "nnls", sample_folds = 10, - shortstack = T, - silent = T) + shortstack = TRUE, + silent = TRUE) summary(stacking_fit) ``` @@ -231,8 +231,8 @@ stacking_IV_fit <- ddml_pliv(y = y, D = D, Z = Z, X = X_c, learners_ZX = learners_DX, ensemble_type = "nnls", sample_folds = 10, - shortstack = T, - silent = T) + shortstack = TRUE, + silent = TRUE) summary(stacking_IV_fit) # Stacking weights associated with each base learner diff --git a/vignettes/articles/example_BLP95.Rmd.txt b/vignettes/articles/example_BLP95.Rmd.txt index c4a7778..0429eec 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 ) ``` @@ -136,8 +138,8 @@ 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) + silent = TRUE) +summary(lasso_fit) ``` # Estimating the Flexible Partially Linear IV Model with Multiple Learners @@ -183,10 +185,10 @@ stacking_fit <- ddml_fpliv(y, D = D, Z = Z_c, X = X_c, learners = learners, ensemble_type = c("nnls1"), - shortstack = T, + shortstack = TRUE, sample_folds = 10, - silent = T) -t(round(summary(stacking_fit), 4)[2, , ]) + silent = TRUE) +summary(stacking_fit) ``` Interestingly, the coefficient is closer to the OLS estimates than to the TSLS estimates (with or without lasso)! @@ -263,10 +265,10 @@ stacking_r_fit <- ddml_fpliv(y, D = D, Z = Zr_, X = Xr_, learners = learner, ensemble_type = c("nnls1"), - shortstack = T, + shortstack = TRUE, sample_folds = 10, - silent = T) -round(summary(stacking_r_fit)[2, , 1], 4) + 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. diff --git a/vignettes/articles/new_ml_wrapper.Rmd.txt b/vignettes/articles/new_ml_wrapper.Rmd.txt index 1f248da..73f67ae 100644 --- a/vignettes/articles/new_ml_wrapper.Rmd.txt +++ b/vignettes/articles/new_ml_wrapper.Rmd.txt @@ -141,10 +141,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 +153,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 +194,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 +213,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 +231,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/sparse.Rmd.txt b/vignettes/articles/sparse.Rmd.txt index f87e699..c8c4980 100644 --- a/vignettes/articles/sparse.Rmd.txt +++ b/vignettes/articles/sparse.Rmd.txt @@ -78,10 +78,10 @@ stacking_180IV_fit <- ddml_fpliv(y = AK91$LWKLYWGE, D = AK91$EDUC, learners_DX = list(list(fun = 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. @@ -99,10 +99,10 @@ stacking_1530IV_fit <- ddml_fpliv(y = AK91$LWKLYWGE, D = AK91$EDUC, learners_DX = list(list(fun = 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. @@ -132,10 +132,10 @@ stacking_fit <- ddml_fpliv(y = AK91$LWKLYWGE, D = AK91$EDUC, learners_DX = list(list(fun = 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. diff --git a/vignettes/precompile.R b/vignettes/precompile.R index 2a10641..0069bc7 100644 --- a/vignettes/precompile.R +++ b/vignettes/precompile.R @@ -1,31 +1,85 @@ -# 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") +) -# 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") + message("[KNIT] ", v$name, " (", v$src, " -> ", v$out, ")") + t0 <- proc.time() + + if (identical(v$name, "did")) { + old_wd <- setwd("vignettes/articles") + on.exit(setwd(old_wd), add = TRUE) + knit("did.Rmd.txt", "did.Rmd") + setwd(old_wd) + on.exit(NULL) + } 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()) From b1c4be60e85509ad4fd9f57db18144dc3bc65a34 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Tue, 24 Feb 2026 17:01:12 -0600 Subject: [PATCH 07/46] cvc+diagnostics, fix vignettes --- NAMESPACE | 3 + R/crosspred.R | 23 +- R/crossval.R | 7 +- R/cvc.R | 166 +++++++++++ R/ddml_ate.R | 18 +- R/ddml_att.R | 20 +- R/ddml_fpliv.R | 24 +- R/ddml_late.R | 28 +- R/ddml_pliv.R | 30 +- R/ddml_plm.R | 20 +- R/diagnostics.R | 263 ++++++++++++++++++ R/ensemble.R | 32 ++- R/get_CEF.R | 25 +- R/methods.R | 54 +++- R/shortstacking.R | 11 +- R/tidy.R | 23 ++ man/coef.ddml.Rd | 13 + man/confint.ddml.Rd | 17 +- man/diagnostics.Rd | 47 ++++ man/glance.ddml.Rd | 12 + man/print.ddml_diagnostics.Rd | 21 ++ man/summary.ddml.Rd | 13 + man/tidy.ddml.Rd | 13 + man/tidy.ddml_diagnostics.Rd | 37 +++ man/vcov.ddml.Rd | 13 + tests/testthat/test-cvc.R | 87 ++++++ tests/testthat/test-diagnostics.R | 157 +++++++++++ tests/testthat/test-tidy.R | 61 ++++ vignettes/articles/did.Rmd | 148 +++++----- vignettes/articles/did.Rmd.txt | 4 +- vignettes/articles/example_401k.Rmd | 161 ++++++----- vignettes/articles/example_401k.Rmd.txt | 4 +- vignettes/articles/example_BLP95.Rmd | 67 +++-- .../articles/figures/unnamed-chunk-11-1.png | Bin 22824 -> 19668 bytes .../articles/figures/unnamed-chunk-12-1.png | Bin 11296 -> 10347 bytes .../articles/figures/unnamed-chunk-4-1.png | Bin 22821 -> 19661 bytes .../articles/figures/unnamed-chunk-5-1.png | Bin 11308 -> 10334 bytes .../articles/figures/unnamed-chunk-8-1.png | Bin 24795 -> 17816 bytes .../articles/figures/unnamed-chunk-9-1.png | Bin 13353 -> 9021 bytes vignettes/articles/new_ml_wrapper.Rmd | 51 ++-- vignettes/articles/new_ml_wrapper.Rmd.txt | 4 +- vignettes/articles/sparse.Rmd | 62 ++--- vignettes/articles/sparse.Rmd.txt | 4 +- vignettes/articles/stacking.Rmd | 8 +- vignettes/articles/stacking.Rmd.txt | 4 +- vignettes/ddml.Rmd | 51 ++-- vignettes/ddml.Rmd.txt | 4 +- 47 files changed, 1494 insertions(+), 316 deletions(-) create mode 100644 R/cvc.R create mode 100644 R/diagnostics.R create mode 100644 man/diagnostics.Rd create mode 100644 man/print.ddml_diagnostics.Rd create mode 100644 man/tidy.ddml_diagnostics.Rd create mode 100644 tests/testthat/test-cvc.R create mode 100644 tests/testthat/test-diagnostics.R diff --git a/NAMESPACE b/NAMESPACE index e9efc0c..9fd7b5a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,9 +10,11 @@ S3method(predict,mdl_glmnet) S3method(predict,mdl_ranger) S3method(predict,mdl_xgboost) S3method(predict,ols) +S3method(print,ddml_diagnostics) S3method(print,summary.ddml) S3method(summary,ddml) S3method(tidy,ddml) +S3method(tidy,ddml_diagnostics) S3method(vcov,ddml) export(crosspred) export(crossval) @@ -22,6 +24,7 @@ export(ddml_fpliv) export(ddml_late) export(ddml_pliv) export(ddml_plm) +export(diagnostics) export(ensemble) export(ensemble_weights) export(glance) diff --git a/R/crosspred.R b/R/crosspred.R index 6f071bd..f42002f 100644 --- a/R/crosspred.R +++ b/R/crosspred.R @@ -233,7 +233,9 @@ crosspred <- function(y, X, Z = NULL, 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 ", seq_len(sample_folds)) + r2 <- matrix(NA_real_, nlearners^(calc_ensemble), sample_folds) + colnames(mspe) <- colnames(r2) <- + paste("sample fold ", seq_len(sample_folds)) weights <- array(0, dim = c(nlearners, nensb, sample_folds)) for (res in fold_results) { @@ -241,6 +243,7 @@ crosspred <- function(y, X, Z = NULL, oos_fitted[res$oos_indices, ] <- res$oos_fitted_rows if (!is.null(res$weights_k)) weights[, , k] <- res$weights_k if (!is.null(res$mspe_k)) mspe[, k] <- res$mspe_k + if (!is.null(res$r2_k)) r2[, k] <- res$r2_k is_fitted[[k]] <- res$is_fitted_k auxiliary_fitted[[k]] <- res$auxiliary_fitted_k if (!is.null(res$oos_fitted_bylearner_rows)) { @@ -270,13 +273,21 @@ crosspred <- function(y, X, Z = NULL, }#FOR is_fitted <- new_is_fitted }#IF + # Compute per-learner OOS residuals (not computed for FPLIV w/ LIE...) + oos_resid_bylearner <- if (is.numeric(y) && !is.list(y)) { + drop(y) - oos_fitted_bylearner + } else { + NULL + }#IFELSE + # Organize and return output - if (!calc_ensemble) weights <- mspe <- NULL + if (!calc_ensemble) weights <- mspe <- r2 <- NULL output <- list(oos_fitted = oos_fitted, - weights = weights, mspe = mspe, + weights = weights, mspe = mspe, r2 = r2, is_fitted = is_fitted, auxiliary_fitted = auxiliary_fitted, oos_fitted_bylearner = oos_fitted_bylearner, + oos_resid_bylearner = oos_resid_bylearner, is_fitted_bylearner = is_fitted_bylearner, auxiliary_fitted_bylearner = auxiliary_fitted_bylearner) return(output) @@ -330,6 +341,11 @@ crosspred_compute_fold <- function( } else { NULL } + r2_k <- if (calc_ensemble && !is.null(mdl_fit$cv_res)) { + mdl_fit$cv_res$r2 + } else { + NULL + } weight_colnames <- if (calc_ensemble) { colnames(mdl_fit$weights) } else { @@ -384,6 +400,7 @@ crosspred_compute_fold <- function( oos_fitted_rows = oos_fitted_rows, weights_k = weights_k, mspe_k = mspe_k, + r2_k = r2_k, weight_colnames = weight_colnames, is_fitted_k = is_fitted_k, auxiliary_fitted_k = auxiliary_fitted_k, diff --git a/R/crossval.R b/R/crossval.R index 12419d0..f4d9780 100644 --- a/R/crossval.R +++ b/R/crossval.R @@ -135,11 +135,14 @@ crossval <- function(y, X, Z = NULL, oos_resid <- matrix(oos_resid, nobs, nlearners) oos_resid <- oos_resid[order(unlist(cv_subsamples)), , drop = FALSE] - # Compute MSPE by learner + # Compute MSPE and R-squared by learner mspe <- colMeans(oos_resid^2) + y_var <- as.numeric(stats::var(y)) + r2 <- if (y_var > 0) 1 - mspe / y_var else rep(NA_real_, + length(mspe)) # Organize and return output - output <- list(mspe = mspe, + output <- list(mspe = mspe, r2 = r2, oos_resid = oos_resid, cv_subsamples = cv_subsamples) return(output) diff --git a/R/cvc.R b/R/cvc.R new file mode 100644 index 0000000..58bbf94 --- /dev/null +++ b/R/cvc.R @@ -0,0 +1,166 @@ +# Pairwise cross-validation comparison test. +# +# Compares predictive ability of two learners using their +# OOS residuals. Uses multiplier bootstrap for inference, +# with fold-level demeaning to account for cross-fitting +# dependence. +# +# @param resid1 Numeric vector of OOS residuals from learner 1. +# @param resid2 Numeric vector of OOS residuals from learner 2. +# @param fid Integer vector of fold IDs (same length as resid1). +# @param bootnum Number of bootstrap replications. +# +# @return P-value for H0: learner 1 has equal or larger MSPE +# than learner 2. Small p-value means learner 1 is better. +cvc_pairwise <- function(resid1, resid2, fid, + bootnum = 500) { + n <- length(resid1) + zeta <- resid1^2 - resid2^2 + + # Demean by fold to remove cross-fitting dependence + fid_unique <- unique(fid) + zeta_m <- numeric(n) + for (k in fid_unique) { + sel <- which(fid == k) + zeta_m[sel] <- mean(zeta[sel]) + }#FOR + zeta_til <- zeta - zeta_m + zeta_sd <- sqrt(stats::var(zeta_til)) + if (zeta_sd < .Machine$double.eps) return(NA_real_) + + Tx <- sqrt(n) * mean(zeta) / zeta_sd + + # Multiplier bootstrap (no model refitting) + zeta_scaled <- zeta_til / zeta_sd + Txb <- vapply(seq_len(bootnum), function(b) { + (1 / sqrt(n)) * sum(zeta_scaled * stats::rnorm(n)) + }, numeric(1)) + + mean(Txb > Tx) +}#CVC_PAIRWISE + +# 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. +# +# @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 = "/") + Txb <- vapply(seq_len(bootnum), function(b) { + bw <- stats::rnorm(n) + max(colSums(zeta_scaled * bw) / sqrt(n)) + }, numeric(1)) + + mean(Txb > Tx) +}#CVC_ONE_VS_MANY + +# Model confidence set via cross-validation comparison. +# +# For each learner, tests whether it is dominated by any +# other learner. Learners with large p-values form the +# model confidence set. +# +# @param resid_mat Matrix (n x nlearners) of OOS residuals. +# @param fid Integer vector of fold IDs. +# @param bootnum Number of bootstrap replications. +# @param alpha Significance level for the confidence set. +# +# @return List with: pvalues (numeric vector of p-values per +# learner), confidence_set (logical vector). +cvc_confidence_set <- function(resid_mat, fid, + bootnum = 500, + alpha = 0.05) { + nlearners <- ncol(resid_mat) + pvalues <- numeric(nlearners) + for (i in seq_len(nlearners)) { + pvalues[i] <- cvc_one_vs_many( + resid_mat[, i], resid_mat[, -i, drop = FALSE], + fid, bootnum) + }#FOR + list(pvalues = pvalues, + confidence_set = pvalues > alpha) +}#CVC_CONFIDENCE_SET + +# Main CVC entry point. +# +# Runs pairwise comparisons and the model confidence set +# procedure on a matrix of OOS residuals. +# +# @param oos_resid Matrix (n x nlearners) of OOS residuals. +# @param subsamples List of sample fold index vectors (used +# to derive fold IDs). +# @param bootnum Number of bootstrap replications. +# @param alpha Significance level for the confidence set. +# +# @return List with: pairwise (nlearners x nlearners matrix +# of p-values), confidence_set (logical vector), +# pvalues (numeric vector from confidence set procedure). +cvc_test <- function(oos_resid, subsamples, + bootnum = 500, alpha = 0.05) { + n <- nrow(oos_resid) + nlearners <- ncol(oos_resid) + + # Derive fold IDs from subsamples + fid <- integer(n) + for (k in seq_along(subsamples)) { + fid[subsamples[[k]]] <- k + }#FOR + + # Pairwise comparisons + pairwise <- matrix(NA_real_, nlearners, nlearners) + if (!is.null(colnames(oos_resid))) { + rownames(pairwise) <- colnames(pairwise) <- + colnames(oos_resid) + }#IF + for (i in seq_len(nlearners)) { + for (j in seq_len(nlearners)) { + if (i != j) { + pairwise[i, j] <- cvc_pairwise( + oos_resid[, i], oos_resid[, j], + fid, bootnum) + }#IF + }#FOR + }#FOR + + # Model confidence set + cs <- cvc_confidence_set(oos_resid, fid, bootnum, alpha) + + list(pairwise = pairwise, + pvalues = cs$pvalues, + confidence_set = cs$confidence_set) +}#CVC_TEST diff --git a/R/ddml_ate.R b/R/ddml_ate.R index f3c08be..dd79a38 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -251,20 +251,25 @@ ddml_ate <- function(y, D, X, }) coef_names <- "ATE" - # Organize complementary ensemble output + # Ensemble metrics weights <- list(y_X_D0 = y_X_D0_res$weights, y_X_D1 = y_X_D1_res$weights, D_X = D_X_res$weights) - - # 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) + r2 <- list(y_X_D0 = y_X_D0_res$r2, + y_X_D1 = y_X_D1_res$r2, + D_X = D_X_res$r2) - # Organize reduced form predicted values + # Predictions and per-learner residuals oos_pred <- list(EY_D0_X = g_X_byD[, , 1], EY_D1_X = g_X_byD[, , 2], ED_X = m_X) + oos_resid_bylearner <- list( + y_X_D0 = y_X_D0_res$oos_resid_bylearner, + y_X_D1 = y_X_D1_res$oos_resid_bylearner, + D_X = D_X_res$oos_resid_bylearner) # Organize output ddml_fit <- list(ate = ate, weights = weights, mspe = mspe, @@ -285,7 +290,10 @@ ddml_ate <- function(y, D, X, sample_folds = sample_folds, cv_folds = if (shortstack) NULL else cv_folds, - shortstack = shortstack) + shortstack = shortstack, + oos_resid_bylearner = + oos_resid_bylearner, + r2 = r2) # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) diff --git a/R/ddml_att.R b/R/ddml_att.R index 7c0eaa4..910bd86 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -138,16 +138,21 @@ ddml_att <- function(y, D, X, }) coef_names <- "ATT" - # Organize complementary ensemble output + # Ensemble metrics 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) + r2 <- list(y_X_D0 = y_X_D0_res$r2, + D_X = D_X_res$r2) - # Organize reduced form predicted values - oos_pred <- list(EY_D0_X = g_X_D0, ED_X = m_X, ED = D_res$oos_fitted) + # Predictions and per-learner residuals + oos_pred <- list(EY_D0_X = g_X_D0, + ED_X = m_X, + ED = D_res$oos_fitted) + oos_resid_bylearner <- list( + y_X_D0 = y_X_D0_res$oos_resid_bylearner, + D_X = D_X_res$oos_resid_bylearner) # Organize output ddml_fit <- list(att = att, weights = weights, mspe = mspe, @@ -168,7 +173,10 @@ ddml_att <- function(y, D, X, sample_folds = sample_folds, cv_folds = if (shortstack) NULL else cv_folds, - shortstack = shortstack) + shortstack = shortstack, + oos_resid_bylearner = + oos_resid_bylearner, + r2 = r2) # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index 8a58d40..b5519ed 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -338,20 +338,29 @@ ddml_fpliv <- function(y, D, Z, X, coef_names <- rownames(coef) }#IF - # Store complementary ensemble output + # Ensemble metrics and per-learner residuals weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) + r2 <- list(y_X = y_X_res$r2) + oos_resid_bylearner <- list( + y_X = y_X_res$oos_resid_bylearner) for (k in seq_len(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 + weights[[paste0("D", k, "_X")]] <- + D_X_res_list[[k]]$weights }#IFELSE - #mspe[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$mspe }#FOR for (k in seq_len(nD)){ - weights[[paste0("D", k, "_XZ")]] <- D_XZ_res_list[[k]]$weights - mspe[[paste0("D", k, "_XZ")]] <- D_XZ_res_list[[k]]$mspe + weights[[paste0("D", k, "_XZ")]] <- + D_XZ_res_list[[k]]$weights + mspe[[paste0("D", k, "_XZ")]] <- + D_XZ_res_list[[k]]$mspe + r2[[paste0("D", k, "_XZ")]] <- + D_XZ_res_list[[k]]$r2 + oos_resid_bylearner[[paste0("D", k, "_XZ")]] <- + D_XZ_res_list[[k]]$oos_resid_bylearner }#FOR # Organize output @@ -373,7 +382,10 @@ ddml_fpliv <- function(y, D, Z, X, sample_folds = sample_folds, cv_folds = if (shortstack) NULL else cv_folds, - shortstack = shortstack) + shortstack = shortstack, + oos_resid_bylearner = + oos_resid_bylearner, + r2 = r2) # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) diff --git a/R/ddml_late.R b/R/ddml_late.R index 62e32a5..72c99b4 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -337,24 +337,35 @@ ddml_late <- function(y, D, Z, X, }) coef_names <- "LATE" - # Organize complementary ensemble output + # Ensemble metrics 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) - - # 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) + r2 <- list(y_X_Z0 = y_X_Z0_res$r2, + y_X_Z1 = y_X_Z1_res$r2, + D_X_Z0 = D_X_Z0_res$r2, + D_X_Z1 = D_X_Z1_res$r2, + Z_X = Z_X_res$r2) - # 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], + # Predictions and per-learner residuals + 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) + oos_resid_bylearner <- list( + y_X_Z0 = y_X_Z0_res$oos_resid_bylearner, + y_X_Z1 = y_X_Z1_res$oos_resid_bylearner, + D_X_Z0 = D_X_Z0_res$oos_resid_bylearner, + D_X_Z1 = D_X_Z1_res$oos_resid_bylearner, + Z_X = Z_X_res$oos_resid_bylearner) # Organize output ddml_fit <- list(late = late, weights = weights, mspe = mspe, @@ -376,7 +387,10 @@ ddml_late <- function(y, D, Z, X, sample_folds = sample_folds, cv_folds = if (shortstack) NULL else cv_folds, - shortstack = shortstack) + shortstack = shortstack, + oos_resid_bylearner = + oos_resid_bylearner, + r2 = r2) # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index dd4bb39..01ad5e3 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -276,16 +276,31 @@ ddml_pliv <- function(y, D, Z, X, coef_names <- rownames(coef) }#IF - # Store complementary ensemble output + # Ensemble metrics and per-learner residuals weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) + r2 <- list(y_X = y_X_res$r2) + oos_resid_bylearner <- list( + y_X = y_X_res$oos_resid_bylearner) for (k in seq_len(nD)){ - weights[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$weights - mspe[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$mspe + weights[[paste0("D", k, "_X")]] <- + D_X_res_list[[k]]$weights + mspe[[paste0("D", k, "_X")]] <- + D_X_res_list[[k]]$mspe + r2[[paste0("D", k, "_X")]] <- + D_X_res_list[[k]]$r2 + oos_resid_bylearner[[paste0("D", k, "_X")]] <- + D_X_res_list[[k]]$oos_resid_bylearner }#FOR for (k in seq_len(nZ)){ - weights[[paste0("Z", k, "_X")]] <- Z_X_res_list[[k]]$weights - mspe[[paste0("Z", k, "_X")]] <- Z_X_res_list[[k]]$mspe + weights[[paste0("Z", k, "_X")]] <- + Z_X_res_list[[k]]$weights + mspe[[paste0("Z", k, "_X")]] <- + Z_X_res_list[[k]]$mspe + r2[[paste0("Z", k, "_X")]] <- + Z_X_res_list[[k]]$r2 + oos_resid_bylearner[[paste0("Z", k, "_X")]] <- + Z_X_res_list[[k]]$oos_resid_bylearner }#FOR # Organize output @@ -306,7 +321,10 @@ ddml_pliv <- function(y, D, Z, X, sample_folds = sample_folds, cv_folds = if (shortstack) NULL else cv_folds, - shortstack = shortstack) + shortstack = shortstack, + oos_resid_bylearner = + oos_resid_bylearner, + r2 = r2) # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) diff --git a/R/ddml_plm.R b/R/ddml_plm.R index 3dec72d..3bab495 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -299,12 +299,21 @@ ddml_plm <- function(y, D, X, coef_names <- rownames(coef) }#IF - # Store complementary ensemble output + # Ensemble metrics and per-learner residuals weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) + r2 <- list(y_X = y_X_res$r2) + oos_resid_bylearner <- list( + y_X = y_X_res$oos_resid_bylearner) for (k in seq_len(nD)){ - weights[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$weights - mspe[[paste0("D", k, "_X")]] <- D_X_res_list[[k]]$mspe + weights[[paste0("D", k, "_X")]] <- + D_X_res_list[[k]]$weights + mspe[[paste0("D", k, "_X")]] <- + D_X_res_list[[k]]$mspe + r2[[paste0("D", k, "_X")]] <- + D_X_res_list[[k]]$r2 + oos_resid_bylearner[[paste0("D", k, "_X")]] <- + D_X_res_list[[k]]$oos_resid_bylearner }#FOR # Organize output @@ -324,7 +333,10 @@ ddml_plm <- function(y, D, X, sample_folds = sample_folds, cv_folds = if (shortstack) NULL else cv_folds, - shortstack = shortstack) + shortstack = shortstack, + oos_resid_bylearner = + oos_resid_bylearner, + r2 = r2) # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) diff --git a/R/diagnostics.R b/R/diagnostics.R new file mode 100644 index 0000000..5f39c85 --- /dev/null +++ b/R/diagnostics.R @@ -0,0 +1,263 @@ +#' 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 alpha Significance level for the model confidence +#' set. Default 0.05. +#' @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")] +#' plm_fit = ddml_plm(y, D, X, +#' learners = list(what = ols), +#' sample_folds = 2, silent = TRUE) +#' diagnostics(plm_fit) +#' tidy(diagnostics(plm_fit)) +#' } +#' +#' @export +diagnostics <- function(object, cvc = FALSE, + bootnum = 500, alpha = 0.05, + ...) { + if (!inherits(object, "ddml")) { + stop("object must be of class 'ddml'.") + }#IF + + eq_names <- names(object$weights) + single_learner <- "what" %in% names(object$learners) + tables <- list() + + for (eq in eq_names) { + w <- object$weights[[eq]] + m <- object$mspe[[eq]] + r <- object$r2[[eq]] + + # Build per-learner table + if (single_learner) { + m_val <- if (is.null(m) || length(m) == 0) { + NA_real_ + } else { + as.numeric(m[1]) + }#IFELSE + r_val <- if (is.null(r) || length(r) == 0) { + NA_real_ + } else { + as.numeric(r[1]) + }#IFELSE + tbl <- data.frame( + learner = "single", + mspe = m_val, + r2 = r_val, + weight = 1, + stringsAsFactors = FALSE) + } else { + nlearners <- nrow(w) + learner_names <- paste0("learner_", seq_len(nlearners)) + + # 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 + + # MSPE: average across folds if matrix + if (is.matrix(m) && ncol(m) > 1) { + m_avg <- rowMeans(m) + } else { + m_avg <- as.numeric(m) + }#IFELSE + + # R-squared: average across folds if matrix + if (is.matrix(r) && ncol(r) > 1) { + r_avg <- rowMeans(r) + } else { + r_avg <- as.numeric(r) + }#IFELSE + + # Use first ensemble type weights for display + w_display <- if (ncol(w_avg) >= 1) { + w_avg[, 1] + } else { + rep(NA_real_, nlearners) + }#IFELSE + + tbl <- data.frame( + learner = learner_names, + mspe = m_avg, + r2 = r_avg, + weight = w_display, + stringsAsFactors = FALSE, + row.names = NULL) + }#IFELSE + + # CVC p-values (opt-in) + if (cvc && !single_learner) { + resid <- object$oos_resid_bylearner[[eq]] + subs <- get_diag_subsamples(object, eq) + if (!is.null(resid) && !is.null(subs) && + ncol(resid) > 1) { + cvc_res <- cvc_test(resid, subs, bootnum, alpha) + tbl$cvc_pval <- cvc_res$pvalues + tbl$in_conf_set <- cvc_res$confidence_set + } else { + tbl$cvc_pval <- NA_real_ + tbl$in_conf_set <- NA + }#IFELSE + }#IF + + tables[[eq]] <- tbl + }#FOR + + result <- list( + tables = tables, + model_type = class(object)[1], + nobs = object$nobs, + shortstack = object$shortstack, + cvc = cvc, + alpha = alpha) + class(result) <- "ddml_diagnostics" + result +}#DIAGNOSTICS + +# Resolve the correct subsamples for a given equation. +get_diag_subsamples <- function(object, eq) { + model <- class(object)[1] + if (model %in% c("ddml_plm", "ddml_pliv", + "ddml_fpliv")) { + return(object$subsamples) + }#IF + if (model %in% c("ddml_ate", "ddml_att")) { + if (grepl("D0", eq)) return(object$subsamples_byD[[1]]) + if (grepl("D1", eq)) return(object$subsamples_byD[[2]]) + return(merge_subsamples(object$subsamples_byD)) + }#IF + if (model == "ddml_late") { + if (grepl("Z0", eq)) return(object$subsamples_byZ[[1]]) + if (grepl("Z1", eq)) return(object$subsamples_byZ[[2]]) + return(merge_subsamples(object$subsamples_byZ)) + }#IF + object$subsamples +}#GET_DIAG_SUBSAMPLES + +# Reconstruct full-sample folds from stratified folds. +merge_subsamples <- function(subsamples_by) { + K <- length(subsamples_by[[1]]) + lapply(seq_len(K), function(k) { + sort(unlist(lapply(subsamples_by, + function(s) s[[k]]))) + }) +}#MERGE_SUBSAMPLES + +#' 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, ...) { + type_labels <- c( + ddml_plm = "Partially Linear Model", + ddml_pliv = "Partially Linear IV Model", + ddml_fpliv = + "Flexible Partially Linear IV Model", + ddml_ate = "Average Treatment Effect", + ddml_att = + "Average Treatment Effect on the Treated", + ddml_late = "Local Average Treatment Effect") + model_name <- type_labels[x$model_type] + if (is.na(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 + for (col in c("mspe", "r2", "weight", "cvc_pval")) { + if (col %in% names(display)) { + display[[col]] <- round(display[[col]], digits) + }#IF + }#FOR + if ("in_conf_set" %in% names(display)) { + display$in_conf_set <- NULL + }#IF + + print(display, row.names = FALSE, right = TRUE) + cat("\n") + }#FOR + + if (x$cvc && !is.null(x$shortstack) && x$shortstack) { + cat("Note: CVC compares individual base learners.", + "\nShortstacked ensemble CVC is not available", + "(weights use all data).\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} and +#' \code{in_conf_set}. +#' +#' @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(diagnostics(plm_fit)) +#' } +#' +#' @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 562a867..acc98bb 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -28,7 +28,23 @@ #' @export #' #' @examples -#' # Not run +#' \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(fun = ols), +#' list(fun = mdl_glmnet), +#' list(fun = 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, Z = NULL, type = "average", learners, @@ -168,7 +184,19 @@ predict.ensemble <- function(object, newdata, newZ = NULL, ...){ #' @export #' #' @examples -#' # Not run +#' \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(fun = ols), +#' list(fun = mdl_glmnet)), +#' cv_folds = 5, +#' silent = TRUE) +#' ew$weights +#' } ensemble_weights <- function(y, X, Z = NULL, type = "average", learners, diff --git a/R/get_CEF.R b/R/get_CEF.R index 9858ea4..915fa3a 100644 --- a/R/get_CEF.R +++ b/R/get_CEF.R @@ -1,4 +1,18 @@ -# Wrapper for [ddml::crosspred()] and [ddml::shortstacking()]. +# 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 Z Optional instrument matrix. +# @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, Z = NULL, learners, ensemble_type, @@ -54,7 +68,14 @@ get_CEF <- function(y, X, Z = NULL, return(res) }#GET_CEF -# Construct CEF from auxiliary_X +# 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 of get_CEF results, one per D 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) diff --git a/R/methods.R b/R/methods.R index e3fa824..9b73c70 100644 --- a/R/methods.R +++ b/R/methods.R @@ -6,6 +6,18 @@ #' @return Named vector (single ensemble) or matrix #' (multiple ensembles). #' +#' @examples +#' \donttest{ +#' # Fit a PLM and extract coefficients +#' 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) +#' coef(plm_fit) +#' } +#' #' @export coef.ddml <- function(object, ...) { cf <- object$coefficients @@ -29,6 +41,18 @@ coef.ddml <- function(object, ...) { #' #' @return A p x p variance-covariance matrix. #' +#' @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) +#' vcov(plm_fit) +#' vcov(plm_fit, type = "HC3") +#' } +#' #' @export vcov.ddml <- function(object, ensemble_idx = 1, type = "HC1", ...) { @@ -46,15 +70,23 @@ vcov.ddml <- function(object, ensemble_idx = 1, #' @param object An object of class \code{ddml}. #' @param parm Not used (included for generic compatibility). #' @param level Confidence level. Default 0.95. -#' @param ensemble_idx Integer index of the ensemble type to -#' use. Defaults to 1 (first ensemble type). -#' @param type Character string specifying the -#' variance-covariance estimator. One of \code{"HC1"} -#' (default), \code{"HC0"}, or \code{"HC3"}. +#' @inheritParams vcov.ddml #' @param ... Currently unused. #' #' @return A matrix with columns for lower and upper bounds. #' +#' @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) +#' confint(plm_fit) +#' confint(plm_fit, level = 0.90) +#' } +#' #' @importFrom stats vcov #' @export confint.ddml <- function(object, parm, level = 0.95, @@ -90,6 +122,18 @@ confint.ddml <- function(object, parm, level = 0.95, #' #' @return An object of class \code{summary.ddml}. #' +#' @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") +#' } +#' #' @export summary.ddml <- function(object, type = "HC1", ...) { type <- match.arg(type, c("HC0", "HC1", "HC3")) diff --git a/R/shortstacking.R b/R/shortstacking.R index b502240..04426e0 100644 --- a/R/shortstacking.R +++ b/R/shortstacking.R @@ -169,15 +169,22 @@ shortstacking <- function(y, X, Z = NULL, }#IF }#IF - # Compute mspe + # Compute mspe and r-squared mspe <- colMeans((matrix(shortstack_y, nobs, nensb) - oos_fitted)^2) + y_var <- as.numeric(stats::var(shortstack_y)) + r2 <- if (y_var > 0) 1 - mspe / y_var else rep(NA_real_, + length(mspe)) + + # Per-learner OOS residuals (already computed for weight estimation) + oos_resid_bylearner <- as.matrix(fakecv$oos_resid) # return shortstacking output output <- list(oos_fitted = oos_fitted, - weights = weights, mspe = mspe, + weights = weights, mspe = mspe, r2 = r2, is_fitted = is_fitted, auxiliary_fitted = auxiliary_fitted, oos_fitted_bylearner = res$oos_fitted_bylearner, + oos_resid_bylearner = oos_resid_bylearner, is_fitted_bylearner = res$is_fitted_bylearner, auxiliary_fitted_bylearner = res$auxiliary_fitted_bylearner) return(output) diff --git a/R/tidy.R b/R/tidy.R index 466ee82..164d01f 100644 --- a/R/tidy.R +++ b/R/tidy.R @@ -32,6 +32,18 @@ generics::glance #' \code{conf.int = TRUE}, also \code{conf.low} and #' \code{conf.high}. #' +#' @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) +#' } +#' #' @family ddml #' @export #' @method tidy ddml @@ -85,6 +97,17 @@ tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, #' \code{nobs}, \code{sample_folds}, \code{shortstack}, #' \code{ensemble_type}, 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) +#' } +#' #' @family ddml #' @export #' @method glance ddml diff --git a/man/coef.ddml.Rd b/man/coef.ddml.Rd index 1b27880..413f914 100644 --- a/man/coef.ddml.Rd +++ b/man/coef.ddml.Rd @@ -18,3 +18,16 @@ Named vector (single ensemble) or matrix \description{ Extract Model Coefficients } +\examples{ +\donttest{ +# Fit a PLM and extract coefficients +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) +coef(plm_fit) +} + +} diff --git a/man/confint.ddml.Rd b/man/confint.ddml.Rd index 88a4c11..28bd8ce 100644 --- a/man/confint.ddml.Rd +++ b/man/confint.ddml.Rd @@ -18,7 +18,9 @@ use. Defaults to 1 (first ensemble type).} \item{type}{Character string specifying the variance-covariance estimator. One of \code{"HC1"} -(default), \code{"HC0"}, or \code{"HC3"}.} +(default, degrees-of-freedom corrected), \code{"HC0"} +(uncorrected), or \code{"HC3"} (score-based leverage +adjustment for finite-sample robustness).} \item{...}{Currently unused.} } @@ -28,3 +30,16 @@ A matrix with columns for lower and upper bounds. \description{ Confidence Intervals for DDML Estimators } +\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) +confint(plm_fit) +confint(plm_fit, level = 0.90) +} + +} diff --git a/man/diagnostics.Rd b/man/diagnostics.Rd new file mode 100644 index 0000000..960f72d --- /dev/null +++ b/man/diagnostics.Rd @@ -0,0 +1,47 @@ +% 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, alpha = 0.05, ...) +} +\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{alpha}{Significance level for the model confidence +set. Default 0.05.} + +\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")] +plm_fit = ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, silent = TRUE) +diagnostics(plm_fit) +tidy(diagnostics(plm_fit)) +} + +} diff --git a/man/glance.ddml.Rd b/man/glance.ddml.Rd index 8e08cbb..82b9b78 100644 --- a/man/glance.ddml.Rd +++ b/man/glance.ddml.Rd @@ -20,6 +20,18 @@ A one-row \code{data.frame} with columns Returns a one-row summary of model-level statistics, compatible with \pkg{modelsummary} and the \pkg{broom} ecosystem. +} +\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) +} + } \seealso{ Other ddml: 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/summary.ddml.Rd b/man/summary.ddml.Rd index 17df6c4..99f736e 100644 --- a/man/summary.ddml.Rd +++ b/man/summary.ddml.Rd @@ -23,3 +23,16 @@ An object of class \code{summary.ddml}. \description{ Summary for DDML Estimators } +\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") +} + +} diff --git a/man/tidy.ddml.Rd b/man/tidy.ddml.Rd index b048098..d9ae766 100644 --- a/man/tidy.ddml.Rd +++ b/man/tidy.ddml.Rd @@ -44,6 +44,19 @@ Extracts coefficient estimates, standard errors, test statistics, and p-values from a \code{ddml} estimator in a format compatible with \pkg{modelsummary} and the \pkg{broom} ecosystem. +} +\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) +} + } \seealso{ Other ddml: diff --git a/man/tidy.ddml_diagnostics.Rd b/man/tidy.ddml_diagnostics.Rd new file mode 100644 index 0000000..e7ca2a3 --- /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} and +\code{in_conf_set}. +} +\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")] +plm_fit = ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, silent = TRUE) +tidy(diagnostics(plm_fit)) +} + +} diff --git a/man/vcov.ddml.Rd b/man/vcov.ddml.Rd index 479471c..292bb24 100644 --- a/man/vcov.ddml.Rd +++ b/man/vcov.ddml.Rd @@ -26,3 +26,16 @@ A p x p variance-covariance matrix. \description{ Variance-Covariance Matrix for DDML Estimators } +\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) +vcov(plm_fit) +vcov(plm_fit, type = "HC3") +} + +} diff --git a/tests/testthat/test-cvc.R b/tests/testthat/test-cvc.R new file mode 100644 index 0000000..ebd4b3b --- /dev/null +++ b/tests/testthat/test-cvc.R @@ -0,0 +1,87 @@ +test_that("cvc_pairwise detects a dominant learner", { + set.seed(42) + n <- 500 + # Learner 1 has small residuals, learner 2 has large residuals + resid1 <- rnorm(n, sd = 0.5) + resid2 <- rnorm(n, sd = 2.0) + fid <- rep(seq_len(5), each = n / 5) + + # zeta = resid1^2 - resid2^2 < 0 when learner 1 is better + # → Tx < 0 → p-value near 1 (cannot reject that 1 is worse) + pval_12 <- cvc_pairwise(resid1, resid2, fid, bootnum = 500) + expect_true(pval_12 > 0.9) + + # Reversed: learner 2 worse → p-value near 0 + pval_21 <- cvc_pairwise(resid2, resid1, fid, bootnum = 500) + expect_true(pval_21 < 0.1) +}) + +test_that("cvc_pairwise moderate for equal learners", { + set.seed(123) + n <- 1000 + resid1 <- rnorm(n) + resid2 <- rnorm(n) + fid <- rep(seq_len(5), each = n / 5) + + pval <- cvc_pairwise(resid1, resid2, fid, bootnum = 500) + + expect_true(pval > 0.05 && pval < 0.95) +}) + +test_that("cvc_pairwise returns NA for identical residuals", { + n <- 100 + resid <- rnorm(n) + fid <- rep(seq_len(5), each = n / 5) + + pval <- cvc_pairwise(resid, resid, fid, bootnum = 100) + expect_true(is.na(pval)) +}) + +test_that("cvc_confidence_set includes the best learner", { + set.seed(42) + n <- 500 + resid_mat <- cbind( + rnorm(n, sd = 0.5), + rnorm(n, sd = 1.5), + rnorm(n, sd = 2.0)) + fid <- rep(seq_len(5), each = n / 5) + + cs <- cvc_confidence_set(resid_mat, fid, + bootnum = 500, alpha = 0.10) + + expect_length(cs$pvalues, 3) + expect_length(cs$confidence_set, 3) + # Best learner (column 1) should be in the confidence set + expect_true(cs$confidence_set[1]) +}) + +test_that("cvc_test returns correct structure", { + set.seed(42) + n <- 200 + resid_mat <- cbind(rnorm(n), rnorm(n), rnorm(n)) + colnames(resid_mat) <- c("ols", "lasso", "ridge") + subsamples <- list(1:100, 101:200) + + res <- cvc_test(resid_mat, subsamples, + bootnum = 100, alpha = 0.05) + + expect_true(is.list(res)) + expect_equal(dim(res$pairwise), c(3, 3)) + expect_true(all(is.na(diag(res$pairwise)))) + expect_length(res$pvalues, 3) + expect_length(res$confidence_set, 3) + expect_identical(rownames(res$pairwise), + c("ols", "lasso", "ridge")) +}) + +test_that("cvc_test handles unequal fold sizes", { + set.seed(42) + n <- 103 + resid_mat <- cbind(rnorm(n), rnorm(n)) + subsamples <- list(1:51, 52:103) + + res <- cvc_test(resid_mat, subsamples, bootnum = 100) + + expect_equal(dim(res$pairwise), c(2, 2)) + expect_length(res$pvalues, 2) +}) diff --git a/tests/testthat/test-diagnostics.R b/tests/testthat/test-diagnostics.R new file mode 100644 index 0000000..1ca9860 --- /dev/null +++ b/tests/testthat/test-diagnostics.R @@ -0,0 +1,157 @@ +test_that("diagnostics works with PLM single learner", { + 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) + + suppressWarnings({ + 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 <- 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) + + learners <- list(list(fun = ols), list(fun = ols)) + suppressWarnings({ + fit <- ddml_plm(y, D, X, + learners = learners, + ensemble_type = c("nnls1"), + sample_folds = 2, + silent = TRUE) + }) + + diag <- diagnostics(fit) + + # Should have 2 learners per equation + for (eq in names(diag$tables)) { + expect_equal(nrow(diag$tables[[eq]]), 2) + } + + # Weights should sum to ~1 + for (eq in names(diag$tables)) { + expect_equal(sum(diag$tables[[eq]]$weight), 1, + tolerance = 1e-4) + } +}) + +test_that("tidy.ddml_diagnostics returns flat data.frame", { + 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) + + suppressWarnings({ + 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 <- 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) + + learners <- list(list(fun = ols), list(fun = ols)) + suppressWarnings({ + 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 columns should be present + for (eq in names(diag$tables)) { + expect_true("cvc_pval" %in% colnames(diag$tables[[eq]])) + expect_true("in_conf_set" %in% + colnames(diag$tables[[eq]])) + } + + # tidy should include CVC columns + td <- tidy(diag) + expect_true("cvc_pval" %in% colnames(td)) +}) + +test_that("diagnostics works with ATE", { + set.seed(42) + nobs <- 100 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D_tld <- X %*% runif(3) + rnorm(nobs) + D <- 1 * (D_tld > mean(D_tld)) + y <- D + X %*% runif(3) + rnorm(nobs) + + suppressWarnings({ + 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 <- 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(fun = ols), list(fun = ols)) + suppressWarnings({ + 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") +}) diff --git a/tests/testthat/test-tidy.R b/tests/testthat/test-tidy.R index 60f6688..05996aa 100644 --- a/tests/testthat/test-tidy.R +++ b/tests/testthat/test-tidy.R @@ -42,3 +42,64 @@ test_that("tidy and glance broom formatters work correctly", { 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 <- 100 + X <- cbind(1, matrix(rnorm(nobs * 4), nobs, 4)) + D_tld <- X %*% runif(5) + rnorm(nobs) + D <- 1 * (D_tld > mean(D_tld)) + y <- D + X %*% runif(5) + rnorm(nobs) + + learners <- list(list(fun = ols), list(fun = ols)) + suppressWarnings({ + 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 <- 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) + + suppressWarnings({ + 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), 1) + expect_true("term" %in% colnames(td)) + + gl <- glance(fit) + expect_equal(gl$model_type, "ddml_plm") + expect_equal(gl$nobs, nobs) +}) diff --git a/vignettes/articles/did.Rmd b/vignettes/articles/did.Rmd index 4a6a0c9..67ac322 100644 --- a/vignettes/articles/did.Rmd +++ b/vignettes/articles/did.Rmd @@ -61,18 +61,18 @@ summary(attgt_lm) #> #> 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 +#> 2004 2004 -0.0145 0.0214 -0.0718 0.0427 +#> 2004 2005 -0.0764 0.0313 -0.1601 0.0072 +#> 2004 2006 -0.1404 0.0397 -0.2465 -0.0344 * +#> 2004 2007 -0.1069 0.0373 -0.2065 -0.0073 * +#> 2006 2004 -0.0005 0.0223 -0.0599 0.0590 +#> 2006 2005 -0.0062 0.0192 -0.0574 0.0450 +#> 2006 2006 0.0010 0.0199 -0.0523 0.0542 +#> 2006 2007 -0.0413 0.0191 -0.0924 0.0098 +#> 2007 2004 0.0267 0.0136 -0.0096 0.0630 +#> 2007 2005 -0.0046 0.0171 -0.0503 0.0411 +#> 2007 2006 -0.0284 0.0169 -0.0735 0.0166 +#> 2007 2007 -0.0288 0.0173 -0.0749 0.0174 #> --- #> Signif. codes: `*' confidence band does not cover 0 #> @@ -109,18 +109,18 @@ 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.0196 -0.1188 -0.0419 * #> #> #> 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 * +#> -3 0.0267 0.0143 -0.0092 0.0627 +#> -2 -0.0036 0.0134 -0.0373 0.0301 +#> -1 -0.0232 0.0147 -0.0603 0.0138 +#> 0 -0.0211 0.0127 -0.0529 0.0108 +#> 1 -0.0530 0.0165 -0.0946 -0.0114 * +#> 2 -0.1404 0.0349 -0.2281 -0.0528 * +#> 3 -0.1069 0.0333 -0.1907 -0.0231 * #> --- #> Signif. codes: `*' confidence band does not cover 0 #> @@ -201,22 +201,6 @@ attgt_xgboost <- att_gt(yname = "lemp", 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) @@ -229,22 +213,22 @@ summary(attgt_xgboost) #> #> 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 +#> 2004 2004 -3.1503 7.2324 -20.7101 14.4095 +#> 2004 2005 -9.3142 11.6485 -37.5962 18.9677 +#> 2004 2006 -2.4850 11.1398 -29.5317 24.5617 +#> 2004 2007 17.8616 13.8177 -15.6868 51.4101 +#> 2006 2004 12.5594 6.1206 -2.3011 27.4200 +#> 2006 2005 6.0290 3.8927 -3.4222 15.4802 +#> 2006 2006 -1.1808 3.7726 -10.3405 7.9789 +#> 2006 2007 -4.7042 10.0708 -29.1554 19.7469 +#> 2007 2004 -2.8007 14.3252 -37.5814 31.9799 +#> 2007 2005 6.4227 16.4851 -33.6021 46.4476 +#> 2007 2006 2.6596 17.5628 -39.9817 45.3009 +#> 2007 2007 -15.0061 20.3873 -64.5052 34.4929 #> --- #> Signif. codes: `*' confidence band does not cover 0 #> -#> P-value for pre-test of parallel trends assumption: 0.97672 +#> P-value for pre-test of parallel trends assumption: 0.46872 #> Control Group: Never Treated, Anticipation Periods: 0 # plot the coefficients @@ -272,18 +256,18 @@ summary(dyn_xgboost) #> #> 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 +#> -0.4334 6.6254 -13.419 12.5522 #> #> #> 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 +#> -3 -2.8007 14.6781 -34.8946 29.2931 +#> -2 7.8582 12.8711 -20.2846 36.0011 +#> -1 3.4478 13.6719 -26.4462 33.3417 +#> 0 -10.8693 15.3861 -44.5113 22.7726 +#> 1 -6.2409 8.0050 -23.7441 11.2623 +#> 2 -2.4850 11.2198 -27.0174 22.0474 +#> 3 17.8616 12.8811 -10.3031 46.0263 #> --- #> Signif. codes: `*' confidence band does not cover 0 #> @@ -372,14 +356,6 @@ attgt_stacking <- att_gt(yname = "lemp", 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) @@ -392,22 +368,22 @@ summary(attgt_stacking) #> #> 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 +#> 2004 2004 -0.0110 0.0228 -0.0718 0.0498 +#> 2004 2005 -0.0761 0.0311 -0.1588 0.0066 +#> 2004 2006 -0.1408 0.0400 -0.2473 -0.0343 * +#> 2004 2007 -0.1051 0.0350 -0.1982 -0.0120 * +#> 2006 2004 -0.0040 0.0219 -0.0624 0.0544 +#> 2006 2005 -0.0067 0.0194 -0.0584 0.0449 +#> 2006 2006 -0.0010 0.0196 -0.0532 0.0512 +#> 2006 2007 -0.0409 0.0197 -0.0934 0.0115 +#> 2007 2004 0.0234 0.0141 -0.0141 0.0609 +#> 2007 2005 -0.0026 0.0159 -0.0450 0.0398 +#> 2007 2006 -0.0299 0.0178 -0.0772 0.0175 +#> 2007 2007 -0.0285 0.0166 -0.0728 0.0158 #> --- #> Signif. codes: `*' confidence band does not cover 0 #> -#> P-value for pre-test of parallel trends assumption: 0.24863 +#> P-value for pre-test of parallel trends assumption: 0.27165 #> Control Group: Never Treated, Anticipation Periods: 0 # plot the coefficients @@ -436,18 +412,18 @@ summary(dyn_stacking) #> #> 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 * +#> -0.0799 0.0202 -0.1194 -0.0403 * #> #> #> 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 * +#> -3 0.0234 0.0134 -0.0109 0.0577 +#> -2 -0.0029 0.0132 -0.0366 0.0307 +#> -1 -0.0245 0.0135 -0.0589 0.0100 +#> 0 -0.0209 0.0122 -0.0520 0.0103 +#> 1 -0.0527 0.0161 -0.0938 -0.0115 * +#> 2 -0.1408 0.0378 -0.2373 -0.0444 * +#> 3 -0.1051 0.0331 -0.1897 -0.0206 * #> --- #> Signif. codes: `*' confidence band does not cover 0 #> diff --git a/vignettes/articles/did.Rmd.txt b/vignettes/articles/did.Rmd.txt index 1033a4f..df4d6d2 100644 --- a/vignettes/articles/did.Rmd.txt +++ b/vignettes/articles/did.Rmd.txt @@ -13,7 +13,9 @@ knitr::opts_chunk$set( collapse = TRUE, comment = "#>", fig.path = "figures/", - eval = TRUE + eval = TRUE, + warning = FALSE, + message = FALSE ) ``` diff --git a/vignettes/articles/example_401k.Rmd b/vignettes/articles/example_401k.Rmd index 10ab396..3757df2 100644 --- a/vignettes/articles/example_401k.Rmd +++ b/vignettes/articles/example_401k.Rmd @@ -61,21 +61,46 @@ xgboost_fit <- ddml_plm(y = y, D = D, X = X, learners = list(what = mdl_xgboost, args = list(nrounds = 300)), sample_folds = 10, - silent = T) + silent = TRUE) summary(xgboost_fit) -#> PLM estimation results: -#> -#> , , single base learner +#> DDML estimation: Partially Linear Model +#> Obs: 9915 Folds: 10 #> -#> 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 t value Pr(>|t|) +#> D_r 12780 1526 8.38 <2e-16 *** +#> --- +#> 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 @@ -105,16 +130,16 @@ stacking_fit <- ddml_plm(y = y, D = D, X = X, learners = learners, ensemble_type = "nnls", sample_folds = 10, - shortstack = T, - silent = T) + shortstack = TRUE, + silent = TRUE) summary(stacking_fit) -#> PLM estimation results: -#> -#> , , nnls +#> DDML estimation: Partially Linear Model +#> Obs: 9915 Folds: 10 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 t value Pr(>|t|) +#> D_r 13700 1523 8.99 <2e-16 *** +#> --- +#> 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. @@ -122,12 +147,12 @@ To better understand which machine learners contribute to the final estimate, we ```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 +#> [1,] 0.2186 0.2850 +#> [2,] 0.0000 0.0000 +#> [3,] 0.1822 0.3859 +#> [4,] 0.6671 0.2911 +#> [5,] 0.0000 0.0548 +#> [6,] 0.0000 0.0000 ``` # Estimation with Different Sets of Control Variables @@ -178,16 +203,16 @@ stacking_fit <- ddml_plm(y = y, D = D, X = X_c, learners = learners, ensemble_type = "nnls", sample_folds = 10, - shortstack = T, - silent = T) + shortstack = TRUE, + silent = TRUE) summary(stacking_fit) -#> PLM estimation results: -#> -#> , , nnls +#> DDML estimation: Partially Linear Model +#> Obs: 9915 Folds: 10 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 t value Pr(>|t|) +#> D_r 14133 1480 9.55 <2e-16 *** +#> --- +#> 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. @@ -196,13 +221,13 @@ To assess whether the additional effort in expanding the control variables had a ```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 +#> [1,] 0.0000 0.0115 +#> [2,] 0.0593 0.2018 +#> [3,] 0.7312 0.3289 +#> [4,] 0.0000 0.1304 +#> [5,] 0.2274 0.3153 +#> [6,] 0.0134 0.0205 +#> [7,] 0.0000 0.0000 ``` # Estimation with Continious and Binary Outcome and Treatment Variables @@ -244,16 +269,16 @@ stacking_fit <- ddml_plm(y = y, D = D, X = X_c, learners_DX = learners_DX, ensemble_type = "nnls", sample_folds = 10, - shortstack = T, - silent = T) + shortstack = TRUE, + silent = TRUE) summary(stacking_fit) -#> PLM estimation results: -#> -#> , , nnls +#> DDML estimation: Partially Linear Model +#> Obs: 9915 Folds: 10 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 t value Pr(>|t|) +#> D_r 14163 1484 9.54 <2e-16 *** +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` The weights associated with the new base learners are now slightly larger: @@ -263,13 +288,13 @@ The weights associated with the new base learners are now slightly larger: ```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 +#> [1,] 0.0000 0.0539 +#> [2,] 0.0000 0.3156 +#> [3,] 0.7097 0.1155 +#> [4,] 0.0403 0.3328 +#> [5,] 0.2102 0.1297 +#> [6,] 0.0818 0.0643 +#> [7,] 0.0000 0.0000 ``` # Bonus: Instrumental Variable Estimation @@ -290,27 +315,27 @@ stacking_IV_fit <- ddml_pliv(y = y, D = D, Z = Z, X = X_c, learners_ZX = learners_DX, ensemble_type = "nnls", sample_folds = 10, - shortstack = T, - silent = T) + shortstack = TRUE, + silent = TRUE) summary(stacking_IV_fit) -#> PLIV estimation results: -#> -#> , , nnls +#> DDML estimation: Partially Linear IV Model +#> Obs: 9915 Folds: 10 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> (Intercept) -776 531 -1.46 1.44e-01 -#> D_r 12987 1872 6.94 3.97e-12 +#> Estimate Std. Error t value Pr(>|t|) +#> D_r 12711 1892 6.72 1.8e-11 *** +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 # 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 +#> [1,] 0.0000 0.0190 0.0000 +#> [2,] 0.0000 0.1696 0.4500 +#> [3,] 0.8302 0.2829 0.0000 +#> [4,] 0.0000 0.2693 0.3186 +#> [5,] 0.1681 0.2410 0.2291 +#> [6,] 0.0290 0.0188 0.0000 +#> [7,] 0.0000 0.0105 0.0131 ``` diff --git a/vignettes/articles/example_401k.Rmd.txt b/vignettes/articles/example_401k.Rmd.txt index 62ce5ed..2b8cf8a 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 ) ``` diff --git a/vignettes/articles/example_BLP95.Rmd b/vignettes/articles/example_BLP95.Rmd index 469cad9..360e3a9 100644 --- a/vignettes/articles/example_BLP95.Rmd +++ b/vignettes/articles/example_BLP95.Rmd @@ -149,10 +149,15 @@ 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 + silent = TRUE) +summary(lasso_fit) +#> DDML estimation: Flexible Partially Linear IV Model +#> Obs: 2217 Folds: 10 +#> +#> Estimate Std. Error t value Pr(>|t|) +#> D_r -0.14723 0.00901 -16.3 <2e-16 *** +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` # Estimating the Flexible Partially Linear IV Model with Multiple Learners @@ -199,12 +204,17 @@ stacking_fit <- ddml_fpliv(y, D = D, Z = Z_c, X = X_c, learners = learners, ensemble_type = c("nnls1"), - shortstack = T, + shortstack = TRUE, 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 + silent = TRUE) +summary(stacking_fit) +#> DDML estimation: Flexible Partially Linear IV Model +#> Obs: 2217 Folds: 10 Stacking: short-stack +#> +#> Estimate Std. Error t value Pr(>|t|) +#> D_r -0.08145 0.00764 -10.7 <2e-16 *** +#> --- +#> 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)! @@ -213,13 +223,13 @@ To better understand the composition of the final estimator, it is often useful ```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 +#> y_X D1_X D1_XZ +#> [1,] 0.0000 0.0000 0.0000 +#> [2,] 0.0002 0.0000 0.0000 +#> [3,] 0.0000 0.0000 0.0000 +#> [4,] 0.0000 0.0000 0.0000 +#> [5,] 0.4305 0.4593 0.3068 +#> [6,] 0.5693 0.5407 0.6932 ``` # Elasticities @@ -254,11 +264,11 @@ Double/debiased machine learning estimates using only a single lasso base learne ```r # ddml-lasso implied number of products with inelastic demand compute_inelastic_demand(lasso_fit$coef) -#> [1] 596 +#> [1] 598 # ddml-stacking implied number of products with inelastic demand compute_inelastic_demand(stacking_fit$coef) -#> [1] 1417 +#> [1] 1608 ``` # Bonus: Post-Lasso Estimates without Sample-Splitting @@ -308,12 +318,17 @@ stacking_r_fit <- ddml_fpliv(y, D = D, Z = Zr_, X = Xr_, learners = learner, ensemble_type = c("nnls1"), - shortstack = T, + shortstack = TRUE, 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 + silent = TRUE) +summary(stacking_r_fit) +#> DDML estimation: Flexible Partially Linear IV Model +#> Obs: 2217 Folds: 10 Stacking: short-stack +#> +#> Estimate Std. Error t value Pr(>|t|) +#> D_r -0.1079 0.0104 -10.4 <2e-16 *** +#> --- +#> 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. @@ -321,9 +336,9 @@ The similarity of the coefficient estimates to the initial stacking estimates su ```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 +#> y_X D1_X D1_XZ +#> [1,] 0.3116 0.1618 0.0621 +#> [2,] 0.6884 0.8382 0.9379 ``` 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. diff --git a/vignettes/articles/figures/unnamed-chunk-11-1.png b/vignettes/articles/figures/unnamed-chunk-11-1.png index 7c29411fe04cdb64b6b86e794d125ca440c2acf9..268220b1b5d54486fb68104f824d1a5457a73a88 100644 GIT binary patch literal 19668 zcmeHv2UwHYwsrzYk*bU$A|w_-r74O?j};LC8@)@FF1;pkunr1t6?45CJoY zvNA;39-@qa*cXFhR#pL40U1^SGgg@=psD~XctGljfEh!E6(S?RDq|)iWA;Sm2?Iz` zR<>8R2M3_PwBj|UG9k0;`Zv-nvC z0i#U7*b|DugCP(Y1O|hM%OK)PiFokfh@jpqcxH*S3?hRu7UDUJFP$agW{LP&&>Cbj ze;Bh22E$AMjD+#TjPc|Nqu3tEWe|!PKq3*xn8h<@L2ED{V3eTy%$G3M8%gRNE(M>3 z%j1l(7X%_!!~75G_Q6LT0)a!cP9D4LpD@)&i!>Xy9wiYukBGmOa3+6hnZA7CVujK0 z{@oWbJV*SOkJXPH+bXhp)F5xvNQJKg1dZ_NafhJgxi}%4piuZOIOHT78~P3!BCtsSvWtZUaS{Q! z!}(iu|DQ4AY07oUf;V2or%x;`|FBTgh&SSDvsM&#lo`I8S&BO?dy(?1MG zCMT-S-zEo_%{W2K%Dgt#d(;h}+{*?Vv8efEhR<9SmbPLWW*eB1}PaVb{hCA#y33J08y~B6@2AFV1L0ixE z2YE;@2V+EZVx3B%@tpA_zkY;O^k(P^a)uXVk*m~-y*cz{oE*TWvu*bZ(~CDxsPD}q0fsQC#QoSqob*5^xr z8hajkHWfe!6Heh^ATCOX`IN zj;XSG%Fi+yTajkzpPT(8yy(G*iQRiBUJ|gq`WmCP)X-F*b}6D5J){8fFVa@OvPi5rIIQQgVZaZU5eCaam@p_>*oyTUPx!oes% z4yl-PLfo8)r&-_DngioOQw*wPX8)l)T7OM>fcr=*(pM7!xhT59HW#+KsVV|(DKeP{E+`JGU`pLMf?A|+Ivt{e!SRW_{Uy+_rN zmKEOa9>WQ`7m4n5rr3-aQO2^<^K^@~EUw1gvux&SRajUACU(JVlb0=5y&DWAG$;{ObjOjwMMp79VN8bpYK@oz zKF-bVUWw|~n8R3FHA4~($&h7{Pk0|Ab~yQJ^|Irs%JGAr1OnVWoDdePjx+e%UaNKX zeXdpBC5d4rF)~*TsQnILO2AvPA`Xwf*_Q%gT_AdlxvA<@b6IKDzNvOaqYhN>u8y;%U= zEzV}UxOZ`RiD;6|Q@`Asah1p9mgc3?t;SMtKh1b4Fu?K~=%!*TPjmlyE3kF6JyzS~ z=k%H}!2#3h^fo|4#5`U;CX#AUlv21l+2&p-PZIWl>tsb#XXE zFC`4kgKBYap7T@Tt&FVA?G!jF%o7LaEk;UpMR-RwCbRagszwYJ@ z7M7VIpn{F9P^z{6^WK+v;BGJiF(J) zWtz+(fAxb&iI<;%=pdI_2gg|w8LMCvs6qMVCZtiq;k;P*G;Uiq?fON~QMNMb8A1d> zFvzQ<&ldsqp#ln55eY3V^QM=*-cj5cm6n5s43%xHADmxum~RWdhciR4CpQnYgxEWO zCIuCO9bY4Em_#UTr98h|UAYn^Yb+mf5GbklR!rnwh9z>57}$cGPi#ogfMKYdTC{`) zjy^+-2ldCM zchQik1pFliF3!iPRpa;}w+fDCzMM88VC5)i@B;yk z^LKCjDWm6iXYT(Be|ePZ#!_KbM*4WK64OQ`r82WjzT_MN;@dWn!I*8%^c{W{YnNx3 zYA4r}17^>+<$VTY*?`gnv?`LpuzET5qHKPNLhgak2?qb@Oy6-He$NtWphkl1Y#_3roIN=b9?U8gYL=6q@o` zkPG@37x90lDt=5w_jbPxr~s!E0_<-Kd*Rwz8xVSb&42l)Df(GaTg@cE_j06kFqZB0 z%jZ4{H?o5d6K0@G!8d->S>iIbrYvyBK|m@|0HOqNX5*o31KA+Z%s9 zG^{HU?UKK_>w5l;2ccn-a6#$?&`Tjb#Pg37c+o{k@dOTP~6%E}LHV<=SMkfveq2ggn21k?8(LXPVhH>8E%hQZ^&ti&^T*9 z_+A|D!b;ow_<>XmI)BT# z@3|~%V<-!?mU?{Sz1W8rT5GWWEU0!pid61*Su&xwV{ILxWl^4n`MKhoLroV z2iK*IKXt#dAMRbZE=K}t?fg~F9=Hqdx|~?H8#&gS_s0}SMWXW+z6$W%x|L9~-e5ma zE%Eitcb?+Pgm1lBs=4yd-6;iPtk%W+wXyx=^ThCwR~1vr#{Kwr{d#xjnL|Bv{)z1J z{oDjO<^-VMd$%R;t6pKw*-H93mWxN2xv2Mh;C6z)m35wa;qZFfv(I4S%v!=PjHnk5 zFtdLAhxz>b0i2H$5qUke^nN?fC6N7*vp)LZIq;GeF=t_(5=*j~no1xcpcEN`yP9g5Q>$mob zsj99p_$3I*`Tg%N zGIRA21_?KP)~FA`5$__*Y-PqFuc|ot)h2jTyh)(5pdo53lo%>5bdv{kEgYSHzkT|q zj}P6#=yv1kPI$f@+YO)WBr0sGxi@?%rT+=OH@U<&=i8KI+cdYb3bPNr*euY^#Zsdj zylZDZ0$~J95pK|olk@*$Vybvu#m=^Ja!wtA?gU5Vp8*U1>9GA1FysHqmJcpHr{9({ z(5Lj0ZVvM=CaqYxts8d+db9|4gCZ%pW*LntePFjprPIpBOpdR^=*zZ z9o&uguOF5Hc&`D6ZI7|hZTv}%cle8`JLU%BioZSqY34Djfd zi@1lhXEpTs^T&yrq{;z=*cmAXVB-%Xf5u=1C@I864dBinPa%|T$wuJV2B$=+tmhP! z?)qi*wH15b`Y9tn{O5jWL6CpbAWYMMu1qp4^etBlM>YBBGo;MSX!RE~dJkhxQHa5A z>{?m9O6=0~yFrg6TeOth#wsvAhs-8AWKE1S0+h%PhC7AJ<*F1)w*+x8W&#B<|!(Z*rE1d5=ut(MdDgG=b5~0C4Vf+01@a=Td?XLvtn`8)OpHxH+(58j}{T>f^=RU zFcSK*LOs@Zw=?ufj1+V{%7=rDq@>5t3}OpMx)aZx(bLda{(@><+kvwq*nZ4Lv5j4s z3fzo|WDI_eI3hWaK9J40bUVXrF2#T$y$7!La&eIMEZK6^zONvtbVbsEbJZqN%ZobY z)ftIio1N4Vy*-d3r>K!pRWW0=(1G>fNz>~Tt&po4#&uO0drj%uC%fmGam3h!YIz-? zZ5m9V?12l`V#Ba5Ri@-FMsp5Fs>9Jc{dx{O{V*(D5;Ys18EA4UaBQJKMYxP?@g<&k z*+DOk6#ihoqY%xLs=RV7o$u6Swbg>*E_kJP=U{k5?I-S!8V>i&X;>`%R$+eN_>`8{ z`K4#^N`(&4fPjTar^2fS)w3wFd6|4Fowqyp9aJ`$ZWHY6UbXhH4Uh0UA z97!qX#UyPQqI4B99)g zY0jE%wY#*D%biV=va-U#bA^FzD#?5hPJq<4GOSS(=`bIP zd}wt{q);Fwruk`5^N)u8qSH$Ocm3)E>=-dJy@p`7rH+*0-4nL>ZjI^Bew`tq=0QIkZv-@pBh!K4H{;8iV(t}*Q)*;(l;*zaah(SrAoN<|6+)Lu)tDm5r^+LE>VN+R2kMHZ}?7^vCi!H!z} z9wGB`IIokwJnpWEa(t(C$xqT$p!QrvpG#zgBC?0-9HuRyrL^)%kDkmR9#DQWQpQ<7 z2B{5d-(X3n#WU9OBJ6nw0~in>zxY4qYCi6ki*LpwWT38h0{kY%Lpy+2#wMA?gy`}w(8Ou zIrsBC*}4tP*=#-QZH~47IO0^*@L;NKF7UpkD5k9jAI}Giz9g<)?WtA+ZSg+)Py zEwc`WA8Sk>e{w%zXDv1wZ}4TSA+2kG^1eBg}->Q&YqNUR9b5S9 z+q9jd?Y8L_a*LWe(LmymB$|s8@fgf_QGmlLQbbo95%?QuzdpyKwyxWo(F z^~3c1%}Q5D_UKdf^G+y6PIWNibnpN8CmovVi%me4YyT6^aR_%<7F;2%~wuw_)bLm}sEY0b2Yk zf$xpL#0lB+s}^s9He$apOSjT5kys+RycgEqrd;?i(HjEd;qWCG2q1VvE@`^WRJLhYGVl}0tPTp7{HdW zP5=g#-U5Jj-uh!9h_|xRkRv?xV{gjPko=y5nCHNjePi!nEovZ0x&g4v>7F3~8$qqE z5T)8kH7qHG6TU;^@7!;Quf6~#bupuo6}TS0 zZ6i>nPw`kDFeknr>Tn1?p<*W7F68RJwR3h-o4OMYQE`l%MBE~X8;;DT4?^TjNkU`heOhwA<&;J-|Wnl#e_oV&h77e+>}^RRke2JQoI z@)^$Gr@#D5J`o65{g3sc$1fm|<#*@(k3o{qAj}Ao(GNF{b*=;6&m7p;eB;pqf&y08 z4f6S*(5;-DlL7)Qp@Q(@duWjHSruSV0PWZbfV@Ef5CVwegK#Jl78C`jAMo_n;flnA z{s4;lw^hRJyTqs!%E}C!UW{#IyD`k{RvM?`kq-?bMj$#D zo?xL$Rr+dPK{GQ$42`2cUtw_Irm|ej4ck!;VExd_^!{x;B}x`Q7aH}^>d%e_Zo61u3hA=sWV&`;u90~% zRjY)W&#jH{-?cuxVs$p#W*c}jh+rsv&q(8Uu#OGgXg{;@IqcNrDMX-$=pCgOz-zaq zUU+H2md0=RH2y~b|DI}(_z@s-Aa;_aJ$pT-YU`sP&k+#VSX=3UmXnbiTg&7rKqNHEr z4nRZq#h}lvkL#a=8wmyOJ_qpY_3>whRc^t4Q|Wyj8&KOGe^0cZLhUH{o`^)h`Yy_D zGv>(mex76bX#c&RT8K~Up%2i{<4W9F@0igKW-p>95%%BP0w|lxv)*` zx$Li_{ub$A4v$|piP`h_GX!Q#>Sm4v{L=Gyc}~uSxA)m?BbDm+u;t%F10Ig8CM(OE z$X~Z~{(#Zq5iKGzHpB}A#e&*@kv#Z6VE6nv;P)RBnT|`QMw~8BvoH$a8S=1RWuA3y zndt1J+>^@`ahiYtTJ%+e54_f^Ft-JE5e6(b*-t}f7piBgABG)Yk8!S(CRT#1MP+c{U7kv|A2!3A@=Kk+feF% zKBQ{qID%S(nE@1Nw^CL*{cBuhBpNo535FGQ3DtL(5PCbT=x8=b;-LZgOC2JipMC4O zy&5;Lp)av`u1BKP%a>=HrBK7$m~gY_2bX{yMJ0-SnUj1^S@V^_HXVn4<#l1y)>jKZ zHYdaKK@$W`aEkHmd2u#74`~BAI;@`OVFCr*+-P1_dF6arI7FI#$nll-#7#R8U5*B> zQWopW|6XFw=nn#r;v}Y#vI{Qy(l7fPbS$Lg8^Sm;8)C-XQJFEx*tx&{J2YkKH+AP@ zGJ1`I%FE27^~|Sopq730^|fIgNX8UuB|Z!lnqAyKNSmEZjrd{tcVXof=?FghXNm-T zK$s?pB*jxg?VqoFVwm`!S6LC+gt0L8nn5zM(F-lNY?cOO=PN%JcXpFbBc=^4S7DMp zYn?OL0@=6ol+ZH49F7xmhAbbYCi(hl6MAy1Ir0w81uC(aBqVa?9V2N)>3(BzLz*#z z^TWGtfb~i;s%v4cx>b5uV@5jPrP85eIdtPQh(KFX^{Tc80JzI+mOSV6S_Bqx5|JYd zJ)_x@&=q1=yfPp5n57%?Vo1Q}>ah&e=WS<_vsL^pgBv6ALYO#qllp*JDW5EkJ#xf~ zy8DgNq!vQr7D@=!6I{}t$A~xOKi%pfP?_AatwIAy)1!Y8(WkunY2m}Tji0>tK;>IS zTt-XMVS>o+(F_Nu@M)hpqORyqouSoZc_$Hp!>!B>)$M_+Siw+v4AlumO8-Qq|T zg^n8|rZrSlQ&&2a#`HK?K59Gg_YcMDKAns`gqx=Ox1U&Bwa-EMi6;K2FlLCba9eau zD3p}JR(T$Fj^mHq+f0T6Ai;J|` zHJT>}y_zU~{JW|U)4%pEy*(y3W^E=Xw#!wnv}9n;w}i}ZCFQe@D%;

164@>UDGk)i=pe?_uPfFJPCOM!i?c!Er3 z3=Wh9JgM&MF$~D*52N%XuEdxdeMAN&Rw|-hJO40GyXK(*qKu%-(rur}X8X!?ylD0q zDMBUTIaz1_?28^@1twG5l2#D_&}0*G2cI z!C=_jkd-BO`aD**YOX{h+2z4GJ-m}{go!AIKVGuxllqfMMaFU@EFwvRuRgV5q-EJJ zOuJ63Xh0G&3E~=nt{p?S(m2~V7f;Nqd zL!aXdkah$_?SbDXYNxf_%kG2|L$@v2BQ}aZ+t)s#6Rrt_ycR8F;>iZ@%Dp05 ztD>~LLVti9XX*-%!meilnyAIrhD`eUxN~`+E#IDE}*lydAbz!N^Db0AzAv zVz;Y?o8DA&pYNzT#^yVWY+D7{4KC`moo%6?AzZf^gXm>u{oO4R)YEo{`4X?>9uxo7 zeiuO3kFXC|^_}*ryt?1p9r;WfSSoKK$ED$tf(-216poTW8&Qc=Le1`mY6M`BEkmr& zCPsseP#zt68rxs7&W$^+l#`TDZv36gj?|yo+M_YjRf3QsAFUBBVWnaz5x;69JYWHM zC+wF|X{8wSWqG!IuU~EShc>>Sofx5Ljqae4(9$R{tQO<%@WtVhwPgcwfVn16Cv^eU z#w`1tH8aUq{|%}*Ve!}$m~aW3zu^--?;_kSR-|x%ARvkfwQnT8sI0tp-W(9@ndI#% zJX=~~n6hM{cIN3A_f2SZ69s^i^dunhJGf(w_k)1`c1$Q0eFqS*UAAG`uKNH~xX=c! zqYXyb+)|^QE%Av9@Ob+Qfg1uaG91Xtl=5n1qNzE6j`TJBV7wTpV6s^A zEkd!*2>lHL7w}L3w}m69_H2U7?Q=&Ib>lok4wSgOTK8Q*$yYRN_9<{JXvQ4vcBx*!eNE0`4X0b0%-FRrwI+9bRfKO93f%4%SZWiSzr)k0iT(H+I)A!s6M-P{4^7t z&V<7?Ntc2+z#X@#r_HRMuM|Fi(0R%#_aq zmNG#HF?J6ymn8t?4A{(q0?IbMR^?2=Zl^q8hpvS1-6_o9=rH&b96nrDa9y__k;nQ) z8Bk$M0dsX1XZ<*U8*k+@DMzA3S2BJka2<*%724YPl}Ak34gbpDN-S`J!=)W&n2bz3 zz;FjLlSyOMQg7p=pt7U+Ih0`$Ux-Gd&I_?f%!+b`Aqd$wvv>$^r4B@u{iOV|7+mtHsGh(9h2)BLAq z`BbagD3i@bTL9-W{!&gHQA`Td9cA3wkT!%Px?-59uUh|g+=dOd74$960iMNa+{24P zc86SsCu(J-p`Y(^p6TH+Eu{)z6e6x41~)54zGnzHSkInhOLMuEV^+y|XA&U8fT&6| z03CiCHKr;|+Z%gb%21ApR+p6xSr~CQ-jV{xo6B73k*acTtCWrQL(GZ#RknC7lQH}^ zoL81UkJ$V8E5%ritDYTnBKn_r##elnpkvycOvdn*#_M%g`d(jquwfJU;2ZZxUDE%_ zhgf%W>q(#u!Y|J2`bu|(iwKztFqy|G@=E4afVbRvfbmF+iT}Fr&g;c8apPZPS+&$$ zF@22M_zbqeOO(^JhVAlxK!lcR>*2FcxiYR<-OC-uB>n;x^54^k&k}3j6yLMnAA>%> z9oi#*E5nS1#cV$lQijBwWxnvuGbS9(>5;*F>A$LIS8q2$(j9?7Z(zB|#^m|(v+kCF z=M&g&JpRS~us>u~{E7Ad*H4>&Nz4Dl80T6C>hLFVO3iy4_-$?iY&~SV;pl@+Mi9ux zX6D}ouzhE2gv*l~zs)@0baGjRli~q^7(+!c@m>kTr~LQ%qs@Mh2Y9c!H!~F9GQd6Q z5wLzoiFuU&f>{jCYCzzuKLFQ^0wm6v|KuxiZx{ppl?sYJiO_8pH$FT%5qX?D&1a+U zUQ99TtD~h0Y2w&g*Y`#4yb41s#8_H+xn6&?OM?kD|HDK7q}X%PJG);-S6GlzPk49&ArmOZQ3Y8I4If5ZJ0Px{ zOQgo@R=ns>%6aDo0zc0=hMMa}HS|e=^^upB0L^%m%~sKz%)lxIF0JBX7;Z35NIUDx z_Pl@{_wwAQ(sWeXppV5csp%nzIX)0ZMvYxAffJ9jSun(;il zZFvyrdL=@l8IS^V>cCT-O`q;*hN_e~Ke^a;uZ#QKSgHD)Hx3Fe+ z_Yp3~i^C-=A`Bl_o0`|T`Eb>9k%?REXAEKrOwCz5YyPeYjumCISul0Fplw-2b&y|S`K|?ri0FCg*gf+cCWxu@aKXyiY5dt#7_@Z{8z`r>@@Us8+Mcj9xt2AS6-X1A3YlF znxs{@!kK@kKxz-1qS%Xkl`)WB67OE5GkilNe54SA{$WqhOciCN=y0h`NgtzLxW=>T z(A6YW>W^DCWBe3Xm5bd!km!*Ui?JeoC$Po*X?sdT{rqvbu8+3&&DB?G$|SB6`kd(~)xNZ;p;uFtgL|(YKj@n}VF7Mye9W#^>F0NrIul@j&wPGhsbt4Z{j{D)d;Egk zK`(o2XwS5I#$uLzb96<42rUdmpyL$$S2KDFm$2o&Z=)URy74f=^iQZK_PT%xYk=6u zU5`{LNmw#@MAno`je|AKXhN~ zRJDkhvVmZ<`(igKT`QT*sH!5l{2i~U5;VgwBBCT*Pc6kN=xF-K+ucuxc=~6oBF|s& ztaIBYZ)5nVH@Td2Gw0}5L5y;op%}$dPc6+D@&1v5e=TlTeE!*o3cj`KMmB~IvkRQ1 zr`K99vUna1eB6^Ax!<*BzxK!=h0rQgq87cq|W5e}g;lFK0AuKs8~Jf3|HnqK^tdUj5zwntGAw^Khtj4oTsq*b04iRHMjp2Q6r~EAq{*lI=p} zXP{5cftx@CLZfW`fp|l_TiMou;ryZ~bIjDKjhuFXUen!gfjoBFeqK?862ozI-fFjb zh=sm;vTNExb6CYGH`igIp@m)Xr=D3~=<8~3dC=#(JLbmu9Z>5K5~=wDrVzSvsV{sa zEc}tib$3^gaR@ptkBV38Te39J)Og<5 zDoL-*kv0y?j=vx`7vn&B>id!6ThM&MrRFK<^Y&5xYdvU4|6J*EC2ui literal 22824 zcmeIa2V7K1x;EZTRzOfxl+-6B|;eFrdefs$=RR!k# z9Qz><2(yynH4O-a4hezKw=z(JoQz77`w$4U;g-ss>mUh%fJ{~hL<#~ihfq^Ps97P@ zLJ(Gch?EpW${ZqvftX`K3Gx&2A1gJh5H+hlwNN~$!%7V zEhGdkkR2}+PZAXs1+A0YBmbF8nPa5Pu~Hat;j~J=>a#-hS*i7fK<#+_c#=MeWDZ1; z0+*DzIm8@;HOJ!2u_TNX1Y<6R!GL-=42~2pL>({08m|v7A#%NVQap*2O8zTMO|3~S zEKDr~|8}I-jAG3pSaT^XXb6MBVsTg;xJXzM4of0|qU3_)zna1taCH>cj23o)3tvNN zrKT{o20SDGb<}i>){Nq7MoArosU0F5~k7{zzsNjQuY4r7kPf(t`_1CE3v zkw$A$M{5d4JHS;l3X0;vg&)O}MoFY8A4hygA%3(5KiYu@4S;O&9|=z)k@Q(X_ek;j zB+x6YIcSjZ)Dd?o(}wQY5g zg+SmCrE8b(xJS?R&qtmd_ZeEu_8JND=r+J@zqWQQU1hvb$*cNhQpJhNnk)Hpkk>$? zv9&KBuY)hT=i7ql>*I6QKl?v97QGsMT<2J8T=Ch|8)@IKhOf?RDY;D-8Fp)EhWuFV zcS3#Oxf9L|fx~g@k`Uw@8X7b!6biqFgfJXrg(-NBZTxy`Zy9VYKdU~ zcI@d$!Pd6j!~?6+o%WFc1*3DsurU8oIWc!qO=afJ!b4bNDJO&*r-PIiCE_{TY2$Xs z8&KODVd5xaSl!XO)jJvNhH=EUr%;dN&993W;~DSaB#vT2Y=1~1KU7;@6qdZTFqpz+ zj&fP14WJr%B8=|;{2AS674voL-z+?QKP)bz1K9_ndM?s^IqG}}vz_OoHG1?gCx4=hL1rfm!L0as z)GD`aB=8=3zE=xb?|01YY)HdhL1sn5VvKsGD(pSMlqG~7eP2VZBH1?0GeHbX1!z2YTGb|=mP%m4ASe`*!{XA4h@ z!C|B(7CSB&tbA$tVfnxuXDP{?D2pJi`c3OiDwl2F826cs9Fry0EwPjp^(-EE$1cTG zTZ3}Bw3g^5xgj5Sb70C#PT*+&nWH63Tlc0zr|(0d7F`CvthaT!Ln}Q-jit)trGu}x zZ3j|zdO~a&7`|9ZG1jWc1&5TcuyA@N<2u|t&JPBNH(yz^nT!k!biKEa;mg^g{k6Mz zx{8OSOSK`l0%N^VqKjfym5g%SOhmkVq0jjn^|O90sPjETuZ=`B?x-Rmy)K6_c-!~v z4Sv0gHun6TF-mL;?B|b_dc>x;(a95UHX@Fn$ycVKd1s&iExbLeFs`$<`7yc0AIFP0 zT+{KO`CXa{KFq%=Rb!EKK`vw_k7dTr#VcFe>eX}Y0O1n#GMh46-@36iTAF*}{WPYR z#I=L9Q0tKh()^%W=MF)QPmj0#cHWEj#0dJam=VTuZMpc_NYrj6EU>(csdl$+LX}|Q zt0Wv!=Vk{+;6~BD+9{(Qgm2cprZJ=4(X|Z$`uv)e&F^RxAsoAFc}l0VKw{tWYa@+I zJI$nntmqDBHq5p%%Ny;xw|FvYC1t8PPuMYWP%n=Z`?U;4^+;;D6zjMY#|CJ#3!O1s z4GN*z6O&N0^5W>>xQSw!p4ekTEt8w$(Bp_`9?`fp!@`O6v4Dn{yDQ4oFSm(EBt+|n z4|1VvT{lSYmUZ-<2aC)2@94wQpZNIiG!@A`Z@dAmgE9G?fhMb9Xu9( zh|!5BCY~A1)I9^wuX!s#MU|Bh!=RW)8`koaT`htxDNugxT3>1#F@3Q_+T%SI-G{)M z0Qs)>!>$>zVzO!Tf}TqYK?%OQvoizIhMUTN7r%(OIp|5+t)9;I56Oixsf3gnxb5i36j z7ou-dz?~Q1x(2h+ERkI)A!zUc0Y3#(i44$0={t|D7!Bwg##~RvH~UW6c`huv2gk_; zxox!t&pe(8IJ2MOOOaGr^tQlgLtzL)M}!@79me}nu-IVx>UGTtIYpgfSZ&f}0fXj# zu#bh?EI!kysmWwIYN%G~dnU}mvrOACFUj*vnD;OuIOM_lJPIFVQoRHK5VgEbj8 zmuBZJ&BRzC4R@07d+a(ch?btYZ~tKZI=f(0Sri(QJ9`dZ`JA-qyW{8G>`Tb2i@X-1#ltvnj2o?}`i`c+N~Kfi$NcciU9*wrqk8-_tA|E+3L4yu2y3g1laVUK0&+WI zaCWmYDTwpUKi;B3nHV5AemLX_0|VqIDk|j9Xb9_xKTl@IqfNikv^xFq)4wQ8PUfnv zZhYc4@2Oz3L+GJ4&J~vonbFd`o9yM=dRyr|cHon+A!+(H=;d5u#B-wH+Y5I$Y5B>? z_Y==$2g}^2w(c!;w(Gi1zo#`iw?7a(h@W^)6l>rq3zw@^b`&d@H4=nFyiy$!P)m)x zoDa-yn0Fd&nLwf4%0Xi$i#E*yk+Y8Z5k~etDz>@Gvb4ZZOpf}|^%->VtMD=5|o+h^Q47A>_TaX>4YDjuTW z2ezES3^0r8E2BZ(VkZNY^OMIw4Xe`VZTDi6x*&RbFr_oK3gUm{FiXBV#ESOGTM)8Y z&F;4ZA^c( z_o&#*R#|<}^G)5SslReMjqn)Enn7{3)i~L3GZq6F(*TF9jlO3pc7}KGY@ztE9q)pf zp~Aw*BdqAyhp|&?Idj8$1iunqg%0sbW{mQvAB-ioE?Z&3Pzwq1{N#|(g0mO%b=Ufk zWG~h4Aa1Q>(=kO^OdR}M!>$U2qgLIay|N#}rjII(r++|znJ3eAp^YV9h)+6Mb>cu` z@9sB6| zjJ!miJJIu!ki%`OspP~89q(dI-$B+IBxGwb8mjx91=J~B;l9>_$lI))J5!QK>63Jq zWl5!34_kl{xdRJaFkWx_>`je@y{CF>8hk5V0v`6+Q^G%uQ%3JP;=_fq*zG>EKK?!N zJuhzHT@`#UZZtThAMJ0%y6cjKJ7Rl!Z7zZH26LC-Ad!_7P1M_nz`C*23}0wUo45<6 ztWTFj+n}JWk0FmRf+`fo4bEGiPN}xRVhNSniqY}m;1h5{nGo0{9&o;y0^8Bze^%l8 zr|p~nwlBgM9H2aRHq_Rg2pMOebMCX#g2k)f)6(g{)`e&iCR9K7EpSj@h~c11#3rU0|7krG`}dq29}U|IPJ5=g zH{BjaPqk#vITAK=4WCo;Fr{l_9N67bs>!wsZE>9f4jy^rqL|WC@GL|xmE#>**|&_f zUo}IH)Q9}6GBBAC%O2KTZ8+%EBD2xAQa#B=HBvYk>$O0TYT*Yq-iIz3mSUMu)9!cv z!cuVZeAax%?3p42FLq_^kM9yYE;bbp#NALGby-$T2t2-eYxG*V6O7k+>p>b5C1q4- zs5EYjOKWSe<%P>4F@h)QWPV&|TkNemOv|e)&*Yinksv3uxc1U0XLp%APG6bGB`&pv zEO4yNEpy%wG8AWJH9vNKDn8=5??PFg8%vJgjano>Z9TjBYeGGyq6$YqGc6c!x{eItXRF$8AkDQq3_B;0DI(^rFNI0jHWmpR zO3qeH9M0E}9Iu~~`+1V;`xlj0yp?p^2QhT!3B1Q8rhZ0?ont#ymvvczCh1YsX{Be( zQYYZdjn|Y!tfg&dVW)?_GAL4)mywgI$gQhLj?J~3p~lKD)s;ihVoTC7yp<6r5+it_ zmP2k*O3#F@%L^%imn=GmGU>etyc-G{9h~Mpjy-%lk9Qwvs2wzPM#M_#5Qfe-In1U-(ztBL z3;dc`b@uL||1~k@>@$4vw*&)&kLlSP;0pz#TNNlZ$NoBN^#Wr6kH``7nAc7sr(n0$ z!RLD6eJEz&JSDR(FKddEk_oy~wwDJw{~u(XN@-uYTzHP^%HZptzqilxe=nfi`-isU z#n12EKhtPm(thRULTwyeiOA z&o=NB$sQ{a@9QmC)v)PMD${g)cy5zm-vM-6aL{6;pi18tXvTh1tM3?y_CX58WH<3c zQG#Bk3qZ@z0G;cNLXX*8;E=l{a9iU-%t8SNHVJFBnoUKO%7!t>U)xrYR9&r{4|c5S z$U2qhqr=}W6k4x+6CD0PyzE(5X?UegKwWccSYhSVdt;>aBP5A|LFmu5k=2*z)`UIX zyJAwtk)N@Xfq_>IY0-8RlemoU$wo(aG%xvlgp*~CuPUStMZH_H*t&y!hoE_Kbdp(d zAY|qsEA&wrE9>28QFzYo>ynRX_j-q0v!6TKok6a-Zr7BNX~9L#H2GuI=iNhEQGk1LN+0v9A9&M&o~k^%@Wn zvS&aD!4<|wb9!zaW;CZ-*0~IHF<~x@S{z4Q1lguM!-WYO`3QV8dlu|PI;yO=3BE17 ze?v~&d*uk&uf}ZZd3b}`s7%w0IVVNaK86{G@g4>WcK*zJm9s3sHITK~>~g*;+JtPV zt~oA@&Ig~8v& zg`7D?qg~hb(3gXk-uPsM*@f!H8*h)5-?YkRoF6 z@o&#;jHonXG+vNuStj|S2&YW6g_rp&IUZMP>7Ic1GX~!s5836!fjeeg8O_*@*v4VI z@wfvgx1W-t5OtCQWnz6=+nx4x>?8|(=w}whDy8mviLLc*>mSRz!34R7as)qxT^HQ5 zmByEa!-GYGWm$ISHB=&jv+Om}>&r&%ZK#Qr@p7l-xVlAQLy^;QgrI>JQ&|RQh*Vk3 z73yBTBBy*T*i0FlMHMDwqt)s!&gmdyY3dS zQs>-VEZ-SO)LlQ7h&7vSdRgc_*!fiTWicm4V3hQIa#rp|rqErH(=0XnYdbSUtt&5Y zw^Ug^HF6L%ecO2~Z^y2e*qq)CEyxJ`w_s!!~DW z%K6(0_kM7Zw>gF(8UJwo>gi?WMUr4{)NvYs%)Ew%zDHsBSQ7k zboox~N@l)gj5?<_NqMjq5pMhgYgKwN+uJ){0qH6MC$yM*AGUZ8YYrc&IRVGzO=R7a zK@FF8f3(g}=cFCWCw<&;OvH-6EVtGc_I}*ggjPXG2<+PPDbtvycXDB01PtbyYt9DU zmDLCry%yAqy++K|Y+fimEqxrbBXzGz&Qa?kQcUK-O(fQ`$vFMIBQAR)<)-ZJrR_E6 zv#XKwl>xgEmHXRMp=Ws=gkap4V~fw(>5zr`*YtH)F_}h!y%wmcTc_ zVS{Q}Y4=T$fVZMN()G($rIyLr-WOj|G!az~eqc{-M%qw&Wsz5)e(K;v;xbHzRI!V{ z3hgQTlGSAU0QYvFur@_gPU#+dr`EM+Livwmbc)$A0=m0*jUF1DZbYnNuRY5U@nrXY zDyhYGJg@#%;p-9CYm>D%RYHo7Vs;w8$VKak6n@+7I*Lg3&OlpVwdh_Z!AR0)N&Mk0 zNiM?ck@Gj!T!rN`yoN72Qu`xah2V_DQ&L6Z^<9&;5zA}WC6y0i<{1v)rWA+r)7`4$ zuU4pU-*hHdpy) z6zu+}>din0F5Zydt~|aoyU2n%X0&<3tbA}M^dPk7g%cAle>uI7)QKXv<`16pa|-I^ zM=jZ{oEn^3=j3CDVT1biTjvAcfXLt9{Qg}}rI-PzwNl9mz!BTe4I_z0TQNym2=FrozkP8dijaU5mj<|saK9=`Q+h5{=vaU z>7d@FuWIyus1kKsqrlMRt)Ueo6^RQIk$nhP!yw|To2+OpZd%h4)Kt~-(yA9{-*cDb zfhXDlk}Xc+z4f)_&k3gzlLE^Ur8)b{=~_9tX~$GEU{x#L3T+m2D6tf-r@zJmtgQ@7 z)G<~$tVM~Ye7L={I=smubkTBV-IVb@85y$)m8{Qi>S{tn@tPGZ_>%@ni|3?}Z*8eW zWWOv`J6AkF5tavuyQWQXB-8BcA~Krk7i6qFkOODR>?e{^jfiV3sB^?E5%>l_?(leG zl`_{BMCU3Q^a&tUU60F5;VN$K8qDPC<7t^xrWVPw_HW-!xI3;@?c893549SGShU?l zE+Awq3@tBv+xgW3{1 zXB5!BQ+)8St2|B=eC#b(9S`Cccuc=+dg(WGEFjW*64m7z3vEr>M)zgT=Wyh|>%MSC zl0GdYk}j#+L0o1_W|YV)l1^t@UnYpwl0Jx8hRd%p^=2Pcrq=M)GU4!hv)$g}^by7y zM-8>eV}qt*?}@nW;bPS>PuYkTqz<=%n3C^SP>*rHk*R={&yZec6syl=Wc|?}5_}7} zG-KOqndx4O?!ygQED2qaDsm~=&T+>engE6rJJSU~b^u>{RZV=G)6R{qmi8Jr2WhaG z_IuJm?Rc;_%Ut$I!2|%wxb8sTeE_&vU!06s>0iTQ;~IS7Y+nE>cZ57^_K6fu)lQa| zd_D~iP#ulgZ5>?g8^qH!?few5T;T3=xuNQC@=Zr3ntP|X0Vp4iAMdjhl>NDE%I`_I zS^h&*N=p3>{l3`;V-d_&#nIa_3HGp-c^m3`FX#Jj&1`OlS6CyfHP;OJgYlZm zX^|pz?8K2xcXR*SYliCAk)37nuK;SF@f$>TueR}`+6w#akNxpj9*igS#u_sQAMnvp z8F%A$-vNN>xin1(f(O-0t>5E1T-B`lrM;Ng0|4`vn36BL`^dc6>>`hOBs;KOA*=ehYbdAJA$=7cRkLzFXW4+J z{X?WJ&Wufgv3!UZBujw@a1zH(!52KG8iY%8hZyA_0hc$~H5g~!Q<=X^@1Ybt(KQ(W zfG32w>MBcYlfue7_ZE#de0fjPB?An?!c9zIZ; ztQMr!0FW&5y^@1g1lc+`!-1(gOEx$v{HEI3yn%Fbw7)Yg*mua_?_9Aa!c4>CHM!$% zp90QIP(ZefNGF(`n_wY+2uZdj_DjCB*+uIar}zdd|ZI*_b23h&>c1f`a#^Wfpo}Fc3GQV50!qZBNdg zi=XwY(5uV{Qbu%W#f<5l%BS;-W6|cmB)I{cF0D>~!UiJ8Qi{wAppKT_OQRK{y6d%l z6c`E2NDt27YL=GzSBF)Tr9V9rO3mN^PH?c8Mz6{BEu41KXV%le`MZeppGfuYSp5w| z!&aG2{;2CSUj2R!js^2d6@bNB7b|9*Es@RSX?GQ1%9a4qmtA}*o%+cGxS;^V_IuA1 zSRyhG3+OS}=}T{9DTx8}*zRj-s*z(1NK%X_TzTs!IHc6A%x{YD{wOR;=BXRmf7a?W zDHY^aAn0`;Pw7C+sNWM7)uTrBK6_8o4eL#bo~J-o|EVNz3i2^kb-1R>DXuthdyFFf zUBsm9z(Orz($~YbBjIh&Q3`;T|CRZDtby~@)ZsVdI2ajN`3r~B9z0W((b7;kejT}- zcoM9jmb?60UR}@jU34$G)Td6vJD7h8ELLl>rwOte^VdNE|D*jz00y>xq~UtHc@^Zs-k~!ioyMURWaxSuO3<{un%OjQ zEO*S>wTu33jwtkELw3XXXuIbrN{OpbLPzFdUZrY5@wWpW&DC=%NY&Z!f|9RkHT%bp zmxXN!l!)Lf7|zf}x4wf`epd zTQW3CPt!{m8edPI24r;Mcwe!^+_#F+u7KolbmONz^pO0~m3mXrG{Bpm0zfy=JOJQC z)ycpd8SmIb0wYe4fsj22klY%;;waePUlhL{V|Yy$IrW$_ZYeli0Rw{pMPvX&om2wI z6F~l`LZd&~nIYiL6%@Hn!i9cqX^cUU@z)n$r277q3_)T?WA!V6Z##kwbCirkV!8R@ zGHv+N`^XKqKDQO1G;~=~s{h7e^2&U7^3&6f-@wbyMj69Y1Hl2t-S^(om^M-{O&sr^ zM?U=*Ho4Xb%3=YEkQh)WEf4*(G131H<=}tgiLRR^4^+WVdv0ztd)@`fHP=N{IH4+Vtny=YAfPt@kM|ARJq@k7E&#^{U_?JDm-4*tt zSdL+^?e6{!+5AV#DN2Y5@{OG0=8!4=ecxUQvg>>zQ+s*Hw9Vj3JtcM~z);1(TV|uM zp+IfVd%x#N_pa$2FVqaMHP@pU2YqD4*R_rL{j-M=b|?^SM9T0|#ufXI+DDsfItc+I zpzPsa!bx9bACgZ6PQI}r{Ib2mK}=m;894Qm|3er1e_;vyWgOxE+@>$)y| z!!>jc$~69}?f#|&2Xujm7e1g+rR)X59QCbG0!gn_kA#+d1O=yEbB-|Zw5(tcq&f*6 zkfT1DviSQxYgd_b}(ggu!@b24U@G#BbM*znueD1q5 zylm|}9Xd|mmdw8i3`t)rrrPCpceR|No@bPRI670pe}^DQYhe4X-q42j=wIgXn)@77 zD!~c#BM?H8TVXsa2UGmPNNL!LD7eW5+gfP{^dB+PJY99w&|p zAFp%szl7MUwMeS6QO^0)opL-^NVw_`qBXV5w$2bX#%*-XXz~0i*Q)5vhJ>rkMDw{yW?Tk63J^6bji!N;QVef;rKj> zIE&lViqbLpAy3*yly6u>_|&D?^Z+DBcrf23{`S}c-B|r*`6^*6WaME$1XF$GXR2(M zStgu)E78f}?yxo&W6uY1c_Gr<^>QAUql>~icEODXn;tCEoEXR3>Afv14Y20M&^i)h zEfxSx9WC*11F&TDhi(jYEH5T&fGaAUOTQdm%z@dd6d5O2%*#dJH+qM*#@(%qK;gB^ z&UHX$shFaH* zi`KVWj5ZMx0(uXB$U_P9asuUjDKRbU_X<3+15HMtgF znV9{%X4^~m<)}k(Rp_y<-7PDE>C@Xk%s;VBxOqxErg&xFkXA!eHUcbPeIA_(Nj6a??&pxU;3h0$)uDE%`)S^hm&Oe?_gFd?Xvc17m3MaCW#7NTSSs|=I6ZKH z)@V4W9{H9ogDPKhg5ai7v5BMyLookn*aO&l(B9ajYEJ9a0S`xSpgm zE@~MQuxnPVQ5qAVK5GcTpD#aQ3>a%4qn-!b1}(1@zJ2fQ)7GRxV=Dc)QbOv`=KM^I z!_+PNAHKKs=^n1))wa2%*<(*iW>*xLKvQAO$4HZ(e3kW}J)vOjW}4malVaa(Sm$p) zB|JA!y2MrZ+++%@oZgO?e5A8BrN%o?095MU&4*fIB)M=7Zuka}%mgA$jq<3|o$$s2 zwsJ0?T?OEy#owEW_H?AJ?MhfRdznVhqGY)#nARg)mFpQhRtx28MrHl;l8r<9iR*Q+ z9h`TaWYO-kx+;I0llfG*3^WA8^mjMEf0u&|qY5~NgF8#rfQiY7C|{p#Dr*Boz{Qni zHM!SiE@flInRf>A%f^}=n$q9y5+R=ND$(9M+Tq8y6c%k4f@I&8v~Bom37*|v`a0`Z z1wwi5-R!3|HGknd{9qo%JCRfV+AFf&tNi>%f63>eV&Ke_hyjnE$;uL&<*cV-Y_$i+ ztGp4N3X ze3W}$H(wOjbS;2~Qi*u>2ZjgHw1D_zQH=;Onv~sch$O8q@;@Z*@P`S7PN&|jnpSV1 zURK3F9ZZjFU27;O4zpAn83B5xsZ+AISb36jInjqIOND|Cp@!w=YAmC;7R!t-7RU^Q z<%+@Q{RJ1;JKoruz0%`ZQQq(2WDTf532%R;OD!$6YgDLz5frQKd<`^s__q za>2){@90;Psy9t;iAuc@A-)Nx4pnG)zyQ_C*+YgN{elejJuf(!xT`(r;kJB3fOf1o z`=mIeaheFce&%${19mQzT*QJVH)mhxgR9#`D z{_e=?lgpj+_3~<)R@JO%3l6x`_2IPWaA&};27II4}9E<@wJA+memg_tua0923dfA+}UP~e8xr^+})%nMDH#?47-RTMxX%_jA|Nt zra|Z`2^+jHqp)~j21>YBva_}oEtf-|e(4R-!MAU`ICIBy>uHYiL^&IT!$He|~m14@4pfA;$z`s_6j#!U(G1RM~+``L^A z99aXL5}O_!GZmWp19EeLz`lwV@$nXiAo#|IBN0yqJaU!jE6 zRJ^4ws1x@UdhtwiJp~$Kt~Cv(07LGqKAw*$)T|-Pl4RX}>#JlY!Q=l9fo8w^rhoC( z{_jXWzVdS-1afqi{JQ{ucgFq;yYu_`{Qsy_|Bp)bpZjfye}^CRcLXofNb2Quas4ki zXx0I641i=dMhh}W_s2)V?<)TGLl{pOCpcbbfk<@#5|RHWd`x2MC$hVn+4FQBx*PwJ z&yP;#l@4-FO6}EoKb{)`@B?KZ>M@sDP90%QUgT}~`7#UHp?$ygDhOT;><(U;<~~7g zD~vPaF_s^4R+R57B1-@ z1UQTa55m5+tKRfNt}99>Jb}ip11CK-agWwz&G5rrPN)qmxc{H!8nKE+ChOy?pa5P&}d zsyOZubTtNlMTee-O@^8_hUWeS@S}x%y^N0`Q)2*X^cRRv%4F5zDqw4^1fXQCYgB#Y zV!Z|?Co9p`Tf2O}BX?1a5aw2l_We8=>$XwC4z={`U&+#p;p+OL0$4fU{~YE)Cs8On zWJ*ym<=!%qDtqDbDg^`D%XmOFB4#N3*q0ZOen3aE$5{>)HJBS6OZr8~vt0tIm#p%{0<2iDwHn@h@W`S;s zF;`{PX(OZ5>oqua-8JU{CUurg-IL2u<$IW#t1gD@d;BZ7=h7=K{uJKnI(})Pz3n-R zjXuN(5vxTdQVdvO0FtvjEw1W7X+jS}W)xom%sG7xkH7WFg~(3E=faaRJ5x_nIA4JAL+LdyVC?*w^|eniTaxJ(;O9Kqr)YQV-9O2z`KQP@rd@#V z6XZ=zAypKsBGKHZ$WZPVn=c@k2Z{X0B6|L%rtB~&&&_S#=B+=s|8Q;78+JS8>@L@S zk%#I1IySw$Z^MP!-hA+1#(EOC-o$KnC#wob(mOdDY!y%|VyLdaI6*wI4^y(}ca7>) z=)_f7x#6d9B-oaI23+ogVE+O-%{8#Ql23fFZ=Il``Y${j>wQivR@lD&*^TseTDdva zSL1LM=LSzp(OnSfLxA5jUG545sbjjE_vFds| zEdVZTBvA<@Vq${(3Z6h{ceEK@*Jfkq)_!=ZrMabC7}2}!J!1tl(}t$FDYX|P84o(x zHI)v$jeI2l&-a&>YnByyk)Qkt@Q$&4eb39RDuQdk!jviTI+o*%g2aw(6~CyD82aaMGUs9S=Z4c9#v zM>C}AJctLm4C;r~p&Q-H6~+rZ>iXZ1E6!3mUf9}NO+!bkat(vdNsm-RQwMIjyW>H- zb3ebOOPZpwLcDybJd2U zhvw;juV%YcR|jQ!5id%&2lZVD4Z9=1E{vk*M5U;Z`hm)xNEAsO1P>KY{jydF)HP4R zgi0c?`Q-WHCq`FRl40ys^O@#5U*PA!hx40ITjjrw@64GANaOWykJKiI|M54)Otr{z zKNxj>6{;LLNOS{>Qi;3@XvwR4Y#X^ncPEk->eQyou@2_(Byg~Rl?w1ZwCm}Zj0LUrfA>Wl-OcN!7q{O?5SZnj8-(*~DDi z;g63!93~8W=MZdvA6kD`{t9@lOF(RW65i}O5VSu?^@Gl57Es#2OKM}-v*rlwk~;|Y zE4F&X@@mVvnV$UXET62lUt$p(^bfui!NH?xFs^mPb1*L!|3O9u2sLH=&$4B^EjsLi zg>fz`fgBfzB}Y5`@s6l?qB{RV)L9@u~#5 zogG#6KF^H?4`sTt(%U8Z5z=*LZCRyT#Q|y@n|P^3p{v6IHk%Jo>xqM(7GuA&GU3|B zCOrjh-pm;w%XS-5QKOlQOzeGIZ5_&V#6?8JW^Jpyg!SOSL5%QI1QwrJN=$bdG-=K; z#)YHBl3#7X2=}c*qYOoyvl18B3|n2RuQ<=2V_ASc{>f>{hdA5!-YY_YVZ5h&8yk&HaX_ z@sT8I$*7Y8h!0_o)G~~n(w@~3{4~j-I-FbU8m?nvBI4it`G@hZ{t|ehb zmtg{G%o-U@Y_18yna53Th362wxn-T(mCurwP?D3)v-zjPGtZAEnzwExj&teiF3^3H zr5~%xdet;J+xA1$y@cJhK>Qj~s>{4PxITP(@Qy+*iLh3d?G|46B>aSX%< zvy+d~76)dgNhEQ!?Gws=#^w>#_dKmit=%PQSi~Ta$RAw3pz&6nQ;W35l71T?M5=jj zPbwH8Tv!zCs5N9HDoc@!G8gFADgo!r>Y_D!a0Kz2xp9WP4J!slbX^^l&k(H(n7=p8 zW-3SRi0>9$9SV$OP)xpiK(BIHJ45$Qv3k0En!}S6_1PQC_aAcg7Ymj$DZ21vZG}W% zcV#u;%He|>fOgpe^|kK?_ipyLM51EzUKm;iM;1UOvVBr1(apALwi4!`lW6~=EJMvt+$AO)@sgOT?FNtgT;vHtGz6NFgA?pw@L|Ol^zOL zwL4%#2(Zaba_^%1nAhN+LEKCopV3A>i@V`PsJKX~Y-yk$?UW9h_ib0E14~2l7#5M1 zQ%D-JE7M=(p4gF3T%Tb_-4!C(m%6>aA!{u_IGyDS_?|)FVEdP8p#Qy2_J3HJe$=}G zJCY~4AhWP06t_F6El{pzF9UtlTP0?=^{ys=$CQLcw}Kyr%5&t%p6@N)Iw3{|nV;a+d6O;d2t^YPqpw`MLlq;mmL3gM zSJW67aC3x}qqLT)qsbi+Ns-(6q)B!45?!0yTU%iXr+v42zUJ=?T@HAx((gDu{f+s6 zEink?BeD7DQRUOc{U2YTv#Mg{>~3Rpp@c}sv`@r7)Sbm)-`Sq~cBkZ_i zg3q4pV2*H0+F#ecHDU8Lfge=O{)lFBGmBhVw+~9(85zDunC_@i6gmSR)#DMqaJ+9w z$wzL+k%7|R&(3U}?IH9lt|lBXn<6R0rKyk3Y+61Iqt}=ag?E^s@t{4SPARyFm;a<6 z`VL82Zri!!v3>TCA*K@=RWQCxrw}9c$#yBX_YtvavxfFbEEru~Tw<0L=~8rt0yN4! zar3d08_3|Z^+?mH@yqSo?zf0Sw=z66? zV)fQlSL5Z8k8hipEnb7Y&TE>RE0;aaT`B-yeS${L*Q3Q;l|D{JAQq{Qdx%^TR6$Pd z17ANJdgcMXqq+Nb{w0sYo!8Z#HBcl!|imSX1KWI7{9jJCQ&#fRrugqKc zWBYDf{@U){6@J4C6)?#zLQ~a(x2t#Ugh}76Y(1R)EkM(sk8qpRU|{{Qm)<8xzU^ diff --git a/vignettes/articles/figures/unnamed-chunk-12-1.png b/vignettes/articles/figures/unnamed-chunk-12-1.png index 46026b1112f553bd5079d6fd56c7b44b2151eaf9..95bd7133c33383107576097f7d3f499b05bc94b9 100644 GIT binary patch literal 10347 zcmeHt2~<;CvS<0$L~sy@&@562Y$?lrUj~6dFZ^VDRUbql5G(}Z1i@k< zSnx`KI8}oDHtMPhX_tX z)gTath6FVy7Hm@K<2^$`U5a`cTHc31_PpQtLp{Fu>OvrB zh|#$puLh*fj|gte*ZqbQ3rfGuh!1OSmxdq@trB4nc?=YaK8J%K zrBIMFa5#YahtcZY1QP2a!+k|pbETPgU~HX4ogWKX&1^RvNW^YXq4*wyK8w z?OGECmnWiEx*(U(^j)z~>q!#%9gEijDXt^~+$Mn!WXZJCXN{!Tp2VKMQrA2!KM*RLc=&$nfR1f+k=8y4(-cRJ)+BTrUOHunM);I*6>Y^ScpQ zuHRv>NH=wKT!HAFlA+QKvgpiv`MiAgI5xfHpm!(KrLe07N|kE>AWB194NspYF4e53 z1C6sb;nd&QUhEIP`?t1sf2$9>1t}^03_O?alH^mPf=3@7KwC(m>|LvO5~!6NFV5Iq z6W7lvow6C+ap%N@Ko%yW2EUM)XqP^^9A)<+N_0f)shMFO0>@i@MX<#cRn@TN4{=S&V`i!=%*7+ia7UMc zxZI0LD*Utz{{69U)~+YTTH6QWd>%|nPGN2N%M(x+iAI5@#z?=e_0$ZR)ww74ZnoZC zZbph)Pn|s2-q$n2X}fpY*8^fY0zHtz8!INfw!DJSGU?hmz^fsikAqw)_h? z^A|eetz6qNc9!$^0w{ZINzu}%w?FI$!KlBkEk~zeFS^1r)KfQkvDoQr?>RpMEZ(@=}d3(mBYQci^%_Sd$X_SR<7V-S&J11>j)n7De6H8R;ZI~QNR&bN2XGg9yto;aFs?F17p(YFdSb05FcA@ez}GCljFC^gOQ(!nOip^qO1 zR-Y{z%`)hM}U zinNrFH2Ssd$qf0eEq{#7nBD;m449&b$`{THXAS;LPF9u;PNB!~uQMDoFxkl$^5+%D zxF0%Ydamj8e44H#Em7T9Ok^~WhMjc{7GXu)Up3Lu-U*pELaa&hBT|G|CGEzh^6$m( zO5l^kpuBkuBaWV}vf#u6K6&t??J5~rG#s(H_|~pC`hgJULZ`r#US=cSN(yb-`t7^B zD%$Q7=FtpG_Wo5J#ol;Zo_j^@TzsF;@X4?XO)qVxO&`}UWD)ncia4%#$fzdS@+U}& zJP$RhWNV1DiTYqOys=KW;3!(*?Dga)?InKV;L=3%wiemlyl;Jz#}t8DHk=Q5qef%j zsef^~xF@(s)}99qEMX-={B)U6)bY+f1!RfwrFu`dJoZRcmg zKYc9U_Df5rkMgb2wB~Rk5o#G&)WZybAzWRdF2=;q?$^m}V!pQdbmd}rRys$9bbr*& z&CD*j8oS`=zysawGXQ+@oYUG;s6Z%I^67nb>$?tSn;#;p(SiSAH)#FdWmQiLr3eYP zPug~UGNI3k8!lZ-1>SZInB!i|0DZ&Xy-u)>g^h7h9qeOQLwRW#0uSA^Vvs>uvkbV3 zkU|KVDZg1dwqk+Ex)CiT+B#Qtj=rN63rz~K%#c&ll5*?;+ycUb>`kk85N243*X}QL zuUx`P$XE@WRMSc<+(pPPI;8+=!~th6X*1}i*xK!Fo#EsDjwZILjm7*+*DZt{zZ@)N zzsR08?Ee~hjl*gBTyu*|swN&m+xl%vI_O+EVrPt;isTRlK}}WOIeO?A)y~|^0{_<~ zgI76;?M@)ytw!eUt`z(BzSdI*$^l=NKU8dP~Jd(h6550C9p?P5c%4%G(w5T5^)7BrRR%XZR#>F{_N zO1XyFhF_W*kZ6jnaSq#T6gRN?utdc>P)A* z^_4bmL51rUmFafH5M8#DUr66X*8FtZvBCzOZl5jmrsqcM9!{>hO(zZ6H^`H#_t*^& z2lRDlNA=16{Z*20=*H3H+y3NNuHR$S>(tN{M`<4T!|~0#G7{s)+c~nAW9k};KYG#} zidAl{2G~is`SnaF+1L4Et)W{h)D zQJeop)Dkr$jfC{Qxy>}o(rL(ElA*bL5A5go6kQ=|)mP1R$l07&W7&d1OiZCzkq{I; zplJPzomE2d?MlV>`qhI?rK=pDcCfnqjl%g(pADUYQTu zSd0YVnCH8@4Jp5I3yN;JIWaVs9ek^zv-7}hI&gMsw~Ttni9@PxW{r%WmMSAw(~cifu8=hBy4W?$i1f#p^C;0jUy)G!d578`2JJlbAW%D zisHr62f^B}-iaZ<_^m;c6kc6fu;kTw^GB7E8>7elYU~xdzX`+dXmNpK^Aw$4S@crX z@Z$L#p^e*xKB{L4DZ$>^N#(~$>W%Wb zLB}IxQLp9?!C-I4|EW}T-~w*TF4#_me>iXbr;^>tbcTOOiiLk(;EvU5<L@r2AJEnboR4T*_H9kMSR;mn zfC*LMn`=CQ-_o?Kzb7{-6b)HMOjZU>d5_|W-d4la(h4Ax&2Ry%yF))Iep*@ow*OJ& zTL)SS$8NYtqA7p%!AXxDD2Rr5t4r+r(g9sU{sB;vP6iHXJF5J^ zyxu-Ua(<&6!=>s+*HvLC)c!L| z2wa81hJ8v9B^V6%Cjf%li-tsk)A|qkA8q{K8-vY>6}{ksLytB0RC=s0Yw3I6qG~{) zJ2Uxtg65IeK9u4x4(dV>2O=>4 zkE3a;dQi9fSb;DYruz+XfHB-rwObOkGdyCeA%AA7Eei4Ey^@F{+}iJ6oW#y3p{=bu zSH-jT$RFPpB}=$GccVjF!~Ph^qZTK=Qw%x~{ppra%NgA2-leZV8Hzw`-RPE3MaRB} zo!WxfiJA$A$VZ&r`llbdps{a%6xlD}CgXv(NMx&RmLmE%3|1~nMIfI5z??n@3fqT9 z2S4=%*kdQ?Cb^*{JLaOm_CDwqq-jYK@KZ|5%n zPS7iu@VH#ZTs`WMf^41cmh^(}+m4z|1O0SIiQY@?dM+dLsAtOPBf#wt4`Oiq3^W{! z71TCYMdO^3)1wWG)zma(>%%|zIv-n;1)g?+L(3*`$Fo$#sh_2`AeT*ex#WT;OD(JU z#X~t@;7Bp@_oC;|QKV6`lC90eBQmC@wCg^@=9Od?ZK*&v?4CWHazA5zc*Zqs^ouM( z*1zCvQ9f^vPR$PYD7CjA_}oXp+VG67-eBi$5fMkcK!>$0A!yy8`$}bE)}G<#m#(AH z{U*43DAa5Ur+*k>HUi3z+r-m23JH-RGd}I)Jmo4K z6Wx$kmi0JAq5r*At$Pp#R{m6KdEffkQ&Olmd(nxinmJMY4v7YAntQ|Dk-j(5&;esU zJ}V3<3@_edNGIy$19QtfT;14bl^N~lKG((B28Yn433+xnjf73?z;Z{E! zbXPpL$CWR2Fzu>vq&T?1lNq*4amNK&$zhRO4}c3B7W7%~{U(Xpb8tENRCONGpwt1g zzP8f@G$7t`GCuOwS9L;2fLl1&zq;99cKPxhfZ&dngft|aHaHe~Gk zBU78R(E&MGy~zS?f*B~k0NEo=NPX5>MD0AM`Uk=KB=(`y^k3-(%b*6>x&7RI#-_M? zAN7dSiVlBeUNkLX8@$|9%`$v{JZ5B-Xr=XZL%DxuP?I7U|4x(+c%{N8*QOL5f?)5x zw-G3bVUbi(B*_RDYsZ($!Jxqk?P)wX+MfvzC^)dR9y%+~V`b6kxky01DQn+$g7P+$ z-x-jDBbB503h>GTN6c1q;DAnMZ~+%lip!$F~|`*|Dj z0tTBi;;_|u5MlV&_~j+n4QWd;)S3Qeq3tMp)9%g^D&i3OZF*LQU615XI6%ipuW4g; zkl<(k)&qURj!>%^KgtnYeVTg(b49NYjRt(Fo9|(4Z;r_x zg2PXpfvH{p%ckl_sb)nFxO=LA+Yf|v9w$Qon|+m2y)@C{kC}2W3H{Otrs1(Mz}7x3 zFgZ;!pIG!YjDTqm~ zBl{%y#ws=r*jlZ#F9OAc;e2+l~%u=DbDS%&}eSsXwCWpux{r*-*jVM=>_ zFPK%!D?xX;#sAQSkYc z(~xbwabEcL6%_N2tlSdBMxUbo4{rGP9rRz=6R)+g`GDIAa6)QhoA@W+^8MEW$Upvu z@ISo&AL(lHah_nnTK{qb(|&3-7gM5V_50EKuP5&8Auy)~Ydwr!JHLr{lLL2^JHXib zN)K&nYP)W)7OJo~-8~N$m3BZ+AN9B;4c{(fb;^l#nEikW_oE)$~R`8)DKU68kS{M#o61r!#fGQIe1H^^YhRRgX zkV28kkZL2^=i*TGwTqzf@Btr%2fpULgQDP}n>jG44XX21H8W{e!vXqJ9nI>xrdG*= z189hGah;rJU{?VLbWpNL(SR(-t3I|-?z*$|uRSTd9Y#a4HjZ+0d(qa3_>}7$sGI|g zYVZ;d)GLlV@I`v`N~wrDk)m0f$(W(pKaIqyqapJ4G7_oacNp~>-vVg={X(b2NpuFj z{*VWkni*QsvJk>aYlk*6?Z*nrtW_6A2U$nvK33E`e*Jw-p@JLsbN`9xJx;g|r^NIo z_Pa(4M~l%6@$W4u>$XqRu*&5oIMs!YJxw(%;$E!;7Bl6^xaoH*r>=;ttv&I($A}@% z{59vB#+Ghk-v&3kx=5c+vPqS(RD2s9+)S7JNMfuQtlK7x7;)DwwS30}=v2)9C^A|3 z<_4cZHR?vN?(u7H@CA#3Zlg1Loho*E&S^k?Skj)RO!c4j-qDlvCDqUgvi|WRlg%S{ zhYVJBI{VmeALID;iOv?veN7@U3}ePky_`rDvr33b?G>4y%_hQ#GnxYKBGecQO*1#O zmKKOz;;pIg=S!y!Fq^uBBw9;MyBq5Ydrc#reZ)d<3>WZk>*^ToCYbe+N|e?!zI8Zv zMSykG%foB_>$Z;+wA$C*S%^?}>_e|X@gLS%HZfYeTt5X-HaL-h7O zNT-@E+eI(Z5`$jH-7{ok-rTGKHH6qdB;C*gQ5`j9$N9@ccYU~gJ-ae)>}t2(yB+mu z`jUsy_hT>twXkxp)4w(JyX0l30q4E;7#^OdSbXGT0xp5-5Xov3F&%Ve+N4h7X;wyB z(3o-KWupm_r`p56DAv^Uv8T>Q?zSI>I@0#IU|uZ_xN=+_4&b>5Z>>o;q+2edh1A%- zzS*C$qL}9W_mtJ_+NwXfiE~#ycvCd7%}@d=`V*y zCHFHanvcN;z0{XH37ReT@0;rX;H}{s(nfobCHM9SG&~P{Bk(bU%YLW4*yGt0s8aw> zL7`q+eVW$yroWX5^e#c6BnSXuFuvPrj6Jac7A^GNtYu)D=b_*kcW_~^aO8*mXvfvb zwn5=M=cTsE!T{dofT#Wog*OOQvWL;~2cb%37}Gvg!&@3*LHF3>f!^!ftT*gc$Hlp# z_}6Rk2)goON7{;5c|+^H%lgD$2S`&LPb;YBRYb?XA(4SPf#pB`XfCwqsZxI#?`2k~ z7d}>70k*)*lxZy~J=RXqL}j%6F{sj044ujyn3^}5(cdV-3XZUR!suO-6ROd>J^lH^ zX;p<)t?f=WDvNfb$ttwUH|jUs*vc9X-Y?;i=c>06!r1N93f@xwPG>UI%vlFc03Mj7E+T|Zp99)0U>lloyHwX_ki6kDR5o?ckt916A<>Gvg_ zYTDX1h0&zPpM`H|W^#vEYf}(K?|DW>r>(@vgY2N-o*g%#Ny_CxU6&aVhnv3VPGONq z#08w;v4HJ;SC65)GE1#8I&{~ThkCLbnTEJiS7B$I%9e0BG+=p7n<1?w>8NIj7rsZG z7z=aui>(8^z$x^?oL^hy18%zhh>mj^F7rZ3V*%!k-=$Cz@xa@wra0Q!%#Ntk^v2P> zrgW!~e7gt60@aPR3D0W;KACj9*m)?`CqNoT&5Rk3{vPhE_ z1OiboCV+qf5g}9qgkC}o5b{0I-S^wSy#M*$@9duQpZEVChMbu@cV_O~xpUj|JUC}= zvUA729Uu^Brz!Hp1rUe_0RnMN@Noff@QVex z;0_-?41hQQ&f}uzg4J`u>0yCFwZb>L0N8p!(Q|PDxnOZFII0VdjnxBT_4KeVdRQ!g zNX1gw1)Qg*pnz0RQ&Ug_{89=?K%wDWKsXmY9552=g2Q5QI4X_`6gG}c#j)AI005ga zg7c7SNI;>~kZ3g&pe&Mr>1u%T9ZaH-C^QlPq|rz;;FnFQDWH&QC?pbvQbXZ%(kQe= z3IJbZQ?YtftP2$f6f9>oDjWEtve`6J0gY5cqX30OqW~j-$rfpgKw;C^?1@OfMM}*g zg|tWm3T1H-C_pEBk&IBApW{^q_z+?Vf zNE?3;NVbvl5BB~PXaoYmK&B^-S%zfH4lu7v(<8r*fCJ?p>^^_NxZuGF=5KFhuZ>+U zk~~nqME~5dz2XYb zKrsfgBdV51%o|t~wB7cWYj~U{+I)U{%@B39$Mp%Dm%Uxm^wdoVHGn>ZN#o)jWwSPA zKf*m;HVv__uJ#7h7Dv8Ggm1OY#-}vgTEC_q1@b0?=VGz4J?A>+k_?_h3xwc z?0C2i!$=j}djf%Zc84eTsnz@*wq3j1nWgaxqB4OsS*bb1TBM(WuPseB5mQi`OIt^t zQ{}b>=#&?Pt;uBp_{PbyM@-9VJoYYb@>W^m_$J{>#QLR8r-toIzGdgDw}FS zvK-2Y^;y_x!+kr+y*S<~yD<$@RJ3`%EZJ#getR_g%TCnf-ZlthcE+UdID@*SYmN?E zyxq-9*d|=|Es9)ylASaJ56^5-W?h@5r}P{OZz0CBf7>eQBRrUDqF6`HPV+CnKgN~N zq1$yJU&}_FRb$60%dpsY7;f|N0NP%d2wLsxcKT0WUEth zVwpUQaG=9=W01ZyuTp*S;Wa{a?e;0ezG-!crsGtdTbzP!-)54i5vDcPk=?##IvW{%}K@x*FOEfJX^R%NjU5Ko4 zxbKu)9C>Y{KHj@Wb+t=XHQTaE@6x;kHksIM9prNnk(_Iao>h@{@Qr$(j|0o zXolJyAL!`nRJ>&t>uTu1O<>_=BX#StjYhQ(U6)CWwLL>sS}=-#??M>F(3gyP60S2< zaWe9kVwZx5<6&zOiOoK?5B+>_1O@i~Wo^op3m?O};32I9B2}XNb(r~QPj^o^Pv@17 z5iImm_CWorBzcC4(n61 z*1y%E*9a-VRYn-uuE}vtq#N^$#xNBYXI7o!UX9;z?<{Qa(n^WMACc*4W9K@aRbPTX zq>7hs83YL;{SU>Mz4Sq^<_Mz=Q;USj5fbLQeMIPB{~d}rKt<8n56m1d;B1_IGpnRtn=4S)kp1x=kX^yrOATxjk2|~Fy4yh%wlcy2;qy(yB@8!|EMX^cp zMf~KJ;b0+hXY>0di`7~oXRG8>QSR_ATwG|dxbkYrPULmF{IL~i*f$Kgz^r~H^70r_ z;F3ejrkWPyf>~tDlCFVQ=%u68z+s$$yatiyRqP*uHY$* zT)E2>p5KEV%Zxdr-|P-{E6Ty0JX}|F-3u{g=L>-t2EV}+wS&+2H`NpSD>fpRF6z)L z&N0`4!<}XZ)EXo9g?l@J4_N#p#FKl)cly#4m8<+pOcvA`r&dDi-~?6$kxTFMSaH7=WmK>D zQe}$*!8UsVo#jcrTXg`I8FZ~}O_gF&+oWF9FSp$q0k;bDrs6PPXE0g%R}jgiH|y%3 ziZJ+B^x4eS&i2$5K!qD*$7#u(@abEUB!^Q`A@+zCpF%SfaWShZC9u@+zJpuAJ9XaA zJ>1TvcP6~R1wkh%?TvjSu#Jc)NAX~tg7%8S%o|nvu(74epTu|tkk^H+mOyT^kJ`q1 zUoBQodl%U>+1v%MOhen5**g)8r9iIK!*e6ZVm@D0%+oG!N9*A-%&<#J|ckZx?S zJz`Zawt9@l5cl|H;OrB;AH zCHm8aJND`dS0u3Yz&USAsDv*T?VFkrsPO3zkRR!B+|HL9w0q>stdkvR0Is$fXM52* z$Wy6rI^5Hx$0}{xyokFQJ&tA#8Emh*BS|0SG6yc+I^>9AFE#g6ELDh0c=bq>e+miD zb=qNvR!JNqe#~NSeStB9lM<=bg*`_Ti zaQ6V)N-0LgD8F>1nu5OX*UgN)gtFOLQ4`lYZ7B0~=1fe=Ennm0QwXj4EQE#hFEC26 z_GwD?d`)jl&%>!MfZr0FtS9L}V(Bu(Tn=MWkokK%ZdekhthAVLN zuGNfJO}%HPy^G)7dq=2NgsExk^&7${vK2!bcTr;nmBrVYidURHnDDQRrGf8i{5MRu zkBh@^^G&uh`0RoK_9lEZTf;(esdr|8eR-h!MOqE2{HtSSEjEeX`LyW^{<&qVlQ^7B zE1h!u&8(d$wsCX2$ek1$qfxa59tbNAzCKWV^rqC-x4m9M-rU17&XwGks&HjDQz#8hkj;$6si7p+2L zg{2>4fDDJKMqZ4KX8=&2HD4~w`TxN_yT%4Mf`9u3$*Z(~973^a3#JSFGe zGrw|vQT?8E9dDt<9SIT1YIz>#F-adsZNzv7<6*Go%FP7`gr-HtsM@D3CSHf92DTK+ zH3U;k5F3ZTuj2x!8TQnjZ+f?lvS~Kb?DgTC!feOzADuT5ARVoL#Si_n(<-zZd-f?v zR2c?};^PC!Lm-Iz7?8+Me@&D8<-zu3W|yjd=vY@^JY2WU!ONxy15)s&oHRu-RiLwnGNdGDu#5Xiyf>B<{R zs^KHowvRa^B%5KkS^?l`DdmmU>Q|muK3*(mtj7{WI1}i6w$MH}u3y5iIvhM#B?#4x8# zYa~ITFkdR+>`BA(o>+ZfQJi#o6&yq3P&83gFV0cmUnqezv+sqVv0$%Da?`NPMS ziTn)!b>{E7LOLpL6z<$5g6ZbgP}nVkDWk4fDOCyk1HD0+-Y=i}3qr4E;0D_xaRX)J zvAoIv+)5w+yqhXDcJX8`J+(X6sFaN~?qC z4+P&A9n^C!G^ebDPNoxyQmJ@Gcu&k85zKq9jEQ`z%#w_CSF-AClb)UD2HFo?a=4=qvUNqareb6N z|8SuN$i&XQoSQ0|$(7)E?lKiHqoDntkHSLX`%DnhTwtUl2~#u~4JfWs>apc5s~C-v ztVX-<^!7|18Jz4Xx9*bwG|7YMTk<1gHk-x$G2ht~RG(zJgi=g#^_myebmS;L^{~Ul zURJ+UwQs37X8<)!f2}vj1f{=bEhSu4pXycfeM3S%Kd%H)rB0j4*$`OrFwi7*P0cGi zqrK5Li*nQ!P|gKZtExP>6GWzBmJyupFKmpCfWWg99ucf%DVGg0)DuyAPXv3S^n@ca>=vS&XBW2H z_3Qg+UWL<$FxcV<_<<-^7U>t_y~5or_Pqvya4H84uHJ{{@(Kz|{sf)`H*wv&`CVk) zk~8s)Nt7@@*$C)*;U&gmx$XB;u3imAB37M3-immoPH2?3q}Ra}V4H{VBQ?EKUpsb` z^o&2)PVXt7Vb&!!-|4BC`LJ1MbYvHnB{{gj$LA?P4o$9KILL-|5YzvFW1D$sRe-UN zD0FWk;w7kZzW|po{2*RlOyq+H?F4+_&C~hJG@k2jCX{>84~aX-vVuNjXw)L$OZ@IM z;P5%_O~yngZfD_p+Rl*15I`$wl+RF@BzkMo*M)O{KI*lf(tdC{>=vZ)DbU%GqOv$8 zBwTNqmOWxuoZm%{mvfwDgsp^rj+ZseR$&_mBeSzQ_Mjc0xh5SXx)FSxo&*GGT59V1 zz;2Pi{#jdP7{N_{@FH`X=$&Y~2n zgsTlL0nHYa90u=1tw5s=QFT7orGBeI;^iI?!XSPEG-dmz3!UzxMF+h1&XfF}_oXMY72x0Z&QF$9FeE6!@&AeN zqqZ)XzPmovC2mpBREJD%%yjQbH zN)vo-0qRWteiPn_VdW2Vt_zRFe+5aS8S_TQaUW;Zkxx+Px1usuij(j7`S_8Vu>Frc zCFvJrsV5Lf3`WqZG2JQ;IG!If|1z2Be;AN%7)&q=BbfAEoB^@5{4Tk}{N!`|sqDapfGq6iO>-Qo8H+QM213j zemXpZ<>$L~!sRQlli~XxUmGjI-tJ1h7JU|h*{|6ol!^hFINy`e1cT$qg8I%7i1g$C z8wYv>S5V5bDPRTN-?+ixl1xl45F7}dMAYsQxmpR$l>&oLsmx-eQKTFUC?_cZQ8Mx= ziBt1Kl+Z?bIlUv8E3K125b`J)6R;ol_9j14`+sg&HG+M`#ox;3NdqDcl0Mf7_Epq- zJCZ9SvepREkpxekLSR0NV!feINwvSBQKq-0uP&2<0ZD&2il2!`^X4^UfF}woC_cWo&lLbk0P8%>T>?C+=>4z( zKE8vtkj_|OsN%nQ!!vUtdr-HnJki?7%gB#89IM)z70&dgI&niM48fBw{|Lt^CRzBb zq#sdwy)tY7(9|5u+Zu16Yj4o43OH&k4m4{5h}v7T2>Pi8PrbeRL(r4YDzg%uznFvkE9{Sni<)eP)|<8FIw$ zh+_4r-)2yAvD7!#e{8h4+CSSXcvK(f;APOg>Vg~lW&V9uk3hyo+Pu{*GMLzjqMw*XH&9244M1 zMcJ>dCw9&Jk!tuO1L2O|O78(|vSf~$80(}}XvK-2#D2J2xizsaQKr~QPi62@Q;7rERCtTMX zXutTJye{`8fNQMH|93Dz5|K%AZHv52+>7U=^?;;fjIDIL6gbuU34Y-m0(8oqb^_fX zjZHe2aYK3jNW=C8Q%=f54Mwpd5#13j8h{bfxy!|9^Qh=5hXNVDMzF3*M~fdP`S$`` zAS)_@@pV7DToKb+@$HM^wD1cJ^93OD;oB#PUCCd}a&5Je`X2fNO$pH*d~d(bhN&d> zMe70t)|qQx{HV(VP-W*sH=@p6UixrH41gEP44#{s-Rbi)kkPnaHE-8vq^mZEse*B` zo`6C?>$Q@ai+kySbX@yK_Fza2zDESKgX26yVS#^<-~f>eNMWoN;z#5ToyfXm>Sg?1}rJRIcqBZf@L5HG>Esd{}uZ=Wsys^$%g3Q)p^E; zO%h6r_wl%ZHFB$GE={RT9;(1LjP&0=AEvRgtnpl`qW(2gZl{JUvse24{6oUMgz(9B zIw36v{rrLH^4(TNU_bVW<025v$O1aQ;h6=Am54HKdnvc$>THS|kPI|wZZl@Szqsvz zNBVW?P$WvQz-|J~(v10#W)Hyyv2GirwZyt!t&-Ba=t zENLi@b(+pjNZh>mb9S`3_t-^G_oYwE@p$(RlZWVDh0Vs|(@Qq8ZWZ?ymD0`Rf{oDH7h7(g;C^qqB}gi(xCaZVfKEu`e2(VMH|^ z2l&YJLx@I>iAIcA~m+_ihWP&zQ8 z-1ZJS%E)FfN->k*{PRT-2@Kg5)hZLvIpcv~2pkYl30D@=wJ+DjZ{Z>|UY3WK zj8V?qlJygbTu<1jvZG@Y$3H<5$c|yLBWB9aW|C+|`6@@^Fbe2>KJxD*yyc4>>jH&z z-FA@A7YWWYREza*$L)tTJ0dS57w)E?neFk;Jj9c$&a~%Fadji)oKSxk`dbk1qbQ$y zkB0@UPjB?h)pFz@Hz>chk2Njomprl4VjAFN0wL82n7`!7@*gMIV4SNuVe^piTNhl! zJ9ncbEonFX`4ZEpwvX^>G@3U5TkbA2?NJY9m0CIWT>oVZ|=N$FCFn&A^iL zlERem+%iq$iu#IUok!Xc-d)&@y2CGn+uw&;rA)!66zIo^R4E&+|IG;E(; zEsk+BU@s6$JQ`B<$!XkCSt23{tLuw%+y!Pd>w_jk_?qxzt5+&8pTr=?TV&ybIj|MC zt)GSxmq(XB5b6_ebkH}S7=`X{Er*AO(~kn^Cdc-9WQD!1Y;;=bVD&bAliJ}kw`Dne z4jL6@h{9VO>w_>lUS15`rf+95_|^o3gYA~u(l>YK?!~q;cQ_uf3UNRs!}oxnYeS=+ z7z~Z_xP?N! zd(wiB??BBf%txUc7WCO(ankY~J7SN%Nmy$p-;v{M8b|Eke34_ zzTD}F39ZwL?FhEdoDB)G3Xrg>8UJNhg^ATefPYaK?CW~23%bq1ht6_ckal|$QP_vj z8Cv|AJP5Y2T?)9nWS%*uf+q_siHSb7MmwP49=)qGZgS}Ym0Tt z+~XF?)Sx?xiG&?PAZ?fRu*Xv{Q9!xvj59+Z?Pg9dr`jSQ)gK<( zKXAB7bq!*c4n57TSK&~EaPvaAM=O-LwiS{P<8vM60>FgF5zl~6ow{tcULOv+-qz}R zO)X4wvz9{;BoFw8NRxnBKu~}3@^EMn%2oZ4swT2=0vKTgW7?c!>KjHfHm-Ru4H}Tk zBNR857wK%jAavpuzt@|LT_uUYg2sqfb{8|HN5w7MFh%_W)87KN-I(|ircCLxr0?A= z=`^FYmi*XkJ#rddWh;@<65l+(y;T_`Pi9>NKNtSz2KvAAndRU6>TZP*`# S0r&_NWO~y4M9J~1xBmm<_SE(O diff --git a/vignettes/articles/figures/unnamed-chunk-4-1.png b/vignettes/articles/figures/unnamed-chunk-4-1.png index d782142cfaac287ecabaac11a0a11ab332324dd9..a604849dd78f80820c7d52ab1b4d5cd2990470d9 100644 GIT binary patch literal 19661 zcmeIa2V7Ih-v6J35)=eP1(A~IDy&OWs`Tippdz>^y@?<#y$wtWrTv#QWA|)(QzxL^f}#>PPYLiDS-Rgyh68^S((ofiHjpA4r6Mf2KyqRckzPcn zgG7uZj2}D>4=w@@KY}BGYXQIgJRX;Z2XTxa0-i8}A6dYU&EY1h_5`a0?^&g%QF6 zcp3yVe&`EyI^C2Tyb1leDgF6#dXWvtmrg9AgB(Zj^aTQa0Xz-b1H2`uKBEx&_CumN zvN-TrcDQI7xj`Vp?-+leP9HtgAP^+v-0727yyIpDs1c@PmgD3RHu)p(MI7e(T4t~O zq+4z{_QQ9&SPpsb^^3ntwiPNgEYh`1~P5L=80$C-yvG$sKDEL#`Q9?S!iW7GrY)&FQ3!h?|cMVn(JCD=iY!R!CAY&ccB;6FS;~ z%9J02bkLrQ@#_BL1@~;3hTG#WqwdSlXnq|m7Bp%seJdv-XN%k_YI3;aa-q487eynA zb+m>gVBv9!4@Hl=jH0=uRzRiY&NtG$na0}UqibfIbt)~5P;nnwKH84&#cGIg#k9T| zCX+6mtC&3A$L-_nVvjQ4w3{acyKUA&CW75|){SEEcV4k159kGzMUWqSTBK+V5up4M z^);F4q#|W6|O)W*{D4d-z&cH<209?fUNci%f!p2%J@x_WFl_JD3Cj#_ugHZ#@Qm; zrOW&Hcwo!A!HDk*tLR-<)sQteAFgI;ot^aY@b7-yYZBebj;^S3=Hf+h#gAz81-hoj zhqn!Q5}`(}G9O6Er$r+Bwb~B4V`!kCaHyft@`z@M@EXsxf#2R%?4gWv<4>!dE8zBNE{sjx;-?=jl7xQ0XBUj?~4M z@Mc@%V`|1fIr~18KRqZAcL3Y1cEEq-Q-5WikyotLz|HZ`s2Gp-@ea-B?1@ zxSWJtHmOXxH(|eI&iFcG0*DiqNnER67xNMwQW;DuEV15;L+k<{rpp5*T)1i!YW&eL zuBl~kWGIJ2vtY#D^%S98Bcd*IAC{sZTFt|a={dq|z54y?`r3$bCP&?Rf7%TWF`1K@7!~^>D@J)MCzp>v z`HPbZkKdYmh}n8g4Y-*&BV|UOIl0{R*ajYnfvDV;gh_8HR>?IEk!6uJf#oZ`@4PZq zLcNR&YujrUA#tQrjA;eC)N@a+GPu5}Mn>}RUT%zNcYT)D{XNSwvQ@H3Tfx%^Cw%5D z?tl`#h1vd*4(ID&nbFCPz&w;cDWV{>F{R+O8pUkgd!u}bk9x6{D%89XlDeQRMSf=H zLTTR1!aQ8>;j6q>e74vPF_3G05ZNesIL^qkcqKR{UEEx=hoXW#7t~c6Ulue0(HVZB zcF7)1&#G?UOe=Q2E`7c=W27vyX|N&1e0`cq#i<$=B<>@;ze?tM0-93vBLU1v?Fl`x zW#l5J{85`P;=u>eW!Id7ps(v0!JaCnXg0cC;xN&O)rC<>LBq zOd}X%zq2&&<>rP^H2-dmuEQ~>JU)nt|L%7m`os17H}n0>A!jB#8zfeU>4q`rN{*hqU6yif+Q4d= zNw}EJ1S}U3`AVJvNpXmM>Hz!nRJ)%guy2AoW@}A`mhD{?27_#ZyC&FSu(vUZaFD^9 zjnk+8Yh&j(jq^{MN&oN3R4po(MP~XGj+k}5iej#37HuMegp}E>bkf&t^vV|7oASFe z+Vc5G`k-l*ZO1y%{u#a`(5vd{=wn8nSIjnON#?7a0_3M`Y;RkP6j#)H1oS^!D_iH| zZnZy|4#Hhe{uYDS?rq_Gs+GMntxC@%1-|s#hBSIoZ^Mb0fnd3f7|>Bl^)AyHosMgj z7be}ylh$#(ozTdXl%s!<8lfqRKV>7Nt#F>1`Kkd6RM9@MPdS&J{VLy0VQg~6Mk5M@ z!*BX?jJjBE{s;y|+kIP0p{mLh1PqoNB#+~?E-`cUpkXN}Mx2Pj3$8G(NYlO2+}s#5 z_r8kU?3N++X%`=LMlM+i6vRw(f9P7$;B!KMVzFmd1rHS3qv#MQTz3qq@e~93IRD`8 z?~VLFGl>6h=%rCLooDoZ-=>tse-RdB6k?WMYU6FK{&8mTf$*-aIQ|gt3_n)f=5A$A# z)Vmo`m_Qt96YLzIsLn1fgu0n0;)VVEH^OZ*ch-%>HmB(~-wNN?m|nDmu7>F@T0s|j zM#z3DBRiO+&FQ}sswn!M+-Wm^wQL7l{BiHx0noD@gqd#Ww}V~Gs*&`M@c7c@j&TER zYQ+im#(PX>WL!U{(O6Tsx^I^(XF9TSN)Dc(m6<56tPP)c=ab@VDXIQ2eFhcgtY;9_ z&+cH^>v9D4j;D5)q`4H#H6M3eWyQ<=GojjUT+gAm={)n@BM${k%LAEHR(cT^QIe}m zDCQIwMrs{ce)ZRA73hr#jb08xQxzzGNB9eV#S(9r^mD`!8F!ZjX6pvQE60N1d^)IC zO($7oy#HL#nUZCbJ8qTWX_KO>tT}A3{OjNTZ(5se3X>iSFg+GzAZcYF35{M7S$N%xC{Iva`CHsU%J%=fd`R>gm1dEL87!P;R zopZ0Z-|n6Mu^nHUsAs3h^X-OUGpRm&WxF*k#h%^$(q@h<5tp`G=5E$io*%ZGH+P@b zDbR=?N z1ZwHGvDVh+c&K=AqR zkS4XqKxf8WID!QC!@4^(am>smS75r5P^jcn%#;6hQP~O1qn|?b^i;jd3TF(4GSbD| z8kw1kLNQM=5Ky1(+4F`??=-=#m)%WlH+RnuFx_l(=FxTil_qj^O$42OHGk%H=_2)H z#Y~z)-)~Y>59acS5)Vc+heo_IMKnn;mh!6^Y??UV-PoEbCyV@FIb0>e~-**gD-ZmLyEMiktX6(mN$q#vAi z6SwaA4%3dzA=^q6mFk@{1l~o=i(Kxytq(S$WrBg$!mVf(4&= z7WIpZ6;pgUMh|Lqi??fG`U2%3GWR-j3R?wx-TTMWsQcqKX7TDNYTVpC^00SG@;IIV z7ysPR7uegFw?(_TyKeoJNdQX84I^Bp2USFuEeLlizlqsg>dGzzt4yvQ^Ieb34Ig9; zMoY9piDp~tq^DJ`9LyL3RMDK9!wfE=V7B?f_z><6<>4x+;flR?R_Y}kRcy8g!gMV&bLBd zya2Em0c!Lg-9$Zd+sOto(E(k_eK(e~S6Tndnw%XXSXNne@n2tmVW_!3B-ttI(2Z%j zxt_&l!MFxjAf23^9;x=4I@?QMRN$k-jBZv`Z;o_pc-^H%%$c`jSVzmzKLsqr+h$Bn z(tQ+j9*uSJmq}I1;r98#>GQsOuyYS-d#YBODJNw*{K;qumDllGp=_EtnTp<3e)=e1 z+nT&h=coqCZopEoEc2Oe|g%7;ty_Zl>qP7JOf>VvwHaR?Yy^GyQ@Fh7T!(WPJ+0=7q|c=cG%pWU z*vN05*4~;EP%zt5(Z3ZTbC;S|pQ1>eb?b`2Y%NS*6bg3!7!{j%#lqbC7^SPqg(F3$ zOQ>9`atz;HY2-GeZIkGnZ3>UF3OeU@jJkU`Zsjm?Pfb-wmE&O6+BBWi71ZW+;^#pf zTaH0Q6-^Yq5Ss35e8zWTIZv6tbk6*9$jB92ofvZHqovLQ3`erk#;sJ&Gt<>qm%)@( z;odbI8eY@K-mY%@(2QDDMY~^+>pMAf&h66L%UHz%Td0rEa)f=s4gI-#2UR;-K66S` z%YpJuy#VVudLZ$34^7c(Mmx}PvuJ&-GdhBlRJIG7z%oj6aZ)7DT`MURK?b;!hA(ox zSK`mGZ8=aDv1)*(DFjJXURLC7R{+%tY6-(EizC+(g%aBQrv#T%nV^#|3*gR+@!Bt@ zqh;{3H1Ccdw>E9E&|X6EcjP7vQ07jnH{*)LJlEF_BB^ex!xt+H_4Y^(^;&sV8Lvh_ zqMR$xUIV*K(7@*PQ5jUIT)cZHO0@e5+yN99MO5xPd(@Z75%;U zt(;-5Jk6<9#I3-wqs_2(9fw_mqxeH*xfJWHyjZ~?InRLnt{y^Z8LdDHx^Zn)wxB>V z{SAADMVDZ?4c*6U)2g@M#%g@OW@4u54ehW8aaEPfDISq1p{`zHsfwzX2_JMaN)A5f z)!JpdxJ46ide!sYbofA`s(KmzZe#IkO7EvId;)MMB+uyT3D zl&$oAw?1_t%E(-7ke7ePQ}pkh-XC%PjUQ?@A!T)Pb7iS~Bc%0}j+xZPCli@gfVbx- zTc^&<`O8C)AB|9I^k8aQVqhnsgM-yVJ7I!gAs;d;#}3>Iixor-i^<-svBZ zYpW*a8)Lob!%JgB5-N>NZdJwe_JbztR_g1;+2#Uo<)^<#x=|-wA}f_Q#d8Ro$ut*R z+6}%ats-@MXRqaUNRhDu)JL`t={>FvU)lW&aB_Jpo=%o8Uks@p9-4btEOq~!kJmgQ zM^r#C|8ieuooEs77*XCXXppEJWUur=2Ms)8V%jmK%Ds2?+k7V5#Ew=h zbaYvmm`a~(sP7J3q;DaD+o1B@XHaM1`v+qs*B9r8w#L!%{$tK)wcbO~3F(A5;X)-O zLVoCkS9_;3Z9!CBIDmcv87@NHJ2E6;@%bbC?Via)$eP4;3lqyeQ}y)G^;fxS*isO>oM(yw*i>lf2XVVeT58cF?n^ZFd)Cmy|4h@ zM!fKfFFmtgl=bZ-@IbieIyEnPDetNiZ6>|n@`}54U~bE&2IBbnSETNxH+-LuC;P-} z*js)j+|&BxjUPKMFuB&AT>j+QbO7EKY_e~zMOAG?UqnU}1Kbp^e#_J&S$>1mZ+;XP z&fkyVbCxnD|K9>7!Ax zTUGbo*`<3GHzAqh-@v**>TKdzTj|sK(IBO>UJ}t2PtR4%cW-XGDaYBUi>2?Vt3`Z& z9eDeaGQ!_bQ&jU56gZ-l$8RirW$P(sn7mciI=ds&{wZXw%l?9Fs23T(ar`C9ZZaHy ztxYq|L$SN+9O!N0&O#D%PsypcCdsq|W|gNQ6gvWg z#=24Tz=p^s4P<-+#W}@v$kP&AnqM z6}iBytiItjlI83xhZC4PS@5I7G7I4N&8-YT-{*hm;J>0c z`1h_O|AGYKe`fTtW@{sw|$HGf;aIY!b6U$wnAD_ zp?{(HzuAdHJO_YFhtcWae(ca_#|NF0`zNQypdSq~UeV4Sjmuv4~x zq5d}}y7d<)X8=hWYN`08S{bP{yh29b)2J3hd2a4VfPZy(^hmRAA&o991P7I z0xJR;50~z&!z08rs~?&^FQq32)Y~ZEK>XUvIoGHu*ggfzCu8k#V^`S$KuoaJnEdulATWQyM zu=3wZ(}K0zd@XHngOQ=cw~D5L$*ghv*}DP)B{SU(y`~S;YPJKIp}o?x_vE%K85APQ zcsXhR^4pDpS-Ax8dhVB5p|=xy+AxmN@aVgc$lcsf=+85DD2TW2zf9j+Tp4T=0)>7b zfq`5S`CTjMf9ewWH>>%trk0b$CSfgos-a(+;nDlcaJPx9Fb|EaI99yvf&FVoUwwY^ zRKps4B|ml0E{9?Dv;c?l@A2s`F}bB(TfPD16AR5Y=&ow_UOUFR=BBSr-5%aEYMJ%j zU{&qTilKx%%Rzl|i@CA&k(%*gkFw2$ApwQVjr(M9iozRri0fvw%`yDAV4+JjNu@KZA!G0(z5&s1uj4WY_0h z#w~obdhoI{$9>{KsU``)c(r%bS$bq`tWah?;}vqYo?0OpLYtEXW4Ag72T#1tR{oij zp~M-ohqbqyiI3<#qLg{S`IH4s?b4<2)4x zDX$D7fNMim`OR4ipkC_QQUUW+QnM%z>`!Tq86OJ>bRj*yU{Xs7!MN8A=6!X`nvM3X zP;Y+zU*h3qgH(wAk$CD6jd?VO?xz<(ZcRX_u2YLM(v2xet7W$I#v#)!cI(0w*12#C zL_o^hME^Bc^COL!8(ecCb1Ei!I`q~?pHT7QmY#rxta@7?_j#@y1?Wc0g!+QRP$oiF zrn#He{Vu4le&}b+azjkeTA3|NikG}#8Qn8F=V?)4t&;-GwTjY5KT%IAzE2PJIGB)w z=!~~h-S3Oz0YuMhe%1i(+bi`{(IIT0{_gVfQjipFt*P~vY0*WIW{L(zvNl^3s<^== zOtW)aRHNEZ6P2{a9>WVMwg;h;j|$;)Qq-+Jh3T+?#%6WJAA1n7S}`4SYPPC7>JU|f zowwFm18^JXR>tnZlbxyTcofBYpnCH&=#b=CIsB~k>ISL7!$nd4nJl~m0c|nTfk_|V zDqC+P4fs~koSjtn2LuOAP=OstU6@8M@(sOCPt{8a)<%>?Jl~u>Qh7q#1Hj6`{fauO z>~+V|BM@Fwm);0-oJAjjwO_E^HMo8vvjRZb+8zRZbK3a?dqz}Cf-Ky_qBL5@j~5%I zp`IomYqOG2-W5cWx`6VX%&ac6AZV=8=8A=WCMU|&&W_@XoI}t$@rpM%ONo$4Bh)O{ zcw`4n^1g`!tX;#Fb8s1z8Ik8p%FI)~fnFI$%dCG^erk0vz-=`}abku|vlZq_@BPHz zoZ4~{t;CHrSMr+|8Jav?nxN=5GaIg;`o7A!i{jPYcGNH^kY#ktW~lZ?*|lIa0tWau z*Wjp$iQK2fcva7}jO*$K}yB=R1>tAs0 zH9*Q`^;rHgbECDPfyVfoCssv}qHX?^vgSF1gm!Tx^-b6C#X#|V_6(h_17-Ec4XwIG z9YW2r%BIyfd9YG8Ix@=BFU|wde7(8aVKvdKSUs}&ro3m^?dAHu2-4`Yx{c`zC}Z0l zotE(xS&bcT#XzzeXyi5@xaJrj(mGf5$>tZ;d|D5+cd5WntHj?yCq`)2d*&RfR)L~+ zT&dZ9K`lvU&J?&X3gJ1uOgA{E!VB@Ufo}U=7kK+wQO_0B2!(^5Lrq`t`m}^PpHCa6 zR?^n*s4I9<^QwCSHm$WOIjuRyyZM}`c|;npFAn_o+ZU6^fX2E*XLe?8u4<8_Tt%Ke zXAjO7sJF&etvgaWR~{oO<(A6HM*tEYoLyakI=*ayfin9fyX{9?kMG{MFLer+JZLluAoU}&5u2YRBOCB*anYU@9Nvm^F3VpaP&Xw(+( z&1=t|c)=~GzWLR8xheawvqfQ$A|p{KKUv@RrvIhQ2+q_=zlifH_MT^VC6>1k4Ah;? zfhfC6tdNNv*>(;!OD-0j@*82=Rl~nU&e1M9XMQ6rqc#4doXiKEug59$6E#*^Y{{tr zBD2Ufy(c!y*NP$UenrP8RBhDeer3nE>NVr{2p}QPvzZoO7q;4W-mw|6_H?_twfPi! z!_)Ml_Uo86JD%tjrfW>h!#lo^N9XDpKShK2SA;q%oQ}W;~~R`q(!)c3j|rx#X8bX-MYeujF`JjO_um*|%g_ zFe~n^ViBL7s3|u~?W*Gk*qC_Sfg#G)D_34ypD~G+RnUYYJI|rc#v&tP!~9obl^bFC zGqQslA+%THv@m%)UY(JfiP6f2n>N3=@x5fqeXi|1PV1WRob`%CoVM^h_^BzsEK9xf z%Jqd)@4CisYaMW}CHKQaia)@v%J8k+*4^B6-bG@Prih1k{oTP3b--m;3tq%vG8b;^ z2I-A6G391wtF^C2tiB)Yzv(s0q{!?1s)us7&l5#rKh{17;m;bK34bGW;y&km3fMpo zFRj@wwfR59Z;2{VEoq*!GA8W5PmY0E?=21Xaj=Zj@xOK_Qi(7~xHmD>pr^JUSi56T) zKN}^r8>40{2MX$q3nU1#M;rYB#McL~K@`l-U}xgEAKP}@0}$SVucCtHmUl{-B7Hk{ zb7KYy>OBC$d;7lD;05s>3yS>4&(h4yS4tctcj+7Oo{lxY2#DOrnU4noPJ)^&0l6SE zMm|xK?H?aN`=4dG|I54V|MH;Szv(@HRjT|}xpkF~p-TR;*DzZ3l`~#__jL;r2ezwv zt)N$_Y|yzx8pG1Xh7g^N3BJi+M9W~y4EL)!ALkgXC9j|z;~H?R*zwJ`&GhdHwzj3* z2w4+;je^Zw5eo*NF5cF_GK0O$DU^uGArGaqrM^CpWkPxyn&$yH3y@hed6t1|(~(FG z@?}3b*kR1PXl8PKqk!fIyN;Qp(D2)Wl8$Hw`R$wkn~iYsh3poDE@C@w^!#%5LiOX2 zQ>{w*G1UyvlNn?3uff!WFqiKBnYYy)su%_cVpKw>14@lVTsl^!Ps0v2{GPJq9c41dh8 z)Z;|u{5hTkw8*&wzCzr=W{oz(SIbruk=p%7<8B3!MF2!DsrK9hRHOZ0gw0O51B|Q` zdYl3{e=f+~Y0F5jgv@3-8v7_ndw@Z0lZF6|^ljrX+uhGrUvzZYoA&`9idWRq9x^fVSFOD%( z>4|-Rtv)~fW`38OpNcQSt2i*c%wI)P)51I)FFf~lM8Hga=%F4%XQ@a?SDekeW<>C$ zN%b&aSsYoA|4XVnu&XAQ=ALpeKP(8jTDc*|+t# zrrAuE7oOez33ay259q>v#6qn zmOn&cAW`QTbo%W}2D@f+Nn^lgnCTA;H2qIU?Oi)glm<`lg&yq=-Q~UrV`fg$0!vZ! zziwpw@A2gSi7rl3Ds3CB=?gO{n)c8bM~2?~fD{9kRA9i7^nfG?WM?ho_X3>TK0S2P zRj6*hKQm(~xD(D;#eScKl@7n{^N_#|4%b(olYz(CcVm*fz*U>$GF<*+TDJmUCqhT?up?Q zjY@bk>Q!FZ{BWg?Oq|(UMcop&-wcRutmB zf2vS52^lzyglKWq#fG+`)B9GiqN%fh6SwTBb1EIAqurKg*TSXf18UrmS8(f8i=`9$ zErxo|#d^MAI;M)$(AmU19Dh+?KcSjdT$jp*dhqHZbq=u>Y_YO=>g+7w#H3wy+66zp z7ZHb$I5dl`%utXM0@xs@h|Y*}noXr>M(>B;Xi2W0o_fX4FoB`I=&zO%n6K&14d zAw;&NjJJ#Mp!*%Lt?sJK%oxCok>F`I zuuJ*}x40xgt5-pC>=|b3+m1pemaNVm{AGldm*2e41M60mGxRLZZ64&6TAc3Q18#S&8-$jf) z9QYLfNq2^Qy;=;MPb_s_XeX1-s&|-DMxq5mDf@O~Us!VvW(dG^;}r3;#f|>i4;v4Z z>3oOWoNS+)b{xD>g@47(6)SL2wASfOQ3Pi15wH2x4!*{~^ti{0o-23V$1FY8#~-!c z5+|xe*evb7y4%V?6E)>rLbbbGrQ@tHWFOnGL*YO(Ai_sASBC?pmmF@m;+@Lqk7VwS zJ+p0B@mXdOJB*xjTJ>-oN+ME431k_C(%`_G2+eb@@VWW0@SKI^^GKrBJHT^T7NSKWGV(t;Nv!$zOiiJF%6Q5j@+*lPEYI zqk1DO=b>rJJ6QW!kM)v{yVqvU5-JYEbW@Ciyvh+>`q;&${bi)8IcLS48JY#6&FPbk z*GNt8VEF?9x@3dq7zrOM1q$B<)Gx9Q^Q)H&Z0FEkrkl_k zq@d!SDIz{JlSkBvP}`B~@1yP&B2eTC)6Ee^I142DqN-P2v|n=NovG(9|5PpV{Ke?Q zfn(OS+27;Ty@>24x5Pz|92X==s;r7?(u z={}hOd81;28Xl>7Zc>es!ahr!rKRBB?h3!hY^@$z!5fIE`=K6D-rbxdwcgP4)G92m z%%t^PmCp$>;&XB%qHG0dhcnLpmqYj;5AgpzV-2AiQc+ZnVR7i~u1$Q}TC@5uCZnxG zsv9SCc90GtKPp8xUoJK8ITW5C0)38xy)z~{SgS5lM_SSLRVOHGXZyA=XPo3DJs-hN zfdg5b=?WF3nrIhmY zK{cZ0WGtUgNPl00RNdqm`H=H9FG_P_VBrH>e!jI?E1Of3~?<`X!I zh7I+_fB;y#)YM|cYJyW2!I&(z&Y4ut2S-M4c@^ z6Qg`yBZXx1QK{CxGvt(M^0nCDp1Ws2o#k8)LN~_ns~xnH77qt#khFoL@bhM;QIs>Y z%gU#wJUh`{l9d;NF+g%)8PJT|F+KXMZ&MEl7CqH{`*M8Bd+T}&)W$_J^UiQapLqSF z?of$RoZulOIB92Sk%!r$3|7Sufners-C=b{XC)1B`~@QN!QM~-5EyPh?*7j zfIim(AA~*b!QeELG`(Nw#GVS7BCgT(mI0d&8Ym!>KslU8-TyI}Q*Cs4x%|v5M{}uK z=Djy`KF0U>7{iO59ep^Zj_|ylnRzBG0j{f%Y&1hmrHW)$nJvHjRI`Ka%_|n`6MLw% zcYKNqTFa{kl?RSaUg8Bkr4!@c{jRhWW5MGpf+P@aayBYP94rYT75xbO=1j7gmGB}U lj{hyT$UkiZ(c#)ZbpKTNKE4(F`YXt}Guo%KPhGw9{{fQvoHzgg literal 22821 zcmeIa2UwHK);65bmAXYi0VP`zEI<^cx2PZ>3WCy`2!eD4=`D(a(nX3$6Hx(?BE3gM zNN6G@v{0n?7HS~no51#*{hqSFbI#ko|2luJ2d>P_v!>6Qwbs2>o?X{aVcpBK7XpE> zs;MezLm&(Y2!!!F6D`QeuC=%gfk2zCU%jaek`M^UD*X>Qv)YiZO*^1-c>w9vLeu zh*e~-#Bh?r@B2>CmN-BktN&S>%W}-98$}-Eq ze{3dtwAcz#Y$a0+DvFFOF2)t(z(Xmf;EE{}@GA91>IYqh1`oCjJz9nZ&oX+a7IaxA z8kA8#STuGNJ-Un@rC`f4vFI`^7CdMyb`(3hj9sSSB4u!qR=8sDL{eM8QE(K>C^~Z# zT{emZ4|){5x(uG>(Phdgg)-&qyo@bd9z`#YVwXV$Ae;K3EK?{HV-7GpN~$phjH=iQ zR88$HsBsicS;kV90X3K;FkCPKY9o{#qH}6jS-@iMxu*?hPe0(r*HSv)C!S5**r!ud6XulM*IL4Kv7K|Do5IF7;~kD30Nq`eG`pVAWH$j8sGNNLYP4KC@?yuOjZ zib4Ck%B_vMOKcTEraCXvI!~5P5K^4*A<*xc*BC6{^P|y2q##y5afnP&4YHr#$*pp$ zwHCdII_rfGXz>+?loypDeb%`>#Y{I}du$~q=|igW%aHwTL zYN;GDnU@f62q%5q{L#i3s_25hM^p>g@E0Ru7OS>u`t@jETktYt?$#^%`Ii4EK>18N zQT*~JTK#2ukH#l|SR>kXXqp_1ED2#JR&$m^iXAMVgsIEEw3fDsv7^qk+|&E%_|lJc?Z{{+rAh~WuFqW#r(syGtAnpiKMX0JfLo$C*YH0{HF7Q zBp1Ju+3Mvljrq7W$%xRbk+8=Q+1DMsR}S-|;-z}-bK@T0U^RPOUe#3NZ0 zUR5P}e=-o;+nChnm+OBjwjxm$3||6P`;4;ahp&}mg;&YMuUOMY@&DSOXytqsAL*x98H*kBqH)}5Z!0A>iE%Gj!wJWaDUZ|9y*5#S9$M7( zN|nnX4Kldj9*93b?DtDR8+WUVc;9CX>KS-%-0c|>QaF18=59;M;LAFavbIXNmoP>c zDcx#5bTj6pA3je?XNHtAHmOy$b%CTlkUST|b7v&x4RdasnS_}n$`ZdtLzDN)kwz@} z)oGP1#qFjz^7^8X9hsQ^LL_QB)39z@tBDrxw)}7?H|6_U7K+@)j^;OG7$aM{r2Cvl z3B;ktyd~-AZXF+>vs{IfxfS&Dtnj(y<*n_Q0Nkjjj}78|>^yUY*-g9h7%fN7X86e? zej60(oR#nS?ckq?&>c%SGRpeAn=uUPIh<58>C`&Mn^kV|vD~D!?sQ1(e)!gw%5FFF ziSwSy%)#y}1G{X%g@{Lna%)7yw|eCoyLjVk#x=4D$44=wTQC^p^o#;*!*2Uyy~qg( zjSmIx1P>cT@L|0doFA+PQk1OTA;;JQYxZ#<56mkeKB#k5_{Fs0YB`29Bj5|4ZlZPmr6RAzdO5s)ry+q#) zmAd`(bhk_nn|&jVFOT=5xrO7IF>fUI>BbJ^_-bp#5G40?Eij7Ne7_Rs;?8mS)*W0$ zYUlEDQ^1q%8@XnUmWj!Wae5+|ri}t-n@yvm@$&juZ{-7L^$CI6VEFk9jyBt-zPI5y zzp3V za;Cm1DslU&Q}Dt5c;7a9_4j615s*IDgOS5uDej5{a|LVE>Wt;L6joKg#{!g>4Xp3* z5uUQB`<)R(hdOETH68@JwWgQNb2XtDOWgH zNw^tn;&s19N<7!bxO5?ZX7wupVGWo%ac@d8Z@1G|BYhS*Wm}E zu-dSwAg4V{pOZm_nzPXOJ#}hsOLP5r^j;d8?=B8d=~MhEEevnr_J)5f>> zGeUrN!I=9-vor&sFoaJk3@+$9kJdayLgum#IG$L$TFd$luotszZ*^QnP}=ER*Ff+5 zY!jxOj)bq=zvoIcMnDeQBuy=v@CuIoSe~uB0fpYOyu?|Bgsdk0!>jbacxnAha^k;o zJO0xRwac^(Rk*#p!>Cy)j+&@R7;4O)Yl<*4Tg~6u3!J1Da|LHcJ?rj%-&3cJO_z4E zML0y}r{0+( z>>onrlIow4KRQ3cPPZcysoO4y2Q=-4;Hn%t=B{nBqJIGa@yZc_sf>>n+<{7GB@Kfk z;yuz2Z5X=lao+b7HBkv|*goq{_w_6Xk}PYDh+Vw|Xcm1K+g8*?6vVvuE>7)?>68g4+KTvyLN~7RISu7J1 zVyNias$_^!N?cG=2y#qC1)QLiB8}CJ99B-}B@fTiG$z$*Cm@xq_XY}j0d^$&A35P) zFvfq2q-7i}K1|&Ba~$oh!+;%NL>VoA&4%=_{bymrLvClmAu-tN&R~A^D#XiBU zgxbqvY&kgvKtlG)-R1MTW`J*!y5-sc`;V1>;CsenB~!R!b>u@912{DP;LzB_%KM!5 zkDMI2i`Ah8i-ZFEwx;8SL}EfUr!MWJ^m6pHJ$s66SMz!IJeA}SXnJ~q9h~I~x3kJnwb)-kWyw>TP2Rp^-S(); znGX+5W|Ed{;CCsr4ou}2mSYUuPH0*&|DirGCp85jdRTCXGQ@6w ze=bVtp{`BP=w&|R!-^>kmX12}caokc$NU-)KBtXf0LMl4{?g{!h|O_WL6$9i))#j3 z(77p$2ED*${@^o>m*y?q#eLM@P0<|vG{SxHUIUea8Brx(wdGh?-J)#bOXe_c*x??5_fWJxsn9r>^Ww)OX4EZ+2$j zAIaM9>eZNr{7!#E3rygna^H@ap9wFS>bZcQ3Fq?arNloa=pHMG9iUF23S#Qm4yE&7 zXL%()QD%=126Mh|%onyAk$D0vmonHbi!Z5}QDcVst6@8tU^qj&d0_DWeAd3sY1#JD zGt^3+ws*{npWXc)6xFe;L)iTusNJ#VT2r?3&J*opu!emcTlK=xJm3f+ze`%Bb~35v z(><;}%lz&#BI-Ekguw~vt>>qpsZLifO}9lTQD^tal}Nw0U{QEEsZ#}J{;{tGD~@bx zV~GTdCU6zuRSN-&hMeb&1gnwfOA{pkg%)cfKp_yORio(WdK92)QAh|*2&T4=reF{?G|4P)ZK|eNFR4Xj&F_KLXXCEZ$#@;dWBW}F`{7f|oDPR*vqQ3^) zEAF1sxHpcw@*@&40~(OsA6Z~Ol2JXeF#G`PbAgU73N+rAg!K8zYh6leAh^A69d47$%;B6_8%; z&d*~m7fxSt^2&2{crm|HE4*kEGk3C*dP{&={r=`G%prZ5E$)t{u-{IfnM8PK+liOI zFbajh#}$CY1;)W7@>kMJCMSoX68ybXb@F!qoqi$s>78CF&jLLYcbE{K-Q<$RHPBoP z)Sq4Y($vm#A&w`+jSGCXFCkttf-cVjqt?Q(6koal)>wUK(F*SZNuR4k0nQ%B4Q+@B zXJT4?1-j_^2IcPXGBN<&RC`z%AtguK0!i4 zK!@q*^sgfB{tEkio8}@j6v_p<%fyuT68Zfi0$I01!eaEP+`&J0jtvT>d;D)9^!!fy z{l~{^D759>%~mk?<5@{;Hp=^@$#0^+!%vNXJD0NB02KFittKV^*lT%_cxY+Ruhj zyRQojH*@KC5rSEKw9p<+7f#Y<%Xsfp`|&3BH=3GDKsh0G9*i7MUrx4iEnxkH16ggy zg27Af1FCPe(VDhkOpr8H-la@y9>)_@J=%7_ zsBci7&je}*M8)+RI3@p;dx;SNS)-FQG@o}x%QL?+Mwr2q_cB3_@xGb@s?#FfUzsv~ zE@m$<1Wd)`(Bzjrl3VYw;PrNpsNWF*YyxV#3=k4lo3*{`C7-u;<%n`V31}+we}#Mj z>GAwyxw(QnQnQ+rk}tfSol6{k(1s$D(+t+1;Lv{ZLBNH%=@p681ndSCK^ zFd&LDs(<8fKdQOyj#{xE@J+u-7dT(G6_zS$|Ej+XNt{spMv^2qq>a*>Z6=MYUnVd5 zmwrxRnSIKNb2@S$(qS+8(=~;8b^p#a_hy)c{r0}dnP_dIil3BZLo@tPh4XX8LtPwv z#f|%*)28=2Po=Co*#|s;pQpZf+EXkD72_`xI>$}6t`->jxY>TsXdYL4+>Dr3r(Um6 z`8|cjj)@KDQvT`MC#|Lp*$K)=(ir=ZwaH@E$@pU~wW#u;>O3baG>us3EH_$q9dFjr z=0D*wj&i}LG%Sjmik(OygbfBy<(Zr$LwW*#WXMa#M=2EU$)~51^M4Z>=W`Q=wO(UB zLzEs@d_)X7KXA&Z($cbYGlXJ-C_XA>U#l$mdj45h-#s-0QsX5VmvCt@N#RCiw!U!s zvBvXpwUqC2(RGw@yppi7Skxk$r^YVT5G4c`Yi06D>)c%*Zo8I#lACdSh&X zVXSczwOY0nF=7`I%hFi;i6-B5mIZh3JK5#F;jkVbbMJfc%OVu@ZLW8 zD%mO??^C$Wuki_f9Z~F%ZQi7~d3uOXffP67LSB=|K4&{R<3F81cqbOxr<*OQ5*qdP)qxV`s4-9_=>%MF=y% zf?2gLXlJ+12UB6&VxCpHdCg9@XfR{^n2z+N&I||jv50JEw?*aN2IN>b^fdW-K_m3d zw6q;f{xv%`qp;_=SaB5x{K8~!MEZ?X#bS2&x;(7RghkbFAU8KwQ&&paVM4~-FTKQK zz&vYt;gN`ecjpK13!#0*U&%c=#zd~s1^TfUTjH*I9xpJ&b|xp9;j6_;f!ShS+&)hvbvX|eHC``!IpU@?iMe()qJk@u*!)>B(MYW9 zE2*0cp6T-uX@BW%51ztLkv&BbirIMUD!Pt#d*>y~oz_*g#8>w45)2U0Q}!Jm;2EEF zkyIyay-9e-gmI$_a(E!HB#V_D{hs?XrE6+FWnI=yR8GawGT=U%Mq4rQEV=ETQHdu5Lv!IaG> zl=84eZ&V$nr}22N-u&koW1pU2oTkagfxVc`oWcUd#2UbmmV%a_xNRcqZw>YBAotMpVnC#DP;7SnywxFLT<)3``Hw*Ls zX7X(Z(uXLiSbpEfhe%Y*@JU^yRO&xS*Iy#q1-w&Npx6)$c!`4$ue1tezjTf#d2&8w-%77pvu{je zx1aAqg{SXANA)&)!qy;UE3E+8ylN3pusT1Z=lSap|5{sEFBKijCq4JRb7_bN5%J(a zF5vSwl1PhWuYf;N&Jq^eB| zvCz4tCD-b{Kg?=LPl4a@g`63mUW#;ptxTOJf4HJegW8P}AtR2otCiaJFDgy_dVL0n zQEJ+Ovwo`-5``^|ws2YyHcHEqtI6%N9tS7Q4{3H037SGi0v$Jsf;-Y;8OP>FXstC~ zZDGwQQ$eE*p49y^2$wQE90jtJ;v2diEO4eo9R?l?9Wmw0ZrpgQ}%+Fz!#xb`vHK?W&*OYq)R# zVk=V~-9YNS)WJ;K?#$s^c(~xph1E9QI=geNMxuALrJ+C))dkC6p8$Ii67ECJ;tiq6 zpE^I-D@nT6N;>THy_rA%L_|n8ccJms`+Wic(a>!NSee-oV1%t73785QRMj_dt5{c4 z)|nVm)mJ=LVt*Ys-oLp2$+m~16E7shelbuRjfS&Z(TY{asmyB&zTkBY%{A1nidL&$ zibJE%$tHf-2tGxVzs~w@u7>6=c0j~oC`)s$j{cI>H_un7m$&EHiq?>w%-26SQE{^v zqdwhNBW?h{`aN{!-9EPioi)$p_Gbcb34rQ%1N5XL;mt*NE3*eRQ4MkAYCnJtpZSUM z`+W18#x^7>QgT8zhA@8<<~Q_p?`S^q5r20JO}HPor~@yQMUAa&_?=&gf$D$gKpO8~ zT%!f*{C|MWelj&RF&G4>^?&5`f(fLF+QW%x{bP*nci_hFAc!J+(m?GT{?V>26KI8O zE6-(1%RQ*r0zjK038?C(eL^AW-lp zoS}`l<@1|fLA9*fC&rwNH}Id103a!xiX5z)S#&i5~ z15x2)+o4J-(8VLPRd9t*W0FR!|AglzRawZ~)!O5)Ct5PLeiQNE(JOwc8i-(eD%BS# zVYOk|#$flm^vQ3H&Mb7d6qRYk45*sGNe>QRuSdC5&EtnnWxBzD{Uxd~`H_>reh#E> z$;`W}r`TNp?cz7rvvr9UfFg6vd0})u{J7*1K7g-R8x99*x1R66PE{nZ zUD4DEso>+V6hEULx|N;|`Mm2Hd9cX*BHIy^soVh$$YqK1ZOi~e_=i{Nf5f@tpN6mg zw|kZSXXJOq?noseTezv3xVfght9DAX4e?DJbHC^6)-sTu|7DzhH(RVNfDxWXa zG>oX1MeKrLSoQd3v)r+ohBpjpcp4psM#3z7{+ zj%^oHF*S#~Z@7WF|F``Kelo`Y2ZX>#j2GBI%jqwyuGDegf{-aFO**)MH>2DOU@ zfu$RmLqHGOsK-&_C^(KuIy4uP0Q3TkjDN=In$Osu+!txG5hiXw#(Ot;O3_!W>35zP zRCvxjkV-UHewh8I?f5s`Znr=nv&kF)*uY1_rq-Z0WPRu8ePA(qB(brmD`8^|u8z_Z z8yc(uS~x9i9)P_P_CA%hNpE=l&iaM7LeJ}@J(%5VN6lA7rxu`fjwfJ?)mbn#F{_5& zxoQ^)YiktggCb*7bF9S^Jj+l+ zciHR7I~OF@wvwI3%9gLJdLD{2A^6Fe4HNEtl_0GN?jB*_$@oQwW`sa=8I757fvPQe z!fD!9%e5A(?f7-6(8=7FD_x@VUt~`4=N^p2-=Tj@g_V#3>WJ7K#Ot`4qIQuw)L;YV zMW8}?zP|!g>io3I8_*qDcb?phhi_F8``+=}0Gs*TAn%?kPWcM}^dYFWf1`WrTou(= zTMVXZ;3lH-n8<~#=O>_Qpx|rW{xXiO=Yl&40mbsOgQb|knPv zS!>4gUJ)@B=isn9SiGNVd>4YPY-Cq?zdS5g;Q_!t`p2gLv)za31 zY|j2r^$~gfPLDRVs&`111ruJk5vq4d#}$OtZvY~7O9;&0L_7k#=OzH(s947?x+kJc z1wm|X30~Qq41l-oK!eoU047Jp1gWnF%TzJE2jJ3953ZN!4Rdpp-=a1-J-w-Li{>IX zu*%U1NSh2j(??7_+L=}rgyGMc8h(l7`dO1R-PxrwqTZyu2>CG z->d|&+ZTBjxSPHBLpkpsx~mHb^*j=IR^YAh3h#TmRqjUT5ywaVnu7 z%kc3j7KT|Do%7*84YFF3WMKr}y%Fy2jC@FvJ=f4@=+YSL${ zJ!Jkb9b^Eo{Krxn^VQ*^n@Fu&pnx3|q#LX+WfL!$Mx_zf2*6o;M?(up7wVNdeM78(+|K`- zcVrOnK_KB)9&p*t3*m4}^;N`K+LSaCoIgCu)Z+(aAsu;{* zncql7ea=g^MGP4yhl!fx6JcAcbY|4|!k`9zJc~BEk~lD*Qx)|{VgF;PKt-$2f#1>g ze8~w^J@=fDlM_3@Q+AvSzmvOg+42trRj1o48SV8R>~b)a++7E-wgY+Z!MrF^y}#Je z1gTOPKj8NoTKLoR3%IgmA|Yq;Q=gdvPfU%!Yp0A118Sk^^eI@vX^cgLeDSAlD~nx- zNJ7d!iQdv8P%+WLpZR0!4weK&8_u1Z>p$&gLWfKO4xxV#GL!EOC5+)HC!6wzwi@|0 zxJk2%im&dNZO*vAiVY=Bw9VNi`MhY}%Zd}CICy2f8k)yf+!5YHOOOlwH)Q?02HdYG z-|9)u8ag=h<$XgEGscNL+V4M_A}3?I^km4O+H#CS4q_%Y(JZ%Xi{a2rjgxi$V?i!2nu$@LPID7pn6m=ov+ysG3-l`4cpFN+gzCmc>WgJj zLN1#|g!EdB-?0CLI=&?s&RT-4mN&-NDH>K<&ebxL8u9{vR}z#(RB&oggZ0qCc;)bDN0t?$#1j`rjtAi5ho-Whvf*Mz z*pUuQ;e9SIPEKD+fEiKAH->$*znPHD`@S2tKD#EG6e_NW~oOeTmL;7T`CNfxI35uTt8`i>T@_rGKo}eJ>U{<`jFfRmF}nynma93NrB&69Z8Amf;S6g8ZbJ zQ-@5NL=HKwI^OJ5ZH5CDG(*_D7=fI#N8nRhHcx!NqL_HPE41{L)!`uvf_if-qd+L>~5FnS+5#r{JPrGRZ^cz?Q}K((NJI zC|n)Dm`Gc;1j{EkI<0azC)~YcyABugEQ5<4|wA-M;H^gi?D4e3StvL1bEAEe+XJ*08 zxfNGUCxwI>t|igAnL8+3_BiwQ1QdCLLx9a)E9!dkg?Q0P-LmIYntP3&hlTiatt^(9 zkduxo55oJuu9n(C8(LY2wPnX&sQ3FjEJrn>_hKX-2a163K2#dsU)xjDaPl^orVk}9 zXKe?VTc7hv(dFAg4VK_-ZP{AY3ho8bx$ts>V5Gguy`IY|G^iU@=hzPK4exUbZn_mV zNVY*)Onz}0yDV|gT^P1jduWu>k9D#E8)hG0@l4UxP@~B={`UT2CL>=KsI@0Z1y)-? zGffWL;B(u%cC)f+~{h-~91Uo6|lZ*@W0rKHZfzHDUZ;uYEL z+C#+IMRxy#W}8>;poWN1zd(C~U084>D_LcfE`NeX$?Mnb!F7{t=$Nm@T`MI{fs)VUK#UY1SRzL;{Y`um2zsqm?7Dr!^*yn1e38=$we z3ikUOa8ZprVE+y>%$Q~tUmxOtf6sTlaud=i_?Y)6h4Qo8cP3*yQB`5SP7u;R9!*tt zya;LUILq`}QD!g3qokdA{KEW(gw(a6_?shspU&B?)~y)(k~>BKSfstJG5?w7Za2V& z__~E=WXB%{wy}^KCu<#|CPPMN&RJjAdB53EyDY>yNKx}Ug3aRZM0L(Lh-PRBnw~6H z6I7AGyRN8zNFje|K24K{kc1v;*&JVKq6MrlG~0l<{zzYHe^k)%Xkj1Fv^W-LK_M}ZI} zQe++JjbTT2sB@ErpW3fZ;jA1;9RMh8tFyn-GrWEz8zU)S&wDhNorf0xMK+*yD7jZs z*R?|5wIVr0k4q%eC-^slhF>G3K{(aM#vg`LS$JyLgV3e7+sOXh`2wDj*F931j%?8p zaSU&J?u$#O+IErDEOptRf=XjRC{<&?LHAP;O@_j(s-6p-=NZJ)(oT*>7)ZlB3oC;- zZi(;0L!2JF@KAHoQ(3V-|Fr>k!Q4V^#DcJ_HtpxcKZvB-it0ZhxPA-z@jVEodOy*- zG3#*VXC&46lzMOf;bImD^IybK<=`)WIj(X8qW?BcJwEjP>dbl68JGxTn+opiX+9-> z2c1fZl}eJfU>&_SL|^Ui#!^*YIOosfL~8D@Y2?0<=y^j15++lfxZO0`R5qmV!{OV; zyXSP1W4A(PMkA4TkKG1s{P~P==Y;@5({1Q?OK-_&83jMjGrW<@RdTj*Vu#Wvx5stV zKg5YOaD#AA4=Z-vHB&8R1l2%!tC#Q@BHZ;88^XF-J7UiIpRMaVYzxA2L_X_-h+5*& z`I5rJQh{uF$qO`Mo10;_3c)y!=E1h%oFRi6#cBPvtt-X$8)ih zL=fvW-nJUCGAcUcP3Z1mPc#vuBtgEvrh-B)@_#REN;L{Z<81#iW0Tk)dG#g4>+egW zzvo7V|K`4DH33r{oIX@VgW^`}{wkH2i*<{&>azH%pIW6xbjTt|{v8 z0{m?p^MBM_|GWJ>(Jkk(Vq_5OOIV%_*?~B69NwU$n^hKm%*?&2(7f}ciFr4B*DyU} zw{S#5uZ0`j`C9<~0WO!q-cwt*mL~4mjkbpr=?D>Y8?tMDaM$Vp2ojhx0Uq*uH_Hz> zha8c{Jp4qDr3bO{VjDa0M`4`4gMn$wwZP}{NyqdKB9wJ`7nzc3WB*$|%>bC8I%PVX z?Ui;Fb3a&hp5>_saNg_yzLq)~c`_zEk>>z}zJ49JV;X`u^$qVajSqH5c5FvQzc(lC z*pL3om^2ZNlwttUFq15pC_i9tT1;AmdHH45saRLf0@SUVbP{!ed5jlCOwV~ z2fV0@bLQVI1-vyLW!ez%LfL)KNi%Bjl&II)y5+V0NzqXS&mCZ_tEnuaL>AvvW|nMJ zG-Xv>w-b4lO?ArT8n|v-YDHKN0+Tni3!$>1ZFI%E_feH~fTCL6pIyP<^ZX@}2x2@S za|M4wQsM0G`=JdR4!{DSfcvfl2Z!{JHQWDwyCo1Y{~^2VAE@7dr;`-oPtg@=M(EBS9Ns|(ydGLMAPd%+S_At$b6w=%tQ3FvqN3NWLk*8k? zA7hXg0N@db3EIPCa_08;OTbtjdT=!o7}G&f^i4$KlNezTNEEG$sALz=skcXaZm|9G zJHzd4HeTa_ElXcGC&$s>g=aMu^gnl^NCKxfyQ$_LS~b1lDSbGyxzX8l1sz^clX)t<^Gi; ziu??g9cE5%cEcRYkiy2tVacuX{(1@Uq#^4ct^uRh_B}3^h~H2&Tg3ME&LYxW&rA9PgYyja((##=8#8}^{C`J`p zEYj`)2>bOr)aV)koAkkFM?ic?YNJv#i1T`TxSUIOlZs94#28USZpzs8oesVR@ilum zBL~kQ{>eC+e=zvww_S{&hC^6(gIJ!lov4V?5M}`A?x4E=T@2*^!kX}uzKV+V;+ER* z+IwSGEg>bxd+jP5Io|7<@5>3dMldtq?Xo?8wV?37wE~MgqabRCQ z>n7#d&_oIec~5ovz&VnYC?pl-<%!XimGtqx`uSWzQJI{sE6GVI{wAh{8-z|Q2rh_C zP;5)tUuV?%0sbM1PXc~Y58=q}?w9CmxZg?BBpV5_FDv8p#Rk?6$EBx5cWQ`A7{`dj zm)^a%)13*8)p0NM-CCXAsAmrPXl^@!u$1yrLtvG5b`jcg9=Kh3f5yXBa!d6PhaC(e zYrUZ4-zW8XW~>pJ*vCkd7XavmUO?lQ{URFguS8XdQwh82$L_7JP3u6Vlcc@?=)~=7 z7_D|y>eAAP5h(sel2sKOktq*be+aQh@iL4BgFF3mSHi2Qtc^tWe)7y#(iAq6YpB|X zY4L|GkO-PuSTU|a%dt(t+XcBhbJdS*_CGe8u79W;n^^-0QIDU4 zV*C0y`3#?sa>q@or2=On*`}DOxaCt=QOTxSNgj>`o!@#Q50zr9Lg8eQ?R!loC0icri1?Y-o|0z05tcujFZ$v8kukF zMt9)y7*v+PX>+8KON`tTI}qvoZYCQ2Gg$gO_k}?!Y;51~SC>^DOe`Op zNt)tjr2cA#<160CEcQ|PlY%CWU^VS4%Ag?NmPFTH3{NU~K z^#=>JYvHFAJeI&uVz^;x_)o0$CbCC^c1*DA#~jQS*uNoNFMy&B>b#Q771ocip}099 z3_J6GQ_ym8aC8eC(_6QcslT3KPyJ1Rzs(Up3Ik8i7*~2rSNbyVjfKXXgqXAT378Cr zw+Gm8eKh%E;{hFOCa>jdi=Tz|T{fJ|+ru<_t4HFw7EYB$ENF7|ve?es0?_zc7q4T7 zimzFAN<<->ho!5Yv)}~9YDofvN-T?yce;m@hz}4;H62w65v*o$swc`fSJDpwycU9TF{FOUsI5Ar6@dFF#KWv+t>{ItDY@ zYi2)c=1tO@twtwW*A}0K+Gw0yQ^ePG3Y@F5oVpbs!6NdwwoCsgY?eFRaI~BJRR*)A zOnpx}Bg#PGwEvCE>s^Yv>L0Md-A%4V@W$i0B-{0X%chjE-U|x~5l!#u>aoxLXKKbi|D{j+^Z5b%woj$7#n$y2+*p znP1q9$}n`DN%ozM$J1sct1TTI"&z7cl$4yXb`jAJR^Perd$PU#%A5rryWhq#hyF$vzewb1jxr zm?8P+&#Oe$Okzsd52?8cc3!E?^0GaDoV3L ziw+jm`1?~{$SN_YNWXSSasQUa;4B7sMt;xS@C2F_OOPZ^Ey; z8SeY5iS1ci?CE*M1*zZ?_P&{zT=Rgx<#)@K4-n|iHaPem?6r$ta@H8UXtW? z&1}htff5+gx|ruDFjp)lx1v_XVc3K_m(gh^lpmcq8v3_(*@4+x!|n>gC=yAN&wt>Z zM4H4$@+`k@dgB?}BwI<9@M_bUBawp)Z@ugTy&rOU-D8^xQbv?xoqI(2L`ctCz8Hq} z!C;ES`6+amp>-5DuBKfG z@On+kyLRS)>(PTn6PcT#hLYf%>@B{v28ZRc2`WycEk`8#jgpttLA2Z%`?&4`hihgP zmYuH_1@iV}aW>@X=;qO9`9q~o2)3?aXOzs7zniE9W}o#^SE%I;QM;Ud_NK=Bp0Eeu z#&xSbCCHm93}k29hRyvOi!G+@n+DM7i|6gJlpuc<9V+(I*LMeA958_{J6N<9GKo1b zM>B1Nup%Cp*}NOQk***-PBP$+JqjCO3UbI3T56gQ8qK>roZ)Mf!eFnLVmnf8^`JEO+bkte&7j@Lu9!8=~HH z5&uC&L0Hn$AO~Vd3As3Ay9$Tr#@$t0&SBNJi(@w;E#GLu<|0`XW7hEjF65w;IQIH% zcOD$+eH;sus*vLud$XI?E|i)fpRz&OWTRCfYM<@*CB)bHQAS)GUKbHPwyh~})5!Ys)sLmO zY69w*+wrmVkCQn#ihEZkMfSEQ)@x>osKGa!D6MI4JPP{WudWFxYY|rqo;VR|0=Veo z%g5V0p7HYa6L~3H_Di(1LCix3^bbJIL*)Gj-@^)M@bK}QCZsY-#$YX}tDw#iP)X3o zvtfFt7#7(bm)??d%1_f=bYfz{jS+5JQShCCZ{xO=mkX?|De^Br`>)Rt=lnNv2QMt& z`jvSQPgsT>*17zFS9nqNKveo#3+}P9CLpymfF4?C6rG$O=20Qk)z;uUvLc=vY9s1P zGh3+&lJwsCG__C`-;hU=^>`}Kp*zSKyBut^jk&D1{uZh zmLB>bD4!Fo{%Kn6ZzEYrpVA#Y@h3ipB(ucr^yqqp3=FQ~1T$_c$9yzO_Tg7G3AM1J z{(cBzeg<%p3py#Qt83^i>6YzPjo1eFH*s+&Ld7uQ+6US5lk=f@8lY-v=%JKXwu|>f zN_+^$`sv$gPP5xZ6PlHe;=v|!q0vs^+X&kpGA6&n_T#4*{0&hnqr?bG@sP(c%nRS0 lt@xi%6aU9#^XC*s>(1K;#1d?dP=D@NO<6-J=i;qL{|99fFfIT9 diff --git a/vignettes/articles/figures/unnamed-chunk-5-1.png b/vignettes/articles/figures/unnamed-chunk-5-1.png index 6be246aa08c82957807d76d63b708e7908a1009d..af1178f30cc849ceebabb0143ea72450f28a8da6 100644 GIT binary patch literal 10334 zcmeHt2~^WblXwy$hm2g#kQoq&BZ>zS)Zs7+{A5Hx5xf8+2q*{&D1wF?5(ke_1TrEB zBA|#Ma$n&LpbmsXL4j}zDB%iMOhSN!9NTer_S^mc_uHMB{qKAK@4YXtlGoK$U0q$> z)m_z{+ed6I*Q{1s4THhfSX=Es27^gMFqqVotQ4pze)g&u27@0wVspX*pfDH~2J?hr zu`n$7CBZz&0LMx`o>)%+BrK>Q4La1m@&tTX0HBWSNgDJd0}zw2Fp?*hL?)5QgCu|s zigP5Ns+=5ZPE}P-75Js)Pyx`%o-nc}mP`Twcn8UYVzO8a_yCiHQSzZyQ324ZsPrlt z02UQUsRHn&no6V6=u}Wir&HDMUxQeG&+k0>RIAJ5_XW}IYrvaeSX@D1qVbNIt#B{NEDk6YIt76fpEII%hiv<7>#VoN{O!frg z#Diop5JabnSu`<=E(SD-`Vzt7FI*Opei6Wya+j@eS70#BSCTLM(mT8<42FhT@85SK z_|e>u*j;@xqK_4?lQOgJs5Po>PS>c#CMdqk_|OZ37^6K5vaj>r7VC;i_GnhtiAGf& zfw(?aW}QM%gT|_G1vIgP;$qgPy?=OU!_OTlm42Hy!IX~7hDpJUZ4n6QXCh4Ldo=92 ztSoH(A4YwR&~eNM!-La1jkt}%jRclr7qy-@Yw4IC&dhc#H+61n8xbunPS*EbzCUhA zSurzQzKO4RE|3?$tbUz@(+D3K`L>~)tVR+qX(_si7|9Ca<=6dQj$Ie&ugk-QMoVTF zOp2C>-A-j85LOz4hMFCu*tHLdrXk!1^R`P@jZ-;?6jQVc=;MA42g)XiKakJUiC5RS zKtxi$^q9W^d=9VW0N5h@PuP~b8kjj#IW+D0-RPL@1IFmnQ79#}M+$t4PIizuaAfT} zRI0jus_>{JEMy?r;MD{)0F71KMH+>|kc-VD{ zGr?)pAuRXXpQ~Gn?{FGfYRffCGhMjlnwTv&B>p^^-Wx4qdpRl!mL0p!y~(a#G*_+8 zdfjOIP)p#+`s6qi&6}v`>bh^r&t42N^c>oXb``Uyoy-Kwxx5YBQ(725b2})pM;Kh4 z$e11xGR(MZ>dGxjiM5X+4mnzhj$ESCf-q^MiH|GdrY!1!SBjvP&+q4)xVT^$!}Ke3 zC%1I@iT%0uF@&|;TWuYoOpe^TyzSDNkFFGCJ!f;wzEV3svI~{22Xkp6PE6PzAvEF?Ml8{v)!%YNdMrL;zO_8A7iu`(VKljtzLe+Q8NS-< z>C_r4VV)}|93kTq4d;!DMz#CB$roqOqd!K79XJ-6Naz*E+#++xuUebVecx?RMeX_~PUzV9C$oWZ?#L>d;-JlHF-8G9eiVYU$D zgb^kWY`iGBuEDt@jWwu}qHx>yzTUH@(k0bNJbrzecz7u6E04u<^+|r7?iIA@YqtxC zc?Dq(QR(3>!einhzt4xLkeYhu@SA?0TXB;Z6;qs=V4J8Zt5F6Qd6e%K{>KONiOy^hHUg-8$oM^Cs9`aV23NvPcisTL}07TgUr9Vo!x zA6#&mS#^>C4bKQAefJKKox8PCBffAK`MSYo?8nV~N*&h&f-NIdii4 z6(7zxX+y;{M8I&pu&gJSjh{0d@&bM-h>*ve=whhBas5};%3I-8{PoeaJ9`R` z5%ADJxiN|O#^q3%%eB0E(6yit%+?xuz9!_Hb5-ltk0cx{Nu|S@X?0-Sx|uC8s@Je5uZ5I`8UL;l2fXbxo-d zrv1nV6luCmEq-Jn*p7K_h$8deN5kOcBs$a;GQ|Eo{0%A8@dRBr&p;ug!*Y3iK|zNb z5*SmOmnao5_hqkJ<#A52XBytw^j*qazxR01`$q1Y-qfbSpz;Q3qvOuP&Zbt=T)nfw zjTdTTm`R#by!X?{p)fUOr)OZdTWVME3Zmrwg<1_lN*9wiJeqbAqu#sKB}mPWs;cXf z(%ri;kdg+EZA(OyT%CJ8%Dx^t*(0z+b-m%#^A*MUdwZ{JL`UaZPYbn9qg2SMB}Mz7 zg267=rB`t5qm?xb&SVM)(?`i z?(x#w=eJZQVF;gjV=4VSTy!)!MILuDBrKEhbq`@%{Nh>Dw1f6Ur2uj3Rw5 z9Rd{)<=Fw+XVZn!bw|94av}jhk7-2X!o_xV-lp%89%ZX9u)=fIs4>}!cmZN4B!8*3 zdXEnnccbcQEmDh?v+FRK3nO(|`NjDX}AZWxta1~wTSqX0*8~-ug-Va4vOA<}4H9qN7 zqar-uD^Msf@*Pj;Gn@PBEtN<;&%QGoT54LzDTrJak>iN#+P|>hB-+&R=5BS($SUyGbud_Q zie|$iL8v~6$sW&bMj#qKDJ#Lukw~Hv9FE=(!DRnywErNq`a8t88h?oSzZUg}s3e~( zk(VFJf;AD9Kuu4p6`j8TqGo-p@VGd-#)8qa=TMyM@HU|Sa8CW~uTd?fv{R2zAgm@p zX=$~KFFp9!vHWM$RY;-_BEY5gs8DRn`GgAc6DGT(VGA;2d79Ui z^KdSrv)v*&eqw{gxgd4fhBMPCeAf^8w)HP!Z~UP7jS>uO*0>PpS3O;r;aAPG4b?QRSLkE&o72=tUi4bcE6wo)ic)~c1BJX7C$rJ^~XKnAJJA-p3{WIz@uOLnVvUU zWCYzA?dfy}UUcB!yeNh`jPZ=4l$U|^@@?vHj+pJj;sbBW6`Q`$s@Z%gBIuau;(*ND z4O!WSsRdi1on2N!WvIrn`VW=ft*I@Y?xnv|CL7ghV&)sIQ2&a7bUZoOm;AfPywC*y z_aAQAi~Ca-B|dVMpCxJwvj>ivhs=!Jcr44^)6z+%;U)068LJai^M~yy%t64Hhk#d| zPaoJ*EHCeN*HE#!v4wpO4YW5`*OJ=p8X{behPju0!kv7;3|jaRf*m*?KLceI9=e3l zI+hO9{q|zOM*bK(kDfugO@!Tjk6(IKO$o>3apofdRhDZ92BQ{4H`x|+-hOFvJLSC# z$k6Y$1DD*nrr81rKT*43{hvtH|5RT8Pv$><2lAiWsu{j&%(~*Dt{O3aEjY*&Hlx>+ zz%PIP!w1@5ac5H0SIzOAfhf6#M2)jh+Ft8ZB%Pr}3J$hj=37$j+FT+md7TS%U`MH^ zrnd<#YT)$7dmOwD!rDw5{C*L24; zHS`s3eM?eyzMU2x+^~6_2gL3uWXQ*Aa+++aC&peZNPi95QQAzIz0E95h{D>sTvtW6w_4#}!2QRx82#kNj&B%5ia5 ze6MMejq8sIPl2qJ0s=ufUOxi`T0j9x5|vNiuG@yV7e$1a z-Gq?B${~MDUINe(1VYs#3I?C{-VZ)6UuEg2qBNDxPfxS46Q-sH;|&KxXrXz^W>R29;?V~TpE>b1#|ML3X*KL`a_nN+?( zYS)zQnmHjN8p}sNE#hP!ffm1KzB#3~4|0}ywL^*YNTnn1nLv1XBbEw50S8UWLBBG` zS|zHV2}RsH&aN^LCrrifu#t>DjW~8cB0%HyZzKJJ{$__RACYpF4tn=^x(g>xU%c>; zaGfD%W&1ZXe3A7xBY~zK?99PBBOjf63c2flZ?Fk*&-x2f*IK36c;dQx!3G;U2;9pC z2-tD@Ch$+ja?PwZvsVkq>vU~26(g4Yvy2qw+R3w_h*$n9BzL2mK@oPpi667I`(|ue zPL^s7#SSuZe$qyx*JbCych8kE^9SmFjhcyE-L>Y*!7r+OP*Jpn$W~C_?L7E*(X+s~ z6UA?3zcfuDW`c$~@ZA9$rfw0x(m~H&C$6gz2$e{mkk?a{NKYTsX(4t#A{JR}2<=)@ zwlb^F(t1q1d;+N*zrgX~!&l1|=`bdH7o@&ca?xbk4QZL_u3d^pAfk!&Z~U;Z zdy$cc%^)~@QClc@7)eARX07==10ie`vhN>UkP)No_f@eEBC2bnlR*?2 z`u`^acplwYRkW)`Y80zPJl&$H`$_&y2WL4j4!TVQ(kyt`xbBM@NCgm$Bxm|C1rwE7l z-B6Z9TY=vb%mBMl$)p6?|96M~_YLz8O(~HcE99rAd4C~z)eJhhsH5J+( z{ctMO1|n{_Z-6#>PM9Y6S8N^%&1UtjG|m=RB&vRoZYWkJy$sC;QE=mo;--!Q(aQ74 z*^El=kTtK*N2?6=H;!zbu7l1Lg&fyQ&IaS{9*p9C5J4LoB6gkxr_z_awq5W96_hK) zc|}t_<&~8__JJh@&SD&QD?I~Tfr?7^NP_pvzDSRvI!So{4Jlh^8$8GL_I*ZD|N9>J z>>c7)Jx1K#U!H?RHx=V@A24SEW(d+7$X>LaeT9f65x*jbKzg=`7%9-fGU%Y~xVX{x zLAMiy3bi}B5I~db68Xf1M>p`iNK3FXj79)u7S<=C0MOG@b7@V|KB1zcF&QSZ?WLz?(S`(?=OGl@$Nql zT>sKL;6FwEPxFQUCA0s{^|!^DnS==6cm9^*W{Xfk(Vh80iJBl}2D3*wPUyca6YrH< zZj1priio(^BxEkCWdYypbSO?<7S@X#s||k27pG3V#>@}%cTpkOlwvcE+e*(6hSKvY z>1ZrW2(PMjT$Py`y;J9{<(<}fLnY$tZX<4erBiC8y@vdSy<5>RUo}!GoA@)hd-DC3 z)PD^Rhr1b|QKhGk`QbIBa!!HUrUjYI8QnZiMvtu|-|YZC3e+o)DcoNnFHh{0WXVGz z7+ugVU}z|~EyaZfa^&2=^KV5E1UtzQLO^>%rj_hpd(Zwu>$o`)T;zpkz@+MN`b%spkin8X!h#OzWPza0BzqYW!21F~?TmLN5P%MokM(O;A*Z96{H#Ybm zMuFtN0RR4>zWJK;SeGBFG2bkrjQO@N)vo@EL4%RjY}l^AnZ_ZbMT%Svdv-2k^Iif~ zR~+~8@SBWV-;p@|`ICNxBIcU@ge5PjT5eCBkw

oxHX0qH9VgnW+(e&9>taqD}70 z%C*1X7SK}cg|VKX!pN4Il*JLI#SV>+l+p6C+mCGYI_~7zeH^EZa%ILjOZ=x1ey#J` zk-s%emNX1-_^?I1w4lw14>J&hB7qy`J3K;2J57mf$HMK!J530dK1j2ljCMt9dO%w- z^PAQ*N7vBm;-+`EPi1Vb_B!t4n^>>+KPog^Oq(E|{VEQ{ToUtW zYm=@bu(^>J4+}6qa5=rCWy{N+RPg~tV|2Z#^~!X~F|peH6FqWMY!@zu!>}G8-Y+pF ztm!8pgG{3}eW7-6?^NHvbYQkGWZ2a$yTlga=EW~=9bH}6i-pTsskRW1er~EJ-NgH*Zz+m1quQ+9Q^#>SXt?$Fz|!rY+3M!T*;fx5 zFPBp4eAj&5OUIbaW$Vu%$G){v*g`-$&IYQQOc6a+Ru%4OXj?iiqH9<}O_x<2w#;#i z5*92kH(vT8!JZ4w)E-bw|C=eWO z`n(}{SLxI~X%F_yv~9Ar9X)@3{FFys|B)?Be+9MFhG4rYk zW;{-m(|GnszN8M_j>+=Z*#|m3xf?Oov)Fu3xtfzP?b$ z&TwP1fqcB zYD*Zbe}2c`B^8YyzLL>xh&Yzd&ciAN&|-7VQVJpy72u!r^nCU9UM;34%tFPe0W|uiFG)U*3=~m9Q0^(lK;x+k3B5RA@pm z?Exknc^!;TA3Uq^yPrp|e~?{R(OO!K^Xo1&&k~~~bJK9b74k%R*+iPmO5=R;OF}f7 z?RT}(Ol!b{IKOw$Wj9EV^=T*)|KNh(TzEpNV}@P*m~WspcAYBxTFx->&HN2~n2eta zn2?rI_H$keC+y7W{6z=6CUejzFfQa|`aepr#}>oy)d&A9^G?$X{Iv~cZDG5=z})Sp Fe*qVR+&%yR literal 11308 zcmeHt30RZKvS<<_1X%}EP!NKG=m?@B`xaL~HV2hO5L6Ik7i5toBr|NIh(y_BR|FXZ zL+9h`aRy!+03Z{~d8dG~(zJE0T)uCA`Gs_w3;uKpif zGS=nWxo;-~0^!rwJ7)@kaH1d(jtK+@fD~rc6ha`-TbB&4oCj41L>&TgfT*iO)WI(f z;y_STR0JS4fcb`ol$GU_fnRb?Jt!jt2MEDIod9~`90)iZfj}WpKw%MB6atF{Isj~T z5B8_NtR56{S^Y>E85CMQAXf&;Hn^T#PadfUz>$&q5%9|*m*tS_%gFWhWO5mq-8e!X zp^*Wc#-iZVDL4lT0Tdj2Gzts+QCO^z`kayavJo;U^&@1^0}!K)&_H30uvimlFB-Xw zMy{ugfI_CxKmm;`8jHmuIIsvfK$p!mpfpm?qLEp&5f*3$q5$%20&GO4@6ne)$J}@I zEbl=e5;g2E)cv!MHUxr%=$|`%<$lU+KQp9n4BdTG&c{vY$BfKyQ{e}TKgkD%#@Utm zcB}q$v`4GYT|Xytrr7MaYo5hf`c}POTP*(LqPz~+vg&U$5QVgHu0TIWk!R+$Xr0J= zMcfd$eSI(t!W)By2p&K}LJSJn~mtb#~dZ#^{p9 zI?OqfYMZsYvTec3gYi17p0tS-_7rlMwa8el=u?W3eBqms0`xo}XVF7eR%4e??o&cHAuVj5R5-?b7M1>u?Z? z7RU7}_G%#Awh2b?>1nG~t(4ZMVXIxyu)2@_e#^DjrA2XZA4*vw92Q>P*iqpxD=Zq9 z?m&bLG8uso^!|+9)iKpSjA>GHa~cRLUmY#gNi`d*(Al~*IUcNyez)50fk{h0W{P5} zmvaoYJ-vb~*~H8|L650RS?sF&&_CIBRo7ocXKjYQNS9>2N}4hgDSB&;y0!Y`pK4k@ zvkUJ!%hNHBzMtz*nC@_snfaQW6F|fk%e|^Dsz`8;M>tq)dP@&nblF!H^J4wvoLPvFLG zjZL#^H|FO`>QN4Z3_Pp~L;K*+X|Y~E9$CQz(N}b?8=8|16_Yz8TC+>X&g@|zNJ-<1!OIp~UwW}} zpW>o@X>RiOybVy-!WS0I?5J)b9`Mmk=lmv2rA}UFxkd9FG!f0T-Ej4ny3O@k%U6E- zzD52})BILH%O*e`%;5cg4DWLf{=GPb@tBVtR*`D2lLTJt7pxI_tQigM-qtFtnBWs- z&8)-jR-{FG_X%W6ot$!F+UAU|T9X*1(|H_l8q zL}b+s^3H4QAseHM-xLRUM`QB_mhC4E@m@H$>BDk z@vlO-IH^2tQsXy2eo}kGN4g24oZsFo{z9m;P6y$!zuz8N#v498JF9H!GCW`y3(YaA zT1Hz?>v*o(G_K1l!%U6Pk#sc=dEcA@Lo0b6%Wf^CeB`7cjw#ZWx`QB&BS;m0eSUkv z<(RaqfZlQ#Q(%5Kj+z>2pwZwAb;^55IImcdXXl2Rvhsw%wEW&-^ID+>_iFp=`tWOL z`eoH|{3YgUAZBHn>0N#nwJ*^97W9b80e;R*YtQMcQxuLO>&P^?Jwd*(ct?=|>X7Z# zgz)BL@E#Rp;J|Z4(AX9yBwyemJb<1my<@HH!H3jLI`M6UE*zOr@nuawh zzTi$p$uq%4?qv-Yv$MT5aT%JUrJ4R%S@N7mFI|+hP6@t$9o6WOYZP2ZODjq6DbV`W z#wq8+F|IFNJM0TWCfuMozURrUHN8W~wV+Vj-F~V$t@zy3+a>#O+q;O1N6${cj1F;{ zebhqjc}**w7!DXS%BH=kxOO8t`G_*HgizGh6e&tb`DC^JU>MaVkSx5^+i~AK&B1`r zS1ro#I*OqlRZ1l~&=d!+_X$s1&R(kn{Rx^Obp(B%>$fNj-p`I)Jfy}FfygG|*Qr)? zU6GFF4&s_0OG&2-{{ya$EKS~uCh%}4>?wMyi&EA~7_L~P=2hYDGGblU-Ntsi4a7M2 zhlMtsy#wSD5qiTzvJnwdW<|zT-M_}?!wBn9aWBU$Bo}OT2+SY*^lsz2fJeVGH|f>3 z1>0f2Y}l7wV)WSSTK*W})=uVhfvjx{i*P;Z;#hR++>v+B6o{<4(c~VcWn?5_n#b}^ zrIzW5uzX@%!{RN6wxD1a+(t!X!)(u#4<9}`;ELbF*L%8rdEd=mj2tVcIDb}N1)fqA z*R$Ve1#}sH*f#01nzttK(_?jFL8C(MP35i=fmPWY$!I5<&@p#XJK_(%GRv1QVQ5%;(X%!eTT9o6asnRI@-XLpLA{Ki-n7d; zs)0`Z`AXf#S652mnbZpr6GTE~p37puX^}c)ENh-0EPla>{)^W3Un**&kKgwrj=R`X>GG;yQaGj}5h53#9$y@qYPusFR*e)Dd%c8_D=9x~p_v4nC&2VkGdEdg5aU04+el1LG zMz0blGsxxT^)m5z~WD-j+S{&{i0@%@&~#XUz>K@;OgW^L05s@;!G~F zg=kv!;>uQ5TT^M|HDTQHwlhH+P--db`>hKs>`M4!f7$?BELXzY^Xc1ttX zu$oDZsPloNwd?V!TePA2Hcaqr%eNiyPj1hl&~M#vI93n}MV>=J5I+b)&iv`B+9lM< zn=rkUzY@m&`Iy&Ac1^a_1V1xMZtK+AT0Iq*f4dL{!@YA8-mG%c_L5bhNU|8qhA7CV zJ5A>>Pp%F)Z-(PR^@0=qT)KyC<$cGKWvmPF*Vms@#U8##Al@U~(k9yQGg(|rE`R-N z%BL3(z(S%3}y zEt=&$Ni$E*0xaZF$EOEd8G9n=7f`RnWE8Xn1+hSM6qQ#QSca^2A%MCj_ycy#X34J-+oxDiSF` zP>b1xaMO9$`)7{;`nl-Ab_UJKlPhlrdo;H8IxMw~-CMOq1R*=Om7LA3Ru-JSaRmiA zEPf|LL=gLx`=2CGp?EhD#!r)O@P0MEWra=RNF&UFx3!cCuU`t<~NO zQ(odZ8Q=5#zE-;wT0o(C zeV-l#m%IHmo1*R_ejz=X^Wz@G`w3TI5}ai%QVaM-ikm}m^R)Z}ql*;kc_L2pqR0eeTqJ;F<*{6#Fn_ADd9-B8AfrUsH zP);vxm_;fSq}5n$^V>CfYGAUf$ebc_6bX4SeOGFTYPp`@7rCt_->Nu$daz7_quadD zN!vWo|5$)xUC(BpSgB{h9(D)H_MX=b)>!GAac0%Sr^? zUMF0|zUae!5DpO0T1_^Uiiv%ggH3PHZ>P@+Lwll!_!6)IXvQF-AjbH{MT54cVs?O>ZEH|ed8h+um39KG=atjMV>(BQr-3E}ROHb>g& zd-H@%n+B2&IC>1Xp8y;Q;SLJpUa%##LNT;{)dtpQMh_Kkj1nz~60YjFFJSUVW%G%G zw0M1mv#iG3i#2DPz6)B=Uy#WdB5cdpYP#QChFWO!U6hqEhlfrEm6EWNr~!q@R96s= zjn6MX8N_dvT$fBjkb;HMZwgD=Jf*+JzKv-SM$_K>G@pk#o5P4W1S?Aa=-B-+B4M>M zX?0=3q3PV<{lVV)Y!G723dqZYNx-f0Ca*4RQ;_I)O`e!fZQbYTb&tV3fQ*WW2Np9> zFDTq7=>7xtVvBYs7%!Q)n`n4?Z5lJ38u{7VA(3{tsih=? z6@Hi+^hFoko>wUK`n@BAAr1$SODWh#r;}n_PNTw)^*@RF`5)D!XjoOANE>0?2|aJG zmMjUuuAe_U!cKDL7{4j|xIT2zd(9B_3EAJ{^K{h*S@vBws?fb5vDsZ83(loW>(n07 zuKdVN5|!2>9@44&8^Z5u+*Xz>VDfKjvl(V{xjhBLimt=825dIJKYiDnFwR@c8Eh~g zh(5ow6m73EZAiu#)h>f{`dzicf}CJ&$Zdl~HKBWpz=WwnZ!W;?NkWoK zttTb+AI{PwJiy{0(7k!F(F$$Sn#C#Dew=)q zheYz)JcaJv0o|*<&C_q&%N?-vLWsTG!C;(6nZXD>U0BTvZqnVX0RiZw9!m8T82aP7 z6mmZ|BH|G8tV8(zlhB*bB}&v8_*=FP-E1~5qS|k;!O+JfUJZK~O#I1SUlJUydO&do z?Ebswwz0nb+WZ#SiT6Jw-i$CrVGo|Ho%1G&_((p)7-g)i$0Sg+ebJoy1yyC=&n(W{uFYhxl__~^3OCnBOAAOutQX3f3w9T!&-F2G0umA9i|XUy`E~=IDF%oe zpvr#`yixqGu6&wWm}dr9!(ewsRota*z-d_ZS1}b+1rR=q*F=dmh=3r8|1_#xSnx(H zJQFzK3;KUo`E&#<8^rscGr@|1s>ZSx3xq4iTN@7lcK2V+`Ts8s{cq#+sDIHZLnqyq zEeP%m8eQB-E_PZudC=@kX zHAQP`U)TI92UNVthW?#1PIq^+UcWK<0w0t+`oVs2a_L2kpBM<_pRd3(lUsy0{o|{a zkSwG^L;E3;H^*r2%(r?f#ggG=2l4|;X;^Rk|KT98-9Jir)4Rg1dc?W+X%^bTF;f0% zub(_{52$&tu*GE8CJEk1nYjcDf@i`FI-a^1$vDz;(4f87W4hK1ckSF%2H|SvEV=vL0uhR#Ig^3i=&UxGHgY zCU`E2^3MDZRpyu8OLy}d)gaioXntil5U795U4%+(K=v$O)~o2e!7V|-8wjBH?KHxq zocOrq^_Mb$ophjQw+y0r^)hqguK!-##srwj+CyL_Qzz2<(hiM|u5H}a-HV&Dw}nDE z!9G^|d`OLV0{^!}|M4iX0T^4Hvu3IzRXf_&=*0^jGoU#V zAmQlgY`BDvY{CzB%1jGnC>Sq*G>9j-U0BYhr8zd4iEZZrKvhHtWEs0>1CGY@MyLS> zD~wexH>+_1uB<%9wJCEJ^iLte0G_*l;L=nopT}X4-moi~x9Zi_mY>6d7y&X;46J~k zdQ*KvOV2pS?A`pIsf791^qmMu7>CgkNZYFaGYRH@aKh!^BM5owbrtI0y2GCuXP!0> zTd!MS2Z_xK46oZz|LRw)y^l9{@i+VqEdK!~alDcpPAXQq!!x54VUMOIR!DziOCNiy%=c)b+%aN}ri*FGTd=Sad$`V*0Un|tcn!<#jqxs zEf>G@F=I%Wm-ePgipQ`0>01p8rU8M4t&7AP*|lp+QCBeLvI(Vlcs*lw+LAGx+Cyw| zkrZF=5kHrtU@b+ntvH%=Dnbyqv9grU)SayQ+CdC`)5543!3`v%}V!>RS_WDwuaG&DP75Y(((10aVm8#_pCIt30G!!%Y=0>}?A!_G}iSU3GX!($(D!{F`vwf>1 zSv;U!+zhp7u0h7MJYbzQz6;V7aOo|V1dWNz9uOmlnC>xS7$5Q~x4(Cv>Bh7%zP)1I zl$-EPa}>F@AhYaJ+A1a6@?wYd6XMdo+GJx?Pi{Thxb2H7?CFM6WfKoyZ^XQ_1+7= zC|Dnvw5`b9UI)FYQ_d>|1|-W270rBuyAl_-93Haio3{TkgG~M>Mb90NY-Jd;Q19ZW zDxA$sQzBZ&*C(7=XJTT8dCc|JyXIaWYLSB5`~EhKZy5FS$XxC8(64ULKl_k=i3V;g zq&LG&ovQDaeFZAJ(=L7vH8tP*Y(PyIgdDF~zs00Pd|HSn=vUv3S^5LvPy$AqW%6X; z@h@vUsiVZv#8cxh0;%iHvVn5S;6)Vp_swz;2@=Unt?M=zB5wvKmy;A&R4y)z z@!M1^%IQRuNmb{F(x67wA>`7}0H7X~5VJBr&}uv|JD=312z?;}4=vVeoMq%kI%%>N zsBc`VpJHrs^KrGO-O4XBWe(66vhdJYt$(4&7j)v4)&aSE%OvR%b<)v4?n=w;@BV=96>aOqC^ zFU31X(~YvHHrh5R)F0*&BxVR>Vk(RydWy&d`tIs$c?*>ra+n`sXFL#yBmTw73`zGH zy?~&k+nBX)i-Ws_SJSnhS#L#mEOQ-ppRuo3GHHG2J-WBSTorx5UvDlUx0ELmh+w){ z2|K9~tCd>nXeHhu;J(L}Xn}eB_1;dslCd6<*2vvy32iUsBCwx@VP|SGD&Ec!e`=!N1HNT4S7S<1UK~O_Fk-^BdxZzJ4#6*J*;G+VP+b3#sqQuh- zUD65`Od5~s93rmMJ9@*AE5-kiDd G%l`o5Y_b&q diff --git a/vignettes/articles/figures/unnamed-chunk-8-1.png b/vignettes/articles/figures/unnamed-chunk-8-1.png index 8b28bf68f59a261e5038511f32e19bdeba9771d3..f8a422960d9fab622cb269af7fc64f98ade2f377 100644 GIT binary patch literal 17816 zcmeI42Uru?`u`^ZMMZ@b6%~*uDi(^16zQ>oih?Ljnn)8VQCjGU%c85aC;}n^A|N6l zB?5+OgMbJ~2`wZjp_f2_5D6stpWu4;mc4iP-uwUE=T~-~0}nHE&g9I@d*1V&&-)Fx zjLzt-S+!*q1VL*~=pQwPpyfyi68gA8036AEYkvuXV6jF9=Z}G12m%L1AxHy)oFD;F zNI)JEwSqJ>APpx-0|z-3gVO>6q5`7w0-{y|@~NPzr~oKnFICivCocfWiwekF$;(@% z%BS+cRWvl5G@L-eX*d;Y;K-)sZ>&TiD^UR}c>$|bo)wSh1U^Xv6i}tu2}gD+28D;y zfN)M4xMCcxn2aOyQso6wt-$qoS^SNVl|{@V5V8p1Hz|uqD|Uj4oivJZpn&S+VluCo z#{-r4Rrni`Km>(EAkqjVP#DCe_C!J!5uD?1BqE7Mq%nvz9*K}eA`(a>P>3WFjYMOR z7(6mggN$<`7lVQ$lX+wwk4DU*5eYOBC`1~l#{h*vWAJD^-f*xdgG6A^hzuHu0a}B@ z{Ef%p@px9E;7)j{R=m_yUa=FnE{|Ny16QOGc?=Sd0a}CS0qzoXpZ_7erAD%b$^`IQ zR$kS&@PeSNZ}>kjkB>e&5QKnE96fa2@8LLw7bD5E8~W@k7{9LXE`HK&$Rm5VNs#%# z-cv6T7IyEZLvf#TcCS=_WpxP^D{MD(_~edvwUySfuP&eEQA)I1Tglo7v^8g(B$!u{ zGgqb0kGnOUtYDWHSDiTvM?Ugvv4xy$Mi6qs8+6@Ty*I#!Ph6)jF`hd3it8gUGZ^qCAFe zO2P}*TIu?tZ8;qWELEX2FDID)LCUxvOE(I`8xe{T%1a>?!ZxMgSJj$fEO*jsoSAP8 z$KS#I-Y1zL=|1eUx|LpwiNva>Av0h668i&!tvIbB&kht(xsIIvIsfx)|@Wq)Xbf#`D6HFo}SOznXEH9J}yX|XDMGE zh?PP$LlN-l`CR()+FLFce4QnBi=c|u;(J|^^W_j{hT)s=2UgX-rG^gXZtTeti9MgV zwRO!MR(&jtz_>R5C5;el4@JD)yewV4zu=L_Yj3oPe@R#J{RlH>_MDJ|h9AmfXcLsS zABo)RJ7;m)(g^j?V9uK|!mU(8Fr%{Tj)x!k0ai1ZxUzN}QB%=A>0C6trgr@ByRtbu zSj0y)F`TdP1L3wYp$b^SF&g!Gb~miX85=r$3a;dO$l1P+x(DW8v7iMVABcb}sT(yX z3{0+C@#>uWQ{j~h0++-$zB>0g$HP&n3q?vEj9=b=FLXF&Vv|ratT7BcZEvx3!bmNx zmwI6%&M}iwta?gkGRU~%5KY+zdsbtNOz2IfHgejhLx<}XcDO}SCW4HuH;Au;N3>v3 zyNk*K%N~l#)NE1>HK}Fdx->Yr`oxk z-jnGC{Z6;nrV2zfZC;+f*ca-nGg`v9FRVX5zc|q|)^PWP5#47lkQ1m)_oYKJ-f=MX zQO=O(;r|cM(Hvd^KGSGox73`+OW!GL%0kh#dC4CDvGn+d84U;%vVg-d+MDS zI~YuV^#)vEnN$bHhn?wA$tH)Hxm3(82-`L+So4ot@3oa&kzl1j#1H zWn;Hu*+Hf6yRPp8quOrs$Y^r0;Img?0$}r@BZy=M~EFCfeN=F5SJydQYr! zQ9Za(Z`bJil`D{!a99KMKFWQmHm<{~By-k-U0ONz`~4Yv&0^L>jE0*_Cfs+AU$IoL zXKXgjCnq4Fy_H6DzdOdf#v~kgdf{Bq44HjC%dj`AF)e_Fr=Oy@&z(H2bS;zqW&t0c zt5bZiMa~up86OdJ&`>FfGQ}{_C|+xovh;kSt+M3~*~}}XOg*Mhe;WH%o{!-$dqTII zi65D9hWU58(LaQg95l|lG~H?mhl_66j)+P5f(k0`muWEMv_|W?N%bT*(kfu;%_WNC zcGkHuxe;A)#6Eov*^HM59@mW(wGMl213s3Me&}kxeWlgDblY?YK?$Lzqack@EX`5oTg=h2$iEqwqjGZrIBp|`s<+g3c?_tgvt^>3epwiXTxAx-?Poy{zTw)N7=NMk#}~jx7RTwbjc8bnAoV?5!N9RAfOa}eBo%1SPaK3 zFQi9q$wS>#qS!4PF$D2j6wUsqg1_tnXI{=P5l z$0U}3%a#}I6FpK#g}!X5%u>78O{uU}s7MK5neJ+xEmtjbJ+WZAi}VTQiyoT0Sk$}k zS=8%p)NWwjwr`D4E(<5nm+~fy$!luwChqa2rWQ-!GM3#ZLkS8F6D2P;h+=z;V0)^* zJW7gYyK4=?jYD)WnymKrH%WmL*q$$}fbu|17J=IK{Y$l~k2_^#6?Y+^Td(1sS`6Nd zrf&A&cuBAO;Nm>?yq^BEA!XEV6YZh2(a5wA?zOHpwa%>!R%yxi3FJ_f@Ymv`Yw;;m zE~QRPT{s=b}X zdwuHI+48Gic8gbs2qHrp!Mtyoi5bOsXFRp?^Y>UBzOW4e&7R?y$a=(yY;-NK1@Qp~ zrrzT}*x*?x<>}*Lg@nw%!*TkIIb#EJQ)&CeL;5!Ht8`_TXssoM$>4TefTvg;dwn+V~*fDab*pt7~Upm13d%uJ3WB zJK^wGPR@1{;*lPQ1qClIxOqx}sN`ekmy_OQ`OwpxQt|fc4Az@+(y-@{;?$2sSC zY5R^1ys6JEP`f?SNg{-;Sn;ZTB#9mUd_xmOPFj-3d+Rj*=;aixa7*A|1D*ed$AG!r z)QmYPiMpwrC_y|;uxgAvExu%!=+Rz91yYqw@*3?@_I@}%Q5?!>(eTBiih0;XCqB1!ef1l75Q`VEPhKPUK{3RYpKMfP0^9;N?p`|F?t)Q z=F=Xei#vf_y9x$-G$^$a_PaywKaB0S7A1fCgmUh)rOVH+uNGD_l;Rskn=Vtg)cCwY zdC+@v{u_LX9@Q;1)k5Qgt}gOK%%Vu$8{+G zj)B$?-6#jb1M`DLrnt=wa<} z$&K8^LT;(2p9>^BO!WD~C;m1x`7Pu5&kV0$e4==b2s(M;s>hOlV`p;p%x=FAiyx{1 zvolyYPqx|m^f}F6EZDdZ1|lwL+}k8)s+=r&o7qs!GC}MHSl7~I>>;9C>iJnV>N>wl zML<36QCUTSnU$}o6qbvX1ha5U!?D@gWEgOq_p<3VmXz6N1Tf=P9C2mCz||XA0swB6mdkAWeOL>;q1w&h z<}#CkkKDW+Ay9}Om&8vuDvr??*}FO@omHoUq*Lrosq>DMBwM)W8x}*|X&}kAoie`@ zA^ST|{Ui9`paq-H=3Q9d%f^dmig2emk9WuEJYD3@^JY7G7sd6fn5I0x&#{~`#j1{;+re0jU)suAktdjUsNj+SqbB8EwzROw zULr;YuC&+nd3mp{A|eg{xpYC%aN0G)HP@#^3P!LE8mp3Wo(YW6wKw@mJX^>_RzqZ$ z%^pFA^X=CDtZ?1n7TdjE?N(@_SPNb;&X(KM-gHgNCDGskDH=MGQ+7wN|BHy$eDmO! zh1oKaw9no5J4N=AnhwL2w!7w)SIy3hb>@`OZL)ZE7Gbo4x^(~P@dK)Nv5O3{kCbfh zqr5iVtjfZvi|n?ltE(Lhz(?AKG)3px;|EJMlY=YCWvi1T*6eDS?$^Wenqvvdq`m8tga&5wjv|kbyogoPT`{iLF{TYuts@eEvOGc|~L*Z!sey_n=`1Jc( zSyDi2PIpX)zY))IW$o^y;%T}#=}rZY6)bd#ICReky=YHnRb$f6Bq`T_Rz)7)h+Bvu zIFfp+9b8W%Ylhom(VmF*I&&GX?ov$;3}Xmm9Wo#KrT|x<9^4`)qzP9l#P(o9Jde-3 zS06S!1>2m_YGyNIAln@IA#04zb!$DcNOa1@paqhCFp1iS$ZK0rHJ!Mfv>3bsbh>i- zL8kAOH!)~-X_>9u!U?P_sse+4n_J8f?Dw1TD@K*Ge*D4gf$Lt5sOH|WobtiCU8!d+ zoGB{VA4(-+eRz}#rOq3)%WzN024{>puab4o3AQ=2$kb-W{*JY|ePMg4Yt-utX#OAB ztI?bxbNIC5f-=5U;n@peSF3g_exZ^~u+2nO)p-5u)7(FC-!&AJUo;~M;*DI-LnU%Gi$1~{99Ask*(~K(p ztVHpP*O-TvsyVt>H#vqo6CNzwCsD#J4P*o4=P&cm2ata`yZ`$RS^yAoOwd?6ola+# z^l~Uy6^-X-Lq~n6+yQ4G`qalQ9|jNPDeas(0k&5@N~7ARu6Jin*$d+PHZ zhzCrVF+WxWd}0SWPS(Mc zo<>{8@+oDB-3TwvrmJz4OB9g%v=bR-R_!z%@>b%4*gh-}@;3QYiLMrvX zmR~SV{6X<&wqpHsuSY|%;;s|^c|nVbPNDYK`t2%au1s5~9)jSZf)1sa;hOQOSy=)4 zyV4H#H%aX3Y^&47O3xH8U30j5ug=UH^^xNW85SIZd*-!9v#%AUT~-S1^$#jP?OCDo zTnD|JRJR^8O&*bDK2-K8>H6WmL*JQ-)6?8>$LwhNDCHCC+)hj07)CQZ9qwh1UUM>qeFR-bc!_s&2{h2&(-(*;RLaM-YKECNn_YVOyhhp`Q++Y-PRLV?N zuWCrkZ9Cord8RXdnW!HemLT=+a>^mi>|-dTQ^%Eu?;g=U*D)m%h2HrfpzE@t{3HRP zEaamE&O(_kpEM=AkY~erY0(k@BXBH&XRGJUp+pHbf_)eJ;ljtR`!CTakv5Y$d1En@ zjBt19qmxk&t)8}&8Lq~X_z={X{$Uy|w5C>;Irwhzz!~*OG`HLiQe{M1>32%w@SR~Q zXp>Jj#MjM9o`-!}AKLT2|MOz%NCr%O0Ks<9bczHyhTPk%!L2Et`(oNxUWCJOn|B~u zPvZuk$V6iTT`iDtNi~|7=H5C&RqL7u)kiksX?>LI=RBVHwd^1wp~Imd=`c6zOD~C& zK5FZ`&CYe)V<=|ynVgM&r?w2b{ZXsOP)MFakGOCk88UBDW8N?>D=Vp=#~Sq3r+Mv* z8I06;f|hsbeV@K%v4KwSS(`Z*c#H(=`m!ct{55>VYGzz`^Gk}AuV~TLBY)0 zA_~@9cz-K}4+WD-Ubw4NldnTNZmiOuuNImJYD3Y!$Fz(O&6Ied8phG|A^}fY?-+wV z(K8fq&TN>vcsM>nS&{P~1lqA&xR&vb*EG49^8nu)Qj#zuo>%$>40H7ciIXNx^G^e4 zPg5{fz5>%--isA<`V)e-IX-Q~_B_!#q`R`2-d9UAq&^6AgjDxmL^j@bTlhMEEb%2`nxaxII?^bGvc94oAQZ8g8j zILUIW5M?5=qOUM?7@8I8AHE=k^H6y9@P*#(Zk+9Q$i7XDzfw;LF_9K_iCnb;N?h)c zr-1;eEJ$LxL%>CAB-HtHfOrv)&z}oFuEvjIg8`udMCh_x(9Tk8bLjjMl4%LF1IeC& zXJrgiwTdhBnliJ=j}JnSfLzXS0PevmOzN-rr;?w)`oMoz+VuZs%U>+1Yx4p#`gY%& zp8H_wn8wZGHOD^o{5;U!DN*e`KHBq*|LJwy9s>{<(fsL_Kee4d?Nz3-t@2rR7r$fJ`nF0IR!GO?p#GJhRG{K#psrbnOm=P?$=&*`aS* z04!uQ6ZIqXk5lshH*E`y_J5zC7G4^~Oc|eDuh^sIV*m)*Sza4&_~co_)bt+v48EmO zvv|W77(ETsuNgdDD|J;15DB^^fumQ464dJJREeZNr-I?9n0fJk1`~Vv)^}kcJ1+8P zzKG&eM`GXA%v;rW3m#`%JmXWs0;1snEv^!)1>D{h6KU4)=6$6#(?YX+N;v0tpD1s8 z0D&K1$t}ZXg0!yaNFuvKYq_!F&j5TCwzCKo1v80B&`-#2T&l$PDpwx*4p?z#vL_sFi(leA0A-z1Pa6THHJ&)doD()l{v2Hc(8}%k#Vdf7RLHlNGwIlMZgBOHQWZ z9M7gA_S#44O;Qlw;H`VxFy6UqYd<$0Mm~_gvsdcekzju)!lbvY_vmAgpex1{o&_lw z^4=A-hgfaY76m!r-u#hkeFqf*V8O~O>oTPc&?l@XwEyH8pDH4>|0;Fj>Cs+2e`IuN zM4f(qR55xk&T73e5UQwN;A5N_)|+ly>XIkr)9f>29_4|gwYh9=dF(055^}cy6ZS5c z`flLr9-wy!{!bxp|GyWJ|B(^&i%+!L1hOIYw?8NEQrObgd-jUkBufAv2JWol9ENl& zaUit%!nio-7zVi(o$QZ)=yua8NkUu{G8J@KGC_j&;_&;hl!MFpRpv(JqeJO)H8$6} z4tYat0Z(9i`fB1PXS!vMxz{Rwhy5PR#nRSUhE>l%w(d9pa;F6f&7?#NKrUpBfRc7T zh%4om_g^eMH9A^okMKDK41$Z5(-d~Cy6i2+H&o}CF@9)QQ)Bj+9JUPUNUF$JP^b_G zj??IQsRYWWHG2?P7jtdyh!Ciz(klYo={*_bEe*S0u`fRt^5Xl{_ z+E`t}9j_h<)eWlJeLF*BZxx2C%VDbVmbIWNVp&9#VXyHg!;miyl_%pYW~8a{x_*_r zlR1-ygRTw)pLR-ouPe3Q{tsyQ2Q>Tx8vaj&hGjA=UrqYz1tv@@7VrmgOz(qK%wOsT zEu^1UnJGwv2|LgIDfYwZ=3h|_o~qOUv0o1omXMf==4*BTOfLtcq1^gbY z5yRbVUGoE)mzEP{WU#edr&jnh`6?&gaUNCTL>7-pFE`WSp2oi}*x$0U_Nt{GWQgah z!E(LreT^1kV3{LIisQy!v_NiEP1MBq%13?B z8V^Z=a!@~E4MO^C*`XX|`3464W^O3CRr>_c4svkSfECJGZpO<;SKqlnl9T`{%HK^3 z)0ulzk&x06!LMTBL&3ql6sN#TN;VA)4lH49vgCmj)-RYa%D_au00xwd8VC{1g`6ky zPu0$JCkp(PY>+8%NkH(E>sLtlvV+aZ*$A}4Nt!r>q&N?FS>_%h8Bp=^%L zSs!G(-;u1s$)Jl+yGom7cSuW8=UCZ9W5qUNU&DIMNh6>j41zr=l|ZzHJ>iuo{w&HUl#oR5_>T;we_Ha$~c zm_R40V;J%=1*%uuo(561REKA{Qg8>`qMS@JK_6}2lHiR%n>tY0j~WiQ2Dta=bi~{ z2kGE^JLD6gb`UN$L|t!_2ar?sKN=GL-2mekUrd&Gh; znXeX%RMiq58;;z`5d{n67j-^}n2EdLGdJ5#@nK-1)h(N?6Y_-J=}V+=)W%$VXfmv* zs(eXj2(%b)liDeMtY=aem>mCo@ugoW4Un@Mz&(w?s!Qb$X8m6~G=5>${-b{htIyRe z;aq@Fnv41fVC75WVP1OvEW-mwzq&a0sO){jUElc3S1_F?nJD+O8GqHQ&Y8(e{CsE$ zz(iGlJ|h;s)Bczl{yczwfc&MrC&~xI{DDxK^h}4|e8AK@azJGGtEzB+v}L6e(y4yZ zVija44}&3E)R=kxtJ7_MW4KM0)vXMA4E6(z&{=H)Jwe13?uL#C9hbaQNw!e|^UIqvdaj5B|4#!jMs2 zzK*Lq@K0Lmv$n{9#y1)P_9t|gRMwtSwf#MS`~Be)!Qch6$A9De4wlzTtx!?(NrG*% z`SIhuBQb}C(|uO??#2}hyf{dhP2XAd*8P1EYK=-ioR+{TD>J0Vxz$}@=YPEGmz-cA zx2>}JbVCkoTP1VnlgtvX_9yMp81t*N41ESU#$gFM93I{dBV-@`;$e+6D3nLkko z4wp{nYb?&x4jqhhPd%(vl0;O|>46_5A_ws}?D`#nQ>oC)!=cp{G>TClC%7@Aa|sfZBUQyB={pFaXg?ycqs1Z0 zT6>`|kAVovgWRr-r!l0trs|PQ%t3HSGe)xgiv&$O#5r|umlxfpM_R4-Sam^?gnqmNYHjM z6($Q9nSB!1SswbW_NQ6T;=GCO~!D~g8}!ua$@$nzu9|g@Dr2VBwnH&H{YPgH4OC4_SUS4vQS)(ApLTrK{zqhbEJQ9%c&8h>BiL`Y^c1TG8!}o?#5u z2m!Opolq&lJGECz_EwN;mcnqd|Lpd}V;Od5 zDIE=scPPFx@jn_#!t8=4CK}G-@UZ!Fl*qyG$a}iiQSRWt0oaJR&-{r%!;;R^uvByS zn=M`S2N;vd)MRg5OOZGUlc-H$*_!IiQVcb<6c+rsoMXgK2b z<}v8=76J~tIBmb+!h57x z@ids=JX@)+SthML(V<0k>mRpB@e*tA+&{3sWqg~*IENeVE$%G|f=xZO|qHZP& zc?J!6;QM3{_f8-msq93&O+70l?HLe2-HyKDWG&r(xSJ=;e;=1m3+tmjk26z5%8;h* z+x40RvJ#u+<|bN0#M*lm0zOZD78JbD3Rik~D+Kd7{Gs2jfCXF<{hs&ka4gdG3bNGI z&f5Bw;!1Tf+^9RgW0A@z${($^p-0n#=bE2?FEamE6ViX%T^vtf&*!n5;j0_r0TEDoQxKG@w9pepaVsiOny7$C6RA={ zCnC}Xr1#!iLJ2h_c{AYN$8+x4=bnAu|GxL`|DOC7{MMRn%{A8?W6U|e@vX;KE~{+Y zvUdvv0@-#^^@278!is`G*uJwffs~X|iyIIKwC0NXRV8ohLgugNcWcX3PUpjKM({V}gkB zFo}tQ10+X_Mbl56It5y1w8!{a$y(uLt?;rqaCGSwelg~O81pb0i-FqF#?f?RI^7C% zMHU>gR#p%z9Nr4wWre5XWFa^!SsV`3>%w)>qs5q_#dxBP!6C+|7fp|*(-RrLyu`$c z#Js%3Jn+9Iv0?~s1;Ja%;z2_=93J0=?*a!MPw&Fh>7Xd1Amdk&R{@Teyo#Z`7I4f} zY_w95mskPv7{8W^mZ6HFxr!lrOI~72MP5q_I4W9NhFXT^TIT3oIN2_oRTmx{IK~~i z=v{RBP(|WUMcz;gI4Xuf(K&F;4b9Pq==5r8f_2bJ_2L@IeIR0XsY77Z?onD;C1D|Ib`zOk%y~+mMBKy}j2P zlN{Hb%KA94*@pHg#nq&tPw*l_BZ=j+VajO)I#9TfoO#Xn6r|NA1R6eBF*k>%U4PiO z4V1o)5+bAJdRNAXBiwyNlU3Seu>fQ$J0I&!l8O;+T{uSJ<(yi!si*V0iY?Q8Z$BqtjKu`<2A_dlUn?Kxs?L))L{nqIctI{e8*|-m3$1rJt}lMEvtXAB>JUOTMXgAyl%otggBvZb+9OL ztQ^w*AcV!zrP8AO9Sb!fNj67?va_hGMsKZ-Ta{j3priR5nhv$)sPub0mb@mmXZkHU za>CPRe!d&KH8OW{Cd*yv#Ahq}qli+!J!sLeN7=6ga03F{9lf|X&4;9R<7_yU9k0NR z!v%2HPZNc_^yEIrr;H#xHBkOyuiC?NyLRA6n!bV%fvgNHnd_>0@_Y^pv-zWB(z6E( zOoJlFun%<6M}vA7bX#r~OCiMA8oVecx!yC`MYpiT5;!GfCo1^}xmtX<{IEG)H#J{{ zxks#Wr%lT_(^+&evde923C;v93{Mg9*@KWS2hC!SShL-Z2btSpwp3K&&`_If6Lez6 zLOrrNHY$>|t=>>uA>^XRP<>#af*(uzT~VrP7q^4@XbcA5Q-y7QtA2M@Yky`MRnVDT z(7Z`^FRo75QE%bo%AUYPtc$OLkL+@Z!$t8UXyM4^wS&aQZv- z(j>>Ht?LumU=`KsG=86VS63xTA@F^RG0Sp6(A5tZ%9}_6tUdP{+wl8ux@_2IJ9r@H zn3=IWP$=R83c|j9^AdLq3N^3!SB2nDNz5Mka0PQ7Sv{o*zM|q~`U9hg0 zMkB|}X5kZATM4lIE>3KIc&o-b_4JeQ{`IMUI~S zp5#)nW@36gs%+9add=S2abiN@-XR1eKwpm`qwGLNFMB+Aj~<~UtzIsYDkL{u9)mk> zT^9Ge=#jZlR<9zrFEfX{^{6lcGSj*XM{Bwy&dqIuN&h1JiTM2WtT~Tgue7*xOIOJe z%rp8k|WFxYno4QQTRLtyo%Nm^25@i;N4@U%>-;^LN%)jN>+GVY1ZkC4aBR2Ius zg8C+x#tjlp51YbW22uuc#ByqTCGs&)sQx!kSfkl%QI#a*e-Lg~@xa$`+%l`#N>LS` z3w01fpJk(_!C8k(ZlSH+Z!d*v^9PZ7d3dl7lZ6pQm^s3_R&8hlVU5xSzslvX+%}g7 z<$tqm-0pWayWESvR3Wg#h?S49K<8xte4}+Ij?J0-wVvS#c|$FtCmDUAck(pr@W`^9 zS)ue|w|>h^NqkpOo_i57v?QW<(RQ<^67(4lKi;jqwP>#_WJ5ub@z5AsEM{os)oK>E zzmY>=vHMDF>$DiP(uZ&W0pT>npoG-rty>&R%*SH$J-Nl}w^jB(PHN!%7_YEL$toHf z%$HxXg9poEuY~%j^6AkJbzz%Oe)83Kxz~;K*AHP%1%v`H@i;r5V6PgT@HAWLuLi0n zM$6|HqCROgiByQpPrzg4_e@u?vwyzd3WWPGqLf#CTD{wzqjFi8;Lylck&QM|_*L<4 zO+N<^7X5ZG;uJLP>rsqX9CTuFC_B)q_y)1Yz2cg{2ZdwYpWFR=Rb`L}zPVkkv-=K* zB#Aj5+{J^vnKE(pa1l#>{Gg`ej)e$Kw-SRNP)$w3*x0}}> z_qLA`6y-0E>zVi^Z$&rd$^FWeo?h$ou6b_GHllMOQS(1)ri93nkG{Ii2v$zayI?Hj zn4J&&Hl<|vi=s>y(Gq2IIbLRtBRdG1DE7ITOO<|^m!@h2#-Mo(*0?%6W249lA3C`k zSC^KcIcC~nD^Q(1y-6D{na1Q3aB$u?4gAo&ZtD4^Kd+W&T?&S7+)?rZTax%dkL;+5zT zExs%+l-D~^xS+0O>=`%8>3MHE4_2YM@Ou<*Sxinf=go`Ht#ZPofn1r|7>~mhrK`(3 zP8`zd5~qH`LZ;)&9~Kw*o%A03Xjk^lS-(dxI7SEDS?w7owWxIP)4)hj$5^^&TK{ey zEVViJd(^eTJF+`*#LHDNIn2!Fnv%!K2|>{CEoB$)&VKneqq!B#^XImll?}7=9WE$V zX>jSgg>5)9fg)Z5WQn?qtFo&9n!)pXkm-b5DCIYx4I~Tq`#`gPQ3Qk{vLeyjbfeMb zJVW2YVI|FvWpF zW@3~V_+>6H>(6_4GP;ca-X}jjHq_ribA>|RCAdZtFez_ve!^+osbHqNL|tl{7rg&pIKe z+be!guCa3t43<7*$h($#WB8U+O;PDwe8+t-Us7#N$B|z7M>ZyPQ%_eex%z8-kW<>Q zZo)!Nj|Q9gx9*JwM<3F%jtCW9Gd-f_bhW3k2b$N6T$!8Ad+%;H>HuD61(=&R1)i_* z)%%O^%LpRxw%AvFjqmLNul>2L@pu76uv9oTUo706Ys#`vMSJz*++VVIV}uhfTXDs3 zyE5J2W;Q3CK2Ej{;nR<(+g2HF0mSaZ-DqUQR@GXH!X@DrvA>%2h1jW%wtUMSJOzFxla>evr9x>6vVAN&$PU& zD8>CFZQ~gthMqm()|}KF=`Gk$2mz7RmP_7;K$7AiOZSZtd@rms9aZl$dYTwh0Hjo~ z%~N)n=Bwf%yIgbX&7|Ttw>ulfcvnz~V^fM(J{H`h(H?;}QhXEHxYT{ zaoJ*IX*RfzqP(#pyQ+r^uo_DSQ|B;rL+M}GG`YCZTVdLYIbhX7u~XtK!d`KW%bI}0 za?N31CQb6*BhvktAA}S*DV;Uv<6uv68+mg7^W_~px*8~R6>xnRksibR;Mz`}b}iVK zj~wjNN1)e7$V_fQ*mTb|sN6-AJ`)vd^3#?{6_0h75Hwdi$oXs70>m!B7&_+g21cIX9!!)b|7qF9bic1(r!j0MU|iP_JNCnG>>RtOWwN=dnPQ@ zol?3x5uzmR3SR%Rq&PW2X>L4a{#WW$|>51r#S+|#OE%SY@e4)3j!DIiwG!S)JcX0m38&5RQ z`f{ma2$j+r>r>Fg9`e`Evts*WNJIHksRhKf%f|5SJZ&cE9@n<8JjIL*?CBnH$f}78 z%Kx{DV0(2X>2CD0gehe7w()q;3m&WoxM%h1rK5aZQi~fRWju6_WcdX0tqGV!F62~< zyftOyx5pDF7im88^rf*~YH^$d%7^W-u74fuO@Sas{Mjx4A8cS?|AP16zpSb3)L<#<`SccM z<`2$5z`vhEVfX5#9$~j}2fftf97HWA)moFU>_D4b1UlbKAj~wp-9?)i(mm-y!xv2SKMZHg63MPq?Aza0 zTpx|{`YO0hfN14U$G1`?93MHeSV-}wptrj==IHXKX*D8WJ)Aiv>fx@vEb>d~hWzj;gx{ch6Hg`Fg>S9}TAT8gm*uL3 z@yF}!K2lC}m26mEqkg8i$TSKnkr=v4frHVfgaV(2*CXnkx4hR*iGfwENgI&Fect5N z**mKU#7M(-@R-&qoK&i9&x3vPXXLw2vR96m6@#h?x>?`BiZ^xV|KD~04@b*?kv02i zN%!A(UvjQz=7;6t#l;MaWKLY!>hNkyyBsQ%i4Av*cx*l(Bv(cr8=N%N+5o<7*< z_@GmRL_#-ONJ(%ekWZ-jp%O}64NBH8cLO-maQ4ppYWiQuPV2XxdfqV~G0Cs^9? zhZ|mkHGZ~`J!DZ+*{r<-$12n$vQhCR_Vnzl%T?_X64}9EX_WHE{b6{$Gkl<{WFvaw zktcmClklgGYi)gAg-43X*^bgZjSEQ?0cmL?k1P#u*+tQE=2TkN>tr#8Yxgl7YnbUi z>QYn+NjPr*2|S-La?j+K(5e*9$~4;0H_T9!d@o@@ji5jejifKYkIzb%O5CuZv<$&A zE|w7NVvtKANaJNqbzv#I4~MGjMgDaaU-`_+Z@rD^#r>F5$9|E)SBt?id`l9q(b@^0 zxHEjCKh3D2QbVhz6_3)h1Ukg2_4A=lIfJ4-KG}}0j;r(V*1pE&Ik2qKKX=DYe6sv- zS-h?yNuQRv)YOORHp|hFso!fbNlT&Ba#F72k0E+;ee>vFO;=CMP_2t)*3p+&@GB)kT9=zh4!-C z>*it(*~O7IkKw~TV}G9F6~uDO`G(F^uSBx%$bMVr=aL!CV%17q_BAjk*S9r9%q{-v z5_(AWh34Ky9Yw+U_gK3NckFs9=w&l%naS$A7DJqGuP8?F2+pW`;KGIsLz1rRS@c4@^0bCN5 z-pD76*=?3q5O+#`pD02g=UaRJc}l%s*lypJPdE+38#W_-S@gwRy*URzP_^+Pfq31P zNus;u7-%3%y#pM(5_MPGzwiWiD~E@$I;jZK|sU z6L1#8@i1rCS=;TnT0RaFYjizaNlG2n*x)g!!1@8}7fct1+LAdc z4~w0_a~#eQQM+tUCXP*{S*M)CbSM_LFJpu8ClMnagkq_}jL&M#@pU^#PZsglJh#7( z=CiA8)Jan0ya5`ffF2Ak@5vEIL|u;5LEn?EVz1=Y_qE%3Oi5t-E5pUB-tl;TAPS=H zthN-`{6tGt;Od8UmHOhl1dJ9+O8f+Vf@)VEpJrld(}LdNzQy*yehbl*e*WYc&dQb> z^TuXs5l6l;dFt%9NKz-=ub(Zyv0o?YX?4{u=>z%7sW&{j@z~(Bt?Pc_M#>4fbWf^S zNZM|k2K%#=bvlg@Q;pH~(Cq9iqh*++_`VHDOfhqRW?b?M&Yn}XmTIYAL+Q#TiBy|Ady{*+kP4(+w*g6~Lvl}zcyU#w{8V~(8M09q zC3R2+Kbfcg&3@)Rrh{hb9k8%6U2W1u-@r!MI!-GTj|YPFjClvPsP}7g~-{)`cAs)w=vAg1(TzF zl$7wO(UfrHQUpf7rJgliu9X*;=$m{eq}YUdTs*8^g}PQw&WR|xnMK#~^ie|Y{mca{ z)jth>$nTN&Xrbu1orM^th#;tAk4%MxB5CFiHE;Ap*nOGub2J_Om=mT&;{iCy%SOs$ zVk&u667)14+Z{1p(eJr>LCcW^Lk%D*R;l?7P3ok*+bcdd6hK9u9#hiEQSss_QZH0& z7xu7Sv9Gbu%z65*@0?gjGsID3V@vE6{RXJEf#1 zW|VEXsD$rw(XB~7I^_{^978>U;8v#WDpgy|ks(9VA1pG*E{oH`rh3h^&bXO4V6L3W z?J=t#W3{yF-FcatwPi2y=F?^QNykK9E-dd9Kri#yYDLBN2&EiBE3C=wcXZv$G(S&? z5bu5C>5x3RWZpDWWn5^AR-;!|AZfW2LR!j-$#Y1-bpual7o?!%FplR4(;&Jx{%A50?!a3wqS zhGP13gr4rtyoD;44`camBMOs{|5eL}WhR~1nMuMstz3q6r_j^B`cK}dLT=`FExOFH zo%b6$6>=q{5v8}fQ%q*P>dkz{s0|8Yytp>Sz59ITJda_erjWmy?!;Z^JnVLuh-V(A z1er-s_ziUyqzGMzD!jR_9FkZ6734Y#F9ytF9NetPM1~OgJc<*p=6^9O=>IpE#%|PPE)2Pn)38?m)c0WV1gjG zIYh}vP_8<%?#`F)VsEnn}uEnVp%pRfZqA z=3DDE!lnX{&N@q!;$$Cfbht@Fr`~*9U_3@!2)*jCc%dLO$9t}XJE8a##5qM0!B^%* zg-B`s1>^mB>!HocjII60doBYl)Ryb8_PhVIUnA?MJ$;uiDg8IkaVPKEn;!3AuE>-= zT1V4Eu(pob+`xaN-Vb6xCE5$;%!p?4PDM=~W8v>}$(L&R$S~k(@cQ5pjTC#L;uykL z{c>NegSaCv54H$^8%S@5;AffFFU8}{)+{zb5Fa!fV^`ksBz!DAU+#!X0@yQz0SA-U zqcV%q8sW_P>x-r(4Co>ec!ZO_4!9gf^hCT=apYkC90|}CO<^X9-A{rBfsddoY7YQI z1>1h?L9kmLz$F6@vDRER3q1sy5ZQ+dDoM)N*fca?pGtu?e76W)fD=A5yvaJVHwzQW zVki6=E^^M|7gs=9&wDVzjgNtX#d2*`yVN#dmCeodsQ0Y73MkS7gCAM+E@ivKC}g;F zz@8+yREL!W*cK(xKAPasUSCm?Nu2_3L-Ti6uPNMkHxI<~-&<(l0sk$M;pbWYr|kGo zTj+nIB49%PcSA+WQjc9fghYY8x$|tpSZV2qABc%j0qz1nydolk(w5J0#@)$1*MbK( zpC<;ChLos{Qp#>IGEfv8|Fn+#6A>~#=nY>g0tuY}0OujFbx(o3(nReAYQY=Uh(bX| zcj8!KuoF?((?G$jGRNM-LcR$jwt*fiLT@7wkOfc$3jI&2d@d` zJ8;3EGa*NSLqT<;qVD^D7yj=s8Zn}Au0E%r*9A9T?Ra&FD{m|VN1sVQ!WHR>&eMQ> zVP?G3`8=naDJ-{*#vR=Rv}E1g!a>GCMn)sZC}O#7Fkb)UMNFAA2fNNjOV$Oj`Hm)~ zxyr@MV-eO*1{*~K8~_IMd#01&uE5@-;=y?`hAukR521NFh7CTMvi_kju(6rfpdKsT zAGTSSnr1mp_RKtiIgLHPA8TpF&!H-7v>QjPE1T^|bU1N1@`DZVv3IpF57!B@R8>`i zY3PlgxTe3%6;RX1f8}RG$sp5Bvd2ruy1eE=1!WsU`4 zXD)G#Xbh*>x*7QjwejT^?}XmY?>nM-J?`d>j%3P+yz#4)GXjnXL}`J^MO5JyQLzIx z%BaR2xIFR!kyDJ*&UoxGFCHKF9MLVmqTi2M+D)*l8XE1y*?aLjR>=nA1S=kp4^= z94nvS(3f|lzQfm}K|>H4eGZiY#1;<%xPC^-cEetVU}LispyAZ+POuUx;aq%k7(i`% zcHokk55|dYQ5_q-PT0;?zmyipB$0W0(1GQ_cB<+nls4$S3(;)KZLq&;$}cGdtM2$Z z*9dxD9qGil%~3=NzzdF&4;Xj2Xqn#AMqqi`?)p#Rl!9$P zM~3|!oN_uBgoOQloU;AyGftnsk5g`D{S8hz9Z?P-)t_KW?#+0yL=S?>M66W+13dYm z9XTsIzKVKp?vc<$Y_Q`I`MqWUR#mv$iw&lJ5P~v-+V0k2)t4TSvk*T;W!7Kv98+JWlU-%?qyZBP~4=82WjD z^Y>-IZ+nr_;m@1i+r)#g+w>{M#?&uR5iWEb4iu^^z^5t6zsH?DdL+jR@|sHHV~pA|m=-r%Fxd}~eb-O0Kh(Z{M9rkCce zz*}NOM3#;zcgP6DTiQ_KkUx9|X!HqxP2-T1R~}qR1%6I00I2f@I)W)XA z04+CnK2v|ZMK%Dz^X(#2TPi2F%zxdfnLJ%=z`p@88V1d9lmQT^sL=xbhqd}U$9OEd9C zp1zCjbBo#QICaivGfi|U+K1PD24k9PX0zf(^gwDsA1!l{8he$wd}(l)?Yv35M4l^j zwFUEb)p0$jf+Fobku%oUxPYORvHDbh=4Tg6WUG_$frBD_asB+BgoC5~>; zt4-APjw?u8N+F7w(Ms2h))b4s_ia^Ue?Fts(;nO2Ts@El_X2h@59 zt^|+k$Zw%6u>x)4%Tev3@c1J7H@-*oIuVR8K?kE|?OuDp^T2zH0@)SL&xe^4mIiNK zTx&mG$@q`lM)9QoN~=^@qc8&VmTDbZ-l-@_n6K2 zk|xWWaZyb@W&O<(L1_7CuYEeGnm^m7U}ul=FEDKJ^_5>AQSXsh!vNUvX1T5pJU{zZ zP-wWJG=g5*jQ`?fYnkYDhkD=676stPt!9C(v>JYSz9Wb?_~!O%aoVJGfgXJXT}1O_ zR3faIty+0}+^W;{0brp6Bb*AbjBKa~Mw%Lf;-osIa`^%f+d%EP{d5^8#ym4UF20qs z(vj9NTccrbu^-csYPtf;i-7Xe9eCG9o;qyDJp+K|Za#u-?fcL-hG!D1MK5UB>wtns z(}+b!jQDZ$^5%Y+;bTtNTkEeSp&hY@Dx^w=rEXRwKI^5*Qx}u3jf;0x@KJyC6?i)D(A`LvxoVi z9k7}}`}=XX4#0GhBA?VZOC12Bz*28+Z-!DVl3hIs5225DNE4UEw^WX@luH#w&2*5n z1JqO2F2gjh+h4G>i`y;lm+b@1GgOb9vQ6Ci&;#Xo$cP*Qx5#r{vVHq6JpF-$;boA9#&7-7?Mg{F=_@tIV=abos zoM|saWtcPUp^2+uw@5Ks#U~f8i}Zb&<1IsaP^H#BD9C zX|=6yiY8G^ZmC}I1t=GLrSe+~yS}6Kqcj2fNY@ng-o#s5nWMMGH1{cG zIOa1RxTj+QSKtqVM*eRu2r^p#hUJ*uH(r`kLt2>BMDE2*&4-eTbytgnau{Ianhiz~ zE0|smYUqXRUQ;2Z5e0k{*OdDx9sTjw;ijIMIvB8^Ja*d$8gBUBY|VfIf4sUbZdI%{ z;zf{LXezw6&;)oQZ?ah|Z5}Er(&~`O<8nQzzF}cC)}MTREY`Z}x+PYJQl_n$+694m z@}qH;2++Gl0o-uIDw(Y1!Q=x>!#B`*))f zGy3}i&H2Xu+_h%W4@cG3ei{(j6~-Fe!^AT+4&EvP!Gr1hkb9n&$fxvmbo$C>1%)y z`qT~WA7<%3{)1uJK}r z@@DRaCgRPru-vKNwpE_kdrJK4%!C4FF=AO|IqM3FSSP2=^!e!`{6ZQ>Wjf1Fxt(Yu z*gUl=?G3r)?o5v^_j}D=?a8vQ0HF&o0OPE-K&C9}?!lQNO)0lVMPHkhQ{K6mv0@Dc zJP!=4V~xM+=$AUbx|(`?Uir%z6&=Wj%y^w}awvIH!b|`c3btW8sf*84fV({=li)Q{$e{N0#=Tal|~bTDn;nl=f}rn72e(qI4Y7 z_gl3I&X^QH6ct!xYnbX))z6z*`U>BB_2$yE2RozKBy6tKOmxd-CX~V6RgHomvz3+X zIv3Ph)X2%ZM}vGli>2jlFD_m^Jn{^QRE+dwOh!^qCz1)L2?MH+-<;NR7eIC?v9BqOB>xIc-|3&^Ko< zE{uNr4rO?vJHhkRhwnWTaw%X10}1_9j&a4@45wa%+)8i78t<}I_#^(6 zYBd&;?(vVeQ=(f`e^H0XUH+$_ou9y)|B3OB_tuHWt~Vh?yAHVX_^iXsp!e39AN<3c{vEDw?tA!FjLFm1RLx?PW zMx?Lf3QFY1Cv0e>9}nJx|rZIHGa!F@qQxhCq? zF9?(ZG#bFbiy#jMYyM9&E@r;#0v`y7WPBIk&)5EUjemZm|F_5L3rj)f1{x)S0B@U5 z9p&Z^Z8(S0XH(Nsj#uUc(8Mt%{_wqGV6T|I3k0-g@$j^kXa~PY{F8+?r&;NH8TZMa z4l(Y&)tL83e5b0WT!BO3s=*Tp2}#2&z>z9gJt8PCS2WUls_gT~Yv85(xOw~kz-0r$ zc#LiVcS3#S@h2*&XjziWvefY+iBA);-J*Fd6YKWqrV`Fme`)^o?;IS1mobx}M6Sv> zT1nue`rTy~KbQI=X4|#U_fOTI@&1vQF1mVSP~P8-CJ~LEM!uB|Kl4u(I=+fxYVwO(a45cqBeiUjN2?7mn8{Jd>i{SL5^=bPEIWs z>sYZR{0buw8bBNamQSb)dG&A0eSjnJTnGmv0NP#yRqeMActGY|h+)=JEk3Vi`W^I^ zc7;~BTq+NJkr)TSjtRhY{>k(A>c&Qlbk|N?M_^VFx}Ce?ww7em4(Rp!8!ifaEtDsT zJbviLom_7K4UhkdO+T^W()a;^93Jkk8W?zf7F9ilXMXT-GbCG=Q?n1@7RIM0ucz0oX_#T_hvpQ1{{h5Z(q0`5rke;12ts; z>!AaHsi0=*nL`$8D##2*&3eFkP+WTv3|J3Xzg_hKhGGUI^M`5y>Mmc7uhcprzvPws`;XUkNC2Td zx_O`1*lxLFLIS3W;okot=k4yYk%5t>s!ONsCIOS{%FPWG2+(JcWNd2Qw3De+Z{>M$ zy^;xBK3>m_4mh0oQ{ic7ri@9FbmL~^TR67aVaEokb8(w#AHeE*NFMD;Klmj036W$# z(P3edC}fy`O^(T5W>l62)L;p*Hv4mL-TB4&zHSu6A4c@5Rep80 zuT{J95StoZ5-JktKt><0cE+2Ty6C8&{-V))6OCuAUV=@xs4kDa;@?sDo;Re9c zzQlfGi0-hZrW|B~b27k_j$IRSo#-*BUaUHZS%oc=#NZO}?+4d-B&+>pxe4O+F} zLkF7|^$l7rzhBffX!ZPl@f>Sh@_JJ)T$qQqwEoaI2M~JcKTNtHH1EFTCM2@zzDqa! z$2o_Gkm`#c=lmXrJsNzfCA5H2D+0S(8B5F(WMD$Kv(RCEC z689vxg|yrKH#pgL6w%isXZP9mkB$shy;hmEUrXAgpV@%?;{B?lbkiod-B)PlnvA1UiNAD8?m?&=3zS`R5!tv$!S!Pr(I>^E|n8EP`dJc zG0qb7kQ`y=%?7kl&lBKLfa}-s*0DJ^>X$zL@Q(nhbM-Q}v-tj_St?ttK91kU5NLB9>w9hijY`9w{d^l8$^YAf@JYp}y`%%mIh_>DY^jcV zr@3_P5)4Mx1W~a(?~dv%FF(RUu5nb-{%?M`gmpKLL==>&Eh*?rrmO{(ju!1kg74FK zo`}VEJ1#VwS#e)%BhcT0Xo2WGS5S4Y!-qop?lgiR3-hhQh@Qm&y<&MJX7+kh_nJ+a z^iu}yVo}h3z|i;J{5@LMZBw6ipYI{V?yFNhRp3i?kFK)~cL-SA+2*7ktv?X&D?KgDEmDy%DDHbX}%>jVw{hA7PRyxaSv{h zdq}~a*JOhOUT_1|iezvy9P%~Hsx677fa~4uQonfPiQw`*(5_zbTgr-O#cOFHdBEX* zW8)_syp}cV4+1Ri=-5*jdO#%&>w1>)EJr)yZet@5Vj-FhbMj&Fpv>f?%~(6zZ!9w>_EzYMA==`L?yS*vw?}Tc z8Cv$e!Cv`|27d3ir2@l{{vK@cpPjNp{Qj5(UO5Y!Cod3eUXQY+(dP$ak?ZSjO@*`N zd~rI;#YH`Z1|wm^8Qe3NFO!*trC>fx_FC|#3b`W7c0l|_yT)jKN_5SUbE7BwtOa!8jo^`Edpd5Td$`d{ zHCvA%?2XO#^`*CoH8q$m5XpUKdT!1SwIsaNL}tGC0<7-ydk5g6rzJ;x(6J%1;&SplWX|mo& zRkHr>)9Eawj*;)Iyf`_&JUjY(lOw|PDVN9k9@VO7=Smakgwh?mnYF$i*V}kTIK|@h znddKpki|8t+m0ceJ8RyFj;(tNnz_^@xF`qq@5c4opTbv^OY#`0*M9f6sIjoL&XG3X zb_Nkx5%<#Xm>HO7^i4|GTR}6 zT45hJD0qM7`HP4MB=LGWG~Bf1HEC>U;-T|Ia0i_w*0JlUJ^bx|2({wG16>R?_0c1y}G;8E)Y%GhpXdZYAhnQ2{dU+x&PW3 z*T#_}Y$|JO?&-fM0h54q1=`;`uO$xC zd4myA)R|JblW9^arq3uN7vQ*XayiV@caXMn9y(!WZWoqjT_9PMU)ekwb+P|&vgw8L z);xcsbbmgaT%1;z`z_wQ>3wcC@T~Siyp;4&@%Z+@@ssniT!H5~RhKJ2 zn;nmk@On&<){Bx@E`l{a`re*T52OpWP=l(S8$SlvJ1k?+ z?0rm*vWM+Nt#&V15Q)GV1N+;RmzjM}((7cd?t0sq6BJgmSAp6z^Sp&o%jw}=bErX~ zoW*)u&$^gBORR9or&>bjBEG6ibEY*NCgH2sS;JSi3is_b-6LM8h%V@x z7dZfH3>e$fHP(}qNAGtm{y^b$rWxyatpy-wE_)D&;_AYRcv}zA^y?t5?esqmAp4({ z`)Y;eXEiv2F5X8zgQV1_rBc!NlQ`JbjrWxsk+!Y8CBb`l@c5%p=I<4rYI5~r)??4C z*yWCSce1nlArR9!DiO8Ci-RY6eO5XbA{VsA4C@R~d)T4Z(-b_jJkE}C4avzU!v*b4 zaboqG8BriZ>Fg-?kadsPMNKY8YJE|>M_hr%#8lwx_|=I7fvAOs23{5e*|Ao?ho|;M zP;2OGcgWigR0z03-#=Kp!G|q-H&D(kU zlb+Yjy389aCxK4>f|w3cd1F9*6y~7n>C}E2>9sOVP+^;mQjo_i5gtvE-pO=U`j2`0 zN?cM2dqLdVWfsd>q+zL&nPQRfl*>zv;4-9Jj%3*y54 zh8DC?`Sb`R#nO#sz@^mdES{_K%b6T&nVIH`Xn*S-!STLt#U>lgM%h!2BtOOo!BY~T z2JY`y{40p|@Q2xV>eR|)`Qt_+`ZP3m^01yowc9p~-FqspiTYB{lt*4Y$h%Cx?Y%fW zl-Kmm5%$G5Kw+nk-EqXdu<|G1%(BJas-89#GZBMkc>o^tmA(Kjui)V1+l3JdDxMe! z=RJ(r`T+a+YbQ2KWo}C0hIqunU`+aPPYK11Ufp}V2=$QgfelES@EN$)1=KTz?;83l z$>V1Nwy0n;dT3? z-_X%9@73(|I!v@!!uvlIO*Kz1>tbEJxnD^c0)7{jE?-DJXMX>G0eXN&GXMYp diff --git a/vignettes/articles/figures/unnamed-chunk-9-1.png b/vignettes/articles/figures/unnamed-chunk-9-1.png index 2645f8aedcc9cf40aee6130b0b36dbcf8f876e59..06495e7092580694b09282d0e27870d057394328 100644 GIT binary patch literal 9021 zcmeHNc~DbXx=#QBMFCMkKqalyg3|&vyR7L}L`6kh*cWjLtFjXoLt=|!Hv-YLph7?e zL}Vur3|m-)00F`l_7EjN*aQQFkdScS#qNGJ?~k6DepT~c%~ap|a;xt7zH`oZ&pE$u z%l+~EIje13RJK4MkZq?<9=`yANWviy@hNF>u%$Swz8C_5o<4u(k|p>Effz#|2#B#U z#2CC|AqXP)Y`k$Hj1eGVjlmY|uw7L>0+cfb32Y-Gu)_!@aZ{AOZj=2MTQnZd?=+1tdC&!XnW@ z;!wa*NFaS_rqC&L76oi%u_!F?4$w(CbP9=1q0s3h`UaClXL0CYI|mrX8V_R;!$gp< z!^6NZ0I(=IEDDK52Z_R>gR8v_Ghq%5QTQQ%r`4mjx;41w&c-}pgqb%vTlATY?Ofs z52U3b+o4d{ei-Dqgaqcn?=r(wv9ZY0NTf0CCMwXgB@rlozRt+DNU2%slX6Fnjx-aP zK;rxwc_`=`YG~xrLiy?sXZzm>?~|*i5p8+5gq_H(SMu?a(LcjQmPYMsvqDdHV}LBlC>=&7CLIxonzS zc4U@?9}0z3CR{G45sCx^C*a_7!(?}EUH^^&XOpcbk4~P6P3^lf$PX>&-yrSLLzp`} zJcM?|kKm(SgOiY)ESh;f6W}MepD#DX-OCs2)=jyk(057d3?YB_){{$b3nR?#RF^eiZU=e>KJqggA|@2+;fC+MIWgE5GtD-y>M1cgN9e46 z;}h{_R10QC@YbGNufT-#zu6n#S7YbPr#7t3lu#|nbVf&7Jg5zRLfhMv?~S}h+}!NP zH7`&q7S?MLJ#Q#8Xu0OTM_}z0d0%F%#PnJj4P{tHY1}-K69kW3GQ_ncn^}@9Ox!N4 zD+q4rCSA%HT~-EsHdv3M!S>Ofv6Gsv&l%gH1TJsp~A`BL1VwN$g8ik zVY$>a`UiG8o!rY*8(Pf@hUM>?E|~OVe$3#XtEX720;vlQmxXG;H7>b4r6HuJoc+zk zvvZD3xX6Yy5tGlGJPIX|SGW=@ee+@$)aqs)CdCoj+nt$u>Vxc4IkArgs}v;gIj%8) z{!owb?Wd2o!=3Rh^@>nshvdq3N^7~Kc*#IPkgrmDpY92sM5gDCeWQ+!;moE&iSb*6 z-g)f>xs)s|1R(;BzyV|SjAy-jy%Gkvhglwk80}HP1TbBdlndp1O{GBR$c#)D#0ToxXsr)9A)Pk+57%g^)X$1pDylRyEu3z z)7&w!Vi){9b|iEpyzkB`%Y{x4$28g&A)sceWCd)N_Oz?lQkSM!iLe*f@dUv=v7(vr zoROlYrFB46wz)OIhc>%;E+4-slN-fr=zFsmV4xQw^(m>6np}I13B!K$gq&G%&jh1kZ~*4mx^$(hKR!QHNQl9FfOn#WRgy__!b03x1($&3T8v+3tfn z%hZ`%iP+Ejn_$2S@sjw#>a@D-Ur*r;klR)Iju0+$7NzAB@g@dwa*a~>M*6eF$oDb zR{OEG%FQ zr@2#b#F_%$40~2ghyRwOe?9C#GZ8wt2<6s(J$M8x|3S*cI%^#MG34)6_=<1%MM!I{jeX;C@E&*;TmuM;##EWn@ z-H8?SINfy*t?~R!oUg-8#iyzG1u393V9xmC3o<8zHQt8q>XTIOVmq&1=EmSAjVt>u z+fkv8Yms76zE)7jqd$~I{!kj)h(MM)@m)g#EtV>%;j#0I17jXP<)#lg4P+(i_?&25&XfNf;_rJa*lqq^Bd*KuG!Y_=~; zkQZcr*HEFujubkAaO+sHqKJz=H|sG?`)hZ_i&4b9^RzOFZR3J)I0}n4J)6XRKuHH z4EWZqMl?8HImmU4OCb*HIy&%|PSWKKgc`VcKZLJ2TJI#^k^5oAk6&|t@R-?ibxVE1 ztclbJGP`l6WX-3uoRhEbq>3Hf5n7J^xn(SYHtoBb$3M~Q>}qa5fow+kLO!f`~36qb;!_zGQ*&8 zGDs)BJ{)FQky0MQ{9bpf`LuI-O{mW~Ph=9q`L4byns*dB9ntx566&4s6xFj?)ctl@ zGh-@q+HB2#o^>Gay}zOfIYGqZdqK)Ovf`MJ%CUocjN(&3QwI)K8p4eG|T$!;VnQ zhQguHiWLhOK_;YCHPTE)WGpaq=MN09eNA(h)D}>sYn)Jj12;IPAQ_A{ z=hXh0sPos5bnp~>i?W!J(I1Ri|87A0yUY^A6#90h#!s_6yVn-Rk=(lOGZGRXK5Uf} z*(AnwKQT;tozDC#*t_l}dG3963ybcQswgH_8vx(8w|a3tb4ZRv(sPAF9Cl!P#+*ce z>ZcZ)#6sb-U>Ibp)OhCTlF{tEf9g)d)ZDRjuC%U3JZ zy60}4NeQ}EqIc6^2RNM3-D7}vVE#G~&(8$m!O6olmJa@cOIeXR*R9EMZMWT0u`1)4 zv~+EqvWkG_PlrZ?lqz5mHkoHAZJYA@p9Oh|7EeBCl3mp>dX`XIfkHtXtywWVJH%4b?tBHvPV2C8S%pq-3#qHB5P}^9q z6q7D>wz`?&y$wy|^P?2|=o6kE_!ZtU5R#prJAtV;T)k1;BF0X1d$hZ3{)@tXt33Ey zOzJMsn6>{2z<;*>@E?Gbf2z*%2j4SKS)j($`e{s1%|5q79&=33blJj8>$Lr7ct`1v z8^^cqB_Oop%z%Ds8m*Rxw`Y3^YOF60WTD7B@p zeBBK?K}HR)8vX4;`E43lI{eOPyg2jhjmG*S>0>Zz?@x zc+k2B@!!r+v3~|&KDCLAbWx)jJDy4T4WGXtFVRC^t+EThf#lSe8%W-ZwX*sK>b-Kj zHKfg@a|l{g4#tZI6~JJT*wc7!L+&jM=E<;*QkV6B?s@e|JSeR6wklZG-ScANCEyo! za%S?wQEbl>k=%xlJ_c2Ow`Ep{PmBKI^(M`+Gedc~)a+h$Q11ss(hgKmba(K@<_(+C zwGmRfMl1Gtqb)#h2iYbkN=$IFVVND0^P7G_CCrZy4v%hz`xJd$YQ#|NGntULbUulZ# zm=tTlAbFDG8<;{ck76sn{*nX=3hIqDRTwcKpgs;xns208#a#Rph{p3yyu*39)wFsA zdC0-pv?gcs<+l+k3#U+U-xVmRWCK|W^e7?xxR`<M64K4>@52T3MIl@UUCUl=mmd zcZdNJC&>3Qn6+`tdXZ2zVg24-k>pVQ_T3`IglO?i*E9b{1`buu>GFS}x#v!o|HmoA z^Y9Zs%c@>7R#%ptjRf0vVjrpeO;ggZ9;(3>qf2W1ktC%b>bFid*dP6E7U8n%hM> zuioe&^&*=>=wFBjIWqdA{r*AHV3+GV8B~m^am8ZBv~~m~L&S@+yQCVP8-Ano$J8?& zHa`{DVA$n9*)KdPWai3gMP1hFc;HTM`AR5V^VBv(8{F&>4S+Z0m8m@+A|%r^)oqYh@OAv5HSX;#C@z4A$6QJW`p3ghc1AC-bMgN}-41xuD!y;)i>QucB13xL5BM7qp_j)*6@& zN8ibR7z*(@f$vJoN>QGj?blgUtBX^!+k zOw~wcF1Nf(^uX_pUsYLdb&!HVm4D;_(r&976*kbLDU8*Ufsx`*?qLR>LmrZaA@22H z_l`Rc8#K@o_AYZ875z}1F+bDU3T83h3+>pEq?e$D{Lnt8`D-6 zU8iafSA3mfG|Dd3J7EIZTZ@8ab=5>?6$8>WFKk29#Jf%JdY010j#?=53Jc1*WZ|&^ z>VoU<3z_5c(Gu=$8WqVPv@cbyTxqL(dd-BSd!2eu(L;$pQmJO228rT@k*L;KDW2uI1H)9@FI%kSQZTGAI7`z`o&?Mj5xMcbfv zTCeJ9|KuA*Y+iD{hbfAch_PL(D(&(#H;bNN%)~DN5tl|*_r=|=E*-YqBE5DBzMDX^ zV7`O3dzn8=RV*}rpu`uCQU$p?cmf$c#s=FQeQ#!rTC|?_Ey!YLCA0=pxQpAOH z>1V`if?^*IAw>Gis}^d?d1w~opl)7}%v5231&FA9i3tWr2{jX6<#p^&Ig@(!m=22V z6CC^iQG~ey0wv)QPR&4Ta2kLdO>~(Wa=?G`L{0a^OzX5}_XW4o( z*(=NKiV@v5 z2A(?Xyz-Wl!Ri8ErJCkZldfEwqt6(RW!Eg>FLZWe2MI+5ZnbKg9XB_R2S)S>1wu!M so<_HvLRPh?KJ8n%lz#(^Edo&0p}C}(tgGT1pTV56Ja@d{`zt^E7wa(`djJ3c literal 13353 zcmeHu30TtG);Ay~YNa-)O^Qv{v7~OPD7)iHM4dsKECJ%Jbdtxx=~lyYKrx?|m+Ad0_9o)?WX$*ZS?X z*WTPbdc<~t+Hy4z2()0o-Jath&^#0fq%;6i0&4P~Rpx_0V6UTxe%uRu1%b>#ARmyq zImjG%CxCp2+qP{3s$>w042ePNFWf2EFudiQlgYa zlu7{tptp=d_M(&MKxrn?IizNwjM4#iB%sKv>CNGbAi zQnRd))65xd2I@zpEP^?U;KL#Ug&-S^B?bOiQYnX?$)S@t%|M}ZngI%c*(hfeC{m78 zIuH{w+Dsa4rjK%f(mXl}6rfQ$DwRr!K2jn9;470F;KZRzN1LUi94XKYJPN>G#z59l z6mIks(6MT;opUG%q*p2X2M2x#vj&0Sp#6Jx{TTU}*D-T?O)KW1XK>i*MH`>=?mNC1 z<4s>$ob=lPuhu)u4FlJ`NP0c=?q$Z>fR&};EA#!{J|Ol;(ev@(dF7|<9v2o`_NVlV zDm)gsfzo|MlsESa{XlkG%D6@#R4NpTUkibt7J6=*4=b5F!dLcNK(IXtFH9Tu#< zMy2;&Go-X>=GAm-cTdf+!t+S3WYm=U*}i9$N=9hHorQMn5eTHcvIOk=pve_?p;dk0 zEXCuORGV|+bak@S~30l(y2TAszn3?2xRSY6L@^lbY~CF$s)in zC^lczm4tlk^o7Nier;jTWQpF!+l$BYl3%EHNQcpqi!m*=|w~=55L>?S!D9ZM2YWAP&je;2RKcXB|?jbXVQz(oza7aWlr5FRJifX zz3OM1j3qhxvrWHt7w0zq364fc51{R0nQn9uyK^OBcqC35zgf=@?a_yDMAIyfWEqK{ z*0b5v+kGcIW+(VL)R%%FFEPF2Y3xWOY4# z$lwTxuqAOUP%_w>o@*_UG_+;~3J;myQL}4c`Wv2x!;xsK^sgGYw%Crr@ONHA#SsV` z0*+0h!0fQOK{3Inro{N!yve+wb%SQO&RCu+pFbN>VgRp0#FV8z-^uNJ7nE18FBvcQ zc8k#H4!Ly&?5sa=iKDv2>l1!7STE*@ix;D^LRV4*V*c|;tpEDWVL>fM(82b z11J8K=DkCDB@9b!QocAWKF?g2FcG$FM;gkYW`6CU-ko9MK<>wh2j{gvy5eGD#DcUZ zq9-#O=Q zvsfQ3>CiCao~QUeu;ASbr|)K3g%yEVMdUK+0-l>YXm5*IrZWz4xZv2J#Vg%i<=@ASo@I+5f0 zN*fpt!6N6fwbT+C^B6bgl}8j8;W}KPL2S9;G_ywRLwb!|B20ZdIZ@(`nr!e1z4w)? zkK^0o09EdQ^W1l2`I@OmOZBp;`0?AX3U8-4%*bZw%Z2MX(i|JEpX3-Hmxu8 zvx|5GPT#;>-2}8lC$-v(xR|0BZGcQ9BDl|;Z8G9RI;*a3nDUL{o zSV*V%v7g<&J5nY44dJY_1s7&oFO5Gw+%QJ#4ufOOw9UO#cubeO^csoz7{v@)9Noou~D|pj+1RO zYojIt(i$+h(4^`5w!xkE5?Cr3{r-P~e2g9YP*_e>`eS-mg3m@aO8TBc z3S#b?gt3yPE)uo zb(hu1kGFLQh+)19uRT?0_7zj`q0@a$UF+R2rGikzk%mY9E0+<(hQ_Oey0!HJqV+(T z3iqf&B`L#|%hl{!+)whX4tDGhx}f98F_S){==+J=i7AjCAC)D6WV}D^2~Xl>eHxB9|Yfury!i*AHAKe!+^&As2*u?)P-5^(x`>b0F#CucMW;c59KO3q}g zb_Y2PGvG^(^Vl5xCS~I=&bPnP+MRNv`}&K~a7j(ir8Hy*`h!Y(Ojtzr^>Y`ZgVj6 z`x1{7MM#S%WiYCEvtw;~Ot?6H@+>Ro#K*MKX!{BVb++C4xLUc`o*6fSbVm=mm1&c9v6pO(=A~}i@x^g90-UlYU~L( zL7jP;ib0-~H1ow1m-6Fsn+9pk_1^lw?P?g|`d!?OYGc839_NQ#u%T~{KR*1W0WxMJ}R`sM42#)9a} zM+CKlLFRdEqsE?MU27)x)q&+6s8em{fzawS`B^8(H?MCo^r3|yQHX<(|sP{C%Kr{e_C z+mCo~k>V^T9|&a2Ub9WpSf943M8NT&RNuKVomd44(#rAO2Rc7ni?^ zkb3lS!x1V;DAI9+Lg6JTkOFG+g`yRNWjA)d4SXoJx!4aA6EDZV29DTj!HO+0zDrl26=xJo!$+6H0Cmvtk6>e zKYYG|T_1xfG`DDhtF z1ATQENZrhMxZ1}ujzJ)r zzz*=J`9HT4{AZu6<^q$Oo40fXstV(1YQpSMx+(ssqmataQ0V1Fnl*4b?WlbiFHRr)#rxz2F zRbfgpdOHU6DpY6oBrP3T=brKX!vxU+0=7;CsYlzIVnvG}LTnDoXHnN}{O}4#IiQ8)lQ`!)@8;ao zK5GPjEuTPq#a<+>qp|aXNzmJtn3Me}u4_~C+I|-lz_VFm^>lrvfD+f}D!`X0S9;1P zyu9lPZP2n}u;&yi*K%H^rb49PMzlW=VNd8K2!=NzvSHsu?Rt*S4hnNyrB>VAvMpNq zs=J&8Djb!pvm|_&wMa8uVOAut?{vNpc7u)@(3I=&Pf8)b=tC;6%aubA!lML^@eO?I zYY`Xbp074)Ie#{^FloBM5p_<%W*K5_babcGaX7wksiuoU+yM5wGg9#Zy>y}Y0b$Z# z`RW4&&uO1qb;3|Kc7DWiS!8wB9c=Uz|A2#CWmx6FIs#)V3^R5|_seeT5{}JO45gM-mRJCtORLO`83jsA-L|~SY z;Xj=%TS!xQBgro*sZo7V~qQQlLj|hdSj{6}$Y_cR)aOjjkWjw4VbPNTMOUNL>Ls zm*}zqI@Eat`vY z>xiB5fH;R58YAw`Dr8b3g0LTp@GI%x!7{CTFAfNKgck&H>vi(jlNo;Cop*4F%(+y`wy{fb?#-xqV>+nB^#zebS(*4Yo&%`wKoJYVZhN^azbjWc59n!;j z8$&jAL0zvGo~z(Pw*o5&o4y!WW-PzrUjxyc?O$9|8V-YZPVO29!ks^Rt|)s>jQRhq z1`oTbi@JH=7N~6{0~UOzk0Q=t!_D=Ms5^5jR72Mjq0cS*xH;Wc#Y>)u-Srt*A}yMA zFITyD$M4EROjidbLZ~0(mjJ}5^3cFu1SWk)v^#1D+@$Y+*BCT(MZpc~a+UwtDN3%wI zcHsLOx`o(f`^_AH6ofJ|>ieAC-aOU#J!(Z`7asn4-V0L-AcBfxYYwBSO9r#hEIUI9Tg8a`9l+srU9OAvF3AN z8|6Ck)DV6s2`^KGJ?fz`kanp^Ov7(+mp_CRIP;-lk~fg*0d(e!niw1JbyGCVym0a8 zx_em8;H>!5yMt>5s`9b?(_K{UtQBl{4o2X&hVs!0W6rOGixeUd?Q@`O)8#`pOlCfa zJ+oNBA35|?`mEih(BgDt1GsKY^zV(y9|^#chEN0|{V$-Ihp z1EMUpbzkGxFB#&?Fqogrl#V_x!)dqt9%;?C)KDUdkC+Dq-j9xs5#JN-H)OY4xPpIO zIy;~WyH+Y_z2x>cvrk4c+dU9Q&)XB!_Uc{DiIltd;~A@*1P}aEU+?(Nr^%#bpugCn z%_8^9W@f1dH##&vLvSKRmbOvY_m%kASe92z|0hvr)j$pg)eh-?C3k^bAg$hvx!hb` zfp^2qziRNkyTr=^Zj~oI_c+2HJxkU>RnFhTZ> z@HD`l=77VQPdc?(o4a4fsJxytJVwY#fgUc_0J~H|Ii(+KhAvrTQF&80$Q(& zj|Q%U-My;>K~?;5>VM+;*uO3FK)3O9y7#i%sgd#|Iy#jxOkoL>Na_9oYbUbs2l$e6t zzV0hY^<%Wlw}ZUc)2Rtrrt2(TuxFHH9As(nOF&w@`L!3{I$N~h=T-!8PA5AZeA>hm z@X{NE{3;jAD^9@i8E_7W4(kcd*CB`!?)F;)hix~36GI&qn5kMV8tP5KrsDu00$ncK z2BPgxQ2o7r6u1l!0=TII7umWxXM{;JsSH#*S!0}!g&-Kwo$!FlWGP5pfTlICi z>|9Tg#@;a!uaXCxO}-2qRe#pGa_ZV~;FRSOX${orme_>^bHUIcL7_%CzAyN!TzY_K?0Wu%P_!CfH>=~-p0&a2iK21ZJJ^w!0NLnCUohXzDNW$wAJa%9yBFn zj8R5iXy5sL*)8RAw?28OlB*?V4f}3lm_x><5}Ntjc4EZ2dGB=fC~XqzgCzd+%iI0Y z+QAxDmhR%RXkKpK+ejO|l6@mVWiJZ1XTfTxk=1VHmo3dZZtIMthj1!3b?KF=iTNQL zdoTGxr9|w3gN3*7ZttZF%*@_cKbF>xxRJ5>^(pD6`cI2{n}1_xwI=Gnhty9t8x=AO z`J1HfomgRR9%F--UdgpCcDTK-Z;K}3%gp%1r2Xi^iCM#6v2|F_6#eCCG>+f4Tj>@XEa-4 z;&F}ayK=baSu7v2s*v z+w#2hzkWf7l;~eewz@dxQt0)R_p3+)!^K*!mYi8USpQE6tdM^bioE8*E9~-2MUO_T74W z^3cBpmF=!^OD=PqXmXkq0pM$pVPK_vs&HCs9#0Lfd6O&D(U4QDJ zIUlW4i}_$?$x|zdtE4^Zu_;$7UNj9D?qc}SNl#v^y6E7M$vy46<%eMd=nYE+Ffj8oA2BUI<%b?EodtE*wKe0S48;j5> z`$22J+aYfuHU`kEAB+(}XhQvR9K>RJXlPP-=h$84t2Qv$PwpOi#|XpAY3GOcM_r8K zv#o&(HUYy9({Igu3YmN|hI`Q3!r}>V#o1EW-J)!4EP2G9i5yi{&tp%&EI$doT5gO; z+-QeJ0e7@cm?4LeC#@>Q?eyZZ-onDuY6bcPI!~GUx}-e5*_LraOY@cid`}3*LX5-k z?_>bES|&esc8a}88@O8H=+K%tPUw@R!0;v3MbV()xftX4aHHz~d3q+3_@U{v-y1Nagf6l~Lkakd89 zeTY}TJcwUvPU|ZyJkGClaUV0+s&fbjM3HqG8o+0#Zr9lQUa255qZ>#(uYl@y$WGaUy)GWJ zPbWhmHd=tjkE2xz2#X25t(S(P$+xPj*e;!xm>j{*5KsPIm8?%->2a2O?REQoyB z17M^CcBbqc-iC;IEiB$g>Yaq(&Q82b LATE estimation results: -#> -#> Estimate Std. Error t value Pr(>|t|) -#> -0.236 0.19 -1.24 0.214 +#> DDML estimation: Local Average Treatment Effect +#> Obs: 5000 Folds: 10 +#> +#> Estimate Std. Error t value Pr(>|t|) +#> LATE -0.237 0.190 -1.25 0.21 ``` All works well! @@ -148,10 +149,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 +161,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 +203,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,32 +223,34 @@ 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)) +#> Error in FUN(X[[i]], ...): 'CreateProcess' failed to run 'C:\Program Files\WindowsApps\PythonSoftwareFoundation.Python.3.11_3.11.2544.0_x64__qbz5n2kfra8p0\python.exe -c "import sys; print(sys.platform)"' # 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)) +#> Error in eval(expr, envir, enclos): object 'callbacks_list' not found # Estimate ddml_late 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) +#> Error in eval(expr, envir, enclos): object 'learner_keras' not found summary(late_fit) -#> LATE estimation results: -#> -#> Estimate Std. Error t value Pr(>|t|) -#> -0.187 0.189 -0.989 0.322 +#> DDML estimation: Local Average Treatment Effect +#> Obs: 5000 Folds: 10 +#> +#> Estimate Std. Error t value Pr(>|t|) +#> LATE -0.237 0.190 -1.25 0.21 ``` All works well! diff --git a/vignettes/articles/new_ml_wrapper.Rmd.txt b/vignettes/articles/new_ml_wrapper.Rmd.txt index 73f67ae..740de6b 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"), + warning = FALSE, + message = FALSE ) ``` diff --git a/vignettes/articles/sparse.Rmd b/vignettes/articles/sparse.Rmd index a347844..a699843 100644 --- a/vignettes/articles/sparse.Rmd +++ b/vignettes/articles/sparse.Rmd @@ -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 @@ -80,17 +78,17 @@ stacking_180IV_fit <- ddml_fpliv(y = AK91$LWKLYWGE, D = AK91$EDUC, learners_DX = list(list(fun = 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 t value Pr(>|t|) +#> D_r 0.1121 0.0215 5.23 1.7e-07 *** +#> --- +#> 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. @@ -109,17 +107,17 @@ stacking_1530IV_fit <- ddml_fpliv(y = AK91$LWKLYWGE, D = AK91$EDUC, learners_DX = list(list(fun = 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 t value Pr(>|t|) +#> D_r 0.1112 0.0579 1.92 0.055 . +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` 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. @@ -150,17 +148,17 @@ stacking_fit <- ddml_fpliv(y = AK91$LWKLYWGE, D = AK91$EDUC, learners_DX = list(list(fun = 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 t value Pr(>|t|) +#> D_r 0.1148 0.0209 5.49 4e-08 *** +#> --- +#> 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. @@ -169,10 +167,10 @@ The resulting coefficient is close to the coefficient based on 180 instruments. ```r round(stacking_fit$weights$D1_XZ, 4) #> nnls1 -#> [1,] 0.7000 +#> [1,] 0.7409 #> [2,] 0.0000 -#> [3,] 0.2925 -#> [4,] 0.0075 +#> [3,] 0.2591 +#> [4,] 0.0000 ``` # References diff --git a/vignettes/articles/sparse.Rmd.txt b/vignettes/articles/sparse.Rmd.txt index c8c4980..7828e09 100644 --- a/vignettes/articles/sparse.Rmd.txt +++ b/vignettes/articles/sparse.Rmd.txt @@ -12,7 +12,9 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, comment = "#>", - eval = requireNamespace("Matrix") + eval = requireNamespace("Matrix"), + warning = FALSE, + message = FALSE ) ``` diff --git a/vignettes/articles/stacking.Rmd b/vignettes/articles/stacking.Rmd index 8d8a029..867f678 100644 --- a/vignettes/articles/stacking.Rmd +++ b/vignettes/articles/stacking.Rmd @@ -82,11 +82,11 @@ Both stacking and short-stacking construct weighted averages of the considered b ```r cat("Time single learner:", time_singlelearner[1], "\n") -#> Time single learner: 10.39 +#> Time single learner: 3.95 cat("Time short-stacking:", time_shortstacking[1], "\n") -#> Time short-stacking: 12.83 +#> Time short-stacking: 7.47 cat("Time stacking: ", time_stacking[1]) -#> Time stacking: 117.98 +#> Time stacking: 75.75 ``` # 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..88840b4 100644 --- a/vignettes/articles/stacking.Rmd.txt +++ b/vignettes/articles/stacking.Rmd.txt @@ -12,7 +12,9 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, comment = "#>", - eval = TRUE + eval = TRUE, + warning = FALSE, + message = FALSE ) ``` diff --git a/vignettes/ddml.Rmd b/vignettes/ddml.Rmd index 4ae5799..8e4f148 100644 --- a/vignettes/ddml.Rmd +++ b/vignettes/ddml.Rmd @@ -59,10 +59,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 t value Pr(>|t|) +#> 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).) @@ -98,10 +99,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|) -#> 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 t value Pr(>|t|) +#> LATE -0.223 0.187 -1.2 0.23 ``` 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]$: @@ -110,14 +112,14 @@ It is often insightful to see which base learners contribute the most to the fin 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 +#> [,1] [,2] [,3] +#> nnls1 0.9668285 0 0.0331715 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 +#> [,1] [,2] [,3] +#> nnls1 0 0.8027662 0.1972338 ``` # Estimation using Different Types of Short-Stacking @@ -141,13 +143,24 @@ 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 t value Pr(>|t|) +#> LATE -0.231 0.187 -1.24 0.22 +#> +#> Ensemble type: singlebest +#> Estimate Std. Error t value Pr(>|t|) +#> LATE -0.229 0.187 -1.22 0.22 +#> +#> Ensemble type: ols +#> Estimate Std. Error t value Pr(>|t|) +#> LATE -0.231 0.187 -1.23 0.22 +#> +#> Ensemble type: average +#> Estimate Std. Error t value Pr(>|t|) +#> LATE -0.229 0.189 -1.21 0.23 ``` # References diff --git a/vignettes/ddml.Rmd.txt b/vignettes/ddml.Rmd.txt index a0d8ed1..043b75f 100644 --- a/vignettes/ddml.Rmd.txt +++ b/vignettes/ddml.Rmd.txt @@ -12,7 +12,9 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, comment = "#>", - eval = TRUE + eval = TRUE, + warning = FALSE, + message = FALSE ) ``` From aeb961f8492c5e5596672175c218a2188fa4c5f2 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Thu, 26 Feb 2026 12:21:08 -0600 Subject: [PATCH 08/46] migrate to what, deprecate fun --- R/crosspred.R | 9 ++-- R/crossval.R | 11 ++-- R/ddml_ate.R | 6 +-- R/ddml_late.R | 6 +-- R/ddml_plm.R | 6 +-- R/diagnostics.R | 2 +- R/ensemble.R | 16 +++--- R/help_functions.R | 53 ++++++++++++++++--- R/methods.R | 2 +- R/shortstacking.R | 6 +-- tests/testthat/test-crosspred.R | 26 +++++----- tests/testthat/test-crossval.R | 22 ++++---- tests/testthat/test-ddml_ate.R | 12 ++--- tests/testthat/test-ddml_att.R | 14 ++--- tests/testthat/test-ddml_fpliv.R | 66 ++++++++++++------------ tests/testthat/test-ddml_late.R | 16 +++--- tests/testthat/test-ddml_pliv.R | 48 ++++++++--------- tests/testthat/test-ddml_plm.R | 38 +++++++------- tests/testthat/test-diagnostics.R | 6 +-- tests/testthat/test-ensemble.R | 24 ++++----- tests/testthat/test-help_functions.R | 58 +++++++++++++++++++++ tests/testthat/test-methods.R | 14 ++--- tests/testthat/test-shortstacking.R | 6 +-- tests/testthat/test-tidy.R | 4 +- vignettes/articles/did.Rmd.txt | 20 +++---- vignettes/articles/example_401k.Rmd.txt | 40 +++++++------- vignettes/articles/example_BLP95.Rmd.txt | 16 +++--- vignettes/articles/sparse.Rmd.txt | 28 +++++----- vignettes/articles/stacking.Rmd.txt | 12 ++--- vignettes/ddml.Rmd.txt | 6 +-- 30 files changed, 351 insertions(+), 242 deletions(-) diff --git a/R/crosspred.R b/R/crosspred.R index f42002f..a2ee40a 100644 --- a/R/crosspred.R +++ b/R/crosspred.R @@ -122,8 +122,8 @@ #' # 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"), @@ -162,10 +162,13 @@ crosspred <- function(y, X, Z = NULL, cv_subsamples <- cv_subsamples_list }#IF + # Normalize learner specs before parallel dispatch + learners <- normalize_learners(learners) + # Data parameters nobs <- nrow(X) nlearners <- length(learners) - calc_ensemble <- !("what" %in% names(learners)) + calc_ensemble <- !is_single_learner(learners) ncustom <- ncol(custom_ensemble_weights) ncustom <- ifelse(is.null(ncustom), 0, ncustom) nensb <- length(ensemble_type) + ncustom diff --git a/R/crossval.R b/R/crossval.R index f4d9780..8962684 100644 --- a/R/crossval.R +++ b/R/crossval.R @@ -62,9 +62,9 @@ #' #' # 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) @@ -82,6 +82,9 @@ crossval <- function(y, X, Z = NULL, parallel_export <- p$export parallel_packages <- p$packages + # Normalize learner specs: resolve fun/what before parallel dispatch + learners <- normalize_learners(learners) + # Data parameters nobs <- length(y) nlearners <- length(learners) @@ -155,7 +158,7 @@ crossval_compute <- function(test_sample, learner, if (is.null(learner$assign_Z) && !is.null(Z)) learner$assign_Z <- seq_len(ncol(Z)) - mdl_fun <- list(what = learner$fun, args = learner$args) + mdl_fun <- list(what = learner$what, args = learner$args) assign_X <- learner$assign_X assign_Z <- learner$assign_Z diff --git a/R/ddml_ate.R b/R/ddml_ate.R index dd79a38..7ff11c1 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -104,9 +104,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, diff --git a/R/ddml_late.R b/R/ddml_late.R index 72c99b4..c462ebb 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -131,9 +131,9 @@ #' 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, diff --git a/R/ddml_plm.R b/R/ddml_plm.R index 3bab495..a5c70fa 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -140,9 +140,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, diff --git a/R/diagnostics.R b/R/diagnostics.R index 5f39c85..b66eba7 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -40,7 +40,7 @@ diagnostics <- function(object, cvc = FALSE, }#IF eq_names <- names(object$weights) - single_learner <- "what" %in% names(object$learners) + single_learner <- is_single_learner(object$learners) tables <- list() for (eq in eq_names) { diff --git a/R/ensemble.R b/R/ensemble.R index acc98bb..ae97579 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -36,9 +36,9 @@ #' # Fit an ensemble of ols, lasso, and ridge #' ens_fit = ensemble(y, X, #' type = "nnls", -#' 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 = 5, #' silent = TRUE) @@ -53,6 +53,9 @@ ensemble <- function(y, X, Z = NULL, cv_results = NULL, custom_weights = NULL, silent = FALSE) { + # Normalize learner specs + learners <- normalize_learners(learners) + # Data parameters nlearners <- length(learners) # Check if y is constant @@ -98,7 +101,8 @@ ensemble <- function(y, X, Z = NULL, 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) + mdl_fun <- list(what = learners[[m]]$what, + args = learners[[m]]$args) assign_X <- learners[[m]]$assign_X assign_Z <- learners[[m]]$assign_Z # Then fit the model @@ -191,8 +195,8 @@ predict.ensemble <- function(object, newdata, newZ = NULL, ...){ #' # Compute stacking weights via NNLS #' ew = ensemble_weights(y, X, #' type = "nnls", -#' learners = list(list(fun = ols), -#' list(fun = mdl_glmnet)), +#' learners = list(list(what = ols), +#' list(what = mdl_glmnet)), #' cv_folds = 5, #' silent = TRUE) #' ew$weights diff --git a/R/help_functions.R b/R/help_functions.R index eb50a3a..1162745 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -49,6 +49,42 @@ trim_propensity_scores <- function(m_X, trim, ensemble_type) { 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)) { + if (is.null(getOption("ddml.fun_deprecated_warned"))) { + message("Note: 'fun' in learner specifications ", + "is deprecated. Use 'what' instead.") + options(ddml.fun_deprecated_warned = TRUE) + }#IF + return(l$fun) + }#IF + stop("Learner must have a 'what' or 'fun' 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 + # 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, @@ -92,14 +128,17 @@ validate_inputs <- function(y = NULL, D = NULL, X = NULL, Z = NULL, learners = N if (!is.list(learners)) { stop("learners must be a list.") } else { - is_single <- "what" %in% names(learners) + is_single <- is_single_learner(learners) if (!is_single) { for (l in learners) { - if (!is.list(l) || !"fun" %in% names(l)) { - stop("learners structure is invalid.") - } - } - } + if (!is.list(l) || + (is.null(l$what) && is.null(l$fun))) { + stop("Each stacking learner must have a ", + "'what' or 'fun' element.", + call. = FALSE) + }#IF + }#FOR + }#IF } } @@ -135,7 +174,7 @@ validate_custom_weights <- function(custom_weights, learners) { stop("custom_ensemble_weights must be numeric.") } custom_weights <- as.matrix(custom_weights) - n_learners <- if ("what" %in% names(learners)) 1 else length(learners) + 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.") } diff --git a/R/methods.R b/R/methods.R index 9b73c70..550a58f 100644 --- a/R/methods.R +++ b/R/methods.R @@ -137,7 +137,7 @@ confint.ddml <- function(object, parm, level = 0.95, #' @export summary.ddml <- function(object, type = "HC1", ...) { type <- match.arg(type, c("HC0", "HC1", "HC3")) - single_learner <- ("what" %in% names(object$learners)) + single_learner <- is_single_learner(object$learners) ens_type <- if (single_learner) { "single base learner" } else { diff --git a/R/shortstacking.R b/R/shortstacking.R index 04426e0..a4a4f08 100644 --- a/R/shortstacking.R +++ b/R/shortstacking.R @@ -65,8 +65,8 @@ #' # 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"), @@ -91,7 +91,7 @@ shortstacking <- function(y, X, Z = NULL, nlearners <- length(learners) # Throw error if no ensemble is estimated - calc_ensemble <- !("what" %in% names(learners)) + calc_ensemble <- !is_single_learner(learners) if (!calc_ensemble) { stop("shortstacking cannot be estimated with a single learner.") }#IF diff --git a/tests/testthat/test-crosspred.R b/tests/testthat/test-crosspred.R index 77920a1..3dd118a 100644 --- a/tests/testthat/test-crosspred.R +++ b/tests/testthat/test-crosspred.R @@ -35,9 +35,9 @@ test_that("crosspred computes with ensemble procedures", { 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)) + learners <- list(list(what = ols), + list(what = ols), + list(what = ols)) # Compute cross-sample predictions crosspred_res <- crosspred(y, X, Z, learners, @@ -60,9 +60,9 @@ test_that("crosspred computes with ensemble procedures & custom weights", { 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)) + 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") @@ -89,8 +89,8 @@ test_that("crosspred computes with ensemble procedures and sparse matrices", { 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)) + learners <- list(list(what = ols), + list(what = ols)) # Compute cross-sample predictions crosspred_res <- crosspred(y, as(X, "sparseMatrix"), as(Z, "sparseMatrix"), @@ -113,9 +113,9 @@ test_that("crosspred computes auxilliary predictions", { X <- cbind(1, matrix(rnorm(nobs*39), nobs, 39)) 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, @@ -137,8 +137,8 @@ test_that("crosspred returns identical results with parallel", { nobs <- 100 X <- cbind(1, matrix(rnorm(nobs * 39), nobs, 39)) y <- X %*% runif(40) + rnorm(nobs) - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) splits <- get_sample_splits(seq_len(nobs), sample_folds = 3, cv_folds = 3) # Sequential diff --git a/tests/testthat/test-crossval.R b/tests/testthat/test-crossval.R index d88346d..380576a 100644 --- a/tests/testthat/test-crossval.R +++ b/tests/testthat/test-crossval.R @@ -4,7 +4,7 @@ test_that("crossval_compute returns residuals (w/o instruments)", { 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) @@ -18,9 +18,9 @@ test_that("crossval returns residuals by learner (w/o instruments)", { 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, @@ -52,9 +52,9 @@ test_that("crossval returns residuals by learner in correct order", { }#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) @@ -70,9 +70,9 @@ test_that("crossval returns residuals by learner (w/ instruments)", { 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)) + learners <- list(list(what = ols), + list(what = ols), + list(what = mdl_glmnet)) # Compute cross-validation instance cv_res <- crossval(D, X, Z, learners, @@ -90,8 +90,8 @@ test_that("crossval returns identical results with parallel", { nobs <- 100 X <- cbind(1, matrix(rnorm(nobs * 39), nobs, 39)) y <- X %*% runif(40) + rnorm(nobs) - learners <- list(list(fun = ols), - list(fun = ols)) + learners <- list(list(what = ols), + list(what = ols)) cv_subs <- generate_subsamples(nobs, 3) # Sequential res_seq <- crossval(y, X, learners = learners, diff --git a/tests/testthat/test-ddml_ate.R b/tests/testthat/test-ddml_ate.R index 51cea0d..cf4ed8d 100644 --- a/tests/testthat/test-ddml_ate.R +++ b/tests/testthat/test-ddml_ate.R @@ -73,8 +73,8 @@ test_that("ddml_ate computes with an ensemble procedure", { D <- 1 * (D_tld > mean(D_tld)) 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 suppressWarnings({ ddml_ate_fit <- ddml_ate(y, D, X, @@ -96,8 +96,8 @@ test_that("ddml_ate computes w/ multiple ensembles + custom weights", { D <- 1 * (D_tld > mean(D_tld)) 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 suppressWarnings({ ddml_ate_fit <- ddml_ate(y, D, X, @@ -121,7 +121,7 @@ test_that("ddml_ate computes with multiple ensemble procedures & shortstack", { D <- 1 * (D_tld > mean(D_tld)) y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols)) + learners <- list(list(what = ols)) # Compute DDML PLM estimator suppressWarnings({ ddml_ate_fit <- ddml_ate(y, D, X, @@ -199,7 +199,7 @@ test_that("summary.ddml_ate computes with multiple ensemble procedures", { D <- 1 * (D_tld > mean(D_tld)) y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols)) + learners <- list(list(what = ols)) # Compute DDML PLM estimator suppressWarnings({ ddml_ate_fit <- ddml_ate(y, D, X, diff --git a/tests/testthat/test-ddml_att.R b/tests/testthat/test-ddml_att.R index e5c8e5c..7b0444f 100644 --- a/tests/testthat/test-ddml_att.R +++ b/tests/testthat/test-ddml_att.R @@ -73,8 +73,8 @@ test_that("ddml_att computes with an ensemble procedure", { D <- 1 * (D_tld > mean(D_tld)) 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 suppressWarnings({ ddml_att_fit <- ddml_att(y, D, X, @@ -96,8 +96,8 @@ test_that("ddml_att computes w/ multiple ensembles + custom weights", { D <- 1 * (D_tld > mean(D_tld)) 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 suppressWarnings({ ddml_att_fit <- ddml_att(y, D, X, @@ -121,8 +121,8 @@ test_that("ddml_att computes w/ multp ensembles, custom weights + shortstack", { D <- 1 * (D_tld > mean(D_tld)) 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 suppressWarnings({ ddml_att_fit <- ddml_att(y, D, X, @@ -200,7 +200,7 @@ test_that("summary.ddml_att computes with multiple ensemble procedures", { D <- 1 * (D_tld > mean(D_tld)) y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments - learners <- list(list(fun = ols)) + learners <- list(list(what = ols)) # Compute DDML PLM estimator suppressWarnings({ ddml_att_fit <- ddml_att(y, D, X, diff --git a/tests/testthat/test-ddml_fpliv.R b/tests/testthat/test-ddml_fpliv.R index 8a09375..3820629 100644 --- a/tests/testthat/test-ddml_fpliv.R +++ b/tests/testthat/test-ddml_fpliv.R @@ -7,7 +7,7 @@ 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, @@ -31,7 +31,7 @@ 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, @@ -50,8 +50,8 @@ 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)) + learners <- list(list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, @@ -72,8 +72,8 @@ test_that("ddml_fpliv computes with stacking w/o enforcing the LIE", { 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)) + learners <- list(list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, @@ -95,8 +95,8 @@ 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)) + learners <- list(list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, @@ -119,8 +119,8 @@ 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)) + learners <- list(list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, @@ -143,8 +143,8 @@ test_that("ddml_fpliv computes with multiple ensembles w/o the LIE", { 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)) + learners <- list(list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, @@ -167,8 +167,8 @@ 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)) + learners <- list(list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z = as(Z, "sparseMatrix"), @@ -192,13 +192,13 @@ 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)) + 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 LIE-conform DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, @@ -223,8 +223,8 @@ 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)) + learners <- list(list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, @@ -248,8 +248,8 @@ test_that("ddml_fpliv computes w/ ensembles & shortstack but w/o the LIE ", { 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)) + learners <- list(list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, @@ -293,8 +293,8 @@ 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)) + learners <- list(list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, @@ -315,8 +315,8 @@ test_that("ddml_fpliv computes with an ensemble procedure w/o LIE, 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)) + learners <- list(list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, @@ -339,8 +339,8 @@ test_that("ddml_fpliv computes with multiple ensemble procedures, multi D", { X %*% runif(40) + Z %*% c(1, runif(9)) + 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 suppressWarnings({ ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, @@ -364,8 +364,8 @@ test_that("ddml_fpliv computes with ensemble procedures w/o LIE, 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)) + learners <- list(list(what = ols), + list(what = ols)) # Compute LIE-conform DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, diff --git a/tests/testthat/test-ddml_late.R b/tests/testthat/test-ddml_late.R index ab5ad34..6db3a81 100644 --- a/tests/testthat/test-ddml_late.R +++ b/tests/testthat/test-ddml_late.R @@ -104,8 +104,8 @@ test_that("ddml_late computes with an ensemble procedure", { D <- 1 * (D_tld > mean(D_tld)) 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 suppressWarnings({ ddml_late_fit <- ddml_late(y, D, Z, X, @@ -129,8 +129,8 @@ test_that("ddml_late computes w/ multiple ensembles & custom weights", { D <- 1 * (D_tld > mean(D_tld)) 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 suppressWarnings({ ddml_late_fit <- ddml_late(y, D, Z, X, @@ -158,8 +158,8 @@ test_that("ddml_late computes with multiple ensemble procedures + perfect compli D[Z == 1] <- 1 # perfect compliance 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 suppressWarnings({ ddml_late_fit <- ddml_late(y, D, Z, X, @@ -185,8 +185,8 @@ test_that("ddml_late computes w/ mult ensembles, custom weights, & shortstack", D <- 1 * (D_tld > mean(D_tld)) 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 suppressWarnings({ ddml_late_fit <- ddml_late(y, D, Z, X, diff --git a/tests/testthat/test-ddml_pliv.R b/tests/testthat/test-ddml_pliv.R index a77ee9a..9ca9726 100644 --- a/tests/testthat/test-ddml_pliv.R +++ b/tests/testthat/test-ddml_pliv.R @@ -51,8 +51,8 @@ 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, @@ -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, @@ -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, @@ -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, @@ -185,8 +185,8 @@ 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, @@ -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, diff --git a/tests/testthat/test-ddml_plm.R b/tests/testthat/test-ddml_plm.R index 59fd32f..bbe4bd1 100644 --- a/tests/testthat/test-ddml_plm.R +++ b/tests/testthat/test-ddml_plm.R @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -230,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, @@ -258,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, @@ -280,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, @@ -305,7 +305,7 @@ test_that("ddml_plm backward-compat cv_subsamples_list works with message", { # Pre-generate splits splits <- get_sample_splits(seq_len(nobs), sample_folds = 3, cv_folds = 3) - learners <- list(list(fun = ols), list(fun = ols)) + learners <- list(list(what = ols), list(what = ols)) # Call with deprecated cv_subsamples_list — should emit message expect_message( ddml_plm(y, D, X, diff --git a/tests/testthat/test-diagnostics.R b/tests/testthat/test-diagnostics.R index 1ca9860..7f5eaf1 100644 --- a/tests/testthat/test-diagnostics.R +++ b/tests/testthat/test-diagnostics.R @@ -31,7 +31,7 @@ test_that("diagnostics works with PLM multiple learners", { D <- X %*% c(1, 0.5, 0) + rnorm(nobs) y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) - learners <- list(list(fun = ols), list(fun = ols)) + learners <- list(list(what = ols), list(what = ols)) suppressWarnings({ fit <- ddml_plm(y, D, X, learners = learners, @@ -83,7 +83,7 @@ test_that("diagnostics with CVC", { D <- X %*% c(1, 0.5, 0) + rnorm(nobs) y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) - learners <- list(list(fun = ols), list(fun = ols)) + learners <- list(list(what = ols), list(what = ols)) suppressWarnings({ fit <- ddml_plm(y, D, X, learners = learners, @@ -136,7 +136,7 @@ test_that("diagnostics r2 matches manual calculation", { D <- X %*% c(1, 0.5, 0) + rnorm(nobs) y <- 2 * D + X %*% c(0, 1, 0.5) + rnorm(nobs) - learners <- list(list(fun = ols), list(fun = ols)) + learners <- list(list(what = ols), list(what = ols)) suppressWarnings({ fit <- ddml_plm(y, D, X, learners = learners, diff --git a/tests/testthat/test-ensemble.R b/tests/testthat/test-ensemble.R index c934de0..3918c85 100644 --- a/tests/testthat/test-ensemble.R +++ b/tests/testthat/test-ensemble.R @@ -4,8 +4,8 @@ test_that("ensemble_weights returns a weight matrix", { 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)) + 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, @@ -30,8 +30,8 @@ test_that("ensemble returns a list of fitted learners", { 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)) + learners <- list(list(what = mdl_glmnet), + list(what = ols)) # Compute ensemble ens_fit <- ensemble(D, X, Z, type = c("average", "ols", "singlebest"), @@ -48,8 +48,8 @@ test_that("prediction with ensemble learners returns fitted values", { 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)) + learners <- list(list(what = mdl_glmnet), + list(what = ols)) # Compute ensemble ens_fit <- ensemble(D, X, Z, type = c("average", "ols", "singlebest"), @@ -67,8 +67,8 @@ test_that("ensemble_weights returns a weight matrix w/ custom weights", { 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)) + learners <- list(list(what = mdl_glmnet), + list(what = ols)) # Define custom weights weights_DX <- diag(length(learners)) # Compute ensemble weights @@ -89,8 +89,8 @@ test_that("prediction w/ ensembles returns fitted values w/ custom weights", { 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)) + learners <- list(list(what = mdl_glmnet), + list(what = ols)) # Define custom weights weights_DX <- diag(length(learners)) # Compute ensemble @@ -112,8 +112,8 @@ test_that("ensemble returns mean_y for constant outcomes", { 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({ diff --git a/tests/testthat/test-help_functions.R b/tests/testthat/test-help_functions.R index 0be765b..de61798 100644 --- a/tests/testthat/test-help_functions.R +++ b/tests/testthat/test-help_functions.R @@ -7,3 +7,61 @@ 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.*fun") + + # 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) +}) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 6ee80b2..7a1c240 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -6,7 +6,7 @@ test_that("standard S3 generic methods work correctly", { D <- 1 * (D_tld > mean(D_tld)) y <- D + X %*% runif(5) + rnorm(nobs) - learners <- list(list(fun = ols), list(fun = ols)) + learners <- list(list(what = ols), list(what = ols)) suppressWarnings({ fit <- ddml_ate(y, D, X, learners = learners, @@ -51,7 +51,7 @@ test_that("type argument threads through S3 methods", { D <- 1 * (D_tld > mean(D_tld)) y <- D + X %*% runif(5) + rnorm(nobs) - learners <- list(list(fun = ols), list(fun = ols)) + learners <- list(list(what = ols), list(what = ols)) suppressWarnings({ fit <- ddml_ate(y, D, X, learners = learners, @@ -106,10 +106,12 @@ test_that("type works with PLM estimator", { 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) + suppressWarnings({ + 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") diff --git a/tests/testthat/test-shortstacking.R b/tests/testthat/test-shortstacking.R index a03f805..5f3e9d4 100644 --- a/tests/testthat/test-shortstacking.R +++ b/tests/testthat/test-shortstacking.R @@ -5,9 +5,9 @@ test_that("shortstacking computes with ensemble procedures & custom weights", { 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)) + learners <- list(list(what = ols), + list(what = ols), + list(what = ols)) # Compute cross-sample predictions shortstacking_res <- shortstacking(y, X, Z, learners, diff --git a/tests/testthat/test-tidy.R b/tests/testthat/test-tidy.R index 05996aa..04056f5 100644 --- a/tests/testthat/test-tidy.R +++ b/tests/testthat/test-tidy.R @@ -7,7 +7,7 @@ test_that("tidy and glance broom formatters work correctly", { D <- 1 * (D_tld > mean(D_tld)) y <- D + X %*% runif(5) + rnorm(nobs) - learners <- list(list(fun = ols), list(fun = ols)) + learners <- list(list(what = ols), list(what = ols)) suppressWarnings({ fit <- ddml_ate(y, D, X, learners = learners, @@ -51,7 +51,7 @@ test_that("tidy respects type argument", { D <- 1 * (D_tld > mean(D_tld)) y <- D + X %*% runif(5) + rnorm(nobs) - learners <- list(list(fun = ols), list(fun = ols)) + learners <- list(list(what = ols), list(what = ols)) suppressWarnings({ fit <- ddml_ate(y, D, X, learners = learners, diff --git a/vignettes/articles/did.Rmd.txt b/vignettes/articles/did.Rmd.txt index df4d6d2..6490635 100644 --- a/vignettes/articles/did.Rmd.txt +++ b/vignettes/articles/did.Rmd.txt @@ -172,35 +172,35 @@ The reduced form estimators are then optimally combined via non-negative least s ```{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, + learners = list(list(what = ols), + list(what = mdl_xgboost, args = list(nround = 500, params = list(eta = 0.05, max_depth = 1), early_stopping_rounds = 1)), - list(fun = mdl_xgboost, + list(what = mdl_xgboost, args = list(nround = 500, params = list(eta = 0.05, max_depth = 3), early_stopping_rounds = 1)), - list(fun = mdl_ranger, + list(what = mdl_ranger, args = list(num.trees = 1000, max.depth = 1)), - list(fun = mdl_ranger, + list(what = 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, + learners_DX = list(list(what = mdl_glm), + list(what = mdl_xgboost, args = list(nround = 500, params = list(eta = 0.05, max_depth = 1), early_stopping_rounds = 1)), - list(fun = mdl_xgboost, + list(what = mdl_xgboost, args = list(nround = 500, params = list(eta = 0.05, max_depth = 3), early_stopping_rounds = 1)), - list(fun = mdl_ranger, + list(what = mdl_ranger, args = list(num.trees = 1000, max.depth = 1)), - list(fun = mdl_ranger, + list(what = mdl_ranger, args = list(num.trees = 1000, max.depth = 20))) # Call the general ddml_did method w/ additional hard-coded arguments diff --git a/vignettes/articles/example_401k.Rmd.txt b/vignettes/articles/example_401k.Rmd.txt index 2b8cf8a..1f5c0e0 100644 --- a/vignettes/articles/example_401k.Rmd.txt +++ b/vignettes/articles/example_401k.Rmd.txt @@ -81,17 +81,17 @@ 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, +learners <- list(list(what = ols), + list(what = mdl_glmnet), + list(what = mdl_ranger, args = list(num.trees = 250, max.depth = 4)), - list(fun = mdl_ranger, + list(what = mdl_ranger, args = list(num.trees = 250, max.depth = 12)), - list(fun = mdl_xgboost, + list(what = mdl_xgboost, args = list(nrounds = 100)), - list(fun = mdl_xgboost, + list(what = mdl_xgboost, args = list(nrounds = 300))) # PLM with short-stacking @@ -129,24 +129,24 @@ 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, + list(what = mdl_ranger, args = list(num.trees = 250, max.depth = 4), assign_X = X_baseline), - list(fun = mdl_ranger, + list(what = mdl_ranger, args = list(num.trees = 250, max.depth = 12), assign_X = X_baseline), - list(fun = mdl_xgboost, + list(what = mdl_xgboost, args = list(nrounds = 100), assign_X = X_baseline), - list(fun = mdl_xgboost, + list(what = mdl_xgboost, args = list(nrounds = 300), assign_X = X_baseline)) @@ -174,27 +174,27 @@ Equipped with the included ``mdl_glm`` wrapper for generalized linear models (se ```{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, + list(what = mdl_ranger, args = list(num.trees = 250, max.depth = 4), assign_X = X_baseline), - list(fun = mdl_ranger, + list(what = mdl_ranger, args = list(num.trees = 250, max.depth = 12), assign_X = X_baseline), - list(fun = mdl_xgboost, + list(what = mdl_xgboost, args = list(nrounds = 100), assign_X = X_baseline), - list(fun = mdl_xgboost, + list(what = mdl_xgboost, args = list(nrounds = 300), assign_X = X_baseline)) diff --git a/vignettes/articles/example_BLP95.Rmd.txt b/vignettes/articles/example_BLP95.Rmd.txt index 0429eec..256491e 100644 --- a/vignettes/articles/example_BLP95.Rmd.txt +++ b/vignettes/articles/example_BLP95.Rmd.txt @@ -156,26 +156,26 @@ 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 + list(what = mdl_ranger, # random forests with the baseline set args = list(num.trees = 1000, min.node.size = 10), assign_X = set_X, assign_Z = set_Z), - list(fun = mdl_xgboost, # boosted trees with the baseline set + list(what = mdl_xgboost, # boosted trees with the baseline set args = list(nrounds = 300), assign_X = set_X, assign_Z = set_Z)) @@ -256,8 +256,8 @@ From the stacking weights above, we know that the double/debaised machine learni ```{r} # Base learner -learner <- list(list(fun = ols), - list(fun = mdl_xgboost, +learner <- list(list(what = ols), + list(what = mdl_xgboost, args = list(nrounds = 300))) # Compute short-stacked IV estimate diff --git a/vignettes/articles/sparse.Rmd.txt b/vignettes/articles/sparse.Rmd.txt index 7828e09..9d91470 100644 --- a/vignettes/articles/sparse.Rmd.txt +++ b/vignettes/articles/sparse.Rmd.txt @@ -68,16 +68,16 @@ 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 = TRUE, @@ -89,16 +89,16 @@ 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 = TRUE, @@ -114,24 +114,24 @@ 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 = TRUE, diff --git a/vignettes/articles/stacking.Rmd.txt b/vignettes/articles/stacking.Rmd.txt index 88840b4..82e75f6 100644 --- a/vignettes/articles/stacking.Rmd.txt +++ b/vignettes/articles/stacking.Rmd.txt @@ -57,9 +57,9 @@ time_singlelearner <- 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', @@ -70,9 +70,9 @@ time_shortstacking <- 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', diff --git a/vignettes/ddml.Rmd.txt b/vignettes/ddml.Rmd.txt index 043b75f..d8266bd 100644 --- a/vignettes/ddml.Rmd.txt +++ b/vignettes/ddml.Rmd.txt @@ -76,9 +76,9 @@ 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))) ``` From f32f1e8549e0d2dc4d08dd76da897f8617f9e122 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Sat, 28 Feb 2026 21:15:57 -0500 Subject: [PATCH 09/46] cross-fitted predictions pass-through --- R/crosspred.R | 109 +++++++++-------- R/ddml_ate.R | 77 ++++++++---- R/ddml_att.R | 52 +++++--- R/ddml_fpliv.R | 79 ++++++------ R/ddml_late.R | 83 ++++++++----- R/ddml_pliv.R | 80 ++++++------ R/ddml_plm.R | 102 ++++++++++------ R/diagnostics.R | 2 +- R/ensemble.R | 31 +---- R/get_CEF.R | 24 +++- R/help_functions.R | 202 ++++++++++++++++++++++++++++++- R/shortstacking.R | 15 ++- man/crosspred.Rd | 29 ++--- man/crossval.Rd | 6 +- man/ddml_ate.Rd | 58 ++++----- man/ddml_fpliv.Rd | 35 ++++-- man/ddml_late.Rd | 48 ++++---- man/ddml_pliv.Rd | 41 +++++-- man/ddml_plm.Rd | 64 +++++++--- man/ensemble.Rd | 18 ++- man/ensemble_weights.Rd | 14 ++- man/shortstacking.Rd | 8 +- tests/testthat/test-ddml_ate.R | 81 +++++++++++++ tests/testthat/test-ddml_att.R | 35 ++++++ tests/testthat/test-ddml_fpliv.R | 49 ++++++++ tests/testthat/test-ddml_late.R | 37 ++++++ tests/testthat/test-ddml_pliv.R | 35 ++++++ tests/testthat/test-ddml_plm.R | 123 ++++++++++++++++--- 28 files changed, 1137 insertions(+), 400 deletions(-) diff --git a/R/crosspred.R b/R/crosspred.R index a2ee40a..4cdb46d 100644 --- a/R/crosspred.R +++ b/R/crosspred.R @@ -54,9 +54,6 @@ #' 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). #' @param subsamples List of vectors with sample indices for cross-fitting. #' @param cv_subsamples List of lists, each corresponding to a subsample #' containing vectors with subsample indices for cross-validation. @@ -90,18 +87,15 @@ #' a list of matrices with in-sample predictions by sample fold.} #' \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 = TRUE}, a matrix of -#' out-of-sample predictions, each column corresponding to a base -#' learner (in chronological order).} +#' \item{\code{crossfit_fitted}}{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 = TRUE} and -#' \code{compute_predictions_bylearner = TRUE}, a list of matrices -#' with in-sample predictions by sample fold.} +#' \code{compute_insample_predictions = TRUE}, a list of matrices +#' with in-sample predictions by sample fold (per learner).} #' \item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} -#' is not \code{NULL} and -#' \code{compute_predictions_bylearner = TRUE}, a list of -#' matrices with additional predictions for each learner.} +#' is not \code{NULL}, a list of matrices with additional +#' predictions for each learner.} #' } #' @export #' @@ -127,12 +121,11 @@ #' 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$crossfit_fitted) # = length(y) by length(learners) crosspred <- function(y, X, Z = NULL, learners, sample_folds = 10, @@ -140,7 +133,6 @@ crosspred <- function(y, X, Z = NULL, 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, @@ -200,7 +192,6 @@ crosspred <- function(y, X, Z = NULL, calc_ensemble = calc_ensemble, nensb = nensb, nlearners = nlearners, compute_insample_predictions = compute_insample_predictions, - compute_predictions_bylearner = compute_predictions_bylearner, auxiliary_X = auxiliary_X) }#FOLD_FUN @@ -230,7 +221,7 @@ crosspred <- function(y, X, Z = NULL, # Assemble results from fold_results list oos_fitted <- matrix(0, nobs, nensb^(calc_ensemble)) - oos_fitted_bylearner <- matrix(0, nobs, nlearners) + crossfit_fitted <- matrix(0, nobs, nlearners) is_fitted <- rep(list(NULL), sample_folds) is_fitted_bylearner <- rep(list(NULL), sample_folds) auxiliary_fitted <- rep(list(NULL), sample_folds) @@ -241,18 +232,18 @@ crosspred <- function(y, X, Z = NULL, paste("sample fold ", seq_len(sample_folds)) weights <- array(0, dim = c(nlearners, nensb, sample_folds)) + crossval_resid <- rep(list(NULL), sample_folds) for (res in fold_results) { k <- res$k oos_fitted[res$oos_indices, ] <- res$oos_fitted_rows if (!is.null(res$weights_k)) weights[, , k] <- res$weights_k if (!is.null(res$mspe_k)) mspe[, k] <- res$mspe_k if (!is.null(res$r2_k)) r2[, k] <- res$r2_k + crossval_resid[[k]] <- res$crossval_resid_k is_fitted[[k]] <- res$is_fitted_k auxiliary_fitted[[k]] <- res$auxiliary_fitted_k - if (!is.null(res$oos_fitted_bylearner_rows)) { - oos_fitted_bylearner[res$oos_indices, ] <- - res$oos_fitted_bylearner_rows - }#IF + crossfit_fitted[res$oos_indices, ] <- + res$crossfit_fitted_rows is_fitted_bylearner[[k]] <- res$is_fitted_bylearner_k auxiliary_fitted_bylearner[[k]] <- res$auxiliary_fitted_bylearner_k }#FOR @@ -277,20 +268,21 @@ crosspred <- function(y, X, Z = NULL, is_fitted <- new_is_fitted }#IF # Compute per-learner OOS residuals (not computed for FPLIV w/ LIE...) - oos_resid_bylearner <- if (is.numeric(y) && !is.list(y)) { - drop(y) - oos_fitted_bylearner + crossfit_resid <- if (is.numeric(y) && !is.list(y)) { + drop(y) - crossfit_fitted } else { NULL }#IFELSE # Organize and return output - if (!calc_ensemble) weights <- mspe <- r2 <- NULL + if (!calc_ensemble) weights <- mspe <- r2 <- crossval_resid <- NULL output <- list(oos_fitted = oos_fitted, weights = weights, mspe = mspe, r2 = r2, + crossval_resid = crossval_resid, is_fitted = is_fitted, auxiliary_fitted = auxiliary_fitted, - oos_fitted_bylearner = oos_fitted_bylearner, - oos_resid_bylearner = oos_resid_bylearner, + crossfit_fitted = crossfit_fitted, + crossfit_resid = crossfit_resid, is_fitted_bylearner = is_fitted_bylearner, auxiliary_fitted_bylearner = auxiliary_fitted_bylearner) return(output) @@ -300,7 +292,7 @@ crosspred_compute_fold <- function( k, y, X, Z, learners, subsamples, cv_subsamples_k, ensemble_type, cv_folds, custom_ensemble_weights, calc_ensemble, nensb, nlearners, - compute_insample_predictions, compute_predictions_bylearner, + compute_insample_predictions, auxiliary_X) { test_idx <- subsamples[[k]] @@ -339,13 +331,21 @@ crosspred_compute_fold <- function( # Ensemble metadata weights_k <- if (calc_ensemble) mdl_fit$weights else NULL - mspe_k <- if (calc_ensemble && !is.null(mdl_fit$cv_res)) { - mdl_fit$cv_res$mspe + mspe_k <- if (calc_ensemble && + !is.null(mdl_fit$cv_results)) { + mdl_fit$cv_results$mspe + } else { + NULL + } + r2_k <- if (calc_ensemble && + !is.null(mdl_fit$cv_results)) { + mdl_fit$cv_results$r2 } else { NULL } - r2_k <- if (calc_ensemble && !is.null(mdl_fit$cv_res)) { - mdl_fit$cv_res$r2 + crossval_resid_k <- if (calc_ensemble && + !is.null(mdl_fit$cv_results)) { + mdl_fit$cv_results$oos_resid } else { NULL } @@ -375,27 +375,39 @@ crosspred_compute_fold <- function( auxiliary_fitted_k <- stats::predict(mdl_fit, auxiliary_X[[k]]) }#IF - # By-learner predictions (optional) - oos_fitted_bylearner_rows <- NULL + # By-learner predictions is_fitted_bylearner_k <- NULL auxiliary_fitted_bylearner_k <- NULL - if (compute_predictions_bylearner) { - mdl_fit$weights <- diag(1, nlearners) - oos_fitted_bylearner_rows <- - as.numeric(predict.ensemble(mdl_fit, - newdata = X[test_idx, , drop = FALSE], - newZ = Z[test_idx, , drop = FALSE])) + if (!calc_ensemble) { + crossfit_fitted_rows <- matrix(oos_fitted_rows, ncol = 1) if (compute_insample_predictions) { - is_fitted_bylearner_k <- - predict.ensemble(mdl_fit, - newdata = X[train_idx, , drop = FALSE], - newZ = Z[train_idx, , drop = FALSE]) + is_fitted_bylearner_k <- matrix(is_fitted_k, ncol = 1) }#IF if (!is.null(auxiliary_X)) { - auxiliary_fitted_bylearner_k <- - stats::predict(mdl_fit, auxiliary_X[[k]]) + auxiliary_fitted_bylearner_k <- matrix(auxiliary_fitted_k, ncol = 1) }#IF - }#IF + } else { + mdl_fit_bylearner <- mdl_fit + mdl_fit_bylearner$weights <- diag(1, nlearners) + crossfit_fitted_rows <- predict.ensemble( + mdl_fit_bylearner, + newdata = X[test_idx, , drop = FALSE], + newZ = Z[test_idx, , drop = FALSE] + ) + if (compute_insample_predictions) { + is_fitted_bylearner_k <- predict.ensemble( + mdl_fit_bylearner, + newdata = X[train_idx, , drop = FALSE], + newZ = Z[train_idx, , drop = FALSE] + ) + }#IF + if (!is.null(auxiliary_X)) { + auxiliary_fitted_bylearner_k <- stats::predict( + mdl_fit_bylearner, + auxiliary_X[[k]] + ) + }#IF + }#IFELSE list( k = k, @@ -404,10 +416,11 @@ crosspred_compute_fold <- function( weights_k = weights_k, mspe_k = mspe_k, r2_k = r2_k, + crossval_resid_k = crossval_resid_k, weight_colnames = weight_colnames, is_fitted_k = is_fitted_k, auxiliary_fitted_k = auxiliary_fitted_k, - oos_fitted_bylearner_rows = oos_fitted_bylearner_rows, + crossfit_fitted_rows = crossfit_fitted_rows, is_fitted_bylearner_k = is_fitted_bylearner_k, auxiliary_fitted_bylearner_k = auxiliary_fitted_bylearner_k ) diff --git a/R/ddml_ate.R b/R/ddml_ate.R index 7ff11c1..c09c10f 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -29,13 +29,14 @@ #' #' @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 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 ... Deprecated arguments (\code{subsamples}, +#' \code{subsamples_byD}, \code{cv_subsamples}, +#' \code{cv_subsamples_byD}) are still accepted for backward +#' compatibility but should be replaced with \code{splits}. #' @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 @@ -52,6 +53,12 @@ #' 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 via \code{fit$fitted}. See +#' \code{\link{ddml_plm}} for details and an example. +#' @param save_crossval Logical; store inner cross-validation +#' residuals for exact weight recomputation on pass-through. +#' See \code{\link{ddml_plm}} for details. #' #' @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 @@ -125,13 +132,13 @@ ddml_ate <- function(y, D, X, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), stratify = TRUE, - subsamples = NULL, - subsamples_byD = NULL, - cv_subsamples = NULL, - cv_subsamples_byD = NULL, trim = 0.01, silent = FALSE, - parallel = NULL) { + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ...) { # Validate inputs validate_inputs(y = y, D = D, X = X, learners = learners, sample_folds = sample_folds, cv_folds = cv_folds, @@ -149,15 +156,20 @@ ddml_ate <- function(y, D, X, any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & (class(learners[[1]]) != "function") + # Normalize deprecated split arguments into a single splits object + splits <- normalize_splits( + splits = splits, by_label = "D", ...) + validate_fitted_splits_pair(fitted, splits, w_cv) + # Create crossfitting and cv tuples indxs <- get_sample_splits(cluster_variable = cluster_variable, sample_folds = sample_folds, cv_folds = if (w_cv) cv_folds, D = D, stratify = stratify, - subsamples = subsamples, - subsamples_byD = subsamples_byD, - cv_subsamples = cv_subsamples, - cv_subsamples_byD = cv_subsamples_byD) + subsamples = splits$subsamples, + subsamples_byD = splits$subsamples_byD, + cv_subsamples = splits$cv_subsamples, + cv_subsamples_byD = splits$cv_subsamples_byD) check_subsamples(indxs$subsamples, indxs$subsamples_byD, stratify, D) @@ -181,7 +193,8 @@ ddml_ate <- function(y, D, X, cv_subsamples = indxs$cv_subsamples_byD[[1]], silent = silent, label = "E[Y|D=0,X]", auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X), - parallel = parallel) + parallel = parallel, + fitted = fitted$y_X_D0) # Compute estimates of E[y|D=1,X] y_X_D1_res <- get_CEF(y[-is_D0], X[-is_D0, , drop = FALSE], @@ -192,7 +205,8 @@ ddml_ate <- function(y, D, X, cv_subsamples = indxs$cv_subsamples_byD[[2]], silent = silent, label = "E[Y|D=1,X]", auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X), - parallel = parallel) + parallel = parallel, + fitted = fitted$y_X_D1) # Compute estimates of E[D|X] D_X_res <- get_CEF(D, X, @@ -202,7 +216,8 @@ ddml_ate <- function(y, D, X, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, silent = silent, label = "E[D|X]", - parallel = parallel) + parallel = parallel, + fitted = fitted$D_X) # Update ensemble type to account for (optional) custom weights ensb_info <- update_ensemble_info(y_X_D0_res$weights) @@ -262,14 +277,24 @@ ddml_ate <- function(y, D, X, y_X_D1 = y_X_D1_res$r2, D_X = D_X_res$r2) - # Predictions and per-learner residuals + # Predictions oos_pred <- list(EY_D0_X = g_X_byD[, , 1], EY_D1_X = g_X_byD[, , 2], ED_X = m_X) - oos_resid_bylearner <- list( - y_X_D0 = y_X_D0_res$oos_resid_bylearner, - y_X_D1 = y_X_D1_res$oos_resid_bylearner, - D_X = D_X_res$oos_resid_bylearner) + + fitted_export <- list( + y_X_D0 = build_fitted_entry(y_X_D0_res, save_crossval, + include_auxiliary = TRUE), + y_X_D1 = build_fitted_entry(y_X_D1_res, save_crossval, + include_auxiliary = TRUE), + D_X = build_fitted_entry(D_X_res, save_crossval) + ) + splits_export <- list( + subsamples = indxs$subsamples, + subsamples_byD = indxs$subsamples_byD, + cv_subsamples = indxs$cv_subsamples, + cv_subsamples_byD = indxs$cv_subsamples_byD + ) # Organize output ddml_fit <- list(ate = ate, weights = weights, mspe = mspe, @@ -291,8 +316,8 @@ ddml_ate <- function(y, D, X, cv_folds = if (shortstack) NULL else cv_folds, shortstack = shortstack, - oos_resid_bylearner = - oos_resid_bylearner, + fitted = fitted_export, + splits = splits_export, r2 = r2) # Print estimation completion diff --git a/R/ddml_att.R b/R/ddml_att.R index 910bd86..26e3e09 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -12,13 +12,13 @@ ddml_att <- function(y, D, X, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), stratify = TRUE, - subsamples = NULL, - subsamples_byD = NULL, - cv_subsamples = NULL, - cv_subsamples_byD = NULL, trim = 0.01, silent = FALSE, - parallel = NULL) { + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ...) { # Validate inputs validate_inputs(y = y, D = D, X = X, learners = learners, sample_folds = sample_folds, cv_folds = cv_folds, @@ -36,15 +36,20 @@ ddml_att <- function(y, D, X, any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & (class(learners[[1]]) != "function") + # Normalize deprecated split arguments into a single splits object + splits <- normalize_splits( + splits = splits, by_label = "D", ...) + validate_fitted_splits_pair(fitted, splits, w_cv) + # Create crossfitting and cv tuples indxs <- get_sample_splits(cluster_variable = cluster_variable, sample_folds = sample_folds, cv_folds = if (w_cv) cv_folds, D = D, stratify = stratify, - subsamples = subsamples, - subsamples_byD = subsamples_byD, - cv_subsamples = cv_subsamples, - cv_subsamples_byD = cv_subsamples_byD) + subsamples = splits$subsamples, + subsamples_byD = splits$subsamples_byD, + cv_subsamples = splits$cv_subsamples, + cv_subsamples_byD = splits$cv_subsamples_byD) check_subsamples(indxs$subsamples, indxs$subsamples_byD, stratify, D) @@ -68,7 +73,8 @@ ddml_att <- function(y, D, X, cv_subsamples = indxs$cv_subsamples_byD[[1]], silent = silent, label = "E[Y|D=0,X]", auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X), - parallel = parallel) + parallel = parallel, + fitted = fitted$y_X_D0) # Compute estimates of E[D|X] D_X_res <- get_CEF(D, X, @@ -78,7 +84,8 @@ ddml_att <- function(y, D, X, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, silent = silent, label = "E[D|X]", - parallel = parallel) + parallel = parallel, + fitted = fitted$D_X) # Compute estimates of E[D] -- simple computation of averages here D_res <- get_CEF(D, matrix(1, nobs, 1), @@ -98,7 +105,7 @@ ddml_att <- function(y, D, X, multiple_ensembles <- ensb_info$multiple_ensembles # Construct reduced form variables - g_X_D0<- extrapolate_CEF(D = D, + 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$oos_fitted @@ -146,13 +153,22 @@ ddml_att <- function(y, D, X, r2 <- list(y_X_D0 = y_X_D0_res$r2, D_X = D_X_res$r2) - # Predictions and per-learner residuals + # Predictions oos_pred <- list(EY_D0_X = g_X_D0, ED_X = m_X, ED = D_res$oos_fitted) - oos_resid_bylearner <- list( - y_X_D0 = y_X_D0_res$oos_resid_bylearner, - D_X = D_X_res$oos_resid_bylearner) + + fitted_export <- 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) + ) + splits_export <- list( + subsamples = indxs$subsamples, + subsamples_byD = indxs$subsamples_byD, + cv_subsamples = indxs$cv_subsamples, + cv_subsamples_byD = indxs$cv_subsamples_byD + ) # Organize output ddml_fit <- list(att = att, weights = weights, mspe = mspe, @@ -174,8 +190,8 @@ ddml_att <- function(y, D, X, cv_folds = if (shortstack) NULL else cv_folds, shortstack = shortstack, - oos_resid_bylearner = - oos_resid_bylearner, + fitted = fitted_export, + splits = splits_export, r2 = r2) # Print estimation completion diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index b5519ed..c69e4ea 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -30,6 +30,13 @@ #' 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. +#' @param fitted An optional named list of per-equation cross-fitted +#' predictions, typically obtained via \code{fit$fitted}. Not +#' supported when \code{enforce_LIE = TRUE}. See +#' \code{\link{ddml_plm}} for details. +#' @param save_crossval Logical; store inner cross-validation +#' residuals for exact weight recomputation on pass-through. +#' See \code{\link{ddml_plm}} for details. #' #' @return \code{ddml_fpliv} returns an object of S3 class #' \code{ddml_fpliv}. An object of class \code{ddml_fpliv} is a list @@ -90,11 +97,12 @@ ddml_fpliv <- function(y, D, Z, X, custom_ensemble_weights_DXZ = custom_ensemble_weights, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples = NULL, - cv_subsamples = NULL, - cv_subsamples_list = NULL, silent = FALSE, - parallel = NULL) { + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ...) { # Validate inputs validate_inputs(y = y, D = D, X = X, Z = Z, learners = learners, sample_folds = sample_folds, cv_folds = cv_folds, @@ -103,12 +111,9 @@ ddml_fpliv <- function(y, D, Z, X, validate_custom_weights(custom_ensemble_weights_DXZ, learners_DXZ) validate_custom_weights(custom_ensemble_weights_DX, learners_DX) - # 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.") - message("Note: cv_subsamples_list has been renamed to cv_subsamples.") - cv_subsamples <- cv_subsamples_list + if (!is.null(fitted) && enforce_LIE) { + stop(paste("Pass-through via the 'fitted' argument is not", + "currently supported when enforce_LIE = TRUE.")) }#IF # Data parameters @@ -124,12 +129,16 @@ ddml_fpliv <- function(y, D, Z, X, any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & (class(learners[[1]]) != "function") + # Normalize deprecated split arguments into a single splits object + splits <- normalize_splits(splits = splits, ...) + validate_fitted_splits_pair(fitted, splits, w_cv) + # Create crossfitting and cv tuples indxs <- get_sample_splits(cluster_variable = cluster_variable, sample_folds = sample_folds, cv_folds = if (w_cv) cv_folds, - subsamples = subsamples, - cv_subsamples = cv_subsamples) + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples) check_subsamples(indxs$subsamples, NULL, stratify = FALSE) # Estimation start @@ -152,7 +161,8 @@ ddml_fpliv <- function(y, D, Z, X, cv_subsamples = indxs$cv_subsamples, compute_insample_predictions = FALSE, silent = silent, label = "E[Y|X]", - parallel = parallel) + parallel = parallel, + fitted = fitted$y_X) # Compute estimates of E[D|X,Z]. Also calculate in-sample predictions when # the LIE is enforced. @@ -166,7 +176,8 @@ ddml_fpliv <- function(y, D, Z, X, compute_insample_predictions = enforce_LIE, silent = silent, label_prefix = "E[D", label_suffix = "|X,Z]", - parallel = parallel) + parallel = parallel, + fitted = fitted$D_XZ) # When the LIE is not enforced, estimating E[D|X] is straightforward. if (!enforce_LIE) { @@ -297,10 +308,8 @@ ddml_fpliv <- function(y, D, Z, X, 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 = FALSE] - }#IFELSE - - - }#FOR + }#IFELSE + }#FOR }#IF # Residualize @@ -338,13 +347,11 @@ ddml_fpliv <- function(y, D, Z, X, coef_names <- rownames(coef) }#IF - # Ensemble metrics and per-learner residuals + # Ensemble metrics weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) r2 <- list(y_X = y_X_res$r2) - oos_resid_bylearner <- list( - y_X = y_X_res$oos_resid_bylearner) - for (k in seq_len(nD)){ + for (k in seq_len(nD)) { if (enforce_LIE & multiple_ensembles) { weights[[paste0("D", k, "_X")]] <- weights_DX[[k]] } else { @@ -352,17 +359,20 @@ ddml_fpliv <- function(y, D, Z, X, D_X_res_list[[k]]$weights }#IFELSE }#FOR - for (k in seq_len(nD)){ - weights[[paste0("D", k, "_XZ")]] <- - D_XZ_res_list[[k]]$weights - mspe[[paste0("D", k, "_XZ")]] <- - D_XZ_res_list[[k]]$mspe - r2[[paste0("D", k, "_XZ")]] <- - D_XZ_res_list[[k]]$r2 - oos_resid_bylearner[[paste0("D", k, "_XZ")]] <- - D_XZ_res_list[[k]]$oos_resid_bylearner + for (k in seq_len(nD)) { + eq <- paste0("D", k, "_XZ") + 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 + fitted_export <- list( + y_X = build_fitted_entry(y_X_res, save_crossval), + D_XZ = build_fitted_from_list(D_XZ_res_list, save_crossval) + ) + splits_export <- list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples) + # Organize output ddml_fit <- list(coef = coef, weights = weights, mspe = mspe, learners = learners, @@ -370,7 +380,7 @@ ddml_fpliv <- function(y, D, Z, X, learners_DX = learners_DX, iv_fit = iv_fit, cluster_variable = cluster_variable, - subsamples = subsamples, + subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, ensemble_type = ensemble_type, enforce_LIE = enforce_LIE, @@ -383,8 +393,8 @@ ddml_fpliv <- function(y, D, Z, X, cv_folds = if (shortstack) NULL else cv_folds, shortstack = shortstack, - oos_resid_bylearner = - oos_resid_bylearner, + fitted = fitted_export, + splits = splits_export, r2 = r2) # Print estimation completion @@ -396,4 +406,3 @@ ddml_fpliv <- function(y, D, Z, X, class(ddml_fit) <- c("ddml_fpliv", "ddml") return(ddml_fit) }#DDML_FPLIV - diff --git a/R/ddml_late.R b/R/ddml_late.R index c462ebb..9a52ed6 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -65,13 +65,14 @@ #' \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 ... Deprecated arguments (\code{subsamples}, +#' \code{subsamples_byZ}, \code{cv_subsamples}, +#' \code{cv_subsamples_byZ}) are still accepted for backward +#' compatibility but should be replaced with \code{splits}. #' #' @return \code{ddml_late} returns an object of S3 class #' \code{ddml_late}. An object of class \code{ddml_late} is a list @@ -154,13 +155,13 @@ ddml_late <- function(y, D, Z, X, custom_ensemble_weights_ZX = custom_ensemble_weights, cluster_variable = seq_along(y), stratify = TRUE, - subsamples = NULL, - subsamples_byZ = NULL, - cv_subsamples = NULL, - cv_subsamples_byZ = NULL, trim = 0.01, silent = FALSE, - parallel = NULL) { + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ...) { # Validate inputs validate_inputs(y = y, D = D, X = X, Z = Z, learners = learners, sample_folds = sample_folds, cv_folds = cv_folds, @@ -179,15 +180,20 @@ ddml_late <- function(y, D, Z, X, any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & (class(learners[[1]]) != "function") + # Normalize deprecated split arguments into a single splits object + splits <- normalize_splits( + splits = splits, by_label = "Z", ...) + validate_fitted_splits_pair(fitted, splits, w_cv) + # Create crossfitting and cv tuples indxs <- get_sample_splits(cluster_variable = cluster_variable, sample_folds = sample_folds, cv_folds = if (w_cv) cv_folds, D = Z, stratify = stratify, - subsamples = subsamples, - subsamples_byD = subsamples_byZ, - cv_subsamples = cv_subsamples, - cv_subsamples_byD = cv_subsamples_byZ) + subsamples = splits$subsamples, + subsamples_byD = splits$subsamples_byZ, + cv_subsamples = splits$cv_subsamples, + cv_subsamples_byD = splits$cv_subsamples_byZ) check_subsamples(indxs$subsamples, indxs$subsamples_byD, stratify, Z) @@ -211,7 +217,8 @@ ddml_late <- function(y, D, Z, X, cv_subsamples = indxs$cv_subsamples_byD[[1]], silent = silent, label = "E[Y|Z=0,X]", auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X), - parallel = parallel) + parallel = parallel, + fitted = fitted$y_X_Z0) # Compute estimates of E[y|Z=1,X] y_X_Z1_res <- get_CEF(y[-is_Z0], X[-is_Z0, , drop = FALSE], @@ -222,7 +229,8 @@ ddml_late <- function(y, D, Z, X, cv_subsamples = indxs$cv_subsamples_byD[[2]], silent = silent, label = "E[Y|Z=1,X]", auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X), - parallel = parallel) + parallel = parallel, + fitted = fitted$y_X_Z1) # Check for perfect non-compliance if (all(D[Z==0] == 0)) { @@ -243,7 +251,8 @@ ddml_late <- function(y, D, Z, X, cv_subsamples = indxs$cv_subsamples_byD[[1]], silent = silent, label = "E[D|Z=0,X]", auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X), - parallel = parallel) + parallel = parallel, + fitted = fitted$D_X_Z0) }#IFELSE # Check for perfect compliance @@ -265,7 +274,8 @@ ddml_late <- function(y, D, Z, X, cv_subsamples = indxs$cv_subsamples_byD[[2]], silent = silent, label = "E[D|Z=1,X]", auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X), - parallel = parallel) + parallel = parallel, + fitted = fitted$D_X_Z1) }#IFELSE # Compute estimates of E[Z|X] @@ -277,7 +287,8 @@ ddml_late <- function(y, D, Z, X, cv_subsamples = indxs$cv_subsamples, compute_insample_predictions = FALSE, silent = silent, label = "E[Z|X]", - parallel = parallel) + parallel = parallel, + fitted = fitted$Z_X) # Update ensemble type to account for (optional) custom weights ensb_info <- update_ensemble_info(y_X_Z0_res$weights) @@ -354,18 +365,30 @@ ddml_late <- function(y, D, Z, X, D_X_Z1 = D_X_Z1_res$r2, Z_X = Z_X_res$r2) - # Predictions and per-learner residuals + # Predictions 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) - oos_resid_bylearner <- list( - y_X_Z0 = y_X_Z0_res$oos_resid_bylearner, - y_X_Z1 = y_X_Z1_res$oos_resid_bylearner, - D_X_Z0 = D_X_Z0_res$oos_resid_bylearner, - D_X_Z1 = D_X_Z1_res$oos_resid_bylearner, - Z_X = Z_X_res$oos_resid_bylearner) + + fitted_export <- list( + y_X_Z0 = build_fitted_entry(y_X_Z0_res, save_crossval, + include_auxiliary = TRUE), + y_X_Z1 = build_fitted_entry(y_X_Z1_res, save_crossval, + include_auxiliary = TRUE), + D_X_Z0 = build_fitted_entry(D_X_Z0_res, save_crossval, + include_auxiliary = TRUE), + D_X_Z1 = build_fitted_entry(D_X_Z1_res, save_crossval, + include_auxiliary = TRUE), + Z_X = build_fitted_entry(Z_X_res, save_crossval) + ) + splits_export <- list( + subsamples = indxs$subsamples, + subsamples_byZ = indxs$subsamples_byD, + cv_subsamples = indxs$cv_subsamples, + cv_subsamples_byZ = indxs$cv_subsamples_byD + ) # Organize output ddml_fit <- list(late = late, weights = weights, mspe = mspe, @@ -388,8 +411,8 @@ ddml_late <- function(y, D, Z, X, cv_folds = if (shortstack) NULL else cv_folds, shortstack = shortstack, - oos_resid_bylearner = - oos_resid_bylearner, + fitted = fitted_export, + splits = splits_export, r2 = r2) # Print estimation completion diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index 01ad5e3..5dd4b05 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -118,11 +118,12 @@ 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 = NULL, - cv_subsamples_list = NULL, silent = FALSE, - parallel = NULL) { + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ...) { # Validate inputs validate_inputs(y = y, D = D, X = X, Z = Z, learners = learners, sample_folds = sample_folds, cv_folds = cv_folds, @@ -131,14 +132,6 @@ ddml_pliv <- function(y, D, Z, X, validate_custom_weights(custom_ensemble_weights_DX, learners_DX) validate_custom_weights(custom_ensemble_weights_ZX, learners_ZX) - # 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.") - message("Note: cv_subsamples_list has been renamed to cv_subsamples.") - cv_subsamples <- cv_subsamples_list - }#IF - # Data parameters nobs <- length(y) @@ -155,12 +148,16 @@ ddml_pliv <- function(y, D, Z, X, any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & (class(learners[[1]]) != "function") + # Normalize deprecated split arguments into a single splits object + splits <- normalize_splits(splits = splits, ...) + validate_fitted_splits_pair(fitted, splits, w_cv) + # Create crossfitting and cv tuples indxs <- get_sample_splits(cluster_variable = cluster_variable, sample_folds = sample_folds, cv_folds = if (w_cv) cv_folds, - subsamples = subsamples, - cv_subsamples = cv_subsamples) + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples) check_subsamples(indxs$subsamples, NULL, stratify = FALSE) # Estimation start @@ -182,7 +179,8 @@ ddml_pliv <- function(y, D, Z, X, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, silent = silent, label = "E[Y|X]", - parallel = parallel) + parallel = parallel, + fitted = fitted$y_X) # Compute estimates of E[Z|X], loop through instruments Z_X_res_list <- compute_CEF_list( @@ -194,7 +192,8 @@ ddml_pliv <- function(y, D, Z, X, cv_subsamples = indxs$cv_subsamples, silent = silent, label_prefix = "E[Z", label_suffix = "|X]", - parallel = parallel) + parallel = parallel, + fitted = fitted$Z_X) # Compute estimates of E[D|X], loop through endogenous variables D_X_res_list <- compute_CEF_list( @@ -206,7 +205,8 @@ ddml_pliv <- function(y, D, Z, X, cv_subsamples = indxs$cv_subsamples, silent = silent, label_prefix = "E[D", label_suffix = "|X]", - parallel = parallel) + parallel = parallel, + fitted = fitted$D_X) # Update ensemble type to account for (optional) custom weights ensb_info <- update_ensemble_info(y_X_res$weights) @@ -276,33 +276,31 @@ ddml_pliv <- function(y, D, Z, X, coef_names <- rownames(coef) }#IF - # Ensemble metrics and per-learner residuals + # Ensemble metrics weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) r2 <- list(y_X = y_X_res$r2) - oos_resid_bylearner <- list( - y_X = y_X_res$oos_resid_bylearner) - for (k in seq_len(nD)){ - weights[[paste0("D", k, "_X")]] <- - D_X_res_list[[k]]$weights - mspe[[paste0("D", k, "_X")]] <- - D_X_res_list[[k]]$mspe - r2[[paste0("D", k, "_X")]] <- - D_X_res_list[[k]]$r2 - oos_resid_bylearner[[paste0("D", k, "_X")]] <- - D_X_res_list[[k]]$oos_resid_bylearner + for (k in seq_len(nD)) { + eq <- paste0("D", k, "_X") + 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 seq_len(nZ)){ - weights[[paste0("Z", k, "_X")]] <- - Z_X_res_list[[k]]$weights - mspe[[paste0("Z", k, "_X")]] <- - Z_X_res_list[[k]]$mspe - r2[[paste0("Z", k, "_X")]] <- - Z_X_res_list[[k]]$r2 - oos_resid_bylearner[[paste0("Z", k, "_X")]] <- - Z_X_res_list[[k]]$oos_resid_bylearner + for (k in seq_len(nZ)) { + eq <- paste0("Z", k, "_X") + 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 + fitted_export <- list( + y_X = build_fitted_entry(y_X_res, save_crossval), + D_X = build_fitted_from_list(D_X_res_list, save_crossval), + Z_X = build_fitted_from_list(Z_X_res_list, save_crossval) + ) + splits_export <- list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples) + # Organize output ddml_fit <- list(coef = coef, weights = weights, mspe = mspe, learners = learners, @@ -310,7 +308,7 @@ ddml_pliv <- function(y, D, Z, X, learners_DX = learners_DX, iv_fit = iv_fit, cluster_variable = cluster_variable, - subsamples = subsamples, + subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, ensemble_type = ensemble_type, coefficients = coef, @@ -322,8 +320,8 @@ ddml_pliv <- function(y, D, Z, X, cv_folds = if (shortstack) NULL else cv_folds, shortstack = shortstack, - oos_resid_bylearner = - oos_resid_bylearner, + fitted = fitted_export, + splits = splits_export, r2 = r2) # Print estimation completion diff --git a/R/ddml_plm.R b/R/ddml_plm.R index a5c70fa..3cf4eca 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -71,10 +71,10 @@ #' \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 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 ... Deprecated arguments (\code{subsamples}, +#' \code{cv_subsamples}, \code{cv_subsamples_list}) are still +#' accepted for backward compatibility but should be replaced +#' with the \code{splits} argument. #' @param silent Boolean to silence estimation updates. #' @param parallel An optional named list with parallel processing #' options. When \code{NULL} (the default), computation is @@ -88,6 +88,23 @@ #' 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 the example below. +#' @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. #' #' @return \code{ddml_plm} returns an object of S3 class #' \code{ddml_plm}. An object of class \code{ddml_plm} is a list containing @@ -150,6 +167,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, @@ -160,11 +194,12 @@ 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 = NULL, - cv_subsamples_list = NULL, silent = FALSE, - parallel = NULL) { + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ...) { # Validate inputs validate_inputs(y = y, D = D, X = X, learners = learners, sample_folds = sample_folds, cv_folds = cv_folds, @@ -172,14 +207,6 @@ ddml_plm <- function(y, D, X, validate_custom_weights(custom_ensemble_weights, learners) validate_custom_weights(custom_ensemble_weights_DX, learners_DX) - # 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.") - message("Note: cv_subsamples_list has been renamed to cv_subsamples.") - cv_subsamples <- cv_subsamples_list - }#IF - # Data parameters nobs <- length(y) @@ -193,12 +220,16 @@ ddml_plm <- function(y, D, X, (class(learners[[1]]) != "function" | class(learners_DX[[1]]) != "function") + # Normalize deprecated split arguments into a single splits object + splits <- normalize_splits(splits = splits, ...) + validate_fitted_splits_pair(fitted, splits, w_cv) + # Create crossfitting and cv tuples indxs <- get_sample_splits(cluster_variable = cluster_variable, sample_folds = sample_folds, cv_folds = if (w_cv) cv_folds, - subsamples = subsamples, - cv_subsamples = cv_subsamples) + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples) check_subsamples(indxs$subsamples, NULL, stratify = FALSE) # Estimation start @@ -221,7 +252,8 @@ ddml_plm <- function(y, D, X, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, silent = silent, label = "E[Y|X]", - parallel = parallel) + parallel = parallel, + fitted = fitted$y_X) # Compute estimates of E[D|X], loop through endogenous variables D_X_res_list <- compute_CEF_list( @@ -233,7 +265,8 @@ ddml_plm <- function(y, D, X, cv_subsamples = indxs$cv_subsamples, silent = silent, label_prefix = "E[D", label_suffix = "|X]", - parallel = parallel) + parallel = parallel, + fitted = fitted$D_X) # Update ensemble type to account for (optional) custom weights ensb_info <- update_ensemble_info(y_X_res$weights) @@ -299,23 +332,24 @@ ddml_plm <- function(y, D, X, coef_names <- rownames(coef) }#IF - # Ensemble metrics and per-learner residuals + # Ensemble metrics weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) r2 <- list(y_X = y_X_res$r2) - oos_resid_bylearner <- list( - y_X = y_X_res$oos_resid_bylearner) - for (k in seq_len(nD)){ - weights[[paste0("D", k, "_X")]] <- - D_X_res_list[[k]]$weights - mspe[[paste0("D", k, "_X")]] <- - D_X_res_list[[k]]$mspe - r2[[paste0("D", k, "_X")]] <- - D_X_res_list[[k]]$r2 - oos_resid_bylearner[[paste0("D", k, "_X")]] <- - D_X_res_list[[k]]$oos_resid_bylearner + for (k in seq_len(nD)) { + eq <- paste0("D", k, "_X") + 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 + fitted_export <- list( + y_X = build_fitted_entry(y_X_res, save_crossval), + D_X = build_fitted_from_list(D_X_res_list, save_crossval) + ) + splits_export <- list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples) + # Organize output ddml_fit <- list(coef = coef, weights = weights, mspe = mspe, learners = learners, @@ -334,8 +368,8 @@ ddml_plm <- function(y, D, X, cv_folds = if (shortstack) NULL else cv_folds, shortstack = shortstack, - oos_resid_bylearner = - oos_resid_bylearner, + fitted = fitted_export, + splits = splits_export, r2 = r2) # Print estimation completion diff --git a/R/diagnostics.R b/R/diagnostics.R index b66eba7..73635b3 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -109,7 +109,7 @@ diagnostics <- function(object, cvc = FALSE, # CVC p-values (opt-in) if (cvc && !single_learner) { - resid <- object$oos_resid_bylearner[[eq]] + resid <- get_crossfit_resid_for_eq(object$fitted, eq) subs <- get_diag_subsamples(object, eq) if (!is.null(resid) && !is.null(subs) && ncol(resid) > 1) { diff --git a/R/ensemble.R b/R/ensemble.R index ae97579..9af309b 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -84,16 +84,13 @@ ensemble <- function(y, X, Z = NULL, 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) { + # 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.") }#IF - # Compute fit for each included model + # Fit all base learners to keep per-learner outputs always available mdl_fits <- rep(list(NULL), nlearners) for (m in seq_len(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. if (is.null(learners[[m]]$assign_X)) learners[[m]]$assign_X <- 1:ncol(X) @@ -130,34 +127,18 @@ predict.ensemble <- function(object, newdata, newZ = NULL, ...){ 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.") - }#IF - # Calculate fitted values for each model - first_fit <- TRUE + # Calculate fitted values for each learner + fitted_mat <- matrix(0, nrow(newdata), nlearners) for (m in seq_len(nlearners)) { - # Skip model if not assigned positive weight - if (!(m %in% mdl_include)) next - # Get assign_X and assing_Z 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 <- FALSE - }#IF 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 + fitted_ens <- fitted_mat %*% object$weights return(fitted_ens) }#PREDICT.ENSEMBLE diff --git a/R/get_CEF.R b/R/get_CEF.R index 915fa3a..4cde55b 100644 --- a/R/get_CEF.R +++ b/R/get_CEF.R @@ -19,21 +19,37 @@ get_CEF <- function(y, X, Z = NULL, shortstack, custom_ensemble_weights = NULL, compute_insample_predictions = FALSE, - compute_predictions_bylearner = FALSE, subsamples, cv_subsamples, silent = FALSE, label = NULL, auxiliary_X = NULL, shortstack_y = y, - parallel = NULL) { + parallel = NULL, + fitted = NULL) { t0 <- proc.time()[3] if (!is.null(label)) { info_msg(" Estimating ", label, "...", silent = silent) }#IF - # Compute CEF + # Use pre-computed predictions if supplied + if (!is.null(fitted)) { + 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'.")) + }#IF + res <- build_CEF_from_crossfit( + y, fitted$crossfit_fitted, + ensemble_type, custom_ensemble_weights, + crossval_resid = fitted$crossval_resid, + subsamples = subsamples, + auxiliary_fitted_bylearner = fitted$auxiliary_fitted_bylearner) + return(res) + }#IF + + # Compute CEF via cross-fitting if (shortstack) { res <- shortstacking(y, X, Z, learners = learners, @@ -55,8 +71,6 @@ get_CEF <- function(y, X, Z = NULL, custom_ensemble_weights, compute_insample_predictions = compute_insample_predictions, - compute_predictions_bylearner = - compute_predictions_bylearner, subsamples = subsamples, cv_subsamples = cv_subsamples, silent = silent, diff --git a/R/help_functions.R b/R/help_functions.R index 1162745..9dd59da 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -85,6 +85,199 @@ normalize_learners <- function(learners) { learners }#NORMALIZE_LEARNERS +# Build a CEF-like result from pre-computed per-learner predictions. +# When crossval_resid + 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, crossfit_fitted_eq, + ensemble_type, + custom_ensemble_weights, + crossval_resid = NULL, + subsamples = NULL, + auxiliary_fitted_bylearner = NULL) { + nobs <- length(y) + cf <- as.matrix(crossfit_fitted_eq) + nlearners <- ncol(cf) + dummy_learners <- lapply(seq_len(nlearners), + function(i) list(what = identity)) + + # Per-learner OOS residuals, MSPE, and R-squared + oos_resid <- drop(y) - cf + mspe <- colMeans(oos_resid^2) + + if (!is.null(crossval_resid) && !is.null(crossval_resid[[1]]) && + !is.null(subsamples)) { + # Per-fold weight recomputation from inner-CV residuals + K <- length(subsamples) + nensb <- NULL + oos_fitted <- matrix(0, nobs, 1) + all_weights <- vector("list", K) + for (k in seq_len(K)) { + fakecv_k <- list( + oos_resid = crossval_resid[[k]], + mspe = colMeans(crossval_resid[[k]]^2)) + ew_k <- ensemble_weights( + y[subsamples[[k]]], cf[subsamples[[k]], ], + type = ensemble_type, + learners = dummy_learners, + cv_results = fakecv_k, + custom_weights = custom_ensemble_weights, + silent = TRUE) + all_weights[[k]] <- ew_k$weights + if (is.null(nensb)) nensb <- ncol(ew_k$weights) + if (ncol(oos_fitted) < nensb) { + oos_fitted <- matrix(0, nobs, nensb) + }#IF + oos_fitted[subsamples[[k]], ] <- cf[subsamples[[k]], ] %*% + ew_k$weights + }#FOR + weights <- array(0, dim = c(nlearners, nensb, K)) + for (k in seq_len(K)) weights[, , k] <- all_weights[[k]] + } else { + # Global weights from sample-fold residuals + fakecv <- list(oos_resid = oos_resid, + mspe = mspe) + ew <- ensemble_weights( + y, cf, type = ensemble_type, + learners = dummy_learners, + cv_results = fakecv, + custom_weights = custom_ensemble_weights, + silent = TRUE) + weights <- ew$weights + oos_fitted <- cf %*% weights + }#IFELSE + + # Fold-level auxiliary predictions (ATE/ATT/LATE extrapolation) + auxiliary_fitted <- NULL + if (!is.null(auxiliary_fitted_bylearner)) { + K <- length(auxiliary_fitted_bylearner) + auxiliary_fitted <- vector("list", K) + if (length(dim(weights)) == 3) { + for (k in seq_len(K)) { + auxiliary_fitted[[k]] <- + as.matrix(auxiliary_fitted_bylearner[[k]]) %*% + weights[, , k] + }#FOR + } else { + for (k in seq_len(K)) { + auxiliary_fitted[[k]] <- + as.matrix(auxiliary_fitted_bylearner[[k]]) %*% + weights + }#FOR + }#IFELSE + }#IF + y_var <- as.numeric(stats::var(y)) + r2 <- if (y_var > 0) 1 - mspe / y_var else + rep(NA_real_, length(mspe)) + + list(oos_fitted = oos_fitted, + weights = weights, + mspe = mspe, + r2 = r2, + auxiliary_fitted = auxiliary_fitted, + crossfit_fitted = cf, + crossfit_resid = oos_resid, + crossval_resid = crossval_resid) +}#BUILD_CEF_FROM_CROSSFIT + +validate_fitted_splits_pair <- function(fitted, splits, + w_cv = FALSE) { + if (is.null(fitted)) return(invisible(NULL)) + if (is.null(splits)) { + stop("Argument 'splits' must be supplied when 'fitted' is supplied.") + }#IF + if (is.null(splits$subsamples)) { + stop("splits must contain 'subsamples' when 'fitted' is supplied.") + }#IF + if (w_cv && is.null(splits$cv_subsamples)) { + stop(paste("splits must contain 'cv_subsamples' for data-driven", + "stacking when 'fitted' is supplied.")) + }#IF +}#VALIDATE_FITTED_SPLITS_PAIR + +build_fitted_entry <- function(res, save_crossval, + include_auxiliary = FALSE) { + entry <- list(crossfit_fitted = res$crossfit_fitted, + crossfit_resid = res$crossfit_resid) + if (save_crossval) { + entry$crossval_resid <- res$crossval_resid + }#IF + if (include_auxiliary) { + entry$auxiliary_fitted_bylearner <- + res$auxiliary_fitted_bylearner + }#IF + entry +}#BUILD_FITTED_ENTRY + +build_fitted_from_list <- function(res_list, save_crossval) { + lapply(res_list, build_fitted_entry, + save_crossval = save_crossval) +}#BUILD_FITTED_FROM_LIST + +get_crossfit_resid_for_eq <- function(fitted, eq) { + entry <- fitted[[eq]] + if (!is.null(entry) && !is.null(entry$crossfit_resid)) { + return(entry$crossfit_resid) + }#IF + m <- regmatches(eq, regexec("^([A-Za-z]+)(\\d+)(_\\w+)$", + eq))[[1]] + if (length(m) == 4) { + group <- paste0(m[2], m[4]) + idx <- as.integer(m[3]) + entry <- fitted[[group]] + if (is.list(entry) && length(entry) >= idx) { + return(entry[[idx]]$crossfit_resid) + }#IF + }#IF + NULL +}#GET_CROSSFIT_RESID_FOR_EQ + +normalize_splits <- function(splits = NULL, + by_label = NULL, ...) { + dots <- list(...) + subsamples <- dots[["subsamples"]] + cv_subsamples <- dots[["cv_subsamples"]] + # Handle cv_subsamples_list (older deprecated name) + if (!is.null(dots[["cv_subsamples_list"]])) { + if (!is.null(cv_subsamples)) + stop("Specify cv_subsamples or cv_subsamples_list, ", + "not both.") + message("Note: cv_subsamples_list has been renamed to ", + "cv_subsamples.") + cv_subsamples <- dots[["cv_subsamples_list"]] + }#IF + # Handle grouped split args (ATE/ATT/LATE) + subsamples_by <- NULL + cv_subsamples_by <- NULL + if (!is.null(by_label)) { + sub_by <- paste0("subsamples_by", by_label) + cv_sub_by <- paste0("cv_subsamples_by", by_label) + subsamples_by <- dots[[sub_by]] + cv_subsamples_by <- dots[[cv_sub_by]] + }#IF + legacy_used <- !is.null(subsamples) || !is.null(cv_subsamples) || + !is.null(subsamples_by) || !is.null(cv_subsamples_by) + if (legacy_used) { + warning("Deprecated split arguments detected. ", + "Use 'splits' instead.", call. = FALSE) + }#IF + if (is.null(splits) && !legacy_used) return(NULL) + if (is.null(splits)) splits <- list() + if (!is.list(splits)) stop("'splits' must be a list.") + if (is.null(splits$subsamples) && !is.null(subsamples)) + splits$subsamples <- subsamples + if (is.null(splits$cv_subsamples) && !is.null(cv_subsamples)) + splits$cv_subsamples <- cv_subsamples + if (!is.null(by_label)) { + if (is.null(splits[[sub_by]]) && !is.null(subsamples_by)) + splits[[sub_by]] <- subsamples_by + if (is.null(splits[[cv_sub_by]]) && + !is.null(cv_subsamples_by)) + splits[[cv_sub_by]] <- cv_subsamples_by + }#IF + splits +}#NORMALIZE_SPLITS + # 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, @@ -207,10 +400,14 @@ compute_CEF_list <- function(M, X, Z = NULL, compute_insample_predictions = FALSE, silent = FALSE, label_prefix, label_suffix, - parallel = NULL) { + parallel = NULL, + fitted = NULL) { nM <- ncol(M) res_list <- vector("list", nM) for (k in seq_len(nM)) { + fit_k <- if (!is.null(fitted)) { + fitted[[k]] + }#IF res_list[[k]] <- get_CEF( M[, k, drop = FALSE], X, Z = Z, learners = learners, @@ -223,7 +420,8 @@ compute_CEF_list <- function(M, X, Z = NULL, compute_insample_predictions, silent = silent, label = paste0(label_prefix, k, label_suffix), - parallel = parallel) + parallel = parallel, + fitted = fit_k) }#FOR res_list }#COMPUTE_CEF_LIST diff --git a/R/shortstacking.R b/R/shortstacking.R index a4a4f08..c8d80a2 100644 --- a/R/shortstacking.R +++ b/R/shortstacking.R @@ -33,7 +33,7 @@ #' a list of matrices with in-sample predictions by sample fold.} #' \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 +#' \item{\code{crossfit_fitted}}{A matrix of #' out-of-sample predictions, each column corresponding to a base #' learner (in chronological order).} #' \item{\code{is_fitted_bylearner}}{When @@ -73,7 +73,7 @@ #' 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$crossfit_fitted) # = length(y) by length(learners) shortstacking <- function(y, X, Z = NULL, learners, sample_folds = 2, @@ -112,7 +112,6 @@ shortstacking <- function(y, X, Z = NULL, ensemble_type = "average", compute_insample_predictions = compute_insample_predictions, - compute_predictions_bylearner = TRUE, subsamples = subsamples, silent = silent, auxiliary_X = auxiliary_X, @@ -121,14 +120,14 @@ shortstacking <- function(y, X, Z = NULL, # Compute ensemble weights via subsample cross-fitted residual fakecv <- list() fakecv$oos_resid <- matrix(shortstack_y, nobs, nlearners) - - res$oos_fitted_bylearner + res$crossfit_fitted weights <- ensemble_weights(shortstack_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 + oos_fitted <- res$crossfit_fitted %*% weights # Compute auxilliary predictions (optional) auxiliary_fitted <- rep(list(NULL), sample_folds) @@ -176,15 +175,15 @@ shortstacking <- function(y, X, Z = NULL, length(mspe)) # Per-learner OOS residuals (already computed for weight estimation) - oos_resid_bylearner <- as.matrix(fakecv$oos_resid) + crossfit_resid <- as.matrix(fakecv$oos_resid) # return shortstacking output output <- list(oos_fitted = oos_fitted, weights = weights, mspe = mspe, r2 = r2, is_fitted = is_fitted, auxiliary_fitted = auxiliary_fitted, - oos_fitted_bylearner = res$oos_fitted_bylearner, - oos_resid_bylearner = oos_resid_bylearner, + crossfit_fitted = res$crossfit_fitted, + crossfit_resid = crossfit_resid, is_fitted_bylearner = res$is_fitted_bylearner, auxiliary_fitted_bylearner = res$auxiliary_fitted_bylearner) return(output) diff --git a/man/crosspred.Rd b/man/crosspred.Rd index 458a575..b98b183 100644 --- a/man/crosspred.Rd +++ b/man/crosspred.Rd @@ -14,7 +14,6 @@ crosspred( 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, @@ -86,10 +85,6 @@ estimation results corresponding the custom ensemble specification.} \item{compute_insample_predictions}{Indicator equal to 1 if in-sample predictions should also be computed.} -\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.} @@ -132,18 +127,15 @@ ensemble procedures.} a list of matrices with in-sample predictions by sample fold.} \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 = TRUE}, a matrix of -out-of-sample predictions, each column corresponding to a base -learner (in chronological order).} +\item{\code{crossfit_fitted}}{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 = TRUE} and -\code{compute_predictions_bylearner = TRUE}, a list of matrices -with in-sample predictions by sample fold.} +\code{compute_insample_predictions = TRUE}, a list of matrices +with in-sample predictions by sample fold (per learner).} \item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} -is not \code{NULL} and -\code{compute_predictions_bylearner = TRUE}, a list of -matrices with additional predictions for each learner.} +is not \code{NULL}, a list of matrices with additional +predictions for each learner.} } } \description{ @@ -160,17 +152,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$crossfit_fitted) # = length(y) by length(learners) } \references{ Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and diff --git a/man/crossval.Rd b/man/crossval.Rd index 8419947..85c682e 100644 --- a/man/crossval.Rd +++ b/man/crossval.Rd @@ -87,9 +87,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) diff --git a/man/ddml_ate.Rd b/man/ddml_ate.Rd index 73df3f2..955feae 100644 --- a/man/ddml_ate.Rd +++ b/man/ddml_ate.Rd @@ -19,13 +19,13 @@ ddml_ate( custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), stratify = TRUE, - subsamples = NULL, - subsamples_byD = NULL, - cv_subsamples = NULL, - cv_subsamples_byD = NULL, trim = 0.01, silent = FALSE, - parallel = NULL + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ... ) ddml_att( @@ -42,13 +42,13 @@ ddml_att( custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), stratify = TRUE, - subsamples = NULL, - subsamples_byD = NULL, - cv_subsamples = NULL, - cv_subsamples_byD = NULL, trim = 0.01, silent = FALSE, - parallel = NULL + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ... ) } \arguments{ @@ -122,20 +122,6 @@ custom ensemble weights for \code{learners_DX}. Setup is identical to \item{stratify}{Boolean for stratified cross-fitting: if \code{TRUE}, subsamples are constructed to be balanced across treatment levels.} -\item{subsamples}{List of vectors with sample indices for cross-fitting.} - -\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}{List of lists, each corresponding to a subsample -containing vectors with subsample indices for cross-validation.} - -\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{trim}{Number in (0, 1) for trimming the estimated propensity scores at \code{trim} and \code{1-trim}.} @@ -153,6 +139,24 @@ reference global objects).} 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 via \code{fit$fitted}. See +\code{\link{ddml_plm}} for details and 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; store inner cross-validation +residuals for exact weight recomputation on pass-through. +See \code{\link{ddml_plm}} for details.} + +\item{...}{Deprecated arguments (\code{subsamples}, +\code{subsamples_byD}, \code{cv_subsamples}, +\code{cv_subsamples_byD}) are still accepted for backward +compatibility but should be replaced with \code{splits}.} } \value{ \code{ddml_ate} and \code{ddml_att} return an object of S3 class @@ -223,9 +227,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, diff --git a/man/ddml_fpliv.Rd b/man/ddml_fpliv.Rd index d46a4ae..dfa8d88 100644 --- a/man/ddml_fpliv.Rd +++ b/man/ddml_fpliv.Rd @@ -21,11 +21,12 @@ ddml_fpliv( custom_ensemble_weights_DXZ = custom_ensemble_weights, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples = NULL, - cv_subsamples = NULL, - cv_subsamples_list = NULL, silent = FALSE, - parallel = NULL + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ... ) } \arguments{ @@ -108,13 +109,6 @@ 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 of lists, each corresponding to a subsample -containing vectors with subsample indices for cross-validation.} - -\item{cv_subsamples_list}{Deprecated; use \code{cv_subsamples} instead.} - \item{silent}{Boolean to silence estimation updates.} \item{parallel}{An optional named list with parallel processing @@ -129,6 +123,25 @@ reference global objects).} 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 via \code{fit$fitted}. Not +supported when \code{enforce_LIE = TRUE}. See +\code{\link{ddml_plm}} for details.} + +\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; store inner cross-validation +residuals for exact weight recomputation on pass-through. +See \code{\link{ddml_plm}} for details.} + +\item{...}{Deprecated arguments (\code{subsamples}, +\code{cv_subsamples}, \code{cv_subsamples_list}) are still +accepted for backward compatibility but should be replaced +with the \code{splits} argument.} } \value{ \code{ddml_fpliv} returns an object of S3 class diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index 00f600b..bed7f91 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -21,13 +21,13 @@ ddml_late( custom_ensemble_weights_ZX = custom_ensemble_weights, cluster_variable = seq_along(y), stratify = TRUE, - subsamples = NULL, - subsamples_byZ = NULL, - cv_subsamples = NULL, - cv_subsamples_byZ = NULL, trim = 0.01, silent = FALSE, - parallel = NULL + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ... ) } \arguments{ @@ -110,20 +110,6 @@ have the same number of columns.} \item{stratify}{Boolean for stratified cross-fitting: if \code{TRUE}, subsamples are constructed to be balanced across treatment levels.} -\item{subsamples}{List of vectors with sample indices for cross-fitting.} - -\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}{List of lists, each corresponding to a subsample -containing vectors with subsample indices for cross-validation.} - -\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{trim}{Number in (0, 1) for trimming the estimated propensity scores at \code{trim} and \code{1-trim}.} @@ -141,6 +127,24 @@ reference global objects).} 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 via \code{fit$fitted}. See +\code{\link{ddml_plm}} for details and 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; store inner cross-validation +residuals for exact weight recomputation on pass-through. +See \code{\link{ddml_plm}} for details.} + +\item{...}{Deprecated arguments (\code{subsamples}, +\code{subsamples_byZ}, \code{cv_subsamples}, +\code{cv_subsamples_byZ}) are still accepted for backward +compatibility but should be replaced with \code{splits}.} } \value{ \code{ddml_late} returns an object of S3 class @@ -210,9 +214,9 @@ summary(late_fit) 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, diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index e161601..792e0c7 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -20,11 +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 = NULL, - cv_subsamples_list = NULL, silent = FALSE, - parallel = NULL + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ... ) } \arguments{ @@ -104,13 +105,6 @@ 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 of lists, each corresponding to a subsample -containing vectors with subsample indices for cross-validation.} - -\item{cv_subsamples_list}{Deprecated; use \code{cv_subsamples} instead.} - \item{silent}{Boolean to silence estimation updates.} \item{parallel}{An optional named list with parallel processing @@ -125,6 +119,31 @@ reference global objects).} 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 the example below.} + +\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{...}{Deprecated arguments (\code{subsamples}, +\code{cv_subsamples}, \code{cv_subsamples_list}) are still +accepted for backward compatibility but should be replaced +with the \code{splits} argument.} } \value{ \code{ddml_pliv} returns an object of S3 class diff --git a/man/ddml_plm.Rd b/man/ddml_plm.Rd index e51c88f..5763c5b 100644 --- a/man/ddml_plm.Rd +++ b/man/ddml_plm.Rd @@ -17,11 +17,12 @@ ddml_plm( custom_ensemble_weights = NULL, custom_ensemble_weights_DX = custom_ensemble_weights, cluster_variable = seq_along(y), - subsamples = NULL, - cv_subsamples = NULL, - cv_subsamples_list = NULL, silent = FALSE, - parallel = NULL + parallel = NULL, + fitted = NULL, + splits = NULL, + save_crossval = TRUE, + ... ) } \arguments{ @@ -92,13 +93,6 @@ 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 of lists, each corresponding to a subsample -containing vectors with subsample indices for cross-validation.} - -\item{cv_subsamples_list}{Deprecated; use \code{cv_subsamples} instead.} - \item{silent}{Boolean to silence estimation updates.} \item{parallel}{An optional named list with parallel processing @@ -113,6 +107,31 @@ reference global objects).} 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 the example below.} + +\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{...}{Deprecated arguments (\code{subsamples}, +\code{cv_subsamples}, \code{cv_subsamples_list}) are still +accepted for backward compatibility but should be replaced +with the \code{splits} argument.} } \value{ \code{ddml_plm} returns an object of S3 class @@ -169,9 +188,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, @@ -179,6 +198,23 @@ plm_fit <- ddml_plm(y, D, X, 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) +} } \references{ Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and diff --git a/man/ensemble.Rd b/man/ensemble.Rd index 6e90518..b162646 100644 --- a/man/ensemble.Rd +++ b/man/ensemble.Rd @@ -54,7 +54,23 @@ aggregation type and computes cross-validated out-of-sample predictions to inform the weights. } \examples{ -# Not run +\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: diff --git a/man/ensemble_weights.Rd b/man/ensemble_weights.Rd index 7ae4530..835796c 100644 --- a/man/ensemble_weights.Rd +++ b/man/ensemble_weights.Rd @@ -49,7 +49,19 @@ Computes the stacking weights for an ensemble of base learners using cross-validated out-of-sample predictions. } \examples{ -# Not run +\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: diff --git a/man/shortstacking.Rd b/man/shortstacking.Rd index 6d551e2..df32eaa 100644 --- a/man/shortstacking.Rd +++ b/man/shortstacking.Rd @@ -120,7 +120,7 @@ ensemble procedures.} a list of matrices with in-sample predictions by sample fold.} \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 +\item{\code{crossfit_fitted}}{A matrix of out-of-sample predictions, each column corresponding to a base learner (in chronological order).} \item{\code{is_fitted_bylearner}}{When @@ -148,15 +148,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$crossfit_fitted) # = length(y) by length(learners) } \references{ Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). "Model Averaging and diff --git a/tests/testthat/test-ddml_ate.R b/tests/testthat/test-ddml_ate.R index cf4ed8d..e55069b 100644 --- a/tests/testthat/test-ddml_ate.R +++ b/tests/testthat/test-ddml_ate.R @@ -217,3 +217,84 @@ test_that("summary.ddml_ate computes with multiple ensemble procedures", { expect_s3_class(inf_res, "summary.ddml") expect_equal(dim(inf_res$inf_results), 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.3 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.3 * 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 legacy grouped split args warn and still work", { + set.seed(202) + nobs <- 600 + X <- matrix(rnorm(nobs * 4), nobs, 4) + D_tld <- X %*% c(0.7, 0.2, 0.1, 0) + rnorm(nobs) + D <- 1 * (D_tld > mean(D_tld)) + y <- D + X %*% c(0.2, 0.3, 0.1, 0.4) + rnorm(nobs) + learners <- list(what = ols) + splits <- get_sample_splits( + cluster_variable = seq_len(nobs), + sample_folds = 3, + cv_folds = 3, + D = D, + stratify = TRUE + ) + fit_splits <- ddml_ate( + y, D, X, + learners = learners, + sample_folds = 3, + cv_folds = 3, + splits = list( + subsamples = splits$subsamples, + subsamples_byD = splits$subsamples_byD, + cv_subsamples = splits$cv_subsamples, + cv_subsamples_byD = splits$cv_subsamples_byD + ), + silent = TRUE + ) + expect_warning( + fit_legacy <- ddml_ate( + y, D, X, + learners = learners, + sample_folds = 3, + cv_folds = 3, + subsamples = splits$subsamples, + subsamples_byD = splits$subsamples_byD, + cv_subsamples = splits$cv_subsamples, + cv_subsamples_byD = splits$cv_subsamples_byD, + silent = TRUE + ), + "Deprecated split arguments detected" + ) + expect_equal(coef(fit_legacy), coef(fit_splits), tolerance = 1e-8) +}) diff --git a/tests/testthat/test-ddml_att.R b/tests/testthat/test-ddml_att.R index 7b0444f..1d2c78b 100644 --- a/tests/testthat/test-ddml_att.R +++ b/tests/testthat/test-ddml_att.R @@ -218,3 +218,38 @@ test_that("summary.ddml_att computes with multiple ensemble procedures", { expect_s3_class(inf_res, "summary.ddml") expect_equal(dim(inf_res$inf_results), 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.3 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.3 * 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_fpliv.R b/tests/testthat/test-ddml_fpliv.R index 3820629..22dd86a 100644 --- a/tests/testthat/test-ddml_fpliv.R +++ b/tests/testthat/test-ddml_fpliv.R @@ -378,3 +378,52 @@ test_that("ddml_fpliv computes with ensemble procedures w/o LIE, multi D", { # Check output with expectations expect_equal(length(ddml_fpliv_fit$coef), 8) })#TEST_THAT + +test_that("ddml_fpliv 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_fpliv(y, D, Z, X, + learners = learners, + ensemble_type = "average", + enforce_LIE = FALSE, + sample_folds = 2, + silent = TRUE) + + fit2 <- ddml_fpliv(y, D, Z, X, + learners = learners, + ensemble_type = "average", + enforce_LIE = FALSE, + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted, + splits = fit$splits) + expect_equal(coef(fit2), coef(fit), tolerance = 1e-6) + + # Pass-through blocked when enforce_LIE = TRUE + expect_error( + ddml_fpliv(y, D, Z, X, + learners = learners, + sample_folds = 2, + silent = TRUE, + fitted = fit$fitted, + splits = fit$splits), + "not currently supported when enforce_LIE = TRUE" + ) + + # Error when fitted supplied without splits + expect_error( + ddml_fpliv(y, D, Z, X, + learners = learners, + enforce_LIE = FALSE, + 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 6db3a81..6e419be 100644 --- a/tests/testthat/test-ddml_late.R +++ b/tests/testthat/test-ddml_late.R @@ -261,3 +261,40 @@ test_that("summary.ddml_late computes with a single model and dependence", { expect_s3_class(inf_res, "summary.ddml") expect_equal(dim(inf_res$inf_results), 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.3 * X[, 1] + rnorm(nobs) + Z <- 1 * (Z_tld > 0) + D_tld <- 0.3 * Z + 0.2 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.3 * 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 diff --git a/tests/testthat/test-ddml_pliv.R b/tests/testthat/test-ddml_pliv.R index 9ca9726..5c0807b 100644 --- a/tests/testthat/test-ddml_pliv.R +++ b/tests/testthat/test-ddml_pliv.R @@ -244,3 +244,38 @@ test_that("ddml_pliv computes with different ensembles and multivariate D,Z", { # Check output with expectations expect_equal(length(ddml_pliv_fit$coef), 10) })#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 bbe4bd1..0fcdca8 100644 --- a/tests/testthat/test-ddml_plm.R +++ b/tests/testthat/test-ddml_plm.R @@ -306,16 +306,18 @@ test_that("ddml_plm backward-compat cv_subsamples_list works with message", { splits <- get_sample_splits(seq_len(nobs), sample_folds = 3, cv_folds = 3) learners <- list(list(what = ols), list(what = ols)) - # Call with deprecated cv_subsamples_list — should emit message - expect_message( - ddml_plm(y, D, X, - learners = learners, - ensemble_type = "ols", - sample_folds = 3, - subsamples = splits$subsamples, - cv_subsamples_list = splits$cv_subsamples, - silent = TRUE), - "cv_subsamples_list has been renamed") + # Call with deprecated cv_subsamples_list — should emit message + warning + expect_warning( + expect_message( + ddml_plm(y, D, X, + learners = learners, + ensemble_type = "ols", + sample_folds = 3, + splits = list(subsamples = splits$subsamples), + cv_subsamples_list = splits$cv_subsamples, + silent = TRUE), + "cv_subsamples_list has been renamed"), + "Deprecated split arguments detected") })#TEST_THAT test_that("ddml_plm computes with parallel", { @@ -332,14 +334,107 @@ test_that("ddml_plm computes with parallel", { res_seq <- ddml_plm(y, D, X, learners = learners, sample_folds = 3, - subsamples = splits$subsamples, - silent = T) + splits = list(subsamples = splits$subsamples), + silent = TRUE) # Parallel res_par <- ddml_plm(y, D, X, learners = learners, sample_folds = 3, - subsamples = splits$subsamples, - silent = T, + splits = list(subsamples = splits$subsamples), + silent = TRUE, parallel = list(cores = 2)) expect_equal(res_par$coef, res_seq$coef) })#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( + 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$crossfit_fitted)) + expect_true(!is.null(fit$fitted$y_X$crossfit_resid)) + + # 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 legacy split args warn and still work", { + set.seed(101) + nobs <- 200 + X <- matrix(rnorm(nobs * 4), nobs, 4) + D <- X %*% c(1, 0.5, 0.2, 0) + rnorm(nobs) + y <- D + X %*% c(0.3, 0.1, 0.4, 0.2) + rnorm(nobs) + learners <- list(what = ols) + splits <- get_sample_splits(seq_len(nobs), + sample_folds = 3, + cv_folds = 3) + fit_splits <- ddml_plm( + y, D, X, + learners = learners, + sample_folds = 3, + cv_folds = 3, + splits = list( + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples + ), + silent = TRUE + ) + expect_warning( + fit_legacy <- ddml_plm( + y, D, X, + learners = learners, + sample_folds = 3, + cv_folds = 3, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples, + silent = TRUE + ), + "Deprecated split arguments detected" + ) + expect_equal(coef(fit_legacy), coef(fit_splits), tolerance = 1e-8) +}) From f6bc32f10e91f3e64e15af22586c407265bf6169 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Sat, 28 Feb 2026 20:44:59 -0600 Subject: [PATCH 10/46] fix tests, sub 5sec examples --- R/ddml_late.R | 2 + man/ddml_late.Rd | 2 + tests/testthat/test-ddml_ate.R | 142 ++++++++++------------ tests/testthat/test-ddml_att.R | 110 +++++++---------- tests/testthat/test-ddml_fpliv.R | 19 ++- tests/testthat/test-ddml_late.R | 194 ++++++++++++++---------------- tests/testthat/test-diagnostics.R | 48 +++----- tests/testthat/test-methods.R | 40 +++--- tests/testthat/test-tidy.R | 40 +++--- 9 files changed, 260 insertions(+), 337 deletions(-) diff --git a/R/ddml_late.R b/R/ddml_late.R index 9a52ed6..662518e 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -126,6 +126,7 @@ #' 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. @@ -142,6 +143,7 @@ #' sample_folds = 2, #' silent = TRUE) #' summary(late_fit) +#' } ddml_late <- function(y, D, Z, X, learners, learners_DXZ = learners, diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index bed7f91..7606ce0 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -208,6 +208,7 @@ 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. @@ -225,6 +226,7 @@ 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. diff --git a/tests/testthat/test-ddml_ate.R b/tests/testthat/test-ddml_ate.R index e55069b..ceed2d4 100644 --- a/tests/testthat/test-ddml_ate.R +++ b/tests/testthat/test-ddml_ate.R @@ -1,40 +1,36 @@ 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) - suppressWarnings({ - 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) - }) # Check output with expectations expect_equal(length(ddml_ate_fit$ate), 1) })#TEST_THAT test_that("ddml_ate computes with stratify = FALSE", { # 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) - suppressWarnings({ - 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) - }) # Check output with expectations expect_equal(length(ddml_ate_fit$ate), 1) })#TEST_THAT @@ -43,64 +39,59 @@ 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) - suppressWarnings({ - 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) - }) # Check output with expectations expect_equal(length(ddml_ate_fit$ate), 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(what = ols), list(what = ols)) # Compute DDML PLM estimator - suppressWarnings({ - 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) - }) # Check output with expectations expect_equal(length(ddml_ate_fit$ate), 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(what = ols), list(what = ols)) # Compute DDML PLM estimator - suppressWarnings({ - ddml_ate_fit <- ddml_ate(y, D, X, + ddml_ate_fit <- ddml_ate(y, D, X, learners, ensemble_type = c("ols", "nnls", "singlebest", "average"), @@ -108,23 +99,21 @@ test_that("ddml_ate computes w/ multiple ensembles + custom weights", { custom_ensemble_weights = diag(1, 2), sample_folds = 3, silent = T) - }) # Check output with expectations expect_equal(length(ddml_ate_fit$ate), 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(what = ols)) # Compute DDML PLM estimator - suppressWarnings({ - ddml_ate_fit <- ddml_ate(y, D, X, + ddml_ate_fit <- ddml_ate(y, D, X, learners, ensemble_type = c("ols", "nnls", "singlebest", "average"), @@ -132,27 +121,24 @@ test_that("ddml_ate computes with multiple ensemble procedures & shortstack", { cv_folds = 3, sample_folds = 3, silent = T) - }) # Check output with expectations expect_equal(length(ddml_ate_fit$ate), 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) - suppressWarnings({ - 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) - }) # Compute inference results & test print inf_res <- summary(ddml_ate_fit) capture_output({print(inf_res)}, print = FALSE) @@ -165,24 +151,22 @@ 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) - suppressWarnings({ - 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) - }) # Compute inference results & test print inf_res <- summary(ddml_ate_fit) capture_output({print(inf_res)}, print = FALSE) @@ -193,23 +177,21 @@ test_that("summary.ddml_ate computes with a single model and dependence", { 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(what = ols)) # Compute DDML PLM estimator - suppressWarnings({ - 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) - }) # Compute inference results & test print inf_res <- summary(ddml_ate_fit) capture_output({print(inf_res)}, print = FALSE) @@ -222,9 +204,9 @@ test_that("ddml_ate fitted pass-through works", { set.seed(42) nobs <- 500 X <- matrix(rnorm(nobs * 3), nobs, 3) - D_tld <- 0.3 * X[, 1] + rnorm(nobs) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) D <- 1 * (D_tld > 0) - y <- D + 0.3 * X[, 1] + rnorm(nobs) + y <- D + 0.1 * X[, 1] + rnorm(nobs) learners <- list(list(what = ols), list(what = ols)) fit <- ddml_ate(y, D, X, diff --git a/tests/testthat/test-ddml_att.R b/tests/testthat/test-ddml_att.R index 1d2c78b..69a43ba 100644 --- a/tests/testthat/test-ddml_att.R +++ b/tests/testthat/test-ddml_att.R @@ -1,40 +1,36 @@ 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) - suppressWarnings({ - 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) - }) # Check output with expectations expect_equal(length(ddml_att_fit$att), 1) })#TEST_THAT test_that("ddml_att computes with stratify = FALSE", { # 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) - suppressWarnings({ - ddml_att_fit <- ddml_att(y, D, X, + ddml_att_fit <- ddml_att(y, D, X, learners = learners, stratify = FALSE, cv_folds = 3, sample_folds = 3, silent = T) - }) # Check output with expectations expect_equal(length(ddml_att_fit$att), 1) })#TEST_THAT @@ -53,54 +49,49 @@ test_that("ddml_att computes with a single model and dependence", { y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments learners <- list(what = ols) - suppressWarnings({ - 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) - }) # Check output with expectations expect_equal(length(ddml_att_fit$att), 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(what = ols), list(what = ols)) # Compute DDML PLM estimator - suppressWarnings({ - 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) - }) # Check output with expectations expect_equal(length(ddml_att_fit$att), 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(what = ols), list(what = ols)) # Compute DDML PLM estimator - suppressWarnings({ - ddml_att_fit <- ddml_att(y, D, X, + ddml_att_fit <- ddml_att(y, D, X, learners, ensemble_type = c("ols", "nnls", "singlebest", "average"), @@ -108,24 +99,22 @@ test_that("ddml_att computes w/ multiple ensembles + custom weights", { custom_ensemble_weights = diag(1, 2), sample_folds = 3, silent = T) - }) # Check output with expectations expect_equal(length(ddml_att_fit$att), 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(what = ols), list(what = ols)) # Compute DDML PLM estimator - suppressWarnings({ - ddml_att_fit <- ddml_att(y, D, X, + ddml_att_fit <- ddml_att(y, D, X, learners, ensemble_type = c("ols", "average"), shortstack = TRUE, @@ -133,27 +122,24 @@ test_that("ddml_att computes w/ multp ensembles, custom weights + shortstack", { custom_ensemble_weights = diag(1, 2), sample_folds = 3, silent = T) - }) # Check output with expectations expect_equal(length(ddml_att_fit$att), 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) - suppressWarnings({ - 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) - }) # Compute inference results & test print inf_res <- summary(ddml_att_fit) capture_output({print(inf_res)}, print = FALSE) @@ -176,14 +162,12 @@ test_that("summary.ddml_att computes with a single model and dependence", { y <- D + X %*% runif(40) + rnorm(nobs) # Define arguments learners <- list(what = ols) - suppressWarnings({ - 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) - }) # Compute inference results & test print inf_res <- summary(ddml_att_fit) capture_output({print(inf_res)}, print = FALSE) @@ -194,23 +178,21 @@ test_that("summary.ddml_att computes with a single model and dependence", { 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(what = ols)) # Compute DDML PLM estimator - suppressWarnings({ - 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) - }) # Compute inference results & test print inf_res <- summary(ddml_att_fit) capture_output({print(inf_res)}, print = FALSE) @@ -223,9 +205,9 @@ test_that("ddml_att fitted pass-through works", { set.seed(42) nobs <- 500 X <- matrix(rnorm(nobs * 3), nobs, 3) - D_tld <- 0.3 * X[, 1] + rnorm(nobs) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) D <- 1 * (D_tld > 0) - y <- D + 0.3 * X[, 1] + rnorm(nobs) + y <- D + 0.1 * X[, 1] + rnorm(nobs) learners <- list(list(what = ols), list(what = ols)) fit <- ddml_att(y, D, X, diff --git a/tests/testthat/test-ddml_fpliv.R b/tests/testthat/test-ddml_fpliv.R index 22dd86a..26826f9 100644 --- a/tests/testthat/test-ddml_fpliv.R +++ b/tests/testthat/test-ddml_fpliv.R @@ -331,26 +331,25 @@ test_that("ddml_fpliv computes with an ensemble procedure w/o LIE, multi D", { 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] + 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(what = ols), list(what = ols)) # Compute LIE-conform DDML IV estimator - suppressWarnings({ - ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, + 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) - }) # Check output with expectations expect_equal(length(ddml_fpliv_fit$coef), 8) })#TEST_THAT diff --git a/tests/testthat/test-ddml_late.R b/tests/testthat/test-ddml_late.R index 6e419be..7a53d7a 100644 --- a/tests/testthat/test-ddml_late.R +++ b/tests/testthat/test-ddml_late.R @@ -1,44 +1,40 @@ 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) - suppressWarnings({ - 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) - }) # Check output with expectations expect_equal(length(ddml_late_fit$late), 1) })#TEST_THAT test_that("ddml_late computes with stratify = FALSE", { # 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) - suppressWarnings({ - ddml_late_fit <- ddml_late(y, D, Z, X, + ddml_late_fit <- ddml_late(y, D, Z, X, learners = learners, stratify = FALSE, cv_folds = 3, sample_folds = 3, silent = T) - }) # Check output with expectations expect_equal(length(ddml_late_fit$late), 1) })#TEST_THAT @@ -47,93 +43,86 @@ 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) - suppressWarnings({ - 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) - }) # Check output with expectations expect_equal(length(ddml_late_fit$late), 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) - suppressWarnings({ - 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) - }) # Check output with expectations expect_equal(length(ddml_late_fit$late), 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(what = ols), list(what = ols)) # Compute DDML PLM estimator - suppressWarnings({ - 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) - }) # Check output with expectations expect_equal(length(ddml_late_fit$late), 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(what = ols), list(what = ols)) # Compute DDML PLM estimator - suppressWarnings({ - 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", @@ -142,27 +131,25 @@ test_that("ddml_late computes w/ multiple ensembles & custom weights", { custom_ensemble_weights = diag(1, 2), sample_folds = 3, silent = T) - }) # Check output with expectations expect_equal(length(ddml_late_fit$late), 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(what = ols), list(what = ols)) # Compute DDML PLM estimator - suppressWarnings({ - 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", @@ -170,26 +157,24 @@ test_that("ddml_late computes with multiple ensemble procedures + perfect compli cv_folds = 3, sample_folds = 3, silent = T) - }) # Check output with expectations expect_equal(length(ddml_late_fit$late), 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(what = ols), list(what = ols)) # Compute DDML PLM estimator - suppressWarnings({ - 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", @@ -199,29 +184,26 @@ test_that("ddml_late computes w/ mult ensembles, custom weights, & shortstack", custom_ensemble_weights = diag(1, 2), sample_folds = 3, silent = T) - }) # Check output with expectations expect_equal(length(ddml_late_fit$late), 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) - suppressWarnings({ - 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) - }) # Compute inference results & test print inf_res <- summary(ddml_late_fit) capture_output({print(inf_res)}, print = FALSE) @@ -234,26 +216,24 @@ 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) - suppressWarnings({ - 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) - }) # Compute inference results & test print inf_res <- summary(ddml_late_fit) capture_output({print(inf_res)}, print = FALSE) @@ -266,11 +246,11 @@ test_that("ddml_late fitted pass-through works", { set.seed(42) nobs <- 500 X <- matrix(rnorm(nobs * 3), nobs, 3) - Z_tld <- 0.3 * X[, 1] + rnorm(nobs) + Z_tld <- 0.1 * X[, 1] + rnorm(nobs) Z <- 1 * (Z_tld > 0) - D_tld <- 0.3 * Z + 0.2 * X[, 1] + rnorm(nobs) + D_tld <- 0.2 * Z + 0.1 * X[, 1] + rnorm(nobs) D <- 1 * (D_tld > 0) - y <- D + 0.3 * X[, 1] + rnorm(nobs) + y <- D + 0.1 * X[, 1] + rnorm(nobs) learners <- list(list(what = ols), list(what = ols)) fit <- ddml_late(y, D, Z, X, diff --git a/tests/testthat/test-diagnostics.R b/tests/testthat/test-diagnostics.R index 7f5eaf1..ea5f722 100644 --- a/tests/testthat/test-diagnostics.R +++ b/tests/testthat/test-diagnostics.R @@ -1,16 +1,14 @@ test_that("diagnostics works with PLM single learner", { set.seed(42) - nobs <- 100 + 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) - suppressWarnings({ - fit <- ddml_plm(y, D, X, + fit <- ddml_plm(y, D, X, learners = list(what = ols), sample_folds = 2, silent = TRUE) - }) diag <- diagnostics(fit) @@ -26,19 +24,17 @@ test_that("diagnostics works with PLM single learner", { test_that("diagnostics works with PLM multiple learners", { set.seed(42) - nobs <- 100 + 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)) - suppressWarnings({ - fit <- ddml_plm(y, D, X, + fit <- ddml_plm(y, D, X, learners = learners, ensemble_type = c("nnls1"), sample_folds = 2, silent = TRUE) - }) diag <- diagnostics(fit) @@ -56,17 +52,15 @@ test_that("diagnostics works with PLM multiple learners", { test_that("tidy.ddml_diagnostics returns flat data.frame", { set.seed(42) - nobs <- 100 + 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) - suppressWarnings({ - fit <- ddml_plm(y, D, X, + fit <- ddml_plm(y, D, X, learners = list(what = ols), sample_folds = 2, silent = TRUE) - }) td <- tidy(diagnostics(fit)) @@ -78,19 +72,17 @@ test_that("tidy.ddml_diagnostics returns flat data.frame", { test_that("diagnostics with CVC", { set.seed(42) - nobs <- 100 + 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)) - suppressWarnings({ - fit <- ddml_plm(y, D, X, + fit <- ddml_plm(y, D, X, learners = learners, ensemble_type = c("nnls1"), sample_folds = 2, silent = TRUE) - }) diag <- diagnostics(fit, cvc = TRUE, bootnum = 100) @@ -108,18 +100,16 @@ test_that("diagnostics with CVC", { test_that("diagnostics works with ATE", { set.seed(42) - nobs <- 100 + nobs <- 500 X <- matrix(rnorm(nobs * 3), nobs, 3) - D_tld <- X %*% runif(3) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(3) + rnorm(nobs) + D_tld <- 0.1 * X[, 1] + rnorm(nobs) + D <- 1 * (D_tld > 0) + y <- D + 0.1 * X[, 1] + rnorm(nobs) - suppressWarnings({ - fit <- ddml_ate(y, D, X, - learners = list(what = ols), - sample_folds = 2, - silent = TRUE) - }) + fit <- ddml_ate(y, D, X, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) diag <- diagnostics(fit) @@ -131,19 +121,17 @@ test_that("diagnostics works with ATE", { test_that("diagnostics r2 matches manual calculation", { set.seed(42) - nobs <- 200 + 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)) - suppressWarnings({ - fit <- ddml_plm(y, D, X, + 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 diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 7a1c240..e9fc733 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -1,20 +1,18 @@ test_that("standard S3 generic methods work correctly", { set.seed(42) - nobs <- 100 - X <- cbind(1, matrix(rnorm(nobs * 4), nobs, 4)) - D_tld <- X %*% runif(5) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(5) + 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) learners <- list(list(what = ols), list(what = ols)) - suppressWarnings({ - fit <- ddml_ate(y, D, X, + 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) @@ -45,21 +43,19 @@ test_that("standard S3 generic methods work correctly", { test_that("type argument threads through S3 methods", { set.seed(42) - nobs <- 100 - X <- cbind(1, matrix(rnorm(nobs * 4), nobs, 4)) - D_tld <- X %*% runif(5) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(5) + 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) learners <- list(list(what = ols), list(what = ols)) - suppressWarnings({ - fit <- ddml_ate(y, D, X, + 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") @@ -101,17 +97,15 @@ test_that("type argument threads through S3 methods", { test_that("type works with PLM estimator", { set.seed(42) - nobs <- 100 + 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) - suppressWarnings({ - fit <- ddml_plm(y, D, X, - learners = list(what = ols), - sample_folds = 2, - silent = TRUE) - }) + 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") diff --git a/tests/testthat/test-tidy.R b/tests/testthat/test-tidy.R index 04056f5..35cb5d9 100644 --- a/tests/testthat/test-tidy.R +++ b/tests/testthat/test-tidy.R @@ -1,21 +1,19 @@ test_that("tidy and glance broom formatters work correctly", { # Generate a minimal fitted object to test the plumbing set.seed(42) - nobs <- 100 - X <- cbind(1, matrix(rnorm(nobs * 4), nobs, 4)) - D_tld <- X %*% runif(5) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(5) + 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) learners <- list(list(what = ols), list(what = ols)) - suppressWarnings({ - fit <- ddml_ate(y, D, X, + 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) @@ -45,21 +43,19 @@ test_that("tidy and glance broom formatters work correctly", { test_that("tidy respects type argument", { set.seed(42) - nobs <- 100 - X <- cbind(1, matrix(rnorm(nobs * 4), nobs, 4)) - D_tld <- X %*% runif(5) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% runif(5) + 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) learners <- list(list(what = ols), list(what = ols)) - suppressWarnings({ - fit <- ddml_ate(y, D, X, + 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") @@ -82,17 +78,15 @@ test_that("tidy respects type argument", { test_that("tidy works with PLM (multi-covariate D)", { set.seed(42) - nobs <- 100 + 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) - suppressWarnings({ - fit <- ddml_plm(y, D, X, - learners = list(what = ols), - sample_folds = 2, - silent = TRUE) - }) + fit <- ddml_plm(y, D, X, + learners = list(what = ols), + sample_folds = 2, + silent = TRUE) td <- tidy(fit) expect_s3_class(td, "data.frame") From 8bb89fd5de6c564b8cbdcfbdfb75b24341c1ff0f Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Sat, 28 Feb 2026 21:28:33 -0600 Subject: [PATCH 11/46] update docs + pkgdown --- NEWS.md | 32 +++++++++++++++----------------- R/ddml_ate.R | 4 +++- R/ddml_fpliv.R | 5 ++++- R/ddml_late.R | 4 +++- R/ddml_pliv.R | 5 ++++- R/ddml_plm.R | 4 +++- _pkgdown.yml | 12 ++++++++++++ man/ddml_ate.Rd | 4 +++- man/ddml_fpliv.Rd | 5 ++++- man/ddml_late.Rd | 4 +++- man/ddml_pliv.Rd | 5 ++++- man/ddml_plm.Rd | 4 +++- 12 files changed, 61 insertions(+), 27 deletions(-) diff --git a/NEWS.md b/NEWS.md index de35c2e..e9f4cd0 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,22 +1,20 @@ # ddml 0.3.1 -* Adds support for parallel computation in `crosspred()`, `crossval()`, and `shortstacking()` via the `parallel` parameter. Updates progress reporting using `pbapply`. -* Adds stratified cross-fitting to ``ddml_ate()``, ``ddml_att()``, and - ``ddml_late()`` via the ``stratify`` parameter. - Stratified splitting is now the default. -* Adds ``cluster_variable`` to ``crossval()``, ``crosspred()``, and - ``shortstacking()`` for cluster-aware sample splitting. -* Renames ``cv_subsamples_list`` to ``cv_subsamples``. The old name - still works with a deprecation message. -* Warns when any cross-fitting training set has fewer than 100 - observations. -* 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. -* Updates inference and generic S3 methods (`coef`, `vcov`, `confint`, `summary`, `print`). -* Adds compatibility with `broom` (`tidy`, `glance`) and `texreg` (`extract.ddml`) for standardizing estimation output tables. -* Adds `mdl_bigGLM` sparse-matrix unpenalized regression wrapper using `glmnet`. -* Fixes `mdl_xgboost` for binary classification with numeric outcomes. +* Adds `fitted` and `splits` parameters to all `ddml_*()` estimators for re-estimation with different ensemble types without re-fitting base learners. +* Adds `diagnostics()` for per-equation MSPE, R-squared, stacking weights, and cross-validated comparison (CVC) tests. +* Adds HC0 and HC3 variance estimators alongside default HC1 via `type` argument in `vcov()`, `confint()`, `summary()`, and `tidy()`. +* Learner specifications now use `what` instead of `fun`. `fun` is accepted with a deprecation message. +* Sample split arguments consolidated into a single `splits` parameter. +* Adds parallel computation via the `parallel` parameter and progress reporting via `pbapply`. +* Adds stratified cross-fitting to `ddml_ate()`, `ddml_att()`, and `ddml_late()` via `stratify`. Enabled by default. +* Adds `cluster_variable` for cluster-aware sample splitting. +* Adds input validation across all estimators. +* Exports `ensemble()` with documentation and examples. +* Adds `broom` compatibility (`tidy`, `glance`). +* Updates S3 methods (`coef`, `vcov`, `confint`, `summary`, `print`). +* Adds `mdl_bigGLM` sparse-matrix unpenalized regression wrapper. +* `mdl_xgboost()` auto-detects binary factor outcomes. +* Fixes `ddml_fpliv()` with custom weights. # ddml 0.3.0 diff --git a/R/ddml_ate.R b/R/ddml_ate.R index c09c10f..b233260 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -2,7 +2,9 @@ #' #' @family ddml #' -#' @seealso [ddml::summary.ddml()] +#' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], +#' [ddml::confint.ddml()], [ddml::tidy.ddml()], +#' [ddml::glance.ddml()], [ddml::diagnostics()] #' #' @description Estimators of the average treatment effect and the average #' treatment effect on the treated. diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index c69e4ea..fb0e57d 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -2,7 +2,10 @@ #' #' @family ddml #' -#' @seealso [ddml::summary.ddml()], [AER::ivreg()] +#' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], +#' [ddml::confint.ddml()], [ddml::tidy.ddml()], +#' [ddml::glance.ddml()], [ddml::diagnostics()], +#' [AER::ivreg()] #' #' @description Estimator for the flexible partially linear IV model. #' diff --git a/R/ddml_late.R b/R/ddml_late.R index 662518e..48c9816 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -2,7 +2,9 @@ #' #' @family ddml #' -#' @seealso [ddml::summary.ddml()] +#' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], +#' [ddml::confint.ddml()], [ddml::tidy.ddml()], +#' [ddml::glance.ddml()], [ddml::diagnostics()] #' #' @description Estimator of the local average treatment effect. #' diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index 5dd4b05..0528e79 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -2,7 +2,10 @@ #' #' @family ddml #' -#' @seealso [ddml::summary.ddml()], [AER::ivreg()] +#' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], +#' [ddml::confint.ddml()], [ddml::tidy.ddml()], +#' [ddml::glance.ddml()], [ddml::diagnostics()], +#' [AER::ivreg()] #' #' @description Estimator for the partially linear IV model. #' diff --git a/R/ddml_plm.R b/R/ddml_plm.R index 3cf4eca..abed68b 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -2,7 +2,9 @@ #' #' @family ddml #' -#' @seealso [ddml::summary.ddml()] +#' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], +#' [ddml::confint.ddml()], [ddml::tidy.ddml()], +#' [ddml::glance.ddml()], [ddml::diagnostics()] #' #' @description Estimator for the partially linear model. #' diff --git a/_pkgdown.yml b/_pkgdown.yml index 438a994..872e1f8 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -43,6 +43,15 @@ reference: - ddml_pliv - ddml_fpliv - ddml_late +- title: internal + contents: + - coef.ddml + - confint.ddml + - vcov.ddml + - tidy.ddml + - glance.ddml + - tidy.ddml_diagnostics + - ensemble_weights - title: Wrappers for Common (Machine) Learners contents: - ols @@ -50,11 +59,14 @@ reference: - mdl_glmnet - mdl_ranger - mdl_xgboost + - mdl_bigGLM - title: Utilities contents: - crossval - crosspred - shortstacking + - ensemble + - diagnostics - title: Dataset contents: - AE98 diff --git a/man/ddml_ate.Rd b/man/ddml_ate.Rd index 955feae..461f206 100644 --- a/man/ddml_ate.Rd +++ b/man/ddml_ate.Rd @@ -246,7 +246,9 @@ 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]{summary.ddml()}} +\code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, +\code{\link[=confint.ddml]{confint.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, +\code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}} Other ddml: \code{\link{ddml_fpliv}()}, diff --git a/man/ddml_fpliv.Rd b/man/ddml_fpliv.Rd index dfa8d88..18e4e61 100644 --- a/man/ddml_fpliv.Rd +++ b/man/ddml_fpliv.Rd @@ -205,7 +205,10 @@ 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]{summary.ddml()}}, \code{\link[AER:ivreg]{AER::ivreg()}} +\code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, +\code{\link[=confint.ddml]{confint.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, +\code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}}, +\code{\link[AER:ivreg]{AER::ivreg()}} Other ddml: \code{\link{ddml_ate}()}, diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index 7606ce0..bf53ccf 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -241,7 +241,9 @@ Treatment Effects." Econometrica, 62(2), 467-475. Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. } \seealso{ -\code{\link[=summary.ddml]{summary.ddml()}} +\code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, +\code{\link[=confint.ddml]{confint.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, +\code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}} Other ddml: \code{\link{ddml_ate}()}, diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index 792e0c7..aa73888 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -210,7 +210,10 @@ New York. Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. } \seealso{ -\code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[AER:ivreg]{AER::ivreg()}} +\code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, +\code{\link[=confint.ddml]{confint.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, +\code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}}, +\code{\link[AER:ivreg]{AER::ivreg()}} Other ddml: \code{\link{ddml_ate}()}, diff --git a/man/ddml_plm.Rd b/man/ddml_plm.Rd index 5763c5b..838116e 100644 --- a/man/ddml_plm.Rd +++ b/man/ddml_plm.Rd @@ -227,7 +227,9 @@ 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]{summary.ddml()}} +\code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, +\code{\link[=confint.ddml]{confint.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, +\code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}} Other ddml: \code{\link{ddml_ate}()}, From bd6cfbbab4b266673e310fe768a09c5bcdd05528 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Tue, 3 Mar 2026 16:46:52 -0600 Subject: [PATCH 12/46] resampling, median/mean aggregation --- NAMESPACE | 12 + R/ddml_rep.R | 715 +++++++++++++++++++++++++++++++++ man/coef.ddml_rep.Rd | 35 ++ man/confint.ddml_rep.Rd | 55 +++ man/ddml_ate.Rd | 6 +- man/ddml_fpliv.Rd | 6 +- man/ddml_late.Rd | 6 +- man/ddml_pliv.Rd | 6 +- man/ddml_plm.Rd | 6 +- man/ddml_rep.Rd | 63 +++ man/ddml_replicate.Rd | 59 +++ man/glance.ddml.Rd | 6 +- man/glance.ddml_rep.Rd | 51 +++ man/length.ddml_rep.Rd | 30 ++ man/print.ddml_rep.Rd | 32 ++ man/print.summary.ddml_rep.Rd | 21 + man/sub-sub-.ddml_rep.Rd | 32 ++ man/summary.ddml_rep.Rd | 40 ++ man/tidy.ddml.Rd | 6 +- man/tidy.ddml_rep.Rd | 79 ++++ man/vcov.ddml_rep.Rd | 49 +++ tests/testthat/test-ddml_rep.R | 351 ++++++++++++++++ 22 files changed, 1659 insertions(+), 7 deletions(-) create mode 100644 R/ddml_rep.R create mode 100644 man/coef.ddml_rep.Rd create mode 100644 man/confint.ddml_rep.Rd create mode 100644 man/ddml_rep.Rd create mode 100644 man/ddml_replicate.Rd create mode 100644 man/glance.ddml_rep.Rd create mode 100644 man/length.ddml_rep.Rd create mode 100644 man/print.ddml_rep.Rd create mode 100644 man/print.summary.ddml_rep.Rd create mode 100644 man/sub-sub-.ddml_rep.Rd create mode 100644 man/summary.ddml_rep.Rd create mode 100644 man/tidy.ddml_rep.Rd create mode 100644 man/vcov.ddml_rep.Rd create mode 100644 tests/testthat/test-ddml_rep.R diff --git a/NAMESPACE b/NAMESPACE index 9fd7b5a..f39066c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,8 +1,13 @@ # Generated by roxygen2: do not edit by hand +S3method("[[",ddml_rep) S3method(coef,ddml) +S3method(coef,ddml_rep) S3method(confint,ddml) +S3method(confint,ddml_rep) S3method(glance,ddml) +S3method(glance,ddml_rep) +S3method(length,ddml_rep) S3method(predict,ensemble) S3method(predict,mdl_bigGLM) S3method(predict,mdl_glm) @@ -11,11 +16,16 @@ S3method(predict,mdl_ranger) S3method(predict,mdl_xgboost) S3method(predict,ols) S3method(print,ddml_diagnostics) +S3method(print,ddml_rep) S3method(print,summary.ddml) +S3method(print,summary.ddml_rep) S3method(summary,ddml) +S3method(summary,ddml_rep) S3method(tidy,ddml) S3method(tidy,ddml_diagnostics) +S3method(tidy,ddml_rep) S3method(vcov,ddml) +S3method(vcov,ddml_rep) export(crosspred) export(crossval) export(ddml_ate) @@ -24,6 +34,8 @@ 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) diff --git a/R/ddml_rep.R b/R/ddml_rep.R new file mode 100644 index 0000000..f2f31c3 --- /dev/null +++ b/R/ddml_rep.R @@ -0,0 +1,715 @@ +# Internal helpers ----------------------------------------------- + +# Extract SEs from a single ddml fit. +extract_se <- function(object, type = "HC1") { + nensb <- length(object$scores) + p <- length(object$coef_names) + se_mat <- matrix(0, p, nensb) + for (j in seq_len(nensb)) { + V <- compute_ddml_variance( + object$scores[[j]], object$J[[j]], + object$cluster_variable, type = type) + se_mat[, j] <- sqrt(diag(V)) + }#FOR + se_mat +}#EXTRACT_SE + +# Ensure coefficients are always a p x nensb matrix. +normalize_coef_matrix <- function(coefficients, p, nensb) { + if (is.matrix(coefficients)) { + return(coefficients) + }#IF + if (p == 1) { + matrix(coefficients, nrow = 1, ncol = nensb) + } else { + matrix(coefficients, nrow = p, ncol = 1) + }#IFELSE +}#NORMALIZE_COEF_MATRIX + +# Build inference results array from aggregated coef/SE. +build_inf_from_agg <- function(agg, coef_names, + ensemble_type) { + p <- nrow(agg$coefficients) + nensb <- ncol(agg$coefficients) + inf_results <- array(0, dim = c(p, 4, nensb)) + for (j in seq_len(nensb)) { + 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( + coef_names, + c("Estimate", "Std. Error", "t value", "Pr(>|t|)"), + ensemble_type) + inf_results +}#BUILD_INF_FROM_AGG + +# Core aggregation workhorse (Ahrens et al., 2024, Remark 2). +aggregate_reps <- function(object, aggregation = "median", + type = "HC1") { + aggregation <- match.arg(aggregation, + c("median", "mean")) + R <- object$nresamples + nensb <- length(object$ensemble_type) + p <- length(object$coef_names) + + coef_array <- array(0, dim = c(p, nensb, R)) + se_array <- array(0, dim = c(p, nensb, R)) + for (r in seq_len(R)) { + fit <- object$fits[[r]] + coef_array[, , r] <- normalize_coef_matrix( + fit$coefficients, p, nensb) + se_array[, , r] <- extract_se(fit, type = type) + }#FOR + + if (aggregation == "median") { + agg_coef <- apply(coef_array, c(1, 2), + stats::median) + var_total <- se_array^2 + + sweep(coef_array, c(1, 2), agg_coef)^2 + agg_se <- sqrt(apply(var_total, c(1, 2), + stats::median)) + } else { + agg_coef <- apply(coef_array, c(1, 2), mean) + var_total <- se_array^2 + + sweep(coef_array, c(1, 2), agg_coef)^2 + agg_se <- sqrt(apply(var_total, c(1, 2), + function(x) length(x) / sum(1 / x))) + }#IFELSE + + list(coefficients = agg_coef, se = agg_se, + coef_array = coef_array, se_array = se_array) +}#AGGREGATE_REPS + +# 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{"ddml_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 +#' @seealso [ddml_replicate()] +#' @export +ddml_rep <- function(fits) { + 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 + + ens_type <- ref$ensemble_type + if (is.null(ens_type)) { + ens_type <- "single base learner" + }#IF + + structure( + list( + fits = fits, + nresamples = length(fits), + model_type = primary[1], + coef_names = ref$coef_names, + ensemble_type = ens_type, + nobs = ref$nobs, + sample_folds = ref$sample_folds, + shortstack = ref$shortstack + ), + class = "ddml_rep" + ) +}#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 +#' @seealso [ddml_rep()] +#' @export +ddml_replicate <- function(fn, ..., resamples = 5, + silent = FALSE) { + dots <- list(...) + dots$silent <- silent + fits <- vector("list", resamples) + for (r in seq_len(resamples)) { + if (!silent) { + message("[Resample ", r, "/", resamples, "]") + }#IF + fits[[r]] <- do.call(fn, dots) + }#FOR + ddml_rep(fits) +}#DDML_REPLICATE + +# S3 methods ----------------------------------------------------- + +#' Extract a Single Fit from a ddml_rep Object +#' +#' @param x A \code{ddml_rep} object. +#' @param i Integer index of the fit to extract. +#' +#' @return The \code{i}-th \code{ddml} fit. +#' +#' @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) +#' coef(reps[[1]]) +#' } +#' +#' @export +#' @method [[ ddml_rep +`[[.ddml_rep` <- function(x, i) { + x$fits[[i]] +}#[[.DDML_REP + +#' Number of Resamples in a ddml_rep Object +#' +#' @param x A \code{ddml_rep} object. +#' +#' @return Integer number of resamples. +#' +#' @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) +#' length(reps) +#' } +#' +#' @export +#' @method length ddml_rep +length.ddml_rep <- function(x) { + x$nresamples +}#LENGTH.DDML_REP + +#' Print a ddml_rep Object +#' +#' Displays a brief overview of a \code{ddml_rep} object. +#' +#' @param x A \code{ddml_rep} object. +#' @param ... Currently unused. +#' +#' @return \code{x}, invisibly. +#' +#' @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) +#' reps +#' } +#' +#' @export +#' @method print ddml_rep +print.ddml_rep <- function(x, ...) { + type_labels <- c( + ddml_plm = "Partially Linear Model", + ddml_pliv = "Partially Linear IV Model", + ddml_fpliv = + "Flexible Partially Linear IV Model", + ddml_ate = "Average Treatment Effect", + ddml_att = + "Average Treatment Effect on the Treated", + ddml_late = "Local Average Treatment Effect") + model_name <- type_labels[x$model_type] + if (is.na(model_name)) model_name <- x$model_type + + cat("DDML replicated fits:", model_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 + +#' Extract Aggregated Coefficients from a ddml_rep Object +#' +#' @param object A \code{ddml_rep} object. +#' @param ... Additional arguments. Supports +#' \code{aggregation} (\code{"median"} or \code{"mean"}). +#' +#' @return Named vector (single ensemble) or matrix +#' (multiple ensembles). +#' +#' @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) +#' coef(reps) +#' coef(reps, aggregation = "mean") +#' } +#' +#' @export +#' @method coef ddml_rep +coef.ddml_rep <- function(object, + aggregation = c("median", + "mean"), + ...) { + aggregation <- match.arg(aggregation) + agg <- aggregate_reps(object, + aggregation = aggregation) + cf <- agg$coefficients + rownames(cf) <- object$coef_names + colnames(cf) <- object$ensemble_type + if (ncol(cf) == 1) cf <- drop(cf) + cf +}#COEF.DDML_REP + +#' Variance-Covariance Matrix for ddml_rep Objects +#' +#' Returns a diagonal variance-covariance matrix from +#' cross-resample aggregation. +#' +#' @param object A \code{ddml_rep} object. +#' @param ensemble_idx Integer index of the ensemble type. +#' Defaults to 1. +#' @param aggregation Character string, either +#' \code{"median"} (default) or \code{"mean"}. +#' @param type Character string specifying the +#' variance-covariance estimator. One of \code{"HC1"} +#' (default), \code{"HC0"}, or \code{"HC3"}. +#' @param ... Currently unused. +#' +#' @return A diagonal p x p variance-covariance matrix. +#' +#' @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) +#' vcov(reps) +#' } +#' +#' @export +#' @method vcov ddml_rep +vcov.ddml_rep <- function(object, ensemble_idx = 1, + aggregation = c("median", + "mean"), + type = "HC1", ...) { + aggregation <- match.arg(aggregation) + agg <- aggregate_reps(object, + aggregation = aggregation, + type = type) + se_j <- agg$se[, ensemble_idx] + V <- diag(se_j^2, nrow = length(se_j)) + rownames(V) <- colnames(V) <- object$coef_names + V +}#VCOV.DDML_REP + +#' Confidence Intervals for ddml_rep Objects +#' +#' @param object A \code{ddml_rep} object. +#' @param parm Not used (included for generic compatibility). +#' @param level Confidence level. Default 0.95. +#' @param ensemble_idx Integer index of the ensemble type. +#' Defaults to 1. +#' @param aggregation Character string, either +#' \code{"median"} (default) or \code{"mean"}. +#' @param type Character string specifying the +#' variance-covariance estimator. One of \code{"HC1"} +#' (default), \code{"HC0"}, or \code{"HC3"}. +#' @param ... Currently unused. +#' +#' @return A matrix with columns for lower and upper bounds. +#' +#' @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) +#' confint(reps) +#' confint(reps, level = 0.90) +#' } +#' +#' @export +#' @method confint ddml_rep +confint.ddml_rep <- function(object, parm, + level = 0.95, + ensemble_idx = 1, + aggregation = c("median", + "mean"), + type = "HC1", ...) { + aggregation <- match.arg(aggregation) + agg <- aggregate_reps(object, + aggregation = aggregation, + type = type) + cf <- agg$coefficients[, ensemble_idx] + se <- agg$se[, ensemble_idx] + z <- stats::qnorm((1 + level) / 2) + 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) <- object$coef_names + ci +}#CONFINT.DDML_REP + +#' Summary for ddml_rep Objects +#' +#' @param object A \code{ddml_rep} object. +#' @param aggregation Character string, either +#' \code{"median"} (default) or \code{"mean"}. +#' @param type Character string specifying the +#' variance-covariance estimator. One of \code{"HC1"} +#' (default), \code{"HC0"}, or \code{"HC3"}. +#' @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"), + type = "HC1", ...) { + aggregation <- match.arg(aggregation) + type <- match.arg(type, c("HC0", "HC1", "HC3")) + agg <- aggregate_reps(object, + aggregation = aggregation, + type = type) + inf_results <- build_inf_from_agg( + agg, object$coef_names, object$ensemble_type) + result <- list( + inf_results = inf_results, + type = type, + model_type = object$model_type, + nobs = object$nobs, + sample_folds = object$sample_folds, + shortstack = object$shortstack, + ensemble_type = object$ensemble_type, + nresamples = object$nresamples, + aggregation = aggregation + ) + class(result) <- "summary.ddml_rep" + result +}#SUMMARY.DDML_REP + +#' Print Summary for ddml_rep Objects +#' +#' @param x An object of class \code{summary.ddml_rep}. +#' @param digits Number of significant digits. Default 3. +#' @param ... Currently unused. +#' +#' @return \code{x}, invisibly. +#' +#' @export +#' @method print summary.ddml_rep +print.summary.ddml_rep <- function(x, digits = 3, ...) { + type_labels <- c( + ddml_plm = "Partially Linear Model", + ddml_pliv = "Partially Linear IV Model", + ddml_fpliv = + "Flexible Partially Linear IV Model", + ddml_ate = "Average Treatment Effect", + ddml_att = + "Average Treatment Effect on the Treated", + ddml_late = "Local Average Treatment Effect") + model_name <- type_labels[x$model_type] + if (is.na(model_name)) model_name <- x$model_type + + cat("DDML estimation:", model_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") + + nensb <- dim(x$inf_results)[3] + for (j in seq_len(nensb)) { + if (nensb > 1) { + cat("Ensemble type:", + dimnames(x$inf_results)[[3]][j], "\n") + }#IF + tbl <- x$inf_results[, , j] + if (!is.matrix(tbl)) { + tbl <- matrix(tbl, nrow = 1, + dimnames = list( + dimnames(x$inf_results)[[1]], + dimnames(x$inf_results)[[2]])) + }#IF + stats::printCoefmat(tbl, digits = digits, + has.Pvalue = TRUE, + signif.stars = TRUE) + if (j < nensb) cat("\n") + }#FOR + + invisible(x) +}#PRINT.SUMMARY.DDML_REP + +#' Tidy a ddml_rep Object +#' +#' Extracts aggregated coefficient estimates, standard +#' errors, test statistics, and p-values from a +#' \code{ddml_rep} object in a format compatible with +#' \pkg{modelsummary} and the \pkg{broom} ecosystem. +#' +#' @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} to +#' return results for all ensemble types. +#' @param aggregation Character string, either +#' \code{"median"} (default) or \code{"mean"}. +#' @param type Character string specifying the +#' variance-covariance estimator. One of \code{"HC1"} +#' (default), \code{"HC0"}, or \code{"HC3"}. +#' @param conf.int Logical. Include confidence interval +#' columns? Default \code{FALSE}. +#' @param conf.level Confidence level for intervals. +#' Default 0.95. +#' @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}. If +#' \code{conf.int = TRUE}, also \code{conf.low} and +#' \code{conf.high}. +#' +#' @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) +#' } +#' +#' @family ddml +#' @export +#' @method tidy ddml_rep +tidy.ddml_rep <- function(x, ensemble_idx = 1, + aggregation = c("median", + "mean"), + type = "HC1", + conf.int = FALSE, + conf.level = 0.95, ...) { + s <- summary(x, aggregation = aggregation, + type = type) + inf <- s$inf_results + nensb <- dim(inf)[3] + p <- dim(inf)[1] + + if (is.null(ensemble_idx)) { + j_seq <- seq_len(nensb) + } else { + j_seq <- ensemble_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], + ensemble_type = dimnames(inf)[[3]][j], + stringsAsFactors = FALSE + ) + if (conf.int) { + z <- stats::qnorm((1 + conf.level) / 2) + row$conf.low <- + inf[k, 1, j] - z * inf[k, 2, j] + row$conf.high <- + inf[k, 1, j] + z * inf[k, 2, j] + }#IF + rows[[length(rows) + 1]] <- row + }#FOR + }#FOR + do.call(rbind, rows) +}#TIDY.DDML_REP + +#' Glance at a ddml_rep Object +#' +#' Returns a one-row summary of model-level statistics, +#' compatible with \pkg{modelsummary} and the \pkg{broom} +#' ecosystem. +#' +#' @param x A \code{ddml_rep} object. +#' @param ... Currently unused. +#' +#' @return A one-row \code{data.frame} with columns +#' \code{nobs}, \code{sample_folds}, \code{shortstack}, +#' \code{ensemble_type}, \code{model_type}, and +#' \code{nresamples}. +#' +#' @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) +#' } +#' +#' @family ddml +#' @export +#' @method glance ddml_rep +glance.ddml_rep <- 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 = x$model_type, + nresamples = x$nresamples, + stringsAsFactors = FALSE + ) +}#GLANCE.DDML_REP diff --git a/man/coef.ddml_rep.Rd b/man/coef.ddml_rep.Rd new file mode 100644 index 0000000..4f21387 --- /dev/null +++ b/man/coef.ddml_rep.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{coef.ddml_rep} +\alias{coef.ddml_rep} +\title{Extract Aggregated Coefficients from a ddml_rep Object} +\usage{ +\method{coef}{ddml_rep}(object, aggregation = c("median", "mean"), ...) +} +\arguments{ +\item{object}{A \code{ddml_rep} object.} + +\item{...}{Additional arguments. Supports +\code{aggregation} (\code{"median"} or \code{"mean"}).} +} +\value{ +Named vector (single ensemble) or matrix +(multiple ensembles). +} +\description{ +Extract Aggregated Coefficients from a ddml_rep Object +} +\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) +coef(reps) +coef(reps, aggregation = "mean") +} + +} diff --git a/man/confint.ddml_rep.Rd b/man/confint.ddml_rep.Rd new file mode 100644 index 0000000..e30d75c --- /dev/null +++ b/man/confint.ddml_rep.Rd @@ -0,0 +1,55 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{confint.ddml_rep} +\alias{confint.ddml_rep} +\title{Confidence Intervals for ddml_rep Objects} +\usage{ +\method{confint}{ddml_rep}( + object, + parm, + level = 0.95, + ensemble_idx = 1, + aggregation = c("median", "mean"), + type = "HC1", + ... +) +} +\arguments{ +\item{object}{A \code{ddml_rep} object.} + +\item{parm}{Not used (included for generic compatibility).} + +\item{level}{Confidence level. Default 0.95.} + +\item{ensemble_idx}{Integer index of the ensemble type. +Defaults to 1.} + +\item{aggregation}{Character string, either +\code{"median"} (default) or \code{"mean"}.} + +\item{type}{Character string specifying the +variance-covariance estimator. One of \code{"HC1"} +(default), \code{"HC0"}, or \code{"HC3"}.} + +\item{...}{Currently unused.} +} +\value{ +A matrix with columns for lower and upper bounds. +} +\description{ +Confidence Intervals for 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), + sample_folds = 2, + resamples = 3, silent = TRUE) +confint(reps) +confint(reps, level = 0.90) +} + +} diff --git a/man/ddml_ate.Rd b/man/ddml_ate.Rd index 461f206..cb1c4cc 100644 --- a/man/ddml_ate.Rd +++ b/man/ddml_ate.Rd @@ -255,7 +255,11 @@ Other ddml: \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, \code{\link{ddml_plm}()}, +\code{\link{ddml_rep}()}, +\code{\link{ddml_replicate}()}, \code{\link{glance.ddml}()}, -\code{\link{tidy.ddml}()} +\code{\link{glance.ddml_rep}()}, +\code{\link{tidy.ddml}()}, +\code{\link{tidy.ddml_rep}()} } \concept{ddml} diff --git a/man/ddml_fpliv.Rd b/man/ddml_fpliv.Rd index 18e4e61..29f0090 100644 --- a/man/ddml_fpliv.Rd +++ b/man/ddml_fpliv.Rd @@ -215,7 +215,11 @@ Other ddml: \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, \code{\link{ddml_plm}()}, +\code{\link{ddml_rep}()}, +\code{\link{ddml_replicate}()}, \code{\link{glance.ddml}()}, -\code{\link{tidy.ddml}()} +\code{\link{glance.ddml_rep}()}, +\code{\link{tidy.ddml}()}, +\code{\link{tidy.ddml_rep}()} } \concept{ddml} diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index bf53ccf..39ccf7e 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -250,7 +250,11 @@ Other ddml: \code{\link{ddml_fpliv}()}, \code{\link{ddml_pliv}()}, \code{\link{ddml_plm}()}, +\code{\link{ddml_rep}()}, +\code{\link{ddml_replicate}()}, \code{\link{glance.ddml}()}, -\code{\link{tidy.ddml}()} +\code{\link{glance.ddml_rep}()}, +\code{\link{tidy.ddml}()}, +\code{\link{tidy.ddml_rep}()} } \concept{ddml} diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index aa73888..fb54d60 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -220,7 +220,11 @@ Other ddml: \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, \code{\link{ddml_plm}()}, +\code{\link{ddml_rep}()}, +\code{\link{ddml_replicate}()}, \code{\link{glance.ddml}()}, -\code{\link{tidy.ddml}()} +\code{\link{glance.ddml_rep}()}, +\code{\link{tidy.ddml}()}, +\code{\link{tidy.ddml_rep}()} } \concept{ddml} diff --git a/man/ddml_plm.Rd b/man/ddml_plm.Rd index 838116e..756afc8 100644 --- a/man/ddml_plm.Rd +++ b/man/ddml_plm.Rd @@ -236,7 +236,11 @@ Other ddml: \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, +\code{\link{ddml_rep}()}, +\code{\link{ddml_replicate}()}, \code{\link{glance.ddml}()}, -\code{\link{tidy.ddml}()} +\code{\link{glance.ddml_rep}()}, +\code{\link{tidy.ddml}()}, +\code{\link{tidy.ddml_rep}()} } \concept{ddml} diff --git a/man/ddml_rep.Rd b/man/ddml_rep.Rd new file mode 100644 index 0000000..8992f7b --- /dev/null +++ b/man/ddml_rep.Rd @@ -0,0 +1,63 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{ddml_rep} +\alias{ddml_rep} +\title{Construct a Multi-Resample DDML Object} +\usage{ +ddml_rep(fits) +} +\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.} +} +\value{ +An object of class \code{"ddml_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: +\code{\link{ddml_ate}()}, +\code{\link{ddml_fpliv}()}, +\code{\link{ddml_late}()}, +\code{\link{ddml_pliv}()}, +\code{\link{ddml_plm}()}, +\code{\link{ddml_replicate}()}, +\code{\link{glance.ddml}()}, +\code{\link{glance.ddml_rep}()}, +\code{\link{tidy.ddml}()}, +\code{\link{tidy.ddml_rep}()} +} +\concept{ddml} diff --git a/man/ddml_replicate.Rd b/man/ddml_replicate.Rd new file mode 100644 index 0000000..3602814 --- /dev/null +++ b/man/ddml_replicate.Rd @@ -0,0 +1,59 @@ +% 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: +\code{\link{ddml_ate}()}, +\code{\link{ddml_fpliv}()}, +\code{\link{ddml_late}()}, +\code{\link{ddml_pliv}()}, +\code{\link{ddml_plm}()}, +\code{\link{ddml_rep}()}, +\code{\link{glance.ddml}()}, +\code{\link{glance.ddml_rep}()}, +\code{\link{tidy.ddml}()}, +\code{\link{tidy.ddml_rep}()} +} +\concept{ddml} diff --git a/man/glance.ddml.Rd b/man/glance.ddml.Rd index 82b9b78..5f49608 100644 --- a/man/glance.ddml.Rd +++ b/man/glance.ddml.Rd @@ -40,6 +40,10 @@ Other ddml: \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, \code{\link{ddml_plm}()}, -\code{\link{tidy.ddml}()} +\code{\link{ddml_rep}()}, +\code{\link{ddml_replicate}()}, +\code{\link{glance.ddml_rep}()}, +\code{\link{tidy.ddml}()}, +\code{\link{tidy.ddml_rep}()} } \concept{ddml} diff --git a/man/glance.ddml_rep.Rd b/man/glance.ddml_rep.Rd new file mode 100644 index 0000000..d5e9902 --- /dev/null +++ b/man/glance.ddml_rep.Rd @@ -0,0 +1,51 @@ +% 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} with columns +\code{nobs}, \code{sample_folds}, \code{shortstack}, +\code{ensemble_type}, \code{model_type}, and +\code{nresamples}. +} +\description{ +Returns a one-row summary of model-level statistics, +compatible with \pkg{modelsummary} and the \pkg{broom} +ecosystem. +} +\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) +} + +} +\seealso{ +Other ddml: +\code{\link{ddml_ate}()}, +\code{\link{ddml_fpliv}()}, +\code{\link{ddml_late}()}, +\code{\link{ddml_pliv}()}, +\code{\link{ddml_plm}()}, +\code{\link{ddml_rep}()}, +\code{\link{ddml_replicate}()}, +\code{\link{glance.ddml}()}, +\code{\link{tidy.ddml}()}, +\code{\link{tidy.ddml_rep}()} +} +\concept{ddml} diff --git a/man/length.ddml_rep.Rd b/man/length.ddml_rep.Rd new file mode 100644 index 0000000..7b92443 --- /dev/null +++ b/man/length.ddml_rep.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{length.ddml_rep} +\alias{length.ddml_rep} +\title{Number of Resamples in a ddml_rep Object} +\usage{ +\method{length}{ddml_rep}(x) +} +\arguments{ +\item{x}{A \code{ddml_rep} object.} +} +\value{ +Integer number of resamples. +} +\description{ +Number of Resamples in a ddml_rep Object +} +\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) +length(reps) +} + +} diff --git a/man/print.ddml_rep.Rd b/man/print.ddml_rep.Rd new file mode 100644 index 0000000..280289d --- /dev/null +++ b/man/print.ddml_rep.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{print.ddml_rep} +\alias{print.ddml_rep} +\title{Print a ddml_rep Object} +\usage{ +\method{print}{ddml_rep}(x, ...) +} +\arguments{ +\item{x}{A \code{ddml_rep} object.} + +\item{...}{Currently unused.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Displays a brief overview of a \code{ddml_rep} object. +} +\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) +reps +} + +} diff --git a/man/print.summary.ddml_rep.Rd b/man/print.summary.ddml_rep.Rd new file mode 100644 index 0000000..94fe8a3 --- /dev/null +++ b/man/print.summary.ddml_rep.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{print.summary.ddml_rep} +\alias{print.summary.ddml_rep} +\title{Print Summary for ddml_rep Objects} +\usage{ +\method{print}{summary.ddml_rep}(x, digits = 3, ...) +} +\arguments{ +\item{x}{An object of class \code{summary.ddml_rep}.} + +\item{digits}{Number of significant digits. Default 3.} + +\item{...}{Currently unused.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Print Summary for ddml_rep Objects +} diff --git a/man/sub-sub-.ddml_rep.Rd b/man/sub-sub-.ddml_rep.Rd new file mode 100644 index 0000000..bdbc5e3 --- /dev/null +++ b/man/sub-sub-.ddml_rep.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{[[.ddml_rep} +\alias{[[.ddml_rep} +\title{Extract a Single Fit from a ddml_rep Object} +\usage{ +\method{[[}{ddml_rep}(x, i) +} +\arguments{ +\item{x}{A \code{ddml_rep} object.} + +\item{i}{Integer index of the fit to extract.} +} +\value{ +The \code{i}-th \code{ddml} fit. +} +\description{ +Extract a Single Fit from a ddml_rep Object +} +\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) +coef(reps[[1]]) +} + +} diff --git a/man/summary.ddml_rep.Rd b/man/summary.ddml_rep.Rd new file mode 100644 index 0000000..a1af08c --- /dev/null +++ b/man/summary.ddml_rep.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{summary.ddml_rep} +\alias{summary.ddml_rep} +\title{Summary for ddml_rep Objects} +\usage{ +\method{summary}{ddml_rep}(object, aggregation = c("median", "mean"), type = "HC1", ...) +} +\arguments{ +\item{object}{A \code{ddml_rep} object.} + +\item{aggregation}{Character string, either +\code{"median"} (default) or \code{"mean"}.} + +\item{type}{Character string specifying the +variance-covariance estimator. One of \code{"HC1"} +(default), \code{"HC0"}, or \code{"HC3"}.} + +\item{...}{Currently unused.} +} +\value{ +An object of class \code{"summary.ddml_rep"}. +} +\description{ +Summary for 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), + sample_folds = 2, + resamples = 3, silent = TRUE) +summary(reps) +summary(reps, aggregation = "mean") +} + +} diff --git a/man/tidy.ddml.Rd b/man/tidy.ddml.Rd index d9ae766..e51b6e4 100644 --- a/man/tidy.ddml.Rd +++ b/man/tidy.ddml.Rd @@ -65,6 +65,10 @@ Other ddml: \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, \code{\link{ddml_plm}()}, -\code{\link{glance.ddml}()} +\code{\link{ddml_rep}()}, +\code{\link{ddml_replicate}()}, +\code{\link{glance.ddml}()}, +\code{\link{glance.ddml_rep}()}, +\code{\link{tidy.ddml_rep}()} } \concept{ddml} diff --git a/man/tidy.ddml_rep.Rd b/man/tidy.ddml_rep.Rd new file mode 100644 index 0000000..e027aef --- /dev/null +++ b/man/tidy.ddml_rep.Rd @@ -0,0 +1,79 @@ +% 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"), + type = "HC1", + conf.int = FALSE, + conf.level = 0.95, + ... +) +} +\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} to +return results for all ensemble types.} + +\item{aggregation}{Character string, either +\code{"median"} (default) or \code{"mean"}.} + +\item{type}{Character string specifying the +variance-covariance estimator. One of \code{"HC1"} +(default), \code{"HC0"}, or \code{"HC3"}.} + +\item{conf.int}{Logical. Include confidence interval +columns? Default \code{FALSE}.} + +\item{conf.level}{Confidence level for intervals. +Default 0.95.} + +\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}. If +\code{conf.int = TRUE}, also \code{conf.low} and +\code{conf.high}. +} +\description{ +Extracts aggregated coefficient estimates, standard +errors, test statistics, and p-values from a +\code{ddml_rep} object in a format compatible with +\pkg{modelsummary} and the \pkg{broom} ecosystem. +} +\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{ +Other ddml: +\code{\link{ddml_ate}()}, +\code{\link{ddml_fpliv}()}, +\code{\link{ddml_late}()}, +\code{\link{ddml_pliv}()}, +\code{\link{ddml_plm}()}, +\code{\link{ddml_rep}()}, +\code{\link{ddml_replicate}()}, +\code{\link{glance.ddml}()}, +\code{\link{glance.ddml_rep}()}, +\code{\link{tidy.ddml}()} +} +\concept{ddml} diff --git a/man/vcov.ddml_rep.Rd b/man/vcov.ddml_rep.Rd new file mode 100644 index 0000000..c9d25b9 --- /dev/null +++ b/man/vcov.ddml_rep.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{vcov.ddml_rep} +\alias{vcov.ddml_rep} +\title{Variance-Covariance Matrix for ddml_rep Objects} +\usage{ +\method{vcov}{ddml_rep}( + object, + ensemble_idx = 1, + aggregation = c("median", "mean"), + type = "HC1", + ... +) +} +\arguments{ +\item{object}{A \code{ddml_rep} object.} + +\item{ensemble_idx}{Integer index of the ensemble type. +Defaults to 1.} + +\item{aggregation}{Character string, either +\code{"median"} (default) or \code{"mean"}.} + +\item{type}{Character string specifying the +variance-covariance estimator. One of \code{"HC1"} +(default), \code{"HC0"}, or \code{"HC3"}.} + +\item{...}{Currently unused.} +} +\value{ +A diagonal p x p variance-covariance matrix. +} +\description{ +Returns a diagonal variance-covariance matrix from +cross-resample 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) +vcov(reps) +} + +} diff --git a/tests/testthat/test-ddml_rep.R b/tests/testthat/test-ddml_rep.R new file mode 100644 index 0000000..afbab89 --- /dev/null +++ b/tests/testthat/test-ddml_rep.R @@ -0,0 +1,351 @@ +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 + cf <- coef(reps) + expect_true(is.numeric(cf)) + expect_length(cf, 1) + + # coef with mean aggregation differs from median + cf_mean <- coef(reps, aggregation = "mean") + expect_true(is.numeric(cf_mean)) + + # Aggregated coef is within range of per-resample coefs + per_rep_coefs <- sapply(seq_len(3), + function(i) coef(reps[[i]])) + expect_true(cf >= min(per_rep_coefs) - 0.01) + expect_true(cf <= max(per_rep_coefs) + 0.01) + + # vcov + V <- vcov(reps) + expect_true(is.matrix(V)) + expect_equal(dim(V), c(1, 1)) + 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(1, 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$inf_results)) + expect_equal(dim(s$inf_results)[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") + %in% colnames(td))) + expect_equal(nrow(td), 1) + + # 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") + + # 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("aggregation formulas are 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) + + reps <- ddml_replicate(ddml_plm, + y = y, D = D, X = X, + learners = list(what = ols), + sample_folds = 2, + resamples = 5, + silent = TRUE) + + # Extract per-resample coefs and SEs manually + R <- 5 + coefs <- sapply(seq_len(R), function(i) coef(reps[[i]])) + ses <- sapply(seq_len(R), function(i) { + V <- vcov(reps[[i]]) + sqrt(diag(V)) + }) + + # Median aggregation + expected_coef_med <- median(coefs) + var_total_med <- ses^2 + (coefs - expected_coef_med)^2 + expected_se_med <- sqrt(median(var_total_med)) + + actual_coef_med <- coef(reps, aggregation = "median") + s_med <- summary(reps, aggregation = "median") + actual_se_med <- s_med$inf_results[1, 2, 1] + + expect_equal(actual_coef_med, expected_coef_med, + tolerance = 1e-10) + expect_equal(actual_se_med, expected_se_med, + tolerance = 1e-10) + + # Mean aggregation + expected_coef_mean <- mean(coefs) + var_total_mean <- ses^2 + (coefs - expected_coef_mean)^2 + expected_se_mean <- sqrt( + length(var_total_mean) / sum(1 / var_total_mean)) + + actual_coef_mean <- coef(reps, aggregation = "mean") + s_mean <- summary(reps, aggregation = "mean") + actual_se_mean <- s_mean$inf_results[1, 2, 1] + + expect_equal(actual_coef_mean, expected_coef_mean, + tolerance = 1e-10) + expect_equal(actual_se_mean, expected_se_mean, + tolerance = 1e-10) +}) + +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)) +}) From fea189970334ded74ac16cb2d860ea468cabd00e Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Thu, 5 Mar 2026 10:37:11 -0600 Subject: [PATCH 13/46] cleanup aggregation + new vignettes --- R/ddml_ate.R | 7 +- R/ddml_att.R | 7 +- R/ddml_fpliv.R | 6 +- R/ddml_late.R | 7 +- R/ddml_pliv.R | 6 +- R/ddml_plm.R | 6 +- R/ddml_rep.R | 89 ++++--- R/help_functions.R | 3 +- R/inference_functions.R | 8 +- R/methods.R | 10 +- README.Rmd | 11 +- README.md | 24 +- _pkgdown.yml | 3 + man/coef.ddml_rep.Rd | 6 +- tests/testthat/test-ddml_plm.R | 103 ++++++++ vignettes/articles/did.Rmd | 224 +++++++++++------- vignettes/articles/did.Rmd.txt | 96 +++++--- vignettes/articles/example_401k.Rmd | 183 ++++++++------ vignettes/articles/example_401k.Rmd.txt | 72 ++++-- vignettes/articles/example_BLP95.Rmd | 62 ++--- vignettes/articles/example_BLP95.Rmd.txt | 18 +- .../articles/figures/unnamed-chunk-11-1.png | Bin 19668 -> 23116 bytes .../articles/figures/unnamed-chunk-12-1.png | Bin 10347 -> 11637 bytes .../articles/figures/unnamed-chunk-4-1.png | Bin 19661 -> 23083 bytes .../articles/figures/unnamed-chunk-5-1.png | Bin 10334 -> 11667 bytes .../articles/figures/unnamed-chunk-8-1.png | Bin 17816 -> 23124 bytes .../articles/figures/unnamed-chunk-9-1.png | Bin 9021 -> 11240 bytes .../articles/modelsummary_integration.Rmd | 224 ++++++++++++++++++ .../articles/modelsummary_integration.Rmd.txt | 177 ++++++++++++++ vignettes/articles/repeated_resampling.Rmd | 223 +++++++++++++++++ .../articles/repeated_resampling.Rmd.txt | 196 +++++++++++++++ vignettes/articles/sparse.Rmd | 28 +-- vignettes/articles/stacking.Rmd | 26 +- vignettes/articles/stacking.Rmd.txt | 8 +- vignettes/articles/stacking_diagnostics.Rmd | 210 ++++++++++++++++ .../articles/stacking_diagnostics.Rmd.txt | 127 ++++++++++ vignettes/ddml.Rmd | 134 +++++++++-- vignettes/ddml.Rmd.txt | 79 +++++- vignettes/precompile.R | 14 +- 39 files changed, 1993 insertions(+), 404 deletions(-) create mode 100644 vignettes/articles/modelsummary_integration.Rmd create mode 100644 vignettes/articles/modelsummary_integration.Rmd.txt create mode 100644 vignettes/articles/repeated_resampling.Rmd create mode 100644 vignettes/articles/repeated_resampling.Rmd.txt create mode 100644 vignettes/articles/stacking_diagnostics.Rmd create mode 100644 vignettes/articles/stacking_diagnostics.Rmd.txt diff --git a/R/ddml_ate.R b/R/ddml_ate.R index b233260..75b09da 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -246,7 +246,6 @@ ddml_ate <- function(y, D, X, D * (y - g1) / m - (1 - D) * (y - g0) / (1 - m) + g1 - g0, nobs, 1) ate <- mean(psi_b) - names(ate) <- ensemble_type psi_a <- matrix(-1, nobs, 1) } else { y_copy <- matrix(rep(y, nensb), nobs, nensb) @@ -255,7 +254,6 @@ ddml_ate <- function(y, D, X, (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 psi_a <- matrix(-1, nobs, nensb) }#IFELSE @@ -267,6 +265,9 @@ ddml_ate <- function(y, D, X, as.matrix(mean(psi_a[, j])) }) coef_names <- "ATE" + coef <- matrix(ate, nrow = 1, ncol = nensb) + rownames(coef) <- coef_names + colnames(coef) <- ensemble_type # Ensemble metrics weights <- list(y_X_D0 = y_X_D0_res$weights, @@ -309,7 +310,7 @@ ddml_ate <- function(y, D, X, cv_subsamples_byD = indxs$cv_subsamples_byD, ensemble_type = ensemble_type, - coefficients = ate, + coefficients = coef, scores = scores, J = J_list, coef_names = coef_names, diff --git a/R/ddml_att.R b/R/ddml_att.R index 26e3e09..0ed3571 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -123,7 +123,6 @@ ddml_att <- function(y, D, X, nobs, 1) psi_a <- matrix(-D / p, nobs, 1) att <- -mean(psi_b) / mean(psi_a) - names(att) <- ensemble_type } else { y_copy <- matrix(rep(y, nensb), nobs, nensb) D_copy <- matrix(rep(D, nensb), nobs, nensb) @@ -133,7 +132,6 @@ ddml_att <- function(y, D, X, (p_copy * (1 - m_X_tr)) psi_a <- -D_copy / p_copy att <- -colMeans(psi_b) / colMeans(psi_a) - names(att) <- ensemble_type }#IFELSE # Compute scores and Jacobian from psi_a/psi_b @@ -144,6 +142,9 @@ ddml_att <- function(y, D, X, as.matrix(mean(psi_a[, j])) }) coef_names <- "ATT" + coef <- matrix(att, nrow = 1, ncol = nensb) + rownames(coef) <- coef_names + colnames(coef) <- ensemble_type # Ensemble metrics weights <- list(y_X_D0 = y_X_D0_res$weights, @@ -181,7 +182,7 @@ ddml_att <- function(y, D, X, cv_subsamples_byD = indxs$cv_subsamples_byD, ensemble_type = ensemble_type, - coefficients = att, + coefficients = coef, scores = scores, J = J_list, coef_names = coef_names, diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index fb0e57d..1e5c34e 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -235,7 +235,9 @@ ddml_fpliv <- function(y, D, Z, X, iv_fit <- AER::ivreg(y_r ~ D_r | V_r) # Organize complementary ensemble output - coef <- stats::coef(iv_fit)[-1] + coef_vec <- stats::coef(iv_fit)[-1] + coef <- matrix(coef_vec, nrow = nD, ncol = 1) + colnames(coef) <- ensemble_type # Compute scores and Jacobian D_r_mat <- as.matrix(D_r) @@ -244,7 +246,7 @@ ddml_fpliv <- function(y, D, Z, X, e <- as.vector(y_r - D_r_mat %*% coef) scores <- list(D_hat * e) J_list <- list(-crossprod(D_hat, D_r_mat) / nobs) - coef_names <- names(coef) + coef_names <- names(coef_vec) }#IF # If multiple ensembles are calculated, iterate over each type. diff --git a/R/ddml_late.R b/R/ddml_late.R index 48c9816..7bceaac 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -328,7 +328,6 @@ ddml_late <- function(y, D, Z, X, -(Z * (D - p1) / r - (1 - Z) * (D - p0) / (1 - r) + p1 - p0), nobs, 1) late <- -mean(psi_b) / mean(psi_a) - names(late) <- ensemble_type } else { y_copy <- matrix(rep(y, nensb), nobs, nensb) D_copy <- matrix(rep(D, nensb), nobs, nensb) @@ -340,7 +339,6 @@ ddml_late <- function(y, D, Z, X, (1 - Z_copy) * (D_copy - p_X_byZ[, , 1]) / (1 - r_X_tr) + p_X_byZ[, , 2] - p_X_byZ[, , 1]) late <- -colMeans(psi_b) / colMeans(psi_a) - names(late) <- ensemble_type }#IFELSE # Compute scores and Jacobian from psi_a/psi_b @@ -351,6 +349,9 @@ ddml_late <- function(y, D, Z, X, as.matrix(mean(psi_a[, j])) }) coef_names <- "LATE" + coef <- matrix(late, nrow = 1, ncol = nensb) + rownames(coef) <- coef_names + colnames(coef) <- ensemble_type # Ensemble metrics weights <- list(y_X_Z0 = y_X_Z0_res$weights, @@ -406,7 +407,7 @@ ddml_late <- function(y, D, Z, X, cv_subsamples_byZ = indxs$cv_subsamples_byD, ensemble_type = ensemble_type, - coefficients = late, + coefficients = coef, scores = scores, J = J_list, coef_names = coef_names, diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index 0528e79..d89bb2d 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -229,7 +229,9 @@ ddml_pliv <- function(y, D, Z, X, iv_fit <- AER::ivreg(y_r ~ D_r | V_r) # Organize complementary ensemble output - coef <- stats::coef(iv_fit)[-1] + coef_vec <- stats::coef(iv_fit)[-1] + coef <- matrix(coef_vec, nrow = nD, ncol = 1) + colnames(coef) <- ensemble_type # Compute scores and Jacobian D_r_mat <- as.matrix(D_r) @@ -238,7 +240,7 @@ ddml_pliv <- function(y, D, Z, X, e <- as.vector(y_r - D_r_mat %*% coef) scores <- list(D_hat * e) J_list <- list(-crossprod(D_hat, D_r_mat) / nobs) - coef_names <- names(coef) + coef_names <- names(coef_vec) }#IF # If multiple ensembles are calculated, iterate over each type. diff --git a/R/ddml_plm.R b/R/ddml_plm.R index abed68b..3d8e189 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -287,14 +287,16 @@ ddml_plm <- function(y, D, X, ols_fit <- stats::lm(y_r ~ D_r) # Organize complementary ensemble output - coef <- stats::coef(ols_fit)[-1] + coef_vec <- stats::coef(ols_fit)[-1] + coef <- matrix(coef_vec, nrow = nD, ncol = 1) + colnames(coef) <- ensemble_type # Compute scores and Jacobian D_r_mat <- as.matrix(D_r) e <- as.vector(y_r - D_r_mat %*% coef) scores <- list(D_r_mat * e) J_list <- list(-crossprod(D_r_mat) / nobs) - coef_names <- names(coef) + coef_names <- names(coef_vec) }#IF # If multiple ensembles are calculated, iterate over each type. diff --git a/R/ddml_rep.R b/R/ddml_rep.R index f2f31c3..73fcb6b 100644 --- a/R/ddml_rep.R +++ b/R/ddml_rep.R @@ -1,31 +1,5 @@ # Internal helpers ----------------------------------------------- -# Extract SEs from a single ddml fit. -extract_se <- function(object, type = "HC1") { - nensb <- length(object$scores) - p <- length(object$coef_names) - se_mat <- matrix(0, p, nensb) - for (j in seq_len(nensb)) { - V <- compute_ddml_variance( - object$scores[[j]], object$J[[j]], - object$cluster_variable, type = type) - se_mat[, j] <- sqrt(diag(V)) - }#FOR - se_mat -}#EXTRACT_SE - -# Ensure coefficients are always a p x nensb matrix. -normalize_coef_matrix <- function(coefficients, p, nensb) { - if (is.matrix(coefficients)) { - return(coefficients) - }#IF - if (p == 1) { - matrix(coefficients, nrow = 1, ncol = nensb) - } else { - matrix(coefficients, nrow = p, ncol = 1) - }#IFELSE -}#NORMALIZE_COEF_MATRIX - # Build inference results array from aggregated coef/SE. build_inf_from_agg <- function(agg, coef_names, ensemble_type) { @@ -60,31 +34,50 @@ aggregate_reps <- function(object, aggregation = "median", p <- length(object$coef_names) coef_array <- array(0, dim = c(p, nensb, R)) - se_array <- array(0, dim = c(p, nensb, R)) + vcov_array <- array(0, dim = c(p, p, nensb, R)) for (r in seq_len(R)) { fit <- object$fits[[r]] - coef_array[, , r] <- normalize_coef_matrix( - fit$coefficients, p, nensb) - se_array[, , r] <- extract_se(fit, type = type) + coef_array[, , r] <- fit$coefficients + for (j in seq_len(nensb)) { + vcov_array[, , j, r] <- compute_ddml_variance( + fit$scores[[j]], fit$J[[j]], + fit$cluster_variable, type = type) + }#FOR }#FOR + agg_vcov <- array(0, dim = c(p, p, nensb)) if (aggregation == "median") { agg_coef <- apply(coef_array, c(1, 2), stats::median) - var_total <- se_array^2 + - sweep(coef_array, c(1, 2), agg_coef)^2 - agg_se <- sqrt(apply(var_total, c(1, 2), - stats::median)) } else { agg_coef <- apply(coef_array, c(1, 2), mean) - var_total <- se_array^2 + - sweep(coef_array, c(1, 2), agg_coef)^2 - agg_se <- sqrt(apply(var_total, c(1, 2), - function(x) length(x) / sum(1 / x))) }#IFELSE + for (j in seq_len(nensb)) { + for (k1 in seq_len(p)) { + for (k2 in seq_len(p)) { + bdiff_1 <- coef_array[k1, j, ] - agg_coef[k1, j] + bdiff_2 <- coef_array[k2, j, ] - agg_coef[k2, j] + Vvec <- vcov_array[k1, k2, j, ] + abs(bdiff_1 * bdiff_2) + if (aggregation == "median") { + agg_vcov[k1, k2, j] <- stats::median(Vvec) + } else { + agg_vcov[k1, k2, j] <- length(Vvec) / sum(1 / Vvec) + }#IFELSE + }#FOR + }#FOR + }#FOR + + agg_se <- matrix(0, nrow = p, ncol = nensb) + for (j in seq_len(nensb)) { + 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, - coef_array = coef_array, se_array = se_array) + vcov = agg_vcov, coef_array = coef_array, + vcov_array = vcov_array) }#AGGREGATE_REPS # Exported functions --------------------------------------------- @@ -339,8 +332,9 @@ print.ddml_rep <- function(x, ...) { #' Extract Aggregated Coefficients from a ddml_rep Object #' #' @param object A \code{ddml_rep} object. -#' @param ... Additional arguments. Supports -#' \code{aggregation} (\code{"median"} or \code{"mean"}). +#' @param aggregation Character string, either +#' \code{"median"} (default) or \code{"mean"}. +#' @param ... Additional arguments. #' #' @return Named vector (single ensemble) or matrix #' (multiple ensembles). @@ -376,8 +370,8 @@ coef.ddml_rep <- function(object, #' Variance-Covariance Matrix for ddml_rep Objects #' -#' Returns a diagonal variance-covariance matrix from -#' cross-resample aggregation. +#' Returns a variance-covariance matrix from cross-resample +#' aggregation. #' #' @param object A \code{ddml_rep} object. #' @param ensemble_idx Integer index of the ensemble type. @@ -389,7 +383,7 @@ coef.ddml_rep <- function(object, #' (default), \code{"HC0"}, or \code{"HC3"}. #' @param ... Currently unused. #' -#' @return A diagonal p x p variance-covariance matrix. +#' @return A p x p variance-covariance matrix. #' #' @examples #' \donttest{ @@ -413,8 +407,11 @@ vcov.ddml_rep <- function(object, ensemble_idx = 1, agg <- aggregate_reps(object, aggregation = aggregation, type = type) - se_j <- agg$se[, ensemble_idx] - V <- diag(se_j^2, nrow = length(se_j)) + V <- agg$vcov[, , ensemble_idx] + if (!is.matrix(V)) { + V <- matrix(V, nrow = length(object$coef_names), + ncol = length(object$coef_names)) + }#IF rownames(V) <- colnames(V) <- object$coef_names V }#VCOV.DDML_REP diff --git a/R/help_functions.R b/R/help_functions.R index 9dd59da..57ba46d 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -113,11 +113,12 @@ build_CEF_from_crossfit <- function(y, crossfit_fitted_eq, oos_fitted <- matrix(0, nobs, 1) all_weights <- vector("list", K) for (k in seq_len(K)) { + train_idx <- setdiff(seq_len(nobs), subsamples[[k]]) fakecv_k <- list( oos_resid = crossval_resid[[k]], mspe = colMeans(crossval_resid[[k]]^2)) ew_k <- ensemble_weights( - y[subsamples[[k]]], cf[subsamples[[k]], ], + y[train_idx], cf[train_idx, ], type = ensemble_type, learners = dummy_learners, cv_results = fakecv_k, diff --git a/R/inference_functions.R b/R/inference_functions.R index a4b9756..5ef3765 100644 --- a/R/inference_functions.R +++ b/R/inference_functions.R @@ -43,16 +43,12 @@ compute_ddml_inference <- function(coefficients, scores, J, cluster_variable = NULL, type = "HC1") { nensb <- length(ensemble_type) - p <- NCOL(scores[[1]]) + p <- nrow(coefficients) inf_results <- array(0, dim = c(p, 4, nensb)) for (j in seq_len(nensb)) { - if (is.matrix(coefficients)) { - theta_j <- coefficients[, j] - } else { - theta_j <- coefficients[j] - }#IFELSE + theta_j <- coefficients[, j] V <- compute_ddml_variance(scores[[j]], J[[j]], cluster_variable, diff --git a/R/methods.R b/R/methods.R index 550a58f..669e472 100644 --- a/R/methods.R +++ b/R/methods.R @@ -23,6 +23,9 @@ coef.ddml <- function(object, ...) { cf <- object$coefficients if (is.matrix(cf) && ncol(cf) == 1) { cf <- drop(cf) + if (length(cf) == 1) { + names(cf) <- NULL + }#IF }#IF cf }#COEF.DDML @@ -92,12 +95,7 @@ vcov.ddml <- function(object, ensemble_idx = 1, confint.ddml <- function(object, parm, level = 0.95, ensemble_idx = 1, type = "HC1", ...) { - cf <- object$coefficients - if (is.matrix(cf)) { - cf <- cf[, ensemble_idx] - } else { - cf <- cf[ensemble_idx] - }#IFELSE + cf <- object$coefficients[, ensemble_idx] V <- vcov(object, ensemble_idx = ensemble_idx, type = type) diff --git a/README.Rmd b/README.Rmd index efbdb0a..868168f 100644 --- a/README.Rmd +++ b/README.Rmd @@ -68,9 +68,9 @@ X = AE98[, c("age","agefst","black","hisp","othrace","educ")] # Estimate the local average treatment effect using short-stacking with base # learners ols, rlasso, 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 +86,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")`` discusses integration with the diff-in-diff package [``did``](https://bcallaway11.github.io/did/) For additional applied examples, see our case studies: diff --git a/README.md b/README.md index 6cd4acd..2e8da1d 100644 --- a/README.md +++ b/README.md @@ -84,9 +84,9 @@ learners: # Estimate the local average treatment effect using short-stacking with base # learners ols, rlasso, 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 t value Pr(>|t|) +#> LATE -0.220 0.187 -1.18 0.24 ``` ## Learn More about `ddml` @@ -107,6 +108,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 @@ -141,7 +148,8 @@ 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 872e1f8..bf0c426 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -77,6 +77,9 @@ articles: contents: - ddml - articles/stacking + - articles/stacking_diagnostics + - articles/repeated_resampling + - articles/modelsummary_integration - articles/new_ml_wrapper - articles/sparse - articles/did diff --git a/man/coef.ddml_rep.Rd b/man/coef.ddml_rep.Rd index 4f21387..20ae346 100644 --- a/man/coef.ddml_rep.Rd +++ b/man/coef.ddml_rep.Rd @@ -9,8 +9,10 @@ \arguments{ \item{object}{A \code{ddml_rep} object.} -\item{...}{Additional arguments. Supports -\code{aggregation} (\code{"median"} or \code{"mean"}).} +\item{aggregation}{Character string, either +\code{"median"} (default) or \code{"mean"}.} + +\item{...}{Additional arguments.} } \value{ Named vector (single ensemble) or matrix diff --git a/tests/testthat/test-ddml_plm.R b/tests/testthat/test-ddml_plm.R index 0fcdca8..560c0fb 100644 --- a/tests/testthat/test-ddml_plm.R +++ b/tests/testthat/test-ddml_plm.R @@ -403,6 +403,109 @@ test_that("ddml_plm fitted pass-through works", { ) }) +test_that("ddml_plm pass-through with nnls/nnls1 reproduces exactly via crossval_resid", { + 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) + splits <- list( + subsamples = presplits$subsamples, + cv_subsamples = presplits$cv_subsamples) + + 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) + + # crossval_resid must be stored for exact reproduction + expect_true( + !is.null(fit_fresh$fitted$y_X$crossval_resid), + info = paste(ens, "y_X crossval_resid")) + + # 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) + splits <- list( + subsamples = presplits$subsamples, + cv_subsamples = presplits$cv_subsamples) + + # Fit with save_crossval = FALSE strips crossval_resid + 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$crossval_resid) + + # average ensemble: still exact without crossval_resid + 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 legacy split args warn and still work", { set.seed(101) nobs <- 200 diff --git a/vignettes/articles/did.Rmd b/vignettes/articles/did.Rmd index 67ac322..bd4b603 100644 --- a/vignettes/articles/did.Rmd +++ b/vignettes/articles/did.Rmd @@ -22,7 +22,8 @@ For illustration, consider the data of Callaway and Sant'Anna (2020) on county-l ```r -# Load the did package +# Load ddml and did +library(ddml) library(did) set.seed(588239) @@ -85,7 +86,7 @@ The ``did`` package offers visualization methods using ``gglpot2``: ```r -ggdid(attgt_lm, ylim = c(-.4, .4)) +ggdid(attgt_lm) ```

@@ -126,7 +127,7 @@ summary(dyn_lm) #> #> Control Group: Never Treated, Anticipation Periods: 0 #> Estimation Method: Doubly Robust -ggdid(dyn_lm, ylim = c(-.4, .4)) +ggdid(dyn_lm) ```
@@ -134,7 +135,7 @@ ggdid(dyn_lm, ylim = c(-.4, .4))

Dynamic Treatment Effect Estimates.

-# Contructing a ``xgboost``-based Diff-in-Diff Estimator +# Constructing 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. @@ -152,8 +153,8 @@ This two-step approach allows for cleaner code when considering multiple ddml-ba The below code-snippet constructs a simple estimation method following step 1: ```r -# load the ddml package -library(ddml) +# Initialize a global list to store fits for diagnostic inspection +global_ddml_fits <- list() # write a general wrapper for ddml_att ddml_did_method <- function(y1, y0, D, covariates, ...) { @@ -161,6 +162,10 @@ ddml_did_method <- function(y1, y0, D, covariates, ...) { delta_y <- y1 - y0 # Compute the ATT att_fit <- ddml_att(y = delta_y, D = D, X = covariates, ...) + + # Store the fit in the global list + global_ddml_fits[[length(global_ddml_fits) + 1]] <<- att_fit + # 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) @@ -175,8 +180,8 @@ A potentially suitable machine learning reduced form estimator is gradient tree 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), + args = list(nround = 50, + params = list(eta = 0.1, max_depth = 3), early_stopping_rounds = 1)) learners_DX = learners @@ -184,7 +189,7 @@ my_did_xgboost <- function(y1, y0, D, covariates, ...) { ddml_did_method(y1, y0, D, covariates, learners = learners, learners_DX = learners_DX, - sample_folds = 10, + sample_folds = 5, silent = TRUE) }#MY_DID_XGBOOST ``` @@ -213,26 +218,26 @@ summary(attgt_xgboost) #> #> Group-Time Average Treatment Effects: #> Group Time ATT(g,t) Std. Error [95% Simult. Conf. Band] -#> 2004 2004 -3.1503 7.2324 -20.7101 14.4095 -#> 2004 2005 -9.3142 11.6485 -37.5962 18.9677 -#> 2004 2006 -2.4850 11.1398 -29.5317 24.5617 -#> 2004 2007 17.8616 13.8177 -15.6868 51.4101 -#> 2006 2004 12.5594 6.1206 -2.3011 27.4200 -#> 2006 2005 6.0290 3.8927 -3.4222 15.4802 -#> 2006 2006 -1.1808 3.7726 -10.3405 7.9789 -#> 2006 2007 -4.7042 10.0708 -29.1554 19.7469 -#> 2007 2004 -2.8007 14.3252 -37.5814 31.9799 -#> 2007 2005 6.4227 16.4851 -33.6021 46.4476 -#> 2007 2006 2.6596 17.5628 -39.9817 45.3009 -#> 2007 2007 -15.0061 20.3873 -64.5052 34.4929 +#> 2004 2004 -0.4859 1.9087 -5.1543 4.1825 +#> 2004 2005 0.0885 2.2336 -5.3745 5.5515 +#> 2004 2006 0.3182 0.8942 -1.8690 2.5054 +#> 2004 2007 3.1768 1.9115 -1.4985 7.8521 +#> 2006 2004 -0.0792 0.1078 -0.3427 0.1844 +#> 2006 2005 0.1491 0.1388 -0.1905 0.4887 +#> 2006 2006 0.0698 0.1348 -0.2599 0.3995 +#> 2006 2007 -0.1889 0.2324 -0.7573 0.3795 +#> 2007 2004 -0.0321 0.0577 -0.1731 0.1090 +#> 2007 2005 0.3086 0.1650 -0.0949 0.7121 +#> 2007 2006 -0.0739 0.1595 -0.4641 0.3163 +#> 2007 2007 0.0403 0.3692 -0.8626 0.9433 #> --- #> Signif. codes: `*' confidence band does not cover 0 #> -#> P-value for pre-test of parallel trends assumption: 0.46872 +#> P-value for pre-test of parallel trends assumption: 0.17498 #> Control Group: Never Treated, Anticipation Periods: 0 # plot the coefficients -ggdid(attgt_xgboost, ylim = c(-.4, .4)) +ggdid(attgt_xgboost) ```
@@ -255,24 +260,24 @@ summary(dyn_xgboost) #> #> #> Overall summary of ATT's based on event-study/dynamic aggregation: -#> ATT Std. Error [ 95% Conf. Int.] -#> -0.4334 6.6254 -13.419 12.5522 +#> ATT Std. Error [ 95% Conf. Int.] +#> 0.8475 0.6729 -0.4713 2.1663 #> #> #> Dynamic Effects: #> Event time Estimate Std. Error [95% Simult. Conf. Band] -#> -3 -2.8007 14.6781 -34.8946 29.2931 -#> -2 7.8582 12.8711 -20.2846 36.0011 -#> -1 3.4478 13.6719 -26.4462 33.3417 -#> 0 -10.8693 15.3861 -44.5113 22.7726 -#> 1 -6.2409 8.0050 -23.7441 11.2623 -#> 2 -2.4850 11.2198 -27.0174 22.0474 -#> 3 17.8616 12.8811 -10.3031 46.0263 +#> -3 -0.0321 0.0568 -0.1609 0.0967 +#> -2 0.2179 0.1337 -0.0853 0.5211 +#> -1 -0.0217 0.1200 -0.2939 0.2504 +#> 0 -0.0086 0.3829 -0.8769 0.8597 +#> 1 -0.0964 0.8577 -2.0416 1.8487 +#> 2 0.3182 0.8646 -1.6425 2.2788 +#> 3 3.1768 2.0440 -1.4587 7.8122 #> --- #> Signif. codes: `*' confidence band does not cover 0 #> #> Control Group: Never Treated, Anticipation Periods: 0 -ggdid(dyn_xgboost, ylim = c(-.4, .4)) +ggdid(dyn_xgboost) ```
@@ -286,7 +291,7 @@ Given these two coefficients, is there a good reason to choose one over the othe 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. -# Contructing a Shortstacking-based Diff-in-Diff Estimator +# Constructing 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. @@ -296,48 +301,48 @@ We construct a new wrapper for our ``ddml_did_method`` that hard-codes different - gradient tree boosting with more and less regularization - random forests with more and less regularization -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")`). +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")``). ```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), + learners = list(list(what = ols), + list(what = mdl_xgboost, + args = list(nround = 50, + params = list(eta = 0.1, max_depth = 1), early_stopping_rounds = 1)), - list(fun = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 3), + list(what = mdl_xgboost, + args = list(nround = 50, + params = list(eta = 0.1, 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))) + list(what = mdl_ranger, + args = list(num.trees = 100, + max.depth = 5)), + list(what = mdl_ranger, + args = list(num.trees = 100, + max.depth = 10))) # 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), + learners_DX = list(list(what = mdl_glm), + list(what = mdl_xgboost, + args = list(nround = 50, + params = list(eta = 0.1, max_depth = 1), early_stopping_rounds = 1)), - list(fun = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 3), + list(what = mdl_xgboost, + args = list(nround = 50, + params = list(eta = 0.1, 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))) + list(what = mdl_ranger, + args = list(num.trees = 100, + max.depth = 5)), + list(what = mdl_ranger, + args = list(num.trees = 100, + max.depth = 10))) # 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, + sample_folds = 5, ensemble_type = "nnls", shortstack = TRUE, silent = TRUE) @@ -348,6 +353,9 @@ Finally, we recompute the group-time average treatment effects using our shortst ```r +# Clear the global fits list from the previous xgboost runs +global_ddml_fits <- list() + # estimate group-time average treatment effects with ddml attgt_stacking <- att_gt(yname = "lemp", gname = "first.treat", @@ -368,26 +376,26 @@ summary(attgt_stacking) #> #> Group-Time Average Treatment Effects: #> Group Time ATT(g,t) Std. Error [95% Simult. Conf. Band] -#> 2004 2004 -0.0110 0.0228 -0.0718 0.0498 -#> 2004 2005 -0.0761 0.0311 -0.1588 0.0066 -#> 2004 2006 -0.1408 0.0400 -0.2473 -0.0343 * -#> 2004 2007 -0.1051 0.0350 -0.1982 -0.0120 * -#> 2006 2004 -0.0040 0.0219 -0.0624 0.0544 -#> 2006 2005 -0.0067 0.0194 -0.0584 0.0449 -#> 2006 2006 -0.0010 0.0196 -0.0532 0.0512 -#> 2006 2007 -0.0409 0.0197 -0.0934 0.0115 -#> 2007 2004 0.0234 0.0141 -0.0141 0.0609 -#> 2007 2005 -0.0026 0.0159 -0.0450 0.0398 -#> 2007 2006 -0.0299 0.0178 -0.0772 0.0175 -#> 2007 2007 -0.0285 0.0166 -0.0728 0.0158 +#> 2004 2004 -0.0121 0.0233 -0.0738 0.0495 +#> 2004 2005 -0.0800 0.0305 -0.1606 0.0007 +#> 2004 2006 -0.1404 0.0385 -0.2419 -0.0389 * +#> 2004 2007 -0.1085 0.0355 -0.2022 -0.0148 * +#> 2006 2004 -0.0007 0.0207 -0.0552 0.0538 +#> 2006 2005 -0.0070 0.0189 -0.0570 0.0429 +#> 2006 2006 0.0002 0.0203 -0.0533 0.0538 +#> 2006 2007 -0.0372 0.0202 -0.0905 0.0161 +#> 2007 2004 0.0212 0.0127 -0.0123 0.0546 +#> 2007 2005 -0.0025 0.0151 -0.0423 0.0372 +#> 2007 2006 -0.0296 0.0169 -0.0743 0.0151 +#> 2007 2007 -0.0277 0.0166 -0.0715 0.0160 #> --- #> Signif. codes: `*' confidence band does not cover 0 #> -#> P-value for pre-test of parallel trends assumption: 0.27165 +#> P-value for pre-test of parallel trends assumption: 0.33819 #> Control Group: Never Treated, Anticipation Periods: 0 # plot the coefficients -ggdid(attgt_stacking, ylim = c(-.4, .4)) +ggdid(attgt_stacking) ```
@@ -412,23 +420,23 @@ summary(dyn_stacking) #> #> Overall summary of ATT's based on event-study/dynamic aggregation: #> ATT Std. Error [ 95% Conf. Int.] -#> -0.0799 0.0202 -0.1194 -0.0403 * +#> -0.0801 0.0203 -0.12 -0.0403 * #> #> #> Dynamic Effects: #> Event time Estimate Std. Error [95% Simult. Conf. Band] -#> -3 0.0234 0.0134 -0.0109 0.0577 -#> -2 -0.0029 0.0132 -0.0366 0.0307 -#> -1 -0.0245 0.0135 -0.0589 0.0100 -#> 0 -0.0209 0.0122 -0.0520 0.0103 -#> 1 -0.0527 0.0161 -0.0938 -0.0115 * -#> 2 -0.1408 0.0378 -0.2373 -0.0444 * -#> 3 -0.1051 0.0331 -0.1897 -0.0206 * +#> -3 0.0212 0.0148 -0.0166 0.0589 +#> -2 -0.0021 0.0126 -0.0343 0.0301 +#> -1 -0.0243 0.0145 -0.0613 0.0127 +#> 0 -0.0202 0.0120 -0.0508 0.0103 +#> 1 -0.0514 0.0160 -0.0923 -0.0106 * +#> 2 -0.1404 0.0416 -0.2466 -0.0342 * +#> 3 -0.1085 0.0330 -0.1928 -0.0241 * #> --- #> Signif. codes: `*' confidence band does not cover 0 #> #> Control Group: Never Treated, Anticipation Periods: 0 -ggdid(dyn_stacking, ylim = c(-.4, .4)) +ggdid(dyn_stacking) ```
@@ -436,6 +444,52 @@ ggdid(dyn_stacking, ylim = c(-.4, .4))

Stacking-based Dynamic Treatment Effect Estimates.

+# Stacking Diagnostics for Group-Time Effects + +Because the ``did`` package encapsulates the estimation of each group-time cell dynamically, the resulting ``MP`` object does not natively return the underlying ``ddml`` model estimators for inspection. + +However, because we stored the intermediate fits in the ``global_ddml_fits`` list inside our ``ddml_did_method`` wrapper, we can easily run stacking diagnostics on any specific cell. + +For example, let's look at the diagnostics for the ``(g=2004, t=2006)`` cell (which is the third group-time cell evaluated by the shortstacking estimator): + + +```r +# Extract the ddml_att fit computed for Group 2004 at Time 2006 +cell_fit <- global_ddml_fits[[3]] + +# Run stacking diagnostics on the computed cell, enabling CVC testing +print(diagnostics(cell_fit, cvc = TRUE)) +#> Stacking diagnostics: Average Treatment Effect on the Treated +#> Obs: 329 +#> +#> y_X_D0: +#> learner mspe r2 weight cvc_pval +#> learner_1 0.0662 8e-04 0.3048 0.958 +#> learner_2 0.0662 8e-04 0.0184 0.002 +#> learner_3 0.0662 8e-04 0.0000 0.000 +#> learner_4 0.0662 8e-04 0.0000 0.272 +#> learner_5 0.0662 8e-04 0.0000 0.464 +#> +#> D_X: +#> learner mspe r2 weight cvc_pval +#> learner_1 0.057 0.0043 0.9216 0.930 +#> learner_2 0.057 0.0043 0.0506 0.000 +#> learner_3 0.057 0.0043 0.0000 0.000 +#> learner_4 0.057 0.0043 0.0000 0.400 +#> learner_5 0.057 0.0043 0.0000 0.598 +#> +#> Note: CVC compares individual base learners. +#> Shortstacked ensemble CVC is not available (weights use all data). +``` + +This diagnostic output displays the cross-validated Mean Squared Prediction Error (MSPE), the out-of-sample $R^2$, the non-negative least squares (NNLS) weights assigned to each base learner, and the CVC p-value. + +**How to Interpret These Metrics to Guide Learner Choice:** + +1. **$R^2$**: Evaluates the proportion of variance explained by each learner out-of-sample. Because these are computed on hold-out folds, negative values can occur and indicate that a learner performs worse than a simple constant mean prediction (often a sign of severe overfitting or algorithmic mismatch). +2. **Weights**: The short-stacking algorithm assigns weights to optimally combine the learners and minimize the overall MSPE. Learners with $0$ weight do not contribute to the final predictions because their predictive power is either poor or entirely subsumed by other models in the ensemble. +3. **CVC P-Values**: The ``cvc_pval`` column shows the p-value from a Cross-Validation Criteria test (Ahrens et al. 2024), comparing each learner's MSPE against the MSPE of the single-best ML model in the list. A high p-value (e.g. > 0.05) indicates that the learner's predictive performance is not statistically worse than the best learner. If simple linear models (e.g., ``ols``) show high p-values, it implies machine learning does not significantly improve prediction out-of-sample for this specific parameter, which can legally justify reverting to simpler, faster estimators. +4. **Actionable Efficiency**: If your diagnostic output consistently assigns $0$ weight, negative $R^2$, and $0.000$ CVC p-values to computationally expensive models (like deep random forests), you can safely remove them from the ``learners`` list in future runs to dramatically reduce computation time without sacrificing accuracy. # References diff --git a/vignettes/articles/did.Rmd.txt b/vignettes/articles/did.Rmd.txt index 6490635..ec90441 100644 --- a/vignettes/articles/did.Rmd.txt +++ b/vignettes/articles/did.Rmd.txt @@ -30,7 +30,8 @@ For an excellent introduction to differences-in-differences with multiple time p 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). ```{r} -# Load the did package +# Load ddml and did +library(ddml) library(did) set.seed(588239) @@ -57,7 +58,7 @@ 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)) +ggdid(attgt_lm) ``` Further, the group-time average treatment effects can easily be aggregated, for example, to estimate dynamic average treatment effects: @@ -66,10 +67,10 @@ Further, the group-time average treatment effects can easily be aggregated, for # aggregate the group-time average treatment effects dyn_lm <- aggte(attgt_lm, type = "dynamic") summary(dyn_lm) -ggdid(dyn_lm, ylim = c(-.4, .4)) +ggdid(dyn_lm) ``` -# Contructing a ``xgboost``-based Diff-in-Diff Estimator +# Constructing 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. @@ -86,8 +87,8 @@ This two-step approach allows for cleaner code when considering multiple ddml-ba The below code-snippet constructs a simple estimation method following step 1: ```{r} -# load the ddml package -library(ddml) +# Initialize a global list to store fits for diagnostic inspection +global_ddml_fits <- list() # write a general wrapper for ddml_att ddml_did_method <- function(y1, y0, D, covariates, ...) { @@ -95,6 +96,10 @@ ddml_did_method <- function(y1, y0, D, covariates, ...) { delta_y <- y1 - y0 # Compute the ATT att_fit <- ddml_att(y = delta_y, D = D, X = covariates, ...) + + # Store the fit in the global list + global_ddml_fits[[length(global_ddml_fits) + 1]] <<- att_fit + # 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) @@ -108,8 +113,8 @@ A potentially suitable machine learning reduced form estimator is gradient tree 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), + args = list(nround = 50, + params = list(eta = 0.1, max_depth = 3), early_stopping_rounds = 1)) learners_DX = learners @@ -117,7 +122,7 @@ my_did_xgboost <- function(y1, y0, D, covariates, ...) { ddml_did_method(y1, y0, D, covariates, learners = learners, learners_DX = learners_DX, - sample_folds = 10, + sample_folds = 5, silent = TRUE) }#MY_DID_XGBOOST ``` @@ -138,7 +143,7 @@ attgt_xgboost <- att_gt(yname = "lemp", summary(attgt_xgboost) # plot the coefficients -ggdid(attgt_xgboost, ylim = c(-.4, .4)) +ggdid(attgt_xgboost) ``` 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: @@ -147,7 +152,7 @@ Of course, use of the ``ddml``-based reduced form estimator still allows us to l # aggregate the group-time average treatment effects dyn_xgboost <- aggte(attgt_xgboost, type = "dynamic") summary(dyn_xgboost) -ggdid(dyn_xgboost, ylim = c(-.4, .4)) +ggdid(dyn_xgboost) ``` @@ -157,7 +162,7 @@ Given these two coefficients, is there a good reason to choose one over the othe 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. -# Contructing a Shortstacking-based Diff-in-Diff Estimator +# Constructing 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. @@ -167,47 +172,47 @@ We construct a new wrapper for our ``ddml_did_method`` that hard-codes different - gradient tree boosting with more and less regularization - random forests with more and less regularization -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")`). +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")``). ```{r} my_did_stacking <- function(y1, y0, D, covariates, ...) { # Hard-code learners for outcome reduced-form learners = list(list(what = ols), list(what = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 1), + args = list(nround = 50, + params = list(eta = 0.1, max_depth = 1), early_stopping_rounds = 1)), list(what = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 3), + args = list(nround = 50, + params = list(eta = 0.1, max_depth = 3), early_stopping_rounds = 1)), list(what = mdl_ranger, - args = list(num.trees = 1000, - max.depth = 1)), + args = list(num.trees = 100, + max.depth = 5)), list(what = mdl_ranger, - args = list(num.trees = 1000, - max.depth = 20))) + args = list(num.trees = 100, + max.depth = 10))) # Hard-code learners for treatment reduced-form learners_DX = list(list(what = mdl_glm), list(what = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 1), + args = list(nround = 50, + params = list(eta = 0.1, max_depth = 1), early_stopping_rounds = 1)), list(what = mdl_xgboost, - args = list(nround = 500, - params = list(eta = 0.05, max_depth = 3), + args = list(nround = 50, + params = list(eta = 0.1, max_depth = 3), early_stopping_rounds = 1)), list(what = mdl_ranger, - args = list(num.trees = 1000, - max.depth = 1)), + args = list(num.trees = 100, + max.depth = 5)), list(what = mdl_ranger, - args = list(num.trees = 1000, - max.depth = 20))) + args = list(num.trees = 100, + max.depth = 10))) # 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, + sample_folds = 5, ensemble_type = "nnls", shortstack = TRUE, silent = TRUE) @@ -217,6 +222,9 @@ my_did_stacking <- function(y1, y0, D, covariates, ...) { 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."} +# Clear the global fits list from the previous xgboost runs +global_ddml_fits <- list() + # estimate group-time average treatment effects with ddml attgt_stacking <- att_gt(yname = "lemp", gname = "first.treat", @@ -230,7 +238,7 @@ attgt_stacking <- att_gt(yname = "lemp", summary(attgt_stacking) # plot the coefficients -ggdid(attgt_stacking, ylim = c(-.4, .4)) +ggdid(attgt_stacking) ``` 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!) @@ -240,10 +248,34 @@ Other settings, in particular settings with multiple control variables, may show # aggregate the group-time average treatment effects dyn_stacking <- aggte(attgt_stacking, type = "dynamic") summary(dyn_stacking) -ggdid(dyn_stacking, ylim = c(-.4, .4)) +ggdid(dyn_stacking) ``` +# Stacking Diagnostics for Group-Time Effects + +Because the ``did`` package encapsulates the estimation of each group-time cell dynamically, the resulting ``MP`` object does not natively return the underlying ``ddml`` model estimators for inspection. + +However, because we stored the intermediate fits in the ``global_ddml_fits`` list inside our ``ddml_did_method`` wrapper, we can easily run stacking diagnostics on any specific cell. + +For example, let's look at the diagnostics for the ``(g=2004, t=2006)`` cell (which is the third group-time cell evaluated by the shortstacking estimator): + +```{r} +# Extract the ddml_att fit computed for Group 2004 at Time 2006 +cell_fit <- global_ddml_fits[[3]] + +# Run stacking diagnostics on the computed cell, enabling CVC testing +print(diagnostics(cell_fit, cvc = TRUE)) +``` + +This diagnostic output displays the cross-validated Mean Squared Prediction Error (MSPE), the out-of-sample $R^2$, the non-negative least squares (NNLS) weights assigned to each base learner, and the CVC p-value. + +**How to Interpret These Metrics to Guide Learner Choice:** + +1. **$R^2$**: Evaluates the proportion of variance explained by each learner out-of-sample. Because these are computed on hold-out folds, negative values can occur and indicate that a learner performs worse than a simple constant mean prediction (often a sign of severe overfitting or algorithmic mismatch). +2. **Weights**: The short-stacking algorithm assigns weights to optimally combine the learners and minimize the overall MSPE. Learners with $0$ weight do not contribute to the final predictions because their predictive power is either poor or entirely subsumed by other models in the ensemble. +3. **CVC P-Values**: The ``cvc_pval`` column shows the p-value from a Cross-Validation Criteria test (Ahrens et al. 2024), comparing each learner's MSPE against the MSPE of the single-best ML model in the list. A high p-value (e.g. > 0.05) indicates that the learner's predictive performance is not statistically worse than the best learner. If simple linear models (e.g., ``ols``) show high p-values, it implies machine learning does not significantly improve prediction out-of-sample for this specific parameter, which can legally justify reverting to simpler, faster estimators. +4. **Actionable Efficiency**: If your diagnostic output consistently assigns $0$ weight, negative $R^2$, and $0.000$ CVC p-values to computationally expensive models (like deep random forests), you can safely remove them from the ``learners`` list in future runs to dramatically reduce computation time without sacrificing accuracy. # References diff --git a/vignettes/articles/example_401k.Rmd b/vignettes/articles/example_401k.Rmd index 3757df2..0c8295a 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}). @@ -59,15 +59,15 @@ 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, + args = list(nrounds = 50)), + sample_folds = 5, silent = TRUE) summary(xgboost_fit) #> DDML estimation: Partially Linear Model -#> Obs: 9915 Folds: 10 +#> Obs: 9915 Folds: 5 #> #> Estimate Std. Error t value Pr(>|t|) -#> D_r 12780 1526 8.38 <2e-16 *** +#> D_r 13916 1544 9.01 <2e-16 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 @@ -112,32 +112,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, + sample_folds = 5, shortstack = TRUE, silent = TRUE) summary(stacking_fit) #> DDML estimation: Partially Linear Model -#> Obs: 9915 Folds: 10 Stacking: short-stack +#> Obs: 9915 Folds: 5 Stacking: short-stack #> #> Estimate Std. Error t value Pr(>|t|) -#> D_r 13700 1523 8.99 <2e-16 *** +#> D_r 13602 1550 8.77 <2e-16 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` @@ -147,11 +147,11 @@ To better understand which machine learners contribute to the final estimate, we ```r sapply(stacking_fit$weights, round, 4) #> y_X D1_X -#> [1,] 0.2186 0.2850 +#> [1,] 0.2394 0.2865 #> [2,] 0.0000 0.0000 -#> [3,] 0.1822 0.3859 -#> [4,] 0.6671 0.2911 -#> [5,] 0.0000 0.0548 +#> [3,] 0.1096 0.1720 +#> [4,] 0.7020 0.5387 +#> [5,] 0.0383 0.0164 #> [6,] 0.0000 0.0000 ``` @@ -177,40 +177,40 @@ 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, + sample_folds = 5, shortstack = TRUE, silent = TRUE) summary(stacking_fit) #> DDML estimation: Partially Linear Model -#> Obs: 9915 Folds: 10 Stacking: short-stack +#> Obs: 9915 Folds: 5 Stacking: short-stack #> #> Estimate Std. Error t value Pr(>|t|) -#> D_r 14133 1480 9.55 <2e-16 *** +#> D_r 14008 1463 9.57 <2e-16 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` @@ -221,13 +221,13 @@ To assess whether the additional effort in expanding the control variables had a ```r sapply(stacking_fit$weights, round, 4) #> y_X D1_X -#> [1,] 0.0000 0.0115 -#> [2,] 0.0593 0.2018 -#> [3,] 0.7312 0.3289 -#> [4,] 0.0000 0.1304 -#> [5,] 0.2274 0.3153 -#> [6,] 0.0134 0.0205 -#> [7,] 0.0000 0.0000 +#> [1,] 0.0000 0.0968 +#> [2,] 0.0000 0.3466 +#> [3,] 0.7371 0.0000 +#> [4,] 0.1001 0.1537 +#> [5,] 0.1557 0.3304 +#> [6,] 0.0662 0.0483 +#> [7,] 0.0000 0.0333 ``` # Estimation with Continious and Binary Outcome and Treatment Variables @@ -239,28 +239,28 @@ Equipped with the included ``mdl_glm`` wrapper for generalized linear models (se ```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 @@ -268,15 +268,15 @@ stacking_fit <- ddml_plm(y = y, D = D, X = X_c, learners = learners, learners_DX = learners_DX, ensemble_type = "nnls", - sample_folds = 10, + sample_folds = 5, shortstack = TRUE, silent = TRUE) summary(stacking_fit) #> DDML estimation: Partially Linear Model -#> Obs: 9915 Folds: 10 Stacking: short-stack +#> Obs: 9915 Folds: 5 Stacking: short-stack #> #> Estimate Std. Error t value Pr(>|t|) -#> D_r 14163 1484 9.54 <2e-16 *** +#> D_r 13945 1491 9.35 <2e-16 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` @@ -288,15 +288,46 @@ The weights associated with the new base learners are now slightly larger: ```r sapply(stacking_fit$weights, round, 4) #> y_X D1_X -#> [1,] 0.0000 0.0539 -#> [2,] 0.0000 0.3156 -#> [3,] 0.7097 0.1155 -#> [4,] 0.0403 0.3328 -#> [5,] 0.2102 0.1297 -#> [6,] 0.0818 0.0643 +#> [1,] 0.0974 0.0426 +#> [2,] 0.0000 0.3245 +#> [3,] 0.7681 0.0000 +#> [4,] 0.0000 0.1538 +#> [5,] 0.1674 0.4265 +#> [6,] 0.0000 0.0622 #> [7,] 0.0000 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 computed ``crossval_resid`` and ``crossfit_fitted`` objects for the specified learners, we can bypass the estimation step entirely. + + +```r +# Extract the predictions and residuals from the previous fit +advanced_passthrough <- list( + crossfit_fitted = stacking_fit$fitted$crossfit_fitted, + crossval_resid = stacking_fit$fitted$crossval_resid +) + +# 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 = advanced_passthrough, # Pass the predictions directly + silent = TRUE +) +#> Error in validate_fitted_splits_pair(fitted, splits, w_cv): Argument 'splits' must be supplied when 'fitted' is supplied. +summary(stacking_refit) +#> Error in eval(expr, envir, enclos): object 'stacking_refit' not found +``` + # Bonus: Instrumental Variable Estimation Instead of considering the partially linear regression model, we may also be interested in an instrumental variable approach. A commonly used instrument for participation in a 401k is 401k _eligibility_. @@ -314,28 +345,28 @@ 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, + sample_folds = 5, shortstack = TRUE, silent = TRUE) summary(stacking_IV_fit) #> DDML estimation: Partially Linear IV Model -#> Obs: 9915 Folds: 10 Stacking: short-stack +#> Obs: 9915 Folds: 5 Stacking: short-stack #> #> Estimate Std. Error t value Pr(>|t|) -#> D_r 12711 1892 6.72 1.8e-11 *** +#> D_r 12899 1915 6.73 1.6e-11 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 # Stacking weights associated with each base learner sapply(stacking_IV_fit$weights, round, 4) #> y_X D1_X Z1_X -#> [1,] 0.0000 0.0190 0.0000 -#> [2,] 0.0000 0.1696 0.4500 -#> [3,] 0.8302 0.2829 0.0000 -#> [4,] 0.0000 0.2693 0.3186 -#> [5,] 0.1681 0.2410 0.2291 -#> [6,] 0.0290 0.0188 0.0000 -#> [7,] 0.0000 0.0105 0.0131 +#> [1,] 0.0236 0.0439 0.0000 +#> [2,] 0.5938 0.3279 0.3792 +#> [3,] 0.1051 0.0620 0.0000 +#> [4,] 0.0000 0.0000 0.0387 +#> [5,] 0.3113 0.5625 0.5855 +#> [6,] 0.0000 0.0000 0.0000 +#> [7,] 0.0000 0.0077 0.0000 ``` diff --git a/vignettes/articles/example_401k.Rmd.txt b/vignettes/articles/example_401k.Rmd.txt index 1f5c0e0..e46b262 100644 --- a/vignettes/articles/example_401k.Rmd.txt +++ b/vignettes/articles/example_401k.Rmd.txt @@ -34,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}). @@ -63,8 +63,8 @@ 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, + args = list(nrounds = 50)), + sample_folds = 5, silent = TRUE) summary(xgboost_fit) @@ -84,21 +84,21 @@ The estimate is nearly identical to the estimate using just gradient boosting. learners <- list(list(what = ols), list(what = mdl_glmnet), list(what = mdl_ranger, - args = list(num.trees = 250, + args = list(num.trees = 100, max.depth = 4)), list(what = mdl_ranger, - args = list(num.trees = 250, - max.depth = 12)), + args = list(num.trees = 100, + max.depth = 8)), list(what = mdl_xgboost, - args = list(nrounds = 100)), + args = list(nrounds = 50)), list(what = mdl_xgboost, - args = list(nrounds = 300))) + 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, + sample_folds = 5, shortstack = TRUE, silent = TRUE) summary(stacking_fit) @@ -136,25 +136,25 @@ learners <- list(list(what = ols, list(what = mdl_glmnet, assign_X = X_extended), list(what = mdl_ranger, - args = list(num.trees = 250, + args = list(num.trees = 100, max.depth = 4), assign_X = X_baseline), list(what = mdl_ranger, - args = list(num.trees = 250, - max.depth = 12), + args = list(num.trees = 100, + max.depth = 8), assign_X = X_baseline), list(what = mdl_xgboost, - args = list(nrounds = 100), + args = list(nrounds = 50), assign_X = X_baseline), list(what = mdl_xgboost, - args = list(nrounds = 300), + 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, + sample_folds = 5, shortstack = TRUE, silent = TRUE) summary(stacking_fit) @@ -184,18 +184,18 @@ learners_DX <- list(list(what = mdl_glm, args = list(family = "binomial"), assign_X = X_extended), list(what = mdl_ranger, - args = list(num.trees = 250, + args = list(num.trees = 100, max.depth = 4), assign_X = X_baseline), list(what = mdl_ranger, - args = list(num.trees = 250, - max.depth = 12), + args = list(num.trees = 100, + max.depth = 8), assign_X = X_baseline), list(what = mdl_xgboost, - args = list(nrounds = 100), + args = list(nrounds = 50), assign_X = X_baseline), list(what = mdl_xgboost, - args = list(nrounds = 300), + args = list(nrounds = 150), assign_X = X_baseline)) # PLM with short-stacking and different sets of learners @@ -203,7 +203,7 @@ stacking_fit <- ddml_plm(y = y, D = D, X = X_c, learners = learners, learners_DX = learners_DX, ensemble_type = "nnls", - sample_folds = 10, + sample_folds = 5, shortstack = TRUE, silent = TRUE) summary(stacking_fit) @@ -216,6 +216,34 @@ The weights associated with the new base learners are now slightly larger: sapply(stacking_fit$weights, round, 4) ``` +# 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 computed ``crossval_resid`` and ``crossfit_fitted`` objects for the specified learners, we can bypass the estimation step entirely. + +```{r} +# Extract the predictions and residuals from the previous fit +advanced_passthrough <- list( + crossfit_fitted = stacking_fit$fitted$crossfit_fitted, + crossval_resid = stacking_fit$fitted$crossval_resid +) + +# 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 = advanced_passthrough, # Pass the predictions directly + silent = TRUE +) +summary(stacking_refit) +``` + # Bonus: Instrumental Variable Estimation Instead of considering the partially linear regression model, we may also be interested in an instrumental variable approach. A commonly used instrument for participation in a 401k is 401k _eligibility_. @@ -232,7 +260,7 @@ 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, + sample_folds = 5, shortstack = TRUE, silent = TRUE) summary(stacking_IV_fit) diff --git a/vignettes/articles/example_BLP95.Rmd b/vignettes/articles/example_BLP95.Rmd index 360e3a9..fa7275b 100644 --- a/vignettes/articles/example_BLP95.Rmd +++ b/vignettes/articles/example_BLP95.Rmd @@ -148,14 +148,14 @@ learner <- list(what = mdl_glmnet) lasso_fit <- ddml_fpliv(y, D = D, Z = ZL, X = XL, learners = learner, - sample_folds = 10, + sample_folds = 5, silent = TRUE) summary(lasso_fit) #> DDML estimation: Flexible Partially Linear IV Model -#> Obs: 2217 Folds: 10 +#> Obs: 2217 Folds: 5 #> #> Estimate Std. Error t value Pr(>|t|) -#> D_r -0.14723 0.00901 -16.3 <2e-16 *** +#> D_r -0.14501 0.00885 -16.4 <2e-16 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` @@ -175,27 +175,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)) @@ -205,14 +205,14 @@ stacking_fit <- ddml_fpliv(y, D = D, learners = learners, ensemble_type = c("nnls1"), shortstack = TRUE, - sample_folds = 10, + sample_folds = 5, silent = TRUE) summary(stacking_fit) #> DDML estimation: Flexible Partially Linear IV Model -#> Obs: 2217 Folds: 10 Stacking: short-stack +#> Obs: 2217 Folds: 5 Stacking: short-stack #> #> Estimate Std. Error t value Pr(>|t|) -#> D_r -0.08145 0.00764 -10.7 <2e-16 *** +#> D_r -0.10240 0.00867 -11.8 <2e-16 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` @@ -225,11 +225,11 @@ To better understand the composition of the final estimator, it is often useful sapply(stacking_fit$weights, round, 4) #> y_X D1_X D1_XZ #> [1,] 0.0000 0.0000 0.0000 -#> [2,] 0.0002 0.0000 0.0000 +#> [2,] 0.0000 0.0000 0.0000 #> [3,] 0.0000 0.0000 0.0000 -#> [4,] 0.0000 0.0000 0.0000 -#> [5,] 0.4305 0.4593 0.3068 -#> [6,] 0.5693 0.5407 0.6932 +#> [4,] 0.0000 0.0138 0.0000 +#> [5,] 0.3786 0.5434 0.4844 +#> [6,] 0.6214 0.4429 0.5156 ``` # Elasticities @@ -259,16 +259,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] 598 +#> [1] 635 # ddml-stacking implied number of products with inelastic demand compute_inelastic_demand(stacking_fit$coef) -#> [1] 1608 +#> [1] 1362 ``` # Bonus: Post-Lasso Estimates without Sample-Splitting @@ -291,7 +291,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. @@ -304,14 +304,14 @@ 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, @@ -319,14 +319,14 @@ stacking_r_fit <- ddml_fpliv(y, D = D, learners = learner, ensemble_type = c("nnls1"), shortstack = TRUE, - sample_folds = 10, + sample_folds = 5, silent = TRUE) summary(stacking_r_fit) #> DDML estimation: Flexible Partially Linear IV Model -#> Obs: 2217 Folds: 10 Stacking: short-stack +#> Obs: 2217 Folds: 5 Stacking: short-stack #> #> Estimate Std. Error t value Pr(>|t|) -#> D_r -0.1079 0.0104 -10.4 <2e-16 *** +#> D_r -0.115 0.010 -11.5 <2e-16 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` @@ -337,8 +337,8 @@ The similarity of the coefficient estimates to the initial stacking estimates su ```r sapply(stacking_r_fit$weights, round, 4) #> y_X D1_X D1_XZ -#> [1,] 0.3116 0.1618 0.0621 -#> [2,] 0.6884 0.8382 0.9379 +#> [1,] 0.2647 0.1262 0.0555 +#> [2,] 0.7353 0.8738 0.9445 ``` 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. diff --git a/vignettes/articles/example_BLP95.Rmd.txt b/vignettes/articles/example_BLP95.Rmd.txt index 256491e..57beddd 100644 --- a/vignettes/articles/example_BLP95.Rmd.txt +++ b/vignettes/articles/example_BLP95.Rmd.txt @@ -137,7 +137,7 @@ learner <- list(what = mdl_glmnet) lasso_fit <- ddml_fpliv(y, D = D, Z = ZL, X = XL, learners = learner, - sample_folds = 10, + sample_folds = 5, silent = TRUE) summary(lasso_fit) ``` @@ -171,12 +171,12 @@ learners <- list(list(what = ols, # ols with the baseline set assign_X = set_XL, assign_Z = set_ZL), list(what = mdl_ranger, # random forests with the baseline set - args = list(num.trees = 1000, + args = list(num.trees = 100, min.node.size = 10), assign_X = set_X, assign_Z = set_Z), list(what = mdl_xgboost, # boosted trees with the baseline set - args = list(nrounds = 300), + args = list(nrounds = 50), assign_X = set_X, assign_Z = set_Z)) @@ -186,7 +186,7 @@ stacking_fit <- ddml_fpliv(y, D = D, learners = learners, ensemble_type = c("nnls1"), shortstack = TRUE, - sample_folds = 10, + sample_folds = 5, silent = TRUE) summary(stacking_fit) ``` @@ -219,7 +219,7 @@ 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) @@ -242,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. @@ -252,13 +252,13 @@ 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(what = ols), list(what = mdl_xgboost, - args = list(nrounds = 300))) + args = list(nrounds = 50))) # Compute short-stacked IV estimate stacking_r_fit <- ddml_fpliv(y, D = D, @@ -266,7 +266,7 @@ stacking_r_fit <- ddml_fpliv(y, D = D, learners = learner, ensemble_type = c("nnls1"), shortstack = TRUE, - sample_folds = 10, + sample_folds = 5, silent = TRUE) summary(stacking_r_fit) ``` diff --git a/vignettes/articles/figures/unnamed-chunk-11-1.png b/vignettes/articles/figures/unnamed-chunk-11-1.png index 268220b1b5d54486fb68104f824d1a5457a73a88..ec9dfe916842fd108d32b5b97c2105f96827f51f 100644 GIT binary patch literal 23116 zcmeHv2V9fM)^`dBhyscNDv(&gr70GamWTyb5!77;q**8;kkEUHB9=uUiik)PQPBlN zKnXPwTnGXI1!)EdHK8Llkorx6yZhev?%uoi{oQ-N`@P@h_lU{NnKRGKGjnFn{LlZn zb;8VeN@E|wc5q!wSWN@_7Qzu;#2XuRJ;?l5L|eHdMcmF=l7Fe^plJGTfjx`2clEpn(Ck8_w)Hfp%o(e@G!CRhCq}n1^=L!559&F2omz`p#$FsB#(9R<81sx8SHJ>pRRDr ze&JOfBtWX%2uI{PwTXy?Ot}_E&e$C>$%|kLz`X zmSmbYX8Hyh)(?Bz8OIu*zR9}uY1ce^f%|=U8U^~O(rpLl&8_V?F6J~b+?Cli_>{2Z)UcT}_Tmx9iYI9}eVeYafPPv-7&i)`r4^Ey zfE9UrB1ocUk{5L6c0xB+lgKbr#|;l}MfzKFFKLp(=A&Z6UoTXVoeAICxhY%lt77FF zKLyRHP~^2p=jK#&NH*N`MXj)a`FL7TKUb2r61Q=76@IW96*|g!JISNBgfC=LCOIv! zdkH2DX+O^OB{9NZE8zVfYH&c(f8m$&Y~=Qx~X&~mex^>U4g3rHBt^L%kS2(?6TcM zDlaz3(^HukpWQFBnAzORy$fL8ZeB2;~YSf4|5kabjraZtlk26fb5qa#c$uBsv}CACCM z@|+@zWkO}zxiBuyVM@nwYr0MI7FF*=S0-%_5?4C6hPAwg^A3S!WGpJgrr_$s3)p@W z6v|!46BC6KOjaAch~O=zaHAXMRk*;Px#ay6G8+1<1dO1yd&{> zYMGgtT0~a07Mpv7v@q4jE@QU2eKrIB3P)cuo6jhK2-uQ4a zqKrz@VRg|rgt9X!>7|q_^0eeh1FtYkG(^hh9Nb0>{Wnv43me4b@;`ZlRm-h(z4e@@~-ib(=F{5%uqC!j_dN_+G+ecwNa{k-IKEY`~~Nv4T|6<_r%M};NWuzd`s6+tsKOs zuw1fU-UR01mshtcrjxY1-jrR*TiB?nY;~5VxoSzWG$+i>;7oZ?YxB=@nijaMrS%6I zCqMAVPg-F`0m>~KCJCgLaZ35AI@7XlpWd7~f-R@JYID-4ybSKxkO4BQrEKof++WY` z7JY-u;plD`;uq?;iVv4FN#vKewB^F5J-of0xmi)ha&kKtTh(ANkD_jPK4$~}*ra@z z^9+I4GKuO8@(6xIW-c4(B(f`&_qOPg;`4}uo>L|>by!|FC?ZiV=1^Q4CH)Zl<{bA@ zRo^r6$n_fQ8I@%NPyHDPQh_(Ey^u=5c3~KOb4_>XM`^5R9K^ryrI8SSI?xvqIS$Wew_3i*-a;-%UVSE=PS z<1G|m=ZkKq!}GhYQbsG2B!l7kG1c?3o{bulBo@6i$#rCT%{#i^ZE%y-ClQCVL>#)V zwnpD7Re~;>u}435>uK1H&qoa9Y^Eq#g68iB&0l14TJMv(T+#Qr0pnar`#h#g8RN9; z8pM6EbL1&|lOhz-!c)GLWnfyU=~sq7frk7z%RjTNPPF`2>qEzheM}&H)7@Fj86aqb zLGcY&%)wXIVdmLp1fLV%Y=k~)-rp7ak+$d^ZlTBPYYu3%|C|@v^B((56$v>V!}OcT z&FO9kox8qO9(L+iyEND*DPf%^mhbZ60G2Uvzz0{iZUFw&%-lXno@QRoJ+m!qHYAw) zaw`?NJxVBz1Y{Gx#jIi{#19dCtsX?$T5EozF6W? zHXyUq_AhL97ZvF_6|)+@cmvhlU_7%^Sr3}XcVdor5-=KNVg7nZEv~C~8P{(@uiWK= zhd=YEq;Uf&5eHEm+6Ucl&EYS+o7C`|&%(O-@i1t)SiCyXY39nQsN6v3sfv@R0RL{O z8g^Dcwvblsz);TiU14aWKQW!t78b~hl#g}e6$vz1LW{qV&w{^2{*Jl%R#F_YdE;L% z>hW39HKuWp)MbBTf&U$qe_(rXdk<12!DB5=8h30pFuLI9;j_>k%KwtO{=iPKVRi|&ev79PsK9z;j8eYKc}O;xS4?_i%SGXEMPvDOn$m&A{~9JF;FY=frz)0Z{-d?-YH*@>sG7rnOEJHkcRjT$T`M-uz`RZ0ApuUmD0{)!^* z3@-d)XDJ_}k$Vz-X_wA}XK(_S>spry%S{dN_4Z|)9&K+0t#cRXA1b8r#$vZ24W+NW zd$7T@xdj^xJ%6LPVz-2NIVk$|Hnt#V8#>QDybJ3)xWy=Oz3F!+&><^MeseIwrB>pm zbbgeh(~jdip;ITH7vEm->|69u%AF+z+Cl|KmNg3$)SP>G0oG?_SzN#3*>)AAo!IKS z504Nk2_MKz>E$;q9%pLr8M=Y9xqA5C`_7)5F$;)f+y_1Hh|R0<+EJ=;#TBb0OcIy! zM4r@ds&&A49D<#4TIHy%vu_i0d%;cZ#0`pfaQCbZCDyNuF+ta=KQ^T=Gv0!9lsmcY z{}(mYlfuzCj6^z`b(zxlhQYKq!cNgYQ5-PoD>UP9_x7jlO0-sur~}>7z%ZrD)%IwE zZk^d5R~)HbWC}z>8vYdhvj@KRKr&ZtU+3u%RFK0V;qVc!xunAa2(Gd#279VB;r0$l$SetBp#8+TOU`!P*U|!0oc9lIKDA@$U*o(G9+s# z^!w!UarUbT19o_-l8j7=@Ch}y!=@LG$l}>;pQW$9hHJapbeWU4{E{^kG&7q;&%=Ae zjC6uk?^QT1UuohU4Kqsm%jbPjqNcpX_EaNcLE*n-M{6JlozLe;iT~Uvb!dkwQOe-} zddTVPU70M#4|zj-WrTxdcL`4a>v9FF-1u`p>@StbpTm?{V=L5+wdN=CCv(C}MkW-*pBX(lF&HGW7gqVNJ&92kQkQqSNZ?+k`T=%A~Hj2!)>PB(CPJZc|0R?huUX=7ny_ zQSD!T#^HV)Qjqv!{#)l~7gfz?28`SLBuVu9FIn1qQY5XydphTT0T6uA@jlR!l3hbM>^ zLQUGk#sWQVf{FJn5D^Y(frxPW2t)*9Vw<3<|0hMneZ3?O^0R$*W|+c^RH2Ehchzn| zzU>j&5{H9C$l}4V=uMcHMcDQ`W`CNt+DZ+btmHqv*g?bceHDDrz5_M$jQoP*N9B^r(wz z91I&c8ru$_wS^{KL(S7q&%xWfKYM#4#XlzJ z#Su`A1~SQHcWk6vsc%@uA@sSUB3r=Led0~pXFY#;Ik5CP)B-#1TB-#M>jQD1{XVYK zx@+qkr<;t%*cNd&B6qBXX$J}S=qOcWaBAe-LiidMNL~e!Go)&c^!g&}7)}PIY&^>b zeeN5PYf>$_htg0)tALX=UlYVg@~s7>laanzozl=Nw`62=6^nrTMGeyFPKwfd{gBD9 zU2yx_F+(S20+DsN&LjzO(}%bZ6)LM?jxZxJD6|%6hQaPhh%1SRsLIOdii@AvhV+q< zd1Q(nLL$*%K|FxQX+zT^aF9O>{Ow*UIHQOeN{gS8kwK&X5uDlv0el0E`W2#@ZRPv3HCC;t6NMKN^gU1 z_x?o`qM-LTaFxv~YwS7XjxpKrg*Ppc_Thnhlh$gfb4I-R6I!u+_$i7*@a z$!n@7bE&KFdHXytBvvx+cHLGnCgM8BYQO)7&Qu~UWC#1FaNT1=3HSMBQAQ!|p65T_ zYK?pEh5QzmgQe~5(Pa-%oeI-S&dW{XSpP^)Er zGi|AdRnN-Pv%(Ev+Iwxitx;=6WAJx|6*~L)ygtd)$UVAUQC`HMV_Lyp_0Yicb8Rhj zr_X(M<*ku)d(dge+d2&&Xejrv?d|6+$7+05OpN8a+MnUA8nL-I(~ZI1-j776%h$*8 z%GI&O5;ZkG4da}=c5~_ZgI*`wdKxNG>tkcdM)bg{>~&RGZL zxhgbB6M3=OfIzVb;&ndok(!8@J1#wlh>PGwj54-c&a4s}h@?x!sB~>D<@j$#W;6lO zgu=^}Z%f3O71^_Gkn6tf;U4ADZcm{5OB2h85h0Utl6LK7#3q^pxes6LPHb0RAA4{a zAu*vMx;mX-QU0MVx*CiX^+#!E(;f$>b*m#YygzjA4cGIMZ@r|ryNJ^NYMG9l7{xuE z&=wY>jYPPk2D3*+?@v^&kA^c^J0rWPUHLYxgUc8@!O#jgiBXm<_R3gcGP({PRf8c_ z)n)p1_Z>zb>3>_y9r2D*nc=V`yG=dSr4XHnFn6|{>~-HSkH;p>$UB!ga4|GzLjziw z=%rCEn$U0#x-KdLRIzwzW%N%K5$s2S63?BdVk@=1D1WCgsmQ%<;+q4buYdcE0m zec!F%)wCb!TOGlk?yzGq?Wx`difz5#!6o2~5%M?Y-M{+?a{n2$A%{Il@(K!K^<`l> z`84b-Kst$yS*Soh$66~UWb{qWB!F8u@+cccfLQK_+}Ljh%21oVQ2_)JcD9tF!|L5}DTWVGjwKoIEVg+a3u0 zq_`QW#~t!KM(gHjYH3WwvM6e$wE4a}l=0ZewqVvr$TPY)G_a`Tz?W(gMLza~IzVC5 zCSSX~i$Wzf@(1JR#-kihbti{&3MeaMqKuXI`rB#n?YIl2(!iC+SFwmB}!c8$;R_TXHAtPsG}novE9`O=0mEImGbVWx=Hu~&FN~trvx%XF;XZjA7N6XP`gbew7!s)wpIlsAlz`Nfe)LY3vvF_(s zfOG7&V0crfr!Q}a8FM44MsYpfd!i1uul@tn3UxD&yW+F2#ypr%XQO8nUhC_J8;}R# zeZJrUtp>A% zGbUe?UXGVH_qAY9H@gkJct-K%%v(^81CvlI&A}zOr`r`{HWqf6+#KMarn3Tlqn{)| zmtXd2W~W$)+D%7Z3s(Lf+Vhx4s~zZ_IM`f;^U=RaEK~A+8!=R8y%sxRGZCN`m!pCM zhu;+}>6(#kHT2`ghP*|!r?`8m)ursmq!|Y9CFX-oNX-RqQ2-lFPTHQT^Zp`elU_Hq zm{b^~$F!)Gew<)uQsg`4H!8j7bn${w<@_$Mwv{6wuk?7YVVMVZ10;Cm^p#VYnYk2y zcs@%#w$(b(&G7lfx&Mm#=p_qKABmc$s1vmYmSFbP8h<9X*^N;)Tp!bC4EH5%FEmUq zRKoi~TR-cd&sccX7=Om>sUlwi=nHUM!Wa6-Lv|zj^Vm;1Xk)|_cB@l3cft>C2N3H3 z_IRg%Q1kag6BF@rF>b^;!W_H@O_r$X=;M3D2}3)7)rXuf3&PSs!Pmk&XCkG0sdn*Dz;C;XcPcqb>i4G-C*vra1*a1y{ z*ZmhLNpMV8QfOho&*G(EuWsF)zps=s#Yw%W;FYunkmFC^q#%)P@&jCuJsa&dKt^b%uB8BnvHK13vuaeRIBsOryo7PH6 zQMm|wgb3V+bVH;oRr;>_&v!K!dnNnLWo>zx2g{-92e}2WT17+zn8XRLE}lYJ<$qoP zO(>1n-|E&62$Q=zFWDq2@(dhMeR;yH3=#k*4A3!2-1pQOv2Z$N&H0Cd`z3_V7*({$ z<~~f?kaLmXBu{(kuPN}2jBdbD(hl4Uv8~S6^cN6P{yg9z?glLh*|hPW;G`5C z_18QP_UoDgKdAQ`iJE&rwaB$@aEvc-cK}2pxmDl^1vz8V1x}LDB-mIB+@YbA;>gtk zPpNzt;e?nH6T+yXLxy}GuEFysYB3I*0 zjgynUj&p&ND1iRb1qWP0s1J;Fhpz~sKy(Qa1mpegw@U~h81Vvx>o5QnjU-HfXDI** z!PEh#VM1UKOrAfL{!9C`c^~ZOL$pcM85RuM3lo^E#3QTl#%<1$jUg9lc}?>5qSqwr zHJaa7en5#N=v)`z0_^&_88K%*+i%fwSn|H$^gYq~Nt~?c``y>UVb}co$%X`-U8!0K zwa^Lx-~)jCnBW9Cy;=ruUC_7}1iDTGz3RDn1YD=p&}i*&>$n~o7 zoYLoK$w%#9l~ogAUW}Nl4%)B5L9(j|0AezR-*H`&3}45rC7x?7T$Ho$0e)!;@g>bM z!Pbye)!-))un~m`FtHP<)FK#j} zj1Bl_&6~s1Qm_|Gv-RMuvKv(`qg&)X%Ik! z#Gm%?&*eZE5A)BO)qiM6-SWxzcrv+lX}f9iI4*9p+@YmiDITDDWOV^XD_98v0hoJM z=Id5$TD&Gq5U?Xi7jZy+-2&*t^3%R9;mXjC#;;odyz}{S$FIY?W)wZ2x3sk18i*eX zwgh27g1y1Co#mhFys$fedz-V~7_A%bzj%)vN#l2!0K!`^8-}N)oOhV08t-X4Z1fg#D>B?=kvVao;ZsO7un~;UQI?P^kS; zcYfi>Xm`%cuT>pHWA+mCC)~SkwCK(cu~hgR;K4fkt8GG#?GP9+7vaKus|qa4xYw~c zh=V9nWRs2D&v$x2uo6!^x~$AB3K;8lo4U#3^H_^BuSKqH5^gs(!Mw7Hv7_{cxIB?- zN&-(v`>=?EJNv+0L8za*Fkz(vJ~%5lJ#{i{g+tEixMG~g6=9n;i<>Y7j^s5dp%_@d zvm4s3xM5<7B%{72ZA7Nz9>OZ?qa?p&iw?sorG%A&<-1^qzIA|B_RK|QE`>KRz8Ha; zar(h$sYNRQBjJR{+)r6_`jOH0oQ^8OXo{q``~$)MRJb;?FaEV}`3m3$U&Fk1#Na;J z33d*ceifwbrauzu=2hq|<-e8|tGsR%h?Wxs^a%dnu@wdbp>n3TaBo+En4V2Y5L;IX z98HiVQyYgkcS!&)Ur86hI)4lX`X6#({#5=CGKfl&ZHy2!do%<%^pHFM)b4v4i-YVq z49>&iyWvfnnK1&Jzbs++rgxO?!9Nb){U*{Ug3J3I5{ZC2rQL+%RD~x~45x0`TiY(o zB{&yYO;uLr8Zsw&(+eo%;Tx23LYjT(>$eCF;YygPpV9)N)7YNd={Em@uV3F-bNEL6 zc!rj{VSWDyKWc+BnpnajbAOVTmw)IxbBpiQTUpsbQUW*$oH3u(C{a^nOea{nFZJPmlwudlxFmFP9U1Cgy z25(Y}*kfgx(Oj;|h$7DBtB@7(@@K+r-7(KJCR$u=FY&4*YTA7$0N(6_68UqEu~jjq zkxWH4os^6H#OubqcQqhMvtK-ZT19j=l&s7 zQCRBLJqS;<-KB}1fF|4gx^Nws_BR4im#l3ovV%Pk^+&^3p0m8c6>Fo`99fSqNP0i2 zSHm)a`%=N} zZ7ZDIbKX)+tClz6qj(YBIyoOoZ=Ru8;|jZ_eMVQv2~a`|B_+1?gNdSkk@Uj^T#($P zsv=R9UE1t<8@hO|mBs9vK^rL=6701Mt9oK@yKm9lS)`RV{xqEb#-Qz;r;;HdQw<3L zN5_ANl=x4zB)>z5{DYjW@y!BoZj#A>Klq_v1hBliK7aU2NN?1zY=K@DatIB%44^zc zHC9!cAODUni9ISwa~usO`SxZ8W_@V}D9M4CRrr*Zp+PK4_{6YY*AkRhwFKo=-kFbW zqc$$vvC~+*=3UFmt2#V)V!*WvfxUX%kW9x7cAWPiJgwYpti5{NG@a9*=8o~O+1Iq( zB%BZf+4hW&%bqwBbr#teXB&J#+?izP27-fBytZb>rMl_U92)yyNp zT^Q@3?U_uRx(<&uH5y6dQnL78%#&z~SqOK`on+MMtiYg8JX~3GNH2kEKEzt2h4O>5 za_z+idg=5AmW6z5wt*Wz8KQp@pi#VN(tMcXHOa2+0v6rcn4%kdplyk~trirF$UKW;ETKp^m=H=fQy$&+JZzN(U5|?fLp=75gVKb8E5^hTk&aBGn z3X>@hbvVCHmU#{;pqp8}q<6KA&MDv>QFg)nN(=o(mon)nf+M7TazSfLCjy^UBWS+XU5_vbh|;cKl5-nqmgUd^{9AZclZ1*Z-y8tv9BSj2|DCgM(_@Ip95U2dw^P2 zj`tXCA8$om{?ThH@>)(KykqzC{_#$RJWWm#XBH9i=+p49>r59e+psQU?su755;ahS z>K+<12{*aEb=rWjd#K@~q1#p%A_Ok!0#G3+@eZ|yk&Q+tx6 z@0|^y=tW7#uqsMt{LtO@O5p|NGyW45XHgG%y?veu*z)>B}_d zfSQbaY}Z3zSDRfX3rXSQakLaIthYXi-_CV~!M@!4Tsn@W7*aWW#=LT{4>u9TRQM{} z(OFwW@RhyDY^QX1D<2XII66+9kHzlJYyak_iM+$cg&;6}cK#jUUt`lDazOg@UXw!`w;-&t9${i>*#6JvZiZbu}MAE(pXuthk8i`ED5R0 zTXI2oBQBGg(mvq@fhZUW-U~3vJnG|r9;*K)b=Jql(7wh8X9mfwqi@l8xXs-igGc)u==Slntr)AA+ zWbu0bYqrGy4!sQY@w#=U- z0Rw9|GtH^!;1g{P&#bcE0Fn>1Vp*bs1w3gN1*8xVQ?+Lfm+83DE#o3A=$H{ zbzhIvDje4fj?{G2!I9eG7Tv$ph6GjZ4lN3IZ@$r*S1Dirc`vQ6Rx`H&gbN8UuI`dD zjx^>FDznR5*XmdmzR}CiafHvh!zxP@x^3h020>c2=!dN3AG9*8CWc`!NI^1 zjc{|3VUI8b_Q2BV{_g->88{C!^wmVGXD3CT z%y}Y?qeGO%6Sg2L>eT@hc`7&>R=FQ4;pDUwa15ZOL@Qyyu~<{A&Gq{LHcoE5HM{x# zi>27)EnE{vwg3caXa=1DSn%grqKrXhK18T zLGVLk&2WQ~sKkJkrRnXh_lCgtTLZpG(%nW7 z=Tv(RV8;kqlZgP1016hn7N_@;XV_qy4>&aW0s@>MlwfHI!A#~Ex1}w5$6oohOcEvM zcCfY1PQTc$WCO+lAKfKVq_~hs8kJ)-rfluwpoc6t5{uHjB^(q2tj4E2@W<0LMaI4D z(~of<-U|tL+AuHgDU+L}ufDQWS3#`|9&7%56HvGp)>rG(ObS>q&VyLLpQ~wFRL{09 zi1srAz|B&#ua>^jwHMojRIC-M1?`HkyEUPyF7-?Ezb+eZf=$uwehk4Y8-_0&5p=-d zf7{+)^M+|}b-L%W2I>+zZ!9a5CI&N?2Jp)gv?3sMZG%FWsemXU5rt$BS|D@ILlB^V zs}Mva{F(8u?h<}@uzy?U5nnNnfP*H@WowqZi|4qkj(djI^IWzfLDPLf5#!=LZmsg> zooMwg*5@wUoVL3fjuw2&{fzd;UGTg$Rch=SMrNolczz~kXuys{d%;eDCwEsC4|tLI zWZXUQFb71Q0IK8`6{O>88RUNGcEFx|52D8YHxzl_O<&%c7XpRK$>PUAgH@p5f4Yj0LKnf74RZWZBalN z69;dtF#?CfGEgWIIM;vYXW%(6I(_=$pZ1P^d(dVc(0P^ zF=uwyh#8ZSQN>g;wJ;c2y9&IM>FWK4c|BWsDW|77B#x%Z#d$z^D-BN(kK(jJt-SM2)e&w7|#eE&Twz#!p$(c0R#@!N0U z6tSlXayF8qv&4uWskg%Drn7sdgEZqj)$UzU`%Vg)NNUFrN_P6wFa(Rik4@&DAInnf z96Faf_SD`xjHZWmk>Ah%SZoiSPRkwHkQQ1#kr_}sT5MXKb7I*`(?Ags$bEpg{mzry z(u@mXm;P8XUlBJPZNbd?@oYfG)bvCyF_>wNkF1WSHX@Gap8wKqzuMq+I|Lg+h zbl1Ychm4xQi`C;palEr*@_g9@XSA|8sneDDa6^}m_joJ=vwLJR1~+hFps2h|4H;!FQ;}^sZp@-B%wAdjX?tDqk}}!Q&T}`H{h@e6+%Uly?X_z+My2$EyZHP1w{Q3GL)m#5ukv^4 zpEP?&%yvwz-;bm=6SBH4pDj3zojAgbmc@6jh^B_MjP_pehd;>Mkp9&CL798olFe;ik95rJ9v_p&%HhXuuP5-j?i{!5P}t+a4YPzN zM4jw!wWJoOSuGp5G>t3Lqb=JLS4F0}q=vF>W#j7`eMNQ`_ z_;Ckkttqem`mJ^%TQ+Paj}Lay&!t)*N*`R%td{N+Gj}39#J3LJ@(SIcA(z^<^D5tVt+={Gja-4JWZh=?9()rosQ>b&9fT*r)ORA;A6I?@@CWwS;S_Hc_j_UBVE19xSn zHzIBPf`ir841}P0-}`4Qp37K|3ddqzp2B-WhwuAxU4k2Ziep8taX=M~-KvuO;SS2T zVyAuCivuJ|%)||?ZDg878_8;6axZz^oBEP&uqseVRI%naR}%LVX`Qpn zDsZL=9XUR;dgmXK7F?}0gq`XyizmpJ0v@bhcS{ZObOv zE;Ma4L!Yb8$IUuFM%nPSu!;o(en;m*- Ibnfc^0U-Y^lmGw# literal 19668 zcmeHv2UwHYwsrzYk*bU$A|w_-r74O?j};LC8@)@FF1;pkunr1t6?45CJoY zvNA;39-@qa*cXFhR#pL40U1^SGgg@=psD~XctGljfEh!E6(S?RDq|)iWA;Sm2?Iz` zR<>8R2M3_PwBj|UG9k0;`Zv-nvC z0i#U7*b|DugCP(Y1O|hM%OK)PiFokfh@jpqcxH*S3?hRu7UDUJFP$agW{LP&&>Cbj ze;Bh22E$AMjD+#TjPc|Nqu3tEWe|!PKq3*xn8h<@L2ED{V3eTy%$G3M8%gRNE(M>3 z%j1l(7X%_!!~75G_Q6LT0)a!cP9D4LpD@)&i!>Xy9wiYukBGmOa3+6hnZA7CVujK0 z{@oWbJV*SOkJXPH+bXhp)F5xvNQJKg1dZ_NafhJgxi}%4piuZOIOHT78~P3!BCtsSvWtZUaS{Q! z!}(iu|DQ4AY07oUf;V2or%x;`|FBTgh&SSDvsM&#lo`I8S&BO?dy(?1MG zCMT-S-zEo_%{W2K%Dgt#d(;h}+{*?Vv8efEhR<9SmbPLWW*eB1}PaVb{hCA#y33J08y~B6@2AFV1L0ixE z2YE;@2V+EZVx3B%@tpA_zkY;O^k(P^a)uXVk*m~-y*cz{oE*TWvu*bZ(~CDxsPD}q0fsQC#QoSqob*5^xr z8hajkHWfe!6Heh^ATCOX`IN zj;XSG%Fi+yTajkzpPT(8yy(G*iQRiBUJ|gq`WmCP)X-F*b}6D5J){8fFVa@OvPi5rIIQQgVZaZU5eCaam@p_>*oyTUPx!oes% z4yl-PLfo8)r&-_DngioOQw*wPX8)l)T7OM>fcr=*(pM7!xhT59HW#+KsVV|(DKeP{E+`JGU`pLMf?A|+Ivt{e!SRW_{Uy+_rN zmKEOa9>WQ`7m4n5rr3-aQO2^<^K^@~EUw1gvux&SRajUACU(JVlb0=5y&DWAG$;{ObjOjwMMp79VN8bpYK@oz zKF-bVUWw|~n8R3FHA4~($&h7{Pk0|Ab~yQJ^|Irs%JGAr1OnVWoDdePjx+e%UaNKX zeXdpBC5d4rF)~*TsQnILO2AvPA`Xwf*_Q%gT_AdlxvA<@b6IKDzNvOaqYhN>u8y;%U= zEzV}UxOZ`RiD;6|Q@`Asah1p9mgc3?t;SMtKh1b4Fu?K~=%!*TPjmlyE3kF6JyzS~ z=k%H}!2#3h^fo|4#5`U;CX#AUlv21l+2&p-PZIWl>tsb#XXE zFC`4kgKBYap7T@Tt&FVA?G!jF%o7LaEk;UpMR-RwCbRagszwYJ@ z7M7VIpn{F9P^z{6^WK+v;BGJiF(J) zWtz+(fAxb&iI<;%=pdI_2gg|w8LMCvs6qMVCZtiq;k;P*G;Uiq?fON~QMNMb8A1d> zFvzQ<&ldsqp#ln55eY3V^QM=*-cj5cm6n5s43%xHADmxum~RWdhciR4CpQnYgxEWO zCIuCO9bY4Em_#UTr98h|UAYn^Yb+mf5GbklR!rnwh9z>57}$cGPi#ogfMKYdTC{`) zjy^+-2ldCM zchQik1pFliF3!iPRpa;}w+fDCzMM88VC5)i@B;yk z^LKCjDWm6iXYT(Be|ePZ#!_KbM*4WK64OQ`r82WjzT_MN;@dWn!I*8%^c{W{YnNx3 zYA4r}17^>+<$VTY*?`gnv?`LpuzET5qHKPNLhgak2?qb@Oy6-He$NtWphkl1Y#_3roIN=b9?U8gYL=6q@o` zkPG@37x90lDt=5w_jbPxr~s!E0_<-Kd*Rwz8xVSb&42l)Df(GaTg@cE_j06kFqZB0 z%jZ4{H?o5d6K0@G!8d->S>iIbrYvyBK|m@|0HOqNX5*o31KA+Z%s9 zG^{HU?UKK_>w5l;2ccn-a6#$?&`Tjb#Pg37c+o{k@dOTP~6%E}LHV<=SMkfveq2ggn21k?8(LXPVhH>8E%hQZ^&ti&^T*9 z_+A|D!b;ow_<>XmI)BT# z@3|~%V<-!?mU?{Sz1W8rT5GWWEU0!pid61*Su&xwV{ILxWl^4n`MKhoLroV z2iK*IKXt#dAMRbZE=K}t?fg~F9=Hqdx|~?H8#&gS_s0}SMWXW+z6$W%x|L9~-e5ma zE%Eitcb?+Pgm1lBs=4yd-6;iPtk%W+wXyx=^ThCwR~1vr#{Kwr{d#xjnL|Bv{)z1J z{oDjO<^-VMd$%R;t6pKw*-H93mWxN2xv2Mh;C6z)m35wa;qZFfv(I4S%v!=PjHnk5 zFtdLAhxz>b0i2H$5qUke^nN?fC6N7*vp)LZIq;GeF=t_(5=*j~no1xcpcEN`yP9g5Q>$mob zsj99p_$3I*`Tg%N zGIRA21_?KP)~FA`5$__*Y-PqFuc|ot)h2jTyh)(5pdo53lo%>5bdv{kEgYSHzkT|q zj}P6#=yv1kPI$f@+YO)WBr0sGxi@?%rT+=OH@U<&=i8KI+cdYb3bPNr*euY^#Zsdj zylZDZ0$~J95pK|olk@*$Vybvu#m=^Ja!wtA?gU5Vp8*U1>9GA1FysHqmJcpHr{9({ z(5Lj0ZVvM=CaqYxts8d+db9|4gCZ%pW*LntePFjprPIpBOpdR^=*zZ z9o&uguOF5Hc&`D6ZI7|hZTv}%cle8`JLU%BioZSqY34Djfd zi@1lhXEpTs^T&yrq{;z=*cmAXVB-%Xf5u=1C@I864dBinPa%|T$wuJV2B$=+tmhP! z?)qi*wH15b`Y9tn{O5jWL6CpbAWYMMu1qp4^etBlM>YBBGo;MSX!RE~dJkhxQHa5A z>{?m9O6=0~yFrg6TeOth#wsvAhs-8AWKE1S0+h%PhC7AJ<*F1)w*+x8W&#B<|!(Z*rE1d5=ut(MdDgG=b5~0C4Vf+01@a=Td?XLvtn`8)OpHxH+(58j}{T>f^=RU zFcSK*LOs@Zw=?ufj1+V{%7=rDq@>5t3}OpMx)aZx(bLda{(@><+kvwq*nZ4Lv5j4s z3fzo|WDI_eI3hWaK9J40bUVXrF2#T$y$7!La&eIMEZK6^zONvtbVbsEbJZqN%ZobY z)ftIio1N4Vy*-d3r>K!pRWW0=(1G>fNz>~Tt&po4#&uO0drj%uC%fmGam3h!YIz-? zZ5m9V?12l`V#Ba5Ri@-FMsp5Fs>9Jc{dx{O{V*(D5;Ys18EA4UaBQJKMYxP?@g<&k z*+DOk6#ihoqY%xLs=RV7o$u6Swbg>*E_kJP=U{k5?I-S!8V>i&X;>`%R$+eN_>`8{ z`K4#^N`(&4fPjTar^2fS)w3wFd6|4Fowqyp9aJ`$ZWHY6UbXhH4Uh0UA z97!qX#UyPQqI4B99)g zY0jE%wY#*D%biV=va-U#bA^FzD#?5hPJq<4GOSS(=`bIP zd}wt{q);Fwruk`5^N)u8qSH$Ocm3)E>=-dJy@p`7rH+*0-4nL>ZjI^Bew`tq=0QIkZv-@pBh!K4H{;8iV(t}*Q)*;(l;*zaah(SrAoN<|6+)Lu)tDm5r^+LE>VN+R2kMHZ}?7^vCi!H!z} z9wGB`IIokwJnpWEa(t(C$xqT$p!QrvpG#zgBC?0-9HuRyrL^)%kDkmR9#DQWQpQ<7 z2B{5d-(X3n#WU9OBJ6nw0~in>zxY4qYCi6ki*LpwWT38h0{kY%Lpy+2#wMA?gy`}w(8Ou zIrsBC*}4tP*=#-QZH~47IO0^*@L;NKF7UpkD5k9jAI}Giz9g<)?WtA+ZSg+)Py zEwc`WA8Sk>e{w%zXDv1wZ}4TSA+2kG^1eBg}->Q&YqNUR9b5S9 z+q9jd?Y8L_a*LWe(LmymB$|s8@fgf_QGmlLQbbo95%?QuzdpyKwyxWo(F z^~3c1%}Q5D_UKdf^G+y6PIWNibnpN8CmovVi%me4YyT6^aR_%<7F;2%~wuw_)bLm}sEY0b2Yk zf$xpL#0lB+s}^s9He$apOSjT5kys+RycgEqrd;?i(HjEd;qWCG2q1VvE@`^WRJLhYGVl}0tPTp7{HdW zP5=g#-U5Jj-uh!9h_|xRkRv?xV{gjPko=y5nCHNjePi!nEovZ0x&g4v>7F3~8$qqE z5T)8kH7qHG6TU;^@7!;Quf6~#bupuo6}TS0 zZ6i>nPw`kDFeknr>Tn1?p<*W7F68RJwR3h-o4OMYQE`l%MBE~X8;;DT4?^TjNkU`heOhwA<&;J-|Wnl#e_oV&h77e+>}^RRke2JQoI z@)^$Gr@#D5J`o65{g3sc$1fm|<#*@(k3o{qAj}Ao(GNF{b*=;6&m7p;eB;pqf&y08 z4f6S*(5;-DlL7)Qp@Q(@duWjHSruSV0PWZbfV@Ef5CVwegK#Jl78C`jAMo_n;flnA z{s4;lw^hRJyTqs!%E}C!UW{#IyD`k{RvM?`kq-?bMj$#D zo?xL$Rr+dPK{GQ$42`2cUtw_Irm|ej4ck!;VExd_^!{x;B}x`Q7aH}^>d%e_Zo61u3hA=sWV&`;u90~% zRjY)W&#jH{-?cuxVs$p#W*c}jh+rsv&q(8Uu#OGgXg{;@IqcNrDMX-$=pCgOz-zaq zUU+H2md0=RH2y~b|DI}(_z@s-Aa;_aJ$pT-YU`sP&k+#VSX=3UmXnbiTg&7rKqNHEr z4nRZq#h}lvkL#a=8wmyOJ_qpY_3>whRc^t4Q|Wyj8&KOGe^0cZLhUH{o`^)h`Yy_D zGv>(mex76bX#c&RT8K~Up%2i{<4W9F@0igKW-p>95%%BP0w|lxv)*` zx$Li_{ub$A4v$|piP`h_GX!Q#>Sm4v{L=Gyc}~uSxA)m?BbDm+u;t%F10Ig8CM(OE z$X~Z~{(#Zq5iKGzHpB}A#e&*@kv#Z6VE6nv;P)RBnT|`QMw~8BvoH$a8S=1RWuA3y zndt1J+>^@`ahiYtTJ%+e54_f^Ft-JE5e6(b*-t}f7piBgABG)Yk8!S(CRT#1MP+c{U7kv|A2!3A@=Kk+feF% zKBQ{qID%S(nE@1Nw^CL*{cBuhBpNo535FGQ3DtL(5PCbT=x8=b;-LZgOC2JipMC4O zy&5;Lp)av`u1BKP%a>=HrBK7$m~gY_2bX{yMJ0-SnUj1^S@V^_HXVn4<#l1y)>jKZ zHYdaKK@$W`aEkHmd2u#74`~BAI;@`OVFCr*+-P1_dF6arI7FI#$nll-#7#R8U5*B> zQWopW|6XFw=nn#r;v}Y#vI{Qy(l7fPbS$Lg8^Sm;8)C-XQJFEx*tx&{J2YkKH+AP@ zGJ1`I%FE27^~|Sopq730^|fIgNX8UuB|Z!lnqAyKNSmEZjrd{tcVXof=?FghXNm-T zK$s?pB*jxg?VqoFVwm`!S6LC+gt0L8nn5zM(F-lNY?cOO=PN%JcXpFbBc=^4S7DMp zYn?OL0@=6ol+ZH49F7xmhAbbYCi(hl6MAy1Ir0w81uC(aBqVa?9V2N)>3(BzLz*#z z^TWGtfb~i;s%v4cx>b5uV@5jPrP85eIdtPQh(KFX^{Tc80JzI+mOSV6S_Bqx5|JYd zJ)_x@&=q1=yfPp5n57%?Vo1Q}>ah&e=WS<_vsL^pgBv6ALYO#qllp*JDW5EkJ#xf~ zy8DgNq!vQr7D@=!6I{}t$A~xOKi%pfP?_AatwIAy)1!Y8(WkunY2m}Tji0>tK;>IS zTt-XMVS>o+(F_Nu@M)hpqORyqouSoZc_$Hp!>!B>)$M_+Siw+v4AlumO8-Qq|T zg^n8|rZrSlQ&&2a#`HK?K59Gg_YcMDKAns`gqx=Ox1U&Bwa-EMi6;K2FlLCba9eau zD3p}JR(T$Fj^mHq+f0T6Ai;J|` zHJT>}y_zU~{JW|U)4%pEy*(y3W^E=Xw#!wnv}9n;w}i}ZCFQe@D%;

164@>UDGk)i=pe?_uPfFJPCOM!i?c!Er3 z3=Wh9JgM&MF$~D*52N%XuEdxdeMAN&Rw|-hJO40GyXK(*qKu%-(rur}X8X!?ylD0q zDMBUTIaz1_?28^@1twG5l2#D_&}0*G2cI z!C=_jkd-BO`aD**YOX{h+2z4GJ-m}{go!AIKVGuxllqfMMaFU@EFwvRuRgV5q-EJJ zOuJ63Xh0G&3E~=nt{p?S(m2~V7f;Nqd zL!aXdkah$_?SbDXYNxf_%kG2|L$@v2BQ}aZ+t)s#6Rrt_ycR8F;>iZ@%Dp05 ztD>~LLVti9XX*-%!meilnyAIrhD`eUxN~`+E#IDE}*lydAbz!N^Db0AzAv zVz;Y?o8DA&pYNzT#^yVWY+D7{4KC`moo%6?AzZf^gXm>u{oO4R)YEo{`4X?>9uxo7 zeiuO3kFXC|^_}*ryt?1p9r;WfSSoKK$ED$tf(-216poTW8&Qc=Le1`mY6M`BEkmr& zCPsseP#zt68rxs7&W$^+l#`TDZv36gj?|yo+M_YjRf3QsAFUBBVWnaz5x;69JYWHM zC+wF|X{8wSWqG!IuU~EShc>>Sofx5Ljqae4(9$R{tQO<%@WtVhwPgcwfVn16Cv^eU z#w`1tH8aUq{|%}*Ve!}$m~aW3zu^--?;_kSR-|x%ARvkfwQnT8sI0tp-W(9@ndI#% zJX=~~n6hM{cIN3A_f2SZ69s^i^dunhJGf(w_k)1`c1$Q0eFqS*UAAG`uKNH~xX=c! zqYXyb+)|^QE%Av9@Ob+Qfg1uaG91Xtl=5n1qNzE6j`TJBV7wTpV6s^A zEkd!*2>lHL7w}L3w}m69_H2U7?Q=&Ib>lok4wSgOTK8Q*$yYRN_9<{JXvQ4vcBx*!eNE0`4X0b0%-FRrwI+9bRfKO93f%4%SZWiSzr)k0iT(H+I)A!s6M-P{4^7t z&V<7?Ntc2+z#X@#r_HRMuM|Fi(0R%#_aq zmNG#HF?J6ymn8t?4A{(q0?IbMR^?2=Zl^q8hpvS1-6_o9=rH&b96nrDa9y__k;nQ) z8Bk$M0dsX1XZ<*U8*k+@DMzA3S2BJka2<*%724YPl}Ak34gbpDN-S`J!=)W&n2bz3 zz;FjLlSyOMQg7p=pt7U+Ih0`$Ux-Gd&I_?f%!+b`Aqd$wvv>$^r4B@u{iOV|7+mtHsGh(9h2)BLAq z`BbagD3i@bTL9-W{!&gHQA`Td9cA3wkT!%Px?-59uUh|g+=dOd74$960iMNa+{24P zc86SsCu(J-p`Y(^p6TH+Eu{)z6e6x41~)54zGnzHSkInhOLMuEV^+y|XA&U8fT&6| z03CiCHKr;|+Z%gb%21ApR+p6xSr~CQ-jV{xo6B73k*acTtCWrQL(GZ#RknC7lQH}^ zoL81UkJ$V8E5%ritDYTnBKn_r##elnpkvycOvdn*#_M%g`d(jquwfJU;2ZZxUDE%_ zhgf%W>q(#u!Y|J2`bu|(iwKztFqy|G@=E4afVbRvfbmF+iT}Fr&g;c8apPZPS+&$$ zF@22M_zbqeOO(^JhVAlxK!lcR>*2FcxiYR<-OC-uB>n;x^54^k&k}3j6yLMnAA>%> z9oi#*E5nS1#cV$lQijBwWxnvuGbS9(>5;*F>A$LIS8q2$(j9?7Z(zB|#^m|(v+kCF z=M&g&JpRS~us>u~{E7Ad*H4>&Nz4Dl80T6C>hLFVO3iy4_-$?iY&~SV;pl@+Mi9ux zX6D}ouzhE2gv*l~zs)@0baGjRli~q^7(+!c@m>kTr~LQ%qs@Mh2Y9c!H!~F9GQd6Q z5wLzoiFuU&f>{jCYCzzuKLFQ^0wm6v|KuxiZx{ppl?sYJiO_8pH$FT%5qX?D&1a+U zUQ99TtD~h0Y2w&g*Y`#4yb41s#8_H+xn6&?OM?kD|HDK7q}X%PJG);-S6GlzPk49&ArmOZQ3Y8I4If5ZJ0Px{ zOQgo@R=ns>%6aDo0zc0=hMMa}HS|e=^^upB0L^%m%~sKz%)lxIF0JBX7;Z35NIUDx z_Pl@{_wwAQ(sWeXppV5csp%nzIX)0ZMvYxAffJ9jSun(;il zZFvyrdL=@l8IS^V>cCT-O`q;*hN_e~Ke^a;uZ#QKSgHD)Hx3Fe+ z_Yp3~i^C-=A`Bl_o0`|T`Eb>9k%?REXAEKrOwCz5YyPeYjumCISul0Fplw-2b&y|S`K|?ri0FCg*gf+cCWxu@aKXyiY5dt#7_@Z{8z`r>@@Us8+Mcj9xt2AS6-X1A3YlF znxs{@!kK@kKxz-1qS%Xkl`)WB67OE5GkilNe54SA{$WqhOciCN=y0h`NgtzLxW=>T z(A6YW>W^DCWBe3Xm5bd!km!*Ui?JeoC$Po*X?sdT{rqvbu8+3&&DB?G$|SB6`kd(~)xNZ;p;uFtgL|(YKj@n}VF7Mye9W#^>F0NrIul@j&wPGhsbt4Z{j{D)d;Egk zK`(o2XwS5I#$uLzb96<42rUdmpyL$$S2KDFm$2o&Z=)URy74f=^iQZK_PT%xYk=6u zU5`{LNmw#@MAno`je|AKXhN~ zRJDkhvVmZ<`(igKT`QT*sH!5l{2i~U5;VgwBBCT*Pc6kN=xF-K+ucuxc=~6oBF|s& ztaIBYZ)5nVH@Td2Gw0}5L5y;op%}$dPc6+D@&1v5e=TlTeE!*o3cj`KMmB~IvkRQ1 zr`K99vUna1eB6^Ax!<*BzxK!=h0rQgq87cq|W5e}g;lFK0AuKs8~Jf3|HnqK^tdUj5zwntGAw^Khtj4oTsq*b04iRHMjp2Q6r~EAq{*lI=p} zXP{5cftx@CLZfW`fp|l_TiMou;ryZ~bIjDKjhuFXUen!gfjoBFeqK?862ozI-fFjb zh=sm;vTNExb6CYGH`igIp@m)Xr=D3~=<8~3dC=#(JLbmu9Z>5K5~=wDrVzSvsV{sa zEc}tib$3^gaR@ptkBV38Te39J)Og<5 zDoL-*kv0y?j=vx`7vn&B>id!6ThM&MrRFK<^Y&5xYdvU4|6J*EC2ui diff --git a/vignettes/articles/figures/unnamed-chunk-12-1.png b/vignettes/articles/figures/unnamed-chunk-12-1.png index 95bd7133c33383107576097f7d3f499b05bc94b9..af169c893e1fad48bc76d7acd5a4fe8746e19be7 100644 GIT binary patch literal 11637 zcmeHt2~<yx~K&bC>+HnAZPy!GLg<)j{m{Rzc>Ouqp>9}vtw>#k~0%46n z1R$)f5!UcO1rbmJ*RAEh0P6s_P^@7Jh3!&N9RTxL!v&_51W?!kC2)Z#)(A>~HKl}2 zfuGq>j{H}alf%d8yzCM-R02UTAIv0Yl>ZoI47f1M z7@RUDTzCvvN*P?{$P6Zf$zi}m4u`>k{~=~s4wF&FWH6Y_GN!zd!{qRoFr5dnDb{RC z0J{V(6gC@TLlB3N!(o(hm~dfmm@qFahR5N-1>!)^F!2b6l=(-d4kgR0(r(i$EZZ;b-G&WXS7CdjtZ5 z*tKKpw=o%GU1JIEgE!y#Y*BpR?wxT`KgDEYHI`6jOR?QshGWM^rr1kpGn#E}bkQ_6%_JTg z^2(P^9;QlV^a8RZ*DgE5<3TCJF!l=T+PzVv0QE&Oeq2mTQpc4FSRPg9k#g>3#6tUgTQGua}01TL1};&k0ee@@OD&L3t;bjFM*v_3`j zs#Epgp42urnN2_vyW@}#E>DerFfUl{4Qx8kg>)5SlC~@P7ky6>CgVclO;SORodB4y z#T$4K#2=rgPi2;rSeX>q3pwU%S5HZ^h$VtZI!!Y6aTi&_A2`0PvpNf(Z)R|k6X7o> zf10r}uTBC_8qUh5SGCp9rBmehmXh}?ZYd71Mt6(1O)?seR!BZE7rrqf&1AisE)=kK zl58Ofi@%Zn+T=8iBwh6QvaNJ7s~ML&740i(YziU{@l`VN6kxR?*19?ex;-S8mrDX- zi#7(3Xz#xw+Y!TNCPz|}Cm+(LS=m#`WI^pIW-ztkr6=;^mUOH@MuT$et_Q_I z>!dxJY0+&*WQ1^^2Uvk2hZp}S5Q^pnPGx|dm6Kw$b9*1kf<7-O*!`h#u&3-3zHuH) zf7i`|A4F1<9*NZ4W#mNJ@c^4KnQvuqR>MnUBrDvl+fCLz;A*2#bSubW>{A;d>NFl8 zI6NiCjr0<0LKO!x2lsc-W9f9;PoGXcG@-B>Ac5;hpar*T(zu-J*Xd>4H^qe}p}Zq$ zY@{fx!$c`etf5b7(cj(A8)GIN9#0s2<4$^iGL878B&l4l=S@LsV}E)-ZG#)#utTk0 zz{(4;u$yJ#al)FI3LDJj@~{tW5A}osyF*0eM*|-}13alTRG1Iu83!Jk-9Fl#_Ef?* zM!I!5JT156`@X07?OEGq6J%8tHE$p@lf0k3L9u*UP(#6JMSuG~3&S8Q(@oUF<*=V?yUd(jqxpJ+#0A(y zyFYWgv8QV}CY?(t66|>_q7WHBQoGnDc~plI8;rZvw{Z{gz5YgKm`rXtH@f7dly%~e z*Lx%GNqa@XB!>>|jJ^>WEtWb1?Je+-1q$*p2ce9PGbg(a4R;)}zJ zlBY|__d6ZZ`pUDta08~xJsgEfi1-OSISv+gg+&*~ZNi1}7BtuD-GXFnx}?T8({nk- zeWvreqQA_vzZ!g{**W_)e`ub6r5;v?!V11v?2hSBsTVd5?%p0?j%Hb5;%Hm#Uf172 zO$r4MM9p0>&2_zhZN{l``;mP z>7AbC5dqPFHNEnXqbu%vT5t;k=#K5y=c?9A+N>Kx#W5|-X_4G`En-f#Qb(*7(G?I7 zv?|RpjpcW(TdJScB@ACyp=Z!)8YW|-G6UU$l?GnQ-F}{GeY@Quwk9QtT3ANQFQMrl zsica2&gP91imQx6A3T-jWF`=;$=Wp$)H=54(nke59Lw{yO;%lb`1-gLVVN+eYP~0( zGbU=wAT`anaxe1prViKU!rT!mE~R@@3wDo|+bO6uoZV4AtRY1g2N*+4 zvM@Adh!CRa&p+|QpwxtDZt7u^a>EXFih1-VseK?mibe^Gx@I%OHv9USl=^MCr_)pW zZFu#EQ`@SKAXy{l64_+mDNkF^Bx@TV!9~|f%0#+3G>(mS-SCjyE@hX-!II=_s|M{q zb@OSmjn$S9L6K$b2df7P=!?l^!tSWx8)l?v0rhMyQB>1X*Yk>+RZM7&n%U!0Lb82x z`rH_4bqfFS%_Ebw?g@MBgJ_-9VA?|;!2{#Q=u3yGM|%9Khy_pH*++S)i_ddC?ygp_ zh;!_c_Pq4xUutO_nP5$7`r7jch~JS)4I^e3Jsz1o^@z1AH#dxb-pn0Y_DR06`Jjs8 zN3NC)mU49;7Zak#X7o}oA20l--Q)^4zT;U*d})jS(JXK}qbWP{po`Vcb_P49tNN6> z{dl=8G3~f0Oz^%iE-0*af@_P#*oB^sk%DI2^|Nhj&h)^daJQ1EcS$Cz zm=T+D3m}$jm#%eVEa8m3hsV#&oVvCY0`1H=F@L5V9{#nJA{y!j52&tcrQLQ*EYt^m2h=I;&*~ zfh-HrUy?hJoYHXzPx9VBWT}*5wdtm$^Uipq2E5U5UZ;yflasGzTSs@3#pyO8BU70wmdvT>?T-Z8D#+6Mz z`FK;go?5LbSK>@&F4V^=?OuWpji?A8Jl?iJn_~BiG#gi_vUT+oL?`_p^h{CymCMc2 z?}*uZTXq0~1ti#ps>-8>rTEY$KinP-;co&1naobD@}ZZDL=;?z%oH4u%zQD|pSBQTl zLv8N&(g@x2gGT0bH%6N(Ad;* zVAx_v#`RlGhaIPL!^|*YM*+cRT_g)HAtlmP6=8R}HleWc$9=$@(|Mm&k&|H8{2wI2 z@BS5DBbRHB>&SP3AHAz@@BR*Wmmv3kcv9-Te&%8Cr+%pw{4cAut0)d^rEkyRH>g;< zI7(DF1sy`&1H0iZ>~E?giKriTN%)J&)xr@=S>jt*(|$Q$o!77GkSot;t$UvAcFEp^ zFQ0%BOG%;uX`j~wZ!-e+Troi%=X1$~zc|iXV=FA1=E-QqzT(wXZ`WjOgmr)j6S5ON%PkgyzAx*0U>isf=(Hx3m}@qPN^q5XWn&{Q^I( z*a14eb_1^?NTQNp&5gXiUByZFj#Vy*)+SfqMw>o+o&Ftg_IsR9j3d12?qB>;Md=(I zZu%Ot^+nb?Tja&BrUUq9d6<6uA}aV|L0mDx$VrWdRl@_msxG>NCCqZpe*A1uxhy5;JST(KK{Gy5HqBkZ~kJx zqDiP3M(qZu)+LG+o_#?L*#<0Hi8OdRH6>J3vFp4JuG_O;;Z%1n|1Z`RuWQ!qpawh4 zF_e6%JopLOunpLzrFDK6aDMN9eNbAv6^Fi0otxd$yxFA~K05K97UlW;9!+Ep7Gro0 zRPz!_7n1;_&uz57u$tR3p`fa)umV$~PokeU*#|6Ig*2c|%vwr7R5hSdKXI<7pl{v+ zEv0XO^X3wg`j^!rPh1oe&*)J4=F`1uG*@BNuK)W)zfADVH(z-47qkh>FxL`4!@7O# zGgQ<@ozL(=hhLapJAGCYxme{hK45v@9A@+})6aS!uKp?HPn-PXbrN%}dA68#$Wi-r zo(2->i9ue3uS1fy0Y9rKQ&PZhb+s^9WX?(q;EX!37XUNR_iurSEh+4r~|=6pU5$S{F%Bo_R`SP&cx}lYal{f*{K-LX1gnNXB-L& zoGTVx^_{$>|gT*kT@@3hjACR#zB{EDs0dR<5l!YN2 zm(Mj|t%mUQTR6R&#k}!YB0|XtVw&URd=)d zgz6k?`G*z-Z7s|qWX=by4(cD8@}LmRz#H9GwoC8uY80^+Wza5{oy(Ov%^2* z3BO^b1J+r`h)a`p!=BbFu_bLqqkAWsTXYw|uBS0BvE42w^r8nauwyv_8ruLc{%e_{uy~?Il&&Tz~=_PhJsWpB?@$=lV~xeu)i#e=Y4)ua7Ob zXZXz*JHv$ea2$|tYfa3wC7)c&0f}g?6e>(K9Wl|xG3^ldSu4M z>Kil~PF8bVv?!PP*@C35bBbydINsne`hn@@a3JxHfkl1zME|jC1;4JD0gMNC$+Wb* zLHPjSXpCNan+YG@F2Ft*;%tS6zqm6mZIj6XlljW)0608lx!z6A>i!tJzy1&aBH@TW z7rxTD=OPQ}CUD?Ro(tS2)X46uGtC1U`J&k==ZYfIFEL#n%Wf(S_`$N{wcWLree*W@AU>ZypcnprLx8$60*n90 z*E97Ol?FJW$qrUBNlLpuCkEcy2EhUv8$M6%NJ%evLQ`f;4mY(P8xSuk5<+ON7kYM0 zU}t(IU$UE9Ov5lH@3BCu?qkHQNuQcmeL@jVMMOy}nc}mC-*t|JX7pwC&S%|)uLCXw zTFLq+(<{<_AerZt2MXPbiK|a8V{o#g9rhPgecmL?WS+A7{GD5YjDr?AMeCl zV4@ug@Uoc+v*8jUa3?%TZnC@y^y>1xw zYy(tcInnd_b%&Q@FZt{SN0|+w8Yvocd*_}O(HNR=_R=$u+Imv+9uQOJk_~|@CJENpzax1m5oysrCB)w7Pj+)mW}eQ7EWjNrgB1B z531I08(LCv2p}s7jq?* z9*);~P99q}j(R3x-0ba&;dqk2lBv)rYY4ZH1~^rzr&Rx*kQ|3ancrT3(=?snr}by` zUVe8MyBNNP%=}~5kpILdcK>!q{%^c!^hQugZ^SxPn~-O6uvU%{WIbi^#HsZ# zeRlz@dV3;0*`Xlg-BS3HMnxIx1SpR^e^G2d)zB1LX(g>~gJL%kD*Guzx)<#3gJHMO ziS@>|PouV`vg2)ORs>N>|8{DYS2?D`{&Q;;+)CPN&6f1B2F=YK3cNC|dJ=+cNz)%# z$EE|ho?Ob%P=|T_ho#sHi`Qsc&hiJIUyEzADKkw>S&n(Z?|p8p$kM2%KO3zZ&=0&f zVm>i7Wv5!SkRrMhQnB9dXwfk2O%lHI@DIy@N7fPyBSW`eS=WXT4H z>)b27qDgBytOt&6SgR>&33b+t44i&B{U`+=uCJH93s4@wAVov;3{ok1y?I@wNcaBu zSj^qGOHmfMflQIY(zLOslFE;LfgiQBoKrxp4r;VdKK0=2`xqU{$0#x(h}6jGV?`Rf z^-QhJE8f0#LwLBs4~?3hhiRL40Gs!sws{;yiu4O)vkeUW$LR{0E9e#UkE%zJH;qn_ z?)ixpy&ABR#h)@jC+fm_xCqVia*Dv~_Va_rYFOs>GQspu1*Bz|jIWVPi;Cbk_%#Ye zoaa+VUcz2x9NLX4o1X3=1_~BOBKtO~DBoEKyHMoj3b8b>(} z)Il5gbB+^lcQ!S)6-3wDGzL@_RV=iS(&f{LegJ>}Bj~@v3mxgkj2yl&O4Ar9GDxYh ze`ZOaKjLK~?%jt6yid3SsRcX8W5X9li7Uj@2ghG|{-BY)6K)6u0=Vb+Z?s8H^)5hN z^2+2}^k*^Vd5tyQKjM;Sn)C(6Q(?sa#&!IMzJdMM98?5tUl$dw9C6E1{`vH-oz6QR IZu36-AKwpY=Kufz literal 10347 zcmeHt2~<;CvS<0$L~sy@&@562Y$?lrUj~6dFZ^VDRUbql5G(}Z1i@k< zSnx`KI8}oDHtMPhX_tX z)gTath6FVy7Hm@K<2^$`U5a`cTHc31_PpQtLp{Fu>OvrB zh|#$puLh*fj|gte*ZqbQ3rfGuh!1OSmxdq@trB4nc?=YaK8J%K zrBIMFa5#YahtcZY1QP2a!+k|pbETPgU~HX4ogWKX&1^RvNW^YXq4*wyK8w z?OGECmnWiEx*(U(^j)z~>q!#%9gEijDXt^~+$Mn!WXZJCXN{!Tp2VKMQrA2!KM*RLc=&$nfR1f+k=8y4(-cRJ)+BTrUOHunM);I*6>Y^ScpQ zuHRv>NH=wKT!HAFlA+QKvgpiv`MiAgI5xfHpm!(KrLe07N|kE>AWB194NspYF4e53 z1C6sb;nd&QUhEIP`?t1sf2$9>1t}^03_O?alH^mPf=3@7KwC(m>|LvO5~!6NFV5Iq z6W7lvow6C+ap%N@Ko%yW2EUM)XqP^^9A)<+N_0f)shMFO0>@i@MX<#cRn@TN4{=S&V`i!=%*7+ia7UMc zxZI0LD*Utz{{69U)~+YTTH6QWd>%|nPGN2N%M(x+iAI5@#z?=e_0$ZR)ww74ZnoZC zZbph)Pn|s2-q$n2X}fpY*8^fY0zHtz8!INfw!DJSGU?hmz^fsikAqw)_h? z^A|eetz6qNc9!$^0w{ZINzu}%w?FI$!KlBkEk~zeFS^1r)KfQkvDoQr?>RpMEZ(@=}d3(mBYQci^%_Sd$X_SR<7V-S&J11>j)n7De6H8R;ZI~QNR&bN2XGg9yto;aFs?F17p(YFdSb05FcA@ez}GCljFC^gOQ(!nOip^qO1 zR-Y{z%`)hM}U zinNrFH2Ssd$qf0eEq{#7nBD;m449&b$`{THXAS;LPF9u;PNB!~uQMDoFxkl$^5+%D zxF0%Ydamj8e44H#Em7T9Ok^~WhMjc{7GXu)Up3Lu-U*pELaa&hBT|G|CGEzh^6$m( zO5l^kpuBkuBaWV}vf#u6K6&t??J5~rG#s(H_|~pC`hgJULZ`r#US=cSN(yb-`t7^B zD%$Q7=FtpG_Wo5J#ol;Zo_j^@TzsF;@X4?XO)qVxO&`}UWD)ncia4%#$fzdS@+U}& zJP$RhWNV1DiTYqOys=KW;3!(*?Dga)?InKV;L=3%wiemlyl;Jz#}t8DHk=Q5qef%j zsef^~xF@(s)}99qEMX-={B)U6)bY+f1!RfwrFu`dJoZRcmg zKYc9U_Df5rkMgb2wB~Rk5o#G&)WZybAzWRdF2=;q?$^m}V!pQdbmd}rRys$9bbr*& z&CD*j8oS`=zysawGXQ+@oYUG;s6Z%I^67nb>$?tSn;#;p(SiSAH)#FdWmQiLr3eYP zPug~UGNI3k8!lZ-1>SZInB!i|0DZ&Xy-u)>g^h7h9qeOQLwRW#0uSA^Vvs>uvkbV3 zkU|KVDZg1dwqk+Ex)CiT+B#Qtj=rN63rz~K%#c&ll5*?;+ycUb>`kk85N243*X}QL zuUx`P$XE@WRMSc<+(pPPI;8+=!~th6X*1}i*xK!Fo#EsDjwZILjm7*+*DZt{zZ@)N zzsR08?Ee~hjl*gBTyu*|swN&m+xl%vI_O+EVrPt;isTRlK}}WOIeO?A)y~|^0{_<~ zgI76;?M@)ytw!eUt`z(BzSdI*$^l=NKU8dP~Jd(h6550C9p?P5c%4%G(w5T5^)7BrRR%XZR#>F{_N zO1XyFhF_W*kZ6jnaSq#T6gRN?utdc>P)A* z^_4bmL51rUmFafH5M8#DUr66X*8FtZvBCzOZl5jmrsqcM9!{>hO(zZ6H^`H#_t*^& z2lRDlNA=16{Z*20=*H3H+y3NNuHR$S>(tN{M`<4T!|~0#G7{s)+c~nAW9k};KYG#} zidAl{2G~is`SnaF+1L4Et)W{h)D zQJeop)Dkr$jfC{Qxy>}o(rL(ElA*bL5A5go6kQ=|)mP1R$l07&W7&d1OiZCzkq{I; zplJPzomE2d?MlV>`qhI?rK=pDcCfnqjl%g(pADUYQTu zSd0YVnCH8@4Jp5I3yN;JIWaVs9ek^zv-7}hI&gMsw~Ttni9@PxW{r%WmMSAw(~cifu8=hBy4W?$i1f#p^C;0jUy)G!d578`2JJlbAW%D zisHr62f^B}-iaZ<_^m;c6kc6fu;kTw^GB7E8>7elYU~xdzX`+dXmNpK^Aw$4S@crX z@Z$L#p^e*xKB{L4DZ$>^N#(~$>W%Wb zLB}IxQLp9?!C-I4|EW}T-~w*TF4#_me>iXbr;^>tbcTOOiiLk(;EvU5<L@r2AJEnboR4T*_H9kMSR;mn zfC*LMn`=CQ-_o?Kzb7{-6b)HMOjZU>d5_|W-d4la(h4Ax&2Ry%yF))Iep*@ow*OJ& zTL)SS$8NYtqA7p%!AXxDD2Rr5t4r+r(g9sU{sB;vP6iHXJF5J^ zyxu-Ua(<&6!=>s+*HvLC)c!L| z2wa81hJ8v9B^V6%Cjf%li-tsk)A|qkA8q{K8-vY>6}{ksLytB0RC=s0Yw3I6qG~{) zJ2Uxtg65IeK9u4x4(dV>2O=>4 zkE3a;dQi9fSb;DYruz+XfHB-rwObOkGdyCeA%AA7Eei4Ey^@F{+}iJ6oW#y3p{=bu zSH-jT$RFPpB}=$GccVjF!~Ph^qZTK=Qw%x~{ppra%NgA2-leZV8Hzw`-RPE3MaRB} zo!WxfiJA$A$VZ&r`llbdps{a%6xlD}CgXv(NMx&RmLmE%3|1~nMIfI5z??n@3fqT9 z2S4=%*kdQ?Cb^*{JLaOm_CDwqq-jYK@KZ|5%n zPS7iu@VH#ZTs`WMf^41cmh^(}+m4z|1O0SIiQY@?dM+dLsAtOPBf#wt4`Oiq3^W{! z71TCYMdO^3)1wWG)zma(>%%|zIv-n;1)g?+L(3*`$Fo$#sh_2`AeT*ex#WT;OD(JU z#X~t@;7Bp@_oC;|QKV6`lC90eBQmC@wCg^@=9Od?ZK*&v?4CWHazA5zc*Zqs^ouM( z*1zCvQ9f^vPR$PYD7CjA_}oXp+VG67-eBi$5fMkcK!>$0A!yy8`$}bE)}G<#m#(AH z{U*43DAa5Ur+*k>HUi3z+r-m23JH-RGd}I)Jmo4K z6Wx$kmi0JAq5r*At$Pp#R{m6KdEffkQ&Olmd(nxinmJMY4v7YAntQ|Dk-j(5&;esU zJ}V3<3@_edNGIy$19QtfT;14bl^N~lKG((B28Yn433+xnjf73?z;Z{E! zbXPpL$CWR2Fzu>vq&T?1lNq*4amNK&$zhRO4}c3B7W7%~{U(Xpb8tENRCONGpwt1g zzP8f@G$7t`GCuOwS9L;2fLl1&zq;99cKPxhfZ&dngft|aHaHe~Gk zBU78R(E&MGy~zS?f*B~k0NEo=NPX5>MD0AM`Uk=KB=(`y^k3-(%b*6>x&7RI#-_M? zAN7dSiVlBeUNkLX8@$|9%`$v{JZ5B-Xr=XZL%DxuP?I7U|4x(+c%{N8*QOL5f?)5x zw-G3bVUbi(B*_RDYsZ($!Jxqk?P)wX+MfvzC^)dR9y%+~V`b6kxky01DQn+$g7P+$ z-x-jDBbB503h>GTN6c1q;DAnMZ~+%lip!$F~|`*|Dj z0tTBi;;_|u5MlV&_~j+n4QWd;)S3Qeq3tMp)9%g^D&i3OZF*LQU615XI6%ipuW4g; zkl<(k)&qURj!>%^KgtnYeVTg(b49NYjRt(Fo9|(4Z;r_x zg2PXpfvH{p%ckl_sb)nFxO=LA+Yf|v9w$Qon|+m2y)@C{kC}2W3H{Otrs1(Mz}7x3 zFgZ;!pIG!YjDTqm~ zBl{%y#ws=r*jlZ#F9OAc;e2+l~%u=DbDS%&}eSsXwCWpux{r*-*jVM=>_ zFPK%!D?xX;#sAQSkYc z(~xbwabEcL6%_N2tlSdBMxUbo4{rGP9rRz=6R)+g`GDIAa6)QhoA@W+^8MEW$Upvu z@ISo&AL(lHah_nnTK{qb(|&3-7gM5V_50EKuP5&8Auy)~Ydwr!JHLr{lLL2^JHXib zN)K&nYP)W)7OJo~-8~N$m3BZ+AN9B;4c{(fb;^l#nEikW_oE)$~R`8)DKU68kS{M#o61r!#fGQIe1H^^YhRRgX zkV28kkZL2^=i*TGwTqzf@Btr%2fpULgQDP}n>jG44XX21H8W{e!vXqJ9nI>xrdG*= z189hGah;rJU{?VLbWpNL(SR(-t3I|-?z*$|uRSTd9Y#a4HjZ+0d(qa3_>}7$sGI|g zYVZ;d)GLlV@I`v`N~wrDk)m0f$(W(pKaIqyqapJ4G7_oacNp~>-vVg={X(b2NpuFj z{*VWkni*QsvJk>aYlk*6?Z*nrtW_6A2U$nvK33E`e*Jw-p@JLsbN`9xJx;g|r^NIo z_Pa(4M~l%6@$W4u>$XqRu*&5oIMs!YJxw(%;$E!;7Bl6^xaoH*r>=;ttv&I($A}@% z{59vB#+Ghk-v&3kx=5c+vPqS(RD2s9+)S7JNMfuQtlK7x7;)DwwS30}=v2)9C^A|3 z<_4cZHR?vN?(u7H@CA#3Zlg1Loho*E&S^k?Skj)RO!c4j-qDlvCDqUgvi|WRlg%S{ zhYVJBI{VmeALID;iOv?veN7@U3}ePky_`rDvr33b?G>4y%_hQ#GnxYKBGecQO*1#O zmKKOz;;pIg=S!y!Fq^uBBw9;MyBq5Ydrc#reZ)d<3>WZk>*^ToCYbe+N|e?!zI8Zv zMSykG%foB_>$Z;+wA$C*S%^?}>_e|X@gLS%HZfYeTt5X-HaL-h7O zNT-@E+eI(Z5`$jH-7{ok-rTGKHH6qdB;C*gQ5`j9$N9@ccYU~gJ-ae)>}t2(yB+mu z`jUsy_hT>twXkxp)4w(JyX0l30q4E;7#^OdSbXGT0xp5-5Xov3F&%Ve+N4h7X;wyB z(3o-KWupm_r`p56DAv^Uv8T>Q?zSI>I@0#IU|uZ_xN=+_4&b>5Z>>o;q+2edh1A%- zzS*C$qL}9W_mtJ_+NwXfiE~#ycvCd7%}@d=`V*y zCHFHanvcN;z0{XH37ReT@0;rX;H}{s(nfobCHM9SG&~P{Bk(bU%YLW4*yGt0s8aw> zL7`q+eVW$yroWX5^e#c6BnSXuFuvPrj6Jac7A^GNtYu)D=b_*kcW_~^aO8*mXvfvb zwn5=M=cTsE!T{dofT#Wog*OOQvWL;~2cb%37}Gvg!&@3*LHF3>f!^!ftT*gc$Hlp# z_}6Rk2)goON7{;5c|+^H%lgD$2S`&LPb;YBRYb?XA(4SPf#pB`XfCwqsZxI#?`2k~ z7d}>70k*)*lxZy~J=RXqL}j%6F{sj044ujyn3^}5(cdV-3XZUR!suO-6ROd>J^lH^ zX;p<)t?f=WDvNfb$ttwUH|jUs*vc9X-Y?;i=c>06!r1N93f@xwPG>UI%vlFc03Mj7E+T|Zp99)0U>lloyHwX_ki6kDR5o?ckt916A<>Gvg_ zYTDX1h0&zPpM`H|W^#vEYf}(K?|DW>r>(@vgY2N-o*g%#Ny_CxU6&aVhnv3VPGONq z#08w;v4HJ;SC65)GE1#8I&{~ThkCLbnTEJiS7B$I%9e0BG+=p7n<1?w>8NIj7rsZG z7z=aui>(8^z$x^?oL^hy18%zhh>mj^F7rZ3V*%!k-=$Cz@xa@wra0Q!%#Ntk^v2P> zrgW!~e7gt60@aPR3D0W;KACj9!VsgP}^m7YYUqHM|5Vi#kd5$Y+GDN3>>#Z!_jVGIVv z3_^<~4aUAR7-KNo|DI9LdCq&DbKbMO@A;o|-e*2PKA(HL?&Wvi*L~mD_xk>B95XRo zEVW7s0)Z?(Y;@oR1R{opK*T>tz(GvrTl@162=w7G_2na+60&#-C5fHc< z1Yrfy(ShhVL3HpCr+knMha=z!H8{cwu9gC_BH-Wwp%jD_UkwgXL%`Ln)YPm})Kd6B zijIzxjuUwBI!^gIc5Jbb(k1n;DS z&&T8Qsdy?sMGc-}1?2Ic3x0&>&&kgTgy#hCzv(%-C*KK@@1&ED2M@?j&8PD7`FxN` zkVWt#6Ug9cB9MCsP2ia%3(J!U&&eQ7@M|JB^^kie$vylg!t*9Fp{WTx?L&ZB$^TC4`h^O+Ye0~r4c@LS;(*z!J56C(Rp2?m`eh;5N80?a%WLNjYeO*{#Bqc6&*=l7b@Y|4 z6g7xQGlS>eg7ZMVXQz9a`A7C)_awzoi zO&sLdK{Vv&^?yFu@f|K`fqm3fT_D5hsZD-E5fG zz{>$b@|`QXkOYbmv~`Hw+N#C(Pgo7>JWwS`;WoA3G3SqQT1c~#Qx%v)gmn-T#~2)E zJWHY4kJmolt*iJBcA;T2l<;}P5Hok5VH-4^TB&ZJLo%JRVinJ;hZOrgYd(S+D)pNa z%|H?6`i5oeu#;~YS)Aq!x=qn;h>6`T+*U1K>xhDQ2un+y`xfOIGLRLLM=m#1%IMcNLU8mOi(%N`m5UGfIOJUjJCzIxkbhRVYYu!a6cUpW*!WDwMsuwFJ)& zOx{JiRIb`?wkeXRn4!Bqt3hccet?#Qoo=qTw}&LWUjc2^>+?L^a<%F0DTZY{TduYz z(tLhgmNML#m?%z$Xy4Cy<4#a*e^zOGFgG6tii5`r=y|ny5-0A6z zMAC+^Ya!{HhtLm9Pfq7^)S%D{b;mo53Q=jq8yrx706P(|lHS~Yk2cLahPhr<>jzCc-x%eM^=EpHt3OCSpk8v< zW8_O_htlwi?%UxIGtZYwn|*v|rh>GPwd@t#D2+4E2B;&ZYOTD@(Us-NiHZIq(&tuH z&EL(Z7k_CW4}bP$L$?GyJkLr!ped!4Hn`;q?(hm#Bttf&I5BFR>^Canz>9B>@}`eJ z*c#@Q&MIsn`I3VZbjx;u3C5`8N1-?!>ldq+6t&I~p=b2==gdB;lZ`nWRA(8fw1yd0 zFu=tX6Lolx$XSpyyLULfZLt~fvLVUep5#jr2uPaIU!Lv%&0_fblWVeJQ{^-)zcM#B zcfclq8QatG0Zi(`#MqFj@yes>cY;RxGN~m&4qd5AiTrZ&D(*Pst7igOdj-x4Armux zTGPb3#lh_K_7vUr&;grxy1tjE1sWoAB?i~FXT*Oz{Vn!sJ)JlIDbuBWW+b*WzNLUS z>Ta_Pfm78!g!Y~H^qr~0Dh@qxbEVZVA`P=opZQYST5I^=f$TX+iL&xL2s}GOS0sx^ z4Vqk336^LT;hE#=BzAQWPhI^L-F9pA)K^Ywvg^2ql|fG9DHBlht`PKTSyg>f$O(4h z5~X)Vxfd(A+r(;D+xA}a7q_203Nq%E+5*)gz6yoJ1aQ9uyb55xNRO(gN9(odXO%Lf zUSuvO%{j78Jh$a|OzONar;X7XGwV`M)EXCm^66qS>$Zi^r|#A=;kFD1?Wh@jHe`TA&0Hftbr{>f0b4 z`7mhYAQYN zSr-2g8uIGgG;S0dXw!0aygjHulcn;2te_i$MV}T|PufXi*3Vg zw;>_so{hLRy1vt!OM5W`4uOGL-xNi>!pX5B(vA0fp=UVVdKNI4$MSR;%1rK;5!ev78C1tkDcdSYKAY%NKrDI+JRm#ylE!xKopH))i>A z>{^Crw{uqra-|yFu#un?iI(WfVZ>lliM$qOiTCN^uVX470}YGBUyF!zUOFU8nWE2? zs9`TR;MxqN7^umX-RU9S^}wPP$@?uv8n(9U zXP*|k5x zU}Xn>V|VYH6n98F3{evQ>v#OWLCG2KMz&;idbTM-%mpWmxJ&4pd9ZUjf7=P;Z>aA# zI`~g0t!Dx{*+^5J2waL#RDp&@ErHry=@)Zdia6x#_Ca|epmT*v;xk)aX6`G9MM+A; zK3ttQROZU>9BQqQqpi@^R6uOop>^T29hKL0yVcp|AqmSPxf@JqN%5f0RDiDL9I+ghpHWwmQa| z`V;7$Vh+K9*R33v%SJe8XkCcLZPyXBEN@IUNaiW=TP@dJ1G6f+S?An7q`l2AVTDcv zZWs2eL-*sHzM$8yUHKDLqtzA8cGkaYn;Sc@<$=1WP07S?|8RLmM|S4rWr+Fri@#nO z%%|~Mm8{VmJ%o%skV+;3 z#qEe&x#lj;N^^>Bx8m+ykb~j~yH`u;{7Ix&16u9q0E&CX;d(VRwAVuk#%QmVg6zu% z4Y%$L19dLt8aZAN)bLa(#dz@@BXrHyC&v8(;g0ghmAwU7{z9{ymN;r?0l8apf6|Cs z4dlk0IS}{$UtLUm>4>?d2Gk}4N`)cb^v|$ z{DG83+oEwFmIiJX%q_&KZnyJ4*w=1E=DmgA&Nfy9NsCNR^=af8!}h5be_8i14rDsJ z4q5(wD@c-pN;)~kiG-h)FxtLTP-q|eYTOxRXv)g@yR{!QBqhc^L|LRgIE=pVQ^-?| zd?4eP|Ln9oa!l?W{zzR6Uca{C~RE#gD?C4xNT?8%SLDv{tF3_ zTSQ^oCf7OH`rEN4!qQQJLxNpMIFgTS(29EcmVVuSEB#v%FvR(yG5gC14ymS7YQob`tdiXub{Ys*r{Y+zJIWf02nS+8= zAQx(}Lc960^v2y#*L+yjdZIW$X#x_tC|5B4X&-P`S~er6TmNXtAN`0Pf2DXYpucPYT_o6NgfH*nCFmBC)MXzu zdd0#EF_WYmnhZut!z#9aZ&eNbK(e&N_16N~Pe-H;i!#Gd(j$V+O!8aolaZDv3p~7l zTXNYlxr)eKQv9vBXi*6Fq3H8Dem4eo8i?3<~QvL|?cq7?&vtiA>?- zQG}-K77p(QWL}k^i=k73lNJ$7tBSBOu%IWkzT(fy%fFlQh}}P1$t%*m~|y!csS%Dm@noe_*jM zZhAwEP`FT?{b#&F#PIy`g!w?npH>3pyHC>S$otLFIEac0GEPK9dk?gFBeJYo(nuK! zH8DX0mFnRI1EY$ImctvvU`_L74X=7v2~N*1Ab;YWR{kAsRO|4Uow`7md=LRCf2`f>vWdAWyr{YEFDfJ|=@2wj zS;8o-TC}(0jpL?z`gNCaw*;-e=X3ShO}nKecI`!LfGxoNy#bZWPj9}isMoHauaFZ!ft;q(<4fhM1xsAB5clirC*TRhm+AITn^fP{}bO*VuDraM4Tf z#%9tK<)!W3>!=-tg=XuKAC^L^mo38+xv?|#`r)FP2)ywgC?U|5<%)#CZi5g|;q6WP zPc)1M%k=gQ06#=s-DJ}wWAspubHUv#6I{Zwj=16sWdgA~LCJ+@Z zZPb-G$hfX0?JgB3EddSzg04jBt|lf&Fb@%w7OIGrrp#I6GfjI+2!7}cc2Gw|!%Wt3 z^kYfTkpSorFg`e<$LmEz9w{TEF0#AZ2swH)HyBav_@3>G6P0T&V3EQb)2 zkT|A{T!cV8Hb$>NBGGZU?PxSk18RrEK^$Qf5Gb_f_X7X$D3$rE%3#1fWe9;lqyG}N z@%Pyd?(YD$lt_V%BURktfa2O(2RCrs`@Cd8-shTj^3FI*;c3vZe!#e2UT{)0iev1F zCI}CJC;Efxg}I|~F?)W=3NcRn^Ek}?8)CicydIaC8z|1#;fgGhUVPn61^Eyr0n3Ud z^ToF4xVVwHoZ;vcekUn$km}G9$}bO|ZEC1pHn1^;t9dC&+44BQ9OQk+Dd%Z zE1oB6va&M5tv#rlWL5OqgXeCDPU|isaEHBN8fxZi+OXPvteS|h{+UT>N?@)jC!G-< za&fMKxcOa+yn=kYKrI0!E1O|f{8HpWr)Rb0`m&d9s#b4C+bHfg2y^i)8>`WTtne8N9EUbA_ zJUdLjd=ol1Hb6YF&9u>(NP1-uI8-rwg#X1GDFC(`)ZQhF$DwfOl zan|#rT9(0cvN^1&^!79Cj_za<#*Vo>=|FNqD1ke}z)p~DAJ!Q>TW`h~EKh8xi#{E_ zt9UaTb4W3Di@3weFLkzo@+pJX53_ho2} zzOo*A!|Pi6NUNc7F@mgl=5i)3ejfC?AF+!&^JLhvZh3c)?m`Y=qFZF~^kC2O+<2Dx zeEjIiH5vtV3e^3dJt>`<42{BS?P*k@Gr8!qb{#H3eA;Zp>%pVS++ihsx&$EJTb~|3BFp}!;LiG)?KMb;$4+BOSt(~oORun8qyg4 zS;z1A9oFL>@LG9!bnoOOcLP`+%m1;Z^J|=OWx4l=Vo=^SPRlEdq14gQS3x-T1D{o6YP_U%|PXee~UOF;*X=WSUOO9|+KX^>$!pQc3~>{TH%T z_E|vZI_V^ScWY~_w|dEZt*85-0?MYX{s_vS)t#nbSjwDg9rS*?W|SBj%zvCWy**n3&Fcfus&_M^&Gb6oD3QixKC^5s z8f#Gx*2=P-x2JIivP-paRckgNb-61%kI=rB-XBniGUWDGw#NfZ%A0TBb^mVZZd~)4 zbx4*uM#6?$FxS2EW?uyTmiLibO+8lh9LLtiibk?f?t3$5h@!T26$bT&usWNjObOC3 zkB5`+oPeOgIp*ij^jovY=EM*=n<2NLyBU2Yw<@(f=O`LmYUzXZKSyOj^Bg(2wjpLJ zvDokN1wy&)+#tuG+Pj@Gtef??$YN4~WW`OJwYV-4=M33GIX)b)H?lpk+GM2)T6#C;R}k?+x$N^ zHt@&UG|OPF4w9wC+R{w=L20s4yzJC%MSLG^Hd(!dbbf>|Qc0)L0=xp>G_b^aD@w%^ z#xYH2X|;ug1IG<=thFIBI|9(-^x#iH8KNW3s`429)0hJ`$tVqE14*Ahn3+hf%5NVI z899wo$cnl1GHGr$Rw;>3uic>6r!fEB7l2f|usk`nxT8VfAWW|+Vqej7)bL^Ht_$Pf2pUF|y9dzb&o4p*a-qRl3z8wO;!#`BPh5E0NwHqr|ow(_~v5oOm z3KDype_WY`Nq)5LPvN36!#I}`h%soSCIB2Udo`7Gram^%#kcNUtS-^n$t~=%xdMJpI5dNznLvRj`9oakfjhada{^GZeRUHE^}Sx#Ulr- zOW$z!5@Vx+rt4W4x0N_U-P34A1v(S{P~vaIkOar1sad$j=Z&~1_@62JkEzkLRd}lT zgtnV3PIW2pQUS2i!L!iqYyTF^3OC18)n>A4u1H8Ak-*pGv9ao(KVe6GnE@NMW_)m8 zL3uj{SglR797X}3%GAr=Qb2?$MQK?TATOi_-Jk= zFe_cSirapUo=?KK`ZsiQ49GhJ@3bfAp8|LcxH3t=XWZCYMQjCk7sn@<(XQJasg?@g z>*#RB<`M@yF(W%(c4Uj2Vy7DTE}DT}1?yojR|Ga!lX=x15V>UMieEsV{rO~?;oP&;%m zx;a02;~AS&99j-^hS?DMl6gr(0dXM$xBW5il*MIG=Td~&Ns_FCH|E`b3jv~q=IVYV zsx&n0|AgINghQ_e<)Y@dzEqJ;j_~mu?Re9gT)YR%ZwPw0KJPGk#cM1T;)9*rlACuqb$v?Pu9Hw5`maiyKUsz+5UP;Pw3jkjNsSY~b zZQoWLuoXtGUe=?8|9USjDD(`5|EYt=@IxyIE~!t!i+& z6}s?U+fr-ND`ZL<0zer~$^Ldc-W^I~C2oCC9g~jU-yi9%tUUUwY2} zw!LWYjH_t1!-Y_hjV&Uusfj}^*8^KLg9q2D29*n40fxL3@Kk$iQtdWkkf(oQ)bk+J zHq#z2S}ACLQJ~K$)=Ba+`v~=iO#N{z1nSx92=$!Hi)AZ1qnir~27bVz3e<0Tac_|+ z>-{0BO(KdFz!_rohFXAsD32k=+rId3lW*QvUd6fj*B@UV`t4Vh_T)2SSgP3ua5&MUkg7LZ^zqcIq9Rni@GN zoO>@*4s<|P9T84GwPh5;54{VsQ?hSz-NSO>^ljbiFS7BWaQf3ruY}F^6#QT=u z&k040KGuURH5N)(yUYmXwJ?3dmkt?%0Rd|w|JX*Z(ZZTo_3yeS{(V;O?=Af|QM3P- zUew)J>T8DbzwMKUuW;v=NUvYmON|}_aQO`4+bMR+iWJg#_1oF@o*{bX`!2Wv$rktv zfnBtB37#u(JOa9MN`ew1a6JNAFSJd9LzHOu%=?7?Uzwg8i6+e8J z_y1+9est&;q$)5<9{^L+)pP-_GAKC7-@CXJIy4WUs+qM!%u%#W)hU&yob#T z&mNEVp~tN)J94#24U_Ma?6sUtm;XVW6x2VJh@GrDtsFpB>=@K9^6|V4+n4-ZY~6Sg zxjmEo8YJp*t5N*i*3s(rn-UVb3zE@jQ0BZR{i`yPYdsO02+dPq+gi1a1kk z$9x(BtqgoI`F@AESS+{O=PYdBU7`FXpzc7Ik^cI~Y!TqtCfL^wia5Bk58wNC8~_oC z+mRUasD1i7Icq3qvy{D|T}!_U?=rW`1gG|emXz(c2&2PW+tyAZdn(+pm4ScHSkma$#$%J(51TOLvSck+UjN)*RMF_kG6bi0?HZoFx z*&-tH*HB#kJ{ah)7vR9(?CBPxQ7!9fs*|3?`YRlo&UO<*Gee1IkXSGFzy zYlaDyjVrr<3tRhV!*GVuoN}!0$AaotaDEtjA|pAz&VZS0%Fy>}UFXf7I1;baKRL^f zjCVqp7R{5n?-UdiihLM1_+CR56?3Gu(72oMftid3NlKoTrw6|)hNh|jP#3Z~l3r&p znOrY7|Ev#1e}b^Jw6eJJ1Y03YccuiV|@TL(A28boJ8CQx?%Xi#HEM zmfp%yNne9^Hpg0zji;$8HjP*h@+u_-$lX{;Yqw-6pXu08Y4X0Tvz}ix{pdU)IFRc-#W&e-W#hAc^kVMU1%0Dcw? zIO9D?da&EvaKGWUC#DUe4wtSCl^lPsyu75KbR>mi=Jf&V(NipP*`N!jN7XNz z{Q0^=EZZxI%MGps*<``18}%1XR!fvuP3wAc|@yQ5X103+L{G-h|^)$pY-#v01WHN~5? z8gA(MMlUj=FNa4`+_3Lz(|rxP52BTOgz#^q0)sOzZD8#AgN#y}Qiv=2xSYvI=XY3b z{&Q(Va6svt#D|W7P`AW#7y$MfG6N?*u6p!Sm^jOZC4VfdJ2CvNLZ6?kj>!%%X9M^) z96dbZdc#;tWb*k5!z#@s<}2D_8(5!6{I5wPU4=5qRI(}(A_BNse+N17e?__82Y2Z( z5}z08?Cji7GCizLE=jTF_<8E8b9>t(<89W=HP>1eP*DQL<9$yO3U_*q3Q~zP)_jdu zPVH&`K-bio9!vJU-W=>V{>FdqCmf_v`$x3z>1l7&THXeq5LQd9o8w5nEor*F*k*Pd zkZh1-2}=Dn16_7MD(cFSf_(SBxyn=vlD{X*Nqy}QHZV2V9ddgQINoH9BZ}wU8I?Pi z)k@P=4m^0^>Nl>!m?ISzmSVGwYc4aQLh=c3J%^0ckv;9YunX^Jp=b18PIKlDk6{j3 zea2|sFQng ze{2S7mjHFlN)2GP^NzNE)f0KMfWFo3TpLLv205^!P$ci$kkOq1=m)E@Tn@8>&g*}M zolUQ!bDE+wSw`DzUNn{HUBaR}hD#@?T!kxK4!x9L($ta#_riK(oVgjbhRx$Fk|{*- z;xuk6zsi;q$^Ahset;+>X$5S&=#IXYoKr|UHPUTUHJ?Q8+mLwByA80qz6=7Y7wa%1 zQ~qUgrbQdmqJ4>fFpq-Mzp#WwI7OChsEe_l?{+y|3+AUynI0DA4<;xM**ElI~8(sOMiq z+A1`Z70Y1@+_X9(y=CXZ%@~-*l}XU4dQ;c}<(73Amt9J?maFogcbb>-F9a z4@^1=J(o2JSW$#e1ua24kZ{u{>U8p&iH-A9HkFrkW3QuXp0aVvATnBi5o@dUV`sfj zRN~m()OG(+{M?tngtUbyQquOql?Dt*oNNooBAsg47#-a}|I*d?riQ7(;F#(k^l3KO zOVu-gF($(s9d#L4@^UPBd6Q@_PHFRQ8Y|!&M6qi#>eEaj?>ybW6*D02WyRZG*G0!tF2Xr!r*^hOUEX#P27v5 z+FMILRV)E4xST&>X~kkUb^>nZZ*xu0Vh8AYSKowaa{oZnDh%wM!obS#Kyi3xk3g08 z{q~XPejX08eaUZtTK*hp+{LA38YPw`QMDXe$&~3Ee4GKdSIX}BbW2OGq?O2vw;m42Ajyv!%)>fO;m8W zHpp#Cf%f3yp=1hx!II0#obe$46f=)eM_eM!!hU$J)=dj`LA(SYN`@ zlV`mfLSG+5ciKAu#IUu!wvgzfV9)we*J_q@z!^{2n{x#@z8ZzZas1okhaX2Y_v%D{y4zdVg;%cU4N~O z1Njx1z!ocSAbpwj5VxHIXl3jIZnyU<&E(=hZ)WEyx&`YL0NMn+uvrGW2si7GJPBk) z3%uL`n`@)Mkn#Aa0HOOg3dAhKQ>E>#_w?-8eZlM)+KqM^Z+uP6wMLRMMwMDx^ZxPC z9Z*8B<=zu3R|@dX#JhXrf%)dY2DT_8Z6fa1g4}zclLmMTAVEs%C(M&{4IuRddh3&8 z;MM#QY4Bew&{G&9YTs5Wq}6#!EPy)TuAgvvnWO+;9U=ycrt@r8B9V?J?Z&{!0Q-ah zM6Y3|--%xTM@HaRCOdZ2{Zh05>Jo5p4vX}bf6k3iDb1!^3`zG3u`%HJ3cwp#;1|vS zI+MW<&J6;vS*?)tDPRK%t#v}aD{*B*43GvuETKUT5T$^f54cLIIBSk=fPp=BQEtS;}_%2(|5f2x=kBE(0foG155o&13fsG5y#Ye#E2CJ~Q7y9{% zz)mpM7-4>CtenJ8=5~``9tzxk0i5NhBoP%U^!7EA0BfI7_&woIa4rGMM<{U_%qv9J zer}l7bUD-Qm15TL+7at7MMCr1!stF_^%#89v;t1$#b2y%AX&(@G%PCd79{bxGvolbO8Q_C*ocMv%kZV`rJ2aM?`TTvUg1u-Qcu7HOH*q*yjA43XI*}N*LAD=4S6$x+tviI)vhP${AtB!1r4%s;M z!`4;y(gG%4hxk5A0f|qcTKD6{n?iQu+}5rC3GeIkA3Pg=eFzR-;C=q$+@RYs4Xiy$t=Q3y-M_Fz*L|l5%_s&=Ov_=%_aLqb zNs_=nz$=#+3w+_WRgGuI=ceo3sQ*S1U4UJ(PyN(xA9=?`+@X2pBz4o>1!^f0DVsEI zbE!$6eq1}hcr$WQj*t#|3)g0)C)d4htC)}xYIXp9y5VPOi7+7nb0{22AOb=(+Vw^inxkjlG&Le6pV6b&Zt(+m(V-Y_}?%I+kc`*@Y^5eR(bIP7xLus3m z-@2ZC6@2+bycHzrW6SvXrIH6O)n`jA3=#EAv=$eg4v=@M^pwN4Acra4<1e{=;dI5g*f3b*1+{^>~e0B~F2LYdn zc!hvMk>I;P65um+`+ysI+V|3wiqzM4^6OtcxkW#YhBWV;)x)2m7FMw&%I@#lg_LeMKpVQO z!9An=oU|8m+WrFiPW}taoq#6ZTNL(!dLv}mczSt`&r9Q~%wuA&jAOOk7_qyUcEtAK zszx88^*zP9lE}z@rj>Hf>CJHSw5>1==7_DLg;O+IF@({uJt+oK1tHhFgS& zhhxnK`p0MOwNbN2o?NfK2*-AIg!rVtaO142v+sSmu4iT@ zmzVoRou{&`0T;BJ=bIJ$)oL&;{xVk2JLNb^7j`c)v}b1c4zAa+I+X2NL$0~8wTWT`sJjS9f>-O|c8G6?k(d@ekNm!xd#%`)>l)Zl#F8(Sh#!XMLgv)rx);e+4 z>50n}>8fY#4kS~HR$BSoHY-_^<{MwPQejnH;Cg8F+fGmRC(AD{7p*NE8#k<*?X!!! zG1c3wpi0IS6R7udf>Ycu?&bvzRx4=J-fXnSjw@{)A^mGzPK(J{>BEC{1{96#Zrt#? za*rQ*-yR(>#+Y(sy=ZqY}xh{OMvBetx=SWn;w0*`X!)wymoQdaScG!yTN;%XagFF%8EpTF>Ymzw@Z{r9;yD zJxFR#K}P$fv$?0-hxf7GNgBDy-=>B%jdrqW!R+%pbI)}S7hGoDN9~tZsrguQ8to-R z3DGT2U=`dDpmQnJyHK#YQEMf{H_f#>+*i+`0Q5)&1uwg-k6?**<$p z8MDW+GiS%NxLe>U)!Y7JPh|#g_rwmiy^R;$s2f(5iN!d`oz@gvY(-LPF6%r0p>X$U z-*M*$P=8&2O6wE3t*#X{Rb`$dnkiW>xm#<`x^<4it1CNiSx^fm#8kfM2I;fz! z`>LJ`IBPD8))bgy9)dO;aSNMJ| zuU&@F*nqSO4h#&F{$$#p`q7PfJSggIfB(eQMK)XF7);p~c?|6!vQ)R2AYv@b8ZMAftfk=3Uo4fmss|kxK z$-{2DY+X*i9iZ3MIZAmcBinOcp)O~wRA=4A;gz6W!>y|w`ce8NdxjprFbLQ&@1C2= z?yCLxQMQTc?#v_B*@>y;x*aNcZ<|z5`}Mh7L9MIXc{%yGC5Tr^krEVjRG#~cY|;5q zU$Ws?{T`FyeXvhz-s#jOCkj$|MBlj{K!FkDE!w1Im$>Ex+oMtBX<}Pce$nozx3|{? zHpjMy?|$>%Ku+ApXjr;nK6<}M_$&rH=vrEd8&=>aHHi1` zgs2!Z6tJ!tn~)BN(1lZ14ej2Xhe|3%?Dp~GRGOMnD-Ha%ARP?Rh4beJLi6Tv?_2#1 zOegg49|xyb8I27p*+w-SR}c*R%h0m8!NhIITGRHsJ3o@sW3(HF{9?*%?rXQq?%41INy?y4ZVRV;(%G)5 zwxnY%na!Cpa8Q(&TR3%m-<7@{LjDDVJlP`$0#7sCr%ePOeLj59^y@?<#y$wtWrTv#QWA|)(QzxL^f}#>PPYLiDS-Rgyh68^S((ofiHjpA4r6Mf2KyqRckzPcn zgG7uZj2}D>4=w@@KY}BGYXQIgJRX;Z2XTxa0-i8}A6dYU&EY1h_5`a0?^&g%QF6 zcp3yVe&`EyI^C2Tyb1leDgF6#dXWvtmrg9AgB(Zj^aTQa0Xz-b1H2`uKBEx&_CumN zvN-TrcDQI7xj`Vp?-+leP9HtgAP^+v-0727yyIpDs1c@PmgD3RHu)p(MI7e(T4t~O zq+4z{_QQ9&SPpsb^^3ntwiPNgEYh`1~P5L=80$C-yvG$sKDEL#`Q9?S!iW7GrY)&FQ3!h?|cMVn(JCD=iY!R!CAY&ccB;6FS;~ z%9J02bkLrQ@#_BL1@~;3hTG#WqwdSlXnq|m7Bp%seJdv-XN%k_YI3;aa-q487eynA zb+m>gVBv9!4@Hl=jH0=uRzRiY&NtG$na0}UqibfIbt)~5P;nnwKH84&#cGIg#k9T| zCX+6mtC&3A$L-_nVvjQ4w3{acyKUA&CW75|){SEEcV4k159kGzMUWqSTBK+V5up4M z^);F4q#|W6|O)W*{D4d-z&cH<209?fUNci%f!p2%J@x_WFl_JD3Cj#_ugHZ#@Qm; zrOW&Hcwo!A!HDk*tLR-<)sQteAFgI;ot^aY@b7-yYZBebj;^S3=Hf+h#gAz81-hoj zhqn!Q5}`(}G9O6Er$r+Bwb~B4V`!kCaHyft@`z@M@EXsxf#2R%?4gWv<4>!dE8zBNE{sjx;-?=jl7xQ0XBUj?~4M z@Mc@%V`|1fIr~18KRqZAcL3Y1cEEq-Q-5WikyotLz|HZ`s2Gp-@ea-B?1@ zxSWJtHmOXxH(|eI&iFcG0*DiqNnER67xNMwQW;DuEV15;L+k<{rpp5*T)1i!YW&eL zuBl~kWGIJ2vtY#D^%S98Bcd*IAC{sZTFt|a={dq|z54y?`r3$bCP&?Rf7%TWF`1K@7!~^>D@J)MCzp>v z`HPbZkKdYmh}n8g4Y-*&BV|UOIl0{R*ajYnfvDV;gh_8HR>?IEk!6uJf#oZ`@4PZq zLcNR&YujrUA#tQrjA;eC)N@a+GPu5}Mn>}RUT%zNcYT)D{XNSwvQ@H3Tfx%^Cw%5D z?tl`#h1vd*4(ID&nbFCPz&w;cDWV{>F{R+O8pUkgd!u}bk9x6{D%89XlDeQRMSf=H zLTTR1!aQ8>;j6q>e74vPF_3G05ZNesIL^qkcqKR{UEEx=hoXW#7t~c6Ulue0(HVZB zcF7)1&#G?UOe=Q2E`7c=W27vyX|N&1e0`cq#i<$=B<>@;ze?tM0-93vBLU1v?Fl`x zW#l5J{85`P;=u>eW!Id7ps(v0!JaCnXg0cC;xN&O)rC<>LBq zOd}X%zq2&&<>rP^H2-dmuEQ~>JU)nt|L%7m`os17H}n0>A!jB#8zfeU>4q`rN{*hqU6yif+Q4d= zNw}EJ1S}U3`AVJvNpXmM>Hz!nRJ)%guy2AoW@}A`mhD{?27_#ZyC&FSu(vUZaFD^9 zjnk+8Yh&j(jq^{MN&oN3R4po(MP~XGj+k}5iej#37HuMegp}E>bkf&t^vV|7oASFe z+Vc5G`k-l*ZO1y%{u#a`(5vd{=wn8nSIjnON#?7a0_3M`Y;RkP6j#)H1oS^!D_iH| zZnZy|4#Hhe{uYDS?rq_Gs+GMntxC@%1-|s#hBSIoZ^Mb0fnd3f7|>Bl^)AyHosMgj z7be}ylh$#(ozTdXl%s!<8lfqRKV>7Nt#F>1`Kkd6RM9@MPdS&J{VLy0VQg~6Mk5M@ z!*BX?jJjBE{s;y|+kIP0p{mLh1PqoNB#+~?E-`cUpkXN}Mx2Pj3$8G(NYlO2+}s#5 z_r8kU?3N++X%`=LMlM+i6vRw(f9P7$;B!KMVzFmd1rHS3qv#MQTz3qq@e~93IRD`8 z?~VLFGl>6h=%rCLooDoZ-=>tse-RdB6k?WMYU6FK{&8mTf$*-aIQ|gt3_n)f=5A$A# z)Vmo`m_Qt96YLzIsLn1fgu0n0;)VVEH^OZ*ch-%>HmB(~-wNN?m|nDmu7>F@T0s|j zM#z3DBRiO+&FQ}sswn!M+-Wm^wQL7l{BiHx0noD@gqd#Ww}V~Gs*&`M@c7c@j&TER zYQ+im#(PX>WL!U{(O6Tsx^I^(XF9TSN)Dc(m6<56tPP)c=ab@VDXIQ2eFhcgtY;9_ z&+cH^>v9D4j;D5)q`4H#H6M3eWyQ<=GojjUT+gAm={)n@BM${k%LAEHR(cT^QIe}m zDCQIwMrs{ce)ZRA73hr#jb08xQxzzGNB9eV#S(9r^mD`!8F!ZjX6pvQE60N1d^)IC zO($7oy#HL#nUZCbJ8qTWX_KO>tT}A3{OjNTZ(5se3X>iSFg+GzAZcYF35{M7S$N%xC{Iva`CHsU%J%=fd`R>gm1dEL87!P;R zopZ0Z-|n6Mu^nHUsAs3h^X-OUGpRm&WxF*k#h%^$(q@h<5tp`G=5E$io*%ZGH+P@b zDbR=?N z1ZwHGvDVh+c&K=AqR zkS4XqKxf8WID!QC!@4^(am>smS75r5P^jcn%#;6hQP~O1qn|?b^i;jd3TF(4GSbD| z8kw1kLNQM=5Ky1(+4F`??=-=#m)%WlH+RnuFx_l(=FxTil_qj^O$42OHGk%H=_2)H z#Y~z)-)~Y>59acS5)Vc+heo_IMKnn;mh!6^Y??UV-PoEbCyV@FIb0>e~-**gD-ZmLyEMiktX6(mN$q#vAi z6SwaA4%3dzA=^q6mFk@{1l~o=i(Kxytq(S$WrBg$!mVf(4&= z7WIpZ6;pgUMh|Lqi??fG`U2%3GWR-j3R?wx-TTMWsQcqKX7TDNYTVpC^00SG@;IIV z7ysPR7uegFw?(_TyKeoJNdQX84I^Bp2USFuEeLlizlqsg>dGzzt4yvQ^Ieb34Ig9; zMoY9piDp~tq^DJ`9LyL3RMDK9!wfE=V7B?f_z><6<>4x+;flR?R_Y}kRcy8g!gMV&bLBd zya2Em0c!Lg-9$Zd+sOto(E(k_eK(e~S6Tndnw%XXSXNne@n2tmVW_!3B-ttI(2Z%j zxt_&l!MFxjAf23^9;x=4I@?QMRN$k-jBZv`Z;o_pc-^H%%$c`jSVzmzKLsqr+h$Bn z(tQ+j9*uSJmq}I1;r98#>GQsOuyYS-d#YBODJNw*{K;qumDllGp=_EtnTp<3e)=e1 z+nT&h=coqCZopEoEc2Oe|g%7;ty_Zl>qP7JOf>VvwHaR?Yy^GyQ@Fh7T!(WPJ+0=7q|c=cG%pWU z*vN05*4~;EP%zt5(Z3ZTbC;S|pQ1>eb?b`2Y%NS*6bg3!7!{j%#lqbC7^SPqg(F3$ zOQ>9`atz;HY2-GeZIkGnZ3>UF3OeU@jJkU`Zsjm?Pfb-wmE&O6+BBWi71ZW+;^#pf zTaH0Q6-^Yq5Ss35e8zWTIZv6tbk6*9$jB92ofvZHqovLQ3`erk#;sJ&Gt<>qm%)@( z;odbI8eY@K-mY%@(2QDDMY~^+>pMAf&h66L%UHz%Td0rEa)f=s4gI-#2UR;-K66S` z%YpJuy#VVudLZ$34^7c(Mmx}PvuJ&-GdhBlRJIG7z%oj6aZ)7DT`MURK?b;!hA(ox zSK`mGZ8=aDv1)*(DFjJXURLC7R{+%tY6-(EizC+(g%aBQrv#T%nV^#|3*gR+@!Bt@ zqh;{3H1Ccdw>E9E&|X6EcjP7vQ07jnH{*)LJlEF_BB^ex!xt+H_4Y^(^;&sV8Lvh_ zqMR$xUIV*K(7@*PQ5jUIT)cZHO0@e5+yN99MO5xPd(@Z75%;U zt(;-5Jk6<9#I3-wqs_2(9fw_mqxeH*xfJWHyjZ~?InRLnt{y^Z8LdDHx^Zn)wxB>V z{SAADMVDZ?4c*6U)2g@M#%g@OW@4u54ehW8aaEPfDISq1p{`zHsfwzX2_JMaN)A5f z)!JpdxJ46ide!sYbofA`s(KmzZe#IkO7EvId;)MMB+uyT3D zl&$oAw?1_t%E(-7ke7ePQ}pkh-XC%PjUQ?@A!T)Pb7iS~Bc%0}j+xZPCli@gfVbx- zTc^&<`O8C)AB|9I^k8aQVqhnsgM-yVJ7I!gAs;d;#}3>Iixor-i^<-svBZ zYpW*a8)Lob!%JgB5-N>NZdJwe_JbztR_g1;+2#Uo<)^<#x=|-wA}f_Q#d8Ro$ut*R z+6}%ats-@MXRqaUNRhDu)JL`t={>FvU)lW&aB_Jpo=%o8Uks@p9-4btEOq~!kJmgQ zM^r#C|8ieuooEs77*XCXXppEJWUur=2Ms)8V%jmK%Ds2?+k7V5#Ew=h zbaYvmm`a~(sP7J3q;DaD+o1B@XHaM1`v+qs*B9r8w#L!%{$tK)wcbO~3F(A5;X)-O zLVoCkS9_;3Z9!CBIDmcv87@NHJ2E6;@%bbC?Via)$eP4;3lqyeQ}y)G^;fxS*isO>oM(yw*i>lf2XVVeT58cF?n^ZFd)Cmy|4h@ zM!fKfFFmtgl=bZ-@IbieIyEnPDetNiZ6>|n@`}54U~bE&2IBbnSETNxH+-LuC;P-} z*js)j+|&BxjUPKMFuB&AT>j+QbO7EKY_e~zMOAG?UqnU}1Kbp^e#_J&S$>1mZ+;XP z&fkyVbCxnD|K9>7!Ax zTUGbo*`<3GHzAqh-@v**>TKdzTj|sK(IBO>UJ}t2PtR4%cW-XGDaYBUi>2?Vt3`Z& z9eDeaGQ!_bQ&jU56gZ-l$8RirW$P(sn7mciI=ds&{wZXw%l?9Fs23T(ar`C9ZZaHy ztxYq|L$SN+9O!N0&O#D%PsypcCdsq|W|gNQ6gvWg z#=24Tz=p^s4P<-+#W}@v$kP&AnqM z6}iBytiItjlI83xhZC4PS@5I7G7I4N&8-YT-{*hm;J>0c z`1h_O|AGYKe`fTtW@{sw|$HGf;aIY!b6U$wnAD_ zp?{(HzuAdHJO_YFhtcWae(ca_#|NF0`zNQypdSq~UeV4Sjmuv4~x zq5d}}y7d<)X8=hWYN`08S{bP{yh29b)2J3hd2a4VfPZy(^hmRAA&o991P7I z0xJR;50~z&!z08rs~?&^FQq32)Y~ZEK>XUvIoGHu*ggfzCu8k#V^`S$KuoaJnEdulATWQyM zu=3wZ(}K0zd@XHngOQ=cw~D5L$*ghv*}DP)B{SU(y`~S;YPJKIp}o?x_vE%K85APQ zcsXhR^4pDpS-Ax8dhVB5p|=xy+AxmN@aVgc$lcsf=+85DD2TW2zf9j+Tp4T=0)>7b zfq`5S`CTjMf9ewWH>>%trk0b$CSfgos-a(+;nDlcaJPx9Fb|EaI99yvf&FVoUwwY^ zRKps4B|ml0E{9?Dv;c?l@A2s`F}bB(TfPD16AR5Y=&ow_UOUFR=BBSr-5%aEYMJ%j zU{&qTilKx%%Rzl|i@CA&k(%*gkFw2$ApwQVjr(M9iozRri0fvw%`yDAV4+JjNu@KZA!G0(z5&s1uj4WY_0h z#w~obdhoI{$9>{KsU``)c(r%bS$bq`tWah?;}vqYo?0OpLYtEXW4Ag72T#1tR{oij zp~M-ohqbqyiI3<#qLg{S`IH4s?b4<2)4x zDX$D7fNMim`OR4ipkC_QQUUW+QnM%z>`!Tq86OJ>bRj*yU{Xs7!MN8A=6!X`nvM3X zP;Y+zU*h3qgH(wAk$CD6jd?VO?xz<(ZcRX_u2YLM(v2xet7W$I#v#)!cI(0w*12#C zL_o^hME^Bc^COL!8(ecCb1Ei!I`q~?pHT7QmY#rxta@7?_j#@y1?Wc0g!+QRP$oiF zrn#He{Vu4le&}b+azjkeTA3|NikG}#8Qn8F=V?)4t&;-GwTjY5KT%IAzE2PJIGB)w z=!~~h-S3Oz0YuMhe%1i(+bi`{(IIT0{_gVfQjipFt*P~vY0*WIW{L(zvNl^3s<^== zOtW)aRHNEZ6P2{a9>WVMwg;h;j|$;)Qq-+Jh3T+?#%6WJAA1n7S}`4SYPPC7>JU|f zowwFm18^JXR>tnZlbxyTcofBYpnCH&=#b=CIsB~k>ISL7!$nd4nJl~m0c|nTfk_|V zDqC+P4fs~koSjtn2LuOAP=OstU6@8M@(sOCPt{8a)<%>?Jl~u>Qh7q#1Hj6`{fauO z>~+V|BM@Fwm);0-oJAjjwO_E^HMo8vvjRZb+8zRZbK3a?dqz}Cf-Ky_qBL5@j~5%I zp`IomYqOG2-W5cWx`6VX%&ac6AZV=8=8A=WCMU|&&W_@XoI}t$@rpM%ONo$4Bh)O{ zcw`4n^1g`!tX;#Fb8s1z8Ik8p%FI)~fnFI$%dCG^erk0vz-=`}abku|vlZq_@BPHz zoZ4~{t;CHrSMr+|8Jav?nxN=5GaIg;`o7A!i{jPYcGNH^kY#ktW~lZ?*|lIa0tWau z*Wjp$iQK2fcva7}jO*$K}yB=R1>tAs0 zH9*Q`^;rHgbECDPfyVfoCssv}qHX?^vgSF1gm!Tx^-b6C#X#|V_6(h_17-Ec4XwIG z9YW2r%BIyfd9YG8Ix@=BFU|wde7(8aVKvdKSUs}&ro3m^?dAHu2-4`Yx{c`zC}Z0l zotE(xS&bcT#XzzeXyi5@xaJrj(mGf5$>tZ;d|D5+cd5WntHj?yCq`)2d*&RfR)L~+ zT&dZ9K`lvU&J?&X3gJ1uOgA{E!VB@Ufo}U=7kK+wQO_0B2!(^5Lrq`t`m}^PpHCa6 zR?^n*s4I9<^QwCSHm$WOIjuRyyZM}`c|;npFAn_o+ZU6^fX2E*XLe?8u4<8_Tt%Ke zXAjO7sJF&etvgaWR~{oO<(A6HM*tEYoLyakI=*ayfin9fyX{9?kMG{MFLer+JZLluAoU}&5u2YRBOCB*anYU@9Nvm^F3VpaP&Xw(+( z&1=t|c)=~GzWLR8xheawvqfQ$A|p{KKUv@RrvIhQ2+q_=zlifH_MT^VC6>1k4Ah;? zfhfC6tdNNv*>(;!OD-0j@*82=Rl~nU&e1M9XMQ6rqc#4doXiKEug59$6E#*^Y{{tr zBD2Ufy(c!y*NP$UenrP8RBhDeer3nE>NVr{2p}QPvzZoO7q;4W-mw|6_H?_twfPi! z!_)Ml_Uo86JD%tjrfW>h!#lo^N9XDpKShK2SA;q%oQ}W;~~R`q(!)c3j|rx#X8bX-MYeujF`JjO_um*|%g_ zFe~n^ViBL7s3|u~?W*Gk*qC_Sfg#G)D_34ypD~G+RnUYYJI|rc#v&tP!~9obl^bFC zGqQslA+%THv@m%)UY(JfiP6f2n>N3=@x5fqeXi|1PV1WRob`%CoVM^h_^BzsEK9xf z%Jqd)@4CisYaMW}CHKQaia)@v%J8k+*4^B6-bG@Prih1k{oTP3b--m;3tq%vG8b;^ z2I-A6G391wtF^C2tiB)Yzv(s0q{!?1s)us7&l5#rKh{17;m;bK34bGW;y&km3fMpo zFRj@wwfR59Z;2{VEoq*!GA8W5PmY0E?=21Xaj=Zj@xOK_Qi(7~xHmD>pr^JUSi56T) zKN}^r8>40{2MX$q3nU1#M;rYB#McL~K@`l-U}xgEAKP}@0}$SVucCtHmUl{-B7Hk{ zb7KYy>OBC$d;7lD;05s>3yS>4&(h4yS4tctcj+7Oo{lxY2#DOrnU4noPJ)^&0l6SE zMm|xK?H?aN`=4dG|I54V|MH;Szv(@HRjT|}xpkF~p-TR;*DzZ3l`~#__jL;r2ezwv zt)N$_Y|yzx8pG1Xh7g^N3BJi+M9W~y4EL)!ALkgXC9j|z;~H?R*zwJ`&GhdHwzj3* z2w4+;je^Zw5eo*NF5cF_GK0O$DU^uGArGaqrM^CpWkPxyn&$yH3y@hed6t1|(~(FG z@?}3b*kR1PXl8PKqk!fIyN;Qp(D2)Wl8$Hw`R$wkn~iYsh3poDE@C@w^!#%5LiOX2 zQ>{w*G1UyvlNn?3uff!WFqiKBnYYy)su%_cVpKw>14@lVTsl^!Ps0v2{GPJq9c41dh8 z)Z;|u{5hTkw8*&wzCzr=W{oz(SIbruk=p%7<8B3!MF2!DsrK9hRHOZ0gw0O51B|Q` zdYl3{e=f+~Y0F5jgv@3-8v7_ndw@Z0lZF6|^ljrX+uhGrUvzZYoA&`9idWRq9x^fVSFOD%( z>4|-Rtv)~fW`38OpNcQSt2i*c%wI)P)51I)FFf~lM8Hga=%F4%XQ@a?SDekeW<>C$ zN%b&aSsYoA|4XVnu&XAQ=ALpeKP(8jTDc*|+t# zrrAuE7oOez33ay259q>v#6qn zmOn&cAW`QTbo%W}2D@f+Nn^lgnCTA;H2qIU?Oi)glm<`lg&yq=-Q~UrV`fg$0!vZ! zziwpw@A2gSi7rl3Ds3CB=?gO{n)c8bM~2?~fD{9kRA9i7^nfG?WM?ho_X3>TK0S2P zRj6*hKQm(~xD(D;#eScKl@7n{^N_#|4%b(olYz(CcVm*fz*U>$GF<*+TDJmUCqhT?up?Q zjY@bk>Q!FZ{BWg?Oq|(UMcop&-wcRutmB zf2vS52^lzyglKWq#fG+`)B9GiqN%fh6SwTBb1EIAqurKg*TSXf18UrmS8(f8i=`9$ zErxo|#d^MAI;M)$(AmU19Dh+?KcSjdT$jp*dhqHZbq=u>Y_YO=>g+7w#H3wy+66zp z7ZHb$I5dl`%utXM0@xs@h|Y*}noXr>M(>B;Xi2W0o_fX4FoB`I=&zO%n6K&14d zAw;&NjJJ#Mp!*%Lt?sJK%oxCok>F`I zuuJ*}x40xgt5-pC>=|b3+m1pemaNVm{AGldm*2e41M60mGxRLZZ64&6TAc3Q18#S&8-$jf) z9QYLfNq2^Qy;=;MPb_s_XeX1-s&|-DMxq5mDf@O~Us!VvW(dG^;}r3;#f|>i4;v4Z z>3oOWoNS+)b{xD>g@47(6)SL2wASfOQ3Pi15wH2x4!*{~^ti{0o-23V$1FY8#~-!c z5+|xe*evb7y4%V?6E)>rLbbbGrQ@tHWFOnGL*YO(Ai_sASBC?pmmF@m;+@Lqk7VwS zJ+p0B@mXdOJB*xjTJ>-oN+ME431k_C(%`_G2+eb@@VWW0@SKI^^GKrBJHT^T7NSKWGV(t;Nv!$zOiiJF%6Q5j@+*lPEYI zqk1DO=b>rJJ6QW!kM)v{yVqvU5-JYEbW@Ciyvh+>`q;&${bi)8IcLS48JY#6&FPbk z*GNt8VEF?9x@3dq7zrOM1q$B<)Gx9Q^Q)H&Z0FEkrkl_k zq@d!SDIz{JlSkBvP}`B~@1yP&B2eTC)6Ee^I142DqN-P2v|n=NovG(9|5PpV{Ke?Q zfn(OS+27;Ty@>24x5Pz|92X==s;r7?(u z={}hOd81;28Xl>7Zc>es!ahr!rKRBB?h3!hY^@$z!5fIE`=K6D-rbxdwcgP4)G92m z%%t^PmCp$>;&XB%qHG0dhcnLpmqYj;5AgpzV-2AiQc+ZnVR7i~u1$Q}TC@5uCZnxG zsv9SCc90GtKPp8xUoJK8ITW5C0)38xy)z~{SgS5lM_SSLRVOHGXZyA=XPo3DJs-hN zfdg5b=?WF3nrIhmY zK{cZ0WGtUgNPl00RNdqm`H=H9FG_P_VBrH>e!jI?E1Of3~?<`X!I zh7I+_fB;y#)YM|cYJyW2!I&(z&Y4ut2S-M4c@^ z6Qg`yBZXx1QK{CxGvt(M^0nCDp1Ws2o#k8)LN~_ns~xnH77qt#khFoL@bhM;QIs>Y z%gU#wJUh`{l9d;NF+g%)8PJT|F+KXMZ&MEl7CqH{`*M8Bd+T}&)W$_J^UiQapLqSF z?of$RoZulOIB92Sk%!r$3|7Sufners-C=b{XC)1B`~@QN!QM~-5EyPh?*7j zfIim(AA~*b!QeELG`(Nw#GVS7BCgT(mI0d&8Ym!>KslU8-TyI}Q*Cs4x%|v5M{}uK z=Djy`KF0U>7{iO59ep^Zj_|ylnRzBG0j{f%Y&1hmrHW)$nJvHjRI`Ka%_|n`6MLw% zcYKNqTFa{kl?RSaUg8Bkr4!@c{jRhWW5MGpf+P@aayBYP94rYT75xbO=1j7gmGB}U lj{hyT$UkiZ(c#)ZbpKTNKE4(F`YXt}Guo%KPhGw9{{fQvoHzgg diff --git a/vignettes/articles/figures/unnamed-chunk-5-1.png b/vignettes/articles/figures/unnamed-chunk-5-1.png index af1178f30cc849ceebabb0143ea72450f28a8da6..241b54e4267f3970a999308f2be811ae39ba6933 100644 GIT binary patch literal 11667 zcmeHt2~<-_(`Ys%xBv=@2uM^0bOdo{4T&o_B5@W)P(U071qDPl2_!*K#t)G=I3l~- z$S?>|kev_#AutReVnEga0mB}W03qxBJ2>+#|NG~BZ{B%!+g)8%T~%FG z-M4QZb+TW!c+FxM47Ti$!~QQ|utj(n3^{^Ef|eKGSHFP4;Pyuyzd8UuVK8eL%nN31 z4YLMsD$J`0d|N9YFKaJQsMer`+I_sD+6%y0g96%$yr|t?MW8@bYZ%qbnp)IN1@&$y zTlth`XEU=)OS4PCo0ZK3g;V4OEAp}~qJjcoyNkM^A_xL-07wa_e3+$7P*|l*PALl% zJ`-Rm1!bX`$zrlNOwh>TFgf52u}ZU9%u*JU$zqkVl${(FhtC4-e5jjh-A(oCE&_$x z-3@g^5Qmw~VU}`OpfEWs01MFYIebtc4g`%v2J%^@d=`_>0foiqg917sJ_JEUUH~1` zT?7F{945qPL3|Db`jqS|5km`5&TrpU13{_Z0&Iibo ziuuEYP-7o`YN2lsmolOE3uK}g;Uihyt_ZfIU)kwWn3)R+cH6O!oZ(QOxjnW~Juogf?b1wEor$Wmn}s)El|^68oW5xpKB(A>-u4`_Di++Gca&>82EF-s!_ zL{^7FA>nJ|jul@u-Yjh&7~7NLuLzoLY?;e!(!r%xI*!IdFU8;ao(x?}Wh-W9lStgh zEvvFj&1W0tj#+9_a~nz9>32tK86r8^dZ(;zSBlC|V`tLDk_MVd2VauoY*8d**4|SHCp9ObG8z&kXt|nPvAR_-0o12nJ4^ul4J)uaU@4kZC znN`WS?-kfy@ExPXnmi*!CT(+PsCj>>zqDR(oG~zmYHnYS6vV~m=rlAJPj+oEZA|P~ zvaL7Y*W?s=DlyjgctYE=iPE0OBzO6-fhw2lab!|URE*cZ2-uY^#l+R-s55LWL))& zO0#z7(ZIt;R=p*XZPr48gwO5Lu`Mvcyl*xQ%Y`~yd`QP zqiIk;E}yTI_Fusi5TvbxK6%)Sh0@orD=8E1bI%sBrD9pCL_=d4V^+VuYh`CeN`X|} z&}_;mqGFfqu;TU8TBwG6U%^Xlj2+D*(@VCuX^BqNafMZtGDaLOH3>CTqvucPzi42N z5!yfBT{Jw_`C*twDv0r;KBcCWoBBeHQ#&~K;GNi1mfKTv@=ULxLLL@jiHVC1_|TTOYJO_N2`M7qJ0|y> zt++R`2AIyQZB3owpycbDjUMcEm>enEaLSQ>KZJeGF|SRk7y3$Fbx0mfUj0gJ#Zi@1)*{S1}1%GK-N2TvxHEM?Xi z+{{gCpIUU5jn1*Jx~KEpdp@0VF|wg=iJM}|0Ff`xGtr~%Ow}mmZGY-5>eFyG-(aIp zO}F`x=%pU)gAV%wP{X;qT@6&xSY0=ES}$Zg0;3gd*{CX-5v= zSDCC0U-{k(KNtTzYZ37VE&wy2pqLU)MDWuQ`QrY;y6CgM@Xpd(g~Xi&HP-5j&dS}> zD6jhUH)FbOPJe9?QPPF&&MXd73*Wt+?(|wQM zd90;2xuzY$dx<{TJr&hsjNy2gX)H@NKnHeEdicx6q7L3(No_IoOXcemu=k?uFniA*?cu(-Y*t%?xj$3FL4?7-T0BF_F^ zy9vE^-w7>-oEFD?agTP1=z{N=q*PfQ$L~%!Pb_goCtjDtLc;@f(K}+1`E%WI!9l{r zk@Bf|{d%dnbP%YT+|?yWwPRnIem)gVcw|1AU3DpAKTex!gS}a4j%kd2)b4&gIL@S1 zM@!)&Q8#Jq=**@6 zf?N4>0#|ig#n8D5Uyp5(kGL%%Ix|&Cd_T7)?5>ig#xM<)At!TAuQ1C>p5p(kPiwrf z@avWS;kvvG-{)oi`LJl4e2u*X$4<=);-mq)I3K*RSLXu=c)v1iR6%eWfS+Q3UkmHz)SB0pk0zI3>lr&UlW z8K~o#nd-Ei`R<~fE@RGZyiU-IP5iDLb+)B5qAcX6vAp^ZVJDeprXBrUX;h)j;@rPznt5iVUdyXlB+jDXNL1m&GoIB&?5!M`>EH@TiEy)lEx{|rd;J`NG=73 z=b5t>FW6*V#;INBF25D@S8M3-T=Rn?HP}iE{0v`YSmi3cup*A#8y4R*!Ce;Vt?<)1 znKRUp$a!Oedwza$b##MXsv~LYjl@$m)jL19wR?Penqbs}O*OYmSKzZ*3Aelj`QD>f;qJYyqzeLH)0T6Kj= zkZ%~=io;O};oUU&a(qAq^*%@e2NpyU#gZ8zuR3*cwPkYGYa7xyy35Qlubv7u>L*mJ z6TOd<%R^*+Rw)YY8jjtyV5gcT=;xy{Wd5u^ue1;Da;k9yu0H6Xvh@NC-f6j$Bh97# zyiWMoP%-kpg_70+Qn-t2_TuY2WD_=R9CWjIS4JBbS1D}ei^e;bDk<#&DXnnB?@Mv* z)#@E?z{-B-sQT;OWr^xg&e zJ&#sf;N+FMG3s9cZlzD3p|y7`?pgr9m3|a|`hZg4V8A)#FOWy^zv58&b?~30ss9EG zn&@pkKhv&ijy-~(+Cl;o)Yi1DkYutAk5tUfCZ+9OMJ z@mWV&_T#5E{z9fiV%WqxcPba_UdVennvAYDsMUC16@x&;9*5#og(qz3#kXoR+771P zE6a-dQA=wY(A zc}4h6;yQEM1Cp}Y6rAUI{FXW2 z$U;j3kgFoRDRXO3_F{DCuW-U7A4SZ&6;xwEhp!@L0h^DSgO;*VtsK6t@K-#_u~gSz zktnG-nEgWbKEqvT^5h;^k;=-?9yGDm7l-jF^~%ZzB{$ih{KA${N#)N#j#RBqdgCjJ zc&7!NS%)Qawf({G#K~me24h=)PwhJH((vQ1d;?lf!+_(os*M zm0GMwWXAv;GhQpHnqsXwEvjQ{YGJgq=SOXG)Eu5puu{nS^&eH7K{>maoy)g>L|8Be zW%tZ*SIvTctHTiAZc?gmL2I{6Fv)*c{a;=GXQVL{$Y^&SH&U)s<$?e*K7=wlw6ORx zC|ey7+ar`J)C32dH_XXE=+#@*>ZgYZs|onk#&F$AnHon8U1Nl)Ny2&B!aeV!&dv*z zNR}p2mU<{+_^24q71V*o%&q@lAq&&d%B7)>ElmDldC5^~)q(^UO%3kdbK|4risF{2 zs9`Wmzw`k<&nGhXws}~I+`_Zx{+A0Pey*Zng0VNkr0w^?hu^7m$@?ZL$tiqr>pvsA_92`V8of1Tv?M zn5B1tT4bbn!=w1s8-e=fy4clFr()9a5z_bjIxeZ&o4bMqsLHx3_Jpd9>239)m9BZlr=L!YghYiQvyO0R&w8%yIUU)lUU+0AV; zj7OnX+rhI#0%jRuTf;fg{DN_alz&<9_zndIM?LBKN0zH`)qC=tw}+k@nu^E&XaG`N zZhDw)I5BvTb$*6rxCE{FOY;YjZC<-!OPwqH4ox{6yJ=&XQG~@P+*ZOs6Gh9%qBaGj+O}>1q6C`Ej2DKQ3ueq zyRJGkI5?xS9EiLVURn~SvQYgmrLSbY6VCtCl#-~X@eKzLbNU2}xxHW2^3FUZ%-odH zrnx}p5dKFs^cxd+wlU^k8ThN?PbHF|(KC-`zq2%h!!4uY;$$E_eZ_Y>6?9Y+G?c}~ ztz8U$v)Y5$xDJCSqlPwu6_`NLzfOV4ms1~WYChP9o!JLW;9)cg3_LUhf+5Ul1J)3M z2w4A{*7H}#zqqsC^mG6HJ2t)Cv{FnkA)=Cy5Yb-9NZU3!Qy{> z{jzp)@pJyyU$h&4!;3{0tj&g-jU6hBXMW1 zhH}a_`6m=RrKW?hyKe)A1&)T8k1e|EbLJ8kQCM&m2s0q9^-+PBc12v^z2A4@ z6->>cuv~R$tZ&W}?1PskP`>JRmpd24KIyXp|HU}zQs73GQbAbPrXp$8;rv{z90c7k z5Om#cBaiaDQ~W2Wl%W%VovJVhJvMH9gY^^bJp{|S=?Y15x@9u2kNl)HT^ zSUFm7tM&i>^3ETAc0c3*hhs9p4Wc1!xK-Ia^Yx(WPEX3b8b{Su9>W!ztR~mgX`HWy z@wJrOyN7@8)utZhBU85GWiepS=J3Nj{K#qysTyqMjJ}dljF)QSJY^L6A{3>-r-D!(-gzX!h> z&MRay6vjN#1e=}H8uUu_G3~W+pe>1i{%$z3av@i4m=x6k9)21{u|JMXSs1x9oG4&q ziT3*UjLUZzOiQHidwApwH#XVH4KHLQ`!TA<`ZN1;Iv;uKQcJm_eMo^!A$yS^zLYlN zvr{sb@TJZhj`(y!FA2%2!Br(|`L|wCuRk`k0i{(%CeqxY=yAQRL2zsexqFSwVy9&8 zq?U{j@ZmMtzQq!QtJER#0{z67j{fjYWoEES=KrCM_yV5nK$o{afwXMJtFYY^+coj- zQj1*L>zmkS`J#|dgW+byP7?(|JF<(}DbwU@S?ovLHB=p*qLJ9vaR^oZ8Cm!I7-9ug zdjLXtRIS2xP#k4O(rwRjh*h*bnV-4g5i8b1nf(pLBUUOyJ|X>$K0Pm`NqR^-C)o#Y zp|PVIJ_FgHDJBFkFBFfss2WY`RTRQKA~p-m{SD!x1IJEiy(ngXHG-=$$m)H>)uvuA z^q^Xb7e8dDmA)NaKm~Ci6Z;BQA^1$~a=1b2ln) zg(}?h9uHaQrPRCOJ0MG&FpIvPZdx4q8trUchBv;h z;~aiLC@=mXLs&JrMKCxxr_xzj-*6!Qp3W}m>`=oUW}9lMQB1)G%urcH#lAfuNC7Rc ze4DtI-a4r>Ut4RiIA4n@K0u#qp1IpuTWN+#GlQ?IAD*0$cTF-A^A0|?uv-n$8g}%0 z$j{0K6YOb`k-QGKo}Y5J2+DLjbi^$@C-bq^k*3jFCp&P%CCvnk{v07_A=}FRARqTz zOreeg)^2)l_SdMhq&o>82r;LMITF!R9o*qqN5~{j{Z%%0=|Cz;A>{0jopGa z?pte8hYvr_^HC=-dJovS?jCO%rc+0u1x0QR-iRrP-cg6kBSt?v={6*}jOl2)e`=yY zRT%qRG5f+?ADjs~f}27DhZ$OiY`tjhO*{Er`+|LM2P(i10C0V8g8tkcSEZrWsa8MV zIpiWNUd6i}9QlIQzS)Zs7+{A5Hx5xf8+2q*{&D1wF?5(ke_1TrEB zBA|#Ma$n&LpbmsXL4j}zDB%iMOhSN!9NTer_S^mc_uHMB{qKAK@4YXtlGoK$U0q$> z)m_z{+ed6I*Q{1s4THhfSX=Es27^gMFqqVotQ4pze)g&u27@0wVspX*pfDH~2J?hr zu`n$7CBZz&0LMx`o>)%+BrK>Q4La1m@&tTX0HBWSNgDJd0}zw2Fp?*hL?)5QgCu|s zigP5Ns+=5ZPE}P-75Js)Pyx`%o-nc}mP`Twcn8UYVzO8a_yCiHQSzZyQ324ZsPrlt z02UQUsRHn&no6V6=u}Wir&HDMUxQeG&+k0>RIAJ5_XW}IYrvaeSX@D1qVbNIt#B{NEDk6YIt76fpEII%hiv<7>#VoN{O!frg z#Diop5JabnSu`<=E(SD-`Vzt7FI*Opei6Wya+j@eS70#BSCTLM(mT8<42FhT@85SK z_|e>u*j;@xqK_4?lQOgJs5Po>PS>c#CMdqk_|OZ37^6K5vaj>r7VC;i_GnhtiAGf& zfw(?aW}QM%gT|_G1vIgP;$qgPy?=OU!_OTlm42Hy!IX~7hDpJUZ4n6QXCh4Ldo=92 ztSoH(A4YwR&~eNM!-La1jkt}%jRclr7qy-@Yw4IC&dhc#H+61n8xbunPS*EbzCUhA zSurzQzKO4RE|3?$tbUz@(+D3K`L>~)tVR+qX(_si7|9Ca<=6dQj$Ie&ugk-QMoVTF zOp2C>-A-j85LOz4hMFCu*tHLdrXk!1^R`P@jZ-;?6jQVc=;MA42g)XiKakJUiC5RS zKtxi$^q9W^d=9VW0N5h@PuP~b8kjj#IW+D0-RPL@1IFmnQ79#}M+$t4PIizuaAfT} zRI0jus_>{JEMy?r;MD{)0F71KMH+>|kc-VD{ zGr?)pAuRXXpQ~Gn?{FGfYRffCGhMjlnwTv&B>p^^-Wx4qdpRl!mL0p!y~(a#G*_+8 zdfjOIP)p#+`s6qi&6}v`>bh^r&t42N^c>oXb``Uyoy-Kwxx5YBQ(725b2})pM;Kh4 z$e11xGR(MZ>dGxjiM5X+4mnzhj$ESCf-q^MiH|GdrY!1!SBjvP&+q4)xVT^$!}Ke3 zC%1I@iT%0uF@&|;TWuYoOpe^TyzSDNkFFGCJ!f;wzEV3svI~{22Xkp6PE6PzAvEF?Ml8{v)!%YNdMrL;zO_8A7iu`(VKljtzLe+Q8NS-< z>C_r4VV)}|93kTq4d;!DMz#CB$roqOqd!K79XJ-6Naz*E+#++xuUebVecx?RMeX_~PUzV9C$oWZ?#L>d;-JlHF-8G9eiVYU$D zgb^kWY`iGBuEDt@jWwu}qHx>yzTUH@(k0bNJbrzecz7u6E04u<^+|r7?iIA@YqtxC zc?Dq(QR(3>!einhzt4xLkeYhu@SA?0TXB;Z6;qs=V4J8Zt5F6Qd6e%K{>KONiOy^hHUg-8$oM^Cs9`aV23NvPcisTL}07TgUr9Vo!x zA6#&mS#^>C4bKQAefJKKox8PCBffAK`MSYo?8nV~N*&h&f-NIdii4 z6(7zxX+y;{M8I&pu&gJSjh{0d@&bM-h>*ve=whhBas5};%3I-8{PoeaJ9`R` z5%ADJxiN|O#^q3%%eB0E(6yit%+?xuz9!_Hb5-ltk0cx{Nu|S@X?0-Sx|uC8s@Je5uZ5I`8UL;l2fXbxo-d zrv1nV6luCmEq-Jn*p7K_h$8deN5kOcBs$a;GQ|Eo{0%A8@dRBr&p;ug!*Y3iK|zNb z5*SmOmnao5_hqkJ<#A52XBytw^j*qazxR01`$q1Y-qfbSpz;Q3qvOuP&Zbt=T)nfw zjTdTTm`R#by!X?{p)fUOr)OZdTWVME3Zmrwg<1_lN*9wiJeqbAqu#sKB}mPWs;cXf z(%ri;kdg+EZA(OyT%CJ8%Dx^t*(0z+b-m%#^A*MUdwZ{JL`UaZPYbn9qg2SMB}Mz7 zg267=rB`t5qm?xb&SVM)(?`i z?(x#w=eJZQVF;gjV=4VSTy!)!MILuDBrKEhbq`@%{Nh>Dw1f6Ur2uj3Rw5 z9Rd{)<=Fw+XVZn!bw|94av}jhk7-2X!o_xV-lp%89%ZX9u)=fIs4>}!cmZN4B!8*3 zdXEnnccbcQEmDh?v+FRK3nO(|`NjDX}AZWxta1~wTSqX0*8~-ug-Va4vOA<}4H9qN7 zqar-uD^Msf@*Pj;Gn@PBEtN<;&%QGoT54LzDTrJak>iN#+P|>hB-+&R=5BS($SUyGbud_Q zie|$iL8v~6$sW&bMj#qKDJ#Lukw~Hv9FE=(!DRnywErNq`a8t88h?oSzZUg}s3e~( zk(VFJf;AD9Kuu4p6`j8TqGo-p@VGd-#)8qa=TMyM@HU|Sa8CW~uTd?fv{R2zAgm@p zX=$~KFFp9!vHWM$RY;-_BEY5gs8DRn`GgAc6DGT(VGA;2d79Ui z^KdSrv)v*&eqw{gxgd4fhBMPCeAf^8w)HP!Z~UP7jS>uO*0>PpS3O;r;aAPG4b?QRSLkE&o72=tUi4bcE6wo)ic)~c1BJX7C$rJ^~XKnAJJA-p3{WIz@uOLnVvUU zWCYzA?dfy}UUcB!yeNh`jPZ=4l$U|^@@?vHj+pJj;sbBW6`Q`$s@Z%gBIuau;(*ND z4O!WSsRdi1on2N!WvIrn`VW=ft*I@Y?xnv|CL7ghV&)sIQ2&a7bUZoOm;AfPywC*y z_aAQAi~Ca-B|dVMpCxJwvj>ivhs=!Jcr44^)6z+%;U)068LJai^M~yy%t64Hhk#d| zPaoJ*EHCeN*HE#!v4wpO4YW5`*OJ=p8X{behPju0!kv7;3|jaRf*m*?KLceI9=e3l zI+hO9{q|zOM*bK(kDfugO@!Tjk6(IKO$o>3apofdRhDZ92BQ{4H`x|+-hOFvJLSC# z$k6Y$1DD*nrr81rKT*43{hvtH|5RT8Pv$><2lAiWsu{j&%(~*Dt{O3aEjY*&Hlx>+ zz%PIP!w1@5ac5H0SIzOAfhf6#M2)jh+Ft8ZB%Pr}3J$hj=37$j+FT+md7TS%U`MH^ zrnd<#YT)$7dmOwD!rDw5{C*L24; zHS`s3eM?eyzMU2x+^~6_2gL3uWXQ*Aa+++aC&peZNPi95QQAzIz0E95h{D>sTvtW6w_4#}!2QRx82#kNj&B%5ia5 ze6MMejq8sIPl2qJ0s=ufUOxi`T0j9x5|vNiuG@yV7e$1a z-Gq?B${~MDUINe(1VYs#3I?C{-VZ)6UuEg2qBNDxPfxS46Q-sH;|&KxXrXz^W>R29;?V~TpE>b1#|ML3X*KL`a_nN+?( zYS)zQnmHjN8p}sNE#hP!ffm1KzB#3~4|0}ywL^*YNTnn1nLv1XBbEw50S8UWLBBG` zS|zHV2}RsH&aN^LCrrifu#t>DjW~8cB0%HyZzKJJ{$__RACYpF4tn=^x(g>xU%c>; zaGfD%W&1ZXe3A7xBY~zK?99PBBOjf63c2flZ?Fk*&-x2f*IK36c;dQx!3G;U2;9pC z2-tD@Ch$+ja?PwZvsVkq>vU~26(g4Yvy2qw+R3w_h*$n9BzL2mK@oPpi667I`(|ue zPL^s7#SSuZe$qyx*JbCych8kE^9SmFjhcyE-L>Y*!7r+OP*Jpn$W~C_?L7E*(X+s~ z6UA?3zcfuDW`c$~@ZA9$rfw0x(m~H&C$6gz2$e{mkk?a{NKYTsX(4t#A{JR}2<=)@ zwlb^F(t1q1d;+N*zrgX~!&l1|=`bdH7o@&ca?xbk4QZL_u3d^pAfk!&Z~U;Z zdy$cc%^)~@QClc@7)eARX07==10ie`vhN>UkP)No_f@eEBC2bnlR*?2 z`u`^acplwYRkW)`Y80zPJl&$H`$_&y2WL4j4!TVQ(kyt`xbBM@NCgm$Bxm|C1rwE7l z-B6Z9TY=vb%mBMl$)p6?|96M~_YLz8O(~HcE99rAd4C~z)eJhhsH5J+( z{ctMO1|n{_Z-6#>PM9Y6S8N^%&1UtjG|m=RB&vRoZYWkJy$sC;QE=mo;--!Q(aQ74 z*^El=kTtK*N2?6=H;!zbu7l1Lg&fyQ&IaS{9*p9C5J4LoB6gkxr_z_awq5W96_hK) zc|}t_<&~8__JJh@&SD&QD?I~Tfr?7^NP_pvzDSRvI!So{4Jlh^8$8GL_I*ZD|N9>J z>>c7)Jx1K#U!H?RHx=V@A24SEW(d+7$X>LaeT9f65x*jbKzg=`7%9-fGU%Y~xVX{x zLAMiy3bi}B5I~db68Xf1M>p`iNK3FXj79)u7S<=C0MOG@b7@V|KB1zcF&QSZ?WLz?(S`(?=OGl@$Nql zT>sKL;6FwEPxFQUCA0s{^|!^DnS==6cm9^*W{Xfk(Vh80iJBl}2D3*wPUyca6YrH< zZj1priio(^BxEkCWdYypbSO?<7S@X#s||k27pG3V#>@}%cTpkOlwvcE+e*(6hSKvY z>1ZrW2(PMjT$Py`y;J9{<(<}fLnY$tZX<4erBiC8y@vdSy<5>RUo}!GoA@)hd-DC3 z)PD^Rhr1b|QKhGk`QbIBa!!HUrUjYI8QnZiMvtu|-|YZC3e+o)DcoNnFHh{0WXVGz z7+ugVU}z|~EyaZfa^&2=^KV5E1UtzQLO^>%rj_hpd(Zwu>$o`)T;zpkz@+MN`b%spkin8X!h#OzWPza0BzqYW!21F~?TmLN5P%MokM(O;A*Z96{H#Ybm zMuFtN0RR4>zWJK;SeGBFG2bkrjQO@N)vo@EL4%RjY}l^AnZ_ZbMT%Svdv-2k^Iif~ zR~+~8@SBWV-;p@|`ICNxBIcU@ge5PjT5eCBkw

oxHX0qH9VgnW+(e&9>taqD}70 z%C*1X7SK}cg|VKX!pN4Il*JLI#SV>+l+p6C+mCGYI_~7zeH^EZa%ILjOZ=x1ey#J` zk-s%emNX1-_^?I1w4lw14>J&hB7qy`J3K;2J57mf$HMK!J530dK1j2ljCMt9dO%w- z^PAQ*N7vBm;-+`EPi1Vb_B!t4n^>>+KPog^Oq(E|{VEQ{ToUtW zYm=@bu(^>J4+}6qa5=rCWy{N+RPg~tV|2Z#^~!X~F|peH6FqWMY!@zu!>}G8-Y+pF ztm!8pgG{3}eW7-6?^NHvbYQkGWZ2a$yTlga=EW~=9bH}6i-pTsskRW1er~EJ-NgH*Zz+m1quQ+9Q^#>SXt?$Fz|!rY+3M!T*;fx5 zFPBp4eAj&5OUIbaW$Vu%$G){v*g`-$&IYQQOc6a+Ru%4OXj?iiqH9<}O_x<2w#;#i z5*92kH(vT8!JZ4w)E-bw|C=eWO z`n(}{SLxI~X%F_yv~9Ar9X)@3{FFys|B)?Be+9MFhG4rYk zW;{-m(|GnszN8M_j>+=Z*#|m3xf?Oov)Fu3xtfzP?b$ z&TwP1fqcB zYD*Zbe}2c`B^8YyzLL>xh&Yzd&ciAN&|-7VQVJpy72u!r^nCU9UM;34%tFPe0W|uiFG)U*3=~m9Q0^(lK;x+k3B5RA@pm z?Exknc^!;TA3Uq^yPrp|e~?{R(OO!K^Xo1&&k~~~bJK9b74k%R*+iPmO5=R;OF}f7 z?RT}(Ol!b{IKOw$Wj9EV^=T*)|KNh(TzEpNV}@P*m~WspcAYBxTFx->&HN2~n2eta zn2?rI_H$keC+y7W{6z=6CUejzFfQa|`aepr#}>oy)d&A9^G?$X{Iv~cZDG5=z})Sp Fe*qVR+&%yR diff --git a/vignettes/articles/figures/unnamed-chunk-8-1.png b/vignettes/articles/figures/unnamed-chunk-8-1.png index f8a422960d9fab622cb269af7fc64f98ade2f377..3f76227dbb7b1e3fedbb0f22462f023cecc78d93 100644 GIT binary patch literal 23124 zcmeHv2V7IzmVOedBE<$GEjG|Ah$2dds3_RLN|7dAMM9Ha5=BHsB?^jk5fzmVLI^D? zLO_~;0UMAHePiGes3g2y~OVmx9>JYtqSN-028j0arcE=A0et;7RS65~;_R8q1`QA%Nh zQZzN4G@ZbO(R3=*#E?u%-&=}7EX8;%m3S;u*p_Uz6L^y*xPVBZ6Ncne2rf286M}Kl z#1vvMg(M7#oub5(VhPG)zvBFGuU-*e;c%~T;D6#PLVuwXq|iyT5CbkCPAVj^3)yTS z#1Y~A2si?`h&Vz&jtDL)ft#Ozdqn`xI6oqR*iY!E68hOh+$$mhM8}K zn}pFMVVp>X;KGndY!aK@Pk7Z&!1WWsMd$}|RB%!IsqB6>dnnkGO2kq73DkZf732oV zoFALYX0t8DKug#umh6-icA*m}mrW{UgA)4*Y$}mW1-U_gfL4O)b6&#cW>PR##erd2 z=5A>21%b%E=lp{rKY8myAaKZG{e5Tr62`iySSjCN3aaV)_~G}3LL~^_V38UnArZ=D z>GH#YJiK$^n=xCCTg=AumMhH%&3(8U65nxg+p-MTW9#FGCRx^pH(A}CzW z+V3IqZhdX@@oq0Yxj-#|ZJOJ^>1t|VYRnf z|1d>HM-*bvd=jyD!6RTH5j8=+1yO&1gn9aUe4)1D6PXL9dWk*rAqvL4Z*#A#!ssp5 zD@rP(zH~0WJ*R&U1?s7IH`(DG1@yK?Hd_YgmgS#rlTLW>@HChETFmd72wFP_J5#x+Sxl z>=4~96Z1OCL$Gz%cfh6?Z5;w|iugqhE7>QV!LH*fjQDh|XjmVg6@;hdAYx*o^g?;- zHMRJoTk;P?R$i^vY7yWc7@SK>F2{NxSD;geH^S48%38#UD;k*|&(6N5Kqfh7Pj|^+ zDy!n96bKOYM_D|cSnq~QP1nf14k0f_>u0ll`JZWc?9sbGy?q`HRo{?6$d6Ml3A{a>{$^q&$sgGFlt73m&-RX=9|lrM|$r*G8~B zbzbw}q3SezQ05v;bFE*S$kC9Vg#-1_yD?PQii2r#6joJVf2YlM8-3-n`|hr!nO3<= zulw#^ha6~X6OGo?3AQhm#L#ygVx%4uAEtLtoj%&C_tBw{Dv_4fa2~qifT>>dY-n2t z-7KgBsRa)cJ$*SOy86i1iZxdI1=d~9f~hd)(?;nRLhcX_Azt8n7S-p-IS#VX@tHJh zcE{y8j|oV{Cv!xDI19B%6?MAk$IK+g;UzKcYag@+o9LamUI{=}YFmaD`lCR-8Nb z*1N?TXIz}z`MUC(<4Rt&{i~o*^%HYYT>A*2qhO>mJxNzbOWyw#E~}in{B^;WkeOQY z^HcZ*>X`Q#x8N@!uSe7KPtlHnHhxVUY-tE_3#=WX^6~bHS6mew@{b)g4jKR1_bzr>=zAa>5n=-pi6qQrNR)PDPhHKT@xVpv0Rt}V8FB5$G z6%?}Qwy2CUn@=S6EJ)x{zT9V_C_M=&9c<-{r2(_aYaRR}VIT*|xnke8f zN20}vt4@+j$~BW7yCr8*OL+3W_=VI5wFuPq;L3|>Q_osw9~~Sh*IO%wju_el_qCv8 zh$~$XF={oP99-HU3Ig^KUzDU*ORvGSD>q!*0*6R=jG;4ZDy>=Hw+f#TZGI(M`nCuL zkQt4r0DF4TO?v@{GQRY=Ff}zFeh10BGZKAC@yYmw21dF;hXkgi-s28vn0~fIlMvLr z@QL?M4=-axc~7|wNg%B<+zNlQyQ4Yb?J7{KVQn}KPr;hdM-%xSx+B$eJBtYoG1Mf} z%#)>xqHk}odJK!S;G+F&TBmj&Yei1@Z%RQ!&J43skCBC@7gTIkR3}9Y(fS|raJHUb zy1R>*y^$&_#n8WW2{?EN<}G}>Z;YaMT-*SE9z#Wz4^J)@;3M{gFdR!MZsTS>-+Dz) zuK~i$-~@(LM5LEZ(D@n@#1Xg6mL#9Dnee#Rm+|*=W@rc#Va=ibPAh$ZqQ|L=h*vEw zYA-4qPrIR_Yc}fiScF`vSulvL+so>kzS6&hGlk zS7y89moYsiq{=SZxqH#}30X8GA45PyJ{$ksyIf{R-7;Gj>(O;tn7WDlg{!CX8Kr8B zcPI4%P#q%G;Su9*SiLF-P&XBRxyG!Lpt-v?$vqxm-bZp4_rmh(iaaYB$i4l4{g{6E z1`XLM_E(N`|9NQag;j4;5q~}3fARGHk6WIgwudOhzqO5hED1uCT#r2!uq~vyDeB< zRvU?8wAT#Ws=qBLCJ!h1VW zkY@|8gFkgqar3y^Goc@^C&kDc6zg3bVqYSHS^ ztR=KeA}_C9O4g3#)fT;!tIOXeO9+Wx~3Bh=_#iTA03cj@VDiQIjX3E5sx;%sS+y%hWVqSer%mE zD8*6y=`k|@|KegAYmON=Zh>EE=zOB4pr9kJj~Gh8?Xxj5T2Q=+{-og*nv{?*eNGIT z;su(y64SNR@Qv`2rLNFN_$+nKE%ew@cS&Tw@2KJSpjx*;UIe#OQKhSc1(y1mu9)$! z)8l)CxJ&<`4jA;T_?pfe#)w1uh>v5%v2{w(?;OG8V0g)U2|2pQ0s&S+P3L||OL;II z^qf_&C-`Fy1JTAmMgQ!9{|h~!l2|9ri0JJDGrb$k^o@xLTMapLeK(lv`U(omR~-Sf zy%x0eQ_Zbw&%n|s@dQg_GaScRJ0JsWnc)r~z8#1oU=NN0;g3KVgC5|DZjLyynR#>V zDvVa6v3yi^Sswi+?7e2~iLIeWAFjj%#whHLEX$#SwDqX_cO5UMY~-FmHKs3o8(4HC zVm<<{g-Q?ud|gO;7W?fR$id6$b`kQSsjtr>eaks8QFkYLu zTbn~X`gaqTPj7k@%V_}Y)Kj@1rEX*jI$i=Ti9$!WC-44V1IJm)F>X7+Y0A`y;l|~5-_0jpRH*mU6N*juUd_QW&HgFE({gTpwf`W;=!7)RSh3%(s z&ZFFL&VdYu>~9xwoxjJ7J>sxROw$=zp#c9Z#`$BX5$6TMK>r0t|2y?%;I(S&6u2jT z|7K2Q&L{AKdP?1i;wl6l+}wX=3jMPq{y{S$tud#g=U1i^nZJKp(u6^Z;k|y~vDBRw zXR~p)<4M2hK1F|W0<$;Swg9i`|6-oI(Y{kBX3x%LYtQbdf3)E4*}FyT)#FQHtg21@eT z_+qM^BGfh%tdHPXBI}0%1!{KXE0NXOr%Lon7se_V^c>y_zr0gzU0MqNzyM6Piq^DY z(>0IR*5i{l7dJN7Z&QRyuH+=xjK@b%oHty=Zz!ucZ3Y(Py0pe=T})a}Vz+-GLG<+I zDD+$P;2T6%N8hDtvOpZy>Z=;g&zSWs_kI+a*3u=2bDXxo9VO%Gqqwxo>oh1`63zWv^kT?5&EG*j zc!aBM7AZ9YUZ|(B=d`)h;)gkLNn~HbM_30yS^nJnw ztJ3@JQLi$z+})icnko2Q%mI8hlX=&^xO%@vElR*k$_~-M8l<2qHApsiZAM#?bH2O1 z)2#1CsN{`M$}EMoTx)B%$V4UCqJHtl*NsAh^fI}u4g3Q=_%G3(<*DUg7QJUGGo>O* zSg|f}9*?0;UHWbOJCTo9L$xffmY33Y4fXJee;oE_adJ60vU&y^van6L(%_BM;vv0LciXw?;J zvH{|TQ%~ok7`sG4$;UdO@yto(@`1Bvq4}tkgocIY8cmG>bZOE2=q0bmd$rQriklY0 zS7TDz)v%HB`9eW#N_tkMNL|vqM5gz6`bRxPpv1?E&I0fQBGm>oKJq@c71;m@Q`s3v z@d;6CjmW*>(9_%SUXR{_PY9Wsx#hCqKpuFHk2jw~HIzOiL^D;>bKkJg{|ddLo`uVt z7@qMukmu_zrzENqjWQHjxG_rJV%7o`7^o!k5<-n?8rUSk>L+8#q>-%5IClqzz+BU_ z={Cr{(Hys;hC_Qlp%Y}}m5nizK_2fS(&tPU;>S)%t6+(VnFlI7s(VdnDn;+qr==z; zvqaX1OJefTA*}fNY~S)ya|A!-2`-c6Gq9%hytHZ&(c3Ik>UJo3Z%ccio`59AxYfq9 za8me@k*#pmRWBE#6knfnk0Oe{^jh*r-VT-cNZfNj9EpKmEVDZ=-aZrQM_;TmC>5+e zFRhO439_BFOX>-!3Ew7C`8AXg<(84W=WCIO_0|%tVf7DaMZIxGU7w=~DOsSnP(Y~q zgtRu6Jdo;m0WKojX;5#0D7)<|CSvnlI!N^*)0av^?3dQX_B4dtewVzSgs?pCZlhxn z!|GS_(Ge@t3_?blARvP9e-iNW*8t974sOZ*>XMe0rd-Bq%`ORkYQwxTtDVgrtDvPN zxzZ=3TpCNt92e5%8uymXd|iXC_^)xqy>nC}XpMK+MkSGEhR)!s(S9&$>fv_Yz#GtixvXHs!G zS|?R)-t{a_k3AlEPA*=k+WxX3W}arVgZ1g2#BnPdnSFJ;sZL(UrW&R$I^(frjt`^r zdl+BYi+HO;0_uhosJZ2NKT1%A9BXz4HJ?VDT%0jBG1yE|CSJ0ZEzp8b?(yyPYx?|a zT!yfw*5)C$Xd3E%5#60~4nCA6pXb3%_yw>yQ)M)2JCeIdG{x^~i7FW9ZW^Goq)y_=OArLVsEQRTx( z6rI|x*E2M4bq}(s*&ksNqg|+~bfLQ*Tl}Exi>^h#uYg0Y$6QLqPejJVzt)$P+*-36 zGCT4sMCMUA&nUiI5<~t#q!TBFeNFFcsKO};wJ`O%T%Nqro4Ksz9ga!>Y@u7Ki7Om@agdAJ1Y>M4LDOTUPbyU5rV zXzQlC)1iNlF-h*lmxW~oho1 zG^kl8YSVhPjsetlWv*8NzE%3NrG-lsbGr*A{fO^ly{Bl1_Hv)BS<`r)2n(0AmlHp9 z-O`*<5t;#j>d=T0Q@5oBUHAUIr3D}d4qqIR+GkKleg+R zL-{#LUlw1c|9}(57Aw{qb+JWyv#Oc`XW(8xV*TFG*Omhl;`E?u_c9K{}Jyqe!A zS5=|0-Sk%TT}dIn3=x+lIOR?hP>CtLyj+78sL{ZnT`k5nXkjppL2HEI8nnvlDsu(L#D_}iLQ`&V{#f>WEyvb3LhN5A$Z-d(#+-n?=ePrSH%Fs$ zxU$Q(!2g4YiXS0_UcfD23p`W-ekTcieHG@IPQ!6v;dB4wz*UA@p*38*hx6>ugg@9H zssPpV4^fE?8h_YY$mZCLxlW|A+9({s#ucnZFlkeGH@CoH&C_2w>zzs5C>g1vR^q{U zfOZ#zg3*e-A%&7nIuD_kghIZcnF=J39%;waJs@+O*b+6)sieCi+c?Y_&EVE1!uz zHdz;U=#)|C?mFQ}cj{Q=(%lW3R zLUEkNMVnurny-#M&wWY8K7ZcLkGU^#IUx&OCeN+U`e*~hwWWOggDWvVM1dnbhASFz zVk7hB(mQ@xb6D@xlIV)RyXpXf_@k}-M~T*6QSlm6z80~1sn;W}cs~6(M5{O`%GU3L zga9bY1AwA%hiM5I;b5ZQF%-^-e#cNaBf5m4a7FKjeE2@15zpjaeII<4VS^v#o|wA- zcMSgD(Je1*c?TM3Q8fcD*<;-%#i8h&O3tKwv5$A4d$6X?UU{s;q`2Y?;)@+}X$^9s z3VvWZ{uaYrouY#~W!LXVAZ-E`iNlLK`*Bl+%`)Wgz{b)x7q3lRWbYnyeXdo<36cPA zaj>BXLUA3^W}WA>4iY)<;qC?8>A=s~VdHc=%ioL~aIyF*5>-e%t^I}+5%#i#;7fAF zwjmoOoCxyT7=SgI0)1M$eN=hotenAjxGSKD3R>q<4c zA}jv=0rvn{qboFeYo_si$FHjn4u||rcj)OTiR^;nVs#s0M{9BJ>=J|oj_FWA!%;%8 zDim1wFVAy3btmi;X(c} zZcx>&Qc(v95J9xeaPy>o&pu8x)q@&m+lL@9%8)x}IWbq9W9V;A5Z(m$O-eo{Zxi^u zU>t>VQSr}c_nDk>n4p@Hz&^8cIoM6apcfaueGzgYu`b=eLr9A6DhfV~IRAmGJN#-nb zTdm^dqC0^Zmj}!^TH8fn;@kqS_CX+(9(ZJGV7<9vV6c8TJeD75ZZWcfS>A#D8$nQ8 zLX?pDY}-d!gB8`8mF6!gKGrq-VlBTBH~&A9`^L(ju^Q#W;5hH>&z>j(hxyW|*iku41!;3m$Z%NX zGzcnxv4I=95S4vwGJ#3!qTR*H8|%#fd^G!f(6-8pB9(2F#tU37Mwmaw?mIL?yL}{VEx5AoDNpf+a@p%=dx9Ui-Lzs zMQdG#^6l@vmx=2EUXD~r1Y*Jp*3%TnfL#MW6Nq2nhesO(?EFU1-LVy1u$OLsDxJxW);)fn^eOpIEo}q#`{B za>E&tmUG07W+ro`E*@AXkP0x@qq{GJcsJe2$7uH_4nYn8do1B>->v${;^N?oQ`03a zT8#~Q$8xXys5$T=`U>l|mW~I7jCr``6=r&e7jXPDsgnALb9xi0%c`dvuno7V(whksE-6WoeWj(OAb=`F)$wG_Pd(pc}~eKuTSubfeM z8AShVfkM|k2Gcb|{D%>)h8mrH?tk{X{SA?>=i1(j)qP{?1Gu|A8b@n)b0FY(eCE=4 zec#IqRXkihPJqLqqdjxx=aan#ve>I*OhJ!Ue$-o(N5)quA>N_+DNU&O_sp+l85d{?N8 z62jF}Tg)hXl^+NSB9w2417ke@MB{idf1W=guM7Y!vdcob;4vd)r`vk;a1|(Q~mbLpk1BoCj5`WvB`|v9NfHI5bFon~jSM^o7 z;WcBA-Bxo7p@p%(#V}D<*U0R}qS$?X211L!3pF!$MuxLx)auYd!PIO9PPq}OT3b(H zky`J@=Cd_nDr*E9#?@@ZFt)hfURKL4yh($MD%L<5E_Yma&Zc42!b3WKGDEEAao1z- zr{4AxmAB9|HpRW~-N4^vqo&^X@6T*FH6Hd!rj z+#nytZoONnW2rBfpyS1uQ)V?K2VYd7m)>4cA1dIx7waZVjj&H+3OO>)4{TWPi6CFK zViq`y-)_A-+@}`_P~CEzl5(ZyN`MISt1)_Pf@;!p_?_ANH4|0{lR}8&dALlf*o$(bOtJ20+wWjL{C$hbZ*yj_8&K5yTB?Oe9&TE|gVL z7um_{aDKL7eDPd{guQT0`Mbn0)KnTugE=s|x^4dr2k@Tpk>%AGo~b4YayBxgcmFiu zG*mK<>1EN?GD^AOFxjhnPBvgG8zVg}+*W@y=LL^QbwvHLdjg3M64}_5n0@VfSfZ81 zp0Cxjq7$iyhqIy5ZMHq`iFYqQfofa%tf_$o5>*meDsQjeO?yK@#<|E@6<22r;q0FtE~~JcYTpR z7b2npPtL#(T<(!lOnkro4iBX@VgKaV8$}84+;=#BFt?PW(_J=-cENd?11jGt=8eix zr|5Sh{Z?Y$skDMaE�c$7W(&gW!=@*(8Ci^H?ud4?k0flr;sNSB! zt3_{n%L58`FbQsB0q_9t`A*qPG(_wlMSA&Lm@0t5LqM@B+Kh~iZ338?Hogpf{KD{< zzcsr(oMNm)n(9((O~RH9k}uZAcZCE)?3;`cx~!6dwF?H5zH|C0Go7ZnknYRpX1_ki zrVT2=U?);z(3cgPl$k+nxmUDse0#v70!oPUXu5yeHzH6?_W^LZYI!i1cRLiD#YLF& z&6W`6!Z-NRhVs4W`@2Du>*}ag%Jkw^H_Jkbk zm#-mjZZ-Uv***JcMvpaBwF#DU6tM5I=W9pXcBAG=ZS1efCU{z#p1I8Z1pJwFfB(-D z=+d@MYT&rU73LI*`Ar~#q0Hmy>s^!&C@_znmyBnxMhlE^NNiLIwjJKEb|he~t000D zvHLJUW7!WXyI!257)aJ`iX2zEYwjftIE@)JbZ3`;Q&1*fZTi~3!uP%0HABW`VZEqM z7i&A@JRmUloCcn};(^@f7x&Rv<)i8Sx9GF&>+xFfh`W@wIXw*!_)qhX+lNA#HL_e=Fw4$X#BJPigRSs z)8ca)>hSyv{-PV+@=0sKN0rQ!dh723+VCO!(Xb*f8qKuFA2nkrz&Aj?7b*$y8Tvgm z*@?W%gI|bCt_-@^9fY?IhsMtJ-xbA9PPjK zv!)78A&w~bcLlZd&|Odx0;(kCepkGTZ@{4)QLs|tau{Pn&--G<;|X091z%sX0ct9QUc)s@}wh~&Yhg{@Hs1In?BpC8Ob zs>Hf3Rt^tWNoLF>uO;#hpyjsi>6!^R50QQH6HRvY?HBO8jCyQ0s_?mxC(j%mHVdup z+c(QLB)xJOf~*CU+P`4QdQHP~@p6=MpEuvg^)u+w#q9doSpv>&`o*hH_4NWumjR_w zXjB32EX3Ah%?sr3Va#AnTv)S_yo*F*=Q(pG;#GTacRaKArCgbwtH3}- zBu+;0_O95$6>HVWncd&z$|02NP8ogNqd z?v-$)ag_X%?pKMdk!Lc$3Wo;>t-4pg9xYeEI!T^hXS zGhz4u%GpH@;G_bNs;Xd&K-Oi9a2=zIuW{lk9DVL%#R^U=JE)Nu(9*Q)T;TN_gDmxl zCfquV@7slR(VKHuA==F&Jbl0zihQ#GV(nG@-#gnvwev2)nu8Q4$B*jXmFR7nk%WO$ z1ET$LQGfrhjbyQr0a&qL2owrfco1#vt~XDC76{07f9P`v|05>xf1@EJHd4hW&2R|= zVVeNkm5v99(mCkwkO_Z}*!G(Y#Q%$#Qlb1mFoz7cVqbrix%qU?a_9iAMAcHXYOdc{ zSb-~6d6{6inAlKL@2`0z6ZEQIkuEQ|gN1W3yioad{#wA{*uoA~H!C8yiaNwAr2yFR5%{(B);gGby zCZDVB%&ZxEzc87khr0L(ePT2GQ|e8C;Tk#rL{B+HPV-`7fNM57=OFNe9uP9*I3=9U z@Lm@N4AS-I5Vy16pIaq1yVST-esa|#FF$Nk{Ba+k5a9K1n3}3ZOHPT#_dlHy3p)>f z7taf7>+P#FtIs7A)XXYO8}VHS`i#zcYv7I$b)YvyF3~sRO^JL$(&w#PCKa7i;eM*&}|mJ_q#y_G{x{Ii(9uWvL+-lD)?8z~}rlH0Ew zN-%d={>kj6jfr*B)0W>^KU*|4hI8THZ}`AX{*RkM4UOS~pErP;`<;vm@b|y=r{o31 zgtlJnvGUoE-LA0r0E={VzsgVlCF48$&Y84?)UMdk1nCj@HRQpAt^ba?@=ILwo7BfI z=^OUn{6`6}rLej8c~b|9c_s30>Fvwv}o=LDxXaoAuj zpTO39WOW27#w2&^<@h(5Nqs3@)?l>;5pm=ct`IZ40)xNQ1#u|EZKyK$LGLE ztG+?6=s#ZEfU?Uv2 zl;Ot?dVh&ew*+Exn8r&WCWj=q1Y-V$bF4y_0x<5jd^NzVG;EMe1F-;FfR%i7;OzEX z5DZYx;a>W81^o{B@@I^}zvF4@FRbM7G;2eB`(gK(1ykp%qB$hbIuJ6p$?ixBD7<@x z&Xn*H&-v4)o+TRezhu&f$U|YNw6ceX5xl(j8s<#oq0oCqoB$p7E1akmbn0pVdBda= zK`@F~?+^z~gcvA*Fb!UHO%6i-wuuvv@@JNRwH`wxBQ4+N;!S|Q^28XXvJre(<>8V7 z$i|nIxFGvV`*)V|UO4jP@Zoq&>$ct#*3BZH`UXBlJqi-RE+gpf`HTrgJ5S?EO3u|j zP)a3=3hB6HxyavgT$4S9FU8ItKSQifYe^39!e6pl@R;2W44RH;3Cs?0iR5F!6N5L< zkToxg(9+tkb^SF1&axTpO$u}A>0bD!Xh_C!52!z`3F-8iv_Ujd7iZO##8}J6d*1c7 zP_+>@H+MJjPN>0dtvC0|zYDid6l%|=&DxgXP{VSfuSY&o!M8l#E<}rCLJh1C)<|i- zfp6;;nhqWIwLm~xU%Ww=;(Eq2NA88anN26ZT~LmUG^z*Ynzt1A=0b6oIf-CY1#V{m zcqB63m_P#f>*$#yh*?6(GuZ|me$OGlGrYX#gO3PRcjo7aEE7a%99dTVAz>6DZ?VP4 z78;#egsv-DRi@=<9qurD?FtlXmfQzBW!m?VI`=*Rcd{#BZ@|pk_-!zbptSWKbzRAH z((IR4M&$=4fnC=6suW$f7z__L4JlnHY#?Oz8xTR`gO{(UUS$Jp&DKK*$W0Jiy%GwA zgOAYY1JeoM3u3@bi&EPI>F4rYgxKkIU2Ge8hkd$@V~2P^1ycl-NC18Aom{% zIE0PKNXdIi0g~~HId$wlodep*;WeH7AA4^cMv!SivP;k8p|OoL|HpN%PgWow^E&7@ zQfyVQS5=B^S7GSC$^h945R~5-#pS})zNnY4g_65vdi*?6U%$qwt#8a`k{NSsNNjpf zXGocDi1Se7L?-2==l({UqBh^Gv&2EYOv*0LQ^~k8mgki9m@`|-)Cn-$3|y-`b1u4VGtWHE*BzNtrZ>-S(l2e5mDC ztW;*^5yX)uUt}PWFdFjm*r-NP!1F8giJ=*rG;4gWQEkT7_{Hq=$SwTOSY%R+`V4I* zf=oi@YfuiQ`X2|;QbRgex6a1wL>tWMT5RDTXdAWKMp76tne+4> z{cx9Rh4)y!85$}=2v%sml>Rm!F%^>3WAyX)>w z2q?gxo2z2WUTeIa!%N+(6nA>pI}+of7L7*;nMS8RbVWx?W6FH^Xobl~O9tiPVdm=C zRQp_`s$XiJz9W9k)@6iDFBlD)86E}|GDruV?}?brDsTp0Ry#ONHAEcA_d`YnYNE0> z3khI-i-uDcw+zn+VdGBc9O4sjNGH9c7Fy+vHy%RV&I5ua4WF;?vCu9myVP9^X-)4@ z?)-SjS z*5z%%K_kQUuu}=vUh$=xc|z&y%J|hZL|ojT5ADHLeavDis=%|;j5RE-Tzzh3Rym}B zMM^Au^r_9u804p{Gu#%Cy;Xsr-(Yzk8mnRd((`C8>jq? zOL-YoLjAk@i9QN3*H4H*zm}4^te(OZc&1{CrRoKw&a!9b$Yd2hjg=UrxrAI{vZV4{ zAsPfee_d=Jcbs4c1o<|HoDH73GVSH{gwdMc^iGsmso=%N*M|fs?FiFl}pYStX9^0qdYrTVmEe$VlbZIne-V%bz6{qeBsZK22AJiDZ;Rr*z!&A z1mB|*?=>}_&$hl?W?15>=l9vwzqE76%OSYk%4~OSf`c7i?_ z16Vb7S7*1JoA9yBeua|w?u{#|{bIWg5eDGLXaXpgbii#tgixP*pPzHi9MPAbu7B)#1R?KyXdGWVIII(c)4A13tT8cU*l?-`J8dLX zJ>PMs3Dq+$oVTFlwV;V9maO-*(HZfvWisnxL^QxmNaJ(x+_I2KRQ8&9I5cimNQilM z0DLp;MZ$UvHPF_|ywYZs=SFy{Y5hrBeE4M8S>-u9U)jn2xjA`S&g0)ap8jPtko#<& Y80|YPfuA2VL%{FwK_mUF{pYX!KPg~Z1poj5 literal 17816 zcmeI42Uru?`u`^ZMMZ@b6%~*uDi(^16zQ>oih?Ljnn)8VQCjGU%c85aC;}n^A|N6l zB?5+OgMbJ~2`wZjp_f2_5D6stpWu4;mc4iP-uwUE=T~-~0}nHE&g9I@d*1V&&-)Fx zjLzt-S+!*q1VL*~=pQwPpyfyi68gA8036AEYkvuXV6jF9=Z}G12m%L1AxHy)oFD;F zNI)JEwSqJ>APpx-0|z-3gVO>6q5`7w0-{y|@~NPzr~oKnFICivCocfWiwekF$;(@% z%BS+cRWvl5G@L-eX*d;Y;K-)sZ>&TiD^UR}c>$|bo)wSh1U^Xv6i}tu2}gD+28D;y zfN)M4xMCcxn2aOyQso6wt-$qoS^SNVl|{@V5V8p1Hz|uqD|Uj4oivJZpn&S+VluCo z#{-r4Rrni`Km>(EAkqjVP#DCe_C!J!5uD?1BqE7Mq%nvz9*K}eA`(a>P>3WFjYMOR z7(6mggN$<`7lVQ$lX+wwk4DU*5eYOBC`1~l#{h*vWAJD^-f*xdgG6A^hzuHu0a}B@ z{Ef%p@px9E;7)j{R=m_yUa=FnE{|Ny16QOGc?=Sd0a}CS0qzoXpZ_7erAD%b$^`IQ zR$kS&@PeSNZ}>kjkB>e&5QKnE96fa2@8LLw7bD5E8~W@k7{9LXE`HK&$Rm5VNs#%# z-cv6T7IyEZLvf#TcCS=_WpxP^D{MD(_~edvwUySfuP&eEQA)I1Tglo7v^8g(B$!u{ zGgqb0kGnOUtYDWHSDiTvM?Ugvv4xy$Mi6qs8+6@Ty*I#!Ph6)jF`hd3it8gUGZ^qCAFe zO2P}*TIu?tZ8;qWELEX2FDID)LCUxvOE(I`8xe{T%1a>?!ZxMgSJj$fEO*jsoSAP8 z$KS#I-Y1zL=|1eUx|LpwiNva>Av0h668i&!tvIbB&kht(xsIIvIsfx)|@Wq)Xbf#`D6HFo}SOznXEH9J}yX|XDMGE zh?PP$LlN-l`CR()+FLFce4QnBi=c|u;(J|^^W_j{hT)s=2UgX-rG^gXZtTeti9MgV zwRO!MR(&jtz_>R5C5;el4@JD)yewV4zu=L_Yj3oPe@R#J{RlH>_MDJ|h9AmfXcLsS zABo)RJ7;m)(g^j?V9uK|!mU(8Fr%{Tj)x!k0ai1ZxUzN}QB%=A>0C6trgr@ByRtbu zSj0y)F`TdP1L3wYp$b^SF&g!Gb~miX85=r$3a;dO$l1P+x(DW8v7iMVABcb}sT(yX z3{0+C@#>uWQ{j~h0++-$zB>0g$HP&n3q?vEj9=b=FLXF&Vv|ratT7BcZEvx3!bmNx zmwI6%&M}iwta?gkGRU~%5KY+zdsbtNOz2IfHgejhLx<}XcDO}SCW4HuH;Au;N3>v3 zyNk*K%N~l#)NE1>HK}Fdx->Yr`oxk z-jnGC{Z6;nrV2zfZC;+f*ca-nGg`v9FRVX5zc|q|)^PWP5#47lkQ1m)_oYKJ-f=MX zQO=O(;r|cM(Hvd^KGSGox73`+OW!GL%0kh#dC4CDvGn+d84U;%vVg-d+MDS zI~YuV^#)vEnN$bHhn?wA$tH)Hxm3(82-`L+So4ot@3oa&kzl1j#1H zWn;Hu*+Hf6yRPp8quOrs$Y^r0;Img?0$}r@BZy=M~EFCfeN=F5SJydQYr! zQ9Za(Z`bJil`D{!a99KMKFWQmHm<{~By-k-U0ONz`~4Yv&0^L>jE0*_Cfs+AU$IoL zXKXgjCnq4Fy_H6DzdOdf#v~kgdf{Bq44HjC%dj`AF)e_Fr=Oy@&z(H2bS;zqW&t0c zt5bZiMa~up86OdJ&`>FfGQ}{_C|+xovh;kSt+M3~*~}}XOg*Mhe;WH%o{!-$dqTII zi65D9hWU58(LaQg95l|lG~H?mhl_66j)+P5f(k0`muWEMv_|W?N%bT*(kfu;%_WNC zcGkHuxe;A)#6Eov*^HM59@mW(wGMl213s3Me&}kxeWlgDblY?YK?$Lzqack@EX`5oTg=h2$iEqwqjGZrIBp|`s<+g3c?_tgvt^>3epwiXTxAx-?Poy{zTw)N7=NMk#}~jx7RTwbjc8bnAoV?5!N9RAfOa}eBo%1SPaK3 zFQi9q$wS>#qS!4PF$D2j6wUsqg1_tnXI{=P5l z$0U}3%a#}I6FpK#g}!X5%u>78O{uU}s7MK5neJ+xEmtjbJ+WZAi}VTQiyoT0Sk$}k zS=8%p)NWwjwr`D4E(<5nm+~fy$!luwChqa2rWQ-!GM3#ZLkS8F6D2P;h+=z;V0)^* zJW7gYyK4=?jYD)WnymKrH%WmL*q$$}fbu|17J=IK{Y$l~k2_^#6?Y+^Td(1sS`6Nd zrf&A&cuBAO;Nm>?yq^BEA!XEV6YZh2(a5wA?zOHpwa%>!R%yxi3FJ_f@Ymv`Yw;;m zE~QRPT{s=b}X zdwuHI+48Gic8gbs2qHrp!Mtyoi5bOsXFRp?^Y>UBzOW4e&7R?y$a=(yY;-NK1@Qp~ zrrzT}*x*?x<>}*Lg@nw%!*TkIIb#EJQ)&CeL;5!Ht8`_TXssoM$>4TefTvg;dwn+V~*fDab*pt7~Upm13d%uJ3WB zJK^wGPR@1{;*lPQ1qClIxOqx}sN`ekmy_OQ`OwpxQt|fc4Az@+(y-@{;?$2sSC zY5R^1ys6JEP`f?SNg{-;Sn;ZTB#9mUd_xmOPFj-3d+Rj*=;aixa7*A|1D*ed$AG!r z)QmYPiMpwrC_y|;uxgAvExu%!=+Rz91yYqw@*3?@_I@}%Q5?!>(eTBiih0;XCqB1!ef1l75Q`VEPhKPUK{3RYpKMfP0^9;N?p`|F?t)Q z=F=Xei#vf_y9x$-G$^$a_PaywKaB0S7A1fCgmUh)rOVH+uNGD_l;Rskn=Vtg)cCwY zdC+@v{u_LX9@Q;1)k5Qgt}gOK%%Vu$8{+G zj)B$?-6#jb1M`DLrnt=wa<} z$&K8^LT;(2p9>^BO!WD~C;m1x`7Pu5&kV0$e4==b2s(M;s>hOlV`p;p%x=FAiyx{1 zvolyYPqx|m^f}F6EZDdZ1|lwL+}k8)s+=r&o7qs!GC}MHSl7~I>>;9C>iJnV>N>wl zML<36QCUTSnU$}o6qbvX1ha5U!?D@gWEgOq_p<3VmXz6N1Tf=P9C2mCz||XA0swB6mdkAWeOL>;q1w&h z<}#CkkKDW+Ay9}Om&8vuDvr??*}FO@omHoUq*Lrosq>DMBwM)W8x}*|X&}kAoie`@ zA^ST|{Ui9`paq-H=3Q9d%f^dmig2emk9WuEJYD3@^JY7G7sd6fn5I0x&#{~`#j1{;+re0jU)suAktdjUsNj+SqbB8EwzROw zULr;YuC&+nd3mp{A|eg{xpYC%aN0G)HP@#^3P!LE8mp3Wo(YW6wKw@mJX^>_RzqZ$ z%^pFA^X=CDtZ?1n7TdjE?N(@_SPNb;&X(KM-gHgNCDGskDH=MGQ+7wN|BHy$eDmO! zh1oKaw9no5J4N=AnhwL2w!7w)SIy3hb>@`OZL)ZE7Gbo4x^(~P@dK)Nv5O3{kCbfh zqr5iVtjfZvi|n?ltE(Lhz(?AKG)3px;|EJMlY=YCWvi1T*6eDS?$^Wenqvvdq`m8tga&5wjv|kbyogoPT`{iLF{TYuts@eEvOGc|~L*Z!sey_n=`1Jc( zSyDi2PIpX)zY))IW$o^y;%T}#=}rZY6)bd#ICReky=YHnRb$f6Bq`T_Rz)7)h+Bvu zIFfp+9b8W%Ylhom(VmF*I&&GX?ov$;3}Xmm9Wo#KrT|x<9^4`)qzP9l#P(o9Jde-3 zS06S!1>2m_YGyNIAln@IA#04zb!$DcNOa1@paqhCFp1iS$ZK0rHJ!Mfv>3bsbh>i- zL8kAOH!)~-X_>9u!U?P_sse+4n_J8f?Dw1TD@K*Ge*D4gf$Lt5sOH|WobtiCU8!d+ zoGB{VA4(-+eRz}#rOq3)%WzN024{>puab4o3AQ=2$kb-W{*JY|ePMg4Yt-utX#OAB ztI?bxbNIC5f-=5U;n@peSF3g_exZ^~u+2nO)p-5u)7(FC-!&AJUo;~M;*DI-LnU%Gi$1~{99Ask*(~K(p ztVHpP*O-TvsyVt>H#vqo6CNzwCsD#J4P*o4=P&cm2ata`yZ`$RS^yAoOwd?6ola+# z^l~Uy6^-X-Lq~n6+yQ4G`qalQ9|jNPDeas(0k&5@N~7ARu6Jin*$d+PHZ zhzCrVF+WxWd}0SWPS(Mc zo<>{8@+oDB-3TwvrmJz4OB9g%v=bR-R_!z%@>b%4*gh-}@;3QYiLMrvX zmR~SV{6X<&wqpHsuSY|%;;s|^c|nVbPNDYK`t2%au1s5~9)jSZf)1sa;hOQOSy=)4 zyV4H#H%aX3Y^&47O3xH8U30j5ug=UH^^xNW85SIZd*-!9v#%AUT~-S1^$#jP?OCDo zTnD|JRJR^8O&*bDK2-K8>H6WmL*JQ-)6?8>$LwhNDCHCC+)hj07)CQZ9qwh1UUM>qeFR-bc!_s&2{h2&(-(*;RLaM-YKECNn_YVOyhhp`Q++Y-PRLV?N zuWCrkZ9Cord8RXdnW!HemLT=+a>^mi>|-dTQ^%Eu?;g=U*D)m%h2HrfpzE@t{3HRP zEaamE&O(_kpEM=AkY~erY0(k@BXBH&XRGJUp+pHbf_)eJ;ljtR`!CTakv5Y$d1En@ zjBt19qmxk&t)8}&8Lq~X_z={X{$Uy|w5C>;Irwhzz!~*OG`HLiQe{M1>32%w@SR~Q zXp>Jj#MjM9o`-!}AKLT2|MOz%NCr%O0Ks<9bczHyhTPk%!L2Et`(oNxUWCJOn|B~u zPvZuk$V6iTT`iDtNi~|7=H5C&RqL7u)kiksX?>LI=RBVHwd^1wp~Imd=`c6zOD~C& zK5FZ`&CYe)V<=|ynVgM&r?w2b{ZXsOP)MFakGOCk88UBDW8N?>D=Vp=#~Sq3r+Mv* z8I06;f|hsbeV@K%v4KwSS(`Z*c#H(=`m!ct{55>VYGzz`^Gk}AuV~TLBY)0 zA_~@9cz-K}4+WD-Ubw4NldnTNZmiOuuNImJYD3Y!$Fz(O&6Ied8phG|A^}fY?-+wV z(K8fq&TN>vcsM>nS&{P~1lqA&xR&vb*EG49^8nu)Qj#zuo>%$>40H7ciIXNx^G^e4 zPg5{fz5>%--isA<`V)e-IX-Q~_B_!#q`R`2-d9UAq&^6AgjDxmL^j@bTlhMEEb%2`nxaxII?^bGvc94oAQZ8g8j zILUIW5M?5=qOUM?7@8I8AHE=k^H6y9@P*#(Zk+9Q$i7XDzfw;LF_9K_iCnb;N?h)c zr-1;eEJ$LxL%>CAB-HtHfOrv)&z}oFuEvjIg8`udMCh_x(9Tk8bLjjMl4%LF1IeC& zXJrgiwTdhBnliJ=j}JnSfLzXS0PevmOzN-rr;?w)`oMoz+VuZs%U>+1Yx4p#`gY%& zp8H_wn8wZGHOD^o{5;U!DN*e`KHBq*|LJwy9s>{<(fsL_Kee4d?Nz3-t@2rR7r$fJ`nF0IR!GO?p#GJhRG{K#psrbnOm=P?$=&*`aS* z04!uQ6ZIqXk5lshH*E`y_J5zC7G4^~Oc|eDuh^sIV*m)*Sza4&_~co_)bt+v48EmO zvv|W77(ETsuNgdDD|J;15DB^^fumQ464dJJREeZNr-I?9n0fJk1`~Vv)^}kcJ1+8P zzKG&eM`GXA%v;rW3m#`%JmXWs0;1snEv^!)1>D{h6KU4)=6$6#(?YX+N;v0tpD1s8 z0D&K1$t}ZXg0!yaNFuvKYq_!F&j5TCwzCKo1v80B&`-#2T&l$PDpwx*4p?z#vL_sFi(leA0A-z1Pa6THHJ&)doD()l{v2Hc(8}%k#Vdf7RLHlNGwIlMZgBOHQWZ z9M7gA_S#44O;Qlw;H`VxFy6UqYd<$0Mm~_gvsdcekzju)!lbvY_vmAgpex1{o&_lw z^4=A-hgfaY76m!r-u#hkeFqf*V8O~O>oTPc&?l@XwEyH8pDH4>|0;Fj>Cs+2e`IuN zM4f(qR55xk&T73e5UQwN;A5N_)|+ly>XIkr)9f>29_4|gwYh9=dF(055^}cy6ZS5c z`flLr9-wy!{!bxp|GyWJ|B(^&i%+!L1hOIYw?8NEQrObgd-jUkBufAv2JWol9ENl& zaUit%!nio-7zVi(o$QZ)=yua8NkUu{G8J@KGC_j&;_&;hl!MFpRpv(JqeJO)H8$6} z4tYat0Z(9i`fB1PXS!vMxz{Rwhy5PR#nRSUhE>l%w(d9pa;F6f&7?#NKrUpBfRc7T zh%4om_g^eMH9A^okMKDK41$Z5(-d~Cy6i2+H&o}CF@9)QQ)Bj+9JUPUNUF$JP^b_G zj??IQsRYWWHG2?P7jtdyh!Ciz(klYo={*_bEe*S0u`fRt^5Xl{_ z+E`t}9j_h<)eWlJeLF*BZxx2C%VDbVmbIWNVp&9#VXyHg!;miyl_%pYW~8a{x_*_r zlR1-ygRTw)pLR-ouPe3Q{tsyQ2Q>Tx8vaj&hGjA=UrqYz1tv@@7VrmgOz(qK%wOsT zEu^1UnJGwv2|LgIDfYwZ=3h|_o~qOUv0o1omXMf==4*BTOfLtcq1^gbY z5yRbVUGoE)mzEP{WU#edr&jnh`6?&gaUNCTL>7-pFE`WSp2oi}*x$0U_Nt{GWQgah z!E(LreT^1kV3{LIisQy!v_NiEP1MBq%13?B z8V^Z=a!@~E4MO^C*`XX|`3464W^O3CRr>_c4svkSfECJGZpO<;SKqlnl9T`{%HK^3 z)0ulzk&x06!LMTBL&3ql6sN#TN;VA)4lH49vgCmj)-RYa%D_au00xwd8VC{1g`6ky zPu0$JCkp(PY>+8%NkH(E>sLtlvV+aZ*$A}4Nt!r>q&N?FS>_%h8Bp=^%L zSs!G(-;u1s$)Jl+yGom7cSuW8=UCZ9W5qUNU&DIMNh6>j41zr=l|ZzHJ>iuo{w&HUl#oR5_>T;we_Ha$~c zm_R40V;J%=1*%uuo(561REKA{Qg8>`qMS@JK_6}2lHiR%n>tY0j~WiQ2Dta=bi~{ z2kGE^JLD6gb`UN$L|t!_2ar?sKN=GL-2mekUrd&Gh; znXeX%RMiq58;;z`5d{n67j-^}n2EdLGdJ5#@nK-1)h(N?6Y_-J=}V+=)W%$VXfmv* zs(eXj2(%b)liDeMtY=aem>mCo@ugoW4Un@Mz&(w?s!Qb$X8m6~G=5>${-b{htIyRe z;aq@Fnv41fVC75WVP1OvEW-mwzq&a0sO){jUElc3S1_F?nJD+O8GqHQ&Y8(e{CsE$ zz(iGlJ|h;s)Bczl{yczwfc&MrC&~xI{DDxK^h}4|e8AK@azJGGtEzB+v}L6e(y4yZ zVija44}&3E)R=kxtJ7_MW4KM0)vXMA4E6(z&{=H)Jwe13?uL#C9hbaQNw!e|^UIqvdaj5B|4#!jMs2 zzK*Lq@K0Lmv$n{9#y1)P_9t|gRMwtSwf#MS`~Be)!Qch6$A9De4wlzTtx!?(NrG*% z`SIhuBQb}C(|uO??#2}hyf{dhP2XAd*8P1EYK=-ioR+{TD>J0Vxz$}@=YPEGmz-cA zx2>}JbVCkoTP1VnlgtvX_9yMp81t*N41ESU#$gFM93I{dBV-@`;$e+6D3nLkko z4wp{nYb?&x4jqhhPd%(vl0;O|>46_5A_ws}?D`#nQ>oC)!=cp{G>TClC%7@Aa|sfZBUQyB={pFaXg?ycqs1Z0 zT6>`|kAVovgWRr-r!l0trs|PQ%t3HSGe)xgiv&$O#5r|umlxfpM_R4-Sam^?gnqmNYHjM z6($Q9nSB!1SswbW_NQ6T;=GCO~!D~g8}!ua$@$nzu9|g@Dr2VBwnH&H{YPgH4OC4_SUS4vQS)(ApLTrK{zqhbEJQ9%c&8h>BiL`Y^c1TG8!}o?#5u z2m!Opolq&lJGECz_EwN;mcnqd|Lpd}V;Od5 zDIE=scPPFx@jn_#!t8=4CK}G-@UZ!Fl*qyG$a}iiQSRWt0oaJR&-{r%!;;R^uvByS zn=M`S2N;vd)MRg5OOZGUlc-H$*_!IiQVcb<6c+rsoMXgK2b z<}v8=76J~tIBmb+!h57x z@ids=JX@)+SthML(V<0k>mRpB@e*tA+&{3sWqg~*IENeVE$%G|f=xZO|qHZP& zc?J!6;QM3{_f8-msq93&O+70l?HLe2-HyKDWG&r(xSJ=;e;=1m3+tmjk26z5%8;h* z+x40RvJ#u+<|bN0#M*lm0zOZD78JbD3Rik~D+Kd7{Gs2jfCXF<{hs&ka4gdG3bNGI z&f5Bw;!1Tf+^9RgW0A@z${($^p-0n#=bE2?FEamE6ViX%T^vtf&*!n5;j0)Gbllu!@|{F4eCta<*V?KuPjb@6aLybmlwAhr-l zAjH-dVhdggkiZ(SY%Bi-+6IC|umx)f%%hEMfgqnPNMKz}Ab}ZJ0}?>6g%AR52{i;l z4U+&CnLv^JS65U-Dypk1sspdIA`(cfnm|ZRpluBSB#@U`!vtyo0OSLi0;SY}^tqZuBhgqSu#&|hvA`=pt1F_B>S!bqjaEmKH?nA~IT~0$2QUe? zOhO>D1|$NL2`~YGMJi&E>R2?8NGux23yPUz&4C240N_(n#2l?|jz*eefkc~|0|{&d z<^TYw2?WIf%o+d`#3BK6G+>SefNk>W%LN0Ux%Oehl0aRmhC6vjLLjFhDrf~cHz@rOcQIinyd zUui;iD=6SKp-{x$-&-UMDviz!7GYxIb3OT@K?|HHt+JOW9VG?jB?3YIWr?v{DLCP< zClVN2U2xy8pcWvlZXT)VKP%RjwRhh9w$^5;hWIT$l4FhlxX7c=a5W|ENai)GZVP>7L0|MTzrlMKVi%%Rhd5~rzqe^xBQYv$h{0G3u8GC^9YVQ>| zwc&eDb@JO;7%X|(9FfLUJk0yHWF*?UA=2Ep+FyWdyk2gV?q!W=3W*xSFJEDbK#@)0 zX1?xWfG=B-C;G7ZuJIe?DLudM+wdhTkV{rd;g@`s0_uOlE~1g!me$_E-*-gebLb~g zfg$|XX&f`BroxKohn*+oW~lE1e7?KO0Be z7eCvA2+5Sj#%!%j#YuvI#tVxXA?6z71ySwtE2C+>Q?Y`<&h?LxO9J9^dL(C|cqv-K zUtktBQT2GuIKJ7qXPkh83?}{}9NsG&5tlae1q#1Zx8q$gZ|JYt#+?~@m)lN@?AcKIgyCLqsP z3hbsbiC+CDt(dcym23su7{T1f*In)#UR*C{w&nuEFNeDop>g3e9M!`i7-+Cw>oNMB&Y2O!8S4x+|9Ncc7MgPATSb5-myL3o)+Kbbw=Ih50`V6Qz z)r#+wPc$|pIwf7Wu;P9Pbqo%U(yv1P`0Ison9mCGTNSv)+O^ouOUdm}w!2s2LI$it z{Ndy4%K=UJ^T)sE>UJ+Zy9r`yI8{q?ZH}*EK$3FF^pDD&gO#%A)XZ>`8V|`t81PY; z8XbQXf8IVqOU+5L>Ej6$LrvG-Mfwq6()Z{#zKgrRWB^|0iZb+%O8K!%L!s^*s%%k- zkJ4{gM()S-SKDDYQa2^P9aVF0$xB`pSX7_xOC9UpIQLWo0hb!xKn-y4J@g}}qiJUw8jh>< zUJ+*kV>7QW?_|QM64pywTfmv;=9#EInv>cb=YwLHP8k#F3l2USQ$u2d_@D<$nQ<$V zd{AXP1F;9HKIKt-d0YLj>7PJ!@&N zD33Z>S(F4FZcV;o*=*poY=1_>Gc@D!T9a6vFs@x7nzs}i`CV9&4wpgOP}q9L?^S~_ z!ZTin+cG>pozP57M3+o7on9@M&|={=WW~O@e?vVIe!cT1tRiN*eSS81rnU5Co=JaK zKTfJAWAdtV*F(K^-KY+-Z=(<+uR-J0M@;x;(mmZMK~tBK7m5cG1_BTCbPFFdVh|&f z;CjF4x|Ga>MLdD4S^=*Zeu;xOY>_8rS0*+(EpoJR086=3$CEfYH`oA&+HmC-oQ*Fb zt`trU`QD5vjcK@0vs*Ua*`b}9cfs>$$4B%8ck7FROypA3JZFjT-Fdl20y?(2sat{D z&r5u=N^-lG?wJm)3lJaSL?kq0kGC(mIn-mWO}+{JWb@(SW@Ag!ghHh~?ZUF2I%pO# ze}*>vIw0=X3HpV_MoH?~g52iv*I^CcTA7~4CgiQKLua@xQ7<1#V5unYwBNCd2K01zY=24`Fb~J2USF6;FsU;HflO_2ea=e$;U4Aq0eQ1 z4d1+nQ|}ydnj+|zEv$nUF(xYHmh~I`b|D5g2jY&YN*PCV>aWwX!?Q|h#Amdrgg0`0 zSwY#vERielZOPbWVPumKkfD1io}L}2vYVuN4OZ2kEc+>U(zHwSIvCOP_a}X@58t)W zcMyRBe*yZF@dSOfIQ(L1JY_w_ecd87e%6b7qf@t}_3dnDNE8-jh-1VS^Y<$U#Pv@u z2r9-iXVFrt=X%Z8kvp<0tc&bk%(i~?-QQQn6)?35``kgVqjHp6>%2o2HD+PCFl@!c zNlRpQGN+YZRqt6EXUndm^G$2n2)jli(t zd6{y^0@fVp%Ug=?d_Un^AmE|=ojaR956KHeh?(p1qn?oZWQaq_a&Xb9a^p=`2E#5ED&&!B+PAE@!^?(sq$uCI6g7zoZ zJa6e!%#z=YK;p~r+O!ii^FQ@tL^f6rLA{T6ZbXs~f9|mEJJeD2?nQ6*_DZ(|Ub{w& zbh(oQ800-Ww;Y<4C}|J|k-mDjw2new(BtA>NTkQQ<-@Gohk_KQ;USuv5RhaQ6^K3z zhWhDm7Rl}~Dp|9o^&bgw|4=;qcbUnfv2XoMTu=}*a4u!RXu8)*P5k{o9Cn|A+BEg< zXyo}}CM%iijk@1}5&OAA-l*ISswyqkt8gk)9X&T{@8so}moLw~iif;=8ijf@^HXD= zgg5j$sB`C6ns~;~>g4wEF~?4dJD113$@?P08bJxQ3M)wzQ-ywE_p+x}gPfDA)X7a5 zc8I~qPo2sYYtU8PiPuogqn3ye49d{RZDC&8;TdK*xY-*9^C+r-dMAN~Cu*wJKCP;P zioT{4z}e!p-zendXGtr_>G{=grCRAFJmhe}S(L82p5@mF$Yu|7#8k?P+@avSLqg3p zD87r*D4oM^S7I7bta8`OyZ*eKJbnm)zIo3l%@FM`47>)RZPy{l;72$~X(+c8N|2Mi?wVYhZ?C#pn z<+~?}$LU+khy0ORP-vlBE8gCQvD|5W#`>_*oXTOKK&GV*ldZk|= zdIB|LQC^zI8$BC?8J)(G*B1wY9 zO8;949EY^@YSJ?Wg$K4{u!>mqCQJ~E=f0j`U$@XC2wXuKmSbsqxemkn2ng%IE<}^pa(iX!mnr^&k6pc{ zC3cmX6DBNQPmOd5a{c?d1Oz92B1k{3)UNy1CrJJQo;Be!M!6vJyxl_MO?TiAe7(4V z-2PPfrhy~9CHS*^=#T*lNEaNWKqkrGTn+#5tCHUd9@6}w0z(+3C`jPT#K?CYKA4uJm^1^v-%s03+_5Bu6g$jPp%LhAJdQ($8Ms1-YY?PH!K_-h|R|^ z(l8Z7_+$epe<{Ry0>5c0@XDjRJ%iZ0bEQ2dr+~?3VD(B8Bi}_^V5PG zwSjuP?2GXQ4i}|gVCH{?rUCj5(Gt4m1f z?o6vkyWblhlcbjqov$wh)%wImdGs+GIrY4-+n}#GTzDR( zYuR32A0JT_Z}3pQ;|8GIhX<(|;6VPZ`1?b_q0P0}*Go`ijg!#B<;PL(+|nbbs19+> z)-FkLhTwjl9RZDdK~G~}MAYiK;xv+vjeGMbMi+=?pEg+l!h(2l(*ycw0-&x0>h@o*AL?_p6;=rU)bf3L>Z2$Vis7$Sx$ zDtv7q#kwIM;2~EY50|r*S7|;V@FW&eJPfw#HkSBQ&jW?u{cj=v*2yms_JzD^Mp{W^ zG!?WTkJV6T1G$xCR3v?G`hVu;_UoW_7k}g3=kt2@gP?f436b@FSAHgl9A_7cR}_Ix z6No0KgD^8}4dv4l5FEEx66PwuXyEqG`0II`o$(-u2#*y4mi{EeU<-m3B)RSfg3Vwn zR0qin;>i{0tV&*_|0WtG7u~=rqI#YpDi|0+b%@gqM$%*wNu;(3VFPk*@pnj{*3#9} zLw)z9eIPq%8y{py@z8{JIHO*f@;_!dJ3PcsC*xP?BUqX7b6t;fJy0>bQP(sHbNicO z0}rCVM%d{iwk%p8R3H1C=NyBn!skpC<3+AIM(c50@3 zXGUTh{8I|v;ODr?Wln~4qpo2MsPos-z#M0X0aw9bBt%Q@A6Bj;Z20Y24G=cJ>B|Wf z@$65E>CxxyL9KK`o|Nn0$!C!SY@1w@?jngkIGwz2KnuEkSjNAH+x?q<#{A1gMpd6B zD6b}rCsy=T%s2KUX*76sNBKOr=g9} zt-94n)|nJAtXPbW6B>dPoI$YBaD&w&Z<=`oUn#e%pr;{uD~ zn2U-?Ey8o$&>%Kdg2?biLhGgzGko)MC`O2fl!P)J!b?$@P3BM2Dfq5{T#jaF8;i9k zcKLRG_#yCFgqnBo(?`bX>LZ5sKj97Z!Zso7o?YPk&)djD^3iK%lo%DO5q$*%Num~% zeyOyW_`dkrd|2L9{Pm$$-sZVvSOwh26IaJV&70(1j;k&IHQzX3xGW`HZ$GLmY--Xp z)*zlS7WoadBSFjL$#5y`HmXP1R&O)w=e53|`%OSCv;(&`6001pH9oWpc6)a#hLsdy zp1|fVUGWr-YxtGk@3TwasB9oQq@b)1xZO>Vs5mXFUfM;lL?lR)5DubRbi636ZGh>B zI%xfP*y(*bPVzVtFm!EBQh%UF4{PfuiKkg?c zQH7fUw^$FTz7_~L-e+503nKKNyv^8S`!nf_qfp5Q{l^#M{y*j?|8*bdh>h-H@iC5L zU!AQynkl@7H@N-pz~>*1lIrwmFz9sY ztoOHLD-R%{P^BmGDD!{$Zp&bKJ9kw^WM7k(<_Qn#lWhn)14IjAe@3c`$~R7^7vQQ`T<;o;J(Jt)e4J+{EXtPoi{J^G6 zmOlOpW0YQiIeO|Mwb3jVJgS9<*Obcsr_<+$59fWPl+fYW5W#muodOI)t6!cDRey7( zn5g%kS)|COO`wcelVj3Bhg(H2!Bp?lsysE7me#tneB^mQ?7O50s=4WKULrrRcORI5 zSEnf!1AlS;Y#Fh^@$)v6Zcw7;3=n5WqfnV=3oV=J4Vgt3iWktgKm zR%Xdw$*Ab#*LWJ4|0B#S&Q`inzgCwcavA&cRxoD;Z?XC7 zsi`7!gdTCo+)B1|fL;6?sfSJ@C-Sl2tv@A{7%``PqgNg(U6kDLmf?OdJ(b$0Ll77r z3Y`%d*S?OcO+w#&=-;0~5{H#_~X4*eyqM17yC*I+WSer~W*Z$7j@ z$`wA&S`iz><+^xN*-eI1D`G!KQ#=84q1@u@ZF3wen`Cf|z|^BUgoK6K)L{v?blaIZ z>|zj-G%giQu&3M@itl8ZY{B|c_@dF`shYDH&|rs#9CPp;Ky6ym08?msbnC?9;83aI z6fFL|y5KFx>R`$&Iy{u(Q#FpCmTK#*$y_83rDx+V#=s4IQ9{3W<>Nby_?-Uq#k>y# zxxo5TYXs58C4pN(ldk>waG&BkY3PKJV=&w-gD;rskfFo5K2;3-K*+uIz*Anv`^tyI z;=9fu+l8De3bp%8lQjM|pfv!jDYZZpgvmPd=~D(P?K)&;Z%fpiP!&!x^sM6fo?~z` z{>2&6GxwV-iAqV}Tvrkd=D}`~HKkh-obn#uo7o)M*lWDTPT6c_yjGwuDi_|NKZa~w zAsKvhMA?9;5!(bs54(xTe&@TjItwfU~` zu`}SC8H-xoGtH@4oQ@o0s>uU3x|}_%w*4<~z{fNtiIXw!U0N#(@3Q)MfUU%|I@MPyrbZ_n@@ zW#@d4DkR_ujG#lA;@4mvJw8m($_DJu`8B-Sr;FwYHYq0Cs;Xoq3FuGMs23JGMo%ux z=g;ob)$^}MWHviNAG*VKpUO*$5&gic5vAu>YM}4+yWhN*9p+|;9=1Ps57~gLOSRwC zocLXzX+-=1H_U;Bv;y=^`}+>$E&7KYQRJygN|^@%{7kC2GSn4mea?i~l9pEPLAZgh z(vD``pl@ABO>#pO-oX>dL76)jo2Jr?a?HCsg+@S#*i~5SnBGe~7usmCm_*8qC`z>t zc}3rc<&RH40$(6>nZ$^}k1HO5Q`}^yO7_HANP>aK#;@81iU&1n8$HfxLxWA{{Um$I z-ga+f=VRs;qEu9(S8C4Jf868M+5c|no-5ppIRow!3A*T;CJSBS)p~8m>c}QqMnU>E zlF>j+_)mBbBdC747fSZB7{H1}9ZNH)untU`RnF!$1kt`4jBWkIiKn>PiQXv$;;;+K zX~*KWk}NOOqw=<6q9|D_shncMr#ZrQmntN8og!W8ih|PTM@5#;St!GFegY!M9T>!n zlM2=3^E#-u;p)&icm#iNqxH(9&@mgr%c~j%m_!Bn5_O$dbrMnw)2BA%V(U^H`z@w2 zX8g$0z~}YrIx>9vxaDL=~oj*3yUX8djSc*Tp)MzegFO3n=%9^|7WUm8nfV%{PVJ+5+8$ o@VNigkl>#QC;nSsGN2qCH@9qGT4%ici(Th^?t9C2pZMWF02LrEf&c&j literal 9021 zcmeHNc~DbXx=#QBMFCMkKqalyg3|&vyR7L}L`6kh*cWjLtFjXoLt=|!Hv-YLph7?e zL}Vur3|m-)00F`l_7EjN*aQQFkdScS#qNGJ?~k6DepT~c%~ap|a;xt7zH`oZ&pE$u z%l+~EIje13RJK4MkZq?<9=`yANWviy@hNF>u%$Swz8C_5o<4u(k|p>Effz#|2#B#U z#2CC|AqXP)Y`k$Hj1eGVjlmY|uw7L>0+cfb32Y-Gu)_!@aZ{AOZj=2MTQnZd?=+1tdC&!XnW@ z;!wa*NFaS_rqC&L76oi%u_!F?4$w(CbP9=1q0s3h`UaClXL0CYI|mrX8V_R;!$gp< z!^6NZ0I(=IEDDK52Z_R>gR8v_Ghq%5QTQQ%r`4mjx;41w&c-}pgqb%vTlATY?Ofs z52U3b+o4d{ei-Dqgaqcn?=r(wv9ZY0NTf0CCMwXgB@rlozRt+DNU2%slX6Fnjx-aP zK;rxwc_`=`YG~xrLiy?sXZzm>?~|*i5p8+5gq_H(SMu?a(LcjQmPYMsvqDdHV}LBlC>=&7CLIxonzS zc4U@?9}0z3CR{G45sCx^C*a_7!(?}EUH^^&XOpcbk4~P6P3^lf$PX>&-yrSLLzp`} zJcM?|kKm(SgOiY)ESh;f6W}MepD#DX-OCs2)=jyk(057d3?YB_){{$b3nR?#RF^eiZU=e>KJqggA|@2+;fC+MIWgE5GtD-y>M1cgN9e46 z;}h{_R10QC@YbGNufT-#zu6n#S7YbPr#7t3lu#|nbVf&7Jg5zRLfhMv?~S}h+}!NP zH7`&q7S?MLJ#Q#8Xu0OTM_}z0d0%F%#PnJj4P{tHY1}-K69kW3GQ_ncn^}@9Ox!N4 zD+q4rCSA%HT~-EsHdv3M!S>Ofv6Gsv&l%gH1TJsp~A`BL1VwN$g8ik zVY$>a`UiG8o!rY*8(Pf@hUM>?E|~OVe$3#XtEX720;vlQmxXG;H7>b4r6HuJoc+zk zvvZD3xX6Yy5tGlGJPIX|SGW=@ee+@$)aqs)CdCoj+nt$u>Vxc4IkArgs}v;gIj%8) z{!owb?Wd2o!=3Rh^@>nshvdq3N^7~Kc*#IPkgrmDpY92sM5gDCeWQ+!;moE&iSb*6 z-g)f>xs)s|1R(;BzyV|SjAy-jy%Gkvhglwk80}HP1TbBdlndp1O{GBR$c#)D#0ToxXsr)9A)Pk+57%g^)X$1pDylRyEu3z z)7&w!Vi){9b|iEpyzkB`%Y{x4$28g&A)sceWCd)N_Oz?lQkSM!iLe*f@dUv=v7(vr zoROlYrFB46wz)OIhc>%;E+4-slN-fr=zFsmV4xQw^(m>6np}I13B!K$gq&G%&jh1kZ~*4mx^$(hKR!QHNQl9FfOn#WRgy__!b03x1($&3T8v+3tfn z%hZ`%iP+Ejn_$2S@sjw#>a@D-Ur*r;klR)Iju0+$7NzAB@g@dwa*a~>M*6eF$oDb zR{OEG%FQ zr@2#b#F_%$40~2ghyRwOe?9C#GZ8wt2<6s(J$M8x|3S*cI%^#MG34)6_=<1%MM!I{jeX;C@E&*;TmuM;##EWn@ z-H8?SINfy*t?~R!oUg-8#iyzG1u393V9xmC3o<8zHQt8q>XTIOVmq&1=EmSAjVt>u z+fkv8Yms76zE)7jqd$~I{!kj)h(MM)@m)g#EtV>%;j#0I17jXP<)#lg4P+(i_?&25&XfNf;_rJa*lqq^Bd*KuG!Y_=~; zkQZcr*HEFujubkAaO+sHqKJz=H|sG?`)hZ_i&4b9^RzOFZR3J)I0}n4J)6XRKuHH z4EWZqMl?8HImmU4OCb*HIy&%|PSWKKgc`VcKZLJ2TJI#^k^5oAk6&|t@R-?ibxVE1 ztclbJGP`l6WX-3uoRhEbq>3Hf5n7J^xn(SYHtoBb$3M~Q>}qa5fow+kLO!f`~36qb;!_zGQ*&8 zGDs)BJ{)FQky0MQ{9bpf`LuI-O{mW~Ph=9q`L4byns*dB9ntx566&4s6xFj?)ctl@ zGh-@q+HB2#o^>Gay}zOfIYGqZdqK)Ovf`MJ%CUocjN(&3QwI)K8p4eG|T$!;VnQ zhQguHiWLhOK_;YCHPTE)WGpaq=MN09eNA(h)D}>sYn)Jj12;IPAQ_A{ z=hXh0sPos5bnp~>i?W!J(I1Ri|87A0yUY^A6#90h#!s_6yVn-Rk=(lOGZGRXK5Uf} z*(AnwKQT;tozDC#*t_l}dG3963ybcQswgH_8vx(8w|a3tb4ZRv(sPAF9Cl!P#+*ce z>ZcZ)#6sb-U>Ibp)OhCTlF{tEf9g)d)ZDRjuC%U3JZ zy60}4NeQ}EqIc6^2RNM3-D7}vVE#G~&(8$m!O6olmJa@cOIeXR*R9EMZMWT0u`1)4 zv~+EqvWkG_PlrZ?lqz5mHkoHAZJYA@p9Oh|7EeBCl3mp>dX`XIfkHtXtywWVJH%4b?tBHvPV2C8S%pq-3#qHB5P}^9q z6q7D>wz`?&y$wy|^P?2|=o6kE_!ZtU5R#prJAtV;T)k1;BF0X1d$hZ3{)@tXt33Ey zOzJMsn6>{2z<;*>@E?Gbf2z*%2j4SKS)j($`e{s1%|5q79&=33blJj8>$Lr7ct`1v z8^^cqB_Oop%z%Ds8m*Rxw`Y3^YOF60WTD7B@p zeBBK?K}HR)8vX4;`E43lI{eOPyg2jhjmG*S>0>Zz?@x zc+k2B@!!r+v3~|&KDCLAbWx)jJDy4T4WGXtFVRC^t+EThf#lSe8%W-ZwX*sK>b-Kj zHKfg@a|l{g4#tZI6~JJT*wc7!L+&jM=E<;*QkV6B?s@e|JSeR6wklZG-ScANCEyo! za%S?wQEbl>k=%xlJ_c2Ow`Ep{PmBKI^(M`+Gedc~)a+h$Q11ss(hgKmba(K@<_(+C zwGmRfMl1Gtqb)#h2iYbkN=$IFVVND0^P7G_CCrZy4v%hz`xJd$YQ#|NGntULbUulZ# zm=tTlAbFDG8<;{ck76sn{*nX=3hIqDRTwcKpgs;xns208#a#Rph{p3yyu*39)wFsA zdC0-pv?gcs<+l+k3#U+U-xVmRWCK|W^e7?xxR`<M64K4>@52T3MIl@UUCUl=mmd zcZdNJC&>3Qn6+`tdXZ2zVg24-k>pVQ_T3`IglO?i*E9b{1`buu>GFS}x#v!o|HmoA z^Y9Zs%c@>7R#%ptjRf0vVjrpeO;ggZ9;(3>qf2W1ktC%b>bFid*dP6E7U8n%hM> zuioe&^&*=>=wFBjIWqdA{r*AHV3+GV8B~m^am8ZBv~~m~L&S@+yQCVP8-Ano$J8?& zHa`{DVA$n9*)KdPWai3gMP1hFc;HTM`AR5V^VBv(8{F&>4S+Z0m8m@+A|%r^)oqYh@OAv5HSX;#C@z4A$6QJW`p3ghc1AC-bMgN}-41xuD!y;)i>QucB13xL5BM7qp_j)*6@& zN8ibR7z*(@f$vJoN>QGj?blgUtBX^!+k zOw~wcF1Nf(^uX_pUsYLdb&!HVm4D;_(r&976*kbLDU8*Ufsx`*?qLR>LmrZaA@22H z_l`Rc8#K@o_AYZ875z}1F+bDU3T83h3+>pEq?e$D{Lnt8`D-6 zU8iafSA3mfG|Dd3J7EIZTZ@8ab=5>?6$8>WFKk29#Jf%JdY010j#?=53Jc1*WZ|&^ z>VoU<3z_5c(Gu=$8WqVPv@cbyTxqL(dd-BSd!2eu(L;$pQmJO228rT@k*L;KDW2uI1H)9@FI%kSQZTGAI7`z`o&?Mj5xMcbfv zTCeJ9|KuA*Y+iD{hbfAch_PL(D(&(#H;bNN%)~DN5tl|*_r=|=E*-YqBE5DBzMDX^ zV7`O3dzn8=RV*}rpu`uCQU$p?cmf$c#s=FQeQ#!rTC|?_Ey!YLCA0=pxQpAOH z>1V`if?^*IAw>Gis}^d?d1w~opl)7}%v5231&FA9i3tWr2{jX6<#p^&Ig@(!m=22V z6CC^iQG~ey0wv)QPR&4Ta2kLdO>~(Wa=?G`L{0a^OzX5}_XW4o( z*(=NKiV@v5 z2A(?Xyz-Wl!Ri8ErJCkZldfEwqt6(RW!Eg>FLZWe2MI+5ZnbKg9XB_R2S)S>1wu!M so<_HvLRPh?KJ8n%lz#(^Edo&0p}C}(tgGT1pTV56Ja@d{`zt^E7wa(`djJ3c diff --git a/vignettes/articles/modelsummary_integration.Rmd b/vignettes/articles/modelsummary_integration.Rmd new file mode 100644 index 0000000..0d0bb65 --- /dev/null +++ b/vignettes/articles/modelsummary_integration.Rmd @@ -0,0 +1,224 @@ +--- +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 (require("modelsummary", 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 D_r -0.1851801 0.03224716 -5.742526 9.327476e-09 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 conf.low +#> 1 D_r -0.1857013 0.03220572 -5.766097 8.112844e-09 singlebest -0.2488233 +#> conf.high +#> 1 -0.1225792 +``` + +## ``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 +``` + +# 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 (require("modelsummary", quietly = TRUE)) { + msummary(model_list, + stars = TRUE, + coef_rename = c("D" = "Treatment (D)"), + gof_omit = "AIC|BIC|Log.Lik.|F|RMSE") +} +#> Error: Package `tinytable` required for this function to work. +#> Please install it by running `install.packages("tinytable")`. +``` + +Notice how ``modelsummary`` automatically pulled the custom goodness-of-fit metrics from ``glance.ddml()`` (e.g., ``sample_folds``, ``shortstack``, ``ensemble_type``). + +If you wish to show the results for the *other* ensemble type (``singlebest``) in the table, ``modelsummary`` requires us to pass either a custom tidier or explicitly extract and rename the components. A simple robust trick is to manually tidy the ``ddml`` output first when dealing with secondary ensembles. + + +```r +# Retrieve tidied data.frames +df_nnls <- tidy(ddml_fit, ensemble_idx = 1) +df_singlebest <- tidy(ddml_fit, ensemble_idx = 2) + +if (require("modelsummary", quietly = TRUE)) { + msummary( + list("DDML (NNLS)" = df_nnls, "DDML (Single Best)" = df_singlebest), + title = "Comparison of Stacking Approaches", + shape = term ~ model + statistic, + gof_map = NA # We omit model statistics since we passed data.frames directly + ) +} +#> Objects of class `NULL` are currently not supported. +#> Error: `modelsummary could not extract the required information from a model of +#> class "data.frame". The package tried a sequence of 2 helper functions +#> to extract estimates: +#> +#> parameters::parameters(model) +#> broom::tidy(model) +#> +#> To draw a table, one of these commands must return a `data.frame` with a +#> column named "term". The `modelsummary` website explains how to +#> summarize unsupported models or add support for new models yourself: +#> https://modelsummary.com/vignettes/modelsummary.html +#> +#> These errors messages were generated during extraction: +#> +#> `parameters::parameters(model)` did not return a valid data.frame. +#> `broom::tidy(model)` did not return a valid data.frame. +``` + +# 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 +repl_fit <- ddml_replicate( + ddml_plm, + y = y, D = D, X = X, + learners = list(list(what = ols)), + resamples = 3, + sample_folds = 5, + silent = TRUE +) +#> Error in ddml_replicate(ddml_plm, y = y, D = D, X = X, learners = list(list(what = ols)), : could not find function "ddml_replicate" + +# Extract aggregated coefficients +tidy(repl_fit) +#> Error in eval(expr, envir, enclos): object 'repl_fit' not found + +# Combine standard fit and averaged fit in a table +if (require("modelsummary", quietly = TRUE)) { + msummary(list("Single Split" = ddml_fit, "Repeated 3x" = repl_fit), + stars = TRUE) +} +#> Error in eval(expr, envir, enclos): object 'repl_fit' not found +``` + +# 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 +#> 1 y_X learner_1 0.2412722 0.02764647 0.4186534 +#> 2 y_X learner_2 0.2413187 0.02745888 0.5734605 +#> 3 D1_X learner_1 0.2206338 0.05336647 0.7208025 +#> 4 D1_X learner_2 0.2206689 0.05321582 0.2715648 +``` + +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. + diff --git a/vignettes/articles/modelsummary_integration.Rmd.txt b/vignettes/articles/modelsummary_integration.Rmd.txt new file mode 100644 index 0000000..550d97b --- /dev/null +++ b/vignettes/articles/modelsummary_integration.Rmd.txt @@ -0,0 +1,177 @@ +--- +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 (require("modelsummary", 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 (require("modelsummary", 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``). + +If you wish to show the results for the *other* ensemble type (``singlebest``) in the table, ``modelsummary`` requires us to pass either a custom tidier or explicitly extract and rename the components. A simple robust trick is to manually tidy the ``ddml`` output first when dealing with secondary ensembles. + +```{r} +# Retrieve tidied data.frames +df_nnls <- tidy(ddml_fit, ensemble_idx = 1) +df_singlebest <- tidy(ddml_fit, ensemble_idx = 2) + +if (require("modelsummary", quietly = TRUE)) { + msummary( + list("DDML (NNLS)" = df_nnls, "DDML (Single Best)" = df_singlebest), + title = "Comparison of Stacking Approaches", + shape = term ~ model + statistic, + gof_map = NA # We omit model statistics since we passed data.frames directly + ) +} +``` + +# 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 +repl_fit <- ddml_replicate( + ddml_plm, + y = y, D = D, X = X, + learners = list(list(what = ols)), + resamples = 3, + sample_folds = 5, + silent = TRUE +) + +# Extract aggregated coefficients +tidy(repl_fit) + +# Combine standard fit and averaged fit in a table +if (require("modelsummary", quietly = TRUE)) { + msummary(list("Single Split" = ddml_fit, "Repeated 3x" = 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. + diff --git a/vignettes/articles/repeated_resampling.Rmd b/vignettes/articles/repeated_resampling.Rmd new file mode 100644 index 0000000..a06b4f7 --- /dev/null +++ b/vignettes/articles/repeated_resampling.Rmd @@ -0,0 +1,223 @@ +--- +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 t value Pr(>|t|) +#> D_r -0.120 0.033 -3.62 0.00029 *** +#> --- +#> 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 +) +#> Error in ddml_replicate(ddml_plm, y = y, D = D, X = X, learners = learners, : could not find function "ddml_replicate" + +# Observe the class of the returned object +class(fit_rep) +#> Error in eval(expr, envir, enclos): object 'fit_rep' not found +``` + +# 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 +#> Error in eval(expr, envir, enclos): object 'fit_rep' not found + +# Aggregate inference (Median Aggregation) +summary(fit_rep) +#> Error in h(simpleError(msg, call)): error in evaluating the argument 'object' in selecting a method for function 'summary': object 'fit_rep' not found + +# Extract only the coefficients +coef(fit_rep) +#> Error in eval(expr, envir, enclos): object 'fit_rep' not found + +# Extract confidence intervals (with HC3 standard errors passed to the VCoV estimator) +confint(fit_rep, type = "HC3") +#> Error in eval(expr, envir, enclos): object 'fit_rep' not found +``` + +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") +#> Error in h(simpleError(msg, call)): error in evaluating the argument 'object' in selecting a method for function 'summary': object 'fit_rep' not found +``` + +## Visualizing Splitting Variance + +We can inspect the exact variation across the five sample splits by extracting the point estimates from the underlying arrays of the ``ddml_rep`` object: + + +```r +# Individual point estimates for the 'nnls' ensemble across the 5 independent splits +split_estimates <- fit_rep$coef_array[1, "nnls", ] +#> Error in eval(expr, envir, enclos): object 'fit_rep' not found +print(split_estimates) +#> Error in h(simpleError(msg, call)): error in evaluating the argument 'x' in selecting a method for function 'print': object 'split_estimates' not found + +# Variance of the point estimates across splits +var(split_estimates) +#> Error in eval(expr, envir, enclos): object 'split_estimates' not found +``` + +## 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 +) +#> Error in ddml_replicate(ddml_plm, y = y, D = AE98[sub_idx, c("morekids", : could not find function "ddml_replicate" + +# Extract the full aggregated Variance-Covariance matrix +vcov(fit_rep_multi) +#> Error in eval(expr, envir, enclos): object 'fit_rep_multi' not found +``` + +## 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]] +#> Error in eval(expr, envir, enclos): object 'fit_rep' not found +class(run_3) +#> Error in eval(expr, envir, enclos): object 'run_3' not found + +# View its specific diagnostics +diagnostics(run_3) +#> Error in eval(expr, envir, enclos): object 'run_3' not found +``` + +# 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) +#> Error in ddml_rep(fits_list): could not find function "ddml_rep" +class(manual_rep) +#> Error in eval(expr, envir, enclos): object 'manual_rep' not found + +# 3. Aggregate results +summary(manual_rep) +#> Error in h(simpleError(msg, call)): error in evaluating the argument 'object' in selecting a method for function 'summary': object 'manual_rep' not found +``` + +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, 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..91b2f49 --- /dev/null +++ b/vignettes/articles/repeated_resampling.Rmd.txt @@ -0,0 +1,196 @@ +--- +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 arrays of the ``ddml_rep`` object: + +```{r} +# Individual point estimates for the 'nnls' ensemble across the 5 independent splits +split_estimates <- fit_rep$coef_array[1, "nnls", ] +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, 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 a699843..f2f0479 100644 --- a/vignettes/articles/sparse.Rmd +++ b/vignettes/articles/sparse.Rmd @@ -66,16 +66,16 @@ 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 = TRUE, @@ -95,16 +95,16 @@ The exercise can be repeated with the larger set of 1530 instruments as well. Wi ```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 = TRUE, @@ -128,24 +128,24 @@ 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 = TRUE, diff --git a/vignettes/articles/stacking.Rmd b/vignettes/articles/stacking.Rmd index 867f678..98f85ae 100644 --- a/vignettes/articles/stacking.Rmd +++ b/vignettes/articles/stacking.Rmd @@ -45,34 +45,34 @@ 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 ``` @@ -82,11 +82,11 @@ Both stacking and short-stacking construct weighted averages of the considered b ```r cat("Time single learner:", time_singlelearner[1], "\n") -#> Time single learner: 3.95 +#> Time single learner: 1.97 cat("Time short-stacking:", time_shortstacking[1], "\n") -#> Time short-stacking: 7.47 +#> Time short-stacking: 4.23 cat("Time stacking: ", time_stacking[1]) -#> Time stacking: 75.75 +#> Time stacking: 26.36 ``` # References diff --git a/vignettes/articles/stacking.Rmd.txt b/vignettes/articles/stacking.Rmd.txt index 82e75f6..d61c833 100644 --- a/vignettes/articles/stacking.Rmd.txt +++ b/vignettes/articles/stacking.Rmd.txt @@ -51,7 +51,7 @@ 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 @@ -64,7 +64,7 @@ time_shortstacking <- system.time({ max_depth = 1))), ensemble_type = 'nnls1', shortstack = TRUE, - sample_folds = 10, + sample_folds = 5, silent = TRUE) })#SYSTEM.TIME @@ -77,8 +77,8 @@ time_stacking <- system.time({ max_depth = 1))), ensemble_type = 'nnls1', shortstack = FALSE, - sample_folds = 10, - cv_folds = 10, + sample_folds = 5, + cv_folds = 5, silent = TRUE) })#SYSTEM.TIME ``` diff --git a/vignettes/articles/stacking_diagnostics.Rmd b/vignettes/articles/stacking_diagnostics.Rmd new file mode 100644 index 0000000..15fe83e --- /dev/null +++ b/vignettes/articles/stacking_diagnostics.Rmd @@ -0,0 +1,210 @@ +--- +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 +#> learner_1 0.2407 0.0322 0.0000 +#> learner_2 0.2407 0.0322 0.8975 +#> learner_3 0.2407 0.0322 0.0000 +#> learner_4 0.2407 0.0322 0.1025 +#> +#> y_X_Z1: +#> learner mspe r2 weight +#> learner_1 0.2419 0.0316 0.0000 +#> learner_2 0.2419 0.0316 0.8775 +#> learner_3 0.2419 0.0316 0.0874 +#> learner_4 0.2419 0.0316 0.0351 +#> +#> D_X_Z0: +#> learner mspe r2 weight +#> learner_1 0.209 0.0799 0.6868 +#> learner_2 0.209 0.0799 0.0000 +#> learner_3 0.209 0.0799 0.0693 +#> learner_4 0.209 0.0799 0.2439 +#> +#> D_X_Z1: +#> learner mspe r2 weight +#> learner_1 0.2235 0.0813 0.7212 +#> learner_2 0.2235 0.0813 0.0000 +#> learner_3 0.2235 0.0813 0.1049 +#> learner_4 0.2235 0.0813 0.1739 +#> +#> Z_X: +#> learner mspe r2 weight +#> learner_1 0.2498 2e-04 0 +#> learner_2 0.2498 2e-04 1 +#> learner_3 0.2498 2e-04 0 +#> learner_4 0.2498 2e-04 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 +#> 1 y_X_Z0 learner_1 0.2406740 0.03216873 4.946908e-17 +#> 2 y_X_Z0 learner_2 0.2406740 0.03216873 8.975098e-01 +#> 3 y_X_Z0 learner_3 0.2406740 0.03216873 0.000000e+00 +#> 4 y_X_Z0 learner_4 0.2406740 0.03216873 1.024902e-01 +#> 5 y_X_Z1 learner_1 0.2418787 0.03156255 0.000000e+00 +#> 6 y_X_Z1 learner_2 0.2418787 0.03156255 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 cvc_pval +#> learner_1 0.2407 0.0322 0.0000 0.610 +#> learner_2 0.2407 0.0322 0.8975 0.991 +#> learner_3 0.2407 0.0322 0.0000 0.002 +#> learner_4 0.2407 0.0322 0.1025 0.001 +#> +#> y_X_Z1: +#> learner mspe r2 weight cvc_pval +#> learner_1 0.2419 0.0316 0.0000 0.238 +#> learner_2 0.2419 0.0316 0.8775 1.000 +#> learner_3 0.2419 0.0316 0.0874 0.002 +#> learner_4 0.2419 0.0316 0.0351 0.000 +#> +#> D_X_Z0: +#> learner mspe r2 weight cvc_pval +#> learner_1 0.209 0.0799 0.6868 0.843 +#> learner_2 0.209 0.0799 0.0000 0.870 +#> learner_3 0.209 0.0799 0.0693 0.001 +#> learner_4 0.209 0.0799 0.2439 0.020 +#> +#> D_X_Z1: +#> learner mspe r2 weight cvc_pval +#> learner_1 0.2235 0.0813 0.7212 0.916 +#> learner_2 0.2235 0.0813 0.0000 0.767 +#> learner_3 0.2235 0.0813 0.1049 0.000 +#> learner_4 0.2235 0.0813 0.1739 0.005 +#> +#> Z_X: +#> learner mspe r2 weight cvc_pval +#> learner_1 0.2498 2e-04 0 0.048 +#> learner_2 0.2498 2e-04 1 0.995 +#> learner_3 0.2498 2e-04 0 0.245 +#> learner_4 0.2498 2e-04 0 0.000 +#> +#> Note: CVC compares individual base learners. +#> Shortstacked ensemble CVC is not available (weights use all data). +``` + +Two new columns are 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. +- **In Conf. Set:** Logical indicator of whether the learner belongs to the Model Confidence Set (the set of learners for which the null hypothesis of equal performance to the best learner cannot be rejected). + +Often, simple parametric models (like OLS) perform remarkably similarly to highly flexible machine learners (like XGBoost) after accounting for the variation across cross-fitting folds. The CVC tests provide a rigorous statistical foundation for model selection and ensemble justification. + +# Advanced Standalone CVC Usage + +The testing machinery underlying ``diagnostics`` is built on a suite of accessible internal functions. If you wish to directly compare exactly two learners, you can use ``cvc_pairwise()``. It returns the point estimate of the difference in MSPE, standard error, t-statistic, and p-value. + +Below, we extract the cross-fitted residuals for the $E[Y|Z=0, X]$ equation and compare the first two base learners (OLS and Lasso). + + +```r +# Extract the residuals for the first equation (E[Y|Z=0, X]) +resids <- late_fit$crossfit_resid[[1]] +fold_ids <- late_fit$subsamples_byZ[[1]] + +# Compare Learner 1 (OLS) vs Learner 2 (Lasso) +cvc_pairwise(resids, 1, 2, fold_ids) +#> Error in cvc_pairwise(resids, 1, 2, fold_ids): could not find function "cvc_pairwise" +``` + +# 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. + +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_diagnostics.Rmd.txt b/vignettes/articles/stacking_diagnostics.Rmd.txt new file mode 100644 index 0000000..8f8fc41 --- /dev/null +++ b/vignettes/articles/stacking_diagnostics.Rmd.txt @@ -0,0 +1,127 @@ +--- +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) +``` + +Two new columns are 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. +- **In Conf. Set:** Logical indicator of whether the learner belongs to the Model Confidence Set (the set of learners for which the null hypothesis of equal performance to the best learner cannot be rejected). + +Often, simple parametric models (like OLS) perform remarkably similarly to highly flexible machine learners (like XGBoost) after accounting for the variation across cross-fitting folds. The CVC tests provide a rigorous statistical foundation for model selection and ensemble justification. + +# Advanced Standalone CVC Usage + +The testing machinery underlying ``diagnostics`` is built on a suite of accessible internal functions. If you wish to directly compare exactly two learners, you can use ``cvc_pairwise()``. It returns the point estimate of the difference in MSPE, standard error, t-statistic, and p-value. + +Below, we extract the cross-fitted residuals for the $E[Y|Z=0, X]$ equation and compare the first two base learners (OLS and Lasso). + +```{r} +# Extract the residuals for the first equation (E[Y|Z=0, X]) +resids <- late_fit$crossfit_resid[[1]] +fold_ids <- late_fit$subsamples_byZ[[1]] + +# Compare Learner 1 (OLS) vs Learner 2 (Lasso) +cvc_pairwise(resids, 1, 2, fold_ids) +``` + +# 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. + +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/ddml.Rmd b/vignettes/ddml.Rmd index 8e4f148..c5caf14 100644 --- a/vignettes/ddml.Rmd +++ b/vignettes/ddml.Rmd @@ -17,9 +17,10 @@ This article is an introduction to double/debiased machine learning using short- 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 @@ -77,9 +78,9 @@ 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))) ``` @@ -106,29 +107,55 @@ summary(late_fit) #> LATE -0.223 0.187 -1.2 0.23 ``` -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.9668285 0 0.0331715 - -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 0.8027662 0.1972338 +diagnostics(late_fit) +#> Stacking diagnostics: Local Average Treatment Effect +#> Obs: 5000 +#> +#> y_X_Z0: +#> learner mspe r2 weight +#> learner_1 0.2412 0.0299 0.9668 +#> learner_2 0.2412 0.0299 0.0000 +#> learner_3 0.2412 0.0299 0.0332 +#> +#> y_X_Z1: +#> learner mspe r2 weight +#> learner_1 0.2424 0.0297 0.0000 +#> learner_2 0.2424 0.0297 0.8028 +#> learner_3 0.2424 0.0297 0.1972 +#> +#> D_X_Z0: +#> learner mspe r2 weight +#> learner_1 0.2091 0.0791 0.9303 +#> learner_2 0.2091 0.0791 0.0000 +#> learner_3 0.2091 0.0791 0.0697 +#> +#> D_X_Z1: +#> learner mspe r2 weight +#> learner_1 0.2234 0.0817 0.9557 +#> learner_2 0.2234 0.0817 0.0000 +#> learner_3 0.2234 0.0817 0.0443 +#> +#> Z_X: +#> learner mspe r2 weight +#> learner_1 0.2499 -1e-04 0.0000 +#> learner_2 0.2499 -1e-04 0.5509 +#> learner_3 0.2499 -1e-04 0.4491 ``` +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 @@ -163,8 +190,77 @@ summary(late_fit) #> LATE -0.229 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 t value Pr(>|t|) +#> D_r -0.1467 0.0147 -9.97 <2e-16 *** +#> --- +#> 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) +#> Error in ddml_replicate(ddml_plm, y = y, D = D, X = X, learners = learners_multiple, : could not find function "ddml_replicate" +summary(plm_rep) +#> Error in eval(expr, envir, enclos): object 'plm_rep' not found +``` + +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, 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 d8266bd..05be33a 100644 --- a/vignettes/ddml.Rmd.txt +++ b/vignettes/ddml.Rmd.txt @@ -25,9 +25,10 @@ This article is an introduction to double/debiased machine learning using short- 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 @@ -99,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} @@ -130,8 +131,66 @@ 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, 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 0069bc7..8c585ef 100644 --- a/vignettes/precompile.R +++ b/vignettes/precompile.R @@ -39,7 +39,19 @@ VIGNETTES <- list( src = "vignettes/articles/did.Rmd.txt", out = "vignettes/articles/did.Rmd", deps = c("ddml", "did"), - note = "needs setwd for fig.path") + 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") ) args <- commandArgs(trailingOnly = TRUE) From 8d289c2b71a8d2cba3d7bf761c50406582622cac Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Thu, 5 Mar 2026 10:52:26 -0600 Subject: [PATCH 14/46] news + adds JEL ref --- NEWS.md | 1 + README.Rmd | 2 ++ README.md | 4 ++++ vignettes/articles/did.Rmd | 4 +++- vignettes/articles/did.Rmd.txt | 4 +++- vignettes/articles/repeated_resampling.Rmd.txt | 2 ++ vignettes/articles/stacking_diagnostics.Rmd.txt | 2 ++ vignettes/ddml.Rmd | 2 ++ vignettes/ddml.Rmd.txt | 2 ++ 9 files changed, 21 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index e9f4cd0..ca556df 100644 --- a/NEWS.md +++ b/NEWS.md @@ -14,6 +14,7 @@ * Updates S3 methods (`coef`, `vcov`, `confint`, `summary`, `print`). * Adds `mdl_bigGLM` sparse-matrix unpenalized regression wrapper. * `mdl_xgboost()` auto-detects binary factor outcomes. +* Adds `ddml_rep()` and `ddml_replicate()` for repeated cross-fitting with median or mean aggregation. * Fixes `ddml_fpliv()` with custom weights. # ddml 0.3.0 diff --git a/README.Rmd b/README.Rmd index 868168f..4ef611a 100644 --- a/README.Rmd +++ b/README.Rmd @@ -104,6 +104,8 @@ For additional applied examples, see our case studies: ## 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 2e8da1d..3b71b37 100644 --- a/README.md +++ b/README.md @@ -144,6 +144,10 @@ and ## 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/vignettes/articles/did.Rmd b/vignettes/articles/did.Rmd index bd4b603..b38558f 100644 --- a/vignettes/articles/did.Rmd +++ b/vignettes/articles/did.Rmd @@ -14,7 +14,7 @@ vignette: > 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. -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). +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). See also Ahrens et al. (2026) for an example of staggered differences-in-differences estimated with ddml. # Estimation using ``did``'s Default Estimator @@ -494,6 +494,8 @@ This diagnostic output displays the cross-validated Mean Squared Prediction Erro # 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. + Callaway B, Sant'Anna P (2021). “Difference-in-differences with multiple time periods.” Journal of Econometrics, 200-230. Callaway B, Sant'Anna P (2021). “did: Difference in Differences.” R package version 2.1.2, https://bcallaway11.github.io/did/. diff --git a/vignettes/articles/did.Rmd.txt b/vignettes/articles/did.Rmd.txt index ec90441..b3c4f69 100644 --- a/vignettes/articles/did.Rmd.txt +++ b/vignettes/articles/did.Rmd.txt @@ -23,7 +23,7 @@ knitr::opts_chunk$set( 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. -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). +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). See also Ahrens et al. (2026) for an example of staggered differences-in-differences estimated with ddml. # Estimation using ``did``'s Default Estimator @@ -280,6 +280,8 @@ This diagnostic output displays the cross-validated Mean Squared Prediction Erro # 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. + Callaway B, Sant'Anna P (2021). “Difference-in-differences with multiple time periods.” Journal of Econometrics, 200-230. Callaway B, Sant'Anna P (2021). “did: Difference in Differences.” R package version 2.1.2, https://bcallaway11.github.io/did/. diff --git a/vignettes/articles/repeated_resampling.Rmd.txt b/vignettes/articles/repeated_resampling.Rmd.txt index 91b2f49..d9933e8 100644 --- a/vignettes/articles/repeated_resampling.Rmd.txt +++ b/vignettes/articles/repeated_resampling.Rmd.txt @@ -191,6 +191,8 @@ This flexibility allows ``ddml`` to scale efficiently from local laptops to mass # 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/stacking_diagnostics.Rmd.txt b/vignettes/articles/stacking_diagnostics.Rmd.txt index 8f8fc41..826b883 100644 --- a/vignettes/articles/stacking_diagnostics.Rmd.txt +++ b/vignettes/articles/stacking_diagnostics.Rmd.txt @@ -122,6 +122,8 @@ cvc_pairwise(resids, 1, 2, fold_ids) # 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. diff --git a/vignettes/ddml.Rmd b/vignettes/ddml.Rmd index c5caf14..78953a5 100644 --- a/vignettes/ddml.Rmd +++ b/vignettes/ddml.Rmd @@ -259,6 +259,8 @@ For additional applied examples, see: # 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. diff --git a/vignettes/ddml.Rmd.txt b/vignettes/ddml.Rmd.txt index 05be33a..eb3e258 100644 --- a/vignettes/ddml.Rmd.txt +++ b/vignettes/ddml.Rmd.txt @@ -189,6 +189,8 @@ For additional applied examples, see: # 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. From ce12b8f182fa07a7b8665eddb8b22f2a910d930d Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Fri, 6 Mar 2026 07:56:37 -0600 Subject: [PATCH 15/46] refactor ddml_* estimators --- NAMESPACE | 6 + NEWS.md | 1 + R/ddml_apo.R | 284 ++++++++++++ R/ddml_ate.R | 334 +++++++------- R/ddml_att.R | 276 ++++++------ R/ddml_fpliv.R | 385 ++++++---------- R/ddml_late.R | 415 ++++++++---------- R/ddml_pliv.R | 256 ++++++----- R/ddml_plm.R | 220 +++++----- R/ddml_rep.R | 58 +-- R/diagnostics.R | 43 +- R/get_CEF.R | 90 +++- R/help_functions.R | 86 +++- R/inference_functions.R | 56 ++- R/methods.R | 170 +++++-- R/tidy.R | 3 +- README.md | 4 +- _pkgdown.yml | 14 + man/cash-.ddml.Rd | 21 + man/confint.ddml.Rd | 4 +- man/ddml_apo.Rd | 226 ++++++++++ man/ddml_ate.Rd | 58 ++- man/ddml_fpliv.Rd | 28 +- man/ddml_late.Rd | 56 ++- man/ddml_pliv.Rd | 21 +- man/ddml_plm.Rd | 20 +- man/nobs.ddml.Rd | 19 + man/sub-.summary.ddml.Rd | 22 + man/summary.ddml.Rd | 11 +- man/vcov.ddml.Rd | 60 ++- man/vcov.ddml_rep.Rd | 6 +- tests/testthat/test-ddml_apo.R | 299 +++++++++++++ tests/testthat/test-ddml_ate.R | 64 ++- tests/testthat/test-ddml_att.R | 36 +- tests/testthat/test-ddml_fpliv.R | 134 +++--- tests/testthat/test-ddml_late.R | 78 +++- tests/testthat/test-ddml_pliv.R | 80 +++- tests/testthat/test-ddml_plm.R | 93 ++-- tests/testthat/test-ddml_rep.R | 57 +-- tests/testthat/test-inference_functions.R | 55 +-- tests/testthat/test-methods.R | 16 +- tests/testthat/test-tidy.R | 2 +- vignettes/articles/did.Rmd | 4 +- vignettes/articles/did.Rmd.txt | 4 +- vignettes/articles/example_401k.Rmd | 47 +- vignettes/articles/example_401k.Rmd.txt | 12 +- vignettes/articles/example_BLP95.Rmd | 28 +- vignettes/articles/example_BLP95.Rmd.txt | 16 +- vignettes/articles/repeated_resampling.Rmd | 2 + vignettes/articles/sparse.Rmd | 10 +- vignettes/articles/sparse.Rmd.txt | 4 +- vignettes/articles/stacking.Rmd | 10 +- vignettes/articles/stacking.Rmd.txt | 4 +- vignettes/articles/stacking_diagnostics.Rmd | 4 +- .../articles/stacking_diagnostics.Rmd.txt | 2 +- vignettes/ddml.Rmd | 12 +- vignettes/ddml.Rmd.txt | 12 +- 57 files changed, 2771 insertions(+), 1567 deletions(-) create mode 100644 R/ddml_apo.R create mode 100644 man/cash-.ddml.Rd create mode 100644 man/ddml_apo.Rd create mode 100644 man/nobs.ddml.Rd create mode 100644 man/sub-.summary.ddml.Rd create mode 100644 tests/testthat/test-ddml_apo.R diff --git a/NAMESPACE b/NAMESPACE index f39066c..4967157 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,7 @@ # Generated by roxygen2: do not edit by hand +S3method("$",ddml) +S3method("[",summary.ddml) S3method("[[",ddml_rep) S3method(coef,ddml) S3method(coef,ddml_rep) @@ -8,6 +10,7 @@ S3method(confint,ddml_rep) S3method(glance,ddml) S3method(glance,ddml_rep) S3method(length,ddml_rep) +S3method(nobs,ddml) S3method(predict,ensemble) S3method(predict,mdl_bigGLM) S3method(predict,mdl_glm) @@ -20,6 +23,7 @@ S3method(print,ddml_rep) S3method(print,summary.ddml) S3method(print,summary.ddml_rep) S3method(summary,ddml) +S3method(summary,ddml_apo) S3method(summary,ddml_rep) S3method(tidy,ddml) S3method(tidy,ddml_diagnostics) @@ -28,6 +32,7 @@ S3method(vcov,ddml) S3method(vcov,ddml_rep) export(crosspred) export(crossval) +export(ddml_apo) export(ddml_ate) export(ddml_att) export(ddml_fpliv) @@ -50,4 +55,5 @@ export(shortstacking) export(tidy) importFrom(generics,glance) importFrom(generics,tidy) +importFrom(stats,nobs) importFrom(stats,vcov) diff --git a/NEWS.md b/NEWS.md index ca556df..889169b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # ddml 0.3.1 +* Adds `ddml_apo()` for average potential outcome estimation. * Adds `fitted` and `splits` parameters to all `ddml_*()` estimators for re-estimation with different ensemble types without re-fitting base learners. * Adds `diagnostics()` for per-equation MSPE, R-squared, stacking weights, and cross-validated comparison (CVC) tests. * Adds HC0 and HC3 variance estimators alongside default HC1 via `type` argument in `vcov()`, `confint()`, `summary()`, and `tidy()`. diff --git a/R/ddml_apo.R b/R/ddml_apo.R new file mode 100644 index 0000000..404b6c4 --- /dev/null +++ b/R/ddml_apo.R @@ -0,0 +1,284 @@ +#' DDML Estimator for the Average Potential Outcome +#' +#' @description \code{ddml_apo} provides a Double/Debiased Machine Learning +#' estimator for the average potential outcome, allowing for custom +#' weights \eqn{\omega(X)}. +#' +#' @details \code{ddml_apo} provides a Double/Debiased Machine Learning +#' estimator for the target parameter \eqn{\theta_0} in the model given by +#' +#' \eqn{Y = g_0(D, X) + U,} +#' +#' where \eqn{(Y, D, X, U)} is a random vector such that +#' \eqn{E[U\vert D, X] = 0} and +#' \eqn{\Pr(D=d\vert X) \in (0, 1)} with probability 1, +#' and \eqn{g_0} is an unknown nuisance function. +#' +#' In this model, the average potential outcome (APO) for treatment +#' level \eqn{d} is defined as +#' +#' \eqn{\theta_0^{\textrm{APO}} \equiv E[\omega(X) g_0(d, X)]}, +#' +#' where \eqn{\omega(X)} is a known weighting function. If \eqn{\omega(X) = 1}, +#' this parameter corresponds to the standard Average Potential Outcome (APO) +#' at treatment level \eqn{d}. +#' +#' The estimating equation is +#' \eqn{E[m(W; \theta_0, \eta_0)] = 0}, where +#' \eqn{W = (Y, D, X)}, and the Neyman orthogonal score is +#' +#' \eqn{m(W; \theta, \eta) = \left( \frac{\mathbbm{1}\{D=d\} (Y - \ell(X))}{p(X)} + \ell(X) \right) \omega(X) - \theta} +#' +#' with nuisance parameters \eqn{\eta = (\ell, p)} taking +#' true values \eqn{\ell_0(X) = E[Y|D=d, X]} and \eqn{p_0(X) = E[\mathbbm{1}\{D=d\}|X]}. +#' +#' @inheritParams ddml_plm +#' @inheritParams ddml_ate +#' @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 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 ... Deprecated arguments (\code{subsamples_byd}, +#' \code{cv_subsamples_byd}) are still accepted for backward +#' compatibility but should be replaced with the \code{splits} +#' argument. +#' +#' @return \code{ddml_apo} returns a list object of class \code{ddml_apo} +#' and \code{ddml} with the following properties: +#' \describe{ +#' \item{\code{coefficients}}{A matrix of estimated coefficients.} +#' \item{\code{ensemble_weights}}{The ensemble weights.} +#' \item{\code{mspe}}{The in-sample mean squared prediction errors.} +#' \item{\code{r2}}{The out-of-sample R-squared.} +#' \item{\code{psi_a}, \code{psi_b}}{The scale and scores associated with +#' evaluating the Neyman orthogonal score.} +#' \item{\code{scores}}{A list of evaluating the Neyman orthogonal scores.} +#' \item{\code{J}}{A list of evaluating the Jacobian of the Neyman +#' orthogonal scores.} +#' \item{\code{fitted}}{An optional list of fitted nuisance estimators. +#' See \code{\link{ddml_plm}} for more information.} +#' \item{\code{splits}}{The data splitting structure.} +#' \item{\code{learners}}{The original list of learners.} +#' \item{\code{learners_DX}}{The original list of learners for the propensity +#' score.} +#' \item{\code{ensemble_type}}{The ensemble type.} +#' \item{\code{nobs}}{The number of observations.} +#' \item{\code{sample_folds}}{The number of sample folds.} +#' \item{\code{cv_folds}}{The number of cross-validation folds.} +#' \item{\code{shortstack}}{A boolean indicating if shortstacking was used.} +#' \item{\code{cluster_variable}}{The original cluster variable.} +#' \item{\code{call}}{The match.call().} +#' } +#' +#' @references Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). +#' "Model Averaging and Double Machine Learning." +#' \url{https://arxiv.org/abs/2401.01645} +#' @seealso \code{\link{summary.ddml}} +#' \code{\link{ddml_plm}}, \code{\link{ddml_pliv}}, +#' \code{\link{ddml_fpliv}}, \code{\link{ddml_late}}, +#' \code{\link{ddml_ate}} +#' @export +#' +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, + 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 + splits <- normalize_splits(splits = splits, by_label = "d", ...) + validate_fitted_splits_pair(fitted, splits, !shortstack) + indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + D = D_ind, stratify = stratify, + subsamples = splits$subsamples, + subsamples_byD = splits$subsamples_byd, + cv_subsamples = splits$cv_subsamples, + cv_subsamples_byD = splits$cv_subsamples_byd) + check_subsamples(indxs$subsamples, indxs$subsamples_byD, + stratify, D_ind) + + # Prepare paralllelization and estimation start + t0 <- proc.time()[3] + 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 + + # == 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) + + ensb_info <- update_ensemble_info(y_X_res$weights, + D_X_res$oos_fitted) + ensemble_type <- ensb_info$ensemble_type + nensb <- ensb_info$nensb + + # == Score construction =========================================== + + g_X <- extrapolate_CEF( + D = D_ind, + CEF_res_byD = list(list( + fit = list( + ensemble_fitted = y_X_res$oos_fitted, + auxiliary_fitted = y_X_res$auxiliary_fitted), + d = 1)), + aux_indx = indxs$aux_indx[2])[, , 1] + m_X <- D_X_res$oos_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 <- (D_ind_mat * (y_mat - g_X) / m_X_tr + g_X) * weights_mat + psi_a <- matrix(-1, nobs, nensb) + + # == Target parameter ============================================= + + apo <- colMeans(psi_b) + + scores <- lapply(seq_len(nensb), function(j) { + as.matrix(psi_a[, j] * apo[j] + psi_b[, j]) + }) + J_list <- lapply(seq_len(nensb), function(j) { + as.matrix(mean(psi_a[, j])) + }) + + coef_names <- "APO" + coef <- matrix(apo, nrow = 1, ncol = nensb) + rownames(coef) <- coef_names + colnames(coef) <- ensemble_type + + # == Output ======================================================= + + ddml_fit <- list( + 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), + psi_a = psi_a, psi_b = psi_b, + scores = scores, J = J_list, + 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, + d = d, + weights = weights, + learners = learners, + learners_DX = learners_DX, + 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( + subsamples = indxs$subsamples, + subsamples_byd = indxs$subsamples_byD, + cv_subsamples = indxs$cv_subsamples, + cv_subsamples_byd = indxs$cv_subsamples_byD), + call = cl) + + elapsed <- round(proc.time()[3] - t0, 1) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) + }#IF + + class(ddml_fit) <- c("ddml_apo", "ddml") + return(ddml_fit) +}#DDML_APO + +#' @export +summary.ddml_apo <- function(object, ...) { + summary.ddml(object, ...) +} diff --git a/R/ddml_ate.R b/R/ddml_ate.R index 75b09da..7552257 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -9,8 +9,8 @@ #' @description Estimators of 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 +#' @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 #' @@ -21,14 +21,31 @@ #' \eqn{\Pr(D=1\vert X) \in (0, 1)} with probability 1, #' and \eqn{g_0} is an unknown nuisance function. #' -#' In this model, the average treatment effect is defined as +#' In this model, the average treatment effect (ATE) is defined as #' -#' \eqn{\theta_0^{\textrm{ATE}} \equiv E[g_0(1, X) - g_0(0, X)]}. +#' \eqn{\theta_0^{\textrm{ATE}} \equiv E[g_0(1, X) - g_0(0, X)]}, #' -#' and the average treatment effect on the treated is defined as +#' and the average treatment effect on the treated (ATT) is defined as #' #' \eqn{\theta_0^{\textrm{ATT}} \equiv E[g_0(1, X) - g_0(0, X)\vert D = 1]}. #' +#' The estimating equations are +#' \eqn{E[m(W; \theta_0, \eta_0)] = 0}, where +#' \eqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta}, +#' \eqn{W = (Y, D, X)}, and the Neyman orthogonal scores are +#' +#' \eqn{\psi_b^{\textrm{ATE}}(W; \eta) = \frac{D(Y - \ell_1(X))}{m(X)} - \frac{(1-D)(Y-\ell_0(X))}{1-m(X)} + \ell_1(X) - \ell_0(X)} +#' +#' \eqn{\psi_a^{\textrm{ATE}}(W; \eta) = -1} +#' +#' \eqn{\psi_b^{\textrm{ATT}}(W; \eta) = \frac{D(Y - \ell_0(X))}{p} - \frac{m(X)(1-D)(Y-\ell_0(X))}{p(1-m(X))}} +#' +#' \eqn{\psi_a^{\textrm{ATT}}(W; \eta) = -\frac{D}{p}} +#' +#' with nuisance parameters \eqn{\eta = (\ell_0, \ell_1, m, p)} taking +#' true values \eqn{\ell_{d,0}(X) = E[Y|D=d, X]}, \eqn{m_0(X) = E[D|X]}, +#' and \eqn{p_0 = E[D]}. +#' #' @inheritParams ddml_plm #' @param D The binary endogenous variable of interest. #' @param splits An optional list of sample split objects. For @@ -67,20 +84,24 @@ #' \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{coefficients}}{A matrix of estimated coefficients.} +#' \item{\code{ensemble_weights}}{A list of matrices, providing the +#' weight assigned to each base learner 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()].} -#' \item{\code{oos_pred}}{List of matrices, providing the reduced form -#' predicted values.} -#' \item{\code{learners},\code{learners_DX},\code{cluster_variable}, -#' \code{subsamples_byD},\code{cv_subsamples_byD}, +#' base learner computed by the cross-validation step in the +#' ensemble construction.} +#' \item{\code{r2}}{The out-of-sample R-squared.} +#' \item{\code{psi_a}, \code{psi_b}}{Matrices needed for the +#' computation of scores. Used in [ddml::summary.ddml()].} +#' \item{\code{scores}}{A list of evaluated Neyman orthogonal +#' scores.} +#' \item{\code{J}}{A list of evaluated Jacobians.} +#' \item{\code{fitted}}{A list of fitted nuisance estimators. +#' See \code{\link{ddml_plm}} for more information.} +#' \item{\code{splits}}{The data splitting structure.} +#' \item{\code{learners},\code{learners_DX}, +#' \code{cluster_variable}, #' \code{ensemble_type}}{Pass-through of #' selected user-provided arguments. See above.} #' } @@ -141,194 +162,187 @@ ddml_ate <- function(y, D, X, splits = NULL, save_crossval = TRUE, ...) { - # Validate inputs + cl <- match.call() + + # == Preliminaries ================================================ + + 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]")) + validate_inputs(y = y, D = D, X = X, learners = learners, - sample_folds = sample_folds, cv_folds = cv_folds, + sample_folds = sample_folds, + cv_folds = cv_folds, ensemble_type = ensemble_type, trim = trim, require_binary_D = TRUE) validate_custom_weights(custom_ensemble_weights, learners) validate_custom_weights(custom_ensemble_weights_DX, learners_DX) - # Data parameters nobs <- length(y) - is_D0 <- which(D == 0) - # Check whether ddml uses conventional stacking w/ data driven weights - w_cv <- !shortstack & - any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & - (class(learners[[1]]) != "function") + splits <- normalize_splits(splits = splits, by_label = "D", ...) + validate_fitted_splits_pair(fitted, splits, !shortstack) - # Normalize deprecated split arguments into a single splits object - splits <- normalize_splits( - splits = splits, by_label = "D", ...) - validate_fitted_splits_pair(fitted, splits, w_cv) - - # Create crossfitting and cv tuples - indxs <- get_sample_splits(cluster_variable = cluster_variable, - sample_folds = sample_folds, - cv_folds = if (w_cv) cv_folds, - D = D, stratify = stratify, - subsamples = splits$subsamples, - subsamples_byD = splits$subsamples_byD, - cv_subsamples = splits$cv_subsamples, - cv_subsamples_byD = splits$cv_subsamples_byD) + indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + D = D, stratify = stratify, + subsamples = splits$subsamples, + subsamples_byD = splits$subsamples_byD, + cv_subsamples = splits$cv_subsamples, + cv_subsamples_byD = splits$cv_subsamples_byD) check_subsamples(indxs$subsamples, indxs$subsamples_byD, stratify, D) - # Estimation start t0 <- proc.time()[3] mode_str <- if (!is.null(parallel)) { p <- parse_parallel(parallel) paste0("parallel, ", p$num_cores, " cores") } else { "sequential" - } - info_msg("ddml_ate: estimating (", mode_str, ")", - silent = silent) - - # Compute estimates of E[y|D=0,X] - 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 = "E[Y|D=0,X]", - auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X), - parallel = parallel, - fitted = fitted$y_X_D0) + }#IFELSE + if (!is.null(messages$start) && messages$start != "") { + info_msg(sprintf(messages$start, mode_str), + silent = silent) + }#IF - # Compute estimates of E[y|D=1,X] - y_X_D1_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[[2]], - cv_subsamples = indxs$cv_subsamples_byD[[2]], - silent = silent, label = "E[Y|D=1,X]", - auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X), - parallel = parallel, - fitted = fitted$y_X_D1) + # == Reduced-form estimation ====================================== - # Compute estimates of E[D|X] + # 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, + custom_ensemble_weights = + custom_ensemble_weights_DX, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, - silent = silent, label = "E[D|X]", + silent = silent, label = messages$D_X, parallel = parallel, fitted = fitted$D_X) - # Update ensemble type to account for (optional) custom weights - ensb_info <- update_ensemble_info(y_X_D0_res$weights) - ensemble_type <- ensb_info$ensemble_type - nensb <- ensb_info$nensb - multiple_ensembles <- ensb_info$multiple_ensembles + # Splits for apo(d=1): byD indices match D_ind = D + apo_splits_1 <- list( + subsamples = indxs$subsamples, + subsamples_byd = indxs$subsamples_byD, + cv_subsamples = indxs$cv_subsamples, + cv_subsamples_byd = indxs$cv_subsamples_byD) + # Splits for apo(d=0): swap byD indices since D_ind = 1-D + apo_splits_0 <- list( + subsamples = indxs$subsamples, + subsamples_byd = list(indxs$subsamples_byD[[2]], + indxs$subsamples_byD[[1]]), + cv_subsamples = indxs$cv_subsamples, + cv_subsamples_byd = if (!is.null(indxs$cv_subsamples_byD)) + list(indxs$cv_subsamples_byD[[2]], + indxs$cv_subsamples_byD[[1]])) - # 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_indx = indxs$aux_indx) - m_X <- D_X_res$oos_fitted + # Pre-ensembled propensity for ddml_apo delegation. + # For d=0, flip: P(D=0|X) = 1 - P(D=1|X). + fitted_D_X_1 <- list(ensemble_fitted = D_X_res$oos_fitted) + fitted_D_X_0 <- list(ensemble_fitted = 1 - D_X_res$oos_fitted) - # Trim propensity scores, return warnings - m_X_tr <- trim_propensity_scores(m_X, trim, ensemble_type) + # E[g(1,X)] via ddml_apo + 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_1), + messages = list(start = "", finish = "", + y_X = messages$y_D1, D_X = "")) - # Compute the ATE using the constructed variables - if (!multiple_ensembles) { - g0 <- g_X_byD[, , 1] - g1 <- g_X_byD[, , 2] - m <- as.vector(m_X_tr) - psi_b <- matrix( - D * (y - g1) / m - (1 - D) * (y - g0) / (1 - m) + g1 - g0, - nobs, 1) - ate <- mean(psi_b) - psi_a <- matrix(-1, nobs, 1) - } else { - 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) - psi_a <- matrix(-1, nobs, nensb) - }#IFELSE + # 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 = "")) + + ensemble_type <- apo_1$ensemble_type + nensb <- ncol(apo_1$coefficients) + + # == Score construction =========================================== + psi_b <- apo_1$psi_b - apo_0$psi_b + psi_a <- matrix(-1, nobs, nensb) + + # == Target parameter ============================================= + + ate <- as.vector(apo_1$coefficients) - as.vector(apo_0$coefficients) - # Compute scores and Jacobian from psi_a/psi_b scores <- lapply(seq_len(nensb), function(j) { as.matrix(psi_a[, j] * ate[j] + psi_b[, j]) }) J_list <- lapply(seq_len(nensb), function(j) { as.matrix(mean(psi_a[, j])) }) + coef_names <- "ATE" coef <- matrix(ate, nrow = 1, ncol = nensb) rownames(coef) <- coef_names colnames(coef) <- ensemble_type - # Ensemble metrics - weights <- list(y_X_D0 = y_X_D0_res$weights, - y_X_D1 = y_X_D1_res$weights, - D_X = D_X_res$weights) - mspe <- list(y_X_D0 = y_X_D0_res$mspe, - y_X_D1 = y_X_D1_res$mspe, - D_X = D_X_res$mspe) - r2 <- list(y_X_D0 = y_X_D0_res$r2, - y_X_D1 = y_X_D1_res$r2, - D_X = D_X_res$r2) - - # Predictions - oos_pred <- list(EY_D0_X = g_X_byD[, , 1], - EY_D1_X = g_X_byD[, , 2], - ED_X = m_X) - - fitted_export <- list( - y_X_D0 = build_fitted_entry(y_X_D0_res, save_crossval, - include_auxiliary = TRUE), - y_X_D1 = build_fitted_entry(y_X_D1_res, save_crossval, - include_auxiliary = TRUE), - D_X = build_fitted_entry(D_X_res, save_crossval) - ) - splits_export <- list( - subsamples = indxs$subsamples, - subsamples_byD = indxs$subsamples_byD, - cv_subsamples = indxs$cv_subsamples, - cv_subsamples_byD = indxs$cv_subsamples_byD - ) + # == Output ======================================================= - # 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 = indxs$subsamples_byD, - cv_subsamples_byD = - indxs$cv_subsamples_byD, - ensemble_type = ensemble_type, - coefficients = coef, - scores = scores, - J = J_list, - coef_names = coef_names, - nobs = nobs, - sample_folds = sample_folds, - cv_folds = if (shortstack) NULL - else cv_folds, - shortstack = shortstack, - fitted = fitted_export, - splits = splits_export, - r2 = r2) + ddml_fit <- list( + 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 = D_X_res$weights), + mspe = list(y_X_D0 = apo_0$mspe$y_X, + y_X_D1 = apo_1$mspe$y_X, + D_X = D_X_res$mspe), + r2 = list(y_X_D0 = apo_0$r2$y_X, + y_X_D1 = apo_1$r2$y_X, + D_X = D_X_res$r2), + psi_a = psi_a, psi_b = psi_b, + scores = scores, J = J_list, + 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, + learners = learners, + learners_DX = learners_DX, + cluster_variable = cluster_variable, + fitted = list( + y_X_D0 = apo_0$fitted$y_X, + y_X_D1 = apo_1$fitted$y_X, + D_X = build_fitted_entry(D_X_res, save_crossval)), + splits = list( + subsamples = indxs$subsamples, + subsamples_byD = indxs$subsamples_byD, + cv_subsamples = indxs$cv_subsamples, + cv_subsamples_byD = indxs$cv_subsamples_byD), + call = cl) - # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) - info_msg("ddml_ate: completed in ", elapsed, "s", - silent = silent) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) + }#IF - # Amend class and return class(ddml_fit) <- c("ddml_ate", "ddml") return(ddml_fit) }#DDML_ATE diff --git a/R/ddml_att.R b/R/ddml_att.R index 0ed3571..83e2c10 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -19,188 +19,178 @@ ddml_att <- function(y, D, X, splits = NULL, save_crossval = TRUE, ...) { - # Validate inputs + 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]")) + validate_inputs(y = y, D = D, X = X, learners = learners, - sample_folds = sample_folds, cv_folds = cv_folds, + sample_folds = sample_folds, + cv_folds = cv_folds, ensemble_type = ensemble_type, trim = trim, require_binary_D = TRUE) validate_custom_weights(custom_ensemble_weights, learners) - validate_custom_weights(custom_ensemble_weights_DX, learners_DX) + validate_custom_weights(custom_ensemble_weights_DX, + learners_DX) - # Data parameters nobs <- length(y) - is_D0 <- which(D == 0) - - # Check whether ddml uses conventional stacking w/ data driven weights - w_cv <- !shortstack & - any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & - (class(learners[[1]]) != "function") - - # Normalize deprecated split arguments into a single splits object - splits <- normalize_splits( - splits = splits, by_label = "D", ...) - validate_fitted_splits_pair(fitted, splits, w_cv) - - # Create crossfitting and cv tuples - indxs <- get_sample_splits(cluster_variable = cluster_variable, - sample_folds = sample_folds, - cv_folds = if (w_cv) cv_folds, - D = D, stratify = stratify, - subsamples = splits$subsamples, - subsamples_byD = splits$subsamples_byD, - cv_subsamples = splits$cv_subsamples, - cv_subsamples_byD = splits$cv_subsamples_byD) + + splits <- normalize_splits(splits = splits, by_label = "D", ...) + validate_fitted_splits_pair(fitted, splits, !shortstack) + + indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + D = D, stratify = stratify, + subsamples = splits$subsamples, + subsamples_byD = splits$subsamples_byD, + cv_subsamples = splits$cv_subsamples, + cv_subsamples_byD = splits$cv_subsamples_byD) check_subsamples(indxs$subsamples, indxs$subsamples_byD, stratify, D) - # Estimation start t0 <- proc.time()[3] mode_str <- if (!is.null(parallel)) { p <- parse_parallel(parallel) paste0("parallel, ", p$num_cores, " cores") } else { "sequential" - } - info_msg("ddml_att: estimating (", mode_str, ")", - silent = silent) - - # Compute estimates of E[y|D=0,X] - 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 = "E[Y|D=0,X]", - auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X), - parallel = parallel, - fitted = fitted$y_X_D0) - - # Compute estimates of E[D|X] + }#IFELSE + if (!is.null(messages$start) && messages$start != "") { + info_msg(sprintf(messages$start, mode_str), silent = silent) + }#IF + + # == 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, + custom_ensemble_weights = + custom_ensemble_weights_DX, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, - silent = silent, label = "E[D|X]", + silent = silent, label = messages$D_X, parallel = parallel, fitted = fitted$D_X) - # Compute estimates of E[D] -- simple computation of averages here - D_res <- get_CEF(D, matrix(1, nobs, 1), - learners = list(what = ols), - ensemble_type = "average", - shortstack = FALSE, - cv_subsamples = NULL, - subsamples = indxs$subsamples, - silent = TRUE, - label = "E[D]", - parallel = parallel) - - # Update ensemble type to account for (optional) custom weights - ensb_info <- update_ensemble_info(y_X_D0_res$weights) - ensemble_type <- ensb_info$ensemble_type - nensb <- ensb_info$nensb - multiple_ensembles <- ensb_info$multiple_ensembles - - # Construct reduced form variables - 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$oos_fitted + # E[Y|D=0,X] via ddml_apo(d=0) + # Swap byD indices: apo uses D_ind = 1*(D==0), so byD + # levels are reversed relative to the ATT's D. + apo_splits_0 <- list( + subsamples = indxs$subsamples, + subsamples_byd = list(indxs$subsamples_byD[[2]], + indxs$subsamples_byD[[1]]), + cv_subsamples = indxs$cv_subsamples, + cv_subsamples_byd = if (!is.null(indxs$cv_subsamples_byD)) + list(indxs$cv_subsamples_byD[[2]], + indxs$cv_subsamples_byD[[1]])) + + # Pre-ensembled propensity: P(D=0|X) = 1 - E[D|X] + fitted_D_X_0 <- list( + ensemble_fitted = 1 - D_X_res$oos_fitted) + + 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 = "")) + + ensemble_type <- apo_0$ensemble_type + nensb <- ncol(apo_0$coefficients) + + # == Score construction =========================================== + + # Reconstruct full-sample g_X_D0 from the apo fitted object + g_X_D0 <- extrapolate_CEF( + D = D, + CEF_res_byD = list(list( + fit = apo_0$fitted$y_X, d = 0)), + aux_indx = indxs$aux_indx)[, , 1] - # Trim propensity scores, return warnings + m_X <- D_X_res$oos_fitted m_X_tr <- trim_propensity_scores(m_X, trim, ensemble_type) + p <- mean(D) - # Compute the ATT using the constructed variables - if (!multiple_ensembles) { - p <- as.vector(D_res$oos_fitted) - g0 <- as.vector(g_X_D0) - m <- as.vector(m_X_tr) - psi_b <- matrix( - D * (y - g0) / p - m * (1 - D) * (y - g0) / (p * (1 - m)), - nobs, 1) - psi_a <- matrix(-D / p, nobs, 1) - att <- -mean(psi_b) / mean(psi_a) - } else { - 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) - }#IFELSE + D_mat <- matrix(D, nobs, nensb) + y_mat <- matrix(y, nobs, nensb) + + psi_b <- D_mat * (y_mat - g_X_D0) / p - + m_X_tr * (1 - D_mat) * (y_mat - g_X_D0) / + (p * (1 - m_X_tr)) + psi_a <- -D_mat / p + + # == Target parameter ============================================= + + att <- -colMeans(psi_b) / colMeans(psi_a) - # Compute scores and Jacobian from psi_a/psi_b scores <- lapply(seq_len(nensb), function(j) { as.matrix(psi_a[, j] * att[j] + psi_b[, j]) }) J_list <- lapply(seq_len(nensb), function(j) { as.matrix(mean(psi_a[, j])) }) + coef_names <- "ATT" coef <- matrix(att, nrow = 1, ncol = nensb) rownames(coef) <- coef_names colnames(coef) <- ensemble_type - # Ensemble metrics - weights <- list(y_X_D0 = y_X_D0_res$weights, - D_X = D_X_res$weights) - mspe <- list(y_X_D0 = y_X_D0_res$mspe, - D_X = D_X_res$mspe) - r2 <- list(y_X_D0 = y_X_D0_res$r2, - D_X = D_X_res$r2) - - # Predictions - oos_pred <- list(EY_D0_X = g_X_D0, - ED_X = m_X, - ED = D_res$oos_fitted) - - fitted_export <- 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) - ) - splits_export <- list( - subsamples = indxs$subsamples, - subsamples_byD = indxs$subsamples_byD, - cv_subsamples = indxs$cv_subsamples, - cv_subsamples_byD = indxs$cv_subsamples_byD - ) - - # 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_byD = indxs$subsamples_byD, - cv_subsamples_byD = - indxs$cv_subsamples_byD, - ensemble_type = ensemble_type, - coefficients = coef, - scores = scores, - J = J_list, - coef_names = coef_names, - nobs = nobs, - sample_folds = sample_folds, - cv_folds = if (shortstack) NULL - else cv_folds, - shortstack = shortstack, - fitted = fitted_export, - splits = splits_export, - r2 = r2) - - # Print estimation completion + # == Output ======================================================= + + ddml_fit <- list( + coefficients = coef, + ensemble_weights = list( + y_X_D0 = apo_0$ensemble_weights$y_X, + D_X = D_X_res$weights), + mspe = list(y_X_D0 = apo_0$mspe$y_X, + D_X = D_X_res$mspe), + r2 = list(y_X_D0 = apo_0$r2$y_X, + D_X = D_X_res$r2), + psi_a = psi_a, psi_b = psi_b, + scores = scores, J = J_list, + 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, + learners = learners, + learners_DX = learners_DX, + cluster_variable = cluster_variable, + fitted = list( + y_X_D0 = apo_0$fitted$y_X, + D_X = build_fitted_entry(D_X_res, save_crossval)), + splits = list( + subsamples = indxs$subsamples, + subsamples_byD = indxs$subsamples_byD, + cv_subsamples = indxs$cv_subsamples, + cv_subsamples_byD = indxs$cv_subsamples_byD), + call = cl) + elapsed <- round(proc.time()[3] - t0, 1) - info_msg("ddml_att: completed in ", elapsed, "s", - silent = silent) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) + }#IF - # Amend class and return class(ddml_fit) <- c("ddml_att", "ddml") return(ddml_fit) }#DDML_ATT diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index 1e5c34e..047679e 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -9,8 +9,8 @@ #' #' @description Estimator for the flexible 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 +#' @details \code{ddml_fpliv} provides a Double/Debiased Machine Learning +#' estimator for the target parameter \eqn{\theta_0} in the partially #' linear IV model given by #' #' \eqn{Y = \theta_0D + g_0(X) + U,} @@ -19,6 +19,17 @@ #' \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. #' +#' In this model, the target parameter \eqn{\theta_0} is identified by the +#' estimating equation +#' \eqn{E[m(W; \theta_0, \eta_0)] = 0}, where \eqn{W = (Y, D, Z, X)} and +#' \eqn{m(W; \theta, \eta)} is the Neyman orthogonal score +#' +#' \eqn{m(W; \theta, \eta) = (Y - \ell(X) - \theta(D - r(X)))(v(X, Z) - r(X)),} +#' +#' with nuisance parameters \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]}. +#' #' @inheritParams ddml_pliv #' @param Z A (sparse) matrix of instruments. #' @param learners_DXZ,learners_DX Optional arguments to allow for different @@ -31,11 +42,8 @@ #' \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. #' @param fitted An optional named list of per-equation cross-fitted -#' predictions, typically obtained via \code{fit$fitted}. Not -#' supported when \code{enforce_LIE = TRUE}. See +#' predictions, typically obtained via \code{fit$fitted}. See #' \code{\link{ddml_plm}} for details. #' @param save_crossval Logical; store inner cross-validation #' residuals for exact weight recomputation on pass-through. @@ -45,8 +53,9 @@ #' \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 +#' \item{\code{coef}}{A vector with the \eqn{\theta_0} estimates and +#' the second-stage intercept (last element).} +#' \item{\code{ensemble_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 @@ -95,7 +104,6 @@ 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, @@ -106,69 +114,69 @@ ddml_fpliv <- function(y, D, Z, X, splits = NULL, save_crossval = TRUE, ...) { - # Validate inputs - validate_inputs(y = y, D = D, X = X, Z = Z, learners = learners, - sample_folds = sample_folds, cv_folds = cv_folds, + cl <- match.call() + + # == 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) 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) - - if (!is.null(fitted) && enforce_LIE) { - stop(paste("Pass-through via the 'fitted' argument is not", - "currently supported when enforce_LIE = TRUE.")) - }#IF + validate_custom_weights(custom_ensemble_weights_DXZ, + learners_DXZ) + validate_custom_weights(custom_ensemble_weights_DX, + learners_DX) - # Data parameters nobs <- length(y) - nensb_raw <- length(ensemble_type) # number of ensembles w/o custom weights - - # Check for multivariate endogenous variables D <- as.matrix(D) nD <- ncol(D) - # Check whether ddml uses conventional stacking w/ data driven weights - w_cv <- !shortstack & - any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & - (class(learners[[1]]) != "function") - - # Normalize deprecated split arguments into a single splits object splits <- normalize_splits(splits = splits, ...) - validate_fitted_splits_pair(fitted, splits, w_cv) + validate_fitted_splits_pair(fitted, splits, !shortstack) - # Create crossfitting and cv tuples - indxs <- get_sample_splits(cluster_variable = cluster_variable, - sample_folds = sample_folds, - cv_folds = if (w_cv) cv_folds, - subsamples = splits$subsamples, - cv_subsamples = splits$cv_subsamples) + indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples) check_subsamples(indxs$subsamples, NULL, stratify = FALSE) - # Estimation start t0 <- proc.time()[3] mode_str <- if (!is.null(parallel)) { p <- parse_parallel(parallel) paste0("parallel, ", p$num_cores, " cores") } else { "sequential" - } - info_msg("ddml_fpliv: estimating (", mode_str, ")", - silent = silent) + }#IFELSE + if (!is.null(messages$start) && messages$start != "") { + info_msg(sprintf(messages$start, mode_str), + silent = silent) + }#IF + + # == Reduced-form estimation ====================================== - # Compute estimates of E[y|X] + # E[Y|X] y_X_res <- get_CEF(y, X, Z = NULL, - learners = learners, ensemble_type = ensemble_type, + learners = learners, + ensemble_type = ensemble_type, shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights, + custom_ensemble_weights = + custom_ensemble_weights, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, compute_insample_predictions = FALSE, - silent = silent, label = "E[Y|X]", + silent = silent, label = messages$y_X, parallel = parallel, fitted = fitted$y_X) - # Compute estimates of E[D|X,Z]. Also calculate in-sample predictions when - # the LIE is enforced. + # E[D|X,Z] D_XZ_res_list <- compute_CEF_list( D, X, Z = Z, learners = learners_DXZ, ensemble_type = ensemble_type, @@ -176,238 +184,127 @@ ddml_fpliv <- function(y, D, Z, X, custom_ensemble_weights = custom_ensemble_weights_DXZ, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, - compute_insample_predictions = enforce_LIE, + compute_insample_predictions = FALSE, silent = silent, label_prefix = "E[D", label_suffix = "|X,Z]", parallel = parallel, fitted = fitted$D_XZ) - # When the LIE is not enforced, estimating E[D|X] is straightforward. - if (!enforce_LIE) { - D_X_res_list <- compute_CEF_list( - D, X, Z = NULL, learners = learners_DX, - ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights_DX, - subsamples = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples, - compute_insample_predictions = FALSE, - silent = silent, - label_prefix = "E[D", label_suffix = "|X]", - parallel = parallel) - }#IF + # E[D|X] + D_X_res_list <- compute_CEF_list( + D, X, Z = NULL, learners = learners_DX, + ensemble_type = ensemble_type, + shortstack = shortstack, + custom_ensemble_weights = custom_ensemble_weights_DX, + subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples, + compute_insample_predictions = FALSE, + silent = silent, + label_prefix = "E[D", label_suffix = "|X]", + parallel = parallel, + fitted = fitted$D_X) - # Update ensemble type to account for (optional) custom weights ensb_info <- update_ensemble_info(y_X_res$weights) ensemble_type <- ensb_info$ensemble_type nensb <- ensb_info$nensb - multiple_ensembles <- ensb_info$multiple_ensembles - - # 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 seq_len(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 = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples, - compute_insample_predictions = FALSE, - silent = silent, - label = paste0("E[D", k, "|X]"), - shortstack_y = D_XZ_res_list[[k]]$oos_fitted, - parallel = parallel) - }#FOR - }#IFELSE - - # 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) - - # Compute IV estimate with constructed variables - iv_fit <- AER::ivreg(y_r ~ D_r | V_r) - - # Organize complementary ensemble output - coef_vec <- stats::coef(iv_fit)[-1] - coef <- matrix(coef_vec, nrow = nD, ncol = 1) - colnames(coef) <- ensemble_type - - # Compute scores and Jacobian - D_r_mat <- as.matrix(D_r) - V_r_mat <- as.matrix(V_r) - D_hat <- stats::lm.fit(V_r_mat, D_r_mat)$fitted.values - e <- as.vector(y_r - D_r_mat %*% coef) - scores <- list(D_hat * e) - J_list <- list(-crossprod(D_hat, D_r_mat) / nobs) - coef_names <- names(coef_vec) - }#IF - # 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) - scores <- vector("list", nensb) - J_list <- vector("list", 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 + # == Score construction =========================================== - # 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 + coef <- matrix(0, nD + 1, nensb) + iv_fit <- rep(list(1), nensb) + scores <- vector("list", nensb) + J_list <- vector("list", nensb) + psi_a <- vector("list", nensb) + psi_b <- vector("list", nensb) - # Compute coefficients for each ensemble - for (j in seq_len(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 seq_len(nD)) { - label_jk <- paste0("E[D", k, "|X] (", - ensemble_type[j], ")") + cn_weights <- dimnames(y_X_res$weights)[[2]] + colnames(coef) <- names(iv_fit) <- + if (is.null(cn_weights)) ensemble_type else cn_weights - # 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 = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples, - compute_insample_predictions = FALSE, - silent = silent, - label = label_jk, - shortstack_y = D_XZ_res_list[[k]]$oos_fitted[, j], - parallel = parallel) - } 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 = FALSE], - subsamples = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples, - compute_insample_predictions = FALSE, - silent = silent, - label = label_jk, - shortstack_y = D_XZ_res_list[[k]]$oos_fitted[, j], - parallel = parallel) - # 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 = FALSE] - }#IFELSE - }#FOR - }#IF + for (j in seq_len(nensb)) { + 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) + y_r <- y - cbind(y_X_res$oos_fitted)[, j] - # 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 + iv_fit_j <- AER::ivreg(y_r ~ D_r | V_r, x = TRUE) - # Residualize y - y_r <- y - y_X_res$oos_fitted[, j] + coef_iv_j <- stats::coef(iv_fit_j) + coef[, j] <- c(coef_iv_j[-1], coef_iv_j[1]) + iv_fit[[j]] <- iv_fit_j - # Compute IV estimate with constructed variables - iv_fit_j <- AER::ivreg(y_r ~ D_r | V_r) + D_r_mat <- as.matrix(D_r) + D_hat <- as.matrix( + iv_fit_j$x$projected[, -1, drop = FALSE]) + X_hat <- cbind(D_hat, 1) + X_full <- cbind(D_r_mat, 1) + e_j <- as.vector(stats::residuals(iv_fit_j)) + scores[[j]] <- X_hat * e_j + J_list[[j]] <- -crossprod(X_hat, X_full) / nobs - # Organize complementary ensemble output - coef[, j] <- stats::coef(iv_fit_j)[-1] - iv_fit[[j]] <- iv_fit_j + psi_b[[j]] <- X_hat * as.vector(y_r) + psi_a[[j]] <- -sapply(seq_len(nD + 1), + function(k) X_hat * X_full[, k], + simplify = "array") + }#FOR - # Compute scores and Jacobian - D_r_mat <- as.matrix(D_r) - V_r_mat <- as.matrix(V_r) - D_hat <- stats::lm.fit(V_r_mat, D_r_mat)$fitted.values - e_j <- as.vector(y_r - D_r_mat %*% coef[, j]) - scores[[j]] <- D_hat * e_j - J_list[[j]] <- -crossprod(D_hat, D_r_mat) / nobs + # == Target parameter ============================================= - if (enforce_LIE) { - for (k in seq_len(nD)) weights_DX[[k]][, j, ] <- D_X_res_list[[k]]$weights - }#IF - }#FOR - rownames(coef) <- names(iv_fit[[1]]$coefficients)[-1] - coef_names <- rownames(coef) - }#IF + cn_j <- names(iv_fit[[1]]$coefficients) + rownames(coef) <- c(cn_j[-1], cn_j[1]) + coef_names <- rownames(coef) - # Ensemble metrics - 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) r2 <- list(y_X = y_X_res$r2) for (k in seq_len(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 + ensemble_weights[[paste0("D", k, "_X")]] <- + D_X_res_list[[k]]$weights }#FOR for (k in seq_len(nD)) { eq <- paste0("D", k, "_XZ") - weights[[eq]] <- D_XZ_res_list[[k]]$weights + 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 - fitted_export <- list( - y_X = build_fitted_entry(y_X_res, save_crossval), - D_XZ = build_fitted_from_list(D_XZ_res_list, save_crossval) - ) - splits_export <- list(subsamples = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples) + # == Output ======================================================= - # 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 = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples, - ensemble_type = ensemble_type, - enforce_LIE = enforce_LIE, - coefficients = coef, - scores = scores, - J = J_list, - coef_names = coef_names, - nobs = nobs, - sample_folds = sample_folds, - cv_folds = if (shortstack) NULL - else cv_folds, - shortstack = shortstack, - fitted = fitted_export, - splits = splits_export, - r2 = r2) + ddml_fit <- list( + coefficients = coef, + iv_fit = iv_fit, + ensemble_weights = ensemble_weights, + mspe = mspe, + r2 = r2, + psi_a = psi_a, psi_b = psi_b, + scores = scores, J = J_list, + 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, + learners = learners, + learners_DXZ = learners_DXZ, + learners_DX = learners_DX, + cluster_variable = cluster_variable, + fitted = list( + y_X = build_fitted_entry(y_X_res, save_crossval), + D_XZ = build_fitted_from_list(D_XZ_res_list, + save_crossval), + D_X = build_fitted_from_list(D_X_res_list, + save_crossval)), + splits = list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples), + call = cl) - # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) - info_msg("ddml_fpliv: completed in ", elapsed, "s", - silent = silent) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) + }#IF - # Amend class and return class(ddml_fit) <- c("ddml_fpliv", "ddml") return(ddml_fit) }#DDML_FPLIV diff --git a/R/ddml_late.R b/R/ddml_late.R index 7bceaac..0d629ae 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -8,7 +8,7 @@ #' #' @description Estimator of the local average treatment effect. #' -#' @details \code{ddml_late} provides a double/debiased machine learning +#' @details \code{ddml_late} provides a Double/Debiased Machine Learning #' estimator for the local average treatment effect in the interactive model #' given by #' @@ -22,10 +22,23 @@ #' \eqn{p_0(Z, X) \equiv \Pr(D=1\vert Z, X)}, and #' \eqn{g_0} is an unknown nuisance function. #' -#' In this model, the local average treatment effect is defined as +#' In this model, the local average treatment effect (LATE) is defined as #' #' \eqn{\theta_0^{\textrm{LATE}} \equiv -#' E[g_0(1, X) - g_0(0, X)\vert p_0(1, X) > p(0, X)]}. +#' E[g_0(1, X) - g_0(0, X)\vert p_0(1, X) > p_0(0, X)]}. +#' +#' The estimating equation is +#' \eqn{E[m(W; \theta_0, \eta_0)] = 0}, where +#' \eqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta}, +#' \eqn{W = (Y, D, Z, X)}, and the Neyman orthogonal scores are +#' +#' \eqn{\psi_b(W; \eta) = \frac{Z(Y - \ell_1(X))}{m(X)} - \frac{(1-Z)(Y-\ell_0(X))}{1-m(X)} + \ell_1(X) - \ell_0(X)} +#' +#' \eqn{\psi_a(W; \eta) = -\left(\frac{Z(D - r_1(X))}{m(X)} - \frac{(1-Z)(D-r_0(X))}{1-m(X)} + r_1(X) - r_0(X)\right)} +#' +#' with nuisance parameters \eqn{\eta = (\ell_0, \ell_1, r_0, r_1, m)} 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{m_0(X) = E[Z|X]}. #' #' @inheritParams ddml_ate #' @param Z Binary instrumental variable. @@ -80,22 +93,26 @@ #' \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()].} -#' \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_byZ}, -#' \code{cv_subsamples_byZ},\code{ensemble_type}}{Pass-through -#' of selected user-provided arguments. See above.} +#' \item{\code{coefficients}}{A matrix of estimated coefficients.} +#' \item{\code{ensemble_weights}}{A list of matrices, providing the +#' weight assigned to each base learner by the ensemble +#' procedure.} +#' \item{\code{mspe}}{A list of matrices, providing the MSPE of +#' each base learner computed by the cross-validation step +#' in the ensemble construction.} +#' \item{\code{r2}}{The out-of-sample R-squared.} +#' \item{\code{psi_a}, \code{psi_b}}{Matrices needed for the +#' computation of scores. Used in [ddml::summary.ddml()].} +#' \item{\code{scores}}{A list of evaluated Neyman orthogonal +#' scores.} +#' \item{\code{J}}{A list of evaluated Jacobians.} +#' \item{\code{fitted}}{A list of fitted nuisance estimators. +#' See \code{\link{ddml_plm}} for more information.} +#' \item{\code{splits}}{The data splitting structure.} +#' \item{\code{learners},\code{learners_DXZ}, +#' \code{learners_ZX},\code{cluster_variable}, +#' \code{ensemble_type}}{Pass-through of selected +#' user-provided arguments. See above.} #' } #' @export #' @@ -166,266 +183,204 @@ ddml_late <- function(y, D, Z, X, splits = NULL, save_crossval = TRUE, ...) { - # Validate inputs - validate_inputs(y = y, D = D, X = X, Z = Z, learners = learners, - sample_folds = sample_folds, cv_folds = cv_folds, + cl <- match.call() + + # == Preliminaries ================================================ + + 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]")) + + 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, 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) + validate_custom_weights(custom_ensemble_weights_DXZ, + learners_DXZ) + validate_custom_weights(custom_ensemble_weights_ZX, + learners_ZX) - # Data parameters nobs <- length(y) - is_Z0 <- which(Z == 0) - # Check whether ddml uses conventional stacking w/ data driven weights - w_cv <- !shortstack & - any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & - (class(learners[[1]]) != "function") - - # Normalize deprecated split arguments into a single splits object splits <- normalize_splits( splits = splits, by_label = "Z", ...) - validate_fitted_splits_pair(fitted, splits, w_cv) + validate_fitted_splits_pair(fitted, splits, !shortstack) - # Create crossfitting and cv tuples - indxs <- get_sample_splits(cluster_variable = cluster_variable, - sample_folds = sample_folds, - cv_folds = if (w_cv) cv_folds, - D = Z, stratify = stratify, - subsamples = splits$subsamples, - subsamples_byD = splits$subsamples_byZ, - cv_subsamples = splits$cv_subsamples, - cv_subsamples_byD = splits$cv_subsamples_byZ) + indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + D = Z, stratify = stratify, + subsamples = splits$subsamples, + subsamples_byD = splits$subsamples_byZ, + cv_subsamples = splits$cv_subsamples, + cv_subsamples_byD = splits$cv_subsamples_byZ) check_subsamples(indxs$subsamples, indxs$subsamples_byD, stratify, Z) - # Estimation start t0 <- proc.time()[3] mode_str <- if (!is.null(parallel)) { p <- parse_parallel(parallel) paste0("parallel, ", p$num_cores, " cores") } else { "sequential" - } - info_msg("ddml_late: estimating (", mode_str, ")", - silent = silent) - - # Compute estimates of E[y|Z=0,X] - y_X_Z0_res <- get_CEF(y[is_Z0], X[is_Z0, , 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 = "E[Y|Z=0,X]", - auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X), - parallel = parallel, - fitted = fitted$y_X_Z0) - - # Compute estimates of E[y|Z=1,X] - y_X_Z1_res <- get_CEF(y[-is_Z0], X[-is_Z0, , 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 = "E[Y|Z=1,X]", - auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X), - parallel = parallel, - fitted = fitted$y_X_Z1) - - # Check for perfect non-compliance - if (all(D[Z==0] == 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}) - info_msg(" E[D|Z=0,X] .......... skipped ", - "(perfect non-compliance)", silent = silent) - } else { - # Compute estimates of E[D|Z=0,X] - D_X_Z0_res <- get_CEF(D[is_Z0], X[is_Z0, , drop = FALSE], - learners = learners_DXZ, - ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights_DXZ, - subsamples = indxs$subsamples_byD[[1]], - cv_subsamples = indxs$cv_subsamples_byD[[1]], - silent = silent, label = "E[D|Z=0,X]", - auxiliary_X = get_auxiliary_X(indxs$aux_indx[[1]], X), - parallel = parallel, - fitted = fitted$D_X_Z0) }#IFELSE + if (!is.null(messages$start) && messages$start != "") { + info_msg(sprintf(messages$start, mode_str), + silent = silent) + }#IF - # Check for perfect compliance - if (all(D[Z==1] == 1)) { - 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}) - info_msg(" E[D|Z=1,X] .......... skipped ", - "(perfect compliance)", silent = silent) - } else { - # Compute estimates of E[D|Z=1,X] - D_X_Z1_res <- get_CEF(D[-is_Z0], X[-is_Z0, , drop = FALSE], - learners = learners_DXZ, - ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights_DXZ, - subsamples = indxs$subsamples_byD[[2]], - cv_subsamples = indxs$cv_subsamples_byD[[2]], - silent = silent, label = "E[D|Z=1,X]", - auxiliary_X = get_auxiliary_X(indxs$aux_indx[[2]], X), - parallel = parallel, - fitted = fitted$D_X_Z1) - }#IFELSE + # == Reduced-form estimation ====================================== - # Compute estimates of E[Z|X] + # E[Z|X] Z_X_res <- get_CEF(Z, X, - learners = learners_ZX, ensemble_type = ensemble_type, + learners = learners_ZX, + ensemble_type = ensemble_type, shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights_ZX, + custom_ensemble_weights = + custom_ensemble_weights_ZX, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, compute_insample_predictions = FALSE, - silent = silent, label = "E[Z|X]", + silent = silent, label = messages$Z_X, parallel = parallel, fitted = fitted$Z_X) - # Update ensemble type to account for (optional) custom weights - ensb_info <- update_ensemble_info(y_X_Z0_res$weights) - ensemble_type <- ensb_info$ensemble_type - nensb <- ensb_info$nensb - multiple_ensembles <- ensb_info$multiple_ensembles + splits_Z <- list( + subsamples = indxs$subsamples, + subsamples_byD = indxs$subsamples_byD, + cv_subsamples = indxs$cv_subsamples, + cv_subsamples_byD = indxs$cv_subsamples_byD) - # 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_indx = indxs$aux_indx) - 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_indx = indxs$aux_indx) - r_X <- Z_X_res$oos_fitted + fitted_Z_X <- build_fitted_entry(Z_X_res, save_crossval) - # Trim propensity scores, return warnings - r_X_tr <- trim_propensity_scores(r_X, trim, ensemble_type) + # Second stage: 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, + trim = trim, parallel = parallel, silent = silent, + splits = splits_Z, + fitted = list(y_X_D0 = fitted$y_X_Z0, + y_X_D1 = fitted$y_X_Z1, + D_X = fitted_Z_X), + save_crossval = save_crossval, + messages = list(start = "", finish = "", + y_D1 = messages$y_Z1, + y_D0 = messages$y_Z0, D_X = "")) - # Compute the LATE using the constructed variables - if (!multiple_ensembles) { - l0 <- l_X_byZ[, , 1] - l1 <- l_X_byZ[, , 2] - p0 <- p_X_byZ[, , 1] - p1 <- p_X_byZ[, , 2] - r <- as.vector(r_X_tr) - psi_b <- matrix( - Z * (y - l1) / r - (1 - Z) * (y - l0) / (1 - r) + l1 - l0, - nobs, 1) - psi_a <- matrix( - -(Z * (D - p1) / r - (1 - Z) * (D - p0) / (1 - r) + p1 - p0), - nobs, 1) - late <- -mean(psi_b) / mean(psi_a) - } else { - 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]) - late <- -colMeans(psi_b) / colMeans(psi_a) - }#IFELSE + # First stage: D ~ Z via ddml_ate + 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, + trim = trim, parallel = parallel, silent = silent, + splits = splits_Z, + fitted = list(y_X_D0 = fitted$D_X_Z0, + y_X_D1 = fitted$D_X_Z1, + D_X = fitted_Z_X), + save_crossval = save_crossval, + messages = list(start = "", finish = "", + y_D1 = messages$D_Z1, + y_D0 = messages$D_Z0, D_X = "")) + + ensemble_type <- ate_rf$ensemble_type + nensb <- ncol(ate_rf$coefficients) + + # == Score construction =========================================== + + psi_b <- ate_rf$psi_b + psi_a <- -ate_fs$psi_b + + # == Target parameter ============================================= + + late <- as.vector(ate_rf$coefficients) / as.vector(ate_fs$coefficients) - # Compute scores and Jacobian from psi_a/psi_b scores <- lapply(seq_len(nensb), function(j) { as.matrix(psi_a[, j] * late[j] + psi_b[, j]) }) J_list <- lapply(seq_len(nensb), function(j) { as.matrix(mean(psi_a[, j])) }) + coef_names <- "LATE" coef <- matrix(late, nrow = 1, ncol = nensb) rownames(coef) <- coef_names colnames(coef) <- ensemble_type - # Ensemble metrics - 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) - 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) - r2 <- list(y_X_Z0 = y_X_Z0_res$r2, - y_X_Z1 = y_X_Z1_res$r2, - D_X_Z0 = D_X_Z0_res$r2, - D_X_Z1 = D_X_Z1_res$r2, - Z_X = Z_X_res$r2) + # == Output ======================================================= - # Predictions - 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) - - fitted_export <- list( - y_X_Z0 = build_fitted_entry(y_X_Z0_res, save_crossval, - include_auxiliary = TRUE), - y_X_Z1 = build_fitted_entry(y_X_Z1_res, save_crossval, - include_auxiliary = TRUE), - D_X_Z0 = build_fitted_entry(D_X_Z0_res, save_crossval, - include_auxiliary = TRUE), - D_X_Z1 = build_fitted_entry(D_X_Z1_res, save_crossval, - include_auxiliary = TRUE), - Z_X = build_fitted_entry(Z_X_res, save_crossval) - ) - splits_export <- list( - subsamples = indxs$subsamples, - subsamples_byZ = indxs$subsamples_byD, - cv_subsamples = indxs$cv_subsamples, - cv_subsamples_byZ = indxs$cv_subsamples_byD - ) + splits_export <- ate_rf$splits + names(splits_export)[names(splits_export) == + "subsamples_byD"] <- "subsamples_byZ" + if ("cv_subsamples_byD" %in% names(splits_export)) { + names(splits_export)[names(splits_export) == + "cv_subsamples_byD"] <- "cv_subsamples_byZ" + }#IF - # 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 = indxs$subsamples_byD, - cv_subsamples_byZ = - indxs$cv_subsamples_byD, - ensemble_type = ensemble_type, - coefficients = coef, - scores = scores, - J = J_list, - coef_names = coef_names, - nobs = nobs, - sample_folds = sample_folds, - cv_folds = if (shortstack) NULL - else cv_folds, - shortstack = shortstack, - fitted = fitted_export, - splits = splits_export, - r2 = r2) + ddml_fit <- list( + 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), + psi_a = psi_a, psi_b = psi_b, + scores = scores, J = J_list, + 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, + learners = learners, + learners_DXZ = learners_DXZ, + learners_ZX = learners_ZX, + 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 = splits_export, + call = cl) - # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) - info_msg("ddml_late: completed in ", elapsed, "s", - silent = silent) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) + }#IF - # Amend class and return class(ddml_fit) <- c("ddml_late", "ddml") return(ddml_fit) }#DDML_LATE diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index d89bb2d..1903288 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -9,8 +9,8 @@ #' #' @description Estimator for 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 +#' @details \code{ddml_pliv} provides a Double/Debiased Machine Learning +#' estimator for the target parameter \eqn{\theta_0} in the partially #' linear IV model given by #' #' \eqn{Y = \theta_0D + g_0(X) + U,} @@ -19,6 +19,17 @@ #' \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. #' +#' In this model, the target parameter \eqn{\theta_0} is identified by the +#' estimating equation +#' \eqn{E[m(W; \theta_0, \eta_0)] = 0}, where \eqn{W = (Y, D, Z, X)} and +#' \eqn{m(W; \theta, \eta)} is the Neyman orthogonal score +#' +#' \eqn{m(W; \theta, \eta) = (Y - \ell(X) - \theta(D - r_D(X)))(Z - r_Z(X)),} +#' +#' with nuisance parameters \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]}. +#' #' @inheritParams ddml_plm #' @param Z A matrix of instruments. #' @param learners May take one of two forms, depending on whether a single @@ -64,8 +75,9 @@ #' \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 +#' \item{\code{coef}}{A vector with the \eqn{\theta_0} estimates and +#' the second-stage intercept (last element).} +#' \item{\code{ensemble_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 @@ -127,65 +139,70 @@ ddml_pliv <- function(y, D, Z, X, splits = NULL, save_crossval = TRUE, ...) { - # Validate inputs - validate_inputs(y = y, D = D, X = X, Z = Z, learners = learners, - sample_folds = sample_folds, cv_folds = cv_folds, + 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) 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) + validate_custom_weights(custom_ensemble_weights_DX, + learners_DX) + validate_custom_weights(custom_ensemble_weights_ZX, + learners_ZX) - # Data parameters nobs <- length(y) - - # Check for multivariate endogenous variables D <- as.matrix(D) nD <- ncol(D) - - # Check for multivariate instruments Z <- as.matrix(Z) nZ <- ncol(Z) - # Check whether ddml uses conventional stacking w/ data driven weights - w_cv <- !shortstack & - any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & - (class(learners[[1]]) != "function") - - # Normalize deprecated split arguments into a single splits object splits <- normalize_splits(splits = splits, ...) - validate_fitted_splits_pair(fitted, splits, w_cv) + validate_fitted_splits_pair(fitted, splits, !shortstack) - # Create crossfitting and cv tuples - indxs <- get_sample_splits(cluster_variable = cluster_variable, - sample_folds = sample_folds, - cv_folds = if (w_cv) cv_folds, - subsamples = splits$subsamples, - cv_subsamples = splits$cv_subsamples) + indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples) check_subsamples(indxs$subsamples, NULL, stratify = FALSE) - # Estimation start t0 <- proc.time()[3] mode_str <- if (!is.null(parallel)) { p <- parse_parallel(parallel) paste0("parallel, ", p$num_cores, " cores") } else { "sequential" - } - info_msg("ddml_pliv: estimating (", mode_str, ")", - silent = silent) + }#IFELSE + if (!is.null(messages$start) && messages$start != "") { + info_msg(sprintf(messages$start, mode_str), + silent = silent) + }#IF - # 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, + custom_ensemble_weights = + custom_ensemble_weights, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, - silent = silent, label = "E[Y|X]", + silent = silent, label = messages$y_X, parallel = parallel, fitted = fitted$y_X) - # Compute estimates of E[Z|X], loop through instruments + # E[Z|X] Z_X_res_list <- compute_CEF_list( Z, X, learners = learners_ZX, ensemble_type = ensemble_type, @@ -198,7 +215,7 @@ ddml_pliv <- function(y, D, Z, X, parallel = parallel, fitted = fitted$Z_X) - # Compute estimates of E[D|X], loop through endogenous variables + # E[D|X] D_X_res_list <- compute_CEF_list( D, X, learners = learners_DX, ensemble_type = ensemble_type, @@ -211,130 +228,107 @@ ddml_pliv <- function(y, D, Z, X, parallel = parallel, fitted = fitted$D_X) - # Update ensemble type to account for (optional) custom weights ensb_info <- update_ensemble_info(y_X_res$weights) ensemble_type <- ensb_info$ensemble_type nensb <- ensb_info$nensb - multiple_ensembles <- ensb_info$multiple_ensembles - # If a single ensemble is calculated, no loops are required. - if (!multiple_ensembles) { + # == Score construction =========================================== - # 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) + iv_fit <- rep(list(1), nensb) + scores <- vector("list", nensb) + J_list <- vector("list", nensb) + psi_a <- vector("list", nensb) + psi_b <- vector("list", nensb) - # Compute IV estimate with constructed variables - iv_fit <- AER::ivreg(y_r ~ D_r | V_r) + for (j in seq_len(nensb)) { + y_r <- y - cbind(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) - # Organize complementary ensemble output - coef_vec <- stats::coef(iv_fit)[-1] - coef <- matrix(coef_vec, nrow = nD, ncol = 1) - colnames(coef) <- ensemble_type + iv_fit_j <- AER::ivreg(y_r ~ D_r | V_r, x = TRUE) - # Compute scores and Jacobian - D_r_mat <- as.matrix(D_r) - V_r_mat <- as.matrix(V_r) - D_hat <- stats::lm.fit(V_r_mat, D_r_mat)$fitted.values - e <- as.vector(y_r - D_r_mat %*% coef) - scores <- list(D_hat * e) - J_list <- list(-crossprod(D_hat, D_r_mat) / nobs) - coef_names <- names(coef_vec) - }#IF + coef_iv_j <- stats::coef(iv_fit_j) + coef[, j] <- c(coef_iv_j[-1], coef_iv_j[1]) + iv_fit[[j]] <- iv_fit_j - # 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) - scores <- vector("list", nensb) - J_list <- vector("list", nensb) - nlearners <- length(learners) - nlearners_DX <- length(learners_DX); nlearners_ZX <- length(learners_ZX) - - # Compute coefficients for each ensemble - for (j in seq_len(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) + D_r_mat <- as.matrix(D_r) + D_hat <- as.matrix( + iv_fit_j$x$projected[, -1, drop = FALSE]) + X_hat <- cbind(D_hat, 1) + X_full <- cbind(D_r_mat, 1) + e_j <- as.vector(stats::residuals(iv_fit_j)) + scores[[j]] <- X_hat * e_j + J_list[[j]] <- -crossprod(X_hat, X_full) / nobs - # Compute IV estimate with constructed variables - iv_fit_j <- AER::ivreg(y_r ~ D_r | V_r) + psi_b[[j]] <- X_hat * as.vector(y_r) + psi_a[[j]] <- -sapply(seq_len(nD + 1), + function(k) X_hat * X_full[, k], + simplify = "array") + }#FOR - # Organize complementary ensemble output - coef[, j] <- stats::coef(iv_fit_j)[-1] - iv_fit[[j]] <- iv_fit_j + # == Target parameter ============================================= - # Compute scores and Jacobian - D_r_mat <- as.matrix(D_r) - V_r_mat <- as.matrix(V_r) - D_hat <- stats::lm.fit(V_r_mat, D_r_mat)$fitted.values - e_j <- as.vector(y_r - D_r_mat %*% coef[, j]) - scores[[j]] <- D_hat * e_j - J_list[[j]] <- -crossprod(D_hat, D_r_mat) / nobs - }#FOR - # Assign names for more legible output - colnames(coef) <- names(iv_fit) <- ensemble_type - rownames(coef) <- names(iv_fit_j$coefficients)[-1] - coef_names <- rownames(coef) - }#IF + cn_weights <- dimnames(y_X_res$weights)[[2]] + colnames(coef) <- names(iv_fit) <- + if (is.null(cn_weights)) ensemble_type else cn_weights + cn_j <- names(iv_fit_j$coefficients) + rownames(coef) <- c(cn_j[-1], cn_j[1]) + coef_names <- rownames(coef) - # Ensemble metrics - 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) r2 <- list(y_X = y_X_res$r2) for (k in seq_len(nD)) { eq <- paste0("D", k, "_X") - weights[[eq]] <- D_X_res_list[[k]]$weights + 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 seq_len(nZ)) { eq <- paste0("Z", k, "_X") - weights[[eq]] <- Z_X_res_list[[k]]$weights + 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 - fitted_export <- list( - y_X = build_fitted_entry(y_X_res, save_crossval), - D_X = build_fitted_from_list(D_X_res_list, save_crossval), - Z_X = build_fitted_from_list(Z_X_res_list, save_crossval) - ) - splits_export <- list(subsamples = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples) + # == Output ======================================================= - # 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 = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples, - ensemble_type = ensemble_type, - coefficients = coef, - scores = scores, - J = J_list, - coef_names = coef_names, - nobs = nobs, - sample_folds = sample_folds, - cv_folds = if (shortstack) NULL - else cv_folds, - shortstack = shortstack, - fitted = fitted_export, - splits = splits_export, - r2 = r2) + ddml_fit <- list( + coefficients = coef, + iv_fit = iv_fit, + ensemble_weights = ensemble_weights, + mspe = mspe, + r2 = r2, + psi_a = psi_a, psi_b = psi_b, + scores = scores, J = J_list, + 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, + learners = learners, + learners_DX = learners_DX, + learners_ZX = learners_ZX, + cluster_variable = cluster_variable, + fitted = list( + y_X = build_fitted_entry(y_X_res, save_crossval), + D_X = build_fitted_from_list(D_X_res_list, + save_crossval), + Z_X = build_fitted_from_list(Z_X_res_list, + save_crossval)), + splits = list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples), + call = cl) - # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) - info_msg("ddml_pliv: completed in ", elapsed, "s", - silent = silent) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) + }#IF - # Amend class and return class(ddml_fit) <- c("ddml_pliv", "ddml") return(ddml_fit) }#DDML_PLIV diff --git a/R/ddml_plm.R b/R/ddml_plm.R index 3d8e189..94d9e36 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -8,8 +8,8 @@ #' #' @description Estimator for the partially linear model. #' -#' @details \code{ddml_plm} provides a double/debiased machine learning -#' estimator for the parameter of interest \eqn{\theta_0} in the partially +#' @details \code{ddml_plm} provides a Double/Debiased Machine Learning +#' estimator for the target parameter \eqn{\theta_0} in the partially #' linear model given by #' #' \eqn{Y = \theta_0D + g_0(X) + U,} @@ -18,6 +18,16 @@ #' \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. #' +#' In this model, the target parameter \eqn{\theta_0} is identified by the +#' estimating equation +#' \eqn{E[m(W; \theta_0, \eta_0)] = 0}, where \eqn{W = (Y, D, X)} and +#' \eqn{m(W; \theta, \eta)} is the Neyman orthogonal score +#' +#' \eqn{m(W; \theta, \eta) = (Y - \ell(X) - \theta(D - r(X)))(D - r(X)),} +#' +#' with nuisance parameters \eqn{\eta = (\ell, r)} taking true values +#' \eqn{\ell_0(X) = E[Y|X]} and \eqn{r_0(X) = E[D|X]}. +#' #' @param y The outcome variable. #' @param D A matrix of endogenous variables. #' @param X A (sparse) matrix of control variables. @@ -112,8 +122,9 @@ #' \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 +#' \item{\code{coef}}{A vector with the \eqn{\theta_0} estimates and +#' the second-stage intercept (last element).} +#' \item{\code{ensemble_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 @@ -202,50 +213,52 @@ ddml_plm <- function(y, D, X, splits = NULL, save_crossval = TRUE, ...) { - # Validate inputs + 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, + sample_folds = sample_folds, + cv_folds = cv_folds, ensemble_type = ensemble_type) validate_custom_weights(custom_ensemble_weights, learners) - validate_custom_weights(custom_ensemble_weights_DX, learners_DX) + validate_custom_weights(custom_ensemble_weights_DX, + learners_DX) - # Data parameters nobs <- length(y) - - # Check for multivariate endogenous variables D <- as.matrix(D) nD <- ncol(D) - # Check whether ddml uses conventional stacking w/ data driven weights - w_cv <- !shortstack & - any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & - (class(learners[[1]]) != "function" | - class(learners_DX[[1]]) != "function") - - # Normalize deprecated split arguments into a single splits object splits <- normalize_splits(splits = splits, ...) - validate_fitted_splits_pair(fitted, splits, w_cv) + validate_fitted_splits_pair(fitted, splits, !shortstack) - # Create crossfitting and cv tuples - indxs <- get_sample_splits(cluster_variable = cluster_variable, - sample_folds = sample_folds, - cv_folds = if (w_cv) cv_folds, - subsamples = splits$subsamples, - cv_subsamples = splits$cv_subsamples) + indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + subsamples = splits$subsamples, + cv_subsamples = splits$cv_subsamples) check_subsamples(indxs$subsamples, NULL, stratify = FALSE) - # Estimation start t0 <- proc.time()[3] mode_str <- if (!is.null(parallel)) { p <- parse_parallel(parallel) paste0("parallel, ", p$num_cores, " cores") } else { "sequential" - } - info_msg("ddml_plm: estimating (", mode_str, ")", - silent = silent) + }#IFELSE + if (!is.null(messages$start) && messages$start != "") { + info_msg(sprintf(messages$start, mode_str), + silent = silent) + }#IF - # 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, @@ -270,119 +283,94 @@ ddml_plm <- function(y, D, X, parallel = parallel, fitted = fitted$D_X) - # Update ensemble type to account for (optional) custom weights ensb_info <- update_ensemble_info(y_X_res$weights) ensemble_type <- ensb_info$ensemble_type nensb <- ensb_info$nensb - multiple_ensembles <- ensb_info$multiple_ensembles - # If a single ensemble is calculated, no loops are required. - if (!multiple_ensembles) { + # == Score construction =========================================== - # Residualize - y_r <- y - y_X_res$oos_fitted - D_r <- D - get_oosfitted(D_X_res_list) + coef <- matrix(0, nD + 1, nensb) + ols_fit <- rep(list(1), nensb) + scores <- vector("list", nensb) + J_list <- vector("list", nensb) + psi_a <- vector("list", nensb) + psi_b <- vector("list", nensb) + for (j in seq_len(nensb)) { + D_r <- D - get_oosfitted(D_X_res_list, j) + y_r <- y - cbind(y_X_res$oos_fitted)[, j] - # Compute OLS estimate with constructed variables - ols_fit <- stats::lm(y_r ~ D_r) + ols_fit_j <- stats::lm(y_r ~ D_r) - # Organize complementary ensemble output - coef_vec <- stats::coef(ols_fit)[-1] - coef <- matrix(coef_vec, nrow = nD, ncol = 1) - colnames(coef) <- ensemble_type + coef_ols_j <- stats::coef(ols_fit_j) + coef[, j] <- c(coef_ols_j[-1], coef_ols_j[1]) + ols_fit[[j]] <- ols_fit_j - # Compute scores and Jacobian D_r_mat <- as.matrix(D_r) - e <- as.vector(y_r - D_r_mat %*% coef) - scores <- list(D_r_mat * e) - J_list <- list(-crossprod(D_r_mat) / nobs) - coef_names <- names(coef_vec) - }#IF + X_full <- cbind(D_r_mat, 1) + e_j <- as.vector(stats::residuals(ols_fit_j)) + scores[[j]] <- X_full * e_j + J_list[[j]] <- -crossprod(X_full) / nobs - # 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) - scores <- vector("list", nensb) - J_list <- vector("list", nensb) - nlearners <- length(learners); nlearners_DX <- length(learners_DX) - - # Compute coefficients for each ensemble - for (j in seq_len(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) - - # Organize complementary ensemble output - coef[, j] <- stats::coef(ols_fit_j)[-1] - ols_fit[[j]] <- ols_fit_j + psi_b[[j]] <- X_full * as.vector(y_r) + psi_a[[j]] <- -sapply(seq_len(nD + 1), + function(k) X_full * X_full[, k], + simplify = "array") + }#FOR - # Compute scores and Jacobian - D_r_mat <- as.matrix(D_r) - e_j <- as.vector(y_r - D_r_mat %*% coef[, j]) - scores[[j]] <- D_r_mat * e_j - J_list[[j]] <- -crossprod(D_r_mat) / nobs - }#FOR + # == Target parameter ============================================= - # 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] - coef_names <- rownames(coef) - }#IF + cn_weights <- dimnames(y_X_res$weights)[[2]] + colnames(coef) <- names(ols_fit) <- + if (is.null(cn_weights)) ensemble_type else cn_weights + cn_j <- names(ols_fit_j$coefficients) + rownames(coef) <- c(cn_j[-1], cn_j[1]) + coef_names <- rownames(coef) # Ensemble metrics - 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) r2 <- list(y_X = y_X_res$r2) for (k in seq_len(nD)) { eq <- paste0("D", k, "_X") - weights[[eq]] <- D_X_res_list[[k]]$weights + 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 - fitted_export <- list( - y_X = build_fitted_entry(y_X_res, save_crossval), - D_X = build_fitted_from_list(D_X_res_list, save_crossval) - ) - splits_export <- list(subsamples = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples) + # == Output ======================================================= - # 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 = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples, - ensemble_type = ensemble_type, - coefficients = coef, - scores = scores, - J = J_list, - coef_names = coef_names, - nobs = nobs, - sample_folds = sample_folds, - cv_folds = if (shortstack) NULL - else cv_folds, - shortstack = shortstack, - fitted = fitted_export, - splits = splits_export, - r2 = r2) + ddml_fit <- list( + coefficients = coef, + ols_fit = ols_fit, + ensemble_weights = ensemble_weights, + mspe = mspe, + r2 = r2, + psi_a = psi_a, psi_b = psi_b, + scores = scores, J = J_list, + 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, + learners = learners, + learners_DX = learners_DX, + cluster_variable = cluster_variable, + fitted = list( + y_X = build_fitted_entry(y_X_res, save_crossval), + D_X = build_fitted_from_list(D_X_res_list, + save_crossval)), + splits = list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples), + call = cl) - # Print estimation completion elapsed <- round(proc.time()[3] - t0, 1) - info_msg("ddml_plm: completed in ", elapsed, "s", - silent = silent) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) + }#IF - # Amend class and return class(ddml_fit) <- c("ddml_plm", "ddml") return(ddml_fit) }#DDML_PLM - diff --git a/R/ddml_rep.R b/R/ddml_rep.R index 73fcb6b..f715fd0 100644 --- a/R/ddml_rep.R +++ b/R/ddml_rep.R @@ -39,9 +39,13 @@ aggregate_reps <- function(object, aggregation = "median", fit <- object$fits[[r]] coef_array[, , r] <- fit$coefficients for (j in seq_len(nensb)) { + h <- if (type == "HC3") { + compute_leverage(fit, j) + }#IF vcov_array[, , j, r] <- compute_ddml_variance( fit$scores[[j]], fit$J[[j]], - fit$cluster_variable, type = type) + fit$cluster_variable, type = type, + leverage = h) }#FOR }#FOR @@ -177,6 +181,7 @@ ddml_rep <- function(fits) { nresamples = length(fits), model_type = primary[1], coef_names = ref$coef_names, + estimator_name= if (!is.null(ref$estimator_name)) ref$estimator_name else primary[1], ensemble_type = ens_type, nobs = ref$nobs, sample_folds = ref$sample_folds, @@ -223,6 +228,13 @@ ddml_replicate <- function(fn, ..., resamples = 5, silent = FALSE) { dots <- list(...) dots$silent <- silent + # Suppress inner start/finish messages to avoid console spam + if (is.null(dots$messages)) { + dots$messages <- list(start = "", finish = "") + } else { + dots$messages$start <- "" + dots$messages$finish <- "" + } fits <- vector("list", resamples) for (r in seq_len(resamples)) { if (!silent) { @@ -308,19 +320,7 @@ length.ddml_rep <- function(x) { #' @export #' @method print ddml_rep print.ddml_rep <- function(x, ...) { - type_labels <- c( - ddml_plm = "Partially Linear Model", - ddml_pliv = "Partially Linear IV Model", - ddml_fpliv = - "Flexible Partially Linear IV Model", - ddml_ate = "Average Treatment Effect", - ddml_att = - "Average Treatment Effect on the Treated", - ddml_late = "Local Average Treatment Effect") - model_name <- type_labels[x$model_type] - if (is.na(model_name)) model_name <- x$model_type - - cat("DDML replicated fits:", model_name, "\n") + cat("DDML replicated fits:", x$estimator_name, "\n") cat(" Resamples:", x$nresamples, " Obs:", x$nobs, " Folds:", x$sample_folds, "\n\n") @@ -506,9 +506,10 @@ summary.ddml_rep <- function(object, inf_results <- build_inf_from_agg( agg, object$coef_names, object$ensemble_type) result <- list( - inf_results = inf_results, + coefficients = inf_results, type = type, model_type = object$model_type, + estimator_name= object$estimator_name, nobs = object$nobs, sample_folds = object$sample_folds, shortstack = object$shortstack, @@ -531,19 +532,7 @@ summary.ddml_rep <- function(object, #' @export #' @method print summary.ddml_rep print.summary.ddml_rep <- function(x, digits = 3, ...) { - type_labels <- c( - ddml_plm = "Partially Linear Model", - ddml_pliv = "Partially Linear IV Model", - ddml_fpliv = - "Flexible Partially Linear IV Model", - ddml_ate = "Average Treatment Effect", - ddml_att = - "Average Treatment Effect on the Treated", - ddml_late = "Local Average Treatment Effect") - model_name <- type_labels[x$model_type] - if (is.na(model_name)) model_name <- x$model_type - - cat("DDML estimation:", model_name, "\n") + cat("DDML estimation:", x$estimator_name, "\n") cat("Obs:", x$nobs, " Folds:", x$sample_folds, " Resamples:", x$nresamples, @@ -556,18 +545,18 @@ print.summary.ddml_rep <- function(x, digits = 3, ...) { }#IF cat("\n\n") - nensb <- dim(x$inf_results)[3] + nensb <- dim(x$coefficients)[3] for (j in seq_len(nensb)) { if (nensb > 1) { cat("Ensemble type:", - dimnames(x$inf_results)[[3]][j], "\n") + dimnames(x$coefficients)[[3]][j], "\n") }#IF - tbl <- x$inf_results[, , j] + tbl <- x$coefficients[, , j] if (!is.matrix(tbl)) { tbl <- matrix(tbl, nrow = 1, dimnames = list( - dimnames(x$inf_results)[[1]], - dimnames(x$inf_results)[[2]])) + dimnames(x$coefficients)[[1]], + dimnames(x$coefficients)[[2]])) }#IF stats::printCoefmat(tbl, digits = digits, has.Pvalue = TRUE, @@ -630,7 +619,7 @@ tidy.ddml_rep <- function(x, ensemble_idx = 1, conf.level = 0.95, ...) { s <- summary(x, aggregation = aggregation, type = type) - inf <- s$inf_results + inf <- s$coefficients nensb <- dim(inf)[3] p <- dim(inf)[1] @@ -706,6 +695,7 @@ glance.ddml_rep <- function(x, ...) { ensemble_type = paste(x$ensemble_type, collapse = ", "), model_type = x$model_type, + estimator_name = x$estimator_name, nresamples = x$nresamples, stringsAsFactors = FALSE ) diff --git a/R/diagnostics.R b/R/diagnostics.R index 73635b3..066312c 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -39,12 +39,12 @@ diagnostics <- function(object, cvc = FALSE, stop("object must be of class 'ddml'.") }#IF - eq_names <- names(object$weights) + eq_names <- names(object$ensemble_weights) single_learner <- is_single_learner(object$learners) tables <- list() for (eq in eq_names) { - w <- object$weights[[eq]] + w <- object$ensemble_weights[[eq]] m <- object$mspe[[eq]] r <- object$r2[[eq]] @@ -128,6 +128,7 @@ diagnostics <- function(object, cvc = FALSE, result <- list( tables = tables, model_type = class(object)[1], + estimator_name = object$estimator_name, nobs = object$nobs, shortstack = object$shortstack, cvc = cvc, @@ -138,21 +139,16 @@ diagnostics <- function(object, cvc = FALSE, # Resolve the correct subsamples for a given equation. get_diag_subsamples <- function(object, eq) { - model <- class(object)[1] - if (model %in% c("ddml_plm", "ddml_pliv", - "ddml_fpliv")) { - return(object$subsamples) - }#IF - if (model %in% c("ddml_ate", "ddml_att")) { - if (grepl("D0", eq)) return(object$subsamples_byD[[1]]) - if (grepl("D1", eq)) return(object$subsamples_byD[[2]]) - return(merge_subsamples(object$subsamples_byD)) - }#IF - if (model == "ddml_late") { - if (grepl("Z0", eq)) return(object$subsamples_byZ[[1]]) - if (grepl("Z1", eq)) return(object$subsamples_byZ[[2]]) - return(merge_subsamples(object$subsamples_byZ)) - }#IF + splits <- object$splits + if (grepl("D0|d0", eq, ignore.case = TRUE) && !is.null(splits$subsamples_byD)) return(splits$subsamples_byD[[1]]) + if (grepl("D1|d1", eq, ignore.case = TRUE) && !is.null(splits$subsamples_byD)) return(splits$subsamples_byD[[2]]) + if (grepl("D0|d0", eq, ignore.case = TRUE) && !is.null(splits$subsamples_byd)) return(splits$subsamples_byd[[1]]) + if (grepl("D1|d1", eq, ignore.case = TRUE) && !is.null(splits$subsamples_byd)) return(splits$subsamples_byd[[2]]) + + if (grepl("Z0", eq, ignore.case = TRUE) && !is.null(splits$subsamples_byZ)) return(splits$subsamples_byZ[[1]]) + if (grepl("Z1", eq, ignore.case = TRUE) && !is.null(splits$subsamples_byZ)) return(splits$subsamples_byZ[[2]]) + + if (!is.null(splits$subsamples)) return(splits$subsamples) object$subsamples }#GET_DIAG_SUBSAMPLES @@ -175,17 +171,8 @@ merge_subsamples <- function(subsamples_by) { #' #' @export print.ddml_diagnostics <- function(x, digits = 4, ...) { - type_labels <- c( - ddml_plm = "Partially Linear Model", - ddml_pliv = "Partially Linear IV Model", - ddml_fpliv = - "Flexible Partially Linear IV Model", - ddml_ate = "Average Treatment Effect", - ddml_att = - "Average Treatment Effect on the Treated", - ddml_late = "Local Average Treatment Effect") - model_name <- type_labels[x$model_type] - if (is.na(model_name)) model_name <- x$model_type + 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") diff --git a/R/get_CEF.R b/R/get_CEF.R index 4cde55b..907954a 100644 --- a/R/get_CEF.R +++ b/R/get_CEF.R @@ -29,27 +29,78 @@ get_CEF <- function(y, X, Z = NULL, fitted = NULL) { t0 <- proc.time()[3] - if (!is.null(label)) { - info_msg(" Estimating ", label, "...", silent = silent) - }#IF - # Use pre-computed predictions if supplied if (!is.null(fitted)) { - 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'.")) + if (!is.null(label)) { + info_msg(" Estimating ", label, "...", silent = silent) + }#IF + if (!is.null(fitted$crossfit_fitted)) { + # 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'.")) + }#IF + res <- build_CEF_from_crossfit( + y, fitted$crossfit_fitted, + ensemble_type, custom_ensemble_weights, + crossval_resid = fitted$crossval_resid, + subsamples = subsamples, + auxiliary_fitted_bylearner = + fitted$auxiliary_fitted_bylearner) + return(res) + }#IF + if (!is.null(fitted$ensemble_fitted)) { + # Rule 1: pre-ensembled predictions, use directly + res <- list(oos_fitted = fitted$ensemble_fitted, + weights = NULL, mspe = NULL, r2 = NULL, + auxiliary_fitted = NULL, + crossfit_fitted = NULL, + crossfit_resid = NULL, + crossval_resid = NULL) + return(res) + }#IF + }#IF + + # Constant or empty y: return trivial predictions + 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 <- if (!is.null(custom_ensemble_weights)) + ncol(custom_ensemble_weights) else 0L + 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 - res <- build_CEF_from_crossfit( - y, fitted$crossfit_fitted, - ensemble_type, custom_ensemble_weights, - crossval_resid = fitted$crossval_resid, - subsamples = subsamples, - auxiliary_fitted_bylearner = fitted$auxiliary_fitted_bylearner) - return(res) + + return(list( + oos_fitted = matrix(constant_val, n, nensb), + weights = NULL, mspe = NULL, r2 = NULL, + crossfit_fitted = matrix(constant_val, n, nlearners), + crossfit_resid = matrix(0, n, nlearners), + crossval_resid = 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, learners = learners, @@ -97,13 +148,16 @@ extrapolate_CEF <- function(D, CEF_res_byD, aux_indx) { D_levels <- lapply(CEF_res_byD, function(x) x$d) is_D <- rep(list(NULL), nCEF) for (d in seq_len(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) + nensb <- ncol(as.matrix( + CEF_res_byD[[1]][[1]]$ensemble_fitted)) + sample_folds <- length( + CEF_res_byD[[1]][[1]]$auxiliary_fitted) # Populate CEF g_X_byD <- array(0, dim = c(nobs, nensb, nCEF)) for (d in seq_len(nCEF)) { - g_X_byD[is_D[[d]], , d] <- CEF_res_byD[[d]][[1]]$oos_fitted + g_X_byD[is_D[[d]], , d] <- + CEF_res_byD[[d]][[1]]$ensemble_fitted for (k in seq_len(sample_folds)) { g_X_byD[aux_indx[[d]][[k]], , d] <- CEF_res_byD[[d]][[1]]$auxiliary_fitted[[k]] diff --git a/R/help_functions.R b/R/help_functions.R index 57ba46d..526cfca 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -1,5 +1,26 @@ # 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 + # Simple generalized inverse wrapper. csolve <- function(X) { # Attempt inversion @@ -24,23 +45,23 @@ get_oosfitted <- function(res_list, j = NULL) { }#GET_OOSRESID # 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 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.")) + } else { + warning(paste0(ensemble_type[j], ": ", ntrim, + " propensity scores were trimmed.")) + }#IFELSE + }#IF m_X[indx_trim_0, j] <- trim m_X[indx_trim_1, j] <- 1 - trim }#IF @@ -134,6 +155,8 @@ build_CEF_from_crossfit <- function(y, crossfit_fitted_eq, }#FOR weights <- array(0, dim = c(nlearners, 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 { # Global weights from sample-fold residuals fakecv <- list(oos_resid = oos_resid, @@ -148,6 +171,14 @@ build_CEF_from_crossfit <- function(y, crossfit_fitted_eq, oos_fitted <- cf %*% weights }#IFELSE + # Propagate ensemble type names to oos_fitted columns + ens_names <- if (length(dim(weights)) == 3) { + colnames(weights[, , 1]) + } else { + colnames(weights) + } + if (!is.null(ens_names)) colnames(oos_fitted) <- ens_names + # Fold-level auxiliary predictions (ATE/ATT/LATE extrapolation) auxiliary_fitted <- NULL if (!is.null(auxiliary_fitted_bylearner)) { @@ -198,12 +229,14 @@ validate_fitted_splits_pair <- function(fitted, splits, build_fitted_entry <- function(res, save_crossval, include_auxiliary = FALSE) { - entry <- list(crossfit_fitted = res$crossfit_fitted, + entry <- list(ensemble_fitted = res$oos_fitted, + crossfit_fitted = res$crossfit_fitted, crossfit_resid = res$crossfit_resid) if (save_crossval) { entry$crossval_resid <- res$crossval_resid }#IF if (include_auxiliary) { + entry$auxiliary_fitted <- res$auxiliary_fitted entry$auxiliary_fitted_bylearner <- res$auxiliary_fitted_bylearner }#IF @@ -280,9 +313,11 @@ normalize_splits <- function(splits = NULL, }#NORMALIZE_SPLITS # Input validation checks for DDML estimators -validate_inputs <- function(y = NULL, D = NULL, X = NULL, Z = NULL, learners = NULL, +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, require_binary_D = FALSE) { nobs <- length(y) if (!is.null(y)) { @@ -360,6 +395,15 @@ validate_inputs <- function(y = NULL, D = NULL, X = NULL, Z = NULL, learners = N stop("trim must be a numeric value strictly between 0 and 0.5.") } } + + if (!is.null(weights) && !is.null(y)) { + if (!is.numeric(weights) || anyNA(weights)) { + stop("weights must be a numeric vector with no NAs.") + } + if (length(weights) != nobs) { + stop("weights must have the same length as y.") + } + } }#VALIDATE_INPUTS validate_custom_weights <- function(custom_weights, learners) { @@ -383,10 +427,18 @@ compute_ncustom_nensb <- function(ensemble_type, list(ncustom = ncustom, nensb = nensb) }#COMPUTE_NCUSTOM_NENSB -# Update ensemble info from CEF result weights. -update_ensemble_info <- function(res_weights) { - ensemble_type <- dimnames(res_weights)[[2]] - nensb <- if (is.null(ensemble_type)) 1L else length(ensemble_type) +# Update ensemble info from CEF result weights or oos_fitted. +update_ensemble_info <- function(res_weights = NULL, + oos_fitted = NULL) { + if (!is.null(res_weights)) { + ensemble_type <- dimnames(res_weights)[[2]] + } else if (!is.null(oos_fitted)) { + ensemble_type <- colnames(as.matrix(oos_fitted)) + } else { + ensemble_type <- NULL + }#IFELSE + nensb <- if (is.null(ensemble_type)) 1L + else length(ensemble_type) multiple_ensembles <- nensb > 1 list(ensemble_type = ensemble_type, nensb = nensb, multiple_ensembles = multiple_ensembles) diff --git a/R/inference_functions.R b/R/inference_functions.R index 5ef3765..f474708 100644 --- a/R/inference_functions.R +++ b/R/inference_functions.R @@ -1,23 +1,60 @@ +compute_leverage <- function(object, ensemble_idx = 1) { + if (is.list(object$psi_a)) { + psi_a_j <- object$psi_a[[min(ensemble_idx, length(object$psi_a))]] + J_j <- object$J[[min(ensemble_idx, length(object$J))]] + J_inv <- solve(J_j) + J_inv_vec <- as.vector(t(J_inv)) + + p <- ncol(J_j) + n <- object$nobs + dim(psi_a_j) <- c(n, p * p) + h <- (psi_a_j %*% J_inv_vec) / n + return(as.vector(h)) + } else if (!is.null(object$psi_a) && is.matrix(object$psi_a)) { + psi_a_j <- object$psi_a[, + min(ensemble_idx, ncol(object$psi_a))] + J_j <- as.numeric(object$J[[min(ensemble_idx, length(object$J))]]) + return(as.vector(psi_a_j / (object$nobs * J_j))) + }#IFELSE + + # Fallback for gracefully handling objects generated by older package versions + fit_obj <- if (!is.null(object$ols_fit)) { + object$ols_fit + } else { + object$iv_fit + }#IFELSE + if (is.list(fit_obj) && + !inherits(fit_obj, "lm") && + !inherits(fit_obj, "ivreg")) { + fit_obj <- fit_obj[[ensemble_idx]] + }#IF + as.vector(stats::hatvalues(fit_obj)) +}#COMPUTE_LEVERAGE + compute_ddml_variance <- function(scores, J, cluster_variable = NULL, - type = "HC1") { + type = "HC1", + leverage = NULL) { type <- match.arg(type, c("HC0", "HC1", "HC3")) sc <- as.matrix(scores) J_j <- as.matrix(J) p <- ncol(sc) # Cluster aggregation: rowsum scores to cluster level - if (!is.null(cluster_variable) && - !identical(seq_len(nrow(sc)), - as.integer(cluster_variable))) { + clustered <- !is.null(cluster_variable) && + !identical(seq_len(nrow(sc)), + as.integer(cluster_variable)) + if (clustered) { sc <- rowsum(sc, cluster_variable) }#IF n_eff <- nrow(sc) if (type == "HC3") { - PtP_inv <- solve(crossprod(sc)) - h <- rowSums((sc %*% PtP_inv) * sc) + h <- leverage + if (clustered) { + h <- as.vector(tapply(h, cluster_variable, sum)) + }#IF sc <- sc / (1 - h) meat <- crossprod(sc) / n_eff J_inv <- solve(J_j) @@ -41,7 +78,8 @@ compute_ddml_inference <- function(coefficients, scores, J, coef_names = NULL, ensemble_type, cluster_variable = NULL, - type = "HC1") { + type = "HC1", + leverage_list = NULL) { nensb <- length(ensemble_type) p <- nrow(coefficients) @@ -49,10 +87,12 @@ compute_ddml_inference <- function(coefficients, scores, J, for (j in seq_len(nensb)) { theta_j <- coefficients[, j] + h <- if (!is.null(leverage_list)) leverage_list[[j]] V <- compute_ddml_variance(scores[[j]], J[[j]], cluster_variable, - type = type) + type = type, + leverage = h) se <- sqrt(diag(V)) t_val <- theta_j / se p_val <- 2 * stats::pnorm(abs(t_val), diff --git a/R/methods.R b/R/methods.R index 669e472..7015169 100644 --- a/R/methods.R +++ b/R/methods.R @@ -1,3 +1,24 @@ +#' Access Elements of a DDML Object +#' +#' Provides backward compatibility for renamed elements. +#' Accessing \code{$weights} is deprecated; use +#' \code{$ensemble_weights} instead. +#' +#' @param x An object of class \code{ddml}. +#' @param name Element name. +#' +#' @return The requested element. +#' +#' @export +`$.ddml` <- function(x, name) { + if (name == "weights") { + message("Note: '$weights' is deprecated for ddml ", + "objects. Use '$ensemble_weights' instead.") + return(.subset2(x, "ensemble_weights")) + }#IF + .subset2(x, name) +}#`$.DDML` + #' Extract Model Coefficients #' #' @param object An object of class \code{ddml}. @@ -22,27 +43,90 @@ coef.ddml <- function(object, ...) { cf <- object$coefficients if (is.matrix(cf) && ncol(cf) == 1) { - cf <- drop(cf) - if (length(cf) == 1) { - names(cf) <- NULL - }#IF + nm <- rownames(cf) + cf <- as.vector(cf) + names(cf) <- nm }#IF cf }#COEF.DDML +#' Extract Number of Observations +#' +#' @param object An object of class \code{ddml}. +#' @param ... Currently unused. +#' +#' @return An integer specifying the number of observations. +#' +#' @importFrom stats nobs +#' @export +nobs.ddml <- function(object, ...) { + object$nobs +}#NOBS.DDML + #' Variance-Covariance Matrix for DDML Estimators #' +#' @description Computes a heteroskedasticity-robust +#' variance-covariance matrix for the DDML estimator +#' \eqn{\hat\theta}. +#' +#' @details All implemented DDML estimators solve a moment +#' condition of the form +#' \eqn{E[m(W; \theta_0, \eta_0)] = 0} where the score +#' decomposes as +#' +#' \eqn{m(W_i; \theta, \eta) = \psi_{b}(W_i; \eta) + \psi_{a}(W_i; \eta)\,\theta.} +#' +#' Write \eqn{m_i = m(W_i; \hat\theta, \hat\eta)} for the +#' evaluated score and +#' \eqn{\hat{J} = n^{-1}\sum_i \psi_a(W_i; \hat\eta)} for +#' the sample Jacobian. Three sandwich estimators are +#' available: +#' +#' \strong{HC0}: +#' \deqn{V_{\textrm{HC0}} = \hat{J}^{-1} +#' \left(\frac{1}{n}\sum_i m_i m_i'\right) +#' \hat{J}^{-\top} / n} +#' +#' \strong{HC1} (default): +#' \deqn{V_{\textrm{HC1}} = V_{\textrm{HC0}} +#' \times \frac{n}{n - p}} +#' +#' where \eqn{p} is the dimension of \eqn{\theta}. +#' +#' \strong{HC3}: +#' \deqn{V_{\textrm{HC3}} = \hat{J}^{-1} +#' \left(\frac{1}{n}\sum_i +#' \frac{m_i m_i'}{(1 - h_{ii})^2}\right) +#' \hat{J}^{-\top} / n} +#' +#' where \eqn{h_{ii}} is the generalized leverage. In the +#' general case, +#' \deqn{h_{ii} = \mathrm{tr}\!\left( +#' \nabla_\theta m(W_i; \hat\theta, \hat\eta) +#' \left[\sum_{j=1}^n +#' \nabla_\theta m(W_j; \hat\theta, \hat\eta) +#' \right]^{-1}\right)} +#' +#' where \eqn{\nabla_\theta m(W_i; \hat\theta, \hat\eta)} +#' is the derivative of the \eqn{i}-th score with respect +#' to \eqn{\theta} (the nuisance parameters \eqn{\hat\eta} +#' are treated as fixed, having been estimated +#' out-of-sample). For the linear scores implemented in +#' \code{ddml}, the derivative is +#' \eqn{\nabla_\theta m(W_i; \theta, \eta) = \psi_a(W_i; \eta)}, +#' so the leverage simplifies to +#' +#' \eqn{h_{ii} = \mathrm{tr}(\psi_a(W_i; \hat\eta)\,(n\hat{J})^{-1}).} +#' #' @param object An object of class \code{ddml}. #' @param ensemble_idx Integer index of the ensemble type to #' use. Defaults to 1 (first ensemble type). #' @param type Character string specifying the #' variance-covariance estimator. One of \code{"HC1"} -#' (default, degrees-of-freedom corrected), \code{"HC0"} -#' (uncorrected), or \code{"HC3"} (score-based leverage -#' adjustment for finite-sample robustness). +#' (default), \code{"HC0"}, or \code{"HC3"}. #' @param ... Currently unused. #' -#' @return A p x p variance-covariance matrix. +#' @return A \eqn{p \times p}{p x p} variance-covariance matrix. #' #' @examples #' \donttest{ @@ -59,11 +143,15 @@ coef.ddml <- function(object, ...) { #' @export vcov.ddml <- function(object, ensemble_idx = 1, type = "HC1", ...) { + h <- if (type == "HC3") { + compute_leverage(object, ensemble_idx) + }#IF V <- compute_ddml_variance( object$scores[[ensemble_idx]], object$J[[ensemble_idx]], object$cluster_variable, - type = type) + type = type, + leverage = h) rownames(V) <- colnames(V) <- object$coef_names V }#VCOV.DDML @@ -108,14 +196,38 @@ confint.ddml <- function(object, parm, level = 0.95, ci }#CONFINT.DDML +#' Subscript a DDML Summary Object (Deprecated) +#' +#' Delegates \code{[} to the underlying inference array. +#' This method exists for backward compatibility only; +#' use \code{x$coefficients[...]} instead. +#' +#' @param x An object of class \code{summary.ddml}. +#' @param ... Indices passed to \code{[} on the inference +#' array. +#' +#' @return The subset of the inference array. +#' +#' @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, t-values, and p-values for all +#' ensemble types. Standard errors are based on a +#' heteroskedasticity-robust sandwich variance; see +#' \code{\link{vcov.ddml}} for the HC0/HC1/HC3 formulas. +#' #' @param object An object of class \code{ddml}. #' @param type Character string specifying the #' variance-covariance estimator. One of \code{"HC1"} -#' (default, degrees-of-freedom corrected), \code{"HC0"} -#' (uncorrected), or \code{"HC3"} (score-based leverage -#' adjustment for finite-sample robustness). +#' (default), \code{"HC0"}, or \code{"HC3"}. See +#' \code{\link{vcov.ddml}} for details. #' @param ... Currently unused. #' #' @return An object of class \code{summary.ddml}. @@ -142,6 +254,11 @@ summary.ddml <- function(object, type = "HC1", ...) { object$ensemble_type }#IFELSE + h_list <- if (type == "HC3") { + lapply(seq_along(object$scores), function(j) { + compute_leverage(object, j) + }) + }#IF inf <- compute_ddml_inference( coefficients = object$coefficients, scores = object$scores, @@ -149,12 +266,14 @@ summary.ddml <- function(object, type = "HC1", ...) { coef_names = object$coef_names, ensemble_type = ens_type, cluster_variable = object$cluster_variable, - type = type) + type = type, + leverage_list = h_list) result <- list( - inf_results = inf, + coefficients = inf, type = type, model_type = class(object)[1], + estimator_name = object$estimator_name, nobs = object$nobs, sample_folds = object$sample_folds, shortstack = object$shortstack, @@ -175,17 +294,8 @@ summary.ddml <- function(object, type = "HC1", ...) { #' #' @export print.summary.ddml <- function(x, digits = 3, ...) { - type_labels <- c( - ddml_plm = "Partially Linear Model", - ddml_pliv = "Partially Linear IV Model", - ddml_fpliv = - "Flexible Partially Linear IV Model", - ddml_ate = "Average Treatment Effect", - ddml_att = - "Average Treatment Effect on the Treated", - ddml_late = "Local Average Treatment Effect") - model_name <- type_labels[x$model_type] - if (is.na(model_name)) model_name <- x$model_type + 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, @@ -198,18 +308,18 @@ print.summary.ddml <- function(x, digits = 3, ...) { }#IF cat("\n\n") - nensb <- dim(x$inf_results)[3] + nensb <- dim(x$coefficients)[3] for (j in seq_len(nensb)) { if (nensb > 1) { cat("Ensemble type:", - dimnames(x$inf_results)[[3]][j], "\n") + dimnames(x$coefficients)[[3]][j], "\n") }#IF - tbl <- x$inf_results[, , j] + tbl <- x$coefficients[, , j] if (!is.matrix(tbl)) { tbl <- matrix(tbl, nrow = 1, dimnames = list( - dimnames(x$inf_results)[[1]], - dimnames(x$inf_results)[[2]])) + dimnames(x$coefficients)[[1]], + dimnames(x$coefficients)[[2]])) }#IF stats::printCoefmat(tbl, digits = digits, has.Pvalue = TRUE, diff --git a/R/tidy.R b/R/tidy.R index 164d01f..7858774 100644 --- a/R/tidy.R +++ b/R/tidy.R @@ -51,7 +51,7 @@ tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, conf.level = 0.95, type = "HC1", ...) { s <- summary(x, type = type) - inf <- s$inf_results + inf <- s$coefficients nensb <- dim(inf)[3] p <- dim(inf)[1] @@ -118,6 +118,7 @@ glance.ddml <- function(x, ...) { 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 \ No newline at end of file diff --git a/README.md b/README.md index 3b71b37..1fad591 100644 --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ Version](https://www.r-pkg.org/badges/version/ddml)](https://cran.r-project.org/ [![cranlogs](https://cranlogs.r-pkg.org/badges/ddml)](https://cran.r-project.org/package=ddml) -`ddml` is an implementation of double/debiased machine learning +`ddml` is an implementation of Double/Debiased Machine Learning estimators as proposed by Chernozhukov et al. (2018). The key feature of `ddml` is the straightforward estimation of nuisance parameters using (short-)stacking (Wolpert, 1992), which allows for multiple machine @@ -69,7 +69,7 @@ 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`). Since the +Double/Debiased Machine Learning (see `?ddml_late`). Since the statistical properties of machine learners depend heavily on the underlying (unknown!) structure of the data, adaptive combination of multiple machine learners can increase robustness. In the below snippet, diff --git a/_pkgdown.yml b/_pkgdown.yml index bf0c426..8425ca1 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -43,15 +43,29 @@ reference: - ddml_pliv - ddml_fpliv - ddml_late +- title: Repeated Resampling + contents: + - ddml_replicate + - ddml_rep - title: internal contents: - coef.ddml - confint.ddml - vcov.ddml + - nobs.ddml + - "`$.ddml`" + - "`[.summary.ddml`" - tidy.ddml - glance.ddml - tidy.ddml_diagnostics - ensemble_weights + - coef.ddml_rep + - confint.ddml_rep + - vcov.ddml_rep + - tidy.ddml_rep + - glance.ddml_rep + - length.ddml_rep + - "`[[.ddml_rep`" - title: Wrappers for Common (Machine) Learners contents: - ols diff --git a/man/cash-.ddml.Rd b/man/cash-.ddml.Rd new file mode 100644 index 0000000..15e6cd3 --- /dev/null +++ b/man/cash-.ddml.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods.R +\name{$.ddml} +\alias{$.ddml} +\title{Access Elements of a DDML Object} +\usage{ +\method{$}{ddml}(x, name) +} +\arguments{ +\item{x}{An object of class \code{ddml}.} + +\item{name}{Element name.} +} +\value{ +The requested element. +} +\description{ +Provides backward compatibility for renamed elements. +Accessing \code{$weights} is deprecated; use +\code{$ensemble_weights} instead. +} diff --git a/man/confint.ddml.Rd b/man/confint.ddml.Rd index 28bd8ce..97505b3 100644 --- a/man/confint.ddml.Rd +++ b/man/confint.ddml.Rd @@ -18,9 +18,7 @@ use. Defaults to 1 (first ensemble type).} \item{type}{Character string specifying the variance-covariance estimator. One of \code{"HC1"} -(default, degrees-of-freedom corrected), \code{"HC0"} -(uncorrected), or \code{"HC3"} (score-based leverage -adjustment for finite-sample robustness).} +(default), \code{"HC0"}, or \code{"HC3"}.} \item{...}{Currently unused.} } diff --git a/man/ddml_apo.Rd b/man/ddml_apo.Rd new file mode 100644 index 0000000..715f445 --- /dev/null +++ b/man/ddml_apo.Rd @@ -0,0 +1,226 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_apo.R +\name{ddml_apo} +\alias{ddml_apo} +\title{DDML 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 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}.} + +\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 the example below.} + +\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{...}{Deprecated arguments (\code{subsamples_byd}, +\code{cv_subsamples_byd}) are still accepted for backward +compatibility but should be replaced with the \code{splits} +argument.} +} +\value{ +\code{ddml_apo} returns a list object of class \code{ddml_apo} +and \code{ddml} with the following properties: +\describe{ +\item{\code{coefficients}}{A matrix of estimated coefficients.} +\item{\code{ensemble_weights}}{The ensemble weights.} +\item{\code{mspe}}{The in-sample mean squared prediction errors.} +\item{\code{r2}}{The out-of-sample R-squared.} +\item{\code{psi_a}, \code{psi_b}}{The scale and scores associated with +evaluating the Neyman orthogonal score.} +\item{\code{scores}}{A list of evaluating the Neyman orthogonal scores.} +\item{\code{J}}{A list of evaluating the Jacobian of the Neyman +orthogonal scores.} +\item{\code{fitted}}{An optional list of fitted nuisance estimators. +See \code{\link{ddml_plm}} for more information.} +\item{\code{splits}}{The data splitting structure.} +\item{\code{learners}}{The original list of learners.} +\item{\code{learners_DX}}{The original list of learners for the propensity +score.} +\item{\code{ensemble_type}}{The ensemble type.} +\item{\code{nobs}}{The number of observations.} +\item{\code{sample_folds}}{The number of sample folds.} +\item{\code{cv_folds}}{The number of cross-validation folds.} +\item{\code{shortstack}}{A boolean indicating if shortstacking was used.} +\item{\code{cluster_variable}}{The original cluster variable.} +\item{\code{call}}{The match.call().} +} +} +\description{ +\code{ddml_apo} provides a Double/Debiased Machine Learning +estimator for the average potential outcome, allowing for custom +weights \eqn{\omega(X)}. +} +\details{ +\code{ddml_apo} provides a Double/Debiased Machine Learning +estimator for the target parameter \eqn{\theta_0} in the model given by + +\eqn{Y = g_0(D, X) + U,} + +where \eqn{(Y, D, X, U)} is a random vector such that +\eqn{E[U\vert D, X] = 0} and +\eqn{\Pr(D=d\vert X) \in (0, 1)} with probability 1, +and \eqn{g_0} is an unknown nuisance function. + +In this model, the average potential outcome (APO) for treatment +level \eqn{d} is defined as + +\eqn{\theta_0^{\textrm{APO}} \equiv E[\omega(X) g_0(d, X)]}, + +where \eqn{\omega(X)} is a known weighting function. If \eqn{\omega(X) = 1}, +this parameter corresponds to the standard Average Potential Outcome (APO) +at treatment level \eqn{d}. + +The estimating equation is +\eqn{E[m(W; \theta_0, \eta_0)] = 0}, where +\eqn{W = (Y, D, X)}, and the Neyman orthogonal score is + +\eqn{m(W; \theta, \eta) = \left( \frac{\mathbbm{1}\{D=d\} (Y - \ell(X))}{p(X)} + \ell(X) \right) \omega(X) - \theta} + +\if{html}{\out{

}}\preformatted{with nuisance parameters \eqn{\eta = (\ell, p)} taking +true values \eqn{\ell_0(X) = E[Y|D=d, X]} and \eqn{p_0(X) = E[\mathbbm{1}\{D=d\}|X]}. +}\if{html}{\out{
}} +} +\references{ +Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). +"Model Averaging and Double Machine Learning." +\url{https://arxiv.org/abs/2401.01645} +} +\seealso{ +\code{\link{summary.ddml}} +\code{\link{ddml_plm}}, \code{\link{ddml_pliv}}, +\code{\link{ddml_fpliv}}, \code{\link{ddml_late}}, +\code{\link{ddml_ate}} +} diff --git a/man/ddml_ate.Rd b/man/ddml_ate.Rd index cb1c4cc..c660081 100644 --- a/man/ddml_ate.Rd +++ b/man/ddml_ate.Rd @@ -164,20 +164,24 @@ compatibility but should be replaced with \code{splits}.} \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{coefficients}}{A matrix of estimated coefficients.} +\item{\code{ensemble_weights}}{A list of matrices, providing the +weight assigned to each base learner 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]{summary.ddml()}}.} -\item{\code{oos_pred}}{List of matrices, providing the reduced form -predicted values.} -\item{\code{learners},\code{learners_DX},\code{cluster_variable}, -\code{subsamples_byD},\code{cv_subsamples_byD}, +base learner computed by the cross-validation step in the +ensemble construction.} +\item{\code{r2}}{The out-of-sample R-squared.} +\item{\code{psi_a}, \code{psi_b}}{Matrices needed for the +computation of scores. Used in \code{\link[=summary.ddml]{summary.ddml()}}.} +\item{\code{scores}}{A list of evaluated Neyman orthogonal +scores.} +\item{\code{J}}{A list of evaluated Jacobians.} +\item{\code{fitted}}{A list of fitted nuisance estimators. +See \code{\link{ddml_plm}} for more information.} +\item{\code{splits}}{The data splitting structure.} +\item{\code{learners},\code{learners_DX}, +\code{cluster_variable}, \code{ensemble_type}}{Pass-through of selected user-provided arguments. See above.} } @@ -187,8 +191,8 @@ Estimators of 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 +\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 @@ -199,13 +203,31 @@ where \eqn{(Y, D, X, U)} is a random vector such that \eqn{\Pr(D=1\vert X) \in (0, 1)} with probability 1, and \eqn{g_0} is an unknown nuisance function. -In this model, the average treatment effect is defined as +In this model, the average treatment effect (ATE) is defined as -\eqn{\theta_0^{\textrm{ATE}} \equiv E[g_0(1, X) - g_0(0, X)]}. +\eqn{\theta_0^{\textrm{ATE}} \equiv E[g_0(1, X) - g_0(0, X)]}, -and the average treatment effect on the treated is defined as +and the average treatment effect on the treated (ATT) is defined as \eqn{\theta_0^{\textrm{ATT}} \equiv E[g_0(1, X) - g_0(0, X)\vert D = 1]}. + +The estimating equations are +\eqn{E[m(W; \theta_0, \eta_0)] = 0}, where +\eqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta}, +\eqn{W = (Y, D, X)}, and the Neyman orthogonal scores are + +\eqn{\psi_b^{\textrm{ATE}}(W; \eta) = \frac{D(Y - \ell_1(X))}{m(X)} - \frac{(1-D)(Y-\ell_0(X))}{1-m(X)} + \ell_1(X) - \ell_0(X)} + +\eqn{\psi_a^{\textrm{ATE}}(W; \eta) = -1} + +\eqn{\psi_b^{\textrm{ATT}}(W; \eta) = \frac{D(Y - \ell_0(X))}{p} - \frac{m(X)(1-D)(Y-\ell_0(X))}{p(1-m(X))}} + +\eqn{\psi_a^{\textrm{ATT}}(W; \eta) = -\frac{D}{p}} + +\if{html}{\out{
}}\preformatted{with nuisance parameters \eqn{\eta = (\ell_0, \ell_1, m, p)} taking +true values \eqn{\ell_{d,0}(X) = E[Y|D=d, X]}, \eqn{m_0(X) = E[D|X]}, +and \eqn{p_0 = E[D]}. +}\if{html}{\out{
}} } \examples{ # Construct variables from the included Angrist & Evans (1998) data diff --git a/man/ddml_fpliv.Rd b/man/ddml_fpliv.Rd index 29f0090..1a54b2d 100644 --- a/man/ddml_fpliv.Rd +++ b/man/ddml_fpliv.Rd @@ -16,7 +16,6 @@ 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, @@ -90,9 +89,6 @@ 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{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} @@ -125,8 +121,7 @@ that use packages not imported by \code{ddml}).} }} \item{fitted}{An optional named list of per-equation cross-fitted -predictions, typically obtained via \code{fit$fitted}. Not -supported when \code{enforce_LIE = TRUE}. See +predictions, typically obtained via \code{fit$fitted}. See \code{\link{ddml_plm}} for details.} \item{splits}{An optional list of sample split objects, typically @@ -148,8 +143,9 @@ with the \code{splits} argument.} \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 +\item{\code{coef}}{A vector with the \eqn{\theta_0} estimates and +the second-stage intercept (last element).} +\item{\code{ensemble_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 @@ -169,8 +165,8 @@ selected user-provided arguments. See above.} Estimator for the flexible 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 +\code{ddml_fpliv} provides a Double/Debiased Machine Learning +estimator for the target parameter \eqn{\theta_0} in the partially linear IV model given by \eqn{Y = \theta_0D + g_0(X) + U,} @@ -178,6 +174,18 @@ linear IV model given by 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. + +In this model, the target parameter \eqn{\theta_0} is identified by the +estimating equation +\eqn{E[m(W; \theta_0, \eta_0)] = 0}, where \eqn{W = (Y, D, Z, X)} and +\eqn{m(W; \theta, \eta)} is the Neyman orthogonal score + +\eqn{m(W; \theta, \eta) = (Y - \ell(X) - \theta(D - r(X)))(v(X, Z) - r(X)),} + +\if{html}{\out{
}}\preformatted{with nuisance parameters \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]}. +}\if{html}{\out{
}} } \examples{ # Construct variables from the included Angrist & Evans (1998) data diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index 39ccf7e..90b624f 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -151,29 +151,33 @@ compatibility but should be replaced with \code{splits}.} \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]{summary.ddml()}}.} -\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_byZ}, -\code{cv_subsamples_byZ},\code{ensemble_type}}{Pass-through -of selected user-provided arguments. See above.} +\item{\code{coefficients}}{A matrix of estimated coefficients.} +\item{\code{ensemble_weights}}{A list of matrices, providing the +weight assigned to each base learner by the ensemble +procedure.} +\item{\code{mspe}}{A list of matrices, providing the MSPE of +each base learner computed by the cross-validation step +in the ensemble construction.} +\item{\code{r2}}{The out-of-sample R-squared.} +\item{\code{psi_a}, \code{psi_b}}{Matrices needed for the +computation of scores. Used in \code{\link[=summary.ddml]{summary.ddml()}}.} +\item{\code{scores}}{A list of evaluated Neyman orthogonal +scores.} +\item{\code{J}}{A list of evaluated Jacobians.} +\item{\code{fitted}}{A list of fitted nuisance estimators. +See \code{\link{ddml_plm}} for more information.} +\item{\code{splits}}{The data splitting structure.} +\item{\code{learners},\code{learners_DXZ}, +\code{learners_ZX},\code{cluster_variable}, +\code{ensemble_type}}{Pass-through of selected +user-provided arguments. See above.} } } \description{ Estimator of the local average treatment effect. } \details{ -\code{ddml_late} provides a double/debiased machine learning +\code{ddml_late} provides a Double/Debiased Machine Learning estimator for the local average treatment effect in the interactive model given by @@ -187,10 +191,24 @@ where \eqn{(Y, D, X, Z, U)} is a random vector such that \eqn{p_0(Z, X) \equiv \Pr(D=1\vert Z, X)}, and \eqn{g_0} is an unknown nuisance function. -In this model, the local average treatment effect is defined as +In this model, the local average treatment effect (LATE) is defined as \eqn{\theta_0^{\textrm{LATE}} \equiv - E[g_0(1, X) - g_0(0, X)\vert p_0(1, X) > p(0, X)]}. + E[g_0(1, X) - g_0(0, X)\vert p_0(1, X) > p_0(0, X)]}. + +The estimating equation is +\eqn{E[m(W; \theta_0, \eta_0)] = 0}, where +\eqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta}, +\eqn{W = (Y, D, Z, X)}, and the Neyman orthogonal scores are + +\eqn{\psi_b(W; \eta) = \frac{Z(Y - \ell_1(X))}{m(X)} - \frac{(1-Z)(Y-\ell_0(X))}{1-m(X)} + \ell_1(X) - \ell_0(X)} + +\eqn{\psi_a(W; \eta) = -\left(\frac{Z(D - r_1(X))}{m(X)} - \frac{(1-Z)(D-r_0(X))}{1-m(X)} + r_1(X) - r_0(X)\right)} + +\if{html}{\out{
}}\preformatted{with nuisance parameters \eqn{\eta = (\ell_0, \ell_1, r_0, r_1, m)} 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{m_0(X) = E[Z|X]}. +}\if{html}{\out{
}} } \examples{ # Construct variables from the included Angrist & Evans (1998) data diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index fb54d60..76f43d8 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -150,8 +150,9 @@ with the \code{splits} argument.} \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 +\item{\code{coef}}{A vector with the \eqn{\theta_0} estimates and +the second-stage intercept (last element).} +\item{\code{ensemble_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 @@ -171,8 +172,8 @@ selected user-provided arguments. See above.} Estimator for 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 +\code{ddml_pliv} provides a Double/Debiased Machine Learning +estimator for the target parameter \eqn{\theta_0} in the partially linear IV model given by \eqn{Y = \theta_0D + g_0(X) + U,} @@ -180,6 +181,18 @@ linear IV model given by 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. + +In this model, the target parameter \eqn{\theta_0} is identified by the +estimating equation +\eqn{E[m(W; \theta_0, \eta_0)] = 0}, where \eqn{W = (Y, D, Z, X)} and +\eqn{m(W; \theta, \eta)} is the Neyman orthogonal score + +\eqn{m(W; \theta, \eta) = (Y - \ell(X) - \theta(D - r_D(X)))(Z - r_Z(X)),} + +\if{html}{\out{
}}\preformatted{with nuisance parameters \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]}. +}\if{html}{\out{
}} } \examples{ # Construct variables from the included Angrist & Evans (1998) data diff --git a/man/ddml_plm.Rd b/man/ddml_plm.Rd index 756afc8..aefc726 100644 --- a/man/ddml_plm.Rd +++ b/man/ddml_plm.Rd @@ -138,8 +138,9 @@ with the \code{splits} argument.} \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 +\item{\code{coef}}{A vector with the \eqn{\theta_0} estimates and +the second-stage intercept (last element).} +\item{\code{ensemble_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 @@ -158,8 +159,8 @@ arguments. See above.} Estimator for the partially linear model. } \details{ -\code{ddml_plm} provides a double/debiased machine learning -estimator for the parameter of interest \eqn{\theta_0} in the partially +\code{ddml_plm} provides a Double/Debiased Machine Learning +estimator for the target parameter \eqn{\theta_0} in the partially linear model given by \eqn{Y = \theta_0D + g_0(X) + U,} @@ -167,6 +168,17 @@ linear model given by 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. + +In this model, the target parameter \eqn{\theta_0} is identified by the +estimating equation +\eqn{E[m(W; \theta_0, \eta_0)] = 0}, where \eqn{W = (Y, D, X)} and +\eqn{m(W; \theta, \eta)} is the Neyman orthogonal score + +\eqn{m(W; \theta, \eta) = (Y - \ell(X) - \theta(D - r(X)))(D - r(X)),} + +\if{html}{\out{
}}\preformatted{with nuisance parameters \eqn{\eta = (\ell, r)} taking true values +\eqn{\ell_0(X) = E[Y|X]} and \eqn{r_0(X) = E[D|X]}. +}\if{html}{\out{
}} } \examples{ # Construct variables from the included Angrist & Evans (1998) data diff --git a/man/nobs.ddml.Rd b/man/nobs.ddml.Rd new file mode 100644 index 0000000..89b606d --- /dev/null +++ b/man/nobs.ddml.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods.R +\name{nobs.ddml} +\alias{nobs.ddml} +\title{Extract Number of Observations} +\usage{ +\method{nobs}{ddml}(object, ...) +} +\arguments{ +\item{object}{An object of class \code{ddml}.} + +\item{...}{Currently unused.} +} +\value{ +An integer specifying the number of observations. +} +\description{ +Extract Number of Observations +} diff --git a/man/sub-.summary.ddml.Rd b/man/sub-.summary.ddml.Rd new file mode 100644 index 0000000..5ee980a --- /dev/null +++ b/man/sub-.summary.ddml.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods.R +\name{[.summary.ddml} +\alias{[.summary.ddml} +\title{Subscript a DDML Summary Object (Deprecated)} +\usage{ +\method{[}{summary.ddml}(x, ...) +} +\arguments{ +\item{x}{An object of class \code{summary.ddml}.} + +\item{...}{Indices passed to \code{[} on the inference +array.} +} +\value{ +The subset of the inference array. +} +\description{ +Delegates \code{[} to the underlying inference array. +This method exists for backward compatibility only; +use \code{x$coefficients[...]} instead. +} diff --git a/man/summary.ddml.Rd b/man/summary.ddml.Rd index 99f736e..081be5d 100644 --- a/man/summary.ddml.Rd +++ b/man/summary.ddml.Rd @@ -11,9 +11,8 @@ \item{type}{Character string specifying the variance-covariance estimator. One of \code{"HC1"} -(default, degrees-of-freedom corrected), \code{"HC0"} -(uncorrected), or \code{"HC3"} (score-based leverage -adjustment for finite-sample robustness).} +(default), \code{"HC0"}, or \code{"HC3"}. See +\code{\link{vcov.ddml}} for details.} \item{...}{Currently unused.} } @@ -21,7 +20,11 @@ adjustment for finite-sample robustness).} An object of class \code{summary.ddml}. } \description{ -Summary for DDML Estimators +Computes a coefficient table with estimates, +standard errors, t-values, and p-values for all +ensemble types. Standard errors are based on a +heteroskedasticity-robust sandwich variance; see +\code{\link{vcov.ddml}} for the HC0/HC1/HC3 formulas. } \examples{ \donttest{ diff --git a/man/vcov.ddml.Rd b/man/vcov.ddml.Rd index 292bb24..5a7b8c3 100644 --- a/man/vcov.ddml.Rd +++ b/man/vcov.ddml.Rd @@ -14,17 +14,67 @@ use. Defaults to 1 (first ensemble type).} \item{type}{Character string specifying the variance-covariance estimator. One of \code{"HC1"} -(default, degrees-of-freedom corrected), \code{"HC0"} -(uncorrected), or \code{"HC3"} (score-based leverage -adjustment for finite-sample robustness).} +(default), \code{"HC0"}, or \code{"HC3"}.} \item{...}{Currently unused.} } \value{ -A p x p variance-covariance matrix. +A \eqn{p \times p}{p x p} variance-covariance matrix. } \description{ -Variance-Covariance Matrix for DDML Estimators +Computes a heteroskedasticity-robust +variance-covariance matrix for the DDML estimator +\eqn{\hat\theta}. +} +\details{ +All implemented DDML estimators solve a moment +condition of the form +\eqn{E[m(W; \theta_0, \eta_0)] = 0} where the score +decomposes as + +\eqn{m(W_i; \theta, \eta) = \psi_{b}(W_i; \eta) + \psi_{a}(W_i; \eta)\,\theta.} + +Write \eqn{m_i = m(W_i; \hat\theta, \hat\eta)} for the +evaluated score and +\eqn{\hat{J} = n^{-1}\sum_i \psi_a(W_i; \hat\eta)} for +the sample Jacobian. Three sandwich estimators are +available: + +\strong{HC0}: +\deqn{V_{\textrm{HC0}} = \hat{J}^{-1} + \left(\frac{1}{n}\sum_i m_i m_i'\right) + \hat{J}^{-\top} / n} + +\strong{HC1} (default): +\deqn{V_{\textrm{HC1}} = V_{\textrm{HC0}} + \times \frac{n}{n - p}} + +where \eqn{p} is the dimension of \eqn{\theta}. + +\strong{HC3}: +\deqn{V_{\textrm{HC3}} = \hat{J}^{-1} + \left(\frac{1}{n}\sum_i + \frac{m_i m_i'}{(1 - h_{ii})^2}\right) + \hat{J}^{-\top} / n} + +where \eqn{h_{ii}} is the generalized leverage. In the +general case, +\deqn{h_{ii} = \mathrm{tr}\!\left( + \nabla_\theta m(W_i; \hat\theta, \hat\eta) + \left[\sum_{j=1}^n + \nabla_\theta m(W_j; \hat\theta, \hat\eta) + \right]^{-1}\right)} + +where \eqn{\nabla_\theta m(W_i; \hat\theta, \hat\eta)} +is the derivative of the \eqn{i}-th score with respect +to \eqn{\theta} (the nuisance parameters \eqn{\hat\eta} +are treated as fixed, having been estimated +out-of-sample). For the linear scores implemented in +\code{ddml}, the derivative is +\eqn{\nabla_\theta m(W_i; \theta, \eta) = \psi_a(W_i; \eta)}, +so the leverage simplifies to + +\eqn{h_{ii} = \mathrm{tr}(\psi_a(W_i; \hat\eta)\,(n\hat{J})^{-1}).} } \examples{ \donttest{ diff --git a/man/vcov.ddml_rep.Rd b/man/vcov.ddml_rep.Rd index c9d25b9..b4c8d46 100644 --- a/man/vcov.ddml_rep.Rd +++ b/man/vcov.ddml_rep.Rd @@ -28,11 +28,11 @@ variance-covariance estimator. One of \code{"HC1"} \item{...}{Currently unused.} } \value{ -A diagonal p x p variance-covariance matrix. +A p x p variance-covariance matrix. } \description{ -Returns a diagonal variance-covariance matrix from -cross-resample aggregation. +Returns a variance-covariance matrix from cross-resample +aggregation. } \examples{ \donttest{ diff --git a/tests/testthat/test-ddml_apo.R b/tests/testthat/test-ddml_apo.R new file mode 100644 index 0000000..c75a981 --- /dev/null +++ b/tests/testthat/test-ddml_apo.R @@ -0,0 +1,299 @@ +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", { + # 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) + # 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" + ) +}) + +test_that("ddml_apo legacy grouped split args warn and still work", { + set.seed(202) + nobs <- 600 + X <- matrix(rnorm(nobs * 4), nobs, 4) + D_tld <- X %*% c(0.7, 0.2, 0.1, 0) + rnorm(nobs) + D <- 1 * (D_tld > mean(D_tld)) + y <- D + X %*% c(0.2, 0.3, 0.1, 0.4) + rnorm(nobs) + learners <- list(what = ols) + splits <- get_sample_splits( + cluster_variable = seq_len(nobs), + sample_folds = 3, + cv_folds = 3, + D = 1 * (D == 1), + stratify = TRUE + ) + fit_splits <- ddml_apo( + y, D, X, + d = 1, + learners = learners, + sample_folds = 3, + cv_folds = 3, + splits = list( + subsamples = splits$subsamples, + subsamples_byd = splits$subsamples_byD, + cv_subsamples = splits$cv_subsamples, + cv_subsamples_byd = splits$cv_subsamples_byD + ), + silent = TRUE + ) + expect_warning( + fit_legacy <- ddml_apo( + y, D, X, + d = 1, + learners = learners, + sample_folds = 3, + cv_folds = 3, + subsamples = splits$subsamples, + subsamples_byd = splits$subsamples_byD, + cv_subsamples = splits$cv_subsamples, + cv_subsamples_byd = splits$cv_subsamples_byD, + silent = TRUE + ), + "Deprecated split arguments detected" + ) + expect_equal(coef(fit_legacy), coef(fit_splits), tolerance = 1e-8) +}) diff --git a/tests/testthat/test-ddml_ate.R b/tests/testthat/test-ddml_ate.R index ceed2d4..e954e14 100644 --- a/tests/testthat/test-ddml_ate.R +++ b/tests/testthat/test-ddml_ate.R @@ -11,9 +11,9 @@ test_that("ddml_ate 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_ate_fit$ate), 1) + expect_equal(length(coef(ddml_ate_fit)), 1) })#TEST_THAT test_that("ddml_ate computes with stratify = FALSE", { @@ -30,9 +30,9 @@ test_that("ddml_ate computes with stratify = FALSE", { 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", { @@ -54,9 +54,9 @@ test_that("ddml_ate computes with a single model and dependence", { 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", { @@ -75,9 +75,9 @@ test_that("ddml_ate computes with an ensemble procedure", { 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", { @@ -98,9 +98,9 @@ test_that("ddml_ate 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_ate_fit$ate), 6) + expect_equal(length(coef(ddml_ate_fit)), 6) })#TEST_THAT test_that("ddml_ate computes with multiple ensemble procedures & shortstack", { @@ -120,9 +120,9 @@ test_that("ddml_ate computes with multiple ensemble procedures & shortstack", { 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", { @@ -138,13 +138,13 @@ test_that("summary.ddml_ate computes with a single model", { 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_s3_class(inf_res, "summary.ddml") - expect_equal(dim(inf_res$inf_results), c(1, 4, 1)) + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_ate computes with a single model and dependence", { @@ -166,13 +166,13 @@ test_that("summary.ddml_ate computes with a single model and dependence", { 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_s3_class(inf_res, "summary.ddml") - expect_equal(dim(inf_res$inf_results), c(1, 4, 1)) + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_ate computes with multiple ensemble procedures", { @@ -191,13 +191,13 @@ test_that("summary.ddml_ate computes with multiple ensemble procedures", { "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_s3_class(inf_res, "summary.ddml") - expect_equal(dim(inf_res$inf_results), c(1, 4, 4)) + expect_equal(dim(inf_res$coefficients), c(1, 4, 4)) })#TEST_THAT test_that("ddml_ate fitted pass-through works", { @@ -280,3 +280,31 @@ test_that("ddml_ate legacy grouped split args warn and still work", { ) expect_equal(coef(fit_legacy), coef(fit_splits), tolerance = 1e-8) }) + +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) +}) diff --git a/tests/testthat/test-ddml_att.R b/tests/testthat/test-ddml_att.R index 69a43ba..06342f0 100644 --- a/tests/testthat/test-ddml_att.R +++ b/tests/testthat/test-ddml_att.R @@ -11,9 +11,9 @@ test_that("ddml_att 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_att_fit$att), 1) + expect_equal(length(coef(ddml_att_fit)), 1) })#TEST_THAT test_that("ddml_att computes with stratify = FALSE", { @@ -30,9 +30,9 @@ test_that("ddml_att computes with stratify = FALSE", { stratify = FALSE, 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", { @@ -54,9 +54,9 @@ test_that("ddml_att computes with a single model and dependence", { 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", { @@ -75,9 +75,9 @@ test_that("ddml_att computes with an ensemble procedure", { 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", { @@ -98,9 +98,9 @@ test_that("ddml_att 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_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", { @@ -121,9 +121,9 @@ test_that("ddml_att computes w/ multp 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_att_fit$att), 4) + expect_equal(length(coef(ddml_att_fit)), 4) })#TEST_THAT test_that("summary.ddml_att computes with a single model", { @@ -139,13 +139,13 @@ test_that("summary.ddml_att computes with a single model", { 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_s3_class(inf_res, "summary.ddml") - expect_equal(dim(inf_res$inf_results), c(1, 4, 1)) + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_att computes with a single model and dependence", { @@ -167,13 +167,13 @@ test_that("summary.ddml_att computes with a single model and dependence", { 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_s3_class(inf_res, "summary.ddml") - expect_equal(dim(inf_res$inf_results), c(1, 4, 1)) + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_att computes with multiple ensemble procedures", { @@ -192,13 +192,13 @@ test_that("summary.ddml_att computes with multiple ensemble procedures", { "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_s3_class(inf_res, "summary.ddml") - expect_equal(dim(inf_res$inf_results), c(1, 4, 4)) + expect_equal(dim(inf_res$coefficients), c(1, 4, 4)) })#TEST_THAT test_that("ddml_att fitted pass-through works", { diff --git a/tests/testthat/test-ddml_fpliv.R b/tests/testthat/test-ddml_fpliv.R index 26826f9..df6e179 100644 --- a/tests/testthat/test-ddml_fpliv.R +++ b/tests/testthat/test-ddml_fpliv.R @@ -11,9 +11,9 @@ test_that("ddml_fpliv computes with a single model", { 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", { @@ -36,9 +36,9 @@ test_that("ddml_fpliv computes with a single model and dependence", { 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", { @@ -58,9 +58,9 @@ test_that("ddml_fpliv computes with an ensemble procedure", { 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) + expect_equal(length(coef(ddml_fpliv_fit)), 2) })#TEST_THAT test_that("ddml_fpliv computes with stacking w/o enforcing the LIE", { @@ -74,16 +74,15 @@ test_that("ddml_fpliv computes with stacking w/o enforcing the LIE", { # Define arguments learners <- list(list(what = ols), list(what = ols)) - # Compute LIE-conform DDML IV estimator + # Compute 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) + 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 multiple ensemble procedures", { @@ -104,10 +103,10 @@ test_that("ddml_fpliv 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_fpliv_fit$coef), 4) + expect_equal(length(coef(ddml_fpliv_fit)), 8) })#TEST_THAT test_that("ddml_fpliv computes with custom weights", { @@ -128,10 +127,10 @@ test_that("ddml_fpliv computes with 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_fpliv_fit$coef), 3) + expect_equal(length(coef(ddml_fpliv_fit)), 6) })#TEST_THAT test_that("ddml_fpliv computes with multiple ensembles w/o the LIE", { @@ -145,17 +144,16 @@ test_that("ddml_fpliv computes with multiple ensembles w/o the LIE", { # Define arguments learners <- list(list(what = ols), list(what = ols)) - # Compute LIE-conform DDML IV estimator + # 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, - enforce_LIE = FALSE, - 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 multiple ensembles and sparse matrices", { @@ -178,9 +176,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", { @@ -208,10 +206,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", { @@ -230,13 +228,13 @@ test_that("ddml_fpliv computes w/ ensembles & shortstack", { 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 ", { @@ -250,17 +248,16 @@ test_that("ddml_fpliv computes w/ ensembles & shortstack but w/o the LIE ", { # Define arguments learners <- list(list(what = ols), list(what = ols)) - # Compute LIE-conform DDML IV estimator + # 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, - enforce_LIE = FALSE, - 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("summary.ddml_fpliv computes with a single model", { @@ -276,12 +273,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) + silent = TRUE) inf_res <- summary(ddml_fpliv_fit) capture_output(print(inf_res), print = FALSE) # Check output with expectations expect_s3_class(inf_res, "summary.ddml") - expect_equal(dim(inf_res$inf_results), c(1, 4, 1)) + expect_equal(dim(inf_res$coefficients), c(2, 4, 1)) })#TEST_THAT test_that("ddml_fpliv computes with an ensemble procedure, multi D", { @@ -301,9 +298,9 @@ test_that("ddml_fpliv computes with an ensemble procedure, multi D", { ensemble_type = "ols", cv_folds = 3, sample_folds = 3, - 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 an ensemble procedure w/o LIE, multi D", { @@ -317,16 +314,15 @@ test_that("ddml_fpliv computes with an ensemble procedure w/o LIE, multi D", { # Define arguments learners <- list(list(what = ols), list(what = ols)) - # Compute LIE-conform DDML IV estimator + # 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", { @@ -349,9 +345,9 @@ test_that("ddml_fpliv computes with multiple ensemble procedures, multi D", { "singlebest", "average"), cv_folds = 3, sample_folds = 5, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 8) + expect_equal(length(coef(ddml_fpliv_fit)), 12) })#TEST_THAT test_that("ddml_fpliv computes with ensemble procedures w/o LIE, multi D", { @@ -365,17 +361,54 @@ test_that("ddml_fpliv computes with ensemble procedures w/o LIE, multi D", { # Define arguments learners <- list(list(what = ols), list(what = ols)) - # Compute LIE-conform DDML IV estimator + # 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, - enforce_LIE = F, - silent = T) + silent = TRUE) # Check output with expectations - expect_equal(length(ddml_fpliv_fit$coef), 8) + expect_equal(length(coef(ddml_fpliv_fit)), 12) +})#TEST_THAT + +test_that("ddml_fpliv HC0/HC1 SEs close to sandwich::vcovHC on iv_fit", { + skip_if_not_installed("sandwich") + 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) + + for (type in c("HC0", "HC1")) { + V_ddml <- vcov(fit, type = type) + V_sw <- sandwich::vcovHC(fit$iv_fit[[1]], 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(fit$iv_fit[[1]], 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", { @@ -390,36 +423,21 @@ test_that("ddml_fpliv fitted pass-through works", { fit <- ddml_fpliv(y, D, Z, X, learners = learners, ensemble_type = "average", - enforce_LIE = FALSE, sample_folds = 2, silent = TRUE) - fit2 <- ddml_fpliv(y, D, Z, X, learners = learners, ensemble_type = "average", - enforce_LIE = FALSE, sample_folds = 2, silent = TRUE, fitted = fit$fitted, splits = fit$splits) expect_equal(coef(fit2), coef(fit), tolerance = 1e-6) - # Pass-through blocked when enforce_LIE = TRUE - expect_error( - ddml_fpliv(y, D, Z, X, - learners = learners, - sample_folds = 2, - silent = TRUE, - fitted = fit$fitted, - splits = fit$splits), - "not currently supported when enforce_LIE = TRUE" - ) - # Error when fitted supplied without splits expect_error( ddml_fpliv(y, D, Z, X, learners = learners, - enforce_LIE = FALSE, sample_folds = 2, silent = TRUE, fitted = fit$fitted), diff --git a/tests/testthat/test-ddml_late.R b/tests/testthat/test-ddml_late.R index 7a53d7a..b3a84ab 100644 --- a/tests/testthat/test-ddml_late.R +++ b/tests/testthat/test-ddml_late.R @@ -13,9 +13,9 @@ test_that("ddml_late 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_late_fit$late), 1) + expect_equal(length(coef(ddml_late_fit)), 1) })#TEST_THAT test_that("ddml_late computes with stratify = FALSE", { @@ -34,9 +34,9 @@ test_that("ddml_late computes with stratify = FALSE", { stratify = FALSE, 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 and dependence", { @@ -60,9 +60,9 @@ test_that("ddml_late computes with a single model and dependence", { 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", { @@ -81,9 +81,9 @@ test_that("ddml_late computes with a single model & perfect non-compliance", { 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", { @@ -104,9 +104,9 @@ test_that("ddml_late computes with an ensemble procedure", { 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", { @@ -130,9 +130,9 @@ 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", { @@ -156,9 +156,9 @@ test_that("ddml_late computes with multiple ensemble procedures + perfect compli "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", { @@ -183,9 +183,9 @@ 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", { @@ -203,13 +203,13 @@ test_that("summary.ddml_late computes with a single model", { 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_s3_class(inf_res, "summary.ddml") - expect_equal(dim(inf_res$inf_results), c(1, 4, 1)) + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) })#TEST_THAT test_that("summary.ddml_late computes with a single model and dependence", { @@ -233,13 +233,13 @@ test_that("summary.ddml_late computes with a single model and dependence", { 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_s3_class(inf_res, "summary.ddml") - expect_equal(dim(inf_res$inf_results), c(1, 4, 1)) + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) })#TEST_THAT test_that("ddml_late fitted pass-through works", { @@ -278,3 +278,41 @@ test_that("ddml_late fitted pass-through works", { "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 5c0807b..89add5f 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", { @@ -59,9 +59,9 @@ test_that("ddml_pliv computes with an ensemble procedure", { 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", { @@ -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 @@ -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", { @@ -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 @@ -192,11 +192,11 @@ test_that("summary.ddml_pliv computes with custom ensemble weights", { 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", { @@ -240,9 +240,47 @@ 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") + 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) + + for (type in c("HC0", "HC1")) { + V_ddml <- vcov(fit, type = type) + V_sw <- sandwich::vcovHC(fit$iv_fit[[1]], 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(fit$iv_fit[[1]], 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", { diff --git a/tests/testthat/test-ddml_plm.R b/tests/testthat/test-ddml_plm.R index 560c0fb..f0494aa 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", { @@ -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", { @@ -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", { @@ -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 @@ -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", { @@ -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", { @@ -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,12 +191,12 @@ test_that("summary.ddml_plm computes with a single model", { learners = learners, cv_folds = 3, sample_folds = 3, - silent = T) + silent = TRUE) inf_res <- summary(ddml_plm_fit) capture_output(print(inf_res), print = FALSE) # Check output with expectations expect_s3_class(inf_res, "summary.ddml") - expect_equal(dim(inf_res$inf_results), c(1, 4, 1)) + expect_equal(dim(inf_res$coefficients), c(2, 4, 1)) })#TEST_THAT test_that("summary.ddml_plm computes with a single model and dependence", { @@ -206,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)) @@ -215,12 +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_s3_class(inf_res, "summary.ddml") - expect_equal(dim(inf_res$inf_results), c(1, 4, 1)) + expect_equal(dim(inf_res$coefficients), c(2, 4, 1)) })#TEST_THAT test_that("summary.ddml_plm computes with multiple ensemble procedures", { @@ -243,12 +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) + silent = TRUE) inf_res <- summary(ddml_plm_fit) capture_output(print(inf_res), print = FALSE) # Check output with expectations expect_s3_class(inf_res, "summary.ddml") - expect_equal(dim(inf_res$inf_results), c(1, 4, 7)) + expect_equal(dim(inf_res$coefficients), c(2, 4, 7)) })#TEST_THAT test_that("ddml_plm computes with an ensemble procedure and multivariate D", { @@ -268,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", { @@ -292,9 +292,9 @@ 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 backward-compat cv_subsamples_list works with message", { @@ -343,7 +343,7 @@ test_that("ddml_plm computes with parallel", { splits = list(subsamples = splits$subsamples), silent = TRUE, parallel = list(cores = 2)) - expect_equal(res_par$coef, res_seq$coef) + expect_equal(coef(res_par), coef(res_seq)) })#TEST_THAT test_that("ddml_plm fitted pass-through works", { @@ -506,6 +506,41 @@ test_that("ddml_plm pass-through with save_crossval = FALSE uses approximate pat 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) + + for (type in c("HC0", "HC1")) { + V_ddml <- vcov(fit, type = type) + V_sw <- sandwich::vcovHC(fit$ols_fit[[1]], 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(fit$ols_fit[[1]], 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 + test_that("ddml_plm legacy split args warn and still work", { set.seed(101) nobs <- 200 diff --git a/tests/testthat/test-ddml_rep.R b/tests/testthat/test-ddml_rep.R index afbab89..bcc078b 100644 --- a/tests/testthat/test-ddml_rep.R +++ b/tests/testthat/test-ddml_rep.R @@ -104,25 +104,25 @@ test_that("coef, vcov, confint work on ddml_rep", { resamples = 3, silent = TRUE) - # coef + # coef (D + intercept = 2 elements) cf <- coef(reps) expect_true(is.numeric(cf)) - expect_length(cf, 1) + expect_length(cf, 2) # coef with mean aggregation differs from median cf_mean <- coef(reps, aggregation = "mean") expect_true(is.numeric(cf_mean)) - # Aggregated coef is within range of per-resample coefs + # Aggregated D coef is within range of per-resample D coefs per_rep_coefs <- sapply(seq_len(3), - function(i) coef(reps[[i]])) - expect_true(cf >= min(per_rep_coefs) - 0.01) - expect_true(cf <= max(per_rep_coefs) + 0.01) + 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(1, 1)) + expect_equal(dim(V), c(2, 2)) expect_true(V[1, 1] > 0) # vcov names @@ -132,7 +132,7 @@ test_that("coef, vcov, confint work on ddml_rep", { # confint ci <- confint(reps) expect_true(is.matrix(ci)) - expect_equal(dim(ci), c(1, 2)) + expect_equal(dim(ci), c(2, 2)) expect_identical(colnames(ci), c(" 2.5 %", "97.5 %")) expect_true(ci[1, 1] < ci[1, 2]) @@ -164,8 +164,8 @@ test_that("summary and print work on ddml_rep", { expect_equal(s$nobs, nobs) expect_equal(s$nresamples, 3) expect_equal(s$aggregation, "median") - expect_true(is.array(s$inf_results)) - expect_equal(dim(s$inf_results)[2], 4) + expect_true(is.array(s$coefficients)) + expect_equal(dim(s$coefficients)[2], 4) # summary with mean aggregation s_mean <- summary(reps, aggregation = "mean") @@ -252,41 +252,48 @@ test_that("aggregation formulas are correct", { resamples = 5, silent = TRUE) - # Extract per-resample coefs and SEs manually + # Extract per-resample coefs and SEs manually (p x R matrices) R <- 5 coefs <- sapply(seq_len(R), function(i) coef(reps[[i]])) ses <- sapply(seq_len(R), function(i) { V <- vcov(reps[[i]]) sqrt(diag(V)) }) + p <- nrow(coefs) - # Median aggregation - expected_coef_med <- median(coefs) - var_total_med <- ses^2 + (coefs - expected_coef_med)^2 - expected_se_med <- sqrt(median(var_total_med)) + # Median aggregation (per coefficient) + expected_coef_med <- apply(coefs, 1, median) + var_total_med <- ses^2 + + (coefs - expected_coef_med)^2 + expected_se_med <- sqrt(apply(var_total_med, 1, median)) actual_coef_med <- coef(reps, aggregation = "median") s_med <- summary(reps, aggregation = "median") - actual_se_med <- s_med$inf_results[1, 2, 1] + actual_se_med <- s_med$coefficients[, 2, 1] - expect_equal(actual_coef_med, expected_coef_med, + expect_equal(unname(actual_coef_med), + unname(expected_coef_med), tolerance = 1e-10) - expect_equal(actual_se_med, expected_se_med, + expect_equal(unname(actual_se_med), + unname(expected_se_med), tolerance = 1e-10) - # Mean aggregation - expected_coef_mean <- mean(coefs) - var_total_mean <- ses^2 + (coefs - expected_coef_mean)^2 + # Mean aggregation (per coefficient) + expected_coef_mean <- rowMeans(coefs) + var_total_mean <- ses^2 + + (coefs - expected_coef_mean)^2 expected_se_mean <- sqrt( - length(var_total_mean) / sum(1 / var_total_mean)) + R / rowSums(1 / var_total_mean)) actual_coef_mean <- coef(reps, aggregation = "mean") s_mean <- summary(reps, aggregation = "mean") - actual_se_mean <- s_mean$inf_results[1, 2, 1] + actual_se_mean <- s_mean$coefficients[, 2, 1] - expect_equal(actual_coef_mean, expected_coef_mean, + expect_equal(unname(actual_coef_mean), + unname(expected_coef_mean), tolerance = 1e-10) - expect_equal(actual_se_mean, expected_se_mean, + expect_equal(unname(actual_se_mean), + unname(expected_se_mean), tolerance = 1e-10) }) diff --git a/tests/testthat/test-inference_functions.R b/tests/testthat/test-inference_functions.R index b023e36..55d51b4 100644 --- a/tests/testthat/test-inference_functions.R +++ b/tests/testthat/test-inference_functions.R @@ -66,85 +66,65 @@ test_that("HC1 equals HC0 scaled by n/(n-p)", { expect_equal(V_hc1, V_hc0 * nobs / (nobs - p)) }) -test_that("compute_ddml_variance computes HC3 correctly", { +test_that("compute_ddml_variance computes HC3 correctly with leverage", { set.seed(42) nobs <- 100 p <- 2 scores <- matrix(rnorm(nobs * p), nobs, p) J <- diag(2, p) + h <- rep(p / nobs, nobs) - # Manual HC3 computation - PtP_inv <- solve(crossprod(scores)) - h <- rowSums((scores %*% PtP_inv) * scores) sc_adj <- scores / (1 - h) meat <- crossprod(sc_adj) / nobs J_inv <- solve(J) expected_v <- J_inv %*% meat %*% t(J_inv) / nobs - V <- compute_ddml_variance(scores, J, type = "HC3") + V <- compute_ddml_variance(scores, J, type = "HC3", + leverage = h) + expect_true(is.matrix(V)) + expect_equal(dim(V), c(p, p)) expect_equal(V, expected_v) }) -test_that("HC3 leverage has correct properties", { +test_that("HC3 with hat-matrix leverage matches manual computation", { set.seed(42) nobs <- 200 p <- 3 - scores <- matrix(rnorm(nobs * p), nobs, p) - - PtP_inv <- solve(crossprod(scores)) - h <- rowSums((scores %*% PtP_inv) * scores) + X <- matrix(rnorm(nobs * p), nobs, p) + h <- rowSums((X %*% solve(crossprod(X))) * X) - # Sum of leverages equals p expect_equal(sum(h), p, tolerance = 1e-10) - - # All leverages in [0, 1] expect_true(all(h >= 0)) expect_true(all(h < 1)) - - # Average leverage = p/n expect_equal(mean(h), p / nobs, tolerance = 1e-10) }) -test_that("HC3 leverage for scalar scores", { - set.seed(42) - nobs <- 100 - scores <- matrix(rnorm(nobs), nobs, 1) - - PtP_inv <- solve(crossprod(scores)) - h <- rowSums((scores %*% PtP_inv) * scores) - - # For p=1: h_i = psi_i^2 / sum(psi_j^2) - expected_h <- as.vector(scores^2) / sum(scores^2) - expect_equal(h, expected_h, tolerance = 1e-10) - expect_equal(sum(h), 1) -}) - -test_that("HC3 with cluster aggregation", { +test_that("HC3 with cluster aggregation and leverage", { set.seed(42) nobs <- 100 p <- 2 scores <- matrix(rnorm(nobs * p), nobs, p) J <- diag(2, p) cluster_var <- rep(1:50, each = 2) + h_obs <- rep(p / nobs, nobs) V <- compute_ddml_variance( scores, J, cluster_variable = cluster_var, - type = "HC3") + type = "HC3", + leverage = h_obs) - # Manual: aggregate scores first, then HC3 on aggregated + # Manual: aggregate scores and leverage to cluster level sc_sum <- rowsum(scores, cluster_var) + h_clust <- as.vector(tapply(h_obs, cluster_var, sum)) n_eff <- 50 - PtP_inv <- solve(crossprod(sc_sum)) - h <- rowSums((sc_sum %*% PtP_inv) * sc_sum) - sc_adj <- sc_sum / (1 - h) + sc_adj <- sc_sum / (1 - h_clust) meat <- crossprod(sc_adj) / n_eff J_inv <- solve(J) expected_v <- J_inv %*% meat %*% t(J_inv) / n_eff expect_equal(V, expected_v) - expect_equal(sum(h), p, tolerance = 1e-10) }) test_that("type rejects invalid values", { @@ -162,13 +142,14 @@ test_that("HC3 >= HC1 >= HC0 for typical data", { p <- 1 scores <- matrix(rnorm(nobs * p), nobs, p) J <- matrix(-1, 1, 1) + h <- rep(p / nobs, nobs) se_hc0 <- sqrt(diag(compute_ddml_variance( scores, J, type = "HC0"))) se_hc1 <- sqrt(diag(compute_ddml_variance( scores, J, type = "HC1"))) se_hc3 <- sqrt(diag(compute_ddml_variance( - scores, J, type = "HC3"))) + scores, J, type = "HC3", leverage = h))) expect_true(all(se_hc1 >= se_hc0)) expect_true(all(se_hc3 >= se_hc0)) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index e9fc733..6384437 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -35,6 +35,12 @@ test_that("standard S3 generic methods work correctly", { 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)) @@ -72,13 +78,13 @@ test_that("type argument threads through S3 methods", { expect_equal(s3$type, "HC3") # HC0 SEs < HC1 SEs (dof correction) - se_hc0 <- s0$inf_results[1, 2, 1] - se_hc1 <- s1$inf_results[1, 2, 1] + 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$inf_results[, 1, ], s1$inf_results[, 1, ]) - expect_equal(s0$inf_results[, 1, ], s3$inf_results[, 1, ]) + 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") @@ -112,6 +118,6 @@ test_that("type works with PLM estimator", { V_hc3 <- vcov(fit, type = "HC3") expect_true(is.matrix(V_hc3)) - expect_equal(dim(V_hc3), c(1, 1)) + expect_equal(dim(V_hc3), c(2, 2)) expect_true(V_hc1[1, 1] > V_hc0[1, 1]) }) diff --git a/tests/testthat/test-tidy.R b/tests/testthat/test-tidy.R index 35cb5d9..6bc5bc1 100644 --- a/tests/testthat/test-tidy.R +++ b/tests/testthat/test-tidy.R @@ -90,7 +90,7 @@ test_that("tidy works with PLM (multi-covariate D)", { td <- tidy(fit) expect_s3_class(td, "data.frame") - expect_equal(nrow(td), 1) + expect_equal(nrow(td), 2) expect_true("term" %in% colnames(td)) gl <- glance(fit) diff --git a/vignettes/articles/did.Rmd b/vignettes/articles/did.Rmd index b38558f..e463f44 100644 --- a/vignettes/articles/did.Rmd +++ b/vignettes/articles/did.Rmd @@ -1,6 +1,6 @@ --- title: "Diff-in-Diff with Double/Debiased Machine Learning" -description: "Tutorial on difference-in-difference estimation with double/debiased machine learning." +description: "Tutorial on difference-in-difference estimation with Double/Debiased Machine Learning." output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Diff-in-Diff with Double/Debiased Machine Learning} @@ -14,7 +14,7 @@ vignette: > 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. -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). See also Ahrens et al. (2026) for an example of staggered differences-in-differences estimated with ddml. +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). See also Ahrens et al. (2026) for an example of staggered differences-in-differences estimated with ddml. # Estimation using ``did``'s Default Estimator diff --git a/vignettes/articles/did.Rmd.txt b/vignettes/articles/did.Rmd.txt index b3c4f69..cb7a9c2 100644 --- a/vignettes/articles/did.Rmd.txt +++ b/vignettes/articles/did.Rmd.txt @@ -1,6 +1,6 @@ --- title: "Diff-in-Diff with Double/Debiased Machine Learning" -description: "Tutorial on difference-in-difference estimation with double/debiased machine learning." +description: "Tutorial on difference-in-difference estimation with Double/Debiased Machine Learning." output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Diff-in-Diff with Double/Debiased Machine Learning} @@ -23,7 +23,7 @@ knitr::opts_chunk$set( 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. -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). See also Ahrens et al. (2026) for an example of staggered differences-in-differences estimated with ddml. +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). See also Ahrens et al. (2026) for an example of staggered differences-in-differences estimated with ddml. # Estimation using ``did``'s Default Estimator diff --git a/vignettes/articles/example_401k.Rmd b/vignettes/articles/example_401k.Rmd index 0c8295a..2fa5e3f 100644 --- a/vignettes/articles/example_401k.Rmd +++ b/vignettes/articles/example_401k.Rmd @@ -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. @@ -145,14 +145,8 @@ 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. ```r -sapply(stacking_fit$weights, round, 4) -#> y_X D1_X -#> [1,] 0.2394 0.2865 -#> [2,] 0.0000 0.0000 -#> [3,] 0.1096 0.1720 -#> [4,] 0.7020 0.5387 -#> [5,] 0.0383 0.0164 -#> [6,] 0.0000 0.0000 +sapply(stacking_fit$ensemble_weights, round, 4) +#> list() ``` # Estimation with Different Sets of Control Variables @@ -219,22 +213,15 @@ To assess whether the additional effort in expanding the control variables had a ```r -sapply(stacking_fit$weights, round, 4) -#> y_X D1_X -#> [1,] 0.0000 0.0968 -#> [2,] 0.0000 0.3466 -#> [3,] 0.7371 0.0000 -#> [4,] 0.1001 0.1537 -#> [5,] 0.1557 0.3304 -#> [6,] 0.0662 0.0483 -#> [7,] 0.0000 0.0333 +sapply(stacking_fit$ensemble_weights, round, 4) +#> list() ``` # 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 @@ -286,15 +273,8 @@ The weights associated with the new base learners are now slightly larger: ```r -sapply(stacking_fit$weights, round, 4) -#> y_X D1_X -#> [1,] 0.0974 0.0426 -#> [2,] 0.0000 0.3245 -#> [3,] 0.7681 0.0000 -#> [4,] 0.0000 0.1538 -#> [5,] 0.1674 0.4265 -#> [6,] 0.0000 0.0622 -#> [7,] 0.0000 0.0000 +sapply(stacking_fit$ensemble_weights, round, 4) +#> list() ``` # Advanced: Rapid Refits with the Passthrough API @@ -358,15 +338,8 @@ summary(stacking_IV_fit) #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 # Stacking weights associated with each base learner -sapply(stacking_IV_fit$weights, round, 4) -#> y_X D1_X Z1_X -#> [1,] 0.0236 0.0439 0.0000 -#> [2,] 0.5938 0.3279 0.3792 -#> [3,] 0.1051 0.0620 0.0000 -#> [4,] 0.0000 0.0000 0.0387 -#> [5,] 0.3113 0.5625 0.5855 -#> [6,] 0.0000 0.0000 0.0000 -#> [7,] 0.0000 0.0077 0.0000 +sapply(stacking_IV_fit$ensemble_weights, round, 4) +#> list() ``` diff --git a/vignettes/articles/example_401k.Rmd.txt b/vignettes/articles/example_401k.Rmd.txt index e46b262..d5a2087 100644 --- a/vignettes/articles/example_401k.Rmd.txt +++ b/vignettes/articles/example_401k.Rmd.txt @@ -55,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. @@ -106,7 +106,7 @@ 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. ```{r} -sapply(stacking_fit$weights, round, 4) +sapply(stacking_fit$ensemble_weights, round, 4) ``` # Estimation with Different Sets of Control Variables @@ -163,14 +163,14 @@ 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. ```{r} -sapply(stacking_fit$weights, round, 4) +sapply(stacking_fit$ensemble_weights, round, 4) ``` # 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] @@ -213,7 +213,7 @@ The weights associated with the new base learners are now slightly larger: ```{r} -sapply(stacking_fit$weights, round, 4) +sapply(stacking_fit$ensemble_weights, round, 4) ``` # Advanced: Rapid Refits with the Passthrough API @@ -266,7 +266,7 @@ stacking_IV_fit <- ddml_pliv(y = y, D = D, Z = Z, X = X_c, summary(stacking_IV_fit) # Stacking weights associated with each base learner -sapply(stacking_IV_fit$weights, round, 4) +sapply(stacking_IV_fit$ensemble_weights, round, 4) ``` diff --git a/vignettes/articles/example_BLP95.Rmd b/vignettes/articles/example_BLP95.Rmd index fa7275b..1ffe28c 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 @@ -222,14 +222,8 @@ To better understand the composition of the final estimator, it is often useful ```r -sapply(stacking_fit$weights, round, 4) -#> y_X D1_X D1_XZ -#> [1,] 0.0000 0.0000 0.0000 -#> [2,] 0.0000 0.0000 0.0000 -#> [3,] 0.0000 0.0000 0.0000 -#> [4,] 0.0000 0.0138 0.0000 -#> [5,] 0.3786 0.5434 0.4844 -#> [6,] 0.6214 0.4429 0.5156 +sapply(stacking_fit$ensemble_weights, round, 4) +#> list() ``` # Elasticities @@ -259,7 +253,7 @@ 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 initial 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 @@ -291,7 +285,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/debiased 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. @@ -304,7 +298,7 @@ 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/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. +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 @@ -335,13 +329,11 @@ The similarity of the coefficient estimates to the initial stacking estimates su ```r -sapply(stacking_r_fit$weights, round, 4) -#> y_X D1_X D1_XZ -#> [1,] 0.2647 0.1262 0.0555 -#> [2,] 0.7353 0.8738 0.9445 +sapply(stacking_r_fit$ensemble_weights, round, 4) +#> list() ``` -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 57beddd..1662fff 100644 --- a/vignettes/articles/example_BLP95.Rmd.txt +++ b/vignettes/articles/example_BLP95.Rmd.txt @@ -25,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. @@ -127,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 @@ -195,7 +195,7 @@ Interestingly, the coefficient is closer to the OLS estimates than to the TSLS e 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. ```{r} -sapply(stacking_fit$weights, round, 4) +sapply(stacking_fit$ensemble_weights, round, 4) ``` # Elasticities @@ -219,7 +219,7 @@ 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 initial 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) @@ -242,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/debiased 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. @@ -252,7 +252,7 @@ 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/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. +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 @@ -274,10 +274,10 @@ 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. ```{r} -sapply(stacking_r_fit$weights, round, 4) +sapply(stacking_r_fit$ensemble_weights, round, 4) ``` -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/repeated_resampling.Rmd b/vignettes/articles/repeated_resampling.Rmd index a06b4f7..d0fbfd7 100644 --- a/vignettes/articles/repeated_resampling.Rmd +++ b/vignettes/articles/repeated_resampling.Rmd @@ -218,6 +218,8 @@ This flexibility allows ``ddml`` to scale efficiently from local laptops to mass # 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 f2f0479..c5e7da1 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 @@ -165,12 +165,8 @@ The resulting coefficient is close to the coefficient based on 180 instruments. ```r -round(stacking_fit$weights$D1_XZ, 4) -#> nnls1 -#> [1,] 0.7409 -#> [2,] 0.0000 -#> [3,] 0.2591 -#> [4,] 0.0000 +round(stacking_fit$ensemble_weights$D1_XZ, 4) +#> Error in round(stacking_fit$ensemble_weights$D1_XZ, 4): non-numeric argument to mathematical function ``` # References diff --git a/vignettes/articles/sparse.Rmd.txt b/vignettes/articles/sparse.Rmd.txt index 9d91470..ba9892c 100644 --- a/vignettes/articles/sparse.Rmd.txt +++ b/vignettes/articles/sparse.Rmd.txt @@ -20,7 +20,7 @@ knitr::opts_chunk$set( # 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) @@ -143,7 +143,7 @@ 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. ```{r} -round(stacking_fit$weights$D1_XZ, 4) +round(stacking_fit$ensemble_weights$D1_XZ, 4) ``` # References diff --git a/vignettes/articles/stacking.Rmd b/vignettes/articles/stacking.Rmd index 98f85ae..67a91f5 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 @@ -77,16 +77,16 @@ time_stacking <- system.time({ })#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: 1.97 +#> Time single learner: 1.75 cat("Time short-stacking:", time_shortstacking[1], "\n") -#> Time short-stacking: 4.23 +#> Time short-stacking: 3.93 cat("Time stacking: ", time_stacking[1]) -#> Time stacking: 26.36 +#> Time stacking: 17.29 ``` # References diff --git a/vignettes/articles/stacking.Rmd.txt b/vignettes/articles/stacking.Rmd.txt index d61c833..314dff6 100644 --- a/vignettes/articles/stacking.Rmd.txt +++ b/vignettes/articles/stacking.Rmd.txt @@ -20,7 +20,7 @@ knitr::opts_chunk$set( # 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 @@ -83,7 +83,7 @@ time_stacking <- system.time({ })#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 index 15fe83e..f3dccef 100644 --- a/vignettes/articles/stacking_diagnostics.Rmd +++ b/vignettes/articles/stacking_diagnostics.Rmd @@ -12,7 +12,7 @@ vignette: > # 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. +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? @@ -205,6 +205,8 @@ cvc_pairwise(resids, 1, 2, fold_ids) # 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. diff --git a/vignettes/articles/stacking_diagnostics.Rmd.txt b/vignettes/articles/stacking_diagnostics.Rmd.txt index 826b883..c96023e 100644 --- a/vignettes/articles/stacking_diagnostics.Rmd.txt +++ b/vignettes/articles/stacking_diagnostics.Rmd.txt @@ -20,7 +20,7 @@ knitr::opts_chunk$set( # 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. +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? diff --git a/vignettes/ddml.Rmd b/vignettes/ddml.Rmd index 78953a5..489e31e 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,7 +13,7 @@ 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 @@ -39,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. @@ -51,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. @@ -85,7 +85,7 @@ learners_multiple <- list(list(what = ols), 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. @@ -221,7 +221,7 @@ Beyond ``ddml_late`` and ``ddml_plm``, the package supports several other causal # 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): +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 diff --git a/vignettes/ddml.Rmd.txt b/vignettes/ddml.Rmd.txt index eb3e258..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} @@ -21,7 +21,7 @@ knitr::opts_chunk$set( # 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 @@ -46,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. @@ -57,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, @@ -84,7 +84,7 @@ learners_multiple <- list(list(what = ols), 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. @@ -154,7 +154,7 @@ Beyond ``ddml_late`` and ``ddml_plm``, the package supports several other causal # 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): +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, From d692817e815e043db9719820afdebcb59af9650a Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Fri, 6 Mar 2026 07:58:18 -0600 Subject: [PATCH 16/46] Update _pkgdown.yml --- _pkgdown.yml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/_pkgdown.yml b/_pkgdown.yml index 8425ca1..84c6972 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -38,11 +38,12 @@ reference: - title: Supported Models contents: - ddml_plm - - ddml_ate - - ddml_att - ddml_pliv - ddml_fpliv + - ddml_ate + - ddml_att - ddml_late + - ddml_apo - title: Repeated Resampling contents: - ddml_replicate From 9cbd8af62108e34090d5ae1ccdc02bb902a50e17 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Fri, 6 Mar 2026 08:28:29 -0600 Subject: [PATCH 17/46] bump version to 0.9 --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3336eea..f3d850b 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"), diff --git a/NEWS.md b/NEWS.md index 889169b..5c55d93 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# ddml 0.3.1 +# ddml 0.9.0 * Adds `ddml_apo()` for average potential outcome estimation. * Adds `fitted` and `splits` parameters to all `ddml_*()` estimators for re-estimation with different ensemble types without re-fitting base learners. From 5afc56d321bec9757c63f7b1c9299ee4de07f838 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Fri, 6 Mar 2026 11:02:08 -0600 Subject: [PATCH 18/46] median agg in spectral norm --- DESCRIPTION | 1 + R/ddml_rep.R | 184 ++++++++++++++++++++++++++------- tests/testthat/test-ddml_rep.R | 177 ++++++++++++++++++++++++------- 3 files changed, 290 insertions(+), 72 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index f3d850b..15274d7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -37,6 +37,7 @@ Imports: generics Suggests: covr, + CVXR, knitr, parallel, rmarkdown, diff --git a/R/ddml_rep.R b/R/ddml_rep.R index f715fd0..d95c1f9 100644 --- a/R/ddml_rep.R +++ b/R/ddml_rep.R @@ -24,15 +24,68 @@ build_inf_from_agg <- function(agg, coef_names, inf_results }#BUILD_INF_FROM_AGG -# Core aggregation workhorse (Ahrens et al., 2024, Remark 2). +# 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") + }#FOR + + result <- CVXR::solve(CVXR::Problem(CVXR::Minimize(obj))) + + if (result$status != "optimal") { + warning("SDP solver returned status '", + result$status, + "'; falling back to element-wise median.", + call. = FALSE) + arr <- array( + unlist(lapply(matrices, as.vector)), + dim = c(p, p, R)) + return(apply(arr, c(1, 2), stats::median)) + }#IF + + V_sol <- result$getValue(V) + (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 then 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")) + c("median", "mean", + "spectral")) R <- object$nresamples nensb <- length(object$ensemble_type) p <- length(object$coef_names) + # == Collect per-replication estimates == coef_array <- array(0, dim = c(p, nensb, R)) vcov_array <- array(0, dim = c(p, p, nensb, R)) for (r in seq_len(R)) { @@ -49,29 +102,39 @@ aggregate_reps <- function(object, aggregation = "median", }#FOR }#FOR - agg_vcov <- array(0, dim = c(p, p, nensb)) - if (aggregation == "median") { - agg_coef <- apply(coef_array, c(1, 2), - stats::median) - } else { + # == 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, nensb)) + for (j in seq_len(nensb)) { - for (k1 in seq_len(p)) { - for (k2 in seq_len(p)) { - bdiff_1 <- coef_array[k1, j, ] - agg_coef[k1, j] - bdiff_2 <- coef_array[k2, j, ] - agg_coef[k2, j] - Vvec <- vcov_array[k1, k2, j, ] + abs(bdiff_1 * bdiff_2) - if (aggregation == "median") { - agg_vcov[k1, k2, j] <- stats::median(Vvec) - } else { - agg_vcov[k1, k2, j] <- length(Vvec) / sum(1 / Vvec) - }#IFELSE - }#FOR + 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 = nensb) for (j in seq_len(nensb)) { V_j <- matrix(agg_vcov[, , j, drop = FALSE], @@ -332,8 +395,9 @@ print.ddml_rep <- function(x, ...) { #' Extract Aggregated Coefficients from a ddml_rep Object #' #' @param object A \code{ddml_rep} object. -#' @param aggregation Character string, either -#' \code{"median"} (default) or \code{"mean"}. +#' @param aggregation Character string: \code{"median"} +#' (default), \code{"mean"}, or \code{"spectral"}. +#' See \code{\link{summary.ddml_rep}} for details. #' @param ... Additional arguments. #' #' @return Named vector (single ensemble) or matrix @@ -352,11 +416,15 @@ print.ddml_rep <- function(x, ...) { #' coef(reps, aggregation = "mean") #' } #' +#' @seealso \code{\link{summary.ddml_rep}} for the +#' aggregation equations. +#' #' @export #' @method coef ddml_rep coef.ddml_rep <- function(object, aggregation = c("median", - "mean"), + "mean", + "spectral"), ...) { aggregation <- match.arg(aggregation) agg <- aggregate_reps(object, @@ -376,8 +444,7 @@ coef.ddml_rep <- function(object, #' @param object A \code{ddml_rep} object. #' @param ensemble_idx Integer index of the ensemble type. #' Defaults to 1. -#' @param aggregation Character string, either -#' \code{"median"} (default) or \code{"mean"}. +#' @inheritParams coef.ddml_rep #' @param type Character string specifying the #' variance-covariance estimator. One of \code{"HC1"} #' (default), \code{"HC0"}, or \code{"HC3"}. @@ -397,11 +464,15 @@ coef.ddml_rep <- function(object, #' vcov(reps) #' } #' +#' @seealso \code{\link{summary.ddml_rep}} for the +#' aggregation equations. +#' #' @export #' @method vcov ddml_rep vcov.ddml_rep <- function(object, ensemble_idx = 1, aggregation = c("median", - "mean"), + "mean", + "spectral"), type = "HC1", ...) { aggregation <- match.arg(aggregation) agg <- aggregate_reps(object, @@ -423,8 +494,7 @@ vcov.ddml_rep <- function(object, ensemble_idx = 1, #' @param level Confidence level. Default 0.95. #' @param ensemble_idx Integer index of the ensemble type. #' Defaults to 1. -#' @param aggregation Character string, either -#' \code{"median"} (default) or \code{"mean"}. +#' @inheritParams coef.ddml_rep #' @param type Character string specifying the #' variance-covariance estimator. One of \code{"HC1"} #' (default), \code{"HC0"}, or \code{"HC3"}. @@ -445,13 +515,17 @@ vcov.ddml_rep <- function(object, ensemble_idx = 1, #' confint(reps, level = 0.90) #' } #' +#' @seealso \code{\link{summary.ddml_rep}} for the +#' aggregation equations. +#' #' @export #' @method confint ddml_rep confint.ddml_rep <- function(object, parm, level = 0.95, ensemble_idx = 1, aggregation = c("median", - "mean"), + "mean", + "spectral"), type = "HC1", ...) { aggregation <- match.arg(aggregation) agg <- aggregate_reps(object, @@ -469,9 +543,41 @@ confint.ddml_rep <- function(object, parm, #' Summary for ddml_rep Objects #' +#' Aggregates coefficient estimates and covariance matrices +#' across \eqn{R} independent sample-splitting replications. +#' +#' @details +#' Let \eqn{\hat\theta_r} and \eqn{\hat\Sigma_r} denote +#' the coefficient vector and sandwich covariance matrix +#' from replication \eqn{r}. +#' +#' \strong{Coefficient aggregation.} +#' For \code{"mean"}: +#' \eqn{\tilde\theta = R^{-1} \sum_{r=1}^{R} \hat\theta_r}. +#' For \code{"median"} and \code{"spectral"}: +#' \eqn{\tilde\theta_j = \mathrm{median}_{r}(\hat\theta_{r,j})}. +#' +#' \strong{Covariance aggregation.} +#' Define the inflated per-replication covariance as +#' \deqn{V_r = \hat\Sigma_r + (\hat\theta_r - \tilde\theta) +#' (\hat\theta_r - \tilde\theta)^\top}. +#' For \code{"mean"}: +#' \eqn{\tilde\Sigma = R^{-1} \sum_{r=1}^{R} V_r}. +#' For \code{"median"}: +#' \eqn{\tilde\Sigma_{ij} = \mathrm{median}_{r}(V_{r,ij})}. +#' For \code{"spectral"}: +#' \eqn{\tilde\Sigma = \arg\min_{\Sigma \succeq 0} \sum_{r} \|\Sigma - V_r\|_2}, +#' solved via \pkg{CVXR}. Guarantees positive semi-definiteness of \eqn{\tilde\Sigma}. +#' +#' @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, either -#' \code{"median"} (default) or \code{"mean"}. +#' @inheritParams coef.ddml_rep #' @param type Character string specifying the #' variance-covariance estimator. One of \code{"HC1"} #' (default), \code{"HC0"}, or \code{"HC3"}. @@ -496,7 +602,8 @@ confint.ddml_rep <- function(object, parm, #' @method summary ddml_rep summary.ddml_rep <- function(object, aggregation = c("median", - "mean"), + "mean", + "spectral"), type = "HC1", ...) { aggregation <- match.arg(aggregation) type <- match.arg(type, c("HC0", "HC1", "HC3")) @@ -578,8 +685,7 @@ print.summary.ddml_rep <- function(x, digits = 3, ...) { #' @param ensemble_idx Integer index of the ensemble type #' to report. Defaults to 1. Set to \code{NULL} to #' return results for all ensemble types. -#' @param aggregation Character string, either -#' \code{"median"} (default) or \code{"mean"}. +#' @inheritParams coef.ddml_rep #' @param type Character string specifying the #' variance-covariance estimator. One of \code{"HC1"} #' (default), \code{"HC0"}, or \code{"HC3"}. @@ -591,9 +697,9 @@ print.summary.ddml_rep <- function(x, digits = 3, ...) { #' #' @return A \code{data.frame} with columns \code{term}, #' \code{estimate}, \code{std.error}, \code{statistic}, -#' \code{p.value}, and \code{ensemble_type}. If -#' \code{conf.int = TRUE}, also \code{conf.low} and -#' \code{conf.high}. +#' \code{p.value}, \code{ensemble_type}, and +#' \code{aggregation}. If \code{conf.int = TRUE}, +#' also \code{conf.low} and \code{conf.high}. #' #' @examples #' \donttest{ @@ -608,15 +714,20 @@ print.summary.ddml_rep <- function(x, digits = 3, ...) { #' tidy(reps, conf.int = TRUE) #' } #' +#' @seealso \code{\link{summary.ddml_rep}} for the +#' aggregation equations. +#' #' @family ddml #' @export #' @method tidy ddml_rep tidy.ddml_rep <- function(x, ensemble_idx = 1, aggregation = c("median", - "mean"), + "mean", + "spectral"), type = "HC1", conf.int = FALSE, conf.level = 0.95, ...) { + aggregation <- match.arg(aggregation) s <- summary(x, aggregation = aggregation, type = type) inf <- s$coefficients @@ -639,6 +750,7 @@ tidy.ddml_rep <- function(x, ensemble_idx = 1, statistic = inf[k, 3, j], p.value = inf[k, 4, j], ensemble_type = dimnames(inf)[[3]][j], + aggregation = aggregation, stringsAsFactors = FALSE ) if (conf.int) { diff --git a/tests/testthat/test-ddml_rep.R b/tests/testthat/test-ddml_rep.R index bcc078b..f247a5c 100644 --- a/tests/testthat/test-ddml_rep.R +++ b/tests/testthat/test-ddml_rep.R @@ -211,9 +211,10 @@ test_that("tidy and glance work on ddml_rep", { 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") - %in% colnames(td))) + "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) @@ -228,6 +229,7 @@ test_that("tidy and glance work on ddml_rep", { # 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) @@ -238,65 +240,168 @@ test_that("tidy and glance work on ddml_rep", { expect_equal(gl$model_type, "ddml_ate") }) -test_that("aggregation formulas are correct", { +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 = 5, + resamples = R, silent = TRUE) - # Extract per-resample coefs and SEs manually (p x R matrices) - R <- 5 - coefs <- sapply(seq_len(R), function(i) coef(reps[[i]])) - ses <- sapply(seq_len(R), function(i) { - V <- vcov(reps[[i]]) - sqrt(diag(V)) - }) + coefs <- sapply(seq_len(R), + function(i) coef(reps[[i]])) + vcovs <- lapply(seq_len(R), + function(i) vcov(reps[[i]])) p <- nrow(coefs) - # Median aggregation (per coefficient) - expected_coef_med <- apply(coefs, 1, median) - var_total_med <- ses^2 + - (coefs - expected_coef_med)^2 - expected_se_med <- sqrt(apply(var_total_med, 1, median)) + # theta_tilde = coordinate-wise median + expected_coef <- apply(coefs, 1, median) - actual_coef_med <- coef(reps, aggregation = "median") - s_med <- summary(reps, aggregation = "median") - actual_se_med <- s_med$coefficients[, 2, 1] + # 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) + }) - expect_equal(unname(actual_coef_med), - unname(expected_coef_med), + # 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_se_med), - unname(expected_se_med), + expect_equal(unname(actual_vcov), + unname(expected_vcov), tolerance = 1e-10) + expect_equal(unname(actual_se), + unname(expected_se), + tolerance = 1e-10) +}) - # Mean aggregation (per coefficient) - expected_coef_mean <- rowMeans(coefs) - var_total_mean <- ses^2 + - (coefs - expected_coef_mean)^2 - expected_se_mean <- sqrt( - R / rowSums(1 / var_total_mean)) +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) - actual_coef_mean <- coef(reps, aggregation = "mean") - s_mean <- summary(reps, aggregation = "mean") - actual_se_mean <- s_mean$coefficients[, 2, 1] + 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)) - expect_equal(unname(actual_coef_mean), - unname(expected_coef_mean), + 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_mean), - unname(expected_se_mean), + 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") + + 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") + + 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 From 0e6c4fbc1192b4e4c1bab128176beb169182e104 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Mon, 9 Mar 2026 08:06:43 -0500 Subject: [PATCH 19/46] inference + spectral agg + renamed cf/cv --- DESCRIPTION | 2 +- NAMESPACE | 4 +- R/AE98.R | 4 +- R/crosspred.R | 162 ++++++++----- R/crossval.R | 83 +++++-- R/cvc.R | 16 +- R/ddml_apo.R | 66 +++-- R/ddml_ate.R | 14 +- R/ddml_att.R | 5 +- R/ddml_fpliv.R | 90 ++++--- R/ddml_late.R | 19 +- R/ddml_pliv.R | 92 +++---- R/ddml_plm.R | 78 +++--- R/ddml_rep.R | 105 ++++---- R/diagnostics.R | 24 +- R/ensemble.R | 34 ++- R/get_CEF.R | 28 +-- R/help_functions.R | 139 ++++++----- R/inference_functions.R | 113 --------- R/methods.R | 229 ++++++++++++++---- R/ml_wrappers.R | 9 +- R/ols.R | 2 +- R/shortstacking.R | 54 ++--- R/subsample_functions.R | 14 +- R/tidy.R | 61 +++-- man/AE98.Rd | 4 +- man/coef.ddml.Rd | 13 +- man/coef.ddml_rep.Rd | 11 +- man/confint.ddml.Rd | 20 +- man/confint.ddml_rep.Rd | 16 +- man/crosspred.Rd | 67 ++++- man/crossval.Rd | 49 +++- man/ddml_apo.Rd | 49 ++-- man/ddml_ate.Rd | 25 +- man/ddml_fpliv.Rd | 55 +++-- man/ddml_late.Rd | 25 +- man/ddml_pliv.Rd | 53 ++-- man/ddml_plm.Rd | 55 ++--- man/ddml_rep.Rd | 24 +- man/ddml_replicate.Rd | 15 +- man/glance.ddml.Rd | 14 +- man/glance.ddml_rep.Rd | 14 -- man/hatvalues.ddml.Rd | 48 ++++ man/nobs.ddml.Rd | 12 +- man/nobs.ddml_rep.Rd | 19 ++ man/print.ddml_rep.Rd | 32 --- man/print.summary.ddml.Rd | 21 -- man/print.summary.ddml_rep.Rd | 21 -- man/shortstacking.Rd | 22 +- man/sub-.summary.ddml.Rd | 22 -- man/summary.ddml.Rd | 41 +++- man/summary.ddml_rep.Rd | 52 +++- man/tidy.ddml.Rd | 14 -- man/tidy.ddml_rep.Rd | 27 +-- man/vcov.ddml.Rd | 19 +- man/vcov.ddml_rep.Rd | 11 +- tests/testthat/test-crosspred.R | 18 +- tests/testthat/test-crossval.R | 22 +- tests/testthat/test-ddml_fpliv.R | 141 ++--------- tests/testthat/test-ddml_pliv.R | 13 +- tests/testthat/test-ddml_plm.R | 28 ++- tests/testthat/test-help_functions.R | 2 +- tests/testthat/test-inference_functions.R | 156 ------------ tests/testthat/test-methods.R | 89 +++++++ tests/testthat/test-shortstacking.R | 4 +- vignettes/articles/example_401k.Rmd.txt | 6 +- .../articles/stacking_diagnostics.Rmd.txt | 2 +- 67 files changed, 1475 insertions(+), 1323 deletions(-) delete mode 100644 R/inference_functions.R create mode 100644 man/hatvalues.ddml.Rd create mode 100644 man/nobs.ddml_rep.Rd delete mode 100644 man/print.ddml_rep.Rd delete mode 100644 man/print.summary.ddml.Rd delete mode 100644 man/print.summary.ddml_rep.Rd delete mode 100644 man/sub-.summary.ddml.Rd delete mode 100644 tests/testthat/test-inference_functions.R diff --git a/DESCRIPTION b/DESCRIPTION index 15274d7..aa57bfd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,7 +25,6 @@ Depends: Imports: methods, stats, - AER, MASS, Matrix, nnls, @@ -36,6 +35,7 @@ Imports: xgboost, generics Suggests: + AER, covr, CVXR, knitr, diff --git a/NAMESPACE b/NAMESPACE index 4967157..e1d4919 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -9,8 +9,10 @@ S3method(confint,ddml) S3method(confint,ddml_rep) S3method(glance,ddml) S3method(glance,ddml_rep) +S3method(hatvalues,ddml) S3method(length,ddml_rep) S3method(nobs,ddml) +S3method(nobs,ddml_rep) S3method(predict,ensemble) S3method(predict,mdl_bigGLM) S3method(predict,mdl_glm) @@ -23,7 +25,6 @@ S3method(print,ddml_rep) S3method(print,summary.ddml) S3method(print,summary.ddml_rep) S3method(summary,ddml) -S3method(summary,ddml_apo) S3method(summary,ddml_rep) S3method(tidy,ddml) S3method(tidy,ddml_diagnostics) @@ -55,5 +56,6 @@ export(shortstacking) export(tidy) importFrom(generics,glance) importFrom(generics,tidy) +importFrom(stats,hatvalues) importFrom(stats,nobs) importFrom(stats,vcov) diff --git a/R/AE98.R b/R/AE98.R index 55864c6..08570fa 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 4cdb46d..129cd6c 100644 --- a/R/crosspred.R +++ b/R/crosspred.R @@ -1,8 +1,48 @@ -#' 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 @@ -19,19 +59,19 @@ #' 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 +#' \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 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.} +#' corresponding to predictive 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}) +#' used in \code{what}. 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 @@ -76,21 +116,21 @@ #' #' @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 +#' \item{\code{insample_fitted}}{When #' \code{compute_insample_predictions = TRUE}. #' a list of matrices with in-sample predictions by sample fold.} #' \item{\code{auxiliary_fitted}}{When \code{auxiliary_X} is not #' \code{NULL}, a list of matrices with additional predictions.} -#' \item{\code{crossfit_fitted}}{A matrix of out-of-sample +#' \item{\code{cf_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 +#' \item{\code{insample_fitted_bylearner}}{When #' \code{compute_insample_predictions = TRUE}, a list of matrices #' with in-sample predictions by sample fold (per learner).} #' \item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} @@ -124,8 +164,8 @@ #' sample_folds = 2, #' cv_folds = 2, #' silent = TRUE) -#' dim(crosspred_res$oos_fitted) # = length(y) by length(ensemble_type) -#' dim(crosspred_res$crossfit_fitted) # = 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) crosspred <- function(y, X, Z = NULL, learners, sample_folds = 10, @@ -166,12 +206,12 @@ crosspred <- function(y, X, Z = NULL, nensb <- length(ensemble_type) + ncustom # Check whether ddml uses conventional stacking w/ data driven weights w_cv <- any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & - (class(learners[[1]]) != "function") + (!is.function(learners[[1]])) # Create crossfitting and cv tuples indxs <- get_sample_splits(cluster_variable = cluster_variable, sample_folds = sample_folds, - cv_folds = if (w_cv) cv_folds, + cv_folds = cv_folds, subsamples = subsamples, cv_subsamples = cv_subsamples) subsamples <- indxs$subsamples @@ -220,10 +260,10 @@ crosspred <- function(y, X, Z = NULL, fold_fun, cl = cl) # Assemble results from fold_results list - oos_fitted <- matrix(0, nobs, nensb^(calc_ensemble)) - crossfit_fitted <- matrix(0, nobs, nlearners) - is_fitted <- rep(list(NULL), sample_folds) - is_fitted_bylearner <- rep(list(NULL), sample_folds) + cf_fitted <- matrix(0, nobs, nensb^(calc_ensemble)) + cf_fitted_bylearner <- matrix(0, nobs, nlearners) + insample_fitted <- rep(list(NULL), sample_folds) + insample_fitted_bylearner <- rep(list(NULL), sample_folds) auxiliary_fitted <- rep(list(NULL), sample_folds) auxiliary_fitted_bylearner <- rep(list(NULL), sample_folds) mspe <- matrix(0, nlearners^(calc_ensemble), sample_folds) @@ -232,19 +272,19 @@ crosspred <- function(y, X, Z = NULL, paste("sample fold ", seq_len(sample_folds)) weights <- array(0, dim = c(nlearners, nensb, sample_folds)) - crossval_resid <- rep(list(NULL), sample_folds) + cv_resid_byfold <- rep(list(NULL), sample_folds) for (res in fold_results) { k <- res$k - oos_fitted[res$oos_indices, ] <- res$oos_fitted_rows + cf_fitted[res$test_indices, ] <- res$cf_fitted_rows if (!is.null(res$weights_k)) weights[, , k] <- res$weights_k if (!is.null(res$mspe_k)) mspe[, k] <- res$mspe_k if (!is.null(res$r2_k)) r2[, k] <- res$r2_k - crossval_resid[[k]] <- res$crossval_resid_k - is_fitted[[k]] <- res$is_fitted_k + cv_resid_byfold[[k]] <- res$cv_resid_byfold_k + insample_fitted[[k]] <- res$insample_fitted_k auxiliary_fitted[[k]] <- res$auxiliary_fitted_k - crossfit_fitted[res$oos_indices, ] <- - res$crossfit_fitted_rows - is_fitted_bylearner[[k]] <- res$is_fitted_bylearner_k + cf_fitted_bylearner[res$test_indices, ] <- + res$cf_fitted_bylearner_rows + insample_fitted_bylearner[[k]] <- res$insample_fitted_bylearner_k auxiliary_fitted_bylearner[[k]] <- res$auxiliary_fitted_bylearner_k }#FOR @@ -256,34 +296,34 @@ crosspred <- function(y, X, Z = NULL, paste("sample fold ", seq_len(sample_folds))) }#IF - # Reorganize is_fitted for multiple ensembles + # Reorganize insample_fitted for multiple ensembles if (compute_insample_predictions && calc_ensemble && nensb > 1) { - new_is_fitted <- rep(list(rep(list(1), sample_folds)), nensb) + new_insample_fitted <- rep(list(rep(list(1), sample_folds)), nensb) for (i in seq_len(nensb)) { for (k in seq_len(sample_folds)) { - new_is_fitted[[i]][[k]] <- - is_fitted[[k]][, i, drop = FALSE] + new_insample_fitted[[i]][[k]] <- + insample_fitted[[k]][, i, drop = FALSE] }#FOR }#FOR - is_fitted <- new_is_fitted + insample_fitted <- new_insample_fitted }#IF # Compute per-learner OOS residuals (not computed for FPLIV w/ LIE...) - crossfit_resid <- if (is.numeric(y) && !is.list(y)) { - drop(y) - crossfit_fitted + cf_resid_bylearner <- if (is.numeric(y) && !is.list(y)) { + drop(y) - cf_fitted_bylearner } else { NULL }#IFELSE # Organize and return output - if (!calc_ensemble) weights <- mspe <- r2 <- crossval_resid <- NULL - output <- list(oos_fitted = oos_fitted, + if (!calc_ensemble) weights <- mspe <- r2 <- cv_resid_byfold <- NULL + output <- list(cf_fitted = cf_fitted, weights = weights, mspe = mspe, r2 = r2, - crossval_resid = crossval_resid, - is_fitted = is_fitted, + cv_resid_byfold = cv_resid_byfold, + insample_fitted = insample_fitted, auxiliary_fitted = auxiliary_fitted, - crossfit_fitted = crossfit_fitted, - crossfit_resid = crossfit_resid, - is_fitted_bylearner = is_fitted_bylearner, + cf_fitted_bylearner = cf_fitted_bylearner, + cf_resid_bylearner = cf_resid_bylearner, + insample_fitted_bylearner = insample_fitted_bylearner, auxiliary_fitted_bylearner = auxiliary_fitted_bylearner) return(output) }#CROSSPRED @@ -300,18 +340,18 @@ crosspred_compute_fold <- function( if (!calc_ensemble) { learners$args$X <- cbind(X[train_idx, ], Z[train_idx, ]) - if ("list" %in% class(y)) { + if (is.list(y)) { learners$args$y <- y[[k]] } else { learners$args$y <- y[train_idx] }#IFELSE mdl_fit <- do.call(do.call, learners) - oos_fitted_rows <- + cf_fitted_rows <- as.numeric(stats::predict(mdl_fit, cbind(X[test_idx, ], Z[test_idx, ]))) } else { - if ("list" %in% class(y)) { + if (is.list(y)) { y_ <- y[[k]] } else { y_ <- y[train_idx] @@ -323,8 +363,8 @@ crosspred_compute_fold <- function( cv_folds, cv_subsamples_k, custom_weights = custom_ensemble_weights, silent = TRUE) - oos_fitted_rows <- - as.numeric(predict.ensemble(mdl_fit, + cf_fitted_rows <- + as.numeric(stats::predict(mdl_fit, newdata = X[test_idx, , drop = FALSE], newZ = Z[test_idx, , drop = FALSE])) }#IFELSE @@ -343,9 +383,9 @@ crosspred_compute_fold <- function( } else { NULL } - crossval_resid_k <- if (calc_ensemble && + cv_resid_byfold_k <- if (calc_ensemble && !is.null(mdl_fit$cv_results)) { - mdl_fit$cv_results$oos_resid + mdl_fit$cv_results$cv_resid } else { NULL } @@ -356,14 +396,14 @@ crosspred_compute_fold <- function( } # In-sample predictions (optional) - is_fitted_k <- NULL + insample_fitted_k <- NULL if (compute_insample_predictions) { if (!calc_ensemble) { - is_fitted_k <- stats::predict(mdl_fit, + insample_fitted_k <- stats::predict(mdl_fit, cbind(X[train_idx, ], Z[train_idx, ])) } else { - is_fitted_k <- predict.ensemble(mdl_fit, + insample_fitted_k <- stats::predict(mdl_fit, newdata = X[train_idx, , drop = FALSE], newZ = Z[train_idx, , drop = FALSE]) }#IFELSE @@ -376,12 +416,12 @@ crosspred_compute_fold <- function( }#IF # By-learner predictions - is_fitted_bylearner_k <- NULL + insample_fitted_bylearner_k <- NULL auxiliary_fitted_bylearner_k <- NULL if (!calc_ensemble) { - crossfit_fitted_rows <- matrix(oos_fitted_rows, ncol = 1) + cf_fitted_bylearner_rows <- matrix(cf_fitted_rows, ncol = 1) if (compute_insample_predictions) { - is_fitted_bylearner_k <- matrix(is_fitted_k, ncol = 1) + insample_fitted_bylearner_k <- matrix(insample_fitted_k, ncol = 1) }#IF if (!is.null(auxiliary_X)) { auxiliary_fitted_bylearner_k <- matrix(auxiliary_fitted_k, ncol = 1) @@ -389,13 +429,13 @@ crosspred_compute_fold <- function( } else { mdl_fit_bylearner <- mdl_fit mdl_fit_bylearner$weights <- diag(1, nlearners) - crossfit_fitted_rows <- predict.ensemble( + cf_fitted_bylearner_rows <- stats::predict( mdl_fit_bylearner, newdata = X[test_idx, , drop = FALSE], newZ = Z[test_idx, , drop = FALSE] ) if (compute_insample_predictions) { - is_fitted_bylearner_k <- predict.ensemble( + insample_fitted_bylearner_k <- stats::predict( mdl_fit_bylearner, newdata = X[train_idx, , drop = FALSE], newZ = Z[train_idx, , drop = FALSE] @@ -411,17 +451,17 @@ crosspred_compute_fold <- function( list( k = k, - oos_indices = test_idx, - oos_fitted_rows = oos_fitted_rows, + test_indices = test_idx, + cf_fitted_rows = cf_fitted_rows, weights_k = weights_k, mspe_k = mspe_k, r2_k = r2_k, - crossval_resid_k = crossval_resid_k, + cv_resid_byfold_k = cv_resid_byfold_k, weight_colnames = weight_colnames, - is_fitted_k = is_fitted_k, + insample_fitted_k = insample_fitted_k, auxiliary_fitted_k = auxiliary_fitted_k, - crossfit_fitted_rows = crossfit_fitted_rows, - is_fitted_bylearner_k = is_fitted_bylearner_k, + cf_fitted_bylearner_rows = cf_fitted_bylearner_rows, + insample_fitted_bylearner_k = insample_fitted_bylearner_k, auxiliary_fitted_bylearner_k = auxiliary_fitted_bylearner_k ) }#CROSSPRED_COMPUTE_FOLD diff --git a/R/crossval.R b/R/crossval.R index 8962684..ab77c3e 100644 --- a/R/crossval.R +++ b/R/crossval.R @@ -5,6 +5,34 @@ #' @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. @@ -12,10 +40,10 @@ #' @param learners \code{learners} is a list of lists, each containing four #' 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.} @@ -24,7 +52,7 @@ #' 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}) +#' used in \code{what}. Omission of \code{assign_X} (and/or \code{assign_Z}) #' results in inclusion of all predictive variables in \code{X} (and/or #' \code{Z}). #' @param cv_folds Number of folds used for cross-validation. @@ -46,12 +74,16 @@ #' @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 #' @@ -82,9 +114,13 @@ crossval <- function(y, X, Z = NULL, parallel_export <- p$export parallel_packages <- p$packages - # Normalize learner specs: resolve fun/what before parallel dispatch + # 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) @@ -134,19 +170,18 @@ crossval <- function(y, X, Z = NULL, cl = cl) # 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 and R-squared by learner - mspe <- colMeans(oos_resid^2) + mspe <- colMeans(cv_resid^2) y_var <- as.numeric(stats::var(y)) - r2 <- if (y_var > 0) 1 - mspe / y_var else rep(NA_real_, - length(mspe)) + r2 <- if (y_var > 0) 1 - mspe / y_var else rep(NA_real_, length(mspe)) # Organize and return output output <- list(mspe = mspe, r2 = r2, - oos_resid = oos_resid, + cv_resid = cv_resid, cv_subsamples = cv_subsamples) return(output) }#CROSSVAL @@ -174,12 +209,12 @@ crossval_compute <- function(test_sample, learner, } ) - oos_fitted <- stats::predict(mdl_fit, - cbind(X[test_sample, assign_X, - drop = FALSE], - Z[test_sample, assign_Z, - drop = FALSE])) - if (!is.matrix(oos_fitted)) oos_fitted <- as.matrix(oos_fitted) - oos_resid <- y[test_sample] - oos_fitted - return(oos_resid) + cv_fitted <- stats::predict(mdl_fit, + cbind(X[test_sample, assign_X, + drop = FALSE], + Z[test_sample, assign_Z, + 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/cvc.R b/R/cvc.R index 58bbf94..f0570de 100644 --- a/R/cvc.R +++ b/R/cvc.R @@ -121,7 +121,7 @@ cvc_confidence_set <- function(resid_mat, fid, # Runs pairwise comparisons and the model confidence set # procedure on a matrix of OOS residuals. # -# @param oos_resid Matrix (n x nlearners) of OOS residuals. +# @param cv_resid Matrix (n x nlearners) of OOS residuals. # @param subsamples List of sample fold index vectors (used # to derive fold IDs). # @param bootnum Number of bootstrap replications. @@ -130,10 +130,10 @@ cvc_confidence_set <- function(resid_mat, fid, # @return List with: pairwise (nlearners x nlearners matrix # of p-values), confidence_set (logical vector), # pvalues (numeric vector from confidence set procedure). -cvc_test <- function(oos_resid, subsamples, +cvc_test <- function(cv_resid, subsamples, bootnum = 500, alpha = 0.05) { - n <- nrow(oos_resid) - nlearners <- ncol(oos_resid) + n <- nrow(cv_resid) + nlearners <- ncol(cv_resid) # Derive fold IDs from subsamples fid <- integer(n) @@ -143,22 +143,22 @@ cvc_test <- function(oos_resid, subsamples, # Pairwise comparisons pairwise <- matrix(NA_real_, nlearners, nlearners) - if (!is.null(colnames(oos_resid))) { + if (!is.null(colnames(cv_resid))) { rownames(pairwise) <- colnames(pairwise) <- - colnames(oos_resid) + colnames(cv_resid) }#IF for (i in seq_len(nlearners)) { for (j in seq_len(nlearners)) { if (i != j) { pairwise[i, j] <- cvc_pairwise( - oos_resid[, i], oos_resid[, j], + cv_resid[, i], cv_resid[, j], fid, bootnum) }#IF }#FOR }#FOR # Model confidence set - cs <- cvc_confidence_set(oos_resid, fid, bootnum, alpha) + cs <- cvc_confidence_set(cv_resid, fid, bootnum, alpha) list(pairwise = pairwise, pvalues = cs$pvalues, diff --git a/R/ddml_apo.R b/R/ddml_apo.R index 404b6c4..a559d00 100644 --- a/R/ddml_apo.R +++ b/R/ddml_apo.R @@ -49,37 +49,38 @@ #' compatibility but should be replaced with the \code{splits} #' argument. #' -#' @return \code{ddml_apo} returns a list object of class \code{ddml_apo} -#' and \code{ddml} with the following properties: -#' \describe{ -#' \item{\code{coefficients}}{A matrix of estimated coefficients.} -#' \item{\code{ensemble_weights}}{The ensemble weights.} -#' \item{\code{mspe}}{The in-sample mean squared prediction errors.} -#' \item{\code{r2}}{The out-of-sample R-squared.} -#' \item{\code{psi_a}, \code{psi_b}}{The scale and scores associated with -#' evaluating the Neyman orthogonal score.} -#' \item{\code{scores}}{A list of evaluating the Neyman orthogonal scores.} -#' \item{\code{J}}{A list of evaluating the Jacobian of the Neyman -#' orthogonal scores.} -#' \item{\code{fitted}}{An optional list of fitted nuisance estimators. -#' See \code{\link{ddml_plm}} for more information.} -#' \item{\code{splits}}{The data splitting structure.} -#' \item{\code{learners}}{The original list of learners.} -#' \item{\code{learners_DX}}{The original list of learners for the propensity -#' score.} -#' \item{\code{ensemble_type}}{The ensemble type.} -#' \item{\code{nobs}}{The number of observations.} -#' \item{\code{sample_folds}}{The number of sample folds.} -#' \item{\code{cv_folds}}{The number of cross-validation folds.} -#' \item{\code{shortstack}}{A boolean indicating if shortstacking was used.} -#' \item{\code{cluster_variable}}{The original cluster variable.} -#' \item{\code{call}}{The match.call().} -#' } +#' @return \code{ddml_apo} returns an object of S3 class +#' \code{ddml_apo}. An object of class \code{ddml_apo} is a list +#' containing the following components: +#' \describe{ +#' \item{\code{coefficients}}{A matrix of estimated coefficients.} +#' \item{\code{ensemble_weights}}{A list of matrices, providing the +#' weight assigned to each base learner by the ensemble +#' procedure.} +#' \item{\code{mspe}}{A list of matrices, providing the MSPE of each +#' base learner computed by the cross-validation step in the +#' ensemble construction.} +#' \item{\code{r2}}{The out-of-sample R-squared.} +#' \item{\code{psi_a}, \code{psi_b}}{Score components used in +#' \code{\link{vcov.ddml}}.} +#' \item{\code{scores}}{A list of evaluated Neyman orthogonal +#' scores.} +#' \item{\code{J}}{A list of evaluated Jacobians.} +#' \item{\code{fitted}}{A list of fitted nuisance estimators. +#' See \code{\link{ddml_plm}} for more information.} +#' \item{\code{splits}}{The data splitting structure.} +#' \item{\code{learners},\code{learners_DX}, +#' \code{cluster_variable}, +#' \code{ensemble_type}}{Pass-through of selected +#' user-provided arguments. See above.} +#' } #' #' @references Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). #' "Model Averaging and Double Machine Learning." #' \url{https://arxiv.org/abs/2401.01645} -#' @seealso \code{\link{summary.ddml}} +#' @seealso \code{\link{summary.ddml}}, +#' \code{\link{vcov.ddml}}, \code{\link{confint.ddml}}, +#' \code{\link{hatvalues.ddml}}, #' \code{\link{ddml_plm}}, \code{\link{ddml_pliv}}, #' \code{\link{ddml_fpliv}}, \code{\link{ddml_late}}, #' \code{\link{ddml_ate}} @@ -122,6 +123,7 @@ ddml_apo <- function(y, D, X, 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, @@ -190,7 +192,7 @@ ddml_apo <- function(y, D, X, fitted = fitted$y_X) ensb_info <- update_ensemble_info(y_X_res$weights, - D_X_res$oos_fitted) + D_X_res$cf_fitted) ensemble_type <- ensb_info$ensemble_type nensb <- ensb_info$nensb @@ -200,11 +202,11 @@ ddml_apo <- function(y, D, X, D = D_ind, CEF_res_byD = list(list( fit = list( - ensemble_fitted = y_X_res$oos_fitted, + 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$oos_fitted + 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, @@ -278,7 +280,3 @@ ddml_apo <- function(y, D, X, return(ddml_fit) }#DDML_APO -#' @export -summary.ddml_apo <- function(object, ...) { - summary.ddml(object, ...) -} diff --git a/R/ddml_ate.R b/R/ddml_ate.R index 7552257..306e2a2 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -1,9 +1,10 @@ #' Estimators of Average Treatment Effects. #' -#' @family ddml +#' @family ddml estimators #' #' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], -#' [ddml::confint.ddml()], [ddml::tidy.ddml()], +#' [ddml::vcov.ddml()], [ddml::confint.ddml()], +#' [ddml::hatvalues.ddml()], [ddml::tidy.ddml()], #' [ddml::glance.ddml()], [ddml::diagnostics()] #' #' @description Estimators of the average treatment effect and the average @@ -92,8 +93,8 @@ #' base learner computed by the cross-validation step in the #' ensemble construction.} #' \item{\code{r2}}{The out-of-sample R-squared.} -#' \item{\code{psi_a}, \code{psi_b}}{Matrices needed for the -#' computation of scores. Used in [ddml::summary.ddml()].} +#' \item{\code{psi_a}, \code{psi_b}}{Score components used in +#' \code{\link{vcov.ddml}}.} #' \item{\code{scores}}{A list of evaluated Neyman orthogonal #' scores.} #' \item{\code{J}}{A list of evaluated Jacobians.} @@ -176,6 +177,7 @@ ddml_ate <- function(y, D, X, 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) @@ -242,8 +244,8 @@ ddml_ate <- function(y, D, X, # Pre-ensembled propensity for ddml_apo delegation. # For d=0, flip: P(D=0|X) = 1 - P(D=1|X). - fitted_D_X_1 <- list(ensemble_fitted = D_X_res$oos_fitted) - fitted_D_X_0 <- list(ensemble_fitted = 1 - D_X_res$oos_fitted) + fitted_D_X_1 <- list(cf_fitted = D_X_res$cf_fitted) + fitted_D_X_0 <- list(cf_fitted = 1 - D_X_res$cf_fitted) # E[g(1,X)] via ddml_apo apo_1 <- ddml_apo( diff --git a/R/ddml_att.R b/R/ddml_att.R index 83e2c10..06ca567 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -32,6 +32,7 @@ ddml_att <- function(y, D, X, 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, @@ -94,7 +95,7 @@ ddml_att <- function(y, D, X, # Pre-ensembled propensity: P(D=0|X) = 1 - E[D|X] fitted_D_X_0 <- list( - ensemble_fitted = 1 - D_X_res$oos_fitted) + cf_fitted = 1 - D_X_res$cf_fitted) apo_0 <- ddml_apo( y = y, D = D, X = X, d = 0, weights = NULL, @@ -123,7 +124,7 @@ ddml_att <- function(y, D, X, fit = apo_0$fitted$y_X, d = 0)), aux_indx = indxs$aux_indx)[, , 1] - m_X <- D_X_res$oos_fitted + m_X <- D_X_res$cf_fitted m_X_tr <- trim_propensity_scores(m_X, trim, ensemble_type) p <- mean(D) diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index 047679e..a58a7e4 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -1,9 +1,10 @@ #' Estimator for the Flexible Partially Linear IV Model. #' -#' @family ddml +#' @family ddml estimators #' #' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], -#' [ddml::confint.ddml()], [ddml::tidy.ddml()], +#' [ddml::vcov.ddml()], [ddml::confint.ddml()], +#' [ddml::hatvalues.ddml()], [ddml::tidy.ddml()], #' [ddml::glance.ddml()], [ddml::diagnostics()], #' [AER::ivreg()] #' @@ -53,22 +54,26 @@ #' \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 and -#' the second-stage intercept (last element).} -#' \item{\code{ensemble_weights}}{A list of matrices, providing the weight -#' assigned to each base learner (in chronological order) by the -#' ensemble procedure.} +#' \item{\code{coefficients}}{A matrix of estimated coefficients.} +#' \item{\code{ensemble_weights}}{A list of matrices, providing the +#' weight assigned to each base learner 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},\code{ensemble_type}}{Pass-through of -#' selected user-provided arguments. See above.} +#' base learner computed by the cross-validation step in the +#' ensemble construction.} +#' \item{\code{r2}}{The out-of-sample R-squared.} +#' \item{\code{psi_a}, \code{psi_b}}{Score components used in +#' \code{\link{vcov.ddml}}.} +#' \item{\code{scores}}{A list of evaluated Neyman orthogonal +#' scores.} +#' \item{\code{J}}{A list of evaluated Jacobians.} +#' \item{\code{fitted}}{A list of fitted nuisance estimators. +#' See \code{\link{ddml_plm}} for more information.} +#' \item{\code{splits}}{The data splitting structure.} +#' \item{\code{learners},\code{learners_DXZ}, +#' \code{learners_DX},\code{cluster_variable}, +#' \code{ensemble_type}}{Pass-through of selected +#' user-provided arguments. See above.} #' } #' @export #' @@ -126,7 +131,8 @@ ddml_fpliv <- function(y, D, Z, X, learners = learners, sample_folds = sample_folds, cv_folds = cv_folds, - ensemble_type = ensemble_type) + ensemble_type = ensemble_type, + cluster_variable = cluster_variable) validate_custom_weights(custom_ensemble_weights, learners) validate_custom_weights(custom_ensemble_weights_DXZ, learners_DXZ) @@ -211,34 +217,38 @@ ddml_fpliv <- function(y, D, Z, X, # == Score construction =========================================== coef <- matrix(0, nD + 1, nensb) - iv_fit <- rep(list(1), nensb) scores <- vector("list", nensb) J_list <- vector("list", nensb) psi_a <- vector("list", nensb) psi_b <- vector("list", nensb) cn_weights <- dimnames(y_X_res$weights)[[2]] - colnames(coef) <- names(iv_fit) <- - if (is.null(cn_weights)) ensemble_type else cn_weights + colnames(coef) <- if (is.null(cn_weights)) ensemble_type else cn_weights for (j in seq_len(nensb)) { - 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) - y_r <- y - cbind(y_X_res$oos_fitted)[, j] + 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] - iv_fit_j <- AER::ivreg(y_r ~ D_r | V_r, x = TRUE) + 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 - coef_iv_j <- stats::coef(iv_fit_j) - coef[, j] <- c(coef_iv_j[-1], coef_iv_j[1]) - iv_fit[[j]] <- iv_fit_j + # 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) - D_r_mat <- as.matrix(D_r) - D_hat <- as.matrix( - iv_fit_j$x$projected[, -1, drop = FALSE]) - X_hat <- cbind(D_hat, 1) - X_full <- cbind(D_r_mat, 1) - e_j <- as.vector(stats::residuals(iv_fit_j)) scores[[j]] <- X_hat * e_j J_list[[j]] <- -crossprod(X_hat, X_full) / nobs @@ -250,10 +260,13 @@ ddml_fpliv <- function(y, D, Z, X, # == Target parameter ============================================= - cn_j <- names(iv_fit[[1]]$coefficients) - rownames(coef) <- c(cn_j[-1], cn_j[1]) + 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) + # == Output ======================================================= + ensemble_weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) r2 <- list(y_X = y_X_res$r2) @@ -268,11 +281,8 @@ ddml_fpliv <- function(y, D, Z, X, r2[[eq]] <- D_XZ_res_list[[k]]$r2 }#FOR - # == Output ======================================================= - ddml_fit <- list( coefficients = coef, - iv_fit = iv_fit, ensemble_weights = ensemble_weights, mspe = mspe, r2 = r2, diff --git a/R/ddml_late.R b/R/ddml_late.R index 0d629ae..20f9939 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -1,9 +1,10 @@ #' Estimator of the Local Average Treatment Effect. #' -#' @family ddml +#' @family ddml estimators #' #' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], -#' [ddml::confint.ddml()], [ddml::tidy.ddml()], +#' [ddml::vcov.ddml()], [ddml::confint.ddml()], +#' [ddml::hatvalues.ddml()], [ddml::tidy.ddml()], #' [ddml::glance.ddml()], [ddml::diagnostics()] #' #' @description Estimator of the local average treatment effect. @@ -56,10 +57,10 @@ #' 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 +#' \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 control variables in \code{X} that are passed to #' the base learner.} @@ -68,7 +69,7 @@ #' 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}) +#' used in \code{what}. 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 @@ -101,8 +102,8 @@ #' each base learner computed by the cross-validation step #' in the ensemble construction.} #' \item{\code{r2}}{The out-of-sample R-squared.} -#' \item{\code{psi_a}, \code{psi_b}}{Matrices needed for the -#' computation of scores. Used in [ddml::summary.ddml()].} +#' \item{\code{psi_a}, \code{psi_b}}{Score components used in +#' \code{\link{vcov.ddml}}.} #' \item{\code{scores}}{A list of evaluated Neyman orthogonal #' scores.} #' \item{\code{J}}{A list of evaluated Jacobians.} @@ -200,6 +201,7 @@ ddml_late <- function(y, D, Z, X, 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, @@ -233,8 +235,7 @@ ddml_late <- function(y, D, Z, X, "sequential" }#IFELSE if (!is.null(messages$start) && messages$start != "") { - info_msg(sprintf(messages$start, mode_str), - silent = silent) + info_msg(sprintf(messages$start, mode_str), silent = silent) }#IF # == Reduced-form estimation ====================================== diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index 1903288..eb545be 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -1,9 +1,10 @@ #' Estimator for the Partially Linear IV Model. #' -#' @family ddml +#' @family ddml estimators #' #' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], -#' [ddml::confint.ddml()], [ddml::tidy.ddml()], +#' [ddml::vcov.ddml()], [ddml::confint.ddml()], +#' [ddml::hatvalues.ddml()], [ddml::tidy.ddml()], #' [ddml::glance.ddml()], [ddml::diagnostics()], #' [AER::ivreg()] #' @@ -46,10 +47,10 @@ #' 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 +#' \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 control variables in \code{X} that are passed to #' the base learner.} @@ -58,7 +59,7 @@ #' 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}) +#' used in \code{what}. 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 @@ -75,22 +76,26 @@ #' \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 and -#' the second-stage intercept (last element).} -#' \item{\code{ensemble_weights}}{A list of matrices, providing the weight -#' assigned to each base learner (in chronological order) by the -#' ensemble procedure.} +#' \item{\code{coefficients}}{A matrix of estimated coefficients.} +#' \item{\code{ensemble_weights}}{A list of matrices, providing the +#' weight assigned to each base learner 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.} +#' base learner computed by the cross-validation step in the +#' ensemble construction.} +#' \item{\code{r2}}{The out-of-sample R-squared.} +#' \item{\code{psi_a}, \code{psi_b}}{Score components used in +#' \code{\link{vcov.ddml}}.} +#' \item{\code{scores}}{A list of evaluated Neyman orthogonal +#' scores.} +#' \item{\code{J}}{A list of evaluated Jacobians.} +#' \item{\code{fitted}}{A list of fitted nuisance estimators. +#' See \code{\link{ddml_plm}} for more information.} +#' \item{\code{splits}}{The data splitting structure.} #' \item{\code{learners},\code{learners_DX},\code{learners_ZX}, -#' \code{cluster_variable}, \code{subsamples}, -#' \code{cv_subsamples},\code{ensemble_type}}{Pass-through of -#' selected user-provided arguments. See above.} +#' \code{cluster_variable}, +#' \code{ensemble_type}}{Pass-through of selected +#' user-provided arguments. See above.} #' } #' @export #' @@ -151,7 +156,8 @@ ddml_pliv <- function(y, D, Z, X, learners = learners, sample_folds = sample_folds, cv_folds = cv_folds, - ensemble_type = ensemble_type) + ensemble_type = ensemble_type, + cluster_variable = cluster_variable) validate_custom_weights(custom_ensemble_weights, learners) validate_custom_weights(custom_ensemble_weights_DX, learners_DX) @@ -235,29 +241,32 @@ ddml_pliv <- function(y, D, Z, X, # == Score construction =========================================== coef <- matrix(0, nD + 1, nensb) - iv_fit <- rep(list(1), nensb) scores <- vector("list", nensb) J_list <- vector("list", nensb) psi_a <- vector("list", nensb) psi_b <- vector("list", nensb) for (j in seq_len(nensb)) { - y_r <- y - cbind(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) - - iv_fit_j <- AER::ivreg(y_r ~ D_r | V_r, x = TRUE) - - coef_iv_j <- stats::coef(iv_fit_j) - coef[, j] <- c(coef_iv_j[-1], coef_iv_j[1]) - iv_fit[[j]] <- iv_fit_j + 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) D_r_mat <- as.matrix(D_r) - D_hat <- as.matrix( - iv_fit_j$x$projected[, -1, drop = FALSE]) - X_hat <- cbind(D_hat, 1) - X_full <- cbind(D_r_mat, 1) - e_j <- as.vector(stats::residuals(iv_fit_j)) + 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 + + 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_list[[j]] <- -crossprod(X_hat, X_full) / nobs @@ -270,12 +279,14 @@ ddml_pliv <- function(y, D, Z, X, # == Target parameter ============================================= cn_weights <- dimnames(y_X_res$weights)[[2]] - colnames(coef) <- names(iv_fit) <- - if (is.null(cn_weights)) ensemble_type else cn_weights - cn_j <- names(iv_fit_j$coefficients) - rownames(coef) <- c(cn_j[-1], cn_j[1]) + 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) + # == Output ======================================================= + ensemble_weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) r2 <- list(y_X = y_X_res$r2) @@ -292,11 +303,8 @@ ddml_pliv <- function(y, D, Z, X, r2[[eq]] <- Z_X_res_list[[k]]$r2 }#FOR - # == Output ======================================================= - ddml_fit <- list( coefficients = coef, - iv_fit = iv_fit, ensemble_weights = ensemble_weights, mspe = mspe, r2 = r2, diff --git a/R/ddml_plm.R b/R/ddml_plm.R index 94d9e36..87ea097 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -1,9 +1,10 @@ #' Estimator for the Partially Linear Model. #' -#' @family ddml +#' @family ddml estimators #' #' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], -#' [ddml::confint.ddml()], [ddml::tidy.ddml()], +#' [ddml::vcov.ddml()], [ddml::confint.ddml()], +#' [ddml::hatvalues.ddml()], [ddml::tidy.ddml()], #' [ddml::glance.ddml()], [ddml::diagnostics()] #' #' @description Estimator for the partially linear model. @@ -45,16 +46,16 @@ #' 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 +#' \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 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 +#' used in \code{what}. Omission of \code{assign_X} results in inclusion of #' all variables in \code{X}. #' @param learners_DX Optional argument to allow for different estimators of #' \eqn{E[D|X]}. Setup is identical to \code{learners}. @@ -122,21 +123,27 @@ #' \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 and -#' the second-stage intercept (last element).} -#' \item{\code{ensemble_weights}}{A list of matrices, providing the weight -#' assigned to each base learner (in chronological order) by the -#' ensemble procedure.} +#' \item{\code{coefficients}}{A matrix of estimated coefficients.} +#' \item{\code{ensemble_weights}}{A list of matrices, providing the +#' weight assigned to each base learner 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}, -#' \code{ensemble_type}}{Pass-through of selected user-provided -#' arguments. See above.} +#' base learner computed by the cross-validation step in the +#' ensemble construction.} +#' \item{\code{r2}}{The out-of-sample R-squared.} +#' \item{\code{psi_a}, \code{psi_b}}{Score components used in +#' \code{\link{vcov.ddml}}.} +#' \item{\code{scores}}{A list of evaluated Neyman orthogonal +#' scores.} +#' \item{\code{J}}{A list of evaluated Jacobians.} +#' \item{\code{fitted}}{A list of fitted nuisance estimators. +#' Can be passed back via the \code{fitted} argument to +#' skip cross-fitting on re-estimation.} +#' \item{\code{splits}}{The data splitting structure.} +#' \item{\code{learners},\code{learners_DX}, +#' \code{cluster_variable}, +#' \code{ensemble_type}}{Pass-through of selected +#' user-provided arguments. See above.} #' } #' @export #' @@ -224,7 +231,8 @@ ddml_plm <- function(y, D, X, validate_inputs(y = y, D = D, X = X, learners = learners, sample_folds = sample_folds, cv_folds = cv_folds, - ensemble_type = ensemble_type) + ensemble_type = ensemble_type, + cluster_variable = cluster_variable) validate_custom_weights(custom_ensemble_weights, learners) validate_custom_weights(custom_ensemble_weights_DX, learners_DX) @@ -290,24 +298,21 @@ ddml_plm <- function(y, D, X, # == Score construction =========================================== coef <- matrix(0, nD + 1, nensb) - ols_fit <- rep(list(1), nensb) scores <- vector("list", nensb) J_list <- vector("list", nensb) psi_a <- vector("list", nensb) psi_b <- vector("list", nensb) for (j in seq_len(nensb)) { - D_r <- D - get_oosfitted(D_X_res_list, j) - y_r <- y - cbind(y_X_res$oos_fitted)[, j] - - ols_fit_j <- stats::lm(y_r ~ D_r) - - coef_ols_j <- stats::coef(ols_fit_j) - coef[, j] <- c(coef_ols_j[-1], coef_ols_j[1]) - ols_fit[[j]] <- ols_fit_j + D_r <- D - get_cf_fitted(D_X_res_list, j) + y_r <- y - cbind(y_X_res$cf_fitted)[, j] D_r_mat <- as.matrix(D_r) X_full <- cbind(D_r_mat, 1) - e_j <- as.vector(stats::residuals(ols_fit_j)) + + 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_list[[j]] <- -crossprod(X_full) / nobs @@ -320,12 +325,14 @@ ddml_plm <- function(y, D, X, # == Target parameter ============================================= cn_weights <- dimnames(y_X_res$weights)[[2]] - colnames(coef) <- names(ols_fit) <- - if (is.null(cn_weights)) ensemble_type else cn_weights - cn_j <- names(ols_fit_j$coefficients) - rownames(coef) <- c(cn_j[-1], cn_j[1]) + 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) + # == Output ======================================================= + # Ensemble metrics ensemble_weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) @@ -337,11 +344,8 @@ ddml_plm <- function(y, D, X, r2[[eq]] <- D_X_res_list[[k]]$r2 }#FOR - # == Output ======================================================= - ddml_fit <- list( coefficients = coef, - ols_fit = ols_fit, ensemble_weights = ensemble_weights, mspe = mspe, r2 = r2, diff --git a/R/ddml_rep.R b/R/ddml_rep.R index d95c1f9..d03dc98 100644 --- a/R/ddml_rep.R +++ b/R/ddml_rep.R @@ -19,7 +19,7 @@ build_inf_from_agg <- function(agg, coef_names, }#FOR dimnames(inf_results) <- list( coef_names, - c("Estimate", "Std. Error", "t value", "Pr(>|t|)"), + c("Estimate", "Std. Error", "z value", "Pr(>|z|)"), ensemble_type) inf_results }#BUILD_INF_FROM_AGG @@ -92,13 +92,8 @@ aggregate_reps <- function(object, aggregation = "median", fit <- object$fits[[r]] coef_array[, , r] <- fit$coefficients for (j in seq_len(nensb)) { - h <- if (type == "HC3") { - compute_leverage(fit, j) - }#IF - vcov_array[, , j, r] <- compute_ddml_variance( - fit$scores[[j]], fit$J[[j]], - fit$cluster_variable, type = type, - leverage = h) + vcov_array[, , j, r] <- stats::vcov(fit, + ensemble_idx = j, type = type) }#FOR }#FOR @@ -186,7 +181,7 @@ aggregate_reps <- function(object, aggregation = "median", #' summary(reps) #' } #' -#' @family ddml +#' @family ddml replication #' @seealso [ddml_replicate()] #' @export ddml_rep <- function(fits) { @@ -284,7 +279,7 @@ ddml_rep <- function(fits) { #' summary(reps) #' } #' -#' @family ddml +#' @family ddml replication #' @seealso [ddml_rep()] #' @export ddml_replicate <- function(fn, ..., resamples = 5, @@ -359,26 +354,24 @@ length.ddml_rep <- function(x) { x$nresamples }#LENGTH.DDML_REP -#' Print a ddml_rep Object -#' -#' Displays a brief overview of a \code{ddml_rep} object. +#' Extract Number of Observations from a ddml_rep Object #' -#' @param x A \code{ddml_rep} object. +#' @param object A \code{ddml_rep} object. #' @param ... Currently unused. #' -#' @return \code{x}, invisibly. +#' @return An integer specifying the number of observations. #' -#' @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) -#' reps -#' } +#' @importFrom stats nobs +#' @export +#' @method nobs ddml_rep +nobs.ddml_rep <- function(object, ...) { + object$nobs +}#NOBS.DDML_REP + +#' @rdname ddml_rep +#' +#' @param x A \code{ddml_rep} object. +#' @param ... Currently unused. #' #' @export #' @method print ddml_rep @@ -422,9 +415,7 @@ print.ddml_rep <- function(x, ...) { #' @export #' @method coef ddml_rep coef.ddml_rep <- function(object, - aggregation = c("median", - "mean", - "spectral"), + aggregation = c("median", "mean", "spectral"), ...) { aggregation <- match.arg(aggregation) agg <- aggregate_reps(object, @@ -445,9 +436,7 @@ coef.ddml_rep <- function(object, #' @param ensemble_idx Integer index of the ensemble type. #' Defaults to 1. #' @inheritParams coef.ddml_rep -#' @param type Character string specifying the -#' variance-covariance estimator. One of \code{"HC1"} -#' (default), \code{"HC0"}, or \code{"HC3"}. +#' @inheritParams vcov.ddml #' @param ... Currently unused. #' #' @return A p x p variance-covariance matrix. @@ -470,10 +459,9 @@ coef.ddml_rep <- function(object, #' @export #' @method vcov ddml_rep vcov.ddml_rep <- function(object, ensemble_idx = 1, - aggregation = c("median", - "mean", - "spectral"), + 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, @@ -490,14 +478,11 @@ vcov.ddml_rep <- function(object, ensemble_idx = 1, #' Confidence Intervals for ddml_rep Objects #' #' @param object A \code{ddml_rep} object. -#' @param parm Not used (included for generic compatibility). -#' @param level Confidence level. Default 0.95. +#' @inheritParams confint.ddml #' @param ensemble_idx Integer index of the ensemble type. #' Defaults to 1. #' @inheritParams coef.ddml_rep -#' @param type Character string specifying the -#' variance-covariance estimator. One of \code{"HC1"} -#' (default), \code{"HC0"}, or \code{"HC3"}. +#' @inheritParams vcov.ddml #' @param ... Currently unused. #' #' @return A matrix with columns for lower and upper bounds. @@ -523,9 +508,7 @@ vcov.ddml_rep <- function(object, ensemble_idx = 1, confint.ddml_rep <- function(object, parm, level = 0.95, ensemble_idx = 1, - aggregation = c("median", - "mean", - "spectral"), + aggregation = c("median", "mean", "spectral"), type = "HC1", ...) { aggregation <- match.arg(aggregation) agg <- aggregate_reps(object, @@ -533,11 +516,30 @@ confint.ddml_rep <- function(object, parm, type = type) cf <- agg$coefficients[, ensemble_idx] se <- agg$se[, ensemble_idx] + cf_names <- object$coef_names + names(cf) <- cf_names + names(se) <- cf_names + + if (missing(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] z <- stats::qnorm((1 + level) / 2) 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) <- object$coef_names + rownames(ci) <- parm ci }#CONFINT.DDML_REP @@ -601,9 +603,7 @@ confint.ddml_rep <- function(object, parm, #' @export #' @method summary ddml_rep summary.ddml_rep <- function(object, - aggregation = c("median", - "mean", - "spectral"), + aggregation = c("median", "mean", "spectral"), type = "HC1", ...) { aggregation <- match.arg(aggregation) type <- match.arg(type, c("HC0", "HC1", "HC3")) @@ -628,13 +628,10 @@ summary.ddml_rep <- function(object, result }#SUMMARY.DDML_REP -#' Print Summary for ddml_rep Objects +#' @rdname summary.ddml_rep #' #' @param x An object of class \code{summary.ddml_rep}. #' @param digits Number of significant digits. Default 3. -#' @param ... Currently unused. -#' -#' @return \code{x}, invisibly. #' #' @export #' @method print summary.ddml_rep @@ -717,13 +714,10 @@ print.summary.ddml_rep <- function(x, digits = 3, ...) { #' @seealso \code{\link{summary.ddml_rep}} for the #' aggregation equations. #' -#' @family ddml #' @export #' @method tidy ddml_rep tidy.ddml_rep <- function(x, ensemble_idx = 1, - aggregation = c("median", - "mean", - "spectral"), + aggregation = c("median", "mean", "spectral"), type = "HC1", conf.int = FALSE, conf.level = 0.95, ...) { @@ -792,7 +786,6 @@ tidy.ddml_rep <- function(x, ensemble_idx = 1, #' glance(reps) #' } #' -#' @family ddml #' @export #' @method glance ddml_rep glance.ddml_rep <- function(x, ...) { diff --git a/R/diagnostics.R b/R/diagnostics.R index 066312c..76c5425 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -91,25 +91,29 @@ diagnostics <- function(object, cvc = FALSE, r_avg <- as.numeric(r) }#IFELSE - # Use first ensemble type weights for display - w_display <- if (ncol(w_avg) >= 1) { - w_avg[, 1] - } else { - rep(NA_real_, nlearners) - }#IFELSE + # Display weights for all ensemble types + ens_names <- colnames(w_avg) + if (is.null(ens_names)) { + ens_names <- paste0("weight_", seq_len(ncol(w_avg))) + }#IF tbl <- data.frame( learner = learner_names, mspe = m_avg, r2 = r_avg, - weight = w_display, stringsAsFactors = FALSE, row.names = NULL) + + # Add a weight column per ensemble type + for (j in seq_len(ncol(w_avg))) { + col_name <- paste0("weight_", ens_names[j]) + tbl[[col_name]] <- w_avg[, j] + }#FOR }#IFELSE # CVC p-values (opt-in) if (cvc && !single_learner) { - resid <- get_crossfit_resid_for_eq(object$fitted, eq) + resid <- get_cf_resid_bylearner_for_eq(object$fitted, eq) subs <- get_diag_subsamples(object, eq) if (!is.null(resid) && !is.null(subs) && ncol(resid) > 1) { @@ -183,7 +187,9 @@ print.ddml_diagnostics <- function(x, digits = 4, ...) { # Format numeric columns display <- tbl - for (col in c("mspe", "r2", "weight", "cvc_pval")) { + 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 diff --git a/R/ensemble.R b/R/ensemble.R index 9af309b..91cac72 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -217,29 +217,41 @@ ensemble_weights <- function(y, X, Z = NULL, } 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) + sq_resid <- Matrix::crossprod(cv_results$cv_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 + 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)) { + weights[, k] <- r$solution + } else { + weights[, k] <- rep(1 / nlearners, nlearners) + }#IFELSE } else if (type[k] == "nnls") { # Reconstruct out of sample fitted values - oos_fitted <- as.numeric(y) - cv_results$oos_resid + cv_fitted <- as.numeric(y) - cv_results$cv_resid # For non-negative stacking, calculate the non-negatuve ols coefficients - weights[, k] <- nnls::nnls(oos_fitted, y)$x + weights[, k] <- nnls::nnls(cv_fitted, y)$x } else if (type[k] == "ols") { # Reconstruct out of sample fitted values - oos_fitted <- as.numeric(y) - cv_results$oos_resid + cv_fitted <- as.numeric(y) - cv_results$cv_resid # For unconstrained stacking, simply calculate the ols coefficients - weights[, k] <- ols(y, oos_fitted, const = FALSE)$coef + weights[, k] <- ols(y, cv_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 = FALSE]) + mdl_min <- which.min(Matrix::colMeans(cv_results$cv_resid^2)[, drop = FALSE]) mdl_min <- (seq_len(nlearners))[mdl_min] # Assign unit weight to the best model weights[mdl_min, k] <- 1 diff --git a/R/get_CEF.R b/R/get_CEF.R index 907954a..4cb6a23 100644 --- a/R/get_CEF.R +++ b/R/get_CEF.R @@ -34,7 +34,7 @@ get_CEF <- function(y, X, Z = NULL, if (!is.null(label)) { info_msg(" Estimating ", label, "...", silent = silent) }#IF - if (!is.null(fitted$crossfit_fitted)) { + 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)) { @@ -43,22 +43,22 @@ get_CEF <- function(y, X, Z = NULL, "'auxiliary_fitted_bylearner'.")) }#IF res <- build_CEF_from_crossfit( - y, fitted$crossfit_fitted, + y, fitted$cf_fitted_bylearner, ensemble_type, custom_ensemble_weights, - crossval_resid = fitted$crossval_resid, + cv_resid_byfold = fitted$cv_resid_byfold, subsamples = subsamples, auxiliary_fitted_bylearner = fitted$auxiliary_fitted_bylearner) return(res) }#IF - if (!is.null(fitted$ensemble_fitted)) { + if (!is.null(fitted$cf_fitted)) { # Rule 1: pre-ensembled predictions, use directly - res <- list(oos_fitted = fitted$ensemble_fitted, + res <- list(cf_fitted = fitted$cf_fitted, weights = NULL, mspe = NULL, r2 = NULL, auxiliary_fitted = NULL, - crossfit_fitted = NULL, - crossfit_resid = NULL, - crossval_resid = NULL) + cf_fitted_bylearner = NULL, + cf_resid_bylearner = NULL, + cv_resid_byfold = NULL) return(res) }#IF }#IF @@ -88,11 +88,11 @@ get_CEF <- function(y, X, Z = NULL, }#IF return(list( - oos_fitted = matrix(constant_val, n, nensb), + cf_fitted = matrix(constant_val, n, nensb), weights = NULL, mspe = NULL, r2 = NULL, - crossfit_fitted = matrix(constant_val, n, nlearners), - crossfit_resid = matrix(0, n, nlearners), - crossval_resid = 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 @@ -149,7 +149,7 @@ extrapolate_CEF <- function(D, CEF_res_byD, aux_indx) { is_D <- rep(list(NULL), nCEF) for (d in seq_len(nCEF)) is_D[[d]] <- which(D == D_levels[d]) nensb <- ncol(as.matrix( - CEF_res_byD[[1]][[1]]$ensemble_fitted)) + CEF_res_byD[[1]][[1]]$cf_fitted)) sample_folds <- length( CEF_res_byD[[1]][[1]]$auxiliary_fitted) @@ -157,7 +157,7 @@ extrapolate_CEF <- function(D, CEF_res_byD, aux_indx) { g_X_byD <- array(0, dim = c(nobs, nensb, nCEF)) for (d in seq_len(nCEF)) { g_X_byD[is_D[[d]], , d] <- - CEF_res_byD[[d]][[1]]$ensemble_fitted + CEF_res_byD[[d]][[1]]$cf_fitted for (k in seq_len(sample_folds)) { g_X_byD[aux_indx[[d]][[k]], , d] <- CEF_res_byD[[d]][[1]]$auxiliary_fitted[[k]] diff --git a/R/help_functions.R b/R/help_functions.R index 526cfca..4f7be49 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -1,5 +1,8 @@ # Collection of small internal functions +# Package-level environment for internal state +.ddml_env <- new.env(parent = emptyenv()) + # Resolve estimator progress messages. # # Merges user-supplied message overrides (passed via dots by @@ -33,16 +36,16 @@ 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, @@ -83,14 +86,14 @@ normalize_learners <- function(learners) { resolve <- function(l) { if (!is.null(l$what)) return(l$what) if (!is.null(l$fun)) { - if (is.null(getOption("ddml.fun_deprecated_warned"))) { + if (is.null(.ddml_env$fun_deprecated_warned)) { message("Note: 'fun' in learner specifications ", "is deprecated. Use 'what' instead.") - options(ddml.fun_deprecated_warned = TRUE) + .ddml_env$fun_deprecated_warned <- TRUE }#IF return(l$fun) }#IF - stop("Learner must have a 'what' or 'fun' element.", + stop("Learner must have a 'what' element.", call. = FALSE) }#RESOLVE @@ -107,37 +110,35 @@ normalize_learners <- function(learners) { }#NORMALIZE_LEARNERS # Build a CEF-like result from pre-computed per-learner predictions. -# When crossval_resid + subsamples are available, recomputes +# 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, crossfit_fitted_eq, +build_CEF_from_crossfit <- function(y, cf_fitted_bylearner_eq, ensemble_type, custom_ensemble_weights, - crossval_resid = NULL, + cv_resid_byfold = NULL, subsamples = NULL, auxiliary_fitted_bylearner = NULL) { nobs <- length(y) - cf <- as.matrix(crossfit_fitted_eq) + cf <- as.matrix(cf_fitted_bylearner_eq) nlearners <- ncol(cf) dummy_learners <- lapply(seq_len(nlearners), function(i) list(what = identity)) - # Per-learner OOS residuals, MSPE, and R-squared - oos_resid <- drop(y) - cf - mspe <- colMeans(oos_resid^2) + cf_resid_bylearner <- drop(y) - cf + mspe <- colMeans(cf_resid_bylearner^2) - if (!is.null(crossval_resid) && !is.null(crossval_resid[[1]]) && + if (!is.null(cv_resid_byfold) && !is.null(cv_resid_byfold[[1]]) && !is.null(subsamples)) { - # Per-fold weight recomputation from inner-CV residuals K <- length(subsamples) nensb <- NULL - oos_fitted <- matrix(0, nobs, 1) + cf_fitted <- matrix(0, nobs, 1) all_weights <- vector("list", K) for (k in seq_len(K)) { train_idx <- setdiff(seq_len(nobs), subsamples[[k]]) fakecv_k <- list( - oos_resid = crossval_resid[[k]], - mspe = colMeans(crossval_resid[[k]]^2)) + 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, @@ -147,10 +148,10 @@ build_CEF_from_crossfit <- function(y, crossfit_fitted_eq, silent = TRUE) all_weights[[k]] <- ew_k$weights if (is.null(nensb)) nensb <- ncol(ew_k$weights) - if (ncol(oos_fitted) < nensb) { - oos_fitted <- matrix(0, nobs, nensb) + if (ncol(cf_fitted) < nensb) { + cf_fitted <- matrix(0, nobs, nensb) }#IF - oos_fitted[subsamples[[k]], ] <- cf[subsamples[[k]], ] %*% + cf_fitted[subsamples[[k]], ] <- cf[subsamples[[k]], ] %*% ew_k$weights }#FOR weights <- array(0, dim = c(nlearners, nensb, K)) @@ -158,8 +159,7 @@ build_CEF_from_crossfit <- function(y, crossfit_fitted_eq, dimnames(weights) <- list(NULL, colnames(all_weights[[1]]), paste("sample fold ", seq_len(K))) } else { - # Global weights from sample-fold residuals - fakecv <- list(oos_resid = oos_resid, + fakecv <- list(cv_resid = cf_resid_bylearner, mspe = mspe) ew <- ensemble_weights( y, cf, type = ensemble_type, @@ -168,16 +168,15 @@ build_CEF_from_crossfit <- function(y, crossfit_fitted_eq, custom_weights = custom_ensemble_weights, silent = TRUE) weights <- ew$weights - oos_fitted <- cf %*% weights + cf_fitted <- cf %*% weights }#IFELSE - # Propagate ensemble type names to oos_fitted columns ens_names <- if (length(dim(weights)) == 3) { colnames(weights[, , 1]) } else { colnames(weights) } - if (!is.null(ens_names)) colnames(oos_fitted) <- ens_names + if (!is.null(ens_names)) colnames(cf_fitted) <- ens_names # Fold-level auxiliary predictions (ATE/ATT/LATE extrapolation) auxiliary_fitted <- NULL @@ -202,14 +201,14 @@ build_CEF_from_crossfit <- function(y, crossfit_fitted_eq, r2 <- if (y_var > 0) 1 - mspe / y_var else rep(NA_real_, length(mspe)) - list(oos_fitted = oos_fitted, + list(cf_fitted = cf_fitted, weights = weights, mspe = mspe, r2 = r2, auxiliary_fitted = auxiliary_fitted, - crossfit_fitted = cf, - crossfit_resid = oos_resid, - crossval_resid = crossval_resid) + cf_fitted_bylearner = cf, + cf_resid_bylearner = cf_resid_bylearner, + cv_resid_byfold = cv_resid_byfold) }#BUILD_CEF_FROM_CROSSFIT validate_fitted_splits_pair <- function(fitted, splits, @@ -229,11 +228,11 @@ validate_fitted_splits_pair <- function(fitted, splits, build_fitted_entry <- function(res, save_crossval, include_auxiliary = FALSE) { - entry <- list(ensemble_fitted = res$oos_fitted, - crossfit_fitted = res$crossfit_fitted, - crossfit_resid = res$crossfit_resid) + 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$crossval_resid <- res$crossval_resid + entry$cv_resid_byfold <- res$cv_resid_byfold }#IF if (include_auxiliary) { entry$auxiliary_fitted <- res$auxiliary_fitted @@ -248,10 +247,10 @@ build_fitted_from_list <- function(res_list, save_crossval) { save_crossval = save_crossval) }#BUILD_FITTED_FROM_LIST -get_crossfit_resid_for_eq <- function(fitted, eq) { +get_cf_resid_bylearner_for_eq <- function(fitted, eq) { entry <- fitted[[eq]] - if (!is.null(entry) && !is.null(entry$crossfit_resid)) { - return(entry$crossfit_resid) + if (!is.null(entry) && !is.null(entry$cf_resid_bylearner)) { + return(entry$cf_resid_bylearner) }#IF m <- regmatches(eq, regexec("^([A-Za-z]+)(\\d+)(_\\w+)$", eq))[[1]] @@ -260,11 +259,11 @@ get_crossfit_resid_for_eq <- function(fitted, eq) { idx <- as.integer(m[3]) entry <- fitted[[group]] if (is.list(entry) && length(entry) >= idx) { - return(entry[[idx]]$crossfit_resid) + return(entry[[idx]]$cf_resid_bylearner) }#IF }#IF NULL -}#GET_CROSSFIT_RESID_FOR_EQ +}#GET_CF_RESID_BYLEARNER_FOR_EQ normalize_splits <- function(splits = NULL, by_label = NULL, ...) { @@ -312,12 +311,32 @@ normalize_splits <- function(splits = NULL, splits }#NORMALIZE_SPLITS +# Validate common arguments for S3 inference methods. +# Returns the validated type (via match.arg) invisibly. +validate_method_args <- function(object, + ensemble_idx = NULL, + type = NULL) { + if (!is.null(type)) { + type <- match.arg(type, c("HC0", "HC1", "HC3")) + }#IF + if (!is.null(ensemble_idx)) { + nensb <- length(object$ensemble_type) + if (nensb == 0) nensb <- 1L + if (ensemble_idx < 1 || ensemble_idx > nensb) { + stop("ensemble_idx must be between 1 and ", + nensb, ".", call. = FALSE) + }#IF + }#IF + invisible(type) +}#VALIDATE_METHOD_ARGS + # 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)) { @@ -363,7 +382,7 @@ validate_inputs <- function(y = NULL, D = NULL, X = NULL, Z = NULL, if (!is.list(l) || (is.null(l$what) && is.null(l$fun))) { stop("Each stacking learner must have a ", - "'what' or 'fun' element.", + "'what' element.", call. = FALSE) }#IF }#FOR @@ -372,27 +391,33 @@ validate_inputs <- function(y = NULL, D = NULL, X = NULL, Z = NULL, } if (!is.null(sample_folds)) { - if (!is.numeric(sample_folds) || length(sample_folds) > 1 || sample_folds < 1 || sample_folds %% 1 != 0) { + if (!is.numeric(sample_folds) || length(sample_folds) > 1 || + sample_folds < 1 || sample_folds %% 1 != 0) { stop("sample_folds must be a positive integer.") } } if (!is.null(cv_folds)) { - if (!is.numeric(cv_folds) || length(cv_folds) > 1 || cv_folds < 1 || cv_folds %% 1 != 0) { + if (!is.numeric(cv_folds) || length(cv_folds) > 1 || + cv_folds < 1 || cv_folds %% 1 != 0) { stop("cv_folds must be a positive integer.") } } 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.") + 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.") } } 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.") + 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.") } } @@ -404,6 +429,12 @@ validate_inputs <- function(y = NULL, D = NULL, X = NULL, Z = NULL, stop("weights must have the same length as y.") } } + + if (!is.null(cluster_variable)) { + if (anyNA(cluster_variable)) { + stop("cluster_variable must not contain NAs.") + } + } }#VALIDATE_INPUTS validate_custom_weights <- function(custom_weights, learners) { @@ -427,13 +458,13 @@ compute_ncustom_nensb <- function(ensemble_type, list(ncustom = ncustom, nensb = nensb) }#COMPUTE_NCUSTOM_NENSB -# Update ensemble info from CEF result weights or oos_fitted. +# Update ensemble info from CEF result weights or cf_fitted. update_ensemble_info <- function(res_weights = NULL, - oos_fitted = NULL) { + cf_fitted = NULL) { if (!is.null(res_weights)) { ensemble_type <- dimnames(res_weights)[[2]] - } else if (!is.null(oos_fitted)) { - ensemble_type <- colnames(as.matrix(oos_fitted)) + } else if (!is.null(cf_fitted)) { + ensemble_type <- colnames(as.matrix(cf_fitted)) } else { ensemble_type <- NULL }#IFELSE diff --git a/R/inference_functions.R b/R/inference_functions.R deleted file mode 100644 index f474708..0000000 --- a/R/inference_functions.R +++ /dev/null @@ -1,113 +0,0 @@ -compute_leverage <- function(object, ensemble_idx = 1) { - if (is.list(object$psi_a)) { - psi_a_j <- object$psi_a[[min(ensemble_idx, length(object$psi_a))]] - J_j <- object$J[[min(ensemble_idx, length(object$J))]] - J_inv <- solve(J_j) - J_inv_vec <- as.vector(t(J_inv)) - - p <- ncol(J_j) - n <- object$nobs - dim(psi_a_j) <- c(n, p * p) - h <- (psi_a_j %*% J_inv_vec) / n - return(as.vector(h)) - } else if (!is.null(object$psi_a) && is.matrix(object$psi_a)) { - psi_a_j <- object$psi_a[, - min(ensemble_idx, ncol(object$psi_a))] - J_j <- as.numeric(object$J[[min(ensemble_idx, length(object$J))]]) - return(as.vector(psi_a_j / (object$nobs * J_j))) - }#IFELSE - - # Fallback for gracefully handling objects generated by older package versions - fit_obj <- if (!is.null(object$ols_fit)) { - object$ols_fit - } else { - object$iv_fit - }#IFELSE - if (is.list(fit_obj) && - !inherits(fit_obj, "lm") && - !inherits(fit_obj, "ivreg")) { - fit_obj <- fit_obj[[ensemble_idx]] - }#IF - as.vector(stats::hatvalues(fit_obj)) -}#COMPUTE_LEVERAGE - -compute_ddml_variance <- function(scores, J, - cluster_variable = NULL, - type = "HC1", - leverage = NULL) { - type <- match.arg(type, c("HC0", "HC1", "HC3")) - sc <- as.matrix(scores) - J_j <- as.matrix(J) - p <- ncol(sc) - - # Cluster aggregation: rowsum scores to cluster level - clustered <- !is.null(cluster_variable) && - !identical(seq_len(nrow(sc)), - as.integer(cluster_variable)) - if (clustered) { - sc <- rowsum(sc, cluster_variable) - }#IF - - n_eff <- nrow(sc) - - if (type == "HC3") { - h <- leverage - if (clustered) { - h <- as.vector(tapply(h, cluster_variable, sum)) - }#IF - sc <- sc / (1 - h) - meat <- crossprod(sc) / n_eff - J_inv <- solve(J_j) - V <- J_inv %*% meat %*% t(J_inv) / n_eff - } else if (type == "HC1") { - meat <- crossprod(sc) / n_eff - J_inv <- solve(J_j) - V <- J_inv %*% meat %*% t(J_inv) * - n_eff / (n_eff - p) / n_eff - } else { - # HC0 - meat <- crossprod(sc) / n_eff - J_inv <- solve(J_j) - V <- J_inv %*% meat %*% t(J_inv) / n_eff - }#IFELSE - - V -}#COMPUTE_DDML_VARIANCE - -compute_ddml_inference <- function(coefficients, scores, J, - coef_names = NULL, - ensemble_type, - cluster_variable = NULL, - type = "HC1", - leverage_list = NULL) { - nensb <- length(ensemble_type) - p <- nrow(coefficients) - - inf_results <- array(0, dim = c(p, 4, nensb)) - - for (j in seq_len(nensb)) { - theta_j <- coefficients[, j] - h <- if (!is.null(leverage_list)) leverage_list[[j]] - - V <- compute_ddml_variance(scores[[j]], J[[j]], - cluster_variable, - type = type, - leverage = h) - se <- sqrt(diag(V)) - t_val <- theta_j / se - p_val <- 2 * stats::pnorm(abs(t_val), - lower.tail = FALSE) - - inf_results[, 1, j] <- theta_j - inf_results[, 2, j] <- se - inf_results[, 3, j] <- t_val - inf_results[, 4, j] <- p_val - }#FOR - - dimnames(inf_results) <- list( - coef_names, - c("Estimate", "Std. Error", "t value", "Pr(>|t|)"), - ensemble_type - ) - inf_results -}#COMPUTE_DDML_INFERENCE diff --git a/R/methods.R b/R/methods.R index 7015169..d621f5e 100644 --- a/R/methods.R +++ b/R/methods.R @@ -21,6 +21,10 @@ #' Extract Model Coefficients #' +#' @description Extracts the estimated coefficients +#' from a DDML model for the specified or default +#' ensemble type. +#' #' @param object An object of class \code{ddml}. #' @param ... Currently unused. #' @@ -39,6 +43,7 @@ #' coef(plm_fit) #' } #' +#' @family ddml inference #' @export coef.ddml <- function(object, ...) { cf <- object$coefficients @@ -52,17 +57,75 @@ coef.ddml <- function(object, ...) { #' Extract Number of Observations #' +#' @description Returns the number of observations +#' used to fit the DDML model. +#' #' @param object An object of class \code{ddml}. #' @param ... Currently unused. #' #' @return An integer specifying the number of observations. #' +#' @family ddml inference #' @importFrom stats nobs #' @export nobs.ddml <- function(object, ...) { object$nobs }#NOBS.DDML +#' Extract Generalized Leverage (Hat Values) +#' +#' @description Computes the generalized leverage (hat values) for a DDML +#' estimator. These values are used internally to compute heteroskedasticity-robust +#' HC3 standard errors. +#' +#' @param model An object of class \code{ddml}. +#' @param ensemble_idx Integer index of the ensemble type to extract leverage +#' values for. Defaults to 1. +#' @param ... Currently unused. +#' +#' @return A numeric vector of generalized leverage values. +#' +#' @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) +#' h = hatvalues(plm_fit) +#' head(h) +#' } +#' +#' @seealso \code{\link{vcov.ddml}} for the use of leverage in HC3 standard errors. +#' +#' @family ddml inference +#' @importFrom stats hatvalues +#' @export +hatvalues.ddml <- function(model, ensemble_idx = 1, ...) { + validate_method_args(model, ensemble_idx = ensemble_idx) + if (is.list(model$psi_a)) { + psi_a_j <- model$psi_a[[ensemble_idx]] + J_j <- model$J[[ensemble_idx]] + J_inv <- csolve(J_j) + J_inv_vec <- as.vector(t(J_inv)) + + p <- ncol(J_j) + n <- model$nobs + dim(psi_a_j) <- c(n, p * p) + h <- (psi_a_j %*% J_inv_vec) / n + return(as.vector(h)) + }#IF + + psi_a_j <- model$psi_a[, ensemble_idx] + J_j <- as.numeric(model$J[[ensemble_idx]]) + as.vector(psi_a_j / (model$nobs * J_j)) +}#HATVALUES.DDML + + + + + #' Variance-Covariance Matrix for DDML Estimators #' #' @description Computes a heteroskedasticity-robust @@ -83,18 +146,18 @@ nobs.ddml <- function(object, ...) { #' available: #' #' \strong{HC0}: -#' \deqn{V_{\textrm{HC0}} = \hat{J}^{-1} +#' \deqn{V_{\mathrm{HC0}} = \hat{J}^{-1} #' \left(\frac{1}{n}\sum_i m_i m_i'\right) #' \hat{J}^{-\top} / n} #' #' \strong{HC1} (default): -#' \deqn{V_{\textrm{HC1}} = V_{\textrm{HC0}} +#' \deqn{V_{\mathrm{HC1}} = V_{\mathrm{HC0}} #' \times \frac{n}{n - p}} #' #' where \eqn{p} is the dimension of \eqn{\theta}. #' #' \strong{HC3}: -#' \deqn{V_{\textrm{HC3}} = \hat{J}^{-1} +#' \deqn{V_{\mathrm{HC3}} = \hat{J}^{-1} #' \left(\frac{1}{n}\sum_i #' \frac{m_i m_i'}{(1 - h_{ii})^2}\right) #' \hat{J}^{-\top} / n} @@ -140,26 +203,68 @@ nobs.ddml <- function(object, ...) { #' vcov(plm_fit, type = "HC3") #' } #' +#' @seealso \code{\link{hatvalues.ddml}}, +#' \code{\link{confint.ddml}}, +#' \code{\link{summary.ddml}} +#' +#' @family ddml inference #' @export vcov.ddml <- function(object, ensemble_idx = 1, type = "HC1", ...) { + type <- validate_method_args(object, + ensemble_idx = ensemble_idx, type = type) + h <- if (type == "HC3") { - compute_leverage(object, ensemble_idx) + stats::hatvalues(object, ensemble_idx = ensemble_idx) }#IF - V <- compute_ddml_variance( - object$scores[[ensemble_idx]], - object$J[[ensemble_idx]], - object$cluster_variable, - type = type, - leverage = h) + + sc <- as.matrix(object$scores[[ensemble_idx]]) + J_j <- as.matrix(object$J[[ensemble_idx]]) + p <- ncol(sc) + + # Cluster aggregation: rowsum scores to cluster level + clustered <- !is.null(object$cluster_variable) && + length(unique(object$cluster_variable)) < nrow(sc) + if (clustered) { + sc <- rowsum(sc, object$cluster_variable) + }#IF + + n_eff <- nrow(sc) + + if (type == "HC3") { + if (clustered) { + h <- as.vector(tapply(h, object$cluster_variable, sum)) + }#IF + sc <- sc / (1 - h) + meat <- crossprod(sc) / n_eff + J_inv <- csolve(J_j) + V <- J_inv %*% meat %*% t(J_inv) / n_eff + } else if (type == "HC1") { + meat <- crossprod(sc) / n_eff + J_inv <- csolve(J_j) + V <- J_inv %*% meat %*% t(J_inv) * + n_eff / (n_eff - p) / n_eff + } else { + # HC0 + meat <- crossprod(sc) / n_eff + J_inv <- csolve(J_j) + V <- J_inv %*% meat %*% t(J_inv) / n_eff + }#IFELSE + rownames(V) <- colnames(V) <- object$coef_names V }#VCOV.DDML #' Confidence Intervals for DDML Estimators #' +#' @description Computes confidence intervals for one or more +#' parameters in a fitted DDML model. +#' #' @param object An object of class \code{ddml}. -#' @param parm Not used (included for generic compatibility). +#' @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. #' @inheritParams vcov.ddml #' @param ... Currently unused. @@ -175,39 +280,47 @@ vcov.ddml <- function(object, ensemble_idx = 1, #' learners = list(what = ols), #' sample_folds = 2, silent = TRUE) #' confint(plm_fit) +#' confint(plm_fit, parm = "D1") #' confint(plm_fit, level = 0.90) #' } +#' +#' @seealso \code{\link{vcov.ddml}} #' +#' @family ddml inference #' @importFrom stats vcov #' @export confint.ddml <- function(object, parm, level = 0.95, ensemble_idx = 1, type = "HC1", ...) { cf <- object$coefficients[, ensemble_idx] + cf_names <- object$coef_names + + if (missing(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.") + }#IF + }#IFELSE + + cf <- cf[parm] V <- vcov(object, ensemble_idx = ensemble_idx, type = type) - se <- sqrt(diag(V)) + se <- sqrt(diag(V))[parm] + z <- stats::qnorm((1 + level) / 2) 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) <- object$coef_names + rownames(ci) <- parm ci }#CONFINT.DDML -#' Subscript a DDML Summary Object (Deprecated) -#' -#' Delegates \code{[} to the underlying inference array. -#' This method exists for backward compatibility only; -#' use \code{x$coefficients[...]} instead. -#' -#' @param x An object of class \code{summary.ddml}. -#' @param ... Indices passed to \code{[} on the inference -#' array. -#' -#' @return The subset of the inference array. -#' +#' @rdname summary.ddml #' @export `[.summary.ddml` <- function(x, ...) { message("Note: subscripting a summary.ddml object with ", @@ -224,13 +337,21 @@ confint.ddml <- function(object, parm, level = 0.95, #' \code{\link{vcov.ddml}} for the HC0/HC1/HC3 formulas. #' #' @param object An object of class \code{ddml}. -#' @param type Character string specifying the -#' variance-covariance estimator. One of \code{"HC1"} -#' (default), \code{"HC0"}, or \code{"HC3"}. See -#' \code{\link{vcov.ddml}} for details. +#' @inheritParams vcov.ddml #' @param ... Currently unused. #' -#' @return An object of class \code{summary.ddml}. +#' @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{ @@ -244,30 +365,45 @@ confint.ddml <- function(object, parm, level = 0.95, #' summary(plm_fit, type = "HC3") #' } #' +#' @seealso \code{\link{vcov.ddml}} +#' +#' @family ddml inference #' @export summary.ddml <- function(object, type = "HC1", ...) { type <- match.arg(type, c("HC0", "HC1", "HC3")) + single_learner <- is_single_learner(object$learners) ens_type <- if (single_learner) { "single base learner" } else { object$ensemble_type }#IFELSE + + nensb <- length(ens_type) + p <- nrow(object$coefficients) - h_list <- if (type == "HC3") { - lapply(seq_along(object$scores), function(j) { - compute_leverage(object, j) - }) - }#IF - inf <- compute_ddml_inference( - coefficients = object$coefficients, - scores = object$scores, - J = object$J, - coef_names = object$coef_names, - ensemble_type = ens_type, - cluster_variable = object$cluster_variable, - type = type, - leverage_list = h_list) + inf <- array(0, dim = c(p, 4, nensb)) + + for (j in seq_len(nensb)) { + theta_j <- object$coefficients[, j] + + V <- stats::vcov(object, ensemble_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|)"), + ens_type + ) result <- list( coefficients = inf, @@ -284,13 +420,10 @@ summary.ddml <- function(object, type = "HC1", ...) { result }#SUMMARY.DDML -#' Print Summary for DDML Estimators +#' @rdname summary.ddml #' #' @param x An object of class \code{summary.ddml}. #' @param digits Number of significant digits. Default 3. -#' @param ... Currently unused. -#' -#' @return \code{x}, invisibly. #' #' @export print.summary.ddml <- function(x, digits = 3, ...) { diff --git a/R/ml_wrappers.R b/R/ml_wrappers.R index f82499f..641ff73 100644 --- a/R/ml_wrappers.R +++ b/R/ml_wrappers.R @@ -50,7 +50,7 @@ mdl_glmnet <- function(y, X, #' @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) { @@ -107,7 +107,8 @@ mdl_xgboost <- function(y, X, ...){ # Compute xgboost dots <- list(...) - if (is.null(dots$params$objective) && is.null(dots$objective) && is.factor(y) && length(levels(y)) == 2) { + 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, @@ -171,13 +172,11 @@ predict.mdl_ranger <- function(object, newdata = NULL, ...){ 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") diff --git a/R/ols.R b/R/ols.R index 5f2a233..e8f851d 100644 --- a/R/ols.R +++ b/R/ols.R @@ -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 diff --git a/R/shortstacking.R b/R/shortstacking.R index c8d80a2..6eba9a5 100644 --- a/R/shortstacking.R +++ b/R/shortstacking.R @@ -23,20 +23,20 @@ #' #' @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 = TRUE}. +#' \item{\code{insample_fitted}}{When \code{compute_insample_predictions = TRUE}. #' a list of matrices with in-sample predictions by sample fold.} #' \item{\code{auxiliary_fitted}}{When \code{auxiliary_X} is not #' \code{NULL}, a list of matrices with additional predictions.} -#' \item{\code{crossfit_fitted}}{A matrix of +#' \item{\code{cf_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 +#' \item{\code{insample_fitted_bylearner}}{When #' \code{compute_insample_predictions = TRUE}, a list of matrices with #' in-sample predictions by sample fold.} #' \item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} is @@ -72,8 +72,8 @@ #' "singlebest"), #' sample_folds = 2, #' silent = TRUE) -#' dim(shortstack_res$oos_fitted) # = length(y) by length(ensemble_type) -#' dim(shortstack_res$crossfit_fitted) # = 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) shortstacking <- function(y, X, Z = NULL, learners, sample_folds = 2, @@ -119,72 +119,72 @@ shortstacking <- function(y, X, Z = NULL, # Compute ensemble weights via subsample cross-fitted residual fakecv <- list() - fakecv$oos_resid <- matrix(shortstack_y, nobs, nlearners) - - res$crossfit_fitted + fakecv$cv_resid <- matrix(shortstack_y, nobs, nlearners) - + res$cf_fitted_bylearner weights <- ensemble_weights(shortstack_y, X, learners = learners, type = ensemble_type, custom_weights = custom_ensemble_weights, cv_results = fakecv)$weights # Compute predictions - oos_fitted <- res$crossfit_fitted %*% 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 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) + insample_fitted <- rep(list(NULL), sample_folds) fakecv_k <- list() if (compute_insample_predictions) { for (k in seq_len(sample_folds)) { # Compute shortstacking weights in-sample nobs_k <- length(y[-subsamples[[k]]]) - fakecv_k$oos_resid <- matrix(y[-subsamples[[k]]], nobs_k, nlearners) - - res$is_fitted_bylearner[[k]] + fakecv_k$cv_resid <- matrix(y[-subsamples[[k]]], nobs_k, nlearners) - + res$insample_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 + insample_fitted[[k]] <- res$insample_fitted_bylearner[[k]] %*% weights_k }#FOR - # When multiple ensembles are computed, need to reorganize is_fitted + # When multiple ensembles are computed, need to reorganize insample_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) + # Loop over each ensemble type to create list of insample_fitted's + new_insample_fitted <- rep(list(rep(list(1), sample_folds)), nensb) for (i in seq_len(nensb)) { for (k in seq_len(sample_folds)) { - new_is_fitted[[i]][[k]] <- is_fitted[[k]][, i, drop = FALSE] + new_insample_fitted[[i]][[k]] <- insample_fitted[[k]][, i, drop = FALSE] }#FOR }#FOR - is_fitted <- new_is_fitted + insample_fitted <- new_insample_fitted }#IF }#IF # Compute mspe and r-squared - mspe <- colMeans((matrix(shortstack_y, nobs, nensb) - oos_fitted)^2) + mspe <- colMeans((matrix(shortstack_y, nobs, nensb) - cf_fitted)^2) y_var <- as.numeric(stats::var(shortstack_y)) r2 <- if (y_var > 0) 1 - mspe / y_var else rep(NA_real_, length(mspe)) # Per-learner OOS residuals (already computed for weight estimation) - crossfit_resid <- as.matrix(fakecv$oos_resid) + cf_resid_bylearner <- as.matrix(fakecv$cv_resid) # return shortstacking output - output <- list(oos_fitted = oos_fitted, + output <- list(cf_fitted = cf_fitted, weights = weights, mspe = mspe, r2 = r2, - is_fitted = is_fitted, + insample_fitted = insample_fitted, auxiliary_fitted = auxiliary_fitted, - crossfit_fitted = res$crossfit_fitted, - crossfit_resid = crossfit_resid, - is_fitted_bylearner = res$is_fitted_bylearner, + cf_fitted_bylearner = res$cf_fitted_bylearner, + cf_resid_bylearner = cf_resid_bylearner, + insample_fitted_bylearner = res$insample_fitted_bylearner, auxiliary_fitted_bylearner = res$auxiliary_fitted_bylearner) return(output) }#SHORTSTACKING diff --git a/R/subsample_functions.R b/R/subsample_functions.R index ffa2e4c..ec47609 100644 --- a/R/subsample_functions.R +++ b/R/subsample_functions.R @@ -13,7 +13,7 @@ get_sample_splits <- function(cluster_variable, by_D <- !is.null(D) # Auto-merge subsamples_byD into subsamples when only byD is given - if (is.null(subsamples) & !is.null(subsamples_byD)) { + if (is.null(subsamples) && !is.null(subsamples_byD)) { if (!by_D) stop("subsamples_byD requires D to be specified.") subsamples <- merge_subsamples_byD(subsamples_byD, D) }#IF @@ -107,12 +107,12 @@ get_crossfit_indices <- function(cluster_variable, # Check whether subsamples need to be constructed compute_cf <- FALSE - if (is.null(subsamples) & is.null(subsamples_byD)) { + if (is.null(subsamples) && is.null(subsamples_byD)) { compute_cf <- TRUE - } else if (is.null(subsamples) & !is.null(subsamples_byD)) { + } else if (is.null(subsamples) && !is.null(subsamples_byD)) { stop(paste0("``subsamples`` must also be set when setting ", "``subsamples_byD``.")) - } else if (!is.null(subsamples) & is.null(subsamples_byD) & by_D) { + } else if (!is.null(subsamples) && is.null(subsamples_byD) && by_D) { stop(paste0("When ``by_D==TRUE``, ``subsamples_byD`` must also be set ", "when setting ``subsamples``.")) }#IF @@ -178,18 +178,18 @@ check_subsamples <- function(subsamples, subsamples_byD, stratify, FUN = function(x, y) y - x) if (min(training_counts_byD) < 100) throw_warning <- TRUE }#IF - if (throw_warning & !by_D) { + 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) { + } 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) { + } 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 ", diff --git a/R/tidy.R b/R/tidy.R index 7858774..ff92474 100644 --- a/R/tidy.R +++ b/R/tidy.R @@ -44,12 +44,13 @@ generics::glance #' tidy(plm_fit, conf.int = TRUE) #' } #' -#' @family ddml #' @export #' @method tidy ddml tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, conf.level = 0.95, type = "HC1", ...) { + type <- match.arg(type, c("HC1", "HC0", "HC3")) + s <- summary(x, type = type) inf <- s$coefficients nensb <- dim(inf)[3] @@ -58,30 +59,50 @@ tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, if (is.null(ensemble_idx)) { j_seq <- seq_len(nensb) } else { + if (any(ensemble_idx < 1) || any(ensemble_idx > nensb)) { + stop(sprintf("ensemble_idx must be between 1 and %d", nensb)) + }#IF j_seq <- ensemble_idx }#IFELSE - rows <- list() + # Pre-allocate rows + n_rows <- length(j_seq) * p + term <- rep(dimnames(inf)[[1]], length(j_seq)) + ensemble_type <- rep(dimnames(inf)[[3]][j_seq], each = p) + + estimate <- numeric(n_rows) + std.error <- numeric(n_rows) + statistic <- numeric(n_rows) + p.value <- numeric(n_rows) + + idx <- 1 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], - ensemble_type = dimnames(inf)[[3]][j], - stringsAsFactors = FALSE - ) - if (conf.int) { - z <- stats::qnorm((1 + conf.level) / 2) - row$conf.low <- inf[k, 1, j] - z * inf[k, 2, j] - row$conf.high <- inf[k, 1, j] + z * inf[k, 2, j] - }#IF - rows[[length(rows) + 1]] <- row + 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 - do.call(rbind, rows) + + res <- data.frame( + term = term, + estimate = estimate, + std.error = std.error, + statistic = statistic, + p.value = p.value, + ensemble_type = ensemble_type, + stringsAsFactors = FALSE + ) + + if (conf.int) { + z <- stats::qnorm((1 + conf.level) / 2) + res$conf.low <- res$estimate - z * res$std.error + res$conf.high <- res$estimate + z * res$std.error + }#IF + + res }#TIDY.DDML #' Glance at a ddml Object @@ -108,7 +129,9 @@ tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, #' glance(plm_fit) #' } #' -#' @family ddml +#' @seealso \code{\link{tidy.ddml}}, +#' \code{\link{summary.ddml}} +#' #' @export #' @method glance ddml glance.ddml <- function(x, ...) { diff --git a/man/AE98.Rd b/man/AE98.Rd index 38bac52..58696c6 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/coef.ddml.Rd b/man/coef.ddml.Rd index 413f914..6d8740a 100644 --- a/man/coef.ddml.Rd +++ b/man/coef.ddml.Rd @@ -16,7 +16,9 @@ Named vector (single ensemble) or matrix (multiple ensembles). } \description{ -Extract Model Coefficients +Extracts the estimated coefficients +from a DDML model for the specified or default +ensemble type. } \examples{ \donttest{ @@ -31,3 +33,12 @@ coef(plm_fit) } } +\seealso{ +Other ddml inference: +\code{\link{[.summary.ddml}()}, +\code{\link{confint.ddml}()}, +\code{\link{hatvalues.ddml}()}, +\code{\link{nobs.ddml}()}, +\code{\link{vcov.ddml}()} +} +\concept{ddml inference} diff --git a/man/coef.ddml_rep.Rd b/man/coef.ddml_rep.Rd index 20ae346..405a833 100644 --- a/man/coef.ddml_rep.Rd +++ b/man/coef.ddml_rep.Rd @@ -4,13 +4,14 @@ \alias{coef.ddml_rep} \title{Extract Aggregated Coefficients from a ddml_rep Object} \usage{ -\method{coef}{ddml_rep}(object, aggregation = c("median", "mean"), ...) +\method{coef}{ddml_rep}(object, aggregation = c("median", "mean", "spectral"), ...) } \arguments{ \item{object}{A \code{ddml_rep} object.} -\item{aggregation}{Character string, either -\code{"median"} (default) or \code{"mean"}.} +\item{aggregation}{Character string: \code{"median"} +(default), \code{"mean"}, or \code{"spectral"}. +See \code{\link{summary.ddml_rep}} for details.} \item{...}{Additional arguments.} } @@ -35,3 +36,7 @@ coef(reps, aggregation = "mean") } } +\seealso{ +\code{\link{summary.ddml_rep}} for the +aggregation equations. +} diff --git a/man/confint.ddml.Rd b/man/confint.ddml.Rd index 97505b3..e9447b6 100644 --- a/man/confint.ddml.Rd +++ b/man/confint.ddml.Rd @@ -9,7 +9,10 @@ \arguments{ \item{object}{An object of class \code{ddml}.} -\item{parm}{Not used (included for generic compatibility).} +\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.} @@ -26,7 +29,8 @@ variance-covariance estimator. One of \code{"HC1"} A matrix with columns for lower and upper bounds. } \description{ -Confidence Intervals for DDML Estimators +Computes confidence intervals for one or more +parameters in a fitted DDML model. } \examples{ \donttest{ @@ -37,7 +41,19 @@ plm_fit = ddml_plm(y, D, X, learners = list(what = ols), sample_folds = 2, silent = TRUE) confint(plm_fit) +confint(plm_fit, parm = "D1") confint(plm_fit, level = 0.90) } } +\seealso{ +\code{\link{vcov.ddml}} + +Other ddml inference: +\code{\link{[.summary.ddml}()}, +\code{\link{coef.ddml}()}, +\code{\link{hatvalues.ddml}()}, +\code{\link{nobs.ddml}()}, +\code{\link{vcov.ddml}()} +} +\concept{ddml inference} diff --git a/man/confint.ddml_rep.Rd b/man/confint.ddml_rep.Rd index e30d75c..4e59f7f 100644 --- a/man/confint.ddml_rep.Rd +++ b/man/confint.ddml_rep.Rd @@ -9,7 +9,7 @@ parm, level = 0.95, ensemble_idx = 1, - aggregation = c("median", "mean"), + aggregation = c("median", "mean", "spectral"), type = "HC1", ... ) @@ -17,15 +17,19 @@ \arguments{ \item{object}{A \code{ddml_rep} object.} -\item{parm}{Not used (included for generic compatibility).} +\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{ensemble_idx}{Integer index of the ensemble type. Defaults to 1.} -\item{aggregation}{Character string, either -\code{"median"} (default) or \code{"mean"}.} +\item{aggregation}{Character string: \code{"median"} +(default), \code{"mean"}, or \code{"spectral"}. +See \code{\link{summary.ddml_rep}} for details.} \item{type}{Character string specifying the variance-covariance estimator. One of \code{"HC1"} @@ -53,3 +57,7 @@ confint(reps, level = 0.90) } } +\seealso{ +\code{\link{summary.ddml_rep}} for the +aggregation equations. +} diff --git a/man/crosspred.Rd b/man/crosspred.Rd index b98b183..e30761a 100644 --- a/man/crosspred.Rd +++ b/man/crosspred.Rd @@ -2,7 +2,7 @@ % 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, @@ -44,19 +44,19 @@ such that it predicts a named input \code{y} using a named input 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 +\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 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.} +corresponding to predictive 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}) +used in \code{what}. Omission of \code{assign_X} (and/or \code{assign_Z}) results in inclusion of all variables in \code{X} (and/or \code{Z}).} \item{sample_folds}{Number of cross-fitting folds.} @@ -116,21 +116,21 @@ 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 +\item{\code{insample_fitted}}{When \code{compute_insample_predictions = TRUE}. a list of matrices with in-sample predictions by sample fold.} \item{\code{auxiliary_fitted}}{When \code{auxiliary_X} is not \code{NULL}, a list of matrices with additional predictions.} -\item{\code{crossfit_fitted}}{A matrix of out-of-sample +\item{\code{cf_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 +\item{\code{insample_fitted_bylearner}}{When \code{compute_insample_predictions = TRUE}, a list of matrices with in-sample predictions by sample fold (per learner).} \item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} @@ -139,7 +139,48 @@ 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 @@ -160,8 +201,8 @@ crosspred_res <- crosspred(y, X, sample_folds = 2, cv_folds = 2, silent = TRUE) -dim(crosspred_res$oos_fitted) # = length(y) by length(ensemble_type) -dim(crosspred_res$crossfit_fitted) # = 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 diff --git a/man/crossval.Rd b/man/crossval.Rd index 85c682e..89a0401 100644 --- a/man/crossval.Rd +++ b/man/crossval.Rd @@ -26,10 +26,10 @@ crossval( \item{learners}{\code{learners} is a list of lists, each containing four 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.} @@ -38,7 +38,7 @@ 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}) +used in \code{what}. Omission of \code{assign_X} (and/or \code{assign_Z}) results in inclusion of all predictive variables in \code{X} (and/or \code{Z}).} @@ -68,18 +68,51 @@ that use packages not imported by \code{ddml}).} \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"] diff --git a/man/ddml_apo.Rd b/man/ddml_apo.Rd index 715f445..c01fdd3 100644 --- a/man/ddml_apo.Rd +++ b/man/ddml_apo.Rd @@ -56,16 +56,16 @@ such that it predicts a named input \code{y} using a named input 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 +\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 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 +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 @@ -151,31 +151,30 @@ compatibility but should be replaced with the \code{splits} argument.} } \value{ -\code{ddml_apo} returns a list object of class \code{ddml_apo} -and \code{ddml} with the following properties: +\code{ddml_apo} returns an object of S3 class +\code{ddml_apo}. An object of class \code{ddml_apo} is a list +containing the following components: \describe{ \item{\code{coefficients}}{A matrix of estimated coefficients.} -\item{\code{ensemble_weights}}{The ensemble weights.} -\item{\code{mspe}}{The in-sample mean squared prediction errors.} +\item{\code{ensemble_weights}}{A list of matrices, providing the +weight assigned to each base learner by the ensemble +procedure.} +\item{\code{mspe}}{A list of matrices, providing the MSPE of each +base learner computed by the cross-validation step in the +ensemble construction.} \item{\code{r2}}{The out-of-sample R-squared.} -\item{\code{psi_a}, \code{psi_b}}{The scale and scores associated with -evaluating the Neyman orthogonal score.} -\item{\code{scores}}{A list of evaluating the Neyman orthogonal scores.} -\item{\code{J}}{A list of evaluating the Jacobian of the Neyman -orthogonal scores.} -\item{\code{fitted}}{An optional list of fitted nuisance estimators. +\item{\code{psi_a}, \code{psi_b}}{Score components used in +\code{\link{vcov.ddml}}.} +\item{\code{scores}}{A list of evaluated Neyman orthogonal +scores.} +\item{\code{J}}{A list of evaluated Jacobians.} +\item{\code{fitted}}{A list of fitted nuisance estimators. See \code{\link{ddml_plm}} for more information.} \item{\code{splits}}{The data splitting structure.} -\item{\code{learners}}{The original list of learners.} -\item{\code{learners_DX}}{The original list of learners for the propensity -score.} -\item{\code{ensemble_type}}{The ensemble type.} -\item{\code{nobs}}{The number of observations.} -\item{\code{sample_folds}}{The number of sample folds.} -\item{\code{cv_folds}}{The number of cross-validation folds.} -\item{\code{shortstack}}{A boolean indicating if shortstacking was used.} -\item{\code{cluster_variable}}{The original cluster variable.} -\item{\code{call}}{The match.call().} +\item{\code{learners},\code{learners_DX}, +\code{cluster_variable}, +\code{ensemble_type}}{Pass-through of selected +user-provided arguments. See above.} } } \description{ @@ -219,7 +218,9 @@ Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). \url{https://arxiv.org/abs/2401.01645} } \seealso{ -\code{\link{summary.ddml}} +\code{\link{summary.ddml}}, +\code{\link{vcov.ddml}}, \code{\link{confint.ddml}}, +\code{\link{hatvalues.ddml}}, \code{\link{ddml_plm}}, \code{\link{ddml_pliv}}, \code{\link{ddml_fpliv}}, \code{\link{ddml_late}}, \code{\link{ddml_ate}} diff --git a/man/ddml_ate.Rd b/man/ddml_ate.Rd index c660081..522037f 100644 --- a/man/ddml_ate.Rd +++ b/man/ddml_ate.Rd @@ -72,16 +72,16 @@ such that it predicts a named input \code{y} using a named input 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 +\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 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 +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 @@ -172,8 +172,8 @@ procedure.} base learner computed by the cross-validation step in the ensemble construction.} \item{\code{r2}}{The out-of-sample R-squared.} -\item{\code{psi_a}, \code{psi_b}}{Matrices needed for the -computation of scores. Used in \code{\link[=summary.ddml]{summary.ddml()}}.} +\item{\code{psi_a}, \code{psi_b}}{Score components used in +\code{\link{vcov.ddml}}.} \item{\code{scores}}{A list of evaluated Neyman orthogonal scores.} \item{\code{J}}{A list of evaluated Jacobians.} @@ -269,19 +269,14 @@ Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. } \seealso{ \code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, -\code{\link[=confint.ddml]{confint.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, +\code{\link[=vcov.ddml]{vcov.ddml()}}, \code{\link[=confint.ddml]{confint.ddml()}}, +\code{\link[=hatvalues.ddml]{hatvalues.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, \code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}} -Other ddml: +Other ddml estimators: \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()}, -\code{\link{ddml_rep}()}, -\code{\link{ddml_replicate}()}, -\code{\link{glance.ddml}()}, -\code{\link{glance.ddml_rep}()}, -\code{\link{tidy.ddml}()}, -\code{\link{tidy.ddml_rep}()} +\code{\link{ddml_plm}()} } -\concept{ddml} +\concept{ddml estimators} diff --git a/man/ddml_fpliv.Rd b/man/ddml_fpliv.Rd index 1a54b2d..05e6bd4 100644 --- a/man/ddml_fpliv.Rd +++ b/man/ddml_fpliv.Rd @@ -51,10 +51,10 @@ such that it predicts a named input \code{y} using a named input 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 +\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 control variables in \code{X} that are passed to the base learner.} @@ -63,7 +63,7 @@ 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}) +used in \code{what}. Omission of \code{assign_X} (and/or \code{assign_Z}) results in inclusion of all variables in \code{X} (and/or \code{Z}).} \item{learners_DXZ, learners_DX}{Optional arguments to allow for different @@ -143,22 +143,26 @@ with the \code{splits} argument.} \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 and -the second-stage intercept (last element).} -\item{\code{ensemble_weights}}{A list of matrices, providing the weight -assigned to each base learner (in chronological order) by the -ensemble procedure.} +\item{\code{coefficients}}{A matrix of estimated coefficients.} +\item{\code{ensemble_weights}}{A list of matrices, providing the +weight assigned to each base learner 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},\code{ensemble_type}}{Pass-through of -selected user-provided arguments. See above.} +base learner computed by the cross-validation step in the +ensemble construction.} +\item{\code{r2}}{The out-of-sample R-squared.} +\item{\code{psi_a}, \code{psi_b}}{Score components used in +\code{\link{vcov.ddml}}.} +\item{\code{scores}}{A list of evaluated Neyman orthogonal +scores.} +\item{\code{J}}{A list of evaluated Jacobians.} +\item{\code{fitted}}{A list of fitted nuisance estimators. +See \code{\link{ddml_plm}} for more information.} +\item{\code{splits}}{The data splitting structure.} +\item{\code{learners},\code{learners_DXZ}, +\code{learners_DX},\code{cluster_variable}, +\code{ensemble_type}}{Pass-through of selected +user-provided arguments. See above.} } } \description{ @@ -214,20 +218,15 @@ Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. } \seealso{ \code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, -\code{\link[=confint.ddml]{confint.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, +\code{\link[=vcov.ddml]{vcov.ddml()}}, \code{\link[=confint.ddml]{confint.ddml()}}, +\code{\link[=hatvalues.ddml]{hatvalues.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, \code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}}, \code{\link[AER:ivreg]{AER::ivreg()}} -Other ddml: +Other ddml estimators: \code{\link{ddml_ate}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()}, -\code{\link{ddml_rep}()}, -\code{\link{ddml_replicate}()}, -\code{\link{glance.ddml}()}, -\code{\link{glance.ddml_rep}()}, -\code{\link{tidy.ddml}()}, -\code{\link{tidy.ddml_rep}()} +\code{\link{ddml_plm}()} } -\concept{ddml} +\concept{ddml estimators} diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index 90b624f..57949c6 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -53,10 +53,10 @@ such that it predicts a named input \code{y} using a named input 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 +\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 control variables in \code{X} that are passed to the base learner.} @@ -65,7 +65,7 @@ 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}) +used in \code{what}. Omission of \code{assign_X} (and/or \code{assign_Z}) results in inclusion of all variables in \code{X} (and/or \code{Z}).} \item{learners_DXZ, learners_ZX}{Optional arguments to allow for different @@ -159,8 +159,8 @@ procedure.} each base learner computed by the cross-validation step in the ensemble construction.} \item{\code{r2}}{The out-of-sample R-squared.} -\item{\code{psi_a}, \code{psi_b}}{Matrices needed for the -computation of scores. Used in \code{\link[=summary.ddml]{summary.ddml()}}.} +\item{\code{psi_a}, \code{psi_b}}{Score components used in +\code{\link{vcov.ddml}}.} \item{\code{scores}}{A list of evaluated Neyman orthogonal scores.} \item{\code{J}}{A list of evaluated Jacobians.} @@ -260,19 +260,14 @@ Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. } \seealso{ \code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, -\code{\link[=confint.ddml]{confint.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, +\code{\link[=vcov.ddml]{vcov.ddml()}}, \code{\link[=confint.ddml]{confint.ddml()}}, +\code{\link[=hatvalues.ddml]{hatvalues.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, \code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}} -Other ddml: +Other ddml estimators: \code{\link{ddml_ate}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()}, -\code{\link{ddml_rep}()}, -\code{\link{ddml_replicate}()}, -\code{\link{glance.ddml}()}, -\code{\link{glance.ddml_rep}()}, -\code{\link{tidy.ddml}()}, -\code{\link{tidy.ddml_rep}()} +\code{\link{ddml_plm}()} } -\concept{ddml} +\concept{ddml estimators} diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index 76f43d8..6889b4f 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -51,10 +51,10 @@ such that it predicts a named input \code{y} using a named input 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 +\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 control variables in \code{X} that are passed to the base learner.} @@ -63,7 +63,7 @@ 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}) +used in \code{what}. Omission of \code{assign_X} (and/or \code{assign_Z}) results in inclusion of all variables in \code{X} (and/or \code{Z}).} \item{learners_DX, learners_ZX}{Optional arguments to allow for different @@ -150,22 +150,26 @@ with the \code{splits} argument.} \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 and -the second-stage intercept (last element).} -\item{\code{ensemble_weights}}{A list of matrices, providing the weight -assigned to each base learner (in chronological order) by the -ensemble procedure.} +\item{\code{coefficients}}{A matrix of estimated coefficients.} +\item{\code{ensemble_weights}}{A list of matrices, providing the +weight assigned to each base learner 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.} +base learner computed by the cross-validation step in the +ensemble construction.} +\item{\code{r2}}{The out-of-sample R-squared.} +\item{\code{psi_a}, \code{psi_b}}{Score components used in +\code{\link{vcov.ddml}}.} +\item{\code{scores}}{A list of evaluated Neyman orthogonal +scores.} +\item{\code{J}}{A list of evaluated Jacobians.} +\item{\code{fitted}}{A list of fitted nuisance estimators. +See \code{\link{ddml_plm}} for more information.} +\item{\code{splits}}{The data splitting structure.} \item{\code{learners},\code{learners_DX},\code{learners_ZX}, -\code{cluster_variable}, \code{subsamples}, -\code{cv_subsamples},\code{ensemble_type}}{Pass-through of -selected user-provided arguments. See above.} +\code{cluster_variable}, +\code{ensemble_type}}{Pass-through of selected +user-provided arguments. See above.} } } \description{ @@ -224,20 +228,15 @@ Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. } \seealso{ \code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, -\code{\link[=confint.ddml]{confint.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, +\code{\link[=vcov.ddml]{vcov.ddml()}}, \code{\link[=confint.ddml]{confint.ddml()}}, +\code{\link[=hatvalues.ddml]{hatvalues.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, \code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}}, \code{\link[AER:ivreg]{AER::ivreg()}} -Other ddml: +Other ddml estimators: \code{\link{ddml_ate}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, -\code{\link{ddml_plm}()}, -\code{\link{ddml_rep}()}, -\code{\link{ddml_replicate}()}, -\code{\link{glance.ddml}()}, -\code{\link{glance.ddml_rep}()}, -\code{\link{tidy.ddml}()}, -\code{\link{tidy.ddml_rep}()} +\code{\link{ddml_plm}()} } -\concept{ddml} +\concept{ddml estimators} diff --git a/man/ddml_plm.Rd b/man/ddml_plm.Rd index aefc726..9d89a9a 100644 --- a/man/ddml_plm.Rd +++ b/man/ddml_plm.Rd @@ -46,16 +46,16 @@ such that it predicts a named input \code{y} using a named input 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 +\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 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 +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 @@ -138,21 +138,27 @@ with the \code{splits} argument.} \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 and -the second-stage intercept (last element).} -\item{\code{ensemble_weights}}{A list of matrices, providing the weight -assigned to each base learner (in chronological order) by the -ensemble procedure.} +\item{\code{coefficients}}{A matrix of estimated coefficients.} +\item{\code{ensemble_weights}}{A list of matrices, providing the +weight assigned to each base learner 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}, -\code{ensemble_type}}{Pass-through of selected user-provided -arguments. See above.} +base learner computed by the cross-validation step in the +ensemble construction.} +\item{\code{r2}}{The out-of-sample R-squared.} +\item{\code{psi_a}, \code{psi_b}}{Score components used in +\code{\link{vcov.ddml}}.} +\item{\code{scores}}{A list of evaluated Neyman orthogonal +scores.} +\item{\code{J}}{A list of evaluated Jacobians.} +\item{\code{fitted}}{A list of fitted nuisance estimators. +Can be passed back via the \code{fitted} argument to +skip cross-fitting on re-estimation.} +\item{\code{splits}}{The data splitting structure.} +\item{\code{learners},\code{learners_DX}, +\code{cluster_variable}, +\code{ensemble_type}}{Pass-through of selected +user-provided arguments. See above.} } } \description{ @@ -240,19 +246,14 @@ Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. } \seealso{ \code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, -\code{\link[=confint.ddml]{confint.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, +\code{\link[=vcov.ddml]{vcov.ddml()}}, \code{\link[=confint.ddml]{confint.ddml()}}, +\code{\link[=hatvalues.ddml]{hatvalues.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, \code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}} -Other ddml: +Other ddml estimators: \code{\link{ddml_ate}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, -\code{\link{ddml_pliv}()}, -\code{\link{ddml_rep}()}, -\code{\link{ddml_replicate}()}, -\code{\link{glance.ddml}()}, -\code{\link{glance.ddml_rep}()}, -\code{\link{tidy.ddml}()}, -\code{\link{tidy.ddml_rep}()} +\code{\link{ddml_pliv}()} } -\concept{ddml} +\concept{ddml estimators} diff --git a/man/ddml_rep.Rd b/man/ddml_rep.Rd index 8992f7b..b3a3a16 100644 --- a/man/ddml_rep.Rd +++ b/man/ddml_rep.Rd @@ -2,15 +2,22 @@ % 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{"ddml_rep"} with fields: @@ -48,16 +55,7 @@ summary(reps) \seealso{ \code{\link[=ddml_replicate]{ddml_replicate()}} -Other ddml: -\code{\link{ddml_ate}()}, -\code{\link{ddml_fpliv}()}, -\code{\link{ddml_late}()}, -\code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()}, -\code{\link{ddml_replicate}()}, -\code{\link{glance.ddml}()}, -\code{\link{glance.ddml_rep}()}, -\code{\link{tidy.ddml}()}, -\code{\link{tidy.ddml_rep}()} -} -\concept{ddml} +Other ddml replication: +\code{\link{ddml_replicate}()} +} +\concept{ddml replication} diff --git a/man/ddml_replicate.Rd b/man/ddml_replicate.Rd index 3602814..c5cf666 100644 --- a/man/ddml_replicate.Rd +++ b/man/ddml_replicate.Rd @@ -44,16 +44,7 @@ summary(reps) \seealso{ \code{\link[=ddml_rep]{ddml_rep()}} -Other ddml: -\code{\link{ddml_ate}()}, -\code{\link{ddml_fpliv}()}, -\code{\link{ddml_late}()}, -\code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()}, -\code{\link{ddml_rep}()}, -\code{\link{glance.ddml}()}, -\code{\link{glance.ddml_rep}()}, -\code{\link{tidy.ddml}()}, -\code{\link{tidy.ddml_rep}()} +Other ddml replication: +\code{\link{ddml_rep}()} } -\concept{ddml} +\concept{ddml replication} diff --git a/man/glance.ddml.Rd b/man/glance.ddml.Rd index 5f49608..51eb3ac 100644 --- a/man/glance.ddml.Rd +++ b/man/glance.ddml.Rd @@ -34,16 +34,6 @@ glance(plm_fit) } \seealso{ -Other ddml: -\code{\link{ddml_ate}()}, -\code{\link{ddml_fpliv}()}, -\code{\link{ddml_late}()}, -\code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()}, -\code{\link{ddml_rep}()}, -\code{\link{ddml_replicate}()}, -\code{\link{glance.ddml_rep}()}, -\code{\link{tidy.ddml}()}, -\code{\link{tidy.ddml_rep}()} +\code{\link{tidy.ddml}}, +\code{\link{summary.ddml}} } -\concept{ddml} diff --git a/man/glance.ddml_rep.Rd b/man/glance.ddml_rep.Rd index d5e9902..74fd2d9 100644 --- a/man/glance.ddml_rep.Rd +++ b/man/glance.ddml_rep.Rd @@ -35,17 +35,3 @@ glance(reps) } } -\seealso{ -Other ddml: -\code{\link{ddml_ate}()}, -\code{\link{ddml_fpliv}()}, -\code{\link{ddml_late}()}, -\code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()}, -\code{\link{ddml_rep}()}, -\code{\link{ddml_replicate}()}, -\code{\link{glance.ddml}()}, -\code{\link{tidy.ddml}()}, -\code{\link{tidy.ddml_rep}()} -} -\concept{ddml} diff --git a/man/hatvalues.ddml.Rd b/man/hatvalues.ddml.Rd new file mode 100644 index 0000000..ecd83c6 --- /dev/null +++ b/man/hatvalues.ddml.Rd @@ -0,0 +1,48 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods.R +\name{hatvalues.ddml} +\alias{hatvalues.ddml} +\title{Extract Generalized Leverage (Hat Values)} +\usage{ +\method{hatvalues}{ddml}(model, ensemble_idx = 1, ...) +} +\arguments{ +\item{model}{An object of class \code{ddml}.} + +\item{ensemble_idx}{Integer index of the ensemble type to extract leverage +values for. Defaults to 1.} + +\item{...}{Currently unused.} +} +\value{ +A numeric vector of generalized leverage values. +} +\description{ +Computes the generalized leverage (hat values) for a DDML +estimator. These values are used internally to compute heteroskedasticity-robust +HC3 standard errors. +} +\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) +h = hatvalues(plm_fit) +head(h) +} + +} +\seealso{ +\code{\link{vcov.ddml}} for the use of leverage in HC3 standard errors. + +Other ddml inference: +\code{\link{[.summary.ddml}()}, +\code{\link{coef.ddml}()}, +\code{\link{confint.ddml}()}, +\code{\link{nobs.ddml}()}, +\code{\link{vcov.ddml}()} +} +\concept{ddml inference} diff --git a/man/nobs.ddml.Rd b/man/nobs.ddml.Rd index 89b606d..697cfe2 100644 --- a/man/nobs.ddml.Rd +++ b/man/nobs.ddml.Rd @@ -15,5 +15,15 @@ An integer specifying the number of observations. } \description{ -Extract Number of Observations +Returns the number of observations +used to fit the DDML model. } +\seealso{ +Other ddml inference: +\code{\link{[.summary.ddml}()}, +\code{\link{coef.ddml}()}, +\code{\link{confint.ddml}()}, +\code{\link{hatvalues.ddml}()}, +\code{\link{vcov.ddml}()} +} +\concept{ddml inference} diff --git a/man/nobs.ddml_rep.Rd b/man/nobs.ddml_rep.Rd new file mode 100644 index 0000000..f6fea74 --- /dev/null +++ b/man/nobs.ddml_rep.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_rep.R +\name{nobs.ddml_rep} +\alias{nobs.ddml_rep} +\title{Extract Number of Observations from a ddml_rep Object} +\usage{ +\method{nobs}{ddml_rep}(object, ...) +} +\arguments{ +\item{object}{A \code{ddml_rep} object.} + +\item{...}{Currently unused.} +} +\value{ +An integer specifying the number of observations. +} +\description{ +Extract Number of Observations from a ddml_rep Object +} diff --git a/man/print.ddml_rep.Rd b/man/print.ddml_rep.Rd deleted file mode 100644 index 280289d..0000000 --- a/man/print.ddml_rep.Rd +++ /dev/null @@ -1,32 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml_rep.R -\name{print.ddml_rep} -\alias{print.ddml_rep} -\title{Print a ddml_rep Object} -\usage{ -\method{print}{ddml_rep}(x, ...) -} -\arguments{ -\item{x}{A \code{ddml_rep} object.} - -\item{...}{Currently unused.} -} -\value{ -\code{x}, invisibly. -} -\description{ -Displays a brief overview of a \code{ddml_rep} object. -} -\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) -reps -} - -} diff --git a/man/print.summary.ddml.Rd b/man/print.summary.ddml.Rd deleted file mode 100644 index 4b739d1..0000000 --- a/man/print.summary.ddml.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/methods.R -\name{print.summary.ddml} -\alias{print.summary.ddml} -\title{Print Summary for DDML Estimators} -\usage{ -\method{print}{summary.ddml}(x, digits = 3, ...) -} -\arguments{ -\item{x}{An object of class \code{summary.ddml}.} - -\item{digits}{Number of significant digits. Default 3.} - -\item{...}{Currently unused.} -} -\value{ -\code{x}, invisibly. -} -\description{ -Print Summary for DDML Estimators -} diff --git a/man/print.summary.ddml_rep.Rd b/man/print.summary.ddml_rep.Rd deleted file mode 100644 index 94fe8a3..0000000 --- a/man/print.summary.ddml_rep.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml_rep.R -\name{print.summary.ddml_rep} -\alias{print.summary.ddml_rep} -\title{Print Summary for ddml_rep Objects} -\usage{ -\method{print}{summary.ddml_rep}(x, digits = 3, ...) -} -\arguments{ -\item{x}{An object of class \code{summary.ddml_rep}.} - -\item{digits}{Number of significant digits. Default 3.} - -\item{...}{Currently unused.} -} -\value{ -\code{x}, invisibly. -} -\description{ -Print Summary for ddml_rep Objects -} diff --git a/man/shortstacking.Rd b/man/shortstacking.Rd index df32eaa..6c5241d 100644 --- a/man/shortstacking.Rd +++ b/man/shortstacking.Rd @@ -42,19 +42,19 @@ such that it predicts a named input \code{y} using a named input 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 +\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 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.} +corresponding to predictive 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}) +used in \code{what}. Omission of \code{assign_X} (and/or \code{assign_Z}) results in inclusion of all variables in \code{X} (and/or \code{Z}).} \item{sample_folds}{Number of cross-fitting folds.} @@ -110,20 +110,20 @@ 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 = TRUE}. +\item{\code{insample_fitted}}{When \code{compute_insample_predictions = TRUE}. a list of matrices with in-sample predictions by sample fold.} \item{\code{auxiliary_fitted}}{When \code{auxiliary_X} is not \code{NULL}, a list of matrices with additional predictions.} -\item{\code{crossfit_fitted}}{A matrix of +\item{\code{cf_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 +\item{\code{insample_fitted_bylearner}}{When \code{compute_insample_predictions = TRUE}, a list of matrices with in-sample predictions by sample fold.} \item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} is @@ -155,8 +155,8 @@ shortstack_res <- shortstacking(y, X, "singlebest"), sample_folds = 2, silent = TRUE) -dim(shortstack_res$oos_fitted) # = length(y) by length(ensemble_type) -dim(shortstack_res$crossfit_fitted) # = 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 diff --git a/man/sub-.summary.ddml.Rd b/man/sub-.summary.ddml.Rd deleted file mode 100644 index 5ee980a..0000000 --- a/man/sub-.summary.ddml.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/methods.R -\name{[.summary.ddml} -\alias{[.summary.ddml} -\title{Subscript a DDML Summary Object (Deprecated)} -\usage{ -\method{[}{summary.ddml}(x, ...) -} -\arguments{ -\item{x}{An object of class \code{summary.ddml}.} - -\item{...}{Indices passed to \code{[} on the inference -array.} -} -\value{ -The subset of the inference array. -} -\description{ -Delegates \code{[} to the underlying inference array. -This method exists for backward compatibility only; -use \code{x$coefficients[...]} instead. -} diff --git a/man/summary.ddml.Rd b/man/summary.ddml.Rd index 081be5d..3ad6bb6 100644 --- a/man/summary.ddml.Rd +++ b/man/summary.ddml.Rd @@ -1,23 +1,43 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/methods.R -\name{summary.ddml} +\name{[.summary.ddml} +\alias{[.summary.ddml} \alias{summary.ddml} +\alias{print.summary.ddml} \title{Summary for DDML Estimators} \usage{ +\method{[}{summary.ddml}(x, ...) + \method{summary}{ddml}(object, type = "HC1", ...) + +\method{print}{summary.ddml}(x, digits = 3, ...) } \arguments{ +\item{x}{An object of class \code{summary.ddml}.} + +\item{...}{Currently unused.} + \item{object}{An object of class \code{ddml}.} \item{type}{Character string specifying the variance-covariance estimator. One of \code{"HC1"} -(default), \code{"HC0"}, or \code{"HC3"}. See -\code{\link{vcov.ddml}} for details.} +(default), \code{"HC0"}, or \code{"HC3"}.} -\item{...}{Currently unused.} +\item{digits}{Number of significant digits. Default 3.} } \value{ -An object of class \code{summary.ddml}. +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, @@ -39,3 +59,14 @@ summary(plm_fit, type = "HC3") } } +\seealso{ +\code{\link{vcov.ddml}} + +Other ddml inference: +\code{\link{coef.ddml}()}, +\code{\link{confint.ddml}()}, +\code{\link{hatvalues.ddml}()}, +\code{\link{nobs.ddml}()}, +\code{\link{vcov.ddml}()} +} +\concept{ddml inference} diff --git a/man/summary.ddml_rep.Rd b/man/summary.ddml_rep.Rd index a1af08c..f5ed28b 100644 --- a/man/summary.ddml_rep.Rd +++ b/man/summary.ddml_rep.Rd @@ -2,27 +2,64 @@ % 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"), type = "HC1", ...) +\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, either -\code{"median"} (default) or \code{"mean"}.} +\item{aggregation}{Character string: \code{"median"} +(default), \code{"mean"}, or \code{"spectral"}. +See \code{\link{summary.ddml_rep}} for details.} \item{type}{Character string specifying the variance-covariance estimator. One of \code{"HC1"} (default), \code{"HC0"}, or \code{"HC3"}.} \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{ -Summary for ddml_rep Objects +Aggregates coefficient estimates and covariance matrices +across \eqn{R} independent sample-splitting replications. +} +\details{ +Let \eqn{\hat\theta_r} and \eqn{\hat\Sigma_r} denote +the coefficient vector and sandwich covariance matrix +from replication \eqn{r}. + +\strong{Coefficient aggregation.} +For \code{"mean"}: +\eqn{\tilde\theta = R^{-1} \sum_{r=1}^{R} \hat\theta_r}. +For \code{"median"} and \code{"spectral"}: +\eqn{\tilde\theta_j = \mathrm{median}_{r}(\hat\theta_{r,j})}. + +\strong{Covariance aggregation.} +Define the inflated per-replication covariance as +\deqn{V_r = \hat\Sigma_r + (\hat\theta_r - \tilde\theta) + (\hat\theta_r - \tilde\theta)^\top}. +For \code{"mean"}: +\eqn{\tilde\Sigma = R^{-1} \sum_{r=1}^{R} V_r}. +For \code{"median"}: +\eqn{\tilde\Sigma_{ij} = \mathrm{median}_{r}(V_{r,ij})}. +For \code{"spectral"}: +\eqn{\tilde\Sigma = \arg\min_{\Sigma \succeq 0} \sum_{r} \|\Sigma - V_r\|_2}, +solved via \pkg{CVXR}. Guarantees positive semi-definiteness of \eqn{\tilde\Sigma}. } \examples{ \donttest{ @@ -38,3 +75,10 @@ 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/tidy.ddml.Rd b/man/tidy.ddml.Rd index e51b6e4..7665736 100644 --- a/man/tidy.ddml.Rd +++ b/man/tidy.ddml.Rd @@ -58,17 +58,3 @@ tidy(plm_fit, conf.int = TRUE) } } -\seealso{ -Other ddml: -\code{\link{ddml_ate}()}, -\code{\link{ddml_fpliv}()}, -\code{\link{ddml_late}()}, -\code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()}, -\code{\link{ddml_rep}()}, -\code{\link{ddml_replicate}()}, -\code{\link{glance.ddml}()}, -\code{\link{glance.ddml_rep}()}, -\code{\link{tidy.ddml_rep}()} -} -\concept{ddml} diff --git a/man/tidy.ddml_rep.Rd b/man/tidy.ddml_rep.Rd index e027aef..e02f137 100644 --- a/man/tidy.ddml_rep.Rd +++ b/man/tidy.ddml_rep.Rd @@ -7,7 +7,7 @@ \method{tidy}{ddml_rep}( x, ensemble_idx = 1, - aggregation = c("median", "mean"), + aggregation = c("median", "mean", "spectral"), type = "HC1", conf.int = FALSE, conf.level = 0.95, @@ -21,8 +21,9 @@ to report. Defaults to 1. Set to \code{NULL} to return results for all ensemble types.} -\item{aggregation}{Character string, either -\code{"median"} (default) or \code{"mean"}.} +\item{aggregation}{Character string: \code{"median"} +(default), \code{"mean"}, or \code{"spectral"}. +See \code{\link{summary.ddml_rep}} for details.} \item{type}{Character string specifying the variance-covariance estimator. One of \code{"HC1"} @@ -39,9 +40,9 @@ Default 0.95.} \value{ A \code{data.frame} with columns \code{term}, \code{estimate}, \code{std.error}, \code{statistic}, -\code{p.value}, and \code{ensemble_type}. If -\code{conf.int = TRUE}, also \code{conf.low} and -\code{conf.high}. +\code{p.value}, \code{ensemble_type}, and +\code{aggregation}. If \code{conf.int = TRUE}, +also \code{conf.low} and \code{conf.high}. } \description{ Extracts aggregated coefficient estimates, standard @@ -64,16 +65,6 @@ tidy(reps, conf.int = TRUE) } \seealso{ -Other ddml: -\code{\link{ddml_ate}()}, -\code{\link{ddml_fpliv}()}, -\code{\link{ddml_late}()}, -\code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()}, -\code{\link{ddml_rep}()}, -\code{\link{ddml_replicate}()}, -\code{\link{glance.ddml}()}, -\code{\link{glance.ddml_rep}()}, -\code{\link{tidy.ddml}()} +\code{\link{summary.ddml_rep}} for the +aggregation equations. } -\concept{ddml} diff --git a/man/vcov.ddml.Rd b/man/vcov.ddml.Rd index 5a7b8c3..b9d3d27 100644 --- a/man/vcov.ddml.Rd +++ b/man/vcov.ddml.Rd @@ -41,18 +41,18 @@ the sample Jacobian. Three sandwich estimators are available: \strong{HC0}: -\deqn{V_{\textrm{HC0}} = \hat{J}^{-1} +\deqn{V_{\mathrm{HC0}} = \hat{J}^{-1} \left(\frac{1}{n}\sum_i m_i m_i'\right) \hat{J}^{-\top} / n} \strong{HC1} (default): -\deqn{V_{\textrm{HC1}} = V_{\textrm{HC0}} +\deqn{V_{\mathrm{HC1}} = V_{\mathrm{HC0}} \times \frac{n}{n - p}} where \eqn{p} is the dimension of \eqn{\theta}. \strong{HC3}: -\deqn{V_{\textrm{HC3}} = \hat{J}^{-1} +\deqn{V_{\mathrm{HC3}} = \hat{J}^{-1} \left(\frac{1}{n}\sum_i \frac{m_i m_i'}{(1 - h_{ii})^2}\right) \hat{J}^{-\top} / n} @@ -89,3 +89,16 @@ vcov(plm_fit, type = "HC3") } } +\seealso{ +\code{\link{hatvalues.ddml}}, +\code{\link{confint.ddml}}, +\code{\link{summary.ddml}} + +Other ddml inference: +\code{\link{[.summary.ddml}()}, +\code{\link{coef.ddml}()}, +\code{\link{confint.ddml}()}, +\code{\link{hatvalues.ddml}()}, +\code{\link{nobs.ddml}()} +} +\concept{ddml inference} diff --git a/man/vcov.ddml_rep.Rd b/man/vcov.ddml_rep.Rd index b4c8d46..64cc338 100644 --- a/man/vcov.ddml_rep.Rd +++ b/man/vcov.ddml_rep.Rd @@ -7,7 +7,7 @@ \method{vcov}{ddml_rep}( object, ensemble_idx = 1, - aggregation = c("median", "mean"), + aggregation = c("median", "mean", "spectral"), type = "HC1", ... ) @@ -18,8 +18,9 @@ \item{ensemble_idx}{Integer index of the ensemble type. Defaults to 1.} -\item{aggregation}{Character string, either -\code{"median"} (default) or \code{"mean"}.} +\item{aggregation}{Character string: \code{"median"} +(default), \code{"mean"}, or \code{"spectral"}. +See \code{\link{summary.ddml_rep}} for details.} \item{type}{Character string specifying the variance-covariance estimator. One of \code{"HC1"} @@ -47,3 +48,7 @@ vcov(reps) } } +\seealso{ +\code{\link{summary.ddml_rep}} for the +aggregation equations. +} diff --git a/tests/testthat/test-crosspred.R b/tests/testthat/test-crosspred.R index 3dd118a..40e5c2a 100644 --- a/tests/testthat/test-crosspred.R +++ b/tests/testthat/test-crosspred.R @@ -24,8 +24,8 @@ test_that("crosspred computes with a single model", { 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) + expect_equal(length(crosspred_res$cf_fitted), length(y)) + expect_equal(length(crosspred_res$insample_fitted), 3) })#TEST_THAT test_that("crosspred computes with ensemble procedures", { @@ -49,8 +49,8 @@ test_that("crosspred computes with ensemble procedures", { 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) + expect_equal(dim(crosspred_res$cf_fitted), c(length(y), 5)) + expect_equal(length(crosspred_res$insample_fitted), 5) })#TEST_THAT test_that("crosspred computes with ensemble procedures & custom weights", { @@ -78,8 +78,8 @@ test_that("crosspred computes with ensemble procedures & custom weights", { compute_insample_predictions = T, silent = T) # 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)) + expect_equal(length(crosspred_res$insample_fitted), 8) })#TEST_THAT test_that("crosspred computes with ensemble procedures and sparse matrices", { @@ -103,8 +103,8 @@ test_that("crosspred computes with ensemble procedures and sparse matrices", { 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) + expect_equal(dim(crosspred_res$cf_fitted), c(length(y), 5)) + expect_equal(length(crosspred_res$insample_fitted), 5) })#TEST_THAT test_that("crosspred computes auxilliary predictions", { @@ -156,6 +156,6 @@ test_that("crosspred returns identical results with parallel", { cv_subsamples = splits$cv_subsamples, silent = T, parallel = list(cores = 2)) - expect_equal(res_par$oos_fitted, res_seq$oos_fitted) + 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 380576a..ff690d6 100644 --- a/tests/testthat/test-crossval.R +++ b/tests/testthat/test-crossval.R @@ -6,10 +6,10 @@ test_that("crossval_compute returns residuals (w/o instruments)", { test_sample <- sample(1:length(y), 33) learner <- list(what = ols) # Compute cross-validation instance - oos_resid <- crossval_compute(test_sample, learner, + cv_resid <- crossval_compute(test_sample, learner, y, X, Z = NULL) # 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)", { @@ -28,7 +28,7 @@ test_that("crossval returns residuals by learner (w/o instruments)", { cv_folds = 3, silent = T) # 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,16 +38,16 @@ 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 @@ -60,8 +60,8 @@ test_that("crossval returns residuals by learner in correct order", { silent = T) # 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)", { @@ -79,8 +79,8 @@ test_that("crossval returns residuals by learner (w/ instruments)", { 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) + expect_equal(all(round(cv_res$cv_resid[, 1], 3) == + round(cv_res$cv_resid[, 2], 3)), TRUE) })#TEST_THAT test_that("crossval returns identical results with parallel", { @@ -101,5 +101,5 @@ test_that("crossval returns identical results with parallel", { cv_subsamples = cv_subs, silent = T, parallel = list(cores = 2)) expect_equal(res_par$mspe, res_seq$mspe) - expect_equal(res_par$oos_resid, res_seq$oos_resid) + expect_equal(res_par$cv_resid, res_seq$cv_resid) })#TEST_THAT diff --git a/tests/testthat/test-ddml_fpliv.R b/tests/testthat/test-ddml_fpliv.R index df6e179..6a3a9bb 100644 --- a/tests/testthat/test-ddml_fpliv.R +++ b/tests/testthat/test-ddml_fpliv.R @@ -42,28 +42,6 @@ test_that("ddml_fpliv computes with a single model and dependence", { })#TEST_THAT test_that("ddml_fpliv computes with an ensemble procedure", { - # 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(what = ols), - list(what = 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 = TRUE) - # Check output with expectations - expect_equal(length(coef(ddml_fpliv_fit)), 2) -})#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)) @@ -78,8 +56,8 @@ test_that("ddml_fpliv computes with stacking w/o enforcing the LIE", { ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, ensemble_type = "ols", - sample_folds = 3, cv_folds = 3, + sample_folds = 3, silent = TRUE) # Check output with expectations expect_equal(length(coef(ddml_fpliv_fit)), 2) @@ -96,7 +74,7 @@ test_that("ddml_fpliv computes with multiple ensemble procedures", { # Define arguments learners <- list(list(what = ols), list(what = ols)) - # Compute LIE-conform DDML IV estimator + # Compute DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, ensemble_type = c("ols", "nnls", @@ -120,7 +98,7 @@ test_that("ddml_fpliv computes with custom weights", { # Define arguments learners <- list(list(what = ols), list(what = ols)) - # Compute LIE-conform DDML IV estimator + # Compute DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, ensemble_type = c("average"), @@ -133,29 +111,6 @@ test_that("ddml_fpliv computes with custom weights", { expect_equal(length(coef(ddml_fpliv_fit)), 6) })#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(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 = TRUE) - # Check output with expectations - expect_equal(length(coef(ddml_fpliv_fit)), 8) -})#TEST_THAT - test_that("ddml_fpliv computes with multiple ensembles and sparse matrices", { # Simulate small dataset nobs <- 200 @@ -167,7 +122,7 @@ test_that("ddml_fpliv computes with multiple ensembles and sparse matrices", { # Define arguments learners <- list(list(what = ols), list(what = ols)) - # Compute LIE-conform DDML IV estimator + # Compute DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z = as(Z, "sparseMatrix"), X = as(X, "sparseMatrix"), @@ -197,7 +152,7 @@ test_that("ddml_fpliv computes with different sets of learners", { list(what = ols)) learners_DX <- list(list(what = ols), list(what = ols)) - # Compute LIE-conform DDML IV estimator + # Compute DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, learners_DXZ = learners_DXZ, @@ -223,7 +178,7 @@ test_that("ddml_fpliv computes w/ ensembles & shortstack", { # Define arguments learners <- list(list(what = ols), list(what = ols)) - # Compute LIE-conform DDML IV estimator + # Compute DDML IV estimator ddml_fpliv_fit <- ddml_fpliv(y, D, Z, X, learners, ensemble_type = c("ols", "nnls", @@ -237,28 +192,7 @@ test_that("ddml_fpliv computes w/ ensembles & shortstack", { 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(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 = TRUE) - # Check output with expectations - expect_equal(length(coef(ddml_fpliv_fit)), 8) -})#TEST_THAT + test_that("summary.ddml_fpliv computes with a single model", { # Simulate small dataset @@ -282,28 +216,6 @@ test_that("summary.ddml_fpliv computes with a single model", { })#TEST_THAT test_that("ddml_fpliv computes with an ensemble procedure, 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(what = ols), - list(what = 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 = TRUE) - # Check output with expectations - expect_equal(length(coef(ddml_fpliv_fit)), 3) -})#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)) @@ -327,6 +239,7 @@ test_that("ddml_fpliv computes with an ensemble procedure w/o LIE, multi D", { test_that("ddml_fpliv computes with multiple ensemble procedures, multi D", { # Simulate small dataset + set.seed(51) nobs <- 500 X <- matrix(rnorm(nobs * 5), nobs, 5) Z <- matrix(rnorm(nobs * 3), nobs, 3) @@ -336,29 +249,6 @@ test_that("ddml_fpliv computes with multiple ensemble procedures, multi D", { 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(what = ols), - list(what = 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 = 5, - silent = TRUE) - # Check output with expectations - 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 - 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(what = ols), list(what = ols)) # Compute DDML IV estimator @@ -367,7 +257,7 @@ test_that("ddml_fpliv computes with ensemble procedures w/o LIE, multi D", { ensemble_type = c("ols", "nnls", "singlebest", "average"), cv_folds = 3, - sample_folds = 3, + sample_folds = 5, silent = TRUE) # Check output with expectations expect_equal(length(coef(ddml_fpliv_fit)), 12) @@ -375,6 +265,7 @@ test_that("ddml_fpliv computes with ensemble procedures w/o LIE, multi D", { 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) @@ -390,9 +281,17 @@ test_that("ddml_fpliv HC0/HC1 SEs close to sandwich::vcovHC on iv_fit", { 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$D_X[[1]]$cf_fitted_bylearner[, 1]) + V_r <- as.matrix(fit$fitted$D_XZ[[1]]$cf_fitted_bylearner[, 1] - fit$fitted$D_X[[1]]$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(fit$iv_fit[[1]], 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), @@ -402,7 +301,7 @@ test_that("ddml_fpliv HC0/HC1 SEs close to sandwich::vcovHC on iv_fit", { } # HC3: regressor-based leverage matches sandwich exactly V_ddml <- vcov(fit, type = "HC3") - V_sw <- sandwich::vcovHC(fit$iv_fit[[1]], 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), diff --git a/tests/testthat/test-ddml_pliv.R b/tests/testthat/test-ddml_pliv.R index 89add5f..a5b4809 100644 --- a/tests/testthat/test-ddml_pliv.R +++ b/tests/testthat/test-ddml_pliv.R @@ -247,6 +247,7 @@ test_that("ddml_pliv computes with different ensembles and multivariate D,Z", { 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) @@ -262,9 +263,17 @@ test_that("ddml_pliv HC0/HC1 SEs close to sandwich::vcovHC on iv_fit", { 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$D_X[[1]]$cf_fitted_bylearner[, 1]) + V_r <- as.matrix(Z - fit$fitted$Z_X[[1]]$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(fit$iv_fit[[1]], 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), @@ -274,7 +283,7 @@ test_that("ddml_pliv HC0/HC1 SEs close to sandwich::vcovHC on iv_fit", { } # HC3: regressor-based leverage matches sandwich exactly V_ddml <- vcov(fit, type = "HC3") - V_sw <- sandwich::vcovHC(fit$iv_fit[[1]], 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), diff --git a/tests/testthat/test-ddml_plm.R b/tests/testthat/test-ddml_plm.R index f0494aa..043c7bf 100644 --- a/tests/testthat/test-ddml_plm.R +++ b/tests/testthat/test-ddml_plm.R @@ -368,8 +368,8 @@ test_that("ddml_plm fitted pass-through works", { # fitted should be stored with per-equation crossfit data expect_true(!is.null(fit$fitted)) - expect_true(!is.null(fit$fitted$y_X$crossfit_fitted)) - expect_true(!is.null(fit$fitted$y_X$crossfit_resid)) + 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, @@ -403,7 +403,7 @@ test_that("ddml_plm fitted pass-through works", { ) }) -test_that("ddml_plm pass-through with nnls/nnls1 reproduces exactly via crossval_resid", { +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) @@ -426,10 +426,10 @@ test_that("ddml_plm pass-through with nnls/nnls1 reproduces exactly via crossval splits = splits, silent = TRUE) - # crossval_resid must be stored for exact reproduction + # cv_resid_byfold must be stored for exact reproduction expect_true( - !is.null(fit_fresh$fitted$y_X$crossval_resid), - info = paste(ens, "y_X crossval_resid")) + !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, @@ -460,7 +460,7 @@ test_that("ddml_plm pass-through with save_crossval = FALSE uses approximate pat subsamples = presplits$subsamples, cv_subsamples = presplits$cv_subsamples) - # Fit with save_crossval = FALSE strips crossval_resid + # Fit with save_crossval = FALSE strips cv_resid_byfold fit_no_cv <- ddml_plm(y, D, X, learners = learners, ensemble_type = "nnls1", @@ -468,9 +468,9 @@ test_that("ddml_plm pass-through with save_crossval = FALSE uses approximate pat splits = splits, save_crossval = FALSE, silent = TRUE) - expect_null(fit_no_cv$fitted$y_X$crossval_resid) + expect_null(fit_no_cv$fitted$y_X$cv_resid_byfold) - # average ensemble: still exact without crossval_resid + # average ensemble: still exact without cv_resid_byfold fit_avg <- ddml_plm(y, D, X, learners = learners, ensemble_type = "average", @@ -519,9 +519,15 @@ test_that("ddml_plm HC0/HC1/HC3 SEs close to sandwich::vcovHC on ols_fit", { 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$D_X[[1]]$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(fit$ols_fit[[1]], 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] @@ -532,7 +538,7 @@ test_that("ddml_plm HC0/HC1/HC3 SEs close to sandwich::vcovHC on ols_fit", { } # HC3: regressor-based leverage matches sandwich exactly V_ddml <- vcov(fit, type = "HC3") - V_sw <- sandwich::vcovHC(fit$ols_fit[[1]], 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), diff --git a/tests/testthat/test-help_functions.R b/tests/testthat/test-help_functions.R index de61798..0d631f0 100644 --- a/tests/testthat/test-help_functions.R +++ b/tests/testthat/test-help_functions.R @@ -38,7 +38,7 @@ test_that("normalize_learners resolves what and fun", { # neither → error expect_error( normalize_learners(list(list(args = list()))), - "what.*fun") + "'what' element") # reset flag options(ddml.fun_deprecated_warned = NULL) diff --git a/tests/testthat/test-inference_functions.R b/tests/testthat/test-inference_functions.R deleted file mode 100644 index 55d51b4..0000000 --- a/tests/testthat/test-inference_functions.R +++ /dev/null @@ -1,156 +0,0 @@ -test_that("compute_ddml_variance computes HC1 sandwich variance correctly", { - set.seed(42) - nobs <- 100 - p <- 2 - scores <- matrix(rnorm(nobs * p), nobs, p) - J <- diag(2, p) - - meat <- crossprod(scores) / nobs - J_inv <- solve(J) - expected_v <- J_inv %*% meat %*% t(J_inv) * nobs / (nobs - p) / nobs - - V <- compute_ddml_variance(scores, J) - - expect_true(is.matrix(V)) - expect_equal(dim(V), c(p, p)) - expect_equal(V, expected_v) -}) - -test_that("compute_ddml_variance handles cluster aggregation correctly", { - set.seed(42) - nobs <- 100 - p <- 2 - scores <- matrix(rnorm(nobs * p), nobs, p) - J <- diag(2, p) - cluster_var <- rep(1:50, each = 2) - - V_clustered <- compute_ddml_variance( - scores, J, cluster_variable = cluster_var) - - sc_sum <- rowsum(scores, cluster_var) - n_eff <- 50 - meat <- crossprod(sc_sum) / n_eff - J_inv <- solve(J) - expected_v <- J_inv %*% meat %*% t(J_inv) * - n_eff / (n_eff - p) / n_eff - - expect_equal(V_clustered, expected_v) -}) - -test_that("compute_ddml_variance computes HC0 correctly", { - set.seed(42) - nobs <- 100 - p <- 2 - scores <- matrix(rnorm(nobs * p), nobs, p) - J <- diag(2, p) - - meat <- crossprod(scores) / nobs - J_inv <- solve(J) - expected_v <- J_inv %*% meat %*% t(J_inv) / nobs - - V <- compute_ddml_variance(scores, J, type = "HC0") - - expect_equal(V, expected_v) -}) - -test_that("HC1 equals HC0 scaled by n/(n-p)", { - set.seed(42) - nobs <- 100 - p <- 2 - scores <- matrix(rnorm(nobs * p), nobs, p) - J <- diag(2, p) - - V_hc0 <- compute_ddml_variance(scores, J, type = "HC0") - V_hc1 <- compute_ddml_variance(scores, J, type = "HC1") - - expect_equal(V_hc1, V_hc0 * nobs / (nobs - p)) -}) - -test_that("compute_ddml_variance computes HC3 correctly with leverage", { - set.seed(42) - nobs <- 100 - p <- 2 - scores <- matrix(rnorm(nobs * p), nobs, p) - J <- diag(2, p) - h <- rep(p / nobs, nobs) - - sc_adj <- scores / (1 - h) - meat <- crossprod(sc_adj) / nobs - J_inv <- solve(J) - expected_v <- J_inv %*% meat %*% t(J_inv) / nobs - - V <- compute_ddml_variance(scores, J, type = "HC3", - leverage = h) - - expect_true(is.matrix(V)) - expect_equal(dim(V), c(p, p)) - expect_equal(V, expected_v) -}) - -test_that("HC3 with hat-matrix leverage matches manual computation", { - set.seed(42) - nobs <- 200 - p <- 3 - X <- matrix(rnorm(nobs * p), nobs, p) - h <- rowSums((X %*% solve(crossprod(X))) * X) - - expect_equal(sum(h), p, tolerance = 1e-10) - expect_true(all(h >= 0)) - expect_true(all(h < 1)) - expect_equal(mean(h), p / nobs, tolerance = 1e-10) -}) - -test_that("HC3 with cluster aggregation and leverage", { - set.seed(42) - nobs <- 100 - p <- 2 - scores <- matrix(rnorm(nobs * p), nobs, p) - J <- diag(2, p) - cluster_var <- rep(1:50, each = 2) - h_obs <- rep(p / nobs, nobs) - - V <- compute_ddml_variance( - scores, J, - cluster_variable = cluster_var, - type = "HC3", - leverage = h_obs) - - # Manual: aggregate scores and leverage to cluster level - sc_sum <- rowsum(scores, cluster_var) - h_clust <- as.vector(tapply(h_obs, cluster_var, sum)) - n_eff <- 50 - sc_adj <- sc_sum / (1 - h_clust) - meat <- crossprod(sc_adj) / n_eff - J_inv <- solve(J) - expected_v <- J_inv %*% meat %*% t(J_inv) / n_eff - - expect_equal(V, expected_v) -}) - -test_that("type rejects invalid values", { - scores <- matrix(rnorm(20), 10, 2) - J <- diag(2) - - expect_error( - compute_ddml_variance(scores, J, type = "HC2"), - "arg") -}) - -test_that("HC3 >= HC1 >= HC0 for typical data", { - set.seed(42) - nobs <- 200 - p <- 1 - scores <- matrix(rnorm(nobs * p), nobs, p) - J <- matrix(-1, 1, 1) - h <- rep(p / nobs, nobs) - - se_hc0 <- sqrt(diag(compute_ddml_variance( - scores, J, type = "HC0"))) - se_hc1 <- sqrt(diag(compute_ddml_variance( - scores, J, type = "HC1"))) - se_hc3 <- sqrt(diag(compute_ddml_variance( - scores, J, type = "HC3", leverage = h))) - - expect_true(all(se_hc1 >= se_hc0)) - expect_true(all(se_hc3 >= se_hc0)) -}) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 6384437..1cf3001 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -121,3 +121,92 @@ test_that("type works with PLM estimator", { 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 <- 200 + 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 <- 200 + 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("ensemble_idx out of range errors", { + set.seed(42) + nobs <- 200 + 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, ensemble_idx = 99)) + expect_error(hatvalues(fit, ensemble_idx = 0)) +}) diff --git a/tests/testthat/test-shortstacking.R b/tests/testthat/test-shortstacking.R index 5f3e9d4..2f64ac8 100644 --- a/tests/testthat/test-shortstacking.R +++ b/tests/testthat/test-shortstacking.R @@ -19,6 +19,6 @@ test_that("shortstacking computes with ensemble procedures & custom weights", { compute_insample_predictions = T, silent = F) # 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)) + expect_equal(length(shortstacking_res$insample_fitted), 8) })#TEST_THAT diff --git a/vignettes/articles/example_401k.Rmd.txt b/vignettes/articles/example_401k.Rmd.txt index d5a2087..2294e0c 100644 --- a/vignettes/articles/example_401k.Rmd.txt +++ b/vignettes/articles/example_401k.Rmd.txt @@ -222,13 +222,13 @@ Estimating multiple machine learners via cross-fitting can be computationally ex 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 computed ``crossval_resid`` and ``crossfit_fitted`` objects for the specified learners, we can bypass the estimation step entirely. +Because ``stacking_fit`` already contains the computed ``cv_resid_byfold`` and ``cf_fitted_bylearner`` objects for the specified learners, we can bypass the estimation step entirely. ```{r} # Extract the predictions and residuals from the previous fit advanced_passthrough <- list( - crossfit_fitted = stacking_fit$fitted$crossfit_fitted, - crossval_resid = stacking_fit$fitted$crossval_resid + cf_fitted_bylearner = stacking_fit$fitted$cf_fitted_bylearner, + cv_resid_byfold = stacking_fit$fitted$cv_resid_byfold ) # Recompute the structural parameter instantly using 'singlebest' diff --git a/vignettes/articles/stacking_diagnostics.Rmd.txt b/vignettes/articles/stacking_diagnostics.Rmd.txt index c96023e..29fd6aa 100644 --- a/vignettes/articles/stacking_diagnostics.Rmd.txt +++ b/vignettes/articles/stacking_diagnostics.Rmd.txt @@ -113,7 +113,7 @@ Below, we extract the cross-fitted residuals for the $E[Y|Z=0, X]$ equation and ```{r} # Extract the residuals for the first equation (E[Y|Z=0, X]) -resids <- late_fit$crossfit_resid[[1]] +resids <- late_fit$cf_resid_bylearner[[1]] fold_ids <- late_fit$subsamples_byZ[[1]] # Compare Learner 1 (OLS) vs Learner 2 (Lasso) From dac4d5c930f727f70be5ed670bc9c413c862b6a6 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Mon, 9 Mar 2026 09:10:46 -0500 Subject: [PATCH 20/46] removes Z passthrough --- NEWS.md | 4 ++ R/crosspred.R | 106 +++++----------------------- R/crossval.R | 29 +++----- R/ddml_fpliv.R | 25 +++++-- R/ddml_late.R | 10 +-- R/ddml_pliv.R | 9 +-- R/ensemble.R | 34 ++++----- R/get_CEF.R | 12 +--- R/help_functions.R | 7 +- R/shortstacking.R | 50 ++----------- man/crosspred.Rd | 12 +--- man/crossval.Rd | 13 +--- man/ddml_fpliv.Rd | 9 +-- man/ddml_late.Rd | 9 +-- man/ddml_pliv.Rd | 9 +-- man/ensemble.Rd | 3 - man/ensemble_weights.Rd | 3 - man/shortstacking.Rd | 18 ++--- tests/testthat/test-crosspred.R | 80 +++------------------ tests/testthat/test-crossval.R | 35 +++------ tests/testthat/test-ensemble.R | 65 ++++++----------- tests/testthat/test-shortstacking.R | 9 +-- 22 files changed, 140 insertions(+), 411 deletions(-) diff --git a/NEWS.md b/NEWS.md index 5c55d93..093689c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -17,6 +17,10 @@ * `mdl_xgboost()` auto-detects binary factor outcomes. * Adds `ddml_rep()` and `ddml_replicate()` for repeated cross-fitting with median or mean aggregation. * Fixes `ddml_fpliv()` with custom weights. +* Breaking changes: + - `crosspred()`, `crossval()`, `ensemble()`, `ensemble_weights()`, and `shortstacking()` no longer accept `Z`/`newZ` arguments. Users must pre-concatenate instruments with covariates (e.g., `cbind(X, Z)`). Estimator-level APIs are unchanged. + - `crosspred()` and `shortstacking()` no longer support `compute_insample_predictions`. The `insample_fitted` output components have been removed. + - `ddml_fpliv()` no longer accepts the `enforce_LIE` argument. # ddml 0.3.0 diff --git a/R/crosspred.R b/R/crosspred.R index 129cd6c..23c5510 100644 --- a/R/crosspred.R +++ b/R/crosspred.R @@ -57,7 +57,7 @@ #' \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: +#' 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 @@ -66,13 +66,10 @@ #' \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 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{what}. 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 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: @@ -92,8 +89,6 @@ #' 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 subsamples List of vectors with sample indices for cross-fitting. #' @param cv_subsamples List of lists, each corresponding to a subsample #' containing vectors with subsample indices for cross-validation. @@ -122,17 +117,11 @@ #' \item{\code{weights}}{An array, providing the weight #' assigned to each base learner (in chronological order) by the #' ensemble procedures.} -#' \item{\code{insample_fitted}}{When -#' \code{compute_insample_predictions = TRUE}. -#' a list of matrices with in-sample predictions by sample fold.} #' \item{\code{auxiliary_fitted}}{When \code{auxiliary_X} is not #' \code{NULL}, a list of matrices with additional predictions.} #' \item{\code{cf_fitted_bylearner}}{A matrix of out-of-sample #' predictions, each column corresponding to a base learner #' (in chronological order).} -#' \item{\code{insample_fitted_bylearner}}{When -#' \code{compute_insample_predictions = TRUE}, a list of matrices -#' with in-sample predictions by sample fold (per learner).} #' \item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} #' is not \code{NULL}, a list of matrices with additional #' predictions for each learner.} @@ -166,13 +155,12 @@ #' silent = TRUE) #' 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, Z = NULL, +crosspred <- function(y, X, learners, sample_folds = 10, ensemble_type = "average", cv_folds = 10, custom_ensemble_weights = NULL, - compute_insample_predictions = FALSE, cluster_variable = seq_along(y), subsamples = NULL, cv_subsamples = NULL, @@ -222,7 +210,7 @@ crosspred <- function(y, X, Z = NULL, # Dispatch fold computation fold_fun <- function(k) { crosspred_compute_fold( - k = k, y = y, X = X, Z = Z, + k = k, y = y, X = X, learners = learners, subsamples = subsamples, cv_subsamples_k = cv_subsamples[[k]], @@ -231,7 +219,6 @@ crosspred <- function(y, X, Z = NULL, custom_ensemble_weights = custom_ensemble_weights, calc_ensemble = calc_ensemble, nensb = nensb, nlearners = nlearners, - compute_insample_predictions = compute_insample_predictions, auxiliary_X = auxiliary_X) }#FOLD_FUN @@ -262,8 +249,6 @@ crosspred <- function(y, X, Z = NULL, # Assemble results from fold_results list cf_fitted <- matrix(0, nobs, nensb^(calc_ensemble)) cf_fitted_bylearner <- matrix(0, nobs, nlearners) - insample_fitted <- rep(list(NULL), sample_folds) - insample_fitted_bylearner <- rep(list(NULL), sample_folds) auxiliary_fitted <- rep(list(NULL), sample_folds) auxiliary_fitted_bylearner <- rep(list(NULL), sample_folds) mspe <- matrix(0, nlearners^(calc_ensemble), sample_folds) @@ -280,11 +265,9 @@ crosspred <- function(y, X, Z = NULL, if (!is.null(res$mspe_k)) mspe[, k] <- res$mspe_k if (!is.null(res$r2_k)) r2[, k] <- res$r2_k cv_resid_byfold[[k]] <- res$cv_resid_byfold_k - insample_fitted[[k]] <- res$insample_fitted_k auxiliary_fitted[[k]] <- res$auxiliary_fitted_k cf_fitted_bylearner[res$test_indices, ] <- res$cf_fitted_bylearner_rows - insample_fitted_bylearner[[k]] <- res$insample_fitted_bylearner_k auxiliary_fitted_bylearner[[k]] <- res$auxiliary_fitted_bylearner_k }#FOR @@ -296,77 +279,47 @@ crosspred <- function(y, X, Z = NULL, paste("sample fold ", seq_len(sample_folds))) }#IF - # Reorganize insample_fitted for multiple ensembles - if (compute_insample_predictions && calc_ensemble && nensb > 1) { - new_insample_fitted <- rep(list(rep(list(1), sample_folds)), nensb) - for (i in seq_len(nensb)) { - for (k in seq_len(sample_folds)) { - new_insample_fitted[[i]][[k]] <- - insample_fitted[[k]][, i, drop = FALSE] - }#FOR - }#FOR - insample_fitted <- new_insample_fitted - }#IF - # Compute per-learner OOS residuals (not computed for FPLIV w/ LIE...) - cf_resid_bylearner <- if (is.numeric(y) && !is.list(y)) { - drop(y) - cf_fitted_bylearner - } else { - NULL - }#IFELSE + # Compute per-learner OOS residuals + cf_resid_bylearner <- drop(y) - cf_fitted_bylearner # Organize and return output if (!calc_ensemble) weights <- mspe <- r2 <- cv_resid_byfold <- NULL output <- list(cf_fitted = cf_fitted, weights = weights, mspe = mspe, r2 = r2, cv_resid_byfold = cv_resid_byfold, - insample_fitted = insample_fitted, auxiliary_fitted = auxiliary_fitted, cf_fitted_bylearner = cf_fitted_bylearner, cf_resid_bylearner = cf_resid_bylearner, - insample_fitted_bylearner = insample_fitted_bylearner, auxiliary_fitted_bylearner = auxiliary_fitted_bylearner) return(output) }#CROSSPRED crosspred_compute_fold <- function( - k, y, X, Z, learners, subsamples, cv_subsamples_k, + k, y, X, learners, subsamples, cv_subsamples_k, ensemble_type, cv_folds, custom_ensemble_weights, calc_ensemble, nensb, nlearners, - compute_insample_predictions, auxiliary_X) { test_idx <- subsamples[[k]] train_idx <- -test_idx if (!calc_ensemble) { - learners$args$X <- cbind(X[train_idx, ], Z[train_idx, ]) - if (is.list(y)) { - learners$args$y <- y[[k]] - } else { - learners$args$y <- y[train_idx] - }#IFELSE + learners$args$X <- X[train_idx, ] + learners$args$y <- y[train_idx] mdl_fit <- do.call(do.call, learners) cf_fitted_rows <- as.numeric(stats::predict(mdl_fit, - cbind(X[test_idx, ], - Z[test_idx, ]))) + X[test_idx, ])) } else { - if (is.list(y)) { - y_ <- y[[k]] - } else { - y_ <- y[train_idx] - }#IFELSE - mdl_fit <- ensemble(y_, + mdl_fit <- ensemble(y[train_idx], X[train_idx, , drop = FALSE], - Z[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], - newZ = Z[test_idx, , drop = FALSE])) + newdata = X[test_idx, , drop = FALSE])) }#IFELSE # Ensemble metadata @@ -395,20 +348,6 @@ crosspred_compute_fold <- function( NULL } - # In-sample predictions (optional) - insample_fitted_k <- NULL - if (compute_insample_predictions) { - if (!calc_ensemble) { - insample_fitted_k <- stats::predict(mdl_fit, - cbind(X[train_idx, ], - Z[train_idx, ])) - } else { - insample_fitted_k <- stats::predict(mdl_fit, - newdata = X[train_idx, , drop = FALSE], - newZ = Z[train_idx, , drop = FALSE]) - }#IFELSE - }#IF - # Auxiliary predictions (optional) auxiliary_fitted_k <- NULL if (!is.null(auxiliary_X)) { @@ -416,31 +355,20 @@ crosspred_compute_fold <- function( }#IF # By-learner predictions - insample_fitted_bylearner_k <- NULL auxiliary_fitted_bylearner_k <- NULL if (!calc_ensemble) { cf_fitted_bylearner_rows <- matrix(cf_fitted_rows, ncol = 1) - if (compute_insample_predictions) { - insample_fitted_bylearner_k <- matrix(insample_fitted_k, ncol = 1) - }#IF if (!is.null(auxiliary_X)) { - auxiliary_fitted_bylearner_k <- matrix(auxiliary_fitted_k, ncol = 1) + auxiliary_fitted_bylearner_k <- matrix(auxiliary_fitted_k, + ncol = 1) }#IF } else { mdl_fit_bylearner <- mdl_fit mdl_fit_bylearner$weights <- diag(1, nlearners) cf_fitted_bylearner_rows <- stats::predict( mdl_fit_bylearner, - newdata = X[test_idx, , drop = FALSE], - newZ = Z[test_idx, , drop = FALSE] + newdata = X[test_idx, , drop = FALSE] ) - if (compute_insample_predictions) { - insample_fitted_bylearner_k <- stats::predict( - mdl_fit_bylearner, - newdata = X[train_idx, , drop = FALSE], - newZ = Z[train_idx, , drop = FALSE] - ) - }#IF if (!is.null(auxiliary_X)) { auxiliary_fitted_bylearner_k <- stats::predict( mdl_fit_bylearner, @@ -458,10 +386,8 @@ crosspred_compute_fold <- function( r2_k = r2_k, cv_resid_byfold_k = cv_resid_byfold_k, weight_colnames = weight_colnames, - insample_fitted_k = insample_fitted_k, auxiliary_fitted_k = auxiliary_fitted_k, cf_fitted_bylearner_rows = cf_fitted_bylearner_rows, - insample_fitted_bylearner_k = insample_fitted_bylearner_k, auxiliary_fitted_bylearner_k = auxiliary_fitted_bylearner_k ) }#CROSSPRED_COMPUTE_FOLD diff --git a/R/crossval.R b/R/crossval.R index ab77c3e..cae7d4b 100644 --- a/R/crossval.R +++ b/R/crossval.R @@ -36,8 +36,7 @@ #' @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{what} The base learner function. The function must be @@ -47,14 +46,10 @@ #' \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{what}. 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. @@ -101,7 +96,7 @@ #' cv_folds = 4, #' silent = TRUE) #' cv_res$mspe -crossval <- function(y, X, Z = NULL, +crossval <- function(y, X, learners, cv_folds = 10, cluster_variable = seq_along(y), @@ -140,7 +135,7 @@ crossval <- function(y, X, Z = NULL, fold_x <- cv_subsamples[[i]] crossval_compute(test_sample = fold_x, learner = learners[[j]], - y, X, Z) + y, X) }#CV_FUN # Compute out-of-sample errors @@ -188,18 +183,14 @@ crossval <- function(y, X, Z = NULL, # Complementary functions ====================================================== crossval_compute <- function(test_sample, learner, - y, X, Z = NULL) { + y, X) { if (is.null(learner$assign_X)) learner$assign_X <- seq_len(ncol(X)) - if (is.null(learner$assign_Z) && !is.null(Z)) - learner$assign_Z <- seq_len(ncol(Z)) mdl_fun <- list(what = learner$what, args = learner$args) assign_X <- learner$assign_X - assign_Z <- learner$assign_Z mdl_fun$args$y <- y[-test_sample] - mdl_fun$args$X <- cbind(X[-test_sample, assign_X, drop = FALSE], - Z[-test_sample, assign_Z, drop = FALSE]) + mdl_fun$args$X <- X[-test_sample, assign_X, drop = FALSE] mdl_fit <- tryCatch( do.call(do.call, mdl_fun), @@ -210,10 +201,8 @@ crossval_compute <- function(test_sample, learner, ) cv_fitted <- stats::predict(mdl_fit, - cbind(X[test_sample, assign_X, - drop = FALSE], - Z[test_sample, assign_Z, - drop = FALSE])) + 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) diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index a58a7e4..208d58b 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -169,7 +169,7 @@ ddml_fpliv <- function(y, D, Z, X, # == Reduced-form estimation ====================================== # E[Y|X] - y_X_res <- get_CEF(y, X, Z = NULL, + y_X_res <- get_CEF(y, X, learners = learners, ensemble_type = ensemble_type, shortstack = shortstack, @@ -177,20 +177,32 @@ ddml_fpliv <- function(y, D, Z, X, custom_ensemble_weights, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, - compute_insample_predictions = FALSE, silent = silent, label = messages$y_X, parallel = parallel, fitted = fitted$y_X) - # E[D|X,Z] + # 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 + }) + } D_XZ_res_list <- compute_CEF_list( - D, X, Z = Z, learners = learners_DXZ, + D, 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, - compute_insample_predictions = FALSE, silent = silent, label_prefix = "E[D", label_suffix = "|X,Z]", parallel = parallel, @@ -198,13 +210,12 @@ ddml_fpliv <- function(y, D, Z, X, # E[D|X] D_X_res_list <- compute_CEF_list( - D, X, Z = NULL, learners = learners_DX, + D, 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, - compute_insample_predictions = FALSE, silent = silent, label_prefix = "E[D", label_suffix = "|X]", parallel = parallel, diff --git a/R/ddml_late.R b/R/ddml_late.R index 20f9939..f329d20 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -55,7 +55,7 @@ #' \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: +#' 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 @@ -64,13 +64,10 @@ #' \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{what}. 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 variables in \code{X}. #' @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 #' identical to \code{learners}. @@ -249,7 +246,6 @@ ddml_late <- function(y, D, Z, X, custom_ensemble_weights_ZX, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, - compute_insample_predictions = FALSE, silent = silent, label = messages$Z_X, parallel = parallel, fitted = fitted$Z_X) diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index eb545be..fd77f3d 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -45,7 +45,7 @@ #' \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: +#' 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 @@ -54,13 +54,10 @@ #' \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{what}. 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 variables in \code{X}. #' @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}. diff --git a/R/ensemble.R b/R/ensemble.R index 91cac72..76ff3b0 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -8,7 +8,7 @@ #' #' @param y The outcome variable. #' @param X The feature matrix. -#' @param Z Optional instrumental variables matrix. + #' @param type A character string indicating the type of ensemble to compute. #' Default is \code{"average"}. #' @param learners A list of base learners. @@ -45,7 +45,7 @@ #' ens_fit$weights #' predict(ens_fit, newdata = X)[1:5] #' } -ensemble <- function(y, X, Z = NULL, +ensemble <- function(y, X, type = "average", learners, cv_folds = 5, @@ -75,7 +75,7 @@ ensemble <- function(y, X, Z = NULL, 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, @@ -91,21 +91,16 @@ ensemble <- function(y, X, Z = NULL, # Fit all base learners to keep per-learner outputs always available mdl_fits <- rep(list(NULL), nlearners) for (m in seq_len(nlearners)) { - # Check whether X, Z assignment has been specified. If not, include all. + # Check whether X assignment has been specified. If not, include all. 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. + learners[[m]]$assign_X <- seq_len(ncol(X)) + # Select the model constructor and the variable assignment. mdl_fun <- list(what = learners[[m]]$what, args = learners[[m]]$args) assign_X <- learners[[m]]$assign_X - assign_Z <- learners[[m]]$assign_Z - # Then fit the model + # Fit the model mdl_fun$args$y <- y - mdl_fun$args$X <- cbind(X[, assign_X], - Z[, assign_Z]) + mdl_fun$args$X <- X[, assign_X, drop = FALSE] mdl_fits[[m]] <- do.call(do.call, mdl_fun) }#FOR @@ -120,7 +115,7 @@ ensemble <- function(y, X, Z = NULL, # Complementary methods ======================================================== #' @exportS3Method -predict.ensemble <- function(object, newdata, newZ = NULL, ...){ +predict.ensemble <- function(object, newdata, ...){ # Data parameters nlearners <- length(object$learners) # If y was constant, return mean_y for all observations @@ -131,10 +126,9 @@ predict.ensemble <- function(object, newdata, newZ = NULL, ...){ 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 fitted <- stats::predict(object$mdl_fits[[m]], - newdata = cbind(newdata[, assign_X], - newZ[, assign_Z])) + newdata = newdata[, assign_X, + drop = FALSE]) fitted_mat[, m] <- methods::as(fitted, "matrix") }#FOR # Compute matrix of fitted values by ensemble type and return @@ -153,7 +147,7 @@ predict.ensemble <- function(object, newdata, newZ = NULL, ...){ #' #' @param y The outcome variable. #' @param X The feature matrix. -#' @param Z Optional instrumental variables matrix. + #' @param type A character string or vector indicating the type(s) of ensemble #' weights to compute. Default is \code{"average"}. #' @param learners A list of base learners. @@ -182,7 +176,7 @@ predict.ensemble <- function(object, newdata, newZ = NULL, ...){ #' silent = TRUE) #' ew$weights #' } -ensemble_weights <- function(y, X, Z = NULL, +ensemble_weights <- function(y, X, type = "average", learners, cv_folds = 5, @@ -201,7 +195,7 @@ ensemble_weights <- function(y, X, Z = NULL, 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, + cv_results <- crossval(y, X, learners = learners, cv_folds = cv_folds, cv_subsamples = cv_subsamples, diff --git a/R/get_CEF.R b/R/get_CEF.R index 4cb6a23..7b7e85f 100644 --- a/R/get_CEF.R +++ b/R/get_CEF.R @@ -6,19 +6,17 @@ # # @param y Outcome vector. # @param X Feature matrix (may be sparse). -# @param Z Optional instrument matrix. # @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, Z = NULL, +get_CEF <- function(y, X, learners, ensemble_type, shortstack, custom_ensemble_weights = NULL, - compute_insample_predictions = FALSE, subsamples, cv_subsamples, silent = FALSE, @@ -102,26 +100,22 @@ get_CEF <- function(y, X, Z = NULL, 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, subsamples = subsamples, 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, subsamples = subsamples, cv_subsamples = cv_subsamples, silent = silent, diff --git a/R/help_functions.R b/R/help_functions.R index 4f7be49..afa946f 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -476,12 +476,11 @@ update_ensemble_info <- function(res_weights = NULL, }#UPDATE_ENSEMBLE_INFO # Compute CEF for each column of M, collecting results in a list. -compute_CEF_list <- function(M, X, Z = NULL, +compute_CEF_list <- function(M, X, learners, ensemble_type, shortstack, custom_ensemble_weights, subsamples, cv_subsamples, - compute_insample_predictions = FALSE, silent = FALSE, label_prefix, label_suffix, parallel = NULL, @@ -493,15 +492,13 @@ compute_CEF_list <- function(M, X, Z = NULL, fitted[[k]] }#IF res_list[[k]] <- get_CEF( - M[, k, drop = FALSE], X, Z = Z, + M[, k, drop = FALSE], X, learners = learners, ensemble_type = ensemble_type, shortstack = shortstack, custom_ensemble_weights = custom_ensemble_weights, subsamples = subsamples, cv_subsamples = cv_subsamples, - compute_insample_predictions = - compute_insample_predictions, silent = silent, label = paste0(label_prefix, k, label_suffix), parallel = parallel, diff --git a/R/shortstacking.R b/R/shortstacking.R index 6eba9a5..c8ca3cf 100644 --- a/R/shortstacking.R +++ b/R/shortstacking.R @@ -29,16 +29,11 @@ #' \item{\code{weights}}{An array, providing the weight #' assigned to each base learner (in chronological order) by the #' ensemble procedures.} -#' \item{\code{insample_fitted}}{When \code{compute_insample_predictions = TRUE}. -#' a list of matrices with in-sample predictions by sample fold.} #' \item{\code{auxiliary_fitted}}{When \code{auxiliary_X} is not #' \code{NULL}, a list of matrices with additional predictions.} #' \item{\code{cf_fitted_bylearner}}{A matrix of #' out-of-sample predictions, each column corresponding to a base #' learner (in chronological order).} -#' \item{\code{insample_fitted_bylearner}}{When -#' \code{compute_insample_predictions = TRUE}, a list of matrices with -#' in-sample predictions by sample fold.} #' \item{\code{auxiliary_fitted_bylearner}}{When \code{auxiliary_X} is #' not \code{NULL}, a #' list of matrices with additional predictions for each learner.} @@ -74,18 +69,20 @@ #' silent = TRUE) #' 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, Z = NULL, +shortstacking <- function(y, X, learners, sample_folds = 2, ensemble_type = "average", custom_ensemble_weights = NULL, - compute_insample_predictions = FALSE, - subsamples = NULL, cluster_variable = seq_along(y), + subsamples = NULL, silent = FALSE, auxiliary_X = NULL, shortstack_y = y, parallel = NULL) { + # Normalize learner specs before parallel dispatch + learners <- normalize_learners(learners) + # Data parameters nobs <- nrow(X) nlearners <- length(learners) @@ -107,11 +104,9 @@ shortstacking <- function(y, X, Z = NULL, nensb <- length(ensemble_type) + ncustom # Compute out-of-sample predictions for each learner - res <- crosspred(y, X, Z, + res <- crosspred(y, X, learners = learners, ensemble_type = "average", - compute_insample_predictions = - compute_insample_predictions, subsamples = subsamples, silent = silent, auxiliary_X = auxiliary_X, @@ -137,37 +132,6 @@ shortstacking <- function(y, X, Z = NULL, }#FOR }#IF - # Compute in-sample predictions (optional) - insample_fitted <- rep(list(NULL), sample_folds) - fakecv_k <- list() - if (compute_insample_predictions) { - for (k in seq_len(sample_folds)) { - # Compute shortstacking weights in-sample - nobs_k <- length(y[-subsamples[[k]]]) - fakecv_k$cv_resid <- matrix(y[-subsamples[[k]]], nobs_k, nlearners) - - res$insample_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 - insample_fitted[[k]] <- res$insample_fitted_bylearner[[k]] %*% weights_k - }#FOR - - # When multiple ensembles are computed, need to reorganize insample_fitted - if (nensb > 1) { - # Loop over each ensemble type to create list of insample_fitted's - new_insample_fitted <- rep(list(rep(list(1), sample_folds)), nensb) - for (i in seq_len(nensb)) { - for (k in seq_len(sample_folds)) { - new_insample_fitted[[i]][[k]] <- insample_fitted[[k]][, i, drop = FALSE] - }#FOR - }#FOR - insample_fitted <- new_insample_fitted - }#IF - }#IF - # Compute mspe and r-squared mspe <- colMeans((matrix(shortstack_y, nobs, nensb) - cf_fitted)^2) y_var <- as.numeric(stats::var(shortstack_y)) @@ -180,11 +144,9 @@ shortstacking <- function(y, X, Z = NULL, # return shortstacking output output <- list(cf_fitted = cf_fitted, weights = weights, mspe = mspe, r2 = r2, - insample_fitted = insample_fitted, auxiliary_fitted = auxiliary_fitted, cf_fitted_bylearner = res$cf_fitted_bylearner, cf_resid_bylearner = cf_resid_bylearner, - insample_fitted_bylearner = res$insample_fitted_bylearner, auxiliary_fitted_bylearner = res$auxiliary_fitted_bylearner) return(output) }#SHORTSTACKING diff --git a/man/crosspred.Rd b/man/crosspred.Rd index e30761a..19db8be 100644 --- a/man/crosspred.Rd +++ b/man/crosspred.Rd @@ -7,7 +7,6 @@ crosspred( y, X, - Z = NULL, learners, sample_folds = 10, ensemble_type = "average", @@ -28,8 +27,6 @@ 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. @@ -42,7 +39,7 @@ such that it predicts a named input \code{y} using a named input \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: +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 @@ -51,13 +48,10 @@ such that it predicts a named input \code{y} using a named input \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 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{what}. 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 variables in \code{X}.} \item{sample_folds}{Number of cross-fitting folds.} diff --git a/man/crossval.Rd b/man/crossval.Rd index 89a0401..ca304d1 100644 --- a/man/crossval.Rd +++ b/man/crossval.Rd @@ -7,7 +7,6 @@ crossval( y, X, - Z = NULL, learners, cv_folds = 10, cluster_variable = seq_along(y), @@ -21,9 +20,7 @@ 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{what} The base learner function. The function must be @@ -33,14 +30,10 @@ such that it predicts a named input \code{y} using a named input \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{what}. 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.} diff --git a/man/ddml_fpliv.Rd b/man/ddml_fpliv.Rd index 05e6bd4..25db719 100644 --- a/man/ddml_fpliv.Rd +++ b/man/ddml_fpliv.Rd @@ -49,7 +49,7 @@ such that it predicts a named input \code{y} using a named input \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: +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 @@ -58,13 +58,10 @@ such that it predicts a named input \code{y} using a named input \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{what}. 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 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 diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index 57949c6..f888f81 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -51,7 +51,7 @@ such that it predicts a named input \code{y} using a named input \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: +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 @@ -60,13 +60,10 @@ such that it predicts a named input \code{y} using a named input \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{what}. 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 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 diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index 6889b4f..c94e4af 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -49,7 +49,7 @@ such that it predicts a named input \code{y} using a named input \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: +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 @@ -58,13 +58,10 @@ such that it predicts a named input \code{y} using a named input \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{what}. 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 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 diff --git a/man/ensemble.Rd b/man/ensemble.Rd index b162646..3e11cb0 100644 --- a/man/ensemble.Rd +++ b/man/ensemble.Rd @@ -7,7 +7,6 @@ ensemble( y, X, - Z = NULL, type = "average", learners, cv_folds = 5, @@ -22,8 +21,6 @@ ensemble( \item{X}{The feature matrix.} -\item{Z}{Optional instrumental variables matrix.} - \item{type}{A character string indicating the type of ensemble to compute. Default is \code{"average"}.} diff --git a/man/ensemble_weights.Rd b/man/ensemble_weights.Rd index 835796c..f2f4f2b 100644 --- a/man/ensemble_weights.Rd +++ b/man/ensemble_weights.Rd @@ -7,7 +7,6 @@ ensemble_weights( y, X, - Z = NULL, type = "average", learners, cv_folds = 5, @@ -22,8 +21,6 @@ ensemble_weights( \item{X}{The feature matrix.} -\item{Z}{Optional instrumental variables matrix.} - \item{type}{A character string or vector indicating the type(s) of ensemble weights to compute. Default is \code{"average"}.} diff --git a/man/shortstacking.Rd b/man/shortstacking.Rd index 6c5241d..b3a2419 100644 --- a/man/shortstacking.Rd +++ b/man/shortstacking.Rd @@ -7,14 +7,13 @@ shortstacking( y, X, - Z = NULL, learners, sample_folds = 2, ensemble_type = "average", custom_ensemble_weights = NULL, compute_insample_predictions = FALSE, - subsamples = NULL, cluster_variable = seq_along(y), + subsamples = NULL, silent = FALSE, auxiliary_X = NULL, shortstack_y = y, @@ -26,8 +25,6 @@ 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. @@ -40,7 +37,7 @@ such that it predicts a named input \code{y} using a named input \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: +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 @@ -49,13 +46,10 @@ such that it predicts a named input \code{y} using a named input \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 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{what}. 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 variables in \code{X}.} \item{sample_folds}{Number of cross-fitting folds.} @@ -80,10 +74,10 @@ estimation results corresponding the custom ensemble specification.} \item{compute_insample_predictions}{Indicator equal to 1 if in-sample predictions should also be computed.} -\item{subsamples}{List of vectors with sample indices for cross-fitting.} - \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{auxiliary_X}{An optional list of matrices of length diff --git a/tests/testthat/test-crosspred.R b/tests/testthat/test-crosspred.R index 40e5c2a..8e496b4 100644 --- a/tests/testthat/test-crosspred.R +++ b/tests/testthat/test-crosspred.R @@ -1,64 +1,8 @@ -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$cf_fitted), length(y)) - expect_equal(length(crosspred_res$insample_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(what = ols), - list(what = ols), - list(what = 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$cf_fitted), c(length(y), 5)) - expect_equal(length(crosspred_res$insample_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(what = ols), list(what = ols), @@ -67,7 +11,7 @@ test_that("crosspred computes with ensemble procedures & 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,43 +19,37 @@ 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$cf_fitted), c(length(y), 8)) - expect_equal(length(crosspred_res$insample_fitted), 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(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$cf_fitted), c(length(y), 5)) - expect_equal(length(crosspred_res$insample_fitted), 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(what = ols), list(what = ols), @@ -124,7 +62,7 @@ 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)) @@ -147,14 +85,14 @@ test_that("crosspred returns identical results with parallel", { sample_folds = 3, cv_folds = 3, subsamples = splits$subsamples, cv_subsamples = splits$cv_subsamples, - silent = T) + 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 = T, + silent = TRUE, parallel = list(cores = 2)) expect_equal(res_par$cf_fitted, res_seq$cf_fitted) expect_equal(res_par$weights, res_seq$weights) diff --git a/tests/testthat/test-crossval.R b/tests/testthat/test-crossval.R index ff690d6..e440212 100644 --- a/tests/testthat/test-crossval.R +++ b/tests/testthat/test-crossval.R @@ -1,4 +1,4 @@ -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) @@ -7,12 +7,12 @@ test_that("crossval_compute returns residuals (w/o instruments)", { learner <- list(what = ols) # Compute cross-validation instance cv_resid <- crossval_compute(test_sample, learner, - y, X, Z = NULL) + y, X) # Check output with expectations 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) @@ -23,10 +23,10 @@ test_that("crossval returns residuals by learner (w/o instruments)", { 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$cv_resid), c(length(y), length(learners))) })#TEST_THAT @@ -57,32 +57,13 @@ test_that("crossval returns residuals by learner in correct order", { list(what = ols, assign_X = 1:10)), cv_subsamples = subsample_list, - silent = T) + silent = TRUE) # Check output with expectations 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(what = ols), - list(what = ols), - list(what = 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$cv_resid[, 1], 3) == - round(cv_res$cv_resid[, 2], 3)), TRUE) -})#TEST_THAT - test_that("crossval returns identical results with parallel", { skip_on_cran() skip_if_not_installed("parallel") @@ -95,10 +76,10 @@ test_that("crossval returns identical results with parallel", { cv_subs <- generate_subsamples(nobs, 3) # Sequential res_seq <- crossval(y, X, learners = learners, - cv_subsamples = cv_subs, silent = T) + cv_subsamples = cv_subs, silent = TRUE) # Parallel res_par <- crossval(y, X, learners = learners, - cv_subsamples = cv_subs, silent = T, + 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) diff --git a/tests/testthat/test-ensemble.R b/tests/testthat/test-ensemble.R index 3918c85..26bbdd8 100644 --- a/tests/testthat/test-ensemble.R +++ b/tests/testthat/test-ensemble.R @@ -1,71 +1,50 @@ 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(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(what = mdl_glmnet), - list(what = 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(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(what = mdl_glmnet), list(what = ols)) @@ -73,12 +52,12 @@ test_that("ensemble_weights returns a weight matrix w/ 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,29 +65,27 @@ 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(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 @@ -117,15 +94,15 @@ test_that("ensemble returns mean_y for constant outcomes", { # 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))) diff --git a/tests/testthat/test-shortstacking.R b/tests/testthat/test-shortstacking.R index 2f64ac8..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(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$cf_fitted), c(length(y), 8)) - expect_equal(length(shortstacking_res$insample_fitted), 8) })#TEST_THAT From eac91f9a830e2ae0ad903cd9acb358ecf1bc2e93 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Mon, 9 Mar 2026 11:18:06 -0500 Subject: [PATCH 21/46] doc improvements + cosmetics --- .github/workflows/pkgdown.yaml | 5 +- NEWS.md | 2 + R/crosspred.R | 73 ++------- R/ddml-class.R | 229 +++++++++++++++++++++++++++ R/ddml_apo.R | 90 ++++++----- R/ddml_ate.R | 75 ++------- R/ddml_att.R | 26 ++-- R/ddml_fpliv.R | 52 ++----- R/ddml_late.R | 84 +++------- R/ddml_pliv.R | 71 ++------- R/ddml_plm.R | 127 ++------------- R/diagnostics.R | 2 +- R/ensemble.R | 18 ++- R/get_CEF.R | 20 +-- R/help_functions.R | 63 +++++--- R/methods.R | 84 ++++------ R/ml_wrappers.R | 54 ++++++- R/ols.R | 9 ++ R/shortstacking.R | 19 +-- R/subsample_functions.R | 16 +- R/tidy.R | 3 +- README.Rmd | 8 +- README.md | 16 +- _pkgdown.yml | 5 + man/crosspred.Rd | 70 ++++----- man/ddml-class.Rd | 266 ++++++++++++++++++++++++++++++++ man/ddml_apo.Rd | 142 +++++++++-------- man/ddml_ate.Rd | 126 +++++++-------- man/ddml_fpliv.Rd | 131 ++++++++-------- man/ddml_late.Rd | 125 +++++++-------- man/ddml_pliv.Rd | 118 ++++++-------- man/ddml_plm.Rd | 119 ++++++-------- man/hatvalues.ddml.Rd | 14 +- man/mdl_glmnet.Rd | 4 +- man/mdl_xgboost.Rd | 2 +- man/predict.ensemble.Rd | 22 +++ man/predict.mdl_bigGLM.Rd | 21 +++ man/predict.mdl_glm.Rd | 22 +++ man/predict.mdl_glmnet.Rd | 22 +++ man/predict.mdl_ranger.Rd | 23 +++ man/predict.mdl_xgboost.Rd | 22 +++ man/predict.ols.Rd | 22 +++ man/shortstacking.Rd | 59 +++---- man/vcov.ddml.Rd | 41 ++--- tests/testthat/test-ddml_ate.R | 46 +++++- tests/testthat/test-ddml_late.R | 2 +- tests/testthat/test-get_CEF.R | 123 +++++++++++++++ 47 files changed, 1593 insertions(+), 1100 deletions(-) create mode 100644 R/ddml-class.R create mode 100644 man/ddml-class.Rd create mode 100644 man/predict.ensemble.Rd create mode 100644 man/predict.mdl_bigGLM.Rd create mode 100644 man/predict.mdl_glm.Rd create mode 100644 man/predict.mdl_glmnet.Rd create mode 100644 man/predict.mdl_ranger.Rd create mode 100644 man/predict.mdl_xgboost.Rd create mode 100644 man/predict.ols.Rd create mode 100644 tests/testthat/test-get_CEF.R diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 98a72d9..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 diff --git a/NEWS.md b/NEWS.md index 093689c..6b03f27 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,8 @@ * Adds `fitted` and `splits` parameters to all `ddml_*()` estimators for re-estimation with different ensemble types without re-fitting base learners. * Adds `diagnostics()` for per-equation MSPE, R-squared, stacking weights, and cross-validated comparison (CVC) tests. * Adds HC0 and HC3 variance estimators alongside default HC1 via `type` argument in `vcov()`, `confint()`, `summary()`, and `tidy()`. +* Adds `hatvalues()` method for generalized leverage diagnostics. +* Adds `nobs()` method returning the number of observations. * Learner specifications now use `what` instead of `fun`. `fun` is accepted with a deprecation message. * Sample split arguments consolidated into a single `splits` parameter. * Adds parallel computation via the `parallel` parameter and progress reporting via `pbapply`. diff --git a/R/crosspred.R b/R/crosspred.R index 23c5510..b272487 100644 --- a/R/crosspred.R +++ b/R/crosspred.R @@ -45,50 +45,7 @@ #' \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 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 predictive 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 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. +#' @inheritParams ddml-class #' @param subsamples List of vectors with sample indices for cross-fitting. #' @param cv_subsamples List of lists, each corresponding to a subsample #' containing vectors with subsample indices for cross-validation. @@ -96,18 +53,6 @@ #' @param auxiliary_X An optional list of matrices of length #' \code{sample_folds}, each containing additional observations to calculate #' predictions for. -#' @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{crosspred} returns a list containing the following components: #' \describe{ @@ -117,11 +62,24 @@ #' \item{\code{weights}}{An array, providing the weight #' assigned to each base learner (in chronological order) by the #' ensemble procedures.} +#' \item{\code{mspe}}{A matrix of per-learner MSPEs, with +#' rows for learners and columns for sample folds. +#' \code{NULL} when a single learner is used.} +#' \item{\code{r2}}{A matrix of per-learner out-of-sample +#' R-squared values. Same dimensions as \code{mspe}. +#' \code{NULL} when a single learner is used.} +#' \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{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.} @@ -177,7 +135,8 @@ crosspred <- function(y, X, # 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.") + 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 diff --git a/R/ddml-class.R b/R/ddml-class.R new file mode 100644 index 0000000..d80c0d4 --- /dev/null +++ b/R/ddml-class.R @@ -0,0 +1,229 @@ +#' Common Output Structure for DDML Estimators +#' +#' @name ddml-class +#' +#' @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. +#' +#' @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, typically a vector of conditional expectation +#' functions. The score \eqn{m} is \emph{Neyman orthogonal}, +#' meaning the moment condition is locally insensitive to +#' perturbations of \eqn{\eta} around \eqn{\eta_0}. +#' +#' Each estimator in \code{ddml} uses a score that decomposes +#' linearly in \eqn{\theta}: +#' +#' \deqn{m(W_i; \theta, \eta) = \psi_b(W_i; \eta) + +#' \psi_a(W_i; \eta)\,\theta.} +#' +#' See the individual estimator pages for the specific forms +#' of \eqn{\psi_a} and \eqn{\psi_b}. +#' +#' 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.} +#' +#' For the linear scores used in \code{ddml}, this yields the +#' closed-form solution +#' +#' \deqn{\hat\theta = -\hat{J}^{-1}\,\hat\psi_b,} +#' +#' where \eqn{\hat\psi_b = n^{-1}\sum_{k}\sum_{i \in I_k} +#' \psi_b(W_i; \hat\eta_{-k})} and +#' \eqn{\hat{J} = n^{-1}\sum_k \sum_{i \in I_k} +#' \psi_a(W_i; \hat\eta_{-k})} is the sample Jacobian. +#' +#' Inference is based on the sandwich variance estimator +#' +#' \deqn{\hat\Sigma = \hat{J}^{-1} \left(\frac{1}{n} +#' \sum_i m_i m_i^\top\right) +#' \hat{J}^{-\top} / n} +#' +#' where \eqn{m_i = m(W_i; \hat\theta, \hat\eta_{-k(i)})}; +#' see \code{\link{vcov.ddml}} for HC0/HC1/HC3 variants. +#' Under regularity conditions and sufficient convergence of \eqn{\hat\eta}, +#' the DML estimator is asymptotically normal: +#' +#' \deqn{\sqrt{n}\,\hat\Sigma^{-1/2}(\hat\theta - \theta_0) +#' \overset{d}{\to} N(0, I).} +#' +#' Further details and regularity conditions are given in +#' Chernozhukov et al. (2018). +#' +#' @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. +#' +#' @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 per-learner MSPEs from +#' the cross-validation step in ensemble construction.} +#' \item{\code{r2}}{A named list of per-learner out-of-sample +#' R-squared values.} +#' \item{\code{psi_a}, \code{psi_b}}{Score component lists +#' (length \code{nensb}). \code{psi_a[[j]]} is an +#' \code{(n x p x p)} array and \code{psi_b[[j]]} is an +#' \code{(n x p)} matrix. Used internally by +#' \code{\link{hatvalues.ddml}}.} +#' \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.ddml}}, \code{\link{vcov.ddml}}, +#' \code{\link{confint.ddml}}, \code{\link{hatvalues.ddml}}, +#' \code{\link{nobs.ddml}}, \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 ... Deprecated arguments are still accepted for backward +#' compatibility but should be replaced with the \code{splits} +#' argument. See individual estimator pages for details. +#' +#' @family ddml estimators +NULL diff --git a/R/ddml_apo.R b/R/ddml_apo.R index a559d00..d02261a 100644 --- a/R/ddml_apo.R +++ b/R/ddml_apo.R @@ -1,5 +1,7 @@ #' DDML Estimator for the Average Potential Outcome #' +#' @family ddml estimators +#' #' @description \code{ddml_apo} provides a Double/Debiased Machine Learning #' estimator for the average potential outcome, allowing for custom #' weights \eqn{\omega(X)}. @@ -32,6 +34,7 @@ #' with nuisance parameters \eqn{\eta = (\ell, p)} taking #' true values \eqn{\ell_0(X) = E[Y|D=d, X]} and \eqn{p_0(X) = E[\mathbbm{1}\{D=d\}|X]}. #' +#' @inheritParams ddml-class #' @inheritParams ddml_plm #' @inheritParams ddml_ate #' @param D The endogenous variable of interest. Can be discrete or continuous. @@ -50,42 +53,34 @@ #' argument. #' #' @return \code{ddml_apo} returns an object of S3 class -#' \code{ddml_apo}. An object of class \code{ddml_apo} is a list -#' containing the following components: -#' \describe{ -#' \item{\code{coefficients}}{A matrix of estimated coefficients.} -#' \item{\code{ensemble_weights}}{A list of matrices, providing the -#' weight assigned to each base learner by the ensemble -#' procedure.} -#' \item{\code{mspe}}{A list of matrices, providing the MSPE of each -#' base learner computed by the cross-validation step in the -#' ensemble construction.} -#' \item{\code{r2}}{The out-of-sample R-squared.} -#' \item{\code{psi_a}, \code{psi_b}}{Score components used in -#' \code{\link{vcov.ddml}}.} -#' \item{\code{scores}}{A list of evaluated Neyman orthogonal -#' scores.} -#' \item{\code{J}}{A list of evaluated Jacobians.} -#' \item{\code{fitted}}{A list of fitted nuisance estimators. -#' See \code{\link{ddml_plm}} for more information.} -#' \item{\code{splits}}{The data splitting structure.} -#' \item{\code{learners},\code{learners_DX}, -#' \code{cluster_variable}, -#' \code{ensemble_type}}{Pass-through of selected -#' user-provided arguments. See above.} -#' } -#' -#' @references Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). -#' "Model Averaging and Double Machine Learning." -#' \url{https://arxiv.org/abs/2401.01645} -#' @seealso \code{\link{summary.ddml}}, -#' \code{\link{vcov.ddml}}, \code{\link{confint.ddml}}, -#' \code{\link{hatvalues.ddml}}, -#' \code{\link{ddml_plm}}, \code{\link{ddml_pliv}}, -#' \code{\link{ddml_fpliv}}, \code{\link{ddml_late}}, -#' \code{\link{ddml_ate}} +#' \code{ddml_apo} and \code{ddml}. See \code{\link{ddml-class}} +#' for the common output structure. Additional pass-through +#' fields: \code{learners}, \code{learners_DX}. +#' +#' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], +#' [ddml::vcov.ddml()], [ddml::confint.ddml()], +#' [ddml::hatvalues.ddml()], [ddml::tidy.ddml()], +#' [ddml::glance.ddml()], [ddml::diagnostics()] +#' #' @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. +#' +#' @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, @@ -191,13 +186,15 @@ ddml_apo <- function(y, D, X, parallel = parallel, fitted = fitted$y_X) - ensb_info <- update_ensemble_info(y_X_res$weights, - D_X_res$cf_fitted) + ensb_info <- update_ensemble_info(y_X_res$weights, D_X_res$cf_fitted) ensemble_type <- ensb_info$ensemble_type nensb <- ensb_info$nensb # == 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( @@ -216,19 +213,20 @@ ddml_apo <- function(y, D, X, D_ind_mat <- matrix(D_ind, nobs, nensb) y_mat <- matrix(y, nobs, nensb) - psi_b <- (D_ind_mat * (y_mat - g_X) / m_X_tr + g_X) * weights_mat - psi_a <- matrix(-1, nobs, nensb) + psi_b_mat <- (D_ind_mat * (y_mat - g_X) / m_X_tr + g_X) * weights_mat + psi_b <- lapply(seq_len(nensb), function(j) psi_b_mat[, j, drop = FALSE]) + psi_a <- lapply(seq_len(nensb), function(j) array(-1, dim = c(nobs, 1, 1))) # == Target parameter ============================================= - apo <- colMeans(psi_b) + apo <- colMeans(psi_b_mat) - scores <- lapply(seq_len(nensb), function(j) { - as.matrix(psi_a[, j] * apo[j] + psi_b[, j]) - }) - J_list <- lapply(seq_len(nensb), function(j) { - as.matrix(mean(psi_a[, j])) - }) + scores <- array(NA_real_, dim = c(nobs, 1, nensb)) + J <- array(NA_real_, dim = c(1, 1, nensb)) + for (j in seq_len(nensb)) { + scores[, 1, j] <- -apo[j] + psi_b_mat[, j] + J[1, 1, j] <- -1 + }#FOR coef_names <- "APO" coef <- matrix(apo, nrow = 1, ncol = nensb) @@ -246,7 +244,7 @@ ddml_apo <- function(y, D, X, r2 = list(y_X = y_X_res$r2, D_X = D_X_res$r2), psi_a = psi_a, psi_b = psi_b, - scores = scores, J = J_list, + scores = scores, J = J, coef_names = coef_names, estimator_name = "Average Potential Outcome", ensemble_type = ensemble_type, diff --git a/R/ddml_ate.R b/R/ddml_ate.R index 306e2a2..43d3b34 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -2,11 +2,6 @@ #' #' @family ddml estimators #' -#' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], -#' [ddml::vcov.ddml()], [ddml::confint.ddml()], -#' [ddml::hatvalues.ddml()], [ddml::tidy.ddml()], -#' [ddml::glance.ddml()], [ddml::diagnostics()] -#' #' @description Estimators of the average treatment effect and the average #' treatment effect on the treated. #' @@ -47,6 +42,7 @@ #' true values \eqn{\ell_{d,0}(X) = E[Y|D=d, X]}, \eqn{m_0(X) = E[D|X]}, #' and \eqn{p_0 = E[D]}. #' +#' @inheritParams ddml-class #' @inheritParams ddml_plm #' @param D The binary endogenous variable of interest. #' @param splits An optional list of sample split objects. For @@ -61,51 +57,12 @@ #' 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 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 via \code{fit$fitted}. See -#' \code{\link{ddml_plm}} for details and an example. -#' @param save_crossval Logical; store inner cross-validation -#' residuals for exact weight recomputation on pass-through. -#' See \code{\link{ddml_plm}} for details. #' -#' @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{coefficients}}{A matrix of estimated coefficients.} -#' \item{\code{ensemble_weights}}{A list of matrices, providing the -#' weight assigned to each base learner by the ensemble -#' procedure.} -#' \item{\code{mspe}}{A list of matrices, providing the MSPE of each -#' base learner computed by the cross-validation step in the -#' ensemble construction.} -#' \item{\code{r2}}{The out-of-sample R-squared.} -#' \item{\code{psi_a}, \code{psi_b}}{Score components used in -#' \code{\link{vcov.ddml}}.} -#' \item{\code{scores}}{A list of evaluated Neyman orthogonal -#' scores.} -#' \item{\code{J}}{A list of evaluated Jacobians.} -#' \item{\code{fitted}}{A list of fitted nuisance estimators. -#' See \code{\link{ddml_plm}} for more information.} -#' \item{\code{splits}}{The data splitting structure.} -#' \item{\code{learners},\code{learners_DX}, -#' \code{cluster_variable}, -#' \code{ensemble_type}}{Pass-through of -#' selected user-provided arguments. See above.} -#' } +#' @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-class}} for the common output structure. +#' Additional pass-through fields: \code{learners}, +#' \code{learners_DX}. #' @export #' #' @references @@ -283,19 +240,21 @@ ddml_ate <- function(y, D, X, nensb <- ncol(apo_1$coefficients) # == Score construction =========================================== - psi_b <- apo_1$psi_b - apo_0$psi_b - psi_a <- matrix(-1, nobs, nensb) + psi_b <- lapply(seq_len(nensb), function(j) { + apo_1$psi_b[[j]] - apo_0$psi_b[[j]] + }) + psi_a <- lapply(seq_len(nensb), function(j) array(-1, dim = c(nobs, 1, 1))) # == Target parameter ============================================= ate <- as.vector(apo_1$coefficients) - as.vector(apo_0$coefficients) - scores <- lapply(seq_len(nensb), function(j) { - as.matrix(psi_a[, j] * ate[j] + psi_b[, j]) - }) - J_list <- lapply(seq_len(nensb), function(j) { - as.matrix(mean(psi_a[, j])) - }) + scores <- array(NA_real_, dim = c(nobs, 1, nensb)) + J <- array(NA_real_, dim = c(1, 1, nensb)) + for (j in seq_len(nensb)) { + scores[, 1, j] <- -ate[j] + as.vector(psi_b[[j]]) + J[1, 1, j] <- -1 + }#FOR coef_names <- "ATE" coef <- matrix(ate, nrow = 1, ncol = nensb) @@ -317,7 +276,7 @@ ddml_ate <- function(y, D, X, y_X_D1 = apo_1$r2$y_X, D_X = D_X_res$r2), psi_a = psi_a, psi_b = psi_b, - scores = scores, J = J_list, + scores = scores, J = J, coef_names = coef_names, estimator_name = "Average Treatment Effect", ensemble_type = ensemble_type, diff --git a/R/ddml_att.R b/R/ddml_att.R index 06ca567..bbcd915 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -117,7 +117,9 @@ ddml_att <- function(y, D, X, # == Score construction =========================================== - # Reconstruct full-sample g_X_D0 from the apo fitted object + # 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( @@ -131,21 +133,23 @@ ddml_att <- function(y, D, X, D_mat <- matrix(D, nobs, nensb) y_mat <- matrix(y, nobs, nensb) - psi_b <- D_mat * (y_mat - g_X_D0) / p - + psi_b_mat <- D_mat * (y_mat - g_X_D0) / p - m_X_tr * (1 - D_mat) * (y_mat - g_X_D0) / (p * (1 - m_X_tr)) - psi_a <- -D_mat / p + psi_a_vec <- -D / p + psi_b <- lapply(seq_len(nensb), function(j) psi_b_mat[, j, drop = FALSE]) + psi_a <- lapply(seq_len(nensb), function(j) array(psi_a_vec, dim = c(nobs, 1, 1))) # == Target parameter ============================================= - att <- -colMeans(psi_b) / colMeans(psi_a) + att <- -colMeans(psi_b_mat) / mean(psi_a_vec) - scores <- lapply(seq_len(nensb), function(j) { - as.matrix(psi_a[, j] * att[j] + psi_b[, j]) - }) - J_list <- lapply(seq_len(nensb), function(j) { - as.matrix(mean(psi_a[, j])) - }) + scores <- array(NA_real_, dim = c(nobs, 1, nensb)) + J <- array(NA_real_, dim = c(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) + }#FOR coef_names <- "ATT" coef <- matrix(att, nrow = 1, ncol = nensb) @@ -164,7 +168,7 @@ ddml_att <- function(y, D, X, r2 = list(y_X_D0 = apo_0$r2$y_X, D_X = D_X_res$r2), psi_a = psi_a, psi_b = psi_b, - scores = scores, J = J_list, + scores = scores, J = J, coef_names = coef_names, estimator_name = "Average Treatment Effect on the Treated", diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index 208d58b..1574d19 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -2,11 +2,7 @@ #' #' @family ddml estimators #' -#' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], -#' [ddml::vcov.ddml()], [ddml::confint.ddml()], -#' [ddml::hatvalues.ddml()], [ddml::tidy.ddml()], -#' [ddml::glance.ddml()], [ddml::diagnostics()], -#' [AER::ivreg()] +#' @seealso [AER::ivreg()] #' #' @description Estimator for the flexible partially linear IV model. #' @@ -31,7 +27,7 @@ #' \eqn{\ell_0(X) = E[Y|X]}, \eqn{r_0(X) = E[D|X]}, and #' \eqn{v_0(X, Z) = E[D|X, Z]}. #' -#' @inheritParams ddml_pliv +#' @inheritParams ddml-class #' @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 @@ -43,38 +39,12 @@ #' \code{custom_ensemble_weights} and #' \code{custom_ensemble_weights_DXZ},\code{custom_ensemble_weights_DX} must #' have the same number of columns. -#' @param fitted An optional named list of per-equation cross-fitted -#' predictions, typically obtained via \code{fit$fitted}. See -#' \code{\link{ddml_plm}} for details. -#' @param save_crossval Logical; store inner cross-validation -#' residuals for exact weight recomputation on pass-through. -#' See \code{\link{ddml_plm}} for details. #' #' @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{coefficients}}{A matrix of estimated coefficients.} -#' \item{\code{ensemble_weights}}{A list of matrices, providing the -#' weight assigned to each base learner by the ensemble -#' procedure.} -#' \item{\code{mspe}}{A list of matrices, providing the MSPE of each -#' base learner computed by the cross-validation step in the -#' ensemble construction.} -#' \item{\code{r2}}{The out-of-sample R-squared.} -#' \item{\code{psi_a}, \code{psi_b}}{Score components used in -#' \code{\link{vcov.ddml}}.} -#' \item{\code{scores}}{A list of evaluated Neyman orthogonal -#' scores.} -#' \item{\code{J}}{A list of evaluated Jacobians.} -#' \item{\code{fitted}}{A list of fitted nuisance estimators. -#' See \code{\link{ddml_plm}} for more information.} -#' \item{\code{splits}}{The data splitting structure.} -#' \item{\code{learners},\code{learners_DXZ}, -#' \code{learners_DX},\code{cluster_variable}, -#' \code{ensemble_type}}{Pass-through of selected -#' user-provided arguments. See above.} -#' } +#' \code{ddml_fpliv} and \code{ddml}. See +#' \code{\link{ddml-class}} for the common output structure. +#' Additional pass-through fields: \code{learners}, +#' \code{learners_DXZ}, \code{learners_DX}. #' @export #' #' @references @@ -228,8 +198,8 @@ ddml_fpliv <- function(y, D, Z, X, # == Score construction =========================================== coef <- matrix(0, nD + 1, nensb) - scores <- vector("list", nensb) - J_list <- vector("list", nensb) + scores <- array(NA_real_, dim = c(nobs, nD + 1, nensb)) + J <- array(NA_real_, dim = c(nD + 1, nD + 1, nensb)) psi_a <- vector("list", nensb) psi_b <- vector("list", nensb) @@ -260,8 +230,8 @@ ddml_fpliv <- function(y, D, Z, X, X_full <- D_fit e_j <- as.vector(y_r - X_full %*% coef_iv_j) - scores[[j]] <- X_hat * e_j - J_list[[j]] <- -crossprod(X_hat, X_full) / nobs + scores[, , j] <- X_hat * e_j + J[, , j] <- -crossprod(X_hat, X_full) / nobs psi_b[[j]] <- X_hat * as.vector(y_r) psi_a[[j]] <- -sapply(seq_len(nD + 1), @@ -298,7 +268,7 @@ ddml_fpliv <- function(y, D, Z, X, mspe = mspe, r2 = r2, psi_a = psi_a, psi_b = psi_b, - scores = scores, J = J_list, + scores = scores, J = J, coef_names = coef_names, estimator_name = "Flexible Partially Linear IV Model", ensemble_type = ensemble_type, diff --git a/R/ddml_late.R b/R/ddml_late.R index f329d20..7fac176 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -2,11 +2,6 @@ #' #' @family ddml estimators #' -#' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], -#' [ddml::vcov.ddml()], [ddml::confint.ddml()], -#' [ddml::hatvalues.ddml()], [ddml::tidy.ddml()], -#' [ddml::glance.ddml()], [ddml::diagnostics()] -#' #' @description Estimator of the local average treatment effect. #' #' @details \code{ddml_late} provides a Double/Debiased Machine Learning @@ -41,33 +36,9 @@ #' true values \eqn{\ell_{z,0}(X) = E[Y|Z=z, X]}, #' \eqn{r_{z,0}(X) = E[D|Z=z, X]}, and \eqn{m_0(X) = E[Z|X]}. #' +#' @inheritParams ddml-class #' @inheritParams ddml_ate #' @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 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 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 #' identical to \code{learners}. @@ -88,30 +59,10 @@ #' compatibility but should be replaced with \code{splits}. #' #' @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{coefficients}}{A matrix of estimated coefficients.} -#' \item{\code{ensemble_weights}}{A list of matrices, providing the -#' weight assigned to each base learner by the ensemble -#' procedure.} -#' \item{\code{mspe}}{A list of matrices, providing the MSPE of -#' each base learner computed by the cross-validation step -#' in the ensemble construction.} -#' \item{\code{r2}}{The out-of-sample R-squared.} -#' \item{\code{psi_a}, \code{psi_b}}{Score components used in -#' \code{\link{vcov.ddml}}.} -#' \item{\code{scores}}{A list of evaluated Neyman orthogonal -#' scores.} -#' \item{\code{J}}{A list of evaluated Jacobians.} -#' \item{\code{fitted}}{A list of fitted nuisance estimators. -#' See \code{\link{ddml_plm}} for more information.} -#' \item{\code{splits}}{The data splitting structure.} -#' \item{\code{learners},\code{learners_DXZ}, -#' \code{learners_ZX},\code{cluster_variable}, -#' \code{ensemble_type}}{Pass-through of selected -#' user-provided arguments. See above.} -#' } +#' \code{ddml_late} and \code{ddml}. See +#' \code{\link{ddml-class}} for the common output structure. +#' Additional pass-through fields: \code{learners}, +#' \code{learners_DXZ}, \code{learners_ZX}. #' @export #' #' @references @@ -301,19 +252,24 @@ ddml_late <- function(y, D, Z, X, # == Score construction =========================================== - psi_b <- ate_rf$psi_b - psi_a <- -ate_fs$psi_b + psi_b <- ate_rf$psi_b # already a list (from ddml_ate) + psi_a <- lapply(seq_len(nensb), function(j) { + array(-as.vector(ate_fs$psi_b[[j]]), + dim = c(nobs, 1, 1)) + }) # == Target parameter ============================================= - late <- as.vector(ate_rf$coefficients) / as.vector(ate_fs$coefficients) + late <- as.vector(ate_rf$coefficients) / + as.vector(ate_fs$coefficients) - scores <- lapply(seq_len(nensb), function(j) { - as.matrix(psi_a[, j] * late[j] + psi_b[, j]) - }) - J_list <- lapply(seq_len(nensb), function(j) { - as.matrix(mean(psi_a[, j])) - }) + scores <- array(NA_real_, dim = c(nobs, 1, nensb)) + J <- array(NA_real_, dim = c(1, 1, nensb)) + for (j in seq_len(nensb)) { + scores[, 1, j] <- psi_a[[j]][, 1, 1] * late[j] + + as.vector(psi_b[[j]]) + J[1, 1, j] <- mean(psi_a[[j]]) + }#FOR coef_names <- "LATE" coef <- matrix(late, nrow = 1, ncol = nensb) @@ -351,7 +307,7 @@ ddml_late <- function(y, D, Z, X, D_X_Z1 = ate_fs$r2$y_X_D1, Z_X = ate_rf$r2$D_X), psi_a = psi_a, psi_b = psi_b, - scores = scores, J = J_list, + scores = scores, J = J, coef_names = coef_names, estimator_name = "Local Average Treatment Effect", ensemble_type = ensemble_type, diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index fd77f3d..da15b7f 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -2,11 +2,7 @@ #' #' @family ddml estimators #' -#' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], -#' [ddml::vcov.ddml()], [ddml::confint.ddml()], -#' [ddml::hatvalues.ddml()], [ddml::tidy.ddml()], -#' [ddml::glance.ddml()], [ddml::diagnostics()], -#' [AER::ivreg()] +#' @seealso [AER::ivreg()] #' #' @description Estimator for the partially linear IV model. #' @@ -31,33 +27,8 @@ #' \eqn{\ell_0(X) = E[Y|X]}, \eqn{r_{D,0}(X) = E[D|X]}, and #' \eqn{r_{Z,0}(X) = E[Z|X]}. #' -#' @inheritParams ddml_plm +#' @inheritParams ddml-class #' @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 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 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}. @@ -70,30 +41,10 @@ #' 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{coefficients}}{A matrix of estimated coefficients.} -#' \item{\code{ensemble_weights}}{A list of matrices, providing the -#' weight assigned to each base learner by the ensemble -#' procedure.} -#' \item{\code{mspe}}{A list of matrices, providing the MSPE of each -#' base learner computed by the cross-validation step in the -#' ensemble construction.} -#' \item{\code{r2}}{The out-of-sample R-squared.} -#' \item{\code{psi_a}, \code{psi_b}}{Score components used in -#' \code{\link{vcov.ddml}}.} -#' \item{\code{scores}}{A list of evaluated Neyman orthogonal -#' scores.} -#' \item{\code{J}}{A list of evaluated Jacobians.} -#' \item{\code{fitted}}{A list of fitted nuisance estimators. -#' See \code{\link{ddml_plm}} for more information.} -#' \item{\code{splits}}{The data splitting structure.} -#' \item{\code{learners},\code{learners_DX},\code{learners_ZX}, -#' \code{cluster_variable}, -#' \code{ensemble_type}}{Pass-through of selected -#' user-provided arguments. See above.} -#' } +#' \code{ddml_pliv} and \code{ddml}. See \code{\link{ddml-class}} +#' for the common output structure. Additional pass-through +#' fields: \code{learners}, \code{learners_DX}, +#' \code{learners_ZX}. #' @export #' #' @references @@ -238,8 +189,8 @@ ddml_pliv <- function(y, D, Z, X, # == Score construction =========================================== coef <- matrix(0, nD + 1, nensb) - scores <- vector("list", nensb) - J_list <- vector("list", nensb) + scores <- array(NA_real_, dim = c(nobs, nD + 1, nensb)) + J <- array(NA_real_, dim = c(nD + 1, nD + 1, nensb)) psi_a <- vector("list", nensb) psi_b <- vector("list", nensb) @@ -264,8 +215,8 @@ ddml_pliv <- function(y, D, Z, X, X_full <- D_fit e_j <- as.vector(y_r - X_full %*% coef_iv_j) - scores[[j]] <- X_hat * e_j - J_list[[j]] <- -crossprod(X_hat, X_full) / nobs + scores[, , j] <- X_hat * e_j + J[, , j] <- -crossprod(X_hat, X_full) / nobs psi_b[[j]] <- X_hat * as.vector(y_r) psi_a[[j]] <- -sapply(seq_len(nD + 1), @@ -306,7 +257,7 @@ ddml_pliv <- function(y, D, Z, X, mspe = mspe, r2 = r2, psi_a = psi_a, psi_b = psi_b, - scores = scores, J = J_list, + scores = scores, J = J, coef_names = coef_names, estimator_name = "Partially Linear IV Model", ensemble_type = ensemble_type, diff --git a/R/ddml_plm.R b/R/ddml_plm.R index 87ea097..5247225 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -2,11 +2,6 @@ #' #' @family ddml estimators #' -#' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], -#' [ddml::vcov.ddml()], [ddml::confint.ddml()], -#' [ddml::hatvalues.ddml()], [ddml::tidy.ddml()], -#' [ddml::glance.ddml()], [ddml::diagnostics()] -#' #' @description Estimator for the partially linear model. #' #' @details \code{ddml_plm} provides a Double/Debiased Machine Learning @@ -29,122 +24,18 @@ #' with nuisance parameters \eqn{\eta = (\ell, r)} taking true values #' \eqn{\ell_0(X) = E[Y|X]} and \eqn{r_0(X) = E[D|X]}. #' -#' @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{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}. +#' @inheritParams ddml-class #' @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 ... Deprecated arguments (\code{subsamples}, -#' \code{cv_subsamples}, \code{cv_subsamples_list}) are still -#' accepted for backward compatibility but should be replaced -#' with the \code{splits} argument. -#' @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 the example below. -#' @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. #' #' @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{coefficients}}{A matrix of estimated coefficients.} -#' \item{\code{ensemble_weights}}{A list of matrices, providing the -#' weight assigned to each base learner by the ensemble -#' procedure.} -#' \item{\code{mspe}}{A list of matrices, providing the MSPE of each -#' base learner computed by the cross-validation step in the -#' ensemble construction.} -#' \item{\code{r2}}{The out-of-sample R-squared.} -#' \item{\code{psi_a}, \code{psi_b}}{Score components used in -#' \code{\link{vcov.ddml}}.} -#' \item{\code{scores}}{A list of evaluated Neyman orthogonal -#' scores.} -#' \item{\code{J}}{A list of evaluated Jacobians.} -#' \item{\code{fitted}}{A list of fitted nuisance estimators. -#' Can be passed back via the \code{fitted} argument to -#' skip cross-fitting on re-estimation.} -#' \item{\code{splits}}{The data splitting structure.} -#' \item{\code{learners},\code{learners_DX}, -#' \code{cluster_variable}, -#' \code{ensemble_type}}{Pass-through of selected -#' user-provided arguments. See above.} -#' } +#' \code{ddml_plm} and \code{ddml}. See \code{\link{ddml-class}} +#' for the common output structure. Additional pass-through +#' fields: \code{learners}, \code{learners_DX}. #' @export #' #' @references @@ -298,8 +189,8 @@ ddml_plm <- function(y, D, X, # == Score construction =========================================== coef <- matrix(0, nD + 1, nensb) - scores <- vector("list", nensb) - J_list <- vector("list", nensb) + scores <- array(NA_real_, dim = c(nobs, nD + 1, nensb)) + J <- array(NA_real_, dim = c(nD + 1, nD + 1, nensb)) psi_a <- vector("list", nensb) psi_b <- vector("list", nensb) for (j in seq_len(nensb)) { @@ -313,8 +204,8 @@ ddml_plm <- function(y, D, X, coef[, j] <- coef_ols_j e_j <- as.vector(y_r - X_full %*% coef_ols_j) - scores[[j]] <- X_full * e_j - J_list[[j]] <- -crossprod(X_full) / nobs + scores[, , j] <- X_full * e_j + J[, , j] <- -crossprod(X_full) / nobs psi_b[[j]] <- X_full * as.vector(y_r) psi_a[[j]] <- -sapply(seq_len(nD + 1), @@ -350,7 +241,7 @@ ddml_plm <- function(y, D, X, mspe = mspe, r2 = r2, psi_a = psi_a, psi_b = psi_b, - scores = scores, J = J_list, + scores = scores, J = J, coef_names = coef_names, estimator_name = "Partially Linear Model", ensemble_type = ensemble_type, diff --git a/R/diagnostics.R b/R/diagnostics.R index 76c5425..10180a5 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -36,7 +36,7 @@ diagnostics <- function(object, cvc = FALSE, bootnum = 500, alpha = 0.05, ...) { if (!inherits(object, "ddml")) { - stop("object must be of class 'ddml'.") + stop("object must be of class 'ddml'.", call. = FALSE) }#IF eq_names <- names(object$ensemble_weights) diff --git a/R/ensemble.R b/R/ensemble.R index 76ff3b0..8dea176 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -61,7 +61,7 @@ ensemble <- function(y, X, # Check if y is constant if (length(unique(y)) == 1) { warning(paste("Outcome variable y is constant. Ensemble will return", - "mean(y) for all predictions.")) + "mean(y) for all predictions."), call. = FALSE) # Return minimal output needed for predictions output <- list( mdl_fits = NULL, @@ -86,7 +86,8 @@ ensemble <- function(y, X, cv_results <- ens_w_res$cv_results # 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.") + warning("None of the learners are assigned positive stacking weights.", + call. = FALSE) }#IF # Fit all base learners to keep per-learner outputs always available mdl_fits <- rep(list(NULL), nlearners) @@ -114,6 +115,15 @@ ensemble <- function(y, X, # 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. +#' +#' @return A matrix of per-learner predictions with one column per +#' base learner. +#' #' @exportS3Method predict.ensemble <- function(object, newdata, ...){ # Data parameters @@ -193,7 +203,7 @@ ensemble_weights <- function(y, X, # Check whether out-of-sample residuals should be calculated to inform the # ensemble weights, and whether previous results are available. cv_stacking <- c("ols", "nnls", "nnls1", "singlebest") - if (any(cv_stacking %in% type) & is.null(cv_results)) { + if (any(cv_stacking %in% type) && is.null(cv_results)) { # Run crossvalidation procedure cv_results <- crossval(y, X, learners = learners, @@ -257,7 +267,7 @@ ensemble_weights <- function(y, X, }#IF # Assign ensemble types to columns if (!(ncustom == 0) && is.null(colnames(custom_weights))) { - colnames(custom_weights) <- paste0("custom_", 1:ncustom) + colnames(custom_weights) <- paste0("custom_", seq_len(ncustom)) }#IF colnames(weights) <- c(type, colnames(custom_weights)) # Organize and return output diff --git a/R/get_CEF.R b/R/get_CEF.R index 7b7e85f..8bfb4dd 100644 --- a/R/get_CEF.R +++ b/R/get_CEF.R @@ -38,15 +38,14 @@ get_CEF <- function(y, X, is.null(fitted$auxiliary_fitted_bylearner)) { stop(paste("When auxiliary predictions are required,", "fitted objects must contain", - "'auxiliary_fitted_bylearner'.")) + "'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) + auxiliary_fitted_bylearner = fitted$auxiliary_fitted_bylearner) return(res) }#IF if (!is.null(fitted$cf_fitted)) { @@ -80,8 +79,7 @@ get_CEF <- function(y, X, }#IF if (!is.null(label) && label != "") { - info_msg(" ", label, - " .......... skipped (constant outcome)", + info_msg(" ", label, " .......... skipped (constant outcome)", silent = silent) }#IF @@ -133,7 +131,9 @@ get_CEF <- function(y, X, # predictions into an (nobs x nensb x nlevels) array. # # @param D Treatment vector. -# @param CEF_res_byD List of get_CEF results, one per D level. +# @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 @@ -143,18 +143,18 @@ extrapolate_CEF <- function(D, CEF_res_byD, aux_indx) { is_D <- rep(list(NULL), nCEF) for (d in seq_len(nCEF)) is_D[[d]] <- which(D == D_levels[d]) nensb <- ncol(as.matrix( - CEF_res_byD[[1]][[1]]$cf_fitted)) + CEF_res_byD[[1]]$fit$cf_fitted)) sample_folds <- length( - CEF_res_byD[[1]][[1]]$auxiliary_fitted) + CEF_res_byD[[1]]$fit$auxiliary_fitted) # Populate CEF g_X_byD <- array(0, dim = c(nobs, nensb, nCEF)) for (d in seq_len(nCEF)) { g_X_byD[is_D[[d]], , d] <- - CEF_res_byD[[d]][[1]]$cf_fitted + 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]][[1]]$auxiliary_fitted[[k]] + CEF_res_byD[[d]]$fit$auxiliary_fitted[[k]] }#FOR }#FOR diff --git a/R/help_functions.R b/R/help_functions.R index afa946f..bb3993d 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -59,10 +59,12 @@ trim_propensity_scores <- function(m_X, trim, ensemble_type, if (!silent) { if (nensb == 1) { warning(paste0(ntrim, - " propensity scores were trimmed.")) + " propensity scores were trimmed."), + call. = FALSE) } else { warning(paste0(ensemble_type[j], ": ", ntrim, - " propensity scores were trimmed.")) + " propensity scores were trimmed."), + call. = FALSE) }#IFELSE }#IF m_X[indx_trim_0, j] <- trim @@ -215,14 +217,17 @@ validate_fitted_splits_pair <- function(fitted, splits, w_cv = FALSE) { if (is.null(fitted)) return(invisible(NULL)) if (is.null(splits)) { - stop("Argument 'splits' must be supplied when 'fitted' is supplied.") + stop("Argument 'splits' must be supplied when 'fitted' is supplied.", + call. = FALSE) }#IF if (is.null(splits$subsamples)) { - stop("splits must contain 'subsamples' when 'fitted' is supplied.") + stop("splits must contain 'subsamples' when 'fitted' is supplied.", + call. = FALSE) }#IF if (w_cv && is.null(splits$cv_subsamples)) { stop(paste("splits must contain 'cv_subsamples' for data-driven", - "stacking when 'fitted' is supplied.")) + "stacking when 'fitted' is supplied."), + call. = FALSE) }#IF }#VALIDATE_FITTED_SPLITS_PAIR @@ -274,7 +279,7 @@ normalize_splits <- function(splits = NULL, if (!is.null(dots[["cv_subsamples_list"]])) { if (!is.null(cv_subsamples)) stop("Specify cv_subsamples or cv_subsamples_list, ", - "not both.") + "not both.", call. = FALSE) message("Note: cv_subsamples_list has been renamed to ", "cv_subsamples.") cv_subsamples <- dots[["cv_subsamples_list"]] @@ -296,7 +301,7 @@ normalize_splits <- function(splits = NULL, }#IF if (is.null(splits) && !legacy_used) return(NULL) if (is.null(splits)) splits <- list() - if (!is.list(splits)) stop("'splits' must be a list.") + if (!is.list(splits)) stop("'splits' must be a list.", call. = FALSE) if (is.null(splits$subsamples) && !is.null(subsamples)) splits$subsamples <- subsamples if (is.null(splits$cv_subsamples) && !is.null(cv_subsamples)) @@ -341,40 +346,44 @@ validate_inputs <- function(y = NULL, D = NULL, X = NULL, Z = NULL, 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.") + 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.") + 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.") + 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).") + 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.") + 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.") + 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.") + stop("learners must be a list.", call. = FALSE) } else { is_single <- is_single_learner(learners) if (!is_single) { @@ -393,14 +402,16 @@ validate_inputs <- function(y = NULL, D = NULL, X = NULL, Z = NULL, 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.") + 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.") + stop("cv_folds must be a positive integer.", + call. = FALSE) } } @@ -409,7 +420,8 @@ validate_inputs <- function(y = NULL, D = NULL, X = NULL, Z = NULL, 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.") + "nnls, nnls1, singlebest, ols, average.", + call. = FALSE) } } @@ -417,22 +429,25 @@ validate_inputs <- function(y = NULL, D = NULL, X = NULL, Z = NULL, 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.") + "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.") + 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.") + 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.") + stop("cluster_variable must not contain NAs.", + call. = FALSE) } } }#VALIDATE_INPUTS @@ -440,12 +455,14 @@ validate_inputs <- function(y = NULL, D = NULL, X = NULL, Z = NULL, 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.") + 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.") + stop("Number of rows in custom_ensemble_weights must match ", + "the number of base learners.", call. = FALSE) } }#VALIDATE_CUSTOM_WEIGHTS diff --git a/R/methods.R b/R/methods.R index d621f5e..6c8335c 100644 --- a/R/methods.R +++ b/R/methods.R @@ -75,8 +75,16 @@ nobs.ddml <- function(object, ...) { #' Extract Generalized Leverage (Hat Values) #' #' @description Computes the generalized leverage (hat values) for a DDML -#' estimator. These values are used internally to compute heteroskedasticity-robust -#' HC3 standard errors. +#' estimator. These values are used internally to compute +#' heteroskedasticity-robust HC3 standard errors. +#' +#' @details See \code{\link{ddml-class}} for the DML framework and +#' the definition of \eqn{\psi_a} and \eqn{\hat{J}}. +#' For the linear scores used in \code{ddml}, +#' the generalized leverage simplifies to +#' +#' \eqn{h_{ii} = \mathrm{tr}(\psi_a(W_i; +#' \hat\eta)\,(n\hat{J})^{-1}).} #' #' @param model An object of class \code{ddml}. #' @param ensemble_idx Integer index of the ensemble type to extract leverage @@ -104,22 +112,14 @@ nobs.ddml <- function(object, ...) { #' @export hatvalues.ddml <- function(model, ensemble_idx = 1, ...) { validate_method_args(model, ensemble_idx = ensemble_idx) - if (is.list(model$psi_a)) { - psi_a_j <- model$psi_a[[ensemble_idx]] - J_j <- model$J[[ensemble_idx]] - J_inv <- csolve(J_j) - J_inv_vec <- as.vector(t(J_inv)) - - p <- ncol(J_j) - n <- model$nobs - dim(psi_a_j) <- c(n, p * p) - h <- (psi_a_j %*% J_inv_vec) / n - return(as.vector(h)) - }#IF - - psi_a_j <- model$psi_a[, ensemble_idx] - J_j <- as.numeric(model$J[[ensemble_idx]]) - as.vector(psi_a_j / (model$nobs * J_j)) + psi_a_j <- model$psi_a[[ensemble_idx]] + J_j <- model$J[, , ensemble_idx, drop = FALSE] + dim(J_j) <- dim(J_j)[1:2] + J_inv <- csolve(J_j) + p <- ncol(J_j) + n <- model$nobs + dim(psi_a_j) <- c(n, p * p) + as.vector((psi_a_j %*% as.vector(t(J_inv))) / n) }#HATVALUES.DDML @@ -132,18 +132,11 @@ hatvalues.ddml <- function(model, ensemble_idx = 1, ...) { #' variance-covariance matrix for the DDML estimator #' \eqn{\hat\theta}. #' -#' @details All implemented DDML estimators solve a moment -#' condition of the form -#' \eqn{E[m(W; \theta_0, \eta_0)] = 0} where the score -#' decomposes as -#' -#' \eqn{m(W_i; \theta, \eta) = \psi_{b}(W_i; \eta) + \psi_{a}(W_i; \eta)\,\theta.} -#' -#' Write \eqn{m_i = m(W_i; \hat\theta, \hat\eta)} for the -#' evaluated score and -#' \eqn{\hat{J} = n^{-1}\sum_i \psi_a(W_i; \hat\eta)} for -#' the sample Jacobian. Three sandwich estimators are -#' available: +#' @details See \code{\link{ddml-class}} for the DML framework, +#' including the definitions of the score \eqn{m_i}, +#' the Jacobian \eqn{\hat{J}}, and the base sandwich +#' estimator \eqn{\hat\Sigma}. This function provides +#' three variants: #' #' \strong{HC0}: #' \deqn{V_{\mathrm{HC0}} = \hat{J}^{-1} @@ -154,7 +147,7 @@ hatvalues.ddml <- function(model, ensemble_idx = 1, ...) { #' \deqn{V_{\mathrm{HC1}} = V_{\mathrm{HC0}} #' \times \frac{n}{n - p}} #' -#' where \eqn{p} is the dimension of \eqn{\theta}. +#' where \eqn{p} is the dimension of \eqn{\theta}. #' #' \strong{HC3}: #' \deqn{V_{\mathrm{HC3}} = \hat{J}^{-1} @@ -162,24 +155,8 @@ hatvalues.ddml <- function(model, ensemble_idx = 1, ...) { #' \frac{m_i m_i'}{(1 - h_{ii})^2}\right) #' \hat{J}^{-\top} / n} #' -#' where \eqn{h_{ii}} is the generalized leverage. In the -#' general case, -#' \deqn{h_{ii} = \mathrm{tr}\!\left( -#' \nabla_\theta m(W_i; \hat\theta, \hat\eta) -#' \left[\sum_{j=1}^n -#' \nabla_\theta m(W_j; \hat\theta, \hat\eta) -#' \right]^{-1}\right)} -#' -#' where \eqn{\nabla_\theta m(W_i; \hat\theta, \hat\eta)} -#' is the derivative of the \eqn{i}-th score with respect -#' to \eqn{\theta} (the nuisance parameters \eqn{\hat\eta} -#' are treated as fixed, having been estimated -#' out-of-sample). For the linear scores implemented in -#' \code{ddml}, the derivative is -#' \eqn{\nabla_\theta m(W_i; \theta, \eta) = \psi_a(W_i; \eta)}, -#' so the leverage simplifies to -#' -#' \eqn{h_{ii} = \mathrm{tr}(\psi_a(W_i; \hat\eta)\,(n\hat{J})^{-1}).} +#' where \eqn{h_{ii}} is the generalized leverage; +#' see \code{\link{hatvalues.ddml}}. #' #' @param object An object of class \code{ddml}. #' @param ensemble_idx Integer index of the ensemble type to @@ -218,8 +195,10 @@ vcov.ddml <- function(object, ensemble_idx = 1, stats::hatvalues(object, ensemble_idx = ensemble_idx) }#IF - sc <- as.matrix(object$scores[[ensemble_idx]]) - J_j <- as.matrix(object$J[[ensemble_idx]]) + sc <- object$scores[, , ensemble_idx, drop = FALSE] + dim(sc) <- dim(sc)[1:2] + J_j <- object$J[, , ensemble_idx, drop = FALSE] + dim(J_j) <- dim(J_j)[1:2] p <- ncol(sc) # Cluster aggregation: rowsum scores to cluster level @@ -302,7 +281,8 @@ confint.ddml <- function(object, parm, level = 0.95, } else { parm <- intersect(parm, cf_names) if (length(parm) == 0) { - stop("None of the specified 'parm' were found in the model coefficients.") + stop("None of the specified 'parm' were found in ", + "the model coefficients.", call. = FALSE) }#IF }#IFELSE diff --git a/R/ml_wrappers.R b/R/ml_wrappers.R index 641ff73..73078e6 100644 --- a/R/ml_wrappers.R +++ b/R/ml_wrappers.R @@ -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,6 +47,15 @@ mdl_glmnet <- function(y, X, return(mdl_fit) }#MDL_GLMNET +#' Predict method for \code{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 @@ -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), @@ -119,6 +128,15 @@ mdl_xgboost <- function(y, X, return(mdl_fit) }#MDL_XGBOOST +#' Predict method for \code{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. @@ -166,6 +184,16 @@ mdl_ranger <- function(y, X, ...){ return(mdl_fit) }#MDL_RANGER +#' Predict method for \code{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 @@ -179,7 +207,8 @@ predict.mdl_ranger <- function(object, newdata = NULL, ...){ } else if (object$treetype == "Regression") { 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 @@ -214,6 +243,15 @@ mdl_glm <- function(y, X, ...) { return(glm_fit) # return fitted glm object }#MDL_GLM +#' Predict method for \code{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 @@ -248,6 +286,14 @@ mdl_bigGLM <- function(y, X, ...) { return(mdl_fit) }#MDL_BIGGLM +#' Predict method for \code{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 diff --git a/R/ols.R b/R/ols.R index e8f851d..20f7bb7 100644 --- a/R/ols.R +++ b/R/ols.R @@ -52,6 +52,15 @@ ols <- function(y, X, # Complementary methods ======================================================== +#' Predict method for \code{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/shortstacking.R b/R/shortstacking.R index c8ca3cf..b7a0e60 100644 --- a/R/shortstacking.R +++ b/R/shortstacking.R @@ -5,21 +5,10 @@ #' @description Predictions using short-stacking. #' #' @inheritParams crosspred +#' @inheritParams ddml-class #' @param shortstack_y Optional vector of the outcome variable to form #' short-stacking predictions for. Base learners are always trained on #' \code{y}. -#' @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{shortstack} returns a list containing the following components: #' \describe{ @@ -29,11 +18,17 @@ #' \item{\code{weights}}{An array, providing the weight #' assigned to each base learner (in chronological order) by the #' ensemble procedures.} +#' \item{\code{mspe}}{A numeric vector of per-ensemble MSPEs for +#' the short-stacked predictions.} +#' \item{\code{r2}}{A numeric vector of per-ensemble +#' 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{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.} diff --git a/R/subsample_functions.R b/R/subsample_functions.R index ec47609..a9b0fdb 100644 --- a/R/subsample_functions.R +++ b/R/subsample_functions.R @@ -14,7 +14,7 @@ get_sample_splits <- function(cluster_variable, # 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.") + if (!by_D) stop("subsamples_byD requires D to be specified.", call. = FALSE) subsamples <- merge_subsamples_byD(subsamples_byD, D) }#IF @@ -111,17 +111,18 @@ get_crossfit_indices <- function(cluster_variable, compute_cf <- TRUE } else if (is.null(subsamples) && !is.null(subsamples_byD)) { stop(paste0("``subsamples`` must also be set when setting ", - "``subsamples_byD``.")) + "``subsamples_byD``."), call. = FALSE) } else if (!is.null(subsamples) && is.null(subsamples_byD) && by_D) { stop(paste0("When ``by_D==TRUE``, ``subsamples_byD`` must also be set ", - "when setting ``subsamples``.")) + "when setting ``subsamples``."), call. = FALSE) }#IF # Compute crossfit indices if (compute_cf) { if (stratify) { if (!by_D) - stop("Stratified sampling only works when ``by_D=TRUE``.") + 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) @@ -195,7 +196,7 @@ check_subsamples <- function(subsamples, subsamples_byD, stratify, min(training_counts_byD), " observations for training. Consider ", "increasing ", fold_arg, " if possible.") }#IFELSE - if (throw_warning) warning(warning_text) + if (throw_warning) warning(warning_text, call. = FALSE) # Return training counts (invisible) invisible(list(training_counts = training_counts, @@ -222,7 +223,7 @@ get_cf_indices_stratified <- function(cluster_variable, sample_folds, # 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.")) + "smaller than the number of sample folds."), call. = FALSE) # Check for clustering cluster <- (length(unique(cluster_variable)) != nobs) @@ -236,7 +237,8 @@ get_cf_indices_stratified <- function(cluster_variable, sample_folds, 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.")) + " 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), diff --git a/R/tidy.R b/R/tidy.R index ff92474..ff47dde 100644 --- a/R/tidy.R +++ b/R/tidy.R @@ -60,7 +60,8 @@ tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, j_seq <- seq_len(nensb) } else { if (any(ensemble_idx < 1) || any(ensemble_idx > nensb)) { - stop(sprintf("ensemble_idx must be between 1 and %d", nensb)) + stop(sprintf("ensemble_idx must be between 1 and %d", nensb), + call. = FALSE) }#IF j_seq <- ensemble_idx }#IFELSE diff --git a/README.Rmd b/README.Rmd index 4ef611a..a43cf07 100644 --- a/README.Rmd +++ b/README.Rmd @@ -66,7 +66,7 @@ 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(what = ols), list(what = mdl_glmnet), @@ -100,7 +100,11 @@ 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 diff --git a/README.md b/README.md index 1fad591..dbbd20f 100644 --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ Version](https://www.r-pkg.org/badges/version/ddml)](https://cran.r-project.org/ [![cranlogs](https://cranlogs.r-pkg.org/badges/ddml)](https://cran.r-project.org/package=ddml) -`ddml` is an implementation of Double/Debiased Machine Learning +`ddml` is an implementation of double/debiased machine learning estimators as proposed by Chernozhukov et al. (2018). The key feature of `ddml` is the straightforward estimation of nuisance parameters using (short-)stacking (Wolpert, 1992), which allows for multiple machine @@ -69,7 +69,7 @@ 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`). Since the +double/debiased machine learning (see `?ddml_late`). Since the statistical properties of machine learners depend heavily on the underlying (unknown!) structure of the data, adaptive combination of multiple machine learners can increase robustness. In the below snippet, @@ -82,7 +82,7 @@ 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(what = ols), list(what = mdl_glmnet), @@ -97,8 +97,8 @@ summary(late_fit_short) #> DDML estimation: Local Average Treatment Effect #> Obs: 5000 Folds: 10 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> LATE -0.220 0.187 -1.18 0.24 +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.223 0.187 -1.19 0.23 ``` ## Learn More about `ddml` @@ -142,6 +142,12 @@ 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 diff --git a/_pkgdown.yml b/_pkgdown.yml index 84c6972..d238a84 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -33,6 +33,7 @@ reference: - title: internal contents: - ddml + - ddml-class - matches("print") - matches("summary") - title: Supported Models @@ -53,6 +54,7 @@ reference: - coef.ddml - confint.ddml - vcov.ddml + - hatvalues.ddml - nobs.ddml - "`$.ddml`" - "`[.summary.ddml`" @@ -65,8 +67,10 @@ reference: - vcov.ddml_rep - tidy.ddml_rep - glance.ddml_rep + - nobs.ddml_rep - length.ddml_rep - "`[[.ddml_rep`" + - reexports - title: Wrappers for Common (Machine) Learners contents: - ols @@ -75,6 +79,7 @@ reference: - mdl_ranger - mdl_xgboost - mdl_bigGLM + - matches("predict") - title: Utilities contents: - crossval diff --git a/man/crosspred.Rd b/man/crosspred.Rd index 19db8be..1bac417 100644 --- a/man/crosspred.Rd +++ b/man/crosspred.Rd @@ -12,7 +12,6 @@ crosspred( ensemble_type = "average", cv_folds = 10, custom_ensemble_weights = NULL, - compute_insample_predictions = FALSE, cluster_variable = seq_along(y), subsamples = NULL, cv_subsamples = NULL, @@ -27,57 +26,45 @@ crosspred( \item{X}{A (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: -\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: +\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}.} \item{\code{assign_X} An optional vector of column indices -corresponding to predictive variables in \code{X} that are -passed to the base learner.} +corresponding to 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}.} +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{cluster_variable}{A vector of cluster indices.} @@ -116,17 +103,24 @@ order).} \item{\code{weights}}{An array, providing the weight assigned to each base learner (in chronological order) by the ensemble procedures.} -\item{\code{insample_fitted}}{When -\code{compute_insample_predictions = TRUE}. -a list of matrices with in-sample predictions by sample fold.} +\item{\code{mspe}}{A matrix of per-learner MSPEs, with +rows for learners and columns for sample folds. +\code{NULL} when a single learner is used.} +\item{\code{r2}}{A matrix of per-learner out-of-sample +R-squared values. Same dimensions as \code{mspe}. +\code{NULL} when a single learner is used.} +\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{cf_fitted_bylearner}}{A matrix of out-of-sample predictions, each column corresponding to a base learner (in chronological order).} -\item{\code{insample_fitted_bylearner}}{When -\code{compute_insample_predictions = TRUE}, a list of matrices -with in-sample predictions by sample fold (per learner).} +\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.} diff --git a/man/ddml-class.Rd b/man/ddml-class.Rd new file mode 100644 index 0000000..f62a51f --- /dev/null +++ b/man/ddml-class.Rd @@ -0,0 +1,266 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml-class.R +\name{ddml-class} +\alias{ddml-class} +\title{Common Output Structure for DDML Estimators} +\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{...}{Deprecated arguments are still accepted for backward +compatibility but should be replaced with the \code{splits} +argument. See individual estimator pages for details.} +} +\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. +} +\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,} + +\if{html}{\out{
}}\preformatted{where \eqn{W} denotes observed random variables and +\eqn{\eta_0} is a (potentially high-dimensional) nuisance +parameter, typically a vector of conditional expectation +functions. The score \eqn{m} is \\emph\{Neyman orthogonal\}, +meaning the moment condition is locally insensitive to +perturbations of \eqn{\eta} around \eqn{\eta_0}. + +Each estimator in \code{ddml} uses a score that decomposes +linearly in \eqn{\theta}: +}\if{html}{\out{
}} + +\deqn{m(W_i; \theta, \eta) = \psi_b(W_i; \eta) + + \psi_a(W_i; \eta)\,\theta.} + +\if{html}{\out{
}}\preformatted{See the individual estimator pages for the specific forms +of \eqn{\psi_a} and \eqn{\psi_b}. + +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 +}\if{html}{\out{
}} + +\deqn{\frac{1}{n} \sum_{k=1}^{K} \sum_{i \in I_k} + m(W_i; \hat\theta, \hat\eta_{-k}) = 0.} + +\if{html}{\out{
}}\preformatted{For the linear scores used in \code{ddml}, this yields the +closed-form solution +}\if{html}{\out{
}} + +\deqn{\hat\theta = -\hat{J}^{-1}\,\hat\psi_b,} + +\if{html}{\out{
}}\preformatted{where \eqn{\hat\psi_b = n^{-1}\sum_{k}\sum_{i \in I_k} + \psi_b(W_i; \hat\eta_{-k})} and +\eqn{\hat{J} = n^{-1}\sum_k \sum_{i \in I_k} + \psi_a(W_i; \hat\eta_{-k})} is the sample Jacobian. + +Inference is based on the sandwich variance estimator +}\if{html}{\out{
}} + +\deqn{\hat\Sigma = \hat{J}^{-1} \left(\frac{1}{n} + \sum_i m_i m_i^\top\right) + \hat{J}^{-\top} / n} + +\if{html}{\out{
}}\preformatted{where \eqn{m_i = m(W_i; \hat\theta, \hat\eta_{-k(i)})}; +see \code{\link{vcov.ddml}} for HC0/HC1/HC3 variants. +Under regularity conditions and sufficient convergence of \eqn{\hat\eta}, +the DML estimator is asymptotically normal: +}\if{html}{\out{
}} + +\deqn{\sqrt{n}\,\hat\Sigma^{-1/2}(\hat\theta - \theta_0) + \overset{d}{\to} N(0, I).} + +\if{html}{\out{
}}\preformatted{Further details and regularity conditions are given in +Chernozhukov et al. (2018). +}\if{html}{\out{
}} +} +\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 per-learner MSPEs from +the cross-validation step in ensemble construction.} +\item{\code{r2}}{A named list of per-learner out-of-sample +R-squared values.} +\item{\code{psi_a}, \code{psi_b}}{Score component lists +(length \code{nensb}). \code{psi_a[[j]]} is an +\code{(n x p x p)} array and \code{psi_b[[j]]} is an +\code{(n x p)} matrix. Used internally by +\code{\link{hatvalues.ddml}}.} +\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.ddml}}, \code{\link{vcov.ddml}}, +\code{\link{confint.ddml}}, \code{\link{hatvalues.ddml}}, +\code{\link{nobs.ddml}}, \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_fpliv}()}, +\code{\link{ddml_late}()}, +\code{\link{ddml_pliv}()}, +\code{\link{ddml_plm}()} +} +\concept{ddml estimators} diff --git a/man/ddml_apo.Rd b/man/ddml_apo.Rd index c01fdd3..c8a0e94 100644 --- a/man/ddml_apo.Rd +++ b/man/ddml_apo.Rd @@ -42,44 +42,49 @@ ddml_apo( \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: +\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{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}.} \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{what}. 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.} } @@ -87,14 +92,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 @@ -129,7 +135,8 @@ 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 the example below.} +\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 @@ -137,8 +144,8 @@ recomputed. This allows fast re-estimation with a different \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 +\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 @@ -152,30 +159,9 @@ argument.} } \value{ \code{ddml_apo} returns an object of S3 class -\code{ddml_apo}. An object of class \code{ddml_apo} is a list -containing the following components: -\describe{ -\item{\code{coefficients}}{A matrix of estimated coefficients.} -\item{\code{ensemble_weights}}{A list of matrices, providing the -weight assigned to each base learner by the ensemble -procedure.} -\item{\code{mspe}}{A list of matrices, providing the MSPE of each -base learner computed by the cross-validation step in the -ensemble construction.} -\item{\code{r2}}{The out-of-sample R-squared.} -\item{\code{psi_a}, \code{psi_b}}{Score components used in -\code{\link{vcov.ddml}}.} -\item{\code{scores}}{A list of evaluated Neyman orthogonal -scores.} -\item{\code{J}}{A list of evaluated Jacobians.} -\item{\code{fitted}}{A list of fitted nuisance estimators. -See \code{\link{ddml_plm}} for more information.} -\item{\code{splits}}{The data splitting structure.} -\item{\code{learners},\code{learners_DX}, -\code{cluster_variable}, -\code{ensemble_type}}{Pass-through of selected -user-provided arguments. See above.} -} +\code{ddml_apo} and \code{ddml}. See \code{\link{ddml-class}} +for the common output structure. Additional pass-through +fields: \code{learners}, \code{learners_DX}. } \description{ \code{ddml_apo} provides a Double/Debiased Machine Learning @@ -211,17 +197,37 @@ The estimating equation is \if{html}{\out{
}}\preformatted{with nuisance parameters \eqn{\eta = (\ell, p)} taking true values \eqn{\ell_0(X) = E[Y|D=d, X]} and \eqn{p_0(X) = E[\mathbbm{1}\{D=d\}|X]}. }\if{html}{\out{
}} +} +\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) + } \references{ -Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024). -"Model Averaging and Double Machine Learning." -\url{https://arxiv.org/abs/2401.01645} +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. } \seealso{ -\code{\link{summary.ddml}}, -\code{\link{vcov.ddml}}, \code{\link{confint.ddml}}, -\code{\link{hatvalues.ddml}}, -\code{\link{ddml_plm}}, \code{\link{ddml_pliv}}, -\code{\link{ddml_fpliv}}, \code{\link{ddml_late}}, -\code{\link{ddml_ate}} +\code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, +\code{\link[=vcov.ddml]{vcov.ddml()}}, \code{\link[=confint.ddml]{confint.ddml()}}, +\code{\link[=hatvalues.ddml]{hatvalues.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, +\code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}} + +Other ddml estimators: +\code{\link{ddml-class}}, +\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_ate.Rd b/man/ddml_ate.Rd index 522037f..b6a741d 100644 --- a/man/ddml_ate.Rd +++ b/man/ddml_ate.Rd @@ -58,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{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}.} \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{what}. 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.} } @@ -103,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 @@ -141,17 +147,25 @@ that use packages not imported by \code{ddml}).} }} \item{fitted}{An optional named list of per-equation cross-fitted -predictions, typically obtained via \code{fit$fitted}. See -\code{\link{ddml_plm}} for details and an example.} +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; store inner cross-validation -residuals for exact weight recomputation on pass-through. -See \code{\link{ddml_plm}} for details.} +\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{...}{Deprecated arguments (\code{subsamples}, \code{subsamples_byD}, \code{cv_subsamples}, @@ -159,32 +173,11 @@ See \code{\link{ddml_plm}} for details.} compatibility but should be replaced with \code{splits}.} } \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: -\describe{ -\item{\code{coefficients}}{A matrix of estimated coefficients.} -\item{\code{ensemble_weights}}{A list of matrices, providing the -weight assigned to each base learner by the ensemble -procedure.} -\item{\code{mspe}}{A list of matrices, providing the MSPE of each -base learner computed by the cross-validation step in the -ensemble construction.} -\item{\code{r2}}{The out-of-sample R-squared.} -\item{\code{psi_a}, \code{psi_b}}{Score components used in -\code{\link{vcov.ddml}}.} -\item{\code{scores}}{A list of evaluated Neyman orthogonal -scores.} -\item{\code{J}}{A list of evaluated Jacobians.} -\item{\code{fitted}}{A list of fitted nuisance estimators. -See \code{\link{ddml_plm}} for more information.} -\item{\code{splits}}{The data splitting structure.} -\item{\code{learners},\code{learners_DX}, -\code{cluster_variable}, -\code{ensemble_type}}{Pass-through of -selected user-provided arguments. See above.} -} +\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-class}} for the common output structure. +Additional pass-through fields: \code{learners}, +\code{learners_DX}. } \description{ Estimators of the average treatment effect and the average @@ -268,12 +261,9 @@ 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]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, -\code{\link[=vcov.ddml]{vcov.ddml()}}, \code{\link[=confint.ddml]{confint.ddml()}}, -\code{\link[=hatvalues.ddml]{hatvalues.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, -\code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}} - Other ddml estimators: +\code{\link{ddml-class}}, +\code{\link{ddml_apo}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, diff --git a/man/ddml_fpliv.Rd b/man/ddml_fpliv.Rd index 25db719..68a125c 100644 --- a/man/ddml_fpliv.Rd +++ b/man/ddml_fpliv.Rd @@ -37,31 +37,34 @@ 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 three named elements: +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{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{what}. 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_DXZ, learners_DX}{Optional arguments to allow for different estimators of \eqn{E[D \vert X, Z]}, \eqn{E[D \vert 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_DXZ, custom_ensemble_weights_DX}{Optional arguments to allow for different @@ -118,49 +124,36 @@ that use packages not imported by \code{ddml}).} }} \item{fitted}{An optional named list of per-equation cross-fitted -predictions, typically obtained via \code{fit$fitted}. See -\code{\link{ddml_plm}} for details.} +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; store inner cross-validation -residuals for exact weight recomputation on pass-through. -See \code{\link{ddml_plm}} for details.} - -\item{...}{Deprecated arguments (\code{subsamples}, -\code{cv_subsamples}, \code{cv_subsamples_list}) are still -accepted for backward compatibility but should be replaced -with the \code{splits} argument.} +\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{...}{Deprecated arguments are still accepted for backward +compatibility but should be replaced with the \code{splits} +argument. See individual estimator pages for details.} } \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{coefficients}}{A matrix of estimated coefficients.} -\item{\code{ensemble_weights}}{A list of matrices, providing the -weight assigned to each base learner by the ensemble -procedure.} -\item{\code{mspe}}{A list of matrices, providing the MSPE of each -base learner computed by the cross-validation step in the -ensemble construction.} -\item{\code{r2}}{The out-of-sample R-squared.} -\item{\code{psi_a}, \code{psi_b}}{Score components used in -\code{\link{vcov.ddml}}.} -\item{\code{scores}}{A list of evaluated Neyman orthogonal -scores.} -\item{\code{J}}{A list of evaluated Jacobians.} -\item{\code{fitted}}{A list of fitted nuisance estimators. -See \code{\link{ddml_plm}} for more information.} -\item{\code{splits}}{The data splitting structure.} -\item{\code{learners},\code{learners_DXZ}, -\code{learners_DX},\code{cluster_variable}, -\code{ensemble_type}}{Pass-through of selected -user-provided arguments. See above.} -} +\code{ddml_fpliv} and \code{ddml}. See +\code{\link{ddml-class}} 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. @@ -214,13 +207,11 @@ 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]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, -\code{\link[=vcov.ddml]{vcov.ddml()}}, \code{\link[=confint.ddml]{confint.ddml()}}, -\code{\link[=hatvalues.ddml]{hatvalues.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, -\code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}}, \code{\link[AER:ivreg]{AER::ivreg()}} Other ddml estimators: +\code{\link{ddml-class}}, +\code{\link{ddml_apo}()}, \code{\link{ddml_ate}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index f888f81..ebb48d3 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -33,37 +33,40 @@ ddml_late( \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 three named elements: +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{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{what}. 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_DXZ, learners_ZX}{Optional arguments to allow for different estimators of \eqn{E[D \vert X, Z]}, \eqn{E[Z \vert X]}. Setup is @@ -71,13 +74,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.} } @@ -85,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 @@ -126,17 +132,25 @@ that use packages not imported by \code{ddml}).} }} \item{fitted}{An optional named list of per-equation cross-fitted -predictions, typically obtained via \code{fit$fitted}. See -\code{\link{ddml_plm}} for details and an example.} +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; store inner cross-validation -residuals for exact weight recomputation on pass-through. -See \code{\link{ddml_plm}} for details.} +\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{...}{Deprecated arguments (\code{subsamples}, \code{subsamples_byZ}, \code{cv_subsamples}, @@ -145,30 +159,10 @@ compatibility but should be replaced with \code{splits}.} } \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{coefficients}}{A matrix of estimated coefficients.} -\item{\code{ensemble_weights}}{A list of matrices, providing the -weight assigned to each base learner by the ensemble -procedure.} -\item{\code{mspe}}{A list of matrices, providing the MSPE of -each base learner computed by the cross-validation step -in the ensemble construction.} -\item{\code{r2}}{The out-of-sample R-squared.} -\item{\code{psi_a}, \code{psi_b}}{Score components used in -\code{\link{vcov.ddml}}.} -\item{\code{scores}}{A list of evaluated Neyman orthogonal -scores.} -\item{\code{J}}{A list of evaluated Jacobians.} -\item{\code{fitted}}{A list of fitted nuisance estimators. -See \code{\link{ddml_plm}} for more information.} -\item{\code{splits}}{The data splitting structure.} -\item{\code{learners},\code{learners_DXZ}, -\code{learners_ZX},\code{cluster_variable}, -\code{ensemble_type}}{Pass-through of selected -user-provided arguments. See above.} -} +\code{ddml_late} and \code{ddml}. See +\code{\link{ddml-class}} 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. @@ -256,12 +250,9 @@ Treatment Effects." Econometrica, 62(2), 467-475. Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. } \seealso{ -\code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, -\code{\link[=vcov.ddml]{vcov.ddml()}}, \code{\link[=confint.ddml]{confint.ddml()}}, -\code{\link[=hatvalues.ddml]{hatvalues.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, -\code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}} - Other ddml estimators: +\code{\link{ddml-class}}, +\code{\link{ddml_apo}()}, \code{\link{ddml_ate}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_pliv}()}, diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index c94e4af..ba62098 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -37,31 +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 three named elements: +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{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{what}. 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, 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 @@ -122,52 +128,32 @@ 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 the example below.} +\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 +\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{...}{Deprecated arguments (\code{subsamples}, -\code{cv_subsamples}, \code{cv_subsamples_list}) are still -accepted for backward compatibility but should be replaced -with the \code{splits} argument.} +\item{...}{Deprecated arguments are still accepted for backward +compatibility but should be replaced with the \code{splits} +argument. See individual estimator pages for details.} } \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{coefficients}}{A matrix of estimated coefficients.} -\item{\code{ensemble_weights}}{A list of matrices, providing the -weight assigned to each base learner by the ensemble -procedure.} -\item{\code{mspe}}{A list of matrices, providing the MSPE of each -base learner computed by the cross-validation step in the -ensemble construction.} -\item{\code{r2}}{The out-of-sample R-squared.} -\item{\code{psi_a}, \code{psi_b}}{Score components used in -\code{\link{vcov.ddml}}.} -\item{\code{scores}}{A list of evaluated Neyman orthogonal -scores.} -\item{\code{J}}{A list of evaluated Jacobians.} -\item{\code{fitted}}{A list of fitted nuisance estimators. -See \code{\link{ddml_plm}} for more information.} -\item{\code{splits}}{The data splitting structure.} -\item{\code{learners},\code{learners_DX},\code{learners_ZX}, -\code{cluster_variable}, -\code{ensemble_type}}{Pass-through of selected -user-provided arguments. See above.} -} +\code{ddml_pliv} and \code{ddml}. See \code{\link{ddml-class}} +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. @@ -224,13 +210,11 @@ New York. Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. } \seealso{ -\code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, -\code{\link[=vcov.ddml]{vcov.ddml()}}, \code{\link[=confint.ddml]{confint.ddml()}}, -\code{\link[=hatvalues.ddml]{hatvalues.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, -\code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}}, \code{\link[AER:ivreg]{AER::ivreg()}} Other ddml estimators: +\code{\link{ddml-class}}, +\code{\link{ddml_apo}()}, \code{\link{ddml_ate}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, diff --git a/man/ddml_plm.Rd b/man/ddml_plm.Rd index 9d89a9a..fcd8f9d 100644 --- a/man/ddml_plm.Rd +++ b/man/ddml_plm.Rd @@ -32,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{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}.} \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{what}. 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.} } @@ -77,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 @@ -113,53 +119,31 @@ 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 the example below.} +\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 +\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{...}{Deprecated arguments (\code{subsamples}, -\code{cv_subsamples}, \code{cv_subsamples_list}) are still -accepted for backward compatibility but should be replaced -with the \code{splits} argument.} +\item{...}{Deprecated arguments are still accepted for backward +compatibility but should be replaced with the \code{splits} +argument. See individual estimator pages for details.} } \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{coefficients}}{A matrix of estimated coefficients.} -\item{\code{ensemble_weights}}{A list of matrices, providing the -weight assigned to each base learner by the ensemble -procedure.} -\item{\code{mspe}}{A list of matrices, providing the MSPE of each -base learner computed by the cross-validation step in the -ensemble construction.} -\item{\code{r2}}{The out-of-sample R-squared.} -\item{\code{psi_a}, \code{psi_b}}{Score components used in -\code{\link{vcov.ddml}}.} -\item{\code{scores}}{A list of evaluated Neyman orthogonal -scores.} -\item{\code{J}}{A list of evaluated Jacobians.} -\item{\code{fitted}}{A list of fitted nuisance estimators. -Can be passed back via the \code{fitted} argument to -skip cross-fitting on re-estimation.} -\item{\code{splits}}{The data splitting structure.} -\item{\code{learners},\code{learners_DX}, -\code{cluster_variable}, -\code{ensemble_type}}{Pass-through of selected -user-provided arguments. See above.} -} +\code{ddml_plm} and \code{ddml}. See \code{\link{ddml-class}} +for the common output structure. Additional pass-through +fields: \code{learners}, \code{learners_DX}. } \description{ Estimator for the partially linear model. @@ -245,12 +229,9 @@ 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]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, -\code{\link[=vcov.ddml]{vcov.ddml()}}, \code{\link[=confint.ddml]{confint.ddml()}}, -\code{\link[=hatvalues.ddml]{hatvalues.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, -\code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}} - Other ddml estimators: +\code{\link{ddml-class}}, +\code{\link{ddml_apo}()}, \code{\link{ddml_ate}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, diff --git a/man/hatvalues.ddml.Rd b/man/hatvalues.ddml.Rd index ecd83c6..910e7f1 100644 --- a/man/hatvalues.ddml.Rd +++ b/man/hatvalues.ddml.Rd @@ -19,8 +19,18 @@ A numeric vector of generalized leverage values. } \description{ Computes the generalized leverage (hat values) for a DDML -estimator. These values are used internally to compute heteroskedasticity-robust -HC3 standard errors. +estimator. These values are used internally to compute +heteroskedasticity-robust HC3 standard errors. +} +\details{ +See \code{\link{ddml-class}} for the DML framework and +the definition of \eqn{\psi_a} and \eqn{\hat{J}}. +For the linear scores used in \code{ddml}, +the generalized leverage simplifies to + +\if{html}{\out{
}}\preformatted{\eqn{h_{ii} = \mathrm{tr}(\psi_a(W_i; + \hat\eta)\,(n\hat{J})^{-1}).} +}\if{html}{\out{
}} } \examples{ \donttest{ diff --git a/man/mdl_glmnet.Rd b/man/mdl_glmnet.Rd index e0e0648..718469b 100644 --- a/man/mdl_glmnet.Rd +++ b/man/mdl_glmnet.Rd @@ -32,11 +32,11 @@ 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()}} diff --git a/man/mdl_xgboost.Rd b/man/mdl_xgboost.Rd index 0943e25..f0ebd72 100644 --- a/man/mdl_xgboost.Rd +++ b/man/mdl_xgboost.Rd @@ -38,7 +38,7 @@ 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()}} diff --git a/man/predict.ensemble.Rd b/man/predict.ensemble.Rd new file mode 100644 index 0000000..a46808b --- /dev/null +++ b/man/predict.ensemble.Rd @@ -0,0 +1,22 @@ +% 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, ...) +} +\arguments{ +\item{object}{A fitted \code{ensemble} object.} + +\item{newdata}{A feature matrix for prediction.} + +\item{...}{Currently unused.} +} +\value{ +A matrix of per-learner predictions with 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..9f26572 --- /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 \code{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 \code{mdl_bigGLM} objects. +} diff --git a/man/predict.mdl_glm.Rd b/man/predict.mdl_glm.Rd new file mode 100644 index 0000000..473caaf --- /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 \code{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 \code{mdl_glm} objects. +} diff --git a/man/predict.mdl_glmnet.Rd b/man/predict.mdl_glmnet.Rd new file mode 100644 index 0000000..e5b92b0 --- /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 \code{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 \code{mdl_glmnet} objects. +} diff --git a/man/predict.mdl_ranger.Rd b/man/predict.mdl_ranger.Rd new file mode 100644 index 0000000..2d4b2ae --- /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 \code{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 \code{mdl_ranger} objects. +} diff --git a/man/predict.mdl_xgboost.Rd b/man/predict.mdl_xgboost.Rd new file mode 100644 index 0000000..01f6cc9 --- /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 \code{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 \code{mdl_xgboost} objects. +} diff --git a/man/predict.ols.Rd b/man/predict.ols.Rd new file mode 100644 index 0000000..b133972 --- /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 \code{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 \code{ols} objects. +} diff --git a/man/shortstacking.Rd b/man/shortstacking.Rd index b3a2419..5dd08ec 100644 --- a/man/shortstacking.Rd +++ b/man/shortstacking.Rd @@ -11,7 +11,6 @@ shortstacking( sample_folds = 2, ensemble_type = "average", custom_ensemble_weights = NULL, - compute_insample_predictions = FALSE, cluster_variable = seq_along(y), subsamples = NULL, silent = FALSE, @@ -25,54 +24,43 @@ shortstacking( \item{X}{A (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: -\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: +\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}.} \item{\code{assign_X} An optional vector of column indices -corresponding to predictive variables in \code{X} that are -passed to the base learner.} +corresponding to 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}.} +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{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{cluster_variable}{A vector of cluster indices.} @@ -110,16 +98,17 @@ order).} \item{\code{weights}}{An array, providing the weight assigned to each base learner (in chronological order) by the ensemble procedures.} -\item{\code{insample_fitted}}{When \code{compute_insample_predictions = TRUE}. -a list of matrices with in-sample predictions by sample fold.} +\item{\code{mspe}}{A numeric vector of per-ensemble MSPEs for +the short-stacked predictions.} +\item{\code{r2}}{A numeric vector of per-ensemble +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{cf_fitted_bylearner}}{A matrix of out-of-sample predictions, each column corresponding to a base learner (in chronological order).} -\item{\code{insample_fitted_bylearner}}{When -\code{compute_insample_predictions = TRUE}, a list of matrices with -in-sample predictions by sample fold.} +\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.} diff --git a/man/vcov.ddml.Rd b/man/vcov.ddml.Rd index b9d3d27..85162f4 100644 --- a/man/vcov.ddml.Rd +++ b/man/vcov.ddml.Rd @@ -27,18 +27,11 @@ variance-covariance matrix for the DDML estimator \eqn{\hat\theta}. } \details{ -All implemented DDML estimators solve a moment -condition of the form -\eqn{E[m(W; \theta_0, \eta_0)] = 0} where the score -decomposes as - -\eqn{m(W_i; \theta, \eta) = \psi_{b}(W_i; \eta) + \psi_{a}(W_i; \eta)\,\theta.} - -Write \eqn{m_i = m(W_i; \hat\theta, \hat\eta)} for the -evaluated score and -\eqn{\hat{J} = n^{-1}\sum_i \psi_a(W_i; \hat\eta)} for -the sample Jacobian. Three sandwich estimators are -available: +See \code{\link{ddml-class}} for the DML framework, +including the definitions of the score \eqn{m_i}, +the Jacobian \eqn{\hat{J}}, and the base sandwich +estimator \eqn{\hat\Sigma}. This function provides +three variants: \strong{HC0}: \deqn{V_{\mathrm{HC0}} = \hat{J}^{-1} @@ -49,7 +42,8 @@ available: \deqn{V_{\mathrm{HC1}} = V_{\mathrm{HC0}} \times \frac{n}{n - p}} -where \eqn{p} is the dimension of \eqn{\theta}. +\if{html}{\out{
}}\preformatted{where \eqn{p} is the dimension of \eqn{\theta}. +}\if{html}{\out{
}} \strong{HC3}: \deqn{V_{\mathrm{HC3}} = \hat{J}^{-1} @@ -57,24 +51,9 @@ where \eqn{p} is the dimension of \eqn{\theta}. \frac{m_i m_i'}{(1 - h_{ii})^2}\right) \hat{J}^{-\top} / n} -where \eqn{h_{ii}} is the generalized leverage. In the -general case, -\deqn{h_{ii} = \mathrm{tr}\!\left( - \nabla_\theta m(W_i; \hat\theta, \hat\eta) - \left[\sum_{j=1}^n - \nabla_\theta m(W_j; \hat\theta, \hat\eta) - \right]^{-1}\right)} - -where \eqn{\nabla_\theta m(W_i; \hat\theta, \hat\eta)} -is the derivative of the \eqn{i}-th score with respect -to \eqn{\theta} (the nuisance parameters \eqn{\hat\eta} -are treated as fixed, having been estimated -out-of-sample). For the linear scores implemented in -\code{ddml}, the derivative is -\eqn{\nabla_\theta m(W_i; \theta, \eta) = \psi_a(W_i; \eta)}, -so the leverage simplifies to - -\eqn{h_{ii} = \mathrm{tr}(\psi_a(W_i; \hat\eta)\,(n\hat{J})^{-1}).} +\if{html}{\out{
}}\preformatted{where \eqn{h_{ii}} is the generalized leverage; +see \code{\link{hatvalues.ddml}}. +}\if{html}{\out{
}} } \examples{ \donttest{ diff --git a/tests/testthat/test-ddml_ate.R b/tests/testthat/test-ddml_ate.R index e954e14..f30ebff 100644 --- a/tests/testthat/test-ddml_ate.R +++ b/tests/testthat/test-ddml_ate.R @@ -291,7 +291,7 @@ test_that("ddml_ate scores are mean-zero", { fit <- ddml_ate(y, D, X, learners = list(what = ols), sample_folds = 3, silent = TRUE) - score_mean <- mean(fit$scores[[1]]) + score_mean <- mean(fit$scores[, , 1]) expect_true(abs(score_mean) < 0.01, label = paste("score mean =", round(score_mean, 6))) }) @@ -308,3 +308,47 @@ test_that("ddml_ate point estimate is close to true ATE", { 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_late.R b/tests/testthat/test-ddml_late.R index b3a84ab..08d8603 100644 --- a/tests/testthat/test-ddml_late.R +++ b/tests/testthat/test-ddml_late.R @@ -291,7 +291,7 @@ test_that("ddml_late scores are mean-zero", { fit <- ddml_late(y, D, Z, X, learners = list(what = ols), sample_folds = 3, silent = TRUE) - score_mean <- mean(fit$scores[[1]]) + score_mean <- mean(fit$scores[, , 1]) expect_true(abs(score_mean) < 0.05, label = paste("score mean =", round(score_mean, 6))) }) diff --git a/tests/testthat/test-get_CEF.R b/tests/testthat/test-get_CEF.R new file mode 100644 index 0000000..091f336 --- /dev/null +++ b/tests/testthat/test-get_CEF.R @@ -0,0 +1,123 @@ +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 From 6ec6a7d0cc628f3202b32a47a8ea05a033899f89 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Mon, 9 Mar 2026 11:41:18 -0500 Subject: [PATCH 22/46] fix cvxr --- R/cvc.R | 4 ++++ R/ddml_apo.R | 2 +- R/ddml_rep.R | 2 +- R/diagnostics.R | 4 ++++ _pkgdown.yml | 4 ++-- vignettes/articles/stacking_diagnostics.Rmd.txt | 2 ++ 6 files changed, 14 insertions(+), 4 deletions(-) diff --git a/R/cvc.R b/R/cvc.R index f0570de..3fa4082 100644 --- a/R/cvc.R +++ b/R/cvc.R @@ -5,6 +5,10 @@ # with fold-level demeaning to account for cross-fitting # dependence. # +# Reference: Lei J (2020). "Cross-Validation With Confidence." +# Journal of the American Statistical Association, +# 115(532), 1978-1997. +# # @param resid1 Numeric vector of OOS residuals from learner 1. # @param resid2 Numeric vector of OOS residuals from learner 2. # @param fid Integer vector of fold IDs (same length as resid1). diff --git a/R/ddml_apo.R b/R/ddml_apo.R index d02261a..855d7d4 100644 --- a/R/ddml_apo.R +++ b/R/ddml_apo.R @@ -1,4 +1,4 @@ -#' DDML Estimator for the Average Potential Outcome +#' Estimator for the Average Potential Outcome. #' #' @family ddml estimators #' diff --git a/R/ddml_rep.R b/R/ddml_rep.R index d03dc98..799cdc9 100644 --- a/R/ddml_rep.R +++ b/R/ddml_rep.R @@ -52,7 +52,7 @@ spectral_median_psd <- function(matrices) { obj <- obj + CVXR::norm(V - matrices[[r]], "2") }#FOR - result <- CVXR::solve(CVXR::Problem(CVXR::Minimize(obj))) + result <- CVXR::psolve(CVXR::Problem(CVXR::Minimize(obj))) if (result$status != "optimal") { warning("SDP solver returned status '", diff --git a/R/diagnostics.R b/R/diagnostics.R index 10180a5..ba09aa1 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -31,6 +31,10 @@ #' tidy(diagnostics(plm_fit)) #' } #' +#' @references +#' Lei J (2020). "Cross-Validation With Confidence." Journal of the American +#' Statistical Association, 115(532), 1978-1997. +#' #' @export diagnostics <- function(object, cvc = FALSE, bootnum = 500, alpha = 0.05, diff --git a/_pkgdown.yml b/_pkgdown.yml index d238a84..09d5429 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -36,7 +36,7 @@ reference: - ddml-class - matches("print") - matches("summary") -- title: Supported Models +- title: Supported DDML Estimators contents: - ddml_plm - ddml_pliv @@ -71,6 +71,7 @@ reference: - length.ddml_rep - "`[[.ddml_rep`" - reexports + - matches("predict") - title: Wrappers for Common (Machine) Learners contents: - ols @@ -79,7 +80,6 @@ reference: - mdl_ranger - mdl_xgboost - mdl_bigGLM - - matches("predict") - title: Utilities contents: - crossval diff --git a/vignettes/articles/stacking_diagnostics.Rmd.txt b/vignettes/articles/stacking_diagnostics.Rmd.txt index 29fd6aa..728ded0 100644 --- a/vignettes/articles/stacking_diagnostics.Rmd.txt +++ b/vignettes/articles/stacking_diagnostics.Rmd.txt @@ -127,3 +127,5 @@ Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, Wiemann T (2026). 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. From 78ae3abdd11d498ca1de1b01cd3ebb31e01894b1 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Tue, 10 Mar 2026 10:33:19 -0500 Subject: [PATCH 23/46] ddml constructor + docs + cvc fixes + new splits --- .Rbuildignore | 1 + .gitignore | 1 + NAMESPACE | 1 + R/AE98.R | 2 +- R/crosspred.R | 38 +- R/crossval.R | 2 +- R/cvc.R | 170 ------ R/ddml-class.R | 229 -------- R/ddml-package.R | 15 + R/ddml.R | 969 ++++++++++++++++++++++++++++++++- R/ddml_apo.R | 114 ++-- R/ddml_ate.R | 137 +++-- R/ddml_att.R | 63 ++- R/ddml_fpliv.R | 98 ++-- R/ddml_late.R | 127 +++-- R/ddml_pliv.R | 91 ++-- R/ddml_plm.R | 85 ++- R/ddml_rep.R | 24 +- R/diagnostics.R | 215 ++++---- R/ensemble.R | 37 +- R/help_functions.R | 59 +- R/methods.R | 444 --------------- R/ml_wrappers.R | 20 +- R/ols.R | 4 +- R/shortstacking.R | 30 +- R/subsample_functions.R | 64 ++- R/tidy.R | 148 ----- _pkgdown.yml | 17 +- tests/testthat/test-ddml_plm.R | 81 +-- 29 files changed, 1604 insertions(+), 1682 deletions(-) delete mode 100644 R/cvc.R delete mode 100644 R/ddml-class.R create mode 100644 R/ddml-package.R delete mode 100644 R/methods.R delete mode 100644 R/tidy.R diff --git a/.Rbuildignore b/.Rbuildignore index f07ecf6..6ffcddd 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -25,3 +25,4 @@ ^\.discussion$ ^\.discussions$ ^GEMINI\.md$ +^README.html$ \ No newline at end of file diff --git a/.gitignore b/.gitignore index 732e3eb..09b0fdf 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,4 @@ inst/doc .discussion/ .discussions/ GEMINI.md +README.html diff --git a/NAMESPACE b/NAMESPACE index e1d4919..8608172 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -33,6 +33,7 @@ S3method(vcov,ddml) S3method(vcov,ddml_rep) export(crosspred) export(crossval) +export(ddml) export(ddml_apo) export(ddml_ate) export(ddml_att) diff --git a/R/AE98.R b/R/AE98.R index 08570fa..97e408a 100644 --- a/R/AE98.R +++ b/R/AE98.R @@ -1,4 +1,4 @@ -#' Random subsample from the data of Angrist & Evans (1998). +#' Random Subsample from the Data of Angrist & Evans (1998) #' #' @description Random subsample from the data of Angrist & Evans (1998). #' diff --git a/R/crosspred.R b/R/crosspred.R index b272487..6a70c23 100644 --- a/R/crosspred.R +++ b/R/crosspred.R @@ -1,4 +1,4 @@ -#' Cross-Fitted Predictions using Stacking. +#' Cross-Fitted Predictions Using Stacking #' #' @family utilities #' @@ -45,7 +45,7 @@ #' \eqn{\mathcal{T}_s} and predictions are made for \eqn{I_s}. #' #' @inheritParams crossval -#' @inheritParams ddml-class +#' @inheritParams ddml-intro #' @param subsamples List of vectors with sample indices for cross-fitting. #' @param cv_subsamples List of lists, each corresponding to a subsample #' containing vectors with subsample indices for cross-validation. @@ -62,16 +62,13 @@ #' \item{\code{weights}}{An array, providing the weight #' assigned to each base learner (in chronological order) by the #' ensemble procedures.} -#' \item{\code{mspe}}{A matrix of per-learner MSPEs, with -#' rows for learners and columns for sample folds. -#' \code{NULL} when a single learner is used.} -#' \item{\code{r2}}{A matrix of per-learner out-of-sample -#' R-squared values. Same dimensions as \code{mspe}. -#' \code{NULL} when a single learner is used.} -#' \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{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{cf_fitted_bylearner}}{A matrix of out-of-sample @@ -210,10 +207,8 @@ crosspred <- function(y, X, 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) - r2 <- matrix(NA_real_, nlearners^(calc_ensemble), sample_folds) - colnames(mspe) <- colnames(r2) <- - paste("sample fold ", seq_len(sample_folds)) + mspe_inner <- matrix(0, nlearners^(calc_ensemble), sample_folds) + colnames(mspe_inner) <- paste("sample fold ", seq_len(sample_folds)) weights <- array(0, dim = c(nlearners, nensb, sample_folds)) cv_resid_byfold <- rep(list(NULL), sample_folds) @@ -221,8 +216,7 @@ crosspred <- function(y, X, k <- res$k cf_fitted[res$test_indices, ] <- res$cf_fitted_rows if (!is.null(res$weights_k)) weights[, , k] <- res$weights_k - if (!is.null(res$mspe_k)) mspe[, k] <- res$mspe_k - if (!is.null(res$r2_k)) r2[, k] <- res$r2_k + if (!is.null(res$mspe_k)) mspe_inner[, k] <- res$mspe_k cv_resid_byfold[[k]] <- res$cv_resid_byfold_k auxiliary_fitted[[k]] <- res$auxiliary_fitted_k cf_fitted_bylearner[res$test_indices, ] <- @@ -241,8 +235,14 @@ crosspred <- function(y, X, # Compute per-learner OOS residuals cf_resid_bylearner <- drop(y) - cf_fitted_bylearner + # Per-learner OOS mspe and r-squared (always available) + mspe <- colMeans(cf_resid_bylearner^2) + y_var <- as.numeric(stats::var(y)) + r2 <- if (y_var > 0) 1 - mspe / y_var else + rep(NA_real_, length(mspe)) + # Organize and return output - if (!calc_ensemble) weights <- mspe <- r2 <- cv_resid_byfold <- NULL + if (!calc_ensemble) weights <- cv_resid_byfold <- NULL output <- list(cf_fitted = cf_fitted, weights = weights, mspe = mspe, r2 = r2, cv_resid_byfold = cv_resid_byfold, diff --git a/R/crossval.R b/R/crossval.R index cae7d4b..78205d5 100644 --- a/R/crossval.R +++ b/R/crossval.R @@ -1,4 +1,4 @@ -#' Estimator of the Mean Squared Prediction Error using Cross-Validation. +#' Estimator of the Mean Squared Prediction Error Using Cross-Validation #' #' @family utilities #' diff --git a/R/cvc.R b/R/cvc.R deleted file mode 100644 index 3fa4082..0000000 --- a/R/cvc.R +++ /dev/null @@ -1,170 +0,0 @@ -# Pairwise cross-validation comparison test. -# -# Compares predictive ability of two learners using their -# OOS residuals. Uses multiplier bootstrap for inference, -# with fold-level demeaning to account for cross-fitting -# dependence. -# -# Reference: Lei J (2020). "Cross-Validation With Confidence." -# Journal of the American Statistical Association, -# 115(532), 1978-1997. -# -# @param resid1 Numeric vector of OOS residuals from learner 1. -# @param resid2 Numeric vector of OOS residuals from learner 2. -# @param fid Integer vector of fold IDs (same length as resid1). -# @param bootnum Number of bootstrap replications. -# -# @return P-value for H0: learner 1 has equal or larger MSPE -# than learner 2. Small p-value means learner 1 is better. -cvc_pairwise <- function(resid1, resid2, fid, - bootnum = 500) { - n <- length(resid1) - zeta <- resid1^2 - resid2^2 - - # Demean by fold to remove cross-fitting dependence - fid_unique <- unique(fid) - zeta_m <- numeric(n) - for (k in fid_unique) { - sel <- which(fid == k) - zeta_m[sel] <- mean(zeta[sel]) - }#FOR - zeta_til <- zeta - zeta_m - zeta_sd <- sqrt(stats::var(zeta_til)) - if (zeta_sd < .Machine$double.eps) return(NA_real_) - - Tx <- sqrt(n) * mean(zeta) / zeta_sd - - # Multiplier bootstrap (no model refitting) - zeta_scaled <- zeta_til / zeta_sd - Txb <- vapply(seq_len(bootnum), function(b) { - (1 / sqrt(n)) * sum(zeta_scaled * stats::rnorm(n)) - }, numeric(1)) - - mean(Txb > Tx) -}#CVC_PAIRWISE - -# 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. -# -# @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 = "/") - Txb <- vapply(seq_len(bootnum), function(b) { - bw <- stats::rnorm(n) - max(colSums(zeta_scaled * bw) / sqrt(n)) - }, numeric(1)) - - mean(Txb > Tx) -}#CVC_ONE_VS_MANY - -# Model confidence set via cross-validation comparison. -# -# For each learner, tests whether it is dominated by any -# other learner. Learners with large p-values form the -# model confidence set. -# -# @param resid_mat Matrix (n x nlearners) of OOS residuals. -# @param fid Integer vector of fold IDs. -# @param bootnum Number of bootstrap replications. -# @param alpha Significance level for the confidence set. -# -# @return List with: pvalues (numeric vector of p-values per -# learner), confidence_set (logical vector). -cvc_confidence_set <- function(resid_mat, fid, - bootnum = 500, - alpha = 0.05) { - nlearners <- ncol(resid_mat) - pvalues <- numeric(nlearners) - for (i in seq_len(nlearners)) { - pvalues[i] <- cvc_one_vs_many( - resid_mat[, i], resid_mat[, -i, drop = FALSE], - fid, bootnum) - }#FOR - list(pvalues = pvalues, - confidence_set = pvalues > alpha) -}#CVC_CONFIDENCE_SET - -# Main CVC entry point. -# -# Runs pairwise comparisons and the model confidence set -# procedure on a matrix of OOS residuals. -# -# @param cv_resid Matrix (n x nlearners) of OOS residuals. -# @param subsamples List of sample fold index vectors (used -# to derive fold IDs). -# @param bootnum Number of bootstrap replications. -# @param alpha Significance level for the confidence set. -# -# @return List with: pairwise (nlearners x nlearners matrix -# of p-values), confidence_set (logical vector), -# pvalues (numeric vector from confidence set procedure). -cvc_test <- function(cv_resid, subsamples, - bootnum = 500, alpha = 0.05) { - n <- nrow(cv_resid) - nlearners <- ncol(cv_resid) - - # Derive fold IDs from subsamples - fid <- integer(n) - for (k in seq_along(subsamples)) { - fid[subsamples[[k]]] <- k - }#FOR - - # Pairwise comparisons - pairwise <- matrix(NA_real_, nlearners, nlearners) - if (!is.null(colnames(cv_resid))) { - rownames(pairwise) <- colnames(pairwise) <- - colnames(cv_resid) - }#IF - for (i in seq_len(nlearners)) { - for (j in seq_len(nlearners)) { - if (i != j) { - pairwise[i, j] <- cvc_pairwise( - cv_resid[, i], cv_resid[, j], - fid, bootnum) - }#IF - }#FOR - }#FOR - - # Model confidence set - cs <- cvc_confidence_set(cv_resid, fid, bootnum, alpha) - - list(pairwise = pairwise, - pvalues = cs$pvalues, - confidence_set = cs$confidence_set) -}#CVC_TEST diff --git a/R/ddml-class.R b/R/ddml-class.R deleted file mode 100644 index d80c0d4..0000000 --- a/R/ddml-class.R +++ /dev/null @@ -1,229 +0,0 @@ -#' Common Output Structure for DDML Estimators -#' -#' @name ddml-class -#' -#' @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. -#' -#' @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, typically a vector of conditional expectation -#' functions. The score \eqn{m} is \emph{Neyman orthogonal}, -#' meaning the moment condition is locally insensitive to -#' perturbations of \eqn{\eta} around \eqn{\eta_0}. -#' -#' Each estimator in \code{ddml} uses a score that decomposes -#' linearly in \eqn{\theta}: -#' -#' \deqn{m(W_i; \theta, \eta) = \psi_b(W_i; \eta) + -#' \psi_a(W_i; \eta)\,\theta.} -#' -#' See the individual estimator pages for the specific forms -#' of \eqn{\psi_a} and \eqn{\psi_b}. -#' -#' 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.} -#' -#' For the linear scores used in \code{ddml}, this yields the -#' closed-form solution -#' -#' \deqn{\hat\theta = -\hat{J}^{-1}\,\hat\psi_b,} -#' -#' where \eqn{\hat\psi_b = n^{-1}\sum_{k}\sum_{i \in I_k} -#' \psi_b(W_i; \hat\eta_{-k})} and -#' \eqn{\hat{J} = n^{-1}\sum_k \sum_{i \in I_k} -#' \psi_a(W_i; \hat\eta_{-k})} is the sample Jacobian. -#' -#' Inference is based on the sandwich variance estimator -#' -#' \deqn{\hat\Sigma = \hat{J}^{-1} \left(\frac{1}{n} -#' \sum_i m_i m_i^\top\right) -#' \hat{J}^{-\top} / n} -#' -#' where \eqn{m_i = m(W_i; \hat\theta, \hat\eta_{-k(i)})}; -#' see \code{\link{vcov.ddml}} for HC0/HC1/HC3 variants. -#' Under regularity conditions and sufficient convergence of \eqn{\hat\eta}, -#' the DML estimator is asymptotically normal: -#' -#' \deqn{\sqrt{n}\,\hat\Sigma^{-1/2}(\hat\theta - \theta_0) -#' \overset{d}{\to} N(0, I).} -#' -#' Further details and regularity conditions are given in -#' Chernozhukov et al. (2018). -#' -#' @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. -#' -#' @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 per-learner MSPEs from -#' the cross-validation step in ensemble construction.} -#' \item{\code{r2}}{A named list of per-learner out-of-sample -#' R-squared values.} -#' \item{\code{psi_a}, \code{psi_b}}{Score component lists -#' (length \code{nensb}). \code{psi_a[[j]]} is an -#' \code{(n x p x p)} array and \code{psi_b[[j]]} is an -#' \code{(n x p)} matrix. Used internally by -#' \code{\link{hatvalues.ddml}}.} -#' \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.ddml}}, \code{\link{vcov.ddml}}, -#' \code{\link{confint.ddml}}, \code{\link{hatvalues.ddml}}, -#' \code{\link{nobs.ddml}}, \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 ... Deprecated arguments are still accepted for backward -#' compatibility but should be replaced with the \code{splits} -#' argument. See individual estimator pages for details. -#' -#' @family ddml estimators -NULL diff --git a/R/ddml-package.R b/R/ddml-package.R new file mode 100644 index 0000000..d8051dc --- /dev/null +++ b/R/ddml-package.R @@ -0,0 +1,15 @@ +#' ddml: Double/Debiased Machine Learning in R +#' +#' @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. +#' +#' @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. +#' +#' @keywords internal +"_PACKAGE" diff --git a/R/ddml.R b/R/ddml.R index d8051dc..a0f1375 100644 --- a/R/ddml.R +++ b/R/ddml.R @@ -1,15 +1,964 @@ -#' 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, typically a vector of conditional expectation +#' functions. The score \eqn{m} is \emph{Neyman orthogonal}, +#' meaning the moment condition is locally insensitive to +#' perturbations of \eqn{\eta} around \eqn{\eta_0}. +#' +#' Each estimator in \code{ddml} uses a score that decomposes +#' linearly in \eqn{\theta}: +#' +#' \deqn{m(W_i; \theta, \eta) = \psi_b(W_i; \eta) + \psi_a(W_i; \eta)\,\theta.} +#' +#' See the individual estimator pages for the specific forms +#' of \eqn{\psi_a} and \eqn{\psi_b}. +#' +#' 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.} +#' +#' For the linear scores used in \code{ddml}, this yields the +#' closed-form solution +#' +#' \deqn{\hat\theta = -\hat{J}^{-1}\,\hat\psi_b,} +#' +#' where \eqn{\hat\psi_b = n^{-1}\sum_{k}\sum_{i \in I_k} +#' \psi_b(W_i; \hat\eta_{-k})} and +#' \eqn{\hat{J} = n^{-1}\sum_k \sum_{i \in I_k} +#' \psi_a(W_i; \hat\eta_{-k})} is the sample Jacobian. +#' +#' Inference is based on the sandwich variance estimator +#' +#' \deqn{\hat\Sigma = \hat{J}^{-1} \left(\frac{1}{n} +#' \sum_i m_i m_i^\top\right) +#' \hat{J}^{-\top} / n} +#' +#' where \eqn{m_i = m(W_i; \hat\theta, \hat\eta_{-k(i)})}; +#' see \code{\link{vcov.ddml}} for HC0/HC1/HC3 variants. +#' Under regularity conditions and sufficient convergence of \eqn{\hat\eta}, +#' the DML estimator is asymptotically normal: +#' +#' \deqn{\sqrt{n}\,\hat\Sigma^{-1/2}(\hat\theta - \theta_0) +#' \overset{d}{\to} N(0, I).} +#' +#' Further details and regularity conditions are given in +#' Chernozhukov et al. (2018). #' #' @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{psi_a}, \code{psi_b}}{Score component lists +#' (length \code{nensb}). \code{psi_a[[j]]} is an +#' \code{(n x p x p)} array and \code{psi_b[[j]]} is an +#' \code{(n x p)} matrix. Used internally by +#' \code{\link{hatvalues.ddml}}.} +#' \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.ddml}}, \code{\link{vcov.ddml}}, +#' \code{\link{confint.ddml}}, \code{\link{hatvalues.ddml}}, +#' \code{\link{nobs.ddml}}, \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.ddml}}, +#' \code{\link{vcov.ddml}}, 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 psi_a A list of length \code{nensb}. Each element is an +#' \code{(n x p x p)} array of individual-level Jacobian +#' contributions. +#' @param psi_b A list of length \code{nensb}. Each element is an +#' \code{(n x p)} matrix of individual-level score +#' contributions. +#' @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 ... 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))) +#' coef <- matrix(theta, 1, 1, +#' dimnames = list("mean", "custom")) +#' +#' fit <- ddml(coefficients = coef, scores = scores, J = J, +#' psi_a = psi_a, psi_b = psi_b, +#' nobs = n, coef_names = "mean", +#' estimator_name = "Sample Mean") +#' summary(fit) +ddml <- function(coefficients, scores, J, + psi_a, psi_b, + 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, + ...) { + # 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.list(psi_a) || !is.list(psi_b)) { + stop("'psi_a' and 'psi_b' must be lists.", 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 (length(psi_a) != nensb || length(psi_b) != nensb) { + stop("'psi_a' and 'psi_b' must have length nensb.", + call. = FALSE) + }#IF + + # Assemble the object + obj <- c(list( + coefficients = coefficients, + ensemble_weights = ensemble_weights, + mspe = mspe, + r2 = r2, + psi_a = psi_a, psi_b = psi_b, + scores = scores, J = J, + coef_names = coef_names, + estimator_name = estimator_name, + ensemble_type = ensemble_type, + nobs = nobs, + 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") else "ddml" + class(obj) <- cls + obj +}#DDML + +# == S3 Methods ============================================================= + +#' @rdname ddml +#' @param x An object of class \code{ddml}. +#' @param name Name of the element to extract. +#' @export +`$.ddml` <- function(x, name) { + if (name == "weights") { + message("Note: '$weights' is deprecated for ddml ", + "objects. Use '$ensemble_weights' instead.") + return(.subset2(x, "ensemble_weights")) + }#IF + .subset2(x, name) +}#`$.DDML` + +#' Extract Model Coefficients +#' +#' @description Extracts the estimated coefficients +#' from a DDML model for the specified or default +#' ensemble type. +#' +#' @param object An object of class \code{ddml}. +#' @param ... Currently unused. +#' +#' @return Named vector (single ensemble) or matrix +#' (multiple ensembles). +#' +#' @examples +#' \donttest{ +#' # Fit a PLM and extract coefficients +#' 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) +#' coef(plm_fit) +#' } +#' +#' @family ddml inference +#' @method coef ddml +#' @export +coef.ddml <- 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.DDML + +#' Extract Number of Observations +#' +#' @description Returns the number of observations +#' used to fit the DDML model. +#' +#' @param object An object of class \code{ddml}. +#' @param ... Currently unused. +#' +#' @return An integer specifying the number of observations. +#' +#' @method nobs ddml +#' @importFrom stats nobs +#' @export +nobs.ddml <- function(object, ...) { + object$nobs +}#NOBS.DDML + +#' Extract Generalized Leverage (Hat Values) +#' +#' @description Computes the generalized leverage (hat values) for a DDML +#' estimator. These values are used internally to compute +#' heteroskedasticity-robust HC3 standard errors. #' +#' @details See \code{\link{ddml-intro}} for the DML framework and +#' the definition of \eqn{\psi_a} and \eqn{\hat{J}}. +#' For the linear scores used in \code{ddml}, +#' the generalized leverage simplifies to +#' +#' \eqn{h_{ii} = \mathrm{tr}(\psi_a(W_i; +#' \hat\eta)\,(n\hat{J})^{-1}).} +#' +#' @param model An object of class \code{ddml}. +#' @param ensemble_idx Integer index of the ensemble type to extract leverage +#' values for. Defaults to 1. +#' @param ... Currently unused. +#' +#' @return A numeric vector of generalized leverage values. +#' +#' @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) +#' h = hatvalues(plm_fit) +#' head(h) +#' } +#' +#' @seealso \code{\link{vcov.ddml}} for the use of leverage in HC3 standard errors. +#' +#' @family ddml inference +#' @importFrom stats hatvalues +#' @export +hatvalues.ddml <- function(model, ensemble_idx = 1, ...) { + validate_method_args(model, ensemble_idx = ensemble_idx) + psi_a_j <- model$psi_a[[ensemble_idx]] + J_j <- model$J[, , ensemble_idx, drop = FALSE] + dim(J_j) <- dim(J_j)[1:2] + J_inv <- csolve(J_j) + p <- ncol(J_j) + n <- model$nobs + dim(psi_a_j) <- c(n, p * p) + as.vector((psi_a_j %*% as.vector(t(J_inv))) / n) +}#HATVALUES.DDML + +#' Variance-Covariance Matrix for DDML Estimators +#' +#' @description Computes a heteroskedasticity-robust +#' variance-covariance matrix for the DDML estimator +#' \eqn{\hat\theta}. +#' +#' @details See \code{\link{ddml-intro}} for the DML framework, +#' including the definitions of the score \eqn{m_i}, +#' the Jacobian \eqn{\hat{J}}, and the base sandwich +#' estimator \eqn{\hat\Sigma}. This function provides +#' three variants: +#' +#' \strong{HC0}: +#' \deqn{V_{\mathrm{HC0}} = \hat{J}^{-1} +#' \left(\frac{1}{n}\sum_i m_i m_i'\right) +#' \hat{J}^{-\top} / n} +#' +#' \strong{HC1} (default): +#' \deqn{V_{\mathrm{HC1}} = V_{\mathrm{HC0}} +#' \times \frac{n}{n - p}} +#' +#' where \eqn{p} is the dimension of \eqn{\theta}. +#' +#' \strong{HC3}: +#' \deqn{V_{\mathrm{HC3}} = \hat{J}^{-1} +#' \left(\frac{1}{n}\sum_i +#' \frac{m_i m_i'}{(1 - h_{ii})^2}\right) +#' \hat{J}^{-\top} / n} +#' +#' where \eqn{h_{ii}} is the generalized leverage; +#' see \code{\link{hatvalues.ddml}}. +#' +#' @param object An object of class \code{ddml}. +#' @param ensemble_idx Integer index of the ensemble type to +#' use. Defaults to 1 (first ensemble type). +#' @param type Character string specifying the +#' variance-covariance estimator. 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. +#' +#' @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) +#' vcov(plm_fit) +#' vcov(plm_fit, type = "HC3") +#' } +#' +#' @seealso \code{\link{hatvalues.ddml}}, +#' \code{\link{confint.ddml}}, +#' \code{\link{summary.ddml}} +#' +#' @family ddml inference +#' @method vcov ddml +#' @export +vcov.ddml <- function(object, ensemble_idx = 1, + type = "HC1", ...) { + type <- validate_method_args(object, + ensemble_idx = ensemble_idx, type = type) + + h <- if (type == "HC3") { + stats::hatvalues(object, ensemble_idx = ensemble_idx) + }#IF + + sc <- object$scores[, , ensemble_idx, drop = FALSE] + dim(sc) <- dim(sc)[1:2] + J_j <- object$J[, , ensemble_idx, drop = FALSE] + dim(J_j) <- dim(J_j)[1:2] + p <- ncol(sc) + + # Cluster aggregation: rowsum scores to cluster level + clustered <- !is.null(object$cluster_variable) && + length(unique(object$cluster_variable)) < nrow(sc) + if (clustered) { + sc <- rowsum(sc, object$cluster_variable) + }#IF + + n_eff <- nrow(sc) + + if (type == "HC3") { + if (clustered) { + h <- as.vector(tapply(h, object$cluster_variable, sum)) + }#IF + sc <- sc / (1 - h) + }#IF + + meat <- crossprod(sc) / n_eff + J_inv <- csolve(J_j) + V <- J_inv %*% meat %*% t(J_inv) / n_eff + + # HC1 degrees-of-freedom correction + if (type == "HC1") { + V <- V * n_eff / (n_eff - p) + }#IF + + rownames(V) <- colnames(V) <- object$coef_names + V +}#VCOV.DDML + +#' Confidence Intervals for DDML Estimators +#' +#' @description Computes confidence intervals for one or more +#' parameters in a fitted DDML model. +#' +#' @param object An object of class \code{ddml}. +#' @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. +#' @inheritParams vcov.ddml +#' @param ... Currently unused. +#' +#' @return A matrix with columns for lower and upper bounds. +#' +#' @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) +#' confint(plm_fit) +#' confint(plm_fit, parm = "D1") +#' confint(plm_fit, level = 0.90) +#' } +#' +#' @seealso \code{\link{vcov.ddml}} +#' +#' @family ddml inference +#' @method confint ddml +#' @importFrom stats vcov +#' @export +confint.ddml <- function(object, parm, level = 0.95, + ensemble_idx = 1, + type = "HC1", ...) { + cf <- object$coefficients[, ensemble_idx] + cf_names <- object$coef_names + + if (missing(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, ensemble_idx = ensemble_idx, + type = type) + se <- sqrt(diag(V))[parm] + + z <- stats::qnorm((1 + level) / 2) + 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 + ci +}#CONFINT.DDML + +#' 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.ddml}} for the HC0/HC1/HC3 formulas. +#' +#' @param object An object of class \code{ddml}. +#' @inheritParams vcov.ddml +#' @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.ddml}} +#' +#' @family ddml inference +#' @method summary ddml +#' @export +summary.ddml <- function(object, type = "HC1", ...) { + type <- match.arg(type, c("HC0", "HC1", "HC3")) + + single_learner <- is_single_learner(object$learners) + ens_type <- if (single_learner) { + "single base learner" + } else { + object$ensemble_type + }#IFELSE + + nensb <- length(ens_type) + p <- nrow(object$coefficients) + + inf <- array(0, dim = c(p, 4, nensb)) + + for (j in seq_len(nensb)) { + theta_j <- object$coefficients[, j] + + V <- stats::vcov(object, ensemble_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|)"), + ens_type + ) + + result <- list( + coefficients = inf, + type = type, + model_type = class(object)[1], + estimator_name = object$estimator_name, + nobs = object$nobs, + sample_folds = object$sample_folds, + shortstack = object$shortstack, + 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") + + nensb <- dim(x$coefficients)[3] + for (j in seq_len(nensb)) { + if (nensb > 1) { + cat("Ensemble type:", + dimnames(x$coefficients)[[3]][j], "\n") + }#IF + tbl <- x$coefficients[, , j] + if (!is.matrix(tbl)) { + tbl <- matrix(tbl, nrow = 1, + dimnames = list( + dimnames(x$coefficients)[[1]], + dimnames(x$coefficients)[[2]])) + }#IF + stats::printCoefmat(tbl, digits = digits, + has.Pvalue = TRUE, + signif.stars = TRUE) + if (j < nensb) cat("\n") + }#FOR + + invisible(x) +}#PRINT.SUMMARY.DDML + +#' @importFrom generics tidy +#' @export +generics::tidy + +#' @importFrom generics glance +#' @export +generics::glance + +#' Tidy a ddml Object +#' +#' Extracts coefficient estimates, standard errors, test +#' statistics, and p-values from a \code{ddml} estimator in a +#' format compatible with \pkg{modelsummary} and the +#' \pkg{broom} ecosystem. +#' +#' @param x A \code{ddml} object. +#' @param ensemble_idx Integer index of the ensemble type to +#' report. Defaults to 1 (first ensemble type). Set to +#' \code{NULL} to return results for all ensemble types. +#' @param conf.int Logical. Include confidence interval +#' columns? Default \code{FALSE}. +#' @param conf.level Confidence level for intervals. +#' Default 0.95. +#' @param type Character string specifying the +#' variance-covariance estimator. One of \code{"HC1"} +#' (default), \code{"HC0"}, or \code{"HC3"}. +#' @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}. If +#' \code{conf.int = TRUE}, also \code{conf.low} and +#' \code{conf.high}. +#' +#' @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", ...) { + type <- match.arg(type, c("HC1", "HC0", "HC3")) + + s <- summary(x, type = type) + inf <- s$coefficients + nensb <- dim(inf)[3] + p <- dim(inf)[1] + + if (is.null(ensemble_idx)) { + j_seq <- seq_len(nensb) + } else { + if (any(ensemble_idx < 1) || any(ensemble_idx > nensb)) { + stop(sprintf("ensemble_idx must be between 1 and %d", nensb), + call. = FALSE) + }#IF + j_seq <- ensemble_idx + }#IFELSE + + # Pre-allocate rows + n_rows <- length(j_seq) * p + term <- rep(dimnames(inf)[[1]], length(j_seq)) + ensemble_type <- rep(dimnames(inf)[[3]][j_seq], each = p) + + estimate <- numeric(n_rows) + std.error <- numeric(n_rows) + statistic <- numeric(n_rows) + 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, + ensemble_type = ensemble_type, + stringsAsFactors = FALSE + ) + + if (conf.int) { + z <- stats::qnorm((1 + conf.level) / 2) + res$conf.low <- res$estimate - z * res$std.error + res$conf.high <- res$estimate + z * res$std.error + }#IF + + res +}#TIDY.DDML + +#' Glance at a ddml Object +#' +#' Returns a one-row summary of model-level statistics, +#' compatible with \pkg{modelsummary} and the \pkg{broom} +#' ecosystem. +#' +#' @param x A \code{ddml} object. +#' @param ... Currently unused. +#' +#' @return A one-row \code{data.frame} with columns +#' \code{nobs}, \code{sample_folds}, \code{shortstack}, +#' \code{ensemble_type}, 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) +#' } +#' +#' @seealso \code{\link{tidy.ddml}}, +#' \code{\link{summary.ddml}} +#' +#' @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 diff --git a/R/ddml_apo.R b/R/ddml_apo.R index 855d7d4..e26de80 100644 --- a/R/ddml_apo.R +++ b/R/ddml_apo.R @@ -1,80 +1,80 @@ -#' Estimator for the Average Potential Outcome. +#' Estimator for the Average Potential Outcome #' #' @family ddml estimators #' -#' @description \code{ddml_apo} provides a Double/Debiased Machine Learning -#' estimator for the average potential outcome, allowing for custom -#' weights \eqn{\omega(X)}. +#' @description Estimator for the average potential outcome, allowing for +#' custom weights \eqn{\omega(X)}. #' -#' @details \code{ddml_apo} provides a Double/Debiased Machine Learning -#' estimator for the target parameter \eqn{\theta_0} in the model given by +#' @details +#' \strong{Parameter of Interest:} \code{ddml_apo} provides a Double/Debiased Machine Learning +#' estimator for the target parameter \eqn{\theta_0} in the model given by: #' -#' \eqn{Y = g_0(D, X) + U,} +#' \deqn{Y = g_0(D, X) + U,} #' #' where \eqn{(Y, D, X, U)} is a random vector such that #' \eqn{E[U\vert D, X] = 0} and #' \eqn{\Pr(D=d\vert X) \in (0, 1)} with probability 1, #' and \eqn{g_0} is an unknown nuisance function. #' -#' In this model, the average potential outcome (APO) for treatment +#' In this model, the average potential outcome (APO) for treatment #' level \eqn{d} is defined as #' -#' \eqn{\theta_0^{\textrm{APO}} \equiv E[\omega(X) g_0(d, X)]}, +#' \deqn{\theta_0^{\textrm{APO}} \equiv E[\omega(X) g_0(d, X)],} #' #' where \eqn{\omega(X)} is a known weighting function. If \eqn{\omega(X) = 1}, #' this parameter corresponds to the standard Average Potential Outcome (APO) #' at treatment level \eqn{d}. #' -#' The estimating equation is -#' \eqn{E[m(W; \theta_0, \eta_0)] = 0}, where -#' \eqn{W = (Y, D, X)}, and the Neyman orthogonal score is +#' \strong{Nuisance Parameters:} The nuisance parameters are +#' \eqn{\eta = (\ell, p)} taking true values \eqn{\ell_0(X) = E[Y|D=d, X]} and +#' \eqn{p_0(X) = E[\mathbf{1}\{D=d\}|X]}. #' -#' \eqn{m(W; \theta, \eta) = \left( \frac{\mathbbm{1}\{D=d\} (Y - \ell(X))}{p(X)} + \ell(X) \right) \omega(X) - \theta} +#' \strong{Neyman Orthogonal Score / Moment Equation:} The Neyman orthogonal score is: #' -#' with nuisance parameters \eqn{\eta = (\ell, p)} taking -#' true values \eqn{\ell_0(X) = E[Y|D=d, X]} and \eqn{p_0(X) = E[\mathbbm{1}\{D=d\}|X]}. +#' \deqn{m(W; \theta, \eta) = \left( \frac{\mathbf{1}\{D=d\} (Y - \ell(X))}{p(X)} + \ell(X) \right) \omega(X) - \theta} #' -#' @inheritParams ddml-class +#' \strong{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: +#' +#' \deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} +#' +#' where: +#' +#' \deqn{\psi_a(W; \eta) = -1} +#' +#' \deqn{\psi_b(W; \eta) = \left( \frac{\mathbf{1}\{D=d\} (Y - \ell(X))}{p(X)} + \ell(X) \right) \omega(X)} +#' +#' @inheritParams ddml-intro #' @inheritParams ddml_plm -#' @inheritParams ddml_ate #' @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 +#' \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 ... Deprecated arguments (\code{subsamples_byd}, -#' \code{cv_subsamples_byd}) are still accepted for backward -#' compatibility but should be replaced with the \code{splits} -#' argument. +#' @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-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}. #' -#' @seealso [ddml::summary.ddml()], [ddml::coef.ddml()], -#' [ddml::vcov.ddml()], [ddml::confint.ddml()], -#' [ddml::hatvalues.ddml()], [ddml::tidy.ddml()], -#' [ddml::glance.ddml()], [ddml::diagnostics()] -#' #' @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. -#' #' @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. +#' # 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, @@ -129,17 +129,14 @@ ddml_apo <- function(y, D, X, if (is.null(weights)) weights <- rep(1, nobs) # Construct sample splits for cross-fitting and cross-validation - splits <- normalize_splits(splits = splits, by_label = "d", ...) validate_fitted_splits_pair(fitted, splits, !shortstack) indxs <- get_sample_splits( cluster_variable = cluster_variable, sample_folds = sample_folds, cv_folds = cv_folds, D = D_ind, stratify = stratify, - subsamples = splits$subsamples, - subsamples_byD = splits$subsamples_byd, - cv_subsamples = splits$cv_subsamples, - cv_subsamples_byD = splits$cv_subsamples_byd) + subsamples = splits$D_X$subsamples, + cv_subsamples = splits$D_X$cv_subsamples) check_subsamples(indxs$subsamples, indxs$subsamples_byD, stratify, D_ind) @@ -235,7 +232,13 @@ ddml_apo <- function(y, D, X, # == Output ======================================================= - ddml_fit <- list( + elapsed <- round(proc.time()[3] - t0, 1) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) + }#IF + + ddml( coefficients = coef, ensemble_weights = list(y_X = y_X_res$weights, D_X = D_X_res$weights), @@ -252,29 +255,24 @@ ddml_apo <- function(y, D, X, sample_folds = sample_folds, cv_folds = if (shortstack) NULL else cv_folds, shortstack = shortstack, - d = d, - weights = weights, - learners = learners, - learners_DX = learners_DX, 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( - subsamples = indxs$subsamples, - subsamples_byd = indxs$subsamples_byD, - cv_subsamples = indxs$cv_subsamples, - cv_subsamples_byd = indxs$cv_subsamples_byD), - call = cl) - - elapsed <- round(proc.time()[3] - t0, 1) - if (!is.null(messages$finish) && messages$finish != "") { - info_msg(sprintf(messages$finish, elapsed), - silent = silent) - }#IF - - class(ddml_fit) <- c("ddml_apo", "ddml") - return(ddml_fit) + 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", + 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 43d3b34..3b861fe 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -1,16 +1,17 @@ -#' Estimators of Average Treatment Effects. +#' Estimator for the Average Treatment Effect #' #' @family ddml estimators #' -#' @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 +#' @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, in the interactive model -#' given by +#' given by: #' -#' \eqn{Y = g_0(D, X) + U,} +#' \deqn{Y = g_0(D, X) + U,} #' #' 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 @@ -19,59 +20,51 @@ #' #' In this model, the average treatment effect (ATE) is defined as #' -#' \eqn{\theta_0^{\textrm{ATE}} \equiv E[g_0(1, X) - g_0(0, X)]}, +#' \deqn{\theta_0^{\textrm{ATE}} \equiv E[g_0(1, X) - g_0(0, X)],} #' #' and the average treatment effect on the treated (ATT) is defined as #' -#' \eqn{\theta_0^{\textrm{ATT}} \equiv E[g_0(1, X) - g_0(0, X)\vert D = 1]}. +#' \deqn{\theta_0^{\textrm{ATT}} \equiv E[g_0(1, X) - g_0(0, X)\vert D = 1].} #' -#' The estimating equations are -#' \eqn{E[m(W; \theta_0, \eta_0)] = 0}, where -#' \eqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta}, -#' \eqn{W = (Y, D, X)}, and the Neyman orthogonal scores are +#' \strong{Neyman Orthogonal Score:} The Neyman orthogonal scores are: #' -#' \eqn{\psi_b^{\textrm{ATE}}(W; \eta) = \frac{D(Y - \ell_1(X))}{m(X)} - \frac{(1-D)(Y-\ell_0(X))}{1-m(X)} + \ell_1(X) - \ell_0(X)} +#' \deqn{m^{\textrm{ATE}}(W; \theta, \eta) = \frac{D(Y - \ell_1(X))}{p(X)} - \frac{(1-D)(Y-\ell_0(X))}{1-p(X)} + \ell_1(X) - \ell_0(X) - \theta} #' -#' \eqn{\psi_a^{\textrm{ATE}}(W; \eta) = -1} +#' \deqn{m^{\textrm{ATT}}(W; \theta, \eta) = \frac{D(Y - \ell_0(X))}{\pi} - \frac{p(X)(1-D)(Y-\ell_0(X))}{\pi(1-p(X))} - \frac{D\theta}{\pi}} #' -#' \eqn{\psi_b^{\textrm{ATT}}(W; \eta) = \frac{D(Y - \ell_0(X))}{p} - \frac{m(X)(1-D)(Y-\ell_0(X))}{p(1-m(X))}} +#' where the nuisance parameters are \eqn{\eta = (\ell_0, \ell_1, p, \pi)} taking true values +#' \eqn{\ell_{d,0}(X) = E[Y|D=d, X]}, \eqn{p_0(X) = E[D|X]}, and \eqn{\pi_0 = E[D]}. #' -#' \eqn{\psi_a^{\textrm{ATT}}(W; \eta) = -\frac{D}{p}} +#' \strong{Linear Decomposition:} The scores decompose linearly in \eqn{\theta}: #' -#' with nuisance parameters \eqn{\eta = (\ell_0, \ell_1, m, p)} taking -#' true values \eqn{\ell_{d,0}(X) = E[Y|D=d, X]}, \eqn{m_0(X) = E[D|X]}, -#' and \eqn{p_0 = E[D]}. +#' \deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} #' -#' @inheritParams ddml-class -#' @inheritParams ddml_plm +#' where: +#' +#' \deqn{\psi_a^{\textrm{ATE}}(W; \eta) = -1} +#' +#' \deqn{\psi_b^{\textrm{ATE}}(W; \eta) = \frac{D(Y - \ell_1(X))}{p(X)} - \frac{(1-D)(Y-\ell_0(X))}{1-p(X)} + \ell_1(X) - \ell_0(X)} +#' +#' \deqn{\psi_a^{\textrm{ATT}}(W; \eta) = -\frac{D}{\pi}} +#' +#' \deqn{\psi_b^{\textrm{ATT}}(W; \eta) = \frac{D(Y - \ell_0(X))}{\pi} - \frac{p(X)(1-D)(Y-\ell_0(X))}{\pi(1-p(X))}} +#' +#' @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 ... Deprecated arguments (\code{subsamples}, -#' \code{subsamples_byD}, \code{cv_subsamples}, -#' \code{cv_subsamples_byD}) are still accepted for backward -#' compatibility but should be replaced with \code{splits}. -#' @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 ... 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-class}} for the common output structure. +#' \code{\link{ddml-intro}} for the common output structure. #' Additional pass-through fields: \code{learners}, #' \code{learners_DX}. #' @export #' -#' @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. -#' #' @examples #' # Construct variables from the included Angrist & Evans (1998) data #' y = AE98[, "worked"] @@ -141,7 +134,6 @@ ddml_ate <- function(y, D, X, nobs <- length(y) - splits <- normalize_splits(splits = splits, by_label = "D", ...) validate_fitted_splits_pair(fitted, splits, !shortstack) indxs <- get_sample_splits( @@ -149,10 +141,14 @@ ddml_ate <- function(y, D, X, sample_folds = sample_folds, cv_folds = cv_folds, D = D, stratify = stratify, - subsamples = splits$subsamples, - subsamples_byD = splits$subsamples_byD, - cv_subsamples = splits$cv_subsamples, - cv_subsamples_byD = splits$cv_subsamples_byD) + 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) @@ -183,21 +179,16 @@ ddml_ate <- function(y, D, X, parallel = parallel, fitted = fitted$D_X) - # Splits for apo(d=1): byD indices match D_ind = D + shared_splits <- list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples) apo_splits_1 <- list( - subsamples = indxs$subsamples, - subsamples_byd = indxs$subsamples_byD, - cv_subsamples = indxs$cv_subsamples, - cv_subsamples_byd = indxs$cv_subsamples_byD) - # Splits for apo(d=0): swap byD indices since D_ind = 1-D + y_X = list(subsamples = indxs$subsamples_byD[[2]], + cv_subsamples = indxs$cv_subsamples_byD[[2]]), + D_X = shared_splits) apo_splits_0 <- list( - subsamples = indxs$subsamples, - subsamples_byd = list(indxs$subsamples_byD[[2]], - indxs$subsamples_byD[[1]]), - cv_subsamples = indxs$cv_subsamples, - cv_subsamples_byd = if (!is.null(indxs$cv_subsamples_byD)) - list(indxs$cv_subsamples_byD[[2]], - indxs$cv_subsamples_byD[[1]])) + y_X = list(subsamples = indxs$subsamples_byD[[1]], + cv_subsamples = indxs$cv_subsamples_byD[[1]]), + D_X = shared_splits) # Pre-ensembled propensity for ddml_apo delegation. # For d=0, flip: P(D=0|X) = 1 - P(D=1|X). @@ -263,7 +254,13 @@ ddml_ate <- function(y, D, X, # == Output ======================================================= - ddml_fit <- list( + elapsed <- round(proc.time()[3] - t0, 1) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) + }#IF + + ddml( coefficients = coef, ensemble_weights = list( y_X_D0 = apo_0$ensemble_weights$y_X, @@ -284,26 +281,24 @@ ddml_ate <- function(y, D, X, sample_folds = sample_folds, cv_folds = if (shortstack) NULL else cv_folds, shortstack = shortstack, - learners = learners, - learners_DX = learners_DX, cluster_variable = cluster_variable, fitted = list( y_X_D0 = apo_0$fitted$y_X, y_X_D1 = apo_1$fitted$y_X, D_X = build_fitted_entry(D_X_res, save_crossval)), splits = list( - subsamples = indxs$subsamples, - subsamples_byD = indxs$subsamples_byD, - cv_subsamples = indxs$cv_subsamples, - cv_subsamples_byD = indxs$cv_subsamples_byD), - call = cl) - - elapsed <- round(proc.time()[3] - t0, 1) - if (!is.null(messages$finish) && messages$finish != "") { - info_msg(sprintf(messages$finish, elapsed), - silent = silent) - }#IF - - class(ddml_fit) <- c("ddml_ate", "ddml") - return(ddml_fit) + 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", + learners = learners, + learners_DX = learners_DX + ) }#DDML_ATE diff --git a/R/ddml_att.R b/R/ddml_att.R index bbcd915..3c1fb34 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -40,7 +40,6 @@ ddml_att <- function(y, D, X, nobs <- length(y) - splits <- normalize_splits(splits = splits, by_label = "D", ...) validate_fitted_splits_pair(fitted, splits, !shortstack) indxs <- get_sample_splits( @@ -48,10 +47,14 @@ ddml_att <- function(y, D, X, sample_folds = sample_folds, cv_folds = cv_folds, D = D, stratify = stratify, - subsamples = splits$subsamples, - subsamples_byD = splits$subsamples_byD, - cv_subsamples = splits$cv_subsamples, - cv_subsamples_byD = splits$cv_subsamples_byD) + 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) @@ -84,14 +87,12 @@ ddml_att <- function(y, D, X, # E[Y|D=0,X] via ddml_apo(d=0) # Swap byD indices: apo uses D_ind = 1*(D==0), so byD # levels are reversed relative to the ATT's D. + shared_splits <- list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples) apo_splits_0 <- list( - subsamples = indxs$subsamples, - subsamples_byd = list(indxs$subsamples_byD[[2]], - indxs$subsamples_byD[[1]]), - cv_subsamples = indxs$cv_subsamples, - cv_subsamples_byd = if (!is.null(indxs$cv_subsamples_byD)) - list(indxs$cv_subsamples_byD[[2]], - indxs$cv_subsamples_byD[[1]])) + y_X = list(subsamples = indxs$subsamples_byD[[1]], + cv_subsamples = indxs$cv_subsamples_byD[[1]]), + D_X = shared_splits) # Pre-ensembled propensity: P(D=0|X) = 1 - E[D|X] fitted_D_X_0 <- list( @@ -158,7 +159,13 @@ ddml_att <- function(y, D, X, # == Output ======================================================= - ddml_fit <- list( + elapsed <- round(proc.time()[3] - t0, 1) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) + }#IF + + ddml( coefficients = coef, ensemble_weights = list( y_X_D0 = apo_0$ensemble_weights$y_X, @@ -177,25 +184,23 @@ ddml_att <- function(y, D, X, sample_folds = sample_folds, cv_folds = if (shortstack) NULL else cv_folds, shortstack = shortstack, - learners = learners, - learners_DX = learners_DX, cluster_variable = cluster_variable, fitted = list( y_X_D0 = apo_0$fitted$y_X, D_X = build_fitted_entry(D_X_res, save_crossval)), splits = list( - subsamples = indxs$subsamples, - subsamples_byD = indxs$subsamples_byD, - cv_subsamples = indxs$cv_subsamples, - cv_subsamples_byD = indxs$cv_subsamples_byD), - call = cl) - - elapsed <- round(proc.time()[3] - t0, 1) - if (!is.null(messages$finish) && messages$finish != "") { - info_msg(sprintf(messages$finish, elapsed), - silent = silent) - }#IF - - class(ddml_fit) <- c("ddml_att", "ddml") - return(ddml_fit) + 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_att", + learners = learners, + learners_DX = learners_DX + ) }#DDML_ATT diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index 1574d19..9941435 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -1,36 +1,41 @@ -#' Estimator for the Flexible Partially Linear IV Model. +#' Estimator for the Flexible Partially Linear IV Coefficient #' #' @family ddml estimators #' -#' @seealso [AER::ivreg()] +#' @description Estimator for the flexible partially linear IV coefficient. #' -#' @description Estimator for the flexible partially linear IV model. -#' -#' @details \code{ddml_fpliv} provides a Double/Debiased Machine Learning +#' @details +#' \strong{Parameter of Interest:} \code{ddml_fpliv} provides a Double/Debiased Machine Learning #' estimator for the target parameter \eqn{\theta_0} in the partially -#' linear IV model given by +#' linear IV model given by: #' -#' \eqn{Y = \theta_0D + g_0(X) + U,} +#' \deqn{Y = \theta_0 D + g_0(X) + U,} #' #' 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. #' -#' In this model, the target parameter \eqn{\theta_0} is identified by the -#' estimating equation -#' \eqn{E[m(W; \theta_0, \eta_0)] = 0}, where \eqn{W = (Y, D, Z, X)} and -#' \eqn{m(W; \theta, \eta)} is the Neyman orthogonal score +#' \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{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: #' -#' \eqn{m(W; \theta, \eta) = (Y - \ell(X) - \theta(D - r(X)))(v(X, Z) - r(X)),} +#' \deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} #' -#' with nuisance parameters \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]}. +#' where: #' -#' @inheritParams ddml-class +#' \deqn{\psi_a(W; \eta) = -(D - r(X))(v(X, Z) - r(X))^\top} +#' +#' \deqn{\psi_b(W; \eta) = (v(X, Z) - r(X))(Y - \ell(X))} +#' +#' @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 @@ -42,21 +47,11 @@ #' #' @return \code{ddml_fpliv} returns an object of S3 class #' \code{ddml_fpliv} and \code{ddml}. See -#' \code{\link{ddml-class}} for the common output structure. +#' \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"] @@ -64,7 +59,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)), @@ -113,15 +108,14 @@ ddml_fpliv <- function(y, D, Z, X, D <- as.matrix(D) nD <- ncol(D) - splits <- normalize_splits(splits = splits, ...) validate_fitted_splits_pair(fitted, splits, !shortstack) indxs <- get_sample_splits( cluster_variable = cluster_variable, sample_folds = sample_folds, cv_folds = cv_folds, - subsamples = splits$subsamples, - cv_subsamples = splits$cv_subsamples) + subsamples = splits[[1]]$subsamples, + cv_subsamples = splits[[1]]$cv_subsamples) check_subsamples(indxs$subsamples, NULL, stratify = FALSE) t0 <- proc.time()[3] @@ -252,8 +246,10 @@ ddml_fpliv <- function(y, D, Z, X, mspe <- list(y_X = y_X_res$mspe) r2 <- list(y_X = y_X_res$r2) for (k in seq_len(nD)) { - ensemble_weights[[paste0("D", k, "_X")]] <- - D_X_res_list[[k]]$weights + 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 seq_len(nD)) { eq <- paste0("D", k, "_XZ") @@ -262,7 +258,13 @@ ddml_fpliv <- function(y, D, Z, X, r2[[eq]] <- D_XZ_res_list[[k]]$r2 }#FOR - ddml_fit <- list( + elapsed <- round(proc.time()[3] - t0, 1) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) + }#IF + + ddml( coefficients = coef, ensemble_weights = ensemble_weights, mspe = mspe, @@ -276,9 +278,6 @@ ddml_fpliv <- function(y, D, Z, X, sample_folds = sample_folds, cv_folds = if (shortstack) NULL else cv_folds, shortstack = shortstack, - learners = learners, - learners_DXZ = learners_DXZ, - learners_DX = learners_DX, cluster_variable = cluster_variable, fitted = list( y_X = build_fitted_entry(y_X_res, save_crossval), @@ -286,16 +285,15 @@ ddml_fpliv <- function(y, D, Z, X, save_crossval), D_X = build_fitted_from_list(D_X_res_list, save_crossval)), - splits = list(subsamples = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples), - call = cl) - - elapsed <- round(proc.time()[3] - t0, 1) - if (!is.null(messages$finish) && messages$finish != "") { - info_msg(sprintf(messages$finish, elapsed), - silent = silent) - }#IF - - class(ddml_fit) <- c("ddml_fpliv", "ddml") - return(ddml_fit) + splits = setNames( + rep(list(list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples)), + length(ensemble_weights)), + names(ensemble_weights)), + call = cl, + subclass = "ddml_fpliv", + learners = learners, + learners_DXZ = learners_DXZ, + learners_DX = learners_DX + ) }#DDML_FPLIV diff --git a/R/ddml_late.R b/R/ddml_late.R index 7fac176..d78f077 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -1,14 +1,15 @@ -#' Estimator of the Local Average Treatment Effect. +#' Estimator for the Local Average Treatment Effect #' #' @family ddml estimators #' -#' @description Estimator of the local average treatment effect. +#' @description Estimator for the local average treatment effect. #' -#' @details \code{ddml_late} provides a Double/Debiased Machine Learning +#' @details +#' \strong{Parameter of Interest:} \code{ddml_late} provides a Double/Debiased Machine Learning #' estimator for the local average treatment effect in the interactive model -#' given by +#' given by: #' -#' \eqn{Y = g_0(D, X) + U,} +#' \deqn{Y = g_0(D, X) + U,} #' #' where \eqn{(Y, D, X, Z, U)} is a random vector such that #' \eqn{\operatorname{supp} D = \operatorname{supp} Z = \{0,1\}}, @@ -20,27 +21,32 @@ #' #' In this model, the local average treatment effect (LATE) is defined as #' -#' \eqn{\theta_0^{\textrm{LATE}} \equiv -#' E[g_0(1, X) - g_0(0, X)\vert p_0(1, X) > p_0(0, X)]}. +#' \deqn{\theta_0^{\textrm{LATE}} \equiv E[g_0(1, X) - g_0(0, X)\vert p_0(1, X) > p_0(0, X)].} #' -#' The estimating equation is -#' \eqn{E[m(W; \theta_0, \eta_0)] = 0}, where -#' \eqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta}, -#' \eqn{W = (Y, D, Z, X)}, and the Neyman orthogonal scores are +#' \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) = E[Z|X]}. #' -#' \eqn{\psi_b(W; \eta) = \frac{Z(Y - \ell_1(X))}{m(X)} - \frac{(1-Z)(Y-\ell_0(X))}{1-m(X)} + \ell_1(X) - \ell_0(X)} +#' \strong{Neyman Orthogonal Score / Moment Equation:} The Neyman orthogonal score is: #' -#' \eqn{\psi_a(W; \eta) = -\left(\frac{Z(D - r_1(X))}{m(X)} - \frac{(1-Z)(D-r_0(X))}{1-m(X)} + r_1(X) - r_0(X)\right)} +#' \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)} #' -#' with nuisance parameters \eqn{\eta = (\ell_0, \ell_1, r_0, r_1, m)} 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{m_0(X) = E[Z|X]}. +#' \strong{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: #' -#' @inheritParams ddml-class -#' @inheritParams ddml_ate +#' \deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} +#' +#' where: +#' +#' \deqn{\psi_a(W; \eta) = -\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)} +#' +#' \deqn{\psi_b(W; \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)} +#' +#' @inheritParams ddml-intro +#' @inheritParams ddml_apo #' @param Z Binary instrumental variable. #' @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 @@ -53,31 +59,19 @@ #' \code{ddml_late}, recommended keys are \code{subsamples}, #' \code{subsamples_byZ}, \code{cv_subsamples}, and #' \code{cv_subsamples_byZ}. -#' @param ... Deprecated arguments (\code{subsamples}, -#' \code{subsamples_byZ}, \code{cv_subsamples}, -#' \code{cv_subsamples_byZ}) are still accepted for backward -#' compatibility but should be replaced with \code{splits}. +#' @param ... Additional arguments passed to internal methods. #' #' @return \code{ddml_late} returns an object of S3 class #' \code{ddml_late} and \code{ddml}. See -#' \code{\link{ddml-class}} for the common output structure. +#' \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 (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"] @@ -97,7 +91,7 @@ #' \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, @@ -159,8 +153,6 @@ ddml_late <- function(y, D, Z, X, nobs <- length(y) - splits <- normalize_splits( - splits = splits, by_label = "Z", ...) validate_fitted_splits_pair(fitted, splits, !shortstack) indxs <- get_sample_splits( @@ -168,10 +160,14 @@ ddml_late <- function(y, D, Z, X, sample_folds = sample_folds, cv_folds = cv_folds, D = Z, stratify = stratify, - subsamples = splits$subsamples, - subsamples_byD = splits$subsamples_byZ, - cv_subsamples = splits$cv_subsamples, - cv_subsamples_byD = splits$cv_subsamples_byZ) + subsamples = splits$Z_X$subsamples, + subsamples_byD = list( + splits$y_X_Z0$subsamples, + splits$y_X_Z1$subsamples), + cv_subsamples = splits$Z_X$cv_subsamples, + cv_subsamples_byD = list( + splits$y_X_Z0$cv_subsamples, + splits$y_X_Z1$cv_subsamples)) check_subsamples(indxs$subsamples, indxs$subsamples_byD, stratify, Z) @@ -202,10 +198,15 @@ ddml_late <- function(y, D, Z, X, fitted = fitted$Z_X) splits_Z <- list( - subsamples = indxs$subsamples, - subsamples_byD = indxs$subsamples_byD, - cv_subsamples = indxs$cv_subsamples, - cv_subsamples_byD = indxs$cv_subsamples_byD) + 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)) fitted_Z_X <- build_fitted_entry(Z_X_res, save_crossval) @@ -278,15 +279,13 @@ ddml_late <- function(y, D, Z, X, # == Output ======================================================= - splits_export <- ate_rf$splits - names(splits_export)[names(splits_export) == - "subsamples_byD"] <- "subsamples_byZ" - if ("cv_subsamples_byD" %in% names(splits_export)) { - names(splits_export)[names(splits_export) == - "cv_subsamples_byD"] <- "cv_subsamples_byZ" + elapsed <- round(proc.time()[3] - t0, 1) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) }#IF - ddml_fit <- list( + ddml( coefficients = coef, ensemble_weights = list( y_X_Z0 = ate_rf$ensemble_weights$y_X_D0, @@ -315,9 +314,6 @@ ddml_late <- function(y, D, Z, X, sample_folds = sample_folds, cv_folds = if (shortstack) NULL else cv_folds, shortstack = shortstack, - learners = learners, - learners_DXZ = learners_DXZ, - learners_ZX = learners_ZX, cluster_variable = cluster_variable, fitted = list( y_X_Z0 = ate_rf$fitted$y_X_D0, @@ -325,15 +321,16 @@ ddml_late <- function(y, D, Z, X, 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 = splits_export, - call = cl) - - elapsed <- round(proc.time()[3] - t0, 1) - if (!is.null(messages$finish) && messages$finish != "") { - info_msg(sprintf(messages$finish, elapsed), - silent = silent) - }#IF - - class(ddml_fit) <- c("ddml_late", "ddml") - return(ddml_fit) + 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", + learners = learners, + learners_DXZ = learners_DXZ, + learners_ZX = learners_ZX + ) }#DDML_LATE diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index da15b7f..bcfc382 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -1,33 +1,38 @@ -#' Estimator for the Partially Linear IV Model. +#' Estimator for the Partially Linear IV Coefficient #' #' @family ddml estimators #' -#' @seealso [AER::ivreg()] +#' @description Estimator for the partially linear IV coefficient. #' -#' @description Estimator for the partially linear IV model. -#' -#' @details \code{ddml_pliv} provides a Double/Debiased Machine Learning +#' @details +#' \strong{Parameter of Interest:} \code{ddml_pliv} provides a Double/Debiased Machine Learning #' estimator for the target parameter \eqn{\theta_0} in the partially -#' linear IV model given by +#' linear IV model given by: #' -#' \eqn{Y = \theta_0D + g_0(X) + U,} +#' \deqn{Y = \theta_0 D + g_0(X) + U,} #' #' 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. #' -#' In this model, the target parameter \eqn{\theta_0} is identified by the -#' estimating equation -#' \eqn{E[m(W; \theta_0, \eta_0)] = 0}, where \eqn{W = (Y, D, Z, X)} and -#' \eqn{m(W; \theta, \eta)} is the Neyman orthogonal score +#' \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{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: #' -#' \eqn{m(W; \theta, \eta) = (Y - \ell(X) - \theta(D - r_D(X)))(Z - r_Z(X)),} +#' \deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} #' -#' with nuisance parameters \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]}. +#' where: #' -#' @inheritParams ddml-class +#' \deqn{\psi_a(W; \eta) = -(D - r_D(X))(Z - r_Z(X))^\top} +#' +#' \deqn{\psi_b(W; \eta) = (Z - r_Z(X))(Y - \ell(X))} +#' +#' @inheritParams ddml-intro #' @param Z A matrix of instruments. #' @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 @@ -41,25 +46,12 @@ #' have the same number of columns. #' #' @return \code{ddml_pliv} returns an object of S3 class -#' \code{ddml_pliv} and \code{ddml}. See \code{\link{ddml-class}} +#' \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,15 +110,14 @@ ddml_pliv <- function(y, D, Z, X, Z <- as.matrix(Z) nZ <- ncol(Z) - splits <- normalize_splits(splits = splits, ...) validate_fitted_splits_pair(fitted, splits, !shortstack) indxs <- get_sample_splits( cluster_variable = cluster_variable, sample_folds = sample_folds, cv_folds = cv_folds, - subsamples = splits$subsamples, - cv_subsamples = splits$cv_subsamples) + subsamples = splits[[1]]$subsamples, + cv_subsamples = splits[[1]]$cv_subsamples) check_subsamples(indxs$subsamples, NULL, stratify = FALSE) t0 <- proc.time()[3] @@ -251,7 +242,13 @@ ddml_pliv <- function(y, D, Z, X, r2[[eq]] <- Z_X_res_list[[k]]$r2 }#FOR - ddml_fit <- list( + elapsed <- round(proc.time()[3] - t0, 1) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) + }#IF + + ddml( coefficients = coef, ensemble_weights = ensemble_weights, mspe = mspe, @@ -265,9 +262,6 @@ ddml_pliv <- function(y, D, Z, X, sample_folds = sample_folds, cv_folds = if (shortstack) NULL else cv_folds, shortstack = shortstack, - learners = learners, - learners_DX = learners_DX, - learners_ZX = learners_ZX, cluster_variable = cluster_variable, fitted = list( y_X = build_fitted_entry(y_X_res, save_crossval), @@ -275,16 +269,15 @@ ddml_pliv <- function(y, D, Z, X, save_crossval), Z_X = build_fitted_from_list(Z_X_res_list, save_crossval)), - splits = list(subsamples = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples), - call = cl) - - elapsed <- round(proc.time()[3] - t0, 1) - if (!is.null(messages$finish) && messages$finish != "") { - info_msg(sprintf(messages$finish, elapsed), - silent = silent) - }#IF - - class(ddml_fit) <- c("ddml_pliv", "ddml") - return(ddml_fit) + splits = setNames( + rep(list(list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples)), + length(ensemble_weights)), + names(ensemble_weights)), + call = cl, + subclass = "ddml_pliv", + learners = learners, + learners_DX = learners_DX, + learners_ZX = learners_ZX + ) }#DDML_PLIV diff --git a/R/ddml_plm.R b/R/ddml_plm.R index 5247225..9450a07 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -1,30 +1,38 @@ -#' Estimator for the Partially Linear Model. +#' Estimator for the Partially Linear Regression Coefficient #' #' @family ddml estimators #' -#' @description Estimator for the partially linear model. +#' @description Estimator for the partially linear regression coefficient. #' -#' @details \code{ddml_plm} provides a Double/Debiased Machine Learning +#' @details +#' \strong{Parameter of Interest:} \code{ddml_plm} provides a Double/Debiased Machine Learning #' estimator for the target parameter \eqn{\theta_0} in the partially -#' linear model given by +#' linear model given by: #' -#' \eqn{Y = \theta_0D + g_0(X) + U,} +#' \deqn{Y = \theta_0 D + g_0(X) + U,} #' #' 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. #' -#' In this model, the target parameter \eqn{\theta_0} is identified by the -#' estimating equation -#' \eqn{E[m(W; \theta_0, \eta_0)] = 0}, where \eqn{W = (Y, D, X)} and -#' \eqn{m(W; \theta, \eta)} is the Neyman orthogonal score +#' \strong{Neyman Orthogonal Score:} The Neyman orthogonal score is: #' -#' \eqn{m(W; \theta, \eta) = (Y - \ell(X) - \theta(D - r(X)))(D - r(X)),} +#' \deqn{m(W; \theta, \eta) = [(Y - \ell(X)) - \theta(D - r(X))](D - r(X))} #' -#' with nuisance parameters \eqn{\eta = (\ell, r)} taking true values -#' \eqn{\ell_0(X) = E[Y|X]} and \eqn{r_0(X) = E[D|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]}. #' -#' @inheritParams ddml-class +#' \strong{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: +#' +#' \deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} +#' +#' where: +#' +#' \deqn{\psi_a(W; \eta) = -(D - r(X))(D - r(X))^\top} +#' +#' \deqn{\psi_b(W; \eta) = (D - r(X))(Y - \ell(X))} +#' +#' @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 custom_ensemble_weights_DX Optional argument to allow for different @@ -33,21 +41,11 @@ #' \code{custom_ensemble_weights_DX} must have the same number of columns. #' #' @return \code{ddml_plm} returns an object of S3 class -#' \code{ddml_plm} and \code{ddml}. See \code{\link{ddml-class}} +#' \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"] @@ -132,15 +130,14 @@ ddml_plm <- function(y, D, X, D <- as.matrix(D) nD <- ncol(D) - splits <- normalize_splits(splits = splits, ...) validate_fitted_splits_pair(fitted, splits, !shortstack) indxs <- get_sample_splits( cluster_variable = cluster_variable, sample_folds = sample_folds, cv_folds = cv_folds, - subsamples = splits$subsamples, - cv_subsamples = splits$cv_subsamples) + subsamples = splits[[1]]$subsamples, + cv_subsamples = splits[[1]]$cv_subsamples) check_subsamples(indxs$subsamples, NULL, stratify = FALSE) t0 <- proc.time()[3] @@ -165,7 +162,7 @@ ddml_plm <- function(y, D, X, custom_ensemble_weights = custom_ensemble_weights, subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples, - silent = silent, label = "E[Y|X]", + silent = silent, label = messages$y_X, parallel = parallel, fitted = fitted$y_X) @@ -235,7 +232,13 @@ ddml_plm <- function(y, D, X, r2[[eq]] <- D_X_res_list[[k]]$r2 }#FOR - ddml_fit <- list( + elapsed <- round(proc.time()[3] - t0, 1) + if (!is.null(messages$finish) && messages$finish != "") { + info_msg(sprintf(messages$finish, elapsed), + silent = silent) + }#IF + + ddml( coefficients = coef, ensemble_weights = ensemble_weights, mspe = mspe, @@ -249,23 +252,19 @@ ddml_plm <- function(y, D, X, sample_folds = sample_folds, cv_folds = if (shortstack) NULL else cv_folds, shortstack = shortstack, - learners = learners, - learners_DX = learners_DX, cluster_variable = cluster_variable, fitted = list( y_X = build_fitted_entry(y_X_res, save_crossval), D_X = build_fitted_from_list(D_X_res_list, save_crossval)), - splits = list(subsamples = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples), - call = cl) - - elapsed <- round(proc.time()[3] - t0, 1) - if (!is.null(messages$finish) && messages$finish != "") { - info_msg(sprintf(messages$finish, elapsed), - silent = silent) - }#IF - - class(ddml_fit) <- c("ddml_plm", "ddml") - return(ddml_fit) + splits = setNames( + rep(list(list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples)), + length(ensemble_weights)), + names(ensemble_weights)), + call = cl, + subclass = "ddml_plm", + learners = learners, + learners_DX = learners_DX + ) }#DDML_PLM diff --git a/R/ddml_rep.R b/R/ddml_rep.R index 799cdc9..192ae36 100644 --- a/R/ddml_rep.R +++ b/R/ddml_rep.R @@ -52,7 +52,10 @@ spectral_median_psd <- function(matrices) { obj <- obj + CVXR::norm(V - matrices[[r]], "2") }#FOR - result <- CVXR::psolve(CVXR::Problem(CVXR::Minimize(obj))) + # Retrieve psolve from CVXR namespace to avoid S4 dispatch + # issues with CVXR::solve / CVXR::psolve across versions. + cvxr_solve <- utils::getFromNamespace("psolve", "CVXR") + result <- cvxr_solve(CVXR::Problem(CVXR::Minimize(obj))) if (result$status != "optimal") { warning("SDP solver returned status '", @@ -163,8 +166,7 @@ aggregate_reps <- function(object, aggregation = "median", #' \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.} +#' \item{shortstack}{Logical, whether short-stacking was used.} #' } #' #' @examples @@ -439,7 +441,7 @@ coef.ddml_rep <- function(object, #' @inheritParams vcov.ddml #' @param ... Currently unused. #' -#' @return A p x p variance-covariance matrix. +#' @return A \eqn{p \times p}{p x p} variance-covariance matrix. #' #' @examples #' \donttest{ @@ -692,10 +694,9 @@ print.summary.ddml_rep <- function(x, digits = 3, ...) { #' Default 0.95. #' @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}. If \code{conf.int = TRUE}, +#' @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}. If \code{conf.int = TRUE}, #' also \code{conf.low} and \code{conf.high}. #' #' @examples @@ -769,10 +770,9 @@ tidy.ddml_rep <- function(x, ensemble_idx = 1, #' @param x A \code{ddml_rep} object. #' @param ... Currently unused. #' -#' @return A one-row \code{data.frame} with columns -#' \code{nobs}, \code{sample_folds}, \code{shortstack}, -#' \code{ensemble_type}, \code{model_type}, and -#' \code{nresamples}. +#' @return A one-row \code{data.frame} with columns \code{nobs}, +#' \code{sample_folds}, \code{shortstack}, \code{ensemble_type}, +#' \code{model_type}, and \code{nresamples}. #' #' @examples #' \donttest{ diff --git a/R/diagnostics.R b/R/diagnostics.R index ba09aa1..6efe691 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -10,34 +10,34 @@ #' learner is significantly outperformed by the others. #' @param bootnum Number of bootstrap replications for CVC. #' Default 500. Ignored when \code{cvc = FALSE}. -#' @param alpha Significance level for the model confidence -#' set. Default 0.05. #' @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. +#' @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 = list(what = ols), +#' learners = learners, #' sample_folds = 2, silent = TRUE) -#' diagnostics(plm_fit) -#' tidy(diagnostics(plm_fit)) +#' 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, alpha = 0.05, + bootnum = 500, ...) { if (!inherits(object, "ddml")) { stop("object must be of class 'ddml'.", call. = FALSE) @@ -53,27 +53,24 @@ diagnostics <- function(object, cvc = FALSE, r <- object$r2[[eq]] # Build per-learner table + nlearners <- if (single_learner) 1L else nrow(w) + learner_names <- if (single_learner) "single" else + paste0("learner_", seq_len(nlearners)) + + # Per-learner 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) + + tbl <- data.frame( + learner = learner_names, + mspe = m_vec, + r2 = r_vec, + stringsAsFactors = FALSE, + row.names = NULL) + if (single_learner) { - m_val <- if (is.null(m) || length(m) == 0) { - NA_real_ - } else { - as.numeric(m[1]) - }#IFELSE - r_val <- if (is.null(r) || length(r) == 0) { - NA_real_ - } else { - as.numeric(r[1]) - }#IFELSE - tbl <- data.frame( - learner = "single", - mspe = m_val, - r2 = r_val, - weight = 1, - stringsAsFactors = FALSE) + tbl$weight <- 1 } else { - nlearners <- nrow(w) - learner_names <- paste0("learner_", seq_len(nlearners)) - # Weights: average across folds if 3D array if (length(dim(w)) == 3) { w_avg <- apply(w, c(1, 2), mean) @@ -81,34 +78,11 @@ diagnostics <- function(object, cvc = FALSE, w_avg <- as.matrix(w) }#IFELSE - # MSPE: average across folds if matrix - if (is.matrix(m) && ncol(m) > 1) { - m_avg <- rowMeans(m) - } else { - m_avg <- as.numeric(m) - }#IFELSE - - # R-squared: average across folds if matrix - if (is.matrix(r) && ncol(r) > 1) { - r_avg <- rowMeans(r) - } else { - r_avg <- as.numeric(r) - }#IFELSE - - # Display weights for all ensemble types ens_names <- colnames(w_avg) if (is.null(ens_names)) { ens_names <- paste0("weight_", seq_len(ncol(w_avg))) }#IF - tbl <- data.frame( - learner = learner_names, - mspe = m_avg, - r2 = r_avg, - stringsAsFactors = FALSE, - row.names = NULL) - - # Add a weight column per ensemble type for (j in seq_len(ncol(w_avg))) { col_name <- paste0("weight_", ens_names[j]) tbl[[col_name]] <- w_avg[, j] @@ -117,17 +91,7 @@ diagnostics <- function(object, cvc = FALSE, # CVC p-values (opt-in) if (cvc && !single_learner) { - resid <- get_cf_resid_bylearner_for_eq(object$fitted, eq) - subs <- get_diag_subsamples(object, eq) - if (!is.null(resid) && !is.null(subs) && - ncol(resid) > 1) { - cvc_res <- cvc_test(resid, subs, bootnum, alpha) - tbl$cvc_pval <- cvc_res$pvalues - tbl$in_conf_set <- cvc_res$confidence_set - } else { - tbl$cvc_pval <- NA_real_ - tbl$in_conf_set <- NA - }#IFELSE + tbl$cvc_pval <- cvc_pvalues(object$fitted, object$splits, eq, bootnum) }#IF tables[[eq]] <- tbl @@ -139,35 +103,101 @@ diagnostics <- function(object, cvc = FALSE, estimator_name = object$estimator_name, nobs = object$nobs, shortstack = object$shortstack, - cvc = cvc, - alpha = alpha) + cvc = cvc) class(result) <- "ddml_diagnostics" result }#DIAGNOSTICS -# Resolve the correct subsamples for a given equation. -get_diag_subsamples <- function(object, eq) { - splits <- object$splits - if (grepl("D0|d0", eq, ignore.case = TRUE) && !is.null(splits$subsamples_byD)) return(splits$subsamples_byD[[1]]) - if (grepl("D1|d1", eq, ignore.case = TRUE) && !is.null(splits$subsamples_byD)) return(splits$subsamples_byD[[2]]) - if (grepl("D0|d0", eq, ignore.case = TRUE) && !is.null(splits$subsamples_byd)) return(splits$subsamples_byd[[1]]) - if (grepl("D1|d1", eq, ignore.case = TRUE) && !is.null(splits$subsamples_byd)) return(splits$subsamples_byd[[2]]) +# 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) { + resid <- get_cf_resid_bylearner_for_eq(fitted, eq) + 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) - if (grepl("Z0", eq, ignore.case = TRUE) && !is.null(splits$subsamples_byZ)) return(splits$subsamples_byZ[[1]]) - if (grepl("Z1", eq, ignore.case = TRUE) && !is.null(splits$subsamples_byZ)) return(splits$subsamples_byZ[[2]]) + 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 - if (!is.null(splits$subsamples)) return(splits$subsamples) - object$subsamples -}#GET_DIAG_SUBSAMPLES + zeta_m <- colMeans(zeta) + zeta_sd <- apply(zeta_til, 2, stats::sd) + zeta_sd[zeta_sd < .Machine$double.eps] <- Inf -# Reconstruct full-sample folds from stratified folds. -merge_subsamples <- function(subsamples_by) { - K <- length(subsamples_by[[1]]) - lapply(seq_len(K), function(k) { - sort(unlist(lapply(subsamples_by, - function(s) s[[k]]))) - }) -}#MERGE_SUBSAMPLES + # Sup-type test statistic + Tx <- max(sqrt(n) * zeta_m / zeta_sd) + + # Multiplier bootstrap + zeta_scaled <- sweep(zeta_til, 2, zeta_sd, FUN = "/") + Txb <- vapply(seq_len(bootnum), function(b) { + bw <- stats::rnorm(n) + max(colSums(zeta_scaled * bw) / sqrt(n)) + }, numeric(1)) + + mean(Txb > Tx) +}#CVC_ONE_VS_MANY #' Print Stacking Diagnostics #' @@ -198,9 +228,6 @@ print.ddml_diagnostics <- function(x, digits = 4, ...) { display[[col]] <- round(display[[col]], digits) }#IF }#FOR - if ("in_conf_set" %in% names(display)) { - display$in_conf_set <- NULL - }#IF print(display, row.names = FALSE, right = TRUE) cat("\n") @@ -225,20 +252,20 @@ print.ddml_diagnostics <- function(x, digits = 4, ...) { #' @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} and -#' \code{in_conf_set}. +#' @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 = list(what = ols), +#' learners = learners, #' sample_folds = 2, silent = TRUE) -#' tidy(diagnostics(plm_fit)) +#' tidy(diagnostics(plm_fit, cvc = TRUE)) #' } #' #' @export diff --git a/R/ensemble.R b/R/ensemble.R index 8dea176..1214655 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -1,4 +1,4 @@ -#' Stacking estimator using combinations of base learners +#' Stacking Estimator Using Combinations of Base Learners #' #' @family utilities #' @@ -8,10 +8,10 @@ #' #' @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. +#' @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. @@ -19,12 +19,17 @@ #' @param silent A boolean indicating whether to suppress progress messages. #' #' @return An object of class \code{ensemble} containing: -#' \item{mdl_fits}{List of fitted base learners.} -#' \item{weights}{Computed ensemble weights.} -#' \item{learners}{The base learners used.} -#' \item{cv_results}{Cross-validation results if computed.} -#' \item{mean_y}{Mean of the outcome variable.} -#' \item{constant_y}{Boolean indicating if y is constant.} +#' \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.} +#' } +#' @family utilities #' @export #' #' @examples @@ -115,7 +120,7 @@ ensemble <- function(y, X, # Complementary methods ======================================================== -#' Predict method for \code{ensemble} objects. +#' Predict Method for \code{ensemble} Objects #' #' @param object A fitted \code{ensemble} object. #' @param newdata A feature matrix for prediction. @@ -160,7 +165,8 @@ predict.ensemble <- function(object, newdata, ...){ #' @param type A character string or vector indicating the type(s) of ensemble #' weights to compute. Default is \code{"average"}. -#' @param learners A list of base learners. +#' @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. @@ -168,8 +174,13 @@ predict.ensemble <- function(object, newdata, ...){ #' @param silent A boolean indicating whether to suppress progress messages. #' #' @return A list containing: -#' \item{weights}{A matrix of computed ensemble weights.} -#' \item{cv_results}{Cross-validation results used for computing weights.} +#' \describe{ +#' \item{\code{weights}}{A matrix of computed ensemble +#' weights.} +#' \item{\code{cv_results}}{Cross-validation results used +#' for computing weights.} +#' } +#' @family utilities #' @export #' #' @examples diff --git a/R/help_functions.R b/R/help_functions.R index bb3993d..a3d02cf 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -217,17 +217,8 @@ validate_fitted_splits_pair <- function(fitted, splits, w_cv = FALSE) { if (is.null(fitted)) return(invisible(NULL)) if (is.null(splits)) { - stop("Argument 'splits' must be supplied when 'fitted' is supplied.", - call. = FALSE) - }#IF - if (is.null(splits$subsamples)) { - stop("splits must contain 'subsamples' when 'fitted' is supplied.", - call. = FALSE) - }#IF - if (w_cv && is.null(splits$cv_subsamples)) { - stop(paste("splits must contain 'cv_subsamples' for data-driven", - "stacking when 'fitted' is supplied."), - call. = FALSE) + stop("'splits' must be supplied when 'fitted' is ", + "supplied.", call. = FALSE) }#IF }#VALIDATE_FITTED_SPLITS_PAIR @@ -270,52 +261,6 @@ get_cf_resid_bylearner_for_eq <- function(fitted, eq) { NULL }#GET_CF_RESID_BYLEARNER_FOR_EQ -normalize_splits <- function(splits = NULL, - by_label = NULL, ...) { - dots <- list(...) - subsamples <- dots[["subsamples"]] - cv_subsamples <- dots[["cv_subsamples"]] - # Handle cv_subsamples_list (older deprecated name) - if (!is.null(dots[["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 <- dots[["cv_subsamples_list"]] - }#IF - # Handle grouped split args (ATE/ATT/LATE) - subsamples_by <- NULL - cv_subsamples_by <- NULL - if (!is.null(by_label)) { - sub_by <- paste0("subsamples_by", by_label) - cv_sub_by <- paste0("cv_subsamples_by", by_label) - subsamples_by <- dots[[sub_by]] - cv_subsamples_by <- dots[[cv_sub_by]] - }#IF - legacy_used <- !is.null(subsamples) || !is.null(cv_subsamples) || - !is.null(subsamples_by) || !is.null(cv_subsamples_by) - if (legacy_used) { - warning("Deprecated split arguments detected. ", - "Use 'splits' instead.", call. = FALSE) - }#IF - if (is.null(splits) && !legacy_used) return(NULL) - if (is.null(splits)) splits <- list() - if (!is.list(splits)) stop("'splits' must be a list.", call. = FALSE) - if (is.null(splits$subsamples) && !is.null(subsamples)) - splits$subsamples <- subsamples - if (is.null(splits$cv_subsamples) && !is.null(cv_subsamples)) - splits$cv_subsamples <- cv_subsamples - if (!is.null(by_label)) { - if (is.null(splits[[sub_by]]) && !is.null(subsamples_by)) - splits[[sub_by]] <- subsamples_by - if (is.null(splits[[cv_sub_by]]) && - !is.null(cv_subsamples_by)) - splits[[cv_sub_by]] <- cv_subsamples_by - }#IF - splits -}#NORMALIZE_SPLITS - # Validate common arguments for S3 inference methods. # Returns the validated type (via match.arg) invisibly. validate_method_args <- function(object, diff --git a/R/methods.R b/R/methods.R deleted file mode 100644 index 6c8335c..0000000 --- a/R/methods.R +++ /dev/null @@ -1,444 +0,0 @@ -#' Access Elements of a DDML Object -#' -#' Provides backward compatibility for renamed elements. -#' Accessing \code{$weights} is deprecated; use -#' \code{$ensemble_weights} instead. -#' -#' @param x An object of class \code{ddml}. -#' @param name Element name. -#' -#' @return The requested element. -#' -#' @export -`$.ddml` <- function(x, name) { - if (name == "weights") { - message("Note: '$weights' is deprecated for ddml ", - "objects. Use '$ensemble_weights' instead.") - return(.subset2(x, "ensemble_weights")) - }#IF - .subset2(x, name) -}#`$.DDML` - -#' Extract Model Coefficients -#' -#' @description Extracts the estimated coefficients -#' from a DDML model for the specified or default -#' ensemble type. -#' -#' @param object An object of class \code{ddml}. -#' @param ... Currently unused. -#' -#' @return Named vector (single ensemble) or matrix -#' (multiple ensembles). -#' -#' @examples -#' \donttest{ -#' # Fit a PLM and extract coefficients -#' 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) -#' coef(plm_fit) -#' } -#' -#' @family ddml inference -#' @export -coef.ddml <- 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.DDML - -#' Extract Number of Observations -#' -#' @description Returns the number of observations -#' used to fit the DDML model. -#' -#' @param object An object of class \code{ddml}. -#' @param ... Currently unused. -#' -#' @return An integer specifying the number of observations. -#' -#' @family ddml inference -#' @importFrom stats nobs -#' @export -nobs.ddml <- function(object, ...) { - object$nobs -}#NOBS.DDML - -#' Extract Generalized Leverage (Hat Values) -#' -#' @description Computes the generalized leverage (hat values) for a DDML -#' estimator. These values are used internally to compute -#' heteroskedasticity-robust HC3 standard errors. -#' -#' @details See \code{\link{ddml-class}} for the DML framework and -#' the definition of \eqn{\psi_a} and \eqn{\hat{J}}. -#' For the linear scores used in \code{ddml}, -#' the generalized leverage simplifies to -#' -#' \eqn{h_{ii} = \mathrm{tr}(\psi_a(W_i; -#' \hat\eta)\,(n\hat{J})^{-1}).} -#' -#' @param model An object of class \code{ddml}. -#' @param ensemble_idx Integer index of the ensemble type to extract leverage -#' values for. Defaults to 1. -#' @param ... Currently unused. -#' -#' @return A numeric vector of generalized leverage values. -#' -#' @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) -#' h = hatvalues(plm_fit) -#' head(h) -#' } -#' -#' @seealso \code{\link{vcov.ddml}} for the use of leverage in HC3 standard errors. -#' -#' @family ddml inference -#' @importFrom stats hatvalues -#' @export -hatvalues.ddml <- function(model, ensemble_idx = 1, ...) { - validate_method_args(model, ensemble_idx = ensemble_idx) - psi_a_j <- model$psi_a[[ensemble_idx]] - J_j <- model$J[, , ensemble_idx, drop = FALSE] - dim(J_j) <- dim(J_j)[1:2] - J_inv <- csolve(J_j) - p <- ncol(J_j) - n <- model$nobs - dim(psi_a_j) <- c(n, p * p) - as.vector((psi_a_j %*% as.vector(t(J_inv))) / n) -}#HATVALUES.DDML - - - - - -#' Variance-Covariance Matrix for DDML Estimators -#' -#' @description Computes a heteroskedasticity-robust -#' variance-covariance matrix for the DDML estimator -#' \eqn{\hat\theta}. -#' -#' @details See \code{\link{ddml-class}} for the DML framework, -#' including the definitions of the score \eqn{m_i}, -#' the Jacobian \eqn{\hat{J}}, and the base sandwich -#' estimator \eqn{\hat\Sigma}. This function provides -#' three variants: -#' -#' \strong{HC0}: -#' \deqn{V_{\mathrm{HC0}} = \hat{J}^{-1} -#' \left(\frac{1}{n}\sum_i m_i m_i'\right) -#' \hat{J}^{-\top} / n} -#' -#' \strong{HC1} (default): -#' \deqn{V_{\mathrm{HC1}} = V_{\mathrm{HC0}} -#' \times \frac{n}{n - p}} -#' -#' where \eqn{p} is the dimension of \eqn{\theta}. -#' -#' \strong{HC3}: -#' \deqn{V_{\mathrm{HC3}} = \hat{J}^{-1} -#' \left(\frac{1}{n}\sum_i -#' \frac{m_i m_i'}{(1 - h_{ii})^2}\right) -#' \hat{J}^{-\top} / n} -#' -#' where \eqn{h_{ii}} is the generalized leverage; -#' see \code{\link{hatvalues.ddml}}. -#' -#' @param object An object of class \code{ddml}. -#' @param ensemble_idx Integer index of the ensemble type to -#' use. Defaults to 1 (first ensemble type). -#' @param type Character string specifying the -#' variance-covariance estimator. 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. -#' -#' @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) -#' vcov(plm_fit) -#' vcov(plm_fit, type = "HC3") -#' } -#' -#' @seealso \code{\link{hatvalues.ddml}}, -#' \code{\link{confint.ddml}}, -#' \code{\link{summary.ddml}} -#' -#' @family ddml inference -#' @export -vcov.ddml <- function(object, ensemble_idx = 1, - type = "HC1", ...) { - type <- validate_method_args(object, - ensemble_idx = ensemble_idx, type = type) - - h <- if (type == "HC3") { - stats::hatvalues(object, ensemble_idx = ensemble_idx) - }#IF - - sc <- object$scores[, , ensemble_idx, drop = FALSE] - dim(sc) <- dim(sc)[1:2] - J_j <- object$J[, , ensemble_idx, drop = FALSE] - dim(J_j) <- dim(J_j)[1:2] - p <- ncol(sc) - - # Cluster aggregation: rowsum scores to cluster level - clustered <- !is.null(object$cluster_variable) && - length(unique(object$cluster_variable)) < nrow(sc) - if (clustered) { - sc <- rowsum(sc, object$cluster_variable) - }#IF - - n_eff <- nrow(sc) - - if (type == "HC3") { - if (clustered) { - h <- as.vector(tapply(h, object$cluster_variable, sum)) - }#IF - sc <- sc / (1 - h) - meat <- crossprod(sc) / n_eff - J_inv <- csolve(J_j) - V <- J_inv %*% meat %*% t(J_inv) / n_eff - } else if (type == "HC1") { - meat <- crossprod(sc) / n_eff - J_inv <- csolve(J_j) - V <- J_inv %*% meat %*% t(J_inv) * - n_eff / (n_eff - p) / n_eff - } else { - # HC0 - meat <- crossprod(sc) / n_eff - J_inv <- csolve(J_j) - V <- J_inv %*% meat %*% t(J_inv) / n_eff - }#IFELSE - - rownames(V) <- colnames(V) <- object$coef_names - V -}#VCOV.DDML - -#' Confidence Intervals for DDML Estimators -#' -#' @description Computes confidence intervals for one or more -#' parameters in a fitted DDML model. -#' -#' @param object An object of class \code{ddml}. -#' @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. -#' @inheritParams vcov.ddml -#' @param ... Currently unused. -#' -#' @return A matrix with columns for lower and upper bounds. -#' -#' @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) -#' confint(plm_fit) -#' confint(plm_fit, parm = "D1") -#' confint(plm_fit, level = 0.90) -#' } -#' -#' @seealso \code{\link{vcov.ddml}} -#' -#' @family ddml inference -#' @importFrom stats vcov -#' @export -confint.ddml <- function(object, parm, level = 0.95, - ensemble_idx = 1, - type = "HC1", ...) { - cf <- object$coefficients[, ensemble_idx] - cf_names <- object$coef_names - - if (missing(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, ensemble_idx = ensemble_idx, - type = type) - se <- sqrt(diag(V))[parm] - - z <- stats::qnorm((1 + level) / 2) - 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 - ci -}#CONFINT.DDML - -#' @rdname summary.ddml -#' @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, t-values, and p-values for all -#' ensemble types. Standard errors are based on a -#' heteroskedasticity-robust sandwich variance; see -#' \code{\link{vcov.ddml}} for the HC0/HC1/HC3 formulas. -#' -#' @param object An object of class \code{ddml}. -#' @inheritParams vcov.ddml -#' @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.ddml}} -#' -#' @family ddml inference -#' @export -summary.ddml <- function(object, type = "HC1", ...) { - type <- match.arg(type, c("HC0", "HC1", "HC3")) - - single_learner <- is_single_learner(object$learners) - ens_type <- if (single_learner) { - "single base learner" - } else { - object$ensemble_type - }#IFELSE - - nensb <- length(ens_type) - p <- nrow(object$coefficients) - - inf <- array(0, dim = c(p, 4, nensb)) - - for (j in seq_len(nensb)) { - theta_j <- object$coefficients[, j] - - V <- stats::vcov(object, ensemble_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|)"), - ens_type - ) - - result <- list( - coefficients = inf, - type = type, - model_type = class(object)[1], - estimator_name = object$estimator_name, - nobs = object$nobs, - sample_folds = object$sample_folds, - shortstack = object$shortstack, - 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. -#' -#' @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") - - nensb <- dim(x$coefficients)[3] - for (j in seq_len(nensb)) { - if (nensb > 1) { - cat("Ensemble type:", - dimnames(x$coefficients)[[3]][j], "\n") - }#IF - tbl <- x$coefficients[, , j] - if (!is.matrix(tbl)) { - tbl <- matrix(tbl, nrow = 1, - dimnames = list( - dimnames(x$coefficients)[[1]], - dimnames(x$coefficients)[[2]])) - }#IF - stats::printCoefmat(tbl, digits = digits, - has.Pvalue = TRUE, - signif.stars = TRUE) - if (j < nensb) cat("\n") - }#FOR - - invisible(x) -}#PRINT.SUMMARY.DDML diff --git a/R/ml_wrappers.R b/R/ml_wrappers.R index 73078e6..cbeae36 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 #' @@ -47,7 +47,7 @@ mdl_glmnet <- function(y, X, return(mdl_fit) }#MDL_GLMNET -#' Predict method for \code{mdl_glmnet} objects. +#' Predict Method for mdl_glmnet Objects #' #' @param object A fitted \code{mdl_glmnet} object. #' @param newdata A (sparse) feature matrix for prediction. @@ -83,7 +83,7 @@ predict.mdl_glmnet <- function(object, newdata = NULL, ...){ # xgboost ====================================================================== -#' Wrapper for [xgboost::xgboost()]. +#' Wrapper for xgboost::xgboost() #' #' @family ml_wrapper #' @@ -128,7 +128,7 @@ mdl_xgboost <- function(y, X, return(mdl_fit) }#MDL_XGBOOST -#' Predict method for \code{mdl_xgboost} objects. +#' Predict Method for mdl_xgboost Objects #' #' @param object A fitted \code{mdl_xgboost} object. #' @param newdata A feature matrix for prediction. @@ -146,7 +146,7 @@ predict.mdl_xgboost <- function(object, newdata = NULL, ...){ # ranger ======================================================================= -#' Wrapper for [ranger::ranger()]. +#' Wrapper for ranger::ranger() #' #' @family ml_wrapper #' @@ -184,7 +184,7 @@ mdl_ranger <- function(y, X, ...){ return(mdl_fit) }#MDL_RANGER -#' Predict method for \code{mdl_ranger} objects. +#' Predict Method for mdl_ranger Objects #' #' @param object A fitted \code{mdl_ranger} object. #' @param newdata A feature matrix for prediction. @@ -215,7 +215,7 @@ predict.mdl_ranger <- function(object, newdata = NULL, ...){ # glm ========================================================================== -#' Wrapper for [stats::glm()]. +#' Wrapper for stats::glm() #' #' @family ml_wrapper #' @@ -243,7 +243,7 @@ mdl_glm <- function(y, X, ...) { return(glm_fit) # return fitted glm object }#MDL_GLM -#' Predict method for \code{mdl_glm} objects. +#' Predict Method for mdl_glm Objects #' #' @param object A fitted \code{mdl_glm} object. #' @param newdata A feature matrix for prediction. @@ -260,7 +260,7 @@ predict.mdl_glm <- function(object, newdata, ...) { # bigGLM ======================================================================= -#' Wrapper for [glmnet::bigGlm()]. +#' Wrapper for glmnet::bigGlm() #' #' @family ml_wrapper #' @@ -286,7 +286,7 @@ mdl_bigGLM <- function(y, X, ...) { return(mdl_fit) }#MDL_BIGGLM -#' Predict method for \code{mdl_bigGLM} objects. +#' Predict Method for mdl_bigGLM Objects #' #' @param object A fitted \code{mdl_bigGLM} object. #' @param newdata A (sparse) feature matrix for prediction. diff --git a/R/ols.R b/R/ols.R index 20f7bb7..c90363f 100644 --- a/R/ols.R +++ b/R/ols.R @@ -1,4 +1,4 @@ -#' Ordinary least squares. +#' Ordinary Least Squares #' #' @family ml_wrapper #' @@ -52,7 +52,7 @@ ols <- function(y, X, # Complementary methods ======================================================== -#' Predict method for \code{ols} objects. +#' Predict Method for ols Objects #' #' @param object A fitted \code{ols} object. #' @param newdata A feature matrix for prediction. If \code{NULL}, diff --git a/R/shortstacking.R b/R/shortstacking.R index b7a0e60..46d0bb6 100644 --- a/R/shortstacking.R +++ b/R/shortstacking.R @@ -1,11 +1,11 @@ -#' Predictions using Short-Stacking. +#' Predictions using Short-Stacking #' #' @family utilities #' #' @description Predictions using short-stacking. #' #' @inheritParams crosspred -#' @inheritParams ddml-class +#' @inheritParams ddml-intro #' @param shortstack_y Optional vector of the outcome variable to form #' short-stacking predictions for. Base learners are always trained on #' \code{y}. @@ -18,20 +18,20 @@ #' \item{\code{weights}}{An array, providing the weight #' assigned to each base learner (in chronological order) by the #' ensemble procedures.} -#' \item{\code{mspe}}{A numeric vector of per-ensemble MSPEs for -#' the short-stacked predictions.} -#' \item{\code{r2}}{A numeric vector of per-ensemble -#' out-of-sample R-squared values.} +#' \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{cf_fitted_bylearner}}{A matrix of -#' out-of-sample predictions, each column corresponding to a base -#' learner (in chronological order).} +#' \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 @@ -127,15 +127,13 @@ shortstacking <- function(y, X, }#FOR }#IF - # Compute mspe and r-squared - mspe <- colMeans((matrix(shortstack_y, nobs, nensb) - cf_fitted)^2) + # Per-learner OOS mspe and r-squared + cf_resid_bylearner <- as.matrix(fakecv$cv_resid) + mspe <- colMeans(cf_resid_bylearner^2) y_var <- as.numeric(stats::var(shortstack_y)) r2 <- if (y_var > 0) 1 - mspe / y_var else rep(NA_real_, length(mspe)) - # Per-learner OOS residuals (already computed for weight estimation) - cf_resid_bylearner <- as.matrix(fakecv$cv_resid) - # return shortstacking output output <- list(cf_fitted = cf_fitted, weights = weights, mspe = mspe, r2 = r2, diff --git a/R/subsample_functions.R b/R/subsample_functions.R index a9b0fdb..4a34973 100644 --- a/R/subsample_functions.R +++ b/R/subsample_functions.R @@ -12,6 +12,14 @@ get_sample_splits <- function(cluster_variable, 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) @@ -56,6 +64,20 @@ get_sample_splits <- function(cluster_variable, }#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) { @@ -96,6 +118,27 @@ merge_subsamples_byD <- function(subsamples_byD, D) { 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, @@ -113,8 +156,7 @@ get_crossfit_indices <- function(cluster_variable, stop(paste0("``subsamples`` must also be set when setting ", "``subsamples_byD``."), call. = FALSE) } else if (!is.null(subsamples) && is.null(subsamples_byD) && by_D) { - stop(paste0("When ``by_D==TRUE``, ``subsamples_byD`` must also be set ", - "when setting ``subsamples``."), call. = FALSE) + subsamples_byD <- derive_subsamples_byD(subsamples, D) }#IF # Compute crossfit indices @@ -370,22 +412,8 @@ get_cf_indices_simple <- function(cluster_variable, sample_folds, subsamples <- generate_subsamples(nobs, sample_folds) }#IFELSE - # Create subsamples_byD (optional) - subsamples_byD <- NULL - if (by_D) { - D_levels <- sort(unique(D)) - nD_levels <- length(D_levels) - subsamples_byD <- rep(list(NULL), nD_levels) - for (d in seq_len(nD_levels)) { - tmp_indx <- rep(NA, nobs) - is_Dd <- which(D == D_levels[d]) - 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 <- if (by_D) { + derive_subsamples_byD(subsamples, D) }#IF list(subsamples = subsamples, diff --git a/R/tidy.R b/R/tidy.R deleted file mode 100644 index ff47dde..0000000 --- a/R/tidy.R +++ /dev/null @@ -1,148 +0,0 @@ -#' @importFrom generics tidy -#' @export -generics::tidy - -#' @importFrom generics glance -#' @export -generics::glance - -#' Tidy a ddml Object -#' -#' Extracts coefficient estimates, standard errors, test -#' statistics, and p-values from a \code{ddml} estimator in a -#' format compatible with \pkg{modelsummary} and the -#' \pkg{broom} ecosystem. -#' -#' @param x A \code{ddml} object. -#' @param ensemble_idx Integer index of the ensemble type to -#' report. Defaults to 1 (first ensemble type). Set to -#' \code{NULL} to return results for all ensemble types. -#' @param conf.int Logical. Include confidence interval -#' columns? Default \code{FALSE}. -#' @param conf.level Confidence level for intervals. -#' Default 0.95. -#' @param type Character string specifying the -#' variance-covariance estimator. One of \code{"HC1"} -#' (default), \code{"HC0"}, or \code{"HC3"}. -#' @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}. If -#' \code{conf.int = TRUE}, also \code{conf.low} and -#' \code{conf.high}. -#' -#' @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", ...) { - type <- match.arg(type, c("HC1", "HC0", "HC3")) - - s <- summary(x, type = type) - inf <- s$coefficients - nensb <- dim(inf)[3] - p <- dim(inf)[1] - - if (is.null(ensemble_idx)) { - j_seq <- seq_len(nensb) - } else { - if (any(ensemble_idx < 1) || any(ensemble_idx > nensb)) { - stop(sprintf("ensemble_idx must be between 1 and %d", nensb), - call. = FALSE) - }#IF - j_seq <- ensemble_idx - }#IFELSE - - # Pre-allocate rows - n_rows <- length(j_seq) * p - term <- rep(dimnames(inf)[[1]], length(j_seq)) - ensemble_type <- rep(dimnames(inf)[[3]][j_seq], each = p) - - estimate <- numeric(n_rows) - std.error <- numeric(n_rows) - statistic <- numeric(n_rows) - 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, - ensemble_type = ensemble_type, - stringsAsFactors = FALSE - ) - - if (conf.int) { - z <- stats::qnorm((1 + conf.level) / 2) - res$conf.low <- res$estimate - z * res$std.error - res$conf.high <- res$estimate + z * res$std.error - }#IF - - res -}#TIDY.DDML - -#' Glance at a ddml Object -#' -#' Returns a one-row summary of model-level statistics, -#' compatible with \pkg{modelsummary} and the \pkg{broom} -#' ecosystem. -#' -#' @param x A \code{ddml} object. -#' @param ... Currently unused. -#' -#' @return A one-row \code{data.frame} with columns -#' \code{nobs}, \code{sample_folds}, \code{shortstack}, -#' \code{ensemble_type}, 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) -#' } -#' -#' @seealso \code{\link{tidy.ddml}}, -#' \code{\link{summary.ddml}} -#' -#' @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 \ No newline at end of file diff --git a/_pkgdown.yml b/_pkgdown.yml index 09d5429..134cce5 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 @@ -32,10 +39,10 @@ navbar: reference: - title: internal contents: - - ddml - - ddml-class + - ddml-package - matches("print") - matches("summary") + - matches("sub-") - title: Supported DDML Estimators contents: - ddml_plm @@ -48,16 +55,16 @@ reference: - title: Repeated Resampling contents: - ddml_replicate - - ddml_rep - title: internal contents: + - ddml-intro + - ddml + - ddml_rep - coef.ddml - confint.ddml - vcov.ddml - hatvalues.ddml - nobs.ddml - - "`$.ddml`" - - "`[.summary.ddml`" - tidy.ddml - glance.ddml - tidy.ddml_diagnostics diff --git a/tests/testthat/test-ddml_plm.R b/tests/testthat/test-ddml_plm.R index 043c7bf..5c0f3e7 100644 --- a/tests/testthat/test-ddml_plm.R +++ b/tests/testthat/test-ddml_plm.R @@ -297,29 +297,6 @@ test_that("ddml_plm computes with multiple ensemble types and multivariate D", { expect_equal(length(coef(ddml_plm_fit)), 15) })#TEST_THAT -test_that("ddml_plm backward-compat cv_subsamples_list works with message", { - nobs <- 200 - X <- cbind(1, matrix(rnorm(nobs * 5), nobs, 5)) - D <- rnorm(nobs) - y <- D + X %*% runif(6) + rnorm(nobs) - # Pre-generate splits - splits <- get_sample_splits(seq_len(nobs), - sample_folds = 3, cv_folds = 3) - learners <- list(list(what = ols), list(what = ols)) - # Call with deprecated cv_subsamples_list — should emit message + warning - expect_warning( - expect_message( - ddml_plm(y, D, X, - learners = learners, - ensemble_type = "ols", - sample_folds = 3, - splits = list(subsamples = splits$subsamples), - cv_subsamples_list = splits$cv_subsamples, - silent = TRUE), - "cv_subsamples_list has been renamed"), - "Deprecated split arguments detected") -})#TEST_THAT - test_that("ddml_plm computes with parallel", { skip_on_cran() skip_if_not_installed("parallel") @@ -334,13 +311,15 @@ test_that("ddml_plm computes with parallel", { res_seq <- ddml_plm(y, D, X, learners = learners, sample_folds = 3, - splits = list(subsamples = splits$subsamples), + 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(subsamples = splits$subsamples), + splits = list( + y_X = list(subsamples = splits$subsamples)), silent = TRUE, parallel = list(cores = 2)) expect_equal(coef(res_par), coef(res_seq)) @@ -362,8 +341,9 @@ test_that("ddml_plm fitted pass-through works", { ensemble_type = "average", sample_folds = 2, splits = list( - subsamples = presplits$subsamples, - cv_subsamples = presplits$cv_subsamples), + y_X = list( + subsamples = presplits$subsamples, + cv_subsamples = presplits$cv_subsamples)), silent = TRUE) # fitted should be stored with per-equation crossfit data @@ -414,9 +394,9 @@ test_that("ddml_plm pass-through with nnls/nnls1 reproduces exactly via cv_resid presplits <- get_sample_splits(seq_len(nobs), sample_folds = 2, cv_folds = 2) - splits <- list( - subsamples = presplits$subsamples, - cv_subsamples = presplits$cv_subsamples) + 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, @@ -456,9 +436,9 @@ test_that("ddml_plm pass-through with save_crossval = FALSE uses approximate pat presplits <- get_sample_splits(seq_len(nobs), sample_folds = 2, cv_folds = 2) - splits <- list( - subsamples = presplits$subsamples, - cv_subsamples = presplits$cv_subsamples) + 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, @@ -547,38 +527,3 @@ test_that("ddml_plm HC0/HC1/HC3 SEs close to sandwich::vcovHC on ols_fit", { info = "PLM HC3") })#TEST_THAT -test_that("ddml_plm legacy split args warn and still work", { - set.seed(101) - nobs <- 200 - X <- matrix(rnorm(nobs * 4), nobs, 4) - D <- X %*% c(1, 0.5, 0.2, 0) + rnorm(nobs) - y <- D + X %*% c(0.3, 0.1, 0.4, 0.2) + rnorm(nobs) - learners <- list(what = ols) - splits <- get_sample_splits(seq_len(nobs), - sample_folds = 3, - cv_folds = 3) - fit_splits <- ddml_plm( - y, D, X, - learners = learners, - sample_folds = 3, - cv_folds = 3, - splits = list( - subsamples = splits$subsamples, - cv_subsamples = splits$cv_subsamples - ), - silent = TRUE - ) - expect_warning( - fit_legacy <- ddml_plm( - y, D, X, - learners = learners, - sample_folds = 3, - cv_folds = 3, - subsamples = splits$subsamples, - cv_subsamples = splits$cv_subsamples, - silent = TRUE - ), - "Deprecated split arguments detected" - ) - expect_equal(coef(fit_legacy), coef(fit_splits), tolerance = 1e-8) -}) From cd5e88d34ead4a3063d2f6e10ef2fac7574ad747 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Tue, 10 Mar 2026 11:54:00 -0500 Subject: [PATCH 24/46] new fitted + refactor help funs --- R/crosspred.R | 3 +- R/ddml_apo.R | 28 +++------ R/ddml_ate.R | 19 +----- R/ddml_att.R | 120 +++++++++++++++++++------------------- R/ddml_fpliv.R | 45 +++++---------- R/ddml_late.R | 18 +----- R/ddml_pliv.R | 41 +++++-------- R/ddml_plm.R | 35 ++++------- R/ensemble.R | 16 +++-- R/get_CEF.R | 21 +++++-- R/help_functions.R | 141 +++++++++++++++++++-------------------------- 11 files changed, 203 insertions(+), 284 deletions(-) diff --git a/R/crosspred.R b/R/crosspred.R index 6a70c23..e05982e 100644 --- a/R/crosspred.R +++ b/R/crosspred.R @@ -224,12 +224,13 @@ crosspred <- function(y, X, auxiliary_fitted_bylearner[[k]] <- res$auxiliary_fitted_bylearner_k }#FOR - # Assign dimnames to weights + # Assign dimnames to weights and cf_fitted if (calc_ensemble) { wnames <- fold_results[[1]]$weight_colnames dimnames(weights) <- list( NULL, wnames, paste("sample fold ", seq_len(sample_folds))) + colnames(cf_fitted) <- wnames }#IF # Compute per-learner OOS residuals diff --git a/R/ddml_apo.R b/R/ddml_apo.R index e26de80..93ed920 100644 --- a/R/ddml_apo.R +++ b/R/ddml_apo.R @@ -121,15 +121,14 @@ ddml_apo <- function(y, D, X, cluster_variable = cluster_variable, require_binary_D = TRUE) validate_custom_weights(custom_ensemble_weights, learners) - validate_custom_weights(custom_ensemble_weights_DX, - learners_DX) + 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, !shortstack) + validate_fitted_splits_pair(fitted, splits) indxs <- get_sample_splits( cluster_variable = cluster_variable, sample_folds = sample_folds, @@ -140,17 +139,8 @@ ddml_apo <- function(y, D, X, check_subsamples(indxs$subsamples, indxs$subsamples_byD, stratify, D_ind) - # Prepare paralllelization and estimation start t0 <- proc.time()[3] - 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(messages, parallel, silent) # == Reduced-form estimation ====================================== @@ -183,9 +173,9 @@ ddml_apo <- function(y, D, X, parallel = parallel, fitted = fitted$y_X) - ensb_info <- update_ensemble_info(y_X_res$weights, D_X_res$cf_fitted) - ensemble_type <- ensb_info$ensemble_type - nensb <- ensb_info$nensb + ensemble_type <- y_X_res$ensemble_type + nensb <- if (is.null(ensemble_type)) 1L + else length(ensemble_type) # == Score construction =========================================== @@ -232,11 +222,7 @@ ddml_apo <- function(y, D, X, # == Output ======================================================= - 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(t0, messages, silent) ddml( coefficients = coef, diff --git a/R/ddml_ate.R b/R/ddml_ate.R index 3b861fe..f5c60d3 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -134,7 +134,7 @@ ddml_ate <- function(y, D, X, nobs <- length(y) - validate_fitted_splits_pair(fitted, splits, !shortstack) + validate_fitted_splits_pair(fitted, splits) indxs <- get_sample_splits( cluster_variable = cluster_variable, @@ -153,16 +153,7 @@ ddml_ate <- function(y, D, X, stratify, D) t0 <- proc.time()[3] - 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(messages, parallel, silent) # == Reduced-form estimation ====================================== @@ -254,11 +245,7 @@ ddml_ate <- function(y, D, X, # == Output ======================================================= - 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(t0, messages, silent) ddml( coefficients = coef, diff --git a/R/ddml_att.R b/R/ddml_att.R index 3c1fb34..746edae 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -26,7 +26,8 @@ ddml_att <- function(y, D, X, dots <- list(...) messages <- resolve_messages(dots, "ddml_att", list( y_D0 = "E[Y|D=0,X]", - D_X = "E[D|X]")) + D_X = "E[D|X]", + D = "E[D]")) validate_inputs(y = y, D = D, X = X, learners = learners, sample_folds = sample_folds, @@ -40,7 +41,7 @@ ddml_att <- function(y, D, X, nobs <- length(y) - validate_fitted_splits_pair(fitted, splits, !shortstack) + validate_fitted_splits_pair(fitted, splits) indxs <- get_sample_splits( cluster_variable = cluster_variable, @@ -59,15 +60,7 @@ ddml_att <- function(y, D, X, stratify, D) t0 <- proc.time()[3] - 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(messages, parallel, silent) # == Reduced-form estimation ====================================== @@ -84,37 +77,38 @@ ddml_att <- function(y, D, X, parallel = parallel, fitted = fitted$D_X) - # E[Y|D=0,X] via ddml_apo(d=0) - # Swap byD indices: apo uses D_ind = 1*(D==0), so byD - # levels are reversed relative to the ATT's D. - shared_splits <- list(subsamples = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples) - apo_splits_0 <- list( - y_X = list(subsamples = indxs$subsamples_byD[[1]], - cv_subsamples = indxs$cv_subsamples_byD[[1]]), - D_X = shared_splits) - - # Pre-ensembled propensity: P(D=0|X) = 1 - E[D|X] - fitted_D_X_0 <- list( - cf_fitted = 1 - D_X_res$cf_fitted) - - 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 = "")) - - ensemble_type <- apo_0$ensemble_type - nensb <- ncol(apo_0$coefficients) + # E[D] (unconditional treatment probability, cross-fitted) + D_res <- get_CEF(D, matrix(1, nobs, 1), + learners = list(what = ols, + args = list(const = FALSE)), + ensemble_type = "average", + shortstack = FALSE, + 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 =========================================== @@ -123,20 +117,19 @@ ddml_att <- function(y, D, X, # observations per fold, where the D=0 model must extrapolate. g_X_D0 <- extrapolate_CEF( D = D, - CEF_res_byD = list(list( - fit = apo_0$fitted$y_X, d = 0)), + 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) - p <- mean(D) + 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 - - m_X_tr * (1 - D_mat) * (y_mat - g_X_D0) / - (p * (1 - m_X_tr)) + 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 psi_b <- lapply(seq_len(nensb), function(j) psi_b_mat[, j, drop = FALSE]) psi_a <- lapply(seq_len(nensb), function(j) array(psi_a_vec, dim = c(nobs, 1, 1))) @@ -159,21 +152,20 @@ ddml_att <- function(y, D, X, # == Output ======================================================= - 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(t0, messages, silent) ddml( coefficients = coef, ensemble_weights = list( - y_X_D0 = apo_0$ensemble_weights$y_X, - D_X = D_X_res$weights), - mspe = list(y_X_D0 = apo_0$mspe$y_X, - D_X = D_X_res$mspe), - r2 = list(y_X_D0 = apo_0$r2$y_X, - D_X = D_X_res$r2), + 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), psi_a = psi_a, psi_b = psi_b, scores = scores, J = J, coef_names = coef_names, @@ -186,8 +178,11 @@ ddml_att <- function(y, D, X, shortstack = shortstack, cluster_variable = cluster_variable, fitted = list( - y_X_D0 = apo_0$fitted$y_X, - D_X = build_fitted_entry(D_X_res, save_crossval)), + 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]], @@ -196,6 +191,9 @@ ddml_att <- function(y, D, X, 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, diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index 9941435..c344d96 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -108,7 +108,7 @@ ddml_fpliv <- function(y, D, Z, X, D <- as.matrix(D) nD <- ncol(D) - validate_fitted_splits_pair(fitted, splits, !shortstack) + validate_fitted_splits_pair(fitted, splits) indxs <- get_sample_splits( cluster_variable = cluster_variable, @@ -119,16 +119,7 @@ ddml_fpliv <- function(y, D, Z, X, check_subsamples(indxs$subsamples, NULL, stratify = FALSE) t0 <- proc.time()[3] - 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(messages, parallel, silent) # == Reduced-form estimation ====================================== @@ -158,8 +149,8 @@ ddml_fpliv <- function(y, D, Z, X, l$assign_X <- c(ax, nX + az) l$assign_Z <- NULL l - }) - } + })#LAPPLY + }#IF D_XZ_res_list <- compute_CEF_list( D, XZ, learners = learners_DXZ, ensemble_type = ensemble_type, @@ -170,7 +161,7 @@ ddml_fpliv <- function(y, D, Z, X, silent = silent, label_prefix = "E[D", label_suffix = "|X,Z]", parallel = parallel, - fitted = fitted$D_XZ) + fitted = unname(fitted[paste0("D", seq_len(nD), "_XZ")])) # E[D|X] D_X_res_list <- compute_CEF_list( @@ -183,11 +174,11 @@ ddml_fpliv <- function(y, D, Z, X, silent = silent, label_prefix = "E[D", label_suffix = "|X]", parallel = parallel, - fitted = fitted$D_X) + fitted = unname(fitted[paste0("D", seq_len(nD), "_X")])) - ensb_info <- update_ensemble_info(y_X_res$weights) - ensemble_type <- ensb_info$ensemble_type - nensb <- ensb_info$nensb + ensemble_type <- y_X_res$ensemble_type + nensb <- if (is.null(ensemble_type)) 1L + else length(ensemble_type) # == Score construction =========================================== @@ -258,11 +249,7 @@ ddml_fpliv <- function(y, D, Z, X, r2[[eq]] <- D_XZ_res_list[[k]]$r2 }#FOR - 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(t0, messages, silent) ddml( coefficients = coef, @@ -279,12 +266,12 @@ ddml_fpliv <- function(y, D, Z, X, 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), - D_XZ = build_fitted_from_list(D_XZ_res_list, - save_crossval), - D_X = build_fitted_from_list(D_X_res_list, - save_crossval)), + 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 = setNames( rep(list(list(subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples)), diff --git a/R/ddml_late.R b/R/ddml_late.R index d78f077..7eaca32 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -153,7 +153,7 @@ ddml_late <- function(y, D, Z, X, nobs <- length(y) - validate_fitted_splits_pair(fitted, splits, !shortstack) + validate_fitted_splits_pair(fitted, splits) indxs <- get_sample_splits( cluster_variable = cluster_variable, @@ -172,15 +172,7 @@ ddml_late <- function(y, D, Z, X, stratify, Z) t0 <- proc.time()[3] - 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(messages, parallel, silent) # == Reduced-form estimation ====================================== @@ -279,11 +271,7 @@ ddml_late <- function(y, D, Z, X, # == Output ======================================================= - 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(t0, messages, silent) ddml( coefficients = coef, diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index bcfc382..854cc3a 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -110,7 +110,7 @@ ddml_pliv <- function(y, D, Z, X, Z <- as.matrix(Z) nZ <- ncol(Z) - validate_fitted_splits_pair(fitted, splits, !shortstack) + validate_fitted_splits_pair(fitted, splits) indxs <- get_sample_splits( cluster_variable = cluster_variable, @@ -121,16 +121,7 @@ ddml_pliv <- function(y, D, Z, X, check_subsamples(indxs$subsamples, NULL, stratify = FALSE) t0 <- proc.time()[3] - 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(messages, parallel, silent) # == Reduced-form estimation ====================================== @@ -158,7 +149,7 @@ ddml_pliv <- function(y, D, Z, X, silent = silent, label_prefix = "E[Z", label_suffix = "|X]", parallel = parallel, - fitted = fitted$Z_X) + fitted = unname(fitted[paste0("Z", seq_len(nZ), "_X")])) # E[D|X] D_X_res_list <- compute_CEF_list( @@ -171,11 +162,11 @@ ddml_pliv <- function(y, D, Z, X, silent = silent, label_prefix = "E[D", label_suffix = "|X]", parallel = parallel, - fitted = fitted$D_X) + fitted = unname(fitted[paste0("D", seq_len(nD), "_X")])) - ensb_info <- update_ensemble_info(y_X_res$weights) - ensemble_type <- ensb_info$ensemble_type - nensb <- ensb_info$nensb + ensemble_type <- y_X_res$ensemble_type + nensb <- if (is.null(ensemble_type)) 1L + else length(ensemble_type) # == Score construction =========================================== @@ -242,11 +233,7 @@ ddml_pliv <- function(y, D, Z, X, r2[[eq]] <- Z_X_res_list[[k]]$r2 }#FOR - 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(t0, messages, silent) ddml( coefficients = coef, @@ -263,12 +250,12 @@ ddml_pliv <- function(y, D, Z, X, 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), - D_X = build_fitted_from_list(D_X_res_list, - save_crossval), - Z_X = build_fitted_from_list(Z_X_res_list, - save_crossval)), + 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 = setNames( rep(list(list(subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples)), diff --git a/R/ddml_plm.R b/R/ddml_plm.R index 9450a07..b4441a1 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -130,7 +130,7 @@ ddml_plm <- function(y, D, X, D <- as.matrix(D) nD <- ncol(D) - validate_fitted_splits_pair(fitted, splits, !shortstack) + validate_fitted_splits_pair(fitted, splits) indxs <- get_sample_splits( cluster_variable = cluster_variable, @@ -141,16 +141,7 @@ ddml_plm <- function(y, D, X, check_subsamples(indxs$subsamples, NULL, stratify = FALSE) t0 <- proc.time()[3] - 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(messages, parallel, silent) # == Reduced-form estimation ====================================== @@ -177,11 +168,11 @@ ddml_plm <- function(y, D, X, silent = silent, label_prefix = "E[D", label_suffix = "|X]", parallel = parallel, - fitted = fitted$D_X) + fitted = unname(fitted[paste0("D", seq_len(nD), "_X")])) - ensb_info <- update_ensemble_info(y_X_res$weights) - ensemble_type <- ensb_info$ensemble_type - nensb <- ensb_info$nensb + ensemble_type <- y_X_res$ensemble_type + nensb <- if (is.null(ensemble_type)) 1L + else length(ensemble_type) # == Score construction =========================================== @@ -232,11 +223,7 @@ ddml_plm <- function(y, D, X, r2[[eq]] <- D_X_res_list[[k]]$r2 }#FOR - 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(t0, messages, silent) ddml( coefficients = coef, @@ -253,10 +240,10 @@ ddml_plm <- function(y, D, X, 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), - D_X = build_fitted_from_list(D_X_res_list, - save_crossval)), + 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 = setNames( rep(list(list(subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples)), diff --git a/R/ensemble.R b/R/ensemble.R index 1214655..6c5b92a 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -165,8 +165,12 @@ predict.ensemble <- function(object, newdata, ...){ #' @param type A character string or vector indicating the type(s) of ensemble #' weights to compute. Default is \code{"average"}. -#' @param learners A list of base learners. See -#' \code{\link{ddml-intro}} for the full specification. +#' @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. @@ -199,14 +203,18 @@ predict.ensemble <- function(object, newdata, ...){ #' } ensemble_weights <- function(y, X, type = "average", - learners, + learners = NULL, cv_folds = 5, cv_subsamples = NULL, cv_results = NULL, custom_weights = NULL, silent = FALSE) { # Data parameters - nlearners <- length(learners) + nlearners <- if (!is.null(cv_results)) { + ncol(cv_results$cv_resid) + } else { + length(learners) + } ncustom <- ncol(custom_weights) ncustom <- ifelse(is.null(ncustom), 0, ncustom) ntype <- length(type) diff --git a/R/get_CEF.R b/R/get_CEF.R index 8bfb4dd..a8006b0 100644 --- a/R/get_CEF.R +++ b/R/get_CEF.R @@ -51,7 +51,10 @@ get_CEF <- function(y, X, if (!is.null(fitted$cf_fitted)) { # Rule 1: pre-ensembled predictions, use directly res <- list(cf_fitted = fitted$cf_fitted, - weights = NULL, mspe = NULL, r2 = NULL, + 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, @@ -85,7 +88,9 @@ get_CEF <- function(y, X, return(list( cf_fitted = matrix(constant_val, n, nensb), - weights = NULL, mspe = NULL, r2 = NULL, + 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, @@ -121,8 +126,16 @@ get_CEF <- function(y, X, parallel = parallel) }#IFELSE - # Return estimates - return(res) + # 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 + + res }#GET_CEF # Extrapolate CEF predictions across treatment levels. diff --git a/R/help_functions.R b/R/help_functions.R index a3d02cf..b31b782 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -24,6 +24,29 @@ resolve_messages <- function(dots, name, labels = list()) { 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 @@ -123,9 +146,6 @@ build_CEF_from_crossfit <- function(y, cf_fitted_bylearner_eq, auxiliary_fitted_bylearner = NULL) { nobs <- length(y) cf <- as.matrix(cf_fitted_bylearner_eq) - nlearners <- ncol(cf) - dummy_learners <- lapply(seq_len(nlearners), - function(i) list(what = identity)) cf_resid_bylearner <- drop(y) - cf mspe <- colMeans(cf_resid_bylearner^2) @@ -133,8 +153,10 @@ build_CEF_from_crossfit <- function(y, cf_fitted_bylearner_eq, if (!is.null(cv_resid_byfold) && !is.null(cv_resid_byfold[[1]]) && !is.null(subsamples)) { K <- length(subsamples) - nensb <- NULL - cf_fitted <- matrix(0, nobs, 1) + ncustom <- if (!is.null(custom_ensemble_weights)) + ncol(custom_ensemble_weights) else 0L + 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]]) @@ -144,19 +166,14 @@ build_CEF_from_crossfit <- function(y, cf_fitted_bylearner_eq, ew_k <- ensemble_weights( y[train_idx], cf[train_idx, ], type = ensemble_type, - learners = dummy_learners, cv_results = fakecv_k, custom_weights = custom_ensemble_weights, silent = TRUE) all_weights[[k]] <- ew_k$weights - if (is.null(nensb)) nensb <- ncol(ew_k$weights) - if (ncol(cf_fitted) < nensb) { - cf_fitted <- matrix(0, nobs, nensb) - }#IF cf_fitted[subsamples[[k]], ] <- cf[subsamples[[k]], ] %*% ew_k$weights }#FOR - weights <- array(0, dim = c(nlearners, nensb, K)) + 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))) @@ -165,7 +182,6 @@ build_CEF_from_crossfit <- function(y, cf_fitted_bylearner_eq, mspe = mspe) ew <- ensemble_weights( y, cf, type = ensemble_type, - learners = dummy_learners, cv_results = fakecv, custom_weights = custom_ensemble_weights, silent = TRUE) @@ -173,38 +189,18 @@ build_CEF_from_crossfit <- function(y, cf_fitted_bylearner_eq, cf_fitted <- cf %*% weights }#IFELSE - ens_names <- if (length(dim(weights)) == 3) { - colnames(weights[, , 1]) - } else { - colnames(weights) - } + ens_names <- colnames(weights) if (!is.null(ens_names)) colnames(cf_fitted) <- ens_names - # Fold-level auxiliary predictions (ATE/ATT/LATE extrapolation) - auxiliary_fitted <- NULL - if (!is.null(auxiliary_fitted_bylearner)) { - K <- length(auxiliary_fitted_bylearner) - auxiliary_fitted <- vector("list", K) - if (length(dim(weights)) == 3) { - for (k in seq_len(K)) { - auxiliary_fitted[[k]] <- - as.matrix(auxiliary_fitted_bylearner[[k]]) %*% - weights[, , k] - }#FOR - } else { - for (k in seq_len(K)) { - auxiliary_fitted[[k]] <- - as.matrix(auxiliary_fitted_bylearner[[k]]) %*% - weights - }#FOR - }#IFELSE - }#IF + auxiliary_fitted <- extrapolate_auxiliary( + auxiliary_fitted_bylearner, weights) y_var <- as.numeric(stats::var(y)) r2 <- if (y_var > 0) 1 - mspe / y_var else rep(NA_real_, length(mspe)) list(cf_fitted = cf_fitted, weights = weights, + ensemble_type = ens_names, mspe = mspe, r2 = r2, auxiliary_fitted = auxiliary_fitted, @@ -213,8 +209,22 @@ build_CEF_from_crossfit <- function(y, cf_fitted_bylearner_eq, cv_resid_byfold = cv_resid_byfold) }#BUILD_CEF_FROM_CROSSFIT -validate_fitted_splits_pair <- function(fitted, splits, - w_cv = FALSE) { +# 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 ", @@ -238,27 +248,20 @@ build_fitted_entry <- function(res, save_crossval, entry }#BUILD_FITTED_ENTRY -build_fitted_from_list <- function(res_list, save_crossval) { - lapply(res_list, build_fitted_entry, - save_crossval = save_crossval) -}#BUILD_FITTED_FROM_LIST +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 get_cf_resid_bylearner_for_eq <- function(fitted, eq) { entry <- fitted[[eq]] - if (!is.null(entry) && !is.null(entry$cf_resid_bylearner)) { - return(entry$cf_resid_bylearner) - }#IF - m <- regmatches(eq, regexec("^([A-Za-z]+)(\\d+)(_\\w+)$", - eq))[[1]] - if (length(m) == 4) { - group <- paste0(m[2], m[4]) - idx <- as.integer(m[3]) - entry <- fitted[[group]] - if (is.list(entry) && length(entry) >= idx) { - return(entry[[idx]]$cf_resid_bylearner) - }#IF - }#IF - NULL + if (!is.null(entry)) entry$cf_resid_bylearner else NULL }#GET_CF_RESID_BYLEARNER_FOR_EQ # Validate common arguments for S3 inference methods. @@ -411,32 +414,6 @@ validate_custom_weights <- function(custom_weights, learners) { } }#VALIDATE_CUSTOM_WEIGHTS -# Compute ncustom and nensb from ensemble config. -compute_ncustom_nensb <- function(ensemble_type, - custom_ensemble_weights) { - ncustom <- ncol(custom_ensemble_weights) - ncustom <- if (is.null(ncustom)) 0L else ncustom - nensb <- length(ensemble_type) + ncustom - list(ncustom = ncustom, nensb = nensb) -}#COMPUTE_NCUSTOM_NENSB - -# Update ensemble info from CEF result weights or cf_fitted. -update_ensemble_info <- function(res_weights = NULL, - cf_fitted = NULL) { - if (!is.null(res_weights)) { - ensemble_type <- dimnames(res_weights)[[2]] - } else if (!is.null(cf_fitted)) { - ensemble_type <- colnames(as.matrix(cf_fitted)) - } else { - ensemble_type <- NULL - }#IFELSE - nensb <- if (is.null(ensemble_type)) 1L - else length(ensemble_type) - multiple_ensembles <- nensb > 1 - list(ensemble_type = ensemble_type, nensb = nensb, - multiple_ensembles = multiple_ensembles) -}#UPDATE_ENSEMBLE_INFO - # Compute CEF for each column of M, collecting results in a list. compute_CEF_list <- function(M, X, learners, ensemble_type, From 09213b61ac830ef0f709e594c4ee84291e44d406 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Tue, 10 Mar 2026 12:02:04 -0500 Subject: [PATCH 25/46] simplify ate, late --- R/ddml_ate.R | 36 ++++++++------------------- R/ddml_late.R | 69 ++++++++++++++------------------------------------- 2 files changed, 30 insertions(+), 75 deletions(-) diff --git a/R/ddml_ate.R b/R/ddml_ate.R index f5c60d3..5348fa5 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -157,19 +157,6 @@ ddml_ate <- function(y, D, X, # == Reduced-form estimation ====================================== - # 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 = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples, - silent = silent, label = messages$D_X, - parallel = parallel, - fitted = fitted$D_X) - shared_splits <- list(subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples) apo_splits_1 <- list( @@ -181,12 +168,7 @@ ddml_ate <- function(y, D, X, cv_subsamples = indxs$cv_subsamples_byD[[1]]), D_X = shared_splits) - # Pre-ensembled propensity for ddml_apo delegation. - # For d=0, flip: P(D=0|X) = 1 - P(D=1|X). - fitted_D_X_1 <- list(cf_fitted = D_X_res$cf_fitted) - fitted_D_X_0 <- list(cf_fitted = 1 - D_X_res$cf_fitted) - - # E[g(1,X)] via ddml_apo + # 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, @@ -198,9 +180,13 @@ ddml_ate <- function(y, D, X, trim = trim, parallel = parallel, silent = silent, splits = apo_splits_1, fitted = list(y_X = fitted$y_X_D1, - D_X = fitted_D_X_1), + D_X = fitted$D_X), messages = list(start = "", finish = "", - y_X = messages$y_D1, D_X = "")) + y_X = messages$y_D1, + D_X = messages$D_X)) + + # 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) # E[g(0,X)] via ddml_apo apo_0 <- ddml_apo( @@ -252,13 +238,13 @@ ddml_ate <- function(y, D, X, ensemble_weights = list( y_X_D0 = apo_0$ensemble_weights$y_X, y_X_D1 = apo_1$ensemble_weights$y_X, - D_X = D_X_res$weights), + 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 = D_X_res$mspe), + 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 = D_X_res$r2), + D_X = apo_1$r2$D_X), psi_a = psi_a, psi_b = psi_b, scores = scores, J = J, coef_names = coef_names, @@ -272,7 +258,7 @@ ddml_ate <- function(y, D, X, fitted = list( y_X_D0 = apo_0$fitted$y_X, y_X_D1 = apo_1$fitted$y_X, - D_X = build_fitted_entry(D_X_res, save_crossval)), + D_X = apo_1$fitted$D_X), splits = list( y_X_D0 = list( subsamples = indxs$subsamples_byD[[1]], diff --git a/R/ddml_late.R b/R/ddml_late.R index 7eaca32..814e59b 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -155,54 +155,22 @@ ddml_late <- function(y, D, Z, X, validate_fitted_splits_pair(fitted, splits) - indxs <- get_sample_splits( - cluster_variable = cluster_variable, - sample_folds = sample_folds, - cv_folds = cv_folds, - D = Z, stratify = stratify, - subsamples = splits$Z_X$subsamples, - subsamples_byD = list( - splits$y_X_Z0$subsamples, - splits$y_X_Z1$subsamples), - cv_subsamples = splits$Z_X$cv_subsamples, - cv_subsamples_byD = list( - splits$y_X_Z0$cv_subsamples, - splits$y_X_Z1$cv_subsamples)) - check_subsamples(indxs$subsamples, indxs$subsamples_byD, - stratify, Z) - t0 <- proc.time()[3] announce_start(messages, parallel, silent) # == Reduced-form estimation ====================================== - # 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 = indxs$subsamples, - cv_subsamples = indxs$cv_subsamples, - silent = silent, label = messages$Z_X, - parallel = parallel, - fitted = fitted$Z_X) - - splits_Z <- 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)) - - fitted_Z_X <- build_fitted_entry(Z_X_res, save_crossval) + # 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) - # Second stage: Y ~ Z via ddml_ate + # Reduced form: Y ~ Z via ddml_ate ate_rf <- ddml_ate( y = y, D = Z, X = X, learners = learners, learners_DX = learners_ZX, @@ -211,17 +179,17 @@ ddml_late <- function(y, D, Z, X, 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 = splits_Z, - fitted = list(y_X_D0 = fitted$y_X_Z0, - y_X_D1 = fitted$y_X_Z1, - D_X = fitted_Z_X), + 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 = "")) + y_D0 = messages$y_Z0, + D_X = messages$Z_X)) - # First stage: D ~ Z via ddml_ate + # 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, @@ -230,11 +198,12 @@ ddml_late <- function(y, D, Z, X, 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 = splits_Z, + splits = ate_rf$splits, fitted = list(y_X_D0 = fitted$D_X_Z0, y_X_D1 = fitted$D_X_Z1, - D_X = fitted_Z_X), + D_X = ate_rf$fitted$D_X), save_crossval = save_crossval, messages = list(start = "", finish = "", y_D1 = messages$D_Z1, From 35ffcfa52182cf737c3b947c652f920c8a62073c Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Tue, 10 Mar 2026 13:14:09 -0500 Subject: [PATCH 26/46] refactor crossfit internals --- R/crosspred.R | 164 ++++++++++--------------------------- R/crossval.R | 61 +++----------- R/ddml_fpliv.R | 53 +++++++----- R/ddml_pliv.R | 52 +++++++----- R/ddml_plm.R | 28 ++++--- R/ensemble.R | 200 +++++++++++++++++++++++++-------------------- R/get_CEF.R | 14 ++-- R/help_functions.R | 84 +++++++++---------- R/parallel.R | 27 ++++++ R/shortstacking.R | 30 +++---- 10 files changed, 329 insertions(+), 384 deletions(-) diff --git a/R/crosspred.R b/R/crosspred.R index e05982e..12439bd 100644 --- a/R/crosspred.R +++ b/R/crosspred.R @@ -123,12 +123,6 @@ crosspred <- function(y, X, silent = FALSE, auxiliary_X = NULL, parallel = NULL) { - # Unpack parallel options - p <- parse_parallel(parallel) - num_cores <- p$num_cores - parallel_export <- p$export - parallel_packages <- p$packages - # Backward compatibility for renamed parameter if (!is.null(cv_subsamples_list)) { if (!is.null(cv_subsamples)) @@ -138,19 +132,12 @@ crosspred <- function(y, X, cv_subsamples <- cv_subsamples_list }#IF - # Normalize learner specs before parallel dispatch - learners <- normalize_learners(learners) - # Data parameters nobs <- nrow(X) - nlearners <- length(learners) - calc_ensemble <- !is_single_learner(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 - # Check whether ddml uses conventional stacking w/ data driven weights - w_cv <- any(ensemble_type %in% c("nnls", "nnls1", "singlebest", "ols")) & - (!is.function(learners[[1]])) # Create crossfitting and cv tuples indxs <- get_sample_splits(cluster_variable = cluster_variable, @@ -161,7 +148,10 @@ crosspred <- function(y, X, 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 + cv_folds <- if (!is.null(cv_subsamples)) + length(cv_subsamples[[1]]) else 0L + if (cv_folds == 0L) + cv_subsamples <- rep(list(NULL), sample_folds) # Dispatch fold computation fold_fun <- function(k) { @@ -173,42 +163,18 @@ crosspred <- function(y, X, ensemble_type = ensemble_type, cv_folds = cv_folds, custom_ensemble_weights = custom_ensemble_weights, - calc_ensemble = calc_ensemble, nensb = nensb, nlearners = nlearners, auxiliary_X = auxiliary_X) }#FOLD_FUN - cl <- NULL - if (num_cores > 1) { - cl <- tryCatch( - setup_parallel_cluster(num_cores, parallel_export, - parallel_packages), - error = function(e) { - warning("Parallel setup failed: ", - conditionMessage(e), - ". Falling back to sequential.", - call. = FALSE) - NULL - } - ) - if (!is.null(cl)) - on.exit(parallel::stopCluster(cl), add = TRUE) - }#IF - - if (silent) { - op <- pbapply::pboptions(type = "none") - on.exit(pbapply::pboptions(op), add = TRUE) - }#IF - fold_results <- pbapply::pblapply(seq_len(sample_folds), - fold_fun, cl = cl) + fold_results <- with_parallel(sample_folds, fold_fun, + parallel, silent) # Assemble results from fold_results list - cf_fitted <- matrix(0, nobs, nensb^(calc_ensemble)) + 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_inner <- matrix(0, nlearners^(calc_ensemble), sample_folds) - colnames(mspe_inner) <- paste("sample fold ", seq_len(sample_folds)) weights <- array(0, dim = c(nlearners, nensb, sample_folds)) cv_resid_byfold <- rep(list(NULL), sample_folds) @@ -216,7 +182,6 @@ crosspred <- function(y, X, k <- res$k cf_fitted[res$test_indices, ] <- res$cf_fitted_rows if (!is.null(res$weights_k)) weights[, , k] <- res$weights_k - if (!is.null(res$mspe_k)) mspe_inner[, k] <- res$mspe_k cv_resid_byfold[[k]] <- res$cv_resid_byfold_k auxiliary_fitted[[k]] <- res$auxiliary_fitted_k cf_fitted_bylearner[res$test_indices, ] <- @@ -225,25 +190,21 @@ crosspred <- function(y, X, }#FOR # Assign dimnames to weights and cf_fitted - if (calc_ensemble) { - wnames <- fold_results[[1]]$weight_colnames - dimnames(weights) <- list( - NULL, wnames, - paste("sample fold ", seq_len(sample_folds))) - colnames(cf_fitted) <- wnames - }#IF + wnames <- fold_results[[1]]$weight_colnames + dimnames(weights) <- list( + NULL, wnames, + paste("sample fold ", seq_len(sample_folds))) + colnames(cf_fitted) <- wnames # Compute per-learner OOS residuals cf_resid_bylearner <- drop(y) - cf_fitted_bylearner # Per-learner OOS mspe and r-squared (always available) - mspe <- colMeans(cf_resid_bylearner^2) - y_var <- as.numeric(stats::var(y)) - r2 <- if (y_var > 0) 1 - mspe / y_var else - rep(NA_real_, length(mspe)) + oos_stats <- compute_mspe_r2(cf_resid_bylearner, y) + mspe <- oos_stats$mspe + r2 <- oos_stats$r2 # Organize and return output - if (!calc_ensemble) weights <- cv_resid_byfold <- NULL output <- list(cf_fitted = cf_fitted, weights = weights, mspe = mspe, r2 = r2, cv_resid_byfold = cv_resid_byfold, @@ -257,93 +218,52 @@ crosspred <- function(y, X, crosspred_compute_fold <- function( k, y, X, learners, subsamples, cv_subsamples_k, ensemble_type, cv_folds, custom_ensemble_weights, - calc_ensemble, nensb, nlearners, - auxiliary_X) { + nensb, nlearners, auxiliary_X) { test_idx <- subsamples[[k]] train_idx <- -test_idx - if (!calc_ensemble) { - learners$args$X <- X[train_idx, ] - learners$args$y <- y[train_idx] - mdl_fit <- do.call(do.call, learners) - cf_fitted_rows <- - as.numeric(stats::predict(mdl_fit, - X[test_idx, ])) - } else { - 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])) - }#IFELSE + # 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 <- if (calc_ensemble) mdl_fit$weights else NULL - mspe_k <- if (calc_ensemble && - !is.null(mdl_fit$cv_results)) { - mdl_fit$cv_results$mspe - } else { - NULL - } - r2_k <- if (calc_ensemble && - !is.null(mdl_fit$cv_results)) { - mdl_fit$cv_results$r2 - } else { - NULL - } - cv_resid_byfold_k <- if (calc_ensemble && - !is.null(mdl_fit$cv_results)) { + weights_k <- mdl_fit$weights + cv_resid_byfold_k <- if (!is.null(mdl_fit$cv_results)) { mdl_fit$cv_results$cv_resid - } else { - NULL - } - weight_colnames <- if (calc_ensemble) { - colnames(mdl_fit$weights) - } else { - NULL } + 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]]) + 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 (!calc_ensemble) { - cf_fitted_bylearner_rows <- matrix(cf_fitted_rows, ncol = 1) - if (!is.null(auxiliary_X)) { - auxiliary_fitted_bylearner_k <- matrix(auxiliary_fitted_k, - ncol = 1) - }#IF - } else { - mdl_fit_bylearner <- mdl_fit - mdl_fit_bylearner$weights <- diag(1, nlearners) - cf_fitted_bylearner_rows <- stats::predict( - mdl_fit_bylearner, - newdata = X[test_idx, , drop = FALSE] - ) - if (!is.null(auxiliary_X)) { - auxiliary_fitted_bylearner_k <- stats::predict( - mdl_fit_bylearner, - auxiliary_X[[k]] - ) - }#IF - }#IFELSE + 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, - mspe_k = mspe_k, - r2_k = r2_k, cv_resid_byfold_k = cv_resid_byfold_k, weight_colnames = weight_colnames, auxiliary_fitted_k = auxiliary_fitted_k, diff --git a/R/crossval.R b/R/crossval.R index 78205d5..3d95613 100644 --- a/R/crossval.R +++ b/R/crossval.R @@ -103,12 +103,6 @@ crossval <- function(y, X, cv_subsamples = NULL, silent = FALSE, parallel = NULL) { - # Unpack parallel options - p <- parse_parallel(parallel) - num_cores <- p$num_cores - parallel_export <- p$export - parallel_packages <- p$packages - # Normalize learner specs before parallel dispatch learners <- normalize_learners(learners) @@ -130,8 +124,8 @@ crossval <- function(y, X, # Define the computation function cv_fun <- function(x) { - j <- ceiling(x / cv_folds) - i <- x - cv_folds * (ceiling(x / cv_folds) - 1) + j <- (x - 1) %/% cv_folds + 1 + i <- (x - 1) %% cv_folds + 1 fold_x <- cv_subsamples[[i]] crossval_compute(test_sample = fold_x, learner = learners[[j]], @@ -140,29 +134,7 @@ crossval <- function(y, X, # Compute out-of-sample errors njobs <- cv_folds * nlearners - cl <- NULL - if (num_cores > 1) { - cl <- tryCatch( - setup_parallel_cluster(num_cores, parallel_export, - parallel_packages), - error = function(e) { - warning("Parallel setup failed: ", - conditionMessage(e), - ". Falling back to sequential.", - call. = FALSE) - NULL - } - ) - if (!is.null(cl)) - on.exit(parallel::stopCluster(cl), add = TRUE) - }#IF - - if (silent) { - op <- pbapply::pboptions(type = "none") - on.exit(pbapply::pboptions(op), add = TRUE) - }#IF - cv_res <- pbapply::pbsapply(seq_len(njobs), cv_fun, - cl = cl) + cv_res <- with_parallel(njobs, cv_fun, parallel, silent) # Compile residual matrix cv_resid <- unlist(cv_res) @@ -170,9 +142,9 @@ crossval <- function(y, X, cv_resid <- cv_resid[order(unlist(cv_subsamples)), , drop = FALSE] # Compute MSPE and R-squared by learner - mspe <- colMeans(cv_resid^2) - y_var <- as.numeric(stats::var(y)) - r2 <- if (y_var > 0) 1 - mspe / y_var else rep(NA_real_, length(mspe)) + cv_stats <- compute_mspe_r2(cv_resid, y) + mspe <- cv_stats$mspe + r2 <- cv_stats$r2 # Organize and return output output <- list(mspe = mspe, r2 = r2, @@ -184,22 +156,11 @@ crossval <- function(y, X, # Complementary functions ====================================================== crossval_compute <- function(test_sample, 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) - assign_X <- learner$assign_X - - mdl_fun$args$y <- y[-test_sample] - mdl_fun$args$X <- X[-test_sample, assign_X, drop = FALSE] - - mdl_fit <- tryCatch( - do.call(do.call, mdl_fun), - error = function(e) { - stop("Learner fitting failed: ", conditionMessage(e), - call. = FALSE) - } - ) - + 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]) diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index c344d96..4050686 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -151,30 +151,39 @@ ddml_fpliv <- function(y, D, Z, X, l })#LAPPLY }#IF - D_XZ_res_list <- compute_CEF_list( - D, 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_prefix = "E[D", label_suffix = "|X,Z]", - parallel = parallel, - fitted = unname(fitted[paste0("D", seq_len(nD), "_XZ")])) + # 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 # E[D|X] - D_X_res_list <- compute_CEF_list( - D, 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_prefix = "E[D", label_suffix = "|X]", - parallel = parallel, - fitted = unname(fitted[paste0("D", seq_len(nD), "_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 ensemble_type <- y_X_res$ensemble_type nensb <- if (is.null(ensemble_type)) 1L diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index 854cc3a..37c5659 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -139,30 +139,38 @@ ddml_pliv <- function(y, D, Z, X, fitted = fitted$y_X) # E[Z|X] - Z_X_res_list <- compute_CEF_list( - Z, 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_prefix = "E[Z", label_suffix = "|X]", - parallel = parallel, - fitted = unname(fitted[paste0("Z", seq_len(nZ), "_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 # E[D|X] - D_X_res_list <- compute_CEF_list( - D, 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_prefix = "E[D", label_suffix = "|X]", - parallel = parallel, - fitted = unname(fitted[paste0("D", seq_len(nD), "_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 ensemble_type <- y_X_res$ensemble_type nensb <- if (is.null(ensemble_type)) 1L diff --git a/R/ddml_plm.R b/R/ddml_plm.R index b4441a1..710857d 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -157,18 +157,22 @@ ddml_plm <- function(y, D, X, parallel = parallel, fitted = fitted$y_X) - # Compute estimates of E[D|X], loop through endogenous variables - D_X_res_list <- compute_CEF_list( - D, 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_prefix = "E[D", label_suffix = "|X]", - parallel = parallel, - fitted = unname(fitted[paste0("D", seq_len(nD), "_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 ensemble_type <- y_X_res$ensemble_type nensb <- if (is.null(ensemble_type)) 1L diff --git a/R/ensemble.R b/R/ensemble.R index 6c5b92a..e4692ae 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -61,24 +61,33 @@ ensemble <- function(y, X, # 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."), call. = FALSE) - # 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, type = type, learners = learners, @@ -91,23 +100,16 @@ ensemble <- function(y, X, cv_results <- ens_w_res$cv_results # 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) + warning("None of the learners are assigned positive stacking ", + "weights.", call. = FALSE) }#IF - # Fit all base learners to keep per-learner outputs always available + + # Fit all base learners mdl_fits <- rep(list(NULL), nlearners) for (m in seq_len(nlearners)) { - # Check whether X assignment has been specified. If not, include all. if (is.null(learners[[m]]$assign_X)) learners[[m]]$assign_X <- seq_len(ncol(X)) - # Select the model constructor and the variable assignment. - mdl_fun <- list(what = learners[[m]]$what, - args = learners[[m]]$args) - assign_X <- learners[[m]]$assign_X - # Fit the model - mdl_fun$args$y <- y - mdl_fun$args$X <- X[, assign_X, drop = FALSE] - mdl_fits[[m]] <- do.call(do.call, mdl_fun) + mdl_fits[[m]] <- fit_learner(learners[[m]], y, X) }#FOR # Organize and return output @@ -125,17 +127,24 @@ ensemble <- function(y, X, #' @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 per-learner predictions with one column per -#' base learner. +#' @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, ...){ - # 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)) + ncols <- if (type == "bylearner") nlearners + else ncol(object$weights) + return(matrix(object$mean_y, nrow(newdata), ncols)) }#IF # Calculate fitted values for each learner fitted_mat <- matrix(0, nrow(newdata), nlearners) @@ -146,9 +155,8 @@ predict.ensemble <- function(object, newdata, ...){ drop = FALSE]) fitted_mat[, m] <- methods::as(fitted, "matrix") }#FOR - # Compute matrix of fitted values by ensemble type and return - fitted_ens <- fitted_mat %*% object$weights - return(fitted_ens) + if (type == "bylearner") return(fitted_mat) + fitted_mat %*% object$weights }#PREDICT.ENSEMBLE # Complementary functions ====================================================== @@ -214,82 +222,98 @@ ensemble_weights <- function(y, X, ncol(cv_results$cv_resid) } else { length(learners) - } - ncustom <- ncol(custom_weights) - ncustom <- ifelse(is.null(ncustom), 0, ncustom) + }#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, learners = learners, cv_folds = cv_folds, cv_subsamples = cv_subsamples, 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 seq_len(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$cv_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 <- 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)) { - weights[, k] <- r$solution - } else { - weights[, k] <- rep(1 / nlearners, nlearners) - }#IFELSE - } else if (type[k] == "nnls") { - # Reconstruct out of sample fitted values - cv_fitted <- as.numeric(y) - cv_results$cv_resid - # For non-negative stacking, calculate the non-negatuve ols coefficients - weights[, k] <- nnls::nnls(cv_fitted, y)$x - } else if (type[k] == "ols") { - # Reconstruct out of sample fitted values - cv_fitted <- as.numeric(y) - cv_results$cv_resid - # For unconstrained stacking, simply calculate the ols coefficients - weights[, k] <- ols(y, cv_fitted, const = FALSE)$coef - } else if (type[k] == "singlebest") { - # Find MSPE-minimizing model - mdl_min <- which.min(Matrix::colMeans(cv_results$cv_resid^2)[, drop = FALSE]) - mdl_min <- (seq_len(nlearners))[mdl_min] - # Assign unit weight to the best model - weights[mdl_min, k] <- 1 - }#IFELSE + 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))) { + 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 a8006b0..254beaf 100644 --- a/R/get_CEF.R +++ b/R/get_CEF.R @@ -22,10 +22,10 @@ get_CEF <- function(y, X, silent = FALSE, label = NULL, auxiliary_X = NULL, - shortstack_y = y, parallel = NULL, fitted = NULL) { - t0 <- proc.time()[3] + # Normalize learner specs once at the entry gate + learners <- normalize_learners(learners) # Use pre-computed predictions if supplied if (!is.null(fitted)) { @@ -63,13 +63,16 @@ get_CEF <- function(y, X, }#IF }#IF - # Constant or empty y: return trivial predictions + # 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 <- if (!is.null(custom_ensemble_weights)) - ncol(custom_ensemble_weights) else 0L + ncustom <- n_custom(custom_ensemble_weights) nensb <- length(ensemble_type) + ncustom n <- length(y) @@ -111,7 +114,6 @@ get_CEF <- function(y, X, subsamples = subsamples, silent = silent, auxiliary_X = auxiliary_X, - shortstack_y = shortstack_y, parallel = parallel) } else { res <- crosspred(y, X, diff --git a/R/help_functions.R b/R/help_functions.R index b31b782..ce3f14e 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -134,6 +134,35 @@ normalize_learners <- function(learners) { 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 @@ -148,13 +177,18 @@ build_CEF_from_crossfit <- function(y, cf_fitted_bylearner_eq, cf <- as.matrix(cf_fitted_bylearner_eq) cf_resid_bylearner <- drop(y) - cf - mspe <- colMeans(cf_resid_bylearner^2) - + 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 <- if (!is.null(custom_ensemble_weights)) - ncol(custom_ensemble_weights) else 0L + ncustom <- n_custom(custom_ensemble_weights) nensb <- length(ensemble_type) + ncustom cf_fitted <- matrix(0, nobs, nensb) all_weights <- vector("list", K) @@ -179,7 +213,7 @@ build_CEF_from_crossfit <- function(y, cf_fitted_bylearner_eq, paste("sample fold ", seq_len(K))) } else { fakecv <- list(cv_resid = cf_resid_bylearner, - mspe = mspe) + mspe = mspe_bylearner) ew <- ensemble_weights( y, cf, type = ensemble_type, cv_results = fakecv, @@ -194,15 +228,13 @@ build_CEF_from_crossfit <- function(y, cf_fitted_bylearner_eq, auxiliary_fitted <- extrapolate_auxiliary( auxiliary_fitted_bylearner, weights) - y_var <- as.numeric(stats::var(y)) - r2 <- if (y_var > 0) 1 - mspe / y_var else - rep(NA_real_, length(mspe)) + oos_stats <- compute_mspe_r2(cf_resid_bylearner, y) list(cf_fitted = cf_fitted, weights = weights, ensemble_type = ens_names, - mspe = mspe, - r2 = r2, + mspe = oos_stats$mspe, + r2 = oos_stats$r2, auxiliary_fitted = auxiliary_fitted, cf_fitted_bylearner = cf, cf_resid_bylearner = cf_resid_bylearner, @@ -413,35 +445,3 @@ validate_custom_weights <- function(custom_weights, learners) { "the number of base learners.", call. = FALSE) } }#VALIDATE_CUSTOM_WEIGHTS - -# Compute CEF for each column of M, collecting results in a list. -compute_CEF_list <- function(M, X, - learners, ensemble_type, - shortstack, - custom_ensemble_weights, - subsamples, cv_subsamples, - silent = FALSE, - label_prefix, label_suffix, - parallel = NULL, - fitted = NULL) { - nM <- ncol(M) - res_list <- vector("list", nM) - for (k in seq_len(nM)) { - fit_k <- if (!is.null(fitted)) { - fitted[[k]] - }#IF - res_list[[k]] <- get_CEF( - M[, k, drop = FALSE], X, - learners = learners, - ensemble_type = ensemble_type, - shortstack = shortstack, - custom_ensemble_weights = custom_ensemble_weights, - subsamples = subsamples, - cv_subsamples = cv_subsamples, - silent = silent, - label = paste0(label_prefix, k, label_suffix), - parallel = parallel, - fitted = fit_k) - }#FOR - res_list -}#COMPUTE_CEF_LIST diff --git a/R/parallel.R b/R/parallel.R index eda4d16..ad2a15e 100644 --- a/R/parallel.R +++ b/R/parallel.R @@ -42,6 +42,33 @@ parse_parallel <- function(parallel) { ) }#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(...) diff --git a/R/shortstacking.R b/R/shortstacking.R index 46d0bb6..b148f9c 100644 --- a/R/shortstacking.R +++ b/R/shortstacking.R @@ -6,9 +6,6 @@ #' #' @inheritParams crosspred #' @inheritParams ddml-intro -#' @param shortstack_y Optional vector of the outcome variable to form -#' short-stacking predictions for. Base learners are always trained on -#' \code{y}. #' #' @return \code{shortstack} returns a list containing the following components: #' \describe{ @@ -73,18 +70,12 @@ shortstacking <- function(y, X, subsamples = NULL, silent = FALSE, auxiliary_X = NULL, - shortstack_y = y, parallel = NULL) { - # Normalize learner specs before parallel dispatch - learners <- normalize_learners(learners) - # Data parameters nobs <- nrow(X) nlearners <- length(learners) - # Throw error if no ensemble is estimated - calc_ensemble <- !is_single_learner(learners) - if (!calc_ensemble) { + if (is_single_learner(learners)) { stop("shortstacking cannot be estimated with a single learner.") }#IF @@ -94,14 +85,14 @@ shortstacking <- function(y, X, 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 + # 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", + cv_folds = NULL, subsamples = subsamples, silent = silent, auxiliary_X = auxiliary_X, @@ -109,9 +100,9 @@ shortstacking <- function(y, X, # Compute ensemble weights via subsample cross-fitted residual fakecv <- list() - fakecv$cv_resid <- matrix(shortstack_y, nobs, nlearners) - + fakecv$cv_resid <- matrix(y, nobs, nlearners) - res$cf_fitted_bylearner - weights <- ensemble_weights(shortstack_y, X, learners = learners, + weights <- ensemble_weights(y, X, learners = learners, type = ensemble_type, custom_weights = custom_ensemble_weights, cv_results = fakecv)$weights @@ -129,10 +120,9 @@ shortstacking <- function(y, X, # Per-learner OOS mspe and r-squared cf_resid_bylearner <- as.matrix(fakecv$cv_resid) - mspe <- colMeans(cf_resid_bylearner^2) - y_var <- as.numeric(stats::var(shortstack_y)) - r2 <- if (y_var > 0) 1 - mspe / y_var else rep(NA_real_, - length(mspe)) + oos_stats <- compute_mspe_r2(cf_resid_bylearner, y) + mspe <- oos_stats$mspe + r2 <- oos_stats$r2 # return shortstacking output output <- list(cf_fitted = cf_fitted, From 5231538f0428b210707e584d796dd2467daafacf Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Tue, 10 Mar 2026 14:47:55 -0500 Subject: [PATCH 27/46] update docs + vignettes + tests --- R/ddml_fpliv.R | 2 +- R/ddml_pliv.R | 2 +- R/ddml_plm.R | 2 +- R/ensemble.R | 3 - README.Rmd | 7 +- README.md | 134 ++--- man/AE98.Rd | 2 +- man/cash-.ddml.Rd | 21 - man/coef.ddml.Rd | 9 +- man/confint.ddml.Rd | 9 +- man/crosspred.Rd | 21 +- man/crossval.Rd | 4 +- man/{ddml-class.Rd => ddml-intro.Rd} | 63 ++- man/ddml-package.Rd | 3 +- man/ddml.Rd | 139 ++++++ man/ddml_apo.Rd | 61 ++- man/ddml_ate.Rd | 59 +-- man/ddml_fpliv.Rd | 57 +-- man/ddml_late.Rd | 60 +-- man/ddml_pliv.Rd | 56 +-- man/ddml_plm.Rd | 50 +- man/ddml_rep.Rd | 3 +- man/diagnostics.Rd | 34 +- man/ensemble.Rd | 23 +- man/ensemble_weights.Rd | 19 +- man/glance.ddml.Rd | 6 +- man/glance.ddml_rep.Rd | 7 +- man/hatvalues.ddml.Rd | 16 +- man/mdl_bigGLM.Rd | 2 +- man/mdl_glm.Rd | 2 +- man/mdl_glmnet.Rd | 2 +- man/mdl_ranger.Rd | 2 +- man/mdl_xgboost.Rd | 2 +- man/nobs.ddml.Rd | 11 +- man/ols.Rd | 2 +- man/predict.ensemble.Rd | 15 +- man/predict.mdl_bigGLM.Rd | 4 +- man/predict.mdl_glm.Rd | 4 +- man/predict.mdl_glmnet.Rd | 4 +- man/predict.mdl_ranger.Rd | 4 +- man/predict.mdl_xgboost.Rd | 4 +- man/predict.ols.Rd | 4 +- man/reexports.Rd | 2 +- man/shortstacking.Rd | 27 +- man/sub-.summary.ddml.Rd | 17 + man/summary.ddml.Rd | 27 +- man/tidy.ddml.Rd | 6 +- man/tidy.ddml_diagnostics.Rd | 12 +- man/tidy.ddml_rep.Rd | 7 +- man/vcov.ddml.Rd | 17 +- man/vcov.ddml_rep.Rd | 2 +- tests/testthat/test-cvc.R | 87 ---- tests/testthat/test-ddml.R | 461 ++++++++++++++++++ tests/testthat/test-ddml_apo.R | 46 -- tests/testthat/test-ddml_ate.R | 45 -- tests/testthat/test-ddml_att.R | 32 +- tests/testthat/test-ddml_fpliv.R | 4 +- tests/testthat/test-ddml_pliv.R | 4 +- tests/testthat/test-ddml_plm.R | 2 +- tests/testthat/test-diagnostics.R | 48 +- tests/testthat/test-ensemble.R | 11 +- tests/testthat/test-get_CEF.R | 131 +++++ tests/testthat/test-help_functions.R | 14 + tests/testthat/test-methods.R | 212 -------- tests/testthat/test-ols.R | 2 +- tests/testthat/test-subsample_functions.R | 35 ++ tests/testthat/test-tidy.R | 99 ---- vignettes/articles/did.Rmd | 131 ++--- vignettes/articles/did.Rmd.txt | 19 +- vignettes/articles/example_401k.Rmd | 166 +++++-- vignettes/articles/example_401k.Rmd.txt | 30 +- vignettes/articles/example_BLP95.Rmd | 79 ++- vignettes/articles/example_BLP95.Rmd.txt | 12 +- .../articles/figures/unnamed-chunk-11-1.png | Bin 23116 -> 23031 bytes .../articles/figures/unnamed-chunk-12-1.png | Bin 11637 -> 11604 bytes .../articles/figures/unnamed-chunk-8-1.png | Bin 23124 -> 22725 bytes .../articles/figures/unnamed-chunk-9-1.png | Bin 11240 -> 10867 bytes .../articles/modelsummary_integration.Rmd | 63 +-- .../articles/modelsummary_integration.Rmd.txt | 8 +- vignettes/articles/new_ml_wrapper.Rmd | 15 - vignettes/articles/new_ml_wrapper.Rmd.txt | 2 +- vignettes/articles/repeated_resampling.Rmd | 84 +++- .../articles/repeated_resampling.Rmd.txt | 6 +- vignettes/articles/sparse.Rmd | 39 +- vignettes/articles/sparse.Rmd.txt | 4 +- vignettes/articles/stacking.Rmd | 6 +- vignettes/articles/stacking_diagnostics.Rmd | 140 +++--- .../articles/stacking_diagnostics.Rmd.txt | 22 +- vignettes/ddml.Rmd | 77 +-- 89 files changed, 1798 insertions(+), 1389 deletions(-) delete mode 100644 man/cash-.ddml.Rd rename man/{ddml-class.Rd => ddml-intro.Rd} (83%) create mode 100644 man/ddml.Rd create mode 100644 man/sub-.summary.ddml.Rd delete mode 100644 tests/testthat/test-cvc.R create mode 100644 tests/testthat/test-ddml.R delete mode 100644 tests/testthat/test-methods.R delete mode 100644 tests/testthat/test-tidy.R diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index 4050686..85b3099 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -281,7 +281,7 @@ ddml_fpliv <- function(y, D, Z, X, "D", "_XZ"), build_fitted_flat(D_X_res_list, save_crossval, "D", "_X")), - splits = setNames( + splits = stats::setNames( rep(list(list(subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples)), length(ensemble_weights)), diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index 37c5659..c37f10a 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -264,7 +264,7 @@ ddml_pliv <- function(y, D, Z, X, "D", "_X"), build_fitted_flat(Z_X_res_list, save_crossval, "Z", "_X")), - splits = setNames( + splits = stats::setNames( rep(list(list(subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples)), length(ensemble_weights)), diff --git a/R/ddml_plm.R b/R/ddml_plm.R index 710857d..6b88af5 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -248,7 +248,7 @@ ddml_plm <- function(y, D, X, list(y_X = build_fitted_entry(y_X_res, save_crossval)), build_fitted_flat(D_X_res_list, save_crossval, "D", "_X")), - splits = setNames( + splits = stats::setNames( rep(list(list(subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples)), length(ensemble_weights)), diff --git a/R/ensemble.R b/R/ensemble.R index e4692ae..6a6cc60 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -29,7 +29,6 @@ #' \item{\code{constant_y}}{Boolean indicating if y is #' constant.} #' } -#' @family utilities #' @export #' #' @examples @@ -170,7 +169,6 @@ predict.ensemble <- function(object, newdata, ..., #' #' @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. @@ -192,7 +190,6 @@ predict.ensemble <- function(object, newdata, ..., #' \item{\code{cv_results}}{Cross-validation results used #' for computing weights.} #' } -#' @family utilities #' @export #' #' @examples diff --git a/README.Rmd b/README.Rmd index a43cf07..7744163 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 ) ``` diff --git a/README.md b/README.md index dbbd20f..44ddf23 100644 --- a/README.md +++ b/README.md @@ -1,42 +1,31 @@ +--- +output: github_document +--- + + # ddml - [![R-CMD-check](https://github.com/thomaswiemann/ddml/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/thomaswiemann/ddml/actions/workflows/R-CMD-check.yaml) [![codecov](https://codecov.io/gh/thomaswiemann/ddml/branch/master/graph/badge.svg?token=PHB9W2TJ6S)](https://app.codecov.io/gh/thomaswiemann/ddml) [![CodeFactor](https://www.codefactor.io/repository/github/thomaswiemann/ddml/badge)](https://www.codefactor.io/repository/github/thomaswiemann/ddml) -[![CRAN -Version](https://www.r-pkg.org/badges/version/ddml)](https://cran.r-project.org/package=ddml) +[![CRAN Version](https://www.r-pkg.org/badges/version/ddml)](https://cran.r-project.org/package=ddml) [![cranlogs](https://cranlogs.r-pkg.org/badges/ddml)](https://cran.r-project.org/package=ddml) -`ddml` is an implementation of double/debiased machine learning -estimators as proposed by Chernozhukov et al. (2018). The key feature of -`ddml` is the straightforward estimation of nuisance parameters using -(short-)stacking (Wolpert, 1992), which allows for multiple machine -learners to increase robustness to the underlying data generating -process. See also [Ahrens et -al. (2024b)](https://arxiv.org/abs/2401.01645) for a detailed -illustration of the practical benefits of combining DDML with -(short-)stacking. - -`ddml` is the sister R package to our -[Stata](https://github.com/aahrens1/ddml/) package, mirroring its key -features while also leveraging R to simplify estimation with -user-provided machine learners and/or sparse matrices. See also [Ahrens -et al. (2024a)](https://arxiv.org/abs/2301.09397) with additional -discussion of the supported causal models and benefits of -(short)-stacking. +``ddml`` is an implementation of double/debiased machine learning estimators as proposed by Chernozhukov et al. (2018). The key feature of ``ddml`` is the straightforward estimation of nuisance parameters using (short-)stacking (Wolpert, 1992), which allows for multiple machine learners to increase robustness to the underlying data generating process. See also [Ahrens et al. (2024b)](https://arxiv.org/abs/2401.01645) for a detailed illustration of the practical benefits of combining DDML with (short-)stacking. + +``ddml`` is the sister R package to our [Stata](https://github.com/aahrens1/ddml/) package, mirroring its key features while also leveraging R to simplify estimation with user-provided machine learners and/or sparse matrices. See also [Ahrens et al. (2024a)](https://arxiv.org/abs/2301.09397) with additional discussion of the supported causal models and benefits of (short)-stacking. ## Installation -Install the latest development version from GitHub (requires -[devtools](https://github.com/r-lib/devtools) package): +Install the latest development version from GitHub (requires [devtools](https://github.com/r-lib/devtools) package): + -``` r +```r if (!require("devtools")) { install.packages("devtools") } @@ -45,18 +34,17 @@ devtools::install_github("thomaswiemann/ddml", dependencies = TRUE) Install the latest public release from CRAN: -``` r +```r install.packages("ddml") ``` + ## Example: LATE Estimation based on (Short-)Stacking -To illustrate `ddml` on a simple example, consider the included random -subsample of 5,000 observations from the data of Angrist & Evans (1998). -The data contains information on the labor supply of mothers, their -children, as well as demographic data. See `?AE98` for details. +To illustrate ``ddml`` on a simple example, consider the included random subsample of 5,000 observations from the data of Angrist & Evans (1998). The data contains information on the labor supply of mothers, their children, as well as demographic data. See ``?AE98`` for details. + -``` r +```r # Load ddml and set seed library(ddml) set.seed(75523) @@ -68,19 +56,14 @@ 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`). Since the -statistical properties of machine learners depend heavily on the -underlying (unknown!) structure of the data, adaptive combination of -multiple machine learners can increase robustness. In the below snippet, -`ddml_late` estimates the LATE with short-stacking based on three base -learners: +``ddml_late`` estimates the local average treatment effect (LATE) using double/debiased machine learning (see ``?ddml_late``). Since the statistical properties of machine learners depend heavily on the underlying (unknown!) structure of the data, adaptive combination of multiple machine learners can increase robustness. In the below snippet, ``ddml_late`` estimates the LATE with short-stacking based on three base learners: -- linear regression (see `?ols`) -- lasso (see `?mdl_glmnet`) -- gradient boosting (see `?mdl_xgboost`) +- linear regression (see ``?ols``) +- lasso (see ``?mdl_glmnet``) +- gradient boosting (see ``?mdl_xgboost``) -``` r + +```r # Estimate the local average treatment effect using short-stacking with base # learners ols, lasso, and xgboost. late_fit_short <- ddml_late(y, D, Z, X, @@ -98,76 +81,49 @@ summary(late_fit_short) #> Obs: 5000 Folds: 10 Stacking: short-stack #> #> Estimate Std. Error z value Pr(>|z|) -#> LATE -0.223 0.187 -1.19 0.23 +#> LATE -0.220 0.187 -1.18 0.24 ``` -## Learn More about `ddml` +## Learn More about ``ddml`` 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("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/) For additional applied examples, see our case studies: -- `vignette("example_401k")` revisits the effect of 401k participation - on retirement savings -- `vignette("example_BLP95")` considers flexible demand estimation with - endogenous prices +- ``vignette("example_401k")`` revisits the effect of 401k participation on retirement savings +- ``vignette("example_BLP95")`` considers flexible demand estimation with endogenous prices ## 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. +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, 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. +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 Review, 88(3), 450-477. -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. +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. -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. -Wolpert D H (1992). “Stacked generalization.” Neural Networks, 5(2), -241-259. diff --git a/man/AE98.Rd b/man/AE98.Rd index 58696c6..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 (1998).} +\title{Random Subsample from the Data of Angrist & Evans (1998)} \format{ A data frame with 5,000 rows and 13 variables. \describe{ diff --git a/man/cash-.ddml.Rd b/man/cash-.ddml.Rd deleted file mode 100644 index 15e6cd3..0000000 --- a/man/cash-.ddml.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/methods.R -\name{$.ddml} -\alias{$.ddml} -\title{Access Elements of a DDML Object} -\usage{ -\method{$}{ddml}(x, name) -} -\arguments{ -\item{x}{An object of class \code{ddml}.} - -\item{name}{Element name.} -} -\value{ -The requested element. -} -\description{ -Provides backward compatibility for renamed elements. -Accessing \code{$weights} is deprecated; use -\code{$ensemble_weights} instead. -} diff --git a/man/coef.ddml.Rd b/man/coef.ddml.Rd index 6d8740a..ae15b10 100644 --- a/man/coef.ddml.Rd +++ b/man/coef.ddml.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/methods.R +% Please edit documentation in R/ddml.R \name{coef.ddml} \alias{coef.ddml} \title{Extract Model Coefficients} @@ -27,18 +27,17 @@ 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) + learners = list(what = ols), + sample_folds = 2, silent = TRUE) coef(plm_fit) } } \seealso{ Other ddml inference: -\code{\link{[.summary.ddml}()}, \code{\link{confint.ddml}()}, \code{\link{hatvalues.ddml}()}, -\code{\link{nobs.ddml}()}, +\code{\link{summary.ddml}()}, \code{\link{vcov.ddml}()} } \concept{ddml inference} diff --git a/man/confint.ddml.Rd b/man/confint.ddml.Rd index e9447b6..8865b92 100644 --- a/man/confint.ddml.Rd +++ b/man/confint.ddml.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/methods.R +% Please edit documentation in R/ddml.R \name{confint.ddml} \alias{confint.ddml} \title{Confidence Intervals for DDML Estimators} @@ -38,8 +38,8 @@ 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) + learners = list(what = ols), + sample_folds = 2, silent = TRUE) confint(plm_fit) confint(plm_fit, parm = "D1") confint(plm_fit, level = 0.90) @@ -50,10 +50,9 @@ confint(plm_fit, level = 0.90) \code{\link{vcov.ddml}} Other ddml inference: -\code{\link{[.summary.ddml}()}, \code{\link{coef.ddml}()}, \code{\link{hatvalues.ddml}()}, -\code{\link{nobs.ddml}()}, +\code{\link{summary.ddml}()}, \code{\link{vcov.ddml}()} } \concept{ddml inference} diff --git a/man/crosspred.Rd b/man/crosspred.Rd index 1bac417..f44bed1 100644 --- a/man/crosspred.Rd +++ b/man/crosspred.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/crosspred.R \name{crosspred} \alias{crosspred} -\title{Cross-Fitted Predictions using Stacking.} +\title{Cross-Fitted Predictions Using Stacking} \usage{ crosspred( y, @@ -103,16 +103,13 @@ order).} \item{\code{weights}}{An array, providing the weight assigned to each base learner (in chronological order) by the ensemble procedures.} -\item{\code{mspe}}{A matrix of per-learner MSPEs, with -rows for learners and columns for sample folds. -\code{NULL} when a single learner is used.} -\item{\code{r2}}{A matrix of per-learner out-of-sample -R-squared values. Same dimensions as \code{mspe}. -\code{NULL} when a single learner is used.} -\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{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{cf_fitted_bylearner}}{A matrix of out-of-sample @@ -201,6 +198,8 @@ 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}()} diff --git a/man/crossval.Rd b/man/crossval.Rd index ca304d1..8578a83 100644 --- a/man/crossval.Rd +++ b/man/crossval.Rd @@ -2,7 +2,7 @@ % 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, @@ -124,6 +124,8 @@ 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}()} diff --git a/man/ddml-class.Rd b/man/ddml-intro.Rd similarity index 83% rename from man/ddml-class.Rd rename to man/ddml-intro.Rd index f62a51f..ca0b739 100644 --- a/man/ddml-class.Rd +++ b/man/ddml-intro.Rd @@ -1,8 +1,8 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml-class.R -\name{ddml-class} -\alias{ddml-class} -\title{Common Output Structure for DDML Estimators} +% 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.} @@ -105,9 +105,7 @@ pass-through calls with data-driven ensembles (e.g., \code{FALSE} to reduce object size at the cost of approximate weight recomputation.} -\item{...}{Deprecated arguments are still accepted for backward -compatibility but should be replaced with the \code{splits} -argument. See individual estimator pages for details.} +\item{...}{Additional arguments passed to internal methods.} } \description{ All \code{ddml_*} estimators (\code{\link{ddml_plm}}, @@ -119,6 +117,11 @@ 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 @@ -126,21 +129,19 @@ parameter \eqn{\theta_0} identified by a moment condition \deqn{E[m(W; \theta_0, \eta_0)] = 0,} -\if{html}{\out{
}}\preformatted{where \eqn{W} denotes observed random variables and +where \eqn{W} denotes observed random variables and \eqn{\eta_0} is a (potentially high-dimensional) nuisance parameter, typically a vector of conditional expectation -functions. The score \eqn{m} is \\emph\{Neyman orthogonal\}, +functions. The score \eqn{m} is \emph{Neyman orthogonal}, meaning the moment condition is locally insensitive to perturbations of \eqn{\eta} around \eqn{\eta_0}. Each estimator in \code{ddml} uses a score that decomposes linearly in \eqn{\theta}: -}\if{html}{\out{
}} -\deqn{m(W_i; \theta, \eta) = \psi_b(W_i; \eta) + - \psi_a(W_i; \eta)\,\theta.} +\deqn{m(W_i; \theta, \eta) = \psi_b(W_i; \eta) + \psi_a(W_i; \eta)\,\theta.} -\if{html}{\out{
}}\preformatted{See the individual estimator pages for the specific forms +See the individual estimator pages for the specific forms of \eqn{\psi_a} and \eqn{\psi_b}. Estimation proceeds via cross-fitting: the sample is randomly @@ -149,41 +150,36 @@ 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 -}\if{html}{\out{
}} \deqn{\frac{1}{n} \sum_{k=1}^{K} \sum_{i \in I_k} - m(W_i; \hat\theta, \hat\eta_{-k}) = 0.} +m(W_i; \hat\theta, \hat\eta_{-k}) = 0.} -\if{html}{\out{
}}\preformatted{For the linear scores used in \code{ddml}, this yields the +For the linear scores used in \code{ddml}, this yields the closed-form solution -}\if{html}{\out{
}} \deqn{\hat\theta = -\hat{J}^{-1}\,\hat\psi_b,} -\if{html}{\out{
}}\preformatted{where \eqn{\hat\psi_b = n^{-1}\sum_{k}\sum_{i \in I_k} - \psi_b(W_i; \hat\eta_{-k})} and +where \eqn{\hat\psi_b = n^{-1}\sum_{k}\sum_{i \in I_k} +\psi_b(W_i; \hat\eta_{-k})} and \eqn{\hat{J} = n^{-1}\sum_k \sum_{i \in I_k} - \psi_a(W_i; \hat\eta_{-k})} is the sample Jacobian. +\psi_a(W_i; \hat\eta_{-k})} is the sample Jacobian. Inference is based on the sandwich variance estimator -}\if{html}{\out{
}} \deqn{\hat\Sigma = \hat{J}^{-1} \left(\frac{1}{n} - \sum_i m_i m_i^\top\right) - \hat{J}^{-\top} / n} +\sum_i m_i m_i^\top\right) +\hat{J}^{-\top} / n} -\if{html}{\out{
}}\preformatted{where \eqn{m_i = m(W_i; \hat\theta, \hat\eta_{-k(i)})}; +where \eqn{m_i = m(W_i; \hat\theta, \hat\eta_{-k(i)})}; see \code{\link{vcov.ddml}} for HC0/HC1/HC3 variants. -Under regularity conditions and sufficient convergence of \eqn{\hat\eta}, +Under regularity conditions and sufficient convergence of \eqn{\hat\eta}, the DML estimator is asymptotically normal: -}\if{html}{\out{
}} \deqn{\sqrt{n}\,\hat\Sigma^{-1/2}(\hat\theta - \theta_0) - \overset{d}{\to} N(0, I).} +\overset{d}{\to} N(0, I).} -\if{html}{\out{
}}\preformatted{Further details and regularity conditions are given in +Further details and regularity conditions are given in Chernozhukov et al. (2018). -}\if{html}{\out{
}} } \section{Common output components}{ @@ -196,10 +192,11 @@ 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 per-learner MSPEs from -the cross-validation step in ensemble construction.} -\item{\code{r2}}{A named list of per-learner out-of-sample -R-squared values.} +\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{psi_a}, \code{psi_b}}{Score component lists (length \code{nensb}). \code{psi_a[[j]]} is an \code{(n x p x p)} array and \code{psi_b[[j]]} is an diff --git a/man/ddml-package.Rd b/man/ddml-package.Rd index 68284c8..d3edf62 100644 --- a/man/ddml-package.Rd +++ b/man/ddml-package.Rd @@ -1,8 +1,7 @@ % 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} \description{ diff --git a/man/ddml.Rd b/man/ddml.Rd new file mode 100644 index 0000000..a0b506a --- /dev/null +++ b/man/ddml.Rd @@ -0,0 +1,139 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml.R +\name{ddml} +\alias{ddml} +\alias{$.ddml} +\title{Construct a \code{ddml} Object.} +\usage{ +ddml( + coefficients, + scores, + J, + psi_a, + psi_b, + 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, + ... +) + +\method{$}{ddml}(x, name) +} +\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{psi_a}{A list of length \code{nensb}. Each element is an +\code{(n x p x p)} array of individual-level Jacobian +contributions.} + +\item{psi_b}{A list of length \code{nensb}. Each element is an +\code{(n x p)} matrix of individual-level score +contributions.} + +\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{...}{Additional named components to include in the object.} + +\item{x}{An object of class \code{ddml}.} + +\item{name}{Name of the element to extract.} +} +\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.ddml}}, +\code{\link{vcov.ddml}}, 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))) +coef <- matrix(theta, 1, 1, + dimnames = list("mean", "custom")) + +fit <- ddml(coefficients = coef, scores = scores, J = J, + psi_a = psi_a, psi_b = psi_b, + nobs = n, coef_names = "mean", + 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 index c8a0e94..67d9d5f 100644 --- a/man/ddml_apo.Rd +++ b/man/ddml_apo.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ddml_apo.R \name{ddml_apo} \alias{ddml_apo} -\title{DDML Estimator for the Average Potential Outcome} +\title{Estimator for the Average Potential Outcome} \usage{ ddml_apo( y, @@ -140,8 +140,8 @@ 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 +\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 @@ -152,27 +152,23 @@ pass-through calls with data-driven ensembles (e.g., \code{FALSE} to reduce object size at the cost of approximate weight recomputation.} -\item{...}{Deprecated arguments (\code{subsamples_byd}, -\code{cv_subsamples_byd}) are still accepted for backward -compatibility but should be replaced with the \code{splits} -argument.} +\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-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{ -\code{ddml_apo} provides a Double/Debiased Machine Learning -estimator for the average potential outcome, allowing for custom -weights \eqn{\omega(X)}. +Estimator for the average potential outcome, allowing for +custom weights \eqn{\omega(X)}. } \details{ -\code{ddml_apo} provides a Double/Debiased Machine Learning -estimator for the target parameter \eqn{\theta_0} in the model given by +\strong{Parameter of Interest:} \code{ddml_apo} provides a Double/Debiased Machine Learning +estimator for the target parameter \eqn{\theta_0} in the model given by: -\eqn{Y = g_0(D, X) + U,} +\deqn{Y = g_0(D, X) + U,} where \eqn{(Y, D, X, U)} is a random vector such that \eqn{E[U\vert D, X] = 0} and @@ -182,21 +178,29 @@ and \eqn{g_0} is an unknown nuisance function. In this model, the average potential outcome (APO) for treatment level \eqn{d} is defined as -\eqn{\theta_0^{\textrm{APO}} \equiv E[\omega(X) g_0(d, X)]}, +\deqn{\theta_0^{\textrm{APO}} \equiv E[\omega(X) g_0(d, X)],} where \eqn{\omega(X)} is a known weighting function. If \eqn{\omega(X) = 1}, this parameter corresponds to the standard Average Potential Outcome (APO) at treatment level \eqn{d}. -The estimating equation is -\eqn{E[m(W; \theta_0, \eta_0)] = 0}, where -\eqn{W = (Y, D, X)}, and the Neyman orthogonal score is +\strong{Nuisance Parameters:} The nuisance parameters are +\eqn{\eta = (\ell, p)} taking true values \eqn{\ell_0(X) = E[Y|D=d, X]} and +\eqn{p_0(X) = E[\mathbf{1}\{D=d\}|X]}. -\eqn{m(W; \theta, \eta) = \left( \frac{\mathbbm{1}\{D=d\} (Y - \ell(X))}{p(X)} + \ell(X) \right) \omega(X) - \theta} +\strong{Neyman Orthogonal Score / Moment Equation:} The Neyman orthogonal score is: -\if{html}{\out{
}}\preformatted{with nuisance parameters \eqn{\eta = (\ell, p)} taking -true values \eqn{\ell_0(X) = E[Y|D=d, X]} and \eqn{p_0(X) = E[\mathbbm{1}\{D=d\}|X]}. -}\if{html}{\out{
}} +\deqn{m(W; \theta, \eta) = \left( \frac{\mathbf{1}\{D=d\} (Y - \ell(X))}{p(X)} + \ell(X) \right) \omega(X) - \theta} + +\strong{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: + +\deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} + +where: + +\deqn{\psi_a(W; \eta) = -1} + +\deqn{\psi_b(W; \eta) = \left( \frac{\mathbf{1}\{D=d\} (Y - \ell(X))}{p(X)} + \ell(X) \right) \omega(X)} } \examples{ # Construct variables from the included Angrist & Evans (1998) data @@ -204,26 +208,17 @@ 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. +# 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) -} -\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. } \seealso{ -\code{\link[=summary.ddml]{summary.ddml()}}, \code{\link[=coef.ddml]{coef.ddml()}}, -\code{\link[=vcov.ddml]{vcov.ddml()}}, \code{\link[=confint.ddml]{confint.ddml()}}, -\code{\link[=hatvalues.ddml]{hatvalues.ddml()}}, \code{\link[=tidy.ddml]{tidy.ddml()}}, -\code{\link[=glance.ddml]{glance.ddml()}}, \code{\link[=diagnostics]{diagnostics()}} - Other ddml estimators: -\code{\link{ddml-class}}, +\code{\link{ddml-intro}}, \code{\link{ddml_ate}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, diff --git a/man/ddml_ate.Rd b/man/ddml_ate.Rd index b6a741d..df869ce 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, @@ -167,29 +167,26 @@ pass-through calls with data-driven ensembles (e.g., \code{FALSE} to reduce object size at the cost of approximate weight recomputation.} -\item{...}{Deprecated arguments (\code{subsamples}, -\code{subsamples_byD}, \code{cv_subsamples}, -\code{cv_subsamples_byD}) are still accepted for backward -compatibility but should be replaced with \code{splits}.} +\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-class}} for the common output structure. +\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 +\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, in the interactive model -given by +given by: -\eqn{Y = g_0(D, X) + U,} +\deqn{Y = g_0(D, X) + U,} 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 @@ -198,29 +195,34 @@ and \eqn{g_0} is an unknown nuisance function. In this model, the average treatment effect (ATE) is defined as -\eqn{\theta_0^{\textrm{ATE}} \equiv E[g_0(1, X) - g_0(0, X)]}, +\deqn{\theta_0^{\textrm{ATE}} \equiv E[g_0(1, X) - g_0(0, X)],} and the average treatment effect on the treated (ATT) is defined as -\eqn{\theta_0^{\textrm{ATT}} \equiv E[g_0(1, X) - g_0(0, X)\vert D = 1]}. +\deqn{\theta_0^{\textrm{ATT}} \equiv E[g_0(1, X) - g_0(0, X)\vert D = 1].} -The estimating equations are -\eqn{E[m(W; \theta_0, \eta_0)] = 0}, where -\eqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta}, -\eqn{W = (Y, D, X)}, and the Neyman orthogonal scores are +\strong{Neyman Orthogonal Score:} The Neyman orthogonal scores are: -\eqn{\psi_b^{\textrm{ATE}}(W; \eta) = \frac{D(Y - \ell_1(X))}{m(X)} - \frac{(1-D)(Y-\ell_0(X))}{1-m(X)} + \ell_1(X) - \ell_0(X)} +\deqn{m^{\textrm{ATE}}(W; \theta, \eta) = \frac{D(Y - \ell_1(X))}{p(X)} - \frac{(1-D)(Y-\ell_0(X))}{1-p(X)} + \ell_1(X) - \ell_0(X) - \theta} -\eqn{\psi_a^{\textrm{ATE}}(W; \eta) = -1} +\deqn{m^{\textrm{ATT}}(W; \theta, \eta) = \frac{D(Y - \ell_0(X))}{\pi} - \frac{p(X)(1-D)(Y-\ell_0(X))}{\pi(1-p(X))} - \frac{D\theta}{\pi}} -\eqn{\psi_b^{\textrm{ATT}}(W; \eta) = \frac{D(Y - \ell_0(X))}{p} - \frac{m(X)(1-D)(Y-\ell_0(X))}{p(1-m(X))}} +where the nuisance parameters are \eqn{\eta = (\ell_0, \ell_1, p, \pi)} taking true values +\eqn{\ell_{d,0}(X) = E[Y|D=d, X]}, \eqn{p_0(X) = E[D|X]}, and \eqn{\pi_0 = E[D]}. -\eqn{\psi_a^{\textrm{ATT}}(W; \eta) = -\frac{D}{p}} +\strong{Linear Decomposition:} The scores decompose linearly in \eqn{\theta}: -\if{html}{\out{
}}\preformatted{with nuisance parameters \eqn{\eta = (\ell_0, \ell_1, m, p)} taking -true values \eqn{\ell_{d,0}(X) = E[Y|D=d, X]}, \eqn{m_0(X) = E[D|X]}, -and \eqn{p_0 = E[D]}. -}\if{html}{\out{
}} +\deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} + +where: + +\deqn{\psi_a^{\textrm{ATE}}(W; \eta) = -1} + +\deqn{\psi_b^{\textrm{ATE}}(W; \eta) = \frac{D(Y - \ell_1(X))}{p(X)} - \frac{(1-D)(Y-\ell_0(X))}{1-p(X)} + \ell_1(X) - \ell_0(X)} + +\deqn{\psi_a^{\textrm{ATT}}(W; \eta) = -\frac{D}{\pi}} + +\deqn{\psi_b^{\textrm{ATT}}(W; \eta) = \frac{D(Y - \ell_0(X))}{\pi} - \frac{p(X)(1-D)(Y-\ell_0(X))}{\pi(1-p(X))}} } \examples{ # Construct variables from the included Angrist & Evans (1998) data @@ -253,16 +255,9 @@ 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{ Other ddml estimators: -\code{\link{ddml-class}}, +\code{\link{ddml-intro}}, \code{\link{ddml_apo}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, diff --git a/man/ddml_fpliv.Rd b/man/ddml_fpliv.Rd index 68a125c..70c0400 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, @@ -67,7 +67,7 @@ arguments being used in \code{what}. Omission of \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.} @@ -144,42 +144,45 @@ pass-through calls with data-driven ensembles (e.g., \code{FALSE} to reduce object size at the cost of approximate weight recomputation.} -\item{...}{Deprecated arguments are still accepted for backward -compatibility but should be replaced with the \code{splits} -argument. See individual estimator pages for details.} +\item{...}{Additional arguments passed to internal methods.} } \value{ \code{ddml_fpliv} returns an object of S3 class \code{ddml_fpliv} and \code{ddml}. See -\code{\link{ddml-class}} for the common output structure. +\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 +\strong{Parameter of Interest:} \code{ddml_fpliv} provides a Double/Debiased Machine Learning estimator for the target parameter \eqn{\theta_0} in the partially -linear IV model given by +linear IV model given by: -\eqn{Y = \theta_0D + g_0(X) + U,} +\deqn{Y = \theta_0 D + g_0(X) + U,} 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. -In this model, the target parameter \eqn{\theta_0} is identified by the -estimating equation -\eqn{E[m(W; \theta_0, \eta_0)] = 0}, where \eqn{W = (Y, D, Z, X)} and -\eqn{m(W; \theta, \eta)} is the Neyman orthogonal score +\strong{Neyman Orthogonal Score:} The Neyman orthogonal score is: -\eqn{m(W; \theta, \eta) = (Y - \ell(X) - \theta(D - r(X)))(v(X, Z) - r(X)),} +\deqn{m(W; \theta, \eta) = [(Y - \ell(X)) - \theta(D - r(X))](v(X, Z) - r(X))} -\if{html}{\out{
}}\preformatted{with nuisance parameters \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]}. -}\if{html}{\out{
}} +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{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: + +\deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} + +where: + +\deqn{\psi_a(W; \eta) = -(D - r(X))(v(X, Z) - r(X))^\top} + +\deqn{\psi_b(W; \eta) = (v(X, Z) - r(X))(Y - \ell(X))} } \examples{ # Construct variables from the included Angrist & Evans (1998) data @@ -188,7 +191,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)), @@ -196,21 +199,9 @@ 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[AER:ivreg]{AER::ivreg()}} - Other ddml estimators: -\code{\link{ddml-class}}, +\code{\link{ddml-intro}}, \code{\link{ddml_apo}()}, \code{\link{ddml_ate}()}, \code{\link{ddml_late}()}, diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index ebb48d3..de98282 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, @@ -69,7 +69,7 @@ arguments being used in \code{what}. Omission of \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.} @@ -152,27 +152,24 @@ pass-through calls with data-driven ensembles (e.g., \code{FALSE} to reduce object size at the cost of approximate weight recomputation.} -\item{...}{Deprecated arguments (\code{subsamples}, -\code{subsamples_byZ}, \code{cv_subsamples}, -\code{cv_subsamples_byZ}) are still accepted for backward -compatibility but should be replaced with \code{splits}.} +\item{...}{Additional arguments passed to internal methods.} } \value{ \code{ddml_late} returns an object of S3 class \code{ddml_late} and \code{ddml}. See -\code{\link{ddml-class}} for the common output structure. +\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 +\strong{Parameter of Interest:} \code{ddml_late} provides a Double/Debiased Machine Learning estimator for the local average treatment effect in the interactive model -given by +given by: -\eqn{Y = g_0(D, X) + U,} +\deqn{Y = g_0(D, X) + U,} where \eqn{(Y, D, X, Z, U)} is a random vector such that \eqn{\operatorname{supp} D = \operatorname{supp} Z = \{0,1\}}, @@ -184,22 +181,26 @@ where \eqn{(Y, D, X, Z, U)} is a random vector such that In this model, the local average treatment effect (LATE) is defined as -\eqn{\theta_0^{\textrm{LATE}} \equiv - E[g_0(1, X) - g_0(0, X)\vert p_0(1, X) > p_0(0, X)]}. +\deqn{\theta_0^{\textrm{LATE}} \equiv E[g_0(1, X) - g_0(0, X)\vert p_0(1, X) > p_0(0, X)].} -The estimating equation is -\eqn{E[m(W; \theta_0, \eta_0)] = 0}, where -\eqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta}, -\eqn{W = (Y, D, Z, X)}, and the Neyman orthogonal scores are +\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) = E[Z|X]}. -\eqn{\psi_b(W; \eta) = \frac{Z(Y - \ell_1(X))}{m(X)} - \frac{(1-Z)(Y-\ell_0(X))}{1-m(X)} + \ell_1(X) - \ell_0(X)} +\strong{Neyman Orthogonal Score / Moment Equation:} The Neyman orthogonal score is: -\eqn{\psi_a(W; \eta) = -\left(\frac{Z(D - r_1(X))}{m(X)} - \frac{(1-Z)(D-r_0(X))}{1-m(X)} + r_1(X) - r_0(X)\right)} +\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)} -\if{html}{\out{
}}\preformatted{with nuisance parameters \eqn{\eta = (\ell_0, \ell_1, r_0, r_1, m)} 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{m_0(X) = E[Z|X]}. -}\if{html}{\out{
}} +\strong{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: + +\deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} + +where: + +\deqn{\psi_a(W; \eta) = -\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)} + +\deqn{\psi_b(W; \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)} } \examples{ # Construct variables from the included Angrist & Evans (1998) data @@ -220,7 +221,7 @@ 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, @@ -237,21 +238,12 @@ 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 (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{ Other ddml estimators: -\code{\link{ddml-class}}, +\code{\link{ddml-intro}}, \code{\link{ddml_apo}()}, \code{\link{ddml_ate}()}, \code{\link{ddml_fpliv}()}, diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index ba62098..41a1ee1 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, @@ -144,42 +144,45 @@ pass-through calls with data-driven ensembles (e.g., \code{FALSE} to reduce object size at the cost of approximate weight recomputation.} -\item{...}{Deprecated arguments are still accepted for backward -compatibility but should be replaced with the \code{splits} -argument. See individual estimator pages for details.} +\item{...}{Additional arguments passed to internal methods.} } \value{ \code{ddml_pliv} returns an object of S3 class -\code{ddml_pliv} and \code{ddml}. See \code{\link{ddml-class}} +\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 +\strong{Parameter of Interest:} \code{ddml_pliv} provides a Double/Debiased Machine Learning estimator for the target parameter \eqn{\theta_0} in the partially -linear IV model given by +linear IV model given by: -\eqn{Y = \theta_0D + g_0(X) + U,} +\deqn{Y = \theta_0 D + g_0(X) + U,} 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. -In this model, the target parameter \eqn{\theta_0} is identified by the -estimating equation -\eqn{E[m(W; \theta_0, \eta_0)] = 0}, where \eqn{W = (Y, D, Z, X)} and -\eqn{m(W; \theta, \eta)} is the Neyman orthogonal score +\strong{Neyman Orthogonal Score:} The Neyman orthogonal score is: -\eqn{m(W; \theta, \eta) = (Y - \ell(X) - \theta(D - r_D(X)))(Z - r_Z(X)),} +\deqn{m(W; \theta, \eta) = [(Y - \ell(X)) - \theta(D - r_D(X))](Z - r_Z(X))} -\if{html}{\out{
}}\preformatted{with nuisance parameters \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]}. -}\if{html}{\out{
}} +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{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: + +\deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} + +where: + +\deqn{\psi_a(W; \eta) = -(D - r_D(X))(Z - r_Z(X))^\top} + +\deqn{\psi_b(W; \eta) = (Z - r_Z(X))(Y - \ell(X))} } \examples{ # Construct variables from the included Angrist & Evans (1998) data @@ -196,24 +199,9 @@ 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[AER:ivreg]{AER::ivreg()}} - Other ddml estimators: -\code{\link{ddml-class}}, +\code{\link{ddml-intro}}, \code{\link{ddml_apo}()}, \code{\link{ddml_ate}()}, \code{\link{ddml_fpliv}()}, diff --git a/man/ddml_plm.Rd b/man/ddml_plm.Rd index fcd8f9d..a03e6bd 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, @@ -135,40 +135,44 @@ pass-through calls with data-driven ensembles (e.g., \code{FALSE} to reduce object size at the cost of approximate weight recomputation.} -\item{...}{Deprecated arguments are still accepted for backward -compatibility but should be replaced with the \code{splits} -argument. See individual estimator pages for details.} +\item{...}{Additional arguments passed to internal methods.} } \value{ \code{ddml_plm} returns an object of S3 class -\code{ddml_plm} and \code{ddml}. See \code{\link{ddml-class}} +\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 +\strong{Parameter of Interest:} \code{ddml_plm} provides a Double/Debiased Machine Learning estimator for the target parameter \eqn{\theta_0} in the partially -linear model given by +linear model given by: -\eqn{Y = \theta_0D + g_0(X) + U,} +\deqn{Y = \theta_0 D + g_0(X) + U,} 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. -In this model, the target parameter \eqn{\theta_0} is identified by the -estimating equation -\eqn{E[m(W; \theta_0, \eta_0)] = 0}, where \eqn{W = (Y, D, X)} and -\eqn{m(W; \theta, \eta)} is the Neyman orthogonal score +\strong{Neyman Orthogonal Score:} The Neyman orthogonal score is: -\eqn{m(W; \theta, \eta) = (Y - \ell(X) - \theta(D - r(X)))(D - r(X)),} +\deqn{m(W; \theta, \eta) = [(Y - \ell(X)) - \theta(D - r(X))](D - r(X))} -\if{html}{\out{
}}\preformatted{with nuisance parameters \eqn{\eta = (\ell, r)} taking true values -\eqn{\ell_0(X) = E[Y|X]} and \eqn{r_0(X) = E[D|X]}. -}\if{html}{\out{
}} +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{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: + +\deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} + +where: + +\deqn{\psi_a(W; \eta) = -(D - r(X))(D - r(X))^\top} + +\deqn{\psi_b(W; \eta) = (D - r(X))(Y - \ell(X))} } \examples{ # Construct variables from the included Angrist & Evans (1998) data @@ -218,19 +222,9 @@ plm_fit2 <- ddml_plm(y, D, X, summary(plm_fit2) } } -\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{ Other ddml estimators: -\code{\link{ddml-class}}, +\code{\link{ddml-intro}}, \code{\link{ddml_apo}()}, \code{\link{ddml_ate}()}, \code{\link{ddml_fpliv}()}, diff --git a/man/ddml_rep.Rd b/man/ddml_rep.Rd index b3a3a16..f93aef2 100644 --- a/man/ddml_rep.Rd +++ b/man/ddml_rep.Rd @@ -29,8 +29,7 @@ An object of class \code{"ddml_rep"} with fields: \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.} +\item{shortstack}{Logical, whether short-stacking was used.} } } \description{ diff --git a/man/diagnostics.Rd b/man/diagnostics.Rd index 960f72d..1ef29fe 100644 --- a/man/diagnostics.Rd +++ b/man/diagnostics.Rd @@ -4,7 +4,7 @@ \alias{diagnostics} \title{Stacking Diagnostics for DDML Estimators} \usage{ -diagnostics(object, cvc = FALSE, bootnum = 500, alpha = 0.05, ...) +diagnostics(object, cvc = FALSE, bootnum = 500, ...) } \arguments{ \item{object}{An object of class \code{ddml}.} @@ -16,16 +16,12 @@ learner is significantly outperformed by the others.} \item{bootnum}{Number of bootstrap replications for CVC. Default 500. Ignored when \code{cvc = FALSE}.} -\item{alpha}{Significance level for the model confidence -set. Default 0.05.} - \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. +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, @@ -37,11 +33,27 @@ ensemble weights, and optionally cross-validation comparison 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 = list(what = ols), + learners = learners, sample_folds = 2, silent = TRUE) -diagnostics(plm_fit) -tidy(diagnostics(plm_fit)) +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 index 3e11cb0..36d9693 100644 --- a/man/ensemble.Rd +++ b/man/ensemble.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ensemble.R \name{ensemble} \alias{ensemble} -\title{Stacking estimator using combinations of base learners} +\title{Stacking Estimator Using Combinations of Base Learners} \usage{ ensemble( y, @@ -24,7 +24,8 @@ ensemble( \item{type}{A character string indicating the type of ensemble to compute. Default is \code{"average"}.} -\item{learners}{A list of base learners.} +\item{learners}{A list of base learners. See +\code{\link{ddml-intro}} for the full specification.} \item{cv_folds}{Number of cross-validation folds.} @@ -38,12 +39,16 @@ Default is \code{"average"}.} } \value{ An object of class \code{ensemble} containing: -\item{mdl_fits}{List of fitted base learners.} -\item{weights}{Computed ensemble weights.} -\item{learners}{The base learners used.} -\item{cv_results}{Cross-validation results if computed.} -\item{mean_y}{Mean of the outcome variable.} -\item{constant_y}{Boolean indicating if y is constant.} +\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 @@ -73,6 +78,8 @@ predict(ens_fit, newdata = X)[1:5] Other utilities: \code{\link{crosspred}()}, \code{\link{crossval}()}, +\code{\link{ddml}()}, +\code{\link{diagnostics}()}, \code{\link{ensemble_weights}()}, \code{\link{shortstacking}()} } diff --git a/man/ensemble_weights.Rd b/man/ensemble_weights.Rd index f2f4f2b..7260a0d 100644 --- a/man/ensemble_weights.Rd +++ b/man/ensemble_weights.Rd @@ -8,7 +8,7 @@ ensemble_weights( y, X, type = "average", - learners, + learners = NULL, cv_folds = 5, cv_subsamples = NULL, cv_results = NULL, @@ -24,7 +24,12 @@ ensemble_weights( \item{type}{A character string or vector indicating the type(s) of ensemble weights to compute. Default is \code{"average"}.} -\item{learners}{A list of base learners.} +\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.} @@ -38,8 +43,12 @@ weights to compute. Default is \code{"average"}.} } \value{ A list containing: -\item{weights}{A matrix of computed ensemble weights.} -\item{cv_results}{Cross-validation results used for computing weights.} +\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 @@ -64,6 +73,8 @@ ew$weights Other utilities: \code{\link{crosspred}()}, \code{\link{crossval}()}, +\code{\link{ddml}()}, +\code{\link{diagnostics}()}, \code{\link{ensemble}()}, \code{\link{shortstacking}()} } diff --git a/man/glance.ddml.Rd b/man/glance.ddml.Rd index 51eb3ac..db5c1a7 100644 --- a/man/glance.ddml.Rd +++ b/man/glance.ddml.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tidy.R +% Please edit documentation in R/ddml.R \name{glance.ddml} \alias{glance.ddml} \title{Glance at a ddml Object} @@ -27,8 +27,8 @@ 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) + 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 index 74fd2d9..d71f3b2 100644 --- a/man/glance.ddml_rep.Rd +++ b/man/glance.ddml_rep.Rd @@ -12,10 +12,9 @@ \item{...}{Currently unused.} } \value{ -A one-row \code{data.frame} with columns -\code{nobs}, \code{sample_folds}, \code{shortstack}, -\code{ensemble_type}, \code{model_type}, and -\code{nresamples}. +A one-row \code{data.frame} with columns \code{nobs}, +\code{sample_folds}, \code{shortstack}, \code{ensemble_type}, +\code{model_type}, and \code{nresamples}. } \description{ Returns a one-row summary of model-level statistics, diff --git a/man/hatvalues.ddml.Rd b/man/hatvalues.ddml.Rd index 910e7f1..09918bf 100644 --- a/man/hatvalues.ddml.Rd +++ b/man/hatvalues.ddml.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/methods.R +% Please edit documentation in R/ddml.R \name{hatvalues.ddml} \alias{hatvalues.ddml} \title{Extract Generalized Leverage (Hat Values)} @@ -23,14 +23,13 @@ estimator. These values are used internally to compute heteroskedasticity-robust HC3 standard errors. } \details{ -See \code{\link{ddml-class}} for the DML framework and +See \code{\link{ddml-intro}} for the DML framework and the definition of \eqn{\psi_a} and \eqn{\hat{J}}. For the linear scores used in \code{ddml}, the generalized leverage simplifies to -\if{html}{\out{
}}\preformatted{\eqn{h_{ii} = \mathrm{tr}(\psi_a(W_i; - \hat\eta)\,(n\hat{J})^{-1}).} -}\if{html}{\out{
}} +\eqn{h_{ii} = \mathrm{tr}(\psi_a(W_i; +\hat\eta)\,(n\hat{J})^{-1}).} } \examples{ \donttest{ @@ -38,8 +37,8 @@ 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) + learners = list(what = ols), + sample_folds = 2, silent = TRUE) h = hatvalues(plm_fit) head(h) } @@ -49,10 +48,9 @@ head(h) \code{\link{vcov.ddml}} for the use of leverage in HC3 standard errors. Other ddml inference: -\code{\link{[.summary.ddml}()}, \code{\link{coef.ddml}()}, \code{\link{confint.ddml}()}, -\code{\link{nobs.ddml}()}, +\code{\link{summary.ddml}()}, \code{\link{vcov.ddml}()} } \concept{ddml inference} diff --git a/man/mdl_bigGLM.Rd b/man/mdl_bigGLM.Rd index 8e776bc..7298c59 100644 --- a/man/mdl_bigGLM.Rd +++ b/man/mdl_bigGLM.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ml_wrappers.R \name{mdl_bigGLM} \alias{mdl_bigGLM} -\title{Wrapper for \code{\link[glmnet:bigGlm]{glmnet::bigGlm()}}.} +\title{Wrapper for glmnet::bigGlm()} \usage{ mdl_bigGLM(y, X, ...) } diff --git a/man/mdl_glm.Rd b/man/mdl_glm.Rd index 6c532ac..3b246bc 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, ...) } diff --git a/man/mdl_glmnet.Rd b/man/mdl_glmnet.Rd index 718469b..b65f878 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, ...) } diff --git a/man/mdl_ranger.Rd b/man/mdl_ranger.Rd index d46972f..441fd4b 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, ...) } diff --git a/man/mdl_xgboost.Rd b/man/mdl_xgboost.Rd index f0ebd72..a443d9b 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, ...) } diff --git a/man/nobs.ddml.Rd b/man/nobs.ddml.Rd index 697cfe2..6732b09 100644 --- a/man/nobs.ddml.Rd +++ b/man/nobs.ddml.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/methods.R +% Please edit documentation in R/ddml.R \name{nobs.ddml} \alias{nobs.ddml} \title{Extract Number of Observations} @@ -18,12 +18,3 @@ An integer specifying the number of observations. Returns the number of observations used to fit the DDML model. } -\seealso{ -Other ddml inference: -\code{\link{[.summary.ddml}()}, -\code{\link{coef.ddml}()}, -\code{\link{confint.ddml}()}, -\code{\link{hatvalues.ddml}()}, -\code{\link{vcov.ddml}()} -} -\concept{ddml inference} diff --git a/man/ols.Rd b/man/ols.Rd index 2a3d3b2..a6a01a6 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) } diff --git a/man/predict.ensemble.Rd b/man/predict.ensemble.Rd index a46808b..cd20f90 100644 --- a/man/predict.ensemble.Rd +++ b/man/predict.ensemble.Rd @@ -2,9 +2,9 @@ % Please edit documentation in R/ensemble.R \name{predict.ensemble} \alias{predict.ensemble} -\title{Predict method for \code{ensemble} objects.} +\title{Predict Method for \code{ensemble} Objects} \usage{ -\method{predict}{ensemble}(object, newdata, ...) +\method{predict}{ensemble}(object, newdata, ..., type = "ensemble") } \arguments{ \item{object}{A fitted \code{ensemble} object.} @@ -12,11 +12,16 @@ \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 per-learner predictions with one column per -base learner. +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. +Predict Method for \code{ensemble} Objects } diff --git a/man/predict.mdl_bigGLM.Rd b/man/predict.mdl_bigGLM.Rd index 9f26572..1cdfbf5 100644 --- a/man/predict.mdl_bigGLM.Rd +++ b/man/predict.mdl_bigGLM.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ml_wrappers.R \name{predict.mdl_bigGLM} \alias{predict.mdl_bigGLM} -\title{Predict method for \code{mdl_bigGLM} objects.} +\title{Predict Method for mdl_bigGLM Objects} \usage{ \method{predict}{mdl_bigGLM}(object, newdata = NULL, ...) } @@ -17,5 +17,5 @@ A numeric vector of predicted values. } \description{ -Predict method for \code{mdl_bigGLM} objects. +Predict Method for mdl_bigGLM Objects } diff --git a/man/predict.mdl_glm.Rd b/man/predict.mdl_glm.Rd index 473caaf..83b6585 100644 --- a/man/predict.mdl_glm.Rd +++ b/man/predict.mdl_glm.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ml_wrappers.R \name{predict.mdl_glm} \alias{predict.mdl_glm} -\title{Predict method for \code{mdl_glm} objects.} +\title{Predict Method for mdl_glm Objects} \usage{ \method{predict}{mdl_glm}(object, newdata, ...) } @@ -18,5 +18,5 @@ A numeric vector of predicted response values. } \description{ -Predict method for \code{mdl_glm} objects. +Predict Method for mdl_glm Objects } diff --git a/man/predict.mdl_glmnet.Rd b/man/predict.mdl_glmnet.Rd index e5b92b0..f0e00f5 100644 --- a/man/predict.mdl_glmnet.Rd +++ b/man/predict.mdl_glmnet.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ml_wrappers.R \name{predict.mdl_glmnet} \alias{predict.mdl_glmnet} -\title{Predict method for \code{mdl_glmnet} objects.} +\title{Predict Method for mdl_glmnet Objects} \usage{ \method{predict}{mdl_glmnet}(object, newdata = NULL, ...) } @@ -18,5 +18,5 @@ A numeric vector of predicted values. } \description{ -Predict method for \code{mdl_glmnet} objects. +Predict Method for mdl_glmnet Objects } diff --git a/man/predict.mdl_ranger.Rd b/man/predict.mdl_ranger.Rd index 2d4b2ae..868a179 100644 --- a/man/predict.mdl_ranger.Rd +++ b/man/predict.mdl_ranger.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ml_wrappers.R \name{predict.mdl_ranger} \alias{predict.mdl_ranger} -\title{Predict method for \code{mdl_ranger} objects.} +\title{Predict Method for mdl_ranger Objects} \usage{ \method{predict}{mdl_ranger}(object, newdata = NULL, ...) } @@ -19,5 +19,5 @@ A numeric vector of predicted values (probabilities for probability forests, point predictions for regression forests). } \description{ -Predict method for \code{mdl_ranger} objects. +Predict Method for mdl_ranger Objects } diff --git a/man/predict.mdl_xgboost.Rd b/man/predict.mdl_xgboost.Rd index 01f6cc9..34585f4 100644 --- a/man/predict.mdl_xgboost.Rd +++ b/man/predict.mdl_xgboost.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ml_wrappers.R \name{predict.mdl_xgboost} \alias{predict.mdl_xgboost} -\title{Predict method for \code{mdl_xgboost} objects.} +\title{Predict Method for mdl_xgboost Objects} \usage{ \method{predict}{mdl_xgboost}(object, newdata = NULL, ...) } @@ -18,5 +18,5 @@ A numeric vector of predicted values. } \description{ -Predict method for \code{mdl_xgboost} objects. +Predict Method for mdl_xgboost Objects } diff --git a/man/predict.ols.Rd b/man/predict.ols.Rd index b133972..998b2e2 100644 --- a/man/predict.ols.Rd +++ b/man/predict.ols.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ols.R \name{predict.ols} \alias{predict.ols} -\title{Predict method for \code{ols} objects.} +\title{Predict Method for ols Objects} \usage{ \method{predict}{ols}(object, newdata = NULL, ...) } @@ -18,5 +18,5 @@ returns fitted values from the training data.} A numeric vector of predicted values. } \description{ -Predict method for \code{ols} objects. +Predict Method for ols Objects } diff --git a/man/reexports.Rd b/man/reexports.Rd index c7fc9ed..15a4c72 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tidy.R +% Please edit documentation in R/ddml.R \docType{import} \name{reexports} \alias{reexports} diff --git a/man/shortstacking.Rd b/man/shortstacking.Rd index 5dd08ec..6ca7dbc 100644 --- a/man/shortstacking.Rd +++ b/man/shortstacking.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/shortstacking.R \name{shortstacking} \alias{shortstacking} -\title{Predictions using Short-Stacking.} +\title{Predictions using Short-Stacking} \usage{ shortstacking( y, @@ -15,7 +15,6 @@ shortstacking( subsamples = NULL, silent = FALSE, auxiliary_X = NULL, - shortstack_y = y, parallel = NULL ) } @@ -72,10 +71,6 @@ corresponding the custom ensemble specification.} \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: @@ -98,20 +93,20 @@ order).} \item{\code{weights}}{An array, providing the weight assigned to each base learner (in chronological order) by the ensemble procedures.} -\item{\code{mspe}}{A numeric vector of per-ensemble MSPEs for -the short-stacked predictions.} -\item{\code{r2}}{A numeric vector of per-ensemble -out-of-sample R-squared values.} +\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{cf_fitted_bylearner}}{A matrix of -out-of-sample predictions, each column corresponding to a base -learner (in chronological order).} +\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 @@ -151,6 +146,8 @@ Wolpert D H (1992). "Stacked generalization." Neural Networks, 5(2), 241-259. Other utilities: \code{\link{crosspred}()}, \code{\link{crossval}()}, +\code{\link{ddml}()}, +\code{\link{diagnostics}()}, \code{\link{ensemble}()}, \code{\link{ensemble_weights}()} } 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 index 3ad6bb6..08422f6 100644 --- a/man/summary.ddml.Rd +++ b/man/summary.ddml.Rd @@ -1,37 +1,33 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/methods.R -\name{[.summary.ddml} -\alias{[.summary.ddml} +% 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}(x, ...) - \method{summary}{ddml}(object, type = "HC1", ...) \method{print}{summary.ddml}(x, digits = 3, ...) } \arguments{ -\item{x}{An object of class \code{summary.ddml}.} - -\item{...}{Currently unused.} - \item{object}{An object of class \code{ddml}.} \item{type}{Character string specifying the variance-covariance estimator. One of \code{"HC1"} (default), \code{"HC0"}, or \code{"HC3"}.} +\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.} +(\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 @@ -41,7 +37,7 @@ folds.} } \description{ Computes a coefficient table with estimates, -standard errors, t-values, and p-values for all +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.ddml}} for the HC0/HC1/HC3 formulas. @@ -52,8 +48,8 @@ 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) + learners = list(what = ols), + sample_folds = 2, silent = TRUE) summary(plm_fit) summary(plm_fit, type = "HC3") } @@ -66,7 +62,6 @@ Other ddml inference: \code{\link{coef.ddml}()}, \code{\link{confint.ddml}()}, \code{\link{hatvalues.ddml}()}, -\code{\link{nobs.ddml}()}, \code{\link{vcov.ddml}()} } \concept{ddml inference} diff --git a/man/tidy.ddml.Rd b/man/tidy.ddml.Rd index 7665736..d47e382 100644 --- a/man/tidy.ddml.Rd +++ b/man/tidy.ddml.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tidy.R +% Please edit documentation in R/ddml.R \name{tidy.ddml} \alias{tidy.ddml} \title{Tidy a ddml Object} @@ -51,8 +51,8 @@ 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) + 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 index e7ca2a3..8bb8977 100644 --- a/man/tidy.ddml_diagnostics.Rd +++ b/man/tidy.ddml_diagnostics.Rd @@ -12,10 +12,8 @@ \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} and -\code{in_conf_set}. +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 @@ -28,10 +26,12 @@ table creation with \code{kable()}, \code{gt()}, or 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 = list(what = ols), + learners = learners, sample_folds = 2, silent = TRUE) -tidy(diagnostics(plm_fit)) +tidy(diagnostics(plm_fit, cvc = TRUE)) } } diff --git a/man/tidy.ddml_rep.Rd b/man/tidy.ddml_rep.Rd index e02f137..4aa37f1 100644 --- a/man/tidy.ddml_rep.Rd +++ b/man/tidy.ddml_rep.Rd @@ -38,10 +38,9 @@ Default 0.95.} \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}. If \code{conf.int = TRUE}, +A \code{data.frame} with columns \code{term}, \code{estimate}, +\code{std.error}, \code{statistic}, \code{p.value}, +\code{ensemble_type}, and \code{aggregation}. If \code{conf.int = TRUE}, also \code{conf.low} and \code{conf.high}. } \description{ diff --git a/man/vcov.ddml.Rd b/man/vcov.ddml.Rd index 85162f4..395b8bb 100644 --- a/man/vcov.ddml.Rd +++ b/man/vcov.ddml.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/methods.R +% Please edit documentation in R/ddml.R \name{vcov.ddml} \alias{vcov.ddml} \title{Variance-Covariance Matrix for DDML Estimators} @@ -27,7 +27,7 @@ variance-covariance matrix for the DDML estimator \eqn{\hat\theta}. } \details{ -See \code{\link{ddml-class}} for the DML framework, +See \code{\link{ddml-intro}} for the DML framework, including the definitions of the score \eqn{m_i}, the Jacobian \eqn{\hat{J}}, and the base sandwich estimator \eqn{\hat\Sigma}. This function provides @@ -42,8 +42,7 @@ three variants: \deqn{V_{\mathrm{HC1}} = V_{\mathrm{HC0}} \times \frac{n}{n - p}} -\if{html}{\out{
}}\preformatted{where \eqn{p} is the dimension of \eqn{\theta}. -}\if{html}{\out{
}} +where \eqn{p} is the dimension of \eqn{\theta}. \strong{HC3}: \deqn{V_{\mathrm{HC3}} = \hat{J}^{-1} @@ -51,9 +50,8 @@ three variants: \frac{m_i m_i'}{(1 - h_{ii})^2}\right) \hat{J}^{-\top} / n} -\if{html}{\out{
}}\preformatted{where \eqn{h_{ii}} is the generalized leverage; +where \eqn{h_{ii}} is the generalized leverage; see \code{\link{hatvalues.ddml}}. -}\if{html}{\out{
}} } \examples{ \donttest{ @@ -61,8 +59,8 @@ 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) + learners = list(what = ols), + sample_folds = 2, silent = TRUE) vcov(plm_fit) vcov(plm_fit, type = "HC3") } @@ -74,10 +72,9 @@ vcov(plm_fit, type = "HC3") \code{\link{summary.ddml}} Other ddml inference: -\code{\link{[.summary.ddml}()}, \code{\link{coef.ddml}()}, \code{\link{confint.ddml}()}, \code{\link{hatvalues.ddml}()}, -\code{\link{nobs.ddml}()} +\code{\link{summary.ddml}()} } \concept{ddml inference} diff --git a/man/vcov.ddml_rep.Rd b/man/vcov.ddml_rep.Rd index 64cc338..5115fd8 100644 --- a/man/vcov.ddml_rep.Rd +++ b/man/vcov.ddml_rep.Rd @@ -29,7 +29,7 @@ variance-covariance estimator. One of \code{"HC1"} \item{...}{Currently unused.} } \value{ -A p x p variance-covariance matrix. +A \eqn{p \times p}{p x p} variance-covariance matrix. } \description{ Returns a variance-covariance matrix from cross-resample diff --git a/tests/testthat/test-cvc.R b/tests/testthat/test-cvc.R deleted file mode 100644 index ebd4b3b..0000000 --- a/tests/testthat/test-cvc.R +++ /dev/null @@ -1,87 +0,0 @@ -test_that("cvc_pairwise detects a dominant learner", { - set.seed(42) - n <- 500 - # Learner 1 has small residuals, learner 2 has large residuals - resid1 <- rnorm(n, sd = 0.5) - resid2 <- rnorm(n, sd = 2.0) - fid <- rep(seq_len(5), each = n / 5) - - # zeta = resid1^2 - resid2^2 < 0 when learner 1 is better - # → Tx < 0 → p-value near 1 (cannot reject that 1 is worse) - pval_12 <- cvc_pairwise(resid1, resid2, fid, bootnum = 500) - expect_true(pval_12 > 0.9) - - # Reversed: learner 2 worse → p-value near 0 - pval_21 <- cvc_pairwise(resid2, resid1, fid, bootnum = 500) - expect_true(pval_21 < 0.1) -}) - -test_that("cvc_pairwise moderate for equal learners", { - set.seed(123) - n <- 1000 - resid1 <- rnorm(n) - resid2 <- rnorm(n) - fid <- rep(seq_len(5), each = n / 5) - - pval <- cvc_pairwise(resid1, resid2, fid, bootnum = 500) - - expect_true(pval > 0.05 && pval < 0.95) -}) - -test_that("cvc_pairwise returns NA for identical residuals", { - n <- 100 - resid <- rnorm(n) - fid <- rep(seq_len(5), each = n / 5) - - pval <- cvc_pairwise(resid, resid, fid, bootnum = 100) - expect_true(is.na(pval)) -}) - -test_that("cvc_confidence_set includes the best learner", { - set.seed(42) - n <- 500 - resid_mat <- cbind( - rnorm(n, sd = 0.5), - rnorm(n, sd = 1.5), - rnorm(n, sd = 2.0)) - fid <- rep(seq_len(5), each = n / 5) - - cs <- cvc_confidence_set(resid_mat, fid, - bootnum = 500, alpha = 0.10) - - expect_length(cs$pvalues, 3) - expect_length(cs$confidence_set, 3) - # Best learner (column 1) should be in the confidence set - expect_true(cs$confidence_set[1]) -}) - -test_that("cvc_test returns correct structure", { - set.seed(42) - n <- 200 - resid_mat <- cbind(rnorm(n), rnorm(n), rnorm(n)) - colnames(resid_mat) <- c("ols", "lasso", "ridge") - subsamples <- list(1:100, 101:200) - - res <- cvc_test(resid_mat, subsamples, - bootnum = 100, alpha = 0.05) - - expect_true(is.list(res)) - expect_equal(dim(res$pairwise), c(3, 3)) - expect_true(all(is.na(diag(res$pairwise)))) - expect_length(res$pvalues, 3) - expect_length(res$confidence_set, 3) - expect_identical(rownames(res$pairwise), - c("ols", "lasso", "ridge")) -}) - -test_that("cvc_test handles unequal fold sizes", { - set.seed(42) - n <- 103 - resid_mat <- cbind(rnorm(n), rnorm(n)) - subsamples <- list(1:51, 52:103) - - res <- cvc_test(resid_mat, subsamples, bootnum = 100) - - expect_equal(dim(res$pairwise), c(2, 2)) - expect_length(res$pvalues, 2) -}) diff --git a/tests/testthat/test-ddml.R b/tests/testthat/test-ddml.R new file mode 100644 index 0000000..933e5ea --- /dev/null +++ b/tests/testthat/test-ddml.R @@ -0,0 +1,461 @@ +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)) + psi_b <- list(matrix(y, ncol = 1)) + psi_a <- list(array(-1, dim = c(n, 1, 1))) + + fit <- ddml( + coefficients = coef, scores = scores, J = J, + psi_a = psi_a, psi_b = psi_b, + 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)) + psi_b <- list(matrix(rnorm(n), ncol = 1)) + psi_a <- list(array(-1, dim = c(n, 1, 1))) + + fit <- ddml( + coefficients = coef, scores = scores, J = J, + psi_a = psi_a, psi_b = psi_b, + 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")) +}) + +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)) + psi_b <- list(matrix(rnorm(n), ncol = 1)) + psi_a <- list(array(-1, dim = c(n, 1, 1))) + + fit <- ddml( + coefficients = coef, scores = scores, J = J, + psi_a = psi_a, psi_b = psi_b, + 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)), + psi_a = list(1), psi_b = list(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)), + psi_a = list(1), psi_b = list(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), + psi_a = list(1), psi_b = list(1), + nobs = n, coef_names = "x", + estimator_name = "Bad"), + "3D array") + + # psi_a/psi_b not lists + expect_error( + ddml(coefficients = matrix(1, 1, 1), + scores = array(1, c(n, 1, 1)), + J = array(1, c(1, 1, 1)), + psi_a = 1, psi_b = list(1), + nobs = n, coef_names = "x", + estimator_name = "Bad"), + "lists") + + # 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)), + psi_a = list(1), psi_b = list(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)), + psi_a = list(1), psi_b = list(1), + nobs = n, coef_names = c("a", "b"), + estimator_name = "Bad"), + "p x p x nensb") + + # Length mismatch: psi_a wrong length + expect_error( + ddml(coefficients = matrix(1, 1, 2), + scores = array(1, c(n, 1, 2)), + J = array(1, c(1, 1, 2)), + psi_a = list(1), psi_b = list(1, 1), + nobs = n, coef_names = "x", + estimator_name = "Bad"), + "length nensb") +}) + +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, ensemble_idx = 2) + expect_true(is.matrix(V)) + expect_equal(dim(V), c(1, 1)) + + # confint + ci <- confint(fit, ensemble_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("ensemble_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, ensemble_idx = 99)) + expect_error(hatvalues(fit, ensemble_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) +}) + diff --git a/tests/testthat/test-ddml_apo.R b/tests/testthat/test-ddml_apo.R index c75a981..3d43a8f 100644 --- a/tests/testthat/test-ddml_apo.R +++ b/tests/testthat/test-ddml_apo.R @@ -251,49 +251,3 @@ test_that("ddml_apo fitted pass-through works", { ) }) -test_that("ddml_apo legacy grouped split args warn and still work", { - set.seed(202) - nobs <- 600 - X <- matrix(rnorm(nobs * 4), nobs, 4) - D_tld <- X %*% c(0.7, 0.2, 0.1, 0) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% c(0.2, 0.3, 0.1, 0.4) + rnorm(nobs) - learners <- list(what = ols) - splits <- get_sample_splits( - cluster_variable = seq_len(nobs), - sample_folds = 3, - cv_folds = 3, - D = 1 * (D == 1), - stratify = TRUE - ) - fit_splits <- ddml_apo( - y, D, X, - d = 1, - learners = learners, - sample_folds = 3, - cv_folds = 3, - splits = list( - subsamples = splits$subsamples, - subsamples_byd = splits$subsamples_byD, - cv_subsamples = splits$cv_subsamples, - cv_subsamples_byd = splits$cv_subsamples_byD - ), - silent = TRUE - ) - expect_warning( - fit_legacy <- ddml_apo( - y, D, X, - d = 1, - learners = learners, - sample_folds = 3, - cv_folds = 3, - subsamples = splits$subsamples, - subsamples_byd = splits$subsamples_byD, - cv_subsamples = splits$cv_subsamples, - cv_subsamples_byd = splits$cv_subsamples_byD, - silent = TRUE - ), - "Deprecated split arguments detected" - ) - expect_equal(coef(fit_legacy), coef(fit_splits), tolerance = 1e-8) -}) diff --git a/tests/testthat/test-ddml_ate.R b/tests/testthat/test-ddml_ate.R index f30ebff..c99aa14 100644 --- a/tests/testthat/test-ddml_ate.R +++ b/tests/testthat/test-ddml_ate.R @@ -236,51 +236,6 @@ test_that("ddml_ate fitted pass-through works", { ) }) -test_that("ddml_ate legacy grouped split args warn and still work", { - set.seed(202) - nobs <- 600 - X <- matrix(rnorm(nobs * 4), nobs, 4) - D_tld <- X %*% c(0.7, 0.2, 0.1, 0) + rnorm(nobs) - D <- 1 * (D_tld > mean(D_tld)) - y <- D + X %*% c(0.2, 0.3, 0.1, 0.4) + rnorm(nobs) - learners <- list(what = ols) - splits <- get_sample_splits( - cluster_variable = seq_len(nobs), - sample_folds = 3, - cv_folds = 3, - D = D, - stratify = TRUE - ) - fit_splits <- ddml_ate( - y, D, X, - learners = learners, - sample_folds = 3, - cv_folds = 3, - splits = list( - subsamples = splits$subsamples, - subsamples_byD = splits$subsamples_byD, - cv_subsamples = splits$cv_subsamples, - cv_subsamples_byD = splits$cv_subsamples_byD - ), - silent = TRUE - ) - expect_warning( - fit_legacy <- ddml_ate( - y, D, X, - learners = learners, - sample_folds = 3, - cv_folds = 3, - subsamples = splits$subsamples, - subsamples_byD = splits$subsamples_byD, - cv_subsamples = splits$cv_subsamples, - cv_subsamples_byD = splits$cv_subsamples_byD, - silent = TRUE - ), - "Deprecated split arguments detected" - ) - expect_equal(coef(fit_legacy), coef(fit_splits), tolerance = 1e-8) -}) - test_that("ddml_ate scores are mean-zero", { nobs <- 500 set.seed(42) diff --git a/tests/testthat/test-ddml_att.R b/tests/testthat/test-ddml_att.R index 06342f0..a448638 100644 --- a/tests/testthat/test-ddml_att.R +++ b/tests/testthat/test-ddml_att.R @@ -36,17 +36,17 @@ test_that("ddml_att computes with stratify = FALSE", { })#TEST_THAT test_that("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) ddml_att_fit <- ddml_att(y, D, X, @@ -149,17 +149,17 @@ test_that("summary.ddml_att computes with a single model", { })#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) ddml_att_fit <- ddml_att(y, D, X, diff --git a/tests/testthat/test-ddml_fpliv.R b/tests/testthat/test-ddml_fpliv.R index 6a3a9bb..4956c51 100644 --- a/tests/testthat/test-ddml_fpliv.R +++ b/tests/testthat/test-ddml_fpliv.R @@ -283,8 +283,8 @@ test_that("ddml_fpliv HC0/HC1 SEs close to sandwich::vcovHC on iv_fit", { # 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$D_X[[1]]$cf_fitted_bylearner[, 1]) - V_r <- as.matrix(fit$fitted$D_XZ[[1]]$cf_fitted_bylearner[, 1] - fit$fitted$D_X[[1]]$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) diff --git a/tests/testthat/test-ddml_pliv.R b/tests/testthat/test-ddml_pliv.R index a5b4809..c12d177 100644 --- a/tests/testthat/test-ddml_pliv.R +++ b/tests/testthat/test-ddml_pliv.R @@ -265,8 +265,8 @@ test_that("ddml_pliv HC0/HC1 SEs close to sandwich::vcovHC on iv_fit", { # 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$D_X[[1]]$cf_fitted_bylearner[, 1]) - V_r <- as.matrix(Z - fit$fitted$Z_X[[1]]$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) diff --git a/tests/testthat/test-ddml_plm.R b/tests/testthat/test-ddml_plm.R index 5c0f3e7..c990925 100644 --- a/tests/testthat/test-ddml_plm.R +++ b/tests/testthat/test-ddml_plm.R @@ -501,7 +501,7 @@ test_that("ddml_plm HC0/HC1/HC3 SEs close to sandwich::vcovHC on ols_fit", { # 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$D_X[[1]]$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) diff --git a/tests/testthat/test-diagnostics.R b/tests/testthat/test-diagnostics.R index ea5f722..135120a 100644 --- a/tests/testthat/test-diagnostics.R +++ b/tests/testthat/test-diagnostics.R @@ -86,16 +86,21 @@ test_that("diagnostics with CVC", { diag <- diagnostics(fit, cvc = TRUE, bootnum = 100) - # CVC columns should be present + # CVC column should be present for (eq in names(diag$tables)) { expect_true("cvc_pval" %in% colnames(diag$tables[[eq]])) - expect_true("in_conf_set" %in% + } + + # 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 columns + # 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", { @@ -143,3 +148,40 @@ 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 26bbdd8..c58b509 100644 --- a/tests/testthat/test-ensemble.R +++ b/tests/testthat/test-ensemble.R @@ -104,9 +104,16 @@ test_that("ensemble returns mean_y for constant outcomes", { # Check predictions 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 index 091f336..78d13e8 100644 --- a/tests/testthat/test-get_CEF.R +++ b/tests/testthat/test-get_CEF.R @@ -121,3 +121,134 @@ test_that("get_CEF pass-through with pre-ensembled fitted uses Rule 1", { 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 0d631f0..d9da1ff 100644 --- a/tests/testthat/test-help_functions.R +++ b/tests/testthat/test-help_functions.R @@ -65,3 +65,17 @@ test_that("ddml_plm works with list(fun=) for backward compat", { 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-methods.R b/tests/testthat/test-methods.R deleted file mode 100644 index 1cf3001..0000000 --- a/tests/testthat/test-methods.R +++ /dev/null @@ -1,212 +0,0 @@ -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, ensemble_idx = 2) - expect_true(is.matrix(V)) - expect_equal(dim(V), c(1, 1)) - - # confint - ci <- confint(fit, ensemble_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 <- 200 - 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 <- 200 - 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("ensemble_idx out of range errors", { - set.seed(42) - nobs <- 200 - 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, ensemble_idx = 99)) - expect_error(hatvalues(fit, ensemble_idx = 0)) -}) 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-subsample_functions.R b/tests/testthat/test-subsample_functions.R index 09871f1..c732a89 100644 --- a/tests/testthat/test-subsample_functions.R +++ b/tests/testthat/test-subsample_functions.R @@ -187,3 +187,38 @@ test_that("auxiliary_X construction works with multi-valued D", { expect_equal(dim(auxiliary_X_d[[1]])[1], length(res$aux_indx[[1]][[1]])) })#TEST_THAT + +# --- 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/tests/testthat/test-tidy.R b/tests/testthat/test-tidy.R deleted file mode 100644 index 6bc5bc1..0000000 --- a/tests/testthat/test-tidy.R +++ /dev/null @@ -1,99 +0,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) -}) diff --git a/vignettes/articles/did.Rmd b/vignettes/articles/did.Rmd index e463f44..4da3d89 100644 --- a/vignettes/articles/did.Rmd +++ b/vignettes/articles/did.Rmd @@ -167,8 +167,9 @@ ddml_did_method <- function(y1, y0, D, covariates, ...) { global_ddml_fits[[length(global_ddml_fits) + 1]] <<- att_fit # 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) + att_est <- as.numeric(att_fit$coefficients) + inf.func <- as.vector(att_fit$psi_b[[1]]) + att_est * as.vector(att_fit$psi_a[[1]]) + output <- list(ATT = att_est, att.inf.func = inf.func) return(output) }#DDML_DID_METHOD ``` @@ -180,7 +181,7 @@ A potentially suitable machine learning reduced form estimator is gradient tree my_did_xgboost <- function(y1, y0, D, covariates, ...) { # Hard-code learners learners = list(what = mdl_xgboost, - args = list(nround = 50, + args = list(nrounds = 50, params = list(eta = 0.1, max_depth = 3), early_stopping_rounds = 1)) learners_DX = learners @@ -218,22 +219,22 @@ summary(attgt_xgboost) #> #> Group-Time Average Treatment Effects: #> Group Time ATT(g,t) Std. Error [95% Simult. Conf. Band] -#> 2004 2004 -0.4859 1.9087 -5.1543 4.1825 -#> 2004 2005 0.0885 2.2336 -5.3745 5.5515 -#> 2004 2006 0.3182 0.8942 -1.8690 2.5054 -#> 2004 2007 3.1768 1.9115 -1.4985 7.8521 -#> 2006 2004 -0.0792 0.1078 -0.3427 0.1844 -#> 2006 2005 0.1491 0.1388 -0.1905 0.4887 -#> 2006 2006 0.0698 0.1348 -0.2599 0.3995 -#> 2006 2007 -0.1889 0.2324 -0.7573 0.3795 -#> 2007 2004 -0.0321 0.0577 -0.1731 0.1090 -#> 2007 2005 0.3086 0.1650 -0.0949 0.7121 -#> 2007 2006 -0.0739 0.1595 -0.4641 0.3163 -#> 2007 2007 0.0403 0.3692 -0.8626 0.9433 +#> 2004 2004 -0.8753 1.2320 -3.8769 2.1263 +#> 2004 2005 0.2318 0.8761 -1.9026 2.3661 +#> 2004 2006 -1.1267 1.9940 -5.9845 3.7312 +#> 2004 2007 2.2817 1.3789 -1.0777 5.6410 +#> 2006 2004 -0.2555 0.1502 -0.6215 0.1104 +#> 2006 2005 0.2194 0.1394 -0.1201 0.5590 +#> 2006 2006 -0.0250 0.0988 -0.2656 0.2156 +#> 2006 2007 0.1796 0.3459 -0.6631 1.0224 +#> 2007 2004 -0.0174 0.1516 -0.3866 0.3519 +#> 2007 2005 0.1452 0.1666 -0.2607 0.5510 +#> 2007 2006 0.0346 0.2012 -0.4556 0.5248 +#> 2007 2007 -0.1585 0.2331 -0.7264 0.4095 #> --- #> Signif. codes: `*' confidence band does not cover 0 #> -#> P-value for pre-test of parallel trends assumption: 0.17498 +#> P-value for pre-test of parallel trends assumption: 0.26144 #> Control Group: Never Treated, Anticipation Periods: 0 # plot the coefficients @@ -261,18 +262,18 @@ summary(dyn_xgboost) #> #> Overall summary of ATT's based on event-study/dynamic aggregation: #> ATT Std. Error [ 95% Conf. Int.] -#> 0.8475 0.6729 -0.4713 2.1663 +#> 0.2866 0.6471 -0.9817 1.5549 #> #> #> Dynamic Effects: #> Event time Estimate Std. Error [95% Simult. Conf. Band] -#> -3 -0.0321 0.0568 -0.1609 0.0967 -#> -2 0.2179 0.1337 -0.0853 0.5211 -#> -1 -0.0217 0.1200 -0.2939 0.2504 -#> 0 -0.0086 0.3829 -0.8769 0.8597 -#> 1 -0.0964 0.8577 -2.0416 1.8487 -#> 2 0.3182 0.8646 -1.6425 2.2788 -#> 3 3.1768 2.0440 -1.4587 7.8122 +#> -3 -0.0174 0.1556 -0.3593 0.3245 +#> -2 0.0514 0.1360 -0.2473 0.3502 +#> -1 0.0779 0.1405 -0.2308 0.3865 +#> 0 -0.2056 0.1859 -0.6140 0.2028 +#> 1 0.1970 0.3309 -0.5299 0.9239 +#> 2 -1.1267 1.9879 -5.4935 3.2401 +#> 3 2.2817 1.3781 -0.7456 5.3089 #> --- #> Signif. codes: `*' confidence band does not cover 0 #> @@ -309,11 +310,11 @@ my_did_stacking <- function(y1, y0, D, covariates, ...) { # Hard-code learners for outcome reduced-form learners = list(list(what = ols), list(what = mdl_xgboost, - args = list(nround = 50, + args = list(nrounds = 50, params = list(eta = 0.1, max_depth = 1), early_stopping_rounds = 1)), list(what = mdl_xgboost, - args = list(nround = 50, + args = list(nrounds = 50, params = list(eta = 0.1, max_depth = 3), early_stopping_rounds = 1)), list(what = mdl_ranger, @@ -325,11 +326,11 @@ my_did_stacking <- function(y1, y0, D, covariates, ...) { # Hard-code learners for treatment reduced-form learners_DX = list(list(what = mdl_glm), list(what = mdl_xgboost, - args = list(nround = 50, + args = list(nrounds = 50, params = list(eta = 0.1, max_depth = 1), early_stopping_rounds = 1)), list(what = mdl_xgboost, - args = list(nround = 50, + args = list(nrounds = 50, params = list(eta = 0.1, max_depth = 3), early_stopping_rounds = 1)), list(what = mdl_ranger, @@ -376,22 +377,22 @@ summary(attgt_stacking) #> #> Group-Time Average Treatment Effects: #> Group Time ATT(g,t) Std. Error [95% Simult. Conf. Band] -#> 2004 2004 -0.0121 0.0233 -0.0738 0.0495 -#> 2004 2005 -0.0800 0.0305 -0.1606 0.0007 -#> 2004 2006 -0.1404 0.0385 -0.2419 -0.0389 * -#> 2004 2007 -0.1085 0.0355 -0.2022 -0.0148 * -#> 2006 2004 -0.0007 0.0207 -0.0552 0.0538 -#> 2006 2005 -0.0070 0.0189 -0.0570 0.0429 -#> 2006 2006 0.0002 0.0203 -0.0533 0.0538 -#> 2006 2007 -0.0372 0.0202 -0.0905 0.0161 -#> 2007 2004 0.0212 0.0127 -0.0123 0.0546 -#> 2007 2005 -0.0025 0.0151 -0.0423 0.0372 -#> 2007 2006 -0.0296 0.0169 -0.0743 0.0151 -#> 2007 2007 -0.0277 0.0166 -0.0715 0.0160 +#> 2004 2004 -0.0105 0.0243 -0.0739 0.0529 +#> 2004 2005 -0.0736 0.0299 -0.1516 0.0045 +#> 2004 2006 -0.1393 0.0377 -0.2375 -0.0410 * +#> 2004 2007 -0.1110 0.0331 -0.1973 -0.0248 * +#> 2006 2004 -0.0016 0.0245 -0.0655 0.0623 +#> 2006 2005 -0.0075 0.0186 -0.0559 0.0410 +#> 2006 2006 0.0075 0.0215 -0.0486 0.0635 +#> 2006 2007 -0.0414 0.0196 -0.0924 0.0096 +#> 2007 2004 0.0266 0.0148 -0.0120 0.0651 +#> 2007 2005 -0.0030 0.0155 -0.0434 0.0375 +#> 2007 2006 -0.0325 0.0176 -0.0783 0.0134 +#> 2007 2007 -0.0287 0.0164 -0.0715 0.0141 #> --- #> Signif. codes: `*' confidence band does not cover 0 #> -#> P-value for pre-test of parallel trends assumption: 0.33819 +#> P-value for pre-test of parallel trends assumption: 0.18267 #> Control Group: Never Treated, Anticipation Periods: 0 # plot the coefficients @@ -420,18 +421,18 @@ summary(dyn_stacking) #> #> Overall summary of ATT's based on event-study/dynamic aggregation: #> ATT Std. Error [ 95% Conf. Int.] -#> -0.0801 0.0203 -0.12 -0.0403 * +#> -0.0804 0.021 -0.1217 -0.0392 * #> #> #> Dynamic Effects: #> Event time Estimate Std. Error [95% Simult. Conf. Band] -#> -3 0.0212 0.0148 -0.0166 0.0589 -#> -2 -0.0021 0.0126 -0.0343 0.0301 -#> -1 -0.0243 0.0145 -0.0613 0.0127 -#> 0 -0.0202 0.0120 -0.0508 0.0103 -#> 1 -0.0514 0.0160 -0.0923 -0.0106 * -#> 2 -0.1404 0.0416 -0.2466 -0.0342 * -#> 3 -0.1085 0.0330 -0.1928 -0.0241 * +#> -3 0.0266 0.0143 -0.0088 0.0619 +#> -2 -0.0027 0.0131 -0.0352 0.0299 +#> -1 -0.0266 0.0145 -0.0626 0.0094 +#> 0 -0.0192 0.0113 -0.0472 0.0087 +#> 1 -0.0521 0.0158 -0.0914 -0.0128 * +#> 2 -0.1393 0.0372 -0.2315 -0.0471 * +#> 3 -0.1110 0.0339 -0.1949 -0.0271 * #> --- #> Signif. codes: `*' confidence band does not cover 0 #> @@ -463,20 +464,24 @@ print(diagnostics(cell_fit, cvc = TRUE)) #> Obs: 329 #> #> y_X_D0: -#> learner mspe r2 weight cvc_pval -#> learner_1 0.0662 8e-04 0.3048 0.958 -#> learner_2 0.0662 8e-04 0.0184 0.002 -#> learner_3 0.0662 8e-04 0.0000 0.000 -#> learner_4 0.0662 8e-04 0.0000 0.272 -#> learner_5 0.0662 8e-04 0.0000 0.464 +#> learner mspe r2 weight_nnls cvc_pval +#> learner_1 0.0666 -0.0066 0.1921 0.982 +#> learner_2 0.1238 -0.8696 0.0000 0.002 +#> learner_3 0.1238 -0.8696 0.0000 0.000 +#> learner_4 0.0676 -0.0218 0.0000 0.266 +#> learner_5 0.0676 -0.0207 0.0000 0.280 #> #> D_X: -#> learner mspe r2 weight cvc_pval -#> learner_1 0.057 0.0043 0.9216 0.930 -#> learner_2 0.057 0.0043 0.0506 0.000 -#> learner_3 0.057 0.0043 0.0000 0.000 -#> learner_4 0.057 0.0043 0.0000 0.400 -#> learner_5 0.057 0.0043 0.0000 0.598 +#> learner mspe r2 weight_nnls cvc_pval +#> learner_1 0.0575 -0.0038 0.9231 0.998 +#> learner_2 0.1011 -0.7655 0.0000 0.000 +#> learner_3 0.1011 -0.7655 0.0000 0.000 +#> learner_4 0.0580 -0.0135 0.0000 0.226 +#> learner_5 0.0581 -0.0145 0.0000 0.130 +#> +#> D: +#> learner mspe r2 weight_average cvc_pval +#> learner_1 0.0571 0.003 1 NA #> #> Note: CVC compares individual base learners. #> Shortstacked ensemble CVC is not available (weights use all data). @@ -488,7 +493,7 @@ This diagnostic output displays the cross-validated Mean Squared Prediction Erro 1. **$R^2$**: Evaluates the proportion of variance explained by each learner out-of-sample. Because these are computed on hold-out folds, negative values can occur and indicate that a learner performs worse than a simple constant mean prediction (often a sign of severe overfitting or algorithmic mismatch). 2. **Weights**: The short-stacking algorithm assigns weights to optimally combine the learners and minimize the overall MSPE. Learners with $0$ weight do not contribute to the final predictions because their predictive power is either poor or entirely subsumed by other models in the ensemble. -3. **CVC P-Values**: The ``cvc_pval`` column shows the p-value from a Cross-Validation Criteria test (Ahrens et al. 2024), comparing each learner's MSPE against the MSPE of the single-best ML model in the list. A high p-value (e.g. > 0.05) indicates that the learner's predictive performance is not statistically worse than the best learner. If simple linear models (e.g., ``ols``) show high p-values, it implies machine learning does not significantly improve prediction out-of-sample for this specific parameter, which can legally justify reverting to simpler, faster estimators. +3. **CVC P-Values**: The ``cvc_pval`` column shows the p-value from a Cross-Validation Criteria test (Lei, 2020), comparing each learner's MSPE against the MSPE of the single-best ML model in the list. A high p-value (e.g. > 0.05) indicates that the learner's predictive performance is not statistically worse than the best learner. If simple linear models (e.g., ``ols``) show high p-values, it implies machine learning does not significantly improve prediction out-of-sample for this specific parameter, which can legally justify reverting to simpler, faster estimators. 4. **Actionable Efficiency**: If your diagnostic output consistently assigns $0$ weight, negative $R^2$, and $0.000$ CVC p-values to computationally expensive models (like deep random forests), you can safely remove them from the ``learners`` list in future runs to dramatically reduce computation time without sacrificing accuracy. @@ -502,3 +507,5 @@ Callaway B, Sant'Anna P (2021). “did: Difference in Differences.” R package Chang NC (2020). "Double/debiased machine learning for difference-in-difference models." The Econometrics Journal, 177-191. +Lei J (2020). "Cross-Validation With Confidence." Journal of the American Statistical Association, 115(532), 1978-1997. + diff --git a/vignettes/articles/did.Rmd.txt b/vignettes/articles/did.Rmd.txt index cb7a9c2..6bbf2d2 100644 --- a/vignettes/articles/did.Rmd.txt +++ b/vignettes/articles/did.Rmd.txt @@ -101,8 +101,9 @@ ddml_did_method <- function(y1, y0, D, covariates, ...) { global_ddml_fits[[length(global_ddml_fits) + 1]] <<- att_fit # 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) + att_est <- as.numeric(att_fit$coefficients) + inf.func <- as.vector(att_fit$psi_b[[1]]) + att_est * as.vector(att_fit$psi_a[[1]]) + output <- list(ATT = att_est, att.inf.func = inf.func) return(output) }#DDML_DID_METHOD ``` @@ -113,7 +114,7 @@ A potentially suitable machine learning reduced form estimator is gradient tree my_did_xgboost <- function(y1, y0, D, covariates, ...) { # Hard-code learners learners = list(what = mdl_xgboost, - args = list(nround = 50, + args = list(nrounds = 50, params = list(eta = 0.1, max_depth = 3), early_stopping_rounds = 1)) learners_DX = learners @@ -179,11 +180,11 @@ my_did_stacking <- function(y1, y0, D, covariates, ...) { # Hard-code learners for outcome reduced-form learners = list(list(what = ols), list(what = mdl_xgboost, - args = list(nround = 50, + args = list(nrounds = 50, params = list(eta = 0.1, max_depth = 1), early_stopping_rounds = 1)), list(what = mdl_xgboost, - args = list(nround = 50, + args = list(nrounds = 50, params = list(eta = 0.1, max_depth = 3), early_stopping_rounds = 1)), list(what = mdl_ranger, @@ -195,11 +196,11 @@ my_did_stacking <- function(y1, y0, D, covariates, ...) { # Hard-code learners for treatment reduced-form learners_DX = list(list(what = mdl_glm), list(what = mdl_xgboost, - args = list(nround = 50, + args = list(nrounds = 50, params = list(eta = 0.1, max_depth = 1), early_stopping_rounds = 1)), list(what = mdl_xgboost, - args = list(nround = 50, + args = list(nrounds = 50, params = list(eta = 0.1, max_depth = 3), early_stopping_rounds = 1)), list(what = mdl_ranger, @@ -274,7 +275,7 @@ This diagnostic output displays the cross-validated Mean Squared Prediction Erro 1. **$R^2$**: Evaluates the proportion of variance explained by each learner out-of-sample. Because these are computed on hold-out folds, negative values can occur and indicate that a learner performs worse than a simple constant mean prediction (often a sign of severe overfitting or algorithmic mismatch). 2. **Weights**: The short-stacking algorithm assigns weights to optimally combine the learners and minimize the overall MSPE. Learners with $0$ weight do not contribute to the final predictions because their predictive power is either poor or entirely subsumed by other models in the ensemble. -3. **CVC P-Values**: The ``cvc_pval`` column shows the p-value from a Cross-Validation Criteria test (Ahrens et al. 2024), comparing each learner's MSPE against the MSPE of the single-best ML model in the list. A high p-value (e.g. > 0.05) indicates that the learner's predictive performance is not statistically worse than the best learner. If simple linear models (e.g., ``ols``) show high p-values, it implies machine learning does not significantly improve prediction out-of-sample for this specific parameter, which can legally justify reverting to simpler, faster estimators. +3. **CVC P-Values**: The ``cvc_pval`` column shows the p-value from a Cross-Validation Criteria test (Lei, 2020), comparing each learner's MSPE against the MSPE of the single-best ML model in the list. A high p-value (e.g. > 0.05) indicates that the learner's predictive performance is not statistically worse than the best learner. If simple linear models (e.g., ``ols``) show high p-values, it implies machine learning does not significantly improve prediction out-of-sample for this specific parameter, which can legally justify reverting to simpler, faster estimators. 4. **Actionable Efficiency**: If your diagnostic output consistently assigns $0$ weight, negative $R^2$, and $0.000$ CVC p-values to computationally expensive models (like deep random forests), you can safely remove them from the ``learners`` list in future runs to dramatically reduce computation time without sacrificing accuracy. @@ -288,3 +289,5 @@ Callaway B, Sant'Anna P (2021). “did: Difference in Differences.” R package Chang NC (2020). "Double/debiased machine learning for difference-in-difference models." The Econometrics Journal, 177-191. +Lei J (2020). "Cross-Validation With Confidence." Journal of the American Statistical Association, 115(532), 1978-1997. + diff --git a/vignettes/articles/example_401k.Rmd b/vignettes/articles/example_401k.Rmd index 2fa5e3f..18598b0 100644 --- a/vignettes/articles/example_401k.Rmd +++ b/vignettes/articles/example_401k.Rmd @@ -66,8 +66,9 @@ summary(xgboost_fit) #> DDML estimation: Partially Linear Model #> Obs: 9915 Folds: 5 #> -#> Estimate Std. Error t value Pr(>|t|) -#> D_r 13916 1544 9.01 <2e-16 *** +#> 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 @@ -136,17 +137,37 @@ summary(stacking_fit) #> DDML estimation: Partially Linear Model #> Obs: 9915 Folds: 5 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> D_r 13602 1550 8.77 <2e-16 *** +#> 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$ensemble_weights, round, 4) -#> list() +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 @@ -203,18 +224,40 @@ summary(stacking_fit) #> DDML estimation: Partially Linear Model #> Obs: 9915 Folds: 5 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> D_r 14008 1463 9.57 <2e-16 *** +#> 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$ensemble_weights, round, 4) -#> list() +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 @@ -262,19 +305,41 @@ summary(stacking_fit) #> DDML estimation: Partially Linear Model #> Obs: 9915 Folds: 5 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> D_r 13945 1491 9.35 <2e-16 *** +#> 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$ensemble_weights, round, 4) -#> list() +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 @@ -283,16 +348,10 @@ Estimating multiple machine learners via cross-fitting can be computationally ex 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 computed ``crossval_resid`` and ``crossfit_fitted`` objects for the specified learners, we can bypass the estimation step entirely. +Because ``stacking_fit`` already contains the cross-fitted predictions and sample splits in its ``fitted`` component, we can bypass the estimation step entirely. ```r -# Extract the predictions and residuals from the previous fit -advanced_passthrough <- list( - crossfit_fitted = stacking_fit$fitted$crossfit_fitted, - crossval_resid = stacking_fit$fitted$crossval_resid -) - # Recompute the structural parameter instantly using 'singlebest' stacking_refit <- ddml_plm( y = y, D = D, X = X_c, @@ -300,12 +359,19 @@ stacking_refit <- ddml_plm( learners_DX = learners_DX, ensemble_type = "singlebest", sample_folds = 5, - fitted = advanced_passthrough, # Pass the predictions directly + fitted = stacking_fit$fitted, # Pass the predictions directly + splits = stacking_fit$splits, # Pass the splits used directly silent = TRUE ) -#> Error in validate_fitted_splits_pair(fitted, splits, w_cv): Argument 'splits' must be supplied when 'fitted' is supplied. summary(stacking_refit) -#> Error in eval(expr, envir, enclos): object 'stacking_refit' not found +#> 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 @@ -332,14 +398,50 @@ summary(stacking_IV_fit) #> DDML estimation: Partially Linear IV Model #> Obs: 9915 Folds: 5 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> D_r 12899 1915 6.73 1.6e-11 *** +#> 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: -# Stacking weights associated with each base learner -sapply(stacking_IV_fit$ensemble_weights, round, 4) -#> list() + +```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 +#> +#> 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 2294e0c..ee08555 100644 --- a/vignettes/articles/example_401k.Rmd.txt +++ b/vignettes/articles/example_401k.Rmd.txt @@ -104,9 +104,9 @@ stacking_fit <- ddml_plm(y = y, D = D, X = X, 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$ensemble_weights, round, 4) +diagnostics(stacking_fit) ``` # Estimation with Different Sets of Control Variables @@ -160,10 +160,10 @@ stacking_fit <- ddml_plm(y = y, D = D, X = X_c, 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$ensemble_weights, round, 4) +diagnostics(stacking_fit) ``` # Estimation with Continious and Binary Outcome and Treatment Variables @@ -209,11 +209,11 @@ stacking_fit <- ddml_plm(y = y, D = D, X = X_c, 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$ensemble_weights, round, 4) +diagnostics(stacking_fit) ``` # Advanced: Rapid Refits with the Passthrough API @@ -222,15 +222,9 @@ Estimating multiple machine learners via cross-fitting can be computationally ex 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 computed ``cv_resid_byfold`` and ``cf_fitted_bylearner`` objects for the specified learners, we can bypass the estimation step entirely. +Because ``stacking_fit`` already contains the cross-fitted predictions and sample splits in its ``fitted`` component, we can bypass the estimation step entirely. ```{r} -# Extract the predictions and residuals from the previous fit -advanced_passthrough <- list( - cf_fitted_bylearner = stacking_fit$fitted$cf_fitted_bylearner, - cv_resid_byfold = stacking_fit$fitted$cv_resid_byfold -) - # Recompute the structural parameter instantly using 'singlebest' stacking_refit <- ddml_plm( y = y, D = D, X = X_c, @@ -238,7 +232,8 @@ stacking_refit <- ddml_plm( learners_DX = learners_DX, ensemble_type = "singlebest", sample_folds = 5, - fitted = advanced_passthrough, # Pass the predictions directly + fitted = stacking_fit$fitted, # Pass the predictions directly + splits = stacking_fit$splits, # Pass the splits used directly silent = TRUE ) summary(stacking_refit) @@ -264,9 +259,12 @@ stacking_IV_fit <- ddml_pliv(y = y, D = D, Z = Z, X = X_c, shortstack = TRUE, silent = TRUE) summary(stacking_IV_fit) +``` -# Stacking weights associated with each base learner -sapply(stacking_IV_fit$ensemble_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 1ffe28c..410eeff 100644 --- a/vignettes/articles/example_BLP95.Rmd +++ b/vignettes/articles/example_BLP95.Rmd @@ -154,8 +154,9 @@ summary(lasso_fit) #> DDML estimation: Flexible Partially Linear IV Model #> Obs: 2217 Folds: 5 #> -#> Estimate Std. Error t value Pr(>|t|) -#> D_r -0.14501 0.00885 -16.4 <2e-16 *** +#> 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 ``` @@ -211,19 +212,48 @@ summary(stacking_fit) #> DDML estimation: Flexible Partially Linear IV Model #> Obs: 2217 Folds: 5 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> D_r -0.10240 0.00867 -11.8 <2e-16 *** +#> 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$ensemble_weights, round, 4) -#> list() +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 @@ -257,12 +287,12 @@ Double/Debiased Machine Learning estimates using only a single lasso base learne ```r # ddml-lasso implied number of products with inelastic demand -compute_inelastic_demand(lasso_fit$coef) -#> [1] 635 +compute_inelastic_demand(coef(lasso_fit)) +#> [1] 1416 # ddml-stacking implied number of products with inelastic demand -compute_inelastic_demand(stacking_fit$coef) -#> [1] 1362 +compute_inelastic_demand(coef(stacking_fit)) +#> [1] 1829 ``` # Bonus: Post-Lasso Estimates without Sample-Splitting @@ -319,18 +349,35 @@ summary(stacking_r_fit) #> DDML estimation: Flexible Partially Linear IV Model #> Obs: 2217 Folds: 5 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> D_r -0.115 0.010 -11.5 <2e-16 *** +#> 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$ensemble_weights, round, 4) -#> list() +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. diff --git a/vignettes/articles/example_BLP95.Rmd.txt b/vignettes/articles/example_BLP95.Rmd.txt index 1662fff..6962363 100644 --- a/vignettes/articles/example_BLP95.Rmd.txt +++ b/vignettes/articles/example_BLP95.Rmd.txt @@ -192,10 +192,10 @@ 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$ensemble_weights, round, 4) +diagnostics(stacking_fit) ``` # Elasticities @@ -222,10 +222,10 @@ 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 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 @@ -271,10 +271,10 @@ stacking_r_fit <- ddml_fpliv(y, D = D, 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$ensemble_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. diff --git a/vignettes/articles/figures/unnamed-chunk-11-1.png b/vignettes/articles/figures/unnamed-chunk-11-1.png index ec9dfe916842fd108d32b5b97c2105f96827f51f..05cbb44fc7065b95fd41751aeabfc921c6d3fa09 100644 GIT binary patch literal 23031 zcmeIa2Ut_vwl5_;A6a*_p5L5(|-iwq(5z&o6+@gSVQ7lwN z5<-jMhR{LS0U{LkWbP!W4MYMa3TD9Tgv+n=tjl#H zcrqd$hL+wCh+HM_AJnbIR}TU~Ku#Pzd_Ev)tcP15>mNd6ZBaMcP*7XB7klZ#EmI4# z=c5;!z7DKc?UH{`5lP)P&~-Nvz9vdRYs=^SpUpI%d|RT-HyAf3jcBEwX%%GAs|l7{g$wbx>&9PZ-GQV<^b0tq90@NeRds zVPVJxI2^P4zsbJ2s>T34A7*Z9YHE9v(P%q6zYVhLIUW-{qw$g!x?p2#D)0ftTv@|t zdlDDg-Zl+U#iqdCwZ*ixxwFq9P2nI@q=rqtLQ3S`oTJ-vt_4y{%5)_mM@F_Ih^(w* zYBroS!eaR&3rJg=5y}nE{L~#v9g|623Yd&EZHhi&t0U z#bqH6a0g?W#uphH$f9p9kX7k17$x(iHhi`7cpvrRoXv^r)#heY zVM;08lR7pnD^yp8zz6VoIB`@{PODe39*V#nZMUD(Q1{=t;uq0k$nne=Om|<p5h(sefnFGoe$+=Jax@Aq3@G3SVB}hb8 z6yDz?8mbywF5pGy1AQ@1jwG^>yKVBU^yM`Rtr zHbz7TPeqy=L3fos@Tcbw;B%0_%C-b-Q2Agn!}J`_%hPLOlc$c&v~Ci?<9b}!>6yEG z4TV*uNlg9MZEYR25~!t|-Fsx+wZ|zF*~r3ctPEr6P3X{@qpPGpXwJ+&#!V2rnn{N=SAl@ zwHsQUj>jY^FLA$ROsKSe>q<;Kh}J+v?%5W}aw$LUpMorao0E zg;tmv>cROnQn@cQgdV8kX1OpxazuZN3Po#UMl?-Odd$Q&Z)9*DQIXj*biaJMz@d%d z@X^Sn|v0YXHp~KcZ z#BN8<&KPUpQwImDEVD02<5K6oK6x=Hq6CF%ewKuJp?y)`hKNlv<~yHglvA4bD^tF; zn$o7xp}rx(Z;k7$rcFc3wfc*S>|ei5!a!tSaWUB@d&)}7U$H}D6yLhJKlLEqub8Tp zAzYNZtQ2}L(&|Y&X*&$&k;W15Dj~<@IFqx?4~2O78Bd+{z7#@RcizfqX(+DI=tbya zMiu>4?@}83yoQG3izf*I86%Yx`pZj8y;aJIBpC^e(eNQe){8*8)9eI?SxDrP8Yh+p zV>Ar5(NxGzHgbhX#Du#4k_l_YCE@}_J{axG^+k=li}|+`i;L{9NIr5W?nXc&=!X#X z#7W}P;V=H`Xu2(%!_JAMWcdcWqna2xGJeF@?TcrsnKjg}Pln?9m|Qr#f6Yzt8n0a{ zHV68gDws}HUt8>a5mR$Z521mJWs8av<4Kz+eg%s;i45z~GhMB^!xZAW<-xN0QaawJ z1#0v)HctNH#kv~RCyympPdg8l^xATp8XJ>46btvdSsoiN@rFW+9%Kj(gwm79Z&ox` z)Xt5Tab|ll2NZMFRbF-ZqNNhTVDA>HEc3y5)b5Ja%v~6p&Fd)qya_w&{IbceAJ8jv8?p9C8*YE)p}F!0^QBHv zU+n`SezIJirkT<-xsrqYc#ZBr+9a|9o_3NeZ~x9Z4Ij676{WrRnM#bESkb+5-8TWw zw7Cpq-BA?e%?yymmYSg>26~HCSueveu{PButW4r`2Pe0EAyS2U2<=RoyK8`se};ja z*Xkt^h~-Spd9u(GYhlBYs5@2^Hyr2mxyO<2+gw8AYcdZDg(Q_k4nyMh*T|eqPAS(@ z2~D{P^pV-fViWV65e_J+x0AG&FLfOAal}1u?pIXU?%a-m#CgZ&y$>OlE5EU&Dc2Z zi_Tt-=6rJRfqg|~th8`tn&}SSJ86PylIEZnKF!NG&pErhwJ-Hxlyb33;{}WQud70O zF9m!4D&Cif7nrJWVp%a__H}B76-HMWMAG;6g|f|Q{-s6s(h)F|vP%EA zck9RRF%Z=?zoGB~m!JtZ)_iz``t5pu<00U?-h2F3aA07K9BCTraRT%WZl4?Ofm9#) zXY}>=jr4y{ZCw+^IMtcvl}jmNmlzXes)>!|QzvQa(7<;h!n%jWtQqpw$;!I3jnS^& z&@V9Wup8Pgh3Ej+xlZ$;`6kYMvVohG-ZM;#gPZE9h@3h9JY9C#;#53!@z2vW9Gca^ z;rY)KI}$S<=vdLRPEwx4>_ogz*ks&xIE($!`IOSQP3JGq@?G0;fj^P_f(j*O=NH^c z7&wX>a@3D<7#iqN82I{vcaL2&&XPjq3Q0)dd;BPjE$;Y3O_=P|32a36*Yk!uz+l%% z+;jvZ6UvzrvJto;cLsHRzearKN3)>3%CGa6m&e>IR5?-6efg=F6{Aclxi5@RabPp9 z3t6fjl=;olLI$TS|Gk=kIjh9{iOLF_vTviz(SZxjly-%c!mdMtZ9cHX?N8Q#%HEs7IrYs-xX|&mBK!fS|MWZpn7T_ zR7>j&_WW_dwrz-+rkcx7;dgpBY%qR=Y0*(wp2Ia>p~>CZ)(*Ui5)%UV?XRnzIt-mO znK_>clGaLyp4s`w`NH%k{@AyOa2c5N4rsdn&~gW0uAl=TZe9n!x6%xCU=1@Ml;0X# z0&A2nVXvm4`AmT$qzJ~|-G2}Myg@&<_TT$Q^~AuMyBy0A1j630$9PCR6sEQXcGjVz z@tRxus=bdev7M>=6RdWI)o(-C&(VyBr0e?CL<|$yT8{|fYDLDND7xuCMgQ$3V5lg1 zge!4g6~}*~CO%%z5b4Is{KqeloV3$$_mSlVpsT33a!q}Mnn=xDaodQeuKb~WFE2Yh zIe~&-+ug7$KEZyCM5aFKc7o*&=#|~@ZTy5CN043{E`kK@8HFdWL5Uqlk!LqpfrOLU zNBE0Ob$fgIX~DP?sQ5MX)BLq&eBXCxYz42iU$ocqmYndptD9HadnCZ`?0PH4UwM_W z77_XztpEL**?0vtzP$U?jSmT#r3HtQ%rYRYq@Z%SWWiiLa6qR zisg=!5#r!DOmxZ(Px?a_Etmtm?Tp{wAD%;-1giir~ zAy7pP=`0ldj?wbEP*_#7owxffXTtt+m9*AYK1?wJTNQ5*+qJc{t{w(E1b+r;j~>}c zAN`&+sHLUl^oJ}t=oKga5MnT@2l+xYK*ew5k5d6*9K~yE#nf)49o0NptqGJDZsQB| zVX0K|iREGGiAMh0FWi68+o+bTw2FPiBarv(!ng9Y4{vQL>EAaoS-UM31C&J?3aFu< zPXcvebQ%Gz-HtH6zkMebGr$|*nze=~FP^#(S-A~C;HeAv_SP5+USnZfM+|oJn@X5b z;5B6SuhKf{CVQ_8r#{~65PJe8yd81w>hT0Pe0>t;+8T+=90xg>Nq%fF#|Xs&3Gs6$C^4~ zow9C82L}m@O*k?*Ya8FjJg_;Aa%)I&<#4^}r-1UM738M6TOE3a`LIn`cr!S|=V=&h z@W(Y@aSb&^UH%DvM+_YP#q$nA2|)3V?hjq8!EK@m z0hiFZtq7lm5CN~3?ABhwISbWwF#U+W{RscuvGUbNQJ1%Z#$v1)6WJyw4iV=!)C8z%q<92Nlklw zaLm!{Zb9y$Zb4u$zZY8gE4-;8pv*3w?{-EGE2pLNq_&%P$WUlfb`pP!bX3Fh&u?{O z%?S<4yn`E7jpe<=TaK6i5%(^;l>IbmG&mYCXH0d5#;!8tXtQIDM(vABUSj3tCD zy=ZiNi{x;>R&T)O<#0TavsG154ur*D(F6~>FJpbtmpn(PAxHflV~JSN~A_pRu_+)H2-`? z%f~}So%=eWPt)2VU6(jdJy?xdqR>1 z>hEtdOH&ySgx~eJAMO>J!X-IBfOcANf)*b+ zaISJDI~;PuADoy6Rp={g;svI@(4OSEg%0S?BoHtUPR)0#&(AOk`$lBDBj`uO2jw4y zal+`d?H1FLLIYJpa8iaz?Otw=aLp^9W>@bHvs3FW=KJ-M9&?3Q3YEPXD8QMSHXn?`#iTgNnL%l_G_RGYea}%#e^bM9e$s4}d4ybf%5c;N@pkZQFXa#Awk~5bi?901i&^hw@Gj9v z>E7WH1A+Lb3h)8WD5k#=ovf03TFE^apXzuK_vJ-u6OFqx%3Qdb5Q`s5T?+R8;OSY< z9vUD|nQFnIn#NqHWwQLuz>q*DTh8=qkDJDqs3ATuW4{c{oUr5^#RnZC3aTozg$Dex z>&Hw9QG~$C6((n8!=aUeROC@_-ev^ji+`$<2y`C7Rn;6 z)K6%!%H)@txfFXJOc+qh+8+9ETJOf|?H*Zq1%qjL)cl0+lncV>;5VbNbxNl0U zUWjArN0*Tq>znAR_Ck8qL|wWb)|IxC#0(1$Gmlwp_2 zG~zGjmtTCVIb*T;Ug;t9HIz-LJEyiphgJ>n%22w4j*NROE;~1PX*ve@PiIs528C6( zlnGt)uBG12T+vvvsBZqwoFe1A#KB~%k0X5o&}cx6xPeCh@SF$y}e$X`O#3+5XIO+p#8B6^H< zix!_nlV3h@LC4l!r8b+I`kQFFqRr1sVU5t~vHL9`5n6TTUFCf?pA*Gbbp|%JRf(T- z2|41bgJ8h23&l}p;$Ai8U2X@fI&MK^hj&5~&@+!1!3S)qZ&}Ye`^H0)SnYM3Y6b&S zx}?%LH%B5&%w)c9Ve|+oyL9T#`p*aeltrYbvyv;0WOA-HhB6u(pQ0x($?#NxUZP6u z#co3x`WcfS`}lnd^MkJEPn#RZ;`=F30^i z!+x|7IQx8^$I*Y6gRkz@LgIX-i#n@rPZ0i4k+#)MW)Q<*twcN=n*NbPE+6@LuCE)< z7+(jyB?6A_W0x56Hi;o~j~B}dxFL?sIGqB=NZ?6Q6#@1{Sr)rzPrX89fn79h-laq@ zD0kr=4E6|t@cCTQ)ptEw#m&Y3Ss~*~VS8uJ^p8Gz$()7F7Wnfr*O1lhCE*tY<>mfBURYM6$eW>JQkAQ}L*$-OE-iez;|8!l z?qgcg^$;3Qy{$U@Z60i2Zi|V@cD3DR37{ap9X6VGE4$E1O-3SqB{cmAJ1f5(4(DMZ zr`dYg#xM7PZFLF^fa(8CL#DY|zcutoG3LVoU?j=ST3R%()f1%$Q+oCk?>LDEc51BoD$ly3n2))M$r3mg@NAGltF6N#Msh4 z=&c(dYvH*5Ki?FRduheP&`!$m?5uB^A~msKDm;kAY9}uRfGnchc}5w)qSATx8bD{1 zV|l9@U_;?+ct%^BLoM*bs{f9rLU;qN69qD%b#5@aYM z;x2Eg1IQ43Tbm?p2XCFL&CYe0F}EY^rJn&L?KMeCe&!^qPU$GHna||CY#IT0i{(AF z1go?ZmGV{vU@Zg05s!lXZ1lYl&&7#V6FmbAYo2d&8GeL`81DUE^e9vEN70`{pMNh} z|6D%(dr|#b1D*}eYxOkG>$u!?EO0}9Z*@CxKQ6bb&+|wA4@Ijbe|W~;p{+*5V3jL) zue4g!Rsa<=NvAM}%3WXRG_1HI%F_YYHXcFA{ZZ+^EY0zW803S>{5o5H;25gZ#VK6t z=4G55XqDOncQM`ZhbT*2S{>!2zr`{H&lBo;m{*xreo=w%Pj3qUyfFjx6T;VEjTM9q8xLZK zBv~RgIaVuwuB!nO%#?&*^U14RgS9^XeUf%T^7k+UYVUyfZ>)lDpy+&Bu`TW)ufCly z&tvGgGBtd*Vb1Z&rJ|2hk}K}0D*%0(P%VKiPYX6|ZH z3W#}|_(liYK>G=tkh!CgDLRkM1N-^97ijIa2!I{A0|Nj++`q9&{?RgepFmkiwyp&J z{mo!A0Em%+v?EEjd7{%VWX^h$w^4X+LP8U;```n|y@NgN_DJQpisuzJxg{g{A!{B- z!TvHkR6}iQ*UD}OV@c%{xHmX7kC`1seZJ!6aa4h~{qV!l{>(xGp=z?9gke+tPTsfQ z5XL<{DaoB*e`0b2zbyG)gy}ydR7f7w>#q2@=OB(vG77}xYpl$*2_Vb5 zy~p*$Us@{a1+fITcv)K!ITIWUVrRze<}LG_86|n!5Jy^!2rp_a`noLib;wa@dgI>} z#&zH(o(J%*1BPE+wiY=0sU84_ry+=s1Xc|S1xAiN3@8O~R)4jrfpHKOpT|4fP(J*y!1soBJ zfk>SAn*weh8)VP@Pz?UlVOh<3Qvllhb`%)?NZ>pP7){in_RCBueCT6Iqc|E@tg!bsm5=D%HX1C$65c zdq@Ak?bqXU(EyyrrCkX_l)w7pymmssQ}IN+Rx?luka^vtky)0?&3+ijuA z!Yd%`Jo~#t*;>#IaYka}$W@C4UgK$mLxBLVnS0IkdD5by%ng(YUtoT%ekPT($w;LM zeoaX%8K7#-tJoRu7#}K0G1PN1 zrmVr?OLgVfiK8$zF`;IL>C!sC^J1I3BOB39LmFanmOGm#*a1=d5Zt-N%-H(PvsFWR zSt>R~Z;R>jC4y>eBAOUfmBmeCuVgig3f2ur2FcypVtq9|DV4^Z+-QeVf5NrlJnwWy zS}#rG-Ll8OY-JAnG%)(~xI*Zq@XoQe-D>JFa^0QX*6%mI7!Q9JqB^xcN()i{!Hv^Z zAbgBo9Xy+7fU3@PcB31;HM#S^nA9)Lou}D;+nxPs#AYWgvV7*9NwgM1C6`m&C7Y?- zG+O9(fcq7G&82u~?u(1(tqC-`v+(o7k@el3wjJf!OA5adPB#VVKsI=z^sM))#xUpK z>3T_FAC4qZ77IT&ubMmJb*7`gsS?S`AjYGY3KN{S*tM3OZekU~)P^v@3xvU}M0tWl zh{IllUE3ji)CV0Gt}DJFceS4O6^C=mUESQ}ln1r+YoJ|Gvd%5A?& z*ruo>+_0dxd12LHsVJqT+DtqPvh7tuWO%o9tD|+iRyrRL+t@v%om~-Cb=cc#m{FFR zv8skdQPHB`4100TA_J_Wr{{*tlAjE|+pD43fvW!6AMWLSYT)fAd(_3e^%h6{SPC|J zWz&)>Ftv?BO^l9ItI~LyhV8d2KiPRM^mD$^DUPSsw^xYTqZK!k)?;U1hNLbw1W!w* zn_F0d+L+gfi*(n;~$5V(`>4ARz~~)B=wRCIb{oaSc!;chDN0Oz6Axl zP4|sfjn_NUTZvp|3h7IcSSsbwItd8uub?vitG1B3x3H;Cee8a6TU%S4P0+MCTkn$! z`dvUuM<}ym@tg`Sm^GV2b9E<#bWI&6BIQ4vmsLc_vm4u2vOmrGctnbyng9eOkgXis5D(=&yjmxmgT=- zQ)lN2pvDb*A;i+d=6d1Ts_bA3|#jRx{MlHAz1>y`bE-s{mP)XlY}iTMH;YZm#SFe`^0>|2OLzqNf~?_I{?v{y063D3)*BjwjT|Ag&T z{Y*;?1rcixLXA(9T`wo!o+bZOl};K(4KNlJ1g55frcHZ$v@~!GhiNMf3Lzlly*)if z69Uz=n1FU#PZg!zI6TcMPfVoVADpY&NaRsJX&nvzWkgPLVxmr-snezIckgQM3rJu- zZa#>Zx1wd6DPI>e!HEmC6MHvdhkhXst+-G!?!MJK040loSU0smEp2}(Dx0PID$faC zV|TrtUjJSxFEe}G+XE&2X-ZBXW36~1sVy3yw>=*_B~#ep@OMCPqeK`-ZV0I7=b++Ah53gcsa z)K-op>meBucz&|Ii7_6dc0&)b0`u{|MG?y%;MsNEixu*jMbnu+kmAh~)NWf_03>D& zMh?HwSmWke(#bq>>cZaghxxN1h(tl(;3U@4SJG8z%MGkbtoEUhkn&AfvVY)vKyv*H z4r(z#=U64ro?>Lbg`b@c$rBRnmyDhQlvKRT+)$gJe>s-=HDVX8JRP?g+XKsf&%+Q~ z*^hDF9WBt^vfB~UF`@60V}_h{{fM7N@FnuJa^Lsgej7mqggYah|HAf)v=vzZI#6VJqjYOGNXGbZ|iK0vP17H+s%3 z$Yb_3(t9<$zZNt_?3J|#8~!h!dw@xv1jvx4ufC&>xRq~9Tt7WzU>Y`-vGZXtRXLU! zOUOJi?&86YLn|pyGyu&|WHtys!2Eg=;Dw+ffEaUMi3)#^dc)jkCQ z$U7@}F%XQyQ0lq;$7iOC4&A1>vUu*p>CrbsXG!6%;W`ana$F<^Q^c5)bQirxF<4c@ zT%6M#m}r*tU3Mk_&wvpsz=a=24BUiHxyv*nJ`3@{ZA`#A>6j=!`Or@I-u$g^@!c2K zGb7S&zvYb=5N=4+c4a^|b>g9BJih@i#v*~yTv_bF#~ZD9y5aoYCjfra(y6p4XZp`x z%%W#aU&wLI*<=Mai=+~uN3JGVW}bmRpY>g4y2fooR5U1o$8nZ*4_2uK6>)G_j%zkp z=DLBnW|}0HPlN*@(6?q3;?kExptrK`fsyb+pk+@ilivO$1p0SGOaD6+ZSw2+cqp2d zVQ`$!+`ES{zAyRj&Di@F5ug6Iuo(dv)Zpe`;LzhU-2hB;j}O!E_?Nd#Ork9%eq_-G z244LkD-eF?HJ|II3#G6n9d`HMxK7g2iuqVUwF4&hI}g5;al)+aUktU8b40rHyL5E zhRCZtM%e0~p3A@HF~WrHTVqc1>1F>+k>8Mo621q;#q|2k*E#le0(ww-<1(M}4?z+c zxI?AtASjM6GN7ifJ-iD(IB@Y+Q4ymWP+Pt;GkKs-3a2+XuwinElqk{aB({NCt_(xL%H@#y)Oq_(BKV`Pld+)Qh@1#+Fe8k(&yMGzS9W%fQ zs5#FpP=Bsj9v8?1JkLU>+@Q5MW$-Pn83^ja>Pt`pxfo(Fs(i89c9vmRX^7&*<1_?$oghC7i~0tY};l^72;1=`{Ab=b^a+ zb|Wt6rRO&%ItK=4xXmn32Q|H61^lD};;2$GBL>&YzS5fQtvgQ4n}9Ytu9d)?%J;$b zWx3(edSk>158UX!OOn7Rv-&+qbuIDG#NT)NQtq~Tpuq%~uAhbL9awHvU$1A0)+Dg} zn#ToRUvv(sgbZBibm_~nc)w@kq4~|+vf3)P+lpf-h#jwb6=bC%7a*@SQ~0J zgWS{kIK6Mt=-JC!O9gbl4LbDY8@Ht`jot&L`>1nF>iEU6IIdKjBT6qdgwUb)#{GR; zV<9r7uxFgWbVNSR?*Oe(8)%tq!IdT z2D9GnU8i@38BuW!R`-D%zPU8KvF`IN$_@0d4{YVk5_X!(hY-A0)nt{p?n;yyHDUSr z(z>HMk09TQZ}Ye-hoZ7#R+FN<8F}@(+QupYjm;W5IqweWp4prG!1`H|Kr0*(3VdJAq-%;~yvY!a^zUk0>R3nAqHG$T7JVjX#FF#{ZQ+qx7G&P zqOeC7#0Q&eU&$BE%HBR$tBKHI2u4S$*Q)nzg4Wi3EAkb;^h)IZYVq#F`)c-w z9M>AP)ipi`7q1B{wuXuN6;JOed(>DJ?@5<)k*g!c-=bI7f3UY36Yp*+HrqJ8s^&nN zhKbEHBXM_W?AU{i`0<{Hrz|?xAN1%6wGfDlJVQ0Jq7YIo1qWuAwm2S9wCK9?IO-v_ z-A&(?;$Uf3*!7`P=;z2!QucV$fmZts*l-2G(V8aPuY=VIMy0}r>c^ugkvg*#y2y~> zt3MIeBRwXNPy3woFJ>s#&AR$D>_aG;vr>w+M)pFBJr1=H%=5v@nkg#WB!B8i!umrV zLX2H$(O(-Y7w&t7Y})L-s^)Ovw~$E|YURGr?$9^r$O@sm%2In)b(f8l&LkQb>502{ zEO=6~feRJ#UtgfVc%T0Nc$+3mYCeY)h*vDC?#%phW%ip#R`G1(wW+BQvkM_i zm+q~2y!pHK!bs~%2H^V7mcpg{w z?s_nyh7Rpga>f_;DB(lzowB%g99494uL1&z?knv?xyzDw7jQR41?DOE0h@BY)#t z%$=CZi$z+jev(RJRWEuk;+g@fhS&2_pg9|8EH`313-jG_sBw3aL~91@%Q}`gwT1ba^<}+sB-RY$(lxoeB7eRa{>9$- fzvz}LboavrwVm&w&%jrLAt#QR9L?3geEa_cUKv7j literal 23116 zcmeHv2V9fM)^`dBhyscNDv(&gr70GamWTyb5!77;q**8;kkEUHB9=uUiik)PQPBlN zKnXPwTnGXI1!)EdHK8Llkorx6yZhev?%uoi{oQ-N`@P@h_lU{NnKRGKGjnFn{LlZn zb;8VeN@E|wc5q!wSWN@_7Qzu;#2XuRJ;?l5L|eHdMcmF=l7Fe^plJGTfjx`2clEpn(Ck8_w)Hfp%o(e@G!CRhCq}n1^=L!559&F2omz`p#$FsB#(9R<81sx8SHJ>pRRDr ze&JOfBtWX%2uI{PwTXy?Ot}_E&e$C>$%|kLz`X zmSmbYX8Hyh)(?Bz8OIu*zR9}uY1ce^f%|=U8U^~O(rpLl&8_V?F6J~b+?Cli_>{2Z)UcT}_Tmx9iYI9}eVeYafPPv-7&i)`r4^Ey zfE9UrB1ocUk{5L6c0xB+lgKbr#|;l}MfzKFFKLp(=A&Z6UoTXVoeAICxhY%lt77FF zKLyRHP~^2p=jK#&NH*N`MXj)a`FL7TKUb2r61Q=76@IW96*|g!JISNBgfC=LCOIv! zdkH2DX+O^OB{9NZE8zVfYH&c(f8m$&Y~=Qx~X&~mex^>U4g3rHBt^L%kS2(?6TcM zDlaz3(^HukpWQFBnAzORy$fL8ZeB2;~YSf4|5kabjraZtlk26fb5qa#c$uBsv}CACCM z@|+@zWkO}zxiBuyVM@nwYr0MI7FF*=S0-%_5?4C6hPAwg^A3S!WGpJgrr_$s3)p@W z6v|!46BC6KOjaAch~O=zaHAXMRk*;Px#ay6G8+1<1dO1yd&{> zYMGgtT0~a07Mpv7v@q4jE@QU2eKrIB3P)cuo6jhK2-uQ4a zqKrz@VRg|rgt9X!>7|q_^0eeh1FtYkG(^hh9Nb0>{Wnv43me4b@;`ZlRm-h(z4e@@~-ib(=F{5%uqC!j_dN_+G+ecwNa{k-IKEY`~~Nv4T|6<_r%M};NWuzd`s6+tsKOs zuw1fU-UR01mshtcrjxY1-jrR*TiB?nY;~5VxoSzWG$+i>;7oZ?YxB=@nijaMrS%6I zCqMAVPg-F`0m>~KCJCgLaZ35AI@7XlpWd7~f-R@JYID-4ybSKxkO4BQrEKof++WY` z7JY-u;plD`;uq?;iVv4FN#vKewB^F5J-of0xmi)ha&kKtTh(ANkD_jPK4$~}*ra@z z^9+I4GKuO8@(6xIW-c4(B(f`&_qOPg;`4}uo>L|>by!|FC?ZiV=1^Q4CH)Zl<{bA@ zRo^r6$n_fQ8I@%NPyHDPQh_(Ey^u=5c3~KOb4_>XM`^5R9K^ryrI8SSI?xvqIS$Wew_3i*-a;-%UVSE=PS z<1G|m=ZkKq!}GhYQbsG2B!l7kG1c?3o{bulBo@6i$#rCT%{#i^ZE%y-ClQCVL>#)V zwnpD7Re~;>u}435>uK1H&qoa9Y^Eq#g68iB&0l14TJMv(T+#Qr0pnar`#h#g8RN9; z8pM6EbL1&|lOhz-!c)GLWnfyU=~sq7frk7z%RjTNPPF`2>qEzheM}&H)7@Fj86aqb zLGcY&%)wXIVdmLp1fLV%Y=k~)-rp7ak+$d^ZlTBPYYu3%|C|@v^B((56$v>V!}OcT z&FO9kox8qO9(L+iyEND*DPf%^mhbZ60G2Uvzz0{iZUFw&%-lXno@QRoJ+m!qHYAw) zaw`?NJxVBz1Y{Gx#jIi{#19dCtsX?$T5EozF6W? zHXyUq_AhL97ZvF_6|)+@cmvhlU_7%^Sr3}XcVdor5-=KNVg7nZEv~C~8P{(@uiWK= zhd=YEq;Uf&5eHEm+6Ucl&EYS+o7C`|&%(O-@i1t)SiCyXY39nQsN6v3sfv@R0RL{O z8g^Dcwvblsz);TiU14aWKQW!t78b~hl#g}e6$vz1LW{qV&w{^2{*Jl%R#F_YdE;L% z>hW39HKuWp)MbBTf&U$qe_(rXdk<12!DB5=8h30pFuLI9;j_>k%KwtO{=iPKVRi|&ev79PsK9z;j8eYKc}O;xS4?_i%SGXEMPvDOn$m&A{~9JF;FY=frz)0Z{-d?-YH*@>sG7rnOEJHkcRjT$T`M-uz`RZ0ApuUmD0{)!^* z3@-d)XDJ_}k$Vz-X_wA}XK(_S>spry%S{dN_4Z|)9&K+0t#cRXA1b8r#$vZ24W+NW zd$7T@xdj^xJ%6LPVz-2NIVk$|Hnt#V8#>QDybJ3)xWy=Oz3F!+&><^MeseIwrB>pm zbbgeh(~jdip;ITH7vEm->|69u%AF+z+Cl|KmNg3$)SP>G0oG?_SzN#3*>)AAo!IKS z504Nk2_MKz>E$;q9%pLr8M=Y9xqA5C`_7)5F$;)f+y_1Hh|R0<+EJ=;#TBb0OcIy! zM4r@ds&&A49D<#4TIHy%vu_i0d%;cZ#0`pfaQCbZCDyNuF+ta=KQ^T=Gv0!9lsmcY z{}(mYlfuzCj6^z`b(zxlhQYKq!cNgYQ5-PoD>UP9_x7jlO0-sur~}>7z%ZrD)%IwE zZk^d5R~)HbWC}z>8vYdhvj@KRKr&ZtU+3u%RFK0V;qVc!xunAa2(Gd#279VB;r0$l$SetBp#8+TOU`!P*U|!0oc9lIKDA@$U*o(G9+s# z^!w!UarUbT19o_-l8j7=@Ch}y!=@LG$l}>;pQW$9hHJapbeWU4{E{^kG&7q;&%=Ae zjC6uk?^QT1UuohU4Kqsm%jbPjqNcpX_EaNcLE*n-M{6JlozLe;iT~Uvb!dkwQOe-} zddTVPU70M#4|zj-WrTxdcL`4a>v9FF-1u`p>@StbpTm?{V=L5+wdN=CCv(C}MkW-*pBX(lF&HGW7gqVNJ&92kQkQqSNZ?+k`T=%A~Hj2!)>PB(CPJZc|0R?huUX=7ny_ zQSD!T#^HV)Qjqv!{#)l~7gfz?28`SLBuVu9FIn1qQY5XydphTT0T6uA@jlR!l3hbM>^ zLQUGk#sWQVf{FJn5D^Y(frxPW2t)*9Vw<3<|0hMneZ3?O^0R$*W|+c^RH2Ehchzn| zzU>j&5{H9C$l}4V=uMcHMcDQ`W`CNt+DZ+btmHqv*g?bceHDDrz5_M$jQoP*N9B^r(wz z91I&c8ru$_wS^{KL(S7q&%xWfKYM#4#XlzJ z#Su`A1~SQHcWk6vsc%@uA@sSUB3r=Led0~pXFY#;Ik5CP)B-#1TB-#M>jQD1{XVYK zx@+qkr<;t%*cNd&B6qBXX$J}S=qOcWaBAe-LiidMNL~e!Go)&c^!g&}7)}PIY&^>b zeeN5PYf>$_htg0)tALX=UlYVg@~s7>laanzozl=Nw`62=6^nrTMGeyFPKwfd{gBD9 zU2yx_F+(S20+DsN&LjzO(}%bZ6)LM?jxZxJD6|%6hQaPhh%1SRsLIOdii@AvhV+q< zd1Q(nLL$*%K|FxQX+zT^aF9O>{Ow*UIHQOeN{gS8kwK&X5uDlv0el0E`W2#@ZRPv3HCC;t6NMKN^gU1 z_x?o`qM-LTaFxv~YwS7XjxpKrg*Ppc_Thnhlh$gfb4I-R6I!u+_$i7*@a z$!n@7bE&KFdHXytBvvx+cHLGnCgM8BYQO)7&Qu~UWC#1FaNT1=3HSMBQAQ!|p65T_ zYK?pEh5QzmgQe~5(Pa-%oeI-S&dW{XSpP^)Er zGi|AdRnN-Pv%(Ev+Iwxitx;=6WAJx|6*~L)ygtd)$UVAUQC`HMV_Lyp_0Yicb8Rhj zr_X(M<*ku)d(dge+d2&&Xejrv?d|6+$7+05OpN8a+MnUA8nL-I(~ZI1-j776%h$*8 z%GI&O5;ZkG4da}=c5~_ZgI*`wdKxNG>tkcdM)bg{>~&RGZL zxhgbB6M3=OfIzVb;&ndok(!8@J1#wlh>PGwj54-c&a4s}h@?x!sB~>D<@j$#W;6lO zgu=^}Z%f3O71^_Gkn6tf;U4ADZcm{5OB2h85h0Utl6LK7#3q^pxes6LPHb0RAA4{a zAu*vMx;mX-QU0MVx*CiX^+#!E(;f$>b*m#YygzjA4cGIMZ@r|ryNJ^NYMG9l7{xuE z&=wY>jYPPk2D3*+?@v^&kA^c^J0rWPUHLYxgUc8@!O#jgiBXm<_R3gcGP({PRf8c_ z)n)p1_Z>zb>3>_y9r2D*nc=V`yG=dSr4XHnFn6|{>~-HSkH;p>$UB!ga4|GzLjziw z=%rCEn$U0#x-KdLRIzwzW%N%K5$s2S63?BdVk@=1D1WCgsmQ%<;+q4buYdcE0m zec!F%)wCb!TOGlk?yzGq?Wx`difz5#!6o2~5%M?Y-M{+?a{n2$A%{Il@(K!K^<`l> z`84b-Kst$yS*Soh$66~UWb{qWB!F8u@+cccfLQK_+}Ljh%21oVQ2_)JcD9tF!|L5}DTWVGjwKoIEVg+a3u0 zq_`QW#~t!KM(gHjYH3WwvM6e$wE4a}l=0ZewqVvr$TPY)G_a`Tz?W(gMLza~IzVC5 zCSSX~i$Wzf@(1JR#-kihbti{&3MeaMqKuXI`rB#n?YIl2(!iC+SFwmB}!c8$;R_TXHAtPsG}novE9`O=0mEImGbVWx=Hu~&FN~trvx%XF;XZjA7N6XP`gbew7!s)wpIlsAlz`Nfe)LY3vvF_(s zfOG7&V0crfr!Q}a8FM44MsYpfd!i1uul@tn3UxD&yW+F2#ypr%XQO8nUhC_J8;}R# zeZJrUtp>A% zGbUe?UXGVH_qAY9H@gkJct-K%%v(^81CvlI&A}zOr`r`{HWqf6+#KMarn3Tlqn{)| zmtXd2W~W$)+D%7Z3s(Lf+Vhx4s~zZ_IM`f;^U=RaEK~A+8!=R8y%sxRGZCN`m!pCM zhu;+}>6(#kHT2`ghP*|!r?`8m)ursmq!|Y9CFX-oNX-RqQ2-lFPTHQT^Zp`elU_Hq zm{b^~$F!)Gew<)uQsg`4H!8j7bn${w<@_$Mwv{6wuk?7YVVMVZ10;Cm^p#VYnYk2y zcs@%#w$(b(&G7lfx&Mm#=p_qKABmc$s1vmYmSFbP8h<9X*^N;)Tp!bC4EH5%FEmUq zRKoi~TR-cd&sccX7=Om>sUlwi=nHUM!Wa6-Lv|zj^Vm;1Xk)|_cB@l3cft>C2N3H3 z_IRg%Q1kag6BF@rF>b^;!W_H@O_r$X=;M3D2}3)7)rXuf3&PSs!Pmk&XCkG0sdn*Dz;C;XcPcqb>i4G-C*vra1*a1y{ z*ZmhLNpMV8QfOho&*G(EuWsF)zps=s#Yw%W;FYunkmFC^q#%)P@&jCuJsa&dKt^b%uB8BnvHK13vuaeRIBsOryo7PH6 zQMm|wgb3V+bVH;oRr;>_&v!K!dnNnLWo>zx2g{-92e}2WT17+zn8XRLE}lYJ<$qoP zO(>1n-|E&62$Q=zFWDq2@(dhMeR;yH3=#k*4A3!2-1pQOv2Z$N&H0Cd`z3_V7*({$ z<~~f?kaLmXBu{(kuPN}2jBdbD(hl4Uv8~S6^cN6P{yg9z?glLh*|hPW;G`5C z_18QP_UoDgKdAQ`iJE&rwaB$@aEvc-cK}2pxmDl^1vz8V1x}LDB-mIB+@YbA;>gtk zPpNzt;e?nH6T+yXLxy}GuEFysYB3I*0 zjgynUj&p&ND1iRb1qWP0s1J;Fhpz~sKy(Qa1mpegw@U~h81Vvx>o5QnjU-HfXDI** z!PEh#VM1UKOrAfL{!9C`c^~ZOL$pcM85RuM3lo^E#3QTl#%<1$jUg9lc}?>5qSqwr zHJaa7en5#N=v)`z0_^&_88K%*+i%fwSn|H$^gYq~Nt~?c``y>UVb}co$%X`-U8!0K zwa^Lx-~)jCnBW9Cy;=ruUC_7}1iDTGz3RDn1YD=p&}i*&>$n~o7 zoYLoK$w%#9l~ogAUW}Nl4%)B5L9(j|0AezR-*H`&3}45rC7x?7T$Ho$0e)!;@g>bM z!Pbye)!-))un~m`FtHP<)FK#j} zj1Bl_&6~s1Qm_|Gv-RMuvKv(`qg&)X%Ik! z#Gm%?&*eZE5A)BO)qiM6-SWxzcrv+lX}f9iI4*9p+@YmiDITDDWOV^XD_98v0hoJM z=Id5$TD&Gq5U?Xi7jZy+-2&*t^3%R9;mXjC#;;odyz}{S$FIY?W)wZ2x3sk18i*eX zwgh27g1y1Co#mhFys$fedz-V~7_A%bzj%)vN#l2!0K!`^8-}N)oOhV08t-X4Z1fg#D>B?=kvVao;ZsO7un~;UQI?P^kS; zcYfi>Xm`%cuT>pHWA+mCC)~SkwCK(cu~hgR;K4fkt8GG#?GP9+7vaKus|qa4xYw~c zh=V9nWRs2D&v$x2uo6!^x~$AB3K;8lo4U#3^H_^BuSKqH5^gs(!Mw7Hv7_{cxIB?- zN&-(v`>=?EJNv+0L8za*Fkz(vJ~%5lJ#{i{g+tEixMG~g6=9n;i<>Y7j^s5dp%_@d zvm4s3xM5<7B%{72ZA7Nz9>OZ?qa?p&iw?sorG%A&<-1^qzIA|B_RK|QE`>KRz8Ha; zar(h$sYNRQBjJR{+)r6_`jOH0oQ^8OXo{q``~$)MRJb;?FaEV}`3m3$U&Fk1#Na;J z33d*ceifwbrauzu=2hq|<-e8|tGsR%h?Wxs^a%dnu@wdbp>n3TaBo+En4V2Y5L;IX z98HiVQyYgkcS!&)Ur86hI)4lX`X6#({#5=CGKfl&ZHy2!do%<%^pHFM)b4v4i-YVq z49>&iyWvfnnK1&Jzbs++rgxO?!9Nb){U*{Ug3J3I5{ZC2rQL+%RD~x~45x0`TiY(o zB{&yYO;uLr8Zsw&(+eo%;Tx23LYjT(>$eCF;YygPpV9)N)7YNd={Em@uV3F-bNEL6 zc!rj{VSWDyKWc+BnpnajbAOVTmw)IxbBpiQTUpsbQUW*$oH3u(C{a^nOea{nFZJPmlwudlxFmFP9U1Cgy z25(Y}*kfgx(Oj;|h$7DBtB@7(@@K+r-7(KJCR$u=FY&4*YTA7$0N(6_68UqEu~jjq zkxWH4os^6H#OubqcQqhMvtK-ZT19j=l&s7 zQCRBLJqS;<-KB}1fF|4gx^Nws_BR4im#l3ovV%Pk^+&^3p0m8c6>Fo`99fSqNP0i2 zSHm)a`%=N} zZ7ZDIbKX)+tClz6qj(YBIyoOoZ=Ru8;|jZ_eMVQv2~a`|B_+1?gNdSkk@Uj^T#($P zsv=R9UE1t<8@hO|mBs9vK^rL=6701Mt9oK@yKm9lS)`RV{xqEb#-Qz;r;;HdQw<3L zN5_ANl=x4zB)>z5{DYjW@y!BoZj#A>Klq_v1hBliK7aU2NN?1zY=K@DatIB%44^zc zHC9!cAODUni9ISwa~usO`SxZ8W_@V}D9M4CRrr*Zp+PK4_{6YY*AkRhwFKo=-kFbW zqc$$vvC~+*=3UFmt2#V)V!*WvfxUX%kW9x7cAWPiJgwYpti5{NG@a9*=8o~O+1Iq( zB%BZf+4hW&%bqwBbr#teXB&J#+?izP27-fBytZb>rMl_U92)yyNp zT^Q@3?U_uRx(<&uH5y6dQnL78%#&z~SqOK`on+MMtiYg8JX~3GNH2kEKEzt2h4O>5 za_z+idg=5AmW6z5wt*Wz8KQp@pi#VN(tMcXHOa2+0v6rcn4%kdplyk~trirF$UKW;ETKp^m=H=fQy$&+JZzN(U5|?fLp=75gVKb8E5^hTk&aBGn z3X>@hbvVCHmU#{;pqp8}q<6KA&MDv>QFg)nN(=o(mon)nf+M7TazSfLCjy^UBWS+XU5_vbh|;cKl5-nqmgUd^{9AZclZ1*Z-y8tv9BSj2|DCgM(_@Ip95U2dw^P2 zj`tXCA8$om{?ThH@>)(KykqzC{_#$RJWWm#XBH9i=+p49>r59e+psQU?su755;ahS z>K+<12{*aEb=rWjd#K@~q1#p%A_Ok!0#G3+@eZ|yk&Q+tx6 z@0|^y=tW7#uqsMt{LtO@O5p|NGyW45XHgG%y?veu*z)>B}_d zfSQbaY}Z3zSDRfX3rXSQakLaIthYXi-_CV~!M@!4Tsn@W7*aWW#=LT{4>u9TRQM{} z(OFwW@RhyDY^QX1D<2XII66+9kHzlJYyak_iM+$cg&;6}cK#jUUt`lDazOg@UXw!`w;-&t9${i>*#6JvZiZbu}MAE(pXuthk8i`ED5R0 zTXI2oBQBGg(mvq@fhZUW-U~3vJnG|r9;*K)b=Jql(7wh8X9mfwqi@l8xXs-igGc)u==Slntr)AA+ zWbu0bYqrGy4!sQY@w#=U- z0Rw9|GtH^!;1g{P&#bcE0Fn>1Vp*bs1w3gN1*8xVQ?+Lfm+83DE#o3A=$H{ zbzhIvDje4fj?{G2!I9eG7Tv$ph6GjZ4lN3IZ@$r*S1Dirc`vQ6Rx`H&gbN8UuI`dD zjx^>FDznR5*XmdmzR}CiafHvh!zxP@x^3h020>c2=!dN3AG9*8CWc`!NI^1 zjc{|3VUI8b_Q2BV{_g->88{C!^wmVGXD3CT z%y}Y?qeGO%6Sg2L>eT@hc`7&>R=FQ4;pDUwa15ZOL@Qyyu~<{A&Gq{LHcoE5HM{x# zi>27)EnE{vwg3caXa=1DSn%grqKrXhK18T zLGVLk&2WQ~sKkJkrRnXh_lCgtTLZpG(%nW7 z=Tv(RV8;kqlZgP1016hn7N_@;XV_qy4>&aW0s@>MlwfHI!A#~Ex1}w5$6oohOcEvM zcCfY1PQTc$WCO+lAKfKVq_~hs8kJ)-rfluwpoc6t5{uHjB^(q2tj4E2@W<0LMaI4D z(~of<-U|tL+AuHgDU+L}ufDQWS3#`|9&7%56HvGp)>rG(ObS>q&VyLLpQ~wFRL{09 zi1srAz|B&#ua>^jwHMojRIC-M1?`HkyEUPyF7-?Ezb+eZf=$uwehk4Y8-_0&5p=-d zf7{+)^M+|}b-L%W2I>+zZ!9a5CI&N?2Jp)gv?3sMZG%FWsemXU5rt$BS|D@ILlB^V zs}Mva{F(8u?h<}@uzy?U5nnNnfP*H@WowqZi|4qkj(djI^IWzfLDPLf5#!=LZmsg> zooMwg*5@wUoVL3fjuw2&{fzd;UGTg$Rch=SMrNolczz~kXuys{d%;eDCwEsC4|tLI zWZXUQFb71Q0IK8`6{O>88RUNGcEFx|52D8YHxzl_O<&%c7XpRK$>PUAgH@p5f4Yj0LKnf74RZWZBalN z69;dtF#?CfGEgWIIM;vYXW%(6I(_=$pZ1P^d(dVc(0P^ zF=uwyh#8ZSQN>g;wJ;c2y9&IM>FWK4c|BWsDW|77B#x%Z#d$z^D-BN(kK(jJt-SM2)e&w7|#eE&Twz#!p$(c0R#@!N0U z6tSlXayF8qv&4uWskg%Drn7sdgEZqj)$UzU`%Vg)NNUFrN_P6wFa(Rik4@&DAInnf z96Faf_SD`xjHZWmk>Ah%SZoiSPRkwHkQQ1#kr_}sT5MXKb7I*`(?Ags$bEpg{mzry z(u@mXm;P8XUlBJPZNbd?@oYfG)bvCyF_>wNkF1WSHX@Gap8wKqzuMq+I|Lg+h zbl1Ychm4xQi`C;palEr*@_g9@XSA|8sneDDa6^}m_joJ=vwLJR1~+hFps2h|4H;!FQ;}^sZp@-B%wAdjX?tDqk}}!Q&T}`H{h@e6+%Uly?X_z+My2$EyZHP1w{Q3GL)m#5ukv^4 zpEP?&%yvwz-;bm=6SBH4pDj3zojAgbmc@6jh^B_MjP_pehd;>Mkp9&CL798olFe;ik95rJ9v_p&%HhXuuP5-j?i{!5P}t+a4YPzN zM4jw!wWJoOSuGp5G>t3Lqb=JLS4F0}q=vF>W#j7`eMNQ`_ z_;Ckkttqem`mJ^%TQ+Paj}Lay&!t)*N*`R%td{N+Gj}39#J3LJ@(SIcA(z^<^D5tVt+={Gja-4JWZh=?9()rosQ>b&9fT*r)ORA;A6I?@@CWwS;S_Hc_j_UBVE19xSn zHzIBPf`ir841}P0-}`4Qp37K|3ddqzp2B-WhwuAxU4k2Ziep8taX=M~-KvuO;SS2T zVyAuCivuJ|%)||?ZDg878_8;6axZz^oBEP&uqseVRI%naR}%LVX`Qpn zDsZL=9XUR;dgmXK7F?}0gq`XyizmpJ0v@bhcS{ZObOv zE;Ma4L!Yb8$IUuFM%nPSu!;o(en;m*- Ibnfc^0U-Y^lmGw# diff --git a/vignettes/articles/figures/unnamed-chunk-12-1.png b/vignettes/articles/figures/unnamed-chunk-12-1.png index af169c893e1fad48bc76d7acd5a4fe8746e19be7..aa7a75aa509dc58b4606d953850ffef9ffee8871 100644 GIT binary patch delta 6976 zcmb_g2~<-_)+QlHP&PpY*%FZ!7ZhBOojhC`9D!(SgKUW?iUNY5tbx2BxF7=2j3Tl` zMVq!+f*>Gk5R_$Th=?JwBw-bhB|u2nviuL)o`3#1b7sz*^XHs*^6K8I@4L6|ty@)3 z;QraYFavhtKD=YMiF0Yle za%!A!rCq~U>FA(K<{Dj5(eu9e0`csRS>h==4HUK58Vp#nF7ZfnO2%m5e%zX&chNA@7{y#r*O{l|eLGG7CKIf}(kp5ZV;4Pk1T{a^5@EV_@J2lc2jGsvJ5y{gY zAjMgn1%B}taOUXz%+gZO3`MhD7-Z0P^4U~ksW6mYu{1e$3=}bkE*uKyNI&?t6iWt1 zTn$A-tPcK}yb8g7w=s{~x$>85q&-Yy`UEDO2AajBeUg{Hkvz=Iw^C_xg&;o7V?-gr zf1CXY6@a^`3+sA2A>VO44JWd~Ea!OD)4a0XfUMS<7sdu4nBm!&OT)3z?EY|Rf)mxB z>NVWRXHePB{9R(Zk#Uys`LKsMcnM|EH&o(m1eQnU@~UiNDWSC_$FMf$-^PquN`k^u zxklJW4Zky7tcGbh*eP5Ld)AG^OtoFUE}6kf3q3>AeT#}*fvC2NHk(<9Ar(Gre+;kq z!$>R0%W-TZhVy63;61$^x$P9#vOH$O8UKkW6w|gQq}Lm5AbSO8gat-L#(XfCq3%sZnxJpiPk4im5vsC z8h-S|=tVfuMo;=IXZ!rclvKwW1#x{ys$&_4X;#JOeOPArT;Q7?EoOd^>NE+#E~7ot z+z<0?E2?Z-Ot-OyYcao&DO6XFfpyhPxG52rxoj&{<%PSn)jPP9@$ zT~U-~U|wIIp+gHq8Urqxu$eRs*Nai-7#FOwRD=`KJ(7Sdbuxj)$*OI(^aQ@9oXx+| z!YpoW!HX|18Z7JY;Qzc21Vw}6bm^j>*KV`cfE=4Md1aIP-MY4-tqNKyTe#^WKVQJ* zn$s^{G471yDFp`xQe`T@D}p=i0gDWed^OIk!koc<`xX$WNA7Bt3RA~@_wj0H*H>n> zL=;xVGw92S(&8|WK>4A1FHo~~%*qq6#Tz9whPzn#m8(2D9<&HvF7^_(cUw-mM<1uV z?@0{0yWHj@j_Nf*_xKi9w9HMUVix=62WO^8MtXH=*h=@lo|Ll!xfj0iNf)da*){!8 z-b7`2PpZ6LJ~J@OA|QN1QT?3G&xx0p_nZ&ObTMit?g3Y^C+C=b)+q3npNfpIpH7vo#5=CSX8iMTu& z1}yz}#%6746)9_lb>@d^jS3Ol241vSVCYXfkgn1dzPY2AFcQaXX$q6~8Bg|OOe$pL z#mT+k$IQpIxkQ?HD2*Sl9Avkq*5YDB^B7)1(G=(mepF~$O3UjNnUk}M$J`_g3uT}2 zwnHP%_1&T06q*{4R`8;|q9oZO;kkhi@&sM^eY;v*;w|wV;hPhu@^D`&_oF@LL!$z* zeLlKI=uBo$jG{krx^AB_f8L{aZBvLKAIFIF6_A%2y1)JD+fI0qc`z%two?}TWOfLv z6m^RmjP?eBM}|f<5j0XB=IvV{+RYH{k=kBvzuzkFyf08OKY&22894##>V^4N_H+E^ z1Bje~A2JemACQW}i8IR|EUWE+QoZsW&{{b9{w6F9f0cLg8$+cjYPYiix_DX5e;x=_ zBhP5G96o$e{>Fqh*@pX654<#V0u~wV+YvnySVcd^NW599r$*{d_a#06ts$?t=c)`*@ci%-P zDz7W@%zT?+duo*5Rf=JIxSS8ouzeX`6utd7{?0sY>x7!e(}`nN8AfKXusstUi*|~P$jw0`yMDpW zi6RJgyy(q5uz@-8>YWp=p>h|RP<^j#1bc1Clz9Ose9^~z6c1O+Hb&rnI02h2^^sVG{M%>(L6R@X4gD|O7*sm*sJ zHoiEwH?sHQ$@aD%Vm_)0if#EOmY0nhPq*0^L#D{o-}OV?pRpaISg z5^^`QFyrqst!!ZBQ$mDur#F=9f9Y+^tkmI`RPHecP004KH`9jtmv6eG==fRxXd@b(e!uD=ktrs;K`Qa zaf0$&oAYP0lDF^A1hqqn?-Peg5 zejcm5CrH2gFkgTv6pRyES5|dB;>GgCucz3Jg)S-_#&wQ#8RKM&!~c+YMc4-7YF>Q^ zxh4(}M6`cR3-CC7jBD0TcO*`om@kYI?C*Lz z+8X+H*-$MIq_(oC&fwF}-|V%WxGuwDm4jc!mxM1di-P3Wv`S|_CO4^tb22WgKb19V z0do^wFJP(=DlP*q*cc5;~N&bG(anh3yZQZw;9G*N`p^ArEAr| zE#QmEnMtv_C%!PBaPIc!s0G~w_$MtK;0!KA#7?e?B4Du2Od=qeb6u(UnX+xp3p+Yn zS!z0cI@n9!l^2aardby+{XDWzed>UC$F18ji1EMP(oj9i9+USOwBVeomMwbwNS;U@ zi(i$>z>C5zH89-qXAAdMO`DmmgKO|Q%%3AWHkd!qH&6`Q@!Lx=75y09UO)>(j^gc_usUIQx zpuc(eV?FFx1`hbC%6bPyN5w#ErxD4{{2j?$8F3cryceB(L|&6bQFIWAwJ3$kM<`?! z6s22P>tFn@-Sw+1Zq6?zpERgS-u7Hs6N4V9cE|6!bQpMo#GL)2Act^4yhxaq-S+sz zK?DP+yCjz=^SeN!xHy%N99Faz0?cyrao8 zQf(VkIwu@`INy*`AX#oM$#G&F0fZaA5AhVMFluJ%XXb1h(^**uZPa01rxsx9j@!|N z*92TtwWU<5{m*hxz|G{gyq&PdF~hs(91%X)?@R?NOxBxJ7>{0$T3mS(7+GK|e4P?A zF-S&*PpoaCc<@u*TdDJ3g1axVUn!2BM=gJ8w6$$()O`qZ%aA5t+p$qHld|IL$HQmP z=-r-8iv*t}LP>g^6#Y-TR^{%E5y|;BogVs`s+|hg<_m>0@w#8&~byRe&8y81Gd;KZWmXgDd1e9sd(*WjNU#{^)e1$ zj;>D5#y%dr;zwy$cRA{0;w>T~kqn3g8mO@C-;jtD{*CpzAh8dz-nfZ-fxI0zxbH4 zcO!vfxzQdp(14vroryxz^arYmHO%`l!e?O>z{C;0 zFM7sM5esN;gKe%^P`_n}R-}*=@gjwKb=6zPfLq3r_ zEYklg-hT_{`XB83KX||V3bWubm)v#jKb9{A)%{wmw+KhXXRDI?*IA~LbjYNu8&1kT zIQH>ng&KvS0e}&~_}&WD=&IKwlhg2h*YB&OJWjM>$FF*P^|eZ2x`IvbUsqcJ?JDhA zcddKw{n3J}-S|&0R~44FparY!&l0&Ruvdm?otq>@+yW8lU<2#l4n>QyPt%dIRnr4{ z^yU7Vh|8xH$7#C2HKz45=lx?!lJ!T==)&Pu09-ABB%^bavL1CDEb(`dW|#e#-R{r3 zk|i4I%=LguU+qVvLkT-q+MM71{&-MO1~J?KT|2GdP?DJ|9h+?5#Y;kYiRURL6kaj{ zfdqixCjY)o5S!97PoZM28K40K{HH4;-{=_LdvUvVuDY>(HVfQ}24wyaThT{?yJA4a z@!8=Zd?xx2e6JP!NI)+uAEQvDM{e&8F3_oMhm3&~&H0Nhw6Bbtc}S#cEa`NvVw1=b zfzZ@~z1oHboFUL_0(_g^gDCzjM(pp<7Djrup6pi%|0La+*QEf5D^f|PdwAw#s4VNN zlKlvJ3AUS5(RKOyHR;S3Y>_>IuYPQ9se0JC6puh|$qYiI{GzF5J zGJ9H;8S%P+i+z;im5f_ToEdr(B)Tg89<9=A0*rOK%fL5c)9h5k&!;$=K^X_F)M2n& zKdvUyygjW=Ds2DufxG$9mPXPZ2NN?SMTje7BWQb(0AIrHqv1nRP{P z4V3ZIP@G$tpasFzrf0M6p*SnNvHYh3b7f8V!qxjn6hKra!HLlR9S&-@DKp{j2d^bDHb}dMy#Az z&m)HV>M+|j5drlzs>Hf!Sv|0>L!_<<*55*XjEBWjO++NP+UW(DlP0jBP_MEbZFloO zE8Jw^E63g$B`q-IIc#wuJ-hulC^8>(`9meB%hpROC767_V}f`<=tiMp{;g*Kf<-l&57keRPH&#P@WU1{ykZ}6xng2as9 z@Aie{c%)iv`CO`Qy|l@u3$if@w`7)2dw-vuvaB?5`m@}dUQ2K4%k+e(Ni;AQYYOyy~bI;uw~R(HmQPyFaYoNL4MY5vSE@Oqji?|=Cu^p((I^rS9Et4q==N7 zqu3qj)M8n@%ixcdVEMs5@g1%xj~jndgFFJ9LoQ;kwgi`r9+NldHjBuFQ6=ahJVyuC zJiRk7p|Fg5`XhM5Be`+~V_jy@^f@`7VZZlpc^yR?!eBp`EBok!6O(4^#nira-Or&L z&M;v*KE^mJC;U7(ZmAIlyI`&sqq88?_FXVsI9ED)Y|T)A*Qfxi&;4*uIMk->t?_ZF zk~Ph{x$z(S_=wUMtuCyI*~}AFd)nXU23*pgf>$gxruDHS206qX5``M_?x-iQ&6u@f zoT@lAdjTXE!i}G9z^E8ZPZsaop$Y@FY7fFfp$OQH$W@%tE_|Z+1JiI=nd1 z8bgn?J7^pdax#1PXe-esGGs_HXSYY8e+Y>T_VS!KNuDH$a&rS6iNOae7U38SHyiB% zeM0+uJjfZF<~5-WuWMFQg_plg(08^&!mUTy8o}WTXqPyR4=<(9PeH$MpBZqp?v#zgBNLSUD>>UoM0PY5_Z4E z(Gz!b=v!QBs{C!_>LleFp``;QAZBqPBrF_!T0E4RV&;`?gf33Z;EtWKmEXUZgrR!M z!}^aXAY(Vyto8rR2>p^)=e~SZn3zJhsQ%2dU9al=kfiF?6^uUBLYjz}jZQ5Z1R4fg z324_WNo7!L@<|O<=xU+r{_g(hH9l#AUb!y$2-S_C>=Qg7Zq`M?`VS}|9Vd}Zv*62< zsiwDcxD)!kJ?VmPv$&=?>8f9kyEl@%-fbS_ey+CbOxjaK&}sU4|2B=~QK4u{9vCya z?sgO$eyS2)WUVF^WaE8!_eVRhyx~K&bC>+HnAZPy!GLg<)j{m{Rzc>Ouqp>9}vtw>#k~0%46n z1R$)f5!UcO1rbmJ*RAEh0P6s_P^@7Jh3!&N9RTxL!v&_51W?!kC2)Z#)(A>~HKl}2 zfuGq>j{H}alf%d8yzCM-R02UTAIv0Yl>ZoI47f1M z7@RUDTzCvvN*P?{$P6Zf$zi}m4u`>k{~=~s4wF&FWH6Y_GN!zd!{qRoFr5dnDb{RC z0J{V(6gC@TLlB3N!(o(hm~dfmm@qFahR5N-1>!)^F!2b6l=(-d4kgR0(r(i$EZZ;b-G&WXS7CdjtZ5 z*tKKpw=o%GU1JIEgE!y#Y*BpR?wxT`KgDEYHI`6jOR?QshGWM^rr1kpGn#E}bkQ_6%_JTg z^2(P^9;QlV^a8RZ*DgE5<3TCJF!l=T+PzVv0QE&Oeq2mTQpc4FSRPg9k#g>3#6tUgTQGua}01TL1};&k0ee@@OD&L3t;bjFM*v_3`j zs#Epgp42urnN2_vyW@}#E>DerFfUl{4Qx8kg>)5SlC~@P7ky6>CgVclO;SORodB4y z#T$4K#2=rgPi2;rSeX>q3pwU%S5HZ^h$VtZI!!Y6aTi&_A2`0PvpNf(Z)R|k6X7o> zf10r}uTBC_8qUh5SGCp9rBmehmXh}?ZYd71Mt6(1O)?seR!BZE7rrqf&1AisE)=kK zl58Ofi@%Zn+T=8iBwh6QvaNJ7s~ML&740i(YziU{@l`VN6kxR?*19?ex;-S8mrDX- zi#7(3Xz#xw+Y!TNCPz|}Cm+(LS=m#`WI^pIW-ztkr6=;^mUOH@MuT$et_Q_I z>!dxJY0+&*WQ1^^2Uvk2hZp}S5Q^pnPGx|dm6Kw$b9*1kf<7-O*!`h#u&3-3zHuH) zf7i`|A4F1<9*NZ4W#mNJ@c^4KnQvuqR>MnUBrDvl+fCLz;A*2#bSubW>{A;d>NFl8 zI6NiCjr0<0LKO!x2lsc-W9f9;PoGXcG@-B>Ac5;hpar*T(zu-J*Xd>4H^qe}p}Zq$ zY@{fx!$c`etf5b7(cj(A8)GIN9#0s2<4$^iGL878B&l4l=S@LsV}E)-ZG#)#utTk0 zz{(4;u$yJ#al)FI3LDJj@~{tW5A}osyF*0eM*|-}13alTRG1Iu83!Jk-9Fl#_Ef?* zM!I!5JT156`@X07?OEGq6J%8tHE$p@lf0k3L9u*UP(#6JMSuG~3&S8Q(@oUF<*=V?yUd(jqxpJ+#0A(y zyFYWgv8QV}CY?(t66|>_q7WHBQoGnDc~plI8;rZvw{Z{gz5YgKm`rXtH@f7dly%~e z*Lx%GNqa@XB!>>|jJ^>WEtWb1?Je+-1q$*p2ce9PGbg(a4R;)}zJ zlBY|__d6ZZ`pUDta08~xJsgEfi1-OSISv+gg+&*~ZNi1}7BtuD-GXFnx}?T8({nk- zeWvreqQA_vzZ!g{**W_)e`ub6r5;v?!V11v?2hSBsTVd5?%p0?j%Hb5;%Hm#Uf172 zO$r4MM9p0>&2_zhZN{l``;mP z>7AbC5dqPFHNEnXqbu%vT5t;k=#K5y=c?9A+N>Kx#W5|-X_4G`En-f#Qb(*7(G?I7 zv?|RpjpcW(TdJScB@ACyp=Z!)8YW|-G6UU$l?GnQ-F}{GeY@Quwk9QtT3ANQFQMrl zsica2&gP91imQx6A3T-jWF`=;$=Wp$)H=54(nke59Lw{yO;%lb`1-gLVVN+eYP~0( zGbU=wAT`anaxe1prViKU!rT!mE~R@@3wDo|+bO6uoZV4AtRY1g2N*+4 zvM@Adh!CRa&p+|QpwxtDZt7u^a>EXFih1-VseK?mibe^Gx@I%OHv9USl=^MCr_)pW zZFu#EQ`@SKAXy{l64_+mDNkF^Bx@TV!9~|f%0#+3G>(mS-SCjyE@hX-!II=_s|M{q zb@OSmjn$S9L6K$b2df7P=!?l^!tSWx8)l?v0rhMyQB>1X*Yk>+RZM7&n%U!0Lb82x z`rH_4bqfFS%_Ebw?g@MBgJ_-9VA?|;!2{#Q=u3yGM|%9Khy_pH*++S)i_ddC?ygp_ zh;!_c_Pq4xUutO_nP5$7`r7jch~JS)4I^e3Jsz1o^@z1AH#dxb-pn0Y_DR06`Jjs8 zN3NC)mU49;7Zak#X7o}oA20l--Q)^4zT;U*d})jS(JXK}qbWP{po`Vcb_P49tNN6> z{dl=8G3~f0Oz^%iE-0*af@_P#*oB^sk%DI2^|Nhj&h)^daJQ1EcS$Cz zm=T+D3m}$jm#%eVEa8m3hsV#&oVvCY0`1H=F@L5V9{#nJA{y!j52&tcrQLQ*EYt^m2h=I;&*~ zfh-HrUy?hJoYHXzPx9VBWT}*5wdtm$^Uipq2E5U5UZ;yflasGzTSs@3#pyO8BU70wmdvT>?T-Z8D#+6Mz z`FK;go?5LbSK>@&F4V^=?OuWpji?A8Jl?iJn_~BiG#gi_vUT+oL?`_p^h{CymCMc2 z?}*uZTXq0~1ti#ps>-8>rTEY$KinP-;co&1naobD@}ZZDL=;?z%oH4u%zQD|pSBQTl zLv8N&(g@x2gGT0bH%6N(Ad;* zVAx_v#`RlGhaIPL!^|*YM*+cRT_g)HAtlmP6=8R}HleWc$9=$@(|Mm&k&|H8{2wI2 z@BS5DBbRHB>&SP3AHAz@@BR*Wmmv3kcv9-Te&%8Cr+%pw{4cAut0)d^rEkyRH>g;< zI7(DF1sy`&1H0iZ>~E?giKriTN%)J&)xr@=S>jt*(|$Q$o!77GkSot;t$UvAcFEp^ zFQ0%BOG%;uX`j~wZ!-e+Troi%=X1$~zc|iXV=FA1=E-QqzT(wXZ`WjOgmr)j6S5ON%PkgyzAx*0U>isf=(Hx3m}@qPN^q5XWn&{Q^I( z*a14eb_1^?NTQNp&5gXiUByZFj#Vy*)+SfqMw>o+o&Ftg_IsR9j3d12?qB>;Md=(I zZu%Ot^+nb?Tja&BrUUq9d6<6uA}aV|L0mDx$VrWdRl@_msxG>NCCqZpe*A1uxhy5;JST(KK{Gy5HqBkZ~kJx zqDiP3M(qZu)+LG+o_#?L*#<0Hi8OdRH6>J3vFp4JuG_O;;Z%1n|1Z`RuWQ!qpawh4 zF_e6%JopLOunpLzrFDK6aDMN9eNbAv6^Fi0otxd$yxFA~K05K97UlW;9!+Ep7Gro0 zRPz!_7n1;_&uz57u$tR3p`fa)umV$~PokeU*#|6Ig*2c|%vwr7R5hSdKXI<7pl{v+ zEv0XO^X3wg`j^!rPh1oe&*)J4=F`1uG*@BNuK)W)zfADVH(z-47qkh>FxL`4!@7O# zGgQ<@ozL(=hhLapJAGCYxme{hK45v@9A@+})6aS!uKp?HPn-PXbrN%}dA68#$Wi-r zo(2->i9ue3uS1fy0Y9rKQ&PZhb+s^9WX?(q;EX!37XUNR_iurSEh+4r~|=6pU5$S{F%Bo_R`SP&cx}lYal{f*{K-LX1gnNXB-L& zoGTVx^_{$>|gT*kT@@3hjACR#zB{EDs0dR<5l!YN2 zm(Mj|t%mUQTR6R&#k}!YB0|XtVw&URd=)d zgz6k?`G*z-Z7s|qWX=by4(cD8@}LmRz#H9GwoC8uY80^+Wza5{oy(Ov%^2* z3BO^b1J+r`h)a`p!=BbFu_bLqqkAWsTXYw|uBS0BvE42w^r8nauwyv_8ruLc{%e_{uy~?Il&&Tz~=_PhJsWpB?@$=lV~xeu)i#e=Y4)ua7Ob zXZXz*JHv$ea2$|tYfa3wC7)c&0f}g?6e>(K9Wl|xG3^ldSu4M z>Kil~PF8bVv?!PP*@C35bBbydINsne`hn@@a3JxHfkl1zME|jC1;4JD0gMNC$+Wb* zLHPjSXpCNan+YG@F2Ft*;%tS6zqm6mZIj6XlljW)0608lx!z6A>i!tJzy1&aBH@TW z7rxTD=OPQ}CUD?Ro(tS2)X46uGtC1U`J&k==ZYfIFEL#n%Wf(S_`$N{wcWLree*W@AU>ZypcnprLx8$60*n90 z*E97Ol?FJW$qrUBNlLpuCkEcy2EhUv8$M6%NJ%evLQ`f;4mY(P8xSuk5<+ON7kYM0 zU}t(IU$UE9Ov5lH@3BCu?qkHQNuQcmeL@jVMMOy}nc}mC-*t|JX7pwC&S%|)uLCXw zTFLq+(<{<_AerZt2MXPbiK|a8V{o#g9rhPgecmL?WS+A7{GD5YjDr?AMeCl zV4@ug@Uoc+v*8jUa3?%TZnC@y^y>1xw zYy(tcInnd_b%&Q@FZt{SN0|+w8Yvocd*_}O(HNR=_R=$u+Imv+9uQOJk_~|@CJENpzax1m5oysrCB)w7Pj+)mW}eQ7EWjNrgB1B z531I08(LCv2p}s7jq?* z9*);~P99q}j(R3x-0ba&;dqk2lBv)rYY4ZH1~^rzr&Rx*kQ|3ancrT3(=?snr}by` zUVe8MyBNNP%=}~5kpILdcK>!q{%^c!^hQugZ^SxPn~-O6uvU%{WIbi^#HsZ# zeRlz@dV3;0*`Xlg-BS3HMnxIx1SpR^e^G2d)zB1LX(g>~gJL%kD*Guzx)<#3gJHMO ziS@>|PouV`vg2)ORs>N>|8{DYS2?D`{&Q;;+)CPN&6f1B2F=YK3cNC|dJ=+cNz)%# z$EE|ho?Ob%P=|T_ho#sHi`Qsc&hiJIUyEzADKkw>S&n(Z?|p8p$kM2%KO3zZ&=0&f zVm>i7Wv5!SkRrMhQnB9dXwfk2O%lHI@DIy@N7fPyBSW`eS=WXT4H z>)b27qDgBytOt&6SgR>&33b+t44i&B{U`+=uCJH93s4@wAVov;3{ok1y?I@wNcaBu zSj^qGOHmfMflQIY(zLOslFE;LfgiQBoKrxp4r;VdKK0=2`xqU{$0#x(h}6jGV?`Rf z^-QhJE8f0#LwLBs4~?3hhiRL40Gs!sws{;yiu4O)vkeUW$LR{0E9e#UkE%zJH;qn_ z?)ixpy&ABR#h)@jC+fm_xCqVia*Dv~_Va_rYFOs>GQspu1*Bz|jIWVPi;Cbk_%#Ye zoaa+VUcz2x9NLX4o1X3=1_~BOBKtO~DBoEKyHMoj3b8b>(} z)Il5gbB+^lcQ!S)6-3wDGzL@_RV=iS(&f{LegJ>}Bj~@v3mxgkj2yl&O4Ar9GDxYh ze`ZOaKjLK~?%jt6yid3SsRcX8W5X9li7Uj@2ghG|{-BY)6K)6u0=Vb+Z?s8H^)5hN z^2+2}^k*^Vd5tyQKjM;Sn)C(6Q(?sa#&!IMzJdMM98?5tUl$dw9C6E1{`vH-oz6QR IZu36-AKwpY=Kufz diff --git a/vignettes/articles/figures/unnamed-chunk-8-1.png b/vignettes/articles/figures/unnamed-chunk-8-1.png index 3f76227dbb7b1e3fedbb0f22462f023cecc78d93..d68af3e5d0dd50d5822c402e4332093212b0f90b 100644 GIT binary patch literal 22725 zcmeHv2V9d`x_%NOMO30Fs3=4o!9r0`L29g^C^#0HGzE!>L!^ZcQB)jJh@v80Mg@_k zASJXQNRuWYgdQajS|~|?03qamzM#9a_s;C@-QV7Ockh4l`^4n*^PY3wbI$v`&-e2w zBmLz|*Dr;^V9Spg96k+$31eU|kx!yRASA8K?jj5Zk3Mzc>=E!21_Oa87)%oebASn< zU_weTlqF146Q=0^(rIL_k0^gF)cL0@Xf(InYaUga&JJxVooO!{Osf>CQa((1(4|J@3LPCTO(h&fPhu~fQFr2iGsZr6@{HcA_+SX z2+SHd{MlUs?9>qq?A7MqkM6%H#A>7la9YB{!=-I}+0xQ;d9Y>mM}+&HlXbTjb9$EO zs=|WYuER+lnP1E0Y`P8!?b48zCZ+|%#Q4$Tl^Jj0Yh%R4tBT4mR7UfC=D6|vYXP)Q z>8Uo@vW6o|`f>yJ8&(*~?NO(Ct`fKHQ{I8j-8a|R6+oL*kDs@ljy5(5J7#?~J%v9X zoQ1toH2s_&G$8k8COUPuUB<82MhPTBV5RPMo3lmez!--EG9jw z$84i{!%veIY(GzLk ze&c@7&*uk_eVx&AA|=l(PhsfNJN8Yp)R9Qr&vQPTzP7_%mWtc1Rvu0}K_5tK^<--a zxz-<zL6*b*J;$I3GGTw+gY_M)sX3@BnoLH`$?Bpa#hV=44kj=R5B0T8QvbN zr?cNhSlpJNJfYuF%pZ2pl^V|}SV!E5OKh9p_TVx2e{hv%$%LgXCQ*)eO-HUSjM=ud zYLe248|c~aq&CRaiB?D<@8S4rc@p6HRfL$a8U9x;HS*=xY;{xa{3xL|omi{uFeUWT zL5@Af5YhJ^FB)>d=$du$pRi4V;NHSX+eU|ByLSD~6kn!>hAoTx+w=Z!EQ^0E`myYP zSWGpyCN1Wnw{Tpf(^fY)OxJhmc{N7m{e0DIy`0jWSg_0C$ z6j(5Km^$a;MoFWGN>iiayp2icF|aF>Yl!C+WUS|zvw<(`as13F^HyC>XIch*6s&|1 z(nmlA*PcPw1U0`f| z`l(u+UqOWNyUS%EdQnFF*_M80x%PJ4Nxj*jVZw9&2Fo-1;qX_Dh8U@&$JQ3sp99F1 z;byreC-W#DY!|Arq$oMt+TuIYI&L+zRf`Fof10!#wV3KPH;#{y4KHl7G^P3ow{$26 zOm)(ePwVj)7~W@b0dHoLom1OInk<%ltO&=TyEf0 z2bD(~HeTozN!jv{bvBJY^dnZJubVDJ&Yr!Q9?z@uBxlXcT*8c{t?+z8cA~1Og;cBC ztU(cu`y=faHu4SS7&GB5p1cq}axUJ*_pO|s8oJzkpmc0+%MSf@HCw`_b?R_rCSP0> zlctMMr9K`PXoLQiyX^^;y_mkyp+iEfCf{b`o^DO`oUx;9ef52A%!+j1C=q`y1%Wt~ z5=MyOu?iEH)TPWir-mxfIStcHtcbk}mgG=8%IlBsGV`Bcy)fa%9qB990S&w2FVfdj zu|MUAcvMjMR1t^8!3w|F?~?6vuqDSgrOJJ26+=DgJs71c`l3~H=NSFt5!o7Q=$Zke z$7`=XwK-|-cOr?`ZN#gd0(MRoq5mh{mmKKZ)?{=z&7wDGW@v$hzmFeQ}UA zwQhV_)qd&5fy&(*m49gn+tJgJ&zs0qU5O$XXG9PbR~#_GX|k#ttaaK~60MAB-2sg@ z-ecnz<){Jcao&!Va~mZB)sDd7Gm}34i+ZWptL&i(246(HHd-tr6PTQQoO|o0jGlyj z%QGX~z}RNZlB8>|zGgv{YsZ;T5T0T5uOFRMs zHBQKobL1}2LyNp~yXy!HFSYXf@uz^|ie1vC2{YF=7?5+^iH1$h0bTW6E`8wn>~7if z@W=%p?r0Y!RH`R0Tb3BH@RAhB9_`BYY5wq~bvkG)FUe08n)c^0MxOKh3Ep_^bbCe- zsbc^qVvoONKfOCeZrfh&Q%|g(#<1`BNp&IC``(4zebfs3k!7u_!g6)#1%B))n@18? zsabO)U_w2wBv?Med%!ewe`oJTAP^-evH!fs_a8*4KG;Oi5B;Y1G6&N6@8fNvPQ=ZG zkBWeS(60|DSkOwEed_HnasY|^@*s=pk7HcLM6aDiJT$}*p06TWA`lxM6Z%$xEXW`Jsack5 zp!H_w>{)Grfmkk>)klwDT$ih(DGF}Jg_%=eVm;rCCJDa?L~CJHwN5WDjF( z&mw=I*b2G+#HwXPfHb> zz9D_Vhqjsg!dgpzLRLoaI*54aR0a2*=n5>}6R9KZMEl;J{b)5kbFJWP zFBJUxk1L6mha{>d=UUIX!>_x5UqKR8)8Zg$1=RGtXo>WFN$KF%Nx`pXr#j!KmYqH- zlHU?9uZlGc&nQ&$pBM7(#)#SKz#@xgn>$U2j>0N{q;|q9NvsTWk*^2(7$UkKHKRSs>$_*R1 zAghV>a_fpK6|9$|ft@m=JC0PXsghbAQd!hqY~jwgs;uUaeRRenhZW%Mqkb zK>iT@wtxLK%$Tlvaemya^F3wL{CRf>KUm#w;y_?K2&xUPeJD(I2B#JOj)2IZ`DMs`5}rVP@I`)^w(M?LGTi|7}i;!I2A<=G~5J=)BXUa zH1fPaaW3aoIb2(e9@5_v9&)KbTpqo%)kXEWVZTmsX+jSD}3Dydse|(~&oO)>_NM6L!KA)Ne-|!wepWlHY2Q&=e#| zo(yspBvIr&lN2PWVGJIGlJu);<)ffdNVTELf+WgW&&B`Ul6>9#eS?(;y-~hFxOZ=N z<1GSAX`eRu{jB`9zBB^yu5AMJnII)2Yb7fB>0%k^Cfwqxm-{9(CS-Y-G7@?D?bmyC9}an-`)|P|r=u^jUBy#b zr`TI`GkTXYklL&EDJmI!zw+(-pN@GT$B%DE_*}zqtZ878%LAJx;gPkWB|yTy<8v7& z<->RlEXoq((JBza9h;NW=ESR0fgqT*Sah zg<&BxH%r!Cy(pNWC+{f>uSVH!L*9gD>Pi$eua95^6B?cX&E!8K{yjwkE#DwL@}5X- zrb4G+O&|_Rb4TaKW9WAD$TVO=Si1(E5K;u$6i&o>dCz?bJP8ga?8Up&;6-rRpQ;WY zuMH^5@er(DC_7_L&N5cJ;M>h+@M63bpSLrNocZg3SVQAtc6bI(TimHBZ$@RA#+@2p zjcLlq60qLLI^HZ&8uo&i=uJt~>rrW9^|uvfKVkvdKzyc`RrP+Nb@V0I32Yoj5mx-s za>v(LoQe(KWuS@P;tq# zT1IK}SPXNs9&zz64|2h}#j~9Y&yQb*j45$Co;=TZt&>%O-hzwTmj^V3RfxX@*!zh)1OmqPoUlAFirK;BmJiJWCxt=bCt8W zGlnU-7soG@$(+Cx=g%0=*Ggm6qjc)93ui_uYKO>o2+NLFe&w;;5ULu!^<&hHY^O_S zlG=6F!)LFtBKg;%>Qw6ZGT2))9gK=pNf~vz^;6NRXYLz&g2Smg(-9w^gl1`VZ}OjZ zY7XO%bZ}fYbn0r=wdcb8Yn{>X{XB`dKqt3+BeDk9I5x?(@_uAH2UyO~vB8|+;=qkj z=~=!B?S1#IX-u~}J_#$f6%wn$=~6$t6k}{I7oYJ@@UUYh1b$gxMFbUA+OS4PKDozq z5A_U$V0DEn-&PvASrjkHgK~YGr}j!jx6FNIkiBUYy<02~%O$$q=0rE}>*f3|sLrO| zUG}LA>#34 zek?wTn&WRiFEZQ}OMgceB3@t8S2kPRe}ON>e!dsJ?iaUUQ{@jns;wn4>IKcy#sU0> zM7cnZUW=+vG34f$Y5Wpt@-LRamtWSsLgA<$a zl;$&U63doWiPw?t2glxx<@<_OO~mLGwgfwWzDd&x#LF4s{S``>9-U)zGM(2Du0CFc z+Ufyx$)(n2MTt%7Z-bgHd8J6?NUndRoOS+wEkpR_2%d8gClVSYR^_-yufQ@2tNYR% zb33_t!h|Zd|JL3gVjXhxg`Mz+njG-5ML+i7+Z@kyM!ZKGJ z<-|IKDaeYfB1$O8@TCG|4IYk_aa$Ob((}db%PVEGxU3=FA!@*Asz~pb{08TFI2?Wd ze+jDkEtBNrT4LD3bU{X3OibZSM>KhGJiK-u;Ia+ujxgPA@jmzlbsHOQ;izvSgyf{F z>pexBO2{SnO;QxfIXxpI%_ow`R{p=>czL7|6Sv9`+{uQ*fp9rRzDbykOv#<8-$k%m zZMYSBQ&ZXSd*%>^r61-yBr_7<|FV7dl?^$c=h(?f4b^k#85}YcTALk!aK*V`Cg@}% ztm!todU1D+g2g)kO`lBS&kwU^F2+5|O^ly+_b6#B9|PO`2oN7MJ<{v>etB=-Sx0POYcclmqh>ws7@y70zqjHI zSr>uwT~_ej7a%jQWCBm3{S{a%H*U{V7I}8eQ%a7!tg5JGcR9dv(V@=p_Zh{(-^3RSx#DOsEx#o392Y8=Eok>1@Jf1qFy1vh#A!M3c3h(aw)`X&n zQ&OqZ-F5fXgfj0{q{V8@&(5ac3Uhs4IK#bpLGJJC zXkA$6Y%3??4dLgc zJ7>(!XDsbv-@1vlJPZG_p{Ve2b)^EiR@W|DfRNCvV(9K+5(m{j{u~VD4_;5iKorNPPcWripxt z+~>Dml!sHfs*&BZ&Eer`l13wXJ70@c_2`}YxK5F<)SqY2$x-)Y)XChwsxy$xbGR#` zmw;D8M=vq!(1uX02sy`s*426|kk5|Vz#{`D%clJH=vCNpk7bd2fDb^n4p%0(6@Z)o zkjE9ra!qhiOS?M)K5gWr>Q3cO3OzfDgYWNV^2<16wN5N~ntmmo8qiYS5U9a@+9L5N z%D=WCOKt-IG83cWv$ih$^U+DsIrX+m8Hs^=3dUG1MZq|jdwM^gZ<)O zGvE?wul6ge8S={~;f+KQihMNO`Xb~eIq|MW)C>YJQW#M*SY@C)zrJz5ckGAbnm zU>XdN6)kzTTmfwbu9`661OFYu{;iGYzwWm5>r?RmzquWq$G*1N?7SC6ARfioqLDX$ z{Ipa<8-8Im61l<{vvvvmdYL5Z=mE@^2@r)s{dSb_D&n_kZ%rNnm~a;@<0?Rd-vkj# zzAoQ_KB)+LM}}N)+?UaD`YJ3ymmUfj|VS-&vgU8L?&gf&EOq1%T&$z#l>0 zw1Vmq1$AYMfikzEYn%rApS>U{Emm|$w2HU0uKhJw16`xljM6#2ce?goLySf=)aZR^ zN_4Y1B`5CQRy1QX)UM@KO{4b*rk9Eqh>33KK_N2P>#LgZXa7`9`>bN>R>;^OXeqvM zg}ukw-qljTnzo?_jmR8%JXlxGZYEwWMq6RpjsSTIuOv1f*M7^hHuF?ISAdzUPP&AS79=kQ;37b(duiEp%}~^Pj=#slHH=BOe8Y& z5ax~odbjd8v@SP7K|kCECR+l^7?bIEL>ay*KH#tM2lZ7U)coG{0Hh?*Or*$c zD|+&%F2HnNm+5vN00wM;nG;Wm1eC@A>=a5Fxq|n|37D@TU|m&A^!X+Lz5ftS*tPyQ z0}gsiN!baKJf>XVwF*je(R-^V4Grar;FMlm4WaP>mIvwqRH_Uqjek~v&tV}~H#uph z*ihtd0A*PsHlv>d%obqgThL)0JMb)INc_)1R%LkFP3tj0eIICYV-xU)d2H_8o&KtuTUp6oW$+2SM{FjcN>>P z;RVfiS_>xyUQ%VZu?M=;*L)BB3zb@bXgpdEQon+p3p8pNSv6M9O`H3PONTVAEhH!k z8sX~CI?EnWlPJP1K-yFwl;xYzl&I(TI-Lem@ZIWxkoFZw_%@0tVj6AMMS6F)Jd`UR zZ4%~lAy=CFY(bVfs*9r*eyMcp{3*Ag$e%RckV{V`bdj61TV9jKTq^v-PfGKbh#Rne zg1dD71oy7;ucO5?x5dY0p`md)V@A4t4FGa8pO>k$_D9+UuKc|2AV$+#$Z-)fJ8cEv zB+_jZs-d*^j9THT2$h`%Zw??oj9_NoEmLWRkj$$nIPu2Nae59oHFSVc?~j2T`k zsjdEOaFD_8Dm;OB_!A1gU#IJ--jpZvLyA*KxTy>$O-CT5O8@{Z6RoOfSh$S%2HHWz zd{e3KCk_G#>f8L-!84FwoOB^C<=%gvbbVX?FHE{id8A;wz%+MgeZP29Pz~HLwk&?V zz6AxXAh4BPhZfaA%okC?Izu4z1&P7A03le7gp!qzd&qX6#W2wF+JwG_6s$P-zh@EV zr2Wm5AR#Q&{Y-aAM+^GrDA3=_pq@!N_nbv(EQNY64#WZ6g^&Qo{9*vfM-d3@XGmb+ z6t!Tr=;VST-VVTwBkk>x_Q&*K)0@#d=iqN7;M@CzY$YHGm&hVtpil%IQ6M{*FAB&S zHjPFDw2pBAvlI?*3nHvWAl`^TBK{-8Ur1>ekgUV?A{Th#59 zM0u$&9WtI8YY6U2wm>5WrGzWk#P#U#_?{nQa}|t7!6_5I_T~X3@K%_;P%-3EmDOMG z6pqD1PL0b-fu=0l-q9CcTkC#;ir<9nTX;;rdd^MBer(zve}Tu>HjRq{9*&1p+rV|s2y4~p zqxu9?SY|7f>F!G-6@kK5S1zj>E#IDu^|Tf;?+68ijAdoe@zdN4>dc8lz^8V^1D*1G zRni;SZATQmed_omy?55pV4n>UxI&igxHT?>Q<@LF9UprpdXmTLR>PsB=EYa8 zG3`_7ZM3-;ycI=fKpXE~K-$v=t}EKix^Tjb*v!YHDZ@~Y!2MDd>>RM5|Mkfz+eql@ zsyyO%kkGgi4B9K!9bqKF*zj*&G&LIfbtYL$fa9|~Fq(${Q;nwoWEADkzGO(kd&%D? z<*3FG=7-4fCv@4qHs`x$S|Sv}tLtUdfFYVZn^hKgJtnPlB7i+x9=3WWmXCj-624K> z*-I{P$_+p;e40z~QT&K%K^XbnoVl#dRWD#AH9XaFvSwe-2GUYdHqqTrJucEJy2K^n>mH?- zaj&roDi=<-H@V=Gv|cm>{4~c5wBqW9+I3=+_H(74g|#pL0iDEu&&K^^L>ZFC@{`$T z$MSZoajgw7!Y|kp3!gX{hnhX`Dtn@1R<5W7C=9Dn`YIYeTQ?A`SuZ^(Ug!B*<(;#l z?xcjJ(7K19!WqM2|BX=)e#7-+)>eMem~L}4s>y{xxy&Q^=jShES?I;^)Nx&Aem6q~ z%iQZB=}>2bR8GjppL+oJnPC{|59GJl#*&-6wAYdhgv6_~U#H+a9TM8|c3aJdi&mjy z)eHMQ%&-S;55%z}e6JUbSu$NBA(vSo z8v)>AAaN~E2O=d=8Ex%_-LK* z0aKd^hr2>e{&+GcdrD1ygU!Hqh@@Y}Ki)#S?ln*MnbS^FjPOhLM3fqF`aoHuH(qXE z24YIF=lx)DGlThohC#5t+S90|4MNA7{JqFgyqOzR^@6W$c6b}zZUtUvM(h-3gC(c^ zz8)I(;vb{I{kPbY{!TiOCp!)>dwK>rBSLFm_8?e|HW{M{WRA5>yn`lhbXd}Vq_WPc zMz?UL)t#dQAm(HMq@-C*hUn??Gd|Cb+T`fgbPNO(Otlmi(Nch&nm4tYn5HxNABjM7 zQz@PCIUWu42udeKc$dT9&jj*lIEtCm(nPGyvPNWTq)j%lewpU#j3wgIcDQ8hU$>VJ za1?)55Iy8FHH-OJ^ZJrg&m#z3n(bXbQZ1}6KOKKho#~r=+E-4`pKDcn)rx0+C-=qc zgbmk8?9*$x-?IIcw|vj#&|@a1nhp?_!pk7Po4NyYZvx~L-}(Njkx1%7i&G#cEJbfN zL@qVd;NzL>s3iT^jYQ9AiTPH#WPZT3I+a)7ON)S$ay7fm7t;M3nu_W&Bne}HR5Y)( z5KC=SY0Av+@yCt!PWPT@iiGdyKP)dwwCLYv=iS#>oV431R0vr4{Q*NNQo4>}@utvX zx7MWDhC78i{+BVn-)MrDt*M@N9@@Lf zfjMD%z>cp~vzPtTxC+0oVmK&5A-jX4SnJvgLq0oA1#NVxztVVv{>7em&Gs8<&_XBS zN@vkI`+SiPaKOvCc9Wo}a!2gk*||^0XvoaYZ6fRnqP5%dI^cV zJw0_;x{($+vbQy)3Ep-l1Mm{(dI5CO4Y*4baWTqR!COFGeErVGAdkt$m@L;E80|_L z%`HdR>IKhTKdqpUVVogS(Vz(2)CN+#++qL_SL^(8o2?L)eLjJ+c=*G$Hgd z5vwD&mXJO-_aJ8+H`W&I+1WjJeZ#2wnXVbJ>}Ytqa!Dy2Ue$Y`p8p`{4CNDCH?0_< z${P$GnY|ovuX5VheQs*Hla#ShsnEqq2d%<0bmP-INw}%RWj-?N0gA_kh4h*RL!95!l;Et zMt+UD4gbh&$*6CKjTp>#Xg6BAyja%u4)8MhEkdstuzMf+4dU-(aj~kyw_&pT|B5fi z?-coW=}zgdblFf|HbVL^CQlTB2txy#lm(n756o8>+b-Z}DJps|8nRhkcacQ-Y(ejG z25$NSQUkDQmE-|h0Py=!hYVS(-iKh4LB5Iw`5S~&CxOk2ck-K$CjQ_zugx~G?|z&L zkG^?!#-92k(ccn5@1}xgw~iMF_P^D` zFTZIdAZ*WLG$T>*!1_yrZHTgs3Dt#xN(Z0RpMzehu8-iLZl z=_-_FCd6DJ0b|r`v~^m~eU63OK_{ljH$f>=b^#v}HU@c<*A7X-^4tB2VJoN{*k=Fp z7vb1Tk6H(4*qlUo2)0itzfDrI?#~n?f&EXwR@x8TmA-=q5EBRmC+T{>o}G#e?)i?1ENXYB zx*sb>v)Shg#=c`NK$|bx{}cglsr+IkfIm|7i{5mGcyui?m!kiYxfHWTz+AG}OVO#% z!(|Tjl5OF~ij~mL1xjcMQik`unr#0WwojtHfNHb+>+05Bh~ABBeu=bP-0a*7g`2bu zjN!~U=XL?<2JB_GClnROcWkWhf{0ZIkoK?)p_RmI^e529wizwtwKbn`Q!RI~V}d;^ zlv8@;8`>iv<3Q+i+5Oowfzrl>`8gWi*)G%$h$HnB;^zRlUY%!z$)iOUywP(H>b^j= zTu0i6iGbY^zl#LQHN==qZi#ICgD?57P82nZz^<68{zh&x^q6IB65kBY(-6(=RZWD1 z1)%H!(o_vY)vDO9?S`mmk$@R@471OCkpv6Cvy

6_H5$@NXPid3d}1B6C*yW7eB} z-w3lWS(-$TZ;9U)uJXVCopC#U>)aol+W!)nc$qrq8YAQJ3P4_l_9$Wax^;FRp}l>X zzAXgT{_*91LI`{RwClKz2wr1>1(aBbcop$ynEpIRFHaM?ugX|Mnz;4nh$PR>>^$9} z?Pzt5%gT6^M$kz`=qfSLM9VlaP`RnWxmyLj3%~EJB><|Xs?XGAG^A4f`5)~9{i>YM z5CRFxS)|Ge?nRM7)`vwPycJwo0R11{UR$oHFv2;p-ap{yk_0h>^hMZd$h0n-nC-g+ zSz)yJk^=|n!!e~d-U43|;M~+(3dm(`AhDfr-*oSz&shcO*Y_xaW@~}h0o(+Rs#2{} z)gK)WetXdX*o4w4*F{COH!u1T2(Cdlm{3`Z;2OSI`U#C+lz)YZk@;7Xva^Jk2uw`Sf~nj8$iq?2MzIUz44YSL=c-LG*GXirA~IK@Y}1hTg-GOYMSaO+C|~FfdkkKbVkrf0hh7o|92xHb zOUX(A8vz9DFtB_8P!I(y9RTb5Bk~^?f>gV8>2X;C0d^0dal4HES;BNZ0EgSsz&map zoI~2*Vr-PzT_&TFC6iGTV>PNGnL%5rR>)K>V6GzCSyygx@SqqrubKaHPLdeh zjAMR`9jkbgNMZ%6scVj^ZAPElzM&^18gV*yE0z=Op=)BaGpd`fkC~3zNp{Ne&gIJ% z9Mm3mc8}HYc%IuVYH;p&a4w~gJQn;>W+|4EPE6N{+Au%#0l#4+r}lVOC(^8(u|v#& zyPOlfZ**kRh?6#*tUYivsZ(kd@$PDgakb8j?Cr7L^%GmLH>b=TUV8hDi<=z7SX0*z zw~;ZPx0PCA)zlL`d2PFiQIA%Pe@U;SbgZsVx8in1ay{S38m8`1sEme5r#>XqPBxTd z%ThctxN*kaPkYJ^Olm5v?HM^g?(bLNn4WBKt4Fs0?;d*ooD&oHBS$|7IctuYdsV;B zGyhaf{_aTKt%%bvkCbU?u5eN@@RzDh=Z=qb)|b9+>U~UqF;a7-HS+Nidu;wo&BDDS z(|xh|yS2>)89JTvxA^LHxuJ7(#T_WlIo*={<4Tr}MkXBL7nuac)X0-u9cf;{UU+h2 z>DP^NcRW;0E=kp;{}jk>R1XgdzHhfF+q|$TCY2#-a0%XC&>r77-|F#+D+y0->it?b zHuOXON5z=#p2qVM%#4$b4c&K*-ba02LyWyZt?0y;Pd5Y;K4X~^4xT#aBwKMz#&i@r z2Wdvmj4x=ppB6`WhYJgvzTcpeV2j0{e0jg^^`m7tJa%Wo>qoWD`&6@1jt@0-*MIEM zFp(tgi=u>DN4Xh0N)a{JEXU=T+e@3Ayz8K@1xQPKw?|oFJt%>#tB672Ns&tVubPxo z^H;CHwFMUE^WG}rNbUQDPlp3hF`ibHr))(h)vp>X^ZDkDxulzuJBYmcpF zvvMTPq#DdJbp702!^B2R3!5yzhE^U&xK19RrVTloVD&^MKLCL3^=a+G3lc9pPU+mm z=BisR8CLAM@+f1EX&&wELjq%OQk*znw(994iSbLE25CQg{FK>6Jg38>DMPM~8a2p=7jlD5y;7k?sd zuUud7hMe3G@zaF{@B|}7sc>hvl1kOj*|TBiM}tEe%#GwR-EOv-+4e%Yp*K)qPhn3vKx4+>0sOZLZ^RDnAm{;OnG3 zrfL>U6GQyb=(FIZ8R&vb^}HIV9y9TN$=Q*z^ zfZ6OWD(bNcwU6?!;7w>la*^H;qA8}SG3K{-_rw=()Ohb)M+7vcUOEKKJtlqJO@`^cRWS z1V!@LiuA+rnjXvg2BqUYaDK>}pnH>aq&@!1=Y;~xIP09Mq%4Q-r$ypJd=>QPW0+^^ zD(L1AHF>^wu0+)ii@xd+OoxMei2syV+pVeG5NnM>E%^1GLh$0s!(=k+NSyChpTLNu zX2YfgWiUZVfOZ28Uu)*KY{DW`y<0Z!4Ez$pPa3qMAHePiGes3g2y~OVmx9>JYtqSN-028j0arcE=A0et;7RS65~;_R8q1`QA%Nh zQZzN4G@ZbO(R3=*#E?u%-&=}7EX8;%m3S;u*p_Uz6L^y*xPVBZ6Ncne2rf286M}Kl z#1vvMg(M7#oub5(VhPG)zvBFGuU-*e;c%~T;D6#PLVuwXq|iyT5CbkCPAVj^3)yTS z#1Y~A2si?`h&Vz&jtDL)ft#Ozdqn`xI6oqR*iY!E68hOh+$$mhM8}K zn}pFMVVp>X;KGndY!aK@Pk7Z&!1WWsMd$}|RB%!IsqB6>dnnkGO2kq73DkZf732oV zoFALYX0t8DKug#umh6-icA*m}mrW{UgA)4*Y$}mW1-U_gfL4O)b6&#cW>PR##erd2 z=5A>21%b%E=lp{rKY8myAaKZG{e5Tr62`iySSjCN3aaV)_~G}3LL~^_V38UnArZ=D z>GH#YJiK$^n=xCCTg=AumMhH%&3(8U65nxg+p-MTW9#FGCRx^pH(A}CzW z+V3IqZhdX@@oq0Yxj-#|ZJOJ^>1t|VYRnf z|1d>HM-*bvd=jyD!6RTH5j8=+1yO&1gn9aUe4)1D6PXL9dWk*rAqvL4Z*#A#!ssp5 zD@rP(zH~0WJ*R&U1?s7IH`(DG1@yK?Hd_YgmgS#rlTLW>@HChETFmd72wFP_J5#x+Sxl z>=4~96Z1OCL$Gz%cfh6?Z5;w|iugqhE7>QV!LH*fjQDh|XjmVg6@;hdAYx*o^g?;- zHMRJoTk;P?R$i^vY7yWc7@SK>F2{NxSD;geH^S48%38#UD;k*|&(6N5Kqfh7Pj|^+ zDy!n96bKOYM_D|cSnq~QP1nf14k0f_>u0ll`JZWc?9sbGy?q`HRo{?6$d6Ml3A{a>{$^q&$sgGFlt73m&-RX=9|lrM|$r*G8~B zbzbw}q3SezQ05v;bFE*S$kC9Vg#-1_yD?PQii2r#6joJVf2YlM8-3-n`|hr!nO3<= zulw#^ha6~X6OGo?3AQhm#L#ygVx%4uAEtLtoj%&C_tBw{Dv_4fa2~qifT>>dY-n2t z-7KgBsRa)cJ$*SOy86i1iZxdI1=d~9f~hd)(?;nRLhcX_Azt8n7S-p-IS#VX@tHJh zcE{y8j|oV{Cv!xDI19B%6?MAk$IK+g;UzKcYag@+o9LamUI{=}YFmaD`lCR-8Nb z*1N?TXIz}z`MUC(<4Rt&{i~o*^%HYYT>A*2qhO>mJxNzbOWyw#E~}in{B^;WkeOQY z^HcZ*>X`Q#x8N@!uSe7KPtlHnHhxVUY-tE_3#=WX^6~bHS6mew@{b)g4jKR1_bzr>=zAa>5n=-pi6qQrNR)PDPhHKT@xVpv0Rt}V8FB5$G z6%?}Qwy2CUn@=S6EJ)x{zT9V_C_M=&9c<-{r2(_aYaRR}VIT*|xnke8f zN20}vt4@+j$~BW7yCr8*OL+3W_=VI5wFuPq;L3|>Q_osw9~~Sh*IO%wju_el_qCv8 zh$~$XF={oP99-HU3Ig^KUzDU*ORvGSD>q!*0*6R=jG;4ZDy>=Hw+f#TZGI(M`nCuL zkQt4r0DF4TO?v@{GQRY=Ff}zFeh10BGZKAC@yYmw21dF;hXkgi-s28vn0~fIlMvLr z@QL?M4=-axc~7|wNg%B<+zNlQyQ4Yb?J7{KVQn}KPr;hdM-%xSx+B$eJBtYoG1Mf} z%#)>xqHk}odJK!S;G+F&TBmj&Yei1@Z%RQ!&J43skCBC@7gTIkR3}9Y(fS|raJHUb zy1R>*y^$&_#n8WW2{?EN<}G}>Z;YaMT-*SE9z#Wz4^J)@;3M{gFdR!MZsTS>-+Dz) zuK~i$-~@(LM5LEZ(D@n@#1Xg6mL#9Dnee#Rm+|*=W@rc#Va=ibPAh$ZqQ|L=h*vEw zYA-4qPrIR_Yc}fiScF`vSulvL+so>kzS6&hGlk zS7y89moYsiq{=SZxqH#}30X8GA45PyJ{$ksyIf{R-7;Gj>(O;tn7WDlg{!CX8Kr8B zcPI4%P#q%G;Su9*SiLF-P&XBRxyG!Lpt-v?$vqxm-bZp4_rmh(iaaYB$i4l4{g{6E z1`XLM_E(N`|9NQag;j4;5q~}3fARGHk6WIgwudOhzqO5hED1uCT#r2!uq~vyDeB< zRvU?8wAT#Ws=qBLCJ!h1VW zkY@|8gFkgqar3y^Goc@^C&kDc6zg3bVqYSHS^ ztR=KeA}_C9O4g3#)fT;!tIOXeO9+Wx~3Bh=_#iTA03cj@VDiQIjX3E5sx;%sS+y%hWVqSer%mE zD8*6y=`k|@|KegAYmON=Zh>EE=zOB4pr9kJj~Gh8?Xxj5T2Q=+{-og*nv{?*eNGIT z;su(y64SNR@Qv`2rLNFN_$+nKE%ew@cS&Tw@2KJSpjx*;UIe#OQKhSc1(y1mu9)$! z)8l)CxJ&<`4jA;T_?pfe#)w1uh>v5%v2{w(?;OG8V0g)U2|2pQ0s&S+P3L||OL;II z^qf_&C-`Fy1JTAmMgQ!9{|h~!l2|9ri0JJDGrb$k^o@xLTMapLeK(lv`U(omR~-Sf zy%x0eQ_Zbw&%n|s@dQg_GaScRJ0JsWnc)r~z8#1oU=NN0;g3KVgC5|DZjLyynR#>V zDvVa6v3yi^Sswi+?7e2~iLIeWAFjj%#whHLEX$#SwDqX_cO5UMY~-FmHKs3o8(4HC zVm<<{g-Q?ud|gO;7W?fR$id6$b`kQSsjtr>eaks8QFkYLu zTbn~X`gaqTPj7k@%V_}Y)Kj@1rEX*jI$i=Ti9$!WC-44V1IJm)F>X7+Y0A`y;l|~5-_0jpRH*mU6N*juUd_QW&HgFE({gTpwf`W;=!7)RSh3%(s z&ZFFL&VdYu>~9xwoxjJ7J>sxROw$=zp#c9Z#`$BX5$6TMK>r0t|2y?%;I(S&6u2jT z|7K2Q&L{AKdP?1i;wl6l+}wX=3jMPq{y{S$tud#g=U1i^nZJKp(u6^Z;k|y~vDBRw zXR~p)<4M2hK1F|W0<$;Swg9i`|6-oI(Y{kBX3x%LYtQbdf3)E4*}FyT)#FQHtg21@eT z_+qM^BGfh%tdHPXBI}0%1!{KXE0NXOr%Lon7se_V^c>y_zr0gzU0MqNzyM6Piq^DY z(>0IR*5i{l7dJN7Z&QRyuH+=xjK@b%oHty=Zz!ucZ3Y(Py0pe=T})a}Vz+-GLG<+I zDD+$P;2T6%N8hDtvOpZy>Z=;g&zSWs_kI+a*3u=2bDXxo9VO%Gqqwxo>oh1`63zWv^kT?5&EG*j zc!aBM7AZ9YUZ|(B=d`)h;)gkLNn~HbM_30yS^nJnw ztJ3@JQLi$z+})icnko2Q%mI8hlX=&^xO%@vElR*k$_~-M8l<2qHApsiZAM#?bH2O1 z)2#1CsN{`M$}EMoTx)B%$V4UCqJHtl*NsAh^fI}u4g3Q=_%G3(<*DUg7QJUGGo>O* zSg|f}9*?0;UHWbOJCTo9L$xffmY33Y4fXJee;oE_adJ60vU&y^van6L(%_BM;vv0LciXw?;J zvH{|TQ%~ok7`sG4$;UdO@yto(@`1Bvq4}tkgocIY8cmG>bZOE2=q0bmd$rQriklY0 zS7TDz)v%HB`9eW#N_tkMNL|vqM5gz6`bRxPpv1?E&I0fQBGm>oKJq@c71;m@Q`s3v z@d;6CjmW*>(9_%SUXR{_PY9Wsx#hCqKpuFHk2jw~HIzOiL^D;>bKkJg{|ddLo`uVt z7@qMukmu_zrzENqjWQHjxG_rJV%7o`7^o!k5<-n?8rUSk>L+8#q>-%5IClqzz+BU_ z={Cr{(Hys;hC_Qlp%Y}}m5nizK_2fS(&tPU;>S)%t6+(VnFlI7s(VdnDn;+qr==z; zvqaX1OJefTA*}fNY~S)ya|A!-2`-c6Gq9%hytHZ&(c3Ik>UJo3Z%ccio`59AxYfq9 za8me@k*#pmRWBE#6knfnk0Oe{^jh*r-VT-cNZfNj9EpKmEVDZ=-aZrQM_;TmC>5+e zFRhO439_BFOX>-!3Ew7C`8AXg<(84W=WCIO_0|%tVf7DaMZIxGU7w=~DOsSnP(Y~q zgtRu6Jdo;m0WKojX;5#0D7)<|CSvnlI!N^*)0av^?3dQX_B4dtewVzSgs?pCZlhxn z!|GS_(Ge@t3_?blARvP9e-iNW*8t974sOZ*>XMe0rd-Bq%`ORkYQwxTtDVgrtDvPN zxzZ=3TpCNt92e5%8uymXd|iXC_^)xqy>nC}XpMK+MkSGEhR)!s(S9&$>fv_Yz#GtixvXHs!G zS|?R)-t{a_k3AlEPA*=k+WxX3W}arVgZ1g2#BnPdnSFJ;sZL(UrW&R$I^(frjt`^r zdl+BYi+HO;0_uhosJZ2NKT1%A9BXz4HJ?VDT%0jBG1yE|CSJ0ZEzp8b?(yyPYx?|a zT!yfw*5)C$Xd3E%5#60~4nCA6pXb3%_yw>yQ)M)2JCeIdG{x^~i7FW9ZW^Goq)y_=OArLVsEQRTx( z6rI|x*E2M4bq}(s*&ksNqg|+~bfLQ*Tl}Exi>^h#uYg0Y$6QLqPejJVzt)$P+*-36 zGCT4sMCMUA&nUiI5<~t#q!TBFeNFFcsKO};wJ`O%T%Nqro4Ksz9ga!>Y@u7Ki7Om@agdAJ1Y>M4LDOTUPbyU5rV zXzQlC)1iNlF-h*lmxW~oho1 zG^kl8YSVhPjsetlWv*8NzE%3NrG-lsbGr*A{fO^ly{Bl1_Hv)BS<`r)2n(0AmlHp9 z-O`*<5t;#j>d=T0Q@5oBUHAUIr3D}d4qqIR+GkKleg+R zL-{#LUlw1c|9}(57Aw{qb+JWyv#Oc`XW(8xV*TFG*Omhl;`E?u_c9K{}Jyqe!A zS5=|0-Sk%TT}dIn3=x+lIOR?hP>CtLyj+78sL{ZnT`k5nXkjppL2HEI8nnvlDsu(L#D_}iLQ`&V{#f>WEyvb3LhN5A$Z-d(#+-n?=ePrSH%Fs$ zxU$Q(!2g4YiXS0_UcfD23p`W-ekTcieHG@IPQ!6v;dB4wz*UA@p*38*hx6>ugg@9H zssPpV4^fE?8h_YY$mZCLxlW|A+9({s#ucnZFlkeGH@CoH&C_2w>zzs5C>g1vR^q{U zfOZ#zg3*e-A%&7nIuD_kghIZcnF=J39%;waJs@+O*b+6)sieCi+c?Y_&EVE1!uz zHdz;U=#)|C?mFQ}cj{Q=(%lW3R zLUEkNMVnurny-#M&wWY8K7ZcLkGU^#IUx&OCeN+U`e*~hwWWOggDWvVM1dnbhASFz zVk7hB(mQ@xb6D@xlIV)RyXpXf_@k}-M~T*6QSlm6z80~1sn;W}cs~6(M5{O`%GU3L zga9bY1AwA%hiM5I;b5ZQF%-^-e#cNaBf5m4a7FKjeE2@15zpjaeII<4VS^v#o|wA- zcMSgD(Je1*c?TM3Q8fcD*<;-%#i8h&O3tKwv5$A4d$6X?UU{s;q`2Y?;)@+}X$^9s z3VvWZ{uaYrouY#~W!LXVAZ-E`iNlLK`*Bl+%`)Wgz{b)x7q3lRWbYnyeXdo<36cPA zaj>BXLUA3^W}WA>4iY)<;qC?8>A=s~VdHc=%ioL~aIyF*5>-e%t^I}+5%#i#;7fAF zwjmoOoCxyT7=SgI0)1M$eN=hotenAjxGSKD3R>q<4c zA}jv=0rvn{qboFeYo_si$FHjn4u||rcj)OTiR^;nVs#s0M{9BJ>=J|oj_FWA!%;%8 zDim1wFVAy3btmi;X(c} zZcx>&Qc(v95J9xeaPy>o&pu8x)q@&m+lL@9%8)x}IWbq9W9V;A5Z(m$O-eo{Zxi^u zU>t>VQSr}c_nDk>n4p@Hz&^8cIoM6apcfaueGzgYu`b=eLr9A6DhfV~IRAmGJN#-nb zTdm^dqC0^Zmj}!^TH8fn;@kqS_CX+(9(ZJGV7<9vV6c8TJeD75ZZWcfS>A#D8$nQ8 zLX?pDY}-d!gB8`8mF6!gKGrq-VlBTBH~&A9`^L(ju^Q#W;5hH>&z>j(hxyW|*iku41!;3m$Z%NX zGzcnxv4I=95S4vwGJ#3!qTR*H8|%#fd^G!f(6-8pB9(2F#tU37Mwmaw?mIL?yL}{VEx5AoDNpf+a@p%=dx9Ui-Lzs zMQdG#^6l@vmx=2EUXD~r1Y*Jp*3%TnfL#MW6Nq2nhesO(?EFU1-LVy1u$OLsDxJxW);)fn^eOpIEo}q#`{B za>E&tmUG07W+ro`E*@AXkP0x@qq{GJcsJe2$7uH_4nYn8do1B>->v${;^N?oQ`03a zT8#~Q$8xXys5$T=`U>l|mW~I7jCr``6=r&e7jXPDsgnALb9xi0%c`dvuno7V(whksE-6WoeWj(OAb=`F)$wG_Pd(pc}~eKuTSubfeM z8AShVfkM|k2Gcb|{D%>)h8mrH?tk{X{SA?>=i1(j)qP{?1Gu|A8b@n)b0FY(eCE=4 zec#IqRXkihPJqLqqdjxx=aan#ve>I*OhJ!Ue$-o(N5)quA>N_+DNU&O_sp+l85d{?N8 z62jF}Tg)hXl^+NSB9w2417ke@MB{idf1W=guM7Y!vdcob;4vd)r`vk;a1|(Q~mbLpk1BoCj5`WvB`|v9NfHI5bFon~jSM^o7 z;WcBA-Bxo7p@p%(#V}D<*U0R}qS$?X211L!3pF!$MuxLx)auYd!PIO9PPq}OT3b(H zky`J@=Cd_nDr*E9#?@@ZFt)hfURKL4yh($MD%L<5E_Yma&Zc42!b3WKGDEEAao1z- zr{4AxmAB9|HpRW~-N4^vqo&^X@6T*FH6Hd!rj z+#nytZoONnW2rBfpyS1uQ)V?K2VYd7m)>4cA1dIx7waZVjj&H+3OO>)4{TWPi6CFK zViq`y-)_A-+@}`_P~CEzl5(ZyN`MISt1)_Pf@;!p_?_ANH4|0{lR}8&dALlf*o$(bOtJ20+wWjL{C$hbZ*yj_8&K5yTB?Oe9&TE|gVL z7um_{aDKL7eDPd{guQT0`Mbn0)KnTugE=s|x^4dr2k@Tpk>%AGo~b4YayBxgcmFiu zG*mK<>1EN?GD^AOFxjhnPBvgG8zVg}+*W@y=LL^QbwvHLdjg3M64}_5n0@VfSfZ81 zp0Cxjq7$iyhqIy5ZMHq`iFYqQfofa%tf_$o5>*meDsQjeO?yK@#<|E@6<22r;q0FtE~~JcYTpR z7b2npPtL#(T<(!lOnkro4iBX@VgKaV8$}84+;=#BFt?PW(_J=-cENd?11jGt=8eix zr|5Sh{Z?Y$skDMaE�c$7W(&gW!=@*(8Ci^H?ud4?k0flr;sNSB! zt3_{n%L58`FbQsB0q_9t`A*qPG(_wlMSA&Lm@0t5LqM@B+Kh~iZ338?Hogpf{KD{< zzcsr(oMNm)n(9((O~RH9k}uZAcZCE)?3;`cx~!6dwF?H5zH|C0Go7ZnknYRpX1_ki zrVT2=U?);z(3cgPl$k+nxmUDse0#v70!oPUXu5yeHzH6?_W^LZYI!i1cRLiD#YLF& z&6W`6!Z-NRhVs4W`@2Du>*}ag%Jkw^H_Jkbk zm#-mjZZ-Uv***JcMvpaBwF#DU6tM5I=W9pXcBAG=ZS1efCU{z#p1I8Z1pJwFfB(-D z=+d@MYT&rU73LI*`Ar~#q0Hmy>s^!&C@_znmyBnxMhlE^NNiLIwjJKEb|he~t000D zvHLJUW7!WXyI!257)aJ`iX2zEYwjftIE@)JbZ3`;Q&1*fZTi~3!uP%0HABW`VZEqM z7i&A@JRmUloCcn};(^@f7x&Rv<)i8Sx9GF&>+xFfh`W@wIXw*!_)qhX+lNA#HL_e=Fw4$X#BJPigRSs z)8ca)>hSyv{-PV+@=0sKN0rQ!dh723+VCO!(Xb*f8qKuFA2nkrz&Aj?7b*$y8Tvgm z*@?W%gI|bCt_-@^9fY?IhsMtJ-xbA9PPjK zv!)78A&w~bcLlZd&|Odx0;(kCepkGTZ@{4)QLs|tau{Pn&--G<;|X091z%sX0ct9QUc)s@}wh~&Yhg{@Hs1In?BpC8Ob zs>Hf3Rt^tWNoLF>uO;#hpyjsi>6!^R50QQH6HRvY?HBO8jCyQ0s_?mxC(j%mHVdup z+c(QLB)xJOf~*CU+P`4QdQHP~@p6=MpEuvg^)u+w#q9doSpv>&`o*hH_4NWumjR_w zXjB32EX3Ah%?sr3Va#AnTv)S_yo*F*=Q(pG;#GTacRaKArCgbwtH3}- zBu+;0_O95$6>HVWncd&z$|02NP8ogNqd z?v-$)ag_X%?pKMdk!Lc$3Wo;>t-4pg9xYeEI!T^hXS zGhz4u%GpH@;G_bNs;Xd&K-Oi9a2=zIuW{lk9DVL%#R^U=JE)Nu(9*Q)T;TN_gDmxl zCfquV@7slR(VKHuA==F&Jbl0zihQ#GV(nG@-#gnvwev2)nu8Q4$B*jXmFR7nk%WO$ z1ET$LQGfrhjbyQr0a&qL2owrfco1#vt~XDC76{07f9P`v|05>xf1@EJHd4hW&2R|= zVVeNkm5v99(mCkwkO_Z}*!G(Y#Q%$#Qlb1mFoz7cVqbrix%qU?a_9iAMAcHXYOdc{ zSb-~6d6{6inAlKL@2`0z6ZEQIkuEQ|gN1W3yioad{#wA{*uoA~H!C8yiaNwAr2yFR5%{(B);gGby zCZDVB%&ZxEzc87khr0L(ePT2GQ|e8C;Tk#rL{B+HPV-`7fNM57=OFNe9uP9*I3=9U z@Lm@N4AS-I5Vy16pIaq1yVST-esa|#FF$Nk{Ba+k5a9K1n3}3ZOHPT#_dlHy3p)>f z7taf7>+P#FtIs7A)XXYO8}VHS`i#zcYv7I$b)YvyF3~sRO^JL$(&w#PCKa7i;eM*&}|mJ_q#y_G{x{Ii(9uWvL+-lD)?8z~}rlH0Ew zN-%d={>kj6jfr*B)0W>^KU*|4hI8THZ}`AX{*RkM4UOS~pErP;`<;vm@b|y=r{o31 zgtlJnvGUoE-LA0r0E={VzsgVlCF48$&Y84?)UMdk1nCj@HRQpAt^ba?@=ILwo7BfI z=^OUn{6`6}rLej8c~b|9c_s30>Fvwv}o=LDxXaoAuj zpTO39WOW27#w2&^<@h(5Nqs3@)?l>;5pm=ct`IZ40)xNQ1#u|EZKyK$LGLE ztG+?6=s#ZEfU?Uv2 zl;Ot?dVh&ew*+Exn8r&WCWj=q1Y-V$bF4y_0x<5jd^NzVG;EMe1F-;FfR%i7;OzEX z5DZYx;a>W81^o{B@@I^}zvF4@FRbM7G;2eB`(gK(1ykp%qB$hbIuJ6p$?ixBD7<@x z&Xn*H&-v4)o+TRezhu&f$U|YNw6ceX5xl(j8s<#oq0oCqoB$p7E1akmbn0pVdBda= zK`@F~?+^z~gcvA*Fb!UHO%6i-wuuvv@@JNRwH`wxBQ4+N;!S|Q^28XXvJre(<>8V7 z$i|nIxFGvV`*)V|UO4jP@Zoq&>$ct#*3BZH`UXBlJqi-RE+gpf`HTrgJ5S?EO3u|j zP)a3=3hB6HxyavgT$4S9FU8ItKSQifYe^39!e6pl@R;2W44RH;3Cs?0iR5F!6N5L< zkToxg(9+tkb^SF1&axTpO$u}A>0bD!Xh_C!52!z`3F-8iv_Ujd7iZO##8}J6d*1c7 zP_+>@H+MJjPN>0dtvC0|zYDid6l%|=&DxgXP{VSfuSY&o!M8l#E<}rCLJh1C)<|i- zfp6;;nhqWIwLm~xU%Ww=;(Eq2NA88anN26ZT~LmUG^z*Ynzt1A=0b6oIf-CY1#V{m zcqB63m_P#f>*$#yh*?6(GuZ|me$OGlGrYX#gO3PRcjo7aEE7a%99dTVAz>6DZ?VP4 z78;#egsv-DRi@=<9qurD?FtlXmfQzBW!m?VI`=*Rcd{#BZ@|pk_-!zbptSWKbzRAH z((IR4M&$=4fnC=6suW$f7z__L4JlnHY#?Oz8xTR`gO{(UUS$Jp&DKK*$W0Jiy%GwA zgOAYY1JeoM3u3@bi&EPI>F4rYgxKkIU2Ge8hkd$@V~2P^1ycl-NC18Aom{% zIE0PKNXdIi0g~~HId$wlodep*;WeH7AA4^cMv!SivP;k8p|OoL|HpN%PgWow^E&7@ zQfyVQS5=B^S7GSC$^h945R~5-#pS})zNnY4g_65vdi*?6U%$qwt#8a`k{NSsNNjpf zXGocDi1Se7L?-2==l({UqBh^Gv&2EYOv*0LQ^~k8mgki9m@`|-)Cn-$3|y-`b1u4VGtWHE*BzNtrZ>-S(l2e5mDC ztW;*^5yX)uUt}PWFdFjm*r-NP!1F8giJ=*rG;4gWQEkT7_{Hq=$SwTOSY%R+`V4I* zf=oi@YfuiQ`X2|;QbRgex6a1wL>tWMT5RDTXdAWKMp76tne+4> z{cx9Rh4)y!85$}=2v%sml>Rm!F%^>3WAyX)>w z2q?gxo2z2WUTeIa!%N+(6nA>pI}+of7L7*;nMS8RbVWx?W6FH^Xobl~O9tiPVdm=C zRQp_`s$XiJz9W9k)@6iDFBlD)86E}|GDruV?}?brDsTp0Ry#ONHAEcA_d`YnYNE0> z3khI-i-uDcw+zn+VdGBc9O4sjNGH9c7Fy+vHy%RV&I5ua4WF;?vCu9myVP9^X-)4@ z?)-SjS z*5z%%K_kQUuu}=vUh$=xc|z&y%J|hZL|ojT5ADHLeavDis=%|;j5RE-Tzzh3Rym}B zMM^Au^r_9u804p{Gu#%Cy;Xsr-(Yzk8mnRd((`C8>jq? zOL-YoLjAk@i9QN3*H4H*zm}4^te(OZc&1{CrRoKw&a!9b$Yd2hjg=UrxrAI{vZV4{ zAsPfee_d=Jcbs4c1o<|HoDH73GVSH{gwdMc^iGsmso=%N*M|fs?FiFl}pYStX9^0qdYrTVmEe$VlbZIne-V%bz6{qeBsZK22AJiDZ;Rr*z!&A z1mB|*?=>}_&$hl?W?15>=l9vwzqE76%OSYk%4~OSf`c7i?_ z16Vb7S7*1JoA9yBeua|w?u{#|{bIWg5eDGLXaXpgbii#tgixP*pPzHi9MPAbu7B)#1R?KyXdGWVIII(c)4A13tT8cU*l?-`J8dLX zJ>PMs3Dq+$oVTFlwV;V9maO-*(HZfvWisnxL^QxmNaJ(x+_I2KRQ8&9I5cimNQilM z0DLp;MZ$UvHPF_|ywYZs=SFy{Y5hrBeE4M8S>-u9U)jn2xjA`S&g0)ap8jPtko#<& Y80|YPfuA2VL%{FwK_mUF{pYX!KPg~Z1poj5 diff --git a/vignettes/articles/figures/unnamed-chunk-9-1.png b/vignettes/articles/figures/unnamed-chunk-9-1.png index fb1f745bdf7eac2ebfe5568771f03086ce6ab5df..08a58b061abbd830fe3009b414a3f7b67b7e29b7 100644 GIT binary patch literal 10867 zcmeG?2~<%#UZ~JeV_y2$I{Bz#qRPMQ5UEN(>Rb5@xeea!i zu$7Zmmj;1Aa>wnCd;30XlO409?5@j_O?wfDmU6!g-tH%BeWuohr;*{Sor= zNO=T89szh#@<;&C%e_J6-sa^v003HQIaOFL6asVr(JJBUk3=8=Kp~Lm1PTCb63`0) zfHgFULZZ+~0Fq88(SfIsLdc_#2ow^DLLpFAE9n$En*!k3LMqOjiu0zH1AwDag;b%C zPRgT`2y_YnBsvA41-fC=*#HRXLg8f84K{_qrjXcl04QuW06?XXEffmNy@Bq8)N&!v z5uGGtQ-o}~5U5*af3;)b8kJM$#|A)e4FW+y$B!I57nU(S zFcqUY_UO}avPiOXlT(1a%h%XO}I%dHYfXHkc@3~e$aLyP)Dt!t7E1>^6R?ctvyVB--t z=P(>uLntgQ2$pqH<;fym&^^t7%ai;BEw#+}9`=_-zxC5*&`hhU>o8uNiX!xsDO4d> z=7WcJ<7a>j_28KO^u&Myp57Y1Zc!8WUTeS<8r3KxiPKfbb&PPDY0L;PuM{QGEHhC{ zQNZWaV+v$xLKAUCMY)!%n|U2J!kgqoPpOtGqN1N(T!J;XeXeDrbN%`{tGEbuYc@LM zOsY12g#N5;WnmZ+C+$Y>MdgWhi{BDcvzwGEFPOw(S8 zW)DxSIL(b|HyfS}UxX(c_PT`Rg1I9VDk@PEwPYW7Dsq1K^KO61mbc~F4=VNz@-^!C zDW@6@r#p0@WL*`8Ol!97a@ci7lU(Pf=sDV_CBj1MZkyC-;b>?YlT)49W{A98+(yR= zBY77y(d*|FoRIVPEA)cS-2tl=nyJ`3_!PPGLQsOX*{dCom&UwKai`cx)ha3JHf`0F zlO>7IvxOs$bI$_jPbdd&z-8sTI5ckqbGtb6CvEs)3sGImJLp9;_W^+`th?MwzU7N6 zEezc_GX>_-O0WgnK4a@rqgWcOLcW!|60Ws^XqN7MlajOzU2Xw1Z#0e@NDtcA)QowD zoVO2j9Qs*QWR{WHghk}$2TUj>b5p8gRq@4{hVGH9MvF~YlCN?y{9IYpIod9$l~dQi zr`k41agFW3)tgMekn*~!8ay(hl%c(g+`FIe3S$;{AegO=De;8kFx~1!!OivgCjDMn zWdXa;w54ieaRkvYr9bQSnR{Xgo}?|RY;yOrx%1abp|$Ml;TcD(qXd&%H3*LVWcIjU zYZ#?^DHg@64ii4wRX}`xwb*FEMxr?SK*=*_kxO3@CxQ6kVoEaoWiOtCZMw2xf1UPd7mIX21P}|h`Xo7eZVn|h)eHn| zVsi$g6e||FqEtY{a1ve>t0oFckxONmU0FWPJo_)!$)>_3aj;9jZDob=yni1tAYp;g z{>>sQAs)RPP@s6RkOITyR*83n>`4H=KEN=gg@)O z*#ZoRXWmDt7;dF%;>s*uSgo#)LtqAfaOG9W3(JgMa&6d9QhL7O?b;>2HkxwrZIvId z(E*l>2Zkiw=D43CkD!~bL;X<7<|y^#g*-i|{?^qcJJTcI(uuw2lifdQiaYMoz2zg} zB+b}+z@_FD>N2dGImKBuKq;}OC7e+0#x$*(J>)h{B-Rg{Y8Zv>2_AH@d`c|#pLcI< zm>1~`J^Wwt4VPxG`5vJDBd`wq)jQcRgq$c|1Puq`WA>7Zwx)s;`bz*JJfr@j?MaKA0Lz>0a6K8Y6A4Y-5{c?ZMH(Uxux zcB9ut4ajAS+?snKgOqOJP|dNlC2rRJ_z+~|x~P}A;yt(4MV*BOa&*GsuyKW>As(?I z_w_n_)<+v#H@5OaLNlFQ3dKj)mep-cfz_QdfvE4q#`Ly)N+0VdEIrjQLXGu2M=TI< zO7qBR|1UX=gR)LF2^GQj*z2uq+~7}4hzY1GCK1-r(k=HrnyGUYX2f?2$`fzG zyUi}Ji&NMOU+PDQt^CS2#O3|3*)pPtu}|?$!%}k+72fD7XYVXN14KtXWCk)N|Yr6Pom94s^yrTx zkE4~k@@yy0b5|nY%?F$eWMS)d;jaC6vFnQq#Qwk<|D(p)IXKN$7uZOj*`%i$o-BEW z;I=NkM;6*+S-eNP`gH&=KX+zAA6vbpjb5l(u?H@m&6#$jS+{4u_vi~n%I#JYwCh7U zgMVtAl0XQ)?S&^Fsw>uyqB;|$RC-+nGH!#kwQZ%}5;~BSni!(p=xP~e(_toDM5{#+ zYkqilp~OTm#eb?i_h>2wOTu2jBd)-^yI;v6w^M=-VB3Tvb4(R;>|9v0Crt-g@$P;sEQ!3O2%MXS4SW01CQxsyNC z5K&T+T=0c8zNQoTmd{(AGf_#8R~Vgs{<kG4RKoRE2OA82VN`)#Ea&&4XCtd(eYEcnE-`A!CdkW6UrOpWMO_iZeUoDt zWfWEYvmCfLG6G_|jh9?bMbS|~14U&KUa1RK{J10Fo0_38`K7Si^J|zI49Ll%0K*@{ zM+=zR77`hoX3iGmuPvNm$@1+>V?>m95~D-G=3TV-Xb=#<4PA>@#to;S!+at& z>o?am2lM$P3)UDOFR_1(i%JYANK;f4qX-5=kHA2ZN{XOEf4>;0iMu@t+Ot6sbm#9A z{;O-Rw)oZ+`rE@m>OjmLdDQL2v3Lx~==g7%#J`%i-zdx9+4${t_g7`ra-$DPt1dHu zKyXK4-%ClJcC4mMDk@?kA>SW@VZudqVlkk3NjqsU__Gpj0|fGMD|Cmb=+CyWZzLs8 zCt{vf>PTou2k)tzpO(m1QB)lIBxUzqyIG};Y6MeH|109YS=h}RQx=WGbZU&sh22o- z>!S6z4I05gsF~SGbfN>XJW}Nd43nb=-SP5meHRr1DLn@J#{E%DN&TEcvf;1vPNPFH zN%i`3$jrWl-C+MzU~nS|lthdh%`Gw?0}4>YZAcj#;+NsGWsl*TT&pk`5XoV!8wHC* z&r@HAbs8TMye*l8Ks2qu$FE zq6I#_849!djpF_P(;)W{%)z$2S_&|P9g4WFuIW{ch4(46Fc|XETYwq0ON?@Es)#B5 zohkZSLp@@}UTvC|cyk>JaytWsJ~$%rDNY)EefKVm0ieJCZeRa@1n>uw|DC1Z;u!v+ zlw@tOr|?m%?($L#7hvD9*bJRkQoPi&bJxp_-WwDzP5l1y_klP`tQMpHY zzqF);BdqVN=k>xpIT+0fFF(KPr1M{kCg9=i=bhd4-+c;#6%Yzt)=XEU?(DsUIhJuYg-ZOnM^B|@*fa78K}(wQK=zgx8! z)72#{<{SN53G90$R?Sbgm)O;{PRuuoxc4ifrmIU`%r~+|Y7L>GHCsv}qWtt-vyso) zY+cc(N*lfX!|cGmj&%AdNxQ9U!;bfC0{ec8G5VUbX< zb&ZqrTFz_(&U?e-B6dk?`vzy!2~JLf+zx2r_E)9GXzO=*(o+tx(LYpfUev&m@N(iY zDm0H;45r`t_Or6rYLD~^EbjljhwdRV%UQTI+C2sASGe>SuS%uu?03q#cs56gkMb$? zb4UekIDfHzR!np>?nFW1wm8iq<| zlYRWAe*8kdU|pxWZ<*)h&*ODbyHen%vSk?VXUF9!(k%z49eER7%i0npHdL-VOda@p zW#cOk!n}JbhSzO=rZw2R80hb|yk6dFwgb>Alf8Ktxb-6+b6MuRC z2|9}$JD(Bkc_nYp<@>*)Jjl(?GXJA8^4Gi0R zO=S%U5J>#fV>Ty#aZ9G#xAD$+tu3?Hp1+s@P~TM5_3i2+)Kp&6EwIjN8Xn~!23A*t zn5aBnYKpf5R8Z%R?obo=y63rMFH_;$=U zUITeg-T><%==2F-VFT*`VCKZVklZ`#OrBz13pPfCKe@ZkBpY~@vWqy;9|;73j$Z@2 zf9StIb_KygZ+-gy5AmU|DYRPW-yPbF`LixI_yIvjTGv^z)yQgZZm#tAhhZ332gi*% z_b{L`Njr5g_?i;V2na5=Kz)JW^(d?p2woGS5kNEb6+0k!G2=Z1nuL#T{Rh$RKNiYg zgvY-(_&2V_c01}W~%+Xg&2yAq-4++QJto7&3^3!tHq>8UlGlkmga={ z%;6dKbiK@kc6EavB?A1c1S=fUyGkR__p3qU~#zqkm(j zzIEskx56PHA_Y`_63Cy@Vya{63t0xl^DqqHIlpVW5hUpAaTL$#@iMpwgJCZJlD5TX zl3wY4?S`V6aZ2mC>k;~&rdqJSNVU|Jz~Hs4$!y(9>@y+xYs!?8A>%jG88ggvi*dsn z!hapYcw#7~wPdqLvy2fCiUT4c(W+WVSR~%#SAv?Yn^!Z^|1jJ5B@O?5(!cwezi~qI zFEEW=49Sr2UkRj)4)F_<>W2udmw?j% zsd^~mY*o0bw{DF=AduHH-(xImt-_eo!`wuP3J*9DI6&G{qXS)(Als;}2$^p$0%vWP z5NGAz!#CA*qQO9+(hTZ|L{ICj0Dcb?2iz1+j&fJe!x-nCWAX;RsDk1H0CI71UHR!mjFiboqMN5`UQ!lVo*#~;^9Jn&L(L-kriGjgGZ!sCCh*OVBdfD2E4#t-0S#Y zkUo6j@%2P-s?A~%PqRfi^vBl*E}q8@8|O6O))Et~Oj(b}2+q!eN5P%}o+{G)-~Vx( zC~-uXv6Ti=sCH@}>dzbc!Qv9()pji=gM$lNpr9XiB2j9RWI zqAurK^Shf849n4{+q$!GoE3MkrG&lCrqowQptySS5Fu}%bWQAam%|YP@)82*o zO~uc%s0)sn<+hGU$H1n5?0z3s8gXO%(P&Ln$xEgUkRAm_O^l$bsRqJyD~$x7$dFgl zXX&h7?!duD6FN6PW`d?Q@Ez6KWl_ud2Xg6cRlHV^G^uylZHahL&w6h(`Ow37Bi==R|s%0X{!| zJx&~rpL!Q2xR5Wr)F%40CI8hiSK>xe-^z9OlCh8wmV#$UG~RDFR7T~jany@sLUKx$ zI_Y*oX{7#x)k#pQsunTt$kko5T-1A(vCw|%T${b)!>t|h0krQLx7a+eaCKVL#@Xrt zOTj2QySRP=WqkD(Lv3Zyb=ckc&uE4vy3SrMU*0#!aB-KopMCl2Q^vE25uf7b-mrAy z#(Y4f-WRPf7+LL#=o^BPgZI!yTLTQO&JQX)opvjFn@D%)rW^)7CbG5rkG#|{b)HaI zsFes(1OHf>TOo0lw#2Ltm~BK7i_=bhyR9uXY9d4Tg)!%Wh}2Inrrus`lW)ZpglYkA+Un@KpbWE8t;CNl9B) z(iEfi%V+v=pP1G28DY<4Ds$DXqAe@u!&zev_%YY?nybxCy2AM~_H(AZhbl6ZW1!VA z@fGeJOD{m;|TAIj7u3ORY@ziPU)w>$_#8t+#aF?>=;c-5NX>b6E85VLfQ6t}+fi zH-grTiZ&)#d~g|^NHn>)MH$zsn~O3ZC)XzkhNwAFii+}Cm=764`LCM2!1svKevGcx z)s3TuqM|J+8SeiESJS9A+zYgojpSs$E7$RDSXYWQsupUm*kpv4f zolWwOfX2<3lka2a`;`ZE5C+gjQjSkMJR?(P%B!T}Ii4OB;4|?!Uh+5JhW^!Csej+? d->6W;Bt!e~Cn>r7)sIJyA9XnL^3bI_{{)Gbllu!@|{F4eCta<*V?KuPjb@6aLybmlwAhr-l zAjH-dVhdggkiZ(SY%Bi-+6IC|umx)f%%hEMfgqnPNMKz}Ab}ZJ0}?>6g%AR52{i;l z4U+&CnLv^JS65U-Dypk1sspdIA`(cfnm|ZRpluBSB#@U`!vtyo0OSLi0;SY}^tqZuBhgqSu#&|hvA`=pt1F_B>S!bqjaEmKH?nA~IT~0$2QUe? zOhO>D1|$NL2`~YGMJi&E>R2?8NGux23yPUz&4C240N_(n#2l?|jz*eefkc~|0|{&d z<^TYw2?WIf%o+d`#3BK6G+>SefNk>W%LN0Ux%Oehl0aRmhC6vjLLjFhDrf~cHz@rOcQIinyd zUui;iD=6SKp-{x$-&-UMDviz!7GYxIb3OT@K?|HHt+JOW9VG?jB?3YIWr?v{DLCP< zClVN2U2xy8pcWvlZXT)VKP%RjwRhh9w$^5;hWIT$l4FhlxX7c=a5W|ENai)GZVP>7L0|MTzrlMKVi%%Rhd5~rzqe^xBQYv$h{0G3u8GC^9YVQ>| zwc&eDb@JO;7%X|(9FfLUJk0yHWF*?UA=2Ep+FyWdyk2gV?q!W=3W*xSFJEDbK#@)0 zX1?xWfG=B-C;G7ZuJIe?DLudM+wdhTkV{rd;g@`s0_uOlE~1g!me$_E-*-gebLb~g zfg$|XX&f`BroxKohn*+oW~lE1e7?KO0Be z7eCvA2+5Sj#%!%j#YuvI#tVxXA?6z71ySwtE2C+>Q?Y`<&h?LxO9J9^dL(C|cqv-K zUtktBQT2GuIKJ7qXPkh83?}{}9NsG&5tlae1q#1Zx8q$gZ|JYt#+?~@m)lN@?AcKIgyCLqsP z3hbsbiC+CDt(dcym23su7{T1f*In)#UR*C{w&nuEFNeDop>g3e9M!`i7-+Cw>oNMB&Y2O!8S4x+|9Ncc7MgPATSb5-myL3o)+Kbbw=Ih50`V6Qz z)r#+wPc$|pIwf7Wu;P9Pbqo%U(yv1P`0Ison9mCGTNSv)+O^ouOUdm}w!2s2LI$it z{Ndy4%K=UJ^T)sE>UJ+Zy9r`yI8{q?ZH}*EK$3FF^pDD&gO#%A)XZ>`8V|`t81PY; z8XbQXf8IVqOU+5L>Ej6$LrvG-Mfwq6()Z{#zKgrRWB^|0iZb+%O8K!%L!s^*s%%k- zkJ4{gM()S-SKDDYQa2^P9aVF0$xB`pSX7_xOC9UpIQLWo0hb!xKn-y4J@g}}qiJUw8jh>< zUJ+*kV>7QW?_|QM64pywTfmv;=9#EInv>cb=YwLHP8k#F3l2USQ$u2d_@D<$nQ<$V zd{AXP1F;9HKIKt-d0YLj>7PJ!@&N zD33Z>S(F4FZcV;o*=*poY=1_>Gc@D!T9a6vFs@x7nzs}i`CV9&4wpgOP}q9L?^S~_ z!ZTin+cG>pozP57M3+o7on9@M&|={=WW~O@e?vVIe!cT1tRiN*eSS81rnU5Co=JaK zKTfJAWAdtV*F(K^-KY+-Z=(<+uR-J0M@;x;(mmZMK~tBK7m5cG1_BTCbPFFdVh|&f z;CjF4x|Ga>MLdD4S^=*Zeu;xOY>_8rS0*+(EpoJR086=3$CEfYH`oA&+HmC-oQ*Fb zt`trU`QD5vjcK@0vs*Ua*`b}9cfs>$$4B%8ck7FROypA3JZFjT-Fdl20y?(2sat{D z&r5u=N^-lG?wJm)3lJaSL?kq0kGC(mIn-mWO}+{JWb@(SW@Ag!ghHh~?ZUF2I%pO# ze}*>vIw0=X3HpV_MoH?~g52iv*I^CcTA7~4CgiQKLua@xQ7<1#V5unYwBNCd2K01zY=24`Fb~J2USF6;FsU;HflO_2ea=e$;U4Aq0eQ1 z4d1+nQ|}ydnj+|zEv$nUF(xYHmh~I`b|D5g2jY&YN*PCV>aWwX!?Q|h#Amdrgg0`0 zSwY#vERielZOPbWVPumKkfD1io}L}2vYVuN4OZ2kEc+>U(zHwSIvCOP_a}X@58t)W zcMyRBe*yZF@dSOfIQ(L1JY_w_ecd87e%6b7qf@t}_3dnDNE8-jh-1VS^Y<$U#Pv@u z2r9-iXVFrt=X%Z8kvp<0tc&bk%(i~?-QQQn6)?35``kgVqjHp6>%2o2HD+PCFl@!c zNlRpQGN+YZRqt6EXUndm^G$2n2)jli(t zd6{y^0@fVp%Ug=?d_Un^AmE|=ojaR956KHeh?(p1qn?oZWQaq_a&Xb9a^p=`2E#5ED&&!B+PAE@!^?(sq$uCI6g7zoZ zJa6e!%#z=YK;p~r+O!ii^FQ@tL^f6rLA{T6ZbXs~f9|mEJJeD2?nQ6*_DZ(|Ub{w& zbh(oQ800-Ww;Y<4C}|J|k-mDjw2new(BtA>NTkQQ<-@Gohk_KQ;USuv5RhaQ6^K3z zhWhDm7Rl}~Dp|9o^&bgw|4=;qcbUnfv2XoMTu=}*a4u!RXu8)*P5k{o9Cn|A+BEg< zXyo}}CM%iijk@1}5&OAA-l*ISswyqkt8gk)9X&T{@8so}moLw~iif;=8ijf@^HXD= zgg5j$sB`C6ns~;~>g4wEF~?4dJD113$@?P08bJxQ3M)wzQ-ywE_p+x}gPfDA)X7a5 zc8I~qPo2sYYtU8PiPuogqn3ye49d{RZDC&8;TdK*xY-*9^C+r-dMAN~Cu*wJKCP;P zioT{4z}e!p-zendXGtr_>G{=grCRAFJmhe}S(L82p5@mF$Yu|7#8k?P+@avSLqg3p zD87r*D4oM^S7I7bta8`OyZ*eKJbnm)zIo3l%@FM`47>)RZPy{l;72$~X(+c8N|2Mi?wVYhZ?C#pn z<+~?}$LU+khy0ORP-vlBE8gCQvD|5W#`>_*oXTOKK&GV*ldZk|= zdIB|LQC^zI8$BC?8J)(G*B1wY9 zO8;949EY^@YSJ?Wg$K4{u!>mqCQJ~E=f0j`U$@XC2wXuKmSbsqxemkn2ng%IE<}^pa(iX!mnr^&k6pc{ zC3cmX6DBNQPmOd5a{c?d1Oz92B1k{3)UNy1CrJJQo;Be!M!6vJyxl_MO?TiAe7(4V z-2PPfrhy~9CHS*^=#T*lNEaNWKqkrGTn+#5tCHUd9@6}w0z(+3C`jPT#K?CYKA4uJm^1^v-%s03+_5Bu6g$jPp%LhAJdQ($8Ms1-YY?PH!K_-h|R|^ z(l8Z7_+$epe<{Ry0>5c0@XDjRJ%iZ0bEQ2dr+~?3VD(B8Bi}_^V5PG zwSjuP?2GXQ4i}|gVCH{?rUCj5(Gt4m1f z?o6vkyWblhlcbjqov$wh)%wImdGs+GIrY4-+n}#GTzDR( zYuR32A0JT_Z}3pQ;|8GIhX<(|;6VPZ`1?b_q0P0}*Go`ijg!#B<;PL(+|nbbs19+> z)-FkLhTwjl9RZDdK~G~}MAYiK;xv+vjeGMbMi+=?pEg+l!h(2l(*ycw0-&x0>h@o*AL?_p6;=rU)bf3L>Z2$Vis7$Sx$ zDtv7q#kwIM;2~EY50|r*S7|;V@FW&eJPfw#HkSBQ&jW?u{cj=v*2yms_JzD^Mp{W^ zG!?WTkJV6T1G$xCR3v?G`hVu;_UoW_7k}g3=kt2@gP?f436b@FSAHgl9A_7cR}_Ix z6No0KgD^8}4dv4l5FEEx66PwuXyEqG`0II`o$(-u2#*y4mi{EeU<-m3B)RSfg3Vwn zR0qin;>i{0tV&*_|0WtG7u~=rqI#YpDi|0+b%@gqM$%*wNu;(3VFPk*@pnj{*3#9} zLw)z9eIPq%8y{py@z8{JIHO*f@;_!dJ3PcsC*xP?BUqX7b6t;fJy0>bQP(sHbNicO z0}rCVM%d{iwk%p8R3H1C=NyBn!skpC<3+AIM(c50@3 zXGUTh{8I|v;ODr?Wln~4qpo2MsPos-z#M0X0aw9bBt%Q@A6Bj;Z20Y24G=cJ>B|Wf z@$65E>CxxyL9KK`o|Nn0$!C!SY@1w@?jngkIGwz2KnuEkSjNAH+x?q<#{A1gMpd6B zD6b}rCsy=T%s2KUX*76sNBKOr=g9} zt-94n)|nJAtXPbW6B>dPoI$YBaD&w&Z<=`oUn#e%pr;{uD~ zn2U-?Ey8o$&>%Kdg2?biLhGgzGko)MC`O2fl!P)J!b?$@P3BM2Dfq5{T#jaF8;i9k zcKLRG_#yCFgqnBo(?`bX>LZ5sKj97Z!Zso7o?YPk&)djD^3iK%lo%DO5q$*%Num~% zeyOyW_`dkrd|2L9{Pm$$-sZVvSOwh26IaJV&70(1j;k&IHQzX3xGW`HZ$GLmY--Xp z)*zlS7WoadBSFjL$#5y`HmXP1R&O)w=e53|`%OSCv;(&`6001pH9oWpc6)a#hLsdy zp1|fVUGWr-YxtGk@3TwasB9oQq@b)1xZO>Vs5mXFUfM;lL?lR)5DubRbi636ZGh>B zI%xfP*y(*bPVzVtFm!EBQh%UF4{PfuiKkg?c zQH7fUw^$FTz7_~L-e+503nKKNyv^8S`!nf_qfp5Q{l^#M{y*j?|8*bdh>h-H@iC5L zU!AQynkl@7H@N-pz~>*1lIrwmFz9sY ztoOHLD-R%{P^BmGDD!{$Zp&bKJ9kw^WM7k(<_Qn#lWhn)14IjAe@3c`$~R7^7vQQ`T<;o;J(Jt)e4J+{EXtPoi{J^G6 zmOlOpW0YQiIeO|Mwb3jVJgS9<*Obcsr_<+$59fWPl+fYW5W#muodOI)t6!cDRey7( zn5g%kS)|COO`wcelVj3Bhg(H2!Bp?lsysE7me#tneB^mQ?7O50s=4WKULrrRcORI5 zSEnf!1AlS;Y#Fh^@$)v6Zcw7;3=n5WqfnV=3oV=J4Vgt3iWktgKm zR%Xdw$*Ab#*LWJ4|0B#S&Q`inzgCwcavA&cRxoD;Z?XC7 zsi`7!gdTCo+)B1|fL;6?sfSJ@C-Sl2tv@A{7%``PqgNg(U6kDLmf?OdJ(b$0Ll77r z3Y`%d*S?OcO+w#&=-;0~5{H#_~X4*eyqM17yC*I+WSer~W*Z$7j@ z$`wA&S`iz><+^xN*-eI1D`G!KQ#=84q1@u@ZF3wen`Cf|z|^BUgoK6K)L{v?blaIZ z>|zj-G%giQu&3M@itl8ZY{B|c_@dF`shYDH&|rs#9CPp;Ky6ym08?msbnC?9;83aI z6fFL|y5KFx>R`$&Iy{u(Q#FpCmTK#*$y_83rDx+V#=s4IQ9{3W<>Nby_?-Uq#k>y# zxxo5TYXs58C4pN(ldk>waG&BkY3PKJV=&w-gD;rskfFo5K2;3-K*+uIz*Anv`^tyI z;=9fu+l8De3bp%8lQjM|pfv!jDYZZpgvmPd=~D(P?K)&;Z%fpiP!&!x^sM6fo?~z` z{>2&6GxwV-iAqV}Tvrkd=D}`~HKkh-obn#uo7o)M*lWDTPT6c_yjGwuDi_|NKZa~w zAsKvhMA?9;5!(bs54(xTe&@TjItwfU~` zu`}SC8H-xoGtH@4oQ@o0s>uU3x|}_%w*4<~z{fNtiIXw!U0N#(@3Q)MfUU%|I@MPyrbZ_n@@ zW#@d4DkR_ujG#lA;@4mvJw8m($_DJu`8B-Sr;FwYHYq0Cs;Xoq3FuGMs23JGMo%ux z=g;ob)$^}MWHviNAG*VKpUO*$5&gic5vAu>YM}4+yWhN*9p+|;9=1Ps57~gLOSRwC zocLXzX+-=1H_U;Bv;y=^`}+>$E&7KYQRJygN|^@%{7kC2GSn4mea?i~l9pEPLAZgh z(vD``pl@ABO>#pO-oX>dL76)jo2Jr?a?HCsg+@S#*i~5SnBGe~7usmCm_*8qC`z>t zc}3rc<&RH40$(6>nZ$^}k1HO5Q`}^yO7_HANP>aK#;@81iU&1n8$HfxLxWA{{Um$I z-ga+f=VRs;qEu9(S8C4Jf868M+5c|no-5ppIRow!3A*T;CJSBS)p~8m>c}QqMnU>E zlF>j+_)mBbBdC747fSZB7{H1}9ZNH)untU`RnF!$1kt`4jBWkIiKn>PiQXv$;;;+K zX~*KWk}NOOqw=<6q9|D_shncMr#ZrQmntN8og!W8ih|PTM@5#;St!GFegY!M9T>!n zlM2=3^E#-u;p)&icm#iNqxH(9&@mgr%c~j%m_!Bn5_O$dbrMnw)2BA%V(U^H`z@w2 zX8g$0z~}YrIx>9vxaDL=~oj*3yUX8djSc*Tp)MzegFO3n=%9^|7WUm8nfV%{PVJ+5+8$ o@VNigkl>#QC;nSsGN2qCH@9qGT4%ici(Th^?t9C2pZMWF02LrEf&c&j diff --git a/vignettes/articles/modelsummary_integration.Rmd b/vignettes/articles/modelsummary_integration.Rmd index 0d0bb65..4b7712b 100644 --- a/vignettes/articles/modelsummary_integration.Rmd +++ b/vignettes/articles/modelsummary_integration.Rmd @@ -19,7 +19,7 @@ This article demonstrates how to extract model statistics easily and create prof ```r library(ddml) # Also load modelsummary if it is installed -if (require("modelsummary", quietly = TRUE)) { +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { library(modelsummary) } set.seed(351789) @@ -83,8 +83,9 @@ tidy(ols_fit) # 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 D_r -0.1851801 0.03224716 -5.742526 9.327476e-09 nnls +#> 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. @@ -93,10 +94,12 @@ If you computed multiple ensembles simultaneously, you can specify ``ensemble_id ```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 conf.low -#> 1 D_r -0.1857013 0.03220572 -5.766097 8.112844e-09 singlebest -0.2488233 -#> conf.high -#> 1 -0.1225792 +#> 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 @@ -108,6 +111,8 @@ To grab a single-row summary of the estimator statistics (number of observations 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`` @@ -123,14 +128,12 @@ model_list <- list( ) # Render a simple comparison table if modelsummary is available -if (require("modelsummary", quietly = TRUE)) { +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") } -#> Error: Package `tinytable` required for this function to work. -#> Please install it by running `install.packages("tinytable")`. ``` Notice how ``modelsummary`` automatically pulled the custom goodness-of-fit metrics from ``glance.ddml()`` (e.g., ``sample_folds``, ``shortstack``, ``ensemble_type``). @@ -143,7 +146,7 @@ If you wish to show the results for the *other* ensemble type (``singlebest``) i df_nnls <- tidy(ddml_fit, ensemble_idx = 1) df_singlebest <- tidy(ddml_fit, ensemble_idx = 2) -if (require("modelsummary", quietly = TRUE)) { +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { msummary( list("DDML (NNLS)" = df_nnls, "DDML (Single Best)" = df_singlebest), title = "Comparison of Stacking Approaches", @@ -151,23 +154,6 @@ if (require("modelsummary", quietly = TRUE)) { gof_map = NA # We omit model statistics since we passed data.frames directly ) } -#> Objects of class `NULL` are currently not supported. -#> Error: `modelsummary could not extract the required information from a model of -#> class "data.frame". The package tried a sequence of 2 helper functions -#> to extract estimates: -#> -#> parameters::parameters(model) -#> broom::tidy(model) -#> -#> To draw a table, one of these commands must return a `data.frame` with a -#> column named "term". The `modelsummary` website explains how to -#> summarize unsupported models or add support for new models yourself: -#> https://modelsummary.com/vignettes/modelsummary.html -#> -#> These errors messages were generated during extraction: -#> -#> `parameters::parameters(model)` did not return a valid data.frame. -#> `broom::tidy(model)` did not return a valid data.frame. ``` # Tidy Support for Repeated Resampling @@ -187,18 +173,21 @@ repl_fit <- ddml_replicate( sample_folds = 5, silent = TRUE ) -#> Error in ddml_replicate(ddml_plm, y = y, D = D, X = X, learners = list(list(what = ols)), : could not find function "ddml_replicate" # Extract aggregated coefficients tidy(repl_fit) -#> Error in eval(expr, envir, enclos): object 'repl_fit' not found +#> term estimate std.error statistic p.value ensemble_type +#> 1 D1 -0.185302213 0.03208110 -5.77605637 7.647176e-09 nnls +#> 2 (Intercept) -0.000510678 0.01526034 -0.03346438 9.733043e-01 nnls +#> aggregation +#> 1 median +#> 2 median # Combine standard fit and averaged fit in a table -if (require("modelsummary", quietly = TRUE)) { +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { msummary(list("Single Split" = ddml_fit, "Repeated 3x" = repl_fit), stars = TRUE) } -#> Error in eval(expr, envir, enclos): object 'repl_fit' not found ``` # Diagnostics Integration @@ -213,11 +202,11 @@ diag_fit <- diagnostics(ddml_fit) # Tidy output generates a data.frame head(tidy(diag_fit), 5) -#> equation learner mspe r2 weight -#> 1 y_X learner_1 0.2412722 0.02764647 0.4186534 -#> 2 y_X learner_2 0.2413187 0.02745888 0.5734605 -#> 3 D1_X learner_1 0.2206338 0.05336647 0.7208025 -#> 4 D1_X learner_2 0.2206689 0.05321582 0.2715648 +#> 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. diff --git a/vignettes/articles/modelsummary_integration.Rmd.txt b/vignettes/articles/modelsummary_integration.Rmd.txt index 550d97b..d3908b8 100644 --- a/vignettes/articles/modelsummary_integration.Rmd.txt +++ b/vignettes/articles/modelsummary_integration.Rmd.txt @@ -26,7 +26,7 @@ This article demonstrates how to extract model statistics easily and create prof ```{r setup} library(ddml) # Also load modelsummary if it is installed -if (require("modelsummary", quietly = TRUE)) { +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { library(modelsummary) } set.seed(351789) @@ -106,7 +106,7 @@ model_list <- list( ) # Render a simple comparison table if modelsummary is available -if (require("modelsummary", quietly = TRUE)) { +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { msummary(model_list, stars = TRUE, coef_rename = c("D" = "Treatment (D)"), @@ -123,7 +123,7 @@ If you wish to show the results for the *other* ensemble type (``singlebest``) i df_nnls <- tidy(ddml_fit, ensemble_idx = 1) df_singlebest <- tidy(ddml_fit, ensemble_idx = 2) -if (require("modelsummary", quietly = TRUE)) { +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { msummary( list("DDML (NNLS)" = df_nnls, "DDML (Single Best)" = df_singlebest), title = "Comparison of Stacking Approaches", @@ -154,7 +154,7 @@ repl_fit <- ddml_replicate( tidy(repl_fit) # Combine standard fit and averaged fit in a table -if (require("modelsummary", quietly = TRUE)) { +if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinytable", quietly = TRUE)) { msummary(list("Single Split" = ddml_fit, "Repeated 3x" = repl_fit), stars = TRUE) } diff --git a/vignettes/articles/new_ml_wrapper.Rmd b/vignettes/articles/new_ml_wrapper.Rmd index b8d8a49..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,11 +97,6 @@ late_fit <- ddml_late(y, D, Z, X, sample_folds = 10, silent = TRUE) summary(late_fit) -#> DDML estimation: Local Average Treatment Effect -#> Obs: 5000 Folds: 10 -#> -#> Estimate Std. Error t value Pr(>|t|) -#> LATE -0.237 0.190 -1.25 0.21 ``` All works well! @@ -228,7 +221,6 @@ callbacks_list <- list(callback_early_stopping(monitor = "val_loss", factor = 1/10, patience = 10, verbose = FALSE)) -#> Error in FUN(X[[i]], ...): 'CreateProcess' failed to run 'C:\Program Files\WindowsApps\PythonSoftwareFoundation.Python.3.11_3.11.2544.0_x64__qbz5n2kfra8p0\python.exe -c "import sys; print(sys.platform)"' # Use the neural network base learner learner_keras = list(what = mdl_keras, @@ -237,20 +229,13 @@ learner_keras = list(what = mdl_keras, verbose = FALSE, validation_split = 0.1, callbacks = callbacks_list)) -#> Error in eval(expr, envir, enclos): object 'callbacks_list' not found # Estimate ddml_late late_fit <- ddml_late(y, D, Z, X, learners = learner_keras, sample_folds = 10, silent = TRUE) -#> Error in eval(expr, envir, enclos): object 'learner_keras' not found summary(late_fit) -#> DDML estimation: Local Average Treatment Effect -#> Obs: 5000 Folds: 10 -#> -#> Estimate Std. Error t value Pr(>|t|) -#> LATE -0.237 0.190 -1.25 0.21 ``` All works well! diff --git a/vignettes/articles/new_ml_wrapper.Rmd.txt b/vignettes/articles/new_ml_wrapper.Rmd.txt index 740de6b..68eb285 100644 --- a/vignettes/articles/new_ml_wrapper.Rmd.txt +++ b/vignettes/articles/new_ml_wrapper.Rmd.txt @@ -12,7 +12,7 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, comment = "#>", - eval = requireNamespace("keras"), + eval = requireNamespace("keras", quietly = TRUE) && keras::is_keras_available(), warning = FALSE, message = FALSE ) diff --git a/vignettes/articles/repeated_resampling.Rmd b/vignettes/articles/repeated_resampling.Rmd index d0fbfd7..1b3e7fd 100644 --- a/vignettes/articles/repeated_resampling.Rmd +++ b/vignettes/articles/repeated_resampling.Rmd @@ -61,8 +61,9 @@ summary(fit_single) #> DDML estimation: Partially Linear Model #> Obs: 1000 Folds: 5 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> D_r -0.120 0.033 -3.62 0.00029 *** +#> 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 ``` @@ -83,11 +84,10 @@ fit_rep <- ddml_replicate( resamples = 5, silent = TRUE ) -#> Error in ddml_replicate(ddml_plm, y = y, D = D, X = X, learners = learners, : could not find function "ddml_replicate" # Observe the class of the returned object class(fit_rep) -#> Error in eval(expr, envir, enclos): object 'fit_rep' not found +#> [1] "ddml_rep" ``` # Interacting with ``ddml_rep`` Objects @@ -100,19 +100,33 @@ When summary statistics or coefficients are requested, ``ddml_rep`` automaticall ```r # Print the object details fit_rep -#> Error in eval(expr, envir, enclos): object 'fit_rep' not found +#> 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) -#> Error in h(simpleError(msg, call)): error in evaluating the argument 'object' in selecting a method for function 'summary': object 'fit_rep' not found +#> 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) -#> Error in eval(expr, envir, enclos): object 'fit_rep' not found +#> D1 (Intercept) +#> -0.114085768 0.003836949 # Extract confidence intervals (with HC3 standard errors passed to the VCoV estimator) confint(fit_rep, type = "HC3") -#> Error in eval(expr, envir, enclos): object 'fit_rep' not found +#> 2.5 % 97.5 % +#> D1 -0.17920978 -0.04896176 +#> (Intercept) -0.02645093 0.03412483 ``` You can alternatively switch to **mean** aggregation (Ahrens et al., 2024), which computes the empirical mean across split estimates: @@ -120,24 +134,30 @@ You can alternatively switch to **mean** aggregation (Ahrens et al., 2024), whic ```r summary(fit_rep, aggregation = "mean") -#> Error in h(simpleError(msg, call)): error in evaluating the argument 'object' in selecting a method for function 'summary': object 'fit_rep' not found +#> 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 arrays of the ``ddml_rep`` object: +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 'nnls' ensemble across the 5 independent splits -split_estimates <- fit_rep$coef_array[1, "nnls", ] -#> Error in eval(expr, envir, enclos): object 'fit_rep' not found +# 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) -#> Error in h(simpleError(msg, call)): error in evaluating the argument 'x' in selecting a method for function 'print': object 'split_estimates' not found +#> [1] -0.1117597 -0.1187530 -0.1133071 -0.1197519 -0.1140858 # Variance of the point estimates across splits var(split_estimates) -#> Error in eval(expr, envir, enclos): object 'split_estimates' not found +#> [1] 1.23637e-05 ``` ## Multiple Treatment Variables and Joint Variance @@ -158,11 +178,13 @@ fit_rep_multi <- ddml_replicate( resamples = 5, silent = TRUE ) -#> Error in ddml_replicate(ddml_plm, y = y, D = AE98[sub_idx, c("morekids", : could not find function "ddml_replicate" # Extract the full aggregated Variance-Covariance matrix vcov(fit_rep_multi) -#> Error in eval(expr, envir, enclos): object 'fit_rep_multi' not found +#> 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 @@ -173,13 +195,23 @@ Because a ``ddml_rep`` object is essentially a structured list of pure ``ddml`` ```r # Extract the 3rd replicate fit run_3 <- fit_rep[[3]] -#> Error in eval(expr, envir, enclos): object 'fit_rep' not found class(run_3) -#> Error in eval(expr, envir, enclos): object 'run_3' not found +#> [1] "ddml_plm" "ddml" # View its specific diagnostics diagnostics(run_3) -#> Error in eval(expr, envir, enclos): object 'run_3' not found +#> 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 @@ -205,13 +237,19 @@ fits_list <- lapply(1:3, function(r) { # 2. Combine them into a ddml_rep object manual_rep <- ddml_rep(fits_list) -#> Error in ddml_rep(fits_list): could not find function "ddml_rep" class(manual_rep) -#> Error in eval(expr, envir, enclos): object 'manual_rep' not found +#> [1] "ddml_rep" # 3. Aggregate results summary(manual_rep) -#> Error in h(simpleError(msg, call)): error in evaluating the argument 'object' in selecting a method for function 'summary': object 'manual_rep' not found +#> 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. diff --git a/vignettes/articles/repeated_resampling.Rmd.txt b/vignettes/articles/repeated_resampling.Rmd.txt index d9933e8..1414a2d 100644 --- a/vignettes/articles/repeated_resampling.Rmd.txt +++ b/vignettes/articles/repeated_resampling.Rmd.txt @@ -113,11 +113,11 @@ 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 arrays of the ``ddml_rep`` object: +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 'nnls' ensemble across the 5 independent splits -split_estimates <- fit_rep$coef_array[1, "nnls", ] +# 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 diff --git a/vignettes/articles/sparse.Rmd b/vignettes/articles/sparse.Rmd index c5e7da1..607e1e1 100644 --- a/vignettes/articles/sparse.Rmd +++ b/vignettes/articles/sparse.Rmd @@ -85,8 +85,9 @@ 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|) -#> D_r 0.1121 0.0215 5.23 1.7e-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 ``` @@ -114,10 +115,9 @@ 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|) -#> D_r 0.1112 0.0579 1.92 0.055 . -#> --- -#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +#> 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. @@ -155,18 +155,35 @@ summary(stacking_fit) #> DDML estimation: Flexible Partially Linear IV Model #> Obs: 329509 Folds: 2 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> D_r 0.1148 0.0209 5.49 4e-08 *** +#> 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$ensemble_weights$D1_XZ, 4) -#> Error in round(stacking_fit$ensemble_weights$D1_XZ, 4): non-numeric argument to mathematical function +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 ba9892c..7c08aec 100644 --- a/vignettes/articles/sparse.Rmd.txt +++ b/vignettes/articles/sparse.Rmd.txt @@ -140,10 +140,10 @@ stacking_fit <- ddml_fpliv(y = AK91$LWKLYWGE, D = AK91$EDUC, 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$ensemble_weights$D1_XZ, 4) +diagnostics(stacking_fit) ``` # References diff --git a/vignettes/articles/stacking.Rmd b/vignettes/articles/stacking.Rmd index 67a91f5..ecd52f2 100644 --- a/vignettes/articles/stacking.Rmd +++ b/vignettes/articles/stacking.Rmd @@ -82,11 +82,11 @@ Both stacking and short-stacking construct weighted averages of the considered b ```r cat("Time single learner:", time_singlelearner[1], "\n") -#> Time single learner: 1.75 +#> Time single learner: 2.14 cat("Time short-stacking:", time_shortstacking[1], "\n") -#> Time short-stacking: 3.93 +#> Time short-stacking: 5 cat("Time stacking: ", time_stacking[1]) -#> Time stacking: 17.29 +#> Time stacking: 24.44 ``` # References diff --git a/vignettes/articles/stacking_diagnostics.Rmd b/vignettes/articles/stacking_diagnostics.Rmd index f3dccef..93b9552 100644 --- a/vignettes/articles/stacking_diagnostics.Rmd +++ b/vignettes/articles/stacking_diagnostics.Rmd @@ -72,39 +72,39 @@ print(diag) #> Obs: 5000 #> #> y_X_Z0: -#> learner mspe r2 weight -#> learner_1 0.2407 0.0322 0.0000 -#> learner_2 0.2407 0.0322 0.8975 -#> learner_3 0.2407 0.0322 0.0000 -#> learner_4 0.2407 0.0322 0.1025 +#> 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 -#> learner_1 0.2419 0.0316 0.0000 -#> learner_2 0.2419 0.0316 0.8775 -#> learner_3 0.2419 0.0316 0.0874 -#> learner_4 0.2419 0.0316 0.0351 +#> 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 -#> learner_1 0.209 0.0799 0.6868 -#> learner_2 0.209 0.0799 0.0000 -#> learner_3 0.209 0.0799 0.0693 -#> learner_4 0.209 0.0799 0.2439 +#> 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 -#> learner_1 0.2235 0.0813 0.7212 -#> learner_2 0.2235 0.0813 0.0000 -#> learner_3 0.2235 0.0813 0.1049 -#> learner_4 0.2235 0.0813 0.1739 +#> 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 -#> learner_1 0.2498 2e-04 0 -#> learner_2 0.2498 2e-04 1 -#> learner_3 0.2498 2e-04 0 -#> learner_4 0.2498 2e-04 0 +#> 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: @@ -118,13 +118,13 @@ For workflows integrated with the ``broom`` package, or when preparing publicati ```r head(tidy(diag)) -#> equation learner mspe r2 weight -#> 1 y_X_Z0 learner_1 0.2406740 0.03216873 4.946908e-17 -#> 2 y_X_Z0 learner_2 0.2406740 0.03216873 8.975098e-01 -#> 3 y_X_Z0 learner_3 0.2406740 0.03216873 0.000000e+00 -#> 4 y_X_Z0 learner_4 0.2406740 0.03216873 1.024902e-01 -#> 5 y_X_Z1 learner_1 0.2418787 0.03156255 0.000000e+00 -#> 6 y_X_Z1 learner_2 0.2418787 0.03156255 8.774719e-01 +#> 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) @@ -142,66 +142,46 @@ print(diag_cvc) #> Obs: 5000 #> #> y_X_Z0: -#> learner mspe r2 weight cvc_pval -#> learner_1 0.2407 0.0322 0.0000 0.610 -#> learner_2 0.2407 0.0322 0.8975 0.991 -#> learner_3 0.2407 0.0322 0.0000 0.002 -#> learner_4 0.2407 0.0322 0.1025 0.001 +#> 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 cvc_pval -#> learner_1 0.2419 0.0316 0.0000 0.238 -#> learner_2 0.2419 0.0316 0.8775 1.000 -#> learner_3 0.2419 0.0316 0.0874 0.002 -#> learner_4 0.2419 0.0316 0.0351 0.000 +#> 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 cvc_pval -#> learner_1 0.209 0.0799 0.6868 0.843 -#> learner_2 0.209 0.0799 0.0000 0.870 -#> learner_3 0.209 0.0799 0.0693 0.001 -#> learner_4 0.209 0.0799 0.2439 0.020 +#> 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 cvc_pval -#> learner_1 0.2235 0.0813 0.7212 0.916 -#> learner_2 0.2235 0.0813 0.0000 0.767 -#> learner_3 0.2235 0.0813 0.1049 0.000 -#> learner_4 0.2235 0.0813 0.1739 0.005 +#> 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 cvc_pval -#> learner_1 0.2498 2e-04 0 0.048 -#> learner_2 0.2498 2e-04 1 0.995 -#> learner_3 0.2498 2e-04 0 0.245 -#> learner_4 0.2498 2e-04 0 0.000 +#> 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). ``` -Two new columns are 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. -- **In Conf. Set:** Logical indicator of whether the learner belongs to the Model Confidence Set (the set of learners for which the null hypothesis of equal performance to the best learner cannot be rejected). - -Often, simple parametric models (like OLS) perform remarkably similarly to highly flexible machine learners (like XGBoost) after accounting for the variation across cross-fitting folds. The CVC tests provide a rigorous statistical foundation for model selection and ensemble justification. - -# Advanced Standalone CVC Usage - -The testing machinery underlying ``diagnostics`` is built on a suite of accessible internal functions. If you wish to directly compare exactly two learners, you can use ``cvc_pairwise()``. It returns the point estimate of the difference in MSPE, standard error, t-statistic, and p-value. - -Below, we extract the cross-fitted residuals for the $E[Y|Z=0, X]$ equation and compare the first two base learners (OLS and Lasso). - - -```r -# Extract the residuals for the first equation (E[Y|Z=0, X]) -resids <- late_fit$crossfit_resid[[1]] -fold_ids <- late_fit$subsamples_byZ[[1]] - -# Compare Learner 1 (OLS) vs Learner 2 (Lasso) -cvc_pairwise(resids, 1, 2, fold_ids) -#> Error in cvc_pairwise(resids, 1, 2, fold_ids): could not find function "cvc_pairwise" -``` +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 @@ -210,3 +190,5 @@ Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, Wiemann T (2026). 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 index 728ded0..d32041b 100644 --- a/vignettes/articles/stacking_diagnostics.Rmd.txt +++ b/vignettes/articles/stacking_diagnostics.Rmd.txt @@ -99,26 +99,8 @@ diag_cvc <- diagnostics(late_fit, cvc = TRUE, bootnum = 1000) print(diag_cvc) ``` -Two new columns are 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. -- **In Conf. Set:** Logical indicator of whether the learner belongs to the Model Confidence Set (the set of learners for which the null hypothesis of equal performance to the best learner cannot be rejected). - -Often, simple parametric models (like OLS) perform remarkably similarly to highly flexible machine learners (like XGBoost) after accounting for the variation across cross-fitting folds. The CVC tests provide a rigorous statistical foundation for model selection and ensemble justification. - -# Advanced Standalone CVC Usage - -The testing machinery underlying ``diagnostics`` is built on a suite of accessible internal functions. If you wish to directly compare exactly two learners, you can use ``cvc_pairwise()``. It returns the point estimate of the difference in MSPE, standard error, t-statistic, and p-value. - -Below, we extract the cross-fitted residuals for the $E[Y|Z=0, X]$ equation and compare the first two base learners (OLS and Lasso). - -```{r} -# Extract the residuals for the first equation (E[Y|Z=0, X]) -resids <- late_fit$cf_resid_bylearner[[1]] -fold_ids <- late_fit$subsamples_byZ[[1]] - -# Compare Learner 1 (OLS) vs Learner 2 (Lasso) -cvc_pairwise(resids, 1, 2, fold_ids) -``` +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 diff --git a/vignettes/ddml.Rmd b/vignettes/ddml.Rmd index 489e31e..ca4af42 100644 --- a/vignettes/ddml.Rmd +++ b/vignettes/ddml.Rmd @@ -63,7 +63,7 @@ summary(late_fit) #> DDML estimation: Local Average Treatment Effect #> Obs: 5000 Folds: 3 #> -#> Estimate Std. Error t value Pr(>|t|) +#> 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).) @@ -103,8 +103,8 @@ summary(late_fit) #> DDML estimation: Local Average Treatment Effect #> Obs: 5000 Folds: 3 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> LATE -0.223 0.187 -1.2 0.23 +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.235 0.189 -1.24 0.21 ``` # Inspecting Learner Performance @@ -117,34 +117,34 @@ diagnostics(late_fit) #> Obs: 5000 #> #> y_X_Z0: -#> learner mspe r2 weight -#> learner_1 0.2412 0.0299 0.9668 -#> learner_2 0.2412 0.0299 0.0000 -#> learner_3 0.2412 0.0299 0.0332 +#> 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 -#> learner_1 0.2424 0.0297 0.0000 -#> learner_2 0.2424 0.0297 0.8028 -#> learner_3 0.2424 0.0297 0.1972 +#> 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 -#> learner_1 0.2091 0.0791 0.9303 -#> learner_2 0.2091 0.0791 0.0000 -#> learner_3 0.2091 0.0791 0.0697 +#> 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 -#> learner_1 0.2234 0.0817 0.9557 -#> learner_2 0.2234 0.0817 0.0000 -#> learner_3 0.2234 0.0817 0.0443 +#> 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 -#> learner_1 0.2499 -1e-04 0.0000 -#> learner_2 0.2499 -1e-04 0.5509 -#> learner_3 0.2499 -1e-04 0.4491 +#> 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")``. @@ -174,20 +174,20 @@ summary(late_fit) #> Obs: 5000 Folds: 3 Stacking: short-stack #> #> Ensemble type: nnls -#> Estimate Std. Error t value Pr(>|t|) -#> LATE -0.231 0.187 -1.24 0.22 +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.231 0.189 -1.22 0.22 #> #> Ensemble type: singlebest -#> Estimate Std. Error t value Pr(>|t|) -#> LATE -0.229 0.187 -1.22 0.22 +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.227 0.188 -1.21 0.23 #> #> Ensemble type: ols -#> Estimate Std. Error t value Pr(>|t|) -#> LATE -0.231 0.187 -1.23 0.22 +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.231 0.189 -1.22 0.22 #> #> Ensemble type: average -#> Estimate Std. Error t value Pr(>|t|) -#> LATE -0.229 0.189 -1.21 0.23 +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.228 0.189 -1.21 0.23 ``` # Other Causal Models @@ -206,8 +206,9 @@ summary(plm_fit) #> DDML estimation: Partially Linear Model #> Obs: 5000 Folds: 3 Stacking: short-stack #> -#> Estimate Std. Error t value Pr(>|t|) -#> D_r -0.1467 0.0147 -9.97 <2e-16 *** +#> 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 ``` @@ -233,9 +234,15 @@ plm_rep <- ddml_replicate(ddml_plm, sample_folds = 3, resamples = 5, silent = TRUE) -#> Error in ddml_replicate(ddml_plm, y = y, D = D, X = X, learners = learners_multiple, : could not find function "ddml_replicate" summary(plm_rep) -#> Error in eval(expr, envir, enclos): object 'plm_rep' not found +#> 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")``. From 9f13c25353bc8a7f84b81ab6c00adb354f4c9556 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Tue, 10 Mar 2026 16:21:55 -0500 Subject: [PATCH 28/46] another cvxr fix --- R/ddml_rep.R | 5 +---- tests/testthat/test-ddml_rep.R | 2 ++ 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/R/ddml_rep.R b/R/ddml_rep.R index 192ae36..98ae4fc 100644 --- a/R/ddml_rep.R +++ b/R/ddml_rep.R @@ -52,10 +52,7 @@ spectral_median_psd <- function(matrices) { obj <- obj + CVXR::norm(V - matrices[[r]], "2") }#FOR - # Retrieve psolve from CVXR namespace to avoid S4 dispatch - # issues with CVXR::solve / CVXR::psolve across versions. - cvxr_solve <- utils::getFromNamespace("psolve", "CVXR") - result <- cvxr_solve(CVXR::Problem(CVXR::Minimize(obj))) + result <- CVXR::psolve(CVXR::Problem(CVXR::Minimize(obj))) if (result$status != "optimal") { warning("SDP solver returned status '", diff --git a/tests/testthat/test-ddml_rep.R b/tests/testthat/test-ddml_rep.R index f247a5c..12af5a4 100644 --- a/tests/testthat/test-ddml_rep.R +++ b/tests/testthat/test-ddml_rep.R @@ -343,6 +343,7 @@ test_that("mean aggregation formula is correct", { test_that("spectral aggregation works and equals median for p=1", { skip_if_not_installed("CVXR") + skip_on_ci() set.seed(42) nobs <- 500 @@ -373,6 +374,7 @@ test_that("spectral aggregation works and equals median for p=1", { test_that("spectral aggregation gives PSD matrix for p>1", { skip_if_not_installed("CVXR") + skip_on_ci() set.seed(42) nobs <- 500 From 0e74c439653d6d753cc45b4c202e2783baa4f8f3 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Tue, 10 Mar 2026 16:47:14 -0500 Subject: [PATCH 29/46] Update NEWS.md --- NEWS.md | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/NEWS.md b/NEWS.md index 6b03f27..f5ec62e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -7,7 +7,6 @@ * Adds `hatvalues()` method for generalized leverage diagnostics. * Adds `nobs()` method returning the number of observations. * Learner specifications now use `what` instead of `fun`. `fun` is accepted with a deprecation message. -* Sample split arguments consolidated into a single `splits` parameter. * Adds parallel computation via the `parallel` parameter and progress reporting via `pbapply`. * Adds stratified cross-fitting to `ddml_ate()`, `ddml_att()`, and `ddml_late()` via `stratify`. Enabled by default. * Adds `cluster_variable` for cluster-aware sample splitting. @@ -18,11 +17,14 @@ * Adds `mdl_bigGLM` sparse-matrix unpenalized regression wrapper. * `mdl_xgboost()` auto-detects binary factor outcomes. * Adds `ddml_rep()` and `ddml_replicate()` for repeated cross-fitting with median or mean aggregation. +* `predict.ensemble()` gains `type` argument (`"ensemble"` or `"bylearner"`). * Fixes `ddml_fpliv()` with custom weights. * Breaking changes: - - `crosspred()`, `crossval()`, `ensemble()`, `ensemble_weights()`, and `shortstacking()` no longer accept `Z`/`newZ` arguments. Users must pre-concatenate instruments with covariates (e.g., `cbind(X, Z)`). Estimator-level APIs are unchanged. - - `crosspred()` and `shortstacking()` no longer support `compute_insample_predictions`. The `insample_fitted` output components have been removed. - - `ddml_fpliv()` no longer accepts the `enforce_LIE` argument. + - 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 From 9bee8c38a5aa111c538fb6f81856da7ea0ab2076 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Thu, 19 Mar 2026 16:33:45 -0500 Subject: [PATCH 30/46] multiplier boot+ lin combinations --- R/ddml.R | 140 ++++++++++------- R/ddml_rep.R | 273 +++++++++++++++------------------ R/lincom.R | 420 +++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 624 insertions(+), 209 deletions(-) create mode 100644 R/lincom.R diff --git a/R/ddml.R b/R/ddml.R index a0f1375..a0a2565 100644 --- a/R/ddml.R +++ b/R/ddml.R @@ -376,20 +376,8 @@ ddml <- function(coefficients, scores, J, obj }#DDML -# == S3 Methods ============================================================= +# S3 methods ================================================================ -#' @rdname ddml -#' @param x An object of class \code{ddml}. -#' @param name Name of the element to extract. -#' @export -`$.ddml` <- function(x, name) { - if (name == "weights") { - message("Note: '$weights' is deprecated for ddml ", - "objects. Use '$ensemble_weights' instead.") - return(.subset2(x, "ensemble_weights")) - }#IF - .subset2(x, name) -}#`$.DDML` #' Extract Model Coefficients #' @@ -558,12 +546,7 @@ hatvalues.ddml <- function(model, ensemble_idx = 1, ...) { #' @export vcov.ddml <- function(object, ensemble_idx = 1, type = "HC1", ...) { - type <- validate_method_args(object, - ensemble_idx = ensemble_idx, type = type) - - h <- if (type == "HC3") { - stats::hatvalues(object, ensemble_idx = ensemble_idx) - }#IF + type <- validate_method_args(object, ensemble_idx = ensemble_idx, type = type) sc <- object$scores[, , ensemble_idx, drop = FALSE] dim(sc) <- dim(sc)[1:2] @@ -574,16 +557,12 @@ vcov.ddml <- function(object, ensemble_idx = 1, # Cluster aggregation: rowsum scores to cluster level clustered <- !is.null(object$cluster_variable) && length(unique(object$cluster_variable)) < nrow(sc) - if (clustered) { - sc <- rowsum(sc, object$cluster_variable) - }#IF + if (clustered) sc <- rowsum(sc, object$cluster_variable) n_eff <- nrow(sc) - if (type == "HC3") { - if (clustered) { - h <- as.vector(tapply(h, object$cluster_variable, sum)) - }#IF + h <- stats::hatvalues(object, ensemble_idx = ensemble_idx) + if (clustered) h <- as.vector(tapply(h, object$cluster_variable, sum)) sc <- sc / (1 - h) }#IF @@ -607,14 +586,25 @@ vcov.ddml <- function(object, ensemble_idx = 1, #' #' @param object An object of class \code{ddml}. #' @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. +#' 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. #' @inheritParams vcov.ddml +#' @param uniform Logical. If \code{TRUE}, computes +#' uniform confidence bands using the +#' multiplier bootstrap. The critical value replaces +#' the pointwise Gaussian quantile. Default +#' \code{FALSE}. +#' @param bootstraps Integer number of bootstrap draws for +#' the multiplier bootstrap. 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 uniform critical +#' value. #' #' @examples #' \donttest{ @@ -627,8 +617,15 @@ vcov.ddml <- function(object, ensemble_idx = 1, #' confint(plm_fit) #' confint(plm_fit, parm = "D1") #' confint(plm_fit, level = 0.90) +#' confint(plm_fit, uniform = TRUE) #' } -#' +#' +#' @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.ddml}} #' #' @family ddml inference @@ -637,9 +634,12 @@ vcov.ddml <- function(object, ensemble_idx = 1, #' @export confint.ddml <- function(object, parm, level = 0.95, ensemble_idx = 1, - type = "HC1", ...) { + type = "HC1", + uniform = FALSE, + bootstraps = 999L, ...) { cf <- object$coefficients[, ensemble_idx] cf_names <- object$coef_names + names(cf) <- cf_names if (missing(parm)) { parm <- cf_names @@ -655,15 +655,34 @@ confint.ddml <- function(object, parm, level = 0.95, cf <- cf[parm] - V <- vcov(object, ensemble_idx = ensemble_idx, - type = type) - se <- sqrt(diag(V))[parm] - - z <- stats::qnorm((1 + level) / 2) + V <- vcov(object, ensemble_idx = ensemble_idx, type = type) + se_all <- sqrt(diag(V)) + se <- se_all[parm] + + if (uniform) { + # Multiplier bootstrap + sc <- object$scores[, , ensemble_idx, drop = FALSE] + dim(sc) <- dim(sc)[1:2] + J_j <- object$J[, , ensemble_idx, drop = FALSE] + dim(J_j) <- dim(J_j)[1:2] + cl <- object$cluster_variable + if (!is.null(cl) && length(unique(cl)) < nrow(sc)) sc <- rowsum(sc, cl) + n_eff <- nrow(sc) + inf_func <- sc %*% t(csolve(J_j)) + 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) + bT <- apply(bres, 1, function(b) max(abs(b / sigma))) + 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.DDML @@ -723,25 +742,19 @@ summary.ddml <- function(object, type = "HC1", ...) { type <- match.arg(type, c("HC0", "HC1", "HC3")) single_learner <- is_single_learner(object$learners) - ens_type <- if (single_learner) { - "single base learner" - } else { + ens_type <- if (single_learner) "single base learner" else object$ensemble_type - }#IFELSE nensb <- length(ens_type) p <- nrow(object$coefficients) - inf <- array(0, dim = c(p, 4, nensb)) - for (j in seq_len(nensb)) { theta_j <- object$coefficients[, j] V <- stats::vcov(object, ensemble_idx = j, type = type) se <- sqrt(diag(V)) z_val <- theta_j / se - p_val <- 2 * stats::pnorm(abs(z_val), - lower.tail = FALSE) + p_val <- 2 * stats::pnorm(abs(z_val), lower.tail = FALSE) inf[, 1, j] <- theta_j inf[, 2, j] <- se @@ -840,6 +853,12 @@ generics::glance #' @param type Character string specifying the #' variance-covariance estimator. One of \code{"HC1"} #' (default), \code{"HC0"}, or \code{"HC3"}. +#' @param uniform Logical. If \code{TRUE}, computes uniform confidence intervals +#' using the multiplier bootstrap. Only used when +#' \code{conf.int = TRUE}. Default \code{FALSE}. +#' @param bootstraps Integer number of bootstrap draws for +#' the multiplier bootstrap. Only used when +#' \code{uniform = TRUE}. Default 999. #' @param ... Currently unused. #' #' @return A \code{data.frame} with columns \code{term}, @@ -848,6 +867,12 @@ generics::glance #' \code{conf.int = TRUE}, also \code{conf.low} and #' \code{conf.high}. #' +#' @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. +#' #' @examples #' \donttest{ #' y = AE98[, "worked"] @@ -864,7 +889,9 @@ generics::glance #' @method tidy ddml tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, conf.level = 0.95, - type = "HC1", ...) { + type = "HC1", + uniform = FALSE, + bootstraps = 999L, ...) { type <- match.arg(type, c("HC1", "HC0", "HC3")) s <- summary(x, type = type) @@ -876,22 +903,16 @@ tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, j_seq <- seq_len(nensb) } else { if (any(ensemble_idx < 1) || any(ensemble_idx > nensb)) { - stop(sprintf("ensemble_idx must be between 1 and %d", nensb), - call. = FALSE) + stop(sprintf("ensemble_idx must be between 1 and %d", nensb), call. = FALSE) }#IF j_seq <- ensemble_idx }#IFELSE - # Pre-allocate rows + # Generate tidy output by ensemble n_rows <- length(j_seq) * p term <- rep(dimnames(inf)[[1]], length(j_seq)) ensemble_type <- rep(dimnames(inf)[[3]][j_seq], each = p) - - estimate <- numeric(n_rows) - std.error <- numeric(n_rows) - statistic <- numeric(n_rows) - p.value <- numeric(n_rows) - + estimate <- std.error <- statistic <- p.value <- numeric(n_rows) idx <- 1 for (j in j_seq) { for (k in seq_len(p)) { @@ -914,9 +935,14 @@ tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, ) if (conf.int) { - z <- stats::qnorm((1 + conf.level) / 2) - res$conf.low <- res$estimate - z * res$std.error - res$conf.high <- res$estimate + z * res$std.error + ci_list <- lapply(j_seq, function(j) { + stats::confint(x, ensemble_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 diff --git a/R/ddml_rep.R b/R/ddml_rep.R index 98ae4fc..5481f06 100644 --- a/R/ddml_rep.R +++ b/R/ddml_rep.R @@ -1,28 +1,4 @@ -# Internal helpers ----------------------------------------------- - -# Build inference results array from aggregated coef/SE. -build_inf_from_agg <- function(agg, coef_names, - ensemble_type) { - p <- nrow(agg$coefficients) - nensb <- ncol(agg$coefficients) - inf_results <- array(0, dim = c(p, 4, nensb)) - for (j in seq_len(nensb)) { - 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( - coef_names, - c("Estimate", "Std. Error", "z value", "Pr(>|z|)"), - ensemble_type) - inf_results -}#BUILD_INF_FROM_AGG +# Internal helpers ================================================================ # Spectral-norm median of PSD matrices via SDP (CVXR). # @@ -34,39 +10,31 @@ spectral_median_psd <- function(matrices) { R <- length(matrices) if (p == 1) { - vals <- vapply(matrices, function(m) m[1, 1], - numeric(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) + " 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") - }#FOR - + for (r in seq_len(R)) obj <- obj + CVXR::norm(V - matrices[[r]], "2") + result <- CVXR::psolve(CVXR::Problem(CVXR::Minimize(obj))) if (result$status != "optimal") { - warning("SDP solver returned status '", - result$status, - "'; falling back to element-wise median.", - call. = FALSE) - arr <- array( - unlist(lapply(matrices, as.vector)), - dim = c(p, p, R)) + warning("SDP solver returned status '", result$status, + "'; falling back to element-wise median.", call. = FALSE) + arr <- array(unlist(lapply(matrices, as.vector)), dim = c(p, p, R)) return(apply(arr, c(1, 2), stats::median)) }#IF V_sol <- result$getValue(V) - (V_sol + t(V_sol)) / 2 + (V_sol + t(V_sol)) / 2 # symmetrize to avoid minimal numerical errors }#SPECTRAL_MEDIAN_PSD # Core aggregation workhorse. @@ -76,37 +44,32 @@ spectral_median_psd <- function(matrices) { # where theta_tilde is the aggregated coefficient vector. # The three aggregation rules then 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")) +aggregate_reps <- function(object, aggregation = "median", type = "HC1") { + aggregation <- match.arg(aggregation, c("median", "mean", "spectral")) R <- object$nresamples nensb <- length(object$ensemble_type) p <- length(object$coef_names) - # == Collect per-replication estimates == + # Collect per-replication estimates coef_array <- array(0, dim = c(p, nensb, R)) vcov_array <- array(0, dim = c(p, p, nensb, R)) for (r in seq_len(R)) { fit <- object$fits[[r]] coef_array[, , r] <- fit$coefficients for (j in seq_len(nensb)) { - vcov_array[, , j, r] <- stats::vcov(fit, - ensemble_idx = j, type = type) + vcov_array[, , j, r] <- stats::vcov(fit, ensemble_idx = j, type = type) }#FOR }#FOR - # == Aggregate coefficients == + # 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 == + # Inflate & aggregate covariance agg_vcov <- array(0, dim = c(p, p, nensb)) - for (j in seq_len(nensb)) { V_list <- vector("list", R) for (r in seq_len(R)) { @@ -121,19 +84,15 @@ aggregate_reps <- function(object, aggregation = "median", } 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) + 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 == + # Standard errors agg_se <- matrix(0, nrow = p, ncol = nensb) for (j in seq_len(nensb)) { - V_j <- matrix(agg_vcov[, , j, drop = FALSE], - nrow = p, ncol = p) + V_j <- matrix(agg_vcov[, , j, drop = FALSE], nrow = p, ncol = p) agg_se[, j] <- sqrt(diag(V_j)) }#FOR @@ -142,7 +101,7 @@ aggregate_reps <- function(object, aggregation = "median", vcov_array = vcov_array) }#AGGREGATE_REPS -# Exported functions --------------------------------------------- +# Exported functions =========================================================== #' Construct a Multi-Resample DDML Object #' @@ -184,61 +143,45 @@ aggregate_reps <- function(object, aggregation = "median", #' @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) + 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) + stop("Element ", i, " does not inherit from class 'ddml'.", call. = FALSE) }#IF }#FOR - - primary <- vapply(fits, function(f) class(f)[1], - character(1)) + 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) + 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 (!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.", + 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) + stop("Fit ", i, " has different 'nobs' than fit 1.", call. = FALSE) }#IF }#FOR + # Return ddml_rep object ens_type <- ref$ensemble_type - if (is.null(ens_type)) { - ens_type <- "single base learner" - }#IF - + if (is.null(ens_type)) ens_type <- "single base learner" structure( list( fits = fits, nresamples = length(fits), model_type = primary[1], coef_names = ref$coef_names, - estimator_name= if (!is.null(ref$estimator_name)) ref$estimator_name else primary[1], + estimator_name= if (!is.null(ref$estimator_name)) ref$estimator_name + else primary[1], ensemble_type = ens_type, nobs = ref$nobs, sample_folds = ref$sample_folds, @@ -294,15 +237,13 @@ ddml_replicate <- function(fn, ..., resamples = 5, } fits <- vector("list", resamples) for (r in seq_len(resamples)) { - if (!silent) { - message("[Resample ", r, "/", resamples, "]") - }#IF + if (!silent) message("[Resample ", r, "/", resamples, "]") fits[[r]] <- do.call(fn, dots) }#FOR ddml_rep(fits) }#DDML_REPLICATE -# S3 methods ----------------------------------------------------- +# S3 methods =================================================================== #' Extract a Single Fit from a ddml_rep Object #' @@ -349,9 +290,7 @@ ddml_replicate <- function(fn, ..., resamples = 5, #' #' @export #' @method length ddml_rep -length.ddml_rep <- function(x) { - x$nresamples -}#LENGTH.DDML_REP +length.ddml_rep <- function(x) x$nresamples #' Extract Number of Observations from a ddml_rep Object #' @@ -363,9 +302,7 @@ length.ddml_rep <- function(x) { #' @importFrom stats nobs #' @export #' @method nobs ddml_rep -nobs.ddml_rep <- function(object, ...) { - object$nobs -}#NOBS.DDML_REP +nobs.ddml_rep <- function(object, ...) object$nobs #' @rdname ddml_rep #' @@ -462,9 +399,7 @@ vcov.ddml_rep <- function(object, ensemble_idx = 1, type = "HC1", ...) { type <- match.arg(type, c("HC0", "HC1", "HC3")) aggregation <- match.arg(aggregation) - agg <- aggregate_reps(object, - aggregation = aggregation, - type = type) + agg <- aggregate_reps(object, aggregation = aggregation, type = type) V <- agg$vcov[, , ensemble_idx] if (!is.matrix(V)) { V <- matrix(V, nrow = length(object$coef_names), @@ -485,6 +420,9 @@ vcov.ddml_rep <- function(object, ensemble_idx = 1, #' @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 uniform +#' critical value. #' #' @examples #' \donttest{ @@ -502,23 +440,26 @@ vcov.ddml_rep <- function(object, ensemble_idx = 1, #' @seealso \code{\link{summary.ddml_rep}} for the #' aggregation equations. #' +#' @importFrom stats confint coef #' @export #' @method confint ddml_rep confint.ddml_rep <- function(object, parm, level = 0.95, ensemble_idx = 1, aggregation = c("median", "mean", "spectral"), - type = "HC1", ...) { + type = "HC1", + uniform = FALSE, + bootstraps = 999L, ...) { + # Aggregae coefficients and vcov matrices aggregation <- match.arg(aggregation) - agg <- aggregate_reps(object, - aggregation = aggregation, - type = type) + agg <- aggregate_reps(object, aggregation = aggregation, type = type) cf <- agg$coefficients[, ensemble_idx] se <- agg$se[, ensemble_idx] cf_names <- object$coef_names names(cf) <- cf_names names(se) <- cf_names + # Select parameters & results if (missing(parm)) { parm <- cf_names } else if (is.numeric(parm)) { @@ -527,18 +468,34 @@ confint.ddml_rep <- function(object, parm, parm <- intersect(parm, cf_names) if (length(parm) == 0) { stop("None of the specified 'parm' were found ", - "in the model coefficients.", - call. = FALSE) + "in the model coefficients.", call. = FALSE) }#IF }#IFELSE - cf <- cf[parm] se <- se[parm] - z <- stats::qnorm((1 + level) / 2) + + # Construct confidence intervalus + if (uniform) { + R <- object$nresamples + crit_vals <- vapply(seq_len(R), function(r) { + ci_r <- confint(object$fits[[r]], + level = level, + ensemble_idx = ensemble_idx, + type = type, + uniform = TRUE, + bootstraps = bootstraps) # multiplier bootstrap + attr(ci_r, "crit_val") + }, numeric(1)) + agg_fn <- if (aggregation == "mean") mean else stats::median + z <- agg_fn(crit_vals) # aggregated critical values... + } 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.DDML_REP @@ -604,13 +561,28 @@ confint.ddml_rep <- function(object, parm, summary.ddml_rep <- function(object, aggregation = c("median", "mean", "spectral"), type = "HC1", ...) { + # Aggregae coefficients and vcov matrices aggregation <- match.arg(aggregation) type <- match.arg(type, c("HC0", "HC1", "HC3")) - agg <- aggregate_reps(object, - aggregation = aggregation, - type = type) - inf_results <- build_inf_from_agg( - agg, object$coef_names, object$ensemble_type) + agg <- aggregate_reps(object, aggregation = aggregation, type = type) + # Construct inference results + p <- length(object$coef_names) + nensb <- length(object$ensemble_type) + inf_results <- array(0, dim = c(p, 4, nensb)) + for (j in seq_len(nensb)) { + 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|)"), + object$ensemble_type) result <- list( coefficients = inf_results, type = type, @@ -640,29 +612,19 @@ print.summary.ddml_rep <- function(x, digits = 3, ...) { " 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 + if (!is.null(x$shortstack) && x$shortstack) cat(" Stacking: short-stack") + if (!is.null(x$type) && x$type != "HC1") cat(" SE:", x$type) cat("\n\n") nensb <- dim(x$coefficients)[3] for (j in seq_len(nensb)) { - if (nensb > 1) { - cat("Ensemble type:", - dimnames(x$coefficients)[[3]][j], "\n") - }#IF + if (nensb > 1) cat("Ensemble type:", dimnames(x$coefficients)[[3]][j], "\n") tbl <- x$coefficients[, , j] if (!is.matrix(tbl)) { - tbl <- matrix(tbl, nrow = 1, - dimnames = list( - dimnames(x$coefficients)[[1]], - dimnames(x$coefficients)[[2]])) + tbl <- matrix(tbl, nrow = 1, dimnames = list( + dimnames(x$coefficients)[[1]], dimnames(x$coefficients)[[2]])) }#IF - stats::printCoefmat(tbl, digits = digits, - has.Pvalue = TRUE, + stats::printCoefmat(tbl, digits = digits, has.Pvalue = TRUE, signif.stars = TRUE) if (j < nensb) cat("\n") }#FOR @@ -689,6 +651,12 @@ print.summary.ddml_rep <- function(x, digits = 3, ...) { #' columns? Default \code{FALSE}. #' @param conf.level Confidence level for intervals. #' Default 0.95. +#' @param uniform Logical. If \code{TRUE}, computes +#' uniform confidence intervals using the multiplier +#' bootstrap. Only used when \code{conf.int = TRUE}. +#' Default \code{FALSE}. +#' @param bootstraps Integer number of bootstrap draws. +#' Only used when \code{uniform = TRUE}. Default 999. #' @param ... Currently unused. #' #' @return A \code{data.frame} with columns \code{term}, \code{estimate}, @@ -718,10 +686,11 @@ tidy.ddml_rep <- function(x, ensemble_idx = 1, aggregation = c("median", "mean", "spectral"), type = "HC1", conf.int = FALSE, - conf.level = 0.95, ...) { + conf.level = 0.95, + uniform = FALSE, + bootstraps = 999L, ...) { aggregation <- match.arg(aggregation) - s <- summary(x, aggregation = aggregation, - type = type) + s <- summary(x, aggregation = aggregation, type = type) inf <- s$coefficients nensb <- dim(inf)[3] p <- dim(inf)[1] @@ -745,17 +714,22 @@ tidy.ddml_rep <- function(x, ensemble_idx = 1, aggregation = aggregation, stringsAsFactors = FALSE ) - if (conf.int) { - z <- stats::qnorm((1 + conf.level) / 2) - row$conf.low <- - inf[k, 1, j] - z * inf[k, 2, j] - row$conf.high <- - inf[k, 1, j] + z * inf[k, 2, j] - }#IF rows[[length(rows) + 1]] <- row }#FOR }#FOR - do.call(rbind, rows) + + res <- do.call(rbind, rows) + if (conf.int) { + ci_list <- lapply(j_seq, function(j) { + confint(x, level = conf.level, ensemble_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.DDML_REP #' Glance at a ddml_rep Object @@ -789,13 +763,8 @@ glance.ddml_rep <- 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 = ", "), + shortstack = x$shortstack, + ensemble_type = paste(x$ensemble_type, collapse = ", "), model_type = x$model_type, estimator_name = x$estimator_name, nresamples = x$nresamples, diff --git a/R/lincom.R b/R/lincom.R new file mode 100644 index 0000000..28527b2 --- /dev/null +++ b/R/lincom.R @@ -0,0 +1,420 @@ +#' 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{\lambda = R'\hat\theta}. Inference is based on the +#' influence function +#' +#' \deqn{\phi_i^\lambda = R' \hat J^{-1} m_i +#' + \sum_c \theta_c R_{\cdot c}^{IF}(W_i) R_{c \cdot}} +#' +#' where the second term is the delta-method correction for +#' estimated weights (when \code{R_ifmat} is supplied). +#' +#' The resulting \code{ddml_lincom} object supports all standard +#' inference methods: \code{vcov}, \code{confint}, \code{summary}, +#' and \code{tidy}. For \code{ddml_rep} objects, \code{lincom} +#' can be called directly to obtain a \code{ddml_lincom_rep}. +#' +#' @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 R_ifmat An optional \eqn{(n \times p)}{n x p} matrix +#' of influence functions for the weight vector \eqn{R}. +#' When supplied, a delta-method correction is applied. +#' When \code{NULL} (default), \eqn{R} is treated as fixed. +#' @param ensemble_idx Integer index of the ensemble type to +#' use. Default 1. +#' @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 ... Currently unused. +#' +#' @return An object of class \code{"ddml_lincom"} (for +#' \code{ddml} input) or \code{"ddml_lincom_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, R_ifmat = NULL, + ensemble_idx = 1, + labels = NULL, ...) { + R <- as.matrix(R) + p <- nrow(fit$coefficients) + q <- ncol(R) + n <- fit$nobs + stopifnot(nrow(R) == p) + + # Point estimate: R'theta + att <- fit$coefficients[, ensemble_idx] + lincom_coef <- as.numeric(crossprod(R, att)) + + # Unit-level IF for theta: phi_i = J^{-1} psi_i + sc <- fit$scores[, , ensemble_idx, drop = FALSE] + dim(sc) <- dim(sc)[1:2] + J_j <- fit$J[, , ensemble_idx, drop = FALSE] + dim(J_j) <- dim(J_j)[1:2] + theta_if <- sc %*% t(csolve(J_j)) # n x p + + # Combined IF for R'theta + # Term 1: R' phi_i^theta + lincom_if <- theta_if %*% R # n x q + # Term 2: delta-method correction (when R estimated) + if (!is.null(R_ifmat)) { + stopifnot(nrow(R_ifmat) == n, ncol(R_ifmat) == p) + lincom_if <- lincom_if + R_ifmat %*% (att * R) + }#IF + + # Labels + if (is.null(labels)) labels <- colnames(R) + if (is.null(labels)) labels <- paste0("lc", seq_len(q)) + + # Package as standalone ddml_lincom + coef_mat <- matrix(lincom_coef, nrow = q, ncol = 1) + rownames(coef_mat) <- labels + colnames(coef_mat) <- "lincom" + + obj <- list( + coefficients = coef_mat, + scores = array(-lincom_if, dim = c(n, q, 1)), + J = array(diag(-1, q), dim = c(q, q, 1)), + coef_names = labels, + nobs = n, + estimator_name = "Linear Combination", + ensemble_type = "lincom", + cluster_variable = fit$cluster_variable, + fixed_R = is.null(R_ifmat) + ) + class(obj) <- "ddml_lincom" + obj +}#LINCOM.DDML + +# Internal helper ============================================================== + +# Build a temporary ddml object for delegation. +lincom_to_ddml <- function(lc) { + ddml( + coefficients = lc$coefficients, + scores = lc$scores, + J = lc$J, + psi_a = list(NULL), + psi_b = list(NULL), + nobs = lc$nobs, + coef_names = lc$coef_names, + estimator_name = lc$estimator_name, + ensemble_type = lc$ensemble_type, + cluster_variable = lc$cluster_variable, + call = NULL + ) +}#LINCOM_TO_DDML + +# Build a temporary ddml_rep from per-rep ddml_lincom fits. +lincom_to_ddml_rep <- function(lc_rep) { + ddml_rep(lapply(lc_rep$fits, lincom_to_ddml)) +}#LINCOM_TO_DDML_REP + +# ddml_lincom S3 methods ======================================================= + +#' @rdname lincom +#' @param object A \code{ddml_lincom} object. +#' @export +#' @method coef ddml_lincom +coef.ddml_lincom <- function(object, ...) { + cf <- object$coefficients[, 1] + names(cf) <- object$coef_names + cf +}#COEF.DDML_LINCOM + +#' @rdname lincom +#' @export +#' @method nobs ddml_lincom +nobs.ddml_lincom <- function(object, ...) object$nobs + +#' @rdname lincom +#' @param type Character. Variance estimator type +#' (\code{"HC0"} or \code{"HC1"}). \code{"HC3"} is not +#' supported for linear combinations. +#' @export +#' @method vcov ddml_lincom +vcov.ddml_lincom <- function(object, type = "HC1", ...) { + type <- match.arg(type, c("HC0", "HC1", "HC3")) + if (type == "HC3") { + stop("HC3 standard errors (generalized leverage) are not ", + "currently supported for linear combinations.", + call. = FALSE) + }#IF + vcov(lincom_to_ddml(object), ensemble_idx = 1, type = type) +}#VCOV.DDML_LINCOM + +#' @rdname lincom +#' @param parm Parameters for confidence intervals. +#' @param level Confidence level. Default 0.95. +#' @param uniform Logical. If \code{TRUE}, computes uniform +#' confidence bands via the multiplier bootstrap. +#' @param bootstraps Integer bootstrap draws. Default 999. +#' @export +#' @method confint ddml_lincom +confint.ddml_lincom <- function(object, parm, level = 0.95, + type = "HC1", + uniform = FALSE, + bootstraps = 999L, ...) { + type <- match.arg(type, c("HC0", "HC1", "HC3")) + if (type == "HC3") { + stop("HC3 standard errors (generalized leverage) are not ", + "currently supported for linear combinations.", + call. = FALSE) + }#IF + confint(lincom_to_ddml(object), parm = parm, level = level, + ensemble_idx = 1, type = type, uniform = uniform, + bootstraps = bootstraps) +}#CONFINT.DDML_LINCOM + +#' @rdname lincom +#' @export +#' @method summary ddml_lincom +summary.ddml_lincom <- function(object, type = "HC1", ...) { + type <- match.arg(type, c("HC0", "HC1", "HC3")) + if (type == "HC3") { + stop("HC3 standard errors (generalized leverage) are not ", + "currently supported for linear combinations.", + call. = FALSE) + }#IF + summary(lincom_to_ddml(object), type = type) +}#SUMMARY.DDML_LINCOM + +#' @rdname lincom +#' @param x A \code{ddml_lincom} or \code{ddml_lincom_rep} +#' object. +#' @param conf.int Logical. Include confidence intervals? +#' @param conf.level Confidence level for intervals. +#' @export +#' @method tidy ddml_lincom +tidy.ddml_lincom <- function(x, conf.int = FALSE, + conf.level = 0.95, + type = "HC1", + uniform = FALSE, + bootstraps = 999L, ...) { + type <- match.arg(type, c("HC0", "HC1", "HC3")) + if (type == "HC3") { + stop("HC3 standard errors (generalized leverage) are not ", + "currently supported for linear combinations.", + call. = FALSE) + }#IF + tidy(lincom_to_ddml(x), ensemble_idx = 1, + conf.int = conf.int, conf.level = conf.level, + type = type, uniform = uniform, bootstraps = bootstraps) +}#TIDY.DDML_LINCOM + +#' @rdname lincom +#' @param model A \code{ddml_lincom} or \code{ddml_lincom_rep} object. +#' @export +#' @method hatvalues ddml_lincom +hatvalues.ddml_lincom <- function(model, ...) { + stop("HC3 standard errors (generalized leverage) are not currently ", + "supported for linear combinations.", call. = FALSE) +}#HATVALUES.DDML_LINCOM + +# lincom.ddml_rep ============================================================== + +#' @rdname lincom +#' @export +#' @method lincom ddml_rep +lincom.ddml_rep <- function(fit, R, R_ifmat = NULL, + ensemble_idx = 1, + labels = NULL, ...) { + # Apply lincom.ddml to each rep + lc_fits <- lapply(fit$fits, function(f) { + lincom(f, R = R, R_ifmat = R_ifmat, ensemble_idx = ensemble_idx, + labels = labels) + }) + + obj <- list( + fits = lc_fits, + nresamples = length(lc_fits), + nobs = lc_fits[[1]]$nobs, + coef_names = lc_fits[[1]]$coef_names, + estimator_name = "Linear Combination", + ensemble_type = "lincom", + fixed_R = is.null(R_ifmat) + ) + class(obj) <- "ddml_lincom_rep" + obj +}#LINCOM.DDML_REP + +# ddml_lincom_rep S3 methods =================================================== + +#' @rdname lincom +#' @param aggregation Aggregation method: \code{"median"}, +#' \code{"mean"}, or \code{"spectral"}. +#' @export +#' @method coef ddml_lincom_rep +coef.ddml_lincom_rep <- function(object, aggregation = c("median", "mean"), + ...) { + aggregation <- match.arg(aggregation) + coef(lincom_to_ddml_rep(object), aggregation = aggregation) +}#COEF.DDML_LINCOM_REP + +#' @rdname lincom +#' @export +#' @method nobs ddml_lincom_rep +nobs.ddml_lincom_rep <- function(object, ...) object$nobs + +#' @rdname lincom +#' @export +#' @method vcov ddml_lincom_rep +vcov.ddml_lincom_rep <- function(object, + aggregation = c("median", "mean", + "spectral"), + type = "HC1", ...) { + aggregation <- match.arg(aggregation) + type <- match.arg(type, c("HC0", "HC1", "HC3")) + if (type == "HC3") { + stop("HC3 standard errors (generalized leverage) are not ", + "currently supported for linear combinations.", call. = FALSE) + }#IF + vcov(lincom_to_ddml_rep(object), aggregation = aggregation, type = type) +}#VCOV.DDML_LINCOM_REP + +#' @rdname lincom +#' @export +#' @method confint ddml_lincom_rep +confint.ddml_lincom_rep <- function(object, parm, level = 0.95, + aggregation = c("median", "mean", + "spectral"), + type = "HC1", + uniform = FALSE, + bootstraps = 999L, ...) { + aggregation <- match.arg(aggregation) + type <- match.arg(type, c("HC0", "HC1", "HC3")) + if (type == "HC3") { + stop("HC3 standard errors (generalized leverage) are not ", + "currently supported for linear combinations.", call. = FALSE) + }#IF + confint(lincom_to_ddml_rep(object), parm = parm, level = level, + aggregation = aggregation, type = type, + uniform = uniform, bootstraps = bootstraps) +}#CONFINT.DDML_LINCOM_REP + +#' @rdname lincom +#' @export +#' @method summary ddml_lincom_rep +summary.ddml_lincom_rep <- function(object, + aggregation = c("median", "mean", + "spectral"), + type = "HC1", ...) { + aggregation <- match.arg(aggregation) + type <- match.arg(type, c("HC0", "HC1", "HC3")) + if (type == "HC3") { + stop("HC3 standard errors (generalized leverage) are not ", + "currently supported for linear combinations.", call. = FALSE) + }#IF + summary(lincom_to_ddml_rep(object), aggregation = aggregation, type = type) +}#SUMMARY.DDML_LINCOM_REP + +#' @rdname lincom +#' @export +#' @method tidy ddml_lincom_rep +tidy.ddml_lincom_rep <- function(x, + aggregation = c("median", "mean"), + type = "HC1", + conf.int = FALSE, + conf.level = 0.95, + uniform = FALSE, + bootstraps = 999L, ...) { + aggregation <- match.arg(aggregation) + type <- match.arg(type, c("HC0", "HC1", "HC3")) + if (type == "HC3") { + stop("HC3 standard errors (generalized leverage) are not ", + "currently supported for linear combinations.", call. = FALSE) + }#IF + tidy(lincom_to_ddml_rep(x), aggregation = aggregation, + type = type, conf.int = conf.int, conf.level = conf.level, + uniform = uniform, bootstraps = bootstraps) +}#TIDY.DDML_LINCOM_REP + +#' @rdname lincom +#' @export +#' @method hatvalues ddml_lincom_rep +hatvalues.ddml_lincom_rep <- function(model, ...) { + stop("HC3 standard errors (generalized leverage) are not currently ", + "supported for linear combinations.", call. = FALSE) +}#HATVALUES.DDML_LINCOM_REP + +# Print methods ================================================================ + +#' @rdname lincom +#' @export +#' @method print ddml_lincom +print.ddml_lincom <- function(x, ...) { + cat("DDML Linear Combination\n") + cat("Obs:", x$nobs) + if (!x$fixed_R) cat(" (delta-method)") + cat("\n\n") + cat("Use summary() for inference.\n") + invisible(x) +}#PRINT.DDML_LINCOM + +#' @rdname lincom +#' @export +#' @method print ddml_lincom_rep +print.ddml_lincom_rep <- function(x, ...) { + cat("DDML Linear Combination (replicated)\n") + cat("Obs:", x$nobs, " Resamples:", x$nresamples) + 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.DDML_LINCOM_REP From 7a67448dd058c36051e0467990644a388980a655 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Fri, 20 Mar 2026 11:29:14 -0500 Subject: [PATCH 31/46] if-based inference --- R/ddml.R | 233 ++++++++++++++++++++++++++----------------------- R/ddml_apo.R | 33 +++---- R/ddml_ate.R | 39 ++++----- R/ddml_att.R | 21 +++-- R/ddml_fpliv.R | 38 ++++---- R/ddml_late.R | 53 +++++------ R/ddml_pliv.R | 39 ++++----- R/ddml_plm.R | 38 ++++---- R/lincom.R | 146 ++++++++++++++++++++++--------- 9 files changed, 363 insertions(+), 277 deletions(-) diff --git a/R/ddml.R b/R/ddml.R index a0a2565..49e5aad 100644 --- a/R/ddml.R +++ b/R/ddml.R @@ -24,18 +24,8 @@ #' #' where \eqn{W} denotes observed random variables and #' \eqn{\eta_0} is a (potentially high-dimensional) nuisance -#' parameter, typically a vector of conditional expectation -#' functions. The score \eqn{m} is \emph{Neyman orthogonal}, -#' meaning the moment condition is locally insensitive to -#' perturbations of \eqn{\eta} around \eqn{\eta_0}. -#' -#' Each estimator in \code{ddml} uses a score that decomposes -#' linearly in \eqn{\theta}: -#' -#' \deqn{m(W_i; \theta, \eta) = \psi_b(W_i; \eta) + \psi_a(W_i; \eta)\,\theta.} -#' -#' See the individual estimator pages for the specific forms -#' of \eqn{\psi_a} and \eqn{\psi_b}. +#' 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 @@ -47,32 +37,46 @@ #' \deqn{\frac{1}{n} \sum_{k=1}^{K} \sum_{i \in I_k} #' m(W_i; \hat\theta, \hat\eta_{-k}) = 0.} #' -#' For the linear scores used in \code{ddml}, this yields the -#' closed-form solution +#' 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{\hat\theta = -\hat{J}^{-1}\,\hat\psi_b,} +#' \deqn{\phi_\theta(W_i; \theta, \eta, J) +#' = -J^{-1}\,m(W_i; \theta, \eta).} #' -#' where \eqn{\hat\psi_b = n^{-1}\sum_{k}\sum_{i \in I_k} -#' \psi_b(W_i; \hat\eta_{-k})} and -#' \eqn{\hat{J} = n^{-1}\sum_k \sum_{i \in I_k} -#' \psi_a(W_i; \hat\eta_{-k})} is the sample Jacobian. +#' The variance of \eqn{\hat\theta} is then estimated by #' -#' Inference is based on the sandwich variance estimator +#' \deqn{\hat{V} = \frac{1}{n} \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})'}, #' -#' \deqn{\hat\Sigma = \hat{J}^{-1} \left(\frac{1}{n} -#' \sum_i m_i m_i^\top\right) -#' \hat{J}^{-\top} / n} +#' where \eqn{\hat{J}} is the sample analog of the Jacobian: #' -#' where \eqn{m_i = m(W_i; \hat\theta, \hat\eta_{-k(i)})}; -#' see \code{\link{vcov.ddml}} for HC0/HC1/HC3 variants. -#' Under regularity conditions and sufficient convergence of \eqn{\hat\eta}, -#' the DML estimator is asymptotically normal: +#' \deqn{\hat{J} = \frac{1}{n} \sum_i +#' \frac{\partial m(W_i; \hat\theta, \hat\eta_{-k(i)})} +#' {\partial \theta'}.} #' -#' \deqn{\sqrt{n}\,\hat\Sigma^{-1/2}(\hat\theta - \theta_0) +#' HC1 and HC3 variance estimators are described in +#' \code{\link{vcov.ddml}}. The generalized leverage used in +#' HC3 is defined in \code{\link{hatvalues.ddml}}. +#' +#' 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). +#' 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 #' Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, @@ -99,11 +103,13 @@ #' from cross-fitted residuals.} #' \item{\code{r2}}{A named list of numeric vectors #' containing per-learner out-of-sample R-squared values.} -#' \item{\code{psi_a}, \code{psi_b}}{Score component lists -#' (length \code{nensb}). \code{psi_a[[j]]} is an -#' \code{(n x p x p)} array and \code{psi_b[[j]]} is an -#' \code{(n x p)} matrix. Used internally by -#' \code{\link{hatvalues.ddml}}.} +#' \item{\code{inf_func}}{A 3D array of evaluated influence +#' functions (\code{n x p x nensb}).} +#' \item{\code{dinf_dtheta}}{An optional list of length \code{nensb} +#' containing the derivatives of the influence functions with +#' respect to \eqn{\theta}. Each element is an \code{(n x p x p)} +#' array. Used internally by \code{\link{hatvalues.ddml}} +#' 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 @@ -248,12 +254,8 @@ NULL #' 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 psi_a A list of length \code{nensb}. Each element is an -#' \code{(n x p x p)} array of individual-level Jacobian -#' contributions. -#' @param psi_b A list of length \code{nensb}. Each element is an -#' \code{(n x p)} matrix of individual-level score -#' contributions. +#' @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}). @@ -278,6 +280,8 @@ NULL #' @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 @@ -297,16 +301,16 @@ NULL #' 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))) -#' coef <- matrix(theta, 1, 1, -#' dimnames = list("mean", "custom")) +#' inf_func <- array(y - theta, dim = c(n, 1, 1)) +#' dinf_dtheta <- list(array(1, dim = c(n, 1, 1))) +#' coef <- matrix(theta, 1, 1, dimnames = list("mean", "custom")) #' #' fit <- ddml(coefficients = coef, scores = scores, J = J, -#' psi_a = psi_a, psi_b = psi_b, -#' nobs = n, coef_names = "mean", +#' inf_func = inf_func, nobs = n, coef_names = "mean", +#' dinf_dtheta = dinf_dtheta, #' estimator_name = "Sample Mean") #' summary(fit) -ddml <- function(coefficients, scores, J, - psi_a, psi_b, +ddml <- function(coefficients, scores, J, inf_func, nobs, coef_names, estimator_name, ensemble_type = colnames(coefficients), cluster_variable = seq_len(nobs), @@ -318,6 +322,7 @@ ddml <- function(coefficients, scores, J, fitted = NULL, splits = NULL, call = match.call(), subclass = NULL, + dinf_dtheta = NULL, ...) { # Validate required fields if (!is.matrix(coefficients)) { @@ -329,8 +334,11 @@ ddml <- function(coefficients, scores, J, if (length(dim(J)) != 3) { stop("'J' must be a 3D array.", call. = FALSE) }#IF - if (!is.list(psi_a) || !is.list(psi_b)) { - stop("'psi_a' and 'psi_b' must be lists.", call. = FALSE) + 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 @@ -343,12 +351,18 @@ ddml <- function(coefficients, scores, J, }#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) + stop("'J' dimensions must be (p x p x nensb).", call. = FALSE) }#IF - if (length(psi_a) != nensb || length(psi_b) != nensb) { - stop("'psi_a' and 'psi_b' must have length nensb.", - call. = FALSE) + 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 # Assemble the object @@ -357,7 +371,8 @@ ddml <- function(coefficients, scores, J, ensemble_weights = ensemble_weights, mspe = mspe, r2 = r2, - psi_a = psi_a, psi_b = psi_b, + inf_func = inf_func, + dinf_dtheta = dinf_dtheta, scores = scores, J = J, coef_names = coef_names, estimator_name = estimator_name, @@ -378,7 +393,6 @@ ddml <- function(coefficients, scores, J, # S3 methods ================================================================ - #' Extract Model Coefficients #' #' @description Extracts the estimated coefficients @@ -439,13 +453,20 @@ nobs.ddml <- function(object, ...) { #' estimator. These values are used internally to compute #' heteroskedasticity-robust HC3 standard errors. #' -#' @details See \code{\link{ddml-intro}} for the DML framework and -#' the definition of \eqn{\psi_a} and \eqn{\hat{J}}. -#' For the linear scores used in \code{ddml}, -#' the generalized leverage simplifies to +#' @details See \code{\link{ddml-intro}} for the definition of +#' the influence function \eqn{\phi_\theta(W_i; +#' \theta, \eta, J)}. The generalized leverage is #' -#' \eqn{h_{ii} = \mathrm{tr}(\psi_a(W_i; -#' \hat\eta)\,(n\hat{J})^{-1}).} +#' \deqn{h_\theta(W_i; \theta, \eta, J) +#' = \mathrm{tr}\!\left( +#' -\frac{1}{n} +#' \frac{\partial \phi_\theta(W_i; \theta, \eta, J)} +#' {\partial \theta} +#' \right).} +#' +#' This function returns the estimated hat values +#' \eqn{\hat{h}_{\theta,i} = +#' h_\theta(W_i; \hat\theta, \hat\eta, \hat{J})}. #' #' @param model An object of class \code{ddml}. #' @param ensemble_idx Integer index of the ensemble type to extract leverage @@ -473,14 +494,20 @@ nobs.ddml <- function(object, ...) { #' @export hatvalues.ddml <- function(model, ensemble_idx = 1, ...) { validate_method_args(model, ensemble_idx = ensemble_idx) - psi_a_j <- model$psi_a[[ensemble_idx]] - J_j <- model$J[, , ensemble_idx, drop = FALSE] - dim(J_j) <- dim(J_j)[1:2] - J_inv <- csolve(J_j) - p <- ncol(J_j) + 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 - dim(psi_a_j) <- c(n, p * p) - as.vector((psi_a_j %*% as.vector(t(J_inv))) / n) + p <- dim(model$J)[1] + dinf_j <- model$dinf_dtheta[, , , ensemble_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.DDML #' Variance-Covariance Matrix for DDML Estimators @@ -489,16 +516,17 @@ hatvalues.ddml <- function(model, ensemble_idx = 1, ...) { #' variance-covariance matrix for the DDML estimator #' \eqn{\hat\theta}. #' -#' @details See \code{\link{ddml-intro}} for the DML framework, -#' including the definitions of the score \eqn{m_i}, -#' the Jacobian \eqn{\hat{J}}, and the base sandwich -#' estimator \eqn{\hat\Sigma}. This function provides -#' three variants: +#' @details See \code{\link{ddml-intro}} for the DML framework +#' and the definition of the influence function +#' \eqn{\phi_\theta}. Let \eqn{\hat\phi_i = +#' \phi_\theta(W_i; \hat\theta, \hat\eta, \hat{J})} +#' denote the estimated influence function evaluated at +#' observation \eqn{i}. This function provides three +#' variance estimator variants: #' #' \strong{HC0}: -#' \deqn{V_{\mathrm{HC0}} = \hat{J}^{-1} -#' \left(\frac{1}{n}\sum_i m_i m_i'\right) -#' \hat{J}^{-\top} / n} +#' \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}} @@ -507,12 +535,11 @@ hatvalues.ddml <- function(model, ensemble_idx = 1, ...) { #' where \eqn{p} is the dimension of \eqn{\theta}. #' #' \strong{HC3}: -#' \deqn{V_{\mathrm{HC3}} = \hat{J}^{-1} -#' \left(\frac{1}{n}\sum_i -#' \frac{m_i m_i'}{(1 - h_{ii})^2}\right) -#' \hat{J}^{-\top} / n} +#' \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{h_{ii}} is the generalized leverage; +#' where \eqn{\hat{h}_{\theta,i}} is the generalized leverage; #' see \code{\link{hatvalues.ddml}}. #' #' @param object An object of class \code{ddml}. @@ -548,32 +575,26 @@ vcov.ddml <- function(object, ensemble_idx = 1, type = "HC1", ...) { type <- validate_method_args(object, ensemble_idx = ensemble_idx, type = type) - sc <- object$scores[, , ensemble_idx, drop = FALSE] - dim(sc) <- dim(sc)[1:2] - J_j <- object$J[, , ensemble_idx, drop = FALSE] - dim(J_j) <- dim(J_j)[1:2] - p <- ncol(sc) + if_j <- object$inf_func[, , ensemble_idx, drop = FALSE] + dim(if_j) <- dim(if_j)[1:2] + p <- ncol(if_j) - # Cluster aggregation: rowsum scores to cluster level + # Cluster aggregation: rowsum influence functions to cluster level clustered <- !is.null(object$cluster_variable) && - length(unique(object$cluster_variable)) < nrow(sc) - if (clustered) sc <- rowsum(sc, object$cluster_variable) + length(unique(object$cluster_variable)) < nrow(if_j) + if (clustered) if_j <- rowsum(if_j, object$cluster_variable) - n_eff <- nrow(sc) + n_eff <- nrow(if_j) if (type == "HC3") { h <- stats::hatvalues(object, ensemble_idx = ensemble_idx) if (clustered) h <- as.vector(tapply(h, object$cluster_variable, sum)) - sc <- sc / (1 - h) + if_j <- if_j / (1 - h) }#IF - meat <- crossprod(sc) / n_eff - J_inv <- csolve(J_j) - V <- J_inv %*% meat %*% t(J_inv) / n_eff + V <- crossprod(if_j) / n_eff^2 # HC1 degrees-of-freedom correction - if (type == "HC1") { - V <- V * n_eff / (n_eff - p) - }#IF + if (type == "HC1") V <- V * n_eff / (n_eff - p) rownames(V) <- colnames(V) <- object$coef_names V @@ -661,14 +682,13 @@ confint.ddml <- function(object, parm, level = 0.95, if (uniform) { # Multiplier bootstrap - sc <- object$scores[, , ensemble_idx, drop = FALSE] - dim(sc) <- dim(sc)[1:2] - J_j <- object$J[, , ensemble_idx, drop = FALSE] - dim(J_j) <- dim(J_j)[1:2] - cl <- object$cluster_variable - if (!is.null(cl) && length(unique(cl)) < nrow(sc)) sc <- rowsum(sc, cl) - n_eff <- nrow(sc) - inf_func <- sc %*% t(csolve(J_j)) + inf_func <- object$inf_func[, , ensemble_idx, drop = FALSE] + dim(inf_func) <- dim(inf_func)[1:2] + cl <- object$cluster_variable # check for clustering + if (!is.null(cl) && length(unique(cl)) < nrow(inf_func)) { + inf_func <- rowsum(inf_func, cl) + }#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) @@ -936,8 +956,7 @@ tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, if (conf.int) { ci_list <- lapply(j_seq, function(j) { - stats::confint(x, ensemble_idx = j, - level = conf.level, type = type, + stats::confint(x, ensemble_idx = j, level = conf.level, type = type, uniform = uniform, bootstraps = bootstraps) }) ci_mat <- do.call(rbind, ci_list) diff --git a/R/ddml_apo.R b/R/ddml_apo.R index 93ed920..65b02e1 100644 --- a/R/ddml_apo.R +++ b/R/ddml_apo.R @@ -33,15 +33,12 @@ #' #' \deqn{m(W; \theta, \eta) = \left( \frac{\mathbf{1}\{D=d\} (Y - \ell(X))}{p(X)} + \ell(X) \right) \omega(X) - \theta} #' -#' \strong{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: +#' \strong{Jacobian:} #' -#' \deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} +#' \deqn{J = -1} #' -#' where: -#' -#' \deqn{\psi_a(W; \eta) = -1} -#' -#' \deqn{\psi_b(W; \eta) = \left( \frac{\mathbf{1}\{D=d\} (Y - \ell(X))}{p(X)} + \ell(X) \right) \omega(X)} +#' See \code{\link{ddml-intro}} for how the influence function +#' and inference are derived from these components. #' #' @inheritParams ddml-intro #' @inheritParams ddml_plm @@ -103,7 +100,7 @@ ddml_apo <- function(y, D, X, ...) { cl <- match.call() - # == Preliminaries ================================================ + # Preliminaries -------------------------------------------------------------- dots <- list(...) messages <- resolve_messages(dots, "ddml_apo", list( @@ -142,7 +139,7 @@ ddml_apo <- function(y, D, X, t0 <- proc.time()[3] announce_start(messages, parallel, silent) - # == Reduced-form estimation ====================================== + # Reduced-form estimation ---------------------------------------------------- # P(D = d | X) D_X_res <- get_CEF(D_ind, X, @@ -177,7 +174,7 @@ ddml_apo <- function(y, D, X, nensb <- if (is.null(ensemble_type)) 1L else length(ensemble_type) - # == Score construction =========================================== + # 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} @@ -201,18 +198,21 @@ ddml_apo <- function(y, D, X, y_mat <- matrix(y, nobs, nensb) psi_b_mat <- (D_ind_mat * (y_mat - g_X) / m_X_tr + g_X) * weights_mat - psi_b <- lapply(seq_len(nensb), function(j) psi_b_mat[, j, drop = FALSE]) - psi_a <- lapply(seq_len(nensb), function(j) array(-1, dim = c(nobs, 1, 1))) - - # == Target parameter ============================================= + # 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" @@ -220,7 +220,7 @@ ddml_apo <- function(y, D, X, rownames(coef) <- coef_names colnames(coef) <- ensemble_type - # == Output ======================================================= + # Output --------------------------------------------------------------------- announce_finish(t0, messages, silent) @@ -232,7 +232,7 @@ ddml_apo <- function(y, D, X, D_X = D_X_res$mspe), r2 = list(y_X = y_X_res$r2, D_X = D_X_res$r2), - psi_a = psi_a, psi_b = psi_b, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, scores = scores, J = J, coef_names = coef_names, estimator_name = "Average Potential Outcome", @@ -255,6 +255,7 @@ ddml_apo <- function(y, D, X, cv_subsamples = indxs$cv_subsamples)), call = cl, subclass = "ddml_apo", + # ddml_apo-specific fields d = d, weights = weights, learners = learners, diff --git a/R/ddml_ate.R b/R/ddml_ate.R index 5348fa5..15dcee9 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -35,19 +35,14 @@ #' where the nuisance parameters are \eqn{\eta = (\ell_0, \ell_1, p, \pi)} taking true values #' \eqn{\ell_{d,0}(X) = E[Y|D=d, X]}, \eqn{p_0(X) = E[D|X]}, and \eqn{\pi_0 = E[D]}. #' -#' \strong{Linear Decomposition:} The scores decompose linearly in \eqn{\theta}: +#' \strong{Jacobian:} #' -#' \deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} +#' \deqn{J^{\textrm{ATE}} = -1} #' -#' where: +#' \deqn{J^{\textrm{ATT}} = -E[D / \pi]} #' -#' \deqn{\psi_a^{\textrm{ATE}}(W; \eta) = -1} -#' -#' \deqn{\psi_b^{\textrm{ATE}}(W; \eta) = \frac{D(Y - \ell_1(X))}{p(X)} - \frac{(1-D)(Y-\ell_0(X))}{1-p(X)} + \ell_1(X) - \ell_0(X)} -#' -#' \deqn{\psi_a^{\textrm{ATT}}(W; \eta) = -\frac{D}{\pi}} -#' -#' \deqn{\psi_b^{\textrm{ATT}}(W; \eta) = \frac{D(Y - \ell_0(X))}{\pi} - \frac{p(X)(1-D)(Y-\ell_0(X))}{\pi(1-p(X))}} +#' See \code{\link{ddml-intro}} for how the influence function +#' and inference are derived from these components. #' #' @inheritParams ddml-intro #' @inheritParams ddml_apo @@ -115,7 +110,7 @@ ddml_ate <- function(y, D, X, ...) { cl <- match.call() - # == Preliminaries ================================================ + # Preliminaries -------------------------------------------------------------- dots <- list(...) messages <- resolve_messages(dots, "ddml_ate", list( @@ -155,7 +150,7 @@ ddml_ate <- function(y, D, X, t0 <- proc.time()[3] announce_start(messages, parallel, silent) - # == Reduced-form estimation ====================================== + # Reduced-form estimation ---------------------------------------------------- shared_splits <- list(subsamples = indxs$subsamples, cv_subsamples = indxs$cv_subsamples) @@ -207,29 +202,26 @@ ddml_ate <- function(y, D, X, ensemble_type <- apo_1$ensemble_type nensb <- ncol(apo_1$coefficients) - # == Score construction =========================================== - psi_b <- lapply(seq_len(nensb), function(j) { - apo_1$psi_b[[j]] - apo_0$psi_b[[j]] - }) - psi_a <- lapply(seq_len(nensb), function(j) array(-1, dim = c(nobs, 1, 1))) - - # == Target parameter ============================================= + # Target parameter & influence function -------------------------------------- ate <- as.vector(apo_1$coefficients) - as.vector(apo_0$coefficients) 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] <- -ate[j] + as.vector(psi_b[[j]]) + 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 - # == Output ======================================================= + # Output --------------------------------------------------------------------- announce_finish(t0, messages, silent) @@ -245,7 +237,7 @@ ddml_ate <- function(y, 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), - psi_a = psi_a, psi_b = psi_b, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, scores = scores, J = J, coef_names = coef_names, estimator_name = "Average Treatment Effect", @@ -271,6 +263,7 @@ ddml_ate <- function(y, D, X, cv_subsamples = indxs$cv_subsamples)), call = cl, subclass = "ddml_ate", + # ddml_ate-specific fields learners = learners, learners_DX = learners_DX ) diff --git a/R/ddml_att.R b/R/ddml_att.R index 746edae..08b0df0 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -21,7 +21,7 @@ ddml_att <- function(y, D, X, ...) { cl <- match.call() - # == Preliminaries ================================================ + # Preliminaries -------------------------------------------------------------- dots <- list(...) messages <- resolve_messages(dots, "ddml_att", list( @@ -62,7 +62,7 @@ ddml_att <- function(y, D, X, t0 <- proc.time()[3] announce_start(messages, parallel, silent) - # == Reduced-form estimation ====================================== + # Reduced-form estimation ---------------------------------------------------- # E[D|X] D_X_res <- get_CEF(D, X, @@ -110,7 +110,7 @@ ddml_att <- function(y, D, X, nensb <- if (is.null(ensemble_type)) 1L else length(ensemble_type) - # == Score construction =========================================== + # 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} @@ -131,18 +131,22 @@ ddml_att <- function(y, D, X, 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 - psi_b <- lapply(seq_len(nensb), function(j) psi_b_mat[, j, drop = FALSE]) - psi_a <- lapply(seq_len(nensb), function(j) array(psi_a_vec, dim = c(nobs, 1, 1))) - # == Target parameter ============================================= + # 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" @@ -150,7 +154,7 @@ ddml_att <- function(y, D, X, rownames(coef) <- coef_names colnames(coef) <- ensemble_type - # == Output ======================================================= + # Output --------------------------------------------------------------------- announce_finish(t0, messages, silent) @@ -166,7 +170,7 @@ ddml_att <- function(y, D, X, r2 = list(y_X_D0 = y_X_D0_res$r2, D_X = D_X_res$r2, D = D_res$r2), - psi_a = psi_a, psi_b = psi_b, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, scores = scores, J = J, coef_names = coef_names, estimator_name = @@ -198,6 +202,7 @@ ddml_att <- function(y, D, X, cv_subsamples = indxs$cv_subsamples)), call = cl, subclass = "ddml_att", + # ddml_att-specific fields learners = learners, learners_DX = learners_DX ) diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index 85b3099..835aa88 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -22,15 +22,12 @@ #' 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{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: +#' \strong{Jacobian:} #' -#' \deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} +#' \deqn{J = -E[(D - r(X))(v(X, Z) - r(X))^\top]} #' -#' where: -#' -#' \deqn{\psi_a(W; \eta) = -(D - r(X))(v(X, Z) - r(X))^\top} -#' -#' \deqn{\psi_b(W; \eta) = (v(X, Z) - r(X))(Y - \ell(X))} +#' 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. @@ -86,7 +83,7 @@ ddml_fpliv <- function(y, D, Z, X, ...) { cl <- match.call() - # == Preliminaries ================================================ + # Preliminaries -------------------------------------------------------------- dots <- list(...) messages <- resolve_messages(dots, "ddml_fpliv", list( @@ -121,7 +118,7 @@ ddml_fpliv <- function(y, D, Z, X, t0 <- proc.time()[3] announce_start(messages, parallel, silent) - # == Reduced-form estimation ====================================== + # Reduced-form estimation ---------------------------------------------------- # E[Y|X] y_X_res <- get_CEF(y, X, @@ -189,13 +186,13 @@ ddml_fpliv <- function(y, D, Z, X, nensb <- if (is.null(ensemble_type)) 1L else length(ensemble_type) - # == Score construction =========================================== + # Target parameter & influence function -------------------------------------- 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)) - psi_a <- vector("list", nensb) - psi_b <- vector("list", 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)) cn_weights <- dimnames(y_X_res$weights)[[2]] colnames(coef) <- if (is.null(cn_weights)) ensemble_type else cn_weights @@ -227,20 +224,22 @@ ddml_fpliv <- function(y, D, Z, X, scores[, , j] <- X_hat * e_j J[, , j] <- -crossprod(X_hat, X_full) / nobs - psi_b[[j]] <- X_hat * as.vector(y_r) - psi_a[[j]] <- -sapply(seq_len(nD + 1), - function(k) X_hat * X_full[, k], - simplify = "array") + 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 - # == Target parameter ============================================= 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) - # == Output ======================================================= + # Output --------------------------------------------------------------------- ensemble_weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) @@ -265,7 +264,7 @@ ddml_fpliv <- function(y, D, Z, X, ensemble_weights = ensemble_weights, mspe = mspe, r2 = r2, - psi_a = psi_a, psi_b = psi_b, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, scores = scores, J = J, coef_names = coef_names, estimator_name = "Flexible Partially Linear IV Model", @@ -288,6 +287,7 @@ ddml_fpliv <- function(y, D, Z, X, names(ensemble_weights)), call = cl, subclass = "ddml_fpliv", + # ddml_fpliv-specific fields learners = learners, learners_DXZ = learners_DXZ, learners_DX = learners_DX diff --git a/R/ddml_late.R b/R/ddml_late.R index 814e59b..4f1b769 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -32,15 +32,14 @@ #' #' \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{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: +#' \strong{Jacobian:} #' -#' \deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} +#' \deqn{J = -E\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]} #' -#' where: -#' -#' \deqn{\psi_a(W; \eta) = -\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)} -#' -#' \deqn{\psi_b(W; \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)} +#' See \code{\link{ddml-intro}} for how the influence function +#' and inference are derived from these components. #' #' @inheritParams ddml-intro #' @inheritParams ddml_apo @@ -128,7 +127,7 @@ ddml_late <- function(y, D, Z, X, ...) { cl <- match.call() - # == Preliminaries ================================================ + # Preliminaries -------------------------------------------------------------- dots <- list(...) messages <- resolve_messages(dots, "ddml_late", list( @@ -158,7 +157,7 @@ ddml_late <- function(y, D, Z, X, t0 <- proc.time()[3] announce_start(messages, parallel, silent) - # == Reduced-form estimation ====================================== + # Reduced-form estimation ---------------------------------------------------- # Map LATE splits/fitted to ATE's expected format. ate_splits <- if (!is.null(splits)) list( @@ -212,25 +211,28 @@ ddml_late <- function(y, D, Z, X, ensemble_type <- ate_rf$ensemble_type nensb <- ncol(ate_rf$coefficients) - # == Score construction =========================================== - - psi_b <- ate_rf$psi_b # already a list (from ddml_ate) - psi_a <- lapply(seq_len(nensb), function(j) { - array(-as.vector(ate_fs$psi_b[[j]]), - dim = c(nobs, 1, 1)) - }) - - # == Target parameter ============================================= + # Target parameter & influence function -------------------------------------- - late <- as.vector(ate_rf$coefficients) / - as.vector(ate_fs$coefficients) + late <- as.vector(ate_rf$coefficients) / as.vector(ate_fs$coefficients) 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[[j]][, 1, 1] * late[j] + - as.vector(psi_b[[j]]) - J[1, 1, j] <- mean(psi_a[[j]]) + 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 coef_names <- "LATE" @@ -238,7 +240,7 @@ ddml_late <- function(y, D, Z, X, rownames(coef) <- coef_names colnames(coef) <- ensemble_type - # == Output ======================================================= + # Output --------------------------------------------------------------------- announce_finish(t0, messages, silent) @@ -262,7 +264,7 @@ ddml_late <- function(y, D, Z, X, 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), - psi_a = psi_a, psi_b = psi_b, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, scores = scores, J = J, coef_names = coef_names, estimator_name = "Local Average Treatment Effect", @@ -286,6 +288,7 @@ ddml_late <- function(y, D, Z, X, 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 diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index c37f10a..a4769d7 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -22,15 +22,12 @@ #' 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{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: +#' \strong{Jacobian:} #' -#' \deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} +#' \deqn{J = -E[(D - r_D(X))(Z - r_Z(X))^\top]} #' -#' where: -#' -#' \deqn{\psi_a(W; \eta) = -(D - r_D(X))(Z - r_Z(X))^\top} -#' -#' \deqn{\psi_b(W; \eta) = (Z - r_Z(X))(Y - \ell(X))} +#' 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. @@ -86,7 +83,7 @@ ddml_pliv <- function(y, D, Z, X, ...) { cl <- match.call() - # == Preliminaries ================================================ + # Preliminaries -------------------------------------------------------------- dots <- list(...) messages <- resolve_messages(dots, "ddml_pliv", list( @@ -123,7 +120,7 @@ ddml_pliv <- function(y, D, Z, X, t0 <- proc.time()[3] announce_start(messages, parallel, silent) - # == Reduced-form estimation ====================================== + # Reduced-form estimation ---------------------------------------------------- # E[Y|X] y_X_res <- get_CEF(y, X, @@ -176,14 +173,13 @@ ddml_pliv <- function(y, D, Z, X, nensb <- if (is.null(ensemble_type)) 1L else length(ensemble_type) - # == Score construction =========================================== + # Target parameter & influence function -------------------------------------- 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)) - psi_a <- vector("list", nensb) - psi_b <- vector("list", 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) @@ -208,13 +204,15 @@ ddml_pliv <- function(y, D, Z, X, scores[, , j] <- X_hat * e_j J[, , j] <- -crossprod(X_hat, X_full) / nobs - psi_b[[j]] <- X_hat * as.vector(y_r) - psi_a[[j]] <- -sapply(seq_len(nD + 1), - function(k) X_hat * X_full[, k], - simplify = "array") + 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 - # == Target parameter ============================================= cn_weights <- dimnames(y_X_res$weights)[[2]] colnames(coef) <- if (is.null(cn_weights)) ensemble_type else cn_weights @@ -223,7 +221,7 @@ ddml_pliv <- function(y, D, Z, X, rownames(coef) <- c(cn_j, "(Intercept)") coef_names <- rownames(coef) - # == Output ======================================================= + # Output --------------------------------------------------------------------- ensemble_weights <- list(y_X = y_X_res$weights) mspe <- list(y_X = y_X_res$mspe) @@ -248,7 +246,7 @@ ddml_pliv <- function(y, D, Z, X, ensemble_weights = ensemble_weights, mspe = mspe, r2 = r2, - psi_a = psi_a, psi_b = psi_b, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, scores = scores, J = J, coef_names = coef_names, estimator_name = "Partially Linear IV Model", @@ -271,6 +269,7 @@ ddml_pliv <- function(y, D, Z, X, names(ensemble_weights)), call = cl, subclass = "ddml_pliv", + # ddml_pliv-specific fields learners = learners, learners_DX = learners_DX, learners_ZX = learners_ZX diff --git a/R/ddml_plm.R b/R/ddml_plm.R index 6b88af5..de75557 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -22,15 +22,12 @@ #' 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{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: +#' \strong{Jacobian:} #' -#' \deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} +#' \deqn{J = -E[(D - r_0(X))(D - r_0(X))^\top]} #' -#' where: -#' -#' \deqn{\psi_a(W; \eta) = -(D - r(X))(D - r(X))^\top} -#' -#' \deqn{\psi_b(W; \eta) = (D - r(X))(Y - \ell(X))} +#' 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 @@ -111,7 +108,7 @@ ddml_plm <- function(y, D, X, ...) { cl <- match.call() - # == Preliminaries ================================================ + # Preliminaries -------------------------------------------------------------- dots <- list(...) messages <- resolve_messages(dots, "ddml_plm", list( @@ -143,7 +140,7 @@ ddml_plm <- function(y, D, X, t0 <- proc.time()[3] announce_start(messages, parallel, silent) - # == Reduced-form estimation ====================================== + # Reduced-form estimation ---------------------------------------------------- # E[Y|X] y_X_res <- get_CEF(y, X, @@ -178,13 +175,13 @@ ddml_plm <- function(y, D, X, nensb <- if (is.null(ensemble_type)) 1L else length(ensemble_type) - # == Score construction =========================================== + # Target parameter & influence function -------------------------------------- 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)) - psi_a <- vector("list", nensb) - psi_b <- vector("list", 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] @@ -199,13 +196,15 @@ ddml_plm <- function(y, D, X, scores[, , j] <- X_full * e_j J[, , j] <- -crossprod(X_full) / nobs - psi_b[[j]] <- X_full * as.vector(y_r) - psi_a[[j]] <- -sapply(seq_len(nD + 1), - function(k) X_full * X_full[, k], - simplify = "array") + J_inv <- csolve(matrix(J[, , j], nD + 1, nD + 1)) + inf_func[, , j] <- matrix(scores[, , j], nobs, nD + 1) %*% t(J_inv) + + U <- X_full %*% t(J_inv) + dinf_dtheta[, , , j] <- sapply(seq_len(nD + 1), function(k) { + -X_full[, k] * U + }, simplify = "array") }#FOR - # == Target parameter ============================================= cn_weights <- dimnames(y_X_res$weights)[[2]] colnames(coef) <- if (is.null(cn_weights)) ensemble_type else cn_weights @@ -214,7 +213,7 @@ ddml_plm <- function(y, D, X, rownames(coef) <- c(cn_j, "(Intercept)") coef_names <- rownames(coef) - # == Output ======================================================= + # Output --------------------------------------------------------------------- # Ensemble metrics ensemble_weights <- list(y_X = y_X_res$weights) @@ -234,7 +233,7 @@ ddml_plm <- function(y, D, X, ensemble_weights = ensemble_weights, mspe = mspe, r2 = r2, - psi_a = psi_a, psi_b = psi_b, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, scores = scores, J = J, coef_names = coef_names, estimator_name = "Partially Linear Model", @@ -255,6 +254,7 @@ ddml_plm <- function(y, D, X, names(ensemble_weights)), call = cl, subclass = "ddml_plm", + # ddml_plm-specific fields learners = learners, learners_DX = learners_DX ) diff --git a/R/lincom.R b/R/lincom.R index 28527b2..9805093 100644 --- a/R/lincom.R +++ b/R/lincom.R @@ -10,32 +10,55 @@ #' 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{\lambda = R'\hat\theta}. Inference is based on the -#' influence function +#' \eqn{\gamma = R'\hat\theta}. #' -#' \deqn{\phi_i^\lambda = R' \hat J^{-1} m_i -#' + \sum_c \theta_c R_{\cdot c}^{IF}(W_i) R_{c \cdot}} +#' The influence function for \eqn{\gamma} is obtained via +#' the product rule: #' -#' where the second term is the delta-method correction for -#' estimated weights (when \code{R_ifmat} is supplied). +#' \deqn{\phi_\gamma(W_i; \theta, \eta, J, R) +#' = R' \phi_\theta(W_i; \theta, \eta, J) +#' + \phi_R(W_i)' \theta} #' +#' where \eqn{\phi_\theta} is the influence function of +#' \eqn{\hat\theta} (see \code{\link{ddml-intro}}) and +#' \eqn{\phi_R(W_i)} is the \eqn{p}-vector of influence +#' functions for the weight vector \eqn{R}, i.e., the +#' \eqn{i}-th row of \code{inf_func_R}. The second term +#' vanishes when \eqn{R} is fixed. +#' +#' The leverage for \eqn{\gamma} is defined in +#' \code{\link{hatvalues.ddml_lincom}}. #' The resulting \code{ddml_lincom} object supports all standard #' inference methods: \code{vcov}, \code{confint}, \code{summary}, #' and \code{tidy}. For \code{ddml_rep} objects, \code{lincom} #' can be called directly to obtain a \code{ddml_lincom_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.ddml_lincom}} and +#' \code{\link{hatvalues.ddml_lincom}} for more details. +#' +#' @inheritParams ddml #' @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 R_ifmat An optional \eqn{(n \times p)}{n x p} matrix -#' of influence functions for the weight vector \eqn{R}. -#' When supplied, a delta-method correction is applied. -#' When \code{NULL} (default), \eqn{R} is treated as fixed. #' @param ensemble_idx Integer index of the ensemble type to #' use. Default 1. #' @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)}{n x p} matrix +#' of influence functions \eqn{\phi_{R,i}} for the +#' weight vector \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{"ddml_lincom"} (for @@ -87,9 +110,12 @@ lincom <- function(fit, R, ...) { #' @rdname lincom #' @export #' @method lincom ddml -lincom.ddml <- function(fit, R, R_ifmat = NULL, - ensemble_idx = 1, - labels = NULL, ...) { +lincom.ddml <- function(fit, R, + ensemble_idx = 1, + labels = NULL, + inf_func_R = NULL, + dinf_dR = NULL, + ...) { R <- as.matrix(R) p <- nrow(fit$coefficients) q <- ncol(R) @@ -100,20 +126,36 @@ lincom.ddml <- function(fit, R, R_ifmat = NULL, att <- fit$coefficients[, ensemble_idx] lincom_coef <- as.numeric(crossprod(R, att)) - # Unit-level IF for theta: phi_i = J^{-1} psi_i - sc <- fit$scores[, , ensemble_idx, drop = FALSE] - dim(sc) <- dim(sc)[1:2] - J_j <- fit$J[, , ensemble_idx, drop = FALSE] - dim(J_j) <- dim(J_j)[1:2] - theta_if <- sc %*% t(csolve(J_j)) # n x p + # Unit-level IF for theta: phi_i + theta_if <- fit$inf_func[, , ensemble_idx, drop = FALSE] + dim(theta_if) <- dim(theta_if)[1:2] # Combined IF for R'theta # Term 1: R' phi_i^theta lincom_if <- theta_if %*% R # n x q # Term 2: delta-method correction (when R estimated) - if (!is.null(R_ifmat)) { - stopifnot(nrow(R_ifmat) == n, ncol(R_ifmat) == p) - lincom_if <- lincom_if + R_ifmat %*% (att * R) + if (!is.null(inf_func_R)) { + stopifnot(nrow(inf_func_R) == n, ncol(inf_func_R) == p) + lincom_if <- lincom_if + inf_func_R %*% (att * (R != 0)) + }#IF + + # Map Structural Leverage + dinf_dtheta <- NULL + if (!is.null(fit$dinf_dtheta)) { + dinf_j <- fit$dinf_dtheta[, , , ensemble_idx, drop = FALSE] + dinf_lc <- array(NA_real_, dim = c(n, q, q, 1)) + for (i in seq_len(n)) { + dinf_i <- matrix(dinf_j[i, , , 1], p, p) + # Structural Leverage: R^T * dinf_i * R + dinf_lc[i, , , 1] <- t(R) %*% dinf_i %*% R + }#FOR + dinf_dtheta <- dinf_lc + + if (!is.null(dinf_dR)) { + stopifnot(dim(dinf_dR)[1:3] == c(n, q, q)) + if (length(dim(dinf_dR)) == 3) dim(dinf_dR) <- c(n, q, q, 1) + dinf_dtheta <- dinf_dtheta + dinf_dR + }#IF }#IF # Labels @@ -129,12 +171,14 @@ lincom.ddml <- function(fit, R, R_ifmat = NULL, coefficients = coef_mat, scores = array(-lincom_if, dim = c(n, q, 1)), J = array(diag(-1, q), dim = c(q, q, 1)), + inf_func = array(lincom_if, dim = c(n, q, 1)), + dinf_dtheta = dinf_dtheta, coef_names = labels, nobs = n, estimator_name = "Linear Combination", ensemble_type = "lincom", cluster_variable = fit$cluster_variable, - fixed_R = is.null(R_ifmat) + fixed_R = is.null(inf_func_R) ) class(obj) <- "ddml_lincom" obj @@ -144,12 +188,14 @@ lincom.ddml <- function(fit, R, R_ifmat = NULL, # Build a temporary ddml object for delegation. lincom_to_ddml <- function(lc) { + # dinf_dtheta evaluates to NULL by default + q <- nrow(lc$coefficients) ddml( coefficients = lc$coefficients, scores = lc$scores, J = lc$J, - psi_a = list(NULL), - psi_b = list(NULL), + inf_func = lc$inf_func, + dinf_dtheta = lc$dinf_dtheta, nobs = lc$nobs, coef_names = lc$coef_names, estimator_name = lc$estimator_name, @@ -182,6 +228,13 @@ coef.ddml_lincom <- function(object, ...) { nobs.ddml_lincom <- function(object, ...) object$nobs #' @rdname lincom +#' @details +#' \code{vcov.ddml_lincom} computes the sandwich variance of +#' \eqn{\lambda = R'\hat\theta} using the influence function +#' \eqn{\phi_{\lambda,i} = R' \phi_{\theta,i} +#' + \sum_c \theta_c \phi_{R_c,i}}, +#' where the second term is included only when +#' \code{inf_func_R} was supplied to \code{lincom}. #' @param type Character. Variance estimator type #' (\code{"HC0"} or \code{"HC1"}). \code{"HC3"} is not #' supported for linear combinations. @@ -191,8 +244,7 @@ vcov.ddml_lincom <- function(object, type = "HC1", ...) { type <- match.arg(type, c("HC0", "HC1", "HC3")) if (type == "HC3") { stop("HC3 standard errors (generalized leverage) are not ", - "currently supported for linear combinations.", - call. = FALSE) + "currently supported for linear combinations.", call. = FALSE) }#IF vcov(lincom_to_ddml(object), ensemble_idx = 1, type = type) }#VCOV.DDML_LINCOM @@ -212,8 +264,7 @@ confint.ddml_lincom <- function(object, parm, level = 0.95, type <- match.arg(type, c("HC0", "HC1", "HC3")) if (type == "HC3") { stop("HC3 standard errors (generalized leverage) are not ", - "currently supported for linear combinations.", - call. = FALSE) + "currently supported for linear combinations.", call. = FALSE) }#IF confint(lincom_to_ddml(object), parm = parm, level = level, ensemble_idx = 1, type = type, uniform = uniform, @@ -227,8 +278,7 @@ summary.ddml_lincom <- function(object, type = "HC1", ...) { type <- match.arg(type, c("HC0", "HC1", "HC3")) if (type == "HC3") { stop("HC3 standard errors (generalized leverage) are not ", - "currently supported for linear combinations.", - call. = FALSE) + "currently supported for linear combinations.", call. = FALSE) }#IF summary(lincom_to_ddml(object), type = type) }#SUMMARY.DDML_LINCOM @@ -248,8 +298,7 @@ tidy.ddml_lincom <- function(x, conf.int = FALSE, type <- match.arg(type, c("HC0", "HC1", "HC3")) if (type == "HC3") { stop("HC3 standard errors (generalized leverage) are not ", - "currently supported for linear combinations.", - call. = FALSE) + "currently supported for linear combinations.", call. = FALSE) }#IF tidy(lincom_to_ddml(x), ensemble_idx = 1, conf.int = conf.int, conf.level = conf.level, @@ -257,6 +306,25 @@ tidy.ddml_lincom <- function(x, conf.int = FALSE, }#TIDY.DDML_LINCOM #' @rdname lincom +#' @details +#' \code{hatvalues.ddml_lincom} computes the observation-level +#' leverage for \eqn{\gamma}. The leverage decomposes as: +#' +#' \deqn{h_\gamma(W_i; \theta, \eta, J, R) +#' = \underbrace{R' +#' \left(-\frac{1}{n} +#' \frac{\partial \phi_\theta(W_i; \theta, +#' \eta, J)}{\partial \theta}\right) +#' R}_{\text{structural leverage}} +#' + \underbrace{\theta' +#' \left(-\frac{1}{n} +#' \frac{\partial \phi_R(W_i)} +#' {\partial R}\right) +#' \theta}_{\text{weighting leverage}}} +#' +#' The structural leverage is computed from the parent +#' model's \code{dinf_dtheta}; the weighting leverage +#' requires \code{dinf_dR} to be supplied to \code{lincom}. #' @param model A \code{ddml_lincom} or \code{ddml_lincom_rep} object. #' @export #' @method hatvalues ddml_lincom @@ -270,13 +338,13 @@ hatvalues.ddml_lincom <- function(model, ...) { #' @rdname lincom #' @export #' @method lincom ddml_rep -lincom.ddml_rep <- function(fit, R, R_ifmat = NULL, +lincom.ddml_rep <- function(fit, R, inf_func_R = NULL, dinf_dR = NULL, ensemble_idx = 1, labels = NULL, ...) { # Apply lincom.ddml to each rep lc_fits <- lapply(fit$fits, function(f) { - lincom(f, R = R, R_ifmat = R_ifmat, ensemble_idx = ensemble_idx, - labels = labels) + lincom(f, R = R, inf_func_R = inf_func_R, dinf_dR = dinf_dR, + ensemble_idx = ensemble_idx, labels = labels, ...) }) obj <- list( @@ -286,7 +354,7 @@ lincom.ddml_rep <- function(fit, R, R_ifmat = NULL, coef_names = lc_fits[[1]]$coef_names, estimator_name = "Linear Combination", ensemble_type = "lincom", - fixed_R = is.null(R_ifmat) + fixed_R = is.null(inf_func_R) ) class(obj) <- "ddml_lincom_rep" obj @@ -411,9 +479,7 @@ print.ddml_lincom <- function(x, ...) { print.ddml_lincom_rep <- function(x, ...) { cat("DDML Linear Combination (replicated)\n") cat("Obs:", x$nobs, " Resamples:", x$nresamples) - if (!is.null(x$fixed_R) && !x$fixed_R) { - cat(" (delta-method)") - }#IF + if (!is.null(x$fixed_R) && !x$fixed_R) cat(" (delta-method)") cat("\n\n") cat("Use summary() for aggregated inference.\n") invisible(x) From e9ac868d67c5ccebb1df6f9c489c8d8f25d03293 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Fri, 20 Mar 2026 16:48:08 -0500 Subject: [PATCH 32/46] introduce ral object to unify inference --- R/ddml-package.R | 29 +- R/ddml.R | 559 ++++++------------------------------- R/ddml_apo.R | 1 + R/ddml_plm.R | 3 +- R/ddml_rep.R | 618 +++++++---------------------------------- R/help_functions.R | 40 +-- R/lincom.R | 431 +++++++---------------------- R/ral.R | 677 +++++++++++++++++++++++++++++++++++++++++++++ R/ral_rep.R | 592 +++++++++++++++++++++++++++++++++++++++ 9 files changed, 1606 insertions(+), 1344 deletions(-) create mode 100644 R/ral.R create mode 100644 R/ral_rep.R diff --git a/R/ddml-package.R b/R/ddml-package.R index d8051dc..6cfff95 100644 --- a/R/ddml-package.R +++ b/R/ddml-package.R @@ -1,15 +1,28 @@ -#' ddml: Double/Debiased Machine Learning in R +#' 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 +#' @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 -#' 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. #' #' @keywords internal "_PACKAGE" diff --git a/R/ddml.R b/R/ddml.R index 49e5aad..3ac35b3 100644 --- a/R/ddml.R +++ b/R/ddml.R @@ -37,8 +37,7 @@ #' \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 +#' Inference is based on the influence function. Define the Jacobian #' #' \deqn{J(\theta, \eta) = E\!\left[ #' \frac{\partial m(W; \theta, \eta)} @@ -63,8 +62,20 @@ #' {\partial \theta'}.} #' #' HC1 and HC3 variance estimators are described in -#' \code{\link{vcov.ddml}}. The generalized leverage used in -#' HC3 is defined in \code{\link{hatvalues.ddml}}. +#' \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: @@ -105,11 +116,11 @@ #' 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 list of length \code{nensb} -#' containing the derivatives of the influence functions with -#' respect to \eqn{\theta}. Each element is an \code{(n x p x p)} -#' array. Used internally by \code{\link{hatvalues.ddml}} -#' for HC3 inference.} +#' \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 @@ -140,9 +151,9 @@ #' @section S3 methods: #' The following generic methods are available for all #' \code{ddml} objects: \code{\link{summary.ddml}}, -#' \code{\link{coef.ddml}}, \code{\link{vcov.ddml}}, -#' \code{\link{confint.ddml}}, \code{\link{hatvalues.ddml}}, -#' \code{\link{nobs.ddml}}, \code{\link{tidy.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}}. #' @@ -244,8 +255,8 @@ NULL #' @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.ddml}}, -#' \code{\link{vcov.ddml}}, and \code{\link{tidy.ddml}}. +#' \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 @@ -302,7 +313,7 @@ NULL #' 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 <- list(array(1, 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, @@ -362,7 +373,7 @@ ddml <- function(coefficients, scores, J, inf_func, 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 @@ -378,6 +389,8 @@ ddml <- function(coefficients, scores, J, inf_func, 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, @@ -386,325 +399,15 @@ ddml <- function(coefficients, scores, J, inf_func, splits = splits, call = call), list(...)) - cls <- if (!is.null(subclass)) c(subclass, "ddml") else "ddml" + cls <- if (!is.null(subclass)) c(subclass, "ddml", "ral") else + c("ddml", "ral") class(obj) <- cls obj }#DDML # S3 methods ================================================================ - -#' Extract Model Coefficients -#' -#' @description Extracts the estimated coefficients -#' from a DDML model for the specified or default -#' ensemble type. -#' -#' @param object An object of class \code{ddml}. -#' @param ... Currently unused. -#' -#' @return Named vector (single ensemble) or matrix -#' (multiple ensembles). -#' -#' @examples -#' \donttest{ -#' # Fit a PLM and extract coefficients -#' 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) -#' coef(plm_fit) -#' } -#' -#' @family ddml inference -#' @method coef ddml -#' @export -coef.ddml <- 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.DDML - -#' Extract Number of Observations -#' -#' @description Returns the number of observations -#' used to fit the DDML model. -#' -#' @param object An object of class \code{ddml}. -#' @param ... Currently unused. -#' -#' @return An integer specifying the number of observations. -#' -#' @method nobs ddml -#' @importFrom stats nobs -#' @export -nobs.ddml <- function(object, ...) { - object$nobs -}#NOBS.DDML - -#' Extract Generalized Leverage (Hat Values) -#' -#' @description Computes the generalized leverage (hat values) for a DDML -#' estimator. These values are used internally to compute -#' heteroskedasticity-robust HC3 standard errors. -#' -#' @details See \code{\link{ddml-intro}} for the definition of -#' the influence function \eqn{\phi_\theta(W_i; -#' \theta, \eta, J)}. The generalized leverage is -#' -#' \deqn{h_\theta(W_i; \theta, \eta, J) -#' = \mathrm{tr}\!\left( -#' -\frac{1}{n} -#' \frac{\partial \phi_\theta(W_i; \theta, \eta, J)} -#' {\partial \theta} -#' \right).} -#' -#' This function returns the estimated hat values -#' \eqn{\hat{h}_{\theta,i} = -#' h_\theta(W_i; \hat\theta, \hat\eta, \hat{J})}. -#' -#' @param model An object of class \code{ddml}. -#' @param ensemble_idx Integer index of the ensemble type to extract leverage -#' values for. Defaults to 1. -#' @param ... Currently unused. -#' -#' @return A numeric vector of generalized leverage values. -#' -#' @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) -#' h = hatvalues(plm_fit) -#' head(h) -#' } -#' -#' @seealso \code{\link{vcov.ddml}} for the use of leverage in HC3 standard errors. -#' -#' @family ddml inference -#' @importFrom stats hatvalues -#' @export -hatvalues.ddml <- function(model, ensemble_idx = 1, ...) { - validate_method_args(model, ensemble_idx = ensemble_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 <- dim(model$J)[1] - dinf_j <- model$dinf_dtheta[, , , ensemble_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.DDML - -#' Variance-Covariance Matrix for DDML Estimators -#' -#' @description Computes a heteroskedasticity-robust -#' variance-covariance matrix for the DDML estimator -#' \eqn{\hat\theta}. -#' -#' @details See \code{\link{ddml-intro}} for the DML framework -#' and the definition of the influence function -#' \eqn{\phi_\theta}. Let \eqn{\hat\phi_i = -#' \phi_\theta(W_i; \hat\theta, \hat\eta, \hat{J})} -#' denote the estimated influence function evaluated at -#' observation \eqn{i}. This function provides three -#' variance estimator variants: -#' -#' \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}} -#' -#' where \eqn{p} is the dimension of \eqn{\theta}. -#' -#' \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 generalized leverage; -#' see \code{\link{hatvalues.ddml}}. -#' -#' @param object An object of class \code{ddml}. -#' @param ensemble_idx Integer index of the ensemble type to -#' use. Defaults to 1 (first ensemble type). -#' @param type Character string specifying the -#' variance-covariance estimator. 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. -#' -#' @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) -#' vcov(plm_fit) -#' vcov(plm_fit, type = "HC3") -#' } -#' -#' @seealso \code{\link{hatvalues.ddml}}, -#' \code{\link{confint.ddml}}, -#' \code{\link{summary.ddml}} -#' -#' @family ddml inference -#' @method vcov ddml -#' @export -vcov.ddml <- function(object, ensemble_idx = 1, - type = "HC1", ...) { - type <- validate_method_args(object, ensemble_idx = ensemble_idx, type = type) - - if_j <- object$inf_func[, , ensemble_idx, drop = FALSE] - dim(if_j) <- dim(if_j)[1:2] - p <- ncol(if_j) - - # Cluster aggregation: rowsum influence functions to cluster level - clustered <- !is.null(object$cluster_variable) && - length(unique(object$cluster_variable)) < nrow(if_j) - if (clustered) if_j <- rowsum(if_j, object$cluster_variable) - - n_eff <- nrow(if_j) - if (type == "HC3") { - h <- stats::hatvalues(object, ensemble_idx = ensemble_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.DDML - -#' Confidence Intervals for DDML Estimators -#' -#' @description Computes confidence intervals for one or more -#' parameters in a fitted DDML model. -#' -#' @param object An object of class \code{ddml}. -#' @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. -#' @inheritParams vcov.ddml -#' @param uniform Logical. If \code{TRUE}, computes -#' uniform confidence bands using the -#' multiplier bootstrap. The critical value replaces -#' the pointwise Gaussian quantile. Default -#' \code{FALSE}. -#' @param bootstraps Integer number of bootstrap draws for -#' the multiplier bootstrap. 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 uniform critical -#' value. -#' -#' @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) -#' confint(plm_fit) -#' confint(plm_fit, parm = "D1") -#' confint(plm_fit, level = 0.90) -#' confint(plm_fit, uniform = TRUE) -#' } -#' -#' @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.ddml}} -#' -#' @family ddml inference -#' @method confint ddml -#' @importFrom stats vcov -#' @export -confint.ddml <- function(object, parm, level = 0.95, - ensemble_idx = 1, - type = "HC1", - uniform = FALSE, - bootstraps = 999L, ...) { - cf <- object$coefficients[, ensemble_idx] - cf_names <- object$coef_names - names(cf) <- cf_names - - if (missing(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, ensemble_idx = ensemble_idx, type = type) - se_all <- sqrt(diag(V)) - se <- se_all[parm] - - if (uniform) { - # Multiplier bootstrap - inf_func <- object$inf_func[, , ensemble_idx, drop = FALSE] - dim(inf_func) <- dim(inf_func)[1:2] - cl <- object$cluster_variable # check for clustering - if (!is.null(cl) && length(unique(cl)) < nrow(inf_func)) { - inf_func <- rowsum(inf_func, cl) - }#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) - bT <- apply(bres, 1, function(b) max(abs(b / sigma))) - 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.DDML +# 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}. @@ -723,10 +426,12 @@ confint.ddml <- function(object, parm, level = 0.95, #' 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.ddml}} for the HC0/HC1/HC3 formulas. +#' \code{\link{vcov.ral}} for the HC0/HC1/HC3 formulas. #' #' @param object An object of class \code{ddml}. -#' @inheritParams vcov.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: @@ -753,50 +458,29 @@ confint.ddml <- function(object, parm, level = 0.95, #' summary(plm_fit, type = "HC3") #' } #' -#' @seealso \code{\link{vcov.ddml}} +#' @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 - - nensb <- length(ens_type) - p <- nrow(object$coefficients) - inf <- array(0, dim = c(p, 4, nensb)) - for (j in seq_len(nensb)) { - theta_j <- object$coefficients[, j] - - V <- stats::vcov(object, ensemble_idx = j, type = type) - se <- sqrt(diag(V)) - z_val <- theta_j / se - p_val <- 2 * stats::pnorm(abs(z_val), lower.tail = FALSE) + object$fit_labels <- ens_type - inf[, 1, j] <- theta_j - inf[, 2, j] <- se - inf[, 3, j] <- z_val - inf[, 4, j] <- p_val - }#FOR + # Delegate table computation to ral + result <- summary.ral(object, type = type, ...) - dimnames(inf) <- list( - object$coef_names, - c("Estimate", "Std. Error", "z value", "Pr(>|z|)"), - ens_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 - result <- list( - coefficients = inf, - type = type, - model_type = class(object)[1], - estimator_name = object$estimator_name, - nobs = object$nobs, - sample_folds = object$sample_folds, - shortstack = object$shortstack, - ensemble_type = ens_type) class(result) <- c( paste0("summary.", class(object)[1]), "summary.ddml") @@ -825,24 +509,8 @@ print.summary.ddml <- function(x, digits = 3, ...) { }#IF cat("\n\n") - nensb <- dim(x$coefficients)[3] - for (j in seq_len(nensb)) { - if (nensb > 1) { - cat("Ensemble type:", - dimnames(x$coefficients)[[3]][j], "\n") - }#IF - tbl <- x$coefficients[, , j] - if (!is.matrix(tbl)) { - tbl <- matrix(tbl, nrow = 1, - dimnames = list( - dimnames(x$coefficients)[[1]], - dimnames(x$coefficients)[[2]])) - }#IF - stats::printCoefmat(tbl, digits = digits, - has.Pvalue = TRUE, - signif.stars = TRUE) - if (j < nensb) cat("\n") - }#FOR + print_coef_tables(x$coefficients, fit_label = "Ensemble type", + digits = digits) invisible(x) }#PRINT.SUMMARY.DDML @@ -855,43 +523,27 @@ generics::tidy #' @export generics::glance -#' Tidy a ddml Object +#' Tidy a DDML Object #' -#' Extracts coefficient estimates, standard errors, test -#' statistics, and p-values from a \code{ddml} estimator in a -#' format compatible with \pkg{modelsummary} and the -#' \pkg{broom} ecosystem. +#' 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 (first ensemble type). Set to -#' \code{NULL} to return results for all ensemble types. -#' @param conf.int Logical. Include confidence interval -#' columns? Default \code{FALSE}. -#' @param conf.level Confidence level for intervals. -#' Default 0.95. -#' @param type Character string specifying the -#' variance-covariance estimator. One of \code{"HC1"} -#' (default), \code{"HC0"}, or \code{"HC3"}. -#' @param uniform Logical. If \code{TRUE}, computes uniform confidence intervals -#' using the multiplier bootstrap. Only used when -#' \code{conf.int = TRUE}. Default \code{FALSE}. -#' @param bootstraps Integer number of bootstrap draws for -#' the multiplier bootstrap. Only used when -#' \code{uniform = TRUE}. Default 999. +#' 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}. If -#' \code{conf.int = TRUE}, also \code{conf.low} and -#' \code{conf.high}. -#' -#' @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. +#' \code{estimate}, \code{std.error}, \code{statistic}, +#' \code{p.value}, and \code{ensemble_type}. #' #' @examples #' \donttest{ @@ -912,73 +564,26 @@ tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, type = "HC1", uniform = FALSE, bootstraps = 999L, ...) { - type <- match.arg(type, c("HC1", "HC0", "HC3")) - - s <- summary(x, type = type) - inf <- s$coefficients - nensb <- dim(inf)[3] - p <- dim(inf)[1] - - if (is.null(ensemble_idx)) { - j_seq <- seq_len(nensb) - } else { - if (any(ensemble_idx < 1) || any(ensemble_idx > nensb)) { - stop(sprintf("ensemble_idx must be between 1 and %d", nensb), call. = FALSE) - }#IF - j_seq <- ensemble_idx - }#IFELSE - - # Generate tidy output by ensemble - n_rows <- length(j_seq) * p - term <- rep(dimnames(inf)[[1]], length(j_seq)) - ensemble_type <- 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, - ensemble_type = ensemble_type, - stringsAsFactors = FALSE - ) - - if (conf.int) { - ci_list <- lapply(j_seq, function(j) { - stats::confint(x, ensemble_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(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 +#' Glance at a DDML Object #' -#' Returns a one-row summary of model-level statistics, -#' compatible with \pkg{modelsummary} and the \pkg{broom} -#' ecosystem. +#' 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} with columns -#' \code{nobs}, \code{sample_folds}, \code{shortstack}, -#' \code{ensemble_type}, and \code{model_type}. +#' @return A one-row \code{data.frame}. #' #' @examples #' \donttest{ @@ -991,19 +596,21 @@ tidy.ddml <- function(x, ensemble_idx = 1, conf.int = FALSE, #' glance(plm_fit) #' } #' -#' @seealso \code{\link{tidy.ddml}}, -#' \code{\link{summary.ddml}} -#' #' @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, + 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, + estimator_name = if (is.null(x$estimator_name)) { + class(x)[1] + } else { + x$estimator_name + }, stringsAsFactors = FALSE ) }#GLANCE.DDML diff --git a/R/ddml_apo.R b/R/ddml_apo.R index 65b02e1..af8f091 100644 --- a/R/ddml_apo.R +++ b/R/ddml_apo.R @@ -198,6 +198,7 @@ ddml_apo <- function(y, D, X, 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) diff --git a/R/ddml_plm.R b/R/ddml_plm.R index de75557..4b6fd99 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -196,16 +196,17 @@ ddml_plm <- function(y, D, X, scores[, , j] <- X_full * e_j J[, , j] <- -crossprod(X_full) / nobs + # 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 - cn_weights <- dimnames(y_X_res$weights)[[2]] colnames(coef) <- if (is.null(cn_weights)) ensemble_type else cn_weights cn_j <- colnames(D) diff --git a/R/ddml_rep.R b/R/ddml_rep.R index 5481f06..f1c062c 100644 --- a/R/ddml_rep.R +++ b/R/ddml_rep.R @@ -1,105 +1,10 @@ -# Internal helpers ================================================================ - -# Spectral-norm median of PSD matrices via SDP (CVXR). +# ddml_rep: DML-specific replicated inference =================================== # -# 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") - - result <- CVXR::psolve(CVXR::Problem(CVXR::Minimize(obj))) - - if (result$status != "optimal") { - warning("SDP solver returned status '", result$status, - "'; falling back to element-wise median.", call. = FALSE) - arr <- array(unlist(lapply(matrices, as.vector)), dim = c(p, p, R)) - return(apply(arr, c(1, 2), stats::median)) - }#IF - - V_sol <- result$getValue(V) - (V_sol + t(V_sol)) / 2 # symmetrize to avoid minimal numerical errors -}#SPECTRAL_MEDIAN_PSD - -# Core aggregation workhorse. +# Class hierarchy: +# ddml_rep > ral_rep — adds DML-specific fields and display # -# 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 then 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 - nensb <- length(object$ensemble_type) - p <- length(object$coef_names) - - # Collect per-replication estimates - coef_array <- array(0, dim = c(p, nensb, R)) - vcov_array <- array(0, dim = c(p, p, nensb, R)) - for (r in seq_len(R)) { - fit <- object$fits[[r]] - coef_array[, , r] <- fit$coefficients - for (j in seq_len(nensb)) { - vcov_array[, , j, r] <- stats::vcov(fit, ensemble_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, nensb)) - for (j in seq_len(nensb)) { - 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 = nensb) - for (j in seq_len(nensb)) { - 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 +# Inference methods (coef, vcov, confint, tidy, glance) are +# inherited from ral_rep in ral_rep.R. # Exported functions =========================================================== @@ -113,7 +18,8 @@ aggregate_reps <- function(object, aggregation = "median", type = "HC1") { #' primary class, coefficient names, ensemble type, and #' number of observations. #' -#' @return An object of class \code{"ddml_rep"} with fields: +#' @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.} @@ -145,50 +51,52 @@ aggregate_reps <- function(object, aggregation = "median", type = "HC1") { 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) + 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) + stop("Element ", i, + " does not inherit from class 'ddml'.", + call. = FALSE) }#IF }#FOR - primary <- vapply(fits, function(f) class(f)[1], character(1)) + 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) + 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) + 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 (!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) + stop("Fit ", i, " has different 'nobs' than fit 1.", + call. = FALSE) }#IF }#FOR - # Return ddml_rep object + # Build via ral_rep, then layer DML fields ens_type <- ref$ensemble_type if (is.null(ens_type)) ens_type <- "single base learner" - structure( - list( - fits = fits, - nresamples = length(fits), - model_type = primary[1], - coef_names = ref$coef_names, - estimator_name= if (!is.null(ref$estimator_name)) ref$estimator_name - else primary[1], - ensemble_type = ens_type, - nobs = ref$nobs, - sample_folds = ref$sample_folds, - shortstack = ref$shortstack - ), - class = "ddml_rep" - ) + + 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 @@ -228,13 +136,13 @@ ddml_replicate <- function(fn, ..., resamples = 5, silent = FALSE) { dots <- list(...) dots$silent <- silent - # Suppress inner start/finish messages to avoid console spam + # 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, "]") @@ -243,66 +151,9 @@ ddml_replicate <- function(fn, ..., resamples = 5, ddml_rep(fits) }#DDML_REPLICATE -# S3 methods =================================================================== - -#' Extract a Single Fit from a ddml_rep Object -#' -#' @param x A \code{ddml_rep} object. -#' @param i Integer index of the fit to extract. -#' -#' @return The \code{i}-th \code{ddml} fit. -#' -#' @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) -#' coef(reps[[1]]) -#' } -#' -#' @export -#' @method [[ ddml_rep -`[[.ddml_rep` <- function(x, i) { - x$fits[[i]] -}#[[.DDML_REP - -#' Number of Resamples in a ddml_rep Object -#' -#' @param x A \code{ddml_rep} object. -#' -#' @return Integer number of resamples. -#' -#' @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) -#' length(reps) -#' } -#' -#' @export -#' @method length ddml_rep -length.ddml_rep <- function(x) x$nresamples - -#' Extract Number of Observations from a ddml_rep Object -#' -#' @param object A \code{ddml_rep} object. -#' @param ... Currently unused. -#' -#' @return An integer specifying the number of observations. -#' -#' @importFrom stats nobs -#' @export -#' @method nobs ddml_rep -nobs.ddml_rep <- function(object, ...) object$nobs +# DML-specific S3 methods ===================================================== +# Inference methods (coef, nobs, vcov, confint, [[, length) +# are inherited from ral_rep in ral_rep.R. #' @rdname ddml_rep #' @@ -321,211 +172,15 @@ print.ddml_rep <- function(x, ...) { invisible(x) }#PRINT.DDML_REP -#' Extract Aggregated Coefficients from a ddml_rep Object -#' -#' @param object A \code{ddml_rep} object. -#' @param aggregation Character string: \code{"median"} -#' (default), \code{"mean"}, or \code{"spectral"}. -#' See \code{\link{summary.ddml_rep}} for details. -#' @param ... Additional arguments. -#' -#' @return Named vector (single ensemble) or matrix -#' (multiple ensembles). -#' -#' @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) -#' coef(reps) -#' coef(reps, aggregation = "mean") -#' } -#' -#' @seealso \code{\link{summary.ddml_rep}} for the -#' aggregation equations. -#' -#' @export -#' @method coef ddml_rep -coef.ddml_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$ensemble_type - if (ncol(cf) == 1) cf <- drop(cf) - cf -}#COEF.DDML_REP - -#' Variance-Covariance Matrix for ddml_rep Objects -#' -#' Returns a variance-covariance matrix from cross-resample -#' aggregation. -#' -#' @param object A \code{ddml_rep} object. -#' @param ensemble_idx Integer index of the ensemble type. -#' Defaults to 1. -#' @inheritParams coef.ddml_rep -#' @inheritParams vcov.ddml -#' @param ... Currently unused. -#' -#' @return A \eqn{p \times p}{p x p} variance-covariance matrix. -#' -#' @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) -#' vcov(reps) -#' } -#' -#' @seealso \code{\link{summary.ddml_rep}} for the -#' aggregation equations. -#' -#' @export -#' @method vcov ddml_rep -vcov.ddml_rep <- function(object, ensemble_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[, , ensemble_idx] - if (!is.matrix(V)) { - V <- matrix(V, nrow = length(object$coef_names), - ncol = length(object$coef_names)) - }#IF - rownames(V) <- colnames(V) <- object$coef_names - V -}#VCOV.DDML_REP - -#' Confidence Intervals for ddml_rep Objects -#' -#' @param object A \code{ddml_rep} object. -#' @inheritParams confint.ddml -#' @param ensemble_idx Integer index of the ensemble type. -#' Defaults to 1. -#' @inheritParams coef.ddml_rep -#' @inheritParams vcov.ddml -#' @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 uniform -#' critical value. -#' -#' @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) -#' confint(reps) -#' confint(reps, level = 0.90) -#' } -#' -#' @seealso \code{\link{summary.ddml_rep}} for the -#' aggregation equations. -#' -#' @importFrom stats confint coef -#' @export -#' @method confint ddml_rep -confint.ddml_rep <- function(object, parm, - level = 0.95, - ensemble_idx = 1, - aggregation = c("median", "mean", "spectral"), - type = "HC1", - uniform = FALSE, - bootstraps = 999L, ...) { - # Aggregae coefficients and vcov matrices - aggregation <- match.arg(aggregation) - agg <- aggregate_reps(object, aggregation = aggregation, type = type) - cf <- agg$coefficients[, ensemble_idx] - se <- agg$se[, ensemble_idx] - cf_names <- object$coef_names - names(cf) <- cf_names - names(se) <- cf_names - - # Select parameters & results - if (missing(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 intervalus - if (uniform) { - R <- object$nresamples - crit_vals <- vapply(seq_len(R), function(r) { - ci_r <- confint(object$fits[[r]], - level = level, - ensemble_idx = ensemble_idx, - type = type, - uniform = TRUE, - bootstraps = bootstraps) # multiplier bootstrap - attr(ci_r, "crit_val") - }, numeric(1)) - agg_fn <- if (aggregation == "mean") mean else stats::median - z <- agg_fn(crit_vals) # aggregated critical values... - } 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.DDML_REP - #' Summary for ddml_rep Objects #' -#' Aggregates coefficient estimates and covariance matrices -#' across \eqn{R} independent sample-splitting replications. +#' DML-specific summary override. Adds ensemble type labels, +#' folds, shortstack status to the base \code{ral_rep} +#' summary. #' #' @details -#' Let \eqn{\hat\theta_r} and \eqn{\hat\Sigma_r} denote -#' the coefficient vector and sandwich covariance matrix -#' from replication \eqn{r}. -#' -#' \strong{Coefficient aggregation.} -#' For \code{"mean"}: -#' \eqn{\tilde\theta = R^{-1} \sum_{r=1}^{R} \hat\theta_r}. -#' For \code{"median"} and \code{"spectral"}: -#' \eqn{\tilde\theta_j = \mathrm{median}_{r}(\hat\theta_{r,j})}. -#' -#' \strong{Covariance aggregation.} -#' Define the inflated per-replication covariance as -#' \deqn{V_r = \hat\Sigma_r + (\hat\theta_r - \tilde\theta) -#' (\hat\theta_r - \tilde\theta)^\top}. -#' For \code{"mean"}: -#' \eqn{\tilde\Sigma = R^{-1} \sum_{r=1}^{R} V_r}. -#' For \code{"median"}: -#' \eqn{\tilde\Sigma_{ij} = \mathrm{median}_{r}(V_{r,ij})}. -#' For \code{"spectral"}: -#' \eqn{\tilde\Sigma = \arg\min_{\Sigma \succeq 0} \sum_{r} \|\Sigma - V_r\|_2}, -#' solved via \pkg{CVXR}. Guarantees positive semi-definiteness of \eqn{\tilde\Sigma}. +#' See \code{\link{summary.ral_rep}} for the aggregation +#' formulas. #' #' @references #' Chernozhukov V, Chetverikov D, Demirer M, Duflo E, @@ -535,10 +190,9 @@ confint.ddml_rep <- function(object, parm, #' Journal, 21(1), C1-C68. #' #' @param object A \code{ddml_rep} object. -#' @inheritParams coef.ddml_rep -#' @param type Character string specifying the -#' variance-covariance estimator. One of \code{"HC1"} -#' (default), \code{"HC0"}, or \code{"HC3"}. +#' @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"}. @@ -559,42 +213,26 @@ confint.ddml_rep <- function(object, parm, #' @export #' @method summary ddml_rep summary.ddml_rep <- function(object, - aggregation = c("median", "mean", "spectral"), + aggregation = c("median", "mean", + "spectral"), type = "HC1", ...) { - # Aggregae coefficients and vcov matrices aggregation <- match.arg(aggregation) type <- match.arg(type, c("HC0", "HC1", "HC3")) - agg <- aggregate_reps(object, aggregation = aggregation, type = type) - # Construct inference results - p <- length(object$coef_names) - nensb <- length(object$ensemble_type) - inf_results <- array(0, dim = c(p, 4, nensb)) - for (j in seq_len(nensb)) { - 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|)"), - object$ensemble_type) - result <- list( - coefficients = inf_results, - type = type, - model_type = object$model_type, - estimator_name= object$estimator_name, - nobs = object$nobs, - sample_folds = object$sample_folds, - shortstack = object$shortstack, - ensemble_type = object$ensemble_type, - nresamples = object$nresamples, - aggregation = aggregation - ) + + # 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 @@ -612,57 +250,45 @@ print.summary.ddml_rep <- function(x, digits = 3, ...) { " Folds:", x$sample_folds, " Resamples:", x$nresamples, " Aggregation:", x$aggregation) - if (!is.null(x$shortstack) && x$shortstack) cat(" Stacking: short-stack") - if (!is.null(x$type) && x$type != "HC1") cat(" SE:", x$type) + 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") - nensb <- dim(x$coefficients)[3] - for (j in seq_len(nensb)) { - if (nensb > 1) cat("Ensemble type:", dimnames(x$coefficients)[[3]][j], "\n") - tbl <- x$coefficients[, , j] - if (!is.matrix(tbl)) { - tbl <- matrix(tbl, nrow = 1, dimnames = list( - dimnames(x$coefficients)[[1]], dimnames(x$coefficients)[[2]])) - }#IF - stats::printCoefmat(tbl, digits = digits, has.Pvalue = TRUE, - signif.stars = TRUE) - if (j < nensb) cat("\n") - }#FOR + print_coef_tables(x$coefficients, + fit_label = "Ensemble type", + digits = digits) invisible(x) }#PRINT.SUMMARY.DDML_REP #' Tidy a ddml_rep Object #' -#' Extracts aggregated coefficient estimates, standard -#' errors, test statistics, and p-values from a -#' \code{ddml_rep} object in a format compatible with -#' \pkg{modelsummary} and the \pkg{broom} ecosystem. +#' 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} to -#' return results for all ensemble types. -#' @inheritParams coef.ddml_rep -#' @param type Character string specifying the -#' variance-covariance estimator. One of \code{"HC1"} -#' (default), \code{"HC0"}, or \code{"HC3"}. -#' @param conf.int Logical. Include confidence interval -#' columns? Default \code{FALSE}. -#' @param conf.level Confidence level for intervals. -#' Default 0.95. -#' @param uniform Logical. If \code{TRUE}, computes -#' uniform confidence intervals using the multiplier -#' bootstrap. Only used when \code{conf.int = TRUE}. -#' Default \code{FALSE}. -#' @param bootstraps Integer number of bootstrap draws. -#' Only used when \code{uniform = TRUE}. Default 999. +#' 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}. If \code{conf.int = TRUE}, -#' also \code{conf.low} and \code{conf.high}. +#' @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{ @@ -683,67 +309,34 @@ print.summary.ddml_rep <- function(x, digits = 3, ...) { #' @export #' @method tidy ddml_rep tidy.ddml_rep <- function(x, ensemble_idx = 1, - aggregation = c("median", "mean", "spectral"), + 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 - nensb <- dim(inf)[3] - p <- dim(inf)[1] - - if (is.null(ensemble_idx)) { - j_seq <- seq_len(nensb) - } else { - j_seq <- ensemble_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], - ensemble_type = 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, ensemble_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(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 #' -#' Returns a one-row summary of model-level statistics, -#' compatible with \pkg{modelsummary} and the \pkg{broom} -#' ecosystem. +#' DML-specific glance method. Includes DML fields. #' #' @param x A \code{ddml_rep} object. #' @param ... Currently unused. #' -#' @return A one-row \code{data.frame} with columns \code{nobs}, -#' \code{sample_folds}, \code{shortstack}, \code{ensemble_type}, -#' \code{model_type}, and \code{nresamples}. +#' @return A one-row \code{data.frame}. #' #' @examples #' \donttest{ @@ -764,7 +357,8 @@ glance.ddml_rep <- function(x, ...) { nobs = x$nobs, sample_folds = x$sample_folds, shortstack = x$shortstack, - ensemble_type = paste(x$ensemble_type, collapse = ", "), + ensemble_type = paste(x$ensemble_type, + collapse = ", "), model_type = x$model_type, estimator_name = x$estimator_name, nresamples = x$nresamples, diff --git a/R/help_functions.R b/R/help_functions.R index ce3f14e..c989962 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -296,25 +296,6 @@ get_cf_resid_bylearner_for_eq <- function(fitted, eq) { if (!is.null(entry)) entry$cf_resid_bylearner else NULL }#GET_CF_RESID_BYLEARNER_FOR_EQ -# Validate common arguments for S3 inference methods. -# Returns the validated type (via match.arg) invisibly. -validate_method_args <- function(object, - ensemble_idx = NULL, - type = NULL) { - if (!is.null(type)) { - type <- match.arg(type, c("HC0", "HC1", "HC3")) - }#IF - if (!is.null(ensemble_idx)) { - nensb <- length(object$ensemble_type) - if (nensb == 0) nensb <- 1L - if (ensemble_idx < 1 || ensemble_idx > nensb) { - stop("ensemble_idx must be between 1 and ", - nensb, ".", call. = FALSE) - }#IF - }#IF - invisible(type) -}#VALIDATE_METHOD_ARGS - # Input validation checks for DDML estimators validate_inputs <- function(y = NULL, D = NULL, X = NULL, Z = NULL, learners = NULL, @@ -445,3 +426,24 @@ validate_custom_weights <- function(custom_weights, learners) { "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/lincom.R b/R/lincom.R index 9805093..de9db86 100644 --- a/R/lincom.R +++ b/R/lincom.R @@ -12,44 +12,72 @@ #' matrix \eqn{R}, the linear combination is #' \eqn{\gamma = R'\hat\theta}. #' -#' The influence function for \eqn{\gamma} is obtained via -#' the product rule: +#' The influence function for \eqn{\gamma} is #' -#' \deqn{\phi_\gamma(W_i; \theta, \eta, J, R) -#' = R' \phi_\theta(W_i; \theta, \eta, J) -#' + \phi_R(W_i)' \theta} +#' \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{ddml-intro}}) and -#' \eqn{\phi_R(W_i)} is the \eqn{p}-vector of influence -#' functions for the weight vector \eqn{R}, i.e., the -#' \eqn{i}-th row of \code{inf_func_R}. The second term -#' vanishes when \eqn{R} is fixed. +#' \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 #' -#' The leverage for \eqn{\gamma} is defined in -#' \code{\link{hatvalues.ddml_lincom}}. -#' The resulting \code{ddml_lincom} object supports all standard -#' inference methods: \code{vcov}, \code{confint}, \code{summary}, -#' and \code{tidy}. For \code{ddml_rep} objects, \code{lincom} -#' can be called directly to obtain a \code{ddml_lincom_rep}. +#' \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.ddml_lincom}} and -#' \code{\link{hatvalues.ddml_lincom}} for more details. +#' \code{dinf_dR}. See \code{\link{vcov.ral}} and +#' \code{\link{hatvalues.ral}} for more details. #' -#' @inheritParams ddml + #' @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 ensemble_idx Integer index of the ensemble type to -#' use. Default 1. +#' @param fit_idx Integer index of the fit to use. +#' Default 1. #' @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)}{n x p} matrix -#' of influence functions \eqn{\phi_{R,i}} for the -#' weight vector \eqn{R}. When supplied, a delta-method +#' @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. @@ -61,9 +89,10 @@ #' total leverage used by HC3. #' @param ... Currently unused. #' -#' @return An object of class \code{"ddml_lincom"} (for -#' \code{ddml} input) or \code{"ddml_lincom_rep"} (for -#' \code{ddml_rep} input). +#' @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. @@ -110,10 +139,10 @@ lincom <- function(fit, R, ...) { #' @rdname lincom #' @export #' @method lincom ddml -lincom.ddml <- function(fit, R, - ensemble_idx = 1, - labels = NULL, - inf_func_R = NULL, +lincom.ddml <- function(fit, R, + fit_idx = 1, + labels = NULL, + inf_func_R = NULL, dinf_dR = NULL, ...) { R <- as.matrix(R) @@ -123,11 +152,11 @@ lincom.ddml <- function(fit, R, stopifnot(nrow(R) == p) # Point estimate: R'theta - att <- fit$coefficients[, ensemble_idx] - lincom_coef <- as.numeric(crossprod(R, att)) + theta <- fit$coefficients[, fit_idx] + lincom_coef <- as.numeric(crossprod(R, theta)) # Unit-level IF for theta: phi_i - theta_if <- fit$inf_func[, , ensemble_idx, drop = FALSE] + theta_if <- fit$inf_func[, , fit_idx, drop = FALSE] dim(theta_if) <- dim(theta_if)[1:2] # Combined IF for R'theta @@ -135,14 +164,17 @@ lincom.ddml <- function(fit, R, lincom_if <- theta_if %*% R # n x q # Term 2: delta-method correction (when R estimated) if (!is.null(inf_func_R)) { - stopifnot(nrow(inf_func_R) == n, ncol(inf_func_R) == p) - lincom_if <- lincom_if + inf_func_R %*% (att * (R != 0)) + 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) + for (k in seq_len(q)) { + lincom_if[, k] <- lincom_if[, k] + inf_func_R[, , k] %*% theta + }#FOR }#IF - # Map Structural Leverage + # Map Structural Leverage dinf_dtheta <- NULL if (!is.null(fit$dinf_dtheta)) { - dinf_j <- fit$dinf_dtheta[, , , ensemble_idx, drop = FALSE] + dinf_j <- fit$dinf_dtheta[, , , fit_idx, drop = FALSE] dinf_lc <- array(NA_real_, dim = c(n, q, q, 1)) for (i in seq_len(n)) { dinf_i <- matrix(dinf_j[i, , , 1], p, p) @@ -162,325 +194,68 @@ lincom.ddml <- function(fit, R, if (is.null(labels)) labels <- colnames(R) if (is.null(labels)) labels <- paste0("lc", seq_len(q)) - # Package as standalone ddml_lincom + # Package as lincom > ral coef_mat <- matrix(lincom_coef, nrow = q, ncol = 1) rownames(coef_mat) <- labels colnames(coef_mat) <- "lincom" - obj <- list( - coefficients = coef_mat, - scores = array(-lincom_if, dim = c(n, q, 1)), - J = array(diag(-1, q), dim = c(q, q, 1)), - inf_func = array(lincom_if, dim = c(n, q, 1)), - dinf_dtheta = dinf_dtheta, - coef_names = labels, - nobs = n, - estimator_name = "Linear Combination", - ensemble_type = "lincom", - cluster_variable = fit$cluster_variable, - fixed_R = is.null(inf_func_R) - ) - class(obj) <- "ddml_lincom" - obj + ral(coefficients = coef_mat, + inf_func = array(lincom_if, dim = c(n, q, 1)), + 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 -# Internal helper ============================================================== - -# Build a temporary ddml object for delegation. -lincom_to_ddml <- function(lc) { - # dinf_dtheta evaluates to NULL by default - q <- nrow(lc$coefficients) - ddml( - coefficients = lc$coefficients, - scores = lc$scores, - J = lc$J, - inf_func = lc$inf_func, - dinf_dtheta = lc$dinf_dtheta, - nobs = lc$nobs, - coef_names = lc$coef_names, - estimator_name = lc$estimator_name, - ensemble_type = lc$ensemble_type, - cluster_variable = lc$cluster_variable, - call = NULL - ) -}#LINCOM_TO_DDML - -# Build a temporary ddml_rep from per-rep ddml_lincom fits. -lincom_to_ddml_rep <- function(lc_rep) { - ddml_rep(lapply(lc_rep$fits, lincom_to_ddml)) -}#LINCOM_TO_DDML_REP - -# ddml_lincom S3 methods ======================================================= - -#' @rdname lincom -#' @param object A \code{ddml_lincom} object. -#' @export -#' @method coef ddml_lincom -coef.ddml_lincom <- function(object, ...) { - cf <- object$coefficients[, 1] - names(cf) <- object$coef_names - cf -}#COEF.DDML_LINCOM - -#' @rdname lincom -#' @export -#' @method nobs ddml_lincom -nobs.ddml_lincom <- function(object, ...) object$nobs - -#' @rdname lincom -#' @details -#' \code{vcov.ddml_lincom} computes the sandwich variance of -#' \eqn{\lambda = R'\hat\theta} using the influence function -#' \eqn{\phi_{\lambda,i} = R' \phi_{\theta,i} -#' + \sum_c \theta_c \phi_{R_c,i}}, -#' where the second term is included only when -#' \code{inf_func_R} was supplied to \code{lincom}. -#' @param type Character. Variance estimator type -#' (\code{"HC0"} or \code{"HC1"}). \code{"HC3"} is not -#' supported for linear combinations. -#' @export -#' @method vcov ddml_lincom -vcov.ddml_lincom <- function(object, type = "HC1", ...) { - type <- match.arg(type, c("HC0", "HC1", "HC3")) - if (type == "HC3") { - stop("HC3 standard errors (generalized leverage) are not ", - "currently supported for linear combinations.", call. = FALSE) - }#IF - vcov(lincom_to_ddml(object), ensemble_idx = 1, type = type) -}#VCOV.DDML_LINCOM - -#' @rdname lincom -#' @param parm Parameters for confidence intervals. -#' @param level Confidence level. Default 0.95. -#' @param uniform Logical. If \code{TRUE}, computes uniform -#' confidence bands via the multiplier bootstrap. -#' @param bootstraps Integer bootstrap draws. Default 999. -#' @export -#' @method confint ddml_lincom -confint.ddml_lincom <- function(object, parm, level = 0.95, - type = "HC1", - uniform = FALSE, - bootstraps = 999L, ...) { - type <- match.arg(type, c("HC0", "HC1", "HC3")) - if (type == "HC3") { - stop("HC3 standard errors (generalized leverage) are not ", - "currently supported for linear combinations.", call. = FALSE) - }#IF - confint(lincom_to_ddml(object), parm = parm, level = level, - ensemble_idx = 1, type = type, uniform = uniform, - bootstraps = bootstraps) -}#CONFINT.DDML_LINCOM - -#' @rdname lincom -#' @export -#' @method summary ddml_lincom -summary.ddml_lincom <- function(object, type = "HC1", ...) { - type <- match.arg(type, c("HC0", "HC1", "HC3")) - if (type == "HC3") { - stop("HC3 standard errors (generalized leverage) are not ", - "currently supported for linear combinations.", call. = FALSE) - }#IF - summary(lincom_to_ddml(object), type = type) -}#SUMMARY.DDML_LINCOM - -#' @rdname lincom -#' @param x A \code{ddml_lincom} or \code{ddml_lincom_rep} -#' object. -#' @param conf.int Logical. Include confidence intervals? -#' @param conf.level Confidence level for intervals. -#' @export -#' @method tidy ddml_lincom -tidy.ddml_lincom <- function(x, conf.int = FALSE, - conf.level = 0.95, - type = "HC1", - uniform = FALSE, - bootstraps = 999L, ...) { - type <- match.arg(type, c("HC0", "HC1", "HC3")) - if (type == "HC3") { - stop("HC3 standard errors (generalized leverage) are not ", - "currently supported for linear combinations.", call. = FALSE) - }#IF - tidy(lincom_to_ddml(x), ensemble_idx = 1, - conf.int = conf.int, conf.level = conf.level, - type = type, uniform = uniform, bootstraps = bootstraps) -}#TIDY.DDML_LINCOM - -#' @rdname lincom -#' @details -#' \code{hatvalues.ddml_lincom} computes the observation-level -#' leverage for \eqn{\gamma}. The leverage decomposes as: -#' -#' \deqn{h_\gamma(W_i; \theta, \eta, J, R) -#' = \underbrace{R' -#' \left(-\frac{1}{n} -#' \frac{\partial \phi_\theta(W_i; \theta, -#' \eta, J)}{\partial \theta}\right) -#' R}_{\text{structural leverage}} -#' + \underbrace{\theta' -#' \left(-\frac{1}{n} -#' \frac{\partial \phi_R(W_i)} -#' {\partial R}\right) -#' \theta}_{\text{weighting leverage}}} -#' -#' The structural leverage is computed from the parent -#' model's \code{dinf_dtheta}; the weighting leverage -#' requires \code{dinf_dR} to be supplied to \code{lincom}. -#' @param model A \code{ddml_lincom} or \code{ddml_lincom_rep} object. -#' @export -#' @method hatvalues ddml_lincom -hatvalues.ddml_lincom <- function(model, ...) { - stop("HC3 standard errors (generalized leverage) are not currently ", - "supported for linear combinations.", call. = FALSE) -}#HATVALUES.DDML_LINCOM - # lincom.ddml_rep ============================================================== #' @rdname lincom #' @export #' @method lincom ddml_rep -lincom.ddml_rep <- function(fit, R, inf_func_R = NULL, dinf_dR = NULL, - ensemble_idx = 1, - labels = NULL, ...) { +lincom.ddml_rep <- function(fit, R, inf_func_R = NULL, + dinf_dR = NULL, + fit_idx = 1, + 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, - ensemble_idx = ensemble_idx, labels = labels, ...) + lincom(f, R = R, inf_func_R = inf_func_R, + dinf_dR = dinf_dR, fit_idx = fit_idx, + labels = labels, ...) }) - obj <- list( - fits = lc_fits, - nresamples = length(lc_fits), - nobs = lc_fits[[1]]$nobs, - coef_names = lc_fits[[1]]$coef_names, - estimator_name = "Linear Combination", - ensemble_type = "lincom", - fixed_R = is.null(inf_func_R) - ) - class(obj) <- "ddml_lincom_rep" - obj + ral_rep(lc_fits, subclass = "lincom_rep", + fixed_R = is.null(inf_func_R)) }#LINCOM.DDML_REP -# ddml_lincom_rep S3 methods =================================================== - -#' @rdname lincom -#' @param aggregation Aggregation method: \code{"median"}, -#' \code{"mean"}, or \code{"spectral"}. -#' @export -#' @method coef ddml_lincom_rep -coef.ddml_lincom_rep <- function(object, aggregation = c("median", "mean"), - ...) { - aggregation <- match.arg(aggregation) - coef(lincom_to_ddml_rep(object), aggregation = aggregation) -}#COEF.DDML_LINCOM_REP - -#' @rdname lincom -#' @export -#' @method nobs ddml_lincom_rep -nobs.ddml_lincom_rep <- function(object, ...) object$nobs - -#' @rdname lincom -#' @export -#' @method vcov ddml_lincom_rep -vcov.ddml_lincom_rep <- function(object, - aggregation = c("median", "mean", - "spectral"), - type = "HC1", ...) { - aggregation <- match.arg(aggregation) - type <- match.arg(type, c("HC0", "HC1", "HC3")) - if (type == "HC3") { - stop("HC3 standard errors (generalized leverage) are not ", - "currently supported for linear combinations.", call. = FALSE) - }#IF - vcov(lincom_to_ddml_rep(object), aggregation = aggregation, type = type) -}#VCOV.DDML_LINCOM_REP - -#' @rdname lincom -#' @export -#' @method confint ddml_lincom_rep -confint.ddml_lincom_rep <- function(object, parm, level = 0.95, - aggregation = c("median", "mean", - "spectral"), - type = "HC1", - uniform = FALSE, - bootstraps = 999L, ...) { - aggregation <- match.arg(aggregation) - type <- match.arg(type, c("HC0", "HC1", "HC3")) - if (type == "HC3") { - stop("HC3 standard errors (generalized leverage) are not ", - "currently supported for linear combinations.", call. = FALSE) - }#IF - confint(lincom_to_ddml_rep(object), parm = parm, level = level, - aggregation = aggregation, type = type, - uniform = uniform, bootstraps = bootstraps) -}#CONFINT.DDML_LINCOM_REP - -#' @rdname lincom -#' @export -#' @method summary ddml_lincom_rep -summary.ddml_lincom_rep <- function(object, - aggregation = c("median", "mean", - "spectral"), - type = "HC1", ...) { - aggregation <- match.arg(aggregation) - type <- match.arg(type, c("HC0", "HC1", "HC3")) - if (type == "HC3") { - stop("HC3 standard errors (generalized leverage) are not ", - "currently supported for linear combinations.", call. = FALSE) - }#IF - summary(lincom_to_ddml_rep(object), aggregation = aggregation, type = type) -}#SUMMARY.DDML_LINCOM_REP - -#' @rdname lincom -#' @export -#' @method tidy ddml_lincom_rep -tidy.ddml_lincom_rep <- function(x, - aggregation = c("median", "mean"), - type = "HC1", - conf.int = FALSE, - conf.level = 0.95, - uniform = FALSE, - bootstraps = 999L, ...) { - aggregation <- match.arg(aggregation) - type <- match.arg(type, c("HC0", "HC1", "HC3")) - if (type == "HC3") { - stop("HC3 standard errors (generalized leverage) are not ", - "currently supported for linear combinations.", call. = FALSE) - }#IF - tidy(lincom_to_ddml_rep(x), aggregation = aggregation, - type = type, conf.int = conf.int, conf.level = conf.level, - uniform = uniform, bootstraps = bootstraps) -}#TIDY.DDML_LINCOM_REP - -#' @rdname lincom -#' @export -#' @method hatvalues ddml_lincom_rep -hatvalues.ddml_lincom_rep <- function(model, ...) { - stop("HC3 standard errors (generalized leverage) are not currently ", - "supported for linear combinations.", call. = FALSE) -}#HATVALUES.DDML_LINCOM_REP - # Print methods ================================================================ #' @rdname lincom +#' @param x A \code{lincom} or \code{lincom_rep} object. #' @export -#' @method print ddml_lincom -print.ddml_lincom <- function(x, ...) { - cat("DDML Linear Combination\n") +#' @method print lincom +print.lincom <- function(x, ...) { + cat("Linear Combination\n") cat("Obs:", x$nobs) if (!x$fixed_R) cat(" (delta-method)") cat("\n\n") cat("Use summary() for inference.\n") invisible(x) -}#PRINT.DDML_LINCOM +}#PRINT.LINCOM #' @rdname lincom #' @export -#' @method print ddml_lincom_rep -print.ddml_lincom_rep <- function(x, ...) { - cat("DDML Linear Combination (replicated)\n") - cat("Obs:", x$nobs, " Resamples:", x$nresamples) - if (!is.null(x$fixed_R) && !x$fixed_R) cat(" (delta-method)") +#' @method print lincom_rep +print.lincom_rep <- function(x, ...) { + cat("Linear Combination (replicated)\n") + cat("Obs:", x$nobs, + " Resamples:", x$nresamples) + 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.DDML_LINCOM_REP +}#PRINT.LINCOM_REP diff --git a/R/ral.R b/R/ral.R new file mode 100644 index 0000000..1ba8449 --- /dev/null +++ b/R/ral.R @@ -0,0 +1,677 @@ +# 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}}. +#' +#' @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) + + # Cluster aggregation + clustered <- !is.null(object$cluster_variable) && + length(unique(object$cluster_variable)) < nrow(if_j) + if (clustered) if_j <- rowsum(if_j, object$cluster_variable) + + 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 + if (!is.null(cl) && length(unique(cl)) < nrow(inf_func)) { + inf_func <- rowsum(inf_func, cl) + }#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}. Useful +#' for event-study style coefficient plots. +#' +#' @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{FALSE}. +#' @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)), +#' 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 = FALSE, + 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 diff --git a/R/ral_rep.R b/R/ral_rep.R new file mode 100644 index 0000000..8a01a0b --- /dev/null +++ b/R/ral_rep.R @@ -0,0 +1,592 @@ +# 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") + + result <- CVXR::psolve(CVXR::Problem(CVXR::Minimize(obj))) + + if (result$status != "optimal") { + warning("SDP solver returned status '", result$status, + "'; falling back to element-wise median.", call. = FALSE) + arr <- array(unlist(lapply(matrices, as.vector)), dim = c(p, p, R)) + return(apply(arr, c(1, 2), stats::median)) + }#IF + + V_sol <- result$getValue(V) + (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]] +}#[[.RAL_REP + +#' @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 = FALSE, + 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 From 5571b7afe7464ebd74b64b104fd0a22d08cd25f4 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Sun, 22 Mar 2026 11:51:06 -0500 Subject: [PATCH 33/46] diff-in-diff support --- R/ddml_attgt.R | 416 +++++++++++++++++++++++++++++++++++++++++++++ R/lincom_weights.R | 213 +++++++++++++++++++++++ R/ral.R | 18 +- R/ral_rep.R | 62 +++---- 4 files changed, 664 insertions(+), 45 deletions(-) create mode 100644 R/ddml_attgt.R create mode 100644 R/lincom_weights.R diff --git a/R/ddml_attgt.R b/R/ddml_attgt.R new file mode 100644 index 0000000..d82aae1 --- /dev/null +++ b/R/ddml_attgt.R @@ -0,0 +1,416 @@ +#' 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, using cross-fitted AIPW scores. +#' +#' @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 given by: +#' +#' \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{\Delta_g Y_{i,t} = Y_{i,t} - Y_{i,g^*}} is the +#' difference relative to the universal base period +#' \eqn{g^* = \max\{s : s < g - \text{anticipation}\}}. +#' +#' \strong{Neyman Orthogonal Score:} For each cell \eqn{(g,t)}, the +#' AIPW score is: +#' +#' \deqn{m^{(g,t)}(W_i; \theta, \eta) = +#' \frac{D_i(\Delta_g Y_{i,t} - \ell(X_i))}{\pi} +#' - \frac{q(X_i)(1-D_i)(\Delta_g Y_{i,t} +#' - \ell(X_i))}{\pi(1 - q(X_i))} +#' - \frac{D_i}{\pi} \theta} +#' +#' where \eqn{D_i = \mathbb{1}\{G_i = g\}} is the cell-level +#' treatment indicator, and the nuisance parameters are +#' \eqn{\eta = (q, \ell, \pi)} taking true values +#' \eqn{q_0(X) = \Pr(G_i = g | X_i, \{G_i = g\} \cup +#' \{G_i > t\})}, \eqn{\ell_0(X) = E[\Delta_g Y_{i,t} | +#' G_i \ne g, G_i > t, X_i]}, and +#' \eqn{\pi_0 = \Pr(G_i = g)}. +#' +#' \strong{Jacobian:} +#' +#' \deqn{J = -E[D / \pi]} +#' +#' 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 + + # 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 + + + # Pre-allocate --------------------------------------------------------------- + + nensb <- NULL + coef_mat <- NULL + scores_arr <- NULL + J_arr <- NULL + psi_b_full <- NULL + psi_a_full <- NULL + + # Flat diagnostics lists — keyed by "ATT(g,t):equation" + all_ensemble_weights <- list() + all_mspe <- list() + all_r2 <- list() + all_fitted <- list() + all_splits <- list() + cell_info <- data.frame( + group = integer(C), time = integer(C), + base_period = integer(C), + n_treated = integer(C), n_control = integer(C)) + + # Main loop: per-cell ATT estimation ----------------------------------------- + + for (idx in seq_len(C)) { + gtp <- gt_list[[idx]] + g_val <- gtp$g; tt <- gtp$t + cell_prefix <- paste0("ATT(", g_val, ",", tt, ")") + + # Identify treated and control units + 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 + + # Run ddml_att for this cell + 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) + all_ensemble_weights[[key]] <- fit$ensemble_weights[[eq]] + all_mspe[[key]] <- fit$mspe[[eq]] + all_r2[[key]] <- fit$r2[[eq]] + }#FOR + for (eq in names(fit$fitted)) { + key <- paste0(cell_prefix, ":", eq) + all_fitted[[key]] <- fit$fitted[[eq]] + }#FOR + for (eq in names(fit$splits)) { + key <- paste0(cell_prefix, ":", eq) + all_splits[[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_mat <- matrix(NA_real_, C, nensb) + scores_arr <- array(0, dim = c(n, C, nensb)) + J_arr <- array(0, dim = c(C, C, nensb)) + inf_func_full <- array(0, dim = c(n, C, nensb)) + dinf_dtheta_full <- array(0, dim = c(n, C, C, nensb)) + }#IF + + # Embed cell scores into full-sample arrays + for (j in seq_len(nensb)) { + att_val <- fit$coefficients[1, j] + coef_mat[idx, j] <- att_val + + # Cell-level components (p = 1 for ATT) + cell_scores <- fit$scores[, 1, j] + cell_J <- fit$J[1, 1, j] + cell_inf_func <- fit$inf_func[, 1, j] + cell_dinf_dtheta <- fit$dinf_dtheta[, 1, 1, j] + + # Rescale from cell-level to population-level: + # J_pop = (n_cell/n) * J_cell, so IF_pop = scores/J_pop + # = (n/n_cell) * scores/J_cell = (n/n_cell) * IF_cell + pop_scale <- n / n_cell + + scores_arr[keep, idx, j] <- cell_scores + inf_func_full[keep, idx, j] <- cell_inf_func * pop_scale + # Jacobian: rescale to full-sample average + J_arr[idx, idx, j] <- (n_cell / n) * cell_J + # dinf_dtheta: same rescaling (used for HC3 leverage) + dinf_dtheta_full[keep, idx, idx, j] <- cell_dinf_dtheta * pop_scale + }#FOR + }#FOR + + # Coefficient names ---------------------------------------------------------- + + coef_names <- paste0("ATT(", cell_info$group, ",", cell_info$time, ")") + rownames(coef_mat) <- coef_names + colnames(coef_mat) <- ens_type + + # Store global subsamples for pass-through round-trip + all_splits[["global"]] <- list(subsamples = global_subsamples) + + # Output --------------------------------------------------------------------- + + announce_finish(t0, messages, silent) + + ddml( + coefficients = coef_mat, + ensemble_weights = all_ensemble_weights, + mspe = all_mspe, + r2 = all_r2, + scores = scores_arr, + J = J_arr, + inf_func = inf_func_full, + dinf_dtheta = dinf_dtheta_full, + 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 = all_fitted, + splits = all_splits, + 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/lincom_weights.R b/R/lincom_weights.R new file mode 100644 index 0000000..19b6bf8 --- /dev/null +++ b/R/lincom_weights.R @@ -0,0 +1,213 @@ +#' 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. Default 1. +#' +#' @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 = 1) { + 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 + theta <- ref$coefficients[, fit_idx] + gamma <- as.numeric(crossprod(R, theta)) # q-vector + nG <- length(glist) + 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 (j in seq_len(nG)) { + cells_gk <- keepers[group[keepers] == glist[j]] + if (length(cells_gk) > 0L) { + V[j, k] <- sum(theta[cells_gk] - gamma[k]) / S_k + }#IF + }#FOR + }#FOR + VtV <- crossprod(V) # q x q, constant + dinf_dR <- array(rep(VtV, each = n), dim = c(n, q, q)) + + 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/ral.R b/R/ral.R index 1ba8449..cd6fc6c 100644 --- a/R/ral.R +++ b/R/ral.R @@ -180,7 +180,7 @@ nobs.ral <- function(object, ...) { #' #' \deqn{h_i(\theta) #' = \mathrm{tr}\!\left( -#' -\frac{1}{n} +#' \frac{1}{n} #' \frac{\partial \phi_i(\theta)} #' {\partial \theta} #' \right).} @@ -207,7 +207,7 @@ nobs.ral <- function(object, ...) { 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", + warning("hatvalues: dinf_dtheta not available; returning NA", call. = FALSE) return(rep(NA_real_, nobs(model))) }#IF @@ -588,8 +588,7 @@ glance.ral <- function(x, ...) { #' Plot Coefficients from a RAL Estimator #' #' @description Plots point estimates with confidence intervals -#' from an object inheriting from class \code{ral}. Useful -#' for event-study style coefficient plots. +#' 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. @@ -597,7 +596,7 @@ glance.ral <- function(x, ...) { #' @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{FALSE}. +#' \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. @@ -624,6 +623,7 @@ glance.ral <- function(x, ...) { #' 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) #' @@ -633,7 +633,7 @@ glance.ral <- function(x, ...) { #' @method plot ral #' @export plot.ral <- function(x, parm = NULL, level = 0.95, - uniform = FALSE, + uniform = TRUE, fit_idx = 1, type = "HC1", xlab = NULL, ylab = NULL, @@ -641,8 +641,7 @@ plot.ral <- function(x, parm = NULL, level = 0.95, col = "black", pch = 19, lwd = 1.5, ...) { # Get coefficients and confidence intervals - ci <- confint(x, parm = parm, level = level, - fit_idx = fit_idx, + ci <- confint(x, parm = parm, level = level, fit_idx = fit_idx, type = type, uniform = uniform) cf <- x$coefficients[, fit_idx] labels <- rownames(ci) @@ -657,8 +656,7 @@ plot.ral <- function(x, parm = NULL, level = 0.95, 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") + main <- paste0(format(level * 100, digits = 3), "% ", ci_type, " CI") }#IF # Plot diff --git a/R/ral_rep.R b/R/ral_rep.R index 8a01a0b..06b7809 100644 --- a/R/ral_rep.R +++ b/R/ral_rep.R @@ -35,16 +35,21 @@ spectral_median_psd <- function(matrices) { obj <- 0 for (r in seq_len(R)) obj <- obj + CVXR::norm(V - matrices[[r]], "2") - result <- CVXR::psolve(CVXR::Problem(CVXR::Minimize(obj))) - - if (result$status != "optimal") { - warning("SDP solver returned status '", result$status, - "'; falling back to element-wise median.", call. = FALSE) - arr <- array(unlist(lapply(matrices, as.vector)), dim = c(p, p, R)) - return(apply(arr, c(1, 2), stats::median)) - }#IF - - V_sol <- result$getValue(V) + 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 @@ -55,8 +60,7 @@ spectral_median_psd <- function(matrices) { # 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") { +aggregate_reps <- function(object, aggregation = "median", type = "HC1") { aggregation <- match.arg(aggregation, c("median", "mean", "spectral")) R <- object$nresamples nfit <- object$nfit @@ -69,9 +73,7 @@ aggregate_reps <- function(object, aggregation = "median", 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) + vcov_array[, , j, r] <- stats::vcov(fit, fit_idx = j, type = type) }#FOR }#FOR @@ -98,18 +100,15 @@ aggregate_reps <- function(object, aggregation = "median", } 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) + 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) + V_j <- matrix(agg_vcov[, , j, drop = FALSE], nrow = p, ncol = p) agg_se[, j] <- sqrt(diag(V_j)) }#FOR @@ -181,9 +180,7 @@ ral_rep <- function(fits, subclass = NULL, ...) { #' @method [[ ral_rep #' @export -`[[.ral_rep` <- function(x, i) { - x$fits[[i]] -}#[[.RAL_REP +`[[.ral_rep` <- function(x, i) x$fits[[i]] #' @method length ral_rep #' @export @@ -328,8 +325,7 @@ confint.ral_rep <- function(object, parm = NULL, bootstraps = bootstraps) attr(ci_r, "crit_val") }, numeric(1)) - agg_fn <- if (aggregation == "mean") mean else - stats::median + agg_fn <- if (aggregation == "mean") mean else stats::median z <- agg_fn(crit_vals) } else { z <- stats::qnorm((1 + level) / 2) @@ -469,8 +465,7 @@ print.summary.ral_rep <- function(x, digits = 3, ...) { #' @method tidy ral_rep #' @export tidy.ral_rep <- function(x, fit_idx = 1, - aggregation = c("median", "mean", - "spectral"), + aggregation = c("median", "mean", "spectral"), type = "HC1", conf.int = FALSE, conf.level = 0.95, @@ -549,15 +544,14 @@ glance.ral_rep <- function(x, ...) { #' @method plot ral_rep #' @export plot.ral_rep <- function(x, parm = NULL, level = 0.95, - uniform = FALSE, + 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) + ci <- confint(x, parm = parm, level = level, type = type, uniform = uniform) cf <- coef(x) labels <- rownames(ci) cf <- cf[labels] @@ -571,8 +565,7 @@ plot.ral_rep <- function(x, parm = NULL, level = 0.95, 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") + main <- paste0(format(level * 100, digits = 3), "% ", ci_type, " CI") }#IF # Plot @@ -583,8 +576,7 @@ plot.ral_rep <- function(x, parm = NULL, level = 0.95, 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::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) From 5735abb0578862fd1780caf6d1f266870d499490 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Mon, 23 Mar 2026 11:38:09 -0500 Subject: [PATCH 34/46] full-sample scores for attgt --- R/ddml_attgt.R | 224 ++++++++++++++++++++++++++++++------------------- 1 file changed, 139 insertions(+), 85 deletions(-) diff --git a/R/ddml_attgt.R b/R/ddml_attgt.R index d82aae1..e1009fc 100644 --- a/R/ddml_attgt.R +++ b/R/ddml_attgt.R @@ -4,41 +4,42 @@ #' #' @description Estimator for group-time average treatment effects #' on the treated (GT-ATT) in staggered Difference-in-Differences -#' designs, using cross-fitted AIPW scores. +#' 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 given by: +#' 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{\Delta_g Y_{i,t} = Y_{i,t} - Y_{i,g^*}} is the -#' difference relative to the universal base period -#' \eqn{g^* = \max\{s : s < g - \text{anticipation}\}}. +#' \strong{Neyman Orthogonal Score:} The Neyman orthogonal score +#' is: #' -#' \strong{Neyman Orthogonal Score:} For each cell \eqn{(g,t)}, the -#' AIPW score is: +#' \deqn{m_i^{(g,t)} = +#' \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} #' -#' \deqn{m^{(g,t)}(W_i; \theta, \eta) = -#' \frac{D_i(\Delta_g Y_{i,t} - \ell(X_i))}{\pi} -#' - \frac{q(X_i)(1-D_i)(\Delta_g Y_{i,t} -#' - \ell(X_i))}{\pi(1 - q(X_i))} -#' - \frac{D_i}{\pi} \theta} -#' -#' where \eqn{D_i = \mathbb{1}\{G_i = g\}} is the cell-level -#' treatment indicator, and the nuisance parameters are -#' \eqn{\eta = (q, \ell, \pi)} taking true values -#' \eqn{q_0(X) = \Pr(G_i = g | X_i, \{G_i = g\} \cup -#' \{G_i > t\})}, \eqn{\ell_0(X) = E[\Delta_g Y_{i,t} | -#' G_i \ne g, G_i > t, X_i]}, and -#' \eqn{\pi_0 = \Pr(G_i = g)}. +#' 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 = -E[D / \pi]} +#' \deqn{J^{(g,t)} = -1} #' #' See \code{\link{ddml-intro}} for how the influence function #' and inference are derived from these components. @@ -180,6 +181,7 @@ ddml_attgt <- function(y, X = NULL, t, G, 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) @@ -220,35 +222,58 @@ ddml_attgt <- function(y, X = NULL, t, G, "'t' define at least one post-treatment period.", call. = FALSE) }#IF + # Reduced-form estimation ---------------------------------------------------- - # Pre-allocate --------------------------------------------------------------- + # 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_mat <- NULL - scores_arr <- NULL - J_arr <- NULL - psi_b_full <- NULL - psi_a_full <- NULL - - # Flat diagnostics lists — keyed by "ATT(g,t):equation" - all_ensemble_weights <- list() - all_mspe <- list() - all_r2 <- list() - all_fitted <- list() - all_splits <- list() + 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)) - # Main loop: per-cell ATT estimation ----------------------------------------- + # 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 --------------------------------------------------------- - # Identify treated and control units treated <- (G == g_val) if (control_group == "nevertreated") { control <- never_treated @@ -302,7 +327,8 @@ ddml_attgt <- function(y, X = NULL, t, G, list(D_X = list(subsamples = cell_subsamples)) }#IFELSE - # Run ddml_att for this cell + # 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, @@ -321,17 +347,17 @@ ddml_attgt <- function(y, X = NULL, t, G, # Collect per-cell diagnostics (flat keying) for (eq in names(fit$ensemble_weights)) { key <- paste0(cell_prefix, ":", eq) - all_ensemble_weights[[key]] <- fit$ensemble_weights[[eq]] - all_mspe[[key]] <- fit$mspe[[eq]] - all_r2[[key]] <- fit$r2[[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) - all_fitted[[key]] <- fit$fitted[[eq]] + fitted_list[[key]] <- fit$fitted[[eq]] }#FOR for (eq in names(fit$splits)) { key <- paste0(cell_prefix, ":", eq) - all_splits[[key]] <- fit$splits[[eq]] + splits_list[[key]] <- fit$splits[[eq]] }#FOR # Determine nensb from first fit and allocate @@ -339,60 +365,88 @@ ddml_attgt <- function(y, X = NULL, t, G, nensb <- ncol(fit$coefficients) ens_type <- colnames(fit$coefficients) if (is.null(ens_type)) ens_type <- fit$ensemble_type - coef_mat <- matrix(NA_real_, C, nensb) - scores_arr <- array(0, dim = c(n, C, nensb)) - J_arr <- array(0, dim = c(C, C, nensb)) - inf_func_full <- array(0, dim = c(n, C, nensb)) - dinf_dtheta_full <- array(0, dim = c(n, C, C, nensb)) + 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 - # Embed cell scores into full-sample arrays - for (j in seq_len(nensb)) { - att_val <- fit$coefficients[1, j] - coef_mat[idx, j] <- att_val - - # Cell-level components (p = 1 for ATT) - cell_scores <- fit$scores[, 1, j] - cell_J <- fit$J[1, 1, j] - cell_inf_func <- fit$inf_func[, 1, j] - cell_dinf_dtheta <- fit$dinf_dtheta[, 1, 1, j] - - # Rescale from cell-level to population-level: - # J_pop = (n_cell/n) * J_cell, so IF_pop = scores/J_pop - # = (n/n_cell) * scores/J_cell = (n/n_cell) * IF_cell - pop_scale <- n / n_cell - - scores_arr[keep, idx, j] <- cell_scores - inf_func_full[keep, idx, j] <- cell_inf_func * pop_scale - # Jacobian: rescale to full-sample average - J_arr[idx, idx, j] <- (n_cell / n) * cell_J - # dinf_dtheta: same rescaling (used for HC3 leverage) - dinf_dtheta_full[keep, idx, idx, j] <- cell_dinf_dtheta * pop_scale + # 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 - # Coefficient names ---------------------------------------------------------- + # Target parameter & influence function -------------------------------------- - coef_names <- paste0("ATT(", cell_info$group, ",", cell_info$time, ")") - rownames(coef_mat) <- coef_names - colnames(coef_mat) <- ens_type + 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 - # Store global subsamples for pass-through round-trip - all_splits[["global"]] <- list(subsamples = global_subsamples) + 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_mat, - ensemble_weights = all_ensemble_weights, - mspe = all_mspe, - r2 = all_r2, - scores = scores_arr, - J = J_arr, - inf_func = inf_func_full, - dinf_dtheta = dinf_dtheta_full, + 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", @@ -401,8 +455,8 @@ ddml_attgt <- function(y, X = NULL, t, G, sample_folds = sample_folds, cv_folds = if (shortstack) NULL else cv_folds, shortstack = shortstack, - fitted = all_fitted, - splits = all_splits, + fitted = fitted_list, + splits = splits_list, call = cl, subclass = "ddml_attgt", # ddml_attgt-specific fields From 33fec9be668bedb21a7cd434006c2b142c2692e2 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Mon, 23 Mar 2026 13:09:23 -0500 Subject: [PATCH 35/46] updated docs & tests --- .Rbuildignore | 4 +- .gitignore | 2 + DESCRIPTION | 11 +- NAMESPACE | 46 ++- NEWS.md | 2 +- R/ddml_apo.R | 29 +- R/ddml_ate.R | 34 +- R/ddml_attgt.R | 5 +- R/ddml_fpliv.R | 16 +- R/ddml_late.R | 30 +- R/ddml_pliv.R | 13 +- R/ddml_plm.R | 14 +- man/coef.ddml.Rd | 43 --- man/coef.ddml_rep.Rd | 42 --- man/coef.ral.Rd | 19 ++ man/coef.ral_rep.Rd | 23 ++ man/confint.ddml.Rd | 58 ---- man/confint.ddml_rep.Rd | 63 ---- man/confint.ral.Rd | 58 ++++ man/confint.ral_rep.Rd | 54 ++++ man/ddml-intro.Rd | 92 +++--- man/ddml-package.Rd | 29 +- man/ddml.Rd | 36 +-- man/ddml_apo.Rd | 38 +-- man/ddml_ate.Rd | 48 ++- man/ddml_attgt.Rd | 262 ++++++++++++++++ man/ddml_fpliv.Rd | 26 +- man/ddml_late.Rd | 38 +-- man/ddml_pliv.Rd | 26 +- man/ddml_plm.Rd | 26 +- man/ddml_rep.Rd | 3 +- man/glance.ddml.Rd | 16 +- man/glance.ddml_rep.Rd | 8 +- man/glance.ral.Rd | 20 ++ man/glance.ral_rep.Rd | 21 ++ man/hatvalues.ddml.Rd | 56 ---- man/hatvalues.ral.Rd | 44 +++ man/length.ddml_rep.Rd | 30 -- man/lincom.Rd | 180 +++++++++++ man/lincom_weights_did.Rd | 127 ++++++++ man/nobs.ddml.Rd | 20 -- man/nobs.ddml_rep.Rd | 19 -- man/nobs.ral.Rd | 19 ++ man/plot.ral.Rd | 97 ++++++ man/ral.Rd | 80 +++++ man/ral_rep.Rd | 28 ++ man/sub-sub-.ddml_rep.Rd | 32 -- man/summary.ddml.Rd | 15 +- man/summary.ddml_rep.Rd | 35 +-- man/summary.ral.Rd | 35 +++ man/summary.ral_rep.Rd | 66 ++++ man/tidy.ddml.Rd | 34 +- man/tidy.ddml_rep.Rd | 41 +-- man/tidy.ral.Rd | 52 ++++ man/tidy.ral_rep.Rd | 49 +++ man/vcov.ddml.Rd | 80 ----- man/vcov.ddml_rep.Rd | 54 ---- man/vcov.ral.Rd | 51 +++ man/vcov.ral_rep.Rd | 33 ++ tests/testthat/test-ddml.R | 203 ++++++++++-- tests/testthat/test-ddml_apo.R | 2 +- tests/testthat/test-ddml_attgt.R | 294 ++++++++++++++++++ tests/testthat/test-lincom.R | 364 ++++++++++++++++++++++ tests/testthat/test-lincom_weights.R | 246 +++++++++++++++ tests/testthat/test-ral.R | 443 +++++++++++++++++++++++++++ tests/testthat/test-ral_rep.R | 250 +++++++++++++++ 66 files changed, 3434 insertions(+), 900 deletions(-) delete mode 100644 man/coef.ddml.Rd delete mode 100644 man/coef.ddml_rep.Rd create mode 100644 man/coef.ral.Rd create mode 100644 man/coef.ral_rep.Rd delete mode 100644 man/confint.ddml.Rd delete mode 100644 man/confint.ddml_rep.Rd create mode 100644 man/confint.ral.Rd create mode 100644 man/confint.ral_rep.Rd create mode 100644 man/ddml_attgt.Rd create mode 100644 man/glance.ral.Rd create mode 100644 man/glance.ral_rep.Rd delete mode 100644 man/hatvalues.ddml.Rd create mode 100644 man/hatvalues.ral.Rd delete mode 100644 man/length.ddml_rep.Rd create mode 100644 man/lincom.Rd create mode 100644 man/lincom_weights_did.Rd delete mode 100644 man/nobs.ddml.Rd delete mode 100644 man/nobs.ddml_rep.Rd create mode 100644 man/nobs.ral.Rd create mode 100644 man/plot.ral.Rd create mode 100644 man/ral.Rd create mode 100644 man/ral_rep.Rd delete mode 100644 man/sub-sub-.ddml_rep.Rd create mode 100644 man/summary.ral.Rd create mode 100644 man/summary.ral_rep.Rd create mode 100644 man/tidy.ral.Rd create mode 100644 man/tidy.ral_rep.Rd delete mode 100644 man/vcov.ddml.Rd delete mode 100644 man/vcov.ddml_rep.Rd create mode 100644 man/vcov.ral.Rd create mode 100644 man/vcov.ral_rep.Rd create mode 100644 tests/testthat/test-ddml_attgt.R create mode 100644 tests/testthat/test-lincom.R create mode 100644 tests/testthat/test-lincom_weights.R create mode 100644 tests/testthat/test-ral.R create mode 100644 tests/testthat/test-ral_rep.R diff --git a/.Rbuildignore b/.Rbuildignore index 6ffcddd..e753b78 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -25,4 +25,6 @@ ^\.discussion$ ^\.discussions$ ^GEMINI\.md$ -^README.html$ \ No newline at end of file +^README.html$ +^R/ddml_to_did\.R$ +^tests/testthat/test-ddml_to_did\.R$ \ No newline at end of file diff --git a/.gitignore b/.gitignore index 09b0fdf..f721321 100644 --- a/.gitignore +++ b/.gitignore @@ -14,3 +14,5 @@ inst/doc .discussions/ GEMINI.md README.html +R/ddml_to_did.R +tests/testthat/test-ddml_to_did.R diff --git a/DESCRIPTION b/DESCRIPTION index aa57bfd..4000cb8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,17 +23,18 @@ RoxygenNote: 7.3.3 Depends: R (>= 4.3) Imports: - methods, - stats, + generics, + glmnet, + graphics, MASS, Matrix, + methods, nnls, pbapply, quadprog, - glmnet, ranger, - xgboost, - generics + stats, + xgboost Suggests: AER, covr, diff --git a/NAMESPACE b/NAMESPACE index 8608172..97b2a60 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,18 +1,23 @@ # Generated by roxygen2: do not edit by hand -S3method("$",ddml) S3method("[",summary.ddml) -S3method("[[",ddml_rep) -S3method(coef,ddml) -S3method(coef,ddml_rep) -S3method(confint,ddml) -S3method(confint,ddml_rep) +S3method("[[",ral_rep) +S3method(coef,ral) +S3method(coef,ral_rep) +S3method(confint,ral) +S3method(confint,ral_rep) S3method(glance,ddml) S3method(glance,ddml_rep) -S3method(hatvalues,ddml) -S3method(length,ddml_rep) -S3method(nobs,ddml) -S3method(nobs,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) @@ -22,21 +27,31 @@ S3method(predict,mdl_xgboost) S3method(predict,ols) 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(vcov,ddml) -S3method(vcov,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) @@ -47,16 +62,23 @@ 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 f5ec62e..9140573 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,7 +4,7 @@ * Adds `fitted` and `splits` parameters to all `ddml_*()` estimators for re-estimation with different ensemble types without re-fitting base learners. * Adds `diagnostics()` for per-equation MSPE, R-squared, stacking weights, and cross-validated comparison (CVC) tests. * Adds HC0 and HC3 variance estimators alongside default HC1 via `type` argument in `vcov()`, `confint()`, `summary()`, and `tidy()`. -* Adds `hatvalues()` method for generalized leverage diagnostics. +* Adds `hatvalues()` method for leverage diagnostics. * Adds `nobs()` method returning the number of observations. * Learner specifications now use `what` instead of `fun`. `fun` is accepted with a deprecation message. * Adds parallel computation via the `parallel` parameter and progress reporting via `pbapply`. diff --git a/R/ddml_apo.R b/R/ddml_apo.R index af8f091..71844a7 100644 --- a/R/ddml_apo.R +++ b/R/ddml_apo.R @@ -6,32 +6,25 @@ #' custom weights \eqn{\omega(X)}. #' #' @details -#' \strong{Parameter of Interest:} \code{ddml_apo} provides a Double/Debiased Machine Learning -#' estimator for the target parameter \eqn{\theta_0} in the model given by: +#' \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{Y = g_0(D, X) + U,} +#' \deqn{\theta_0^{\textrm{APO}} = E[\omega(X) E[Y|D=d, X]],} #' -#' where \eqn{(Y, D, X, U)} is a random vector such that -#' \eqn{E[U\vert D, X] = 0} and -#' \eqn{\Pr(D=d\vert X) \in (0, 1)} with probability 1, -#' and \eqn{g_0} is an unknown nuisance function. -#' -#' In this model, the average potential outcome (APO) for treatment -#' level \eqn{d} is defined as -#' -#' \deqn{\theta_0^{\textrm{APO}} \equiv E[\omega(X) g_0(d, X)],} -#' -#' where \eqn{\omega(X)} is a known weighting function. If \eqn{\omega(X) = 1}, -#' this parameter corresponds to the standard Average Potential Outcome (APO) +#' 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, p)} taking true values \eqn{\ell_0(X) = E[Y|D=d, X]} and -#' \eqn{p_0(X) = E[\mathbf{1}\{D=d\}|X]}. +#' \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))}{p(X)} + \ell(X) \right) \omega(X) - \theta} +#' \deqn{m(W; \theta, \eta) = \left( \frac{\mathbf{1}\{D=d\} (Y - \ell(X))}{r(X)} + \ell(X) \right) \omega(X) - \theta} #' #' \strong{Jacobian:} #' diff --git a/R/ddml_ate.R b/R/ddml_ate.R index 15dcee9..acd3ddd 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -6,40 +6,34 @@ #' treatment effect on the treated. #' #' @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, 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{Y = g_0(D, X) + U,} -#' -#' 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. -#' -#' In this model, the average treatment effect (ATE) is defined as -#' -#' \deqn{\theta_0^{\textrm{ATE}} \equiv E[g_0(1, X) - g_0(0, X)],} +#' \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}} \equiv E[g_0(1, X) - g_0(0, X)\vert D = 1].} +#' \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. #' #' \strong{Neyman Orthogonal Score:} The Neyman orthogonal scores are: #' -#' \deqn{m^{\textrm{ATE}}(W; \theta, \eta) = \frac{D(Y - \ell_1(X))}{p(X)} - \frac{(1-D)(Y-\ell_0(X))}{1-p(X)} + \ell_1(X) - \ell_0(X) - \theta} +#' \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} #' -#' \deqn{m^{\textrm{ATT}}(W; \theta, \eta) = \frac{D(Y - \ell_0(X))}{\pi} - \frac{p(X)(1-D)(Y-\ell_0(X))}{\pi(1-p(X))} - \frac{D\theta}{\pi}} +#' \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} #' -#' where the nuisance parameters are \eqn{\eta = (\ell_0, \ell_1, p, \pi)} taking true values -#' \eqn{\ell_{d,0}(X) = E[Y|D=d, X]}, \eqn{p_0(X) = E[D|X]}, and \eqn{\pi_0 = E[D]}. +#' 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:} #' #' \deqn{J^{\textrm{ATE}} = -1} #' -#' \deqn{J^{\textrm{ATT}} = -E[D / \pi]} +#' \deqn{J^{\textrm{ATT}} = -1} #' #' See \code{\link{ddml-intro}} for how the influence function #' and inference are derived from these components. diff --git a/R/ddml_attgt.R b/R/ddml_attgt.R index e1009fc..67653bb 100644 --- a/R/ddml_attgt.R +++ b/R/ddml_attgt.R @@ -18,10 +18,13 @@ #' \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_i^{(g,t)} = +#' \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\} diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index 835aa88..03df9d3 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -5,16 +5,16 @@ #' @description Estimator for the flexible partially linear IV coefficient. #' #' @details -#' \strong{Parameter of Interest:} \code{ddml_fpliv} provides a Double/Debiased Machine Learning -#' estimator for the target parameter \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: #' -#' \deqn{Y = \theta_0 D + g_0(X) + U,} -#' -#' 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{Y = \theta_0 D + g_0(X) + \varepsilon, \quad E[\varepsilon|X, Z] = 0,} #' +#' 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))} diff --git a/R/ddml_late.R b/R/ddml_late.R index 4f1b769..70353fd 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -5,28 +5,22 @@ #' @description Estimator for 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 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{Y = g_0(D, X) + U,} +#' \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]]}} #' -#' 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. -#' -#' In this model, the local average treatment effect (LATE) is defined as -#' -#' \deqn{\theta_0^{\textrm{LATE}} \equiv E[g_0(1, X) - g_0(0, X)\vert p_0(1, X) > p_0(0, X)].} +#' where \eqn{W \equiv (Y, D, X, Z)} is the observed random vector. #' #' \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) = E[Z|X]}. +#' and \eqn{p_0(X) = \Pr(Z=1|X)}. #' #' \strong{Neyman Orthogonal Score / Moment Equation:} The Neyman orthogonal score is: #' @@ -34,9 +28,7 @@ #' #' \strong{Jacobian:} #' -#' \deqn{J = -E\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]} +#' \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. diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index a4769d7..4c77e68 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -5,15 +5,14 @@ #' @description Estimator for the partially linear IV coefficient. #' #' @details -#' \strong{Parameter of Interest:} \code{ddml_pliv} provides a Double/Debiased Machine Learning -#' estimator for the target parameter \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) + U,} +#' \deqn{Y = \theta_0 D + g_0(X) + \varepsilon, \quad E[Z\varepsilon] = 0, \quad E[\varepsilon|X] = 0,} #' -#' 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. +#' 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. #' #' \strong{Neyman Orthogonal Score:} The Neyman orthogonal score is: #' diff --git a/R/ddml_plm.R b/R/ddml_plm.R index 4b6fd99..85f3890 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -5,15 +5,15 @@ #' @description Estimator for the partially linear regression coefficient. #' #' @details -#' \strong{Parameter of Interest:} \code{ddml_plm} provides a Double/Debiased Machine Learning -#' estimator for the target parameter \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) + U,} +#' \deqn{Y = \theta_0 D + g_0(X) + \varepsilon, \quad E[D\varepsilon] = 0, \quad E[\varepsilon|X] = 0,} #' -#' 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. +#' 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. #' #' \strong{Neyman Orthogonal Score:} The Neyman orthogonal score is: #' diff --git a/man/coef.ddml.Rd b/man/coef.ddml.Rd deleted file mode 100644 index ae15b10..0000000 --- a/man/coef.ddml.Rd +++ /dev/null @@ -1,43 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml.R -\name{coef.ddml} -\alias{coef.ddml} -\title{Extract Model Coefficients} -\usage{ -\method{coef}{ddml}(object, ...) -} -\arguments{ -\item{object}{An object of class \code{ddml}.} - -\item{...}{Currently unused.} -} -\value{ -Named vector (single ensemble) or matrix -(multiple ensembles). -} -\description{ -Extracts the estimated coefficients -from a DDML model for the specified or default -ensemble type. -} -\examples{ -\donttest{ -# Fit a PLM and extract coefficients -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) -coef(plm_fit) -} - -} -\seealso{ -Other ddml inference: -\code{\link{confint.ddml}()}, -\code{\link{hatvalues.ddml}()}, -\code{\link{summary.ddml}()}, -\code{\link{vcov.ddml}()} -} -\concept{ddml inference} diff --git a/man/coef.ddml_rep.Rd b/man/coef.ddml_rep.Rd deleted file mode 100644 index 405a833..0000000 --- a/man/coef.ddml_rep.Rd +++ /dev/null @@ -1,42 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml_rep.R -\name{coef.ddml_rep} -\alias{coef.ddml_rep} -\title{Extract Aggregated Coefficients from a ddml_rep Object} -\usage{ -\method{coef}{ddml_rep}(object, aggregation = c("median", "mean", "spectral"), ...) -} -\arguments{ -\item{object}{A \code{ddml_rep} object.} - -\item{aggregation}{Character string: \code{"median"} -(default), \code{"mean"}, or \code{"spectral"}. -See \code{\link{summary.ddml_rep}} for details.} - -\item{...}{Additional arguments.} -} -\value{ -Named vector (single ensemble) or matrix -(multiple ensembles). -} -\description{ -Extract Aggregated Coefficients from a ddml_rep Object -} -\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) -coef(reps) -coef(reps, aggregation = "mean") -} - -} -\seealso{ -\code{\link{summary.ddml_rep}} for the -aggregation equations. -} 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.ddml.Rd b/man/confint.ddml.Rd deleted file mode 100644 index 8865b92..0000000 --- a/man/confint.ddml.Rd +++ /dev/null @@ -1,58 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml.R -\name{confint.ddml} -\alias{confint.ddml} -\title{Confidence Intervals for DDML Estimators} -\usage{ -\method{confint}{ddml}(object, parm, level = 0.95, ensemble_idx = 1, type = "HC1", ...) -} -\arguments{ -\item{object}{An object of class \code{ddml}.} - -\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{ensemble_idx}{Integer index of the ensemble type to -use. Defaults to 1 (first ensemble type).} - -\item{type}{Character string specifying the -variance-covariance estimator. One of \code{"HC1"} -(default), \code{"HC0"}, or \code{"HC3"}.} - -\item{...}{Currently unused.} -} -\value{ -A matrix with columns for lower and upper bounds. -} -\description{ -Computes confidence intervals for one or more -parameters in a fitted DDML model. -} -\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) -confint(plm_fit) -confint(plm_fit, parm = "D1") -confint(plm_fit, level = 0.90) -} - -} -\seealso{ -\code{\link{vcov.ddml}} - -Other ddml inference: -\code{\link{coef.ddml}()}, -\code{\link{hatvalues.ddml}()}, -\code{\link{summary.ddml}()}, -\code{\link{vcov.ddml}()} -} -\concept{ddml inference} diff --git a/man/confint.ddml_rep.Rd b/man/confint.ddml_rep.Rd deleted file mode 100644 index 4e59f7f..0000000 --- a/man/confint.ddml_rep.Rd +++ /dev/null @@ -1,63 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml_rep.R -\name{confint.ddml_rep} -\alias{confint.ddml_rep} -\title{Confidence Intervals for ddml_rep Objects} -\usage{ -\method{confint}{ddml_rep}( - object, - parm, - level = 0.95, - ensemble_idx = 1, - aggregation = c("median", "mean", "spectral"), - type = "HC1", - ... -) -} -\arguments{ -\item{object}{A \code{ddml_rep} object.} - -\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{ensemble_idx}{Integer index of the ensemble type. -Defaults to 1.} - -\item{aggregation}{Character string: \code{"median"} -(default), \code{"mean"}, or \code{"spectral"}. -See \code{\link{summary.ddml_rep}} for details.} - -\item{type}{Character string specifying the -variance-covariance estimator. One of \code{"HC1"} -(default), \code{"HC0"}, or \code{"HC3"}.} - -\item{...}{Currently unused.} -} -\value{ -A matrix with columns for lower and upper bounds. -} -\description{ -Confidence Intervals for 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), - sample_folds = 2, - resamples = 3, silent = TRUE) -confint(reps) -confint(reps, level = 0.90) -} - -} -\seealso{ -\code{\link{summary.ddml_rep}} for the -aggregation equations. -} 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/ddml-intro.Rd b/man/ddml-intro.Rd index ca0b739..40bcbbc 100644 --- a/man/ddml-intro.Rd +++ b/man/ddml-intro.Rd @@ -131,18 +131,8 @@ parameter \eqn{\theta_0} identified by a moment condition where \eqn{W} denotes observed random variables and \eqn{\eta_0} is a (potentially high-dimensional) nuisance -parameter, typically a vector of conditional expectation -functions. The score \eqn{m} is \emph{Neyman orthogonal}, -meaning the moment condition is locally insensitive to -perturbations of \eqn{\eta} around \eqn{\eta_0}. - -Each estimator in \code{ddml} uses a score that decomposes -linearly in \eqn{\theta}: - -\deqn{m(W_i; \theta, \eta) = \psi_b(W_i; \eta) + \psi_a(W_i; \eta)\,\theta.} - -See the individual estimator pages for the specific forms -of \eqn{\psi_a} and \eqn{\psi_b}. +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 @@ -154,32 +144,57 @@ evaluated on fold \eqn{k}. The DML estimator \deqn{\frac{1}{n} \sum_{k=1}^{K} \sum_{i \in I_k} m(W_i; \hat\theta, \hat\eta_{-k}) = 0.} -For the linear scores used in \code{ddml}, this yields the -closed-form solution +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} \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\theta = -\hat{J}^{-1}\,\hat\psi_b,} +\deqn{\hat{J} = \frac{1}{n} \sum_i + \frac{\partial m(W_i; \hat\theta, \hat\eta_{-k(i)})} + {\partial \theta'}.} -where \eqn{\hat\psi_b = n^{-1}\sum_{k}\sum_{i \in I_k} -\psi_b(W_i; \hat\eta_{-k})} and -\eqn{\hat{J} = n^{-1}\sum_k \sum_{i \in I_k} -\psi_a(W_i; \hat\eta_{-k})} is the sample Jacobian. +HC1 and HC3 variance estimators are described in +\code{\link{vcov.ral}}. The leverage +(see \code{\link{hatvalues.ral}}) for the DML estimator +is -Inference is based on the sandwich variance estimator +\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),} -\deqn{\hat\Sigma = \hat{J}^{-1} \left(\frac{1}{n} -\sum_i m_i m_i^\top\right) -\hat{J}^{-\top} / n} +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}. -where \eqn{m_i = m(W_i; \hat\theta, \hat\eta_{-k(i)})}; -see \code{\link{vcov.ddml}} for HC0/HC1/HC3 variants. -Under regularity conditions and sufficient convergence of \eqn{\hat\eta}, -the DML estimator is asymptotically normal: +Under regularity conditions and sufficient convergence of +\eqn{\hat\eta}, the DML estimator is asymptotically normal: -\deqn{\sqrt{n}\,\hat\Sigma^{-1/2}(\hat\theta - \theta_0) +\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). +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}{ @@ -197,11 +212,13 @@ 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{psi_a}, \code{psi_b}}{Score component lists -(length \code{nensb}). \code{psi_a[[j]]} is an -\code{(n x p x p)} array and \code{psi_b[[j]]} is an -\code{(n x p)} matrix. Used internally by -\code{\link{hatvalues.ddml}}.} +\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 @@ -234,9 +251,9 @@ the estimator (e.g., \code{"Partially Linear Model"}).} The following generic methods are available for all \code{ddml} objects: \code{\link{summary.ddml}}, -\code{\link{coef.ddml}}, \code{\link{vcov.ddml}}, -\code{\link{confint.ddml}}, \code{\link{hatvalues.ddml}}, -\code{\link{nobs.ddml}}, \code{\link{tidy.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}}. } @@ -255,6 +272,7 @@ Journal, 21(1), C1-C68. 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}()}, diff --git a/man/ddml-package.Rd b/man/ddml-package.Rd index d3edf62..2f9ce01 100644 --- a/man/ddml-package.Rd +++ b/man/ddml-package.Rd @@ -3,18 +3,31 @@ \docType{package} \name{ddml-package} \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 index a0b506a..35d2733 100644 --- a/man/ddml.Rd +++ b/man/ddml.Rd @@ -2,15 +2,13 @@ % Please edit documentation in R/ddml.R \name{ddml} \alias{ddml} -\alias{$.ddml} \title{Construct a \code{ddml} Object.} \usage{ ddml( coefficients, scores, J, - psi_a, - psi_b, + inf_func, nobs, coef_names, estimator_name, @@ -26,10 +24,9 @@ ddml( splits = NULL, call = match.call(), subclass = NULL, + dinf_dtheta = NULL, ... ) - -\method{$}{ddml}(x, name) } \arguments{ \item{coefficients}{A \code{(p x nensb)} matrix of estimated @@ -42,13 +39,8 @@ 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{psi_a}{A list of length \code{nensb}. Each element is an -\code{(n x p x p)} array of individual-level Jacobian -contributions.} - -\item{psi_b}{A list of length \code{nensb}. Each element is an -\code{(n x p)} matrix of individual-level score -contributions.} +\item{inf_func}{A 3D array of evaluated influence functions +with dimensions \code{(n x p x nensb)}.} \item{nobs}{Number of observations.} @@ -89,11 +81,10 @@ objects. Optional.} provided, the object will have class \code{c(subclass, "ddml")}.} -\item{...}{Additional named components to include in the object.} - -\item{x}{An object of class \code{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{name}{Name of the element to extract.} +\item{...}{Additional named components to include in the object.} } \value{ An object of S3 class \code{"ddml"} (or @@ -104,8 +95,8 @@ See \code{\link{ddml-intro}} for the output structure. 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.ddml}}, -\code{\link{vcov.ddml}}, and \code{\link{tidy.ddml}}. +\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 @@ -118,12 +109,13 @@ 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))) -coef <- matrix(theta, 1, 1, - dimnames = list("mean", "custom")) +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, - psi_a = psi_a, psi_b = psi_b, - nobs = n, coef_names = "mean", + inf_func = inf_func, nobs = n, coef_names = "mean", + dinf_dtheta = dinf_dtheta, estimator_name = "Sample Mean") summary(fit) } diff --git a/man/ddml_apo.Rd b/man/ddml_apo.Rd index 67d9d5f..5e24b66 100644 --- a/man/ddml_apo.Rd +++ b/man/ddml_apo.Rd @@ -165,42 +165,33 @@ 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 target parameter \eqn{\theta_0} in the model given by: +\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{Y = g_0(D, X) + U,} +\deqn{\theta_0^{\textrm{APO}} = E[\omega(X) E[Y|D=d, X]],} -where \eqn{(Y, D, X, U)} is a random vector such that -\eqn{E[U\vert D, X] = 0} and -\eqn{\Pr(D=d\vert X) \in (0, 1)} with probability 1, -and \eqn{g_0} is an unknown nuisance function. - -In this model, the average potential outcome (APO) for treatment -level \eqn{d} is defined as - -\deqn{\theta_0^{\textrm{APO}} \equiv E[\omega(X) g_0(d, X)],} +where \eqn{W \equiv (Y, D, X)} is the observed random vector. where \eqn{\omega(X)} is a known weighting function. If \eqn{\omega(X) = 1}, -this parameter corresponds to the standard Average Potential Outcome (APO) +this parameter corresponds to the average potential outcome at treatment level \eqn{d}. \strong{Nuisance Parameters:} The nuisance parameters are -\eqn{\eta = (\ell, p)} taking true values \eqn{\ell_0(X) = E[Y|D=d, X]} and -\eqn{p_0(X) = E[\mathbf{1}\{D=d\}|X]}. +\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))}{p(X)} + \ell(X) \right) \omega(X) - \theta} - -\strong{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: - -\deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} +\deqn{m(W; \theta, \eta) = \left( \frac{\mathbf{1}\{D=d\} (Y - \ell(X))}{r(X)} + \ell(X) \right) \omega(X) - \theta} -where: +\strong{Jacobian:} -\deqn{\psi_a(W; \eta) = -1} +\deqn{J = -1} -\deqn{\psi_b(W; \eta) = \left( \frac{\mathbf{1}\{D=d\} (Y - \ell(X))}{p(X)} + \ell(X) \right) \omega(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 @@ -220,6 +211,7 @@ summary(apo_fit) 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}()}, diff --git a/man/ddml_ate.Rd b/man/ddml_ate.Rd index df869ce..56a9f4e 100644 --- a/man/ddml_ate.Rd +++ b/man/ddml_ate.Rd @@ -181,48 +181,37 @@ Estimator for the average treatment effect and the average treatment effect on the treated. } \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, 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{Y = g_0(D, X) + U,} - -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. - -In this model, the average treatment effect (ATE) is defined as - -\deqn{\theta_0^{\textrm{ATE}} \equiv E[g_0(1, X) - g_0(0, X)],} +\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}} \equiv E[g_0(1, X) - g_0(0, X)\vert D = 1].} +\deqn{\theta_0^{\textrm{ATT}} = E[Y|D=1] - E[E[Y|D=0, X]|D = 1].} -\strong{Neyman Orthogonal Score:} The Neyman orthogonal scores are: +where \eqn{W \equiv (Y, D, X)} is the observed random vector. -\deqn{m^{\textrm{ATE}}(W; \theta, \eta) = \frac{D(Y - \ell_1(X))}{p(X)} - \frac{(1-D)(Y-\ell_0(X))}{1-p(X)} + \ell_1(X) - \ell_0(X) - \theta} - -\deqn{m^{\textrm{ATT}}(W; \theta, \eta) = \frac{D(Y - \ell_0(X))}{\pi} - \frac{p(X)(1-D)(Y-\ell_0(X))}{\pi(1-p(X))} - \frac{D\theta}{\pi}} - -where the nuisance parameters are \eqn{\eta = (\ell_0, \ell_1, p, \pi)} taking true values -\eqn{\ell_{d,0}(X) = E[Y|D=d, X]}, \eqn{p_0(X) = E[D|X]}, and \eqn{\pi_0 = E[D]}. +\strong{Neyman Orthogonal Score:} The Neyman orthogonal scores are: -\strong{Linear Decomposition:} The scores decompose linearly in \eqn{\theta}: +\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} -\deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} +\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} -where: +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)}. -\deqn{\psi_a^{\textrm{ATE}}(W; \eta) = -1} +\strong{Jacobian:} -\deqn{\psi_b^{\textrm{ATE}}(W; \eta) = \frac{D(Y - \ell_1(X))}{p(X)} - \frac{(1-D)(Y-\ell_0(X))}{1-p(X)} + \ell_1(X) - \ell_0(X)} +\deqn{J^{\textrm{ATE}} = -1} -\deqn{\psi_a^{\textrm{ATT}}(W; \eta) = -\frac{D}{\pi}} +\deqn{J^{\textrm{ATT}} = -1} -\deqn{\psi_b^{\textrm{ATT}}(W; \eta) = \frac{D(Y - \ell_0(X))}{\pi} - \frac{p(X)(1-D)(Y-\ell_0(X))}{\pi(1-p(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 @@ -259,6 +248,7 @@ summary(ate_fit) 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}()}, 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 70c0400..153409e 100644 --- a/man/ddml_fpliv.Rd +++ b/man/ddml_fpliv.Rd @@ -157,15 +157,15 @@ Additional pass-through fields: \code{learners}, Estimator for the flexible partially linear IV coefficient. } \details{ -\strong{Parameter of Interest:} \code{ddml_fpliv} provides a Double/Debiased Machine Learning -estimator for the target parameter \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: -\deqn{Y = \theta_0 D + 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: @@ -174,15 +174,12 @@ and \eqn{g_0} is an unknown nuisance function. 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{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: +\strong{Jacobian:} -\deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} +\deqn{J = -E[(D - r(X))(v(X, Z) - r(X))^\top]} -where: - -\deqn{\psi_a(W; \eta) = -(D - r(X))(v(X, Z) - r(X))^\top} - -\deqn{\psi_b(W; \eta) = (v(X, Z) - r(X))(Y - \ell(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 @@ -204,6 +201,7 @@ 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}()} diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index de98282..e3ccaea 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -165,42 +165,33 @@ Additional pass-through fields: \code{learners}, Estimator for 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 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{Y = g_0(D, X) + U,} +\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]]}} -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. - -In this model, the local average treatment effect (LATE) is defined as - -\deqn{\theta_0^{\textrm{LATE}} \equiv E[g_0(1, X) - g_0(0, X)\vert p_0(1, X) > p_0(0, X)].} +where \eqn{W \equiv (Y, D, X, Z)} is the observed random vector. \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) = E[Z|X]}. +and \eqn{p_0(X) = \Pr(Z=1|X)}. \strong{Neyman Orthogonal Score / Moment Equation:} The Neyman orthogonal score is: \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{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: - -\deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} - -where: +\strong{Jacobian:} -\deqn{\psi_a(W; \eta) = -\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)} +\deqn{J = -E[r_1(X) - r_0(X)]} -\deqn{\psi_b(W; \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)} +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 @@ -246,6 +237,7 @@ 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}()} diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index 41a1ee1..7224cb9 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -157,16 +157,14 @@ fields: \code{learners}, \code{learners_DX}, Estimator for the partially linear IV coefficient. } \details{ -\strong{Parameter of Interest:} \code{ddml_pliv} provides a Double/Debiased Machine Learning -estimator for the target parameter \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) + U,} - -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. +\deqn{Y = \theta_0 D + g_0(X) + \varepsilon, \quad E[Z\varepsilon] = 0, \quad E[\varepsilon|X] = 0,} +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. \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))} @@ -174,15 +172,12 @@ where \eqn{(Y, D, X, Z, U)} is a random vector such that 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{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: - -\deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} - -where: +\strong{Jacobian:} -\deqn{\psi_a(W; \eta) = -(D - r_D(X))(Z - r_Z(X))^\top} +\deqn{J = -E[(D - r_D(X))(Z - r_Z(X))^\top]} -\deqn{\psi_b(W; \eta) = (Z - r_Z(X))(Y - \ell(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 @@ -204,6 +199,7 @@ 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}()} diff --git a/man/ddml_plm.Rd b/man/ddml_plm.Rd index a03e6bd..65972a0 100644 --- a/man/ddml_plm.Rd +++ b/man/ddml_plm.Rd @@ -147,15 +147,15 @@ fields: \code{learners}, \code{learners_DX}. Estimator for the partially linear regression coefficient. } \details{ -\strong{Parameter of Interest:} \code{ddml_plm} provides a Double/Debiased Machine Learning -estimator for the target parameter \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) + U,} +\deqn{Y = \theta_0 D + g_0(X) + \varepsilon, \quad E[D\varepsilon] = 0, \quad E[\varepsilon|X] = 0,} -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. +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. \strong{Neyman Orthogonal Score:} The Neyman orthogonal score is: @@ -164,15 +164,12 @@ where \eqn{(Y, D, X, U)} is a random vector such that 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{Linear Decomposition:} The score decomposes linearly in \eqn{\theta}: +\strong{Jacobian:} -\deqn{m(W; \theta, \eta) = \psi_b(W; \eta) + \psi_a(W; \eta)\theta} +\deqn{J = -E[(D - r_0(X))(D - r_0(X))^\top]} -where: - -\deqn{\psi_a(W; \eta) = -(D - r(X))(D - r(X))^\top} - -\deqn{\psi_b(W; \eta) = (D - r(X))(Y - \ell(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 @@ -227,6 +224,7 @@ 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}()} diff --git a/man/ddml_rep.Rd b/man/ddml_rep.Rd index f93aef2..48a8d4f 100644 --- a/man/ddml_rep.Rd +++ b/man/ddml_rep.Rd @@ -20,7 +20,8 @@ number of observations.} \item{...}{Currently unused.} } \value{ -An object of class \code{"ddml_rep"} with fields: +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.} diff --git a/man/glance.ddml.Rd b/man/glance.ddml.Rd index db5c1a7..5cecb5e 100644 --- a/man/glance.ddml.Rd +++ b/man/glance.ddml.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ddml.R \name{glance.ddml} \alias{glance.ddml} -\title{Glance at a ddml Object} +\title{Glance at a DDML Object} \usage{ \method{glance}{ddml}(x, ...) } @@ -12,14 +12,12 @@ \item{...}{Currently unused.} } \value{ -A one-row \code{data.frame} with columns -\code{nobs}, \code{sample_folds}, \code{shortstack}, -\code{ensemble_type}, and \code{model_type}. +A one-row \code{data.frame}. } \description{ -Returns a one-row summary of model-level statistics, -compatible with \pkg{modelsummary} and the \pkg{broom} -ecosystem. +DML-specific glance method. Includes DML fields like +\code{sample_folds}, \code{shortstack}, and +\code{model_type}. } \examples{ \donttest{ @@ -33,7 +31,3 @@ glance(plm_fit) } } -\seealso{ -\code{\link{tidy.ddml}}, -\code{\link{summary.ddml}} -} diff --git a/man/glance.ddml_rep.Rd b/man/glance.ddml_rep.Rd index d71f3b2..ce848b5 100644 --- a/man/glance.ddml_rep.Rd +++ b/man/glance.ddml_rep.Rd @@ -12,14 +12,10 @@ \item{...}{Currently unused.} } \value{ -A one-row \code{data.frame} with columns \code{nobs}, -\code{sample_folds}, \code{shortstack}, \code{ensemble_type}, -\code{model_type}, and \code{nresamples}. +A one-row \code{data.frame}. } \description{ -Returns a one-row summary of model-level statistics, -compatible with \pkg{modelsummary} and the \pkg{broom} -ecosystem. +DML-specific glance method. Includes DML fields. } \examples{ \donttest{ 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.ddml.Rd b/man/hatvalues.ddml.Rd deleted file mode 100644 index 09918bf..0000000 --- a/man/hatvalues.ddml.Rd +++ /dev/null @@ -1,56 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml.R -\name{hatvalues.ddml} -\alias{hatvalues.ddml} -\title{Extract Generalized Leverage (Hat Values)} -\usage{ -\method{hatvalues}{ddml}(model, ensemble_idx = 1, ...) -} -\arguments{ -\item{model}{An object of class \code{ddml}.} - -\item{ensemble_idx}{Integer index of the ensemble type to extract leverage -values for. Defaults to 1.} - -\item{...}{Currently unused.} -} -\value{ -A numeric vector of generalized leverage values. -} -\description{ -Computes the generalized leverage (hat values) for a DDML -estimator. These values are used internally to compute -heteroskedasticity-robust HC3 standard errors. -} -\details{ -See \code{\link{ddml-intro}} for the DML framework and -the definition of \eqn{\psi_a} and \eqn{\hat{J}}. -For the linear scores used in \code{ddml}, -the generalized leverage simplifies to - -\eqn{h_{ii} = \mathrm{tr}(\psi_a(W_i; -\hat\eta)\,(n\hat{J})^{-1}).} -} -\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) -h = hatvalues(plm_fit) -head(h) -} - -} -\seealso{ -\code{\link{vcov.ddml}} for the use of leverage in HC3 standard errors. - -Other ddml inference: -\code{\link{coef.ddml}()}, -\code{\link{confint.ddml}()}, -\code{\link{summary.ddml}()}, -\code{\link{vcov.ddml}()} -} -\concept{ddml inference} 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/length.ddml_rep.Rd b/man/length.ddml_rep.Rd deleted file mode 100644 index 7b92443..0000000 --- a/man/length.ddml_rep.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml_rep.R -\name{length.ddml_rep} -\alias{length.ddml_rep} -\title{Number of Resamples in a ddml_rep Object} -\usage{ -\method{length}{ddml_rep}(x) -} -\arguments{ -\item{x}{A \code{ddml_rep} object.} -} -\value{ -Integer number of resamples. -} -\description{ -Number of Resamples in a ddml_rep Object -} -\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) -length(reps) -} - -} diff --git a/man/lincom.Rd b/man/lincom.Rd new file mode 100644 index 0000000..5e655c3 --- /dev/null +++ b/man/lincom.Rd @@ -0,0 +1,180 @@ +% 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 = 1, + labels = NULL, + inf_func_R = NULL, + dinf_dR = NULL, + ... +) + +\method{lincom}{ddml_rep}( + fit, + R, + inf_func_R = NULL, + dinf_dR = NULL, + fit_idx = 1, + 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. +Default 1.} + +\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..e328bf9 --- /dev/null +++ b/man/lincom_weights_did.Rd @@ -0,0 +1,127 @@ +% 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 = 1 +) +} +\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. Default 1.} +} +\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/nobs.ddml.Rd b/man/nobs.ddml.Rd deleted file mode 100644 index 6732b09..0000000 --- a/man/nobs.ddml.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml.R -\name{nobs.ddml} -\alias{nobs.ddml} -\title{Extract Number of Observations} -\usage{ -\method{nobs}{ddml}(object, ...) -} -\arguments{ -\item{object}{An object of class \code{ddml}.} - -\item{...}{Currently unused.} -} -\value{ -An integer specifying the number of observations. -} -\description{ -Returns the number of observations -used to fit the DDML model. -} diff --git a/man/nobs.ddml_rep.Rd b/man/nobs.ddml_rep.Rd deleted file mode 100644 index f6fea74..0000000 --- a/man/nobs.ddml_rep.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml_rep.R -\name{nobs.ddml_rep} -\alias{nobs.ddml_rep} -\title{Extract Number of Observations from a ddml_rep Object} -\usage{ -\method{nobs}{ddml_rep}(object, ...) -} -\arguments{ -\item{object}{A \code{ddml_rep} object.} - -\item{...}{Currently unused.} -} -\value{ -An integer specifying the number of observations. -} -\description{ -Extract Number of Observations from a ddml_rep Object -} 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/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/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/sub-sub-.ddml_rep.Rd b/man/sub-sub-.ddml_rep.Rd deleted file mode 100644 index bdbc5e3..0000000 --- a/man/sub-sub-.ddml_rep.Rd +++ /dev/null @@ -1,32 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml_rep.R -\name{[[.ddml_rep} -\alias{[[.ddml_rep} -\title{Extract a Single Fit from a ddml_rep Object} -\usage{ -\method{[[}{ddml_rep}(x, i) -} -\arguments{ -\item{x}{A \code{ddml_rep} object.} - -\item{i}{Integer index of the fit to extract.} -} -\value{ -The \code{i}-th \code{ddml} fit. -} -\description{ -Extract a Single Fit from a ddml_rep Object -} -\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) -coef(reps[[1]]) -} - -} diff --git a/man/summary.ddml.Rd b/man/summary.ddml.Rd index 08422f6..664c13f 100644 --- a/man/summary.ddml.Rd +++ b/man/summary.ddml.Rd @@ -12,9 +12,9 @@ \arguments{ \item{object}{An object of class \code{ddml}.} -\item{type}{Character string specifying the -variance-covariance estimator. One of \code{"HC1"} -(default), \code{"HC0"}, or \code{"HC3"}.} +\item{type}{Character. HC type (\code{"HC0"}, +\code{"HC1"}, or \code{"HC3"}). Default +\code{"HC1"}.} \item{...}{Currently unused.} @@ -40,7 +40,7 @@ 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.ddml}} for the HC0/HC1/HC3 formulas. +\code{\link{vcov.ral}} for the HC0/HC1/HC3 formulas. } \examples{ \donttest{ @@ -56,12 +56,9 @@ summary(plm_fit, type = "HC3") } \seealso{ -\code{\link{vcov.ddml}} +\code{\link{vcov.ral}} Other ddml inference: -\code{\link{coef.ddml}()}, -\code{\link{confint.ddml}()}, -\code{\link{hatvalues.ddml}()}, -\code{\link{vcov.ddml}()} +\code{\link{lincom}()} } \concept{ddml inference} diff --git a/man/summary.ddml_rep.Rd b/man/summary.ddml_rep.Rd index f5ed28b..a11a7b5 100644 --- a/man/summary.ddml_rep.Rd +++ b/man/summary.ddml_rep.Rd @@ -18,12 +18,9 @@ \item{object}{A \code{ddml_rep} object.} \item{aggregation}{Character string: \code{"median"} -(default), \code{"mean"}, or \code{"spectral"}. -See \code{\link{summary.ddml_rep}} for details.} +(default), \code{"mean"}, or \code{"spectral"}.} -\item{type}{Character string specifying the -variance-covariance estimator. One of \code{"HC1"} -(default), \code{"HC0"}, or \code{"HC3"}.} +\item{type}{Character. HC type. Default \code{"HC1"}.} \item{...}{Currently unused.} @@ -35,31 +32,13 @@ variance-covariance estimator. One of \code{"HC1"} An object of class \code{"summary.ddml_rep"}. } \description{ -Aggregates coefficient estimates and covariance matrices -across \eqn{R} independent sample-splitting replications. +DML-specific summary override. Adds ensemble type labels, +folds, shortstack status to the base \code{ral_rep} +summary. } \details{ -Let \eqn{\hat\theta_r} and \eqn{\hat\Sigma_r} denote -the coefficient vector and sandwich covariance matrix -from replication \eqn{r}. - -\strong{Coefficient aggregation.} -For \code{"mean"}: -\eqn{\tilde\theta = R^{-1} \sum_{r=1}^{R} \hat\theta_r}. -For \code{"median"} and \code{"spectral"}: -\eqn{\tilde\theta_j = \mathrm{median}_{r}(\hat\theta_{r,j})}. - -\strong{Covariance aggregation.} -Define the inflated per-replication covariance as -\deqn{V_r = \hat\Sigma_r + (\hat\theta_r - \tilde\theta) - (\hat\theta_r - \tilde\theta)^\top}. -For \code{"mean"}: -\eqn{\tilde\Sigma = R^{-1} \sum_{r=1}^{R} V_r}. -For \code{"median"}: -\eqn{\tilde\Sigma_{ij} = \mathrm{median}_{r}(V_{r,ij})}. -For \code{"spectral"}: -\eqn{\tilde\Sigma = \arg\min_{\Sigma \succeq 0} \sum_{r} \|\Sigma - V_r\|_2}, -solved via \pkg{CVXR}. Guarantees positive semi-definiteness of \eqn{\tilde\Sigma}. +See \code{\link{summary.ral_rep}} for the aggregation +formulas. } \examples{ \donttest{ 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 index d47e382..6c63d29 100644 --- a/man/tidy.ddml.Rd +++ b/man/tidy.ddml.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ddml.R \name{tidy.ddml} \alias{tidy.ddml} -\title{Tidy a ddml Object} +\title{Tidy a DDML Object} \usage{ \method{tidy}{ddml}( x, @@ -10,6 +10,8 @@ conf.int = FALSE, conf.level = 0.95, type = "HC1", + uniform = FALSE, + bootstraps = 999L, ... ) } @@ -17,33 +19,31 @@ \item{x}{A \code{ddml} object.} \item{ensemble_idx}{Integer index of the ensemble type to -report. Defaults to 1 (first ensemble type). Set to -\code{NULL} to return results for all ensemble types.} +report. Defaults to 1. Set to \code{NULL} for all.} -\item{conf.int}{Logical. Include confidence interval -columns? Default \code{FALSE}.} +\item{conf.int}{Logical. Include confidence intervals? +Default \code{FALSE}.} -\item{conf.level}{Confidence level for intervals. -Default 0.95.} +\item{conf.level}{Confidence level. Default 0.95.} -\item{type}{Character string specifying the -variance-covariance estimator. One of \code{"HC1"} -(default), \code{"HC0"}, or \code{"HC3"}.} +\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}. If -\code{conf.int = TRUE}, also \code{conf.low} and -\code{conf.high}. +\code{p.value}, and \code{ensemble_type}. } \description{ -Extracts coefficient estimates, standard errors, test -statistics, and p-values from a \code{ddml} estimator in a -format compatible with \pkg{modelsummary} and the -\pkg{broom} ecosystem. +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{ diff --git a/man/tidy.ddml_rep.Rd b/man/tidy.ddml_rep.Rd index 4aa37f1..90801e1 100644 --- a/man/tidy.ddml_rep.Rd +++ b/man/tidy.ddml_rep.Rd @@ -11,6 +11,8 @@ type = "HC1", conf.int = FALSE, conf.level = 0.95, + uniform = FALSE, + bootstraps = 999L, ... ) } @@ -18,36 +20,35 @@ \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} to -return results for all ensemble types.} +to report. Defaults to 1. Set to \code{NULL} for +all ensemble types.} -\item{aggregation}{Character string: \code{"median"} -(default), \code{"mean"}, or \code{"spectral"}. -See \code{\link{summary.ddml_rep}} for details.} +\item{aggregation}{Character string. Aggregation method.} -\item{type}{Character string specifying the -variance-covariance estimator. One of \code{"HC1"} -(default), \code{"HC0"}, or \code{"HC3"}.} +\item{type}{Character. HC type. Default \code{"HC1"}.} -\item{conf.int}{Logical. Include confidence interval -columns? Default \code{FALSE}.} +\item{conf.int}{Logical. Include CIs? Default +\code{FALSE}.} -\item{conf.level}{Confidence level for intervals. -Default 0.95.} +\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}. If \code{conf.int = TRUE}, -also \code{conf.low} and \code{conf.high}. +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{ -Extracts aggregated coefficient estimates, standard -errors, test statistics, and p-values from a -\code{ddml_rep} object in a format compatible with -\pkg{modelsummary} and the \pkg{broom} ecosystem. +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{ 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.ddml.Rd b/man/vcov.ddml.Rd deleted file mode 100644 index 395b8bb..0000000 --- a/man/vcov.ddml.Rd +++ /dev/null @@ -1,80 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml.R -\name{vcov.ddml} -\alias{vcov.ddml} -\title{Variance-Covariance Matrix for DDML Estimators} -\usage{ -\method{vcov}{ddml}(object, ensemble_idx = 1, type = "HC1", ...) -} -\arguments{ -\item{object}{An object of class \code{ddml}.} - -\item{ensemble_idx}{Integer index of the ensemble type to -use. Defaults to 1 (first ensemble type).} - -\item{type}{Character string specifying the -variance-covariance estimator. 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 for the DDML estimator -\eqn{\hat\theta}. -} -\details{ -See \code{\link{ddml-intro}} for the DML framework, -including the definitions of the score \eqn{m_i}, -the Jacobian \eqn{\hat{J}}, and the base sandwich -estimator \eqn{\hat\Sigma}. This function provides -three variants: - -\strong{HC0}: -\deqn{V_{\mathrm{HC0}} = \hat{J}^{-1} - \left(\frac{1}{n}\sum_i m_i m_i'\right) - \hat{J}^{-\top} / n} - -\strong{HC1} (default): -\deqn{V_{\mathrm{HC1}} = V_{\mathrm{HC0}} - \times \frac{n}{n - p}} - -where \eqn{p} is the dimension of \eqn{\theta}. - -\strong{HC3}: -\deqn{V_{\mathrm{HC3}} = \hat{J}^{-1} - \left(\frac{1}{n}\sum_i - \frac{m_i m_i'}{(1 - h_{ii})^2}\right) - \hat{J}^{-\top} / n} - -where \eqn{h_{ii}} is the generalized leverage; -see \code{\link{hatvalues.ddml}}. -} -\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) -vcov(plm_fit) -vcov(plm_fit, type = "HC3") -} - -} -\seealso{ -\code{\link{hatvalues.ddml}}, -\code{\link{confint.ddml}}, -\code{\link{summary.ddml}} - -Other ddml inference: -\code{\link{coef.ddml}()}, -\code{\link{confint.ddml}()}, -\code{\link{hatvalues.ddml}()}, -\code{\link{summary.ddml}()} -} -\concept{ddml inference} diff --git a/man/vcov.ddml_rep.Rd b/man/vcov.ddml_rep.Rd deleted file mode 100644 index 5115fd8..0000000 --- a/man/vcov.ddml_rep.Rd +++ /dev/null @@ -1,54 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ddml_rep.R -\name{vcov.ddml_rep} -\alias{vcov.ddml_rep} -\title{Variance-Covariance Matrix for ddml_rep Objects} -\usage{ -\method{vcov}{ddml_rep}( - object, - ensemble_idx = 1, - aggregation = c("median", "mean", "spectral"), - type = "HC1", - ... -) -} -\arguments{ -\item{object}{A \code{ddml_rep} object.} - -\item{ensemble_idx}{Integer index of the ensemble type. -Defaults to 1.} - -\item{aggregation}{Character string: \code{"median"} -(default), \code{"mean"}, or \code{"spectral"}. -See \code{\link{summary.ddml_rep}} for details.} - -\item{type}{Character string specifying the -variance-covariance estimator. 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{ -Returns a variance-covariance matrix from cross-resample -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) -vcov(reps) -} - -} -\seealso{ -\code{\link{summary.ddml_rep}} for the -aggregation equations. -} diff --git a/man/vcov.ral.Rd b/man/vcov.ral.Rd new file mode 100644 index 0000000..6f4662f --- /dev/null +++ b/man/vcov.ral.Rd @@ -0,0 +1,51 @@ +% 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}}. +} +\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-ddml.R b/tests/testthat/test-ddml.R index 933e5ea..e006da7 100644 --- a/tests/testthat/test-ddml.R +++ b/tests/testthat/test-ddml.R @@ -7,12 +7,12 @@ test_that("ddml() constructs a valid ddml object", { 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)) - 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)) fit <- ddml( coefficients = coef, scores = scores, J = J, - psi_a = psi_a, psi_b = psi_b, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, nobs = n, coef_names = "mean", estimator_name = "Sample Mean", sample_folds = 5, @@ -38,19 +38,19 @@ test_that("ddml() with subclass", { 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)) - psi_b <- list(matrix(rnorm(n), ncol = 1)) - psi_a <- list(array(-1, dim = c(n, 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, - psi_a = psi_a, psi_b = psi_b, + 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")) + expect_equal(class(fit), c("my_custom", "ddml", "ral")) }) test_that("ddml() passes extra args via ...", { @@ -58,12 +58,12 @@ test_that("ddml() passes extra args via ...", { 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)) - psi_b <- list(matrix(rnorm(n), ncol = 1)) - psi_a <- list(array(-1, dim = c(n, 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, - psi_a = psi_a, psi_b = psi_b, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, nobs = n, coef_names = "x", estimator_name = "Test", my_extra = "hello", @@ -80,7 +80,7 @@ test_that("ddml() rejects bad inputs", { expect_error( ddml(coefficients = 1:3, scores = array(1, c(n, 3, 1)), J = array(1, c(3, 3, 1)), - psi_a = list(1), psi_b = list(1), + inf_func = array(1, c(n, 3, 1)), nobs = n, coef_names = "x", estimator_name = "Bad"), "matrix") @@ -90,7 +90,7 @@ test_that("ddml() rejects bad inputs", { ddml(coefficients = matrix(1, 1, 1), scores = matrix(1, n, 1), J = array(1, c(1, 1, 1)), - psi_a = list(1), psi_b = list(1), + inf_func = array(1, c(n, 1, 1)), nobs = n, coef_names = "x", estimator_name = "Bad"), "3D array") @@ -100,27 +100,38 @@ test_that("ddml() rejects bad inputs", { ddml(coefficients = matrix(1, 1, 1), scores = array(1, c(n, 1, 1)), J = matrix(1, 1, 1), - psi_a = list(1), psi_b = list(1), + inf_func = array(1, c(n, 1, 1)), nobs = n, coef_names = "x", estimator_name = "Bad"), "3D array") - # psi_a/psi_b not lists + # 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)), - psi_a = 1, psi_b = list(1), + inf_func = matrix(1, n, 1), nobs = n, coef_names = "x", estimator_name = "Bad"), - "lists") + "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)), - psi_a = list(1), psi_b = list(1), + inf_func = array(1, c(n, 1, 1)), nobs = n, coef_names = "x", estimator_name = "Bad"), "nobs x p x nensb") @@ -130,20 +141,31 @@ test_that("ddml() rejects bad inputs", { ddml(coefficients = matrix(1, 2, 1), scores = array(1, c(n, 2, 1)), J = array(1, c(1, 1, 1)), - psi_a = list(1), psi_b = list(1), + inf_func = array(1, c(n, 2, 1)), nobs = n, coef_names = c("a", "b"), estimator_name = "Bad"), "p x p x nensb") - # Length mismatch: psi_a wrong length + # 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)), - psi_a = list(1), psi_b = list(1, 1), + inf_func = array(1, c(n, 1, 1)), nobs = n, coef_names = "x", estimator_name = "Bad"), - "length nensb") + "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", { @@ -168,12 +190,12 @@ test_that("standard S3 generic methods work correctly", { expect_length(cf, 2) # vcov - V <- vcov(fit, ensemble_idx = 2) + V <- vcov(fit, fit_idx = 2) expect_true(is.matrix(V)) expect_equal(dim(V), c(1, 1)) # confint - ci <- confint(fit, ensemble_idx = 1) + 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 %")) @@ -344,7 +366,7 @@ test_that("hatvalues works for multi-parameter estimator", { expect_true(all(is.finite(h))) }) -test_that("ensemble_idx out of range errors", { +test_that("fit_idx out of range errors", { set.seed(42) nobs <- 500 X <- matrix(rnorm(nobs * 3), nobs, 3) @@ -355,8 +377,8 @@ test_that("ensemble_idx out of range errors", { learners = list(what = ols), sample_folds = 2, silent = TRUE) - expect_error(vcov(fit, ensemble_idx = 99)) - expect_error(hatvalues(fit, ensemble_idx = 0)) + expect_error(vcov(fit, fit_idx = 99)) + expect_error(hatvalues(fit, fit_idx = 0)) }) test_that("tidy and glance broom formatters work correctly", { @@ -459,3 +481,132 @@ test_that("tidy works with PLM (multi-covariate D)", { 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 + ) +}) diff --git a/tests/testthat/test-ddml_apo.R b/tests/testthat/test-ddml_apo.R index 3d43a8f..aca09b9 100644 --- a/tests/testthat/test-ddml_apo.R +++ b/tests/testthat/test-ddml_apo.R @@ -40,7 +40,7 @@ test_that("ddml_apo computes with weights", { })#TEST_THAT test_that("ddml_apo computes with a single model and dependence", { - # Simulate small dataset + set.seed(1) n_cluster <- 200 nobs <- 500 X <- matrix(rnorm(n_cluster * 5), n_cluster, 5) 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-lincom.R b/tests/testthat/test-lincom.R new file mode 100644 index 0000000..879c46a --- /dev/null +++ b/tests/testthat/test-lincom.R @@ -0,0 +1,364 @@ +# 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 + 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-ral.R b/tests/testthat/test-ral.R new file mode 100644 index 0000000..392bfa1 --- /dev/null +++ b/tests/testthat/test-ral.R @@ -0,0 +1,443 @@ +# 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 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 From 215eab48634b18bc01873220bca97c34516b3bc7 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Mon, 23 Mar 2026 15:15:03 -0500 Subject: [PATCH 36/46] vignette updates --- README.Rmd | 2 +- README.md | 132 ++-- _pkgdown.yml | 62 +- vignettes/articles/did.Rmd | 679 ++++++++---------- vignettes/articles/did.Rmd.txt | 392 +++++----- .../figures/did-unnamed-chunk-10-1.png | Bin 0 -> 15458 bytes .../figures/did-unnamed-chunk-15-1.png | Bin 0 -> 16168 bytes .../figures/did-unnamed-chunk-7-1.png | Bin 0 -> 15217 bytes .../articles/figures/unnamed-chunk-11-1.png | Bin 23031 -> 0 bytes .../articles/figures/unnamed-chunk-12-1.png | Bin 11604 -> 0 bytes .../articles/figures/unnamed-chunk-13-1.png | Bin 36499 -> 0 bytes .../articles/figures/unnamed-chunk-16-1.png | Bin 22821 -> 0 bytes .../articles/figures/unnamed-chunk-17-1.png | Bin 11308 -> 0 bytes .../articles/figures/unnamed-chunk-20-1.png | Bin 24795 -> 0 bytes .../articles/figures/unnamed-chunk-21-1.png | Bin 13353 -> 0 bytes .../articles/figures/unnamed-chunk-23-1.png | Bin 22824 -> 0 bytes .../articles/figures/unnamed-chunk-24-1.png | Bin 11296 -> 0 bytes .../articles/figures/unnamed-chunk-4-1.png | Bin 23083 -> 0 bytes .../articles/figures/unnamed-chunk-5-1.png | Bin 11667 -> 0 bytes .../articles/figures/unnamed-chunk-8-1.png | Bin 22725 -> 0 bytes .../articles/figures/unnamed-chunk-9-1.png | Bin 10867 -> 0 bytes .../articles/modelsummary_integration.Rmd | 41 ++ .../articles/modelsummary_integration.Rmd.txt | 38 + vignettes/articles/repeated_resampling.Rmd | 8 +- vignettes/articles/stacking.Rmd | 6 +- vignettes/ddml.Rmd | 8 +- vignettes/precompile.R | 14 +- 27 files changed, 706 insertions(+), 676 deletions(-) create mode 100644 vignettes/articles/figures/did-unnamed-chunk-10-1.png create mode 100644 vignettes/articles/figures/did-unnamed-chunk-15-1.png create mode 100644 vignettes/articles/figures/did-unnamed-chunk-7-1.png delete mode 100644 vignettes/articles/figures/unnamed-chunk-11-1.png delete mode 100644 vignettes/articles/figures/unnamed-chunk-12-1.png delete mode 100644 vignettes/articles/figures/unnamed-chunk-13-1.png delete mode 100644 vignettes/articles/figures/unnamed-chunk-16-1.png delete mode 100644 vignettes/articles/figures/unnamed-chunk-17-1.png delete mode 100644 vignettes/articles/figures/unnamed-chunk-20-1.png delete mode 100644 vignettes/articles/figures/unnamed-chunk-21-1.png delete mode 100644 vignettes/articles/figures/unnamed-chunk-23-1.png delete mode 100644 vignettes/articles/figures/unnamed-chunk-24-1.png delete mode 100644 vignettes/articles/figures/unnamed-chunk-4-1.png delete mode 100644 vignettes/articles/figures/unnamed-chunk-5-1.png delete mode 100644 vignettes/articles/figures/unnamed-chunk-8-1.png delete mode 100644 vignettes/articles/figures/unnamed-chunk-9-1.png diff --git a/README.Rmd b/README.Rmd index 7744163..1cbe10b 100644 --- a/README.Rmd +++ b/README.Rmd @@ -94,7 +94,7 @@ Check out our articles to learn more: - ``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: diff --git a/README.md b/README.md index 44ddf23..1c871d1 100644 --- a/README.md +++ b/README.md @@ -1,31 +1,42 @@ ---- -output: github_document ---- - - # ddml + [![R-CMD-check](https://github.com/thomaswiemann/ddml/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/thomaswiemann/ddml/actions/workflows/R-CMD-check.yaml) [![codecov](https://codecov.io/gh/thomaswiemann/ddml/branch/master/graph/badge.svg?token=PHB9W2TJ6S)](https://app.codecov.io/gh/thomaswiemann/ddml) [![CodeFactor](https://www.codefactor.io/repository/github/thomaswiemann/ddml/badge)](https://www.codefactor.io/repository/github/thomaswiemann/ddml) -[![CRAN Version](https://www.r-pkg.org/badges/version/ddml)](https://cran.r-project.org/package=ddml) +[![CRAN +Version](https://www.r-pkg.org/badges/version/ddml)](https://cran.r-project.org/package=ddml) [![cranlogs](https://cranlogs.r-pkg.org/badges/ddml)](https://cran.r-project.org/package=ddml) -``ddml`` is an implementation of double/debiased machine learning estimators as proposed by Chernozhukov et al. (2018). The key feature of ``ddml`` is the straightforward estimation of nuisance parameters using (short-)stacking (Wolpert, 1992), which allows for multiple machine learners to increase robustness to the underlying data generating process. See also [Ahrens et al. (2024b)](https://arxiv.org/abs/2401.01645) for a detailed illustration of the practical benefits of combining DDML with (short-)stacking. - -``ddml`` is the sister R package to our [Stata](https://github.com/aahrens1/ddml/) package, mirroring its key features while also leveraging R to simplify estimation with user-provided machine learners and/or sparse matrices. See also [Ahrens et al. (2024a)](https://arxiv.org/abs/2301.09397) with additional discussion of the supported causal models and benefits of (short)-stacking. +`ddml` is an implementation of double/debiased machine learning +estimators as proposed by Chernozhukov et al. (2018). The key feature of +`ddml` is the straightforward estimation of nuisance parameters using +(short-)stacking (Wolpert, 1992), which allows for multiple machine +learners to increase robustness to the underlying data generating +process. See also [Ahrens et +al. (2024b)](https://arxiv.org/abs/2401.01645) for a detailed +illustration of the practical benefits of combining DDML with +(short-)stacking. + +`ddml` is the sister R package to our +[Stata](https://github.com/aahrens1/ddml/) package, mirroring its key +features while also leveraging R to simplify estimation with +user-provided machine learners and/or sparse matrices. See also [Ahrens +et al. (2024a)](https://arxiv.org/abs/2301.09397) with additional +discussion of the supported causal models and benefits of +(short)-stacking. ## Installation -Install the latest development version from GitHub (requires [devtools](https://github.com/r-lib/devtools) package): - +Install the latest development version from GitHub (requires +[devtools](https://github.com/r-lib/devtools) package): -```r +``` r if (!require("devtools")) { install.packages("devtools") } @@ -34,17 +45,18 @@ devtools::install_github("thomaswiemann/ddml", dependencies = TRUE) Install the latest public release from CRAN: -```r +``` r install.packages("ddml") ``` - ## Example: LATE Estimation based on (Short-)Stacking -To illustrate ``ddml`` on a simple example, consider the included random subsample of 5,000 observations from the data of Angrist & Evans (1998). The data contains information on the labor supply of mothers, their children, as well as demographic data. See ``?AE98`` for details. - +To illustrate `ddml` on a simple example, consider the included random +subsample of 5,000 observations from the data of Angrist & Evans (1998). +The data contains information on the labor supply of mothers, their +children, as well as demographic data. See `?AE98` for details. -```r +``` r # Load ddml and set seed library(ddml) set.seed(75523) @@ -56,14 +68,19 @@ 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``). Since the statistical properties of machine learners depend heavily on the underlying (unknown!) structure of the data, adaptive combination of multiple machine learners can increase robustness. In the below snippet, ``ddml_late`` estimates the LATE with short-stacking based on three base learners: +`ddml_late` estimates the local average treatment effect (LATE) using +double/debiased machine learning (see `?ddml_late`). Since the +statistical properties of machine learners depend heavily on the +underlying (unknown!) structure of the data, adaptive combination of +multiple machine learners can increase robustness. In the below snippet, +`ddml_late` estimates the LATE with short-stacking based on three base +learners: -- linear regression (see ``?ols``) -- lasso (see ``?mdl_glmnet``) -- gradient boosting (see ``?mdl_xgboost``) +- linear regression (see `?ols`) +- lasso (see `?mdl_glmnet`) +- gradient boosting (see `?mdl_xgboost`) - -```r +``` r # Estimate the local average treatment effect using short-stacking with base # learners ols, lasso, and xgboost. late_fit_short <- ddml_late(y, D, Z, X, @@ -84,46 +101,73 @@ summary(late_fit_short) #> LATE -0.220 0.187 -1.18 0.24 ``` -## Learn More about ``ddml`` +## Learn More about `ddml` 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("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")` covers DiD estimation, aggregation, and inference in + staggered adoption designs For additional applied examples, see our case studies: -- ``vignette("example_401k")`` revisits the effect of 401k participation on retirement savings -- ``vignette("example_BLP95")`` considers flexible demand estimation with endogenous prices +- `vignette("example_401k")` revisits the effect of 401k participation + on retirement savings +- `vignette("example_BLP95")` considers flexible demand estimation with + endogenous prices ## 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. +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, 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. +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. - -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. +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. +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. +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. diff --git a/_pkgdown.yml b/_pkgdown.yml index 134cce5..22474be 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -37,12 +37,6 @@ navbar: - github reference: -- title: internal - contents: - - ddml-package - - matches("print") - - matches("summary") - - matches("sub-") - title: Supported DDML Estimators contents: - ddml_plm @@ -52,33 +46,17 @@ reference: - ddml_att - ddml_late - ddml_apo + - ddml_attgt + - title: Repeated Resampling contents: - ddml_replicate -- title: internal + +- title: Linear Combinations and Aggregation contents: - - ddml-intro - - ddml - - ddml_rep - - coef.ddml - - confint.ddml - - vcov.ddml - - hatvalues.ddml - - nobs.ddml - - tidy.ddml - - glance.ddml - - tidy.ddml_diagnostics - - ensemble_weights - - coef.ddml_rep - - confint.ddml_rep - - vcov.ddml_rep - - tidy.ddml_rep - - glance.ddml_rep - - nobs.ddml_rep - - length.ddml_rep - - "`[[.ddml_rep`" - - reexports - - matches("predict") + - lincom + - lincom_weights_did + - title: Wrappers for Common (Machine) Learners contents: - ols @@ -87,6 +65,7 @@ reference: - mdl_ranger - mdl_xgboost - mdl_bigGLM + - title: Utilities contents: - crossval @@ -94,10 +73,34 @@ reference: - 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") + - ensemble_weights + - reexports + articles: - title: Key Features navbar: ~ @@ -113,4 +116,3 @@ articles: - title: Case Studies contents: - starts_with("articles/example") - diff --git a/vignettes/articles/did.Rmd b/vignettes/articles/did.Rmd index 4da3d89..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,93 +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). See also Ahrens et al. (2026) for an example of staggered differences-in-differences estimated with ddml. +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 ddml and did 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.0214 -0.0718 0.0427 -#> 2004 2005 -0.0764 0.0313 -0.1601 0.0072 -#> 2004 2006 -0.1404 0.0397 -0.2465 -0.0344 * -#> 2004 2007 -0.1069 0.0373 -0.2065 -0.0073 * -#> 2006 2004 -0.0005 0.0223 -0.0599 0.0590 -#> 2006 2005 -0.0062 0.0192 -0.0574 0.0450 -#> 2006 2006 0.0010 0.0199 -0.0523 0.0542 -#> 2006 2007 -0.0413 0.0191 -0.0924 0.0098 -#> 2007 2004 0.0267 0.0136 -0.0096 0.0630 -#> 2007 2005 -0.0046 0.0171 -0.0503 0.0411 -#> 2007 2006 -0.0284 0.0169 -0.0735 0.0166 -#> 2007 2007 -0.0288 0.0173 -0.0749 0.0174 -#> --- -#> 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) -``` +# 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) #> @@ -110,402 +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.0196 -0.1188 -0.0419 * +#> -0.0804 0.0209 -0.1213 -0.0394 * #> #> #> Dynamic Effects: #> Event time Estimate Std. Error [95% Simult. Conf. Band] -#> -3 0.0267 0.0143 -0.0092 0.0627 -#> -2 -0.0036 0.0134 -0.0373 0.0301 -#> -1 -0.0232 0.0147 -0.0603 0.0138 -#> 0 -0.0211 0.0127 -0.0529 0.0108 -#> 1 -0.0530 0.0165 -0.0946 -0.0114 * -#> 2 -0.1404 0.0349 -0.2281 -0.0528 * -#> 3 -0.1069 0.0333 -0.1907 -0.0231 * +#> -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) ``` -
-Dynamic Treatment Effect Estimates. -

Dynamic Treatment Effect Estimates.

-
-# Constructing 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 -# Initialize a global list to store fits for diagnostic inspection -global_ddml_fits <- list() - -# 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, ...) - - # Store the fit in the global list - global_ddml_fits[[length(global_ddml_fits) + 1]] <<- att_fit - - # Return results - att_est <- as.numeric(att_fit$coefficients) - inf.func <- as.vector(att_fit$psi_b[[1]]) + att_est * as.vector(att_fit$psi_a[[1]]) - output <- list(ATT = att_est, 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(nrounds = 50, - params = list(eta = 0.1, 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 = 5, - 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).

+
-```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) - -# 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.8753 1.2320 -3.8769 2.1263 -#> 2004 2005 0.2318 0.8761 -1.9026 2.3661 -#> 2004 2006 -1.1267 1.9940 -5.9845 3.7312 -#> 2004 2007 2.2817 1.3789 -1.0777 5.6410 -#> 2006 2004 -0.2555 0.1502 -0.6215 0.1104 -#> 2006 2005 0.2194 0.1394 -0.1201 0.5590 -#> 2006 2006 -0.0250 0.0988 -0.2656 0.2156 -#> 2006 2007 0.1796 0.3459 -0.6631 1.0224 -#> 2007 2004 -0.0174 0.1516 -0.3866 0.3519 -#> 2007 2005 0.1452 0.1666 -0.2607 0.5510 -#> 2007 2006 0.0346 0.2012 -0.4556 0.5248 -#> 2007 2007 -0.1585 0.2331 -0.7264 0.4095 -#> --- -#> Signif. codes: `*' confidence band does not cover 0 -#> -#> P-value for pre-test of parallel trends assumption: 0.26144 -#> Control Group: Never Treated, Anticipation Periods: 0 -# plot the coefficients -ggdid(attgt_xgboost) -``` +# Stacking-based Estimation -
-xgboost-based Diff-in-Diff Estimates. -

xgboost-based Diff-in-Diff Estimates.

-
+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 -# 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.2866 0.6471 -0.9817 1.5549 -#> -#> -#> Dynamic Effects: -#> Event time Estimate Std. Error [95% Simult. Conf. Band] -#> -3 -0.0174 0.1556 -0.3593 0.3245 -#> -2 0.0514 0.1360 -0.2473 0.3502 -#> -1 0.0779 0.1405 -0.2308 0.3865 -#> 0 -0.2056 0.1859 -0.6140 0.2028 -#> 1 0.1970 0.3309 -0.5299 0.9239 -#> 2 -1.1267 1.9879 -5.4935 3.2401 -#> 3 2.2817 1.3781 -0.7456 5.3089 +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 -#> -#> Control Group: Never Treated, Anticipation Periods: 0 -ggdid(dyn_xgboost) +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +``` + + +```r +plot(lc_dyn_s, uniform = TRUE, ylab = "ATT", main = "Dynamic ATT (Stacking)") ```
-xgboost-based Dynamic Treatment Effect Estimates. -

xgboost-based Dynamic Treatment Effect Estimates.

+Dynamic Treatment Effect Estimates (Stacking). +

Dynamic Treatment Effect Estimates (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: -# Constructing 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 +# 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 +``` -We construct a new wrapper for our ``ddml_did_method`` that hard-codes different reduced form estimators: +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. -- linear or logistic regression -- gradient tree boosting with more and less regularization -- random forests with more and less regularization -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")``). +# Comparing Results + +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(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))) - # Hard-code learners for treatment reduced-form - learners_DX = 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))) - # 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 = 5, - 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) +#> 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 ``` -Finally, we recompute the group-time average treatment effects using our shortstacking estimator: +# Repeated Resampling with Uniform Inference -```r -# Clear the global fits list from the previous xgboost runs -global_ddml_fits <- list() - -# 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) - -# 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.0105 0.0243 -0.0739 0.0529 -#> 2004 2005 -0.0736 0.0299 -0.1516 0.0045 -#> 2004 2006 -0.1393 0.0377 -0.2375 -0.0410 * -#> 2004 2007 -0.1110 0.0331 -0.1973 -0.0248 * -#> 2006 2004 -0.0016 0.0245 -0.0655 0.0623 -#> 2006 2005 -0.0075 0.0186 -0.0559 0.0410 -#> 2006 2006 0.0075 0.0215 -0.0486 0.0635 -#> 2006 2007 -0.0414 0.0196 -0.0924 0.0096 -#> 2007 2004 0.0266 0.0148 -0.0120 0.0651 -#> 2007 2005 -0.0030 0.0155 -0.0434 0.0375 -#> 2007 2006 -0.0325 0.0176 -0.0783 0.0134 -#> 2007 2007 -0.0287 0.0164 -0.0715 0.0141 -#> --- -#> Signif. codes: `*' confidence band does not cover 0 -#> -#> P-value for pre-test of parallel trends assumption: 0.18267 -#> Control Group: Never Treated, Anticipation Periods: 0 +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) -``` -
-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. +```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 +) +``` ```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.0804 0.021 -0.1217 -0.0392 * -#> -#> -#> Dynamic Effects: -#> Event time Estimate Std. Error [95% Simult. Conf. Band] -#> -3 0.0266 0.0143 -0.0088 0.0619 -#> -2 -0.0027 0.0131 -0.0352 0.0299 -#> -1 -0.0266 0.0145 -0.0626 0.0094 -#> 0 -0.0192 0.0113 -0.0472 0.0087 -#> 1 -0.0521 0.0158 -0.0914 -0.0128 * -#> 2 -0.1393 0.0372 -0.2315 -0.0471 * -#> 3 -0.1110 0.0339 -0.1949 -0.0271 * +# 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 -#> -#> Control Group: Never Treated, Anticipation Periods: 0 -ggdid(dyn_stacking) +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` -
-Stacking-based Dynamic Treatment Effect Estimates. -

Stacking-based Dynamic Treatment Effect Estimates.

-
- -# Stacking Diagnostics for Group-Time Effects - -Because the ``did`` package encapsulates the estimation of each group-time cell dynamically, the resulting ``MP`` object does not natively return the underlying ``ddml`` model estimators for inspection. - -However, because we stored the intermediate fits in the ``global_ddml_fits`` list inside our ``ddml_did_method`` wrapper, we can easily run stacking diagnostics on any specific cell. - -For example, let's look at the diagnostics for the ``(g=2004, t=2006)`` cell (which is the third group-time cell evaluated by the shortstacking estimator): +The plot method for replicated objects displays median-aggregated estimates with confidence bands. We can request uniform bands via ``uniform = TRUE``: ```r -# Extract the ddml_att fit computed for Group 2004 at Time 2006 -cell_fit <- global_ddml_fits[[3]] - -# Run stacking diagnostics on the computed cell, enabling CVC testing -print(diagnostics(cell_fit, cvc = TRUE)) -#> Stacking diagnostics: Average Treatment Effect on the Treated -#> Obs: 329 -#> -#> y_X_D0: -#> learner mspe r2 weight_nnls cvc_pval -#> learner_1 0.0666 -0.0066 0.1921 0.982 -#> learner_2 0.1238 -0.8696 0.0000 0.002 -#> learner_3 0.1238 -0.8696 0.0000 0.000 -#> learner_4 0.0676 -0.0218 0.0000 0.266 -#> learner_5 0.0676 -0.0207 0.0000 0.280 -#> -#> D_X: -#> learner mspe r2 weight_nnls cvc_pval -#> learner_1 0.0575 -0.0038 0.9231 0.998 -#> learner_2 0.1011 -0.7655 0.0000 0.000 -#> learner_3 0.1011 -0.7655 0.0000 0.000 -#> learner_4 0.0580 -0.0135 0.0000 0.226 -#> learner_5 0.0581 -0.0145 0.0000 0.130 -#> -#> D: -#> learner mspe r2 weight_average cvc_pval -#> learner_1 0.0571 0.003 1 NA -#> -#> Note: CVC compares individual base learners. -#> Shortstacked ensemble CVC is not available (weights use all data). +plot(lc_dyn_r, uniform = TRUE, + ylab = "ATT", main = "Dynamic ATT (Median, Uniform CI)") ``` -This diagnostic output displays the cross-validated Mean Squared Prediction Error (MSPE), the out-of-sample $R^2$, the non-negative least squares (NNLS) weights assigned to each base learner, and the CVC p-value. - -**How to Interpret These Metrics to Guide Learner Choice:** +
+Dynamic ATT with Uniform Confidence Bands. +

Dynamic ATT with Uniform Confidence Bands.

+
-1. **$R^2$**: Evaluates the proportion of variance explained by each learner out-of-sample. Because these are computed on hold-out folds, negative values can occur and indicate that a learner performs worse than a simple constant mean prediction (often a sign of severe overfitting or algorithmic mismatch). -2. **Weights**: The short-stacking algorithm assigns weights to optimally combine the learners and minimize the overall MSPE. Learners with $0$ weight do not contribute to the final predictions because their predictive power is either poor or entirely subsumed by other models in the ensemble. -3. **CVC P-Values**: The ``cvc_pval`` column shows the p-value from a Cross-Validation Criteria test (Lei, 2020), comparing each learner's MSPE against the MSPE of the single-best ML model in the list. A high p-value (e.g. > 0.05) indicates that the learner's predictive performance is not statistically worse than the best learner. If simple linear models (e.g., ``ols``) show high p-values, it implies machine learning does not significantly improve prediction out-of-sample for this specific parameter, which can legally justify reverting to simpler, faster estimators. -4. **Actionable Efficiency**: If your diagnostic output consistently assigns $0$ weight, negative $R^2$, and $0.000$ CVC p-values to computationally expensive models (like deep random forests), you can safely remove them from the ``learners`` list in future runs to dramatically reduce computation time without sacrificing accuracy. +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 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. -Callaway B, Sant'Anna P (2021). “Difference-in-differences with multiple time periods.” Journal of Econometrics, 200-230. - -Callaway B, Sant'Anna P (2021). “did: Difference in Differences.” R package version 2.1.2, https://bcallaway11.github.io/did/. +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. -Chang NC (2020). "Double/debiased machine learning for difference-in-difference models." The Econometrics Journal, 177-191. +Callaway B, Sant'Anna P (2021). "Difference-in-differences with multiple time periods." Journal of Econometrics, 225(2), 200-230. -Lei J (2020). "Cross-Validation With Confidence." Journal of the American Statistical Association, 115(532), 1978-1997. +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 6bbf2d2..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,7 +12,7 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, comment = "#>", - fig.path = "figures/", + fig.path = "figures/did-", eval = TRUE, warning = FALSE, message = FALSE @@ -21,273 +21,267 @@ knitr::opts_chunk$set( # 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). See also Ahrens et al. (2026) for an example of staggered differences-in-differences estimated with ddml. +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 ddml and did 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) -``` - -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) ``` -# Constructing 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. -Fortunately, a convex combination of causal effects can be guaranteed (without parametric functional form assumptions) when using machine learning (nonparametric) reduced form estimators. +# GT-ATT Estimation with ``ddml_attgt`` -``ddml`` facilitates the use of a large set of machine learning reduced form estimators, including simultaneous considerations of multiple estimators via (short-)stacking. +We estimate GT-ATTs using ``ddml_attgt``. To validate against the ``did`` baseline, we start with 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`` - -This two-step approach allows for cleaner code when considering multiple ddml-based estimators (as we do in this article). - -The below code-snippet constructs a simple estimation method following step 1: ```{r} -# Initialize a global list to store fits for diagnostic inspection -global_ddml_fits <- list() - -# 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, ...) - - # Store the fit in the global list - global_ddml_fits[[length(global_ddml_fits) + 1]] <<- att_fit - - # Return results - att_est <- as.numeric(att_fit$coefficients) - inf.func <- as.vector(att_fit$psi_b[[1]]) + att_est * as.vector(att_fit$psi_a[[1]]) - output <- list(ATT = att_est, att.inf.func = inf.func) - return(output) -}#DDML_DID_METHOD +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) ``` -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``). -```{r} -my_did_xgboost <- function(y1, y0, D, covariates, ...) { - # Hard-code learners - learners = list(what = mdl_xgboost, - args = list(nrounds = 50, - params = list(eta = 0.1, 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 = 5, - silent = TRUE) -}#MY_DID_XGBOOST -``` +# Dynamic Aggregation via ``lincom`` -We can now use the reduced form estimator ``my_did_xgboost`` and pass it via the ``est_method`` argument: +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: -```{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) - -# plot the coefficients -ggdid(attgt_xgboost) +```{r} +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) ``` -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: +Pre-treatment event times (e < 0) serve as placebo tests: under the parallel trends assumption, these should be close to zero. -```{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) +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)") ``` -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? - -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. -# Constructing 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. +# Stacking-based Estimation -We construct a new wrapper for our ``ddml_did_method`` that hard-codes different reduced form estimators: +We next leverage (short-)stacking to combine multiple base learners. Including OLS and logit ensures that the simpler specifications are never spuriously discarded: -- linear or logistic regression -- gradient tree boosting with more and less regularization -- random forests with more and less regularization - -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")``). +```{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} -my_did_stacking <- function(y1, y0, D, covariates, ...) { - # Hard-code learners for outcome reduced-form - learners = 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))) - # Hard-code learners for treatment reduced-form - learners_DX = 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))) - # 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 = 5, - ensemble_type = "nnls", - shortstack = TRUE, - silent = TRUE) -}#MY_DID_STACKING +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) ``` -Finally, we recompute the group-time average treatment effects using our shortstacking estimator: +```{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)") +``` -```{r, fig.width=8, fig.height=10, fig.align='center', out.width="90%", dpi = 200, fig.cap="Stacking-based Diff-in-Diff Estimates."} -# Clear the global fits list from the previous xgboost runs -global_ddml_fits <- list() -# 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) +# Learner Diagnostics -# summarize the results -summary(attgt_stacking) +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: -# plot the coefficients -ggdid(attgt_stacking) +```{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) ``` -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. +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. -```{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) -``` +# Comparing Results + +We compare the dynamic treatment effects from the OLS, stacking, and ``did`` baseline estimators: -# Stacking Diagnostics for Group-Time Effects +```{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) +``` -Because the ``did`` package encapsulates the estimation of each group-time cell dynamically, the resulting ``MP`` object does not natively return the underlying ``ddml`` model estimators for inspection. -However, because we stored the intermediate fits in the ``global_ddml_fits`` list inside our ``ddml_did_method`` wrapper, we can easily run stacking diagnostics on any specific cell. +# Repeated Resampling with Uniform Inference -For example, let's look at the diagnostics for the ``(g=2004, t=2006)`` cell (which is the third group-time cell evaluated by the shortstacking estimator): +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} -# Extract the ddml_att fit computed for Group 2004 at Time 2006 -cell_fit <- global_ddml_fits[[3]] +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 +) +``` -# Run stacking diagnostics on the computed cell, enabling CVC testing -print(diagnostics(cell_fit, cvc = TRUE)) +```{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) ``` -This diagnostic output displays the cross-validated Mean Squared Prediction Error (MSPE), the out-of-sample $R^2$, the non-negative least squares (NNLS) weights assigned to each base learner, and the CVC p-value. +The plot method for replicated objects displays median-aggregated estimates with confidence bands. We can request uniform bands via ``uniform = TRUE``: -**How to Interpret These Metrics to Guide Learner Choice:** +```{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)") +``` -1. **$R^2$**: Evaluates the proportion of variance explained by each learner out-of-sample. Because these are computed on hold-out folds, negative values can occur and indicate that a learner performs worse than a simple constant mean prediction (often a sign of severe overfitting or algorithmic mismatch). -2. **Weights**: The short-stacking algorithm assigns weights to optimally combine the learners and minimize the overall MSPE. Learners with $0$ weight do not contribute to the final predictions because their predictive power is either poor or entirely subsumed by other models in the ensemble. -3. **CVC P-Values**: The ``cvc_pval`` column shows the p-value from a Cross-Validation Criteria test (Lei, 2020), comparing each learner's MSPE against the MSPE of the single-best ML model in the list. A high p-value (e.g. > 0.05) indicates that the learner's predictive performance is not statistically worse than the best learner. If simple linear models (e.g., ``ols``) show high p-values, it implies machine learning does not significantly improve prediction out-of-sample for this specific parameter, which can legally justify reverting to simpler, faster estimators. -4. **Actionable Efficiency**: If your diagnostic output consistently assigns $0$ weight, negative $R^2$, and $0.000$ CVC p-values to computationally expensive models (like deep random forests), you can safely remove them from the ``learners`` list in future runs to dramatically reduce computation time without sacrificing accuracy. +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 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. -Callaway B, Sant'Anna P (2021). “Difference-in-differences with multiple time periods.” Journal of Econometrics, 200-230. - -Callaway B, Sant'Anna P (2021). “did: Difference in Differences.” R package version 2.1.2, https://bcallaway11.github.io/did/. +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. -Chang NC (2020). "Double/debiased machine learning for difference-in-difference models." The Econometrics Journal, 177-191. +Callaway B, Sant'Anna P (2021). "Difference-in-differences with multiple time periods." Journal of Econometrics, 225(2), 200-230. -Lei J (2020). "Cross-Validation With Confidence." Journal of the American Statistical Association, 115(532), 1978-1997. +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/figures/did-unnamed-chunk-10-1.png b/vignettes/articles/figures/did-unnamed-chunk-10-1.png new file mode 100644 index 0000000000000000000000000000000000000000..1c7a1eeb7223d315a39d523a8b71fae2ef910d19 GIT binary patch literal 15458 zcmeHu2|U#8+VE6_?5U;*r9~ZO)Ds@W@I~Iz5g?)&Uw%I&N<)jeShcoea{%P-1oKJ*K%Liz0AdZdw0k# zP+ovQAY?6fnjb(Q#Bm73ydKGUpyi;edpLNb@7rTz0p1Y^Lj=MdVQ7dj1g{AQ_k8dj zd@)40!)@>bd`K{KcQMkNyEoY4<*HulX0Y?Z#@m3}#Hlt=#KFF{oo z_EhY(NJ+zs)v&Az92G(y$r!)S)2&GBo$hFBEA+wImAh>#9E+ zMEW3LtTSV3sU7l@cNvxf@&Q{^V{1`XQS)R#9mn1)WiLulQ;B+)Dww#>55UUdCsr{Y zic_=ge0hI$R+M zwBWNqLvA^J$Z|YhF7G#7tsHCbnx!r=PCJYpFHcZ0nV2;(1x`a`W6E{)FRP42U}CwpZiy@jp2kR4~+%o?dqx@@l01Aj+J8#U_u4+E}m6z3XHMi zr+*3B!@`DR5~1px*s|l@gXof-!vnrUehe$WqvBZ3RV50cZEs^)w}+X>i7K^I<6fLc zY*b1SQ`UEa-`r_UKQy3gOAd@QJbsMkyda;A`qA%-7>2XFi-Erkh4mmf*d6^uY zI#DOiED?)?s?$?>bq#OYl5#&+)Ms`U>{Ur@J0Ory@;1fQ^2;WAH*Yw0rU5(F6*r!X z->5Q*j>bO=wp_Lp!Cg(H=3c2dItd+ZkT;|!@^}JFne^ zyl;$xh$B~$-{F6S9_el);dZP`jNh_hNqoo4-MGZ{m~dU}c>MP8G$_~^CcJ8q5TuTTEoQ`YA(*raaY7#T2?8t1=(vY#x+9ocLX zZ=#JqlTwheiQ2B%mCC<&8E0V-d=av*vIN zc1Y)4O|}-Edb8-lWJj-O<&KrNTw?@>SF92ag?zC4A@?vf3o+udrQ>vor&+**cgD3{ z)(wO=AD4LZ`*MctlH#>;8|AVIzX%AmuChka*a-C^F8k|nY0nChiZ;w78f!xBGYQoq z4c#n?d>awL-iRt4Zan>7j!~8m>80xVm6Y7cRTE3u;H78Xn@C1GH=});ZGCTbc#W8N zr`h%|JGaA!Y#f0L53aq7<9i$}wQpKUdO7EA9_ohT{PW5FJ`rd29nN)adxJXE>T_PdEiq?7gfT5jv!CF5~4tQuZ08D+b%fOJOV&07_1 zvtLO4WcmV3_~V#dq9n?!-`CLJ4EI8p)L*Ww9KXd|n#IE7)mkjQW3i{Rsv&y2xRWZY zPln611BJ@y|-c})&J|ZUO_Emvi zS>{MJDra?+<6>nnjY?5b<;vHnVZ2UOjlh0H->1JdQJgVIdRrjH>bojQnT*gNoji}F z-|Cc|@TXT*cB#H*ZvQA~ZIRDJzu1k#L|!f!;YCGFJ&GydZOCW4okS;ZD0xd$?9+Lz^2aT1z>yS=G(6~3x;zq?p$YTc!0P!(LgE=%Ms3SJ`I_$L4e=lmY&#V~3kMr}6qLZ762<^P=i=(m}2` zOt=~fb^pC0!$N^NG(57T!Ofn$vb4|cx8%5!^E>++(y#kSW1s-O8}18)+s#GYDuBQqZeMG(z4-fxogCA%j+8Je@p{nK2?dk2 z#!VYZjNokV)^vynalu{zLA& z&1vME54HLvT5EiPVzyt&JJpVFoQ}bDEKhDF+eJkivSO9fNR?p(NH2ca6?*=MWf`ks zvjxbp7@ph}tMp@`dV0r`FA&vHc7=ng^z2mA+Q>&M`8Vr)8F5-minp{6P4GvDCHSWv z6X7}Oq?1Q~s{~zx6lZ-Ox6r}*C2G9o=q*VU1)>{VMh89U2$`p%GBi2T)SVG=nB4A@ z2<4z(4EWr;S>0{$krn-pEH{9pbGKC8k4FpG3~xqkJY|y!I<+RhcP`fXT$@y3Cf>wX zi9X?cwyeBfyiqB&@D_?fNb-?AwB8+gfVX*m5IQ$wTtEK37^AG}p|ugJZlL7Vggmp# zuFP$dPLZNh^V9xhq;%kVZf@oHH%7bwM-CrN=N>I=I>j)M4bdQd>8q)ic)S>|l-d&Y zIV|fK`vjxn+eBj5LBndAeDEq{G?JE;diCg(DxG`2o_IScWy6LEmYDB(=y+0n<#~4G ze0BN;w@~ar2e#CEYx-FuQX!z}&b4`Y)hS-a;m{>aghJ#%*GX=OPx>{%uC`!FR6bX4 z@^Dftx`K!B?XVfii5OW{R>`VI6MBrb&)IAIe^qQ&t{^Q&48&R1Z&;%Gxg<9T(W+0# zT9#$7Aqnq?Xw&;2s=hrP)X%J<5Gn>bm>lD|km^d(Z3U;dNJd#SG`B<&wKf_FS>QIU zB%J}SCdCjBS9IDViE1N26KYs=Y_TFke5;~UEA^6-ZeG+J3k_09?BZh26B6?-nd2hl zwLP+k#(&G=?|T$m9;ap4WSPGoM%gN|_U;y$!bwmiL1mDY1^p z-zuPUCj|5*4A}}G?)pZk0gFrBKo0pjsg0U#+bh6Epg8?ztvf=bFgszXmx1Yecm6oR zekEyTOX-*~!sRR!`e`t!$0Z|R&MALc*0&q6%JUx?-tKcSy(>dC3LPmwv4oabi5aeZ zZIco8tXlk0g%0U86)*5Bx-`fgRY4W-vzJg*4yf)4(q3T|%y2B(i}U1@@|@*xb1XL3 zm)dmC{q$`K{aL@WGx~5WHW+z3QATqbI);&4$Y<9_)hmUDT)#I%UYDfRfl|kg+ehn9 z%P~MDs?4yE62sY z_xP{v4VGj6%_`F)AVPb!`>pRiWiD4G8yFddMQjPP9<6OiA6iJC0U<+sb5hC_i)o?f znye%-J4JFVi@|Q@E+_4-X3+Rrz#T=B=gF`>vlCz5k;e~=HUgKKmN`aWaYoV@QDBJl z{IfAOQ^F!@M;~irL5(j?TtQkX^1c&G>DWQ6 zE{j`=j@Ex7ve^{HsGpgpk3_PONF=!=gB;l$pg1dcFoPGWQ{@dkXTI4x)KJ4ewQ80Y zl3tflgim7m%nDtxk<@YB^YcXX>)ztFFkTAHbY?i9CmB=uHca=C$lrmsR?`$`Lt@CX z9C(42n&-}GX9kXBkb9Klo0~EgxfTTRtcfF&4h4@s^Qamp484A zz}A`Ada>L&%^aOgrB~0)Q2-NkpQCOx(hu&_!q%H(!d|dWYlJGz*|q|>$xWgsn9}26 zXJlr8nH~*ud7b%0WBOxZ=5_|cDA1)xdgv!>LB2* z;>_(^{PH-zpB3_7;G}yuWEE-MGFaYkwrNZCDTHg&nZrNIHX6BRmB?X7=g&a(*rw?( zWmr^9XN2NXNz|_GB1e{#+m79@19Jfh#7~DpI5$n|QdF(u4LCW0d{evp^1wrz>C`e4 zEW+d>vK*`ykherL+P`CsyFbjBf@TIwX(sahWmxqikgSaydd%tEtcxAPwc2j9p2#tq z@qh{x=_S)7G~o1p{OQv}{h1T}<;KYGj)kP>O4NOvFW-Nqe-U}0V8IVgoN}n1M+?Uo z%{rDZLp9YVEwux)mnGiX&uO0jLl1B4)dZu!J|aMCrtyC*cqXNCp&b`4URh&gCx;Oe zcjKPN`m;AgmO(8IN*{gmVrc=cP8`?Po&HZRG98MdR?7c0la9A~pTn;w$w#g#yW^P= z&?^_S^~5re{ZJmisPn({<^p}U@6oL<43yZW<}ZuU;3Qd%wp|#h#jO7I)8#%Pz39gN zGtpRyX=G*kfXUf&5Ys$JyQMTCb~!bPp}Ft(8Y*NwQ6;wH?*8Q6Se4AX&-?1F~ zuCK!L*ziw7gjbc9VwFF^*$6JL@p?^+eJ9BODSD`tP#ebk|;O`98Zn z%?5^%0l~pz6Fp|U`lsD>I4O*<*n(9)EY14XcVy}kgP5&(y9MOVKnWTLq4M78*!yju z{M=(A!MYYOo-bGc*WI`O(xL^*Sh3kE$Qa!iaTba>A#rd`*!c>%7*kO)%!_(S$j6>2jc<&y+)jlw6*%e955#WRrf~q1tPr=DL8cBTiH%&$wB)65M6iHODIj-_I zoUx+Qz^)>q_lpuCrlTVLp%ByPAXD2u3kCDhIO`qUbi7y*CTMx0=Fxylh7fjjp2vY; z9b1^S#logv)&m_1!7mQnxuLoTWO{SlRr9euALO1~f(#VC8zH^~5q8iB+(pd{{mEao4Mw?p<`#zzvlCOVGoulaY5P z4qe-3C7BCW{p|w+@!x3cs%?Zwm$u=sW-x~v+Znn;_L5h&fE5||76UP(VXs^#%V?2; z+3vr6>F1_bxmNe_RV(a3W(D(n&ss$Ab{rN2%thb1F4#{kYe+-KHZIXU9B}wy65@+0 zqeUE)_(f7@#6JAowNoR>kwP=fDtkEJOKx|d65^uGB$zHlz~&hd*Hte=p$l8YOf~9D zD&!7%;>w+?>4H;!m$v}AJ0E@3Zz|m-E7~epwtQ6_kYnMqF{@xuOj_wc=K6CIcD}~sMFHi{(q16P>M2jl?m$gjN6p>QR4t@vq4*UhZTPAnW%KHp&7y6xm_k zy{G@s7Gp!xTNFmdhc^J{n6@|lE2y`n7RIWFp;rFT+CUr&s7o1j+%{u~rHtaoN3iO} zg>Rmc-@F-T+w#~QDTE8Yb451Q(j{%fcYSS)I^`Y}8&n>2$$8A)Vg~o{3&!9Ww>6lg z5`NT{gBd9voV9<1HKRBZ`@FwH9;{wR1E#8`SFbB(WEq&0Vs(2+vFiWeCY%o8k*rk=}}|d8^8M)o=gpvbAC4)!-&#$E@#skY|l2mL<3B zP+!XseS_SoHGV3^a|$zj(r+sU;0 z7?%#blhU0T!(tV>^~=de^~p$fE;%M-&QN!oqrY4$Q|Cd~bZh}nGn)MPy4D(>RifOL ztdc|ih&Jn?`sVKV?(+V)Mr+r7A@+f@fw3mGAaZLPby$lceS1F~DUV~Y+=UF!(Q$c- z^cP|5bjDzLh72PVU!5T?14r@mYgD6Cq{ws7++d+wGZ@*<=0h$+fpot5RlQ$lX_v)f z^CH)j^)2<)k>W3!#D+i>YE4pUFEi$;!jq&9gDt-iQ~zGUI;9+&}Z73q3C z=4)`os!=71w6}0RDM^C%c9Bof*jVole0|LVlS`^2`{v!J0k1AehZ@MICRs-4!Ur9y zAz?~0F+LV?UcZ7{t-kz~#*CL-hUoNDEbDt0z>GLE$rL2=DXz1UMHj@5d?u1+eL)f< z-|_M#$5MLMh5z2P^mFj;>GrzJF<#{ITaZU4y-PB88AW;^sn6#MwDwI&57*>6V6g6{ zJB|~qp9S`m@Mh<~twnrzyp(Rt7u$oI^F>L9WuhLonuHior1yMTLQn>q)WueaMOG+M z7%#|(A?^|nZI>tz7H1VcbMJdc>l?li&DXw42)FCftjN@+)KfSzDU$Ek1-!~s_vj?y^2}H?4UPB87*CCPYsDp9V8MQS-`sti= zEOwZ0RNGp_t|v>K=*a^OhOM{Gay${gpNdK3bQG_lNPoKkZI68okMR8L-V@>xP{(sv z9fg5TubC}Q#)G^)PQZ9KF3kWx#?*bd;}FHAPOfk_t${EM|d+nPR%^w65o1y50Ae88KqlfT%ezqi=%^KaKks2%ztZ6&4Bq+~EIYsrw(I*k^ZXoTaK@ z)~eWuxbf^Ljk9hesCe4uBNo`&Qaaa=Qbw!Mz#C{mLZ@ARi_Vn*Js;qnZ+nG3A=5q0 zy%NBQjO2w8M7?IjGkpN?{(dirgzo7u@lRI=VKTUNy4GZl&MP~>)Mf-d#`4bs-^&sD zbJufNlno5#LMOX(Du{K7p21SNC|K;>zYwDv6aUwpc#i^E>1ChS$us`Xewy2bMe%H$ z|LN-gDXu=79R8fPgloUQmzn<4Ja(J26B_?(0B(w3qslM&G0fem^&@}r8-KxB_){MB zg3nAN8Wny_w+?rLIJHRx!UTapaCWYDMl%a9{79Fvay(w+9@pR1Uk zs8NJRXd!K*!}ht=?kk!X9p-@2F7Rc;5vb7W9}lS8(=i; zl9&}laFxgBVWc>1%Bn&Vwc-ji-(MOtqO`7LW94q#oYT?z3HG?CcMU9?U^Krg`?(at z4m1VfJk$-Qz&(p$K%oHIt{xm>FnIziV$@8r7x-s$PbqcRZ}~kMsjve#59}Z3EkL&x zYqQW&sQYoy{5&8r<#lZur@z1*rysUhg&_{M*-e8P$q}#I{%8uINIwN4gY(&CQ_`V5AF8r>sRd0BPat1!^UdgK)wBMeGbXqldZ*R0?H-ftb)A+%RY;-N}^tdmH<*u&VEG^>yeXo6*f<3NWlMyRZ zvuFB%Om9xxC83qNX`3M@*)zY+NNWn8r3FrD4Cb{zm~X1gkOe#R6(N&p&7z~^S@N`3 zd1=ThR=DBGg7LN9bKfpz$euvbD>}`1mo6IZD92P+S39X2KP4-(!ZlKuv`AS@YA$5 zhvhJW#H@`XA|mzAp-8_~W5_BvA;u&zXP~*yfzSLmb`V)C0gJ=F`;p*}hWwW({Ts~x zRTPQlZ+C%w|1-ZnnDnJeBPLz1>PG3tzGi8uzU5SDc+K}(Vm78I2cP>Ke@=&wmAsJR zjyH}~q@4J(?SEVcix6N@D30)mMk4MhIwAbF$YqvynRgr#Xp`W8$38slDDS=!z2EtY zy9%@Kh%V=F$J$N&&ig4{ei5$w3h6m1c4w(mnA|6UHIMq}tzh^1H#b_>43qaV6mJ{EgRQ@ zqbC?zWvMm(!m{Gx!{ZS}gC?H^-SNdWL3v*S661ChJmH9q@pm?QK7WR(q-9d7UK@P5 z^j3Fl(0mJN!sCDsOLHaZYH!VvH1bA1nUbGmZ?(C_k7M83oaPcUL2u@bCxv}7h@!ZF z9kuvJYGq@5FEQRP&+<9f73g0kx;H#{NxXYv0{=+Q`PXf{lg&zHrTGzcEroA+G`$(H zTN7BFv;wxE&VZPyUhodw-)r5;D9`TE1am9Ocu`Klgkot!uCumoN=#tRrtLeqdpw!E z)zJmi^fJ`%i}PD3r^*BNt%)pEkPUVc%r$Qh?SJDO!nXN#hveuHz=99%=+G@4ZSaRJvB3n&j}O+)JN+z+!dN^y(Fd} zw2^1kJ9b)`-xW5+H0`kb_EM9()pM&fJNX@|H@%>-so$A3a~BQ1kF^$f3lN@w6edA;=**>Hx%h`%;;8a{+3S;{17+OaV#v=+fZR zyh>_RXbwg&cC0l`42G2u!Df+%h#7}k9a0a)bBwF*!lOM01t(NVMzQrwo+;}$_EnU0 zA2|RRhQrb>JNBHuH?xmPD|1NA@Ejc}kvO{VhrSZ+L{5TxK=Oy?{VbWOaG5f zhdLFOah(3p{vSG0-f6y6w@eJE_z13aMTM*+soMNPafz__-r#t`Ir+T{?c&r*avhw0(6@P*=?@NWwOE^8i;h(VmelTQKq51F>2zp-n@ z+*Xi$@^bf{(77)ITNH2=*=q)o_`byOYU!DU3UqA|m{@edbrBeXAsXHM6Y+okUh+Tt d=c0Uc?zQxDuL#AN@Nb1JE%ut{{N{4*zX0a#x%dD8 literal 0 HcmV?d00001 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 0000000000000000000000000000000000000000..696568c212d3c463d1df60c69e86775adddf74db GIT binary patch literal 16168 zcmeHu2|Sc*+xWCmr=&7bB<*yP(aDmn(SkNxg)+8EWSt^rY@<@Cv34Y7k4nt3L=0w_ z9A_#yNMd3#GRig>Ph%fr{`X^W>OJTEzVH8j-~0Q1|KI-%J&pUmuj{_{>$;ccwwZ~M z#1FDRAP@+N!-ozYM<5pA5r_rdix+^F6X%=)!GFDG$4(l6{}Bjn1i}fSt&PwI&uD~G z5%^mh;RH9pA17@m@EffS+M}bjqrsEu1OTQ-zCjAfk4|&>r`a`uS+f-I_-@> ztp64MH_!8}&t3##1LE+(eJAmW{jEXg8eYdgxsrrwMFON(Yg)_kuz#4rI}f}Io1<-y2wZhafMW0z5wwe>Lz;; z!WoG|>`BMZd$E?j6j7^Whq!16&A+mnD1%5ery@Ru|9?KDF(_EqbiQ4_({ z7lzIbzioV4-I~i;kB#ut5R3=AEFVhK8!6f-hkmyl-Rip__iU6QT2MYb8jeP1m+S5o z>@j=fGldVbF}~bY!E8L&5f>IA?7yH^>YVuLl>wBsG>q&uHZsD^fBlveFKvv^6}-)% z2NdEjk4um$P;a)gIEp-l$5Tcxe;;e8cRi<|YrmJO%$hJoX-HgcHK+Er&~AQpNzu?KNs1+nIT9c)iCP3n*vmVdbEbosTV@(@GVPTw+T* zyk2a7CCr1V#L_PAaT%2iXIsdudmWe3 zMcbIAAnDUQ`B!C=N5*%rT-*#SePiOzJrw#buZ(^urSaN@^rC# zP73E$pGIvv12vs?=Vp)1fc9POfmC%2EnjtijeAcTf9A~_m>NRuz3_3l_SEDMVHnMw zq*Ax`yYHP;$c?-g>^E6HflX9Zqob1wvN%p?NCKsdl`-qmg3bP<0hYQK`_#n_YBVne?FPq`DK9aD@O~q_PF0c zn_BCcNwMcBbk_26G5wV{NloZht7;D!BsaDmZIX)rlC2d@GE%wMwLP|R{7c{9R9!G; z-LH}|ZOv34-eBCz3sIIh89mp@!pbPywdL6Z2erpA&YjJ%H`}@_WbNHPJjQbthW!}N z_^tWrxboXp(;BusDtN5Zqpky2o#JH+`Ff-kGQB5~@;+V1P-bbzjc_eXfa(e*KR4I=VIi6{?M<$=r!QVu*SM1ZbUb1y zuWchIeXz^0Rk!q%z|YR-jQXPV%jHEqXQzU%rQ==V*hwiJ>cNpl)%aF?trYDxV#N-)W$7Ho(Q`e2OPs6pkRE$;{1bGCauia@qONSG ze?2@(YK-GyqXy-Avpg=(&zJ)3b}x|Zxb8-{IoS55 zAcy-30sJe0h-2vwr$;#FcZOnzwcn0o6Nl}!FuHrDMqlnjqc4!`U!zfxT|M0AJo`(| zMh=|OuOT!-Qh1v}w$>FHE7^F)a?Ch?HTErnrx4&55*&1UH0~w2ZfgJV(UAZPwStCQvw}{_ z3EGfbdn%qG+gs`4YpA9}bq+2+C4G$3oh-Of;9L2AfksNHTc8`S^s8&%+un;wLFX=q z1MenzcU$}}6Glnu6xs#_aO~b2l5TeOn?pIx2V0rm5j%-w^>?N0B>R&S+P9~ssQ5T; zULLRrGS3pkv3BgHMRbzq2}lDgSA0r-vlZz8mT)}nf?ko398l^(#G>a~dZnG}X zqj;E8v+pz^u^$p5a?1_6TA6*7cpa<-mDFads!X(MeaW`9I9AXfPx};V`eNsAbRD!t zh-Yc{k1P+*;4;_n4?fvvLfIaPwVLnj)u(t*q5cY6cdIbeukCUbrNK`uA<-+l*POpLB4c`>~~8ICGbVk$9SZ%H`t4#zfPiX z(%4anvkwbiK4khtbFHb>X{RRxc_&)OJ*G%ltk@}!`<*oL3P*XmoM#%Q$oZ*2#v1l6 zV@N~jyFzPkKg&tsCDV_@mI!WmaS<4nTo}&Bi&6Y8FH>o1tZTx!$OxF)UMpwlW`E(v ziyJ0yRuFN%mqyX{wNq_BIpR^xUyUS=UJy`X3N`D?iJDn8jheqgV5qP@-5xGzu2`ei5MRl6C1lhmHMFtas0XC64CBWY+``J$ zSV3sVILiR^-J~S`YDMW*~CY<&yJ$PthrL zUEkjtI@)I%s&Fs(TpYVhAd7t!d$aq4d=5Ttw7}B-m;GW4eB7@)o+L5w4EHoUIy1iP z^m!d5cfyUTBg1w7*ePaR2CWhi`6FvE??GF8OQ7Tf^-vtIWGX34^B8ZSwodqUH=N+7 z_sGY(oE}7V(=ey8lWNMB$x+46(b#2Q_Obv$1T<@$!g;^oG7^PKRRtEdbonDlfu|U3 zSySXc-kmR@Ey?XP|45xjvxmfF?&tpMQaLW&V)|tn?@giqZ}fnQ>xvyUM0uJ`a%|hg zn?j$23&yrNC4E1kgLLs`w$F;kFVmVU1w`CbM|QxMmI1n4;C#CA;6zWPRSxv?nFYw) z(ptAC5h0$#C*OU2CgDs?rzoV?`S+Zr^7b^!t)JwZzd9pdZt#DxP49a6HYF>J+YeGo8Bom;L)<%EsQL%lc-_r&8PGg!Ma{mpjFqJP5U&$Inh_N-Sg~mBUY{BShht&FviR=*RB}Y1Y(?oI1mbBAXZ0SV1-A0)EVf&uQASxKhDT+r40& z@@uUv2f-|@)N0MmTnsgV6{VSpS7fwHTN}FD|JGHaz7)vI7g}$q(B-8;T%M~QI+`W9 z9Gz22!a<&s3yCAKH%C0uDM+l@JknqdXHA9Mp?HOl7mHhds`h48Mv=l~B2sb!q=t90 z8kr`wy3{YYI}&s`!hHJK#Cb%`-%pj*IG;PfTY~Ha{(lByX}JUrHQ8{=uNKz*Dl`xB zw-WqP$6k%4fKqQagZ1*2V^`4f0{c%L84LKUxyr`8-3)7TsTduj=X{cu&o&XPW4xQJ ztYvBB%8H|H8QXeosf`JGlV9*fl>|?Ms;!Wnw0t6$IVYC;z!=TwpAEnW#aomhL&J46Zaf?n#cGKG7PjU0){bWXMW{#-@e<@xy z$vEF~Y%6;B`J|c7vPgDK3*$?u`|9Ap_ZjwQ8L}#$S4s4q{Y_88Qi+wAJ)pC5>N;+u z@`&JmqlEa@(Vy99A9^a@Tbin4)ziD)O#2zl^Xd?HtjP;;+_n)(TXTRdC>Q;xb1c_DLAb*i{W7!cRxe|F=20DkhyOn=bgEPFMuHBW8s|-ZPBFab+Wd;qPv-_d>Q=Sv~hX97>X$giJYs|I~893{Dis=tRXv6DovL&hjJ$Eq>Ay{{!XLQ1}EznRlvvR)Va?Lq#^<=;2YSBGCOSYdJKb0!jrIAJe*yY* zntQ^IsJR8udOU}&BjENbk21~MNK_>Dkmd)lewY49g*6`I4#{91;tyn1ob;aOqGV^9 zua_o!OkE~=8-tyccq#LYzNqIXWmbr0ut{%z&@+6rBI9_b*om4&kE-(UI~0Y3?e3?G zWE#Zn+$VFSiJFf@@D#Q!)dcVAYv0V@Y^Q(cnEHKJl?}$8bR8cahr=havrVu1RbAZF z=#W)%MQyD#w!f2MH5#Wm^mUt7=E;!E&iU^?TT_pApcHUpDsxEr>{bxmj!Qg=UwY_( zNQI)Yj@DFrJG5R-QsPumrMQ_Hb)^WgmNa*`!Ti%Bp#_k|3}uz72ijaIH;wJMuc#U|>>ysj>dF^1;j_P(rygeb3*F(Hs)yS>c(d3EC?M+fHR%LA| z;cST+iDu(TIK8Mk&s>Gk@|d`}<{Ug}v`r7s3jEw)P6?~rW4mm#=dt`aKkOVWNj4TK zdv=xb`i5%8$HzI&!vSdu?$iiS@XU}mNyK>xwy4xsHc2><=Tr_9TlLv{P(@1-%a78B zZqA7FH1&k0eXX0q)W;s?_E{;}glVq)OX-`5{6-}5^GI&Z`MRTJbJAN$uMSXuG^;fK zpZjNYgUnTIUT;3F%M%Bo5u@43zr!};eA9Z65c!-4B*q0I_z8xJeZ3|yw7TT`a~ydo zvpAn>stnU(qRK*3XH6UMiR;IybH^*tNbHO;66l!Gfe_8OxJH?{I9hpDIpKr%ia9f( zum!$q+08)d#aZl#6hVXGEP;+zROj^iGLQAlZ}s*HWh9<$dMY7#QCmL_yI@vOF&N0V zeCGmgWAu?(CJq-F%~-f4wIfd6^pR~u@%w1QIS(mWQ&{_F1E85=Mn3uR?wA_&tCY`q zL5wYAk`tL_b?l>`??mV1>Zl48P%E-27_&Ua262O&k@h~arK0tSKX-(emGsk1sTqqD}a>`EByQePts&=^GDO5bKTL*~lPPy-Pc&^2?a(pr&0)-N@L z(i~?jRdr2S80ec$BozQaG-0U=GNhiOBr^lB%&RqJ?)$~D{>H4!=2^4W^&!`+Mb_B$PP$#0xP z>g9y$iO>03{tgz_s3BfLg%e5okx-9C&KV4attS^T;KBRgG#3Xz>?dexk8LGf^p_4K zx0OkJ)58})-5G6U|BIVvG2CPiZ(+_@Fo>g2b)@3E977w|L+K#;S}o75y`B#OuGcQt zq*gohK#(HWF4DQ(G=F8p)`X*)YraO?LWGo}z6xIF=9I`5+rR|9bsFzdT9wwirp@-l zelze#z#JvzF861>q=d31>|DC^#()#E%>KW}`+u7RYKlvqhmJKss%)CD>^O_;xkPLUGLF-g>HFinjf zum!4@aO@ zht~_}oWmm*EkIP?9cpVpdD`P*WNIQ_Yw2!}Kp-a&xnC6-L%w7e)1H zi_5{&R`qQlCae;X43jm%~N8U_2>3O6EiZ|wB{W!lYdBU*EYh{-=A`uf$F0wK-*s=w=jo8 z|7mtxxya~;2G;o}lx$O0o!4CGgwtnyTCc3A8io$O-;gS?0~%s^bjk91A&sySnn(~!FsH6Tz!_ueNre*#%C3|C)^YTayQ&2;cP&xoKul{4@HBI3vXb4F zJJa7WSEo%dqBruc?b)mfu+jvz)bl#d1@ejr1E@3&Z=M{4zVYmii=hhW-$b+XwlBQL;DqTQygNpPaU0B?*uPi3}-v*gG>S*aHNHtrY&-(cS;y z01-?>x%Abkd;5wW1;nu!zDcPZc}2{OIMC zh{KLJhCeYbRlB58@jkw%9|HF%asE!g~uBRg5# zC?mAMQ`Jbe-T<-Xc)w<|1K|9B_BRtqksL zp^T7rtsj;@Fe~0u&*;p4UK`h6*5=Qv);Zmvk3%e~PRsa2B{|)tMl8JwoFtD z43~RtoSp8MZnkY=-}=eXR;=@V$_1;@;SLt=D{)pdJBsnS_B&C#9?>GRCk}>%bk!K` zl^;e&NYDD6r8`6@wI>fGbv4qj%(K%Ev`Eoy^YgV1%AteJk8aTl*jx$L7I3+yloH=T z20G4uE6uy|kHxU@(~=qPfBDR|ZGEZwJEk*mIcsaz=lWf9#bnYc_}hcspW0Kjv0*B641NTBn~c@+gkXpC04!lJN0OQydLK03 z7dGTm?Q~4pE%wx;FKbF+&8|IjI;6{R9fyw)zqFnY*gT7^&q#^Yd%1yk2n{%ElP^IfU&}%3<2i0PidbWFPyn5Rc*d6~4k?jAZ zpVoJZirQ}HuoD*2$hpo%35IR{vvKW8|#as1nJcVee1a%@K^mN_OygZ9j{xnAPQ9#LyobV~ruh2J2<6 zs-1bjHOzh_YQ{I6H4E7#b-DZ{zU|=^1!C_mBPjkM{%X((y-p?8LQucAowfy9d7Oq% zci9QoLorjRr|>M9N~{akVf!Rregs>`znN3(pG$|xhL?bC;#=vnV^0AFlvdN_z6tPi zVC(JyZjKoIH9-evb{ki2Wr_?$U`K2t!wIbf)bAB2D5Rm_6GbrK5e=|418iO}wnR=KMvO(8w?fg13hf?Z z6<}aVucI&hd?*L6)zN59IiH zT8@K3E&1Yg2~mOCt~ki!v-CVOjWRYki?jnP?3&A6%{>V`9*gyZ7}U zr$ND%Bw_E@JfDzek0Ai3R>A&KChI@3j(W7ViaE7;vC8~ZMYdAo4#7k3a1BU$)V|r<^YD{x<}B zEd2r4Cxtf*Z074fFxt$*F;ow{>&7>)?O%c)_`c6wt(07IF5$ZrR~um;xtwrYAyIU27V;elA4gxMrx4nDDryZF+FXfH?_-yI(_G025l@y5!!K65~F#))$m)^3VLSGP&a&=+t-$id)e^^yG+{P zWx;JC0`orZz;*$*M8K_++j_LfLk3iT{s+IA?qb zvQ4JuC^Ua=!o;Q8MgAH20Z<5L<+lcuxKyWT;&rQKQWl+( z!D#NZq&CL5)tDv}uQ3k04+`-rX)XaArdp*B@>)rq0xP1-TSG_;94htRa1)m#V9L}h zDH9g%NK`5~Xaxg@jWA+*0bu>qtHjbL&~?_*i2lBzrWD7Oh#b&zldhA^suLoqOFxeZ zf`~F^FfwJ2p%A_5-3`C3b^FbKYUaBAU|9YoFOzudPsKoqCp7l4DC;oAd} zmAH-|tKjz+Q8Q?B@O6gi0ZiSZwPA>h29VhF>Db_bn{G38zJo{_o^)n>}JTBcCssY;O$k@nsB*o$caUY$J?J5X2WlX6Z(YYsi(mWXHYI!OQ$ zyMfE@7yewRC7Sv>ReUG;X(iI-zykY2I(~r&_6mEELlj%$vn^Feg#AAl^e z6z!JwZ@W!}NEGCOcXasY%-z6-rdykw{EMiXw5DY*m9O=!UJjpKEpAGH@1{_cx{cP} z>oc(gM@wN2W$?w6!mw+EyJxBf9RD8nKO&HMS9F0D{m;K0r8zb=H1>HkD71TUya$3H zbl^u^cx*y-b!S`$qt1jju;XZVHOCcW4DLy7TXi^oAUQDx!`Df}13>&xj0xB~47NlS z!=WeOHq-LNhu^LE*6aIqVt$$)CS^u7ZfN@@e#%Qtd#q$4z7iTy_= zE-SNOVoT;;vTmY6x@@RhD@Bs^I{{Ztog8lL`$X5y4><1Iub7HYkQJthjnKx*jf0oy z2J$#D^%Vj-dL-pZg4mghuom~ZaL3zs z0mr@iGXS2;VWVe9Oaq6RpDIwiSGCBgX8RjYb7(b@OK(>ex^Wh}?`qw;4IBzF2tN=t zRgS|}&P_-q{p zuMC-P?w*CpCe*EJp;T{aKp)y!u6n>nec;a7JY&gH%8ETSkA}7wS2y$$I`g=mxc6Yu zL`*HqcB)i;DwyQG`G!3?t*tw^S5XgHgz+)R8y>2Ted%#XMt0Z!Hvz}J`xU{}=D>LL z#+FN+BoZ6P>FIgbZuFR) zlze5KuH^bm)88?s3MCZc@sqDOv>)Bcy+55VuF48F9Zex^dY)$qPJsGaO!q;)B+J&e zyOB`^gAce6WphNrYfeJodbNT5K^f2%!4N*%Ug-bbrqHdAlYSfVZ%7nH3s~&9h~DNK zIz~WjPqdX~&-60)aktxi$szaGo73;cCMU^3&KKYVCO7mvI;D0j z_H{mH>@wOWus+v5;DpChhuuAsM}(sDUw-Xo6P#&QjsU#$#;H=KEbl<==RQ}Tnlx>9 z^KNU4YxdOS#dQ-t@WULuQmKk@kD8`HQ6Z7@g%yF+Um|+5F(>2li33+0Fml0}ZKG~e z3i2Rmc3x-On&ujIE-otc+f)LF(dian1u1v8tWc7x$~Evt0wbpN)k0=`Z+jL9sU}LS zVaL&36-7_{i?cd6-IpTb^qPZ?3)@BNT(G$5FB6uw>o)35V- z;M}!gU+;0}4zxB5FAm^~3>S+buL4NS=7kH0`T!<-<+XlxrvNgK#fW*o)TPd#kg*={# z@4xz%w+rU-8sHMv9xTmEKEJFNR=x^STmqB20LTm`6_&h5Opwo}iYws8yhlFj=Z$O3 z#E4{LSSxqG?URS+R83tBiwI1#OldxyX)w}wd*Om3KxcQRQLHkfCW(e2kX+gPT$3$p mqV@iMiTD4Vmz(>93&hUrKJ|)OR|dcFe%Qd|V9tJrYySu1{RA!m literal 0 HcmV?d00001 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 0000000000000000000000000000000000000000..7ffe4441fc4e5ab736a324d72606000524b44c23 GIT binary patch literal 15217 zcmeHuc|4R|`}nljvZoqZqoU_2OAE?g60NkVFg#_c#3V6e8xl5H1LPeS|*vj77KbJ+bw8w(s zE-(b>20ieL1Ny;7JBI^i0pmFBh1@3?2(+1xPrn1}6S-u0$_s%|BEx@+JU)0EBM@s4 zdw1_VhW&k{)9tLx-uq8IpTEW;{pG`IUX|F34}}hd{jxRG?UAAA9v#~^duG@U=k67| z>`r%nqFUcza=o9KUgM$Q8B3PTdr{-K7;#Cbg^55wX(}W{*DYxA)vaVvM4hk}V*A?v zHt_fnnH3nM`)svRazID3m=!Uo+7Y@i_dIiFqEHZJa{5hz>!&h~RzXZz=?=pO_G&?_ zW1O>83Ecw*?D1xcMou98Yro0$9BfN3I((Bf>Y|1ix|dCyd;j4VQcZ&KMcjpE2ql15 z0ga&$N>fMFuQ-OhzoR`Clscp0Bi=9zcW%;3WIu0VkEDzVWcsUk zh@&S`?QpfjoH2I47)4mCut^RzjgM^J9N02mWKT9AD%_7OxPq~7u&wZKm`!l5t`{ti z@>+2dI^$NJRof8X|C{!)+R^hbeVA7 z1rwo;!aDOg_Kn`!zL`Mr^0STBN-!ANfb-|J<-hG%_1kk}(rKrGzPYpkponPn#K&J!@9dDw`5wHf*xzC0~(U~3&g zzK3?4e8LcMKt^(0+320W=L31NID^cpH%!s@W!Ope(W&0HF4V{lw~hJcMLCZyh9GU- z!Z4i=@=q(cnKbJu;g6Tmz1%4;^QR<*l675fAkiYd|ocQjz-e5lEY`6 zPxV#d?^|UjRTb%0bSw4YId;abgx+iJHU4sPlIxz;Q#DA8O-&vh*^M58)Z)7F!{;I+ z`#qs$l8jer2Y8eQ_GIH6DmLj&$j3(-Y<1-XzTD>!_^3^zVWwx%s>)=IlblBTk^Mu= zjXBK{S@OCZ^0V6pA(%jUzsviv$ekXQi+ejDIa4p#3N#I6m~z8t41-g;Z1lYF z;7Lh3V<hk7-B~ZF6WM`6@F;CDq-0z4I!UT+u7lKLwpEVjwkaXf&tZwZNGw zP%7Ptkh3#g2Q95jwhhYNIdWdAlPv$|uQ=aVdr1^O3UDLUG<#zvhA|sH^vREcKK1nW z(6raY_4wj0krn3fBvKV)<54nA&bDQXD+UkMH$hDsPjSjgw%B0hmiFZ857?>G6E?p+ zueZxASyI_E7#-KZ8lhY}b9;z3taI7peoVhO?m*Ws74Teb_Vl7coZRrBm%PWAgi=7l zt#~cgYoM_`hSOeK*!98NpT|MJR5I#6>pz$|Egm;hrmI8q&koH{BcSd8sUr#K=v~0= zkJMpSmqy3{T~EZ6jxMJdppstnQo`TJ)cS~^1N^^@Vpe+$3^j&nEkm7Gx#Yo+Jh$Tq=>_%V&aLgcrEP7}JU{c>zY zEx{?KvqjqBm_BkKFBPr+wLKIXbVxw_kbBqSZijie=zD} zM9iCE-RG@=;>cQJ`e6lfB+5=F$oE+G#)`6Z_ePcLP%1K$N{z=!qMcV+q{&a(bac&0 zOQF7xR{EvMwH>FH0N?<8NlZPhzL#3B?d9VAsdT2ACiFVLFWdsV z=#SMj0fcJ^67jn<3UO)Ae{#e9ome46uAbWQ{FAS2Sf!sA&9-dHbIElnyT~qIbk$wz z-?RQ>uMH6vA;`Ga_D;J0(k`K0*v%@Wt6Jnp5t=}NH0pq`R#zl+W*2smLkLoaEIOr1 zdLV`R0|bQ-XmP1<4!xAsI(aAr3GK!P5>}R+a}rtteDlBk=Us1XS*fw1q2WwFzO(EO z6b9qHYm2QyM_a9WRDv^pAkQwD*b<_*&Op}saR-?-*V^@z>dIk^IOdM03`L>H@^=)) zHXJFWDdG>I2ib-Rx5`SBPxSm&xXzO(7!xK+(`V0AuMPY>Ea@LjU z>ijxAUlHEGqA<)%*^q4!RicLtdrw#ZV~hicmWfaaDjkw3mQR z4SrrH@VHus6t{Ks!q?k_ju~Ey&TkQ;LnF#@r!G2Zm{e;uA9*g3u8)jWtAI{KvnR(c zu56DSP)E7XW(bnyk0>7S)?9PY2l!ko>;?AgJO@eaV)HGH<;VILfBdqF@;p%zt&~+^ zKoog@G)!h;qPmU%?A$rVRTOHS`aK@f%i{ERQ{$f`9L%w189b_tNkkQr3U4kc6xH2a zOOE&8BuA;y(~@wFK7?zhiEj`_@AlSiEV{aFM;LRaa?PdBb11-0K51dJK$CM=Kc-D6 zU>R@NbSS2&vkGmIHW=LS)r=vyB3NA!xq!(DNg2#)N?wW?il$E7r5)oFqe*htx=|7N zU1_f>S$FOFI-eVpeVig7t z14K~k`@h;VS1vH*R2XKkZ#4EOCt2K;rX(J&BKiU4}O)wKh8RsW&Dedg;8y&yo#>MtcZphZ*JPzR|qF zz9%|TiW1AyzdTVoA^5yYFwwi}c!XXl(@JKZKs6$iEG{TXnC@^{;A02bz*tdCo}Q~) zvT`=1{jB@~FJUckUX9HP`J zWmX#v0#0$>_XoQ~(swNwg(fL3Gk9>d%!24~#{#zvPiX_~Im|Og94*PtBnH1Zpll40 zPh40auxh9A_1JsAr(rs6zVm4{u+f@{hcSxO=D=$U=-sd~(({}FKD96v8O3AMUp?GG z)^-!_vXs(7`;M9ZN**F+b(tUazxuY+;=J|mB9<1w^)?dEUANdx_kZx9%hFU5p1}_( zP7~;m1~%QRnecV*RhE)^s-E-*AsD>F+zh)YD5M!>%dHtaa5>5_<=S;1x|Q-Ws$k4pxzz4%Ms2q^uzs9Of;62)WEitO&uV^XEiT z4p4uXvxA&CVqk5Fu>mfbixdRtiw?p`(C98MQeb}OMZ`Qs{%i!OZ&qSOUTY(e2NzvY zXgnrG`w=V%7<+3dCLEJ;17D&&QMT%S(A(agHo_2UvW(Hg5J=rzKMuaqH`fpLGzzF~ zkyLhNjy(=a*Apx*TT+=ms>zu#R@O7qdL_at>4^ z(haPIIaf0l&~-LiSC1=h=xdL_5i>xvh#z%)Yj&TOMYiAiqbhkBVZx zYrfkOEJ&^|C^2R>bxO3j{cGsPNJe@DB7##qN1 zSs=|kgkZo=IDn|RUJQ7VdBXW_WL``8W)7=3S8u-OGDDLT885z(!3+lJj6T*gue|H) z(f;*6C^PWntiGBAOhAt^S^g;O^kD`22hoj-2T4H-eR?kl(wfW_=m0ui?K{Qc!(@M5 zS;LM#uSCArACS0TZWf_ktwrkjRGvE~;r7Y4T(a1xkRKr;%VR;{DlFZ!B&RW!oBqg( zofpngZ>2ATGqf|>kE=BRbDqQ&I>T09i&|J zPwylgnoK69Q(C*{V-~Ncx^XAt)=mE^b##4wJypRZ!&uHIKvs(u#SNgrDhK~&yn|t7 zDb-*0L%;5@pcm(u^2A%|Xc^~>ed?iE?`rH5;J_5%GeOWSfoGtwT7cCp80m)~rOl|Rqt&eW~^PQ zII^@F6_*$MT$SVkj$zdN55AK~kAPLuQq}L^=)?*0bgtU1yVLxoG$^J0fM>c0jbV`l#Zqf9_{nv&x4ur&ztl(rS=48r@V{yyo@=s*})09a2xt z1eLw5Wo^_~6~yxAlLvirk5usX`r?z8YyE_;?#>8|gYhjlT578LmlLcdCGVD86l+<4 z&I^`CS*3;}EFZV&wU&cLHJBmR9T`a+b_{8bTbTQLg~4o%=cj6va>vH`xnFcag>Cd& z$G-;<;7@r)?U#;RAbLA#_Oke;)PH~nhCQB@F6a-L0Qmt z-NGtQT)_I)>--VJXH!QbV(Rc;tmdD^@*}fWDxfG{{6#F2&_d5G+5VT)=U%U<@y}j# z2wud=a$0Y^+f|u=iT{L1{^5gz6g_;@ z*sCGA1$jn@qlsFa;-T8EQyAqk#i$I)J!z6TnKAe)cDv_cTVhsF5}85 z`pohjS(10YvfqjyQR^V~nmCtZ12lU|%fWzS{FFS2UL-Y7$cZc1 zcs-wRju$h0>n6Kxp8~mwx%s>zuT-E6HD?lKKjN!Sl%!Qc&U0JwlEu_ps}|rdVogjE zjx#AWgLPMxl1&42h+_ftsmFc}k$P46jp2&QZ}wvkZ-9jb)X0@yq&qtu(`Zqh({X9e z5cdX}d$Z*I=+q7VPrHXGjyTYA9NS##eRLpldOVXX@4n#Dj)lBaBF4uTVHE=0FP6NIRAVnFdrBtHZ z1eqwxjH}^|d8=e?CL5fZOLqq+D^-!uHm^b`c+nCs-T9}_ zdbM|evp1mPZUnTa{q&{_xqWJ#cxx4)$w#Cq=WHX*#hW_7$#3`kOdjB5*fT`0t?A6+ zU>(-_AIA;H0}k#p$ELY!tkOA|?*J$TmA|OMf|H*eYjMDfryQFHG~;icuLPWB?troH z+e-5H*FPRjE5S({i;Tb-`8vr()|!>j=-9&-tHYRq6Vqi$4lC^;Da3jiF}ksX*_yw# zhxP+Ff4g1R4j9 zM;Z#bd2s}^80_!<{SW_$te-V`a{o^R{ul5^Gygx%ob%cQ`sUM8D62abhz*|{-Kl9{ z?`L&g2(jU_;~F~@$dc$YLcqba^Igh-J;(Hs;F8|)UrW9_W?lZdR-8iIT)J)f3^j-9X3`j{;UHjI`a z)8R(_qAQ!vbrhH2nx=1)e#+sV{B(-=^UAU%GF%UI7#REd<8bW0sl$whT)18eUnbz^ zm2HfPsnr!sc}ZW0@A zOMz^Q>(ag4XNPuvE0r;HmX)%YZ+qhR5$YIp_7%}u6FpDiyVl{p(cwkTOk@E_xwg;e zMf+_&i4HoX>v>l-ZVg5D{?s*uNqm-Et{VhuQ=&H(7-$_N6hW^6VaZfsfzc^18#mrF zx@A(d@+Xn+YH1nN2*-n=N()23)@tUs(1#EGkZH%)kuiy{We=Dg0F4>6&QGEW;8Ztr z=M;PNxGyIOTHNMTK~!!HCHQr>L1XBlco(dR|0;Q!0H`0E`p}X}3Y1dmhk=p; zv({6|qTpW2B>3VLruF3eq!8J{=#(4K_kMecXQlRc0LFHqMl6VEd?;%PVrd%gV&gV@yXfQ+1jzR!L;A1!pD}wH)_PcASu<~ zjY5=1|LQQz7XHS1bR(atpN`ad{JboVR{fE)u^227r0>_btK&2HCsBkTuNsl%*N_my z3oH9kCf7(6#H~M0_>-vqnVJ3t9Wqhqn`1dbjoU1S(1Q1BM&KJ#cR9?= zUpn26Fox;TkVnepVHeFlp=`Me1J}p{@_31EwBYTUk+~GwK&k7IbpL}H$#Y9X2p%(W z$2%P)1uM#qaa5q5rphgfpE$2MqxIFz&7UNdM*TCM=eI^ZZgsC=MbZyPp_}2e%_PpS zA-F(b#ObSacgoq@nvcH3)Z}JFX@Iw5(6!^vYTM)Zo){npR|e z(l4|5WlE{V9Cvo0%GgMo&w#MqnPQ6rlL>c?SicCP9S!GHT&6r;LEe7D#wR#qRg`{x z``?Q)+e&Od*)H}kd+Mgs@|oGo%p?=s0&`bh+ds^Deh$mX*;|m04}tcio4AT|N~h4F zXY~jPPJUfVy2eEoq2+Hlhdbl^6xvxi(%<-CZ<0d($~8 z-c#h&8U8)Vze*Gi#Eoh$^`PnwIK*9WH4&k?Kf?)a4X~MuuPY$Vc)HC7H4~y%;5s63 zsbvXsAI)f&Ge@N_&d&7i>-o(RDR(yHZqD9Xn5x1l(p2bc@=M$8ZoXm}e`?95mTP7> zT(z|G&>(Eg!QV8zLl|l6Flcom=1gM zqsOQ@oa{?Q$1z94kf#{*0d{|eu;L4ydB~BBqfE>bdQ3i~N9|z>$w{i>jo$WqjvRhQ z*TL;InZqR+aTt`b>h_6=3B9VAjF>Q0Nj6D}RGrDypA{j@RgGxmsNx0%V$ooGs_y$? zT8iY#(cTOkPEs>n^ftPgA;Yp6&Ft7GhsSdY>8s`D)rI0Rd-_X@Mj&p5Qt8*KoRa67 z&$`ZhoW9NGrDc;wG27==nR2MFr9jqUS;@zyshYCT`r0|h?f1Pt`PhijsuB|sHKBLS zUm`xYQdiPCyH1ZbS}wW^@&NE3r~D0`2jFHU|WO(XV(`3Q4VRX6%{Ki zsN8*->rf8~(?^_g&I-0C3=%TuhfM0bS3<3~nwQyL(CoE~-<%K>tl6J{n=t-> zl~x9^?>#Udl|*U5p>qNHtlL+1#J>-KxrGFD>#P-PI==0D!=B03n_^8-eCdTksg4bj z&$ckdVA-L-)vi_SeJ(Q%6@gaUo`NU_*g}X6^id7=9vew1e)J0Wt-q_WR6PL>kAT4^ z^6C#cI}@fR00oG-KbMP{#~7t$?t^3Zvk1b1ttg9E?kB!xF#+*6?n@B@sUY>cT{7rvU%WB}r_~U5?lPALvT-g#Z8m literal 0 HcmV?d00001 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 05cbb44fc7065b95fd41751aeabfc921c6d3fa09..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 23031 zcmeIa2Ut_vwl5_;A6a*_p5L5(|-iwq(5z&o6+@gSVQ7lwN z5<-jMhR{LS0U{LkWbP!W4MYMa3TD9Tgv+n=tjl#H zcrqd$hL+wCh+HM_AJnbIR}TU~Ku#Pzd_Ev)tcP15>mNd6ZBaMcP*7XB7klZ#EmI4# z=c5;!z7DKc?UH{`5lP)P&~-Nvz9vdRYs=^SpUpI%d|RT-HyAf3jcBEwX%%GAs|l7{g$wbx>&9PZ-GQV<^b0tq90@NeRds zVPVJxI2^P4zsbJ2s>T34A7*Z9YHE9v(P%q6zYVhLIUW-{qw$g!x?p2#D)0ftTv@|t zdlDDg-Zl+U#iqdCwZ*ixxwFq9P2nI@q=rqtLQ3S`oTJ-vt_4y{%5)_mM@F_Ih^(w* zYBroS!eaR&3rJg=5y}nE{L~#v9g|623Yd&EZHhi&t0U z#bqH6a0g?W#uphH$f9p9kX7k17$x(iHhi`7cpvrRoXv^r)#heY zVM;08lR7pnD^yp8zz6VoIB`@{PODe39*V#nZMUD(Q1{=t;uq0k$nne=Om|<p5h(sefnFGoe$+=Jax@Aq3@G3SVB}hb8 z6yDz?8mbywF5pGy1AQ@1jwG^>yKVBU^yM`Rtr zHbz7TPeqy=L3fos@Tcbw;B%0_%C-b-Q2Agn!}J`_%hPLOlc$c&v~Ci?<9b}!>6yEG z4TV*uNlg9MZEYR25~!t|-Fsx+wZ|zF*~r3ctPEr6P3X{@qpPGpXwJ+&#!V2rnn{N=SAl@ zwHsQUj>jY^FLA$ROsKSe>q<;Kh}J+v?%5W}aw$LUpMorao0E zg;tmv>cROnQn@cQgdV8kX1OpxazuZN3Po#UMl?-Odd$Q&Z)9*DQIXj*biaJMz@d%d z@X^Sn|v0YXHp~KcZ z#BN8<&KPUpQwImDEVD02<5K6oK6x=Hq6CF%ewKuJp?y)`hKNlv<~yHglvA4bD^tF; zn$o7xp}rx(Z;k7$rcFc3wfc*S>|ei5!a!tSaWUB@d&)}7U$H}D6yLhJKlLEqub8Tp zAzYNZtQ2}L(&|Y&X*&$&k;W15Dj~<@IFqx?4~2O78Bd+{z7#@RcizfqX(+DI=tbya zMiu>4?@}83yoQG3izf*I86%Yx`pZj8y;aJIBpC^e(eNQe){8*8)9eI?SxDrP8Yh+p zV>Ar5(NxGzHgbhX#Du#4k_l_YCE@}_J{axG^+k=li}|+`i;L{9NIr5W?nXc&=!X#X z#7W}P;V=H`Xu2(%!_JAMWcdcWqna2xGJeF@?TcrsnKjg}Pln?9m|Qr#f6Yzt8n0a{ zHV68gDws}HUt8>a5mR$Z521mJWs8av<4Kz+eg%s;i45z~GhMB^!xZAW<-xN0QaawJ z1#0v)HctNH#kv~RCyympPdg8l^xATp8XJ>46btvdSsoiN@rFW+9%Kj(gwm79Z&ox` z)Xt5Tab|ll2NZMFRbF-ZqNNhTVDA>HEc3y5)b5Ja%v~6p&Fd)qya_w&{IbceAJ8jv8?p9C8*YE)p}F!0^QBHv zU+n`SezIJirkT<-xsrqYc#ZBr+9a|9o_3NeZ~x9Z4Ij676{WrRnM#bESkb+5-8TWw zw7Cpq-BA?e%?yymmYSg>26~HCSueveu{PButW4r`2Pe0EAyS2U2<=RoyK8`se};ja z*Xkt^h~-Spd9u(GYhlBYs5@2^Hyr2mxyO<2+gw8AYcdZDg(Q_k4nyMh*T|eqPAS(@ z2~D{P^pV-fViWV65e_J+x0AG&FLfOAal}1u?pIXU?%a-m#CgZ&y$>OlE5EU&Dc2Z zi_Tt-=6rJRfqg|~th8`tn&}SSJ86PylIEZnKF!NG&pErhwJ-Hxlyb33;{}WQud70O zF9m!4D&Cif7nrJWVp%a__H}B76-HMWMAG;6g|f|Q{-s6s(h)F|vP%EA zck9RRF%Z=?zoGB~m!JtZ)_iz``t5pu<00U?-h2F3aA07K9BCTraRT%WZl4?Ofm9#) zXY}>=jr4y{ZCw+^IMtcvl}jmNmlzXes)>!|QzvQa(7<;h!n%jWtQqpw$;!I3jnS^& z&@V9Wup8Pgh3Ej+xlZ$;`6kYMvVohG-ZM;#gPZE9h@3h9JY9C#;#53!@z2vW9Gca^ z;rY)KI}$S<=vdLRPEwx4>_ogz*ks&xIE($!`IOSQP3JGq@?G0;fj^P_f(j*O=NH^c z7&wX>a@3D<7#iqN82I{vcaL2&&XPjq3Q0)dd;BPjE$;Y3O_=P|32a36*Yk!uz+l%% z+;jvZ6UvzrvJto;cLsHRzearKN3)>3%CGa6m&e>IR5?-6efg=F6{Aclxi5@RabPp9 z3t6fjl=;olLI$TS|Gk=kIjh9{iOLF_vTviz(SZxjly-%c!mdMtZ9cHX?N8Q#%HEs7IrYs-xX|&mBK!fS|MWZpn7T_ zR7>j&_WW_dwrz-+rkcx7;dgpBY%qR=Y0*(wp2Ia>p~>CZ)(*Ui5)%UV?XRnzIt-mO znK_>clGaLyp4s`w`NH%k{@AyOa2c5N4rsdn&~gW0uAl=TZe9n!x6%xCU=1@Ml;0X# z0&A2nVXvm4`AmT$qzJ~|-G2}Myg@&<_TT$Q^~AuMyBy0A1j630$9PCR6sEQXcGjVz z@tRxus=bdev7M>=6RdWI)o(-C&(VyBr0e?CL<|$yT8{|fYDLDND7xuCMgQ$3V5lg1 zge!4g6~}*~CO%%z5b4Is{KqeloV3$$_mSlVpsT33a!q}Mnn=xDaodQeuKb~WFE2Yh zIe~&-+ug7$KEZyCM5aFKc7o*&=#|~@ZTy5CN043{E`kK@8HFdWL5Uqlk!LqpfrOLU zNBE0Ob$fgIX~DP?sQ5MX)BLq&eBXCxYz42iU$ocqmYndptD9HadnCZ`?0PH4UwM_W z77_XztpEL**?0vtzP$U?jSmT#r3HtQ%rYRYq@Z%SWWiiLa6qR zisg=!5#r!DOmxZ(Px?a_Etmtm?Tp{wAD%;-1giir~ zAy7pP=`0ldj?wbEP*_#7owxffXTtt+m9*AYK1?wJTNQ5*+qJc{t{w(E1b+r;j~>}c zAN`&+sHLUl^oJ}t=oKga5MnT@2l+xYK*ew5k5d6*9K~yE#nf)49o0NptqGJDZsQB| zVX0K|iREGGiAMh0FWi68+o+bTw2FPiBarv(!ng9Y4{vQL>EAaoS-UM31C&J?3aFu< zPXcvebQ%Gz-HtH6zkMebGr$|*nze=~FP^#(S-A~C;HeAv_SP5+USnZfM+|oJn@X5b z;5B6SuhKf{CVQ_8r#{~65PJe8yd81w>hT0Pe0>t;+8T+=90xg>Nq%fF#|Xs&3Gs6$C^4~ zow9C82L}m@O*k?*Ya8FjJg_;Aa%)I&<#4^}r-1UM738M6TOE3a`LIn`cr!S|=V=&h z@W(Y@aSb&^UH%DvM+_YP#q$nA2|)3V?hjq8!EK@m z0hiFZtq7lm5CN~3?ABhwISbWwF#U+W{RscuvGUbNQJ1%Z#$v1)6WJyw4iV=!)C8z%q<92Nlklw zaLm!{Zb9y$Zb4u$zZY8gE4-;8pv*3w?{-EGE2pLNq_&%P$WUlfb`pP!bX3Fh&u?{O z%?S<4yn`E7jpe<=TaK6i5%(^;l>IbmG&mYCXH0d5#;!8tXtQIDM(vABUSj3tCD zy=ZiNi{x;>R&T)O<#0TavsG154ur*D(F6~>FJpbtmpn(PAxHflV~JSN~A_pRu_+)H2-`? z%f~}So%=eWPt)2VU6(jdJy?xdqR>1 z>hEtdOH&ySgx~eJAMO>J!X-IBfOcANf)*b+ zaISJDI~;PuADoy6Rp={g;svI@(4OSEg%0S?BoHtUPR)0#&(AOk`$lBDBj`uO2jw4y zal+`d?H1FLLIYJpa8iaz?Otw=aLp^9W>@bHvs3FW=KJ-M9&?3Q3YEPXD8QMSHXn?`#iTgNnL%l_G_RGYea}%#e^bM9e$s4}d4ybf%5c;N@pkZQFXa#Awk~5bi?901i&^hw@Gj9v z>E7WH1A+Lb3h)8WD5k#=ovf03TFE^apXzuK_vJ-u6OFqx%3Qdb5Q`s5T?+R8;OSY< z9vUD|nQFnIn#NqHWwQLuz>q*DTh8=qkDJDqs3ATuW4{c{oUr5^#RnZC3aTozg$Dex z>&Hw9QG~$C6((n8!=aUeROC@_-ev^ji+`$<2y`C7Rn;6 z)K6%!%H)@txfFXJOc+qh+8+9ETJOf|?H*Zq1%qjL)cl0+lncV>;5VbNbxNl0U zUWjArN0*Tq>znAR_Ck8qL|wWb)|IxC#0(1$Gmlwp_2 zG~zGjmtTCVIb*T;Ug;t9HIz-LJEyiphgJ>n%22w4j*NROE;~1PX*ve@PiIs528C6( zlnGt)uBG12T+vvvsBZqwoFe1A#KB~%k0X5o&}cx6xPeCh@SF$y}e$X`O#3+5XIO+p#8B6^H< zix!_nlV3h@LC4l!r8b+I`kQFFqRr1sVU5t~vHL9`5n6TTUFCf?pA*Gbbp|%JRf(T- z2|41bgJ8h23&l}p;$Ai8U2X@fI&MK^hj&5~&@+!1!3S)qZ&}Ye`^H0)SnYM3Y6b&S zx}?%LH%B5&%w)c9Ve|+oyL9T#`p*aeltrYbvyv;0WOA-HhB6u(pQ0x($?#NxUZP6u z#co3x`WcfS`}lnd^MkJEPn#RZ;`=F30^i z!+x|7IQx8^$I*Y6gRkz@LgIX-i#n@rPZ0i4k+#)MW)Q<*twcN=n*NbPE+6@LuCE)< z7+(jyB?6A_W0x56Hi;o~j~B}dxFL?sIGqB=NZ?6Q6#@1{Sr)rzPrX89fn79h-laq@ zD0kr=4E6|t@cCTQ)ptEw#m&Y3Ss~*~VS8uJ^p8Gz$()7F7Wnfr*O1lhCE*tY<>mfBURYM6$eW>JQkAQ}L*$-OE-iez;|8!l z?qgcg^$;3Qy{$U@Z60i2Zi|V@cD3DR37{ap9X6VGE4$E1O-3SqB{cmAJ1f5(4(DMZ zr`dYg#xM7PZFLF^fa(8CL#DY|zcutoG3LVoU?j=ST3R%()f1%$Q+oCk?>LDEc51BoD$ly3n2))M$r3mg@NAGltF6N#Msh4 z=&c(dYvH*5Ki?FRduheP&`!$m?5uB^A~msKDm;kAY9}uRfGnchc}5w)qSATx8bD{1 zV|l9@U_;?+ct%^BLoM*bs{f9rLU;qN69qD%b#5@aYM z;x2Eg1IQ43Tbm?p2XCFL&CYe0F}EY^rJn&L?KMeCe&!^qPU$GHna||CY#IT0i{(AF z1go?ZmGV{vU@Zg05s!lXZ1lYl&&7#V6FmbAYo2d&8GeL`81DUE^e9vEN70`{pMNh} z|6D%(dr|#b1D*}eYxOkG>$u!?EO0}9Z*@CxKQ6bb&+|wA4@Ijbe|W~;p{+*5V3jL) zue4g!Rsa<=NvAM}%3WXRG_1HI%F_YYHXcFA{ZZ+^EY0zW803S>{5o5H;25gZ#VK6t z=4G55XqDOncQM`ZhbT*2S{>!2zr`{H&lBo;m{*xreo=w%Pj3qUyfFjx6T;VEjTM9q8xLZK zBv~RgIaVuwuB!nO%#?&*^U14RgS9^XeUf%T^7k+UYVUyfZ>)lDpy+&Bu`TW)ufCly z&tvGgGBtd*Vb1Z&rJ|2hk}K}0D*%0(P%VKiPYX6|ZH z3W#}|_(liYK>G=tkh!CgDLRkM1N-^97ijIa2!I{A0|Nj++`q9&{?RgepFmkiwyp&J z{mo!A0Em%+v?EEjd7{%VWX^h$w^4X+LP8U;```n|y@NgN_DJQpisuzJxg{g{A!{B- z!TvHkR6}iQ*UD}OV@c%{xHmX7kC`1seZJ!6aa4h~{qV!l{>(xGp=z?9gke+tPTsfQ z5XL<{DaoB*e`0b2zbyG)gy}ydR7f7w>#q2@=OB(vG77}xYpl$*2_Vb5 zy~p*$Us@{a1+fITcv)K!ITIWUVrRze<}LG_86|n!5Jy^!2rp_a`noLib;wa@dgI>} z#&zH(o(J%*1BPE+wiY=0sU84_ry+=s1Xc|S1xAiN3@8O~R)4jrfpHKOpT|4fP(J*y!1soBJ zfk>SAn*weh8)VP@Pz?UlVOh<3Qvllhb`%)?NZ>pP7){in_RCBueCT6Iqc|E@tg!bsm5=D%HX1C$65c zdq@Ak?bqXU(EyyrrCkX_l)w7pymmssQ}IN+Rx?luka^vtky)0?&3+ijuA z!Yd%`Jo~#t*;>#IaYka}$W@C4UgK$mLxBLVnS0IkdD5by%ng(YUtoT%ekPT($w;LM zeoaX%8K7#-tJoRu7#}K0G1PN1 zrmVr?OLgVfiK8$zF`;IL>C!sC^J1I3BOB39LmFanmOGm#*a1=d5Zt-N%-H(PvsFWR zSt>R~Z;R>jC4y>eBAOUfmBmeCuVgig3f2ur2FcypVtq9|DV4^Z+-QeVf5NrlJnwWy zS}#rG-Ll8OY-JAnG%)(~xI*Zq@XoQe-D>JFa^0QX*6%mI7!Q9JqB^xcN()i{!Hv^Z zAbgBo9Xy+7fU3@PcB31;HM#S^nA9)Lou}D;+nxPs#AYWgvV7*9NwgM1C6`m&C7Y?- zG+O9(fcq7G&82u~?u(1(tqC-`v+(o7k@el3wjJf!OA5adPB#VVKsI=z^sM))#xUpK z>3T_FAC4qZ77IT&ubMmJb*7`gsS?S`AjYGY3KN{S*tM3OZekU~)P^v@3xvU}M0tWl zh{IllUE3ji)CV0Gt}DJFceS4O6^C=mUESQ}ln1r+YoJ|Gvd%5A?& z*ruo>+_0dxd12LHsVJqT+DtqPvh7tuWO%o9tD|+iRyrRL+t@v%om~-Cb=cc#m{FFR zv8skdQPHB`4100TA_J_Wr{{*tlAjE|+pD43fvW!6AMWLSYT)fAd(_3e^%h6{SPC|J zWz&)>Ftv?BO^l9ItI~LyhV8d2KiPRM^mD$^DUPSsw^xYTqZK!k)?;U1hNLbw1W!w* zn_F0d+L+gfi*(n;~$5V(`>4ARz~~)B=wRCIb{oaSc!;chDN0Oz6Axl zP4|sfjn_NUTZvp|3h7IcSSsbwItd8uub?vitG1B3x3H;Cee8a6TU%S4P0+MCTkn$! z`dvUuM<}ym@tg`Sm^GV2b9E<#bWI&6BIQ4vmsLc_vm4u2vOmrGctnbyng9eOkgXis5D(=&yjmxmgT=- zQ)lN2pvDb*A;i+d=6d1Ts_bA3|#jRx{MlHAz1>y`bE-s{mP)XlY}iTMH;YZm#SFe`^0>|2OLzqNf~?_I{?v{y063D3)*BjwjT|Ag&T z{Y*;?1rcixLXA(9T`wo!o+bZOl};K(4KNlJ1g55frcHZ$v@~!GhiNMf3Lzlly*)if z69Uz=n1FU#PZg!zI6TcMPfVoVADpY&NaRsJX&nvzWkgPLVxmr-snezIckgQM3rJu- zZa#>Zx1wd6DPI>e!HEmC6MHvdhkhXst+-G!?!MJK040loSU0smEp2}(Dx0PID$faC zV|TrtUjJSxFEe}G+XE&2X-ZBXW36~1sVy3yw>=*_B~#ep@OMCPqeK`-ZV0I7=b++Ah53gcsa z)K-op>meBucz&|Ii7_6dc0&)b0`u{|MG?y%;MsNEixu*jMbnu+kmAh~)NWf_03>D& zMh?HwSmWke(#bq>>cZaghxxN1h(tl(;3U@4SJG8z%MGkbtoEUhkn&AfvVY)vKyv*H z4r(z#=U64ro?>Lbg`b@c$rBRnmyDhQlvKRT+)$gJe>s-=HDVX8JRP?g+XKsf&%+Q~ z*^hDF9WBt^vfB~UF`@60V}_h{{fM7N@FnuJa^Lsgej7mqggYah|HAf)v=vzZI#6VJqjYOGNXGbZ|iK0vP17H+s%3 z$Yb_3(t9<$zZNt_?3J|#8~!h!dw@xv1jvx4ufC&>xRq~9Tt7WzU>Y`-vGZXtRXLU! zOUOJi?&86YLn|pyGyu&|WHtys!2Eg=;Dw+ffEaUMi3)#^dc)jkCQ z$U7@}F%XQyQ0lq;$7iOC4&A1>vUu*p>CrbsXG!6%;W`ana$F<^Q^c5)bQirxF<4c@ zT%6M#m}r*tU3Mk_&wvpsz=a=24BUiHxyv*nJ`3@{ZA`#A>6j=!`Or@I-u$g^@!c2K zGb7S&zvYb=5N=4+c4a^|b>g9BJih@i#v*~yTv_bF#~ZD9y5aoYCjfra(y6p4XZp`x z%%W#aU&wLI*<=Mai=+~uN3JGVW}bmRpY>g4y2fooR5U1o$8nZ*4_2uK6>)G_j%zkp z=DLBnW|}0HPlN*@(6?q3;?kExptrK`fsyb+pk+@ilivO$1p0SGOaD6+ZSw2+cqp2d zVQ`$!+`ES{zAyRj&Di@F5ug6Iuo(dv)Zpe`;LzhU-2hB;j}O!E_?Nd#Ork9%eq_-G z244LkD-eF?HJ|II3#G6n9d`HMxK7g2iuqVUwF4&hI}g5;al)+aUktU8b40rHyL5E zhRCZtM%e0~p3A@HF~WrHTVqc1>1F>+k>8Mo621q;#q|2k*E#le0(ww-<1(M}4?z+c zxI?AtASjM6GN7ifJ-iD(IB@Y+Q4ymWP+Pt;GkKs-3a2+XuwinElqk{aB({NCt_(xL%H@#y)Oq_(BKV`Pld+)Qh@1#+Fe8k(&yMGzS9W%fQ zs5#FpP=Bsj9v8?1JkLU>+@Q5MW$-Pn83^ja>Pt`pxfo(Fs(i89c9vmRX^7&*<1_?$oghC7i~0tY};l^72;1=`{Ab=b^a+ zb|Wt6rRO&%ItK=4xXmn32Q|H61^lD};;2$GBL>&YzS5fQtvgQ4n}9Ytu9d)?%J;$b zWx3(edSk>158UX!OOn7Rv-&+qbuIDG#NT)NQtq~Tpuq%~uAhbL9awHvU$1A0)+Dg} zn#ToRUvv(sgbZBibm_~nc)w@kq4~|+vf3)P+lpf-h#jwb6=bC%7a*@SQ~0J zgWS{kIK6Mt=-JC!O9gbl4LbDY8@Ht`jot&L`>1nF>iEU6IIdKjBT6qdgwUb)#{GR; zV<9r7uxFgWbVNSR?*Oe(8)%tq!IdT z2D9GnU8i@38BuW!R`-D%zPU8KvF`IN$_@0d4{YVk5_X!(hY-A0)nt{p?n;yyHDUSr z(z>HMk09TQZ}Ye-hoZ7#R+FN<8F}@(+QupYjm;W5IqweWp4prG!1`H|Kr0*(3VdJAq-%;~yvY!a^zUk0>R3nAqHG$T7JVjX#FF#{ZQ+qx7G&P zqOeC7#0Q&eU&$BE%HBR$tBKHI2u4S$*Q)nzg4Wi3EAkb;^h)IZYVq#F`)c-w z9M>AP)ipi`7q1B{wuXuN6;JOed(>DJ?@5<)k*g!c-=bI7f3UY36Yp*+HrqJ8s^&nN zhKbEHBXM_W?AU{i`0<{Hrz|?xAN1%6wGfDlJVQ0Jq7YIo1qWuAwm2S9wCK9?IO-v_ z-A&(?;$Uf3*!7`P=;z2!QucV$fmZts*l-2G(V8aPuY=VIMy0}r>c^ugkvg*#y2y~> zt3MIeBRwXNPy3woFJ>s#&AR$D>_aG;vr>w+M)pFBJr1=H%=5v@nkg#WB!B8i!umrV zLX2H$(O(-Y7w&t7Y})L-s^)Ovw~$E|YURGr?$9^r$O@sm%2In)b(f8l&LkQb>502{ zEO=6~feRJ#UtgfVc%T0Nc$+3mYCeY)h*vDC?#%phW%ip#R`G1(wW+BQvkM_i zm+q~2y!pHK!bs~%2H^V7mcpg{w z?s_nyh7Rpga>f_;DB(lzowB%g99494uL1&z?knv?xyzDw7jQR41?DOE0h@BY)#t z%$=CZi$z+jev(RJRWEuk;+g@fhS&2_pg9|8EH`313-jG_sBw3aL~91@%Q}`gwT1ba^<}+sB-RY$(lxoeB7eRa{>9$- fzvz}LboavrwVm&w&%jrLAt#QR9L?3geEa_cUKv7j 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 aa7a75aa509dc58b4606d953850ffef9ffee8871..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 11604 zcmeHt2~<j);=qtnD%zspfXwFNP_P2gYEcjpQ3MqPL6ISl1jUg8L92)i zQPEP$q@W-(f)adGB4UV$Nq~TW3?T%<6mtJ3X#4tK-y8b+`VC#{Wu0W*yU#v*`0caL z*}3Ol+~MM&Hh1Y<6bhxb&2h`uDAXJng;MIpDgnyxFxp(pYkUBoHE4iVjBBNz5y?M{iExLRxrA6(jQQJAar5hSv_tQQ5 z5#(*tbmGbN`gRFj4n39m{Yqh7OSTms5>z!cG<{o#+OhxD)LfLA6B-TAhoGAm=%^iA zVAKjjJZiywP1GeU7PS?Fp&R~#ZuMmhmC)sUyWa4jeu>SpN{L2ubCrCQwZ|ZG+?Sj; zGxBBn%urQ6P1azSnd*@lDrf1Fk2m|RpHxER&aCUL`cy7+arHy>r3_@;fVdwS*n6Hf z)ijWi9nv=09Tz!f5xUXc=2kd-je8iOkE)vD;lwj@y2O!C)ToSTmo5*nLLm9Io zxSsBGt=Wdw76C=^Dazl+O8Dt23grl;>*XSM&F#U|x ze)xO8G5%@N~Z?hC+E~&mLo0 z7q?lmH>Y%Lom=0&^Vup#Dv>shY1IHBC7)&ymHbi#c_6=f;RdHaue@VwL`(HxW#^N4cwR>+a?zRT$Mo!G zN!U!Di{y(L`<{NT>A_Q1Gs*HRlfEHx7ZX}Zc($nAF8WGHHQnh{Bj+!DCJhe*Lz4t1 z#A|gwv0ZJt^D~JF#PG>)YuoKmgQV;~h1mvgs7jakI9qk3xN2hF_N z$NalZ^BTuDwgoK_4mn$<9Pov&6;GKL8y_!FU(8^Oa!5utf}%8sz1NIG=dIxtq-p1E z9Dke^&k?TwqTlq#Hy)g6`_%JCRF& z+bX+!mql!x~~34TB+xBEt$wx!$odG)gS@k2$uc`v)K z-7vWmO10BRZe^|*_en@{s>IFI1}8Zc^Enpf64BFXw)Y{4`PM?tYectR+G?^I$$mP{ zvtcSFN4+uC*;6RF$B}AlM?tNX18!>6sa9Fa6s7E(AWZ$viLEX9?*=Ms&&S%}434QH zsf7DS#8n_;kSN-u8IO~%v&Sdm0Q-<_x`uQBSuOWZ*Je<-{PgN))*kS?g#Ee48aRc| z8^|+9CXJ>IS4zHFOOpxvtB}c~o~taL`)Ati%_$yS=hpfu-X^c1tU-_>JL(I&o^bx& zGs>MEKZJ8+V>O2SJ;MaU`=Id9@T`78Ibkp9{d@laeMajuM4Hs^yH->^GQTXnA?#jx z47+MN7AZWnFF>WM)|0lly3fV~-bgmN$O?6}Ia;D|ZF}J4kwQ;t(;Mp{_sH#4?yF-1 zFHJXk&qTa6!?*bsmNtwIBoQXt$A#h{x`}>GGO^6Py)9w?nDQOpn7Bi>lf23fFlQpt zy#_VzPw(v<;ZiW(AqE}%mRGSyrdJ;fPUCx)DHYk^MMJV$l#Adoy5Nmd!$D46n)1ZW zG7BHSgM(}G(V`3YZuXl@Na+V=|`Ucn&Y|b=Z-?Q}EQ6 zd+p{HmDAG|O2wa5=#=*Z`{=5 zQu`+4J+8hEYlALWBa2fikRIrKszT9IS^GtUYm7CyIdnyv#VQ_URrD-szsa= z1mV4C@HJzT%CLNT4&l)wDc;Q(zb~n ^IH&Ou+ebi5OTnbWfaYJCg&m38osj{8&j zou8$~u3C@Ggi^)RPpvEL;UfK#l^_eYJ~;~|laGsbzGrLHN33!&!WT|!`HjN?S`4vH z!{*ICDyIjQG3*34^$&OLfWjkvn%R_txy&}kT+E?)+QvVOJk};bcLu1a zHr_%PP`9+DaW-8yc_or1+4yNR4uCbgSf{^t%DAa`a8kFvj6L1y2_@6qeJ7onqSo-e z#(t z``ev}dhAT9EBgXZsra_Ihj?PjT;N$@+)~(h{}PZ;+_N-iD8(dU`#>2%Nwpyw zT@W--`+hj4`^>&rfoEL*8o%y3@(J^J{0&a9n8|{FEWJ`*-w(*i)A6(Yl^`ZL?NqfusIT< zoyTV!`U218DV8-S_*!7anqrwW>OhgJD0hZm6TD`X>$9mV;xv&v_nJtWoHL*ea%=Lz ziNCzhtDg#6##&{JbEWR@Fpc;j9)syUplH* zRr)1Y#aot{TkKvH1iOajZe)^M2DIe&r#;jXJ>i(TQi_bh;mf}Pm+A)6b%-FitN4?KO z9!(o-1u&m;nJ%=OuiiT>a~8OE&uDCTH*;8emoPaNe?Py>MMB7qYvAuZlircU?X`m3 zWGC}D8kEu_uq!djglWqp*Ax5F9B!l`e1CMtHVpILeCd=#etyK_34`+0pT-a;$>t_r1sN7q!SjJ}vz zDhge2>Tn&~ot*6X&VdjqdcmfrHV&iFImx%B8*BsiV+>`3xOLnC^(Vb8%P+jl()>cc@^rET7Sz(DoZo zgu!z&7c($KwI}K7^&J?c%N@_UU(`a|Qc3XF<+dwF{NY9Dms`48=_X)&eIeuq#wYqJ z6=*V+8?xtk2Sq^Q&rRs|mXGO{>X`jlmo@nKEh>xYS5zHkGfSy39)gY-%IGi}2$_JQ zG5^02KuC=S)(DSxjxo@5gy9=l0-iyqub=;CANYe3Y4m7RE?o#bysf^NfbXerCx3Bx zv%hd~%x=-E8#&0RwD;39sJQ}biaYEmWI$^wt9~I>(6xlA) zU|+l6Yjx~FKzQCp>HUPL0U^U6bYO1%m3@*V_vg&<*FkR%^RiTX4;oCrW^LTq$kMwC zxuqiUCsr<$ixY;GmS2Cdc`qKn%EReFr50;p)J7}8z@O1z1`pP8bm`MP9EPbJtyM`y`gt%ye}q3E=1L1Hh<5WfbC9q^bT1}2b( z!cB8>o4@xp#8WgGi!qo}`SSC=%}Me`Qdmf+w4L+jNE*;#hjmm%qq#ZqA-4Rw$`iJd z6$-j&54Yp9$*}bDErZ8_H8=>Q1>T-;TM%l)xZ+m@^2Mj{%xyexZed7wSx2^3x2_Mv^yebeii-~xG;iT9Ua_UtzQ@hI1xdK zxBkiy!_Pr$ZIR&=*#52SGuEPz?_z;_n*v=SoS{6%9_M)SmPPg+FXj2Pn&Eh=_FMqm zo@^m}-~z!b46U_mnD^dsRI`(~IGz4vK~#y)bu&dMXS@Cy^$wh))2xxRexEbOuX(Bn z|13na183*i|CND8I$-|iW?-#d9cEn^#u#Zq7mYreS7U~&AAZU-vxU5_W4tG3JqOPe z*G7tsRf+K8<J_>wS%$0C);zZjK4&VA>A+!YjqtTP07p!WmlmTVRsqwW zTHN1MmpYfmO>BwUZRz3AaW4gD_x8KlJO3t)ru0j;ZQp*lLu;M> zXBWqDQ=j0+W(~g;E6{+ljPbf>>8hj&D%Q~s>R9n_m>toIu^f3%)4DpFEAMn1J_#p=9^;#d|LjUq3(+kHB)Wr>MLmo+?A@z}Mwi2At&4ONNTl7`ns{Rtj9ds|cbeGfm5~wM`u|xU^64FzN%@rm82XHA=OA zq&twDhW{YmQz1Sa)=$qR;0p8^O>cwpbgP?yEuiCB?qoy$JNDTeELJm`zB^mBUgm_s zEMEFE3dc^2ksI|dM@Y`GqkjS=IQ`aq#?dnLOXTyMRva3w%B1gZ6In7qWof9%I7-pK zxN(steh!p%ibwIPcq<|8MWdhK@toO`H7!&)SgxE;N6iPim&t9x-lTt91I(iz5W$YTJr!ozy@E~*xZ16ojrZ*Lre>aNv71cS)LE9D| zuLN0M>xF`htg91aG%k$Spe@yZ2Ib$H8o$|}-#z*MWE$>DF1GCHe1yTYV;k8*9dOdA zE|S^W+XF&-BYWKf1;GVY-vrYmFa8_U~0ikmI} zEJ^=lIQ=mz(|?@)E$jEcfKouprvemeUZ&z*fZw@W{0rLt4Gou;G9)C2k`=$~Wed#l zri{P0zj+o;8B~}rjU!P42OlI=Jvk;IUd!~1Cr!nQyB-9}j?aADR*FuH5o}XjJKt05M~3RY*~MQR zn7YA68-mV#IlJMFJLESaNL}Y0BscvfQ@+=Y)H>JG%JeZ`{!xw=(mDWrq<3tW_f z!^EjKIY}1GuMOs5XXP+IZDJ8cQr!h>7isRNW5Ah^=Fh&=l!q3CLH#Y z%geR%^Ozqo3z(3=-$Nz3IIJe9KqT6@=-*#<{Lf6Jf2k7s6Px7JIQ_8F9sCuBm!pHh zqvYTFGR`0NIKDm_7!d}(i3c%V?KOnui>R>n98GG?u#!Hlrdg(~N~=9*@FE6^VVZ$I zsam@yAm_#K1Wxg1&i?E_?{HH>|HJc*;M>sTL`p`}cA9)!e|C_q0j>XNHJ9%fWgg%E zEO*a7^4Wvoqb-Nm2T!ZH$!Mod55%VXz(Z_)guL6JsM3%%a;BATTG2XnNteUh`AT`T zt7Sk+DH~g8_2Z*rfn_b>u};BO;##~08>|}Hfg=HDXQnAuH`K!@qjC2x>LxJxdRr?X zCSSi|gx@8lbYE%N(;bEuP=%@phWyhayJz&bdKGIX1+|4YErvMqWc9GIDF3%2n!YEG z7GFw#M_b3Ep1Io2Y>#cdZM=k0VqAQBP8TSE4;o0?EN?e7^^OU)c*5g7XLzC0YP-+T zPOo#|-_F!!G`vXAbi&BnD3c?_`2p28=k*TB+FGhP!ndeI23QFl_*i&N>c@bwaT zHm<5toBR2DbVLM2ZXxM#drf!RQZZwF8_~9%T4dJ>OpGH)zFN#rF=s}1aarTpNn zwHNbl%EgH35Da1*CR-KpBNRT>Qe~S`>0)@Vq1RL?u9S{3y3`K5tX^ctp*uzDPOr&n zD6G!6XI@ftU6?>H36)!kEAdH%N@Q2zmu0k)4ec`*1hO1K%uXFf4}1VSNj%;VRNT8w z#psPiSQ^BX@fiL7!Qw zdm9c6TFjqew$FQW8=Tv8Q-))rOw%(%57PRrbxuKtEVZI^C#1`KCyXZ!6!mVK)78=1 zJ4Q4VJpESM)u`^J^P;PaJ1jc8@Yg)vvXn`iLvx~*h-4KW4v7N)!-hlX(kWJQJ1>OaDjBOHZa_;2b7x31Nf{F~iZR;s<^qC-(ePkWCkW%~+r~>ZQ7&o!`ulNzSW5nH z9ZvrBWN<$!o%(WWY4rvuIty&eCuq{aD`oWwRg>>xOTN0N0jQh}25}_2`>~M`6eD~p z9{S`#?8RkK@2>0sADXZ-|&26i+nm^UY{tR)iMD+7hb5?KhYP2k*@2 z-uj$s7arUtAGKeN>*&H_gFHP3b}|O(vh3^tCu-1!(n&OdAjrV)1FyHd+8*daO!gdD zhOT+0rHL+il+4fPMcVcSuaD@i5F5SflSHaa2knYj4nTGH+Lu@iWgvOe8SA9NXaw|WLFh7_RpDjos z$xQUnHAl2GJKsn?$>I1NB^waYYk5P&K(;8{*0$`~x_-*Wn1`nl8=O2yXS?2?NlH>V zkDY}m+XRnvKBN&QCxTCf-Yo1&O0e+EFu@nbrV9G@Zd6$}8Ao7xs6ZWCaM@m zG{N7^uW_F~E{#p7vZ{E+-8f&<GHC`=kYsr zG{Mn^ru*Z>-V+k~Kvmhi_$^E~in@1D=gc!b1E^y?4(l|Ctsl9&Gs*mXreMHOv^r(% z{RpXk6q)tv`kRG}*2hbPf>#yxEpe+0D7y9EtXr-#-7A%Sl0%E?op(M0jot;`TCvrd z8OtDhixPXAi6u5RMtUx>^y*iQ^q=_i`nx}sF&Me@Zw;K&&1uKPq`iA|reDfJ$^$Fz kjbA^X^5;4YuSZm*k(aC8%(kj2-j3e3)n!ZGrv0b?AKj~twg3PC 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 b2a40405b9649afaef219fc285f7e6892750fd27..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 36499 zcmeFZXIN8P+b)XB0!u_$A|N0|5l|zbBE3WuML|G%4YAM>B2q$2vP6oAfPnO-ARsLu zoj?eJfb<@Eklqs@kdQ!Ko%|8L!|Qj+|4!q|t~Kn@623Vu@WJAsbX>V?aA6gA zPrOd2d97Nv1kU4_u}7CH&X+(qd?{2I8+o<2*`83&5T7&7zY&vcTCtMB4zr50c!i>1rt*1_ZUE)3`9Tx4=iz_RalxYyK z?Ud0xa6g6TzDfZZf9Wg>u=4akk0aV6x1&0DWYq& zrd7IrNk0tGy?s+dp!)!1_T9~@Y>rg zE%L{knv9^KP~%v{v*e}&BxWQjlgjPvpLcUxA;0sr`cmLN(5VEHB_t`%_MIH**~I%`Fg_VW@w zyU^nvYq_!WPuIe;r36*!p>2}Q>-9mi+pF}*)K&8(+slU59V;p2a(RLDRiW#*c+%vV)DvHf{O+@BcWiltE1Rbo* z$JNV!wjl#WaBOU)YJi+R+`X;PyEFZ^v@{oK?Cm={@0EC45aza?WMv(P6!FC4O&uz$ z(nua!_cq)Zbsaj3UT3m?MD@gs^*l4PhYUaVj~8@DuB;rD!n6)F#mz7G{ak(mb)4HW z*HK(=K=jgQb$Jmv4^lD$)>q{2<%@9yeWeVHx!^21)AN1D`@|E%=!}WhH6>L9w zPD)|w^#~DjTyWILVB~|-*WH}FOjV=;BjJ?MTz1@CHZXc*+ZkRHQq2b5jkgvAC-NcI z+g7KMe4($T=K4dVR3(ye>lM!H|i+IW9{^2|a}aY*OOagID06jG3zROcK-hIAo&60W>~c7dP+l1^DKrQJC>() zdkBvQ!!nK3H`2?EL+leqiUX0}-tKwfQT&;{3hLODctPiYt@gyF5;gz(dQbl}Vzgxj zZvXlN$D^Tk2faV)H(L3iYfMdZ@Z(@tIR9cB#Sv@~ACSFp}O>lok8Be94t&1jQ1yy#}2c1_;#}mRccnrXlm*j&Nw#=0j zC)G^`Lc3SSNB4y0#|!QV8el6%Z`LlWqWhjlGe#EY_}Ts*xp)MBU!qq*q1S<9rXXcJ z_Qu0ccsyUOltrW)k0&?*Vv6(e(Rxr&U5s#dbj&J$;bT^Oqp$$IYD0)$Ri*EcrOQcN za-1EmBe2OQ)m7I~ReYBPNrANFxBQZi%VFo8m3&`*Y53(k*vURv7Ap48Zh<%cQ+zz% zl4H*FpZUzVu+-MYK(8WN$ddl)uKgaZ)}1F=?dUnFI=&4IBxep&VPYOI@)#`MWviMF)vLIm zF)law<{@AP*SG>)dZIlZMOFw0Zs%t&sha0Ad1NyQfh;c0l5t+HUCQxiW`?E+h`sYO z{RbaAuKxK}>^#iP$p92@iDht6*Nc?Ee?4}oV6=#;-ITlSSg`-nz~$bqS1)MT^Wdq! zfo%3S_mK?YwT_7L?3jiqxv&hB{g2lfWHjCbGHKW8IoTv&-k1#xt4fo()nL^eRNu$8f|}Kb9MvvVgjEiBB?7u zOBXd3^ttPOd~XSQapRMv4bF3<$~(TLHhjnlMxHs!u21Qj=Qp0(fEWv{^@MeHzWk%J z{#AH=N3kMl@`PG>r7XMou8bYcqxWQXIBl=TG)u3MzI8Wr;lCf#bxs|WoiCXVF!mhr92_=l&&UoF zEL@w2{t8wB!8fK}o>QSv&56JCeDTr_YrJ8@divgrb zBh$3Fzk-u#Ir6H+1{i!e%aaY-J@-Bmr1UMkO3qXA8^M3cO~^s=RIg2?JE=HzV0Hh* zgq8W%>ym~QG_)eo5|?{J^{-${n!UGT!wi>dheKZDqun%(selF_30xIYZ#;oeMHyp6 zKTsWa)NXb##hd1_*MfduBj`V~Ww=qNYAZ396~#|AeW)+<4j?|cFbed%c|05F$F>;U^i?o@Ep@j zf?$|YPHT(XH?!1&XnZ1-Xi7qIPnmZOJ7+GDv$2b}(S8bbQ>M=)%Ozf~a+hR?u zr7qHkk6VU|ag>`6ch&V~e+iXy?481yzsAHi-+SRa}M$uJN90Q&y4}0@2b^MNbK?k$+!S5ZA}mCj`J+Znjh>$f#;s~&wdG~%aF%w7DH5ychaNskQA zimX#8w)zV40ZpFg-=lW#|m5mkplT%V2p0l>n}?4%lQ}{-%+Xn(IcDo9iM$Od!X) zY9yCS|H7JzD)(`7f6SsyRD14{2x7bCMP&NXL1X6yx4^joWZ-xJ(K=aPg+Fi|Cn*YS zzIt1MyEWgo@S$T!|BnxQ50@lg51Q__`qH>_IaF`uZP2ZbwF0t!rrL$Kr z0Znc$Z?B$HwI@9tw+o$o#oUnTPCGweu*g5}Q)P#z2UAa;dgj!r)2F$(xG1|^AM~ULJOoH<>B5)!9OBIrAe-6Yu_=`y+H`i=gU~`> zo2~B$Z{N3`U>`KSvv{}2=E^b9*znLTj7N_sUan)!b=yD~JVJ_WRkf-!HsuX>Dth5_r0GUA z#vM~3k#auM!fIMkSwlnM80YTovU2|Jzl>f$9HT^3hez?MDfL~M5v^^5Qu)2Izo4H* z`S{N9hW@yF1aGQ_j_9yOk)o#>DC3{b+5XVf)Bl>@bwi4}8mVd>q-BdF-u=@Nsp)?H zF}25dZjQ(Bl{+zaa+TguRFy#HdR|bzv2KFUbNIOKl9_+~vGs?i$05TL&TsN3_-Vr+ zmp^o?8cCMs&bd~FYCPv^ZfI@wq$Z1)nz))yicLINw0cx^dNm{P^4AUffj{L z{0n+q)4`T`SKLaDOfGMJ>TszjJiPtNubQku-h|20{ZPDA6s4yS8j<_Je_Wqhk*;w8 zP}%mT-fOVYvWp1cnc<4Q7pxR@Ko9*EwMo!z#A8kjsF2?9t z59HZBDnb`tRq|N3ag-9=a3V!sGcy3fiVw>iz-D)l;@1%>hbK!)No7C%B6f*`pBSXS zd%0n;alys*-plBbBQ;Dx3grtza#`=%0TYO-`dv>b&EEbnNWPwzECgk-)q+FWvdG_`F< z{gO90Pd!t&GH*2wjTE7^(tJ zELR$azhr^rVT4M$k@sEWY;hjW;G4$T+0L4Xr1Usp+sMIq!zYys2?f#tt?WHj)m4>M zl|Ei)Al&x%c_3k#$`)JV0U(*W%IoTHQ!48zW$T$o+5YC0Xta8GduV91d?>%%7^|oE z*1D=BCGjb*uzH}oK&{i~V#L$#UtL;1o+0(7Rx9l1I8Sn()nx7by#9hGf3m(%W$5zo z;OM8Sfq<2$ebLcm4db1mZ{zXhzf<}f0F zwE~i8nht&PHyQ0288P1i2{uDIdG#YdM9Z-4h{o_pzjA|pbA8n6&={q>{E=po zwMCMxVZ5m+G=0j;;UG}+S%7u#9sRbaR!DD}`Znm*zvOJ>k(r^P?Wl&j_sIMh1#PFd zaPUx4aD6!`eG2sJidE$$a)hjT8FiT{j^$@wz4#AThZ8@P8mSAX^Q5jWnX2k#xRFw@ zPr^+l3eWy9RfB}5nZ~b~nW87ERON4uP7(0q_<@0O`PtOOpFaPf1~~+IU#f#i6_Eu;g#BTPdP0ry+bc z*!`#K9oeWEx zDi?jy%c7hwh?wKQZgt>4NeZgw)sc?oMcsxq6v{|5-nCkt7GAUc`rIuidJSX2)U-$2 z8mIL4c`)sA{Pok<34!F43f-7h@YZBQVjg+0)M+Ah4Rn%kB6=ag;j#Ax_19HCa6hZN z@$0Hg9piDG0Lukl&*&@VWet*fGefo2TFq{GQ45c&V=G!X%*JQm+G&-*3ol!;;FINw$qAv#n~UtZ4J+zF!#d5ZuGL|nD~`EM~8)O z7^YG|l_N;Y$IuU9=*LJ%mF#KQTYk}&>-hM?fMiqWudc`YXIf3DV+1=r`rOlk{rP+% z=+}K{Tr`x8&9>y21^;`xpwRvx^DeY(mkVChYrR)|m__k>?SNln=H@atS|nEfH1mK! z+GCgm6YgW01$AFM{BJ+BP?E)+Yzi9pc0KJ4&sbx>e^e?1TuS?&Ele*Dno=eL_bHxJ!<{nY%`lUn(; zYtU6Eb)1Bt8gs~)2A{(CdFuly)1fD1T?5=LYX(1`*~q8sR%hjuZ`O|H>OSJSFiq8Z zP9nHfwv1`MF2XT}I@wQq_ev%`LjpmCpF!A%ZA{8oh&;PsPw=3kCt>~hu})sSD9Gw| zh^1dhZSu&nPYQJq@c(399p`ud^A<=E4SK1h0Fh7}qYca%9Iqx#*<_^t6R5fRt|T9g zEVoa5roWqu(fuH6onc?uZ8DvMfd}Qe#R9R3}H6Ks#jQP24C;6=Z;NTiZ zQ;@f+0^q4?coDI2kT8*bhryKXfu{N{r{`Z;>tlreu`LP9g$Z~OWMH_{#?Jk#| zI)0cDaIf8&IP2h&0@{72se}bBP64F0)=5%D9`G*io*D6wxrBiZ}*F?y@8tQ(UX%X@6><*DJyzx zGh#3xbsfC*v)W3hL+9k{Tg_MGl@&%uRBt3GC@Ged71&`+rF1}`*ZOJ6R}qg-r}+`< z94S&~pMAny<5`7f|0`GI(3~VYJT;`2mH{2c+uHr0XgRxiTb&0=d-C0>YM|={g`jj) zO0%haWez{m)vN`r>Qj`Ft_*1XzOjK0TW&8y0Y zIH%WNad~-;Pra_447ySM^)i}r8)byrf+4|7l6PN+%j=w*z-MM1iZo;nTc4TR3%@uVH0T-ZZAj;g#f1zvh3P>f| zr;FB{laN}>GuO=ej3gBc@pbH-EnIVz^+gb$9~)^r)WqNZv?=DS)&j!rVz@gfwcI)% zP+%Du4YeMRKN?odP*hC-ah->&m2Ktd1~ zr88G`dJIZ}x?+Xg>uOb`%dCOai1}10e1Em#M`Aya*>SY?G&VN&)D18PC=afcuk$hK z61nRzoFJsLBxszND)p?^pK=@A(^YA1YP zJZ0yYYYi>vSmEa?ciZo#H3hluGjEd{&s9Giq(S?>dMzI1ysbg zc~4zueZHkrMc8k26Vl;>Y)QvJE6H5cX)8I_+c9}-1wM#hc6ZSjVkx04WH#YO-g>Ai z3Fr1b#xA@JGw!!>@p@AE`5*Eghi-=RALc7f(hxHmdSA50``*fI1ZSva;i}IxYmpOH zwI(?X_hQXd{MpiUu&byKPHQqvh1q0Me(F&~{M`FFK-sgcsy+#_UO&$I@v0L2=DOpP z&+R<;Hx_^_6<|eN>9{hn)w)kXgKX7W&IAED3tdHm4@-D$G4Qrw*#_ErME1N<$e6t~ zF|av`R*BK2{EN#fb`^~_#=?=sFFdykX^dUk*_=xG<84trr=)>!VST((azl1qGYM*q zTU?oQ6&2|1-(8ZoENCXdnXOXRo~xQq;&Cte@A zSa&_VX&2s*^L26WduSBl&5xPyb`RX2J-Xjb*GpaNeBI>a)tsC1%I8bdOjY^Zg7fi{ z&)kRgVEzG+!SFb);&klWY@U2AGxz?K$~6Vpgh?{kV|%Ct6?i;)jSgfl?Tf5X6V@(O z6&V_X1IVgElyBhkTLKP?^Strs{BO3^9+3M#g6#Q|c@=Rh4MF#`dn%}>qVzAn)q3#Y zfe$`Qcu*j`zN~V1(9`UAvP6q(wc4h*X~+=Yng!H zyWWLS4Fh1$#NZHlGI`8(7Bi`D-ghh^UUP1Z_nIr8flEZ1H{cH0;g)hm%u;OVvVRC4k zFf{>IQd77oAOGR3K(b}+@xu4IX6D2A5mR2-&9TzYOiJ}9e43IECMO%vI+x;qb+kh( z9X2p}ibb-$oS3kJ0;xRKTFe!QZR^gzB*UMlN5At}Cx7Gx)Ou=fraCk*!4gibBNkv2 znmcODvY6(~Emih_L9<7J6MFohhJdNQW6z(i&r@0MsJ5=zq*TIQcD2bhxf4JQT>N?y%OosL%A#;3b?{$e42Z9JxTd zb5#&bo)>3Vag;3Vnb-`io~lxC>zEZALmj-D>+0*g;p*)dUKTcz>r|6d8?b0*;dQHe zw;i=vm<%%<7lxRm<=jL<<$@l5fRkzr_mYL6v>WTpb2dN?$Q@ z3yNAAKA2|@&1>Bf7nh$L-s>RC!XHCdwN^0n7AemF>HcGf;0n1Te2IK~?gT8Bw$EPI zE311x5-yCQ^v`iN$QQnxC|2#9GB3H>zu7JtxSvDobX^>JIaRvq9Rqbf1j>x08p_y2 zeJB%#)w2?I`Ju(vyRKQ{mKqd^*USU9$N3#f#;URWVEUNtVq z-8#VY1)w}((~X;>^Cq`W%9WRSZkxw{LZb^H=H`~4c2)9!`5`)gLF>q9)oMOm&o=BI zMqvKTzJl4Q`+KB3|4r3md2?L8SWGe?N|@ZDEBoGjwg6P;73AO09Q$(sng1g|o`0i& z68x}mF&Pox-*14I7zbrzA~8K3frYaJbo@03SYZnqP@GJ?t1V1fVGD|&_m{;lc=uN6Y25l`GOKQ#xz<>nOQT8KvHD>}^mJ zJg%8!S+$!H03TUAt*FM@Gj7|@jfEI6X21yZR`F;gT`y;bm(kT{j3dk8Xm6QArsJ-M zOrEuq2;)A@`aR8F zbTUYb7NEiGR9xtqNUNrbi?Y6#X>n`4jYe#wrgs)*rl@SupnFTG;j~lcQw&`&d`-t- z=@6LKxLay;#B69cT{}Z0I!MfL8=vW`yA=ZC=p;~h&hUi*6_<^DJe8gh^E48>w-4U` zjw9(vbWCq;q8Q8Q3%vhe-%9R-c%SMC`)$Q(qPyw!X#wa?rmi%xz$ID`QHmUjvHqv#uTw4Y+feJngSG8KQ_MkxN< zc*XZCe;v~-TN&M&$w44S#Br22ti5fEkKWC)$eCzl;D(O={WFJ?@UFZYubYpKDnG=7 zXqoDnwqAnin3$SN1`$m@tvjivo_sH>7^)+Wpz(uuT8xb~2^mlpnZ=UMdB%O+`Pgh2 z_y8!qo$dG(r(9e!4}HW7i^re#i)j*kA+-TNt}aZ^nVHBihh;` zj|j~dgY}lMsy*eZ0oWefrb_AEBW4y=_OA91xR2!%2Oa7BGC$s9gal6*X>wmKsCJWX zFcAY_c2zsML1KdHoB4GooBeJn1nz_%4%H5X73L1-L!TvG*~@3iBfX;!W#w;I7$7TR zo)g`w<;`Lol9{O0#wKxc>uI&!SwMK6_4K4xq5GZy{vnXL*f6`Mbg~n$MjK-&7Guj~ z1m5r+wxdn>q{tE$2M5jvr~~riN%C)dYo93cS5o!D4=Q74JpX>xX<=Ge33w#=GgXD*-mPHHP-F!LJ0bU5TP}gkueD@yIcLs*6^3hNE@;!9M7+0g01_V)HzELM{nfV(Zs z&)f794rzb2TVxYy^qj%2vGpSo$PTU|=U<5Ko$3AB9n8DCzCY9(cwmjq7wej&_ae!8 zOF8C-tT!cri!))O$i0~`)+X$XwZNe;{q}Z~SjxCoL#k$xOVsFnj%T905hO+81Z@|! zO{m^L_XxQ75>ui3txO8Ac{zPp<0vMIm;%P!SY`Y`(f4r3=a)EwCgG-tO~^#K`75bI zbnCln-gGr}8^-TE95ZJ=0DK_TyZfP1jkW;x-R>-(xCJ88hGhe3a1y9?XUF_-KK01r zomG^j5b_{8qlS!S&Gj~HCPGmMPXKJ3FEM46tB!~o*+Hl#1KivM`Md8=+9l_hJHGo<3 zy|@j$bfxP_^2w1Q_u5@IFsmIrJ)%;3P?Dw+@Vf*_GAHaWs;3s1mvnSqy#lH8pr%e! z3vnzQl&EKm6+ZOif73a$uUNH{GS$cSi_#L5g6)(M@hPKb}+rBF_2-cV3Th>I)#X>h0tOO4EK zH@^38*e@ZXmgQulA82wrB)DOh2ve1{&0M`;=FnC{{uKZnm5SPk(FQYe2R6%aw}zP` zVEBjuvnBcPJ1s*1azd!gmW0)8ZFb7m1Es&)hp--#1~OQkfu@E|s~9xF=Qi;kB7oRq+I*J%LXaIN%*6mzCM=8(6F zhNvkEliFq07n$nD%pCeII=o#{9kJmIJuAYpT&|>LSNAv*wGzTM4tA z)7%Nz4Jnc9C*O(*PEd7B0t0;PtO*^uWRBYUtJ1`hn)_{LAx zeX{0zc6N4cEiG2{&=qK`tT5uWXufyI8qG^MG1Ls;19JS^4_~|+9Fgj@M=!xLuqgkR zw@x-4SZh$~L@lo44(IuM*bdz2Qo0>rjW=CCM9ng zH9@2v%#ZBDS(H5@{P{mdn zWOl9b+Lh}`GH5|aQH_g(wZ#*Ynt3+YGDbL<5ea3WSo?2?cISX4G$w~a_co?k8)pc% z$bP@FAhFQ~#D0iu6!40Umi3l8?9aj(bndBynR(G8fW4PhCsbm8L~=Ul^kQ^2?)*;Dl1=kn z#GxMh9|o73;}u4rU3>RBKSv*+&^Avt5Kgk#lzzdU;qP$^K<+p$=~>HGpM7b^B4PI- zxVjQ4-pe}fv>co-F-KctH%>L8Sn)85*-WW4>Nl`p{+@vKo_;GfyqgYN7lQo$|M>9c zf6F(ps2Y3iQta7chFkb))XsM>k`7CA|Z6P`Ef$ z-wmjjgD&%wI8AOo0+kR}AnU4_MPxAoG6VcBojhv_rq$y1hNnV6r4s-(Y(Kj?xEgee zSdCH|H8;fp{zM0^A7#xXS0tBaWgs%?$9sM5eMdhNxFB~1e6ZOJ z{0c(__&OXs8`|F}LF9o?27RDs9^}AHuV4>_)fd8%?KE>0UlRIlUli=mx|gZ0#CQCe zdv`i(9t)d*q{|I$PAcLkk&KNwLvFrx+Nk*SK8pxS7J87=6S&w=EQ)ykkH3z{C&LI( zKzg_zYfxhJ&LGiO1%j0&Ocz2pWnLmbnD#s*i=Q{e24l$2wB z*kPd6c(Qi=Z%5^(;WJ438dRr&+Kk$^>9y#LgEHSr;neD+%V#s7jHW~s9O+;A?c4rx ze-99UY2GG`;3whX)sB3-vTAU(Lw1#10|`DouKBTYrj4~6t~$LBX0CIhXuEA^_iX zF(=0*9S0QR(sD<3N4$EbRN;aT^^r?{JxBhllybuK)X|STdL-OLz3-1juU{Y%w0@14 zF8@yoPLk*8?&C;OSN{Iev|`@9{-pHdhq=K!7e?{o{G8 z6z7+xE`CC+Z+?XKIq2E?v23^wZBOaVV;1VhGv9J&H^|1P^Y^`Q{Kx6(EA&=VWIV)oRH*JwEYFKwP;`FK#B!}+S$ z;j^=LD#MiTUMf?g=kId(`L#DS`KZp*S^=wD>b({48-KC?O^(l_&aLH>M;j;`l+*H9 zs?V-4?&QUDkpd&6PjYpyt^l1s*K_!8`b$*lNBE36KFE`umU(-e+mF@cMf1l8E;h`1!-TMMaH& z{QVJK=w^xWEw{QH8YR#@?BM}I@uE#D%=woWqmiISaDRz*>Fiq?QUUw~m{6giRNOWUv;JHhT0-ic)=z53{qk%h%CV*Ja_unt`$csXq@*8&wD= zZX7QCoxp`#jRgogpimCmU4Gw|;X^)(Q+ttErp0m5&J4GmO4eXOk^oryzy2>kz|0U_ zXw4CdV#c>I)-XqPG38QhcWfe8CREd%myRSQ-+0l|!F|{E()Zp*=7#tAu{wB^!%?>7 zTeX~}1DwSAZ3@-s;$L+T@>6~nzbr-JBJ(5MvH#oY=UA)XL zqPWn>^B%8iQ??Xh9Cg(o^rI!2x-V)?=<#lmS^j6v^$XV;JBk9g`sk^^!KSl+P7esy4tNqvWUBL4$ex4Me$Yk!jKSbEq2Ptn;b)|%rzKaEa z%ts+8s`>7#fBw8HIk?$TRB51rr|0F?lF*3l{+)68Db>S@=gpXGHjpucV%=$UG1v}g zn9W|nxYIcQu|L~i>K;da2n=UDp|1Xhn23g0d+*D-B3X5d5}el4?Y9+%H00bCcFh$V zX#Uh5pyGDt!u+x%aV4G?G;lHa$f}N3^bJe`v&z@H-JYY(0-IL$LcAc ziFZM*t*sEBF$qlj==T?*0qftFQ*Z|hvQXxB;z)p8Wr2zvFm!#L$f@w3eoN`pZWvMy z(_4*WZ0r;3WHE~w0mS6n&PHC{%zY9rkhc9UC^j~B#5O=0)1Id6sj-`HaDU{2_mH6? z!S{t%w=9a*xrVNj!7NIFY3+{S{juegUKEoo=h*WB?Kcy`Pp87Dv?mvXqiUQozf5Bnl@us6LNL)n{)j%MCz6A4&1K+y-6Q`Smw%upfscWByJFVd&$ zW}DW?1^A>#N&U8tS9hl@ZZgjx^IcFuK>>m?CWUDSChEsxP_;+YHXDy7+Pr?`)!o7m zJ%}#}l)x+&LK&;s(HepfG7yoFFl*?3c^=8f--;tKfj6A`J{L`21Zo)}Mbpk;YHcrL zSsVNwUAvg#>R!8$u$%%tnB~{L;GyN!-LEamXzfb8r5AZIc%C(tc;)(J>EiAPR8~eN z%Bk$-SlQ7tYB%UdH>#(Rz(0~8Ww{cuR04}J&5A_R@YN08J<3a3BWWlm%|L@@=hdCb zI#{~-qE%~Ty`J0yl;Hk4-WbpZAbj>BqVnHDq!=OxL zySig{@zJP*xqkV>>PG+x%MT$_CSXeomGE0ByK9WxYcuE4YmVJ%}29Y`627^k`d_6xWVASc9?v zjtvvOrjcC^~|uT*!;Rm|dIDhxQ~;R=j-FejS%s_D;ud8rKFSzTG| zISBcH+mxUIQ1FhFp>JRpRb4V21~`y)25ejJaJGKfOcS`{0% ze!o5QVB~;F#ZAA6R?l*!0MlGuU40h>WGLMC)@J-2dNZc%^RmH=6@zGX%II>+Tr?O- zSqB(c?$EtDQ5`8n3jB=0_>-{IDEBfz-VghVM*D64V8?Am!n8&nXQEAFnvcT=5N{FTOzA#`zPF!$XubLSGuz-O&?%!`%rO7E4T!XK~u%eg$4dLorD z{=2J1!U-}EI-p>*M=B~RwD|3AB^T-G=<1fAHnz4F8qUK2=G@dYzOuI?9#r0A425P^ z_68m2Ot@}&*03+epy2!Wn`<}vZvq&()zu;dzNoz+!mT}4!gBwsk!4jy?%+z1UPotV z`RQ_C;zfuoRB*M`_viQV8o)U#%l)oQFs`iZR@T#04eZ3@68xhaGq4w`xgpF>*rDY; zuVvWEFLO0|9;C1(g5Pl?PCqZ3(sGH!EbG4Rd$*uUAV#u z>+g-%=+E~keEzmZ^5#?Dsh2 z<>f8+Z^M7bSyjEXq-exg+7%Y*ZIjD0t?|Rd_8UBm^0~JuMF@a1WfaSrSI>4h1gV1Y-I{$D6cuPBOnXoLHP|0@ zP$kej*uN}#NtpH(v(5j}B0cJ~h?>&cjhkx1kxY%T7*Q@^W#Nq?=p7Ybm6S?@ytF8H zzybjbECO1mNuZ_7tvQ5N*Q{AvCnLsdjHa#`T9_np01h|;0->m)m$Ib#rpnUQ^9sxq zWUcz-%K=l%Z4h2`bxP9NZ);-i%wE5>^p{sG*J)qMTJ}U&yOAfF0Hf+cT~5>LY$*pg zWT|69gmpUJvnNei$hJ+1STlDG1QHSwTIxzR9>r5WnjJlH>K%da++7Qdmoq*BJmFRi z*%_{XEXjkoc_a9Vg@sb!-sW=3`1m;2$V2lf|9k!$ z|CS@5X8Ki~?sAZqdZT+RdBT7GiV@FFy)7?)Uv~G*#ZL(d4p^IiIGebC;`D{lIyh-L zMM5{h4!c(lXkcxa!lS%F@?v*{yOD{>?U$pa%PEzvBM!i~-3k+S*uIKGdE!TfatWE4 zn4E*~FnA4$A;#p?)CW7A+bk0%Q?yv1&e}`Q(sJyx=G&~pT~}^^Za>Yioui!9@IXAJ;Fi$gN9TvgUU8Zbirawh_~ zV>u!qfBUwU?C`0JJH)8~Ai3Nx51hZVlx3beTM;K+=C6s~dmPfz(wuyD;m>t-bh6-yVccdVw&~u|M%oRtyu7@YvQ#cn4YgVJ=Y_SN zOAj(1&Mz%FVn3Nfp*XLVf#nnp1YL_1_~%6vGc){91y+lA^l*=1s-Dj@g;o?OxNlXmoR+$53vLAulbhu_b4e;q%5ykFk3 zq=xU@xew=WUc%&}(e7hq_WkmReM%(3U-Yg;?Q45{<--a0I=3C3_q^9i zeE95j@Z3eX)wKjO=A}-A=v@wp0Mf`(Qm^+9wZ4oL@Z{8u00)jQ(~lg_ZQS}&*Y?Ky zR`RQX3dg$~Eq;FeKp51RAfs)~5yxQXdKk)m*M&Clo-#|^+0N-4ycn!i#`=4E{p~!k z7t>>NEM;VhL7>jp=>kANmLaXJ=wa}Qblc|@frry*rK6VYa_iYsA zdvK8nMVB0FqCdrgs{}W&L$KZu?!I00|FrieP)%mtns6+?Do_+C5m6B+3K0YW1q7KD zL>UA`<{3ml=3)$C3Z)1t1t?QwR^~a(2q6S;U?$9Sh>T$h0YV5#NYZcg>($?PZ};lk zeeeJG>eV+3UHF>!4Evn3&)&~|&OSDe+E#ZpVp{u?*)iTlQD=OSiiG;nCl)1`C3sV6ImOt202~l+V8_DeED^7_Vq@Q zfaN?lqw&_Kk#v2loKqJyOQ6k|V*I)IX{#u0zO|tC`xby2zk8>n@e>EQ+aC_}02JD2 zi?7u`rMlIv`{EV%h-7Z~lTe$cHx)Eo{%F|5SH*bgsY zaP}NYiBZ4}k<(-q(wbHINH5`VAE&X0FJ_u&T89wOMUk7|WKJ>R71xm8a&oZ=^e$b)KDYy@dl27F~_G;PqGnXUEW!9YbRlRUO)$}SA;%5MwY`q()@Xm02c zl9h+*q{TXDKDd1HBvlaV50Bt1iJ-#ceUZOv>ZFmbs_Z9!K@hTEhPNt$hU^}t_gDJ1 z)ukK6z_z8^e|rDipVH^F-T}kM0;Gw5( zH8_Bc04mjO+vUI@tvsgFq-wau#^(Uv$kH;W-2gCizZs#Snx?VV9_NFg#j=rSKW5GX zGZvWGZtj>Cn`cF`>946V9im?_DqJ?HPk#5Csusoz*gdjf-U~8dce?8iuc1@xEhgY4 zzlnW1HpH_M8fMthjh;W;iWFmPPyTTJ(GJ$rma2|x-55@#gRwfak~>y7bAKUVm zFRHWvh}`?Gjo0u0k zNCb7IkDPVAqTZtE)GwenDmLWG!DGK=K5%v}bHymb#(GzTv$y9VQ@uBfMkbMaUt`wI z$}@^qH|?{Nd!Mv~NPwbj>#&@lnYVhC^seL}=F$D4=2BApO=v``&jbfDQMK{uRux9& zqD>`A+P0gsbNmqE(aMak_g8$ps1?L0Cb~JLEm&XAhZE6*8|sqC9a$3+}Q@6JM6-y zW0P)`R_55DpOZnLKv6&;RmdQN4I=h0mOpUC*LNX2E*(CUeY=)&5fmjA7v^}Zoq7=) zDw3?HJt;pBreSB12_T|3MedX@6e1-=2!HZwo?o~c4dT{-TfnVH=MJ1Lm7j*V!xwCJ zjUe9(Hyi)chTTQBv`p{VIlHZ>j^l0?=5Cei8BU<6giPxEQIm(cuVE}YeufeKb{0T# zY%bZbA9Fn317tGXa=Z|j^E~F%%m=X5-Hwlu5oEzBRNv|`(Aq_FR>St#I0x-hU@$E7 z_O{!f%p{nOt*jGF(jhX)-Hsm|fUT+s-1AwQJH`Qe{FLw~{eDUV@>sQSYH0BEYi>>V zI}FD28MRNBcp<-*cLBI~JN0DOU;1ZxT`uNt%bUu(+UAvf?7R1j>y)^3i%0G&GE$LQ zD%y8(bbUfme{WCyM)>T~eIJV?*d%i47|2`Mm9~Hvu$~^8y68xfyr$}gyJ2^0Eba3= z8_3e3wx9q2Fz=oPR(mg}N^RfjpQMykT&_~^ex(owMM`|pvkd$~7!$a!2M1KW9*~65 zTU>4DO_CbfoA~f|4HUu6s7FY?AnyJ%(pd&g+NopLsi?s3Mfwo6@A9IuS7SdBxs4Ukl93gqD3bvW$ zRbO9_{sMf*hUeJ1p+a+eW z5^$`-tIoWE_3Cse5Q~qJN&s=JJzBxpjbTK9602X-ykJoQ|5a+r0X0?(ZB3X_Q@@zd zgvDlYKG%B8JGaT zgxjHD9~Uj>O(D0+3T49dg)V$G=Em%4qsuK|c~GMlP<_;43l0f^o0{LBlrMaQja*nc zNZ6Kp+PLdUnmegmcN>v5so3AwXj-kF8d_KuioJ8Z z#q}~M^gOUeZ-l&~SK~V!qTT}RH70X{h{AV12 z!OV2Agxd?eDvE&}^isq@`wv-?cdYX=G5r{TY6I-MlN`a4gvpyk&=8Ro^^6(_+DH%~ z{tjl(k@tvwR)AFpP2G)*28Jcm^8t1qm%u-29}~16{E1UQ0hr)Fy%*a(3yj)(o=boN z^w!q{1iw9dvs@!2Ku5RdReqC(<4(KJrBhLYw*jGjaNiCqXWnW+<^!&6r3|p4-(Hk~ zdemKc3!7w?oA}FKYEN_aLaA#^g^}-{yVkOq-7Fk^{1>jHnZs;Em^di(C!qh)4+2ce zT4X(~T7nHqylD@A$0nLa1%>jRtpIra3dw*D1RBfjDb08Mw)iEb(Dr40Mfm-(x+YfN zgjx8xxOo3;5fp3$e6OChAX!uHKQfW(zcb47Z%W}x!KeYvu72UJ>lP_bYdAQ@%F9S%Np=7w>W-a6akCH zBD1b+wTl^wR3|wkJ~42SHIlYhb~76wA7l(6-oHn<#tE~gG@#kWGFE{tI=#+5l=P=| z1CaQLVa}I$HsHGwiIOIDA8C7LWQv@0wJ=8++l{&qKj(f=m-}8{4b>{^Iq(;2t4)%6 z@#EoU0budOP%B*YH)|)o)P5w`wG;bQ^Y_cOFc+EW*FS>)Erzmhry4DECu*GltfAw& z&B-6FhRr~SqPA{6ulsNBZj|6-yiH8c8(()Hipr)Qtk*&ojaaG(G*qZZB+8^$>l2A%wQj_pHrl*X)@ZLLcu6nU!vfE zQUI9(x)Y`D1Z(#6K#@8txI3d3^K$Vhu+zxne1*gNEFrBaAUP%~r6qd%lIO%30RaC34imt_Pmn!A$|*_Uu$ zy!A9WkR8J%E_s#zdU!E1@o9cC zR`cF4(3m4;@e^9M$FjqMW{O#>@;12FJu0=7I-BBbh+G(_K45=!v{%C>DDM~Ihd+Yl zrtc1xrH%Don9TL}n$I_~Bi4AI5%5X3Klnz;RizI?q|&+1^vuuV1BMugQ<9~2*Ky;} zfylZ%_2jY~NZ)$wHCrNCBMTK^%&BpcRbPva^zn+BVic5d8b0BsnHRF2;=dg!#WFG z{iGAK<2adL9&jVQPx$lg7VynMR`7&EO`Vi&8iwXW@01q0_EPVE7!(yzT+)+iBNWln zinMgjZiVh5!4W}N=A4-2^}{GQV|(}6c(U}Neo#yBSG4b8mqjGxsUHq%&yoN?j#Osm zJ6@4cRcch|dd&ey3-PN>+GRHYrui2!)CugM#lMK5=D62&Q72Ssp96vb;fo3( zc2J|`K_`Qc7G2!7-tcMaNM#-@OG;(Ztyt9!Vf-6@lC0b7xu5IXAN^(ve0U;v4dHYr z@8~5D=Vk=t!}k-hzt! zf;5>*ofq6^zT|)XtJ@QCWprxjT@Ntucbx7FromVfJ#Y>%UomQ(X;Swu7!^_RO=*Ri z>^+hB_qd*h)tLHsuNfngg`>who3N$$+oO5;z7Eqs4z-cijjE-Y=FPC84PR*F2c_sY z;+IfeA$@R`2pYqcdP7DeCCv-8*oBpzOuY#{r~hL4&4=g7A7rz2&92$K<&3C{b?)Pa=ZxB_mMhY=Y|UB-yTI(mcY`LTkAS7=`b5 z1jqr+h{|yuZRB?Ku!k)F$!FnJ?IEEQg5^mN#H##y=8Nc;N)9*>l$gbjj7_DSSkOqS zh)=UtB36~7f+z#fOo!YP!k72hp!@tySkm+SnEMg-K+MY?h*^dD3IcJy)YQ~WdDa0r zkW#(-G4qzi-SR=&1PA|JlNW5ZwBh`(WW(sY?pEt4K8x|DrjHxXonMX2yYLGDsxR!o z0%pIDWGa@+rUI3`j)_>_>VqSXDs+#F5Rw7^U(shS#&=?JQc*#{XN%>!ftIZkd=_)I zG@jm;jplyT2Qx3|JXDY?{6~~Cex}cod=Pum3oQhZ z8^jSwpnFk**DQvO9)EMXZwQR`8+*#K$mr%Qz$*P`BvY#0BMU;ZvQTZh!jtrz6LnCE zV(yLEDKO^0FKRDiAQjV9rNz-)rVjirz+50Ryf*SkLO?34KhS7`UCK#eqv zZpfx`*+z_(8>GLvv`5L@ZhiXLit{V$%-oI z=bio)B>9OM_8NdB!=RBEApQ#m{?d@gJ*UT}Z=mLwPYkX^x8l{Ah0bhN-|5iRX5GUk z?7(VE5e%nD@u`y5`RzR|mGC3a!4ZdtJc;ja)jtJx7eNH`ZF=8DIbmbv-9;M)n3+Uk z*cVaP9Uf4=))@##FFMC&1p&Y(wH{dOjo!qLO|1U}WH<&+c6 zM@Ouwv-XqH>5wyYF2w2r;*nTR7*XHsbX+ciR*c5b7ix~~u-OOBVl-4gIu%$X$_94On8;t&hZdHf6yEyMg zeGmbwEKixB)o}$8v0k5Jjo>AgHH_@~?=9Fplm6gJ*tq%o*4EaR7Uk%np`nMSrel~T z;D3jD+B7y(70Wy|*)8yLeqHKFMA#)qk>%|x+pKqoPW=COy~e+^s`n5qLKbN465PC! zy17^gV6OFzRirO!gh5Hkr?kn1$QLhwEb7_G3sD2#U9k7DB_+P^YQkM6YA4Gq8o*Eg z(A`bH6ZLbAGlwv%q#D zDW3%t=lvHd$@au_yoyuw*U3o6iyo+T4yUj$F_UF`af>OPu9h`}X8QM+Dz;h!R?J%m z^@H~3S2$&=vYC5wa`RT>N!ChBRFi~(u>Dd`^+toob?W^y7c_3sRg5MJRNOs)Qb3EB zVK(fZxeNy7dm*nDYnTDFEsF0EJ&`;YL;w`O5_A=AI0Iy8kR{c@HJH8Yq)g%+Su>*t zN=stQGV~J}R$m-BQV<|X~A~ZfE__xl$CZ$HW|KqKH31z4s>V# zZu7}%>-jADJ!gQ!Q{8opw(n6_5IFKD4~HguI(5dssK&{AqOpGoj;mY%9F%Zc_DsAdYHv6WeK=iy z`h#OXr3rI5?HvG-3}uZ;i&=uXbfJZLg-$HDrhj*}Fa&>AH1?E0)~VF>2W5}fUk9$u z4xg7m?ram$&2)O&!`d!I!r`u1qi%Gyu?jaDpo&@5xmJ=_ON{d+BqYvBS=ZmlW)i^E%!fn{29jEpbi43oiZ-6d1P2hvVp0>b@_%QaSrl$i5L&1#(2?Qe@f8?~AAF zrJ~a_ECeCnzVPx_Wax3ulcV#yST?htuHR;7c~Q}7FhU-He>4vhFH3I5Mr@3X!b58m zmg8?xR&CIirswBBU%O(I)9N~qL7G?n!HrR@{JzaL*ZtcK^6BFh558zQs1S>k3_dt+ z0Rj&>dShU(ssJ28JdLe@!+pKH=El-kQd-taXym>^NgKri z&OYOKZyo0&Vz(kH5O?%l^3d5(Trlgs#-B3JIj-R4S13jOF&CK>(r^#p7Jaw8?b(Ix zl)&}|v-;KlWOXar{FYj3Q~Oa_K(i=v!i)wJok&*n-(y*SLq~AJc3Q5^+R=)_@nvvt4`r3nRDLJkD}6jc!j-gBRAtPcppXBw#< zjqC;Lq!A*=-Xci)fHye@M%aD~ zxx>^;9^vp&ab0XqG%w}>fSz&w#2mSBVr|iWYp#%LFwnCPj*Gl?_SC_{c&NG)z}yK6 z3S$2Nd`e25))lcD{+_t(6aUCRR!&;Q)6|}Qz4yKhplM`|y0QUvHwssd=v^9Lf72}# zHV-zmkwNy3^|z35Ka6raFkLHPW*++8Suy_|M$VB?JKVF84%rx0Y@Mj~pDAP`P->)t-WFl0l2jiYU|Z>ceIPlsbnI66_NS{HEQ6p?`W#b3xI0S+cT$+iK9^ zj>~So;lU^#D0y>s8*-RFiIb`Hx+Zu%aM>sJQrN~cE~}ov%_YQIF27lC`z*G-@Z$jk z|A-3d#Td+emk7@f9Q@yRsoZ~vvA{YS^m(vh(mpenko#RTh$Y-wdl3Oz(f(|?$$1JtSe*No$iM91bP0QLRJ$oyCfVW^-3`~-_kA9VKhcJ9Y8W8Hp zW>c@mH_o#7e9_eaBa@7Uq5$R)7rwSn`o)VE!qF5W&ceb1OukiZ2$0SaRJPA+c0ZA= zb3<=$`#qL;+w-I)EaqbfKs{zL%(ruX$BnG-*Sn8eI~Zlimm1}&15Au?M}Yk3+eQJn zNfi}dDEh(Xw%<1`nYP2n0AH8gssG)LSzlBHIPv)A*!Z|Xt~!!LVx0t@aOnAs6X3`q z0nQk3q~z53>wb%$w*}eM_qXcM3i9&N++P!gG@f+70iI2iR#oLF1-P;czty<}Tvmfo zGqkwHI9w7l$f!4lYDYDUyL)-D_}w-RSb*#bp~(&qzb%Y3==-eFt*RY6cDsbIRO&0S9B~;L!aU^LaYbx6(YpzAPV?5c zsN+5#7h+g#3)~;RZ((X0&0W>9QDzjmmkbnIK^)PS$p*;V!qG=ZM;GK=1If2;tN_df z;PXGb3=wj2!CWlc&?r-(l0+)dO{VUzkFv%a*pl`EesTes&OK&s3Koh& z&mkh#?aJh9-bY!!JRRmMe()^&vgOdz>mKqqjIUjun7n*Z^8L%#spk>mKfNwtFLAsR zN(h1>!Sh@t@1w*sFdY#&M%8j*Wb}3L0W=c4nq|mq$60a1f4LhV0KVY1Zt}rYSk=9j zW^1bjxQf8>l}ZNDJ`4}cREru?yP`Vti1>;}EQZ@-vI_G-D;D_T#ChewHGsgY#qK@Z z=sooQjyCMLL%If(!Q!85>J&Z#XxP5mu;lO2ToCBYfXH{rT>g8)nY%yE4ZeB$!{s^i z_vmKck6d&*^2f|Y&6NZ0Vm%Sy={oN^>dm-4V)>ZIP~N9VG24()9-)4z^0k?gvEJ2I z@>2rQXbP^?7t>JAyUI5?m#0mm8*WUy4ZZt0{dLvpHe-doy~=?6taE%^c4otc4^LEP zsBd+6qSZr+D=$u#KC&z{T&fIKKHTyYx}<=a)=Bzkm~?4IKdHCmsO#n8t*W()C7?cy z(CV%eIE`Du>!A!W2qfYsi#n0G$b|rq9TDpJ+wLKu3Ymkd0-wvS#}Z22IFP}T@2x8%0Hh`= zGtno_AmUoM6kww79+WLkvp$d*#&iZr(Ur*GGx*hH{Tk#$*k~ZT za6uV3o8xrr8Lw&|v!l0|L1&|+_k)|O-)K%%bh+7@?3YxhYUHiZDZB=Iz0 zhQ5^c1Vs%E9$rHjd8G;guMe8TPLY7Nttjh0{(IY;I4gSHhM^2KN4+c2B~Q_wZ2L+r z+6w?zD@fUHe+Y&4$>0=z(iZ->eJAO4SyHc)pfGg`J?l(4* zz=&!l5voz`DiIwr{nEx)sJ3=dqVQ3#Vdz4m#(^qgGg3vNaIv27_00?OTkWzUh} zeOjX%j*HQuRkjimT8{2$v9#~IbmPG>cziY@^McOf?*fbwwxMkjWnCba=9k>*Zx_Xv_&o~FTb?|f~;xebO*;0EIo2dgh zwq&Bijtp1c8P?wIbwZ|AB0*SFR zZu7y|bWcXxw+@k<>(}$cQzK-l`AN5;-^@BSWly4P&3B~{P3VX~9rxD9b8AL&VuU<& z{-tKaq+2ukXZlLQN1u90WVcdhw``%$ZI(oZ)W(SD=diEBz3xFX&1`33&Mu}tlvs=+ zcpM3=&6N4uL~b;61x2VhDSQ{=tx_LE`bh#7(hVEsOrnJEWG5!t*FTx>*Ue23WUQ()1~arCu-?+ z8Gbj{fp^KL$L%Ek)H4X{S?w%2V*Az6Siz@#9JLq5i#{KCS5e!du05wuZT|Wbxzoz>~!@>wn(rGSG+sy94OwJYXejSpNm$? z(f?fhe`S#c*5O_7`$0G`GH^PRbhF< zR8v<3v$VFFZe@hdBrc{x&xdUB6pxL9h{^ORxq$Kh56qT4T&`fKul*HH;k%UhgIl-^ z^~tOTeLMX>cI0TUUkfo}Xsrcm$h|zVhK* zwYC#5gpcn{7*ukv??j%la{s_r(d4#wX(z_*CMcx}!LE@~D!7L7#O;}|sUt6TV<+Ns znYM*hEEqE=YkkB;A4=wtur~E9S0Ihb7!E$c865c=U)rd`-0c+$_<*X^$ zN-F9g>2H8yGX1GS?+P$q%L&InS-hAtYD8`|Wn06U25;=RNDx#LKL>QcC9U z3kA`uMg4Tf*QV%$u|CQW8>4nmxTxD^@a&3qvc>1}d7)kV^=Y=sVyqoy{^fAFCc7~s zSfze=`53U9{0{7Nq9IjJ9>vf4*hunfiu21oS!+Gr|Nd>Z?BmbNUhKkVm1gDC!C!lI zdrIcr>{P;aFFhi0ZV_iT!P$98kfpvUn5h-q6Q|id7_mO>Bso#nwb%3uN?C(n({!g? ziws{mbJ8>vSmQk<;U-F_QVlwMVz*4xP72#IM)2UjtR2Yw=&*&aD)&>q3Kw{6fv0j_ ztl0maYNG1_(>J(E7&lQ^gB z=mBhmdN`hhrzKs-B~HdDeIwCY-YbcGWa@*gV(L&`F$_HuK}XMm{#28lJB%gQ{Lu>k(W4R`0o7u zIrU(dOL@=kWhW>td^LaOgc z-yuEmvVa|_=QLba2$0|xb%7=A~)V7v2Z1_$$n&6%%s1Ykfn&9ql z4SP+32P>4Y*#kdEk$Su%w*<6QvWJ-4VM37A0l#F|e#xsPqt%pyFrlDcC0x!&&*Mme z+w6e(i7q+1PyC*L2K34`#)#$L{A+Wa71sg1`g`8w;UBQ~zuDIR&zJwh1(ta$9Pqa| zd3EpJF$MjPy{!LlCGYjj4DK)_FJ^5ak!oUzjEocDx`lsDo6oSf9(G~m-C6}bgs>dG z$a{WSR?Q&?pUDo}leDZs`~hM${%1dJ*nS-D-SKuA2SaT>fJ%Bn|K_dr99(FSZFymD z#XChv|K{=S)}@*o95_z;<}1ENA>u>WjPaM$!#IMebUz4k4m#bZI*pU70gU+jlbN51X*tnRoQJfwS9Chj!0B5 z>^qs;6J-n@dL?yh?SR=i1G1`wVQ@((|;aMGTqKILRkKV&jit0%FeJ3k4}8oQ`mt z)*dJ~54@B4JAaqagRG_$65JKd?H zH(!HeDlgIQKql&pT>!gz5ZFBz%f6HoPWOfTf0Bk68}{kXOW5sgW4W*`18`1_nppzX zNZf{K(5D_&Wt5n&;yqsN>Sr8(&j$YyTROQP=H~k1S_Qec{(|p7M%{lv=qLhL8x0+}k%mDb<=}N_m`J z!SPLcj5HEop-|w@Tm2gYqUbDhwN#Hk=Ho<#D?)L53QEQ)D6&AZwhL$nh5J<#Bz>`?164;%JCqn%parzb*6-HhB zb|Zij+Uxd^33U>gczVaw42552rYjc{zWmjO5br|^Lfi6YBWD#QB+_rJ zqM97$H~-`+QiZIW83|DSn9QK<3o;f+4wafyjkr2<;lD-sivR>?iAS!xovBOrn6_|p z*@Y#cTAOi^L|U^?M$dybXF{urLiLSaZ~uNg7|a~>2$}vOcWx_uUj&JHV+Eu5l<;4qn*#isCFsP^ZSrp@~n=FnpAivbdTKl3uhze8z2HhUZ}X=bPeUxH8Vw@(Ka@fl32KA~zO zw4EtI`Wr~$>m?u+l?FoGuCT`khtgjZ>iUk++L zEUIhMgSX8$PqaZ>8a=a3TMtvk?BBuq*XNU+vYiFdG<3d<^y~aGHU|j)Ll7$UXr=Mi zQVS8>eL7wDxuAgkMNM|Uo;_XwZAxG1)1Of9Rhr$uq{^s6Upa*cZt|rA2Z2`l1S~YGi#wEI7_zAxEwtvJJ;(a@w#3*K98^=~K$`2`gg^ z_{XP)xO&{DYqSP@SFTRGe~LA@#}qZqiJf3g7i@} zoGGC8A{Kd@_o`W;hka@pKSrv_DsDw2)`d@oniH|tD;nHc9S>AEvF-ATc?SU)KD;_bnKwPh39VIdlUxSb( z%r2gs<_|PE#k=c^QjOE=7GZ(&gm3wYN*}f8x$5-updD63C2HVyO0o&*P5!ylTl@-t zm^>`2uI^>TrUaN}0{U+hs~cfnWedb>&AjJ|tm01_a0v2_$%vz?*TyEK)a?)N=w9Ig zEL+Y68x7Uho#{3W*O>boU56XCR?v83iPYCXptygs)Ul({jU*89Srn}%`>hn`a6$Iy zQ_pA@C*<+g8!-k2rk^RqC}wckQ_C}6F>pV%%dl|cDb=%HlhR>BouV?T2%nf#iECw% zd+F;J8zc&rpFaVIboi}lrVowrAu6)skd7%a>oz?B%_JoW5tapD{$)?G} z0^zDXe(-#GqS8X-q+FUox~d}o#RzhVYmq@l#tC6Fgb#jf20Qwp?}b2%?Ribt^?E-M z?8Uv#B{D`1xcJwN`A6ppUY$Dmr&%uvxF9fGMELX>AW;`Dexi9|8i#A};CbXgx^5hK z$EnNClk`y@ZWZ^s5---{j;VXrbKWT}`{qXT9ivmB)NJ>3|Elr`e1_t7 z%aZ-+jg?|li_A4K-k=JT&6ez0!ff>&B|c*Q%64@C?MS>Ll>EYCwJN|=j>kTn68Au7 zeBQ74+&XvX-tckST*#6^ld9YYFB0dvM11fR?vTUh{H?$t3V{2`Id^*s!BUC93OtNa zVGXpdVPNco^P-}G<=o@1xhPpbtqUAQ_!ix%PEM?t>^OgfOi3P&iz)wIon zzqWI5X}El=I2vq9P8-ATmH1fsvzSyc6Z^}{@ScC_!hcjBojZfJ=NKft>2 zX+SZ#4$51D$35XnWiC8IN1yNn`0LSu1SO}$BOnrN5PHy}v2XLvLn(jhSkqR+!I`(s z+S(9fb^yT0BdFeaYM=uW*T~dm9s^aUiEC&S+dmJ)E2CZlb_;izK={fy+eCt1*L>*b zoZ@}Kof%s0K$fE0hL{%H(aJ|8I@HTGt7#lEnPu$9#kX3J7o+_mJ}yonll6AqFJiV4 zeqDLh9-SJ9?T8Hnqxhr82hS*S>X14D@BJ-erkk6a35k<7N+4SyUp{7R#|k}^IgYJIN(L>*f_x^Z#OJow~Ac)syXgm) z0yxTUPL+)st5H>n9bt6zT+92s%~{nI1&!?-uzENnjU!>Y(%@5uHiTlfA&+rFnZQ5# zPE7$@VL)Z^NiD-ZpTvaFO$Mtxt+-G#4*wCzmz(_Fb+d0#ZIRy)&N3WCy`2!eD4=`D(a(nX3$6Hx(?BE3gM zNN6G@v{0n?7HS~no51#*{hqSFbI#ko|2luJ2d>P_v!>6Qwbs2>o?X{aVcpBK7XpE> zs;MezLm&(Y2!!!F6D`QeuC=%gfk2zCU%jaek`M^UD*X>Qv)YiZO*^1-c>w9vLeu zh*e~-#Bh?r@B2>CmN-BktN&S>%W}-98$}-Eq ze{3dtwAcz#Y$a0+DvFFOF2)t(z(Xmf;EE{}@GA91>IYqh1`oCjJz9nZ&oX+a7IaxA z8kA8#STuGNJ-Un@rC`f4vFI`^7CdMyb`(3hj9sSSB4u!qR=8sDL{eM8QE(K>C^~Z# zT{emZ4|){5x(uG>(Phdgg)-&qyo@bd9z`#YVwXV$Ae;K3EK?{HV-7GpN~$phjH=iQ zR88$HsBsicS;kV90X3K;FkCPKY9o{#qH}6jS-@iMxu*?hPe0(r*HSv)C!S5**r!ud6XulM*IL4Kv7K|Do5IF7;~kD30Nq`eG`pVAWH$j8sGNNLYP4KC@?yuOjZ zib4Ck%B_vMOKcTEraCXvI!~5P5K^4*A<*xc*BC6{^P|y2q##y5afnP&4YHr#$*pp$ zwHCdII_rfGXz>+?loypDeb%`>#Y{I}du$~q=|igW%aHwTL zYN;GDnU@f62q%5q{L#i3s_25hM^p>g@E0Ru7OS>u`t@jETktYt?$#^%`Ii4EK>18N zQT*~JTK#2ukH#l|SR>kXXqp_1ED2#JR&$m^iXAMVgsIEEw3fDsv7^qk+|&E%_|lJc?Z{{+rAh~WuFqW#r(syGtAnpiKMX0JfLo$C*YH0{HF7Q zBp1Ju+3Mvljrq7W$%xRbk+8=Q+1DMsR}S-|;-z}-bK@T0U^RPOUe#3NZ0 zUR5P}e=-o;+nChnm+OBjwjxm$3||6P`;4;ahp&}mg;&YMuUOMY@&DSOXytqsAL*x98H*kBqH)}5Z!0A>iE%Gj!wJWaDUZ|9y*5#S9$M7( zN|nnX4Kldj9*93b?DtDR8+WUVc;9CX>KS-%-0c|>QaF18=59;M;LAFavbIXNmoP>c zDcx#5bTj6pA3je?XNHtAHmOy$b%CTlkUST|b7v&x4RdasnS_}n$`ZdtLzDN)kwz@} z)oGP1#qFjz^7^8X9hsQ^LL_QB)39z@tBDrxw)}7?H|6_U7K+@)j^;OG7$aM{r2Cvl z3B;ktyd~-AZXF+>vs{IfxfS&Dtnj(y<*n_Q0Nkjjj}78|>^yUY*-g9h7%fN7X86e? zej60(oR#nS?ckq?&>c%SGRpeAn=uUPIh<58>C`&Mn^kV|vD~D!?sQ1(e)!gw%5FFF ziSwSy%)#y}1G{X%g@{Lna%)7yw|eCoyLjVk#x=4D$44=wTQC^p^o#;*!*2Uyy~qg( zjSmIx1P>cT@L|0doFA+PQk1OTA;;JQYxZ#<56mkeKB#k5_{Fs0YB`29Bj5|4ZlZPmr6RAzdO5s)ry+q#) zmAd`(bhk_nn|&jVFOT=5xrO7IF>fUI>BbJ^_-bp#5G40?Eij7Ne7_Rs;?8mS)*W0$ zYUlEDQ^1q%8@XnUmWj!Wae5+|ri}t-n@yvm@$&juZ{-7L^$CI6VEFk9jyBt-zPI5y zzp3V za;Cm1DslU&Q}Dt5c;7a9_4j615s*IDgOS5uDej5{a|LVE>Wt;L6joKg#{!g>4Xp3* z5uUQB`<)R(hdOETH68@JwWgQNb2XtDOWgH zNw^tn;&s19N<7!bxO5?ZX7wupVGWo%ac@d8Z@1G|BYhS*Wm}E zu-dSwAg4V{pOZm_nzPXOJ#}hsOLP5r^j;d8?=B8d=~MhEEevnr_J)5f>> zGeUrN!I=9-vor&sFoaJk3@+$9kJdayLgum#IG$L$TFd$luotszZ*^QnP}=ER*Ff+5 zY!jxOj)bq=zvoIcMnDeQBuy=v@CuIoSe~uB0fpYOyu?|Bgsdk0!>jbacxnAha^k;o zJO0xRwac^(Rk*#p!>Cy)j+&@R7;4O)Yl<*4Tg~6u3!J1Da|LHcJ?rj%-&3cJO_z4E zML0y}r{0+( z>>onrlIow4KRQ3cPPZcysoO4y2Q=-4;Hn%t=B{nBqJIGa@yZc_sf>>n+<{7GB@Kfk z;yuz2Z5X=lao+b7HBkv|*goq{_w_6Xk}PYDh+Vw|Xcm1K+g8*?6vVvuE>7)?>68g4+KTvyLN~7RISu7J1 zVyNias$_^!N?cG=2y#qC1)QLiB8}CJ99B-}B@fTiG$z$*Cm@xq_XY}j0d^$&A35P) zFvfq2q-7i}K1|&Ba~$oh!+;%NL>VoA&4%=_{bymrLvClmAu-tN&R~A^D#XiBU zgxbqvY&kgvKtlG)-R1MTW`J*!y5-sc`;V1>;CsenB~!R!b>u@912{DP;LzB_%KM!5 zkDMI2i`Ah8i-ZFEwx;8SL}EfUr!MWJ^m6pHJ$s66SMz!IJeA}SXnJ~q9h~I~x3kJnwb)-kWyw>TP2Rp^-S(); znGX+5W|Ed{;CCsr4ou}2mSYUuPH0*&|DirGCp85jdRTCXGQ@6w ze=bVtp{`BP=w&|R!-^>kmX12}caokc$NU-)KBtXf0LMl4{?g{!h|O_WL6$9i))#j3 z(77p$2ED*${@^o>m*y?q#eLM@P0<|vG{SxHUIUea8Brx(wdGh?-J)#bOXe_c*x??5_fWJxsn9r>^Ww)OX4EZ+2$j zAIaM9>eZNr{7!#E3rygna^H@ap9wFS>bZcQ3Fq?arNloa=pHMG9iUF23S#Qm4yE&7 zXL%()QD%=126Mh|%onyAk$D0vmonHbi!Z5}QDcVst6@8tU^qj&d0_DWeAd3sY1#JD zGt^3+ws*{npWXc)6xFe;L)iTusNJ#VT2r?3&J*opu!emcTlK=xJm3f+ze`%Bb~35v z(><;}%lz&#BI-Ekguw~vt>>qpsZLifO}9lTQD^tal}Nw0U{QEEsZ#}J{;{tGD~@bx zV~GTdCU6zuRSN-&hMeb&1gnwfOA{pkg%)cfKp_yORio(WdK92)QAh|*2&T4=reF{?G|4P)ZK|eNFR4Xj&F_KLXXCEZ$#@;dWBW}F`{7f|oDPR*vqQ3^) zEAF1sxHpcw@*@&40~(OsA6Z~Ol2JXeF#G`PbAgU73N+rAg!K8zYh6leAh^A69d47$%;B6_8%; z&d*~m7fxSt^2&2{crm|HE4*kEGk3C*dP{&={r=`G%prZ5E$)t{u-{IfnM8PK+liOI zFbajh#}$CY1;)W7@>kMJCMSoX68ybXb@F!qoqi$s>78CF&jLLYcbE{K-Q<$RHPBoP z)Sq4Y($vm#A&w`+jSGCXFCkttf-cVjqt?Q(6koal)>wUK(F*SZNuR4k0nQ%B4Q+@B zXJT4?1-j_^2IcPXGBN<&RC`z%AtguK0!i4 zK!@q*^sgfB{tEkio8}@j6v_p<%fyuT68Zfi0$I01!eaEP+`&J0jtvT>d;D)9^!!fy z{l~{^D759>%~mk?<5@{;Hp=^@$#0^+!%vNXJD0NB02KFittKV^*lT%_cxY+Ruhj zyRQojH*@KC5rSEKw9p<+7f#Y<%Xsfp`|&3BH=3GDKsh0G9*i7MUrx4iEnxkH16ggy zg27Af1FCPe(VDhkOpr8H-la@y9>)_@J=%7_ zsBci7&je}*M8)+RI3@p;dx;SNS)-FQG@o}x%QL?+Mwr2q_cB3_@xGb@s?#FfUzsv~ zE@m$<1Wd)`(Bzjrl3VYw;PrNpsNWF*YyxV#3=k4lo3*{`C7-u;<%n`V31}+we}#Mj z>GAwyxw(QnQnQ+rk}tfSol6{k(1s$D(+t+1;Lv{ZLBNH%=@p681ndSCK^ zFd&LDs(<8fKdQOyj#{xE@J+u-7dT(G6_zS$|Ej+XNt{spMv^2qq>a*>Z6=MYUnVd5 zmwrxRnSIKNb2@S$(qS+8(=~;8b^p#a_hy)c{r0}dnP_dIil3BZLo@tPh4XX8LtPwv z#f|%*)28=2Po=Co*#|s;pQpZf+EXkD72_`xI>$}6t`->jxY>TsXdYL4+>Dr3r(Um6 z`8|cjj)@KDQvT`MC#|Lp*$K)=(ir=ZwaH@E$@pU~wW#u;>O3baG>us3EH_$q9dFjr z=0D*wj&i}LG%Sjmik(OygbfBy<(Zr$LwW*#WXMa#M=2EU$)~51^M4Z>=W`Q=wO(UB zLzEs@d_)X7KXA&Z($cbYGlXJ-C_XA>U#l$mdj45h-#s-0QsX5VmvCt@N#RCiw!U!s zvBvXpwUqC2(RGw@yppi7Skxk$r^YVT5G4c`Yi06D>)c%*Zo8I#lACdSh&X zVXSczwOY0nF=7`I%hFi;i6-B5mIZh3JK5#F;jkVbbMJfc%OVu@ZLW8 zD%mO??^C$Wuki_f9Z~F%ZQi7~d3uOXffP67LSB=|K4&{R<3F81cqbOxr<*OQ5*qdP)qxV`s4-9_=>%MF=y% zf?2gLXlJ+12UB6&VxCpHdCg9@XfR{^n2z+N&I||jv50JEw?*aN2IN>b^fdW-K_m3d zw6q;f{xv%`qp;_=SaB5x{K8~!MEZ?X#bS2&x;(7RghkbFAU8KwQ&&paVM4~-FTKQK zz&vYt;gN`ecjpK13!#0*U&%c=#zd~s1^TfUTjH*I9xpJ&b|xp9;j6_;f!ShS+&)hvbvX|eHC``!IpU@?iMe()qJk@u*!)>B(MYW9 zE2*0cp6T-uX@BW%51ztLkv&BbirIMUD!Pt#d*>y~oz_*g#8>w45)2U0Q}!Jm;2EEF zkyIyay-9e-gmI$_a(E!HB#V_D{hs?XrE6+FWnI=yR8GawGT=U%Mq4rQEV=ETQHdu5Lv!IaG> zl=84eZ&V$nr}22N-u&koW1pU2oTkagfxVc`oWcUd#2UbmmV%a_xNRcqZw>YBAotMpVnC#DP;7SnywxFLT<)3``Hw*Ls zX7X(Z(uXLiSbpEfhe%Y*@JU^yRO&xS*Iy#q1-w&Npx6)$c!`4$ue1tezjTf#d2&8w-%77pvu{je zx1aAqg{SXANA)&)!qy;UE3E+8ylN3pusT1Z=lSap|5{sEFBKijCq4JRb7_bN5%J(a zF5vSwl1PhWuYf;N&Jq^eB| zvCz4tCD-b{Kg?=LPl4a@g`63mUW#;ptxTOJf4HJegW8P}AtR2otCiaJFDgy_dVL0n zQEJ+Ovwo`-5``^|ws2YyHcHEqtI6%N9tS7Q4{3H037SGi0v$Jsf;-Y;8OP>FXstC~ zZDGwQQ$eE*p49y^2$wQE90jtJ;v2diEO4eo9R?l?9Wmw0ZrpgQ}%+Fz!#xb`vHK?W&*OYq)R# zVk=V~-9YNS)WJ;K?#$s^c(~xph1E9QI=geNMxuALrJ+C))dkC6p8$Ii67ECJ;tiq6 zpE^I-D@nT6N;>THy_rA%L_|n8ccJms`+Wic(a>!NSee-oV1%t73785QRMj_dt5{c4 z)|nVm)mJ=LVt*Ys-oLp2$+m~16E7shelbuRjfS&Z(TY{asmyB&zTkBY%{A1nidL&$ zibJE%$tHf-2tGxVzs~w@u7>6=c0j~oC`)s$j{cI>H_un7m$&EHiq?>w%-26SQE{^v zqdwhNBW?h{`aN{!-9EPioi)$p_Gbcb34rQ%1N5XL;mt*NE3*eRQ4MkAYCnJtpZSUM z`+W18#x^7>QgT8zhA@8<<~Q_p?`S^q5r20JO}HPor~@yQMUAa&_?=&gf$D$gKpO8~ zT%!f*{C|MWelj&RF&G4>^?&5`f(fLF+QW%x{bP*nci_hFAc!J+(m?GT{?V>26KI8O zE6-(1%RQ*r0zjK038?C(eL^AW-lp zoS}`l<@1|fLA9*fC&rwNH}Id103a!xiX5z)S#&i5~ z15x2)+o4J-(8VLPRd9t*W0FR!|AglzRawZ~)!O5)Ct5PLeiQNE(JOwc8i-(eD%BS# zVYOk|#$flm^vQ3H&Mb7d6qRYk45*sGNe>QRuSdC5&EtnnWxBzD{Uxd~`H_>reh#E> z$;`W}r`TNp?cz7rvvr9UfFg6vd0})u{J7*1K7g-R8x99*x1R66PE{nZ zUD4DEso>+V6hEULx|N;|`Mm2Hd9cX*BHIy^soVh$$YqK1ZOi~e_=i{Nf5f@tpN6mg zw|kZSXXJOq?noseTezv3xVfght9DAX4e?DJbHC^6)-sTu|7DzhH(RVNfDxWXa zG>oX1MeKrLSoQd3v)r+ohBpjpcp4psM#3z7{+ zj%^oHF*S#~Z@7WF|F``Kelo`Y2ZX>#j2GBI%jqwyuGDegf{-aFO**)MH>2DOU@ zfu$RmLqHGOsK-&_C^(KuIy4uP0Q3TkjDN=In$Osu+!txG5hiXw#(Ot;O3_!W>35zP zRCvxjkV-UHewh8I?f5s`Znr=nv&kF)*uY1_rq-Z0WPRu8ePA(qB(brmD`8^|u8z_Z z8yc(uS~x9i9)P_P_CA%hNpE=l&iaM7LeJ}@J(%5VN6lA7rxu`fjwfJ?)mbn#F{_5& zxoQ^)YiktggCb*7bF9S^Jj+l+ zciHR7I~OF@wvwI3%9gLJdLD{2A^6Fe4HNEtl_0GN?jB*_$@oQwW`sa=8I757fvPQe z!fD!9%e5A(?f7-6(8=7FD_x@VUt~`4=N^p2-=Tj@g_V#3>WJ7K#Ot`4qIQuw)L;YV zMW8}?zP|!g>io3I8_*qDcb?phhi_F8``+=}0Gs*TAn%?kPWcM}^dYFWf1`WrTou(= zTMVXZ;3lH-n8<~#=O>_Qpx|rW{xXiO=Yl&40mbsOgQb|knPv zS!>4gUJ)@B=isn9SiGNVd>4YPY-Cq?zdS5g;Q_!t`p2gLv)za31 zY|j2r^$~gfPLDRVs&`111ruJk5vq4d#}$OtZvY~7O9;&0L_7k#=OzH(s947?x+kJc z1wm|X30~Qq41l-oK!eoU047Jp1gWnF%TzJE2jJ3953ZN!4Rdpp-=a1-J-w-Li{>IX zu*%U1NSh2j(??7_+L=}rgyGMc8h(l7`dO1R-PxrwqTZyu2>CG z->d|&+ZTBjxSPHBLpkpsx~mHb^*j=IR^YAh3h#TmRqjUT5ywaVnu7 z%kc3j7KT|Do%7*84YFF3WMKr}y%Fy2jC@FvJ=f4@=+YSL${ zJ!Jkb9b^Eo{Krxn^VQ*^n@Fu&pnx3|q#LX+WfL!$Mx_zf2*6o;M?(up7wVNdeM78(+|K`- zcVrOnK_KB)9&p*t3*m4}^;N`K+LSaCoIgCu)Z+(aAsu;{* zncql7ea=g^MGP4yhl!fx6JcAcbY|4|!k`9zJc~BEk~lD*Qx)|{VgF;PKt-$2f#1>g ze8~w^J@=fDlM_3@Q+AvSzmvOg+42trRj1o48SV8R>~b)a++7E-wgY+Z!MrF^y}#Je z1gTOPKj8NoTKLoR3%IgmA|Yq;Q=gdvPfU%!Yp0A118Sk^^eI@vX^cgLeDSAlD~nx- zNJ7d!iQdv8P%+WLpZR0!4weK&8_u1Z>p$&gLWfKO4xxV#GL!EOC5+)HC!6wzwi@|0 zxJk2%im&dNZO*vAiVY=Bw9VNi`MhY}%Zd}CICy2f8k)yf+!5YHOOOlwH)Q?02HdYG z-|9)u8ag=h<$XgEGscNL+V4M_A}3?I^km4O+H#CS4q_%Y(JZ%Xi{a2rjgxi$V?i!2nu$@LPID7pn6m=ov+ysG3-l`4cpFN+gzCmc>WgJj zLN1#|g!EdB-?0CLI=&?s&RT-4mN&-NDH>K<&ebxL8u9{vR}z#(RB&oggZ0qCc;)bDN0t?$#1j`rjtAi5ho-Whvf*Mz z*pUuQ;e9SIPEKD+fEiKAH->$*znPHD`@S2tKD#EG6e_NW~oOeTmL;7T`CNfxI35uTt8`i>T@_rGKo}eJ>U{<`jFfRmF}nynma93NrB&69Z8Amf;S6g8ZbJ zQ-@5NL=HKwI^OJ5ZH5CDG(*_D7=fI#N8nRhHcx!NqL_HPE41{L)!`uvf_if-qd+L>~5FnS+5#r{JPrGRZ^cz?Q}K((NJI zC|n)Dm`Gc;1j{EkI<0azC)~YcyABugEQ5<4|wA-M;H^gi?D4e3StvL1bEAEe+XJ*08 zxfNGUCxwI>t|igAnL8+3_BiwQ1QdCLLx9a)E9!dkg?Q0P-LmIYntP3&hlTiatt^(9 zkduxo55oJuu9n(C8(LY2wPnX&sQ3FjEJrn>_hKX-2a163K2#dsU)xjDaPl^orVk}9 zXKe?VTc7hv(dFAg4VK_-ZP{AY3ho8bx$ts>V5Gguy`IY|G^iU@=hzPK4exUbZn_mV zNVY*)Onz}0yDV|gT^P1jduWu>k9D#E8)hG0@l4UxP@~B={`UT2CL>=KsI@0Z1y)-? zGffWL;B(u%cC)f+~{h-~91Uo6|lZ*@W0rKHZfzHDUZ;uYEL z+C#+IMRxy#W}8>;poWN1zd(C~U084>D_LcfE`NeX$?Mnb!F7{t=$Nm@T`MI{fs)VUK#UY1SRzL;{Y`um2zsqm?7Dr!^*yn1e38=$we z3ikUOa8ZprVE+y>%$Q~tUmxOtf6sTlaud=i_?Y)6h4Qo8cP3*yQB`5SP7u;R9!*tt zya;LUILq`}QD!g3qokdA{KEW(gw(a6_?shspU&B?)~y)(k~>BKSfstJG5?w7Za2V& z__~E=WXB%{wy}^KCu<#|CPPMN&RJjAdB53EyDY>yNKx}Ug3aRZM0L(Lh-PRBnw~6H z6I7AGyRN8zNFje|K24K{kc1v;*&JVKq6MrlG~0l<{zzYHe^k)%Xkj1Fv^W-LK_M}ZI} zQe++JjbTT2sB@ErpW3fZ;jA1;9RMh8tFyn-GrWEz8zU)S&wDhNorf0xMK+*yD7jZs z*R?|5wIVr0k4q%eC-^slhF>G3K{(aM#vg`LS$JyLgV3e7+sOXh`2wDj*F931j%?8p zaSU&J?u$#O+IErDEOptRf=XjRC{<&?LHAP;O@_j(s-6p-=NZJ)(oT*>7)ZlB3oC;- zZi(;0L!2JF@KAHoQ(3V-|Fr>k!Q4V^#DcJ_HtpxcKZvB-it0ZhxPA-z@jVEodOy*- zG3#*VXC&46lzMOf;bImD^IybK<=`)WIj(X8qW?BcJwEjP>dbl68JGxTn+opiX+9-> z2c1fZl}eJfU>&_SL|^Ui#!^*YIOosfL~8D@Y2?0<=y^j15++lfxZO0`R5qmV!{OV; zyXSP1W4A(PMkA4TkKG1s{P~P==Y;@5({1Q?OK-_&83jMjGrW<@RdTj*Vu#Wvx5stV zKg5YOaD#AA4=Z-vHB&8R1l2%!tC#Q@BHZ;88^XF-J7UiIpRMaVYzxA2L_X_-h+5*& z`I5rJQh{uF$qO`Mo10;_3c)y!=E1h%oFRi6#cBPvtt-X$8)ih zL=fvW-nJUCGAcUcP3Z1mPc#vuBtgEvrh-B)@_#REN;L{Z<81#iW0Tk)dG#g4>+egW zzvo7V|K`4DH33r{oIX@VgW^`}{wkH2i*<{&>azH%pIW6xbjTt|{v8 z0{m?p^MBM_|GWJ>(Jkk(Vq_5OOIV%_*?~B69NwU$n^hKm%*?&2(7f}ciFr4B*DyU} zw{S#5uZ0`j`C9<~0WO!q-cwt*mL~4mjkbpr=?D>Y8?tMDaM$Vp2ojhx0Uq*uH_Hz> zha8c{Jp4qDr3bO{VjDa0M`4`4gMn$wwZP}{NyqdKB9wJ`7nzc3WB*$|%>bC8I%PVX z?Ui;Fb3a&hp5>_saNg_yzLq)~c`_zEk>>z}zJ49JV;X`u^$qVajSqH5c5FvQzc(lC z*pL3om^2ZNlwttUFq15pC_i9tT1;AmdHH45saRLf0@SUVbP{!ed5jlCOwV~ z2fV0@bLQVI1-vyLW!ez%LfL)KNi%Bjl&II)y5+V0NzqXS&mCZ_tEnuaL>AvvW|nMJ zG-Xv>w-b4lO?ArT8n|v-YDHKN0+Tni3!$>1ZFI%E_feH~fTCL6pIyP<^ZX@}2x2@S za|M4wQsM0G`=JdR4!{DSfcvfl2Z!{JHQWDwyCo1Y{~^2VAE@7dr;`-oPtg@=M(EBS9Ns|(ydGLMAPd%+S_At$b6w=%tQ3FvqN3NWLk*8k? zA7hXg0N@db3EIPCa_08;OTbtjdT=!o7}G&f^i4$KlNezTNEEG$sALz=skcXaZm|9G zJHzd4HeTa_ElXcGC&$s>g=aMu^gnl^NCKxfyQ$_LS~b1lDSbGyxzX8l1sz^clX)t<^Gi; ziu??g9cE5%cEcRYkiy2tVacuX{(1@Uq#^4ct^uRh_B}3^h~H2&Tg3ME&LYxW&rA9PgYyja((##=8#8}^{C`J`p zEYj`)2>bOr)aV)koAkkFM?ic?YNJv#i1T`TxSUIOlZs94#28USZpzs8oesVR@ilum zBL~kQ{>eC+e=zvww_S{&hC^6(gIJ!lov4V?5M}`A?x4E=T@2*^!kX}uzKV+V;+ER* z+IwSGEg>bxd+jP5Io|7<@5>3dMldtq?Xo?8wV?37wE~MgqabRCQ z>n7#d&_oIec~5ovz&VnYC?pl-<%!XimGtqx`uSWzQJI{sE6GVI{wAh{8-z|Q2rh_C zP;5)tUuV?%0sbM1PXc~Y58=q}?w9CmxZg?BBpV5_FDv8p#Rk?6$EBx5cWQ`A7{`dj zm)^a%)13*8)p0NM-CCXAsAmrPXl^@!u$1yrLtvG5b`jcg9=Kh3f5yXBa!d6PhaC(e zYrUZ4-zW8XW~>pJ*vCkd7XavmUO?lQ{URFguS8XdQwh82$L_7JP3u6Vlcc@?=)~=7 z7_D|y>eAAP5h(sel2sKOktq*be+aQh@iL4BgFF3mSHi2Qtc^tWe)7y#(iAq6YpB|X zY4L|GkO-PuSTU|a%dt(t+XcBhbJdS*_CGe8u79W;n^^-0QIDU4 zV*C0y`3#?sa>q@or2=On*`}DOxaCt=QOTxSNgj>`o!@#Q50zr9Lg8eQ?R!loC0icri1?Y-o|0z05tcujFZ$v8kukF zMt9)y7*v+PX>+8KON`tTI}qvoZYCQ2Gg$gO_k}?!Y;51~SC>^DOe`Op zNt)tjr2cA#<160CEcQ|PlY%CWU^VS4%Ag?NmPFTH3{NU~K z^#=>JYvHFAJeI&uVz^;x_)o0$CbCC^c1*DA#~jQS*uNoNFMy&B>b#Q771ocip}099 z3_J6GQ_ym8aC8eC(_6QcslT3KPyJ1Rzs(Up3Ik8i7*~2rSNbyVjfKXXgqXAT378Cr zw+Gm8eKh%E;{hFOCa>jdi=Tz|T{fJ|+ru<_t4HFw7EYB$ENF7|ve?es0?_zc7q4T7 zimzFAN<<->ho!5Yv)}~9YDofvN-T?yce;m@hz}4;H62w65v*o$swc`fSJDpwycU9TF{FOUsI5Ar6@dFF#KWv+t>{ItDY@ zYi2)c=1tO@twtwW*A}0K+Gw0yQ^ePG3Y@F5oVpbs!6NdwwoCsgY?eFRaI~BJRR*)A zOnpx}Bg#PGwEvCE>s^Yv>L0Md-A%4V@W$i0B-{0X%chjE-U|x~5l!#u>aoxLXKKbi|D{j+^Z5b%woj$7#n$y2+*p znP1q9$}n`DN%ozM$J1sct1TTI"&z7cl$4yXb`jAJR^Perd$PU#%A5rryWhq#hyF$vzewb1jxr zm?8P+&#Oe$Okzsd52?8cc3!E?^0GaDoV3L ziw+jm`1?~{$SN_YNWXSSasQUa;4B7sMt;xS@C2F_OOPZ^Ey; z8SeY5iS1ci?CE*M1*zZ?_P&{zT=Rgx<#)@K4-n|iHaPem?6r$ta@H8UXtW? z&1}htff5+gx|ruDFjp)lx1v_XVc3K_m(gh^lpmcq8v3_(*@4+x!|n>gC=yAN&wt>Z zM4H4$@+`k@dgB?}BwI<9@M_bUBawp)Z@ugTy&rOU-D8^xQbv?xoqI(2L`ctCz8Hq} z!C;ES`6+amp>-5DuBKfG z@On+kyLRS)>(PTn6PcT#hLYf%>@B{v28ZRc2`WycEk`8#jgpttLA2Z%`?&4`hihgP zmYuH_1@iV}aW>@X=;qO9`9q~o2)3?aXOzs7zniE9W}o#^SE%I;QM;Ud_NK=Bp0Eeu z#&xSbCCHm93}k29hRyvOi!G+@n+DM7i|6gJlpuc<9V+(I*LMeA958_{J6N<9GKo1b zM>B1Nup%Cp*}NOQk***-PBP$+JqjCO3UbI3T56gQ8qK>roZ)Mf!eFnLVmnf8^`JEO+bkte&7j@Lu9!8=~HH z5&uC&L0Hn$AO~Vd3As3Ay9$Tr#@$t0&SBNJi(@w;E#GLu<|0`XW7hEjF65w;IQIH% zcOD$+eH;sus*vLud$XI?E|i)fpRz&OWTRCfYM<@*CB)bHQAS)GUKbHPwyh~})5!Ys)sLmO zY69w*+wrmVkCQn#ihEZkMfSEQ)@x>osKGa!D6MI4JPP{WudWFxYY|rqo;VR|0=Veo z%g5V0p7HYa6L~3H_Di(1LCix3^bbJIL*)Gj-@^)M@bK}QCZsY-#$YX}tDw#iP)X3o zvtfFt7#7(bm)??d%1_f=bYfz{jS+5JQShCCZ{xO=mkX?|De^Br`>)Rt=lnNv2QMt& z`jvSQPgsT>*17zFS9nqNKveo#3+}P9CLpymfF4?C6rG$O=20Qk)z;uUvLc=vY9s1P zGh3+&lJwsCG__C`-;hU=^>`}Kp*zSKyBut^jk&D1{uZh zmLB>bD4!Fo{%Kn6ZzEYrpVA#Y@h3ipB(ucr^yqqp3=FQ~1T$_c$9yzO_Tg7G3AM1J z{(cBzeg<%p3py#Qt83^i>6YzPjo1eFH*s+&Ld7uQ+6US5lk=f@8lY-v=%JKXwu|>f zN_+^$`sv$gPP5xZ6PlHe;=v|!q0vs^+X&kpGA6&n_T#4*{0&hnqr?bG@sP(c%nRS0 lt@xi%6aU9#^XC*s>(1K;#1d?dP=D@NO<6-J=i;qL{|99fFfIT9 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 6be246aa08c82957807d76d63b708e7908a1009d..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 11308 zcmeHt30RZKvS<<_1X%}EP!NKG=m?@B`xaL~HV2hO5L6Ik7i5toBr|NIh(y_BR|FXZ zL+9h`aRy!+03Z{~d8dG~(zJE0T)uCA`Gs_w3;uKpif zGS=nWxo;-~0^!rwJ7)@kaH1d(jtK+@fD~rc6ha`-TbB&4oCj41L>&TgfT*iO)WI(f z;y_STR0JS4fcb`ol$GU_fnRb?Jt!jt2MEDIod9~`90)iZfj}WpKw%MB6atF{Isj~T z5B8_NtR56{S^Y>E85CMQAXf&;Hn^T#PadfUz>$&q5%9|*m*tS_%gFWhWO5mq-8e!X zp^*Wc#-iZVDL4lT0Tdj2Gzts+QCO^z`kayavJo;U^&@1^0}!K)&_H30uvimlFB-Xw zMy{ugfI_CxKmm;`8jHmuIIsvfK$p!mpfpm?qLEp&5f*3$q5$%20&GO4@6ne)$J}@I zEbl=e5;g2E)cv!MHUxr%=$|`%<$lU+KQp9n4BdTG&c{vY$BfKyQ{e}TKgkD%#@Utm zcB}q$v`4GYT|Xytrr7MaYo5hf`c}POTP*(LqPz~+vg&U$5QVgHu0TIWk!R+$Xr0J= zMcfd$eSI(t!W)By2p&K}LJSJn~mtb#~dZ#^{p9 zI?OqfYMZsYvTec3gYi17p0tS-_7rlMwa8el=u?W3eBqms0`xo}XVF7eR%4e??o&cHAuVj5R5-?b7M1>u?Z? z7RU7}_G%#Awh2b?>1nG~t(4ZMVXIxyu)2@_e#^DjrA2XZA4*vw92Q>P*iqpxD=Zq9 z?m&bLG8uso^!|+9)iKpSjA>GHa~cRLUmY#gNi`d*(Al~*IUcNyez)50fk{h0W{P5} zmvaoYJ-vb~*~H8|L650RS?sF&&_CIBRo7ocXKjYQNS9>2N}4hgDSB&;y0!Y`pK4k@ zvkUJ!%hNHBzMtz*nC@_snfaQW6F|fk%e|^Dsz`8;M>tq)dP@&nblF!H^J4wvoLPvFLG zjZL#^H|FO`>QN4Z3_Pp~L;K*+X|Y~E9$CQz(N}b?8=8|16_Yz8TC+>X&g@|zNJ-<1!OIp~UwW}} zpW>o@X>RiOybVy-!WS0I?5J)b9`Mmk=lmv2rA}UFxkd9FG!f0T-Ej4ny3O@k%U6E- zzD52})BILH%O*e`%;5cg4DWLf{=GPb@tBVtR*`D2lLTJt7pxI_tQigM-qtFtnBWs- z&8)-jR-{FG_X%W6ot$!F+UAU|T9X*1(|H_l8q zL}b+s^3H4QAseHM-xLRUM`QB_mhC4E@m@H$>BDk z@vlO-IH^2tQsXy2eo}kGN4g24oZsFo{z9m;P6y$!zuz8N#v498JF9H!GCW`y3(YaA zT1Hz?>v*o(G_K1l!%U6Pk#sc=dEcA@Lo0b6%Wf^CeB`7cjw#ZWx`QB&BS;m0eSUkv z<(RaqfZlQ#Q(%5Kj+z>2pwZwAb;^55IImcdXXl2Rvhsw%wEW&-^ID+>_iFp=`tWOL z`eoH|{3YgUAZBHn>0N#nwJ*^97W9b80e;R*YtQMcQxuLO>&P^?Jwd*(ct?=|>X7Z# zgz)BL@E#Rp;J|Z4(AX9yBwyemJb<1my<@HH!H3jLI`M6UE*zOr@nuawh zzTi$p$uq%4?qv-Yv$MT5aT%JUrJ4R%S@N7mFI|+hP6@t$9o6WOYZP2ZODjq6DbV`W z#wq8+F|IFNJM0TWCfuMozURrUHN8W~wV+Vj-F~V$t@zy3+a>#O+q;O1N6${cj1F;{ zebhqjc}**w7!DXS%BH=kxOO8t`G_*HgizGh6e&tb`DC^JU>MaVkSx5^+i~AK&B1`r zS1ro#I*OqlRZ1l~&=d!+_X$s1&R(kn{Rx^Obp(B%>$fNj-p`I)Jfy}FfygG|*Qr)? zU6GFF4&s_0OG&2-{{ya$EKS~uCh%}4>?wMyi&EA~7_L~P=2hYDGGblU-Ntsi4a7M2 zhlMtsy#wSD5qiTzvJnwdW<|zT-M_}?!wBn9aWBU$Bo}OT2+SY*^lsz2fJeVGH|f>3 z1>0f2Y}l7wV)WSSTK*W})=uVhfvjx{i*P;Z;#hR++>v+B6o{<4(c~VcWn?5_n#b}^ zrIzW5uzX@%!{RN6wxD1a+(t!X!)(u#4<9}`;ELbF*L%8rdEd=mj2tVcIDb}N1)fqA z*R$Ve1#}sH*f#01nzttK(_?jFL8C(MP35i=fmPWY$!I5<&@p#XJK_(%GRv1QVQ5%;(X%!eTT9o6asnRI@-XLpLA{Ki-n7d; zs)0`Z`AXf#S652mnbZpr6GTE~p37puX^}c)ENh-0EPla>{)^W3Un**&kKgwrj=R`X>GG;yQaGj}5h53#9$y@qYPusFR*e)Dd%c8_D=9x~p_v4nC&2VkGdEdg5aU04+el1LG zMz0blGsxxT^)m5z~WD-j+S{&{i0@%@&~#XUz>K@;OgW^L05s@;!G~F zg=kv!;>uQ5TT^M|HDTQHwlhH+P--db`>hKs>`M4!f7$?BELXzY^Xc1ttX zu$oDZsPloNwd?V!TePA2Hcaqr%eNiyPj1hl&~M#vI93n}MV>=J5I+b)&iv`B+9lM< zn=rkUzY@m&`Iy&Ac1^a_1V1xMZtK+AT0Iq*f4dL{!@YA8-mG%c_L5bhNU|8qhA7CV zJ5A>>Pp%F)Z-(PR^@0=qT)KyC<$cGKWvmPF*Vms@#U8##Al@U~(k9yQGg(|rE`R-N z%BL3(z(S%3}y zEt=&$Ni$E*0xaZF$EOEd8G9n=7f`RnWE8Xn1+hSM6qQ#QSca^2A%MCj_ycy#X34J-+oxDiSF` zP>b1xaMO9$`)7{;`nl-Ab_UJKlPhlrdo;H8IxMw~-CMOq1R*=Om7LA3Ru-JSaRmiA zEPf|LL=gLx`=2CGp?EhD#!r)O@P0MEWra=RNF&UFx3!cCuU`t<~NO zQ(odZ8Q=5#zE-;wT0o(C zeV-l#m%IHmo1*R_ejz=X^Wz@G`w3TI5}ai%QVaM-ikm}m^R)Z}ql*;kc_L2pqR0eeTqJ;F<*{6#Fn_ADd9-B8AfrUsH zP);vxm_;fSq}5n$^V>CfYGAUf$ebc_6bX4SeOGFTYPp`@7rCt_->Nu$daz7_quadD zN!vWo|5$)xUC(BpSgB{h9(D)H_MX=b)>!GAac0%Sr^? zUMF0|zUae!5DpO0T1_^Uiiv%ggH3PHZ>P@+Lwll!_!6)IXvQF-AjbH{MT54cVs?O>ZEH|ed8h+um39KG=atjMV>(BQr-3E}ROHb>g& zd-H@%n+B2&IC>1Xp8y;Q;SLJpUa%##LNT;{)dtpQMh_Kkj1nz~60YjFFJSUVW%G%G zw0M1mv#iG3i#2DPz6)B=Uy#WdB5cdpYP#QChFWO!U6hqEhlfrEm6EWNr~!q@R96s= zjn6MX8N_dvT$fBjkb;HMZwgD=Jf*+JzKv-SM$_K>G@pk#o5P4W1S?Aa=-B-+B4M>M zX?0=3q3PV<{lVV)Y!G723dqZYNx-f0Ca*4RQ;_I)O`e!fZQbYTb&tV3fQ*WW2Np9> zFDTq7=>7xtVvBYs7%!Q)n`n4?Z5lJ38u{7VA(3{tsih=? z6@Hi+^hFoko>wUK`n@BAAr1$SODWh#r;}n_PNTw)^*@RF`5)D!XjoOANE>0?2|aJG zmMjUuuAe_U!cKDL7{4j|xIT2zd(9B_3EAJ{^K{h*S@vBws?fb5vDsZ83(loW>(n07 zuKdVN5|!2>9@44&8^Z5u+*Xz>VDfKjvl(V{xjhBLimt=825dIJKYiDnFwR@c8Eh~g zh(5ow6m73EZAiu#)h>f{`dzicf}CJ&$Zdl~HKBWpz=WwnZ!W;?NkWoK zttTb+AI{PwJiy{0(7k!F(F$$Sn#C#Dew=)q zheYz)JcaJv0o|*<&C_q&%N?-vLWsTG!C;(6nZXD>U0BTvZqnVX0RiZw9!m8T82aP7 z6mmZ|BH|G8tV8(zlhB*bB}&v8_*=FP-E1~5qS|k;!O+JfUJZK~O#I1SUlJUydO&do z?Ebswwz0nb+WZ#SiT6Jw-i$CrVGo|Ho%1G&_((p)7-g)i$0Sg+ebJoy1yyC=&n(W{uFYhxl__~^3OCnBOAAOutQX3f3w9T!&-F2G0umA9i|XUy`E~=IDF%oe zpvr#`yixqGu6&wWm}dr9!(ewsRota*z-d_ZS1}b+1rR=q*F=dmh=3r8|1_#xSnx(H zJQFzK3;KUo`E&#<8^rscGr@|1s>ZSx3xq4iTN@7lcK2V+`Ts8s{cq#+sDIHZLnqyq zEeP%m8eQB-E_PZudC=@kX zHAQP`U)TI92UNVthW?#1PIq^+UcWK<0w0t+`oVs2a_L2kpBM<_pRd3(lUsy0{o|{a zkSwG^L;E3;H^*r2%(r?f#ggG=2l4|;X;^Rk|KT98-9Jir)4Rg1dc?W+X%^bTF;f0% zub(_{52$&tu*GE8CJEk1nYjcDf@i`FI-a^1$vDz;(4f87W4hK1ckSF%2H|SvEV=vL0uhR#Ig^3i=&UxGHgY zCU`E2^3MDZRpyu8OLy}d)gaioXntil5U795U4%+(K=v$O)~o2e!7V|-8wjBH?KHxq zocOrq^_Mb$ophjQw+y0r^)hqguK!-##srwj+CyL_Qzz2<(hiM|u5H}a-HV&Dw}nDE z!9G^|d`OLV0{^!}|M4iX0T^4Hvu3IzRXf_&=*0^jGoU#V zAmQlgY`BDvY{CzB%1jGnC>Sq*G>9j-U0BYhr8zd4iEZZrKvhHtWEs0>1CGY@MyLS> zD~wexH>+_1uB<%9wJCEJ^iLte0G_*l;L=nopT}X4-moi~x9Zi_mY>6d7y&X;46J~k zdQ*KvOV2pS?A`pIsf791^qmMu7>CgkNZYFaGYRH@aKh!^BM5owbrtI0y2GCuXP!0> zTd!MS2Z_xK46oZz|LRw)y^l9{@i+VqEdK!~alDcpPAXQq!!x54VUMOIR!DziOCNiy%=c)b+%aN}ri*FGTd=Sad$`V*0Un|tcn!<#jqxs zEf>G@F=I%Wm-ePgipQ`0>01p8rU8M4t&7AP*|lp+QCBeLvI(Vlcs*lw+LAGx+Cyw| zkrZF=5kHrtU@b+ntvH%=Dnbyqv9grU)SayQ+CdC`)5543!3`v%}V!>RS_WDwuaG&DP75Y(((10aVm8#_pCIt30G!!%Y=0>}?A!_G}iSU3GX!($(D!{F`vwf>1 zSv;U!+zhp7u0h7MJYbzQz6;V7aOo|V1dWNz9uOmlnC>xS7$5Q~x4(Cv>Bh7%zP)1I zl$-EPa}>F@AhYaJ+A1a6@?wYd6XMdo+GJx?Pi{Thxb2H7?CFM6WfKoyZ^XQ_1+7= zC|Dnvw5`b9UI)FYQ_d>|1|-W270rBuyAl_-93Haio3{TkgG~M>Mb90NY-Jd;Q19ZW zDxA$sQzBZ&*C(7=XJTT8dCc|JyXIaWYLSB5`~EhKZy5FS$XxC8(64ULKl_k=i3V;g zq&LG&ovQDaeFZAJ(=L7vH8tP*Y(PyIgdDF~zs00Pd|HSn=vUv3S^5LvPy$AqW%6X; z@h@vUsiVZv#8cxh0;%iHvVn5S;6)Vp_swz;2@=Unt?M=zB5wvKmy;A&R4y)z z@!M1^%IQRuNmb{F(x67wA>`7}0H7X~5VJBr&}uv|JD=312z?;}4=vVeoMq%kI%%>N zsBc`VpJHrs^KrGO-O4XBWe(66vhdJYt$(4&7j)v4)&aSE%OvR%b<)v4?n=w;@BV=96>aOqC^ zFU31X(~YvHHrh5R)F0*&BxVR>Vk(RydWy&d`tIs$c?*>ra+n`sXFL#yBmTw73`zGH zy?~&k+nBX)i-Ws_SJSnhS#L#mEOQ-ppRuo3GHHG2J-WBSTorx5UvDlUx0ELmh+w){ z2|K9~tCd>nXeHhu;J(L}Xn}eB_1;dslCd6<*2vvy32iUsBCwx@VP|SGD&Ec!e`=!N1HNT4S7S<1UK~O_Fk-^BdxZzJ4#6*J*;G+VP+b3#sqQuh- zUD65`Od5~s93rmMJ9@*AE5-kiDd G%l`o5Y_b&q 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 8b28bf68f59a261e5038511f32e19bdeba9771d3..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 24795 zcmeIa2V7Izwl1E8E(+K{L`b#`5fMcx(h>_r0TEDoQxKG@w9pepaVsiOny7$C6RA={ zCnC}Xr1#!iLJ2h_c{AYN$8+x4=bnAu|GxL`|DOC7{MMRn%{A8?W6U|e@vX;KE~{+Y zvUdvv0@-#^^@278!is`G*uJwffs~X|iyIIKwC0NXRV8ohLgugNcWcX3PUpjKM({V}gkB zFo}tQ10+X_Mbl56It5y1w8!{a$y(uLt?;rqaCGSwelg~O81pb0i-FqF#?f?RI^7C% zMHU>gR#p%z9Nr4wWre5XWFa^!SsV`3>%w)>qs5q_#dxBP!6C+|7fp|*(-RrLyu`$c z#Js%3Jn+9Iv0?~s1;Ja%;z2_=93J0=?*a!MPw&Fh>7Xd1Amdk&R{@Teyo#Z`7I4f} zY_w95mskPv7{8W^mZ6HFxr!lrOI~72MP5q_I4W9NhFXT^TIT3oIN2_oRTmx{IK~~i z=v{RBP(|WUMcz;gI4Xuf(K&F;4b9Pq==5r8f_2bJ_2L@IeIR0XsY77Z?onD;C1D|Ib`zOk%y~+mMBKy}j2P zlN{Hb%KA94*@pHg#nq&tPw*l_BZ=j+VajO)I#9TfoO#Xn6r|NA1R6eBF*k>%U4PiO z4V1o)5+bAJdRNAXBiwyNlU3Seu>fQ$J0I&!l8O;+T{uSJ<(yi!si*V0iY?Q8Z$BqtjKu`<2A_dlUn?Kxs?L))L{nqIctI{e8*|-m3$1rJt}lMEvtXAB>JUOTMXgAyl%otggBvZb+9OL ztQ^w*AcV!zrP8AO9Sb!fNj67?va_hGMsKZ-Ta{j3priR5nhv$)sPub0mb@mmXZkHU za>CPRe!d&KH8OW{Cd*yv#Ahq}qli+!J!sLeN7=6ga03F{9lf|X&4;9R<7_yU9k0NR z!v%2HPZNc_^yEIrr;H#xHBkOyuiC?NyLRA6n!bV%fvgNHnd_>0@_Y^pv-zWB(z6E( zOoJlFun%<6M}vA7bX#r~OCiMA8oVecx!yC`MYpiT5;!GfCo1^}xmtX<{IEG)H#J{{ zxks#Wr%lT_(^+&evde923C;v93{Mg9*@KWS2hC!SShL-Z2btSpwp3K&&`_If6Lez6 zLOrrNHY$>|t=>>uA>^XRP<>#af*(uzT~VrP7q^4@XbcA5Q-y7QtA2M@Yky`MRnVDT z(7Z`^FRo75QE%bo%AUYPtc$OLkL+@Z!$t8UXyM4^wS&aQZv- z(j>>Ht?LumU=`KsG=86VS63xTA@F^RG0Sp6(A5tZ%9}_6tUdP{+wl8ux@_2IJ9r@H zn3=IWP$=R83c|j9^AdLq3N^3!SB2nDNz5Mka0PQ7Sv{o*zM|q~`U9hg0 zMkB|}X5kZATM4lIE>3KIc&o-b_4JeQ{`IMUI~S zp5#)nW@36gs%+9add=S2abiN@-XR1eKwpm`qwGLNFMB+Aj~<~UtzIsYDkL{u9)mk> zT^9Ge=#jZlR<9zrFEfX{^{6lcGSj*XM{Bwy&dqIuN&h1JiTM2WtT~Tgue7*xOIOJe z%rp8k|WFxYno4QQTRLtyo%Nm^25@i;N4@U%>-;^LN%)jN>+GVY1ZkC4aBR2Ius zg8C+x#tjlp51YbW22uuc#ByqTCGs&)sQx!kSfkl%QI#a*e-Lg~@xa$`+%l`#N>LS` z3w01fpJk(_!C8k(ZlSH+Z!d*v^9PZ7d3dl7lZ6pQm^s3_R&8hlVU5xSzslvX+%}g7 z<$tqm-0pWayWESvR3Wg#h?S49K<8xte4}+Ij?J0-wVvS#c|$FtCmDUAck(pr@W`^9 zS)ue|w|>h^NqkpOo_i57v?QW<(RQ<^67(4lKi;jqwP>#_WJ5ub@z5AsEM{os)oK>E zzmY>=vHMDF>$DiP(uZ&W0pT>npoG-rty>&R%*SH$J-Nl}w^jB(PHN!%7_YEL$toHf z%$HxXg9poEuY~%j^6AkJbzz%Oe)83Kxz~;K*AHP%1%v`H@i;r5V6PgT@HAWLuLi0n zM$6|HqCROgiByQpPrzg4_e@u?vwyzd3WWPGqLf#CTD{wzqjFi8;Lylck&QM|_*L<4 zO+N<^7X5ZG;uJLP>rsqX9CTuFC_B)q_y)1Yz2cg{2ZdwYpWFR=Rb`L}zPVkkv-=K* zB#Aj5+{J^vnKE(pa1l#>{Gg`ej)e$Kw-SRNP)$w3*x0}}> z_qLA`6y-0E>zVi^Z$&rd$^FWeo?h$ou6b_GHllMOQS(1)ri93nkG{Ii2v$zayI?Hj zn4J&&Hl<|vi=s>y(Gq2IIbLRtBRdG1DE7ITOO<|^m!@h2#-Mo(*0?%6W249lA3C`k zSC^KcIcC~nD^Q(1y-6D{na1Q3aB$u?4gAo&ZtD4^Kd+W&T?&S7+)?rZTax%dkL;+5zT zExs%+l-D~^xS+0O>=`%8>3MHE4_2YM@Ou<*Sxinf=go`Ht#ZPofn1r|7>~mhrK`(3 zP8`zd5~qH`LZ;)&9~Kw*o%A03Xjk^lS-(dxI7SEDS?w7owWxIP)4)hj$5^^&TK{ey zEVViJd(^eTJF+`*#LHDNIn2!Fnv%!K2|>{CEoB$)&VKneqq!B#^XImll?}7=9WE$V zX>jSgg>5)9fg)Z5WQn?qtFo&9n!)pXkm-b5DCIYx4I~Tq`#`gPQ3Qk{vLeyjbfeMb zJVW2YVI|FvWpF zW@3~V_+>6H>(6_4GP;ca-X}jjHq_ribA>|RCAdZtFez_ve!^+osbHqNL|tl{7rg&pIKe z+be!guCa3t43<7*$h($#WB8U+O;PDwe8+t-Us7#N$B|z7M>ZyPQ%_eex%z8-kW<>Q zZo)!Nj|Q9gx9*JwM<3F%jtCW9Gd-f_bhW3k2b$N6T$!8Ad+%;H>HuD61(=&R1)i_* z)%%O^%LpRxw%AvFjqmLNul>2L@pu76uv9oTUo706Ys#`vMSJz*++VVIV}uhfTXDs3 zyE5J2W;Q3CK2Ej{;nR<(+g2HF0mSaZ-DqUQR@GXH!X@DrvA>%2h1jW%wtUMSJOzFxla>evr9x>6vVAN&$PU& zD8>CFZQ~gthMqm()|}KF=`Gk$2mz7RmP_7;K$7AiOZSZtd@rms9aZl$dYTwh0Hjo~ z%~N)n=Bwf%yIgbX&7|Ttw>ulfcvnz~V^fM(J{H`h(H?;}QhXEHxYT{ zaoJ*IX*RfzqP(#pyQ+r^uo_DSQ|B;rL+M}GG`YCZTVdLYIbhX7u~XtK!d`KW%bI}0 za?N31CQb6*BhvktAA}S*DV;Uv<6uv68+mg7^W_~px*8~R6>xnRksibR;Mz`}b}iVK zj~wjNN1)e7$V_fQ*mTb|sN6-AJ`)vd^3#?{6_0h75Hwdi$oXs70>m!B7&_+g21cIX9!!)b|7qF9bic1(r!j0MU|iP_JNCnG>>RtOWwN=dnPQ@ zol?3x5uzmR3SR%Rq&PW2X>L4a{#WW$|>51r#S+|#OE%SY@e4)3j!DIiwG!S)JcX0m38&5RQ z`f{ma2$j+r>r>Fg9`e`Evts*WNJIHksRhKf%f|5SJZ&cE9@n<8JjIL*?CBnH$f}78 z%Kx{DV0(2X>2CD0gehe7w()q;3m&WoxM%h1rK5aZQi~fRWju6_WcdX0tqGV!F62~< zyftOyx5pDF7im88^rf*~YH^$d%7^W-u74fuO@Sas{Mjx4A8cS?|AP16zpSb3)L<#<`SccM z<`2$5z`vhEVfX5#9$~j}2fftf97HWA)moFU>_D4b1UlbKAj~wp-9?)i(mm-y!xv2SKMZHg63MPq?Aza0 zTpx|{`YO0hfN14U$G1`?93MHeSV-}wptrj==IHXKX*D8WJ)Aiv>fx@vEb>d~hWzj;gx{ch6Hg`Fg>S9}TAT8gm*uL3 z@yF}!K2lC}m26mEqkg8i$TSKnkr=v4frHVfgaV(2*CXnkx4hR*iGfwENgI&Fect5N z**mKU#7M(-@R-&qoK&i9&x3vPXXLw2vR96m6@#h?x>?`BiZ^xV|KD~04@b*?kv02i zN%!A(UvjQz=7;6t#l;MaWKLY!>hNkyyBsQ%i4Av*cx*l(Bv(cr8=N%N+5o<7*< z_@GmRL_#-ONJ(%ekWZ-jp%O}64NBH8cLO-maQ4ppYWiQuPV2XxdfqV~G0Cs^9? zhZ|mkHGZ~`J!DZ+*{r<-$12n$vQhCR_Vnzl%T?_X64}9EX_WHE{b6{$Gkl<{WFvaw zktcmClklgGYi)gAg-43X*^bgZjSEQ?0cmL?k1P#u*+tQE=2TkN>tr#8Yxgl7YnbUi z>QYn+NjPr*2|S-La?j+K(5e*9$~4;0H_T9!d@o@@ji5jejifKYkIzb%O5CuZv<$&A zE|w7NVvtKANaJNqbzv#I4~MGjMgDaaU-`_+Z@rD^#r>F5$9|E)SBt?id`l9q(b@^0 zxHEjCKh3D2QbVhz6_3)h1Ukg2_4A=lIfJ4-KG}}0j;r(V*1pE&Ik2qKKX=DYe6sv- zS-h?yNuQRv)YOORHp|hFso!fbNlT&Ba#F72k0E+;ee>vFO;=CMP_2t)*3p+&@GB)kT9=zh4!-C z>*it(*~O7IkKw~TV}G9F6~uDO`G(F^uSBx%$bMVr=aL!CV%17q_BAjk*S9r9%q{-v z5_(AWh34Ky9Yw+U_gK3NckFs9=w&l%naS$A7DJqGuP8?F2+pW`;KGIsLz1rRS@c4@^0bCN5 z-pD76*=?3q5O+#`pD02g=UaRJc}l%s*lypJPdE+38#W_-S@gwRy*URzP_^+Pfq31P zNus;u7-%3%y#pM(5_MPGzwiWiD~E@$I;jZK|sU z6L1#8@i1rCS=;TnT0RaFYjizaNlG2n*x)g!!1@8}7fct1+LAdc z4~w0_a~#eQQM+tUCXP*{S*M)CbSM_LFJpu8ClMnagkq_}jL&M#@pU^#PZsglJh#7( z=CiA8)Jan0ya5`ffF2Ak@5vEIL|u;5LEn?EVz1=Y_qE%3Oi5t-E5pUB-tl;TAPS=H zthN-`{6tGt;Od8UmHOhl1dJ9+O8f+Vf@)VEpJrld(}LdNzQy*yehbl*e*WYc&dQb> z^TuXs5l6l;dFt%9NKz-=ub(Zyv0o?YX?4{u=>z%7sW&{j@z~(Bt?Pc_M#>4fbWf^S zNZM|k2K%#=bvlg@Q;pH~(Cq9iqh*++_`VHDOfhqRW?b?M&Yn}XmTIYAL+Q#TiBy|Ady{*+kP4(+w*g6~Lvl}zcyU#w{8V~(8M09q zC3R2+Kbfcg&3@)Rrh{hb9k8%6U2W1u-@r!MI!-GTj|YPFjClvPsP}7g~-{)`cAs)w=vAg1(TzF zl$7wO(UfrHQUpf7rJgliu9X*;=$m{eq}YUdTs*8^g}PQw&WR|xnMK#~^ie|Y{mca{ z)jth>$nTN&Xrbu1orM^th#;tAk4%MxB5CFiHE;Ap*nOGub2J_Om=mT&;{iCy%SOs$ zVk&u667)14+Z{1p(eJr>LCcW^Lk%D*R;l?7P3ok*+bcdd6hK9u9#hiEQSss_QZH0& z7xu7Sv9Gbu%z65*@0?gjGsID3V@vE6{RXJEf#1 zW|VEXsD$rw(XB~7I^_{^978>U;8v#WDpgy|ks(9VA1pG*E{oH`rh3h^&bXO4V6L3W z?J=t#W3{yF-FcatwPi2y=F?^QNykK9E-dd9Kri#yYDLBN2&EiBE3C=wcXZv$G(S&? z5bu5C>5x3RWZpDWWn5^AR-;!|AZfW2LR!j-$#Y1-bpual7o?!%FplR4(;&Jx{%A50?!a3wqS zhGP13gr4rtyoD;44`camBMOs{|5eL}WhR~1nMuMstz3q6r_j^B`cK}dLT=`FExOFH zo%b6$6>=q{5v8}fQ%q*P>dkz{s0|8Yytp>Sz59ITJda_erjWmy?!;Z^JnVLuh-V(A z1er-s_ziUyqzGMzD!jR_9FkZ6734Y#F9ytF9NetPM1~OgJc<*p=6^9O=>IpE#%|PPE)2Pn)38?m)c0WV1gjG zIYh}vP_8<%?#`F)VsEnn}uEnVp%pRfZqA z=3DDE!lnX{&N@q!;$$Cfbht@Fr`~*9U_3@!2)*jCc%dLO$9t}XJE8a##5qM0!B^%* zg-B`s1>^mB>!HocjII60doBYl)Ryb8_PhVIUnA?MJ$;uiDg8IkaVPKEn;!3AuE>-= zT1V4Eu(pob+`xaN-Vb6xCE5$;%!p?4PDM=~W8v>}$(L&R$S~k(@cQ5pjTC#L;uykL z{c>NegSaCv54H$^8%S@5;AffFFU8}{)+{zb5Fa!fV^`ksBz!DAU+#!X0@yQz0SA-U zqcV%q8sW_P>x-r(4Co>ec!ZO_4!9gf^hCT=apYkC90|}CO<^X9-A{rBfsddoY7YQI z1>1h?L9kmLz$F6@vDRER3q1sy5ZQ+dDoM)N*fca?pGtu?e76W)fD=A5yvaJVHwzQW zVki6=E^^M|7gs=9&wDVzjgNtX#d2*`yVN#dmCeodsQ0Y73MkS7gCAM+E@ivKC}g;F zz@8+yREL!W*cK(xKAPasUSCm?Nu2_3L-Ti6uPNMkHxI<~-&<(l0sk$M;pbWYr|kGo zTj+nIB49%PcSA+WQjc9fghYY8x$|tpSZV2qABc%j0qz1nydolk(w5J0#@)$1*MbK( zpC<;ChLos{Qp#>IGEfv8|Fn+#6A>~#=nY>g0tuY}0OujFbx(o3(nReAYQY=Uh(bX| zcj8!KuoF?((?G$jGRNM-LcR$jwt*fiLT@7wkOfc$3jI&2d@d` zJ8;3EGa*NSLqT<;qVD^D7yj=s8Zn}Au0E%r*9A9T?Ra&FD{m|VN1sVQ!WHR>&eMQ> zVP?G3`8=naDJ-{*#vR=Rv}E1g!a>GCMn)sZC}O#7Fkb)UMNFAA2fNNjOV$Oj`Hm)~ zxyr@MV-eO*1{*~K8~_IMd#01&uE5@-;=y?`hAukR521NFh7CTMvi_kju(6rfpdKsT zAGTSSnr1mp_RKtiIgLHPA8TpF&!H-7v>QjPE1T^|bU1N1@`DZVv3IpF57!B@R8>`i zY3PlgxTe3%6;RX1f8}RG$sp5Bvd2ruy1eE=1!WsU`4 zXD)G#Xbh*>x*7QjwejT^?}XmY?>nM-J?`d>j%3P+yz#4)GXjnXL}`J^MO5JyQLzIx z%BaR2xIFR!kyDJ*&UoxGFCHKF9MLVmqTi2M+D)*l8XE1y*?aLjR>=nA1S=kp4^= z94nvS(3f|lzQfm}K|>H4eGZiY#1;<%xPC^-cEetVU}LispyAZ+POuUx;aq%k7(i`% zcHokk55|dYQ5_q-PT0;?zmyipB$0W0(1GQ_cB<+nls4$S3(;)KZLq&;$}cGdtM2$Z z*9dxD9qGil%~3=NzzdF&4;Xj2Xqn#AMqqi`?)p#Rl!9$P zM~3|!oN_uBgoOQloU;AyGftnsk5g`D{S8hz9Z?P-)t_KW?#+0yL=S?>M66W+13dYm z9XTsIzKVKp?vc<$Y_Q`I`MqWUR#mv$iw&lJ5P~v-+V0k2)t4TSvk*T;W!7Kv98+JWlU-%?qyZBP~4=82WjD z^Y>-IZ+nr_;m@1i+r)#g+w>{M#?&uR5iWEb4iu^^z^5t6zsH?DdL+jR@|sHHV~pA|m=-r%Fxd}~eb-O0Kh(Z{M9rkCce zz*}NOM3#;zcgP6DTiQ_KkUx9|X!HqxP2-T1R~}qR1%6I00I2f@I)W)XA z04+CnK2v|ZMK%Dz^X(#2TPi2F%zxdfnLJ%=z`p@88V1d9lmQT^sL=xbhqd}U$9OEd9C zp1zCjbBo#QICaivGfi|U+K1PD24k9PX0zf(^gwDsA1!l{8he$wd}(l)?Yv35M4l^j zwFUEb)p0$jf+Fobku%oUxPYORvHDbh=4Tg6WUG_$frBD_asB+BgoC5~>; zt4-APjw?u8N+F7w(Ms2h))b4s_ia^Ue?Fts(;nO2Ts@El_X2h@59 zt^|+k$Zw%6u>x)4%Tev3@c1J7H@-*oIuVR8K?kE|?OuDp^T2zH0@)SL&xe^4mIiNK zTx&mG$@q`lM)9QoN~=^@qc8&VmTDbZ-l-@_n6K2 zk|xWWaZyb@W&O<(L1_7CuYEeGnm^m7U}ul=FEDKJ^_5>AQSXsh!vNUvX1T5pJU{zZ zP-wWJG=g5*jQ`?fYnkYDhkD=676stPt!9C(v>JYSz9Wb?_~!O%aoVJGfgXJXT}1O_ zR3faIty+0}+^W;{0brp6Bb*AbjBKa~Mw%Lf;-osIa`^%f+d%EP{d5^8#ym4UF20qs z(vj9NTccrbu^-csYPtf;i-7Xe9eCG9o;qyDJp+K|Za#u-?fcL-hG!D1MK5UB>wtns z(}+b!jQDZ$^5%Y+;bTtNTkEeSp&hY@Dx^w=rEXRwKI^5*Qx}u3jf;0x@KJyC6?i)D(A`LvxoVi z9k7}}`}=XX4#0GhBA?VZOC12Bz*28+Z-!DVl3hIs5225DNE4UEw^WX@luH#w&2*5n z1JqO2F2gjh+h4G>i`y;lm+b@1GgOb9vQ6Ci&;#Xo$cP*Qx5#r{vVHq6JpF-$;boA9#&7-7?Mg{F=_@tIV=abos zoM|saWtcPUp^2+uw@5Ks#U~f8i}Zb&<1IsaP^H#BD9C zX|=6yiY8G^ZmC}I1t=GLrSe+~yS}6Kqcj2fNY@ng-o#s5nWMMGH1{cG zIOa1RxTj+QSKtqVM*eRu2r^p#hUJ*uH(r`kLt2>BMDE2*&4-eTbytgnau{Ianhiz~ zE0|smYUqXRUQ;2Z5e0k{*OdDx9sTjw;ijIMIvB8^Ja*d$8gBUBY|VfIf4sUbZdI%{ z;zf{LXezw6&;)oQZ?ah|Z5}Er(&~`O<8nQzzF}cC)}MTREY`Z}x+PYJQl_n$+694m z@}qH;2++Gl0o-uIDw(Y1!Q=x>!#B`*))f zGy3}i&H2Xu+_h%W4@cG3ei{(j6~-Fe!^AT+4&EvP!Gr1hkb9n&$fxvmbo$C>1%)y z`qT~WA7<%3{)1uJK}r z@@DRaCgRPru-vKNwpE_kdrJK4%!C4FF=AO|IqM3FSSP2=^!e!`{6ZQ>Wjf1Fxt(Yu z*gUl=?G3r)?o5v^_j}D=?a8vQ0HF&o0OPE-K&C9}?!lQNO)0lVMPHkhQ{K6mv0@Dc zJP!=4V~xM+=$AUbx|(`?Uir%z6&=Wj%y^w}awvIH!b|`c3btW8sf*84fV({=li)Q{$e{N0#=Tal|~bTDn;nl=f}rn72e(qI4Y7 z_gl3I&X^QH6ct!xYnbX))z6z*`U>BB_2$yE2RozKBy6tKOmxd-CX~V6RgHomvz3+X zIv3Ph)X2%ZM}vGli>2jlFD_m^Jn{^QRE+dwOh!^qCz1)L2?MH+-<;NR7eIC?v9BqOB>xIc-|3&^Ko< zE{uNr4rO?vJHhkRhwnWTaw%X10}1_9j&a4@45wa%+)8i78t<}I_#^(6 zYBd&;?(vVeQ=(f`e^H0XUH+$_ou9y)|B3OB_tuHWt~Vh?yAHVX_^iXsp!e39AN<3c{vEDw?tA!FjLFm1RLx?PW zMx?Lf3QFY1Cv0e>9}nJx|rZIHGa!F@qQxhCq? zF9?(ZG#bFbiy#jMYyM9&E@r;#0v`y7WPBIk&)5EUjemZm|F_5L3rj)f1{x)S0B@U5 z9p&Z^Z8(S0XH(Nsj#uUc(8Mt%{_wqGV6T|I3k0-g@$j^kXa~PY{F8+?r&;NH8TZMa z4l(Y&)tL83e5b0WT!BO3s=*Tp2}#2&z>z9gJt8PCS2WUls_gT~Yv85(xOw~kz-0r$ zc#LiVcS3#S@h2*&XjziWvefY+iBA);-J*Fd6YKWqrV`Fme`)^o?;IS1mobx}M6Sv> zT1nue`rTy~KbQI=X4|#U_fOTI@&1vQF1mVSP~P8-CJ~LEM!uB|Kl4u(I=+fxYVwO(a45cqBeiUjN2?7mn8{Jd>i{SL5^=bPEIWs z>sYZR{0buw8bBNamQSb)dG&A0eSjnJTnGmv0NP#yRqeMActGY|h+)=JEk3Vi`W^I^ zc7;~BTq+NJkr)TSjtRhY{>k(A>c&Qlbk|N?M_^VFx}Ce?ww7em4(Rp!8!ifaEtDsT zJbviLom_7K4UhkdO+T^W()a;^93Jkk8W?zf7F9ilXMXT-GbCG=Q?n1@7RIM0ucz0oX_#T_hvpQ1{{h5Z(q0`5rke;12ts; z>!AaHsi0=*nL`$8D##2*&3eFkP+WTv3|J3Xzg_hKhGGUI^M`5y>Mmc7uhcprzvPws`;XUkNC2Td zx_O`1*lxLFLIS3W;okot=k4yYk%5t>s!ONsCIOS{%FPWG2+(JcWNd2Qw3De+Z{>M$ zy^;xBK3>m_4mh0oQ{ic7ri@9FbmL~^TR67aVaEokb8(w#AHeE*NFMD;Klmj036W$# z(P3edC}fy`O^(T5W>l62)L;p*Hv4mL-TB4&zHSu6A4c@5Rep80 zuT{J95StoZ5-JktKt><0cE+2Ty6C8&{-V))6OCuAUV=@xs4kDa;@?sDo;Re9c zzQlfGi0-hZrW|B~b27k_j$IRSo#-*BUaUHZS%oc=#NZO}?+4d-B&+>pxe4O+F} zLkF7|^$l7rzhBffX!ZPl@f>Sh@_JJ)T$qQqwEoaI2M~JcKTNtHH1EFTCM2@zzDqa! z$2o_Gkm`#c=lmXrJsNzfCA5H2D+0S(8B5F(WMD$Kv(RCEC z689vxg|yrKH#pgL6w%isXZP9mkB$shy;hmEUrXAgpV@%?;{B?lbkiod-B)PlnvA1UiNAD8?m?&=3zS`R5!tv$!S!Pr(I>^E|n8EP`dJc zG0qb7kQ`y=%?7kl&lBKLfa}-s*0DJ^>X$zL@Q(nhbM-Q}v-tj_St?ttK91kU5NLB9>w9hijY`9w{d^l8$^YAf@JYp}y`%%mIh_>DY^jcV zr@3_P5)4Mx1W~a(?~dv%FF(RUu5nb-{%?M`gmpKLL==>&Eh*?rrmO{(ju!1kg74FK zo`}VEJ1#VwS#e)%BhcT0Xo2WGS5S4Y!-qop?lgiR3-hhQh@Qm&y<&MJX7+kh_nJ+a z^iu}yVo}h3z|i;J{5@LMZBw6ipYI{V?yFNhRp3i?kFK)~cL-SA+2*7ktv?X&D?KgDEmDy%DDHbX}%>jVw{hA7PRyxaSv{h zdq}~a*JOhOUT_1|iezvy9P%~Hsx677fa~4uQonfPiQw`*(5_zbTgr-O#cOFHdBEX* zW8)_syp}cV4+1Ri=-5*jdO#%&>w1>)EJr)yZet@5Vj-FhbMj&Fpv>f?%~(6zZ!9w>_EzYMA==`L?yS*vw?}Tc z8Cv$e!Cv`|27d3ir2@l{{vK@cpPjNp{Qj5(UO5Y!Cod3eUXQY+(dP$ak?ZSjO@*`N zd~rI;#YH`Z1|wm^8Qe3NFO!*trC>fx_FC|#3b`W7c0l|_yT)jKN_5SUbE7BwtOa!8jo^`Edpd5Td$`d{ zHCvA%?2XO#^`*CoH8q$m5XpUKdT!1SwIsaNL}tGC0<7-ydk5g6rzJ;x(6J%1;&SplWX|mo& zRkHr>)9Eawj*;)Iyf`_&JUjY(lOw|PDVN9k9@VO7=Smakgwh?mnYF$i*V}kTIK|@h znddKpki|8t+m0ceJ8RyFj;(tNnz_^@xF`qq@5c4opTbv^OY#`0*M9f6sIjoL&XG3X zb_Nkx5%<#Xm>HO7^i4|GTR}6 zT45hJD0qM7`HP4MB=LGWG~Bf1HEC>U;-T|Ia0i_w*0JlUJ^bx|2({wG16>R?_0c1y}G;8E)Y%GhpXdZYAhnQ2{dU+x&PW3 z*T#_}Y$|JO?&-fM0h54q1=`;`uO$xC zd4myA)R|JblW9^arq3uN7vQ*XayiV@caXMn9y(!WZWoqjT_9PMU)ekwb+P|&vgw8L z);xcsbbmgaT%1;z`z_wQ>3wcC@T~Siyp;4&@%Z+@@ssniT!H5~RhKJ2 zn;nmk@On&<){Bx@E`l{a`re*T52OpWP=l(S8$SlvJ1k?+ z?0rm*vWM+Nt#&V15Q)GV1N+;RmzjM}((7cd?t0sq6BJgmSAp6z^Sp&o%jw}=bErX~ zoW*)u&$^gBORR9or&>bjBEG6ibEY*NCgH2sS;JSi3is_b-6LM8h%V@x z7dZfH3>e$fHP(}qNAGtm{y^b$rWxyatpy-wE_)D&;_AYRcv}zA^y?t5?esqmAp4({ z`)Y;eXEiv2F5X8zgQV1_rBc!NlQ`JbjrWxsk+!Y8CBb`l@c5%p=I<4rYI5~r)??4C z*yWCSce1nlArR9!DiO8Ci-RY6eO5XbA{VsA4C@R~d)T4Z(-b_jJkE}C4avzU!v*b4 zaboqG8BriZ>Fg-?kadsPMNKY8YJE|>M_hr%#8lwx_|=I7fvAOs23{5e*|Ao?ho|;M zP;2OGcgWigR0z03-#=Kp!G|q-H&D(kU zlb+Yjy389aCxK4>f|w3cd1F9*6y~7n>C}E2>9sOVP+^;mQjo_i5gtvE-pO=U`j2`0 zN?cM2dqLdVWfsd>q+zL&nPQRfl*>zv;4-9Jj%3*y54 zh8DC?`Sb`R#nO#sz@^mdES{_K%b6T&nVIH`Xn*S-!STLt#U>lgM%h!2BtOOo!BY~T z2JY`y{40p|@Q2xV>eR|)`Qt_+`ZP3m^01yowc9p~-FqspiTYB{lt*4Y$h%Cx?Y%fW zl-Kmm5%$G5Kw+nk-EqXdu<|G1%(BJas-89#GZBMkc>o^tmA(Kjui)V1+l3JdDxMe! z=RJ(r`T+a+YbQ2KWo}C0hIqunU`+aPPYK11Ufp}V2=$QgfelES@EN$)1=KTz?;83l z$>V1Nwy0n;dT3? z-_X%9@73(|I!v@!!uvlIO*Kz1>tbEJxnD^c0)7{jE?-DJXMX>G0eXN&GXMYp 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 2645f8aedcc9cf40aee6130b0b36dbcf8f876e59..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 13353 zcmeHu30TtG);Ay~YNa-)O^Qv{v7~OPD7)iHM4dsKECJ%Jbdtxx=~lyYKrx?|m+Ad0_9o)?WX$*ZS?X z*WTPbdc<~t+Hy4z2()0o-Jath&^#0fq%;6i0&4P~Rpx_0V6UTxe%uRu1%b>#ARmyq zImjG%CxCp2+qP{3s$>w042ePNFWf2EFudiQlgYa zlu7{tptp=d_M(&MKxrn?IizNwjM4#iB%sKv>CNGbAi zQnRd))65xd2I@zpEP^?U;KL#Ug&-S^B?bOiQYnX?$)S@t%|M}ZngI%c*(hfeC{m78 zIuH{w+Dsa4rjK%f(mXl}6rfQ$DwRr!K2jn9;470F;KZRzN1LUi94XKYJPN>G#z59l z6mIks(6MT;opUG%q*p2X2M2x#vj&0Sp#6Jx{TTU}*D-T?O)KW1XK>i*MH`>=?mNC1 z<4s>$ob=lPuhu)u4FlJ`NP0c=?q$Z>fR&};EA#!{J|Ol;(ev@(dF7|<9v2o`_NVlV zDm)gsfzo|MlsESa{XlkG%D6@#R4NpTUkibt7J6=*4=b5F!dLcNK(IXtFH9Tu#< zMy2;&Go-X>=GAm-cTdf+!t+S3WYm=U*}i9$N=9hHorQMn5eTHcvIOk=pve_?p;dk0 zEXCuORGV|+bak@S~30l(y2TAszn3?2xRSY6L@^lbY~CF$s)in zC^lczm4tlk^o7Nier;jTWQpF!+l$BYl3%EHNQcpqi!m*=|w~=55L>?S!D9ZM2YWAP&je;2RKcXB|?jbXVQz(oza7aWlr5FRJifX zz3OM1j3qhxvrWHt7w0zq364fc51{R0nQn9uyK^OBcqC35zgf=@?a_yDMAIyfWEqK{ z*0b5v+kGcIW+(VL)R%%FFEPF2Y3xWOY4# z$lwTxuqAOUP%_w>o@*_UG_+;~3J;myQL}4c`Wv2x!;xsK^sgGYw%Crr@ONHA#SsV` z0*+0h!0fQOK{3Inro{N!yve+wb%SQO&RCu+pFbN>VgRp0#FV8z-^uNJ7nE18FBvcQ zc8k#H4!Ly&?5sa=iKDv2>l1!7STE*@ix;D^LRV4*V*c|;tpEDWVL>fM(82b z11J8K=DkCDB@9b!QocAWKF?g2FcG$FM;gkYW`6CU-ko9MK<>wh2j{gvy5eGD#DcUZ zq9-#O=Q zvsfQ3>CiCao~QUeu;ASbr|)K3g%yEVMdUK+0-l>YXm5*IrZWz4xZv2J#Vg%i<=@ASo@I+5f0 zN*fpt!6N6fwbT+C^B6bgl}8j8;W}KPL2S9;G_ywRLwb!|B20ZdIZ@(`nr!e1z4w)? zkK^0o09EdQ^W1l2`I@OmOZBp;`0?AX3U8-4%*bZw%Z2MX(i|JEpX3-Hmxu8 zvx|5GPT#;>-2}8lC$-v(xR|0BZGcQ9BDl|;Z8G9RI;*a3nDUL{o zSV*V%v7g<&J5nY44dJY_1s7&oFO5Gw+%QJ#4ufOOw9UO#cubeO^csoz7{v@)9Noou~D|pj+1RO zYojIt(i$+h(4^`5w!xkE5?Cr3{r-P~e2g9YP*_e>`eS-mg3m@aO8TBc z3S#b?gt3yPE)uo zb(hu1kGFLQh+)19uRT?0_7zj`q0@a$UF+R2rGikzk%mY9E0+<(hQ_Oey0!HJqV+(T z3iqf&B`L#|%hl{!+)whX4tDGhx}f98F_S){==+J=i7AjCAC)D6WV}D^2~Xl>eHxB9|Yfury!i*AHAKe!+^&As2*u?)P-5^(x`>b0F#CucMW;c59KO3q}g zb_Y2PGvG^(^Vl5xCS~I=&bPnP+MRNv`}&K~a7j(ir8Hy*`h!Y(Ojtzr^>Y`ZgVj6 z`x1{7MM#S%WiYCEvtw;~Ot?6H@+>Ro#K*MKX!{BVb++C4xLUc`o*6fSbVm=mm1&c9v6pO(=A~}i@x^g90-UlYU~L( zL7jP;ib0-~H1ow1m-6Fsn+9pk_1^lw?P?g|`d!?OYGc839_NQ#u%T~{KR*1W0WxMJ}R`sM42#)9a} zM+CKlLFRdEqsE?MU27)x)q&+6s8em{fzawS`B^8(H?MCo^r3|yQHX<(|sP{C%Kr{e_C z+mCo~k>V^T9|&a2Ub9WpSf943M8NT&RNuKVomd44(#rAO2Rc7ni?^ zkb3lS!x1V;DAI9+Lg6JTkOFG+g`yRNWjA)d4SXoJx!4aA6EDZV29DTj!HO+0zDrl26=xJo!$+6H0Cmvtk6>e zKYYG|T_1xfG`DDhtF z1ATQENZrhMxZ1}ujzJ)r zzz*=J`9HT4{AZu6<^q$Oo40fXstV(1YQpSMx+(ssqmataQ0V1Fnl*4b?WlbiFHRr)#rxz2F zRbfgpdOHU6DpY6oBrP3T=brKX!vxU+0=7;CsYlzIVnvG}LTnDoXHnN}{O}4#IiQ8)lQ`!)@8;ao zK5GPjEuTPq#a<+>qp|aXNzmJtn3Me}u4_~C+I|-lz_VFm^>lrvfD+f}D!`X0S9;1P zyu9lPZP2n}u;&yi*K%H^rb49PMzlW=VNd8K2!=NzvSHsu?Rt*S4hnNyrB>VAvMpNq zs=J&8Djb!pvm|_&wMa8uVOAut?{vNpc7u)@(3I=&Pf8)b=tC;6%aubA!lML^@eO?I zYY`Xbp074)Ie#{^FloBM5p_<%W*K5_babcGaX7wksiuoU+yM5wGg9#Zy>y}Y0b$Z# z`RW4&&uO1qb;3|Kc7DWiS!8wB9c=Uz|A2#CWmx6FIs#)V3^R5|_seeT5{}JO45gM-mRJCtORLO`83jsA-L|~SY z;Xj=%TS!xQBgro*sZo7V~qQQlLj|hdSj{6}$Y_cR)aOjjkWjw4VbPNTMOUNL>Ls zm*}zqI@Eat`vY z>xiB5fH;R58YAw`Dr8b3g0LTp@GI%x!7{CTFAfNKgck&H>vi(jlNo;Cop*4F%(+y`wy{fb?#-xqV>+nB^#zebS(*4Yo&%`wKoJYVZhN^azbjWc59n!;j z8$&jAL0zvGo~z(Pw*o5&o4y!WW-PzrUjxyc?O$9|8V-YZPVO29!ks^Rt|)s>jQRhq z1`oTbi@JH=7N~6{0~UOzk0Q=t!_D=Ms5^5jR72Mjq0cS*xH;Wc#Y>)u-Srt*A}yMA zFITyD$M4EROjidbLZ~0(mjJ}5^3cFu1SWk)v^#1D+@$Y+*BCT(MZpc~a+UwtDN3%wI zcHsLOx`o(f`^_AH6ofJ|>ieAC-aOU#J!(Z`7asn4-V0L-AcBfxYYwBSO9r#hEIUI9Tg8a`9l+srU9OAvF3AN z8|6Ck)DV6s2`^KGJ?fz`kanp^Ov7(+mp_CRIP;-lk~fg*0d(e!niw1JbyGCVym0a8 zx_em8;H>!5yMt>5s`9b?(_K{UtQBl{4o2X&hVs!0W6rOGixeUd?Q@`O)8#`pOlCfa zJ+oNBA35|?`mEih(BgDt1GsKY^zV(y9|^#chEN0|{V$-Ihp z1EMUpbzkGxFB#&?Fqogrl#V_x!)dqt9%;?C)KDUdkC+Dq-j9xs5#JN-H)OY4xPpIO zIy;~WyH+Y_z2x>cvrk4c+dU9Q&)XB!_Uc{DiIltd;~A@*1P}aEU+?(Nr^%#bpugCn z%_8^9W@f1dH##&vLvSKRmbOvY_m%kASe92z|0hvr)j$pg)eh-?C3k^bAg$hvx!hb` zfp^2qziRNkyTr=^Zj~oI_c+2HJxkU>RnFhTZ> z@HD`l=77VQPdc?(o4a4fsJxytJVwY#fgUc_0J~H|Ii(+KhAvrTQF&80$Q(& zj|Q%U-My;>K~?;5>VM+;*uO3FK)3O9y7#i%sgd#|Iy#jxOkoL>Na_9oYbUbs2l$e6t zzV0hY^<%Wlw}ZUc)2Rtrrt2(TuxFHH9As(nOF&w@`L!3{I$N~h=T-!8PA5AZeA>hm z@X{NE{3;jAD^9@i8E_7W4(kcd*CB`!?)F;)hix~36GI&qn5kMV8tP5KrsDu00$ncK z2BPgxQ2o7r6u1l!0=TII7umWxXM{;JsSH#*S!0}!g&-Kwo$!FlWGP5pfTlICi z>|9Tg#@;a!uaXCxO}-2qRe#pGa_ZV~;FRSOX${orme_>^bHUIcL7_%CzAyN!TzY_K?0Wu%P_!CfH>=~-p0&a2iK21ZJJ^w!0NLnCUohXzDNW$wAJa%9yBFn zj8R5iXy5sL*)8RAw?28OlB*?V4f}3lm_x><5}Ntjc4EZ2dGB=fC~XqzgCzd+%iI0Y z+QAxDmhR%RXkKpK+ejO|l6@mVWiJZ1XTfTxk=1VHmo3dZZtIMthj1!3b?KF=iTNQL zdoTGxr9|w3gN3*7ZttZF%*@_cKbF>xxRJ5>^(pD6`cI2{n}1_xwI=Gnhty9t8x=AO z`J1HfomgRR9%F--UdgpCcDTK-Z;K}3%gp%1r2Xi^iCM#6v2|F_6#eCCG>+f4Tj>@XEa-4 z;&F}ayK=baSu7v2s*v z+w#2hzkWf7l;~eewz@dxQt0)R_p3+)!^K*!mYi8USpQE6tdM^bioE8*E9~-2MUO_T74W z^3cBpmF=!^OD=PqXmXkq0pM$pVPK_vs&HCs9#0Lfd6O&D(U4QDJ zIUlW4i}_$?$x|zdtE4^Zu_;$7UNj9D?qc}SNl#v^y6E7M$vy46<%eMd=nYE+Ffj8oA2BUI<%b?EodtE*wKe0S48;j5> z`$22J+aYfuHU`kEAB+(}XhQvR9K>RJXlPP-=h$84t2Qv$PwpOi#|XpAY3GOcM_r8K zv#o&(HUYy9({Igu3YmN|hI`Q3!r}>V#o1EW-J)!4EP2G9i5yi{&tp%&EI$doT5gO; z+-QeJ0e7@cm?4LeC#@>Q?eyZZ-onDuY6bcPI!~GUx}-e5*_LraOY@cid`}3*LX5-k z?_>bES|&esc8a}88@O8H=+K%tPUw@R!0;v3MbV()xftX4aHHz~d3q+3_@U{v-y1Nagf6l~Lkakd89 zeTY}TJcwUvPU|ZyJkGClaUV0+s&fbjM3HqG8o+0#Zr9lQUa255qZ>#(uYl@y$WGaUy)GWJ zPbWhmHd=tjkE2xz2#X25t(S(P$+xPj*e;!xm>j{*5KsPIm8?%->2a2O?REQoyB z17M^CcBbqc-iC;IEiB$g>Yaq(&Q82b6B|;eFrdefs$=RR!k# z9Qz><2(yynH4O-a4hezKw=z(JoQz77`w$4U;g-ss>mUh%fJ{~hL<#~ihfq^Ps97P@ zLJ(Gch?EpW${ZqvftX`K3Gx&2A1gJh5H+hlwNN~$!%7V zEhGdkkR2}+PZAXs1+A0YBmbF8nPa5Pu~Hat;j~J=>a#-hS*i7fK<#+_c#=MeWDZ1; z0+*DzIm8@;HOJ!2u_TNX1Y<6R!GL-=42~2pL>({08m|v7A#%NVQap*2O8zTMO|3~S zEKDr~|8}I-jAG3pSaT^XXb6MBVsTg;xJXzM4of0|qU3_)zna1taCH>cj23o)3tvNN zrKT{o20SDGb<}i>){Nq7MoArosU0F5~k7{zzsNjQuY4r7kPf(t`_1CE3v zkw$A$M{5d4JHS;l3X0;vg&)O}MoFY8A4hygA%3(5KiYu@4S;O&9|=z)k@Q(X_ek;j zB+x6YIcSjZ)Dd?o(}wQY5g zg+SmCrE8b(xJS?R&qtmd_ZeEu_8JND=r+J@zqWQQU1hvb$*cNhQpJhNnk)Hpkk>$? zv9&KBuY)hT=i7ql>*I6QKl?v97QGsMT<2J8T=Ch|8)@IKhOf?RDY;D-8Fp)EhWuFV zcS3#Oxf9L|fx~g@k`Uw@8X7b!6biqFgfJXrg(-NBZTxy`Zy9VYKdU~ zcI@d$!Pd6j!~?6+o%WFc1*3DsurU8oIWc!qO=afJ!b4bNDJO&*r-PIiCE_{TY2$Xs z8&KODVd5xaSl!XO)jJvNhH=EUr%;dN&993W;~DSaB#vT2Y=1~1KU7;@6qdZTFqpz+ zj&fP14WJr%B8=|;{2AS674voL-z+?QKP)bz1K9_ndM?s^IqG}}vz_OoHG1?gCx4=hL1rfm!L0as z)GD`aB=8=3zE=xb?|01YY)HdhL1sn5VvKsGD(pSMlqG~7eP2VZBH1?0GeHbX1!z2YTGb|=mP%m4ASe`*!{XA4h@ z!C|B(7CSB&tbA$tVfnxuXDP{?D2pJi`c3OiDwl2F826cs9Fry0EwPjp^(-EE$1cTG zTZ3}Bw3g^5xgj5Sb70C#PT*+&nWH63Tlc0zr|(0d7F`CvthaT!Ln}Q-jit)trGu}x zZ3j|zdO~a&7`|9ZG1jWc1&5TcuyA@N<2u|t&JPBNH(yz^nT!k!biKEa;mg^g{k6Mz zx{8OSOSK`l0%N^VqKjfym5g%SOhmkVq0jjn^|O90sPjETuZ=`B?x-Rmy)K6_c-!~v z4Sv0gHun6TF-mL;?B|b_dc>x;(a95UHX@Fn$ycVKd1s&iExbLeFs`$<`7yc0AIFP0 zT+{KO`CXa{KFq%=Rb!EKK`vw_k7dTr#VcFe>eX}Y0O1n#GMh46-@36iTAF*}{WPYR z#I=L9Q0tKh()^%W=MF)QPmj0#cHWEj#0dJam=VTuZMpc_NYrj6EU>(csdl$+LX}|Q zt0Wv!=Vk{+;6~BD+9{(Qgm2cprZJ=4(X|Z$`uv)e&F^RxAsoAFc}l0VKw{tWYa@+I zJI$nntmqDBHq5p%%Ny;xw|FvYC1t8PPuMYWP%n=Z`?U;4^+;;D6zjMY#|CJ#3!O1s z4GN*z6O&N0^5W>>xQSw!p4ekTEt8w$(Bp_`9?`fp!@`O6v4Dn{yDQ4oFSm(EBt+|n z4|1VvT{lSYmUZ-<2aC)2@94wQpZNIiG!@A`Z@dAmgE9G?fhMb9Xu9( zh|!5BCY~A1)I9^wuX!s#MU|Bh!=RW)8`koaT`htxDNugxT3>1#F@3Q_+T%SI-G{)M z0Qs)>!>$>zVzO!Tf}TqYK?%OQvoizIhMUTN7r%(OIp|5+t)9;I56Oixsf3gnxb5i36j z7ou-dz?~Q1x(2h+ERkI)A!zUc0Y3#(i44$0={t|D7!Bwg##~RvH~UW6c`huv2gk_; zxox!t&pe(8IJ2MOOOaGr^tQlgLtzL)M}!@79me}nu-IVx>UGTtIYpgfSZ&f}0fXj# zu#bh?EI!kysmWwIYN%G~dnU}mvrOACFUj*vnD;OuIOM_lJPIFVQoRHK5VgEbj8 zmuBZJ&BRzC4R@07d+a(ch?btYZ~tKZI=f(0Sri(QJ9`dZ`JA-qyW{8G>`Tb2i@X-1#ltvnj2o?}`i`c+N~Kfi$NcciU9*wrqk8-_tA|E+3L4yu2y3g1laVUK0&+WI zaCWmYDTwpUKi;B3nHV5AemLX_0|VqIDk|j9Xb9_xKTl@IqfNikv^xFq)4wQ8PUfnv zZhYc4@2Oz3L+GJ4&J~vonbFd`o9yM=dRyr|cHon+A!+(H=;d5u#B-wH+Y5I$Y5B>? z_Y==$2g}^2w(c!;w(Gi1zo#`iw?7a(h@W^)6l>rq3zw@^b`&d@H4=nFyiy$!P)m)x zoDa-yn0Fd&nLwf4%0Xi$i#E*yk+Y8Z5k~etDz>@Gvb4ZZOpf}|^%->VtMD=5|o+h^Q47A>_TaX>4YDjuTW z2ezES3^0r8E2BZ(VkZNY^OMIw4Xe`VZTDi6x*&RbFr_oK3gUm{FiXBV#ESOGTM)8Y z&F;4ZA^c( z_o&#*R#|<}^G)5SslReMjqn)Enn7{3)i~L3GZq6F(*TF9jlO3pc7}KGY@ztE9q)pf zp~Aw*BdqAyhp|&?Idj8$1iunqg%0sbW{mQvAB-ioE?Z&3Pzwq1{N#|(g0mO%b=Ufk zWG~h4Aa1Q>(=kO^OdR}M!>$U2qgLIay|N#}rjII(r++|znJ3eAp^YV9h)+6Mb>cu` z@9sB6| zjJ!miJJIu!ki%`OspP~89q(dI-$B+IBxGwb8mjx91=J~B;l9>_$lI))J5!QK>63Jq zWl5!34_kl{xdRJaFkWx_>`je@y{CF>8hk5V0v`6+Q^G%uQ%3JP;=_fq*zG>EKK?!N zJuhzHT@`#UZZtThAMJ0%y6cjKJ7Rl!Z7zZH26LC-Ad!_7P1M_nz`C*23}0wUo45<6 ztWTFj+n}JWk0FmRf+`fo4bEGiPN}xRVhNSniqY}m;1h5{nGo0{9&o;y0^8Bze^%l8 zr|p~nwlBgM9H2aRHq_Rg2pMOebMCX#g2k)f)6(g{)`e&iCR9K7EpSj@h~c11#3rU0|7krG`}dq29}U|IPJ5=g zH{BjaPqk#vITAK=4WCo;Fr{l_9N67bs>!wsZE>9f4jy^rqL|WC@GL|xmE#>**|&_f zUo}IH)Q9}6GBBAC%O2KTZ8+%EBD2xAQa#B=HBvYk>$O0TYT*Yq-iIz3mSUMu)9!cv z!cuVZeAax%?3p42FLq_^kM9yYE;bbp#NALGby-$T2t2-eYxG*V6O7k+>p>b5C1q4- zs5EYjOKWSe<%P>4F@h)QWPV&|TkNemOv|e)&*Yinksv3uxc1U0XLp%APG6bGB`&pv zEO4yNEpy%wG8AWJH9vNKDn8=5??PFg8%vJgjano>Z9TjBYeGGyq6$YqGc6c!x{eItXRF$8AkDQq3_B;0DI(^rFNI0jHWmpR zO3qeH9M0E}9Iu~~`+1V;`xlj0yp?p^2QhT!3B1Q8rhZ0?ont#ymvvczCh1YsX{Be( zQYYZdjn|Y!tfg&dVW)?_GAL4)mywgI$gQhLj?J~3p~lKD)s;ihVoTC7yp<6r5+it_ zmP2k*O3#F@%L^%imn=GmGU>etyc-G{9h~Mpjy-%lk9Qwvs2wzPM#M_#5Qfe-In1U-(ztBL z3;dc`b@uL||1~k@>@$4vw*&)&kLlSP;0pz#TNNlZ$NoBN^#Wr6kH``7nAc7sr(n0$ z!RLD6eJEz&JSDR(FKddEk_oy~wwDJw{~u(XN@-uYTzHP^%HZptzqilxe=nfi`-isU z#n12EKhtPm(thRULTwyeiOA z&o=NB$sQ{a@9QmC)v)PMD${g)cy5zm-vM-6aL{6;pi18tXvTh1tM3?y_CX58WH<3c zQG#Bk3qZ@z0G;cNLXX*8;E=l{a9iU-%t8SNHVJFBnoUKO%7!t>U)xrYR9&r{4|c5S z$U2qhqr=}W6k4x+6CD0PyzE(5X?UegKwWccSYhSVdt;>aBP5A|LFmu5k=2*z)`UIX zyJAwtk)N@Xfq_>IY0-8RlemoU$wo(aG%xvlgp*~CuPUStMZH_H*t&y!hoE_Kbdp(d zAY|qsEA&wrE9>28QFzYo>ynRX_j-q0v!6TKok6a-Zr7BNX~9L#H2GuI=iNhEQGk1LN+0v9A9&M&o~k^%@Wn zvS&aD!4<|wb9!zaW;CZ-*0~IHF<~x@S{z4Q1lguM!-WYO`3QV8dlu|PI;yO=3BE17 ze?v~&d*uk&uf}ZZd3b}`s7%w0IVVNaK86{G@g4>WcK*zJm9s3sHITK~>~g*;+JtPV zt~oA@&Ig~8v& zg`7D?qg~hb(3gXk-uPsM*@f!H8*h)5-?YkRoF6 z@o&#;jHonXG+vNuStj|S2&YW6g_rp&IUZMP>7Ic1GX~!s5836!fjeeg8O_*@*v4VI z@wfvgx1W-t5OtCQWnz6=+nx4x>?8|(=w}whDy8mviLLc*>mSRz!34R7as)qxT^HQ5 zmByEa!-GYGWm$ISHB=&jv+Om}>&r&%ZK#Qr@p7l-xVlAQLy^;QgrI>JQ&|RQh*Vk3 z73yBTBBy*T*i0FlMHMDwqt)s!&gmdyY3dS zQs>-VEZ-SO)LlQ7h&7vSdRgc_*!fiTWicm4V3hQIa#rp|rqErH(=0XnYdbSUtt&5Y zw^Ug^HF6L%ecO2~Z^y2e*qq)CEyxJ`w_s!!~DW z%K6(0_kM7Zw>gF(8UJwo>gi?WMUr4{)NvYs%)Ew%zDHsBSQ7k zboox~N@l)gj5?<_NqMjq5pMhgYgKwN+uJ){0qH6MC$yM*AGUZ8YYrc&IRVGzO=R7a zK@FF8f3(g}=cFCWCw<&;OvH-6EVtGc_I}*ggjPXG2<+PPDbtvycXDB01PtbyYt9DU zmDLCry%yAqy++K|Y+fimEqxrbBXzGz&Qa?kQcUK-O(fQ`$vFMIBQAR)<)-ZJrR_E6 zv#XKwl>xgEmHXRMp=Ws=gkap4V~fw(>5zr`*YtH)F_}h!y%wmcTc_ zVS{Q}Y4=T$fVZMN()G($rIyLr-WOj|G!az~eqc{-M%qw&Wsz5)e(K;v;xbHzRI!V{ z3hgQTlGSAU0QYvFur@_gPU#+dr`EM+Livwmbc)$A0=m0*jUF1DZbYnNuRY5U@nrXY zDyhYGJg@#%;p-9CYm>D%RYHo7Vs;w8$VKak6n@+7I*Lg3&OlpVwdh_Z!AR0)N&Mk0 zNiM?ck@Gj!T!rN`yoN72Qu`xah2V_DQ&L6Z^<9&;5zA}WC6y0i<{1v)rWA+r)7`4$ zuU4pU-*hHdpy) z6zu+}>din0F5Zydt~|aoyU2n%X0&<3tbA}M^dPk7g%cAle>uI7)QKXv<`16pa|-I^ zM=jZ{oEn^3=j3CDVT1biTjvAcfXLt9{Qg}}rI-PzwNl9mz!BTe4I_z0TQNym2=FrozkP8dijaU5mj<|saK9=`Q+h5{=vaU z>7d@FuWIyus1kKsqrlMRt)Ueo6^RQIk$nhP!yw|To2+OpZd%h4)Kt~-(yA9{-*cDb zfhXDlk}Xc+z4f)_&k3gzlLE^Ur8)b{=~_9tX~$GEU{x#L3T+m2D6tf-r@zJmtgQ@7 z)G<~$tVM~Ye7L={I=smubkTBV-IVb@85y$)m8{Qi>S{tn@tPGZ_>%@ni|3?}Z*8eW zWWOv`J6AkF5tavuyQWQXB-8BcA~Krk7i6qFkOODR>?e{^jfiV3sB^?E5%>l_?(leG zl`_{BMCU3Q^a&tUU60F5;VN$K8qDPC<7t^xrWVPw_HW-!xI3;@?c893549SGShU?l zE+Awq3@tBv+xgW3{1 zXB5!BQ+)8St2|B=eC#b(9S`Cccuc=+dg(WGEFjW*64m7z3vEr>M)zgT=Wyh|>%MSC zl0GdYk}j#+L0o1_W|YV)l1^t@UnYpwl0Jx8hRd%p^=2Pcrq=M)GU4!hv)$g}^by7y zM-8>eV}qt*?}@nW;bPS>PuYkTqz<=%n3C^SP>*rHk*R={&yZec6syl=Wc|?}5_}7} zG-KOqndx4O?!ygQED2qaDsm~=&T+>engE6rJJSU~b^u>{RZV=G)6R{qmi8Jr2WhaG z_IuJm?Rc;_%Ut$I!2|%wxb8sTeE_&vU!06s>0iTQ;~IS7Y+nE>cZ57^_K6fu)lQa| zd_D~iP#ulgZ5>?g8^qH!?few5T;T3=xuNQC@=Zr3ntP|X0Vp4iAMdjhl>NDE%I`_I zS^h&*N=p3>{l3`;V-d_&#nIa_3HGp-c^m3`FX#Jj&1`OlS6CyfHP;OJgYlZm zX^|pz?8K2xcXR*SYliCAk)37nuK;SF@f$>TueR}`+6w#akNxpj9*igS#u_sQAMnvp z8F%A$-vNN>xin1(f(O-0t>5E1T-B`lrM;Ng0|4`vn36BL`^dc6>>`hOBs;KOA*=ehYbdAJA$=7cRkLzFXW4+J z{X?WJ&Wufgv3!UZBujw@a1zH(!52KG8iY%8hZyA_0hc$~H5g~!Q<=X^@1Ybt(KQ(W zfG32w>MBcYlfue7_ZE#de0fjPB?An?!c9zIZ; ztQMr!0FW&5y^@1g1lc+`!-1(gOEx$v{HEI3yn%Fbw7)Yg*mua_?_9Aa!c4>CHM!$% zp90QIP(ZefNGF(`n_wY+2uZdj_DjCB*+uIar}zdd|ZI*_b23h&>c1f`a#^Wfpo}Fc3GQV50!qZBNdg zi=XwY(5uV{Qbu%W#f<5l%BS;-W6|cmB)I{cF0D>~!UiJ8Qi{wAppKT_OQRK{y6d%l z6c`E2NDt27YL=GzSBF)Tr9V9rO3mN^PH?c8Mz6{BEu41KXV%le`MZeppGfuYSp5w| z!&aG2{;2CSUj2R!js^2d6@bNB7b|9*Es@RSX?GQ1%9a4qmtA}*o%+cGxS;^V_IuA1 zSRyhG3+OS}=}T{9DTx8}*zRj-s*z(1NK%X_TzTs!IHc6A%x{YD{wOR;=BXRmf7a?W zDHY^aAn0`;Pw7C+sNWM7)uTrBK6_8o4eL#bo~J-o|EVNz3i2^kb-1R>DXuthdyFFf zUBsm9z(Orz($~YbBjIh&Q3`;T|CRZDtby~@)ZsVdI2ajN`3r~B9z0W((b7;kejT}- zcoM9jmb?60UR}@jU34$G)Td6vJD7h8ELLl>rwOte^VdNE|D*jz00y>xq~UtHc@^Zs-k~!ioyMURWaxSuO3<{un%OjQ zEO*S>wTu33jwtkELw3XXXuIbrN{OpbLPzFdUZrY5@wWpW&DC=%NY&Z!f|9RkHT%bp zmxXN!l!)Lf7|zf}x4wf`epd zTQW3CPt!{m8edPI24r;Mcwe!^+_#F+u7KolbmONz^pO0~m3mXrG{Bpm0zfy=JOJQC z)ycpd8SmIb0wYe4fsj22klY%;;waePUlhL{V|Yy$IrW$_ZYeli0Rw{pMPvX&om2wI z6F~l`LZd&~nIYiL6%@Hn!i9cqX^cUU@z)n$r277q3_)T?WA!V6Z##kwbCirkV!8R@ zGHv+N`^XKqKDQO1G;~=~s{h7e^2&U7^3&6f-@wbyMj69Y1Hl2t-S^(om^M-{O&sr^ zM?U=*Ho4Xb%3=YEkQh)WEf4*(G131H<=}tgiLRR^4^+WVdv0ztd)@`fHP=N{IH4+Vtny=YAfPt@kM|ARJq@k7E&#^{U_?JDm-4*tt zSdL+^?e6{!+5AV#DN2Y5@{OG0=8!4=ecxUQvg>>zQ+s*Hw9Vj3JtcM~z);1(TV|uM zp+IfVd%x#N_pa$2FVqaMHP@pU2YqD4*R_rL{j-M=b|?^SM9T0|#ufXI+DDsfItc+I zpzPsa!bx9bACgZ6PQI}r{Ib2mK}=m;894Qm|3er1e_;vyWgOxE+@>$)y| z!!>jc$~69}?f#|&2Xujm7e1g+rR)X59QCbG0!gn_kA#+d1O=yEbB-|Zw5(tcq&f*6 zkfT1DviSQxYgd_b}(ggu!@b24U@G#BbM*znueD1q5 zylm|}9Xd|mmdw8i3`t)rrrPCpceR|No@bPRI670pe}^DQYhe4X-q42j=wIgXn)@77 zD!~c#BM?H8TVXsa2UGmPNNL!LD7eW5+gfP{^dB+PJY99w&|p zAFp%szl7MUwMeS6QO^0)opL-^NVw_`qBXV5w$2bX#%*-XXz~0i*Q)5vhJ>rkMDw{yW?Tk63J^6bji!N;QVef;rKj> zIE&lViqbLpAy3*yly6u>_|&D?^Z+DBcrf23{`S}c-B|r*`6^*6WaME$1XF$GXR2(M zStgu)E78f}?yxo&W6uY1c_Gr<^>QAUql>~icEODXn;tCEoEXR3>Afv14Y20M&^i)h zEfxSx9WC*11F&TDhi(jYEH5T&fGaAUOTQdm%z@dd6d5O2%*#dJH+qM*#@(%qK;gB^ z&UHX$shFaH* zi`KVWj5ZMx0(uXB$U_P9asuUjDKRbU_X<3+15HMtgF znV9{%X4^~m<)}k(Rp_y<-7PDE>C@Xk%s;VBxOqxErg&xFkXA!eHUcbPeIA_(Nj6a??&pxU;3h0$)uDE%`)S^hm&Oe?_gFd?Xvc17m3MaCW#7NTSSs|=I6ZKH z)@V4W9{H9ogDPKhg5ai7v5BMyLookn*aO&l(B9ajYEJ9a0S`xSpgm zE@~MQuxnPVQ5qAVK5GcTpD#aQ3>a%4qn-!b1}(1@zJ2fQ)7GRxV=Dc)QbOv`=KM^I z!_+PNAHKKs=^n1))wa2%*<(*iW>*xLKvQAO$4HZ(e3kW}J)vOjW}4malVaa(Sm$p) zB|JA!y2MrZ+++%@oZgO?e5A8BrN%o?095MU&4*fIB)M=7Zuka}%mgA$jq<3|o$$s2 zwsJ0?T?OEy#owEW_H?AJ?MhfRdznVhqGY)#nARg)mFpQhRtx28MrHl;l8r<9iR*Q+ z9h`TaWYO-kx+;I0llfG*3^WA8^mjMEf0u&|qY5~NgF8#rfQiY7C|{p#Dr*Boz{Qni zHM!SiE@flInRf>A%f^}=n$q9y5+R=ND$(9M+Tq8y6c%k4f@I&8v~Bom37*|v`a0`Z z1wwi5-R!3|HGknd{9qo%JCRfV+AFf&tNi>%f63>eV&Ke_hyjnE$;uL&<*cV-Y_$i+ ztGp4N3X ze3W}$H(wOjbS;2~Qi*u>2ZjgHw1D_zQH=;Onv~sch$O8q@;@Z*@P`S7PN&|jnpSV1 zURK3F9ZZjFU27;O4zpAn83B5xsZ+AISb36jInjqIOND|Cp@!w=YAmC;7R!t-7RU^Q z<%+@Q{RJ1;JKoruz0%`ZQQq(2WDTf532%R;OD!$6YgDLz5frQKd<`^s__q za>2){@90;Psy9t;iAuc@A-)Nx4pnG)zyQ_C*+YgN{elejJuf(!xT`(r;kJB3fOf1o z`=mIeaheFce&%${19mQzT*QJVH)mhxgR9#`D z{_e=?lgpj+_3~<)R@JO%3l6x`_2IPWaA&};27II4}9E<@wJA+memg_tua0923dfA+}UP~e8xr^+})%nMDH#?47-RTMxX%_jA|Nt zra|Z`2^+jHqp)~j21>YBva_}oEtf-|e(4R-!MAU`ICIBy>uHYiL^&IT!$He|~m14@4pfA;$z`s_6j#!U(G1RM~+``L^A z99aXL5}O_!GZmWp19EeLz`lwV@$nXiAo#|IBN0yqJaU!jE6 zRJ^4ws1x@UdhtwiJp~$Kt~Cv(07LGqKAw*$)T|-Pl4RX}>#JlY!Q=l9fo8w^rhoC( z{_jXWzVdS-1afqi{JQ{ucgFq;yYu_`{Qsy_|Bp)bpZjfye}^CRcLXofNb2Quas4ki zXx0I641i=dMhh}W_s2)V?<)TGLl{pOCpcbbfk<@#5|RHWd`x2MC$hVn+4FQBx*PwJ z&yP;#l@4-FO6}EoKb{)`@B?KZ>M@sDP90%QUgT}~`7#UHp?$ygDhOT;><(U;<~~7g zD~vPaF_s^4R+R57B1-@ z1UQTa55m5+tKRfNt}99>Jb}ip11CK-agWwz&G5rrPN)qmxc{H!8nKE+ChOy?pa5P&}d zsyOZubTtNlMTee-O@^8_hUWeS@S}x%y^N0`Q)2*X^cRRv%4F5zDqw4^1fXQCYgB#Y zV!Z|?Co9p`Tf2O}BX?1a5aw2l_We8=>$XwC4z={`U&+#p;p+OL0$4fU{~YE)Cs8On zWJ*ym<=!%qDtqDbDg^`D%XmOFB4#N3*q0ZOen3aE$5{>)HJBS6OZr8~vt0tIm#p%{0<2iDwHn@h@W`S;s zF;`{PX(OZ5>oqua-8JU{CUurg-IL2u<$IW#t1gD@d;BZ7=h7=K{uJKnI(})Pz3n-R zjXuN(5vxTdQVdvO0FtvjEw1W7X+jS}W)xom%sG7xkH7WFg~(3E=faaRJ5x_nIA4JAL+LdyVC?*w^|eniTaxJ(;O9Kqr)YQV-9O2z`KQP@rd@#V z6XZ=zAypKsBGKHZ$WZPVn=c@k2Z{X0B6|L%rtB~&&&_S#=B+=s|8Q;78+JS8>@L@S zk%#I1IySw$Z^MP!-hA+1#(EOC-o$KnC#wob(mOdDY!y%|VyLdaI6*wI4^y(}ca7>) z=)_f7x#6d9B-oaI23+ogVE+O-%{8#Ql23fFZ=Il``Y${j>wQivR@lD&*^TseTDdva zSL1LM=LSzp(OnSfLxA5jUG545sbjjE_vFds| zEdVZTBvA<@Vq${(3Z6h{ceEK@*Jfkq)_!=ZrMabC7}2}!J!1tl(}t$FDYX|P84o(x zHI)v$jeI2l&-a&>YnByyk)Qkt@Q$&4eb39RDuQdk!jviTI+o*%g2aw(6~CyD82aaMGUs9S=Z4c9#v zM>C}AJctLm4C;r~p&Q-H6~+rZ>iXZ1E6!3mUf9}NO+!bkat(vdNsm-RQwMIjyW>H- zb3ebOOPZpwLcDybJd2U zhvw;juV%YcR|jQ!5id%&2lZVD4Z9=1E{vk*M5U;Z`hm)xNEAsO1P>KY{jydF)HP4R zgi0c?`Q-WHCq`FRl40ys^O@#5U*PA!hx40ITjjrw@64GANaOWykJKiI|M54)Otr{z zKNxj>6{;LLNOS{>Qi;3@XvwR4Y#X^ncPEk->eQyou@2_(Byg~Rl?w1ZwCm}Zj0LUrfA>Wl-OcN!7q{O?5SZnj8-(*~DDi z;g63!93~8W=MZdvA6kD`{t9@lOF(RW65i}O5VSu?^@Gl57Es#2OKM}-v*rlwk~;|Y zE4F&X@@mVvnV$UXET62lUt$p(^bfui!NH?xFs^mPb1*L!|3O9u2sLH=&$4B^EjsLi zg>fz`fgBfzB}Y5`@s6l?qB{RV)L9@u~#5 zogG#6KF^H?4`sTt(%U8Z5z=*LZCRyT#Q|y@n|P^3p{v6IHk%Jo>xqM(7GuA&GU3|B zCOrjh-pm;w%XS-5QKOlQOzeGIZ5_&V#6?8JW^Jpyg!SOSL5%QI1QwrJN=$bdG-=K; z#)YHBl3#7X2=}c*qYOoyvl18B3|n2RuQ<=2V_ASc{>f>{hdA5!-YY_YVZ5h&8yk&HaX_ z@sT8I$*7Y8h!0_o)G~~n(w@~3{4~j-I-FbU8m?nvBI4it`G@hZ{t|ehb zmtg{G%o-U@Y_18yna53Th362wxn-T(mCurwP?D3)v-zjPGtZAEnzwExj&teiF3^3H zr5~%xdet;J+xA1$y@cJhK>Qj~s>{4PxITP(@Qy+*iLh3d?G|46B>aSX%< zvy+d~76)dgNhEQ!?Gws=#^w>#_dKmit=%PQSi~Ta$RAw3pz&6nQ;W35l71T?M5=jj zPbwH8Tv!zCs5N9HDoc@!G8gFADgo!r>Y_D!a0Kz2xp9WP4J!slbX^^l&k(H(n7=p8 zW-3SRi0>9$9SV$OP)xpiK(BIHJ45$Qv3k0En!}S6_1PQC_aAcg7Ymj$DZ21vZG}W% zcV#u;%He|>fOgpe^|kK?_ipyLM51EzUKm;iM;1UOvVBr1(apALwi4!`lW6~=EJMvt+$AO)@sgOT?FNtgT;vHtGz6NFgA?pw@L|Ol^zOL zwL4%#2(Zaba_^%1nAhN+LEKCopV3A>i@V`PsJKX~Y-yk$?UW9h_ib0E14~2l7#5M1 zQ%D-JE7M=(p4gF3T%Tb_-4!C(m%6>aA!{u_IGyDS_?|)FVEdP8p#Qy2_J3HJe$=}G zJCY~4AhWP06t_F6El{pzF9UtlTP0?=^{ys=$CQLcw}Kyr%5&t%p6@N)Iw3{|nV;a+d6O;d2t^YPqpw`MLlq;mmL3gM zSJW67aC3x}qqLT)qsbi+Ns-(6q)B!45?!0yTU%iXr+v42zUJ=?T@HAx((gDu{f+s6 zEink?BeD7DQRUOc{U2YTv#Mg{>~3Rpp@c}sv`@r7)Sbm)-`Sq~cBkZ_i zg3q4pV2*H0+F#ecHDU8Lfge=O{)lFBGmBhVw+~9(85zDunC_@i6gmSR)#DMqaJ+9w z$wzL+k%7|R&(3U}?IH9lt|lBXn<6R0rKyk3Y+61Iqt}=ag?E^s@t{4SPARyFm;a<6 z`VL82Zri!!v3>TCA*K@=RWQCxrw}9c$#yBX_YtvavxfFbEEru~Tw<0L=~8rt0yN4! zar3d08_3|Z^+?mH@yqSo?zf0Sw=z66? zV)fQlSL5Z8k8hipEnb7Y&TE>RE0;aaT`B-yeS${L*Q3Q;l|D{JAQq{Qdx%^TR6$Pd z17ANJdgcMXqq+Nb{w0sYo!8Z#HBcl!|imSX1KWI7{9jJCQ&#fRrugqKc zWBYDf{@U){6@J4C6)?#zLQ~a(x2t#Ugh}76Y(1R)EkM(sk8qpRU|{{Qm)<8xzU^ 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 46026b1112f553bd5079d6fd56c7b44b2151eaf9..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 11296 zcmeHt2UL?u*KiU-69fbWlonRXx->*m)?`CqNoT&5Rk3{vPhE_ z1OiboCV+qf5g}9qgkC}o5b{0I-S^wSy#M*$@9duQpZEVChMbu@cV_O~xpUj|JUC}= zvUA729Uu^Brz!Hp1rUe_0RnMN@Noff@QVex z;0_-?41hQQ&f}uzg4J`u>0yCFwZb>L0N8p!(Q|PDxnOZFII0VdjnxBT_4KeVdRQ!g zNX1gw1)Qg*pnz0RQ&Ug_{89=?K%wDWKsXmY9552=g2Q5QI4X_`6gG}c#j)AI005ga zg7c7SNI;>~kZ3g&pe&Mr>1u%T9ZaH-C^QlPq|rz;;FnFQDWH&QC?pbvQbXZ%(kQe= z3IJbZQ?YtftP2$f6f9>oDjWEtve`6J0gY5cqX30OqW~j-$rfpgKw;C^?1@OfMM}*g zg|tWm3T1H-C_pEBk&IBApW{^q_z+?Vf zNE?3;NVbvl5BB~PXaoYmK&B^-S%zfH4lu7v(<8r*fCJ?p>^^_NxZuGF=5KFhuZ>+U zk~~nqME~5dz2XYb zKrsfgBdV51%o|t~wB7cWYj~U{+I)U{%@B39$Mp%Dm%Uxm^wdoVHGn>ZN#o)jWwSPA zKf*m;HVv__uJ#7h7Dv8Ggm1OY#-}vgTEC_q1@b0?=VGz4J?A>+k_?_h3xwc z?0C2i!$=j}djf%Zc84eTsnz@*wq3j1nWgaxqB4OsS*bb1TBM(WuPseB5mQi`OIt^t zQ{}b>=#&?Pt;uBp_{PbyM@-9VJoYYb@>W^m_$J{>#QLR8r-toIzGdgDw}FS zvK-2Y^;y_x!+kr+y*S<~yD<$@RJ3`%EZJ#getR_g%TCnf-ZlthcE+UdID@*SYmN?E zyxq-9*d|=|Es9)ylASaJ56^5-W?h@5r}P{OZz0CBf7>eQBRrUDqF6`HPV+CnKgN~N zq1$yJU&}_FRb$60%dpsY7;f|N0NP%d2wLsxcKT0WUEth zVwpUQaG=9=W01ZyuTp*S;Wa{a?e;0ezG-!crsGtdTbzP!-)54i5vDcPk=?##IvW{%}K@x*FOEfJX^R%NjU5Ko4 zxbKu)9C>Y{KHj@Wb+t=XHQTaE@6x;kHksIM9prNnk(_Iao>h@{@Qr$(j|0o zXolJyAL!`nRJ>&t>uTu1O<>_=BX#StjYhQ(U6)CWwLL>sS}=-#??M>F(3gyP60S2< zaWe9kVwZx5<6&zOiOoK?5B+>_1O@i~Wo^op3m?O};32I9B2}XNb(r~QPj^o^Pv@17 z5iImm_CWorBzcC4(n61 z*1y%E*9a-VRYn-uuE}vtq#N^$#xNBYXI7o!UX9;z?<{Qa(n^WMACc*4W9K@aRbPTX zq>7hs83YL;{SU>Mz4Sq^<_Mz=Q;USj5fbLQeMIPB{~d}rKt<8n56m1d;B1_IGpnRtn=4S)kp1x=kX^yrOATxjk2|~Fy4yh%wlcy2;qy(yB@8!|EMX^cp zMf~KJ;b0+hXY>0di`7~oXRG8>QSR_ATwG|dxbkYrPULmF{IL~i*f$Kgz^r~H^70r_ z;F3ejrkWPyf>~tDlCFVQ=%u68z+s$$yatiyRqP*uHY$* zT)E2>p5KEV%Zxdr-|P-{E6Ty0JX}|F-3u{g=L>-t2EV}+wS&+2H`NpSD>fpRF6z)L z&N0`4!<}XZ)EXo9g?l@J4_N#p#FKl)cly#4m8<+pOcvA`r&dDi-~?6$kxTFMSaH7=WmK>D zQe}$*!8UsVo#jcrTXg`I8FZ~}O_gF&+oWF9FSp$q0k;bDrs6PPXE0g%R}jgiH|y%3 ziZJ+B^x4eS&i2$5K!qD*$7#u(@abEUB!^Q`A@+zCpF%SfaWShZC9u@+zJpuAJ9XaA zJ>1TvcP6~R1wkh%?TvjSu#Jc)NAX~tg7%8S%o|nvu(74epTu|tkk^H+mOyT^kJ`q1 zUoBQodl%U>+1v%MOhen5**g)8r9iIK!*e6ZVm@D0%+oG!N9*A-%&<#J|ckZx?S zJz`Zawt9@l5cl|H;OrB;AH zCHm8aJND`dS0u3Yz&USAsDv*T?VFkrsPO3zkRR!B+|HL9w0q>stdkvR0Is$fXM52* z$Wy6rI^5Hx$0}{xyokFQJ&tA#8Emh*BS|0SG6yc+I^>9AFE#g6ELDh0c=bq>e+miD zb=qNvR!JNqe#~NSeStB9lM<=bg*`_Ti zaQ6V)N-0LgD8F>1nu5OX*UgN)gtFOLQ4`lYZ7B0~=1fe=Ennm0QwXj4EQE#hFEC26 z_GwD?d`)jl&%>!MfZr0FtS9L}V(Bu(Tn=MWkokK%ZdekhthAVLN zuGNfJO}%HPy^G)7dq=2NgsExk^&7${vK2!bcTr;nmBrVYidURHnDDQRrGf8i{5MRu zkBh@^^G&uh`0RoK_9lEZTf;(esdr|8eR-h!MOqE2{HtSSEjEeX`LyW^{<&qVlQ^7B zE1h!u&8(d$wsCX2$ek1$qfxa59tbNAzCKWV^rqC-x4m9M-rU17&XwGks&HjDQz#8hkj;$6si7p+2L zg{2>4fDDJKMqZ4KX8=&2HD4~w`TxN_yT%4Mf`9u3$*Z(~973^a3#JSFGe zGrw|vQT?8E9dDt<9SIT1YIz>#F-adsZNzv7<6*Go%FP7`gr-HtsM@D3CSHf92DTK+ zH3U;k5F3ZTuj2x!8TQnjZ+f?lvS~Kb?DgTC!feOzADuT5ARVoL#Si_n(<-zZd-f?v zR2c?};^PC!Lm-Iz7?8+Me@&D8<-zu3W|yjd=vY@^JY2WU!ONxy15)s&oHRu-RiLwnGNdGDu#5Xiyf>B<{R zs^KHowvRa^B%5KkS^?l`DdmmU>Q|muK3*(mtj7{WI1}i6w$MH}u3y5iIvhM#B?#4x8# zYa~ITFkdR+>`BA(o>+ZfQJi#o6&yq3P&83gFV0cmUnqezv+sqVv0$%Da?`NPMS ziTn)!b>{E7LOLpL6z<$5g6ZbgP}nVkDWk4fDOCyk1HD0+-Y=i}3qr4E;0D_xaRX)J zvAoIv+)5w+yqhXDcJX8`J+(X6sFaN~?qC z4+P&A9n^C!G^ebDPNoxyQmJ@Gcu&k85zKq9jEQ`z%#w_CSF-AClb)UD2HFo?a=4=qvUNqareb6N z|8SuN$i&XQoSQ0|$(7)E?lKiHqoDntkHSLX`%DnhTwtUl2~#u~4JfWs>apc5s~C-v ztVX-<^!7|18Jz4Xx9*bwG|7YMTk<1gHk-x$G2ht~RG(zJgi=g#^_myebmS;L^{~Ul zURJ+UwQs37X8<)!f2}vj1f{=bEhSu4pXycfeM3S%Kd%H)rB0j4*$`OrFwi7*P0cGi zqrK5Li*nQ!P|gKZtExP>6GWzBmJyupFKmpCfWWg99ucf%DVGg0)DuyAPXv3S^n@ca>=vS&XBW2H z_3Qg+UWL<$FxcV<_<<-^7U>t_y~5or_Pqvya4H84uHJ{{@(Kz|{sf)`H*wv&`CVk) zk~8s)Nt7@@*$C)*;U&gmx$XB;u3imAB37M3-immoPH2?3q}Ra}V4H{VBQ?EKUpsb` z^o&2)PVXt7Vb&!!-|4BC`LJ1MbYvHnB{{gj$LA?P4o$9KILL-|5YzvFW1D$sRe-UN zD0FWk;w7kZzW|po{2*RlOyq+H?F4+_&C~hJG@k2jCX{>84~aX-vVuNjXw)L$OZ@IM z;P5%_O~yngZfD_p+Rl*15I`$wl+RF@BzkMo*M)O{KI*lf(tdC{>=vZ)DbU%GqOv$8 zBwTNqmOWxuoZm%{mvfwDgsp^rj+ZseR$&_mBeSzQ_Mjc0xh5SXx)FSxo&*GGT59V1 zz;2Pi{#jdP7{N_{@FH`X=$&Y~2n zgsTlL0nHYa90u=1tw5s=QFT7orGBeI;^iI?!XSPEG-dmz3!UzxMF+h1&XfF}_oXMY72x0Z&QF$9FeE6!@&AeN zqqZ)XzPmovC2mpBREJD%%yjQbH zN)vo-0qRWteiPn_VdW2Vt_zRFe+5aS8S_TQaUW;Zkxx+Px1usuij(j7`S_8Vu>Frc zCFvJrsV5Lf3`WqZG2JQ;IG!If|1z2Be;AN%7)&q=BbfAEoB^@5{4Tk}{N!`|sqDapfGq6iO>-Qo8H+QM213j zemXpZ<>$L~!sRQlli~XxUmGjI-tJ1h7JU|h*{|6ol!^hFINy`e1cT$qg8I%7i1g$C z8wYv>S5V5bDPRTN-?+ixl1xl45F7}dMAYsQxmpR$l>&oLsmx-eQKTFUC?_cZQ8Mx= ziBt1Kl+Z?bIlUv8E3K125b`J)6R;ol_9j14`+sg&HG+M`#ox;3NdqDcl0Mf7_Epq- zJCZ9SvepREkpxekLSR0NV!feINwvSBQKq-0uP&2<0ZD&2il2!`^X4^UfF}woC_cWo&lLbk0P8%>T>?C+=>4z( zKE8vtkj_|OsN%nQ!!vUtdr-HnJki?7%gB#89IM)z70&dgI&niM48fBw{|Lt^CRzBb zq#sdwy)tY7(9|5u+Zu16Yj4o43OH&k4m4{5h}v7T2>Pi8PrbeRL(r4YDzg%uznFvkE9{Sni<)eP)|<8FIw$ zh+_4r-)2yAvD7!#e{8h4+CSSXcvK(f;APOg>Vg~lW&V9uk3hyo+Pu{*GMLzjqMw*XH&9244M1 zMcJ>dCw9&Jk!tuO1L2O|O78(|vSf~$80(}}XvK-2#D2J2xizsaQKr~QPi62@Q;7rERCtTMX zXutTJye{`8fNQMH|93Dz5|K%AZHv52+>7U=^?;;fjIDIL6gbuU34Y-m0(8oqb^_fX zjZHe2aYK3jNW=C8Q%=f54Mwpd5#13j8h{bfxy!|9^Qh=5hXNVDMzF3*M~fdP`S$`` zAS)_@@pV7DToKb+@$HM^wD1cJ^93OD;oB#PUCCd}a&5Je`X2fNO$pH*d~d(bhN&d> zMe70t)|qQx{HV(VP-W*sH=@p6UixrH41gEP44#{s-Rbi)kkPnaHE-8vq^mZEse*B` zo`6C?>$Q@ai+kySbX@yK_Fza2zDESKgX26yVS#^<-~f>eNMWoN;z#5ToyfXm>Sg?1}rJRIcqBZf@L5HG>Esd{}uZ=Wsys^$%g3Q)p^E; zO%h6r_wl%ZHFB$GE={RT9;(1LjP&0=AEvRgtnpl`qW(2gZl{JUvse24{6oUMgz(9B zIw36v{rrLH^4(TNU_bVW<025v$O1aQ;h6=Am54HKdnvc$>THS|kPI|wZZl@Szqsvz zNBVW?P$WvQz-|J~(v10#W)Hyyv2GirwZyt!t&-Ba=t zENLi@b(+pjNZh>mb9S`3_t-^G_oYwE@p$(RlZWVDh0Vs|(@Qq8ZWZ?ymD0`Rf{oDH7h7(g;C^qqB}gi(xCaZVfKEu`e2(VMH|^ z2l&YJLx@I>iAIcA~m+_ihWP&zQ8 z-1ZJS%E)FfN->k*{PRT-2@Kg5)hZLvIpcv~2pkYl30D@=wJ+DjZ{Z>|UY3WK zj8V?qlJygbTu<1jvZG@Y$3H<5$c|yLBWB9aW|C+|`6@@^Fbe2>KJxD*yyc4>>jH&z z-FA@A7YWWYREza*$L)tTJ0dS57w)E?neFk;Jj9c$&a~%Fadji)oKSxk`dbk1qbQ$y zkB0@UPjB?h)pFz@Hz>chk2Njomprl4VjAFN0wL82n7`!7@*gMIV4SNuVe^piTNhl! zJ9ncbEonFX`4ZEpwvX^>G@3U5TkbA2?NJY9m0CIWT>oVZ|=N$FCFn&A^iL zlERem+%iq$iu#IUok!Xc-d)&@y2CGn+uw&;rA)!66zIo^R4E&+|IG;E(; zEsk+BU@s6$JQ`B<$!XkCSt23{tLuw%+y!Pd>w_jk_?qxzt5+&8pTr=?TV&ybIj|MC zt)GSxmq(XB5b6_ebkH}S7=`X{Er*AO(~kn^Cdc-9WQD!1Y;;=bVD&bAliJ}kw`Dne z4jL6@h{9VO>w_>lUS15`rf+95_|^o3gYA~u(l>YK?!~q;cQ_uf3UNRs!}oxnYeS=+ z7z~Z_xP?N! zd(wiB??BBf%txUc7WCO(ankY~J7SN%Nmy$p-;v{M8b|Eke34_ zzTD}F39ZwL?FhEdoDB)G3Xrg>8UJNhg^ATefPYaK?CW~23%bq1ht6_ckal|$QP_vj z8Cv|AJP5Y2T?)9nWS%*uf+q_siHSb7MmwP49=)qGZgS}Ym0Tt z+~XF?)Sx?xiG&?PAZ?fRu*Xv{Q9!xvj59+Z?Pg9dr`jSQ)gK<( zKXAB7bq!*c4n57TSK&~EaPvaAM=O-LwiS{P<8vM60>FgF5zl~6ow{tcULOv+-qz}R zO)X4wvz9{;BoFw8NRxnBKu~}3@^EMn%2oZ4swT2=0vKTgW7?c!>KjHfHm-Ru4H}Tk zBNR857wK%jAavpuzt@|LT_uUYg2sqfb{8|HN5w7MFh%_W)87KN-I(|ircCLxr0?A= z=`^FYmi*XkJ#rddWh;@<65l+(y;T_`Pi9>NKNtSz2KvAAndRU6>TZP*`# S0r&_NWO~y4M9J~1xBmm<_SE(O 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 a65490e03b207d511ad88e2be0d0024c199bef5f..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 23083 zcmeHv2|U#8+W#ze#gw9zX`>!VsgP}^m7YYUqHM|5Vi#kd5$Y+GDN3>>#Z!_jVGIVv z3_^<~4aUAR7-KNo|DI9LdCq&DbKbMO@A;o|-e*2PKA(HL?&Wvi*L~mD_xk>B95XRo zEVW7s0)Z?(Y;@oR1R{opK*T>tz(GvrTl@162=w7G_2na+60&#-C5fHc< z1Yrfy(ShhVL3HpCr+knMha=z!H8{cwu9gC_BH-Wwp%jD_UkwgXL%`Ln)YPm})Kd6B zijIzxjuUwBI!^gIc5Jbb(k1n;DS z&&T8Qsdy?sMGc-}1?2Ic3x0&>&&kgTgy#hCzv(%-C*KK@@1&ED2M@?j&8PD7`FxN` zkVWt#6Ug9cB9MCsP2ia%3(J!U&&eQ7@M|JB^^kie$vylg!t*9Fp{WTx?L&ZB$^TC4`h^O+Ye0~r4c@LS;(*z!J56C(Rp2?m`eh;5N80?a%WLNjYeO*{#Bqc6&*=l7b@Y|4 z6g7xQGlS>eg7ZMVXQz9a`A7C)_awzoi zO&sLdK{Vv&^?yFu@f|K`fqm3fT_D5hsZD-E5fG zz{>$b@|`QXkOYbmv~`Hw+N#C(Pgo7>JWwS`;WoA3G3SqQT1c~#Qx%v)gmn-T#~2)E zJWHY4kJmolt*iJBcA;T2l<;}P5Hok5VH-4^TB&ZJLo%JRVinJ;hZOrgYd(S+D)pNa z%|H?6`i5oeu#;~YS)Aq!x=qn;h>6`T+*U1K>xhDQ2un+y`xfOIGLRLLM=m#1%IMcNLU8mOi(%N`m5UGfIOJUjJCzIxkbhRVYYu!a6cUpW*!WDwMsuwFJ)& zOx{JiRIb`?wkeXRn4!Bqt3hccet?#Qoo=qTw}&LWUjc2^>+?L^a<%F0DTZY{TduYz z(tLhgmNML#m?%z$Xy4Cy<4#a*e^zOGFgG6tii5`r=y|ny5-0A6z zMAC+^Ya!{HhtLm9Pfq7^)S%D{b;mo53Q=jq8yrx706P(|lHS~Yk2cLahPhr<>jzCc-x%eM^=EpHt3OCSpk8v< zW8_O_htlwi?%UxIGtZYwn|*v|rh>GPwd@t#D2+4E2B;&ZYOTD@(Us-NiHZIq(&tuH z&EL(Z7k_CW4}bP$L$?GyJkLr!ped!4Hn`;q?(hm#Bttf&I5BFR>^Canz>9B>@}`eJ z*c#@Q&MIsn`I3VZbjx;u3C5`8N1-?!>ldq+6t&I~p=b2==gdB;lZ`nWRA(8fw1yd0 zFu=tX6Lolx$XSpyyLULfZLt~fvLVUep5#jr2uPaIU!Lv%&0_fblWVeJQ{^-)zcM#B zcfclq8QatG0Zi(`#MqFj@yes>cY;RxGN~m&4qd5AiTrZ&D(*Pst7igOdj-x4Armux zTGPb3#lh_K_7vUr&;grxy1tjE1sWoAB?i~FXT*Oz{Vn!sJ)JlIDbuBWW+b*WzNLUS z>Ta_Pfm78!g!Y~H^qr~0Dh@qxbEVZVA`P=opZQYST5I^=f$TX+iL&xL2s}GOS0sx^ z4Vqk336^LT;hE#=BzAQWPhI^L-F9pA)K^Ywvg^2ql|fG9DHBlht`PKTSyg>f$O(4h z5~X)Vxfd(A+r(;D+xA}a7q_203Nq%E+5*)gz6yoJ1aQ9uyb55xNRO(gN9(odXO%Lf zUSuvO%{j78Jh$a|OzONar;X7XGwV`M)EXCm^66qS>$Zi^r|#A=;kFD1?Wh@jHe`TA&0Hftbr{>f0b4 z`7mhYAQYN zSr-2g8uIGgG;S0dXw!0aygjHulcn;2te_i$MV}T|PufXi*3Vg zw;>_so{hLRy1vt!OM5W`4uOGL-xNi>!pX5B(vA0fp=UVVdKNI4$MSR;%1rK;5!ev78C1tkDcdSYKAY%NKrDI+JRm#ylE!xKopH))i>A z>{^Crw{uqra-|yFu#un?iI(WfVZ>lliM$qOiTCN^uVX470}YGBUyF!zUOFU8nWE2? zs9`TR;MxqN7^umX-RU9S^}wPP$@?uv8n(9U zXP*|k5x zU}Xn>V|VYH6n98F3{evQ>v#OWLCG2KMz&;idbTM-%mpWmxJ&4pd9ZUjf7=P;Z>aA# zI`~g0t!Dx{*+^5J2waL#RDp&@ErHry=@)Zdia6x#_Ca|epmT*v;xk)aX6`G9MM+A; zK3ttQROZU>9BQqQqpi@^R6uOop>^T29hKL0yVcp|AqmSPxf@JqN%5f0RDiDL9I+ghpHWwmQa| z`V;7$Vh+K9*R33v%SJe8XkCcLZPyXBEN@IUNaiW=TP@dJ1G6f+S?An7q`l2AVTDcv zZWs2eL-*sHzM$8yUHKDLqtzA8cGkaYn;Sc@<$=1WP07S?|8RLmM|S4rWr+Fri@#nO z%%|~Mm8{VmJ%o%skV+;3 z#qEe&x#lj;N^^>Bx8m+ykb~j~yH`u;{7Ix&16u9q0E&CX;d(VRwAVuk#%QmVg6zu% z4Y%$L19dLt8aZAN)bLa(#dz@@BXrHyC&v8(;g0ghmAwU7{z9{ymN;r?0l8apf6|Cs z4dlk0IS}{$UtLUm>4>?d2Gk}4N`)cb^v|$ z{DG83+oEwFmIiJX%q_&KZnyJ4*w=1E=DmgA&Nfy9NsCNR^=af8!}h5be_8i14rDsJ z4q5(wD@c-pN;)~kiG-h)FxtLTP-q|eYTOxRXv)g@yR{!QBqhc^L|LRgIE=pVQ^-?| zd?4eP|Ln9oa!l?W{zzR6Uca{C~RE#gD?C4xNT?8%SLDv{tF3_ zTSQ^oCf7OH`rEN4!qQQJLxNpMIFgTS(29EcmVVuSEB#v%FvR(yG5gC14ymS7YQob`tdiXub{Ys*r{Y+zJIWf02nS+8= zAQx(}Lc960^v2y#*L+yjdZIW$X#x_tC|5B4X&-P`S~er6TmNXtAN`0Pf2DXYpucPYT_o6NgfH*nCFmBC)MXzu zdd0#EF_WYmnhZut!z#9aZ&eNbK(e&N_16N~Pe-H;i!#Gd(j$V+O!8aolaZDv3p~7l zTXNYlxr)eKQv9vBXi*6Fq3H8Dem4eo8i?3<~QvL|?cq7?&vtiA>?- zQG}-K77p(QWL}k^i=k73lNJ$7tBSBOu%IWkzT(fy%fFlQh}}P1$t%*m~|y!csS%Dm@noe_*jM zZhAwEP`FT?{b#&F#PIy`g!w?npH>3pyHC>S$otLFIEac0GEPK9dk?gFBeJYo(nuK! zH8DX0mFnRI1EY$ImctvvU`_L74X=7v2~N*1Ab;YWR{kAsRO|4Uow`7md=LRCf2`f>vWdAWyr{YEFDfJ|=@2wj zS;8o-TC}(0jpL?z`gNCaw*;-e=X3ShO}nKecI`!LfGxoNy#bZWPj9}isMoHauaFZ!ft;q(<4fhM1xsAB5clirC*TRhm+AITn^fP{}bO*VuDraM4Tf z#%9tK<)!W3>!=-tg=XuKAC^L^mo38+xv?|#`r)FP2)ywgC?U|5<%)#CZi5g|;q6WP zPc)1M%k=gQ06#=s-DJ}wWAspubHUv#6I{Zwj=16sWdgA~LCJ+@Z zZPb-G$hfX0?JgB3EddSzg04jBt|lf&Fb@%w7OIGrrp#I6GfjI+2!7}cc2Gw|!%Wt3 z^kYfTkpSorFg`e<$LmEz9w{TEF0#AZ2swH)HyBav_@3>G6P0T&V3EQb)2 zkT|A{T!cV8Hb$>NBGGZU?PxSk18RrEK^$Qf5Gb_f_X7X$D3$rE%3#1fWe9;lqyG}N z@%Pyd?(YD$lt_V%BURktfa2O(2RCrs`@Cd8-shTj^3FI*;c3vZe!#e2UT{)0iev1F zCI}CJC;Efxg}I|~F?)W=3NcRn^Ek}?8)CicydIaC8z|1#;fgGhUVPn61^Eyr0n3Ud z^ToF4xVVwHoZ;vcekUn$km}G9$}bO|ZEC1pHn1^;t9dC&+44BQ9OQk+Dd%Z zE1oB6va&M5tv#rlWL5OqgXeCDPU|isaEHBN8fxZi+OXPvteS|h{+UT>N?@)jC!G-< za&fMKxcOa+yn=kYKrI0!E1O|f{8HpWr)Rb0`m&d9s#b4C+bHfg2y^i)8>`WTtne8N9EUbA_ zJUdLjd=ol1Hb6YF&9u>(NP1-uI8-rwg#X1GDFC(`)ZQhF$DwfOl zan|#rT9(0cvN^1&^!79Cj_za<#*Vo>=|FNqD1ke}z)p~DAJ!Q>TW`h~EKh8xi#{E_ zt9UaTb4W3Di@3weFLkzo@+pJX53_ho2} zzOo*A!|Pi6NUNc7F@mgl=5i)3ejfC?AF+!&^JLhvZh3c)?m`Y=qFZF~^kC2O+<2Dx zeEjIiH5vtV3e^3dJt>`<42{BS?P*k@Gr8!qb{#H3eA;Zp>%pVS++ihsx&$EJTb~|3BFp}!;LiG)?KMb;$4+BOSt(~oORun8qyg4 zS;z1A9oFL>@LG9!bnoOOcLP`+%m1;Z^J|=OWx4l=Vo=^SPRlEdq14gQS3x-T1D{o6YP_U%|PXee~UOF;*X=WSUOO9|+KX^>$!pQc3~>{TH%T z_E|vZI_V^ScWY~_w|dEZt*85-0?MYX{s_vS)t#nbSjwDg9rS*?W|SBj%zvCWy**n3&Fcfus&_M^&Gb6oD3QixKC^5s z8f#Gx*2=P-x2JIivP-paRckgNb-61%kI=rB-XBniGUWDGw#NfZ%A0TBb^mVZZd~)4 zbx4*uM#6?$FxS2EW?uyTmiLibO+8lh9LLtiibk?f?t3$5h@!T26$bT&usWNjObOC3 zkB5`+oPeOgIp*ij^jovY=EM*=n<2NLyBU2Yw<@(f=O`LmYUzXZKSyOj^Bg(2wjpLJ zvDokN1wy&)+#tuG+Pj@Gtef??$YN4~WW`OJwYV-4=M33GIX)b)H?lpk+GM2)T6#C;R}k?+x$N^ zHt@&UG|OPF4w9wC+R{w=L20s4yzJC%MSLG^Hd(!dbbf>|Qc0)L0=xp>G_b^aD@w%^ z#xYH2X|;ug1IG<=thFIBI|9(-^x#iH8KNW3s`429)0hJ`$tVqE14*Ahn3+hf%5NVI z899wo$cnl1GHGr$Rw;>3uic>6r!fEB7l2f|usk`nxT8VfAWW|+Vqej7)bL^Ht_$Pf2pUF|y9dzb&o4p*a-qRl3z8wO;!#`BPh5E0NwHqr|ow(_~v5oOm z3KDype_WY`Nq)5LPvN36!#I}`h%soSCIB2Udo`7Gram^%#kcNUtS-^n$t~=%xdMJpI5dNznLvRj`9oakfjhada{^GZeRUHE^}Sx#Ulr- zOW$z!5@Vx+rt4W4x0N_U-P34A1v(S{P~vaIkOar1sad$j=Z&~1_@62JkEzkLRd}lT zgtnV3PIW2pQUS2i!L!iqYyTF^3OC18)n>A4u1H8Ak-*pGv9ao(KVe6GnE@NMW_)m8 zL3uj{SglR797X}3%GAr=Qb2?$MQK?TATOi_-Jk= zFe_cSirapUo=?KK`ZsiQ49GhJ@3bfAp8|LcxH3t=XWZCYMQjCk7sn@<(XQJasg?@g z>*#RB<`M@yF(W%(c4Uj2Vy7DTE}DT}1?yojR|Ga!lX=x15V>UMieEsV{rO~?;oP&;%m zx;a02;~AS&99j-^hS?DMl6gr(0dXM$xBW5il*MIG=Td~&Ns_FCH|E`b3jv~q=IVYV zsx&n0|AgINghQ_e<)Y@dzEqJ;j_~mu?Re9gT)YR%ZwPw0KJPGk#cM1T;)9*rlACuqb$v?Pu9Hw5`maiyKUsz+5UP;Pw3jkjNsSY~b zZQoWLuoXtGUe=?8|9USjDD(`5|EYt=@IxyIE~!t!i+& z6}s?U+fr-ND`ZL<0zer~$^Ldc-W^I~C2oCC9g~jU-yi9%tUUUwY2} zw!LWYjH_t1!-Y_hjV&Uusfj}^*8^KLg9q2D29*n40fxL3@Kk$iQtdWkkf(oQ)bk+J zHq#z2S}ACLQJ~K$)=Ba+`v~=iO#N{z1nSx92=$!Hi)AZ1qnir~27bVz3e<0Tac_|+ z>-{0BO(KdFz!_rohFXAsD32k=+rId3lW*QvUd6fj*B@UV`t4Vh_T)2SSgP3ua5&MUkg7LZ^zqcIq9Rni@GN zoO>@*4s<|P9T84GwPh5;54{VsQ?hSz-NSO>^ljbiFS7BWaQf3ruY}F^6#QT=u z&k040KGuURH5N)(yUYmXwJ?3dmkt?%0Rd|w|JX*Z(ZZTo_3yeS{(V;O?=Af|QM3P- zUew)J>T8DbzwMKUuW;v=NUvYmON|}_aQO`4+bMR+iWJg#_1oF@o*{bX`!2Wv$rktv zfnBtB37#u(JOa9MN`ew1a6JNAFSJd9LzHOu%=?7?Uzwg8i6+e8J z_y1+9est&;q$)5<9{^L+)pP-_GAKC7-@CXJIy4WUs+qM!%u%#W)hU&yob#T z&mNEVp~tN)J94#24U_Ma?6sUtm;XVW6x2VJh@GrDtsFpB>=@K9^6|V4+n4-ZY~6Sg zxjmEo8YJp*t5N*i*3s(rn-UVb3zE@jQ0BZR{i`yPYdsO02+dPq+gi1a1kk z$9x(BtqgoI`F@AESS+{O=PYdBU7`FXpzc7Ik^cI~Y!TqtCfL^wia5Bk58wNC8~_oC z+mRUasD1i7Icq3qvy{D|T}!_U?=rW`1gG|emXz(c2&2PW+tyAZdn(+pm4ScHSkma$#$%J(51TOLvSck+UjN)*RMF_kG6bi0?HZoFx z*&-tH*HB#kJ{ah)7vR9(?CBPxQ7!9fs*|3?`YRlo&UO<*Gee1IkXSGFzy zYlaDyjVrr<3tRhV!*GVuoN}!0$AaotaDEtjA|pAz&VZS0%Fy>}UFXf7I1;baKRL^f zjCVqp7R{5n?-UdiihLM1_+CR56?3Gu(72oMftid3NlKoTrw6|)hNh|jP#3Z~l3r&p znOrY7|Ev#1e}b^Jw6eJJ1Y03YccuiV|@TL(A28boJ8CQx?%Xi#HEM zmfp%yNne9^Hpg0zji;$8HjP*h@+u_-$lX{;Yqw-6pXu08Y4X0Tvz}ix{pdU)IFRc-#W&e-W#hAc^kVMU1%0Dcw? zIO9D?da&EvaKGWUC#DUe4wtSCl^lPsyu75KbR>mi=Jf&V(NipP*`N!jN7XNz z{Q0^=EZZxI%MGps*<``18}%1XR!fvuP3wAc|@yQ5X103+L{G-h|^)$pY-#v01WHN~5? z8gA(MMlUj=FNa4`+_3Lz(|rxP52BTOgz#^q0)sOzZD8#AgN#y}Qiv=2xSYvI=XY3b z{&Q(Va6svt#D|W7P`AW#7y$MfG6N?*u6p!Sm^jOZC4VfdJ2CvNLZ6?kj>!%%X9M^) z96dbZdc#;tWb*k5!z#@s<}2D_8(5!6{I5wPU4=5qRI(}(A_BNse+N17e?__82Y2Z( z5}z08?Cji7GCizLE=jTF_<8E8b9>t(<89W=HP>1eP*DQL<9$yO3U_*q3Q~zP)_jdu zPVH&`K-bio9!vJU-W=>V{>FdqCmf_v`$x3z>1l7&THXeq5LQd9o8w5nEor*F*k*Pd zkZh1-2}=Dn16_7MD(cFSf_(SBxyn=vlD{X*Nqy}QHZV2V9ddgQINoH9BZ}wU8I?Pi z)k@P=4m^0^>Nl>!m?ISzmSVGwYc4aQLh=c3J%^0ckv;9YunX^Jp=b18PIKlDk6{j3 zea2|sFQng ze{2S7mjHFlN)2GP^NzNE)f0KMfWFo3TpLLv205^!P$ci$kkOq1=m)E@Tn@8>&g*}M zolUQ!bDE+wSw`DzUNn{HUBaR}hD#@?T!kxK4!x9L($ta#_riK(oVgjbhRx$Fk|{*- z;xuk6zsi;q$^Ahset;+>X$5S&=#IXYoKr|UHPUTUHJ?Q8+mLwByA80qz6=7Y7wa%1 zQ~qUgrbQdmqJ4>fFpq-Mzp#WwI7OChsEe_l?{+y|3+AUynI0DA4<;xM**ElI~8(sOMiq z+A1`Z70Y1@+_X9(y=CXZ%@~-*l}XU4dQ;c}<(73Amt9J?maFogcbb>-F9a z4@^1=J(o2JSW$#e1ua24kZ{u{>U8p&iH-A9HkFrkW3QuXp0aVvATnBi5o@dUV`sfj zRN~m()OG(+{M?tngtUbyQquOql?Dt*oNNooBAsg47#-a}|I*d?riQ7(;F#(k^l3KO zOVu-gF($(s9d#L4@^UPBd6Q@_PHFRQ8Y|!&M6qi#>eEaj?>ybW6*D02WyRZG*G0!tF2Xr!r*^hOUEX#P27v5 z+FMILRV)E4xST&>X~kkUb^>nZZ*xu0Vh8AYSKowaa{oZnDh%wM!obS#Kyi3xk3g08 z{q~XPejX08eaUZtTK*hp+{LA38YPw`QMDXe$&~3Ee4GKdSIX}BbW2OGq?O2vw;m42Ajyv!%)>fO;m8W zHpp#Cf%f3yp=1hx!II0#obe$46f=)eM_eM!!hU$J)=dj`LA(SYN`@ zlV`mfLSG+5ciKAu#IUu!wvgzfV9)we*J_q@z!^{2n{x#@z8ZzZas1okhaX2Y_v%D{y4zdVg;%cU4N~O z1Njx1z!ocSAbpwj5VxHIXl3jIZnyU<&E(=hZ)WEyx&`YL0NMn+uvrGW2si7GJPBk) z3%uL`n`@)Mkn#Aa0HOOg3dAhKQ>E>#_w?-8eZlM)+KqM^Z+uP6wMLRMMwMDx^ZxPC z9Z*8B<=zu3R|@dX#JhXrf%)dY2DT_8Z6fa1g4}zclLmMTAVEs%C(M&{4IuRddh3&8 z;MM#QY4Bew&{G&9YTs5Wq}6#!EPy)TuAgvvnWO+;9U=ycrt@r8B9V?J?Z&{!0Q-ah zM6Y3|--%xTM@HaRCOdZ2{Zh05>Jo5p4vX}bf6k3iDb1!^3`zG3u`%HJ3cwp#;1|vS zI+MW<&J6;vS*?)tDPRK%t#v}aD{*B*43GvuETKUT5T$^f54cLIIBSk=fPp=BQEtS;}_%2(|5f2x=kBE(0foG155o&13fsG5y#Ye#E2CJ~Q7y9{% zz)mpM7-4>CtenJ8=5~``9tzxk0i5NhBoP%U^!7EA0BfI7_&woIa4rGMM<{U_%qv9J zer}l7bUD-Qm15TL+7at7MMCr1!stF_^%#89v;t1$#b2y%AX&(@G%PCd79{bxGvolbO8Q_C*ocMv%kZV`rJ2aM?`TTvUg1u-Qcu7HOH*q*yjA43XI*}N*LAD=4S6$x+tviI)vhP${AtB!1r4%s;M z!`4;y(gG%4hxk5A0f|qcTKD6{n?iQu+}5rC3GeIkA3Pg=eFzR-;C=q$+@RYs4Xiy$t=Q3y-M_Fz*L|l5%_s&=Ov_=%_aLqb zNs_=nz$=#+3w+_WRgGuI=ceo3sQ*S1U4UJ(PyN(xA9=?`+@X2pBz4o>1!^f0DVsEI zbE!$6eq1}hcr$WQj*t#|3)g0)C)d4htC)}xYIXp9y5VPOi7+7nb0{22AOb=(+Vw^inxkjlG&Le6pV6b&Zt(+m(V-Y_}?%I+kc`*@Y^5eR(bIP7xLus3m z-@2ZC6@2+bycHzrW6SvXrIH6O)n`jA3=#EAv=$eg4v=@M^pwN4Acra4<1e{=;dI5g*f3b*1+{^>~e0B~F2LYdn zc!hvMk>I;P65um+`+ysI+V|3wiqzM4^6OtcxkW#YhBWV;)x)2m7FMw&%I@#lg_LeMKpVQO z!9An=oU|8m+WrFiPW}taoq#6ZTNL(!dLv}mczSt`&r9Q~%wuA&jAOOk7_qyUcEtAK zszx88^*zP9lE}z@rj>Hf>CJHSw5>1==7_DLg;O+IF@({uJt+oK1tHhFgS& zhhxnK`p0MOwNbN2o?NfK2*-AIg!rVtaO142v+sSmu4iT@ zmzVoRou{&`0T;BJ=bIJ$)oL&;{xVk2JLNb^7j`c)v}b1c4zAa+I+X2NL$0~8wTWT`sJjS9f>-O|c8G6?k(d@ekNm!xd#%`)>l)Zl#F8(Sh#!XMLgv)rx);e+4 z>50n}>8fY#4kS~HR$BSoHY-_^<{MwPQejnH;Cg8F+fGmRC(AD{7p*NE8#k<*?X!!! zG1c3wpi0IS6R7udf>Ycu?&bvzRx4=J-fXnSjw@{)A^mGzPK(J{>BEC{1{96#Zrt#? za*rQ*-yR(>#+Y(sy=ZqY}xh{OMvBetx=SWn;w0*`X!)wymoQdaScG!yTN;%XagFF%8EpTF>Ymzw@Z{r9;yD zJxFR#K}P$fv$?0-hxf7GNgBDy-=>B%jdrqW!R+%pbI)}S7hGoDN9~tZsrguQ8to-R z3DGT2U=`dDpmQnJyHK#YQEMf{H_f#>+*i+`0Q5)&1uwg-k6?**<$p z8MDW+GiS%NxLe>U)!Y7JPh|#g_rwmiy^R;$s2f(5iN!d`oz@gvY(-LPF6%r0p>X$U z-*M*$P=8&2O6wE3t*#X{Rb`$dnkiW>xm#<`x^<4it1CNiSx^fm#8kfM2I;fz! z`>LJ`IBPD8))bgy9)dO;aSNMJ| zuU&@F*nqSO4h#&F{$$#p`q7PfJSggIfB(eQMK)XF7);p~c?|6!vQ)R2AYv@b8ZMAftfk=3Uo4fmss|kxK z$-{2DY+X*i9iZ3MIZAmcBinOcp)O~wRA=4A;gz6W!>y|w`ce8NdxjprFbLQ&@1C2= z?yCLxQMQTc?#v_B*@>y;x*aNcZ<|z5`}Mh7L9MIXc{%yGC5Tr^krEVjRG#~cY|;5q zU$Ws?{T`FyeXvhz-s#jOCkj$|MBlj{K!FkDE!w1Im$>Ex+oMtBX<}Pce$nozx3|{? zHpjMy?|$>%Ku+ApXjr;nK6<}M_$&rH=vrEd8&=>aHHi1` zgs2!Z6tJ!tn~)BN(1lZ14ej2Xhe|3%?Dp~GRGOMnD-Ha%ARP?Rh4beJLi6Tv?_2#1 zOegg49|xyb8I27p*+w-SR}c*R%h0m8!NhIITGRHsJ3o@sW3(HF{9?*%?rXQq?%41INy?y4ZVRV;(%G)5 zwxnY%na!Cpa8Q(&TR3%m-<7@{LjDDVJlP`$0#7sCr%ePOeLj59|kev_#AutReVnEga0mB}W03qxBJ2>+#|NG~BZ{B%!+g)8%T~%FG z-M4QZb+TW!c+FxM47Ti$!~QQ|utj(n3^{^Ef|eKGSHFP4;Pyuyzd8UuVK8eL%nN31 z4YLMsD$J`0d|N9YFKaJQsMer`+I_sD+6%y0g96%$yr|t?MW8@bYZ%qbnp)IN1@&$y zTlth`XEU=)OS4PCo0ZK3g;V4OEAp}~qJjcoyNkM^A_xL-07wa_e3+$7P*|l*PALl% zJ`-Rm1!bX`$zrlNOwh>TFgf52u}ZU9%u*JU$zqkVl${(FhtC4-e5jjh-A(oCE&_$x z-3@g^5Qmw~VU}`OpfEWs01MFYIebtc4g`%v2J%^@d=`_>0foiqg917sJ_JEUUH~1` zT?7F{945qPL3|Db`jqS|5km`5&TrpU13{_Z0&Iibo ziuuEYP-7o`YN2lsmolOE3uK}g;Uihyt_ZfIU)kwWn3)R+cH6O!oZ(QOxjnW~Juogf?b1wEor$Wmn}s)El|^68oW5xpKB(A>-u4`_Di++Gca&>82EF-s!_ zL{^7FA>nJ|jul@u-Yjh&7~7NLuLzoLY?;e!(!r%xI*!IdFU8;ao(x?}Wh-W9lStgh zEvvFj&1W0tj#+9_a~nz9>32tK86r8^dZ(;zSBlC|V`tLDk_MVd2VauoY*8d**4|SHCp9ObG8z&kXt|nPvAR_-0o12nJ4^ul4J)uaU@4kZC znN`WS?-kfy@ExPXnmi*!CT(+PsCj>>zqDR(oG~zmYHnYS6vV~m=rlAJPj+oEZA|P~ zvaL7Y*W?s=DlyjgctYE=iPE0OBzO6-fhw2lab!|URE*cZ2-uY^#l+R-s55LWL))& zO0#z7(ZIt;R=p*XZPr48gwO5Lu`Mvcyl*xQ%Y`~yd`QP zqiIk;E}yTI_Fusi5TvbxK6%)Sh0@orD=8E1bI%sBrD9pCL_=d4V^+VuYh`CeN`X|} z&}_;mqGFfqu;TU8TBwG6U%^Xlj2+D*(@VCuX^BqNafMZtGDaLOH3>CTqvucPzi42N z5!yfBT{Jw_`C*twDv0r;KBcCWoBBeHQ#&~K;GNi1mfKTv@=ULxLLL@jiHVC1_|TTOYJO_N2`M7qJ0|y> zt++R`2AIyQZB3owpycbDjUMcEm>enEaLSQ>KZJeGF|SRk7y3$Fbx0mfUj0gJ#Zi@1)*{S1}1%GK-N2TvxHEM?Xi z+{{gCpIUU5jn1*Jx~KEpdp@0VF|wg=iJM}|0Ff`xGtr~%Ow}mmZGY-5>eFyG-(aIp zO}F`x=%pU)gAV%wP{X;qT@6&xSY0=ES}$Zg0;3gd*{CX-5v= zSDCC0U-{k(KNtTzYZ37VE&wy2pqLU)MDWuQ`QrY;y6CgM@Xpd(g~Xi&HP-5j&dS}> zD6jhUH)FbOPJe9?QPPF&&MXd73*Wt+?(|wQM zd90;2xuzY$dx<{TJr&hsjNy2gX)H@NKnHeEdicx6q7L3(No_IoOXcemu=k?uFniA*?cu(-Y*t%?xj$3FL4?7-T0BF_F^ zy9vE^-w7>-oEFD?agTP1=z{N=q*PfQ$L~%!Pb_goCtjDtLc;@f(K}+1`E%WI!9l{r zk@Bf|{d%dnbP%YT+|?yWwPRnIem)gVcw|1AU3DpAKTex!gS}a4j%kd2)b4&gIL@S1 zM@!)&Q8#Jq=**@6 zf?N4>0#|ig#n8D5Uyp5(kGL%%Ix|&Cd_T7)?5>ig#xM<)At!TAuQ1C>p5p(kPiwrf z@avWS;kvvG-{)oi`LJl4e2u*X$4<=);-mq)I3K*RSLXu=c)v1iR6%eWfS+Q3UkmHz)SB0pk0zI3>lr&UlW z8K~o#nd-Ei`R<~fE@RGZyiU-IP5iDLb+)B5qAcX6vAp^ZVJDeprXBrUX;h)j;@rPznt5iVUdyXlB+jDXNL1m&GoIB&?5!M`>EH@TiEy)lEx{|rd;J`NG=73 z=b5t>FW6*V#;INBF25D@S8M3-T=Rn?HP}iE{0v`YSmi3cup*A#8y4R*!Ce;Vt?<)1 znKRUp$a!Oedwza$b##MXsv~LYjl@$m)jL19wR?Penqbs}O*OYmSKzZ*3Aelj`QD>f;qJYyqzeLH)0T6Kj= zkZ%~=io;O};oUU&a(qAq^*%@e2NpyU#gZ8zuR3*cwPkYGYa7xyy35Qlubv7u>L*mJ z6TOd<%R^*+Rw)YY8jjtyV5gcT=;xy{Wd5u^ue1;Da;k9yu0H6Xvh@NC-f6j$Bh97# zyiWMoP%-kpg_70+Qn-t2_TuY2WD_=R9CWjIS4JBbS1D}ei^e;bDk<#&DXnnB?@Mv* z)#@E?z{-B-sQT;OWr^xg&e zJ&#sf;N+FMG3s9cZlzD3p|y7`?pgr9m3|a|`hZg4V8A)#FOWy^zv58&b?~30ss9EG zn&@pkKhv&ijy-~(+Cl;o)Yi1DkYutAk5tUfCZ+9OMJ z@mWV&_T#5E{z9fiV%WqxcPba_UdVennvAYDsMUC16@x&;9*5#og(qz3#kXoR+771P zE6a-dQA=wY(A zc}4h6;yQEM1Cp}Y6rAUI{FXW2 z$U;j3kgFoRDRXO3_F{DCuW-U7A4SZ&6;xwEhp!@L0h^DSgO;*VtsK6t@K-#_u~gSz zktnG-nEgWbKEqvT^5h;^k;=-?9yGDm7l-jF^~%ZzB{$ih{KA${N#)N#j#RBqdgCjJ zc&7!NS%)Qawf({G#K~me24h=)PwhJH((vQ1d;?lf!+_(os*M zm0GMwWXAv;GhQpHnqsXwEvjQ{YGJgq=SOXG)Eu5puu{nS^&eH7K{>maoy)g>L|8Be zW%tZ*SIvTctHTiAZc?gmL2I{6Fv)*c{a;=GXQVL{$Y^&SH&U)s<$?e*K7=wlw6ORx zC|ey7+ar`J)C32dH_XXE=+#@*>ZgYZs|onk#&F$AnHon8U1Nl)Ny2&B!aeV!&dv*z zNR}p2mU<{+_^24q71V*o%&q@lAq&&d%B7)>ElmDldC5^~)q(^UO%3kdbK|4risF{2 zs9`Wmzw`k<&nGhXws}~I+`_Zx{+A0Pey*Zng0VNkr0w^?hu^7m$@?ZL$tiqr>pvsA_92`V8of1Tv?M zn5B1tT4bbn!=w1s8-e=fy4clFr()9a5z_bjIxeZ&o4bMqsLHx3_Jpd9>239)m9BZlr=L!YghYiQvyO0R&w8%yIUU)lUU+0AV; zj7OnX+rhI#0%jRuTf;fg{DN_alz&<9_zndIM?LBKN0zH`)qC=tw}+k@nu^E&XaG`N zZhDw)I5BvTb$*6rxCE{FOY;YjZC<-!OPwqH4ox{6yJ=&XQG~@P+*ZOs6Gh9%qBaGj+O}>1q6C`Ej2DKQ3ueq zyRJGkI5?xS9EiLVURn~SvQYgmrLSbY6VCtCl#-~X@eKzLbNU2}xxHW2^3FUZ%-odH zrnx}p5dKFs^cxd+wlU^k8ThN?PbHF|(KC-`zq2%h!!4uY;$$E_eZ_Y>6?9Y+G?c}~ ztz8U$v)Y5$xDJCSqlPwu6_`NLzfOV4ms1~WYChP9o!JLW;9)cg3_LUhf+5Ul1J)3M z2w4A{*7H}#zqqsC^mG6HJ2t)Cv{FnkA)=Cy5Yb-9NZU3!Qy{> z{jzp)@pJyyU$h&4!;3{0tj&g-jU6hBXMW1 zhH}a_`6m=RrKW?hyKe)A1&)T8k1e|EbLJ8kQCM&m2s0q9^-+PBc12v^z2A4@ z6->>cuv~R$tZ&W}?1PskP`>JRmpd24KIyXp|HU}zQs73GQbAbPrXp$8;rv{z90c7k z5Om#cBaiaDQ~W2Wl%W%VovJVhJvMH9gY^^bJp{|S=?Y15x@9u2kNl)HT^ zSUFm7tM&i>^3ETAc0c3*hhs9p4Wc1!xK-Ia^Yx(WPEX3b8b{Su9>W!ztR~mgX`HWy z@wJrOyN7@8)utZhBU85GWiepS=J3Nj{K#qysTyqMjJ}dljF)QSJY^L6A{3>-r-D!(-gzX!h> z&MRay6vjN#1e=}H8uUu_G3~W+pe>1i{%$z3av@i4m=x6k9)21{u|JMXSs1x9oG4&q ziT3*UjLUZzOiQHidwApwH#XVH4KHLQ`!TA<`ZN1;Iv;uKQcJm_eMo^!A$yS^zLYlN zvr{sb@TJZhj`(y!FA2%2!Br(|`L|wCuRk`k0i{(%CeqxY=yAQRL2zsexqFSwVy9&8 zq?U{j@ZmMtzQq!QtJER#0{z67j{fjYWoEES=KrCM_yV5nK$o{afwXMJtFYY^+coj- zQj1*L>zmkS`J#|dgW+byP7?(|JF<(}DbwU@S?ovLHB=p*qLJ9vaR^oZ8Cm!I7-9ug zdjLXtRIS2xP#k4O(rwRjh*h*bnV-4g5i8b1nf(pLBUUOyJ|X>$K0Pm`NqR^-C)o#Y zp|PVIJ_FgHDJBFkFBFfss2WY`RTRQKA~p-m{SD!x1IJEiy(ngXHG-=$$m)H>)uvuA z^q^Xb7e8dDmA)NaKm~Ci6Z;BQA^1$~a=1b2ln) zg(}?h9uHaQrPRCOJ0MG&FpIvPZdx4q8trUchBv;h z;~aiLC@=mXLs&JrMKCxxr_xzj-*6!Qp3W}m>`=oUW}9lMQB1)G%urcH#lAfuNC7Rc ze4DtI-a4r>Ut4RiIA4n@K0u#qp1IpuTWN+#GlQ?IAD*0$cTF-A^A0|?uv-n$8g}%0 z$j{0K6YOb`k-QGKo}Y5J2+DLjbi^$@C-bq^k*3jFCp&P%CCvnk{v07_A=}FRARqTz zOreeg)^2)l_SdMhq&o>82r;LMITF!R9o*qqN5~{j{Z%%0=|Cz;A>{0jopGa z?pte8hYvr_^HC=-dJovS?jCO%rc+0u1x0QR-iRrP-cg6kBSt?v={6*}jOl2)e`=yY zRT%qRG5f+?ADjs~f}27DhZ$OiY`tjhO*{Er`+|LM2P(i10C0V8g8tkcSEZrWsa8MV zIpiWNUd6i}9QlIQL!^ZcQB)jJh@v80Mg@_k zASJXQNRuWYgdQajS|~|?03qamzM#9a_s;C@-QV7Ockh4l`^4n*^PY3wbI$v`&-e2w zBmLz|*Dr;^V9Spg96k+$31eU|kx!yRASA8K?jj5Zk3Mzc>=E!21_Oa87)%oebASn< zU_weTlqF146Q=0^(rIL_k0^gF)cL0@Xf(InYaUga&JJxVooO!{Osf>CQa((1(4|J@3LPCTO(h&fPhu~fQFr2iGsZr6@{HcA_+SX z2+SHd{MlUs?9>qq?A7MqkM6%H#A>7la9YB{!=-I}+0xQ;d9Y>mM}+&HlXbTjb9$EO zs=|WYuER+lnP1E0Y`P8!?b48zCZ+|%#Q4$Tl^Jj0Yh%R4tBT4mR7UfC=D6|vYXP)Q z>8Uo@vW6o|`f>yJ8&(*~?NO(Ct`fKHQ{I8j-8a|R6+oL*kDs@ljy5(5J7#?~J%v9X zoQ1toH2s_&G$8k8COUPuUB<82MhPTBV5RPMo3lmez!--EG9jw z$84i{!%veIY(GzLk ze&c@7&*uk_eVx&AA|=l(PhsfNJN8Yp)R9Qr&vQPTzP7_%mWtc1Rvu0}K_5tK^<--a zxz-<zL6*b*J;$I3GGTw+gY_M)sX3@BnoLH`$?Bpa#hV=44kj=R5B0T8QvbN zr?cNhSlpJNJfYuF%pZ2pl^V|}SV!E5OKh9p_TVx2e{hv%$%LgXCQ*)eO-HUSjM=ud zYLe248|c~aq&CRaiB?D<@8S4rc@p6HRfL$a8U9x;HS*=xY;{xa{3xL|omi{uFeUWT zL5@Af5YhJ^FB)>d=$du$pRi4V;NHSX+eU|ByLSD~6kn!>hAoTx+w=Z!EQ^0E`myYP zSWGpyCN1Wnw{Tpf(^fY)OxJhmc{N7m{e0DIy`0jWSg_0C$ z6j(5Km^$a;MoFWGN>iiayp2icF|aF>Yl!C+WUS|zvw<(`as13F^HyC>XIch*6s&|1 z(nmlA*PcPw1U0`f| z`l(u+UqOWNyUS%EdQnFF*_M80x%PJ4Nxj*jVZw9&2Fo-1;qX_Dh8U@&$JQ3sp99F1 z;byreC-W#DY!|Arq$oMt+TuIYI&L+zRf`Fof10!#wV3KPH;#{y4KHl7G^P3ow{$26 zOm)(ePwVj)7~W@b0dHoLom1OInk<%ltO&=TyEf0 z2bD(~HeTozN!jv{bvBJY^dnZJubVDJ&Yr!Q9?z@uBxlXcT*8c{t?+z8cA~1Og;cBC ztU(cu`y=faHu4SS7&GB5p1cq}axUJ*_pO|s8oJzkpmc0+%MSf@HCw`_b?R_rCSP0> zlctMMr9K`PXoLQiyX^^;y_mkyp+iEfCf{b`o^DO`oUx;9ef52A%!+j1C=q`y1%Wt~ z5=MyOu?iEH)TPWir-mxfIStcHtcbk}mgG=8%IlBsGV`Bcy)fa%9qB990S&w2FVfdj zu|MUAcvMjMR1t^8!3w|F?~?6vuqDSgrOJJ26+=DgJs71c`l3~H=NSFt5!o7Q=$Zke z$7`=XwK-|-cOr?`ZN#gd0(MRoq5mh{mmKKZ)?{=z&7wDGW@v$hzmFeQ}UA zwQhV_)qd&5fy&(*m49gn+tJgJ&zs0qU5O$XXG9PbR~#_GX|k#ttaaK~60MAB-2sg@ z-ecnz<){Jcao&!Va~mZB)sDd7Gm}34i+ZWptL&i(246(HHd-tr6PTQQoO|o0jGlyj z%QGX~z}RNZlB8>|zGgv{YsZ;T5T0T5uOFRMs zHBQKobL1}2LyNp~yXy!HFSYXf@uz^|ie1vC2{YF=7?5+^iH1$h0bTW6E`8wn>~7if z@W=%p?r0Y!RH`R0Tb3BH@RAhB9_`BYY5wq~bvkG)FUe08n)c^0MxOKh3Ep_^bbCe- zsbc^qVvoONKfOCeZrfh&Q%|g(#<1`BNp&IC``(4zebfs3k!7u_!g6)#1%B))n@18? zsabO)U_w2wBv?Med%!ewe`oJTAP^-evH!fs_a8*4KG;Oi5B;Y1G6&N6@8fNvPQ=ZG zkBWeS(60|DSkOwEed_HnasY|^@*s=pk7HcLM6aDiJT$}*p06TWA`lxM6Z%$xEXW`Jsack5 zp!H_w>{)Grfmkk>)klwDT$ih(DGF}Jg_%=eVm;rCCJDa?L~CJHwN5WDjF( z&mw=I*b2G+#HwXPfHb> zz9D_Vhqjsg!dgpzLRLoaI*54aR0a2*=n5>}6R9KZMEl;J{b)5kbFJWP zFBJUxk1L6mha{>d=UUIX!>_x5UqKR8)8Zg$1=RGtXo>WFN$KF%Nx`pXr#j!KmYqH- zlHU?9uZlGc&nQ&$pBM7(#)#SKz#@xgn>$U2j>0N{q;|q9NvsTWk*^2(7$UkKHKRSs>$_*R1 zAghV>a_fpK6|9$|ft@m=JC0PXsghbAQd!hqY~jwgs;uUaeRRenhZW%Mqkb zK>iT@wtxLK%$Tlvaemya^F3wL{CRf>KUm#w;y_?K2&xUPeJD(I2B#JOj)2IZ`DMs`5}rVP@I`)^w(M?LGTi|7}i;!I2A<=G~5J=)BXUa zH1fPaaW3aoIb2(e9@5_v9&)KbTpqo%)kXEWVZTmsX+jSD}3Dydse|(~&oO)>_NM6L!KA)Ne-|!wepWlHY2Q&=e#| zo(yspBvIr&lN2PWVGJIGlJu);<)ffdNVTELf+WgW&&B`Ul6>9#eS?(;y-~hFxOZ=N z<1GSAX`eRu{jB`9zBB^yu5AMJnII)2Yb7fB>0%k^Cfwqxm-{9(CS-Y-G7@?D?bmyC9}an-`)|P|r=u^jUBy#b zr`TI`GkTXYklL&EDJmI!zw+(-pN@GT$B%DE_*}zqtZ878%LAJx;gPkWB|yTy<8v7& z<->RlEXoq((JBza9h;NW=ESR0fgqT*Sah zg<&BxH%r!Cy(pNWC+{f>uSVH!L*9gD>Pi$eua95^6B?cX&E!8K{yjwkE#DwL@}5X- zrb4G+O&|_Rb4TaKW9WAD$TVO=Si1(E5K;u$6i&o>dCz?bJP8ga?8Up&;6-rRpQ;WY zuMH^5@er(DC_7_L&N5cJ;M>h+@M63bpSLrNocZg3SVQAtc6bI(TimHBZ$@RA#+@2p zjcLlq60qLLI^HZ&8uo&i=uJt~>rrW9^|uvfKVkvdKzyc`RrP+Nb@V0I32Yoj5mx-s za>v(LoQe(KWuS@P;tq# zT1IK}SPXNs9&zz64|2h}#j~9Y&yQb*j45$Co;=TZt&>%O-hzwTmj^V3RfxX@*!zh)1OmqPoUlAFirK;BmJiJWCxt=bCt8W zGlnU-7soG@$(+Cx=g%0=*Ggm6qjc)93ui_uYKO>o2+NLFe&w;;5ULu!^<&hHY^O_S zlG=6F!)LFtBKg;%>Qw6ZGT2))9gK=pNf~vz^;6NRXYLz&g2Smg(-9w^gl1`VZ}OjZ zY7XO%bZ}fYbn0r=wdcb8Yn{>X{XB`dKqt3+BeDk9I5x?(@_uAH2UyO~vB8|+;=qkj z=~=!B?S1#IX-u~}J_#$f6%wn$=~6$t6k}{I7oYJ@@UUYh1b$gxMFbUA+OS4PKDozq z5A_U$V0DEn-&PvASrjkHgK~YGr}j!jx6FNIkiBUYy<02~%O$$q=0rE}>*f3|sLrO| zUG}LA>#34 zek?wTn&WRiFEZQ}OMgceB3@t8S2kPRe}ON>e!dsJ?iaUUQ{@jns;wn4>IKcy#sU0> zM7cnZUW=+vG34f$Y5Wpt@-LRamtWSsLgA<$a zl;$&U63doWiPw?t2glxx<@<_OO~mLGwgfwWzDd&x#LF4s{S``>9-U)zGM(2Du0CFc z+Ufyx$)(n2MTt%7Z-bgHd8J6?NUndRoOS+wEkpR_2%d8gClVSYR^_-yufQ@2tNYR% zb33_t!h|Zd|JL3gVjXhxg`Mz+njG-5ML+i7+Z@kyM!ZKGJ z<-|IKDaeYfB1$O8@TCG|4IYk_aa$Ob((}db%PVEGxU3=FA!@*Asz~pb{08TFI2?Wd ze+jDkEtBNrT4LD3bU{X3OibZSM>KhGJiK-u;Ia+ujxgPA@jmzlbsHOQ;izvSgyf{F z>pexBO2{SnO;QxfIXxpI%_ow`R{p=>czL7|6Sv9`+{uQ*fp9rRzDbykOv#<8-$k%m zZMYSBQ&ZXSd*%>^r61-yBr_7<|FV7dl?^$c=h(?f4b^k#85}YcTALk!aK*V`Cg@}% ztm!todU1D+g2g)kO`lBS&kwU^F2+5|O^ly+_b6#B9|PO`2oN7MJ<{v>etB=-Sx0POYcclmqh>ws7@y70zqjHI zSr>uwT~_ej7a%jQWCBm3{S{a%H*U{V7I}8eQ%a7!tg5JGcR9dv(V@=p_Zh{(-^3RSx#DOsEx#o392Y8=Eok>1@Jf1qFy1vh#A!M3c3h(aw)`X&n zQ&OqZ-F5fXgfj0{q{V8@&(5ac3Uhs4IK#bpLGJJC zXkA$6Y%3??4dLgc zJ7>(!XDsbv-@1vlJPZG_p{Ve2b)^EiR@W|DfRNCvV(9K+5(m{j{u~VD4_;5iKorNPPcWripxt z+~>Dml!sHfs*&BZ&Eer`l13wXJ70@c_2`}YxK5F<)SqY2$x-)Y)XChwsxy$xbGR#` zmw;D8M=vq!(1uX02sy`s*426|kk5|Vz#{`D%clJH=vCNpk7bd2fDb^n4p%0(6@Z)o zkjE9ra!qhiOS?M)K5gWr>Q3cO3OzfDgYWNV^2<16wN5N~ntmmo8qiYS5U9a@+9L5N z%D=WCOKt-IG83cWv$ih$^U+DsIrX+m8Hs^=3dUG1MZq|jdwM^gZ<)O zGvE?wul6ge8S={~;f+KQihMNO`Xb~eIq|MW)C>YJQW#M*SY@C)zrJz5ckGAbnm zU>XdN6)kzTTmfwbu9`661OFYu{;iGYzwWm5>r?RmzquWq$G*1N?7SC6ARfioqLDX$ z{Ipa<8-8Im61l<{vvvvmdYL5Z=mE@^2@r)s{dSb_D&n_kZ%rNnm~a;@<0?Rd-vkj# zzAoQ_KB)+LM}}N)+?UaD`YJ3ymmUfj|VS-&vgU8L?&gf&EOq1%T&$z#l>0 zw1Vmq1$AYMfikzEYn%rApS>U{Emm|$w2HU0uKhJw16`xljM6#2ce?goLySf=)aZR^ zN_4Y1B`5CQRy1QX)UM@KO{4b*rk9Eqh>33KK_N2P>#LgZXa7`9`>bN>R>;^OXeqvM zg}ukw-qljTnzo?_jmR8%JXlxGZYEwWMq6RpjsSTIuOv1f*M7^hHuF?ISAdzUPP&AS79=kQ;37b(duiEp%}~^Pj=#slHH=BOe8Y& z5ax~odbjd8v@SP7K|kCECR+l^7?bIEL>ay*KH#tM2lZ7U)coG{0Hh?*Or*$c zD|+&%F2HnNm+5vN00wM;nG;Wm1eC@A>=a5Fxq|n|37D@TU|m&A^!X+Lz5ftS*tPyQ z0}gsiN!baKJf>XVwF*je(R-^V4Grar;FMlm4WaP>mIvwqRH_Uqjek~v&tV}~H#uph z*ihtd0A*PsHlv>d%obqgThL)0JMb)INc_)1R%LkFP3tj0eIICYV-xU)d2H_8o&KtuTUp6oW$+2SM{FjcN>>P z;RVfiS_>xyUQ%VZu?M=;*L)BB3zb@bXgpdEQon+p3p8pNSv6M9O`H3PONTVAEhH!k z8sX~CI?EnWlPJP1K-yFwl;xYzl&I(TI-Lem@ZIWxkoFZw_%@0tVj6AMMS6F)Jd`UR zZ4%~lAy=CFY(bVfs*9r*eyMcp{3*Ag$e%RckV{V`bdj61TV9jKTq^v-PfGKbh#Rne zg1dD71oy7;ucO5?x5dY0p`md)V@A4t4FGa8pO>k$_D9+UuKc|2AV$+#$Z-)fJ8cEv zB+_jZs-d*^j9THT2$h`%Zw??oj9_NoEmLWRkj$$nIPu2Nae59oHFSVc?~j2T`k zsjdEOaFD_8Dm;OB_!A1gU#IJ--jpZvLyA*KxTy>$O-CT5O8@{Z6RoOfSh$S%2HHWz zd{e3KCk_G#>f8L-!84FwoOB^C<=%gvbbVX?FHE{id8A;wz%+MgeZP29Pz~HLwk&?V zz6AxXAh4BPhZfaA%okC?Izu4z1&P7A03le7gp!qzd&qX6#W2wF+JwG_6s$P-zh@EV zr2Wm5AR#Q&{Y-aAM+^GrDA3=_pq@!N_nbv(EQNY64#WZ6g^&Qo{9*vfM-d3@XGmb+ z6t!Tr=;VST-VVTwBkk>x_Q&*K)0@#d=iqN7;M@CzY$YHGm&hVtpil%IQ6M{*FAB&S zHjPFDw2pBAvlI?*3nHvWAl`^TBK{-8Ur1>ekgUV?A{Th#59 zM0u$&9WtI8YY6U2wm>5WrGzWk#P#U#_?{nQa}|t7!6_5I_T~X3@K%_;P%-3EmDOMG z6pqD1PL0b-fu=0l-q9CcTkC#;ir<9nTX;;rdd^MBer(zve}Tu>HjRq{9*&1p+rV|s2y4~p zqxu9?SY|7f>F!G-6@kK5S1zj>E#IDu^|Tf;?+68ijAdoe@zdN4>dc8lz^8V^1D*1G zRni;SZATQmed_omy?55pV4n>UxI&igxHT?>Q<@LF9UprpdXmTLR>PsB=EYa8 zG3`_7ZM3-;ycI=fKpXE~K-$v=t}EKix^Tjb*v!YHDZ@~Y!2MDd>>RM5|Mkfz+eql@ zsyyO%kkGgi4B9K!9bqKF*zj*&G&LIfbtYL$fa9|~Fq(${Q;nwoWEADkzGO(kd&%D? z<*3FG=7-4fCv@4qHs`x$S|Sv}tLtUdfFYVZn^hKgJtnPlB7i+x9=3WWmXCj-624K> z*-I{P$_+p;e40z~QT&K%K^XbnoVl#dRWD#AH9XaFvSwe-2GUYdHqqTrJucEJy2K^n>mH?- zaj&roDi=<-H@V=Gv|cm>{4~c5wBqW9+I3=+_H(74g|#pL0iDEu&&K^^L>ZFC@{`$T z$MSZoajgw7!Y|kp3!gX{hnhX`Dtn@1R<5W7C=9Dn`YIYeTQ?A`SuZ^(Ug!B*<(;#l z?xcjJ(7K19!WqM2|BX=)e#7-+)>eMem~L}4s>y{xxy&Q^=jShES?I;^)Nx&Aem6q~ z%iQZB=}>2bR8GjppL+oJnPC{|59GJl#*&-6wAYdhgv6_~U#H+a9TM8|c3aJdi&mjy z)eHMQ%&-S;55%z}e6JUbSu$NBA(vSo z8v)>AAaN~E2O=d=8Ex%_-LK* z0aKd^hr2>e{&+GcdrD1ygU!Hqh@@Y}Ki)#S?ln*MnbS^FjPOhLM3fqF`aoHuH(qXE z24YIF=lx)DGlThohC#5t+S90|4MNA7{JqFgyqOzR^@6W$c6b}zZUtUvM(h-3gC(c^ zz8)I(;vb{I{kPbY{!TiOCp!)>dwK>rBSLFm_8?e|HW{M{WRA5>yn`lhbXd}Vq_WPc zMz?UL)t#dQAm(HMq@-C*hUn??Gd|Cb+T`fgbPNO(Otlmi(Nch&nm4tYn5HxNABjM7 zQz@PCIUWu42udeKc$dT9&jj*lIEtCm(nPGyvPNWTq)j%lewpU#j3wgIcDQ8hU$>VJ za1?)55Iy8FHH-OJ^ZJrg&m#z3n(bXbQZ1}6KOKKho#~r=+E-4`pKDcn)rx0+C-=qc zgbmk8?9*$x-?IIcw|vj#&|@a1nhp?_!pk7Po4NyYZvx~L-}(Njkx1%7i&G#cEJbfN zL@qVd;NzL>s3iT^jYQ9AiTPH#WPZT3I+a)7ON)S$ay7fm7t;M3nu_W&Bne}HR5Y)( z5KC=SY0Av+@yCt!PWPT@iiGdyKP)dwwCLYv=iS#>oV431R0vr4{Q*NNQo4>}@utvX zx7MWDhC78i{+BVn-)MrDt*M@N9@@Lf zfjMD%z>cp~vzPtTxC+0oVmK&5A-jX4SnJvgLq0oA1#NVxztVVv{>7em&Gs8<&_XBS zN@vkI`+SiPaKOvCc9Wo}a!2gk*||^0XvoaYZ6fRnqP5%dI^cV zJw0_;x{($+vbQy)3Ep-l1Mm{(dI5CO4Y*4baWTqR!COFGeErVGAdkt$m@L;E80|_L z%`HdR>IKhTKdqpUVVogS(Vz(2)CN+#++qL_SL^(8o2?L)eLjJ+c=*G$Hgd z5vwD&mXJO-_aJ8+H`W&I+1WjJeZ#2wnXVbJ>}Ytqa!Dy2Ue$Y`p8p`{4CNDCH?0_< z${P$GnY|ovuX5VheQs*Hla#ShsnEqq2d%<0bmP-INw}%RWj-?N0gA_kh4h*RL!95!l;Et zMt+UD4gbh&$*6CKjTp>#Xg6BAyja%u4)8MhEkdstuzMf+4dU-(aj~kyw_&pT|B5fi z?-coW=}zgdblFf|HbVL^CQlTB2txy#lm(n756o8>+b-Z}DJps|8nRhkcacQ-Y(ejG z25$NSQUkDQmE-|h0Py=!hYVS(-iKh4LB5Iw`5S~&CxOk2ck-K$CjQ_zugx~G?|z&L zkG^?!#-92k(ccn5@1}xgw~iMF_P^D` zFTZIdAZ*WLG$T>*!1_yrZHTgs3Dt#xN(Z0RpMzehu8-iLZl z=_-_FCd6DJ0b|r`v~^m~eU63OK_{ljH$f>=b^#v}HU@c<*A7X-^4tB2VJoN{*k=Fp z7vb1Tk6H(4*qlUo2)0itzfDrI?#~n?f&EXwR@x8TmA-=q5EBRmC+T{>o}G#e?)i?1ENXYB zx*sb>v)Shg#=c`NK$|bx{}cglsr+IkfIm|7i{5mGcyui?m!kiYxfHWTz+AG}OVO#% z!(|Tjl5OF~ij~mL1xjcMQik`unr#0WwojtHfNHb+>+05Bh~ABBeu=bP-0a*7g`2bu zjN!~U=XL?<2JB_GClnROcWkWhf{0ZIkoK?)p_RmI^e529wizwtwKbn`Q!RI~V}d;^ zlv8@;8`>iv<3Q+i+5Oowfzrl>`8gWi*)G%$h$HnB;^zRlUY%!z$)iOUywP(H>b^j= zTu0i6iGbY^zl#LQHN==qZi#ICgD?57P82nZz^<68{zh&x^q6IB65kBY(-6(=RZWD1 z1)%H!(o_vY)vDO9?S`mmk$@R@471OCkpv6Cvy

6_H5$@NXPid3d}1B6C*yW7eB} z-w3lWS(-$TZ;9U)uJXVCopC#U>)aol+W!)nc$qrq8YAQJ3P4_l_9$Wax^;FRp}l>X zzAXgT{_*91LI`{RwClKz2wr1>1(aBbcop$ynEpIRFHaM?ugX|Mnz;4nh$PR>>^$9} z?Pzt5%gT6^M$kz`=qfSLM9VlaP`RnWxmyLj3%~EJB><|Xs?XGAG^A4f`5)~9{i>YM z5CRFxS)|Ge?nRM7)`vwPycJwo0R11{UR$oHFv2;p-ap{yk_0h>^hMZd$h0n-nC-g+ zSz)yJk^=|n!!e~d-U43|;M~+(3dm(`AhDfr-*oSz&shcO*Y_xaW@~}h0o(+Rs#2{} z)gK)WetXdX*o4w4*F{COH!u1T2(Cdlm{3`Z;2OSI`U#C+lz)YZk@;7Xva^Jk2uw`Sf~nj8$iq?2MzIUz44YSL=c-LG*GXirA~IK@Y}1hTg-GOYMSaO+C|~FfdkkKbVkrf0hh7o|92xHb zOUX(A8vz9DFtB_8P!I(y9RTb5Bk~^?f>gV8>2X;C0d^0dal4HES;BNZ0EgSsz&map zoI~2*Vr-PzT_&TFC6iGTV>PNGnL%5rR>)K>V6GzCSyygx@SqqrubKaHPLdeh zjAMR`9jkbgNMZ%6scVj^ZAPElzM&^18gV*yE0z=Op=)BaGpd`fkC~3zNp{Ne&gIJ% z9Mm3mc8}HYc%IuVYH;p&a4w~gJQn;>W+|4EPE6N{+Au%#0l#4+r}lVOC(^8(u|v#& zyPOlfZ**kRh?6#*tUYivsZ(kd@$PDgakb8j?Cr7L^%GmLH>b=TUV8hDi<=z7SX0*z zw~;ZPx0PCA)zlL`d2PFiQIA%Pe@U;SbgZsVx8in1ay{S38m8`1sEme5r#>XqPBxTd z%ThctxN*kaPkYJ^Olm5v?HM^g?(bLNn4WBKt4Fs0?;d*ooD&oHBS$|7IctuYdsV;B zGyhaf{_aTKt%%bvkCbU?u5eN@@RzDh=Z=qb)|b9+>U~UqF;a7-HS+Nidu;wo&BDDS z(|xh|yS2>)89JTvxA^LHxuJ7(#T_WlIo*={<4Tr}MkXBL7nuac)X0-u9cf;{UU+h2 z>DP^NcRW;0E=kp;{}jk>R1XgdzHhfF+q|$TCY2#-a0%XC&>r77-|F#+D+y0->it?b zHuOXON5z=#p2qVM%#4$b4c&K*-ba02LyWyZt?0y;Pd5Y;K4X~^4xT#aBwKMz#&i@r z2Wdvmj4x=ppB6`WhYJgvzTcpeV2j0{e0jg^^`m7tJa%Wo>qoWD`&6@1jt@0-*MIEM zFp(tgi=u>DN4Xh0N)a{JEXU=T+e@3Ayz8K@1xQPKw?|oFJt%>#tB672Ns&tVubPxo z^H;CHwFMUE^WG}rNbUQDPlp3hF`ibHr))(h)vp>X^ZDkDxulzuJBYmcpF zvvMTPq#DdJbp702!^B2R3!5yzhE^U&xK19RrVTloVD&^MKLCL3^=a+G3lc9pPU+mm z=BisR8CLAM@+f1EX&&wELjq%OQk*znw(994iSbLE25CQg{FK>6Jg38>DMPM~8a2p=7jlD5y;7k?sd zuUud7hMe3G@zaF{@B|}7sc>hvl1kOj*|TBiM}tEe%#GwR-EOv-+4e%Yp*K)qPhn3vKx4+>0sOZLZ^RDnAm{;OnG3 zrfL>U6GQyb=(FIZ8R&vb^}HIV9y9TN$=Q*z^ zfZ6OWD(bNcwU6?!;7w>la*^H;qA8}SG3K{-_rw=()Ohb)M+7vcUOEKKJtlqJO@`^cRWS z1V!@LiuA+rnjXvg2BqUYaDK>}pnH>aq&@!1=Y;~xIP09Mq%4Q-r$ypJd=>QPW0+^^ zD(L1AHF>^wu0+)ii@xd+OoxMei2syV+pVeG5NnM>E%^1GLh$0s!(=k+NSyChpTLNu zX2YfgWiUZVfOZ28Uu)*KY{DW`y<0Z!4Ez$pPa3q%#UZ~JeV_y2$I{Bz#qRPMQ5UEN(>Rb5@xeea!i zu$7Zmmj;1Aa>wnCd;30XlO409?5@j_O?wfDmU6!g-tH%BeWuohr;*{Sor= zNO=T89szh#@<;&C%e_J6-sa^v003HQIaOFL6asVr(JJBUk3=8=Kp~Lm1PTCb63`0) zfHgFULZZ+~0Fq88(SfIsLdc_#2ow^DLLpFAE9n$En*!k3LMqOjiu0zH1AwDag;b%C zPRgT`2y_YnBsvA41-fC=*#HRXLg8f84K{_qrjXcl04QuW06?XXEffmNy@Bq8)N&!v z5uGGtQ-o}~5U5*af3;)b8kJM$#|A)e4FW+y$B!I57nU(S zFcqUY_UO}avPiOXlT(1a%h%XO}I%dHYfXHkc@3~e$aLyP)Dt!t7E1>^6R?ctvyVB--t z=P(>uLntgQ2$pqH<;fym&^^t7%ai;BEw#+}9`=_-zxC5*&`hhU>o8uNiX!xsDO4d> z=7WcJ<7a>j_28KO^u&Myp57Y1Zc!8WUTeS<8r3KxiPKfbb&PPDY0L;PuM{QGEHhC{ zQNZWaV+v$xLKAUCMY)!%n|U2J!kgqoPpOtGqN1N(T!J;XeXeDrbN%`{tGEbuYc@LM zOsY12g#N5;WnmZ+C+$Y>MdgWhi{BDcvzwGEFPOw(S8 zW)DxSIL(b|HyfS}UxX(c_PT`Rg1I9VDk@PEwPYW7Dsq1K^KO61mbc~F4=VNz@-^!C zDW@6@r#p0@WL*`8Ol!97a@ci7lU(Pf=sDV_CBj1MZkyC-;b>?YlT)49W{A98+(yR= zBY77y(d*|FoRIVPEA)cS-2tl=nyJ`3_!PPGLQsOX*{dCom&UwKai`cx)ha3JHf`0F zlO>7IvxOs$bI$_jPbdd&z-8sTI5ckqbGtb6CvEs)3sGImJLp9;_W^+`th?MwzU7N6 zEezc_GX>_-O0WgnK4a@rqgWcOLcW!|60Ws^XqN7MlajOzU2Xw1Z#0e@NDtcA)QowD zoVO2j9Qs*QWR{WHghk}$2TUj>b5p8gRq@4{hVGH9MvF~YlCN?y{9IYpIod9$l~dQi zr`k41agFW3)tgMekn*~!8ay(hl%c(g+`FIe3S$;{AegO=De;8kFx~1!!OivgCjDMn zWdXa;w54ieaRkvYr9bQSnR{Xgo}?|RY;yOrx%1abp|$Ml;TcD(qXd&%H3*LVWcIjU zYZ#?^DHg@64ii4wRX}`xwb*FEMxr?SK*=*_kxO3@CxQ6kVoEaoWiOtCZMw2xf1UPd7mIX21P}|h`Xo7eZVn|h)eHn| zVsi$g6e||FqEtY{a1ve>t0oFckxONmU0FWPJo_)!$)>_3aj;9jZDob=yni1tAYp;g z{>>sQAs)RPP@s6RkOITyR*83n>`4H=KEN=gg@)O z*#ZoRXWmDt7;dF%;>s*uSgo#)LtqAfaOG9W3(JgMa&6d9QhL7O?b;>2HkxwrZIvId z(E*l>2Zkiw=D43CkD!~bL;X<7<|y^#g*-i|{?^qcJJTcI(uuw2lifdQiaYMoz2zg} zB+b}+z@_FD>N2dGImKBuKq;}OC7e+0#x$*(J>)h{B-Rg{Y8Zv>2_AH@d`c|#pLcI< zm>1~`J^Wwt4VPxG`5vJDBd`wq)jQcRgq$c|1Puq`WA>7Zwx)s;`bz*JJfr@j?MaKA0Lz>0a6K8Y6A4Y-5{c?ZMH(Uxux zcB9ut4ajAS+?snKgOqOJP|dNlC2rRJ_z+~|x~P}A;yt(4MV*BOa&*GsuyKW>As(?I z_w_n_)<+v#H@5OaLNlFQ3dKj)mep-cfz_QdfvE4q#`Ly)N+0VdEIrjQLXGu2M=TI< zO7qBR|1UX=gR)LF2^GQj*z2uq+~7}4hzY1GCK1-r(k=HrnyGUYX2f?2$`fzG zyUi}Ji&NMOU+PDQt^CS2#O3|3*)pPtu}|?$!%}k+72fD7XYVXN14KtXWCk)N|Yr6Pom94s^yrTx zkE4~k@@yy0b5|nY%?F$eWMS)d;jaC6vFnQq#Qwk<|D(p)IXKN$7uZOj*`%i$o-BEW z;I=NkM;6*+S-eNP`gH&=KX+zAA6vbpjb5l(u?H@m&6#$jS+{4u_vi~n%I#JYwCh7U zgMVtAl0XQ)?S&^Fsw>uyqB;|$RC-+nGH!#kwQZ%}5;~BSni!(p=xP~e(_toDM5{#+ zYkqilp~OTm#eb?i_h>2wOTu2jBd)-^yI;v6w^M=-VB3Tvb4(R;>|9v0Crt-g@$P;sEQ!3O2%MXS4SW01CQxsyNC z5K&T+T=0c8zNQoTmd{(AGf_#8R~Vgs{<kG4RKoRE2OA82VN`)#Ea&&4XCtd(eYEcnE-`A!CdkW6UrOpWMO_iZeUoDt zWfWEYvmCfLG6G_|jh9?bMbS|~14U&KUa1RK{J10Fo0_38`K7Si^J|zI49Ll%0K*@{ zM+=zR77`hoX3iGmuPvNm$@1+>V?>m95~D-G=3TV-Xb=#<4PA>@#to;S!+at& z>o?am2lM$P3)UDOFR_1(i%JYANK;f4qX-5=kHA2ZN{XOEf4>;0iMu@t+Ot6sbm#9A z{;O-Rw)oZ+`rE@m>OjmLdDQL2v3Lx~==g7%#J`%i-zdx9+4${t_g7`ra-$DPt1dHu zKyXK4-%ClJcC4mMDk@?kA>SW@VZudqVlkk3NjqsU__Gpj0|fGMD|Cmb=+CyWZzLs8 zCt{vf>PTou2k)tzpO(m1QB)lIBxUzqyIG};Y6MeH|109YS=h}RQx=WGbZU&sh22o- z>!S6z4I05gsF~SGbfN>XJW}Nd43nb=-SP5meHRr1DLn@J#{E%DN&TEcvf;1vPNPFH zN%i`3$jrWl-C+MzU~nS|lthdh%`Gw?0}4>YZAcj#;+NsGWsl*TT&pk`5XoV!8wHC* z&r@HAbs8TMye*l8Ks2qu$FE zq6I#_849!djpF_P(;)W{%)z$2S_&|P9g4WFuIW{ch4(46Fc|XETYwq0ON?@Es)#B5 zohkZSLp@@}UTvC|cyk>JaytWsJ~$%rDNY)EefKVm0ieJCZeRa@1n>uw|DC1Z;u!v+ zlw@tOr|?m%?($L#7hvD9*bJRkQoPi&bJxp_-WwDzP5l1y_klP`tQMpHY zzqF);BdqVN=k>xpIT+0fFF(KPr1M{kCg9=i=bhd4-+c;#6%Yzt)=XEU?(DsUIhJuYg-ZOnM^B|@*fa78K}(wQK=zgx8! z)72#{<{SN53G90$R?Sbgm)O;{PRuuoxc4ifrmIU`%r~+|Y7L>GHCsv}qWtt-vyso) zY+cc(N*lfX!|cGmj&%AdNxQ9U!;bfC0{ec8G5VUbX< zb&ZqrTFz_(&U?e-B6dk?`vzy!2~JLf+zx2r_E)9GXzO=*(o+tx(LYpfUev&m@N(iY zDm0H;45r`t_Or6rYLD~^EbjljhwdRV%UQTI+C2sASGe>SuS%uu?03q#cs56gkMb$? zb4UekIDfHzR!np>?nFW1wm8iq<| zlYRWAe*8kdU|pxWZ<*)h&*ODbyHen%vSk?VXUF9!(k%z49eER7%i0npHdL-VOda@p zW#cOk!n}JbhSzO=rZw2R80hb|yk6dFwgb>Alf8Ktxb-6+b6MuRC z2|9}$JD(Bkc_nYp<@>*)Jjl(?GXJA8^4Gi0R zO=S%U5J>#fV>Ty#aZ9G#xAD$+tu3?Hp1+s@P~TM5_3i2+)Kp&6EwIjN8Xn~!23A*t zn5aBnYKpf5R8Z%R?obo=y63rMFH_;$=U zUITeg-T><%==2F-VFT*`VCKZVklZ`#OrBz13pPfCKe@ZkBpY~@vWqy;9|;73j$Z@2 zf9StIb_KygZ+-gy5AmU|DYRPW-yPbF`LixI_yIvjTGv^z)yQgZZm#tAhhZ332gi*% z_b{L`Njr5g_?i;V2na5=Kz)JW^(d?p2woGS5kNEb6+0k!G2=Z1nuL#T{Rh$RKNiYg zgvY-(_&2V_c01}W~%+Xg&2yAq-4++QJto7&3^3!tHq>8UlGlkmga={ z%;6dKbiK@kc6EavB?A1c1S=fUyGkR__p3qU~#zqkm(j zzIEskx56PHA_Y`_63Cy@Vya{63t0xl^DqqHIlpVW5hUpAaTL$#@iMpwgJCZJlD5TX zl3wY4?S`V6aZ2mC>k;~&rdqJSNVU|Jz~Hs4$!y(9>@y+xYs!?8A>%jG88ggvi*dsn z!hapYcw#7~wPdqLvy2fCiUT4c(W+WVSR~%#SAv?Yn^!Z^|1jJ5B@O?5(!cwezi~qI zFEEW=49Sr2UkRj)4)F_<>W2udmw?j% zsd^~mY*o0bw{DF=AduHH-(xImt-_eo!`wuP3J*9DI6&G{qXS)(Als;}2$^p$0%vWP z5NGAz!#CA*qQO9+(hTZ|L{ICj0Dcb?2iz1+j&fJe!x-nCWAX;RsDk1H0CI71UHR!mjFiboqMN5`UQ!lVo*#~;^9Jn&L(L-kriGjgGZ!sCCh*OVBdfD2E4#t-0S#Y zkUo6j@%2P-s?A~%PqRfi^vBl*E}q8@8|O6O))Et~Oj(b}2+q!eN5P%}o+{G)-~Vx( zC~-uXv6Ti=sCH@}>dzbc!Qv9()pji=gM$lNpr9XiB2j9RWI zqAurK^Shf849n4{+q$!GoE3MkrG&lCrqowQptySS5Fu}%bWQAam%|YP@)82*o zO~uc%s0)sn<+hGU$H1n5?0z3s8gXO%(P&Ln$xEgUkRAm_O^l$bsRqJyD~$x7$dFgl zXX&h7?!duD6FN6PW`d?Q@Ez6KWl_ud2Xg6cRlHV^G^uylZHahL&w6h(`Ow37Bi==R|s%0X{!| zJx&~rpL!Q2xR5Wr)F%40CI8hiSK>xe-^z9OlCh8wmV#$UG~RDFR7T~jany@sLUKx$ zI_Y*oX{7#x)k#pQsunTt$kko5T-1A(vCw|%T${b)!>t|h0krQLx7a+eaCKVL#@Xrt zOTj2QySRP=WqkD(Lv3Zyb=ckc&uE4vy3SrMU*0#!aB-KopMCl2Q^vE25uf7b-mrAy z#(Y4f-WRPf7+LL#=o^BPgZI!yTLTQO&JQX)opvjFn@D%)rW^)7CbG5rkG#|{b)HaI zsFes(1OHf>TOo0lw#2Ltm~BK7i_=bhyR9uXY9d4Tg)!%Wh}2Inrrus`lW)ZpglYkA+Un@KpbWE8t;CNl9B) z(iEfi%V+v=pP1G28DY<4Ds$DXqAe@u!&zev_%YY?nybxCy2AM~_H(AZhbl6ZW1!VA z@fGeJOD{m;|TAIj7u3ORY@ziPU)w>$_#8t+#aF?>=;c-5NX>b6E85VLfQ6t}+fi zH-grTiZ&)#d~g|^NHn>)MH$zsn~O3ZC)XzkhNwAFii+}Cm=764`LCM2!1svKevGcx z)s3TuqM|J+8SeiESJS9A+zYgojpSs$E7$RDSXYWQsupUm*kpv4f zolWwOfX2<3lka2a`;`ZE5C+gjQjSkMJR?(P%B!T}Ii4OB;4|?!Uh+5JhW^!Csej+? d->6W;Bt!e~Cn>r7)sIJyA9XnL^3bI_{{ + 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 index d3908b8..cf9445d 100644 --- a/vignettes/articles/modelsummary_integration.Rmd.txt +++ b/vignettes/articles/modelsummary_integration.Rmd.txt @@ -175,3 +175,41 @@ 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/repeated_resampling.Rmd b/vignettes/articles/repeated_resampling.Rmd index 1b3e7fd..f47fe10 100644 --- a/vignettes/articles/repeated_resampling.Rmd +++ b/vignettes/articles/repeated_resampling.Rmd @@ -87,7 +87,7 @@ fit_rep <- ddml_replicate( # Observe the class of the returned object class(fit_rep) -#> [1] "ddml_rep" +#> [1] "ddml_rep" "ral_rep" ``` # Interacting with ``ddml_rep`` Objects @@ -127,6 +127,8 @@ 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: @@ -196,7 +198,7 @@ Because a ``ddml_rep`` object is essentially a structured list of pure ``ddml`` # Extract the 3rd replicate fit run_3 <- fit_rep[[3]] class(run_3) -#> [1] "ddml_plm" "ddml" +#> [1] "ddml_plm" "ddml" "ral" # View its specific diagnostics diagnostics(run_3) @@ -238,7 +240,7 @@ fits_list <- lapply(1:3, function(r) { # 2. Combine them into a ddml_rep object manual_rep <- ddml_rep(fits_list) class(manual_rep) -#> [1] "ddml_rep" +#> [1] "ddml_rep" "ral_rep" # 3. Aggregate results summary(manual_rep) diff --git a/vignettes/articles/stacking.Rmd b/vignettes/articles/stacking.Rmd index ecd52f2..18a7312 100644 --- a/vignettes/articles/stacking.Rmd +++ b/vignettes/articles/stacking.Rmd @@ -82,11 +82,11 @@ Both stacking and short-stacking construct weighted averages of the considered b ```r cat("Time single learner:", time_singlelearner[1], "\n") -#> Time single learner: 2.14 +#> Time single learner: 2.17 cat("Time short-stacking:", time_shortstacking[1], "\n") -#> Time short-stacking: 5 +#> Time short-stacking: 4.55 cat("Time stacking: ", time_stacking[1]) -#> Time stacking: 24.44 +#> Time stacking: 22.23 ``` # References diff --git a/vignettes/ddml.Rmd b/vignettes/ddml.Rmd index ca4af42..ebc8d0d 100644 --- a/vignettes/ddml.Rmd +++ b/vignettes/ddml.Rmd @@ -173,19 +173,19 @@ summary(late_fit) #> DDML estimation: Local Average Treatment Effect #> Obs: 5000 Folds: 3 Stacking: short-stack #> -#> Ensemble type: nnls +#> Ensemble type: nnls #> Estimate Std. Error z value Pr(>|z|) #> LATE -0.231 0.189 -1.22 0.22 #> -#> Ensemble type: singlebest +#> Ensemble type: singlebest #> Estimate Std. Error z value Pr(>|z|) #> LATE -0.227 0.188 -1.21 0.23 #> -#> Ensemble type: ols +#> Ensemble type: ols #> Estimate Std. Error z value Pr(>|z|) #> LATE -0.231 0.189 -1.22 0.22 #> -#> Ensemble type: average +#> Ensemble type: average #> Estimate Std. Error z value Pr(>|z|) #> LATE -0.228 0.189 -1.21 0.23 ``` diff --git a/vignettes/precompile.R b/vignettes/precompile.R index 8c585ef..595ff6a 100644 --- a/vignettes/precompile.R +++ b/vignettes/precompile.R @@ -76,15 +76,19 @@ for (v in VIGNETTES) { next } + 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")) { + if (identical(v$name, "did") || identical(v$name, "did_native")) { old_wd <- setwd("vignettes/articles") - on.exit(setwd(old_wd), add = TRUE) - knit("did.Rmd.txt", "did.Rmd") - setwd(old_wd) - on.exit(NULL) + tryCatch( + knit(basename(v$src), basename(v$out)), + finally = setwd(old_wd)) } else { knit(v$src, v$out) } From edd6a88af68e06487750ee9a9bc22e873b1a6461 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Thu, 26 Mar 2026 11:03:06 -0500 Subject: [PATCH 37/46] multi ensemble tidy + docs + cvc vectorization --- NAMESPACE | 4 + R/ddml.R | 78 +++++++++++- R/ddml_rep.R | 48 +++++++ R/diagnostics.R | 9 +- R/lincom.R | 120 ++++++++++++------ R/lincom_weights.R | 59 ++++++--- R/ral.R | 86 ++++++++++++- R/ral_rep.R | 31 +++++ man/as.list.ddml.Rd | 37 ++++++ man/as.list.ddml_rep.Rd | 34 +++++ man/as.list.ral.Rd | 26 ++++ man/as.list.ral_rep.Rd | 21 +++ man/ddml-intro.Rd | 2 +- man/ddml_apo.Rd | 5 +- man/ddml_pliv.Rd | 1 + man/lincom.Rd | 10 +- man/lincom_weights_did.Rd | 6 +- man/vcov.ral.Rd | 13 ++ tests/testthat/test-ddml.R | 32 +++++ tests/testthat/test-ddml_rep.R | 31 +++++ tests/testthat/test-lincom.R | 95 ++++++++++++++ tests/testthat/test-ral.R | 31 +++++ .../articles/modelsummary_integration.Rmd | 61 +++++++-- .../articles/modelsummary_integration.Rmd.txt | 45 +++++-- vignettes/articles/stacking.Rmd | 6 +- 25 files changed, 788 insertions(+), 103 deletions(-) create mode 100644 man/as.list.ddml.Rd create mode 100644 man/as.list.ddml_rep.Rd create mode 100644 man/as.list.ral.Rd create mode 100644 man/as.list.ral_rep.Rd diff --git a/NAMESPACE b/NAMESPACE index 97b2a60..70a1061 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,10 @@ 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) diff --git a/R/ddml.R b/R/ddml.R index 3ac35b3..67a37d2 100644 --- a/R/ddml.R +++ b/R/ddml.R @@ -50,7 +50,7 @@ #' #' The variance of \eqn{\hat\theta} is then estimated by #' -#' \deqn{\hat{V} = \frac{1}{n} \sum_i +#' \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})'}, @@ -614,3 +614,79 @@ glance.ddml <- function(x, ...) { 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_rep.R b/R/ddml_rep.R index f1c062c..ceaed86 100644 --- a/R/ddml_rep.R +++ b/R/ddml_rep.R @@ -365,3 +365,51 @@ glance.ddml_rep <- function(x, ...) { 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 index 6efe691..7771b39 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -189,12 +189,11 @@ cvc_one_vs_many <- function(resid_base, resid_others, fid, # Sup-type test statistic Tx <- max(sqrt(n) * zeta_m / zeta_sd) - # Multiplier bootstrap + # Multiplier bootstrap (vectorized via matrix multiply) zeta_scaled <- sweep(zeta_til, 2, zeta_sd, FUN = "/") - Txb <- vapply(seq_len(bootnum), function(b) { - bw <- stats::rnorm(n) - max(colSums(zeta_scaled * bw) / sqrt(n)) - }, numeric(1)) + 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 diff --git a/R/lincom.R b/R/lincom.R index de9db86..da0e1d8 100644 --- a/R/lincom.R +++ b/R/lincom.R @@ -68,8 +68,10 @@ #' @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. -#' Default 1. +#' @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. @@ -140,7 +142,7 @@ lincom <- function(fit, R, ...) { #' @export #' @method lincom ddml lincom.ddml <- function(fit, R, - fit_idx = 1, + fit_idx = NULL, labels = NULL, inf_func_R = NULL, dinf_dR = NULL, @@ -151,56 +153,92 @@ lincom.ddml <- function(fit, R, n <- fit$nobs stopifnot(nrow(R) == p) - # Point estimate: R'theta - theta <- fit$coefficients[, fit_idx] - lincom_coef <- as.numeric(crossprod(R, theta)) + # 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) - # Unit-level IF for theta: phi_i - theta_if <- fit$inf_func[, , fit_idx, drop = FALSE] - dim(theta_if) <- dim(theta_if)[1:2] - - # Combined IF for R'theta - # Term 1: R' phi_i^theta - lincom_if <- theta_if %*% R # n x q - # Term 2: delta-method correction (when R estimated) + # 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) - for (k in seq_len(q)) { - lincom_if[, k] <- lincom_if[, k] + inf_func_R[, , k] %*% theta - }#FOR + 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 - # Map Structural Leverage + # Allocate output arrays + coef_mat <- matrix(NA_real_, q, nfit) + lincom_if <- array(0, dim = c(n, q, nfit)) dinf_dtheta <- NULL - if (!is.null(fit$dinf_dtheta)) { - dinf_j <- fit$dinf_dtheta[, , , fit_idx, drop = FALSE] - dinf_lc <- array(NA_real_, dim = c(n, q, q, 1)) - for (i in seq_len(n)) { - dinf_i <- matrix(dinf_j[i, , , 1], p, p) - # Structural Leverage: R^T * dinf_i * R - dinf_lc[i, , , 1] <- t(R) %*% dinf_i %*% R - }#FOR - dinf_dtheta <- dinf_lc - if (!is.null(dinf_dR)) { - stopifnot(dim(dinf_dR)[1:3] == c(n, q, q)) - if (length(dim(dinf_dR)) == 3) dim(dinf_dR) <- c(n, q, q, 1) - dinf_dtheta <- dinf_dtheta + dinf_dR + 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 - }#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)) - # Package as lincom > ral - coef_mat <- matrix(lincom_coef, nrow = q, ncol = 1) + # 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) <- "lincom" + colnames(coef_mat) <- fit_labels ral(coefficients = coef_mat, - inf_func = array(lincom_if, dim = c(n, q, 1)), + inf_func = lincom_if, dinf_dtheta = dinf_dtheta, nobs = n, coef_names = labels, @@ -217,7 +255,7 @@ lincom.ddml <- function(fit, R, #' @method lincom ddml_rep lincom.ddml_rep <- function(fit, R, inf_func_R = NULL, dinf_dR = NULL, - fit_idx = 1, + fit_idx = NULL, labels = NULL, ...) { # Apply lincom.ddml to each rep lc_fits <- lapply(fit$fits, function(f) { @@ -239,6 +277,8 @@ lincom.ddml_rep <- function(fit, R, inf_func_R = NULL, 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") @@ -252,6 +292,8 @@ 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 diff --git a/R/lincom_weights.R b/R/lincom_weights.R index 19b6bf8..62f3ad6 100644 --- a/R/lincom_weights.R +++ b/R/lincom_weights.R @@ -57,7 +57,9 @@ #' 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. Default 1. +#' 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{ @@ -109,7 +111,7 @@ lincom_weights_did <- function(fit, type = c("dynamic", "group", "simple", "calendar"), min_e = -Inf, max_e = Inf, - fit_idx = 1) { + fit_idx = NULL) { type <- match.arg(type) ref <- if (inherits(fit, "ddml_rep")) { fit[[1]] @@ -189,23 +191,46 @@ lincom_weights_did <- function(fit, # 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 - theta <- ref$coefficients[, fit_idx] - gamma <- as.numeric(crossprod(R, theta)) # q-vector + nensb <- ncol(ref$coefficients) nG <- length(glist) - 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 (j in seq_len(nG)) { - cells_gk <- keepers[group[keepers] == glist[j]] - if (length(cells_gk) > 0L) { - V[j, k] <- sum(theta[cells_gk] - gamma[k]) / S_k - }#IF + 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 - }#FOR - VtV <- crossprod(V) # q x q, constant - dinf_dR <- array(rep(VtV, each = n), dim = c(n, q, q)) + 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, diff --git a/R/ral.R b/R/ral.R index cd6fc6c..41ebaec 100644 --- a/R/ral.R +++ b/R/ral.R @@ -248,6 +248,19 @@ hatvalues.ral <- function(model, fit_idx = 1, ...) { #' 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), @@ -271,13 +284,17 @@ vcov.ral <- function(object, fit_idx = 1, 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 + # Cluster aggregation: rescale to cluster-level influence functions clustered <- !is.null(object$cluster_variable) && - length(unique(object$cluster_variable)) < nrow(if_j) - if (clustered) if_j <- rowsum(if_j, 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)) @@ -360,8 +377,10 @@ confint.ral <- function(object, parm = NULL, level = 0.95, inf_func <- object$inf_func[, , fit_idx, drop = FALSE] dim(inf_func) <- dim(inf_func)[1:2] cl <- object$cluster_variable - if (!is.null(cl) && length(unique(cl)) < nrow(inf_func)) { + 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) @@ -673,3 +692,60 @@ plot.ral <- function(x, parm = NULL, level = 0.95, 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 index 06b7809..1270db3 100644 --- a/R/ral_rep.R +++ b/R/ral_rep.R @@ -582,3 +582,34 @@ plot.ral_rep <- function(x, parm = NULL, level = 0.95, 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/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/ddml-intro.Rd b/man/ddml-intro.Rd index 40bcbbc..44047cf 100644 --- a/man/ddml-intro.Rd +++ b/man/ddml-intro.Rd @@ -157,7 +157,7 @@ and the influence function The variance of \eqn{\hat\theta} is then estimated by -\deqn{\hat{V} = \frac{1}{n} \sum_i +\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})'}, diff --git a/man/ddml_apo.Rd b/man/ddml_apo.Rd index 5e24b66..1cf188a 100644 --- a/man/ddml_apo.Rd +++ b/man/ddml_apo.Rd @@ -172,9 +172,8 @@ 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. - -where \eqn{\omega(X)} is a known weighting function. If \eqn{\omega(X) = 1}, +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}. diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index 7224cb9..d5ec65c 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -165,6 +165,7 @@ Machine Learning estimator for the partially linear instrumental variable 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. + \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))} diff --git a/man/lincom.Rd b/man/lincom.Rd index 5e655c3..c54976f 100644 --- a/man/lincom.Rd +++ b/man/lincom.Rd @@ -13,7 +13,7 @@ lincom(fit, R, ...) \method{lincom}{ddml}( fit, R, - fit_idx = 1, + fit_idx = NULL, labels = NULL, inf_func_R = NULL, dinf_dR = NULL, @@ -25,7 +25,7 @@ lincom(fit, R, ...) R, inf_func_R = NULL, dinf_dR = NULL, - fit_idx = 1, + fit_idx = NULL, labels = NULL, ... ) @@ -42,8 +42,10 @@ Each column defines one linear combination.} \item{...}{Currently unused.} -\item{fit_idx}{Integer index of the fit to use. -Default 1.} +\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 diff --git a/man/lincom_weights_did.Rd b/man/lincom_weights_did.Rd index e328bf9..d132a97 100644 --- a/man/lincom_weights_did.Rd +++ b/man/lincom_weights_did.Rd @@ -9,7 +9,7 @@ lincom_weights_did( type = c("dynamic", "group", "simple", "calendar"), min_e = -Inf, max_e = Inf, - fit_idx = 1 + fit_idx = NULL ) } \arguments{ @@ -24,7 +24,9 @@ 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. Default 1.} +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: diff --git a/man/vcov.ral.Rd b/man/vcov.ral.Rd index 6f4662f..d7c0b3f 100644 --- a/man/vcov.ral.Rd +++ b/man/vcov.ral.Rd @@ -44,6 +44,19 @@ variance estimators are available: 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}}, diff --git a/tests/testthat/test-ddml.R b/tests/testthat/test-ddml.R index e006da7..738058c 100644 --- a/tests/testthat/test-ddml.R +++ b/tests/testthat/test-ddml.R @@ -610,3 +610,35 @@ test_that("hatvalues warns and returns NA if dinf_dtheta is missing", { 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_rep.R b/tests/testthat/test-ddml_rep.R index 12af5a4..e135427 100644 --- a/tests/testthat/test-ddml_rep.R +++ b/tests/testthat/test-ddml_rep.R @@ -463,3 +463,34 @@ test_that("type argument threads through ddml_rep methods", { 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-lincom.R b/tests/testthat/test-lincom.R index 879c46a..cef8fb1 100644 --- a/tests/testthat/test-lincom.R +++ b/tests/testthat/test-lincom.R @@ -362,3 +362,98 @@ test_that("lincom_rep HC3 vcov works now", { 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-ral.R b/tests/testthat/test-ral.R index 392bfa1..25b7d75 100644 --- a/tests/testthat/test-ral.R +++ b/tests/testthat/test-ral.R @@ -441,3 +441,34 @@ test_that("plot.ral with parm selects subset", { 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/vignettes/articles/modelsummary_integration.Rmd b/vignettes/articles/modelsummary_integration.Rmd index 5b8cc3a..900f9e6 100644 --- a/vignettes/articles/modelsummary_integration.Rmd +++ b/vignettes/articles/modelsummary_integration.Rmd @@ -138,24 +138,45 @@ if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinyta Notice how ``modelsummary`` automatically pulled the custom goodness-of-fit metrics from ``glance.ddml()`` (e.g., ``sample_folds``, ``shortstack``, ``ensemble_type``). -If you wish to show the results for the *other* ensemble type (``singlebest``) in the table, ``modelsummary`` requires us to pass either a custom tidier or explicitly extract and rename the components. A simple robust trick is to manually tidy the ``ddml`` output first when dealing with secondary ensembles. +## 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 -# Retrieve tidied data.frames -df_nnls <- tidy(ddml_fit, ensemble_idx = 1) -df_singlebest <- tidy(ddml_fit, ensemble_idx = 2) +# 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( - list("DDML (NNLS)" = df_nnls, "DDML (Single Best)" = df_singlebest), - title = "Comparison of Stacking Approaches", - shape = term ~ model + statistic, - gof_map = NA # We omit model statistics since we passed data.frames directly + 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()``. @@ -164,11 +185,16 @@ These aggregated ``ddml_rep`` classes have their own ``tidy`` and ``glance`` met ```r -# Compute a replicated DDML object +# 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)), + learners = list( + list(what = ols), + list(what = mdl_glmnet) + ), + ensemble_type = c("nnls", "singlebest"), + shortstack = TRUE, resamples = 3, sample_folds = 5, silent = TRUE @@ -176,9 +202,9 @@ repl_fit <- ddml_replicate( # Extract aggregated coefficients tidy(repl_fit) -#> term estimate std.error statistic p.value ensemble_type -#> 1 D1 -0.185302213 0.03208110 -5.77605637 7.647176e-09 nnls -#> 2 (Intercept) -0.000510678 0.01526034 -0.03346438 9.733043e-01 nnls +#> 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 @@ -190,6 +216,15 @@ if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinyta } ``` +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. diff --git a/vignettes/articles/modelsummary_integration.Rmd.txt b/vignettes/articles/modelsummary_integration.Rmd.txt index cf9445d..6341a34 100644 --- a/vignettes/articles/modelsummary_integration.Rmd.txt +++ b/vignettes/articles/modelsummary_integration.Rmd.txt @@ -116,23 +116,35 @@ if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinyta Notice how ``modelsummary`` automatically pulled the custom goodness-of-fit metrics from ``glance.ddml()`` (e.g., ``sample_folds``, ``shortstack``, ``ensemble_type``). -If you wish to show the results for the *other* ensemble type (``singlebest``) in the table, ``modelsummary`` requires us to pass either a custom tidier or explicitly extract and rename the components. A simple robust trick is to manually tidy the ``ddml`` output first when dealing with secondary ensembles. +## 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} -# Retrieve tidied data.frames -df_nnls <- tidy(ddml_fit, ensemble_idx = 1) -df_singlebest <- tidy(ddml_fit, ensemble_idx = 2) +# 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( - list("DDML (NNLS)" = df_nnls, "DDML (Single Best)" = df_singlebest), - title = "Comparison of Stacking Approaches", - shape = term ~ model + statistic, - gof_map = NA # We omit model statistics since we passed data.frames directly + 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()``. @@ -140,11 +152,16 @@ Stata uses repeated cross-fitting by default (where the user averages coefficien These aggregated ``ddml_rep`` classes have their own ``tidy`` and ``glance`` methods mimicking their base equivalents. ```{r} -# Compute a replicated DDML object +# 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)), + learners = list( + list(what = ols), + list(what = mdl_glmnet) + ), + ensemble_type = c("nnls", "singlebest"), + shortstack = TRUE, resamples = 3, sample_folds = 5, silent = TRUE @@ -160,6 +177,14 @@ if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinyta } ``` +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. diff --git a/vignettes/articles/stacking.Rmd b/vignettes/articles/stacking.Rmd index 18a7312..385d623 100644 --- a/vignettes/articles/stacking.Rmd +++ b/vignettes/articles/stacking.Rmd @@ -82,11 +82,11 @@ Both stacking and short-stacking construct weighted averages of the considered b ```r cat("Time single learner:", time_singlelearner[1], "\n") -#> Time single learner: 2.17 +#> Time single learner: 2.09 cat("Time short-stacking:", time_shortstacking[1], "\n") -#> Time short-stacking: 4.55 +#> Time short-stacking: 5.75 cat("Time stacking: ", time_stacking[1]) -#> Time stacking: 22.23 +#> Time stacking: 27.11 ``` # References From 228197f0ba05fea9bb96fea6d1d904c2fd3f8b9f Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Thu, 26 Mar 2026 18:04:58 -0500 Subject: [PATCH 38/46] news + docs + mdl_Glm renamed --- NAMESPACE | 4 ++-- NEWS.md | 30 ++++++++++++------------------ R/diagnostics.R | 2 +- R/ml_wrappers.R | 16 ++++++++-------- _pkgdown.yml | 3 ++- man/mdl_bigGLM.Rd | 10 +++++----- man/mdl_glm.Rd | 2 +- man/mdl_glmnet.Rd | 2 +- man/mdl_ranger.Rd | 2 +- man/mdl_xgboost.Rd | 2 +- man/ols.Rd | 2 +- man/predict.mdl_bigGLM.Rd | 12 ++++++------ 12 files changed, 41 insertions(+), 46 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 70a1061..eb7f493 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,7 +23,7 @@ S3method(nobs,ral_rep) S3method(plot,ral) S3method(plot,ral_rep) S3method(predict,ensemble) -S3method(predict,mdl_bigGLM) +S3method(predict,mdl_bigGlm) S3method(predict,mdl_glm) S3method(predict,mdl_glmnet) S3method(predict,mdl_ranger) @@ -68,7 +68,7 @@ export(ensemble_weights) export(glance) export(lincom) export(lincom_weights_did) -export(mdl_bigGLM) +export(mdl_bigGlm) export(mdl_glm) export(mdl_glmnet) export(mdl_ranger) diff --git a/NEWS.md b/NEWS.md index 9140573..e5c1a74 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,25 +1,19 @@ # ddml 0.9.0 -* Adds `ddml_apo()` for average potential outcome estimation. -* Adds `fitted` and `splits` parameters to all `ddml_*()` estimators for re-estimation with different ensemble types without re-fitting base learners. -* Adds `diagnostics()` for per-equation MSPE, R-squared, stacking weights, and cross-validated comparison (CVC) tests. -* Adds HC0 and HC3 variance estimators alongside default HC1 via `type` argument in `vcov()`, `confint()`, `summary()`, and `tidy()`. -* Adds `hatvalues()` method for leverage diagnostics. -* Adds `nobs()` method returning the number of observations. -* Learner specifications now use `what` instead of `fun`. `fun` is accepted with a deprecation message. -* Adds parallel computation via the `parallel` parameter and progress reporting via `pbapply`. -* Adds stratified cross-fitting to `ddml_ate()`, `ddml_att()`, and `ddml_late()` via `stratify`. Enabled by default. -* Adds `cluster_variable` for cluster-aware sample splitting. -* Adds input validation across all estimators. -* Exports `ensemble()` with documentation and examples. -* Adds `broom` compatibility (`tidy`, `glance`). -* Updates S3 methods (`coef`, `vcov`, `confint`, `summary`, `print`). -* Adds `mdl_bigGLM` sparse-matrix unpenalized regression wrapper. -* `mdl_xgboost()` auto-detects binary factor outcomes. -* Adds `ddml_rep()` and `ddml_replicate()` for repeated cross-fitting with median or mean aggregation. -* `predict.ensemble()` gains `type` argument (`"ensemble"` or `"bylearner"`). +* 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 HC0/HC3 variance estimators, parallel computation, stratified cross-fitting, cluster-aware splitting, and input validation. +* Adds `broom` compatibility and `mdl_bigGlm` wrapper. +* Rewrites DiD and `modelsummary` vignettes. * 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. diff --git a/R/diagnostics.R b/R/diagnostics.R index 7771b39..7cb7bef 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -189,7 +189,7 @@ cvc_one_vs_many <- function(resid_base, resid_others, fid, # Sup-type test statistic Tx <- max(sqrt(n) * zeta_m / zeta_sd) - # Multiplier bootstrap (vectorized via matrix multiply) + # 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 diff --git a/R/ml_wrappers.R b/R/ml_wrappers.R index cbeae36..df6d328 100644 --- a/R/ml_wrappers.R +++ b/R/ml_wrappers.R @@ -258,7 +258,7 @@ predict.mdl_glm <- function(object, newdata, ...) { stats::predict.glm(object, df, type = "response", ...) }#PREDICT.MDL_GLM -# bigGLM ======================================================================= +# bigGlm ======================================================================= #' Wrapper for glmnet::bigGlm() #' @@ -273,29 +273,29 @@ predict.mdl_glm <- function(object, newdata, ...) { #' @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}. +#' @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)) +#' bigglm_fit <- mdl_bigGlm(rnorm(100), matrix(rnorm(1000), 100, 10)) #' class(bigglm_fit) -mdl_bigGLM <- function(y, X, ...) { +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)) + class(mdl_fit) <- c("mdl_bigGlm", class(mdl_fit)) return(mdl_fit) }#MDL_BIGGLM -#' Predict Method for mdl_bigGLM Objects +#' Predict Method for mdl_bigGlm Objects #' -#' @param object A fitted \code{mdl_bigGLM} object. +#' @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, ...) { +predict.mdl_bigGlm <- function(object, newdata = NULL, ...) { beta <- object$fitted_coef fitted <- newdata %*% beta[2:nrow(beta), , drop = FALSE] + beta[1, 1] fitted[, 1] diff --git a/_pkgdown.yml b/_pkgdown.yml index 22474be..902f80a 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -64,7 +64,7 @@ reference: - mdl_glmnet - mdl_ranger - mdl_xgboost - - mdl_bigGLM + - mdl_bigGlm - title: Utilities contents: @@ -98,6 +98,7 @@ reference: - matches("tidy") - matches("glance") - matches("predict") + - matches("as.list") - ensemble_weights - reexports diff --git a/man/mdl_bigGLM.Rd b/man/mdl_bigGLM.Rd index 7298c59..8fac4a5 100644 --- a/man/mdl_bigGLM.Rd +++ b/man/mdl_bigGLM.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/ml_wrappers.R -\name{mdl_bigGLM} -\alias{mdl_bigGLM} +\name{mdl_bigGlm} +\alias{mdl_bigGlm} \title{Wrapper for glmnet::bigGlm()} \usage{ -mdl_bigGLM(y, X, ...) +mdl_bigGlm(y, X, ...) } \arguments{ \item{y}{The outcome variable.} @@ -15,13 +15,13 @@ mdl_bigGLM(y, X, ...) \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}. +\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)) +bigglm_fit <- mdl_bigGlm(rnorm(100), matrix(rnorm(1000), 100, 10)) class(bigglm_fit) } \seealso{ diff --git a/man/mdl_glm.Rd b/man/mdl_glm.Rd index 3b246bc..778366e 100644 --- a/man/mdl_glm.Rd +++ b/man/mdl_glm.Rd @@ -30,7 +30,7 @@ class(glm_fit) \code{\link[stats:glm]{stats::glm()}} Other ml_wrapper: -\code{\link{mdl_bigGLM}()}, +\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 b65f878..ea7ef98 100644 --- a/man/mdl_glmnet.Rd +++ b/man/mdl_glmnet.Rd @@ -42,7 +42,7 @@ Statistical Software, 39(5), 1-13. \code{\link[glmnet:glmnet]{glmnet::glmnet()}},\code{\link[glmnet:cv.glmnet]{glmnet::cv.glmnet()}} Other ml_wrapper: -\code{\link{mdl_bigGLM}()}, +\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 441fd4b..1103ee0 100644 --- a/man/mdl_ranger.Rd +++ b/man/mdl_ranger.Rd @@ -35,7 +35,7 @@ Software 77(1), 1-17. \code{\link[ranger:ranger]{ranger::ranger()}} Other ml_wrapper: -\code{\link{mdl_bigGLM}()}, +\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 a443d9b..1abc15a 100644 --- a/man/mdl_xgboost.Rd +++ b/man/mdl_xgboost.Rd @@ -44,7 +44,7 @@ Discovery and Data Mining, 785-794. \code{\link[xgboost:xgboost]{xgboost::xgboost()}} Other ml_wrapper: -\code{\link{mdl_bigGLM}()}, +\code{\link{mdl_bigGlm}()}, \code{\link{mdl_glm}()}, \code{\link{mdl_glmnet}()}, \code{\link{mdl_ranger}()}, diff --git a/man/ols.Rd b/man/ols.Rd index a6a01a6..863c406 100644 --- a/man/ols.Rd +++ b/man/ols.Rd @@ -35,7 +35,7 @@ ols_fit$coef } \seealso{ Other ml_wrapper: -\code{\link{mdl_bigGLM}()}, +\code{\link{mdl_bigGlm}()}, \code{\link{mdl_glm}()}, \code{\link{mdl_glmnet}()}, \code{\link{mdl_ranger}()}, diff --git a/man/predict.mdl_bigGLM.Rd b/man/predict.mdl_bigGLM.Rd index 1cdfbf5..74714c9 100644 --- a/man/predict.mdl_bigGLM.Rd +++ b/man/predict.mdl_bigGLM.Rd @@ -1,13 +1,13 @@ % 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} +\name{predict.mdl_bigGlm} +\alias{predict.mdl_bigGlm} +\title{Predict Method for mdl_bigGlm Objects} \usage{ -\method{predict}{mdl_bigGLM}(object, newdata = NULL, ...) +\method{predict}{mdl_bigGlm}(object, newdata = NULL, ...) } \arguments{ -\item{object}{A fitted \code{mdl_bigGLM} object.} +\item{object}{A fitted \code{mdl_bigGlm} object.} \item{newdata}{A (sparse) feature matrix for prediction.} @@ -17,5 +17,5 @@ A numeric vector of predicted values. } \description{ -Predict Method for mdl_bigGLM Objects +Predict Method for mdl_bigGlm Objects } From 62e0ebc547f1911ed3beaa23fbaf56f437898909 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Fri, 27 Mar 2026 13:36:50 -0500 Subject: [PATCH 39/46] update news --- NEWS.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index e5c1a74..03cc072 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,9 +8,9 @@ * 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 and `mdl_bigGlm` wrapper. -* Rewrites DiD and `modelsummary` vignettes. +* Adds `broom` compatibility. * Fixes `ddml_fpliv()` with custom weights. * Breaking changes: - Inference internals use `$inf_func` instead of `$scores`/`$J`/`$psi_a`/`$psi_b`. From ac4fa0a5e2ade85178652b08a52533f5a2b91571 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Fri, 27 Mar 2026 16:16:30 -0500 Subject: [PATCH 40/46] help_function cleanup --- R/diagnostics.R | 3 ++- R/help_functions.R | 15 ++------------- 2 files changed, 4 insertions(+), 14 deletions(-) diff --git a/R/diagnostics.R b/R/diagnostics.R index 7cb7bef..0e778f0 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -122,7 +122,8 @@ diagnostics <- function(object, cvc = FALSE, # @return Numeric vector of p-values (length = nlearners), # or NA_real_ vector if residuals are unavailable. cvc_pvalues <- function(fitted, splits, eq, bootnum = 500) { - resid <- get_cf_resid_bylearner_for_eq(fitted, eq) + 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 diff --git a/R/help_functions.R b/R/help_functions.R index c989962..a24eb71 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -1,8 +1,5 @@ # Collection of small internal functions -# Package-level environment for internal state -.ddml_env <- new.env(parent = emptyenv()) - # Resolve estimator progress messages. # # Merges user-supplied message overrides (passed via dots by @@ -111,11 +108,8 @@ normalize_learners <- function(learners) { resolve <- function(l) { if (!is.null(l$what)) return(l$what) if (!is.null(l$fun)) { - if (is.null(.ddml_env$fun_deprecated_warned)) { - message("Note: 'fun' in learner specifications ", - "is deprecated. Use 'what' instead.") - .ddml_env$fun_deprecated_warned <- TRUE - }#IF + message("Note: 'fun' in learner specifications ", + "is deprecated. Use 'what' instead.") return(l$fun) }#IF stop("Learner must have a 'what' element.", @@ -291,11 +285,6 @@ build_fitted_flat <- function(res_list, save_crossval, out }#BUILD_FITTED_FLAT -get_cf_resid_bylearner_for_eq <- function(fitted, eq) { - entry <- fitted[[eq]] - if (!is.null(entry)) entry$cf_resid_bylearner else NULL -}#GET_CF_RESID_BYLEARNER_FOR_EQ - # Input validation checks for DDML estimators validate_inputs <- function(y = NULL, D = NULL, X = NULL, Z = NULL, learners = NULL, From f258f3192f9da0b201d80704a43ef64214b099b2 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Sat, 4 Apr 2026 23:01:16 -0500 Subject: [PATCH 41/46] stacking R2 --- R/crosspred.R | 11 +++++++++++ R/diagnostics.R | 30 ++++++++++++++++++++---------- R/help_functions.R | 19 +++++++++++++++++-- R/shortstacking.R | 11 +++++++++++ tests/testthat/test-diagnostics.R | 6 +++--- 5 files changed, 62 insertions(+), 15 deletions(-) diff --git a/R/crosspred.R b/R/crosspred.R index 12439bd..7ca3ec3 100644 --- a/R/crosspred.R +++ b/R/crosspred.R @@ -203,6 +203,17 @@ crosspred <- function(y, X, 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 output <- list(cf_fitted = cf_fitted, diff --git a/R/diagnostics.R b/R/diagnostics.R index 0e778f0..ded9bcb 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -54,12 +54,18 @@ diagnostics <- function(object, cvc = FALSE, # Build per-learner table nlearners <- if (single_learner) 1L else nrow(w) - learner_names <- if (single_learner) "single" else - paste0("learner_", seq_len(nlearners)) - - # Per-learner OOS mspe and r2 + + # 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, @@ -85,13 +91,16 @@ diagnostics <- function(object, cvc = FALSE, for (j in seq_len(ncol(w_avg))) { col_name <- paste0("weight_", ens_names[j]) - tbl[[col_name]] <- w_avg[, 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) { - tbl$cvc_pval <- cvc_pvalues(object$fitted, object$splits, eq, bootnum) + 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 @@ -233,10 +242,11 @@ print.ddml_diagnostics <- function(x, digits = 4, ...) { cat("\n") }#FOR - if (x$cvc && !is.null(x$shortstack) && x$shortstack) { - cat("Note: CVC compares individual base learners.", - "\nShortstacked ensemble CVC is not available", - "(weights use all data).\n") + 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) diff --git a/R/help_functions.R b/R/help_functions.R index a24eb71..a89f190 100644 --- a/R/help_functions.R +++ b/R/help_functions.R @@ -222,13 +222,28 @@ build_CEF_from_crossfit <- function(y, cf_fitted_bylearner_eq, 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 = oos_stats$mspe, - r2 = oos_stats$r2, + mspe = mspe, + r2 = r2, auxiliary_fitted = auxiliary_fitted, cf_fitted_bylearner = cf, cf_resid_bylearner = cf_resid_bylearner, diff --git a/R/shortstacking.R b/R/shortstacking.R index b148f9c..d7c2e53 100644 --- a/R/shortstacking.R +++ b/R/shortstacking.R @@ -124,6 +124,17 @@ shortstacking <- function(y, X, 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)), + colnames(weights)) + }#IF + # return shortstacking output output <- list(cf_fitted = cf_fitted, weights = weights, mspe = mspe, r2 = r2, diff --git a/tests/testthat/test-diagnostics.R b/tests/testthat/test-diagnostics.R index 135120a..128bb44 100644 --- a/tests/testthat/test-diagnostics.R +++ b/tests/testthat/test-diagnostics.R @@ -38,14 +38,14 @@ test_that("diagnostics works with PLM multiple learners", { diag <- diagnostics(fit) - # Should have 2 learners per equation + # Should have 2 learners + ensemble per equation for (eq in names(diag$tables)) { - expect_equal(nrow(diag$tables[[eq]]), 2) + 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), 1, + expect_equal(sum(diag$tables[[eq]]$weight, na.rm = TRUE), 1, tolerance = 1e-4) } }) From 0a894427b049a24eeef226424b66a740a313a9d8 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Wed, 8 Apr 2026 10:11:54 -0500 Subject: [PATCH 42/46] make as.list.ddml generic, add ddml_policy --- NAMESPACE | 1 + R/ddml.R | 22 +- R/ddml_policy.R | 327 ++++++++++++++++++++++++++++++ R/ml_wrappers.R | 9 +- man/ddml-intro.Rd | 6 +- man/ddml_apo.Rd | 3 +- man/ddml_ate.Rd | 3 +- man/ddml_attgt.Rd | 3 +- man/ddml_fpliv.Rd | 3 +- man/ddml_late.Rd | 3 +- man/ddml_pliv.Rd | 3 +- man/ddml_plm.Rd | 3 +- man/ddml_policy.Rd | 251 +++++++++++++++++++++++ tests/testthat/test-ddml_apo.R | 26 +++ tests/testthat/test-ddml_policy.R | 263 ++++++++++++++++++++++++ tests/testthat/test-ml_wrappers.R | 24 +++ 16 files changed, 932 insertions(+), 18 deletions(-) create mode 100644 R/ddml_policy.R create mode 100644 man/ddml_policy.Rd create mode 100644 tests/testthat/test-ddml_policy.R diff --git a/NAMESPACE b/NAMESPACE index eb7f493..fda944f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -60,6 +60,7 @@ export(ddml_fpliv) export(ddml_late) export(ddml_pliv) export(ddml_plm) +export(ddml_policy) export(ddml_rep) export(ddml_replicate) export(diagnostics) diff --git a/R/ddml.R b/R/ddml.R index 67a37d2..cf4c08e 100644 --- a/R/ddml.R +++ b/R/ddml.R @@ -5,7 +5,8 @@ #' @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 +#' \code{\link{ddml_late}}, \code{\link{ddml_apo}}, +#' \code{\link{ddml_policy}}) return #' objects that inherit from S3 class \code{"ddml"}. #' #' Each object is a list containing the components described below. @@ -617,6 +618,17 @@ glance.ddml <- function(x, ...) { # List conversion ============================================================= +# Fields explicitly assembled by the ddml() constructor. +# Everything else on the object is estimator-specific (passed via ...). +DDML_CORE_FIELDS <- c( + "coefficients", "ensemble_weights", "mspe", "r2", + "inf_func", "dinf_dtheta", "scores", "J", + "coef_names", "estimator_name", "ensemble_type", + "nobs", "nfit", "fit_labels", + "sample_folds", "cv_folds", "shortstack", + "cluster_variable", "fitted", "splits", "call" +) + #' Split a DDML Object by Ensemble Type #' #' Returns a named list of single-ensemble \code{ddml} @@ -680,11 +692,9 @@ as.list.ddml <- function(x, ...) { 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]] + # Carry through estimator-specific fields generically + for (nm in setdiff(names(x), DDML_CORE_FIELDS)) { + obj[[nm]] <- x[[nm]] }#FOR out[[j]] <- obj }#FOR diff --git a/R/ddml_policy.R b/R/ddml_policy.R new file mode 100644 index 0000000..3fdf14d --- /dev/null +++ b/R/ddml_policy.R @@ -0,0 +1,327 @@ +#' Estimator for the Multi-Action Policy Value +#' +#' @family ddml estimators +#' +#' @description Estimator for the expected value of a multi-action +#' policy, with optional per-level margins. +#' +#' @details +#' \strong{Parameter of Interest:} \code{ddml_policy} provides a +#' Double/Debiased Machine Learning estimator for the expected +#' value of a multi-action policy +#' \eqn{\pi:\operatorname{supp}(X) \to \{d_1, \ldots, d_K\}} +#' that assigns each unit to one of \eqn{K} treatment levels. +#' The target parameter is +#' +#' \deqn{\theta_0 = \sum_{k=1}^{K} +#' E\!\left[\omega_k(X)\, E[Y \mid D = d_k, X]\right],} +#' +#' where the known weight functions are +#' \eqn{\omega_k(X) = c_k \,\mathbf{1}\{\pi(X) = d_k\}}, +#' and \eqn{c_1, \ldots, c_K} are user-supplied margins. +#' When all margins equal one (\code{margins = NULL}), the +#' parameter reduces to the policy value +#' \eqn{E[Y(\pi(X))]}. +#' +#' Each term in the sum is a weighted average potential outcome +#' (wAPO), estimated internally via \code{\link{ddml_apo}}. +#' +#' \strong{Nuisance Parameters:} For each treatment level +#' \eqn{d_k}, the nuisance parameters are +#' \eqn{\eta_k = (g_k, m_k)} taking true values +#' \eqn{g_{k,0}(X) = E[Y \mid D = d_k, X]} and +#' \eqn{m_{k,0}(X) = \Pr(D = d_k \mid X)}. +#' Only \eqn{K-1} propensity models are estimated; +#' the last is derived as +#' \eqn{m_K(X) = 1 - \sum_{k=1}^{K-1} m_k(X)}. +#' +#' \strong{Neyman Orthogonal Score / Moment Equation:} The Neyman +#' orthogonal score is: +#' +#' \deqn{m(W; \theta, \eta) = \sum_{k=1}^{K} +#' \omega_k(X) \left[ +#' \frac{\mathbf{1}\{D = d_k\}\,(Y - g_k(X))}{m_k(X)} +#' + g_k(X) \right] - \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_apo +#' @param D The observed discrete (potentially multi-valued) treatment +#' variable. +#' @param policy A vector of length \code{nobs} giving the +#' policy-assigned treatment level for each unit. Values must +#' be a subset of those observed in \code{D}. +#' @param margins An optional numeric vector of length \eqn{K} +#' (the number of unique values in \code{policy}) giving +#' per-level multipliers \eqn{c_k}. If \code{NULL} (the +#' default), all margins are set to one, yielding the policy +#' value \eqn{E[Y(\pi(X))]}. +#' @param splits An optional list of sample split objects. For +#' \code{ddml_policy}, this is typically a named list keyed +#' by treatment level. Typically obtained from a previous fit +#' via \code{fit$splits}. +#' @param ... Additional arguments passed to internal methods. +#' +#' @return \code{ddml_policy} returns an object of S3 class +#' \code{ddml_policy} and \code{ddml}. See +#' \code{\link{ddml-intro}} for the common output structure. +#' Additional pass-through fields: \code{learners}, +#' \code{learners_DX}, \code{policy}, \code{margins}. +#' +#' @export +#' +#' @references +#' Dudik M, Langford J, Li L (2011). "Doubly Robust Policy +#' Evaluation and Learning." Proceedings of the 28th +#' International Conference on Machine Learning, 1097-1104. +#' +#' @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")] +#' +#' # Define a simple policy: assign D=1 if age > median, else D=0 +#' policy <- ifelse(X[, "age"] > median(X[, "age"]), 1, 0) +#' +#' # Estimate the policy value using a single base learner, ridge. +#' policy_fit <- ddml_policy(y, D, X, +#' policy = policy, +#' learners = list(what = mdl_glmnet), +#' sample_folds = 2, +#' silent = TRUE) +#' summary(policy_fit) +#' +ddml_policy <- function(y, D, X, + policy, + margins = 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 -------------------------------------------------------------- + + nobs <- length(y) + d_levels <- sort(unique(policy)) + K <- length(d_levels) + + if (length(policy) != nobs) { + stop("'policy' must have the same length as 'y'.", + call. = FALSE) + }#IF + if (!all(d_levels %in% unique(D))) { + stop("All values in 'policy' must appear in 'D'.", + call. = FALSE) + }#IF + + if (is.null(margins)) margins <- rep(1, K) + if (!is.numeric(margins) || length(margins) != K) { + stop("'margins' must be a numeric vector of length ", K, + " (the number of unique policy levels).", + call. = FALSE) + }#IF + + exhaustive <- setequal(d_levels, sort(unique(D))) + n_direct_prop <- if (exhaustive) K - 1L else K + + dots <- list(...) + prop_levels <- d_levels[seq_len(n_direct_prop)] + msg_labels <- stats::setNames( + c(vapply(d_levels, function(d) paste0("E[Y|D=", d, ",X]"), + ""), + vapply(prop_levels, + function(d) paste0("P(D=", d, "|X)"), "")), + c(paste0("y_d", d_levels), + paste0("D_d", prop_levels))) + messages <- resolve_messages(dots, "ddml_policy", + as.list(msg_labels)) + + 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 = FALSE) + validate_custom_weights(custom_ensemble_weights, learners) + validate_custom_weights(custom_ensemble_weights_DX, + learners_DX) + + validate_fitted_splits_pair(fitted, splits) + + # Shared main folds (stratified on multi-valued D) + shared_splits <- if (!is.null(splits)) { + splits$D_X + } else { + indxs <- get_sample_splits( + cluster_variable = cluster_variable, + sample_folds = sample_folds, + cv_folds = cv_folds, + D = D, stratify = stratify) + list(subsamples = indxs$subsamples, + cv_subsamples = indxs$cv_subsamples) + }#IFELSE + + t0 <- proc.time()[3] + announce_start(messages, parallel, silent) + + # Reduced-form estimation ---------------------------------------------------- + + apo_list <- vector("list", K) + + # Levels with directly estimated propensity + for (k in seq_len(n_direct_prop)) { + d_k <- d_levels[k] + apo_list[[k]] <- ddml_apo( + y = y, D = D, X = X, + d = d_k, + weights = margins[k] * (policy == d_k), + 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, stratify = stratify, + trim = trim, parallel = parallel, silent = silent, + splits = list(D_X = shared_splits), + fitted = list( + y_X = fitted[[paste0("y_X_d", d_k)]], + D_X = fitted[[paste0("D_X_d", d_k)]]), + save_crossval = save_crossval, + messages = list( + start = "", finish = "", + y_X = messages[[paste0("y_d", d_k)]], + D_X = messages[[paste0("D_d", d_k)]])) + }#FOR + + # Level K: derive propensity when exhaustive, estimate when not + if (exhaustive) { + derived_prop <- 1 - Reduce( + "+", lapply(apo_list[seq_len(K - 1)], + function(a) a$fitted$D_X$cf_fitted)) + d_K <- d_levels[K] + apo_list[[K]] <- ddml_apo( + y = y, D = D, X = X, + d = d_K, + weights = margins[K] * (policy == d_K), + 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, stratify = stratify, + trim = trim, parallel = parallel, silent = silent, + splits = list(D_X = shared_splits), + fitted = list( + y_X = fitted[[paste0("y_X_d", d_K)]], + D_X = list(cf_fitted = derived_prop)), + save_crossval = save_crossval, + messages = list( + start = "", finish = "", + y_X = messages[[paste0("y_d", d_K)]], + D_X = "")) + }#IF + + ensemble_type <- apo_list[[1]]$ensemble_type + nensb <- ncol(apo_list[[1]]$coefficients) + + # Target parameter & influence function -------------------------------------- + + pv <- rep(0, nensb) + inf_func <- array(0, dim = c(nobs, 1, nensb)) + for (k in seq_len(K)) { + pv <- pv + as.vector(apo_list[[k]]$coefficients) + for (j in seq_len(nensb)) { + inf_func[, 1, j] <- inf_func[, 1, j] + + apo_list[[k]]$inf_func[, 1, j] + }#FOR + }#FOR + + scores <- array(NA_real_, dim = c(nobs, 1, nensb)) + J <- array(NA_real_, dim = c(1, 1, nensb)) + dinf_dtheta <- array(NA_real_, dim = c(nobs, 1, 1, nensb)) + for (j in seq_len(nensb)) { + scores[, 1, j] <- -inf_func[, 1, j] + J[1, 1, j] <- -1 + dinf_dtheta[, 1, 1, j] <- 1 + }#FOR + + coef_names <- "Policy value" + coef <- matrix(pv, nrow = 1, ncol = nensb) + rownames(coef) <- coef_names + colnames(coef) <- ensemble_type + + # Output --------------------------------------------------------------------- + + announce_finish(t0, messages, silent) + + ew <- mspe_out <- r2_out <- fit_out <- spl_out <- list() + for (k in seq_len(K)) { + ky <- paste0("y_X_d", d_levels[k]) + ew[[ky]] <- apo_list[[k]]$ensemble_weights$y_X + mspe_out[[ky]] <- apo_list[[k]]$mspe$y_X + r2_out[[ky]] <- apo_list[[k]]$r2$y_X + fit_out[[ky]] <- apo_list[[k]]$fitted$y_X + spl_out[[ky]] <- apo_list[[k]]$splits$y_X + }#FOR + for (k in seq_len(n_direct_prop)) { + kd <- paste0("D_X_d", d_levels[k]) + ew[[kd]] <- apo_list[[k]]$ensemble_weights$D_X + mspe_out[[kd]] <- apo_list[[k]]$mspe$D_X + r2_out[[kd]] <- apo_list[[k]]$r2$D_X + fit_out[[kd]] <- apo_list[[k]]$fitted$D_X + }#FOR + spl_out$D_X <- shared_splits + + ddml( + coefficients = coef, + ensemble_weights = ew, + mspe = mspe_out, + r2 = r2_out, + inf_func = inf_func, dinf_dtheta = dinf_dtheta, + scores = scores, J = J, + coef_names = coef_names, + estimator_name = "Multi-Action Policy Value", + 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 = fit_out, + splits = spl_out, + call = cl, + subclass = "ddml_policy", + # ddml_policy-specific fields + policy = policy, + margins = margins, + learners = learners, + learners_DX = learners_DX + ) +}#DDML_POLICY diff --git a/R/ml_wrappers.R b/R/ml_wrappers.R index df6d328..bdacfe1 100644 --- a/R/ml_wrappers.R +++ b/R/ml_wrappers.R @@ -116,10 +116,13 @@ mdl_xgboost <- function(y, X, ...){ # Compute xgboost dots <- list(...) - if (is.null(dots$params$objective) && is.null(dots$objective) && - is.factor(y) && length(levels(y)) == 2) { - dots$objective <- "binary:logistic" + + # Ensure binary/multi classification targets are factors (required by xgboost) + obj <- if (!is.null(dots$objective)) dots$objective else dots$params$objective + if (!is.null(obj) && grepl("^(binary|multi):", obj) && !is.factor(y)) { + y <- as.factor(y) }#IF + mdl_fit <- do.call(xgboost::xgboost, c(list(x = X, y = y, nrounds = nrounds, verbosity = verbosity), dots)) diff --git a/man/ddml-intro.Rd b/man/ddml-intro.Rd index 44047cf..5da2800 100644 --- a/man/ddml-intro.Rd +++ b/man/ddml-intro.Rd @@ -111,7 +111,8 @@ weight recomputation.} 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 +\code{\link{ddml_late}}, \code{\link{ddml_apo}}, +\code{\link{ddml_policy}}) return objects that inherit from S3 class \code{"ddml"}. Each object is a list containing the components described below. @@ -276,6 +277,7 @@ Other ddml estimators: \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()} +\code{\link{ddml_plm}()}, +\code{\link{ddml_policy}()} } \concept{ddml estimators} diff --git a/man/ddml_apo.Rd b/man/ddml_apo.Rd index 1cf188a..d2616db 100644 --- a/man/ddml_apo.Rd +++ b/man/ddml_apo.Rd @@ -214,6 +214,7 @@ Other ddml estimators: \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()} +\code{\link{ddml_plm}()}, +\code{\link{ddml_policy}()} } \concept{ddml estimators} diff --git a/man/ddml_ate.Rd b/man/ddml_ate.Rd index 56a9f4e..1dae832 100644 --- a/man/ddml_ate.Rd +++ b/man/ddml_ate.Rd @@ -252,6 +252,7 @@ Other ddml estimators: \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()} +\code{\link{ddml_plm}()}, +\code{\link{ddml_policy}()} } \concept{ddml estimators} diff --git a/man/ddml_attgt.Rd b/man/ddml_attgt.Rd index a1b2978..a799d37 100644 --- a/man/ddml_attgt.Rd +++ b/man/ddml_attgt.Rd @@ -257,6 +257,7 @@ Other ddml estimators: \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()} +\code{\link{ddml_plm}()}, +\code{\link{ddml_policy}()} } \concept{ddml estimators} diff --git a/man/ddml_fpliv.Rd b/man/ddml_fpliv.Rd index 153409e..047d776 100644 --- a/man/ddml_fpliv.Rd +++ b/man/ddml_fpliv.Rd @@ -204,6 +204,7 @@ Other ddml estimators: \code{\link{ddml_attgt}()}, \code{\link{ddml_late}()}, \code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()} +\code{\link{ddml_plm}()}, +\code{\link{ddml_policy}()} } \concept{ddml estimators} diff --git a/man/ddml_late.Rd b/man/ddml_late.Rd index e3ccaea..281c163 100644 --- a/man/ddml_late.Rd +++ b/man/ddml_late.Rd @@ -240,6 +240,7 @@ Other ddml estimators: \code{\link{ddml_attgt}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_pliv}()}, -\code{\link{ddml_plm}()} +\code{\link{ddml_plm}()}, +\code{\link{ddml_policy}()} } \concept{ddml estimators} diff --git a/man/ddml_pliv.Rd b/man/ddml_pliv.Rd index d5ec65c..02395a1 100644 --- a/man/ddml_pliv.Rd +++ b/man/ddml_pliv.Rd @@ -203,6 +203,7 @@ Other ddml estimators: \code{\link{ddml_attgt}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, -\code{\link{ddml_plm}()} +\code{\link{ddml_plm}()}, +\code{\link{ddml_policy}()} } \concept{ddml estimators} diff --git a/man/ddml_plm.Rd b/man/ddml_plm.Rd index 65972a0..512694c 100644 --- a/man/ddml_plm.Rd +++ b/man/ddml_plm.Rd @@ -227,6 +227,7 @@ Other ddml estimators: \code{\link{ddml_attgt}()}, \code{\link{ddml_fpliv}()}, \code{\link{ddml_late}()}, -\code{\link{ddml_pliv}()} +\code{\link{ddml_pliv}()}, +\code{\link{ddml_policy}()} } \concept{ddml estimators} diff --git a/man/ddml_policy.Rd b/man/ddml_policy.Rd new file mode 100644 index 0000000..3f0f81a --- /dev/null +++ b/man/ddml_policy.Rd @@ -0,0 +1,251 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ddml_policy.R +\name{ddml_policy} +\alias{ddml_policy} +\title{Estimator for the Multi-Action Policy Value} +\usage{ +ddml_policy( + y, + D, + X, + policy, + margins = 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 observed discrete (potentially multi-valued) treatment +variable.} + +\item{X}{A (sparse) matrix of control variables.} + +\item{policy}{A vector of length \code{nobs} giving the +policy-assigned treatment level for each unit. Values must +be a subset of those observed in \code{D}.} + +\item{margins}{An optional numeric vector of length \eqn{K} +(the number of unique values in \code{policy}) giving +per-level multipliers \eqn{c_k}. If \code{NULL} (the +default), all margins are set to one, yielding the policy +value \eqn{E[Y(\pi(X))]}.} + +\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_policy}, this is typically a named list keyed +by treatment level. 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_policy} returns an object of S3 class +\code{ddml_policy} and \code{ddml}. See +\code{\link{ddml-intro}} for the common output structure. +Additional pass-through fields: \code{learners}, +\code{learners_DX}, \code{policy}, \code{margins}. +} +\description{ +Estimator for the expected value of a multi-action +policy, with optional per-level margins. +} +\details{ +\strong{Parameter of Interest:} \code{ddml_policy} provides a +Double/Debiased Machine Learning estimator for the expected +value of a multi-action policy +\eqn{\pi:\operatorname{supp}(X) \to \{d_1, \ldots, d_K\}} +that assigns each unit to one of \eqn{K} treatment levels. +The target parameter is + +\deqn{\theta_0 = \sum_{k=1}^{K} + E\!\left[\omega_k(X)\, E[Y \mid D = d_k, X]\right],} + +where the known weight functions are +\eqn{\omega_k(X) = c_k \,\mathbf{1}\{\pi(X) = d_k\}}, +and \eqn{c_1, \ldots, c_K} are user-supplied margins. +When all margins equal one (\code{margins = NULL}), the +parameter reduces to the policy value +\eqn{E[Y(\pi(X))]}. + +Each term in the sum is a weighted average potential outcome +(wAPO), estimated internally via \code{\link{ddml_apo}}. + +\strong{Nuisance Parameters:} For each treatment level +\eqn{d_k}, the nuisance parameters are +\eqn{\eta_k = (g_k, m_k)} taking true values +\eqn{g_{k,0}(X) = E[Y \mid D = d_k, X]} and +\eqn{m_{k,0}(X) = \Pr(D = d_k \mid X)}. +Only \eqn{K-1} propensity models are estimated; +the last is derived as +\eqn{m_K(X) = 1 - \sum_{k=1}^{K-1} m_k(X)}. + +\strong{Neyman Orthogonal Score / Moment Equation:} The Neyman +orthogonal score is: + +\deqn{m(W; \theta, \eta) = \sum_{k=1}^{K} + \omega_k(X) \left[ + \frac{\mathbf{1}\{D = d_k\}\,(Y - g_k(X))}{m_k(X)} + + g_k(X) \right] - \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")] + +# Define a simple policy: assign D=1 if age > median, else D=0 +policy <- ifelse(X[, "age"] > median(X[, "age"]), 1, 0) + +# Estimate the policy value using a single base learner, ridge. +policy_fit <- ddml_policy(y, D, X, + policy = policy, + learners = list(what = mdl_glmnet), + sample_folds = 2, + silent = TRUE) +summary(policy_fit) + +} +\references{ +Dudik M, Langford J, Li L (2011). "Doubly Robust Policy +Evaluation and Learning." Proceedings of the 28th +International Conference on Machine Learning, 1097-1104. +} +\seealso{ +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}()}, +\code{\link{ddml_plm}()} +} +\concept{ddml estimators} diff --git a/tests/testthat/test-ddml_apo.R b/tests/testthat/test-ddml_apo.R index aca09b9..b5d465b 100644 --- a/tests/testthat/test-ddml_apo.R +++ b/tests/testthat/test-ddml_apo.R @@ -251,3 +251,29 @@ test_that("ddml_apo fitted pass-through works", { ) }) +test_that("ddml_apo classification w/ glmnet, ranger, xgboost works", { + set.seed(42) + nobs <- 1000 + X <- matrix(rnorm(nobs * 5), nobs, 5) + D <- rbinom(nobs, 1, 0.5) + # Binary outcome + y <- rbinom(nobs, 1, plogis(0.5 * X[, 1] + 1.5 * D)) + + learners_class <- list( + list(what = mdl_glmnet, args = list(family = "binomial")), + list(what = mdl_ranger, args = list(probability = TRUE)), + list(what = mdl_xgboost, args = list(objective = "binary:logistic", nrounds = 10, verbosity = 0)) + ) + + ddml_apo_fit <- ddml_apo(y, D, X, + d = 1, + learners = learners_class, + ensemble_type = "nnls", + cv_folds = 2, + sample_folds = 2, + silent = TRUE) + + # Basic expectations + expect_true(inherits(ddml_apo_fit, "ddml_apo")) + expect_equal(length(coef(ddml_apo_fit)), 1) +}) diff --git a/tests/testthat/test-ddml_policy.R b/tests/testthat/test-ddml_policy.R new file mode 100644 index 0000000..c36095e --- /dev/null +++ b/tests/testthat/test-ddml_policy.R @@ -0,0 +1,263 @@ +test_that("ddml_policy computes with a single model (K=2)", { + 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) + policy <- ifelse(X[, 1] > 0, 1, 0) + learners <- list(what = ols) + fit <- ddml_policy(y, D, X, + policy = policy, + learners = learners, + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + expect_equal(length(coef(fit)), 1) + expect_s3_class(fit, "ddml_policy") + expect_s3_class(fit, "ddml") +})#TEST_THAT + +test_that("ddml_policy computes with margins", { + 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) + policy <- ifelse(X[, 1] > 0, 1, 0) + learners <- list(what = ols) + fit <- ddml_policy(y, D, X, + policy = policy, + margins = c(2.0, 1.5), + learners = learners, + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + expect_equal(length(coef(fit)), 1) +})#TEST_THAT + +test_that("ddml_policy computes with an ensemble procedure", { + 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) + policy <- ifelse(X[, 1] > 0, 1, 0) + learners <- list(list(what = ols), + list(what = ols)) + fit <- ddml_policy(y, D, X, + policy = policy, + learners = learners, + ensemble_type = "ols", + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + expect_equal(length(coef(fit)), 1) +})#TEST_THAT + +test_that("ddml_policy computes w/ multiple ensembles", { + 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) + policy <- ifelse(X[, 1] > 0, 1, 0) + learners <- list(list(what = ols), + list(what = ols)) + fit <- ddml_policy(y, D, X, + policy = policy, + learners = learners, + ensemble_type = c("ols", "nnls", + "singlebest", "average"), + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + expect_equal(length(coef(fit)), 4) +})#TEST_THAT + +test_that("ddml_policy computes with shortstack", { + 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) + policy <- ifelse(X[, 1] > 0, 1, 0) + learners <- list(list(what = ols)) + fit <- ddml_policy(y, D, X, + policy = policy, + learners = learners, + ensemble_type = c("ols", "average"), + shortstack = TRUE, + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + expect_equal(length(coef(fit)), 2) +})#TEST_THAT + +test_that("summary.ddml computes for ddml_policy", { + 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) + policy <- ifelse(X[, 1] > 0, 1, 0) + learners <- list(what = ols) + fit <- ddml_policy(y, D, X, + policy = policy, + learners = learners, + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + inf_res <- summary(fit) + capture_output({print(inf_res)}, print = FALSE) + expect_s3_class(inf_res, "summary.ddml") + expect_equal(dim(inf_res$coefficients), c(1, 4, 1)) +})#TEST_THAT + +test_that("ddml_policy 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) + policy <- ifelse(X[, 1] > 0, 1, 0) + + learners <- list(list(what = ols), list(what = ols)) + fit <- ddml_policy(y, D, X, + policy = policy, + learners = learners, + ensemble_type = "average", + sample_folds = 2, + silent = TRUE) + + fit2 <- ddml_policy(y, D, X, + policy = policy, + 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_policy(y, D, X, + policy = policy, + 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_policy 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) + policy <- ifelse(X[, 1] > 0, 1, 0) + fit <- ddml_policy(y, D, X, + policy = policy, + 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 + +test_that("ddml_policy with margins=c(1,-1) matches ddml_ate", { + set.seed(123) + nobs <- 500 + 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) + learners <- list(what = ols) + + ate_fit <- ddml_ate(y, D, X, + learners = learners, + sample_folds = 3, + silent = TRUE) + + # Policy that assigns everyone to treatment (all get d=1) + # with margins c(-1, 1) = APO(d=1) - APO(d=0) = ATE + policy_all <- rep(1, nobs) + # But policy levels must cover unique(D) = {0, 1}, so use + # a non-trivial policy and compare the structural form instead. + # With constant policy, can't cover both levels. + # Instead, verify sign/magnitude: ATE ~ 1 and policy value + # with same splits should be in a reasonable range. + policy <- ifelse(X[, 1] > 0, 1, 0) + pol_fit <- ddml_policy(y, D, X, + policy = policy, + learners = learners, + sample_folds = 3, + splits = ate_fit$splits, + silent = TRUE) + expect_equal(length(coef(pol_fit)), 1) +})#TEST_THAT + +test_that("ddml_policy rejects mismatched policy/D", { + nobs <- 100 + X <- matrix(rnorm(nobs * 2), nobs, 2) + D <- sample(c(0, 1), nobs, replace = TRUE) + y <- rnorm(nobs) + learners <- list(what = ols) + + expect_error( + ddml_policy(y, D, X, + policy = rep(2, nobs), + learners = learners, + silent = TRUE), + "must appear in 'D'") + + expect_error( + ddml_policy(y, D, X, + policy = c(0, 1), + learners = learners, + silent = TRUE), + "same length") +})#TEST_THAT + +test_that("ddml_policy computes with partial coverage (K < unique D)", { + set.seed(42) + nobs <- 500 + X <- matrix(rnorm(nobs * 3), nobs, 3) + D <- sample(c(0, 1, 2), nobs, replace = TRUE, + prob = c(0.4, 0.4, 0.2)) + y <- 0.5 * (D == 1) + 1.0 * (D == 2) + 0.1 * X[, 1] + + rnorm(nobs) + policy <- ifelse(X[, 1] > 0, 1, 0) + learners <- list(what = ols) + fit <- ddml_policy(y, D, X, + policy = policy, + learners = learners, + cv_folds = 3, + sample_folds = 3, + silent = TRUE) + expect_equal(length(coef(fit)), 1) + expect_s3_class(fit, "ddml_policy") + inf_res <- summary(fit) + expect_s3_class(inf_res, "summary.ddml") +})#TEST_THAT + +test_that("ddml_policy rejects invalid margins", { + nobs <- 100 + X <- matrix(rnorm(nobs * 2), nobs, 2) + D <- sample(c(0, 1), nobs, replace = TRUE) + y <- rnorm(nobs) + policy <- ifelse(X[, 1] > 0, 1, 0) + learners <- list(what = ols) + + expect_error( + ddml_policy(y, D, X, + policy = policy, + margins = c(1, 2, 3), + learners = learners, + silent = TRUE), + "numeric vector of length 2") +})#TEST_THAT diff --git a/tests/testthat/test-ml_wrappers.R b/tests/testthat/test-ml_wrappers.R index da37d4e..6ea88d7 100644 --- a/tests/testthat/test-ml_wrappers.R +++ b/tests/testthat/test-ml_wrappers.R @@ -86,3 +86,27 @@ test_that("ML wrappers predict probabilities for binary outcomes", { expect_true(max(fitted) <= 1) expect_true(min(fitted) >= 0) })#TEST_THAT + +test_that("ML wrappers correctly target P(Y=1) rather than P(Y=0)", { + set.seed(42) + # Simulate heavily skewed dataset where P(Y=1) ~ 0.9 + nobs <- 200 + X <- matrix(rnorm(nobs * 2), nobs, 2) + y <- rbinom(nobs, 1, 0.9) + + # Because of the updated wrapper, mdl_xgboost accepts numeric y directly for binary:logistic + glmnet_fit <- suppressWarnings(mdl_glmnet(y, X, family = binomial)) + xgboost_fit <- suppressWarnings(mdl_xgboost(y, X, objective = "binary:logistic", nrounds = 5, verbosity = 0)) + ranger_fit <- mdl_ranger(y, X, probability = TRUE) + + # Predict + fitted_glmnet <- predict(glmnet_fit, newdata = X) + fitted_xgboost <- predict(xgboost_fit, newdata = X) + fitted_ranger <- predict(ranger_fit, newdata = X) + + # If P(Y=1) is correctly returned, the sample average of probabilities should be > 0.8 + # (If they mistakenly outputted P(Y=0), the mean would be < 0.2) + expect_true(mean(fitted_glmnet) > 0.8) + expect_true(mean(fitted_xgboost) > 0.8) + expect_true(mean(fitted_ranger) > 0.8) +})#TEST_THAT From f43901350f7ce81b51f43c83dbdc3c367b764935 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Sat, 11 Apr 2026 14:55:20 -0500 Subject: [PATCH 43/46] fix vignettes+correct signs --- .Rbuildignore | 1 + .gitignore | 1 + NAMESPACE | 1 - NEWS.md | 3 +- R/ddml.R | 11 - R/ddml_apo.R | 9 +- R/ddml_ate.R | 4 +- R/ddml_att.R | 4 +- R/ddml_attgt.R | 4 +- R/ddml_fpliv.R | 4 +- R/ddml_late.R | 7 +- R/ddml_pliv.R | 4 +- R/ddml_plm.R | 4 +- R/ddml_policy.R | 8 +- R/ensemble.R | 7 +- R/get_CEF.R | 4 +- R/lincom.R | 2 +- R/lincom_weights.R | 4 +- R/ml_wrappers.R | 7 +- R/ral.R | 11 +- R/subsample_functions.R | 5 + _pkgdown.yml | 2 + flake.lock | 61 ----- flake.nix | 56 ----- man/ddml_policy.Rd | 4 + man/hatvalues.ral.Rd | 2 +- man/lincom.Rd | 2 +- man/ral.Rd | 2 +- man/sub-.summary.ddml.Rd | 17 -- tests/testthat/test-lincom_weights.R | 2 +- tests/testthat/test-ral.R | 2 +- vignettes/articles/did.Rmd | 3 + vignettes/articles/did.Rmd.txt | 3 + vignettes/articles/example_401k.Rmd | 23 +- vignettes/articles/example_401k.Rmd.txt | 2 +- vignettes/articles/example_BLP95.Rmd | 12 + .../articles/modelsummary_integration.Rmd | 208 ++++++++++++++++-- vignettes/articles/new_ml_wrapper.Rmd | 30 ++- vignettes/articles/new_ml_wrapper.Rmd.txt | 18 +- vignettes/articles/repeated_resampling.Rmd | 5 + vignettes/articles/sparse.Rmd | 4 + vignettes/articles/stacking.Rmd | 10 +- vignettes/articles/stacking.Rmd.txt | 4 +- vignettes/articles/stacking_diagnostics.Rmd | 23 +- vignettes/ddml.Rmd | 10 +- vignettes/ddml.Rmd.txt | 2 +- 46 files changed, 372 insertions(+), 240 deletions(-) delete mode 100644 flake.lock delete mode 100644 flake.nix delete mode 100644 man/sub-.summary.ddml.Rd diff --git a/.Rbuildignore b/.Rbuildignore index e753b78..f416d52 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -22,6 +22,7 @@ ^debugging$ ^debugger$ ^\.cursor$ +^\.claude$ ^\.discussion$ ^\.discussions$ ^GEMINI\.md$ diff --git a/.gitignore b/.gitignore index f721321..4c42306 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,4 @@ GEMINI.md README.html R/ddml_to_did.R tests/testthat/test-ddml_to_did.R +/.claude diff --git a/NAMESPACE b/NAMESPACE index fda944f..ae8d719 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,5 @@ # Generated by roxygen2: do not edit by hand -S3method("[",summary.ddml) S3method("[[",ral_rep) S3method(as.list,ddml) S3method(as.list,ddml_rep) diff --git a/NEWS.md b/NEWS.md index 03cc072..8c349a5 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,8 +1,9 @@ # ddml 0.9.0 * Adds `ddml_attgt()` for staggered DiD and `ddml_apo()` for average potential outcomes. +* Adds `ddml_policy()` for multi-action policy value estimation. * Adds `ddml()` constructor for custom DML estimators with user-supplied scores. -* Adds `lincom()` and `lincom_weights_did()` for inference on linear combinations. +* Adds `lincom()` for inference on linear combinations. Supports computation of dynamic average treatment effects via `lincom_weights_did()`. * 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. diff --git a/R/ddml.R b/R/ddml.R index cf4c08e..99c4e85 100644 --- a/R/ddml.R +++ b/R/ddml.R @@ -410,17 +410,6 @@ ddml <- function(coefficients, scores, J, inf_func, # 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 -#' @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, diff --git a/R/ddml_apo.R b/R/ddml_apo.R index 71844a7..5974c40 100644 --- a/R/ddml_apo.R +++ b/R/ddml_apo.R @@ -181,10 +181,9 @@ ddml_apo <- function(y, D, X, d = 1)), aux_indx = indxs$aux_indx[2])[, , 1] m_X <- D_X_res$cf_fitted - is_internal <- is.null(messages$start) || - messages$start == "" + is_internal <- is.null(messages$start) || messages$start == "" # prevents duplicate warnings m_X_tr <- trim_propensity_scores(m_X, trim, ensemble_type, - silent = is_internal) + silent = silent || is_internal) weights_mat <- matrix(weights, nobs, nensb) D_ind_mat <- matrix(D_ind, nobs, nensb) @@ -205,8 +204,8 @@ ddml_apo <- function(y, D, X, 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] + 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" diff --git a/R/ddml_ate.R b/R/ddml_ate.R index acd3ddd..9999cb4 100644 --- a/R/ddml_ate.R +++ b/R/ddml_ate.R @@ -206,9 +206,9 @@ ddml_ate <- function(y, D, X, 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] + scores[, 1, j] <- inf_func[, 1, j] J[1, 1, j] <- -1 - dinf_dtheta[, 1, 1, j] <- 1 + dinf_dtheta[, 1, 1, j] <- -1 }#FOR coef_names <- "ATE" coef <- matrix(ate, nrow = 1, ncol = nensb) diff --git a/R/ddml_att.R b/R/ddml_att.R index 08b0df0..8df7b26 100644 --- a/R/ddml_att.R +++ b/R/ddml_att.R @@ -145,8 +145,8 @@ ddml_att <- function(y, D, X, 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] + 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" diff --git a/R/ddml_attgt.R b/R/ddml_attgt.R index 67653bb..54a95ba 100644 --- a/R/ddml_attgt.R +++ b/R/ddml_attgt.R @@ -420,7 +420,7 @@ ddml_attgt <- function(y, X = NULL, t, G, # 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) + 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 @@ -430,7 +430,7 @@ ddml_attgt <- function(y, X = NULL, t, G, 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) + inf_func[, , j] <- -t(t(scores[, , j]) * J_inv_vec) }#FOR coef_names <- paste0("ATT(", cell_info$group, ",", cell_info$time, ")") diff --git a/R/ddml_fpliv.R b/R/ddml_fpliv.R index 03df9d3..63a1c7e 100644 --- a/R/ddml_fpliv.R +++ b/R/ddml_fpliv.R @@ -225,11 +225,11 @@ ddml_fpliv <- function(y, D, Z, X, J[, , j] <- -crossprod(X_hat, X_full) / nobs J_inv <- csolve(matrix(J[, , j], nD + 1, nD + 1)) - inf_func[, , j] <- matrix(scores[, , j], nobs, nD + 1) %*% t(J_inv) + 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 + X_full[, k] * U }, simplify = "array") }#FOR diff --git a/R/ddml_late.R b/R/ddml_late.R index 70353fd..5844c5b 100644 --- a/R/ddml_late.R +++ b/R/ddml_late.R @@ -217,14 +217,13 @@ ddml_late <- function(y, D, Z, X, 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 + scores[, 1, j] <- phi_rf - phi_fs * late[j] 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) + 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] + dinf_dtheta[, 1, 1, j] <- phi_fs * J_inv[1, 1] }#FOR coef_names <- "LATE" diff --git a/R/ddml_pliv.R b/R/ddml_pliv.R index 4c77e68..bf5e1a5 100644 --- a/R/ddml_pliv.R +++ b/R/ddml_pliv.R @@ -204,11 +204,11 @@ ddml_pliv <- function(y, D, Z, X, J[, , j] <- -crossprod(X_hat, X_full) / nobs J_inv <- csolve(matrix(J[, , j], nD + 1, nD + 1)) - inf_func[, , j] <- matrix(scores[, , j], nobs, nD + 1) %*% t(J_inv) + 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 + X_full[, k] * U }, simplify = "array") }#FOR diff --git a/R/ddml_plm.R b/R/ddml_plm.R index 85f3890..b581e32 100644 --- a/R/ddml_plm.R +++ b/R/ddml_plm.R @@ -198,12 +198,12 @@ ddml_plm <- function(y, D, X, # Influence function J_inv <- csolve(matrix(J[, , j], nD + 1, nD + 1)) - inf_func[, , j] <- matrix(scores[, , j], nobs, nD + 1) %*% t(J_inv) + 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 + X_full[, k] * U }, simplify = "array") }#FOR diff --git a/R/ddml_policy.R b/R/ddml_policy.R index 3fdf14d..944e880 100644 --- a/R/ddml_policy.R +++ b/R/ddml_policy.R @@ -81,6 +81,10 @@ #' Evaluation and Learning." Proceedings of the 28th #' International Conference on Machine Learning, 1097-1104. #' +#' Zhou Z, Athey S, Wager S (2023). "Offline Multi-Action Policy +#' Learning: Generalization and Optimization." Operations +#' Research, 71(2), 698-722. +#' #' @examples #' # Construct variables from the included Angrist & Evans (1998) data #' y = AE98[, "worked"] @@ -267,9 +271,9 @@ ddml_policy <- function(y, D, X, J <- array(NA_real_, dim = c(1, 1, nensb)) dinf_dtheta <- array(NA_real_, dim = c(nobs, 1, 1, nensb)) for (j in seq_len(nensb)) { - scores[, 1, j] <- -inf_func[, 1, j] + scores[, 1, j] <- inf_func[, 1, j] J[1, 1, j] <- -1 - dinf_dtheta[, 1, 1, j] <- 1 + dinf_dtheta[, 1, 1, j] <- -1 }#FOR coef_names <- "Policy value" diff --git a/R/ensemble.R b/R/ensemble.R index 6a6cc60..65064fa 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -273,6 +273,7 @@ compute_w <- function(type, nlearners, cv_results, y) { singlebest = compute_w_singlebest(nlearners, cv_results)) }#COMPUTE_W +#' @noRd 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 @@ -283,7 +284,8 @@ compute_w_nnls1 <- function(nlearners, cv_results) { quadprog::solve.QP(Dmat = Matrix::nearPD(sq_resid)$mat, dvec = matrix(0, nlearners, 1), Amat = A, - bvec = c(1, rep(0, nlearners))), + bvec = c(1, rep(0, nlearners)), + meq = 1), error = function(e) { warning("nnls1 weight optimization failed: ", conditionMessage(e), @@ -297,16 +299,19 @@ compute_w_nnls1 <- function(nlearners, cv_results) { # Unconstrained non-negative least squares (Wolpert-style). # Unlike nnls1, weights are NOT normalized to sum to 1. +#' @noRd 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 +#' @noRd 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 +#' @noRd 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] diff --git a/R/get_CEF.R b/R/get_CEF.R index 254beaf..99fda43 100644 --- a/R/get_CEF.R +++ b/R/get_CEF.R @@ -12,6 +12,7 @@ # @param subsamples List of sample fold indices. # @param cv_subsamples List of cross-validation fold indices. # @param parallel Optional list with parallel config. +#' @noRd get_CEF <- function(y, X, learners, ensemble_type, @@ -150,13 +151,14 @@ get_CEF <- function(y, X, # 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. +#' @noRd 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 seq_len(nCEF)) is_D[[d]] <- which(D == D_levels[d]) + 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( diff --git a/R/lincom.R b/R/lincom.R index da0e1d8..c0f68bb 100644 --- a/R/lincom.R +++ b/R/lincom.R @@ -85,7 +85,7 @@ #' 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}, +#' \eqn{\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. diff --git a/R/lincom_weights.R b/R/lincom_weights.R index 62f3ad6..da7d75d 100644 --- a/R/lincom_weights.R +++ b/R/lincom_weights.R @@ -221,13 +221,13 @@ lincom_weights_did <- function(fit, 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)) + 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), + dinf_dR[, , , jj] <- array(rep(-VtV, each = n), dim = c(n, q, q)) }#FOR }#IFELSE diff --git a/R/ml_wrappers.R b/R/ml_wrappers.R index bdacfe1..f626c62 100644 --- a/R/ml_wrappers.R +++ b/R/ml_wrappers.R @@ -35,7 +35,7 @@ mdl_glmnet <- function(y, X, cv = TRUE, ...){ - # Either copute glmnet with given lambda or determine lambda with cv. + # Either compute glmnet with given lambda or determine lambda with cv. if (cv) { mdl_fit <- glmnet::cv.glmnet(x = X, y = y, ...) } else { @@ -63,14 +63,14 @@ predict.mdl_glmnet <- function(object, newdata = NULL, ...){ class(object) <- class(object)[-1] # Compute predictions if (cv) { - # Determine mse-minimizing lambda + # CV mode: select MSE-minimizing lambda from the CV path which_lambda <- which.min(object$cvm) # Predict using glmnet prediction method fitted <- stats::predict(object$glmnet.fit, newx = newdata, s = object$lambda[which_lambda], type = "response", ...) } else { - # Determine least regularizing lambda + # Non-CV mode: select the least-regularizing (last) lambda which_lambda <- length(object$lambda) # Predict using glmnet prediction method fitted <- stats::predict(object, newx = newdata, @@ -206,6 +206,7 @@ predict.mdl_ranger <- function(object, newdata = NULL, ...){ class(object) <- class(object)[-1] # Predict using randomForest prediction method if (object$treetype == "Probability estimation") { + # Column 2 = positive class probability (ranger orders factor levels) stats::predict(object, data = newdata, ...)$predictions[, 2] } else if (object$treetype == "Regression") { stats::predict(object, data = newdata, ...)$predictions diff --git a/R/ral.R b/R/ral.R index 41ebaec..0af54f9 100644 --- a/R/ral.R +++ b/R/ral.R @@ -31,7 +31,7 @@ #' in the \code{inf_func} slot. #' #' When an observation-level derivative -#' \eqn{-n^{-1}\,\partial \hat\phi_i / \partial \theta} +#' \eqn{\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}}. @@ -179,7 +179,7 @@ nobs.ral <- function(object, ...) { #' is #' #' \deqn{h_i(\theta) -#' = \mathrm{tr}\!\left( +#' = -\mathrm{tr}\!\left( #' \frac{1}{n} #' \frac{\partial \phi_i(\theta)} #' {\partial \theta} @@ -218,7 +218,7 @@ hatvalues.ral <- function(model, fit_idx = 1, ...) { h <- rep(0, n) for (k in seq_len(p)) h <- h + dinf_j[, k, k, 1] - h <- h / n + h <- -h / n as.vector(h) }#HATVALUES.RAL @@ -735,7 +735,10 @@ as.list.ral <- function(x, ...) { coef_names = x$coef_names, cluster_variable = x$cluster_variable, estimator_name = x$estimator_name, - subclass = setdiff(class(x), "ral")[1]) + subclass = { + sub <- setdiff(class(x), "ral") + if (length(sub) > 0) sub[1] else NULL + }) # Carry through extra fields extras <- setdiff(names(x), c(slice_fields, skip_fields, diff --git a/R/subsample_functions.R b/R/subsample_functions.R index 4a34973..88739ab 100644 --- a/R/subsample_functions.R +++ b/R/subsample_functions.R @@ -422,6 +422,11 @@ get_cf_indices_simple <- function(cluster_variable, sample_folds, # Simple function to generate subsamples. generate_subsamples <- function(nobs, sample_folds) { + if (nobs < sample_folds) { + stop("Number of observations (", nobs, + ") is less than the number of folds (", + sample_folds, ").", call. = FALSE) + }#IF sampleframe <- rep(seq_len(sample_folds), ceiling(nobs / sample_folds)) sample_groups <- sample(sampleframe, size = nobs, replace = FALSE) diff --git a/_pkgdown.yml b/_pkgdown.yml index 902f80a..a2af703 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -46,6 +46,7 @@ reference: - ddml_att - ddml_late - ddml_apo + - ddml_policy - ddml_attgt - title: Repeated Resampling @@ -99,6 +100,7 @@ reference: - matches("glance") - matches("predict") - matches("as.list") + - matches("length") - ensemble_weights - reexports diff --git a/flake.lock b/flake.lock deleted file mode 100644 index 295246a..0000000 --- a/flake.lock +++ /dev/null @@ -1,61 +0,0 @@ -{ - "nodes": { - "flake-utils": { - "inputs": { - "systems": "systems" - }, - "locked": { - "lastModified": 1692799911, - "narHash": "sha256-3eihraek4qL744EvQXsK1Ha6C3CR7nnT8X2qWap4RNk=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "f9e7cf818399d17d347f847525c5a5a8032e4e44", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "nixpkgs": { - "locked": { - "lastModified": 1692808169, - "narHash": "sha256-x9Opq06rIiwdwGeK2Ykj69dNc2IvUH1fY55Wm7atwrE=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "9201b5ff357e781bf014d0330d18555695df7ba8", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-unstable", - "repo": "nixpkgs", - "type": "github" - } - }, - "root": { - "inputs": { - "flake-utils": "flake-utils", - "nixpkgs": "nixpkgs" - } - }, - "systems": { - "locked": { - "lastModified": 1681028828, - "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", - "owner": "nix-systems", - "repo": "default", - "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", - "type": "github" - }, - "original": { - "owner": "nix-systems", - "repo": "default", - "type": "github" - } - } - }, - "root": "root", - "version": 7 -} diff --git a/flake.nix b/flake.nix deleted file mode 100644 index 94b2c6a..0000000 --- a/flake.nix +++ /dev/null @@ -1,56 +0,0 @@ -{ - description = "Flake for development of the ddml R package"; - inputs.nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable"; - inputs.flake-utils.url = "github:numtide/flake-utils"; - - outputs = { self, nixpkgs, flake-utils }: - flake-utils.lib.eachDefaultSystem (system: let - - pkgs = nixpkgs.legacyPackages.${system}; - - # Install local version of ddml - ddml = pkgs.rPackages.buildRPackage { - name = "ddml"; - src = ./.; - # ddml dependencies - propagatedBuildInputs = with pkgs.rPackages; [AER MASS Matrix nnls quadprog glmnet ranger xgboost sandwich]; - }; - - # R packages - my-R-packages = with pkgs.rPackages; [ - # this package - ddml - # dependencies - devtools - pkgdown - AER - MASS - Matrix - nnls - quadprog - glmnet - ranger - xgboost - sandwich - covr - testthat - knitr - markdown - rmarkdown - readstata13 - # packages used in the vignettes - did - ]; - my-R = [pkgs.R my-R-packages]; - - in { - devShells.default = pkgs.mkShell { - nativeBuildInputs = [ pkgs.bashInteractive ]; - buildInputs = [ - my-R - pkgs.rstudio - pkgs.quarto # needed for rstudio - ]; - }; - }); -} diff --git a/man/ddml_policy.Rd b/man/ddml_policy.Rd index 3f0f81a..95dea68 100644 --- a/man/ddml_policy.Rd +++ b/man/ddml_policy.Rd @@ -236,6 +236,10 @@ summary(policy_fit) Dudik M, Langford J, Li L (2011). "Doubly Robust Policy Evaluation and Learning." Proceedings of the 28th International Conference on Machine Learning, 1097-1104. + +Zhou Z, Athey S, Wager S (2023). "Offline Multi-Action Policy +Learning: Generalization and Optimization." Operations +Research, 71(2), 698-722. } \seealso{ Other ddml estimators: diff --git a/man/hatvalues.ral.Rd b/man/hatvalues.ral.Rd index 8c05e90..9bd5051 100644 --- a/man/hatvalues.ral.Rd +++ b/man/hatvalues.ral.Rd @@ -27,7 +27,7 @@ The leverage for observation \eqn{i} is \deqn{h_i(\theta) - = \mathrm{tr}\!\left( + = -\mathrm{tr}\!\left( \frac{1}{n} \frac{\partial \phi_i(\theta)} {\partial \theta} diff --git a/man/lincom.Rd b/man/lincom.Rd index c54976f..fbf8e2c 100644 --- a/man/lincom.Rd +++ b/man/lincom.Rd @@ -62,7 +62,7 @@ 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}, +\eqn{\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.} diff --git a/man/ral.Rd b/man/ral.Rd index b7feed1..b1ce4ad 100644 --- a/man/ral.Rd +++ b/man/ral.Rd @@ -66,7 +66,7 @@ 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} +\eqn{\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}}. diff --git a/man/sub-.summary.ddml.Rd b/man/sub-.summary.ddml.Rd deleted file mode 100644 index 429baf5..0000000 --- a/man/sub-.summary.ddml.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% 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/tests/testthat/test-lincom_weights.R b/tests/testthat/test-lincom_weights.R index 1228d13..6e958dd 100644 --- a/tests/testthat/test-lincom_weights.R +++ b/tests/testthat/test-lincom_weights.R @@ -218,7 +218,7 @@ test_that("dinf_dR matches manual V'V computation", { } VtV_manual <- crossprod(V_manual) - expect_equal(w$dinf_dR[1, , ], VtV_manual, tolerance = 1e-10) + expect_equal(w$dinf_dR[1, , ], -VtV_manual, tolerance = 1e-10) })#TEST_THAT test_that("HC3 with dinf_dR differs from HC3 without", { diff --git a/tests/testthat/test-ral.R b/tests/testthat/test-ral.R index 25b7d75..6803f4c 100644 --- a/tests/testthat/test-ral.R +++ b/tests/testthat/test-ral.R @@ -201,7 +201,7 @@ 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)) + dinf_dtheta <- array(-1, dim = c(n, 1, 1, 1)) obj <- ral(coefficients = coefficients, inf_func = inf_func, dinf_dtheta = dinf_dtheta, diff --git a/vignettes/articles/did.Rmd b/vignettes/articles/did.Rmd index 1fd01d6..4f8b595 100644 --- a/vignettes/articles/did.Rmd +++ b/vignettes/articles/did.Rmd @@ -281,6 +281,9 @@ summarize_weights <- function(diag, pattern) { value = TRUE)[1] w_mat <- sapply(eqs, function(eq) diag$tables[[eq]][[w_col]]) learner_names <- diag$tables[[eqs[1]]]$learner + keep <- !is.na(w_mat[, 1]) # exclude nnls1 from weights + w_mat <- w_mat[keep, , drop = FALSE] + learner_names <- learner_names[keep] data.frame( learner = learner_names, min = round(apply(w_mat, 1, min), 4), diff --git a/vignettes/articles/did.Rmd.txt b/vignettes/articles/did.Rmd.txt index 6a5f010..a5ace49 100644 --- a/vignettes/articles/did.Rmd.txt +++ b/vignettes/articles/did.Rmd.txt @@ -198,6 +198,9 @@ summarize_weights <- function(diag, pattern) { value = TRUE)[1] w_mat <- sapply(eqs, function(eq) diag$tables[[eq]][[w_col]]) learner_names <- diag$tables[[eqs[1]]]$learner + keep <- !is.na(w_mat[, 1]) # exclude nnls1 from weights + w_mat <- w_mat[keep, , drop = FALSE] + learner_names <- learner_names[keep] data.frame( learner = learner_names, min = round(apply(w_mat, 1, min), 4), diff --git a/vignettes/articles/example_401k.Rmd b/vignettes/articles/example_401k.Rmd index 18598b0..dc015d0 100644 --- a/vignettes/articles/example_401k.Rmd +++ b/vignettes/articles/example_401k.Rmd @@ -159,6 +159,7 @@ diagnostics(stacking_fit) #> learner_4 2910378985 0.2787 0.7992 #> learner_5 3435902221 0.1485 0.0824 #> learner_6 3716930203 0.0789 0.0000 +#> nnls 2890726991 0.2836 NA #> #> D1_X: #> learner mspe r2 weight_nnls @@ -168,6 +169,10 @@ diagnostics(stacking_fit) #> learner_4 0.1711 0.1144 0.5891 #> learner_5 0.1860 0.0371 0.0000 #> learner_6 0.2045 -0.0588 0.0000 +#> nnls 0.1707 0.1163 NA +#> +#> Note: Ensemble MSPE and R2 for short-stacking rely on full-sample weights +#> and represent in-sample fit over cross-fitted base predictions. ``` # Estimation with Different Sets of Control Variables @@ -248,6 +253,7 @@ diagnostics(stacking_fit) #> learner_5 2926909974 0.2746 0.3365 #> learner_6 4121257708 -0.0213 0.0000 #> learner_7 4614176089 -0.1435 0.0000 +#> nnls 2838742034 0.2965 NA #> #> D1_X: #> learner mspe r2 weight_nnls @@ -258,9 +264,13 @@ diagnostics(stacking_fit) #> learner_5 0.1710 0.1147 0.3848 #> learner_6 0.1825 0.0554 0.1035 #> learner_7 0.2001 -0.0360 0.0038 +#> nnls 0.1705 0.1176 NA +#> +#> Note: Ensemble MSPE and R2 for short-stacking rely on full-sample weights +#> and represent in-sample fit over cross-fitted base predictions. ``` -# Estimation with Continious and Binary Outcome and Treatment Variables +# Estimation with Continuous 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. @@ -330,6 +340,7 @@ diagnostics(stacking_fit) #> learner_5 3026275768 0.2500 0.0347 #> learner_6 3906568364 0.0319 0.0656 #> learner_7 4253407158 -0.0541 0.0000 +#> nnls 2863776446 0.2903 NA #> #> D1_X: #> learner mspe r2 weight_nnls @@ -340,6 +351,10 @@ diagnostics(stacking_fit) #> learner_5 0.1714 0.1127 0.3949 #> learner_6 0.1856 0.0394 0.0203 #> learner_7 0.2037 -0.0544 0.0000 +#> nnls 0.1707 0.1162 NA +#> +#> Note: Ensemble MSPE and R2 for short-stacking rely on full-sample weights +#> and represent in-sample fit over cross-fitted base predictions. ``` # Advanced: Rapid Refits with the Passthrough API @@ -422,6 +437,7 @@ diagnostics(stacking_IV_fit) #> learner_5 2914205541 0.2778 0.2624 #> learner_6 3518126794 0.1281 0.0626 #> learner_7 3808805316 0.0561 0.0099 +#> nnls 2812746541 0.3029 NA #> #> D1_X: #> learner mspe r2 weight_nnls @@ -432,6 +448,7 @@ diagnostics(stacking_IV_fit) #> learner_5 0.1709 0.1152 0.5302 #> learner_6 0.1840 0.0478 0.0469 #> learner_7 0.2024 -0.0475 0.0000 +#> nnls 0.1705 0.1174 NA #> #> Z1_X: #> learner mspe r2 weight_nnls @@ -442,6 +459,10 @@ diagnostics(stacking_IV_fit) #> learner_5 0.1959 0.1608 0.6553 #> learner_6 0.2121 0.0916 0.0000 #> learner_7 0.2313 0.0092 0.0000 +#> nnls 0.1955 0.1627 NA +#> +#> Note: Ensemble MSPE and R2 for short-stacking rely on full-sample weights +#> and represent in-sample fit over cross-fitted base predictions. ``` diff --git a/vignettes/articles/example_401k.Rmd.txt b/vignettes/articles/example_401k.Rmd.txt index ee08555..ae24350 100644 --- a/vignettes/articles/example_401k.Rmd.txt +++ b/vignettes/articles/example_401k.Rmd.txt @@ -166,7 +166,7 @@ To assess whether the additional effort in expanding the control variables had a diagnostics(stacking_fit) ``` -# Estimation with Continious and Binary Outcome and Treatment Variables +# Estimation with Continuous 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. diff --git a/vignettes/articles/example_BLP95.Rmd b/vignettes/articles/example_BLP95.Rmd index 410eeff..b155e5c 100644 --- a/vignettes/articles/example_BLP95.Rmd +++ b/vignettes/articles/example_BLP95.Rmd @@ -236,6 +236,7 @@ diagnostics(stacking_fit) #> learner_4 1.3850 0.2744 0.0000 #> learner_5 1.1000 0.4237 0.3525 #> learner_6 1.0350 0.4578 0.6475 +#> nnls1 1.0076 0.4721 NA #> #> D1_X: #> learner mspe r2 weight_nnls1 @@ -245,6 +246,7 @@ diagnostics(stacking_fit) #> learner_4 28.2471 0.6219 0.0000 #> learner_5 16.9611 0.7730 0.1252 #> learner_6 13.4904 0.8194 0.8195 +#> nnls1 13.2407 0.8228 NA #> #> D1_XZ: #> learner mspe r2 weight_nnls1 @@ -254,6 +256,10 @@ diagnostics(stacking_fit) #> learner_4 23.9814 0.6790 0.0000 #> learner_5 10.2051 0.8634 0.3372 #> learner_6 8.9730 0.8799 0.6548 +#> nnls1 8.4965 0.8863 NA +#> +#> Note: Ensemble MSPE and R2 for short-stacking rely on full-sample weights +#> and represent in-sample fit over cross-fitted base predictions. ``` # Elasticities @@ -368,16 +374,22 @@ diagnostics(stacking_r_fit) #> learner mspe r2 weight_nnls1 #> learner_1 1.4843 0.2224 0.2298 #> learner_2 1.1869 0.3782 0.7702 +#> nnls1 1.1579 0.3934 NA #> #> D1_X: #> learner mspe r2 weight_nnls1 #> learner_1 29.7015 0.6025 0.1121 #> learner_2 14.2630 0.8091 0.8879 +#> nnls1 14.0130 0.8124 NA #> #> D1_XZ: #> learner mspe r2 weight_nnls1 #> learner_1 28.2924 0.6213 0.0725 #> learner_2 10.4439 0.8602 0.9275 +#> nnls1 10.3342 0.8617 NA +#> +#> Note: Ensemble MSPE and R2 for short-stacking rely on full-sample weights +#> and represent in-sample fit over cross-fitted base predictions. ``` 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. diff --git a/vignettes/articles/modelsummary_integration.Rmd b/vignettes/articles/modelsummary_integration.Rmd index 900f9e6..f46c0e4 100644 --- a/vignettes/articles/modelsummary_integration.Rmd +++ b/vignettes/articles/modelsummary_integration.Rmd @@ -136,6 +136,65 @@ if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinyta } ``` + ++----------------+-----------+------------------------+ +| | OLS | DDML (NNLS) | ++================+===========+========================+ +| (Intercept) | 0.108 | 0.004 | ++----------------+-----------+------------------------+ +| | (0.150) | (0.015) | ++----------------+-----------+------------------------+ +| Treatment (D) | -0.189*** | | ++----------------+-----------+------------------------+ +| | (0.033) | | ++----------------+-----------+------------------------+ +| Xage | 0.028*** | | ++----------------+-----------+------------------------+ +| | (0.005) | | ++----------------+-----------+------------------------+ +| Xagefst | -0.029*** | | ++----------------+-----------+------------------------+ +| | (0.006) | | ++----------------+-----------+------------------------+ +| Xblack | 0.256*** | | ++----------------+-----------+------------------------+ +| | (0.063) | | ++----------------+-----------+------------------------+ +| Xhisp | 0.068 | | ++----------------+-----------+------------------------+ +| | (0.099) | | ++----------------+-----------+------------------------+ +| Xothrace | 0.127 | | ++----------------+-----------+------------------------+ +| | (0.091) | | ++----------------+-----------+------------------------+ +| Xeduc | 0.019** | | ++----------------+-----------+------------------------+ +| | (0.007) | | ++----------------+-----------+------------------------+ +| D1 | | -0.185*** | ++----------------+-----------+------------------------+ +| | | (0.032) | ++----------------+-----------+------------------------+ +| Num.Obs. | 1000 | 1000 | ++----------------+-----------+------------------------+ +| R2 | 0.076 | | ++----------------+-----------+------------------------+ +| R2 Adj. | 0.069 | | ++----------------+-----------+------------------------+ +| sample_folds | | 5 | ++----------------+-----------+------------------------+ +| shortstack | | TRUE | ++----------------+-----------+------------------------+ +| ensemble_type | | nnls, singlebest | ++----------------+-----------+------------------------+ +| model_type | | ddml_plm | ++----------------+-----------+------------------------+ +| estimator_name | | Partially Linear Model | ++================+===========+========================+ +| + p < 0.1, * p < 0.05, ** p < 0.01, *** p < 0.001 | ++================+===========+========================+ + 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()`` @@ -147,18 +206,17 @@ When multiple ensemble types are computed simultaneously (as in our fit above), # 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" +#> [1] "nnls" "singlebest" # Each element is a standalone ddml object with full S3 support tidy(ensemble_list[["nnls"]]) -#> # A tibble: 0 × 0 +#> 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 tidy(ensemble_list[["singlebest"]]) -#> # A tibble: 0 × 0 +#> 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 ``` This makes multi-column ensemble comparison tables straightforward: @@ -175,6 +233,65 @@ if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinyta } ``` + ++----------------+-----------+------------------------+------------------------+ +| | OLS | nnls | singlebest | ++================+===========+========================+========================+ +| (Intercept) | 0.108 | 0.004 | -0.001 | ++----------------+-----------+------------------------+------------------------+ +| | (0.150) | (0.015) | (0.015) | ++----------------+-----------+------------------------+------------------------+ +| Treatment (D) | -0.189*** | | | ++----------------+-----------+------------------------+------------------------+ +| | (0.033) | | | ++----------------+-----------+------------------------+------------------------+ +| Xage | 0.028*** | | | ++----------------+-----------+------------------------+------------------------+ +| | (0.005) | | | ++----------------+-----------+------------------------+------------------------+ +| Xagefst | -0.029*** | | | ++----------------+-----------+------------------------+------------------------+ +| | (0.006) | | | ++----------------+-----------+------------------------+------------------------+ +| Xblack | 0.256*** | | | ++----------------+-----------+------------------------+------------------------+ +| | (0.063) | | | ++----------------+-----------+------------------------+------------------------+ +| Xhisp | 0.068 | | | ++----------------+-----------+------------------------+------------------------+ +| | (0.099) | | | ++----------------+-----------+------------------------+------------------------+ +| Xothrace | 0.127 | | | ++----------------+-----------+------------------------+------------------------+ +| | (0.091) | | | ++----------------+-----------+------------------------+------------------------+ +| Xeduc | 0.019** | | | ++----------------+-----------+------------------------+------------------------+ +| | (0.007) | | | ++----------------+-----------+------------------------+------------------------+ +| D1 | | -0.185*** | -0.185*** | ++----------------+-----------+------------------------+------------------------+ +| | | (0.032) | (0.032) | ++----------------+-----------+------------------------+------------------------+ +| Num.Obs. | 1000 | 1000 | 1000 | ++----------------+-----------+------------------------+------------------------+ +| R2 | 0.076 | | | ++----------------+-----------+------------------------+------------------------+ +| R2 Adj. | 0.069 | | | ++----------------+-----------+------------------------+------------------------+ +| sample_folds | | 5 | 5 | ++----------------+-----------+------------------------+------------------------+ +| shortstack | | TRUE | TRUE | ++----------------+-----------+------------------------+------------------------+ +| ensemble_type | | nnls | singlebest | ++----------------+-----------+------------------------+------------------------+ +| model_type | | ddml_plm | ddml_plm | ++----------------+-----------+------------------------+------------------------+ +| estimator_name | | Partially Linear Model | Partially Linear Model | ++================+===========+========================+========================+ +| + p < 0.1, * p < 0.05, ** p < 0.01, *** p < 0.001 | ++================+===========+========================+========================+ + 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 @@ -202,9 +319,9 @@ repl_fit <- ddml_replicate( # 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 +#> term estimate std.error statistic p.value ensemble_type +#> 1 D1 -0.187603585 0.03223104 -5.8205878 5.864103e-09 nnls +#> 2 (Intercept) 0.003429672 0.01526534 0.2246706 8.222355e-01 nnls #> aggregation #> 1 median #> 2 median @@ -216,6 +333,35 @@ if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinyta } ``` + ++----------------+------------------------+------------------------+ +| | Single Split | Repeated 3x | ++================+========================+========================+ +| D1 | -0.185*** | -0.188*** | ++----------------+------------------------+------------------------+ +| | (0.032) | (0.032) | ++----------------+------------------------+------------------------+ +| (Intercept) | 0.004 | 0.003 | ++----------------+------------------------+------------------------+ +| | (0.015) | (0.015) | ++----------------+------------------------+------------------------+ +| Num.Obs. | 1000 | 1000 | ++----------------+------------------------+------------------------+ +| sample_folds | 5 | 5 | ++----------------+------------------------+------------------------+ +| shortstack | TRUE | TRUE | ++----------------+------------------------+------------------------+ +| ensemble_type | nnls, singlebest | nnls, singlebest | ++----------------+------------------------+------------------------+ +| model_type | ddml_plm | ddml_plm | ++----------------+------------------------+------------------------+ +| estimator_name | Partially Linear Model | Partially Linear Model | ++----------------+------------------------+------------------------+ +| nresamples | | 3 | ++================+========================+========================+ +| + p < 0.1, * p < 0.05, ** p < 0.01, *** p < 0.001 | ++================+========================+========================+ + 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: @@ -225,6 +371,35 @@ if (requireNamespace("modelsummary", quietly = TRUE) && requireNamespace("tinyta } ``` + ++----------------+------------------------+------------------------+ +| | nnls | singlebest | ++================+========================+========================+ +| D1 | -0.188*** | -0.188*** | ++----------------+------------------------+------------------------+ +| | (0.032) | (0.032) | ++----------------+------------------------+------------------------+ +| (Intercept) | 0.003 | -0.000 | ++----------------+------------------------+------------------------+ +| | (0.015) | (0.015) | ++----------------+------------------------+------------------------+ +| Num.Obs. | 1000 | 1000 | ++----------------+------------------------+------------------------+ +| sample_folds | 5 | 5 | ++----------------+------------------------+------------------------+ +| shortstack | TRUE | TRUE | ++----------------+------------------------+------------------------+ +| ensemble_type | nnls | singlebest | ++----------------+------------------------+------------------------+ +| model_type | ddml_plm | ddml_plm | ++----------------+------------------------+------------------------+ +| estimator_name | Partially Linear Model | Partially Linear Model | ++----------------+------------------------+------------------------+ +| nresamples | 3 | 3 | ++================+========================+========================+ +| + p < 0.1, * p < 0.05, ** p < 0.01, *** p < 0.001 | ++================+========================+========================+ + # 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. @@ -237,11 +412,12 @@ 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 +#> 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 y_X nnls 0.2412659 0.02767155 NA NA +#> 4 y_X singlebest 0.2413624 0.02728268 NA NA +#> 5 D1_X learner_1 0.2206689 0.05321582 0.8069033 1 ``` 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. diff --git a/vignettes/articles/new_ml_wrapper.Rmd b/vignettes/articles/new_ml_wrapper.Rmd index 58b379d..f00a28d 100644 --- a/vignettes/articles/new_ml_wrapper.Rmd +++ b/vignettes/articles/new_ml_wrapper.Rmd @@ -78,7 +78,9 @@ 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.) @@ -97,6 +99,11 @@ late_fit <- ddml_late(y, D, Z, X, sample_folds = 10, silent = TRUE) summary(late_fit) +#> DDML estimation: Local Average Treatment Effect +#> Obs: 5000 Folds: 10 +#> +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.237 0.190 -1.25 0.21 ``` All works well! @@ -177,15 +184,12 @@ mdl_keras <- function(y, X, steps_per_epoch = steps_per_epoch, verbose = verbose) - # Add standardization to object - nnet$std_y <- std_y - nnet$std_X <- std_X - - # Append class - class(nnet) <- c("mdl_keras", class(nnet)) + # Wrap in an R list to avoid reticulate attribute issues + result <- list(model = nnet, std_y = std_y, std_X = std_X) + class(result) <- "mdl_keras" # Return fitted object - return(nnet) + return(result) }#MDL_KERAS ``` @@ -193,16 +197,15 @@ The prediction method for our fitted object ensures the predictions are returned ```r -predict.mdl_keras <- function(object, newdata){ +predict.mdl_keras <- function(object, newdata, ...){ # Standardize newdata nobs <- nrow(newdata) 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)) + # Predict and convert to numeric vector + fitted <- as.numeric(predict(object$model, newdata, verbose = 0)) # Re-standardize to output and return object$std_y[2] * fitted + object$std_y[1] }#PREDICT.MDL_KERAS @@ -236,6 +239,11 @@ late_fit <- ddml_late(y, D, Z, X, sample_folds = 10, silent = TRUE) summary(late_fit) +#> DDML estimation: Local Average Treatment Effect +#> Obs: 5000 Folds: 10 +#> +#> Estimate Std. Error z value Pr(>|z|) +#> LATE -0.208 0.194 -1.07 0.29 ``` All works well! diff --git a/vignettes/articles/new_ml_wrapper.Rmd.txt b/vignettes/articles/new_ml_wrapper.Rmd.txt index 68eb285..f074810 100644 --- a/vignettes/articles/new_ml_wrapper.Rmd.txt +++ b/vignettes/articles/new_ml_wrapper.Rmd.txt @@ -178,31 +178,27 @@ mdl_keras <- function(y, X, steps_per_epoch = steps_per_epoch, verbose = verbose) - # Add standardization to object - nnet$std_y <- std_y - nnet$std_X <- std_X - - # Append class - class(nnet) <- c("mdl_keras", class(nnet)) + # Wrap in an R list to avoid reticulate attribute issues + result <- list(model = nnet, std_y = std_y, std_X = std_X) + class(result) <- "mdl_keras" # Return fitted object - return(nnet) + return(result) }#MDL_KERAS ``` The prediction method for our fitted object ensures the predictions are returned as a numerical vector: ```{r} -predict.mdl_keras <- function(object, newdata){ +predict.mdl_keras <- function(object, newdata, ...){ # Standardize newdata nobs <- nrow(newdata) 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)) + # Predict and convert to numeric vector + fitted <- as.numeric(predict(object$model, newdata, verbose = 0)) # Re-standardize to output and return object$std_y[2] * fitted + object$std_y[1] }#PREDICT.MDL_KERAS diff --git a/vignettes/articles/repeated_resampling.Rmd b/vignettes/articles/repeated_resampling.Rmd index f47fe10..c9fa3b3 100644 --- a/vignettes/articles/repeated_resampling.Rmd +++ b/vignettes/articles/repeated_resampling.Rmd @@ -209,11 +209,16 @@ diagnostics(run_3) #> learner mspe r2 weight_nnls #> learner_1 0.2402 0.0394 0.0000 #> learner_2 0.2396 0.0415 0.9986 +#> nnls 0.2396 0.0415 NA #> #> D1_X: #> learner mspe r2 weight_nnls #> learner_1 0.2205 0.0659 0.0000 #> learner_2 0.2202 0.0671 0.9926 +#> nnls 0.2202 0.0672 NA +#> +#> Note: Ensemble MSPE and R2 for short-stacking rely on full-sample weights +#> and represent in-sample fit over cross-fitted base predictions. ``` # Manual Construction and HPC Compatibility diff --git a/vignettes/articles/sparse.Rmd b/vignettes/articles/sparse.Rmd index 607e1e1..aec3f93 100644 --- a/vignettes/articles/sparse.Rmd +++ b/vignettes/articles/sparse.Rmd @@ -184,6 +184,10 @@ diagnostics(stacking_fit) #> learner_2 10.2699 0.0461 0.0000 #> learner_3 10.1852 0.0540 0.4126 #> learner_4 10.2673 0.0464 0.0000 +#> nnls1 10.1850 0.0540 NA +#> +#> Note: Ensemble MSPE and R2 for short-stacking rely on full-sample weights +#> and represent in-sample fit over cross-fitted base predictions. ``` # References diff --git a/vignettes/articles/stacking.Rmd b/vignettes/articles/stacking.Rmd index 385d623..fe326f0 100644 --- a/vignettes/articles/stacking.Rmd +++ b/vignettes/articles/stacking.Rmd @@ -82,17 +82,17 @@ Both stacking and short-stacking construct weighted averages of the considered b ```r cat("Time single learner:", time_singlelearner[1], "\n") -#> Time single learner: 2.09 +#> Time single learner: 1.64 cat("Time short-stacking:", time_shortstacking[1], "\n") -#> Time short-stacking: 5.75 +#> Time short-stacking: 3.23 cat("Time stacking: ", time_stacking[1]) -#> Time stacking: 27.11 +#> Time stacking: 15.33 ``` # References -Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024a). “ddml: -Double/debiased machine learning in Stata.” Stata Journal, 24(1): +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." diff --git a/vignettes/articles/stacking.Rmd.txt b/vignettes/articles/stacking.Rmd.txt index 314dff6..cfd1cc2 100644 --- a/vignettes/articles/stacking.Rmd.txt +++ b/vignettes/articles/stacking.Rmd.txt @@ -94,8 +94,8 @@ cat("Time stacking: ", time_stacking[1]) # References -Ahrens A, Hansen C B, Schaffer M E, Wiemann T (2024a). “ddml: -Double/debiased machine learning in Stata.” Stata Journal, 24(1): +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." diff --git a/vignettes/articles/stacking_diagnostics.Rmd b/vignettes/articles/stacking_diagnostics.Rmd index 93b9552..41713f2 100644 --- a/vignettes/articles/stacking_diagnostics.Rmd +++ b/vignettes/articles/stacking_diagnostics.Rmd @@ -77,6 +77,7 @@ print(diag) #> learner_2 0.2407 0.0319 0.901 #> learner_3 0.2446 0.0165 0.000 #> learner_4 0.2470 0.0067 0.099 +#> nnls1 0.2407 0.0322 NA #> #> y_X_Z1: #> learner mspe r2 weight_nnls1 @@ -84,6 +85,7 @@ print(diag) #> learner_2 0.2419 0.0314 0.8775 #> learner_3 0.2459 0.0155 0.0874 #> learner_4 0.2485 0.0049 0.0351 +#> nnls1 0.2419 0.0316 NA #> #> D_X_Z0: #> learner mspe r2 weight_nnls1 @@ -91,6 +93,7 @@ print(diag) #> learner_2 0.2095 0.0776 0.0000 #> learner_3 0.2150 0.0533 0.0693 #> learner_4 0.2130 0.0621 0.2439 +#> nnls1 0.2090 0.0799 NA #> #> D_X_Z1: #> learner mspe r2 weight_nnls1 @@ -98,6 +101,7 @@ print(diag) #> learner_2 0.2239 0.0797 0.0000 #> learner_3 0.2297 0.0560 0.1049 #> learner_4 0.2288 0.0594 0.1739 +#> nnls1 0.2235 0.0813 NA #> #> Z_X: #> learner mspe r2 weight_nnls1 @@ -105,6 +109,10 @@ print(diag) #> learner_2 0.2498 0.0002 1 #> learner_3 0.2501 -0.0010 0 #> learner_4 0.2551 -0.0209 0 +#> nnls1 0.2498 0.0002 NA +#> +#> Note: Ensemble MSPE and R2 for short-stacking rely on full-sample weights +#> and represent in-sample fit over cross-fitted base predictions. ``` For each reduced form equation (e.g., $E[Y|Z=0, X]$), the diagnostics table reports: @@ -123,8 +131,8 @@ head(tidy(diag)) #> 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 +#> 5 y_X_Z0 nnls1 0.2406614 0.032219302 NA +#> 6 y_X_Z1 learner_1 0.2420426 0.030906416 0.000000e+00 ``` # Inference on Base Learners (Cross-Validation Criteria) @@ -147,6 +155,7 @@ print(diag_cvc) #> 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 +#> nnls1 0.2407 0.0322 NA NA #> #> y_X_Z1: #> learner mspe r2 weight_nnls1 cvc_pval @@ -154,6 +163,7 @@ print(diag_cvc) #> 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 +#> nnls1 0.2419 0.0316 NA NA #> #> D_X_Z0: #> learner mspe r2 weight_nnls1 cvc_pval @@ -161,6 +171,7 @@ print(diag_cvc) #> 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 +#> nnls1 0.2090 0.0799 NA NA #> #> D_X_Z1: #> learner mspe r2 weight_nnls1 cvc_pval @@ -168,6 +179,7 @@ print(diag_cvc) #> 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 +#> nnls1 0.2235 0.0813 NA NA #> #> Z_X: #> learner mspe r2 weight_nnls1 cvc_pval @@ -175,9 +187,12 @@ print(diag_cvc) #> 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 +#> nnls1 0.2498 0.0002 NA NA #> -#> Note: CVC compares individual base learners. -#> Shortstacked ensemble CVC is not available (weights use all data). +#> Note: CVC compares individual base learners. +#> Shortstacked ensemble CVC is not available. +#> Note: Ensemble MSPE and R2 for short-stacking rely on full-sample weights +#> and represent in-sample fit over cross-fitted base predictions. ``` A new column is added to the table: diff --git a/vignettes/ddml.Rmd b/vignettes/ddml.Rmd index ebc8d0d..14cde26 100644 --- a/vignettes/ddml.Rmd +++ b/vignettes/ddml.Rmd @@ -87,7 +87,7 @@ learners_multiple <- list(list(what = ols), 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. +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 three base learners with linear coefficients that are constrained to be non-negative and sum to one. ```r @@ -121,30 +121,38 @@ diagnostics(late_fit) #> learner_1 0.2415 0.0289 0.7891 #> learner_2 0.2416 0.0283 0.0000 #> learner_3 0.2442 0.0179 0.2109 +#> nnls1 0.2413 0.0297 NA #> #> 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 +#> nnls1 0.2420 0.0310 NA #> #> 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 +#> nnls1 0.2084 0.0824 NA #> #> 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 +#> nnls1 0.2231 0.0830 NA #> #> 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 +#> nnls1 0.2499 0.0001 NA +#> +#> Note: Ensemble MSPE and R2 for short-stacking rely on full-sample weights +#> and represent in-sample fit over cross-fitted base predictions. ``` For formal statistical tests of whether learner performance differences are significant, see ``vignette("stacking_diagnostics")``. diff --git a/vignettes/ddml.Rmd.txt b/vignettes/ddml.Rmd.txt index 42fd515..0a40469 100644 --- a/vignettes/ddml.Rmd.txt +++ b/vignettes/ddml.Rmd.txt @@ -86,7 +86,7 @@ learners_multiple <- list(list(what = ols), 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. +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 three base learners with linear coefficients that are constrained to be non-negative and sum to one. ```{r} # Estimate the local average treatment effect using short-stacking with base From 8137b6773708523cab54a2f0708365f280dc057a Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Mon, 13 Apr 2026 10:13:57 -0500 Subject: [PATCH 44/46] fix vignettes --- vignettes/articles/did.Rmd | 22 +- .../figures/did-unnamed-chunk-10-1.png | Bin 15458 -> 15465 bytes .../figures/did-unnamed-chunk-15-1.png | Bin 16168 -> 16177 bytes .../figures/did-unnamed-chunk-7-1.png | Bin 15217 -> 15216 bytes vignettes/articles/new_ml_wrapper.Rmd | 2 +- vignettes/articles/neyman_orthogonality.Rmd | 357 ++++++++++++++++++ .../articles/neyman_orthogonality.Rmd.txt | 350 +++++++++++++++++ vignettes/articles/stacking.Rmd | 6 +- vignettes/precompile.R | 6 +- 9 files changed, 727 insertions(+), 16 deletions(-) create mode 100644 vignettes/articles/neyman_orthogonality.Rmd create mode 100644 vignettes/articles/neyman_orthogonality.Rmd.txt diff --git a/vignettes/articles/did.Rmd b/vignettes/articles/did.Rmd index 4f8b595..09637f7 100644 --- a/vignettes/articles/did.Rmd +++ b/vignettes/articles/did.Rmd @@ -160,7 +160,7 @@ summary(lc_dyn) #> 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=0 -0.02010 0.01172 -1.71 0.0864 . #> 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 ** @@ -243,13 +243,13 @@ summary(lc_dyn_s) #> 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=-4 0.00588 0.02457 0.24 0.81096 +#> e=-3 0.02752 0.01776 1.55 0.12113 +#> e=-2 0.02371 0.01457 1.63 0.10356 +#> e=0 -0.02131 0.01177 -1.81 0.07027 . +#> e=1 -0.05714 0.01628 -3.51 0.00045 *** #> e=2 -0.14076 0.03499 -4.02 5.7e-05 *** -#> e=3 -0.10395 0.03332 -3.12 0.0018 ** +#> e=3 -0.10395 0.03332 -3.12 0.00181 ** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ``` @@ -380,10 +380,10 @@ summary(lc_dyn_r) #> #> 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=-3 0.02957 0.01759 1.68 0.09282 . +#> e=-2 0.02405 0.01446 1.66 0.09629 . +#> e=0 -0.01985 0.01164 -1.71 0.08811 . +#> e=1 -0.05498 0.01655 -3.32 0.00089 *** #> e=2 -0.14143 0.03446 -4.10 4.1e-05 *** #> e=3 -0.10858 0.03288 -3.30 0.00096 *** #> --- diff --git a/vignettes/articles/figures/did-unnamed-chunk-10-1.png b/vignettes/articles/figures/did-unnamed-chunk-10-1.png index 1c7a1eeb7223d315a39d523a8b71fae2ef910d19..c218ad5a254851266482d58c4f41669942d3dfc0 100644 GIT binary patch delta 6908 zcmcIp3pmsJ{~w7Jx#Y4!uAz=H%B7N9g>EigL?<>n$`6N?+m_+0EGi*=&pDDo z6-Bd)Op-eIsaRsusN8L0CNukgx8XSd=lB2ppa1jx{+{Ri*go&u>wW!vKHv4=25^t! zG=YPvq@MlH)!`&=$d@u*7B9kksmfX2w84?llH3)f{(uD%LwU-SO3!GcMC@8(AykvM zhB1cl0kl$&Cl~_4OhVG8M%a#f;0|n(5E@H8tfRF#?u`=7?j&7WEgZSm1DC93nb_99 zVxFt@P^kyTnvr=`1Jzx331xRKtu;vNvc&vEiH81V-mPE)Q}F1Pe^yU$9O8?K#0V|I zR>_pIPMgDbdeHAzyzSaxpsTLLVr!{KymcEn)fU{UBJzA_kG5-S&8uFPeog`Z5zh;N9$gq}Qho|k@D=}@8aZZHVvQ#v>sMXy@JS#e+W z&NjpqbD)Zs?Nid)GUjksaE{BzM=x0*Rq;~rKZ`Necz;?pn`AG zrnNP(+1cGU3JYn@iN1i{;CEZLh~Pg}q37Okwa_xd;oQ0M8HOV{QK#nkRP@lYlMWqq zBV-$r@G)lX*7v)xR;=1987g&-`AMp5vp!ywSbGLzUt6QaR;tPE*>BfIj#JucP_Dv# z&(EvKR|AG8m{7z|-?=^*SPi5ZtC7Fh>1e>Jv z?oUOvq3j_ojA)o>&(J$KAC+MS{zpFnW}G$xmkkApr_xT-ed-(%m57`|)%4lV^}0mc zXB~EP)rn6u-Gldo=UjnmWG()$KzA`5od>4eKc1-HxgvZ%+{RTr@8;5WT4(898nJPo ztRbaN1>ycxuS!W^@Jb^|LuUB%jjHJ|+2AyF zy!Jzf<^BX~g}DLUQF|C@M1_>68P8?!mFk`Fu}D^OPOE#|h7jT2v-P(WBULkb>5!`T zIFBZ}XE><8x1*@cdT#nASi998dL?k$pV_njEu3V*&^u7LPo1-IIfuUs_qe#<4-^_$ zm~Xji<MMJMKxS+CX4xa_Y0;n4=QzOqRl7Xbn82ivX|dE;l!01yu&1r7UG|%mFD& z;d*S|#&(26VXmt^<>$xjif-Li@}R!ns)r z1m3g>bzSo;+UQ9ZH2kFUTL@T$1f+Yo7D}_`{HNWUW#6DlB!&D|on5Go@*yD3-~jW}?w;XqQp)1t{Pv??V_K9jtSl2rEl= zx^~hY7k~}CJ9VPQZ$VaD4`4?V#Ze8E+Pi-7V*Bn+?|Hx<1X}DNtP;g}*4p{Lhf72E z4Yo3!$tAB?07ED8Qc`~7p;i>Ctrh_KM;9cqE7{Y{qx)MZ_x2GGA9hHBm5ktslE+lK zT74*V_h#8afaYjby$qO3Xj;ZurK|C+smtWJ~e+k#**PcslYLLLHEv7DiMxBNkOd zMN6QbXrf`TG=xp&Ouw1YBsdRGCWbE5m01Q>WUKgVl{7pF zyKAZG`1Fm4HNw+07nCRAEQb6KJ}3%m@5YVUmIt)7=<3W9C!Gk`k4^QMk0p*s``P@5 zIzCtb!2zO-&t8m%N?Yj6a6Bry6UB7c;bKgE?jb4EVahUY=xjk{5YS*h>o0onsrZA9 znjNfKLc%Y{hzcsj^l?yc8#}kkVZr5Ye;jy&J5%dsxlk!^?nvR}?2C)n=CfqYz~cvy z+aYL1vZ#3A@LPOnZ!G6q`!a9R+Sw6Le3A+tHLwDj;^;4N-8L*XKC_k?K^-8y$b_$xwc7 zz{$#vdVH_;dfnSj1=rRI28D^P(nP@~;h4BnneHpv^?&O!hrRZ|6{j7Oj-Su=a)7Tr znKvrP7v-l5-VF7rg{kJ?QyvL#d^CqGw?Lpq$0p;AT_#aGqBUVBOsTE48+Ggg zVn>2zHZxSYm#nImrIu^3`#OLTE8X7HjKp^-C1fqssQj^jZt3mdH{o;kBZqKR8 z`D?eY8Lqm-HiupE0C2@WNx{4g_hZ#G2`b-7pexk9!P|AQr*7+t^nuv9y&ev^9eRoL zh1D4Sa6D=?j-=>%<0S5k3;UP})fL*8;sPW-2CgE;&6tdo_x!Hts>{hzjg$mrU!UI) zd!+3hyXCVsR5SM%n5T{G9}f4sk2?}oKW?O7gp#<|9ak)y&ac0?i6UQtW!5@w{g0&H zE$Su{Nm3xUrG$=&t+>1!byXsN^~KsR2Lf9QzW;MPmW2RA*8iaFEkc)98c7Ag`)1q0 zBs1HJ-In|0Ky~xyKz<1s+Pu#~*NQHA*Zh*F$vJPKeP&rS?53}uSs)6Ux7?W}f0$5% zGM)y!4{iz>CMxgg2?qP-HZSb- zS;(#Cx&7(0w~OzFFQY3_{)v5t&@FCc+XLyjVjqO1e&whYC*JItTx!hylX<*p32w4& z#Xejz_`7+`YK1XJn^JnZ;<~)SsBGSKsPE|ap_(RHRE({^B@ekw0e(l4h%Ps_Zch>S zsRC$dAVN;GhDfTbf-`tVd&|rR{4%KbAbcJ&*Pdei-hlMT3s4~(COF8jl>J#P>~E@f z7uDC-lSqRkLqXuK#j0WlhH7mqYU`?dx78zs4;SSPfa*1F?u-d-8@@j<^wvnDfOu)q z*55Z(@D5)qn0Bgi`qQSi6G*eB250sjWnl!&~ou(!<8G29Tk z%+4jMhk8Bz8c)6ljxnO}P)9g@6y_I^1!w6K$VdX`A^Mqp;zWw5U4?s+bljAhx{09& z-83t5Dpj`OAx-fRW;B4a==DDkhMjt{PiA?O3fGoK6r17@uf~vSaOBO)5E>QCHW`(k z!Fy@AcY6i*_f+okDl&|-G&rX-5aL0hCuSan$e1p{k)*&Skf%~IPZ5rU;Rz1DyKusv zG-1&3IF%>=$P>3jGQ1g}lZ_JKy6DaYuxA>MeNafXguvQR{afk~zpqIdrYRJ_PPyZj ztWFmM3HdcX(X+>lWyZcKb01K0*nxrX(Sd<8(s%3Q)HLQsn3Jed$p0; z3udEl2OZh|9=6+*dKS7mucT!Urm z-|)PH76$8_qjuDbvQI`-*f0d0%^4A2eY#Yl1Pr#ZgMU-yHcJ>lvW+|V#%440m@m~o z1xA{H8u9_aFl7Z2Hk{+$uF|gGPAA2|x*akftbTA*p~G{F#cmF#W-Txu1Fe5c^y{#U&*;Zrz0py;q=CFD?$1^f&M(`I@ ziA0yADPFhBDE{)(q0G#$dA&@}24FPuw}0j_`SEt~xEWOF+VJYI7`JFH_X00^Y$TkY z=8Yo(TdzkwD-CPw`YEg6#Z+Ee;`KUymfM#^N+N2h>Ua(9`dcTk1P@>dSmj@%9Acfj zPw{>C3A7S`?y1|CFe)a@PD;s_Mta!6J9u+HL5e)1(^k}2GC)#l>u;DA!)Knw)Au(_ zh`W-7eV+yX?~tQhe98TH9fh|$lHX7=JMX=0if?CmV!paKqM@dZNa?LNmt2Io7DiOB zEa1QrVRsVxu8RUYd3>lMVj}o^j_B?{FjBA`Xb+9qTG)epclISw^+=Wf#e&G>tn)5c zvb&cB{?v;ME1VR=pG@Tc(j{CE$AHnemOk+drpt=#6jT!TFo!7OtMhv?q zsPXJ&T-CMV{9jlS?%?erVc!x8n`qE$ zhjP5jQqD+>9gPwvC_ae0i*@xtp5y*GdaWuY`Sa+e>$m8%*+U#4vDEO63aNa$`<`Jji{`_Ac4aloekkr1>7;pk}QkdmZHz&_r^B7$LiMHCbCgsB!CthH}iFP zc$nXsHeH(g3Up~%%KbK2w5N?mJjaXn6(?|-&oU|tN-;WFAt!y5Xe8b`f6+MplwDzF zS0EEPj3xu6G05Y25H9ju=r z6cg&Pz($(h`qY)`DA*|voWr5SgF91eqoed@PE69#nc~*pw;|HD8dD1fPK2I?)@^dT zf7PD(!iLO@3g~maQOe zi#jke-IMcD-0urb*(4}m<*P%iZ^8*xX+L|cQduX@88Ir*Q0%PdBh}Of$#hX?Msm(d z39r74_tET2Zpn|yvB^I=u?4n~5;Mw>8GBQe_Rgu>5nX|$7Q&*iJ@HnG<8C;|S0@Rz ziH;9TC>TU+atZXhUuXdQ!)+09x;l`(^LkVK53!ySnb;jNnd$4@u6eOu7^=XQ{laq* zAyJq3XUf{3X0y%2!9bO-=XnXfP4G0ncGF)AxykV+Y5Zd7jW2|ns*cjyFfHfzHP=lN z9A%C>(8xeH?ysq?;a>cDxbL{N1p&LH!{1_4fFW9K&~fij7;pqBaB96FQBU9{T$O6G zrA68%+EBCJVqOV~{BWt}YDws$K#4KA6Gqgia^zJgEh>a6FDSB#zntY& zHqy7{)~0TfWC1cOOWC~Oh>37;m*SGWt~kmoDceeQwzrH8Hs{`|D^3h$STh`1(Xj2j g9Ox^rts@k-Ti&_bW57EIgZ}ood+#dS5q$2y06bEa1poj5 delta 6938 zcmcIp2{@GN+aI#;TiN%mjzWvX#3<56=#UCSr5sdK1~X{9m5DOZGM%H6B`R4$RMHHS zkxIf*+0HQ2Si_hZF~&CIduJ@w_y3mbyRQG|x?E$Pd;8t@{kxy%eO^Q89&~A>DquuB z4V}MSo2+UmMZo7a8LnKBs4;f)jH0W z_f~*S!Y{HDy(NFokllqpf~NVb^Oz~#hITGU$ZryVP;W&nXFA3r&w2r8&yI~0&WyZs zP&XtRw$^wLihc@Kr5{wSe1k~*SBVpPb`lbxO>_$1Vv2V1 zBCv+27;jv6C#(QDq>#8ZSd*GRVimGcpWiW50+yl2&8D?7Qqoy3LLOnnO?RL8dU?DB zVY21Z)nU*dV5o>~A32XjNiJGzQ5lXGF0z>}QI_2`*OPQ=)9L1(Z<=e_4l|8nJMVgB z>_u7k8P>8-OiQa_QRWL)ed^S$u%E0LYyq zrGEX0=~riw-3?>5@m1B^Hw_#DKgi$*rs@^hWq>}ysLqsYo@jEK_sH&O1G@X`xYMt? zm1(_*xmPRUH>MBx-hRJTyOzL;nX)I8nAdKUM-*o{t%otUqpuqmNpuUERm5H{>3v@|i2EAV)7!i>BOHu&a z&MnRHO%ae)(7jvA)Dc{!B1dI`zk($-WvUysaNE=mm)LeZ<407f67$aV!X*cwHeU*{ zYYEcgcrD=;3^_Q5ONG3^286@pB_OV#-9JsyEN1eJ&JWb;_Zp9X1>3f1AH zCo#>6d_&^;r8w{Zhj9|t&ypCZ_~?$jo@bkG`x@#@C+rl~_Q6t7Ixlgb6)y+QMESOo70TPd^Ynku#m)AvwB=hW$mf&r)&N*R9LW zJ{}nzJvsAj8?W{8;AgZn!eyz(-(^{S!-wXQ>4Ycdx4S`WAX1XTg=oKrA9?SbNY8L{ zlw{pRPQ93y!P=TYZ~xY90ajZKB+D00TKOGC2Ut7i0y{BS@^{m?OZ5tgPQ`S07qoL( zLjKJvar$lAT?yUJzQ0jtiRD#R7<8^fn0FxUIc)2!J0oEHXlWrRhdI-?% z&}vm(L#XqXG#14EV6yz@o@dR2d#Fy4Ysn+Y?3}H$@poqq+;n!ADzPHtdKmNK+bOG? zyoE-|&S=y&0pMG%bel0hsnku*!f%OeCYBv*L|iRT@0O;Af^ofWC;zg>c~;_{4Ky0~ zf}0~ar{ByV(XMC|nEaK~qCu!n-KNB`BkNY#97G<>Nr!ak(!0g!9Ftel=fyt!D%xd~ z9zdqp7uDrRge&aDpV2okJP?L{7uZCd4?S~r6KK5a!9TX0HGAY)6?v_SBuyRT6uhCa zC0Fbr+pt`2DE7~KFfRLP%o zk1pL`+YnML5-*IEPw&4k@%kD*P;Z~j_dDU|RhK+|(|>&>j20|tjf<_w^qWeF>F z;EqW7GdY5EWE8AO{wwZ1#$VIZ2ClLv#}*HDsKddvV3k}7FnHaoZ0bMYnJ%r8q#tKx z_|s||VG{W{b0WZbDQ69O)x$$5{i@2Bk4Z0IPH}vAoZd{_<3Xlz(4H? zp(hfOqTWR%2TuC!Sh79%6rhhzPSc`^+UE}Ya1rBGqsxdf9`vesROv{sVlO^y0y)<> zRP{BEmq{^L0>hYHV0+GTo^dzEEV+!lzRw*3 z(bn7Tvduf;Pd#dXM)#KxP8*8_jcu80%1hwml9%(fCpJI{x$~9dpEVCyhV1ROvoEIg zb2%*uov$3S-tI+vtzPU?3H*uPQ9z?7>ZEUTkFOl9_6zSS~Ju+ zC8Wd{k+H$A0TBu`ruF@SA8dfmeth2I0Tfkh4PeXBiPvhxSQBGBy~$2?>F zBA01snp6?L^=s{S3$pBOuTcOb=EFqPv!1KvI?NCQn~$2Ky8*W5#NgVCmLfsp-PrLDIC1&boRahQYeLk zI@t@fHp@6B>yCS_$fkfKuFhk(kwRx#P*~;tUfq~D)upkS#9XqipKj9Ed1kc46p+l+ zP?pEN%i#X7z)E9cMH-)cti|16aX7IRN#kD##2hO`d@(n) zNQbH%%TYhhga~0MQ@?er!f6%Rt*vs0sJUAa<9Ja}x_HnvwyR`?@HnYIC7OK_Yis{< zVN*J-3OSAkWLfc9omru15;2~CW`O;2P?FG`4=SFCp!e$`0)3ln!x`*jEYrTtBA%Pc z+PYmwy%KENsdX@82D|uM1c*+Xo}zI2>EoKa7XSJPeuEWS25u z?i*`}FZ>3E_yfcOybyq~%n&?5R;0yhluCNwdP+goKymhHRDc1?ON$nnzH?srz7EG_iHAP>NTlnM$`83}*R z?1npx^4#DcVQwWaDL+Jf{s5%HH<8ANvb%fI!F?s$8-yg>vy1)pzK{}$$jG??27>{P z*i4~UbKaN={IxomZnz-b@E@~fCg{@2C4qZZ0;=Bb90d^nCEWYv$AxX+CiT#W*aDs; zc<GEaS_(X}GM=2foO3D;_YlDewI4qX_=|8W@m&m%`Q11$X=Ub&y;6hbi3E>%fEQ zs{};G$A{c+O3a*Sf_eT%rbHdY?T~NN`HMO&2}(W)Bz^mYl9)wF*O26%9cZYc5Pj`U zD9`CWX!qYs!AF9@BYPK4yNEn}Fu~ESiw7EWVnyA4rX@YqnNjRb6a8h*W{HvYBQ0Zlh0l4|*I_#fvZ@_*rcZ25&X zCM&?SEdb|0I1Jc=M9=Y?b@|ocDFs5$6-GHx+dBT+nW?8-m0zkJ&MNrJ9Mi4@4l4*e zQkb*;Ik|U-u>>x7Ri#B&6h;-j~3XSjUt!wrKTo{)E_7q@z=(N2E{KD*s%VlQTjvcy8)g9!bO!Z}8h1K%#gMAyc_29uxUdb~WV4QVzu_fZb(B)WtNp6+Pay zguJZgaajZ}hhEuA`K|(Yx_1)IH72n$o0!a|OwVYPmmgX7vN7=jgB)k)Z~?eOZPjfr zQG?$Cq4r223<&IE*r}X&amt)~y_A(fDqA8#7BQ~6x_TYZuoo?I7HfOm51sI~jpZE; z;}1M3m4^6&OHt?$eY-g=d>{83>vDyd{@AQgH%p8@E!ME)HJboTBL&m}kfT?nIJh9|Iuh zIWkm}lx$C^%?l`7henmw)NyZp_3$PY%DQr>EVQ(|#?^a?w7T{sh*-J3Don$U32K(UpjVKHT_JGX{1cehq$oo8=$2g<@`Mz-0^JmtegVW%^!KCkD& zP&B^XG_Q36H#?gdHXIpk9vV&i&g|J-a2A;%IJ>5so7B}w)pu#=r&kzvZgtN}OCf&m z4gB(&Z%b<*QoMko&CL{PIUM94n-8_`XmGe@bH{%lkT=y3nLU=5&^qeVGjKTY7+vu} zFG{q%W2)g$9uFqE4r6A@jh7))9%xg?r(t6pkA&PTbsE%XDgqqO#4N9D$cJZdt z<38CXkb}TS@oNwC>L&T&V!Vy{FSvLmYRAmr+WX~%yTLQSgUx|koOyqAsn*rJzdkZedKG3AUm(ug>bt$`{?_(052r)A$-C`DpmOs7p`m$jiVOj(6W3Vn7Iz72N!Q zLG{>%CiuIvEW3G+)u=8)W~WjPsdt%mX{+B-)ASvtBTJ18^` zGm*^?Gx^@vjI1FLUxnuZp&G@(%;=4_6bm+ znhvr@s|S_y;>>)we5MrZ#0E-n?G)~B=&2Og{LZO=x&rmy`y<+MY2V^IW^q9g+2_oB zA58L#rC6(cBUr97*+5c#;NE@&U zVtX4ew`C_@Wy^Z&)pv%$7oe6B$n9va4XxnYPk*@qEIax-Cdw#*^Dq|alYy(br$kjK z8@ydJ1HP8WM{cnLVhPn#xnnSUaHqA_$5teqbk&esElM9XNLQ9vk?e$qzCVGji9X9~ zs7;71M$Athq2-DRbR`#bi%4UHf&(=FtOM7$4vlvOAuoa<8>JFBn;rADY}<$Hs|OG5 z2P2;oMAke~O5ImD%%s%$XBC7^j8_AahdqB1R$HcVub)6>eCYBL*a*>rHq`^RfA{-; z)@C`R*p7MqB*=VgUar484O#yY{4Y#Gj3H6idm}jrv*X7?KyYBj`yk$9s=p72+6t>K zj*EBtGbY#*EY$dRG~iXn_TBKggvpA_v1_f=_$W>9cA9LxBG>k=Jz*yG(@bYpYXin( zlfb>5Au&Vf&B2|el>+~Gy11Q#-GIU`mJY`#RMjjh=?_Apj>jA3f(FwD#D(xx>zK*S zTUBN-;J+6Z3MA;sXwOUdu$Q)MOlf~~XVz%B^FF0^dPknq0R{zlDt6(y?Wf|?k%0>7XJSxiqN_!?XE n{6=zln>|JZuOzCsiVrKfnRoFSuBs3M{_Nhd&!u>K(8d1%^6uo? diff --git a/vignettes/articles/figures/did-unnamed-chunk-15-1.png b/vignettes/articles/figures/did-unnamed-chunk-15-1.png index 696568c212d3c463d1df60c69e86775adddf74db..fde99732bf50b29fc4276c1d3057ed7fe2258cb5 100644 GIT binary patch delta 9304 zcmb_ic_5VQ_a7=MTe3zXT}vq>OR`4D%}!BisOa9ZOi^YS=2c2HqPkP5WC_WV6qRL$ zxvo2vD@l_kG&41ctkc+r8O!f^&7i*b_xpZ--+QmWUeEiS?Q_m~&Uw!>`M8I;2dT@T zDtWit8HZW?{eFtM-S{tt!yqEMTmFi6=Bi)`tq?=EkR%g_CkXE+_+FmZ*z$iM* zo-)Gr9T<5Q<|$Z=*udyH&25HQwPlREBze?!Q)Q1_|0Fbz*|K|}Jg3GtdM)EpsA1Oj z6-w+0=O<%H#ef?*y3+{6Hr7vy^|)zAleqN!&&~Zz zg=~y{VXaT3$l*afMip9}R7tv5Q$d<|%tPRt>oO7m00Qk=6;LCdAu4_|8K{V zS&yzd^^Ic8$IKQ|m-w^?X`{ds;|eG`QHJ4<+!f%DoZ=Poc>9~S&W8b>+ur=>5bUQy zycurPU3Jc!eVhy^*^&DsI&{+od_; z6e%vYTktgWo@!UQ_v)o=!;Q7ue?{mbnTJPAr6>{=IheS+SKE!7H#GB8qJj)T-W(8TB3=z9G;tA`C(n;uj;Tg=zZR8j0hxO z!hRHymdIK(;Yq5Y_JpZ?WL%Y8BpDC0L{XnBmi)Xv5CLyGmFD>9L(ueA#A|rtkKroy zQ8^e-Ls($5YmSl&-`Pe(3TFHzuUW#8lN|&TWv4kBC{vPtfl2V;DwTn2@Jd>+{t9$) zAo; zm(KR#x%@}LG8ty-y zps0Gj@bPTCqbeEw{JRuM=I@u&iprSWb?Wkw!ph?bt7TRwvV#WAF{!s8Liwaq7RG+= z&2B|dZBmEY&f1`PQJ?}V7v$aCVWvEIDTJdvXdTK*T2oWTbTjmFHAxLO>;Un9^Ad}G zQlMELC5^7*;X$$xD)A5#Ik9jl9<4Jg6qS)_yP8fcwaOOo4B$YAcuVBv+4??_-D38u zO7$3_HYe>W(ZS%5g!!)~vKq(abb~^C%bf&UBJ_~fCx1H)MQ4yEo0N^G{VOl8Ir@(3-PYi#4%1> zO*r=)dm@A!u28bQ=Chbwec2NXH~nl$89&CzlFDivlG9bB4*bN}3s;mGtp>d8wd&ln z{9N>6Dhi?5)l!Vkc$_HZz@FxLb?;Ns&I#fgCd``8EEubAatj8+2+!>-?YbkZiZB?r z&#^vNt9Z@I1)WO$s{3$W3aH&n&lVjqgaj~Z;>&FWC#Dd_*@XVjf?blh4ZU}tJtk0@ zytvWdL30LI$(fKj$U%yu+)P!{WBaTYezU%xQxifij&72fx(#6t&Z_i%qcO5`WMsb2 zfMd2*fnA<+xKS+i#Iv0WsENKz(|L_SoLH$Q4}=Z9J0wg;fx9hm=39P_`>pN!{1pUF z`B2yj3{;Xh)1q{XHGI&HanVHv%)rv(ztH|Boc^Vs&Oa)WO;vdfpKcC@x%Jy3rD49zjGd-6cmQ5 zwD{vyQY%N*?zkGs?>PjA(TJH;xU6Lfk!`pEf8&)Ss8&Vf!$&3XO5MV@rb*$!@6ore z2mWvzj=~nE@w*Ewil8u>NtxzgHX`7HFzK3*%<^>|uyA)VT)qVs*Mm|Cb>tjC5Ev_0 zK}RLJ8Nug+Pr>B^qJB`6N9`WnxkxcV<%0Qoypo0Yz`kpK0ob-cxP0-_#L5Z9U;zdC z3%rtZ5H}YX{kNW>e~QsxDp$N*|M&9)uO#%u=ZW$XvB+FmAV#wVN08cegoA@DdEMv)^VjF}MKvxT zA=iuLV64vn-_OwhXOm!$Ud70r@Y@K4+DGSYTYWGxINaN)Dq0%WK}qD&_Q%Yi1OZoI7R?ngShNU*OiN<&w zkj%+vE6)Lp-@pjZoW{|pAE0l>2*T<<7diaPpnah?zoe z@X5^-{*h>wZHYTvrC&tE>Ij@5SWKHBtgo^%<7 z|7-$x8cHA!@D$C{&76nHk#pAgjf3%$jZJIZ*ZthvYmtEqW?UD;(RYiIWA~_$`!JgQ zh1{zWbMhRN*sLJ#2QnLHQTN_~SXH9Vts(f%g5y_9!A>5DKEHbML}-i7o|S@zVEXW* zFPe}bV`?J6G{o&NP)?Of99)nIgre7)AQ_1jhFxY^io+}yEUP0*v{0m}eB+H&6O z8}aDU*u1c3JE}j8hXp;%$TXSD=)SXS8TEZPo~R|EaeI$Spd^;K90$So?xGK=WmDL6 z@H1ANGej7*vz}271#z2{ZnG}Zd2We9 ztS)0@ZkCms&0j}OxWQy`)LiU%lC1o5GY0Xq=SU6)tDKoRea$%j-<+Uc1@}V@P(@`(sm_5#9$M_aIG}7f;Y(PKGxsys7svK1mMi_ zkw+QN)C5z18>xWPQG*Y;%V73b4{-+iPuv5ad&JRR2us$h>d-{|amSB@jg>e#fiEAR zi=*@niVXA(ptzlJlMlKyP64VLft-P%#=W3(MLAJ#O6m8e6s^NGqvWd{5c0{ai(z@?i{rDq71&5-iJ@R@G_l-fvz0_mJDVX^>43NbNVLmgiprPe!5^ws z5XXSFm2d@n=}EFp>A;)SnEZi_g3Ht`)tQ7l^7|bzFi+(~JZ*2Fuj;=i|`y+c~4UFd$dl%X^FHB119{IxV zY>4i+Z)!S`Dd)e?wq8Cd6%FYOX@eY#IIL*Ee%1?D;XB!woSDK~<~^NyuMs4~yi208 zF()lONX?ICM4V?W8nhL<_z>u9pD&n=fOK7?hRm!V|1Ht7f2ATE)2}NtT#FP5G)g`M z23rfjC?aABB3Pxk&*Dc3@Xt{Z#2J<3(`l)!k=*j>lU|;reS#o+Fg$AGk>9+%GI}l2 zJ%XqX01YB1*{f0q0)ytkYJXY+M<-2O0Fra!M%%I29B#M_}Oeb^L^aUzk|Ms zd+l#onwxjH#_V;_3cq~r~}S{x=f2W5u(s*;0&s`QN6a~ zx3Q5jZ=|irVvu`+&NFyoN|*P33DQXN+}v70O!LK1CCfwoMAc@rPd)Kq(thy&D-m-;7r#4ha=rO+3>6i4lN8QDU94n;|)hoe` zM#r8ZsO!Pm2g6GsdTHR{K9zA3YaZPQ9Z9ChG`8Lej=9>GoB{jg8t8Jq1*iU;=_ zmx4KY2W1iWbs4{2^dNE0E~kyEEgidk^u;1wBw}=Pr)aP|yD_*)M)lClCR>o@MS=vx{-fc#v*1v8nr-RKEQjv3JA6Dn46YXyg_Ww!7Qj$V0UCsdJfPoVwv>~ z0+s%CGAh)a$V&HD+gWnGVyJJpaeREd_a|;qiF6F(X}}JSXpJtz76L*uyi)QzLm`a!J!)%JWRrA`;-4q^2JV9*Fg4XQ>DKm0IlnJKLatmfe5N4f-dH z_^+kT3tjdd!Uzo+!fI>SYj@sO99Va+hST5~3mKjZEl1~EbK<|ub(z_> zP##4cHY>^_uS}N4-JjC<+WVH0y(JIY9Lqm3_^hZ~i94Epr01Tsb79j4nXYH~Pe1N~ z>sJ{w-2k+0CKi~7DPWGVkH18hk@u9Ge{#~G21N}Jm0?csf{q`BI2R}H9)6&NO)7(I{EB^eox(sbPtNQw+T)?C$ z=4->m!%b(PQQy^ty{NKJcC4fQZCgb5x}eY34>-3z&IFf|7w(dOUrDOI#Xnfp2M`{M zWLF|z(%$d<)bn=OC6Mh~b*(n9#vsM_Ox@!ZP^fcYQXI5)4~d8M3hURojafrwmPt>U zPM7^wnzmc}hJFRMSe&c-+#|h_o}~Vs@KSPV?bGR9`<&wx+xgVRvs4F*m}RF&2aM{6 zWxSFMUU=+F#^x%AQWFOB7rsQb4|8+d+T86pPkfqcSCWdSa?8-E%QJ38f)6izw}%V`8d~k9ihg?&@fWHzhdr$PK-vIt|>< zmT%$kN|v@4SGlYRFYRGcC%X!v#T)J^v|6ntj(U5L=!HAEW_Lb)S|8hqofz2uNqdl| zohhD7^k5#gbhfcV_R`3V=qO(2#Kgo%8NbC>T+<9fF3uS28E|fak>8gS6ZP@sWdK}( zbduwBUeqh>Qs2r#CNrV&`09v?`^b0XxxWdgRobU$ zO_xy$81AJpd{o!HbJ;?E4b2Rh`)h{IQR#%j5C|>LjxlPuUpJQY$|5Y;X4-qK?LC(p z{G`2cLaR!BbV~F3N?mrnR>5Pk9v+<#Qi)!($U_vbgt+BN>Rn5JvrOaN+ou6N+{v5M zPG>)1tUz+`AEC+bqM z>?sk4ER4nTw~N6qLSUMZ(}Bc_Xeid_GjEEkKB}gb1<0jgaud4;Q%~8BS9^}eS;kbb zjr9sE7k8dw^=s^1v#>X8BI3O_XY5g}kcMlO4~Zx+<-c9mUCg7O!pr zoyUa&c~yIEt!}A&8RT}wCsOvs5=#5lCytBX()tklI&Q8ap-mXSI{{WRrU139k^|n7 zf6YbC& zHS#gWTkDFss~4bBmq#hJ`sysdSK{#ChW!nlAXs&AO1r~o%Xt6;4qAuAY7EC-0CrZw zcEY}a0rgiadN%#_7}MDfRyH2M29%uvzda}*eY;_nq&zCEFDYoT*p-v4FaqqD;4IAi zJ8@X3q^>9c36`_~Z_A0g9Ct#qHh#GWX`g@vI3jgq1^W;bVq#yB+!C>%i)ELs;zbCy dGV2xj(^XgO##b!XPegz}X9u@!_w52t{SROs4-^0Z delta 9234 zcmcIpc|4SB-$$iI+Dyihv{TCHL_(r$ZI&rg4Z|rd*6EO$vCT~?HL`T3j>;O9P>7hA zK^|u+IXH48+YCc?#+}_*-s?7Is`ot4dp_rV-{T+mT+46y{3(q0@Y?HK=~Bsg z)H^ts0_~mX8lAA@gqt2A@#BV$G1u2Q8s5&@!G_DaQu-Y*Dy;^1b6hLF@<&y6q?<;< z!8%!9%}Ww=U!VA5qBR!`Lda;IEW!I<{EKk&Dc*5BReO`-Qq^PWEWIgS_x8~SEGLbL zA{^BIR5(ve_6K$LIL!@4;~tWYQj4v<#GO^~mRb6V3P-ijky~oHu`xfT{Aehc`C&Ud zSR1nF&I))zj#Q~VmLhq)e8HpAOtPBF%s`9Vsa$mRLOkR)nJ!D!ek35k;My}S$Sy>O zI{rqy;q9YZ_gvK1nR~GGya#)F_-WkdmO(zHmp0Tmrsf4|%F7b^+G}k`qqK*yYG}8gX8|bIU#!TmyEVQy> zt`tz#k>w3nW1An%*Z?%ke1dcH64 z%ur^>I)IfxY$6L6@JD?~b5{SD5=P$Qu~5Z6U!yhbO)7V1i9in;sieuQ*1;Mw?wz#& zI8QZp#pvFSu-}ghAbUvGFCDod;Mqu}Ph4*KDC2Bfz=^-bm7W9jIXR7_A5rO%p*&hh zixLf|lhZ~y`ee3$TQ!yuTC&G}=|+#ESy4U&kubPeJDd1DJM#y7hswvt$9pae`z0#7 zF~g#`1p)zqmL$)qP3l!8AEnRJMP>)aEp77}P}fl*@FNW2>vM>nVjkCasBl%DZtQB< zO2e&|r~M(bTJIc+SAMSYNP!5Nm8>#9tw%zW`2O5C2Rtf6rEV>D)>6lf;Sn?VI_;y3 zGHqm~9E2;XjJqdd@421b(_CI^nna5z2uTq7A`ptyN7CYr7aO1mbIwCy;YRy|wWFeH z&{0uEg{g&vqfQ??Ia>L@Ms!c_z*fK99RTa3eZJ0%Q>#XlSC%?s* zEqrcyGCFPnr;kLKC-f^C4ki}vn8&M$JWOjqD?+dSh%^;BZ=PIE#h)!xWQiMT_8Giw zY1XG+C~{DmJ#3L4o@#rv(T6zEJ~=r#oXxMXU8qlJeN5gcaE~u)?9yS{*y@sy=Ze31 z7>NWv$)uHbG~0Vxuty-}AdwGbk&`_NV`}#eP1=p>h!n5oni~suS}_Z&4|_Zq*NP5! z+nI2G$w3n&N?tiDM3s#yJvP}X6B*7Ojy*xBofw>VZ(XWc< zIDg)4e)-5yVXN`bDsiI(asZTkw?PwyX^uelc~o050}YT3Ip#7&6TTdu4Zb%6*CSlt zyDL!917-+2I>;oim03M{&l{g$)$y#OuU83nBYa1}!pJ-1=0X)mlclsw5W$G_~-z3RA_J(9sF!u?ia%WxwV7g}6JNWb#aRL`;N> zM%rwd-n@NeFP~EZKlzOJq;>a%=r0sGeU=)VU{?J=TD>PcZ5ySEfD&1g!PQp`>vtc7 zKAjiE7|5Cw9o@0bluN#{{&Y@(^fxp7DY!G4L-)P3QApxCcX(67oP&Y<1DA!Xd`LI7 zb2*p<(w6PAjEbvSAW?blbct=k8}tXL@bKXmS}e0xhHZ{MqAm9&(jKP7=k`LygY6sR z!|Uz+qxIM9{t(}!D({jgT!8p>|JOt_nwGK5m;Htj!j;B5cj%8lNA0q)_Ue)}TKgvl z7tMT^b($%kjAyL(R8rK64{Fuehms# zEQ4jP7cN{#t##fTWqdFT4-Rgh zT#U-fNdp+q^2}R}Azbx1faHiK$9MBsJ%>gv*?`11xBAOs)D|SABK+G3Z7n^$ zg>g$Ohnx~-RIJ>(n^+ONL2rhce}@C#JB@7eWry~?gK;@525+x_Y*Q_*1%UA+-f(9; z(O{5$cuqVcVwA!*d5Q$<%;~BU8{yzDEWJ{mjH+xkb!|G5nSkk_wVpfJ#&eD)&pWAu$ZjIzq+nV42!c`j}yGY(eTSVhR%!2FaoS78XO;_h)@On>kcaSmqS4sBoho zAfef$`XN;(syf@w^45PdzBF{yp6_1nM;TboQamm+ zlmq;+fZtsH`P?w;^XH6=R47AvWX)AU>Ya7FbaIiBx$Ev%&-Bt$$*mV=UVbBT-D+Ol z#mj`~x4V-B1q|{1+1RVv-y`$!$%SGPzo}uaw$3?1ETQc6T;)8XeNs}p>g)k{Vh)uJ zavvbzE3HvVmXGYigcaz@dgT1{rxIkM@u(CC_it)YsN=!EEJ7=nI{zt1F9-MOL9Z3^ z6_0AkNyy9coWAIgqhe_EDKk)?vx==tJv8bZ7dZ(}2)>kb{u<@Kys_>dfsY}2Hfnm2zzWlz7}(axV^1CdGrRXZk)+0ghE zGBUTWEi%bCGj8mhW=>= ze?cGm$29v3#&dk3e-_@q6axB(?E0S=m*2|oRV&4}vwn9PedMNL1EDhHsc0iw6Ac6$ zmKmpt-*kKS8y7U|hhg2}ckIuk7K2M0I1at6?72u^5oQACCz7#o0S4Dz+;)1pm<4>+ z<0LfN3{U-sud@{8hzCFjWf;rQE+H`OH^NhqE=kS;M)>|jD814Y>T zoRuJXcG;23E5!~uxkho_&0TjsExuQ>%6`7#h8hY@+7$Nv`VD>i<3D_#aDl^%VrE8a z9K$scHjnBFS;dEUuz3+?22&myW(rj%Vw;ZjY1cUd-T&q{^zSz;K=X<#E9)&z{%Uew zOibz1A>;klqrP4log2hfrHn+oWnKxTS5qv5P0-?z2Xi=1!N7FJ!td2~%!P!Ch7rE* z8Id##&=|{faSLm{`EEIIbO7Mooc)Hr{qZ-yPo{t}kvCcGNHzWj7W_Uh>478xM0j;A zG0LBKe#_?X@;_P3D!VYJ2=Z+_>)TWB;tDHQgFX6E{W>vUw zD2|5={cYm+a(sxV1JYTbchD)gsA5$Syg{ISjL#zu)EY!NY%cOD`FdwHf0{R^|Fbr( zebXC_-*D~z%h;Pc+WM9)))G4YT|1_Y9_6IJ)^C1yoBZzwoNo_lVh5RtOp(H3K;)YP zoy{%rx`a@5k&2B#bBnQx!I=cIxDf&}U=pi|H`otL5E1V^*}}pV+~7`664}$ray$2k zqKbv)ISn7Cer`JFw^2x~*G!e&<;6t;kVseIW-P9g0r3fum1 zF#EbFfTuKAdiV9KbI-yR1SyXe_w_+HJ%F$AZ&T^MPx^{_PckuE@s2wXm`2X7=Jmgs zIZ?2z|5WdtBhrD$Lg17&a5%F7q{OdY`eM-RocgyTB-@XC8I?1la8+gZJua#V7y6C{ zl^zoM$8o$!WE5d}>);^gXUP>pdw!Qa1wpi}=B_zy=Qdd@nahQ5$ef3P%GBuGQETA+=swE&0_B70tMfRHOwOwr47>?7pY4mI8j+;4B9Yp z@H2DdVMj-PY}PDRUnYpz~nSi&b^&YIaWK(Qch*pu0^ zY=Oc=E~IKd_;|)Dc&8qgX}DHsCYn=r$pDIy(u&`=)CA@DB%o z1KNohJ~Z9f(*BsN-_-{tSfdEFvo55wyqit1Nul&aiZePr-R3V$` z{Gel4W^DCo#4ed_L<6gBG-b6lyI$M@=L_%0^ciH@er|eb#K3BM3;QwIezCe(f?aCP z5pahBQsilZ1I93I|8^VsqbrIqvE5474D+lbbf~pUSyH{xNEGThV9SyU&w?zD=%+b*!cnjJ z?jniYBaOd{u$G3Zm*<1a@>^4>4nvA2U*{kYel2dA`SkL$(I7c|C0P;X5Wb9ZQ#nS^ zs|@~5hQ`siN%0g;cX1dfc~;wm_U%x`uQL~skIh>L!bIQ>*Fv#9y(1Gp z@$`H^wgWq%IoCiJetVe=`;Oa(8tgFjre385Cni1~yk-$#%_wDe%YAzd1 zH4Ryl>LnF39U0|FJ}{2vSWX`+Qaa=tx^J#d@(!aVk1c zpQ>#I+W2obh}nq-3}J~(Ggwj;FE#==KVk9bj${M}!c5N&0kL;4$Qkk1F$eUp{jB|xvVK4T^Td4M@NKTwUT9r<1J1p?id+2)Ih*sDbHJkWs~zS+OLgwz^f3;l5k zGesbhcgzZhE%1ZC}vjSn$SQJXze4_QpxuNg;E)RbPZr#aF!k=C*d2Tf(Nq{R4Vv992b<;qc1 zdL2=o_;Kl*?N@qNFGE^ui#|pp?@kQWPBZymdM!?X##g9g0rKdS6MBVm=f~21r~k_` z=>M18-=+rre<<;{xqfB3@;ijZ1NU0dc1l=7+GEp0V{M}WA)N!`T`&wA_&1Vn-Hk3Q zYmaKJt+XiWS3A;K*5iUR2M?E9RvmiK9~VQz@%0kPU?X{mW&v&^&`Mw zDeT>LCvT0XZuFkyq}PY0-==MC(oe}BA(_D*30b`^=1}4|X89c>_NgS0qZMWnB}aco_)!H z(B;t4Gb5J%!wt>Fn8CLdsOdU~YfsaQ%EP5@mgKnhEOOh~w0R5YwbfFVP_;GUrdN3l zjCl4(bY=0ardlcsI(&5;yllhLaMinl3LLslOGZx=?!m8KR(n1Z+8nfFWa{xnxSMw< zCnx?YH|!`>sXNv%S-GUlt1rIcMU!rYT846HV`)Q<_NWEX@_qUg3Pp(O>FWB>V)mFD8yC1{ z@A9=NmcQXFmGcbGcq+8_*8HlqO6=Qeb zW#Psy8`$|*WjOd9cYo@*t84P`jG(E^uh?iovP?~%YQi#mO1CqXwPFtNUTRHGTDG`) zaX3+R9@>LZos>`fP)E-Mrb^VKkJF&gNvD5ihoKA?gW_|^6i!dReB3C|5vK^Ha7JCH zm6bp+wqNDiTQ12kZC{j|_cxp4&ENTR{pjayeX!D2anmcee3w$ z##e?P`@TwT-*8WcN)PVcx8N!-hEtDJfT>mXp>qp z40pB^RzG_R*hv9)Zec5)(cv;|>m?=qdQ#ki8oT*}z-S1mVd8EDrNY>b2~7p1$t<2B zkeI-4)$2NiG~V_u&_>H{Yi)Hd6#dy`VO#b$TG@+me+wfTAGwo zGl%ovZKhdjp^KSTOeJgAtBwICc}`zafFx)tJ+wDXX7R^}?v_+gAn>Yq)b@!5Htp{d zfCfGf$=Ixct81=j1|-MU7_x6#{hr5REs+&NKiPwSFh?8qAzgmQe;Zs z+%jxgTy02?`CY4a%|l?9zZKKo$szV&W}$5H`DN$gBC$YpWfTEjXREU68GSs3+!yrw z;7&x%D?m-eGzgwQc|Th_Q}PxHP+5!!I}foE5EcR7ofhD|p*ZjdE2euE=I8ZtR+3b@ zIbxVQ-_9u^Of?b~As_)xOI0OU4JIQsH|Nhg49s?Wmc%M6W~^YD7>cKmm0__-E>fS0 x7K_0$#hPz%7l>V;rSEgkZr1-n9NjxJPx9Q}r=GMm1!CaukcowH`T@r){{_pt5SRb} diff --git a/vignettes/articles/figures/did-unnamed-chunk-7-1.png b/vignettes/articles/figures/did-unnamed-chunk-7-1.png index 7ffe4441fc4e5ab736a324d72606000524b44c23..644ecf17288c4fb1f77a73c057f768e870baf390 100644 GIT binary patch delta 8668 zcmcIJ3p7+~+b$V82whN&aSNpkA=Ttkl1jQr)N$>kC~3Nyk;_&F6{VUA$t5bqafxa$ z+f2qONs>B3n6XL9ZN_ylhJWvwF?H5|zJIO%JKtw5YxaKL_qku*=Y95IFekW>qyS(I zNNOAhVmP<0?m0mhj5K8QQuDq!=;73N>Hn7=@Bd!O8y$rpsNQx4=$pPpveJjS-EU>! zB2I@D$@Py8SG022sfjwEPIE=1ZkH;PU5B#e+wcnTvQf8Wz3?ORnb-P!?XDLovd7Py z+r#ay_nR6WeY!*mXJSvZFN%_Mc(WRG|2QzcYNqw&q%Flk1hfPj6q(sIJJZh6s-1)| z;Eg5tamI`Fh9CTX)Z3e(aRaSj|FUh_U#Yq_@BEj!tZiD80SytZ74Oq{ZSG%Bc}bf`4w4_jcRC zqn+-S%FJs$zB#8Qj}*zXhe8;8hO2Jz&+UG(!05)~c@NjAT{EC?cC>{NhXc^eW@q2D zRd=_{QX+i)TG{KED?2izyY{h&Yar46RbqPZ_;QAZi%_gFs7(=4d`xyyMguML@OB%B zdO1;#-^tvsHUk^6sPkC^+#%R-LK#*muz4FQKT_$-Hxcbc+pu8qfK3E$$zDwSW=xJ% zhWh&NC2}xDp>$M^8~)jteu)QRDlJ8)>gOGx*WJbV0U7r<{I?tkqn zqPr5zD+qZfe@}#?2#xBus5Df#c1wNuqRQ-Pi`JlTq4rEo`oY#-m(=5Fcc+!%QQi|0 z);l)2zuWPL&_(k2(Mf7$;%Hr%O~CUtn%P&NiyDT_H8g@)npDrd>@{WwN(f;?V^dR8 zwS#?@^|2b5S58E>i1ri%R~n(^I1W8n<(o7592w^_;t(%IF^K}F4F};H~Zy6l5ofrp?3>>^Rvne zRhR>Ev!qCk1dsZ-%|b{2>zCvh?oe%9WpWmoRaVaZLsRG!0FId|j<+m!$7*%W@E&lE z*jJSt8lILDQe`!*1Dc5}t;XC>z|hfGa+Ee_DHY@Tx0`FU=Hc>P zz`=6hj#$FxXznpnVo7cHYQ0%o!A=|e?%PBJVxN7_YnN@)YWZO>*w@&a7lD@dg&z4? zaRlv14faDms8pKwiw>vohu4ETTOzoU*7qKxnAHya34CEigcp{-BkszS1IF%0CA9INt=IgV22>|mq@YJeQJ{VHejxG|xA(@v>Y z?i!WyOOZCpFnX8C5{CS^9!P6><7ENYW=DAcUTOeJ^mt2vnt-4JgnDJ~7Z_-?&21o4 z2aL28^2%!Us+L#Sg5be?NR`HG7rvK9mf9V%K6}Bn=?oHR)p46w;Te=a&bx}j?u02L z?gApe19nMy#Zyd>RB~Kax(qM@8@HH z5tJTiv>1_PBvVB*ejwBLZ|J_P_-673K5P(!TFB~AjTQ+J#94x1|G!?GA426}!yPBE zU%!2!*b>Iii9_WoR34#XlRENkPxn%BG%t?f@-v_#jh5u}d8#^MLR(sgZolQIt>~ z#H#F-a9LY&!rguel7Vla=Hy+sJ&1;CQLpk^di_%|$Pt8;jR!dOp=)pg?li`Q?Vowu z9d$U4z46Bq0IwOk%Ql!B44~6NYg=33^wgutfTqC%aK2wt{R~-H; z>9+$#iFgf&P^5x(3N~r0xE8BWiAxTf>%Fx5n-_P{7$;~?N>ex+w{@OneX0||^o!1H z7EB$?#&Tz#&pnob^ZcpV3S}w%s!a&E2M(#vOvkHrk=a;B>U!QPO zOM1PY5<_4Ob4~_hc24>)VTQrNj?21=`3>a9Y`e|2Gh?}pwCqI+{ux<&ts(`sekCDe z-!bFK{+wA~BIk>+KqU_NzLt{~<;V>+wf%=k+{1qk=EHr8puQr$)n%l-477YpS;P?@D~ORU*rp6zSrrgi2W}ZE;>e09 z$MkjB4L^eM+5sZV%I6cOhO8-z~BG+Y!QSPl@ozWI=mWg9XuZpJ40tIe&X+^ z#w@OAhgPSz#0x7f;6x}?&~hPdjeyYU^J1*@&iM@Xj`Y#(X}d+kf%3p-IWRIiU*~!Zk_FoL?JH( z4hxs=7Cc@wom?kdtICR2{CQ~yIdz2^fZv4pOI_i}-<~Z9kxI@E1D^}-)oaf+hRcYY zgR;M~q7rxZbcoIHlTKb4R@DEQsecfq6XI`J8Bv`i6oxCkKYG%zkyaI;w@y`81P(TJ z0G_e1eW5oEs_(r=4iC6?`pGU>xIW`BtJ1>g9mzmgjrDLz+Kf0sZEt`(3KQ%4gRi;P zJGP(Df2s}F@g5(Grg%=KEJBtahe}cL9*KlYdM;4!n})TlQGOdNkVX7pa-{N_%g7?BzmKri3jq}HhP zUgn(B1-EFYcwOD+kANNKHwU@|o9_K5&%i%H{tw^+|5$^6CIs-GG2_221n>|2_ir;6 z@O_&B)Y1&#CjVPXpXD-K(sD*%3?~y`)Of$oH%Abc`k9SiZ18*igt4a^;yl2UEvsGV ze@EHdhop97PQhzF>(=v29orWn5u3RNJ~0F$9a$I=3Z8G@VlI4>WA6}<`=HEB6@+>8 zbz;UO>Vh6nD|mgN1LAbRG&$@xdm>>Y(Hd@wVmJdNB;bv%o*^8nvw=o85qE1csPY0n z>*3SLnkS%r$*(v!bZjn?M60T`;Er6t=>LAq4o6Gzolqfr`pITmOAPishR{A~Gh^8m zT1Pf1NnYFX3||y=Yl-k`e7w+cNxi*^!dufQW_%g zs5mVt?dwNbezJOCnwZEUO(xVb{E%;xux~_J;u86x)&_DNTGbHdnA#dYZQ7)J{hN-& z{KsR?!G$iBHKF;E5w1J~9K76>k9v_nwn3YdZMD=F{@%_RN(+o!&_Ju6=XQb^(u;X< zi5#efk)eA^-+e@0uVo9UFilKY;F`N@*EN4Xc_cGdV$1!{R?QXL6bmXs^S$VD>2W7V z9uLnKFI-l{Q?WB;!?o?)+UyGJ{<0XcB$#EO6;wfEDA_icdp!5ztQmM47#?j+sUd}(ftGg_QA(7F*27}v z5f?cTUQ@pw8z0WcUN^TvD+n9G)+e3fEpL?ACE` zzgAn-BBEEgwXHi;(+UlA@J8j zq1YLxFNf+KMDYql-O^-k?VngcQY*|t9RG_FepLUmV_fWTFwi!{yd>7u1|*M~FLO&U zY0(gqwB1O|4)fb+Eg`XF#nw$5T&+UY=tneKLqmGg2eoId-d82Z_8U!k&Sy3li(#>I z*?!Y0&(T07&U=0Qicf>(F|#5?@wY&E5g*4`1bKGHgt{WQLf^C=v5&1Akub);$&sQ6 z%ta#LI%giGEe+GeLHQ^<3Y>f@%%EqWF5X`p4RY*HCc!{L$5OG#BtocvD(j@KC@5^n z=y=X?EZ_2-IQdkV^GsauLt-!Mf#~?UI>6~yyIH5I!{ZWI6W1KW6f&f*PsZt@rJUr+ zzv>hJulC&$G`MXOiZM7IyN{~URCN`3PxfpI77cGrh3{YVB}8G z2PKNBa#~UuewU%HhU&73`QWy9_0$35EilaU4%9VD#Fdq^P)Uuq+9f64JhJ)&v?Qzc$=V&d^0K zo--(aA;;#XhEZYVIh%!= z)Q-k&Xh-hve{oPCTUK!=HD3o#3Kuy31X_9~pXCm=)IXZ^wV33TO^$D^a`+356KmeX zWW|9`X!m6i4MB^3;sO+Y{m|^oIgwHqgk?JEexI2;d z^Yvf%FOrn5dz5B&^6%1MHcSH>>pJ}vSorlX`b_>JXxZ$<>jHdmZgU`J1tIxoehRsi z3?`(~JV(gC85sfRQzqgznp|ONrgP@}Vy8Z<=Ci>9*?Qg%&dmdMnzOK5JzFbJ=O)4d z8M$Vby|I6B3bk1FW}DBSw>eTBVsm&oV;=#@%s)j*NBkte}qHOcl*w;Nuv=PV5PIpi+Q>cvSZ;K7k=0Kvo3U5%4v%=Tcy06+O@A z4#e-GlSHtQjQB6-L(eKuL!D3oS?ynG>&>6KPDQn=Zm#J3_fl>I_eBjI#%L@15tWy z40qCDT>oj-&eX(qWr=(_yf!lWwVC05Z}VByA%KvT^cDe{QZE)kiincvwsca#D_+Ey zTV?7AISF@?6>N?=R8(wB*m3iDlI@o{C}f6j5k`iRMbq6ELRF7LLE-yR-no*>jznpa zTBJ2YazV7^r�!S_fK6T>=MdjKUFptBn!HeU z*tDn4?y^4E!5pk^86FW}J<7z`H6 z61*gQ(gr2^V2{W%q5kQc&twq&$Zt)}6nqn4XU=246B*cs>};w`{%ooz`c<1FP3!6* zACNL7M@p%P{$(|J2P)+ycn7ar!iDk~TOR!)p;k8#6{xylOlw~8pxGQra)H^oIg2D- zOOv6sE`ZhebO+}fH(aT{qb9DhvXUPDnX4XXm9?8+IhfK(w&hwneH(H75p|rLX8(t{*k?=!;!VD7|V?FLqC} z3Lc&**xFD`$1$kq-#kevO~RBMee^)~mu!64x{CmP@g@@rH!3EZm$o%|!1D3Au?5P^ zvhO?H&H~oz3NtSJ*cS;NYBguJ&vZ^xZ4G^VcG?n4*pDB+J8X61Fl8khOLMfOdHJ`6 zPX$jG4+o4uqf;qrl$X=!=1OK@fVUPJFGypVW1;7 z9TiJoVMBPxshd7`v1ghx!Hxcd64>%U@5H6=T4wMdVXQA(8$3Ta5}O23>luyTpYZna zt1zMIy=P8-%|FUL?u?(?$4|>|@ZG~oWB~=gu<}PM+~$}(VP|JT4RnKscM1xhv(X)~obZ@~6cMQ5rLjXLt6TJjSMPem{%mF>`n6 znf`o(YZ32(U%IOnAD^+}X_ljye`uTh_Mjle)pRo)={ zZE>~B_(|i*OVdZkoRp$#^2!_w2YVBZuf*zj1;nek&{hC9?ceyKVR{oZBv zXg=NdB8vJbLQ?l+>9f{+Fv4JH3-fv4X|`X%*5=~$3!LYrX-vY3v`TI2Xq{s`~v*i<8YZNS&n)v+{fb8MDeUOzs(kz-IGh@m~oOb=JOR|z5G zMBmpOeB5W#;@Bt~*OJ8C$qDO{B$G`vug0ByKBWb~DdQty5z{R+|A1?vmDUxYPPcnnpfkV;6tGokWNVEOpnD*(Jr0mv|?~?!T$^r?PKh-W34rU%-1djzQ;~ zHcMK-2*s7huP|-;q`IJ55g8M%)d4Bw@~exF1?I5wXSX!>CRIFth|FUD`G&oJOCs*Z z;|OZbyO+K@;6cIHsgK^?b)pyNdv}|0hr|>*3#Yaggr<69+TNR!#e-}Ii)l_Dx z7A-zdIPi)sd#k5qw7I>Smc1Vtk9vw$-o46>`b_C<|4!@P?*hZaX5sHpQ9QQl>2NKD z7ALwLi2H^iInbFcpa&}jBIT(!?i;2iNJW( zHn{5*>+UcumeB5oQ<<&{-n4EPskgeQZiioC{_UvRw#13(c!XFK=lS*UVBM&*&r6os z4Db8KHABKf9yTk&0=6sQqm;{T5Y%&h9YkYESYuw_CY1DLJ7S8!lXi>c@Z>(SpSpsP zG!%5BRxV2NkT&RyFf+|ifbGy%ykN0{kpH~L=qA7kJGcK`qY delta 8671 zcmc&Zc{r5&zf`tkPa4^`aE=oy8QII)Cfb~i_17V#m^Qq&dC8#c8s)^%h*A-XGBJaU zBS~^3$uUy;>`{|`SigMqqQD+|!VVt$m+Uv~wHM+j%S15KFJ{p)YmV6A>vTCSPi zfW*Bx}qYXcc7A{LU6{6FI!|M*VW!QGW@S5 zKT(WRh*6$XcRVYgr{8;oK>CF}TFKk2iYHdrFI@Q2T=5DWCWZkyH>=`9=j$fis|KX1 zsV#c|+wxdJ`xmC`~{I-mO!)+Wnvc*lOKEUmC&u`ZDjmbM!?66ai5~| zf+x2~Fri5`{L$0io2;7+yAIrwDl|i->oh<|QkQ3^PRsWujp=#?E*1$>ln$uu4K`5U z7ee#2+7ASP%TLO^rGZuUTRQ6xjjnqAem(VGjxmHRJ8^tocUuGjEo>V2$#ai>F0dp8&#HZgKcpx%Hs!jPSZxT@};{W?vL_ zyyWeTHK7x!1JjwbLpWJ(k<7UkPO8i5;>SF?u2&-z+yMcG)%vj^~9pnR~|!X zC0=0YT>0|#Hj&o#3B!*zE1w0T;7kyhmMbYiX0hMGmqL% zljIqu3)0d2TZMn8{Y+VEj%yPsTnyvHMP`r7>I!hW%^|1=`&FeDm+Nm8qDkphLFnKQ zO3C8iN-GNL;5VbzyTeYRK%E$DY!;3!*q@uF&Zq9HKxMVMZDYebvPVIE-4RucxUDbVbFi&_4yp$?~NaEn`;Zqf)r4_+|kLo4Vie#R zwRme-b0wbXl!ZyqC%bzvsQ>KMA-Db`-{!H3`azlrq4(Q-({v}6W;msLhj>x#Ld5CS zD@2G87Bra~W0hD{$?`Yjq3|n{mw4$|oH_UC1DwBBGXk6nkO16nVJ`RLoH+CSG4QV^ z!4XUMr?udk!-=U2BDSh<0J2W{B^XW+zC`|Yddia*ZoH%S<9XrF{;V0s6Gul!F{x^Y z)g;ZWlCvNOBzf%#HF~d62RWA#n%Wd<2Y~2q&)H9bT8qvm`M)*4x^1rTDg9r7F5a-d z_`Pz?L@fnWtqly2BQc|Nn{Vn=pC6NoxA5i12uT0@VR^u$e%}RVEAy7=LHl5X{`&L; zkA|E}Q2aXoqPrY?Hb9L@ra{@D)7By`xFVHKjkyRh?6}vJ8*+xtU1X@a-0Lv;^N}Kn zfX_fbQ^)kRc=EVMb*zT;mpF7AK3ZN0giFZYfp5V3C^?hnE>59ta3ALmT zz~>)^dx#TWvvo7WGeY^B+dhHt|H92}}Cz(TZeb=~U5LWTi*-bxK^ zK15=dsG%wPTL#8g$z30P3o#;8tzI#Pcd_?2ZNbDWRqi}5Xb=^`je!|(w!D7u)hJ2_k>rec%YRd8 zIL?NmVnjM#3d0>k@j6T-lc0mJ4Dx{Kln4_Ai@uTbIlS~dCUvdeHqofrkUZQ`|6oe$ zREK-LbhTwAFO?_Nr|S@*%G#e-mvyFdS_=gUIBV;6Gk-w3onuC~nm56a*Sv3eN${Ue_NRlSOseH`#sQ4+Z~zJWj0(3H~Ki?{eU|` z25tUUA(5arONeJWVcTqOz#-8M%NNhh)OV$H%({l0OQX`-9WMNA$1@+pXF)a3ev&1= zpn7}PIXz=uuhCt?Tm;XhbS^=fDzusYBcJm#RQB%wtneu+O-@c( zY?Eji$gC`aOQ1)%s3E7ebk?1Cuz_aJsb%vhNfSjGDuu2uv_47kezzedNkx`gP9Ix^ z)Q53z<9Er>wKynTll)GWwn>~eV+TCcA7h;Rvs#mUL)0+D9!S~=Sju|Q_g0aVAC|(_ zp(L#-@BVNp*a6wr&ZyDx14RznuPpw7-ynyJe}FKLF8Gg1ublzHHu&eHw+BGJBm8fe zXqD)ppSn^*PpWP9!k5S1(A2 zd$v%FHe(NDI6#SDAKUX}j^3+7aN8|vm}m=x?m*lz(}6~8QW8xyw&kqiAqEb?rzc74 zhe7QCSB1+WMHqF{*AkqSB84PJnYaw)8{mX7 zk~%`>MM0lucg21LHJIsSLaO#BaIoX)vIkX?|7SmYx-|Z(^G!#0);7b9pXFuMRq7c5 z1HK~q+sMN$(*w)K@3c}rY6z^oH@h$7!GQ+u8(MPKNh@45+O8-H->9mKH&fNz_uyiK z`C`l2j%F{lK7HPq%Kbs8vWMB~({3xEePA+&?t|;XuONc~A|t4e21aF*R*0IC7tcwa z$;aHXY8;l0w`R_--CiPn<>T^mu@x16NC;h=7<$GSP9qua17ajO zqKwfzsqgkh9s+s&WiGQyhR?~73qTe+B!PXNm9X_^595v~PLpZRXGdO{I?+{3Qg}^h zI#N^62>C5-B}i8fB(GnAKMh!0XCG!!TgG2StKP7Q+(w#;WX|0R_fA4LRdgn(s6E>Q zxax6i2L=HC%qo+`FKL~Q&1HROmMpN(prvQ4Uo!r1nda-gndWJoe3Ov%^2=KC?pN(3 z6`eO0eB+-3ip{Vd*f(vbuJ(Jp8rV8L98~s{?~5w;-#`WgO$!C9FSet8?JFW&Rie&J z3CRd-l#^gudE2VPFD|^gmb{K4EoHXymp4AGx4-sxb>o$ZR1JZ|LKL;8_Vkeu znkC*{OYcW5a{CCu$dUoJsDvRd8QfINlySQAP_;DspS@0|?DeM6JS@b|T}G#!9~ z)=lfT{c?V6;Zb=*)=XQZ)rrbEgL4T2dO2P|m@-BeKc%(7k)kvi`0#Fh_9=LfGvLUb zgsJe8Ig}Gc5d`tz@!l8NOXl87!%` z_6ytrYZQLbwpVhxonEL<2!VtDY#pFgo!HQ@-K|%1O5s|t1R~fJUR~!ZOI(z~L z3g8}Z|3wi2y*EDU9$xUkh&eB^+aBnxe2nN0JLbu@xhcH*!>6@g`_H*qyZl7ytuATI z7d|z+hcS*^bSH8zHhV6?7jeX3_auACxAd&OPU*}g=9#M^zIl!@K{PW>T{vN?_wb(IzO%G9af z9k;EDId>1+ChN5ohkA$ZWNwFLso1=+1`+&sK``E6fNc85cC#;&Z7Q{1-)sJJ{X+8!F)astdfA2wY3QVnlsS<;YAR7Op+8QVTe0I!{}usNY|QnQ2aes{pKe zr9h50#c`A}`9xoJ4fgGq3^JUv^yFzNAoup| z?_ML{%T_8?bDe2_fXp-v2a{G*GBZ85p@F3&ZA41?meC3Z|1qKt z7bDotCpb=!+~;wlEpqX>v2&qSJ-!Vf zNv%7M7(UbkO<^Xojsw;a>y>Ci@C4T;gqB6rB9gpVw+Sj$_^0pgZKP^jL2+ zqm@Qv1WH9Qd6yvY)5~qJz>>(hC(>2lh6s6}zWM)nqI|`ZX^L7l$6$~q^x#D59WCt}b zH#O@q@QG-Gz!`gBHKGMamM*P$s+LgGc}7=x)l+$x7>dfDnb`_F(Im(8QOvC*2Yi9! z;reqsh)pJExVmr$+`X^GbOi|fDN7Zg3HhW!!tf+)Wk4oy3+6Bgp6MD7yjbGA$9X#R zl>dH6OyLTH_mNff^m>Y-Nxnx>o47f7#&iOHjBzVxsSSW_vK-!AeHrkHwG19{CGm_!`mk=6^##EW%GX#$+W8Xomo-Y65 z+X^S%$%UOF&~Fvbv+J|%(`yoJD+rqp3*t*R|F}j-;FAshteGoFm8`8ZwV00@uzfW5 zX$XQK3}M#tSx@VUL+mq)BXjTDqFUEhM;`P%a?nw??sBsBK329zy7_{+CRr&Go;U8& zC8O(9+obwtrtACUQZSdN%0xPi9ValtS6e2LFE^QNR`HMhrw+`}nW<1v-Z}blgAtKZ z#elIG%9s*C3LL@+XS7T%<?^vlv<62En#UjR_m&oJs5`{gfQH{TZc*uA zKVdW4n!CC>q*WOaMfWPYQ*Lz!wk#wuT~jb!NV}ZNrdz=CRZI3rW1w%@uI>s#H1xJ} z*T#^vaqnz)rscwqq8J~GC5_{AL64x|aJtnI_EZyf)Xejbs^Xp+_YU_}5p{P?ZF~2I z^#NoRQ;4Uc9>~Y+p)cG!0nC)`dR#%kK@Nr1{*vt4IZWJdXkxZ+_@JtZRh47CL}y7= z!jvxSR}KR#T!ccD!7GY{<9TWfzYPg3!&LbgWm9A!gM#PE%uq$Z z;eR=y6o12ImhEaq*s7c(&&55VJajib6(&*ir=dcAy+M(8w3A2BCZc{B;j+aQ;$%;s zdH1OUv-CUa%N-vXT$j!wZA6kcFt?$I37%F{g6$u1(C3Ax!-)E@D7k_>KZc`L?ooemJrm~uQ26qRKz5bH1%q>u}mT9JZ zho(A@ynC$R{X@;`w{tCZac!+jGZ`;Ggj4{DjHViEF&&W?UGEd$bPveW`UihybUF!U z!WlDqD<#7Gw#c?M3a3wj!!6wt*iFlh3F96TBRGiaY^WtJQTe#h?i@UEZS-*#Wls8* z{U+R-Jx(mU_5##8=FMT{YA01=2Ymhe~EKksne|DS%FWiMmSc$^0$wmq;Ybd=tO|&G0 z*Tq1U>8+x%lS3n24Y2{GO!oZQfr2&2bW{XJciKVWK51%U$L;x$C=;NZdGalCg5sT2 zOpWEuPMU#0H8boQa-haPfOG#csnLTV0)Hb}P(86D*g$xC2jKqvIIh0B`d8}C?ABnN z^R~O-?ejZ%+u2~O!Du#i+UhSrR;{y2;Uyd%8acAU6DK0g7BVhu&w3e&C;|mDzD-Nw z?P24U4Y1c?w)?Wg+Z3K@;-Gw=cImrYSQ3a~yhIImuV3DMe7?OQYQOOvGZdm2VtQ1F zW^C}(WM1{nN7&D!gPpay*~moo4;ku_@-}DR2dRbVlz2n`fl_oQZVMXElP-l`A-Cav z@duytEI+J90gUX6IvEV~CFDN$$=wu`*k-YQJ_`PbAu)0h)+<7TquB9?8BRXm<%CFV z150dWo>3pIDMQskEUDlkOzG8L(B2@t`h^XU Obs: 5000 Folds: 10 #> #> Estimate Std. Error z value Pr(>|z|) -#> LATE -0.208 0.194 -1.07 0.29 +#> LATE 0.0227 0.3997 0.06 0.95 ``` All works well! diff --git a/vignettes/articles/neyman_orthogonality.Rmd b/vignettes/articles/neyman_orthogonality.Rmd new file mode 100644 index 0000000..65c736c --- /dev/null +++ b/vignettes/articles/neyman_orthogonality.Rmd @@ -0,0 +1,357 @@ +--- +title: "Neyman Orthogonality in Linear Regression" +description: "From Frisch-Waugh-Lovell to DML: understanding why score choice determines valid inference." +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Why Neyman Orthogonality Matters} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + + + +# Introduction + +This article builds intuition for *Neyman orthogonality*---a key +component of Double/Debiased Machine Learning (DML). Throughout, we focus on ordinary least squares. + +Consider estimating the coefficient $\theta_0$ on a variable of +interest $D$ in a linear model with controls $X$. Introductory econometrics courses typically discuss *partialling out* $X$ before estimating $\theta_0$. Two variants of +this idea lead to the same point estimate: + +- **Procedure A** (partial $D$ only): residualize $D$ with respect to + $X$, then regress $Y$ on $\tilde{D}$. +- **Procedure B** (partial both): residualize *both* $Y$ and $D$ with + respect to $X$, then regress $\tilde{Y}$ on $\tilde{D}$. + +It is tempting to take the first-step coefficients from partialling out $X$ from $D$ and $Y$ as given, and compute standard errors only for the second-step regression coefficient. +As it turns out, this naive approach results in valid inference in Procedure B, but is incorrect for Procedure A. Here, we aim to explain why one procedure is immune to first-step estimation error while the other is not---a property conveniently summarized by the notion of *Neyman orthogonality*. + +The article covers: + +1. Setting up the two procedures and comparing their output to full OLS +2. Deriving how first-step estimation error propagates---or + doesn't---into inference about $\theta_0$ +4. Introducing Neyman orthogonality and its implications +5. Discussing the bridge from OLS to nonparametric/ML first steps and ``ddml_plm`` + + +# Two-Step Procedures with Identical Coefficient Estimates + + +To fix ideas, we generate data from a linear model with a single control: + +$$Y_i = \theta_0 D_i + \beta_0 X_i + U_i,$$ + +where $D_i = \alpha X_i + V_i$ so that $X$ is correlated with both +$D$ and $Y$. + + +```r +library(ddml) +set.seed(48105) + +n <- 500 +theta_0 <- 1 +beta_0 <- 2 +alpha <- 0.8 + +X <- rnorm(n) +V <- rnorm(n) +D <- alpha * X + V +U <- rnorm(n) +Y <- theta_0 * D + beta_0 * X + U +``` + +## Procedure A: Residualize $D$ Only + +For our first procedure, we partial out $X$ from $D$, then regress $Y$ on the residual: + + +```r +D_tilde <- residuals(lm(D ~ X)) +fit_A <- lm(Y ~ D_tilde) +``` + +## Procedure B: Residualize Both $Y$ and $D$ + +For our second procedure, we partial out $X$ from *both* $D$ and $Y$, then regress the residuals on +each other: + + +```r +Y_tilde <- residuals(lm(Y ~ X)) +fit_B <- lm(Y_tilde ~ D_tilde - 1) +``` + +## Comparing to Full OLS +It is useful to compare both two-step procedures with conventional multiple regression. + + +```r +library(sandwich) +library(lmtest) + +fit_full <- lm(Y ~ D + X) + +theta_A <- coef(fit_A)["D_tilde"] +theta_B <- coef(fit_B)["D_tilde"] +theta_full <- coef(fit_full)["D"] + +se_A <- sqrt(diag(vcovHC(fit_A, type = "HC0")))["D_tilde"] +se_B <- sqrt(diag(vcovHC(fit_B, type = "HC0")))["D_tilde"] +se_full <- sqrt(diag(vcovHC(fit_full, type = "HC0")))["D"] + +cat("Full OLS: lm(Y ~ D + X)\n") +#> Full OLS: lm(Y ~ D + X) +cat(" theta_hat:", round(theta_full, 4), + " SE:", round(se_full, 4), "\n\n") +#> theta_hat: 0.9988 SE: 0.047 + +cat("Procedure A: lm(Y ~ D_tilde)\n") +#> Procedure A: lm(Y ~ D_tilde) +cat(" theta_hat:", round(theta_A, 4), + " SE:", round(se_A, 4), "\n\n") +#> theta_hat: 0.9988 SE: 0.1188 + +cat("Procedure B: lm(Y_tilde ~ D_tilde - 1)\n") +#> Procedure B: lm(Y_tilde ~ D_tilde - 1) +cat(" theta_hat:", round(theta_B, 4), + " SE:", round(se_B, 4), "\n") +#> theta_hat: 0.9988 SE: 0.047 +``` + +All three point estimates are identical. This is no accident: +$\tilde{D}$ is orthogonal to $X$ by construction, so omitting $X$ +does not bias the coefficient on $\tilde{D}$. + +But the standard errors tell a different story. **Procedure B** +matches full OLS exactly---both point estimate and standard error. +**Procedure A** gives a standard error that is far too large. + +In both procedures, the software computes the sandwich standard error +treating first-step coefficients as fixed. **If both procedures +ignore first-step estimation uncertainty, why does Procedure A fail +while Procedure B succeeds?** + + +# The First-Order Impact of Nuisance Estimation + + +Estimation of $\theta_0$ in each procedure is based on solving a +sample average of a score function $m(W_i; \theta, \eta) = 0$, +where $\eta$ denotes nuisance parameters. + +For **Procedure A**, the score is + +$$m_A(W_i; \theta, \eta_D) = \tilde{D}_i(Y_i - \tilde{D}_i\theta),$$ + +where $\tilde{D}_i = D_i - X_i'\eta_D$ and the nuisance parameter is +$\eta = \eta_D$ (the coefficient from the regression of $D$ on $X$). + +For **Procedure B**, the score is + +$$m_B(W_i; \theta, \eta) = \tilde{D}_i(\tilde{Y}_i - \tilde{D}_i\theta),$$ + +where $\tilde{Y}_i = Y_i - X_i'\eta_Y$ and the nuisance parameter is +$\eta = (\eta_Y, \eta_D)$ (the coefficients from the regressions of +$Y$ and $D$ on $X$, respectively). + +Given the score, software computes the sandwich standard error by +treating $\hat\eta$ as known: + +$$\widehat{\text{SE}}(\hat\theta) + = \sqrt{\hat{J}^{-2} \cdot \frac{1}{n^2} + \sum_{i=1}^n m(W_i;\, \hat\theta,\, \hat\eta)^2}\,,$$ + +where $\hat{J} = \frac{1}{n}\sum_i +\frac{\partial}{\partial\theta} m(W_i;\, \hat\theta,\, \hat\eta)$ +is the sample Jacobian. Both procedures share the same Jacobian +$\hat{J} \approx -E[\tilde{D}^2]$, so the SE difference traces +entirely to the squared scores in the numerator. At $\theta_0$, +Procedure A's score residual $Y_i - \tilde{D}_i\theta_0$ still +contains the confounders $X_i\beta_0$, inflating the numerator. +Procedure B's score residual +$\tilde{Y}_i - \tilde{D}_i\theta_0 = U_i$ contains only the +structural error---hence its smaller SE. + +Whether this plug-in standard error is *valid* depends on whether +ignoring nuisance estimation is asymptotically justified. A +standard Taylor expansion of the sample moment around the true +parameters $(\theta_0, \eta_0)$ reveals when it is (see, e.g., +Ahrens et al., 2026): + +$$\sqrt{n}(\hat\theta - \theta_0) + = -J_\theta^{-1}\biggl[ + \underbrace{\frac{1}{\sqrt{n}}\sum_i m(W_i; \theta_0, \eta_0)}_{\text{CLT}} + + \underbrace{\frac{1}{\sqrt{n}}\sum_i + \frac{\partial}{\partial \eta} m(W_i; \theta_0, \eta_0) + (\hat\eta - \eta_0)}_{(\star):\text{ first-order impact of nuisance estimation}} + \biggr]$$ + +plus higher order terms. The term $(\star)$ captures the first-order +impact of estimating the nuisance parameter $\eta_0$. Whether +$(\star)$ vanishes determines whether treating $\hat\eta$ as known +is justified. + +## Procedure A: $(\star)$ Does Not Vanish + +Procedure A's score depends on $\eta_D$ through +$\tilde{D}_i = D_i - X_i'\eta_D$. The pathwise derivative of the +expected score with respect to the nuisance parameter is: + +$$\frac{\partial}{\partial \eta_D'}\, + E[m_A(W;\, \theta_0, \eta_D)]\bigg|_{\eta_{D,0}} + = -E[XX']\,\beta_{Y|X}$$ + +where $\beta_{Y|X} = \theta_0\gamma_{D|X} + \beta_0$ is the +coefficient from the regression of $Y$ on $X$. This is **non-zero** +whenever $X$ is related to $Y$. + +As a consequence, estimation error in $\hat\eta_D$ propagates +directly into $\hat\theta_A$. The term $(\star)$ does not vanish, +and the naive standard error---which ignores $(\star)$---is wrong. + +## Procedure B: $(\star)$ Vanishes + +Procedure B's score depends on two nuisance parameters: +$\eta_Y$ (from $Y$ on $X$) and $\eta_D$ (from $D$ on $X$). The +pathwise derivatives of the expected score are: + +$$\frac{\partial}{\partial \eta_Y'} + E[m_B] = -E[\tilde{D}\, X'] = 0$$ + +because $\tilde{D} \perp X$ by the projection of $D$ on $X$, and + +$$\frac{\partial}{\partial \eta_D'} + E[m_B] = -E[X\tilde{Y}] + 2\theta_0 E[X\tilde{D}] + = -E[XU] + \theta_0 E[X\tilde{D}] = 0$$ + +because $\tilde{Y} = \tilde{D}\theta_0 + U$ and both +$U$ and $\tilde{D}$ are orthogonal to $X$. + +**Both pathwise derivatives vanish.** The term $(\star)$ in the +expansion is zero, so first-step estimation of $\hat\eta_Y$ and +$\hat\eta_D$ does not affect the asymptotic distribution of +$\hat\theta_B$---even to first order. The naive standard error is +correct as-is. + +## Numerical Verification + +We can verify the pathwise derivatives numerically: + + +```r +J_gamma_A <- mean(X * (Y - D_tilde * theta_0)) +J_gamma_B <- mean(X * (Y_tilde - D_tilde * theta_0)) + +cat("Pathwise derivatives (should vanish for B only):\n") +#> Pathwise derivatives (should vanish for B only): +cat(" Procedure A: E[X*(Y - Dt*theta)] =", + round(J_gamma_A, 4), "\n") +#> Procedure A: E[X*(Y - Dt*theta)] = 2.672 +cat(" Procedure B: E[X*(Yt - Dt*theta)] =", + round(J_gamma_B, 4), "\n") +#> Procedure B: E[X*(Yt - Dt*theta)] = 0 +``` + + +# Neyman Orthogonality + +The property that makes Procedure B's standard error correct is +called **Neyman orthogonality**. Formally, a score +$m(W;\, \theta, \eta)$ is Neyman orthogonal at $(\theta_0, \eta_0)$ +if small perturbations of the nuisance parameter away from $\eta_0$ +do not create first-order changes in the expected score: + +$$\left.\frac{\partial}{\partial \lambda} + E\bigl[m(W;\,\theta_0,\,\eta_0 + \lambda(\eta - \eta_0)) + \bigr]\right|_{\lambda = 0} = 0, + \quad \forall\, \eta.$$ + +Procedure B's score satisfies this condition: the expected score is +insensitive to perturbations in *both* $\eta_Y$ and $\eta_D$. As a +result, replacing the true nuisance parameters with first-step +estimates does not distort inference about $\theta_0$. + +Procedure A's score does not satisfy Neyman orthogonality: it is +sensitive to perturbations in $\eta_D$, and the standard error +computed by treating $\hat\eta_D$ as known is incorrect. + +An important practical implication is that estimators based on Neyman +orthogonal scores yield inference about $\theta_0$ that does not +depend on the statistical properties of the nuisance estimator +$\hat\eta$. This is useful even in +classical low-dimensional settings, where it avoids cumbersome variance +adjustments to account for first-step estimation. It becomes +particularly important when modern flexible methods---including machine +learning---are used for nuisance estimation, as the statistical +properties of these methods are still under active development. + + +# From OLS to Machine Learning + +In our linear example, both nuisance parameters--- +$\eta_Y = \text{argmin}_\eta\, E[(Y - X'\eta)^2]$ and +$\eta_D = \text{argmin}_\eta\, E[(D - X'\eta)^2]$---are +estimated by OLS. Partialling out both $Y$ and $D$ yields the same +estimate and standard error as full OLS of $Y$ on $(D, X)$. + +The partially linear regression model generalizes this. Instead of +assuming linearity, we allow $X$ to enter flexibly: + +$$Y_i = \theta_0 D_i + g_0(X_i) + \varepsilon_i$$ + +where $g_0(\cdot) = E[Y - \theta_0 D | X]$ is an unknown, potentially +complex, function of $X$. The nuisance parameters become +$\ell_0(X) = E[Y|X]$ and $r_0(X) = E[D|X]$---conditional expectation +functions that can be estimated by machine learning. + +The Neyman orthogonal score for the partially linear model is + +$$m_{PLM}(W;\, \theta, \eta) = + [(Y - \ell(X)) - \theta(D - r(X))](D - r(X)),$$ + +which is the flexible analog of Procedure B's partialling-out +score. As in our linear example, a naive score that adjusts only $Y$ +(analogous to Procedure A) is not Neyman orthogonal and leads to +invalid inference. + +DML combines the Neyman orthogonal score with *cross-fitting*---a form +of sample splitting that addresses a second source of bias +(overfitting bias) arising when the nuisance estimator $\hat\eta$ and +the observations used in the moment condition are statistically +dependent. Together, these two ingredients form the core of the DML +framework. + +The ``ddml`` package implements this approach via ``ddml_plm``: + + +```r +# Example: DML with gradient boosting (not run) +fit_dml <- ddml_plm(Y, D, X, + learners = list(what = mdl_xgboost), + sample_folds = 5) +summary(fit_dml) +``` + +See ``?ddml_plm`` for details and ``vignette("ddml")`` for a full +introduction. + + +# 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. + +Robinson P M (1988). "Root-N-Consistent Semiparametric Regression." +Econometrica, 56(4), 931-954. + +Frisch R, Waugh F V (1933). "Partial Time Regressions as Compared +with Individual Trends." Econometrica, 1(4), 387-401. + +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, +Wiemann T (2025). "An Introduction to Double/Debiased Machine +Learning." Forthcoming. diff --git a/vignettes/articles/neyman_orthogonality.Rmd.txt b/vignettes/articles/neyman_orthogonality.Rmd.txt new file mode 100644 index 0000000..c555e98 --- /dev/null +++ b/vignettes/articles/neyman_orthogonality.Rmd.txt @@ -0,0 +1,350 @@ +--- +title: "Neyman Orthogonality in Linear Regression" +description: "From Frisch-Waugh-Lovell to DML: understanding why score choice determines valid inference." +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Why Neyman Orthogonality Matters} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + eval = TRUE, + warning = FALSE, + message = FALSE +) +``` + +# Introduction + +This article builds intuition for *Neyman orthogonality*---a key +component of Double/Debiased Machine Learning (DML). Throughout, we focus on ordinary least squares. + +Consider estimating the coefficient $\theta_0$ on a variable of +interest $D$ in a linear model with controls $X$. Introductory econometrics courses typically discuss *partialling out* $X$ before estimating $\theta_0$. Two variants of +this idea lead to the same point estimate: + +- **Procedure A** (partial $D$ only): residualize $D$ with respect to + $X$, then regress $Y$ on $\tilde{D}$. +- **Procedure B** (partial both): residualize *both* $Y$ and $D$ with + respect to $X$, then regress $\tilde{Y}$ on $\tilde{D}$. + +It is tempting to take the first-step coefficients from partialling out $X$ from $D$ and $Y$ as given, and compute standard errors only for the second-step regression coefficient. +As it turns out, this naive approach results in valid inference in Procedure B, but is incorrect for Procedure A. Here, we aim to explain why one procedure is immune to first-step estimation error while the other is not---a property conveniently summarized by the notion of *Neyman orthogonality*. + +The article covers: + +1. Setting up the two procedures and comparing their output to full OLS +2. Deriving how first-step estimation error propagates---or + doesn't---into inference about $\theta_0$ +4. Introducing Neyman orthogonality and its implications +5. Discussing the bridge from OLS to nonparametric/ML first steps and ``ddml_plm`` + + +# Two-Step Procedures with Identical Coefficient Estimates + + +To fix ideas, we generate data from a linear model with a single control: + +$$Y_i = \theta_0 D_i + \beta_0 X_i + U_i,$$ + +where $D_i = \alpha X_i + V_i$ so that $X$ is correlated with both +$D$ and $Y$. + +```{r} +library(ddml) +set.seed(48105) + +n <- 500 +theta_0 <- 1 +beta_0 <- 2 +alpha <- 0.8 + +X <- rnorm(n) +V <- rnorm(n) +D <- alpha * X + V +U <- rnorm(n) +Y <- theta_0 * D + beta_0 * X + U +``` + +## Procedure A: Residualize $D$ Only + +For our first procedure, we partial out $X$ from $D$, then regress $Y$ on the residual: + +```{r} +D_tilde <- residuals(lm(D ~ X)) +fit_A <- lm(Y ~ D_tilde) +``` + +## Procedure B: Residualize Both $Y$ and $D$ + +For our second procedure, we partial out $X$ from *both* $D$ and $Y$, then regress the residuals on +each other: + +```{r} +Y_tilde <- residuals(lm(Y ~ X)) +fit_B <- lm(Y_tilde ~ D_tilde - 1) +``` + +## Comparing to Full OLS +It is useful to compare both two-step procedures with conventional multiple regression. + +```{r} +library(sandwich) +library(lmtest) + +fit_full <- lm(Y ~ D + X) + +theta_A <- coef(fit_A)["D_tilde"] +theta_B <- coef(fit_B)["D_tilde"] +theta_full <- coef(fit_full)["D"] + +se_A <- sqrt(diag(vcovHC(fit_A, type = "HC0")))["D_tilde"] +se_B <- sqrt(diag(vcovHC(fit_B, type = "HC0")))["D_tilde"] +se_full <- sqrt(diag(vcovHC(fit_full, type = "HC0")))["D"] + +cat("Full OLS: lm(Y ~ D + X)\n") +cat(" theta_hat:", round(theta_full, 4), + " SE:", round(se_full, 4), "\n\n") + +cat("Procedure A: lm(Y ~ D_tilde)\n") +cat(" theta_hat:", round(theta_A, 4), + " SE:", round(se_A, 4), "\n\n") + +cat("Procedure B: lm(Y_tilde ~ D_tilde - 1)\n") +cat(" theta_hat:", round(theta_B, 4), + " SE:", round(se_B, 4), "\n") +``` + +All three point estimates are identical. This is no accident: +$\tilde{D}$ is orthogonal to $X$ by construction, so omitting $X$ +does not bias the coefficient on $\tilde{D}$. + +But the standard errors tell a different story. **Procedure B** +matches full OLS exactly---both point estimate and standard error. +**Procedure A** gives a standard error that is far too large. + +In both procedures, the software computes the sandwich standard error +treating first-step coefficients as fixed. **If both procedures +ignore first-step estimation uncertainty, why does Procedure A fail +while Procedure B succeeds?** + + +# The First-Order Impact of Nuisance Estimation + + +Estimation of $\theta_0$ in each procedure is based on solving a +sample average of a score function $m(W_i; \theta, \eta) = 0$, +where $\eta$ denotes nuisance parameters. + +For **Procedure A**, the score is + +$$m_A(W_i; \theta, \eta_D) = \tilde{D}_i(Y_i - \tilde{D}_i\theta),$$ + +where $\tilde{D}_i = D_i - X_i'\eta_D$ and the nuisance parameter is +$\eta = \eta_D$ (the coefficient from the regression of $D$ on $X$). + +For **Procedure B**, the score is + +$$m_B(W_i; \theta, \eta) = \tilde{D}_i(\tilde{Y}_i - \tilde{D}_i\theta),$$ + +where $\tilde{Y}_i = Y_i - X_i'\eta_Y$ and the nuisance parameter is +$\eta = (\eta_Y, \eta_D)$ (the coefficients from the regressions of +$Y$ and $D$ on $X$, respectively). + +Given the score, software computes the sandwich standard error by +treating $\hat\eta$ as known: + +$$\widehat{\text{SE}}(\hat\theta) + = \sqrt{\hat{J}^{-2} \cdot \frac{1}{n^2} + \sum_{i=1}^n m(W_i;\, \hat\theta,\, \hat\eta)^2}\,,$$ + +where $\hat{J} = \frac{1}{n}\sum_i +\frac{\partial}{\partial\theta} m(W_i;\, \hat\theta,\, \hat\eta)$ +is the sample Jacobian. Both procedures share the same Jacobian +$\hat{J} \approx -E[\tilde{D}^2]$, so the SE difference traces +entirely to the squared scores in the numerator. At $\theta_0$, +Procedure A's score residual $Y_i - \tilde{D}_i\theta_0$ still +contains the confounders $X_i\beta_0$, inflating the numerator. +Procedure B's score residual +$\tilde{Y}_i - \tilde{D}_i\theta_0 = U_i$ contains only the +structural error---hence its smaller SE. + +Whether this plug-in standard error is *valid* depends on whether +ignoring nuisance estimation is asymptotically justified. A +standard Taylor expansion of the sample moment around the true +parameters $(\theta_0, \eta_0)$ reveals when it is (see, e.g., +Ahrens et al., 2026): + +$$\sqrt{n}(\hat\theta - \theta_0) + = -J_\theta^{-1}\biggl[ + \underbrace{\frac{1}{\sqrt{n}}\sum_i m(W_i; \theta_0, \eta_0)}_{\text{CLT}} + + \underbrace{\frac{1}{\sqrt{n}}\sum_i + \frac{\partial}{\partial \eta} m(W_i; \theta_0, \eta_0) + (\hat\eta - \eta_0)}_{(\star):\text{ first-order impact of nuisance estimation}} + \biggr]$$ + +plus higher order terms. The term $(\star)$ captures the first-order +impact of estimating the nuisance parameter $\eta_0$. Whether +$(\star)$ vanishes determines whether treating $\hat\eta$ as known +is justified. + +## Procedure A: $(\star)$ Does Not Vanish + +Procedure A's score depends on $\eta_D$ through +$\tilde{D}_i = D_i - X_i'\eta_D$. The pathwise derivative of the +expected score with respect to the nuisance parameter is: + +$$\frac{\partial}{\partial \eta_D'}\, + E[m_A(W;\, \theta_0, \eta_D)]\bigg|_{\eta_{D,0}} + = -E[XX']\,\beta_{Y|X}$$ + +where $\beta_{Y|X} = \theta_0\gamma_{D|X} + \beta_0$ is the +coefficient from the regression of $Y$ on $X$. This is **non-zero** +whenever $X$ is related to $Y$. + +As a consequence, estimation error in $\hat\eta_D$ propagates +directly into $\hat\theta_A$. The term $(\star)$ does not vanish, +and the naive standard error---which ignores $(\star)$---is wrong. + +## Procedure B: $(\star)$ Vanishes + +Procedure B's score depends on two nuisance parameters: +$\eta_Y$ (from $Y$ on $X$) and $\eta_D$ (from $D$ on $X$). The +pathwise derivatives of the expected score are: + +$$\frac{\partial}{\partial \eta_Y'} + E[m_B] = -E[\tilde{D}\, X'] = 0$$ + +because $\tilde{D} \perp X$ by the projection of $D$ on $X$, and + +$$\frac{\partial}{\partial \eta_D'} + E[m_B] = -E[X\tilde{Y}] + 2\theta_0 E[X\tilde{D}] + = -E[XU] + \theta_0 E[X\tilde{D}] = 0$$ + +because $\tilde{Y} = \tilde{D}\theta_0 + U$ and both +$U$ and $\tilde{D}$ are orthogonal to $X$. + +**Both pathwise derivatives vanish.** The term $(\star)$ in the +expansion is zero, so first-step estimation of $\hat\eta_Y$ and +$\hat\eta_D$ does not affect the asymptotic distribution of +$\hat\theta_B$---even to first order. The naive standard error is +correct as-is. + +## Numerical Verification + +We can verify the pathwise derivatives numerically: + +```{r} +J_gamma_A <- mean(X * (Y - D_tilde * theta_0)) +J_gamma_B <- mean(X * (Y_tilde - D_tilde * theta_0)) + +cat("Pathwise derivatives (should vanish for B only):\n") +cat(" Procedure A: E[X*(Y - Dt*theta)] =", + round(J_gamma_A, 4), "\n") +cat(" Procedure B: E[X*(Yt - Dt*theta)] =", + round(J_gamma_B, 4), "\n") +``` + + +# Neyman Orthogonality + +The property that makes Procedure B's standard error correct is +called **Neyman orthogonality**. Formally, a score +$m(W;\, \theta, \eta)$ is Neyman orthogonal at $(\theta_0, \eta_0)$ +if small perturbations of the nuisance parameter away from $\eta_0$ +do not create first-order changes in the expected score: + +$$\left.\frac{\partial}{\partial \lambda} + E\bigl[m(W;\,\theta_0,\,\eta_0 + \lambda(\eta - \eta_0)) + \bigr]\right|_{\lambda = 0} = 0, + \quad \forall\, \eta.$$ + +Procedure B's score satisfies this condition: the expected score is +insensitive to perturbations in *both* $\eta_Y$ and $\eta_D$. As a +result, replacing the true nuisance parameters with first-step +estimates does not distort inference about $\theta_0$. + +Procedure A's score does not satisfy Neyman orthogonality: it is +sensitive to perturbations in $\eta_D$, and the standard error +computed by treating $\hat\eta_D$ as known is incorrect. + +An important practical implication is that estimators based on Neyman +orthogonal scores yield inference about $\theta_0$ that does not +depend on the statistical properties of the nuisance estimator +$\hat\eta$. This is useful even in +classical low-dimensional settings, where it avoids cumbersome variance +adjustments to account for first-step estimation. It becomes +particularly important when modern flexible methods---including machine +learning---are used for nuisance estimation, as the statistical +properties of these methods are still under active development. + + +# From OLS to Machine Learning + +In our linear example, both nuisance parameters--- +$\eta_Y = \text{argmin}_\eta\, E[(Y - X'\eta)^2]$ and +$\eta_D = \text{argmin}_\eta\, E[(D - X'\eta)^2]$---are +estimated by OLS. Partialling out both $Y$ and $D$ yields the same +estimate and standard error as full OLS of $Y$ on $(D, X)$. + +The partially linear regression model generalizes this. Instead of +assuming linearity, we allow $X$ to enter flexibly: + +$$Y_i = \theta_0 D_i + g_0(X_i) + \varepsilon_i$$ + +where $g_0(\cdot) = E[Y - \theta_0 D | X]$ is an unknown, potentially +complex, function of $X$. The nuisance parameters become +$\ell_0(X) = E[Y|X]$ and $r_0(X) = E[D|X]$---conditional expectation +functions that can be estimated by machine learning. + +The Neyman orthogonal score for the partially linear model is + +$$m_{PLM}(W;\, \theta, \eta) = + [(Y - \ell(X)) - \theta(D - r(X))](D - r(X)),$$ + +which is the flexible analog of Procedure B's partialling-out +score. As in our linear example, a naive score that adjusts only $Y$ +(analogous to Procedure A) is not Neyman orthogonal and leads to +invalid inference. + +DML combines the Neyman orthogonal score with *cross-fitting*---a form +of sample splitting that addresses a second source of bias +(overfitting bias) arising when the nuisance estimator $\hat\eta$ and +the observations used in the moment condition are statistically +dependent. Together, these two ingredients form the core of the DML +framework. + +The ``ddml`` package implements this approach via ``ddml_plm``: + +```{r, eval = FALSE} +# Example: DML with gradient boosting (not run) +fit_dml <- ddml_plm(Y, D, X, + learners = list(what = mdl_xgboost), + sample_folds = 5) +summary(fit_dml) +``` + +See ``?ddml_plm`` for details and ``vignette("ddml")`` for a full +introduction. + + +# 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. + +Robinson P M (1988). "Root-N-Consistent Semiparametric Regression." +Econometrica, 56(4), 931-954. + +Frisch R, Waugh F V (1933). "Partial Time Regressions as Compared +with Individual Trends." Econometrica, 1(4), 387-401. + +Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, +Wiemann T (2025). "An Introduction to Double/Debiased Machine +Learning." Forthcoming. diff --git a/vignettes/articles/stacking.Rmd b/vignettes/articles/stacking.Rmd index fe326f0..8410507 100644 --- a/vignettes/articles/stacking.Rmd +++ b/vignettes/articles/stacking.Rmd @@ -82,11 +82,11 @@ Both stacking and short-stacking construct weighted averages of the considered b ```r cat("Time single learner:", time_singlelearner[1], "\n") -#> Time single learner: 1.64 +#> Time single learner: 1.81 cat("Time short-stacking:", time_shortstacking[1], "\n") -#> Time short-stacking: 3.23 +#> Time short-stacking: 3.37 cat("Time stacking: ", time_stacking[1]) -#> Time stacking: 15.33 +#> Time stacking: 18.2 ``` # References diff --git a/vignettes/precompile.R b/vignettes/precompile.R index 595ff6a..3bf2fcb 100644 --- a/vignettes/precompile.R +++ b/vignettes/precompile.R @@ -51,7 +51,11 @@ VIGNETTES <- list( list(name = "repeated_resampling", src = "vignettes/articles/repeated_resampling.Rmd.txt", out = "vignettes/articles/repeated_resampling.Rmd", - deps = "ddml") + deps = "ddml"), + list(name = "neyman_orthogonality", + src = "vignettes/articles/neyman_orthogonality.Rmd.txt", + out = "vignettes/articles/neyman_orthogonality.Rmd", + deps = c("ddml", "sandwich", "lmtest")) ) args <- commandArgs(trailingOnly = TRUE) From 0f7539e8cb4b405423c0de779d5fa74d550a9b8a Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Mon, 13 Apr 2026 10:18:53 -0500 Subject: [PATCH 45/46] update readme --- README.Rmd | 1 + README.md | 2 ++ _pkgdown.yml | 3 +++ 3 files changed, 6 insertions(+) diff --git a/README.Rmd b/README.Rmd index 1cbe10b..b69c804 100644 --- a/README.Rmd +++ b/README.Rmd @@ -87,6 +87,7 @@ summary(late_fit_short) Check out our articles to learn more: +- ``vignette("neyman_orthogonality")`` introduces Neyman orthogonality in simple linear regression - ``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 diff --git a/README.md b/README.md index 1c871d1..9563b20 100644 --- a/README.md +++ b/README.md @@ -105,6 +105,8 @@ summary(late_fit_short) Check out our articles to learn more: +- `vignette("neyman_orthogonality")` introduces Neyman orthogonality in + simple linear regression - `vignette("ddml")` is a more detailed introduction to `ddml` - `vignette("stacking")` discusses computational benefits of short-stacking diff --git a/_pkgdown.yml b/_pkgdown.yml index a2af703..9ba0f3c 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -105,6 +105,9 @@ reference: - reexports articles: +- title: Background + contents: + - articles/neyman_orthogonality - title: Key Features navbar: ~ contents: From 0ab53e4cbc7b4e02ca13240a35758b7408366171 Mon Sep 17 00:00:00 2001 From: thomaswiemann Date: Thu, 16 Apr 2026 15:45:58 -0500 Subject: [PATCH 46/46] typo corrections --- vignettes/articles/neyman_orthogonality.Rmd | 46 +++++++++---------- .../articles/neyman_orthogonality.Rmd.txt | 46 +++++++++---------- 2 files changed, 42 insertions(+), 50 deletions(-) diff --git a/vignettes/articles/neyman_orthogonality.Rmd b/vignettes/articles/neyman_orthogonality.Rmd index 65c736c..7bc1287 100644 --- a/vignettes/articles/neyman_orthogonality.Rmd +++ b/vignettes/articles/neyman_orthogonality.Rmd @@ -3,7 +3,7 @@ title: "Neyman Orthogonality in Linear Regression" description: "From Frisch-Waugh-Lovell to DML: understanding why score choice determines valid inference." output: rmarkdown::html_vignette vignette: > - %\VignetteIndexEntry{Why Neyman Orthogonality Matters} + %\VignetteIndexEntry{Neyman Orthogonality in Linear Regression} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- @@ -32,7 +32,7 @@ The article covers: 1. Setting up the two procedures and comparing their output to full OLS 2. Deriving how first-step estimation error propagates---or doesn't---into inference about $\theta_0$ -4. Introducing Neyman orthogonality and its implications +3. Introducing Neyman orthogonality and its implications 5. Discussing the bridge from OLS to nonparametric/ML first steps and ``ddml_plm`` @@ -170,16 +170,15 @@ is the sample Jacobian. Both procedures share the same Jacobian $\hat{J} \approx -E[\tilde{D}^2]$, so the SE difference traces entirely to the squared scores in the numerator. At $\theta_0$, Procedure A's score residual $Y_i - \tilde{D}_i\theta_0$ still -contains the confounders $X_i\beta_0$, inflating the numerator. +contains terms involving $X_i$, inflating the numerator. Procedure B's score residual $\tilde{Y}_i - \tilde{D}_i\theta_0 = U_i$ contains only the structural error---hence its smaller SE. -Whether this plug-in standard error is *valid* depends on whether -ignoring nuisance estimation is asymptotically justified. A -standard Taylor expansion of the sample moment around the true -parameters $(\theta_0, \eta_0)$ reveals when it is (see, e.g., -Ahrens et al., 2026): +Whether the asymptotic distribution of $\hat\theta$ depends on +$\hat\eta$ can be assessed via a standard Taylor expansion of the +sample moment around the true parameters $(\theta_0, \eta_0)$ +(see, e.g., Ahrens et al., 2026): $$\sqrt{n}(\hat\theta - \theta_0) = -J_\theta^{-1}\biggl[ @@ -190,9 +189,9 @@ $$\sqrt{n}(\hat\theta - \theta_0) \biggr]$$ plus higher order terms. The term $(\star)$ captures the first-order -impact of estimating the nuisance parameter $\eta_0$. Whether -$(\star)$ vanishes determines whether treating $\hat\eta$ as known -is justified. +impact of estimating the nuisance parameter $\eta_0$. If $(\star)$ +vanishes, inference about $\theta_0$ can proceed as if $\eta_0$ +were known. ## Procedure A: $(\star)$ Does Not Vanish @@ -280,13 +279,16 @@ computed by treating $\hat\eta_D$ as known is incorrect. An important practical implication is that estimators based on Neyman orthogonal scores yield inference about $\theta_0$ that does not -depend on the statistical properties of the nuisance estimator -$\hat\eta$. This is useful even in -classical low-dimensional settings, where it avoids cumbersome variance -adjustments to account for first-step estimation. It becomes -particularly important when modern flexible methods---including machine -learning---are used for nuisance estimation, as the statistical -properties of these methods are still under active development. +depend on the detailed statistical properties of the nuisance +estimator $\hat\eta$. This is useful even in +classical low-dimensional settings, where it avoids cumbersome +variance adjustments to account for first-step estimation. It +becomes particularly important when modern flexible +methods---including machine learning---are used for nuisance +estimation, as only coarse convergence rates are currently available +for many promising ML methods. By alleviating the first-order impact +of nuisance estimation, Neyman orthogonality makes it possible to +combine such methods with standard asymptotic approximations. # From OLS to Machine Learning @@ -313,7 +315,7 @@ $$m_{PLM}(W;\, \theta, \eta) = [(Y - \ell(X)) - \theta(D - r(X))](D - r(X)),$$ which is the flexible analog of Procedure B's partialling-out -score. As in our linear example, a naive score that adjusts only $Y$ +score. As in our linear example, a naive score that adjusts only $D$ (analogous to Procedure A) is not Neyman orthogonal and leads to invalid inference. @@ -346,12 +348,6 @@ Newey W, Robins J (2018). "Double/debiased machine learning for treatment and structural parameters." The Econometrics Journal, 21(1), C1-C68. -Robinson P M (1988). "Root-N-Consistent Semiparametric Regression." -Econometrica, 56(4), 931-954. - -Frisch R, Waugh F V (1933). "Partial Time Regressions as Compared -with Individual Trends." Econometrica, 1(4), 387-401. - Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, Wiemann T (2025). "An Introduction to Double/Debiased Machine Learning." Forthcoming. diff --git a/vignettes/articles/neyman_orthogonality.Rmd.txt b/vignettes/articles/neyman_orthogonality.Rmd.txt index c555e98..08cc54d 100644 --- a/vignettes/articles/neyman_orthogonality.Rmd.txt +++ b/vignettes/articles/neyman_orthogonality.Rmd.txt @@ -3,7 +3,7 @@ title: "Neyman Orthogonality in Linear Regression" description: "From Frisch-Waugh-Lovell to DML: understanding why score choice determines valid inference." output: rmarkdown::html_vignette vignette: > - %\VignetteIndexEntry{Why Neyman Orthogonality Matters} + %\VignetteIndexEntry{Neyman Orthogonality in Linear Regression} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- @@ -40,7 +40,7 @@ The article covers: 1. Setting up the two procedures and comparing their output to full OLS 2. Deriving how first-step estimation error propagates---or doesn't---into inference about $\theta_0$ -4. Introducing Neyman orthogonality and its implications +3. Introducing Neyman orthogonality and its implications 5. Discussing the bridge from OLS to nonparametric/ML first steps and ``ddml_plm`` @@ -168,16 +168,15 @@ is the sample Jacobian. Both procedures share the same Jacobian $\hat{J} \approx -E[\tilde{D}^2]$, so the SE difference traces entirely to the squared scores in the numerator. At $\theta_0$, Procedure A's score residual $Y_i - \tilde{D}_i\theta_0$ still -contains the confounders $X_i\beta_0$, inflating the numerator. +contains terms involving $X_i$, inflating the numerator. Procedure B's score residual $\tilde{Y}_i - \tilde{D}_i\theta_0 = U_i$ contains only the structural error---hence its smaller SE. -Whether this plug-in standard error is *valid* depends on whether -ignoring nuisance estimation is asymptotically justified. A -standard Taylor expansion of the sample moment around the true -parameters $(\theta_0, \eta_0)$ reveals when it is (see, e.g., -Ahrens et al., 2026): +Whether the asymptotic distribution of $\hat\theta$ depends on +$\hat\eta$ can be assessed via a standard Taylor expansion of the +sample moment around the true parameters $(\theta_0, \eta_0)$ +(see, e.g., Ahrens et al., 2026): $$\sqrt{n}(\hat\theta - \theta_0) = -J_\theta^{-1}\biggl[ @@ -188,9 +187,9 @@ $$\sqrt{n}(\hat\theta - \theta_0) \biggr]$$ plus higher order terms. The term $(\star)$ captures the first-order -impact of estimating the nuisance parameter $\eta_0$. Whether -$(\star)$ vanishes determines whether treating $\hat\eta$ as known -is justified. +impact of estimating the nuisance parameter $\eta_0$. If $(\star)$ +vanishes, inference about $\theta_0$ can proceed as if $\eta_0$ +were known. ## Procedure A: $(\star)$ Does Not Vanish @@ -274,13 +273,16 @@ computed by treating $\hat\eta_D$ as known is incorrect. An important practical implication is that estimators based on Neyman orthogonal scores yield inference about $\theta_0$ that does not -depend on the statistical properties of the nuisance estimator -$\hat\eta$. This is useful even in -classical low-dimensional settings, where it avoids cumbersome variance -adjustments to account for first-step estimation. It becomes -particularly important when modern flexible methods---including machine -learning---are used for nuisance estimation, as the statistical -properties of these methods are still under active development. +depend on the detailed statistical properties of the nuisance +estimator $\hat\eta$. This is useful even in +classical low-dimensional settings, where it avoids cumbersome +variance adjustments to account for first-step estimation. It +becomes particularly important when modern flexible +methods---including machine learning---are used for nuisance +estimation, as only coarse convergence rates are currently available +for many promising ML methods. By alleviating the first-order impact +of nuisance estimation, Neyman orthogonality makes it possible to +combine such methods with standard asymptotic approximations. # From OLS to Machine Learning @@ -307,7 +309,7 @@ $$m_{PLM}(W;\, \theta, \eta) = [(Y - \ell(X)) - \theta(D - r(X))](D - r(X)),$$ which is the flexible analog of Procedure B's partialling-out -score. As in our linear example, a naive score that adjusts only $Y$ +score. As in our linear example, a naive score that adjusts only $D$ (analogous to Procedure A) is not Neyman orthogonal and leads to invalid inference. @@ -339,12 +341,6 @@ Newey W, Robins J (2018). "Double/debiased machine learning for treatment and structural parameters." The Econometrics Journal, 21(1), C1-C68. -Robinson P M (1988). "Root-N-Consistent Semiparametric Regression." -Econometrica, 56(4), 931-954. - -Frisch R, Waugh F V (1933). "Partial Time Regressions as Compared -with Individual Trends." Econometrica, 1(4), 387-401. - Ahrens A, Chernozhukov V, Hansen C B, Kozbur D, Schaffer M E, Wiemann T (2025). "An Introduction to Double/Debiased Machine Learning." Forthcoming.