From f114c6f2a6dcdac85d623d79d6356aec7ff853c6 Mon Sep 17 00:00:00 2001 From: pedrohcgs Date: Fri, 19 Jun 2026 10:27:09 -0400 Subject: [PATCH 1/4] Harden scalar argument validation --- R/att_gt.R | 20 +++++---- R/compute.aggte.R | 9 ++++ R/pre_process_did.R | 18 +++++--- R/pre_process_did2.R | 20 +++++---- R/utility_functions.R | 42 ++++++++++++++++++ tests/testthat/test-error-handling.R | 64 ++++++++++++++++++++++++++++ 6 files changed, 148 insertions(+), 25 deletions(-) diff --git a/R/att_gt.R b/R/att_gt.R index 96d11802..24d3d75d 100644 --- a/R/att_gt.R +++ b/R/att_gt.R @@ -306,6 +306,16 @@ att_gt <- function(yname, if (!is.logical(compute_inffunc) || length(compute_inffunc) != 1 || is.na(compute_inffunc)) { stop("compute_inffunc must be a single logical (TRUE or FALSE).") } + validate_logical_scalar(panel, "panel") + validate_logical_scalar(allow_unbalanced_panel, "allow_unbalanced_panel") + validate_logical_scalar(bstrap, "bstrap") + validate_logical_scalar(cband, "cband") + validate_logical_scalar(faster_mode, "faster_mode") + validate_logical_scalar(print_details, "print_details") + validate_logical_scalar(pl, "pl") + validate_positive_whole_number(cores, "cores") + validate_anticipation(anticipation) + validate_alp(alp) # When influence functions are not computed there are no standard errors, no # uniform bands, and no parallel-trends pre-test, so the bootstrap is moot. if (!compute_inffunc) { @@ -356,17 +366,9 @@ att_gt <- function(yname, stop("Must provide idname when panel = TRUE. Set panel = FALSE for repeated cross sections.") } - # Validate alp (significance level) - if (!is.numeric(alp) || length(alp) != 1 || is.na(alp) || alp <= 0 || alp >= 1) { - stop("alp must be a single number strictly between 0 and 1.") - } - # Validate biters (number of bootstrap iterations) when the bootstrap is used if (bstrap) { - if (!is.numeric(biters) || length(biters) != 1 || is.na(biters) || - biters < 1 || biters != round(biters)) { - stop("biters must be a single positive whole number.") - } + validate_positive_whole_number(biters, "biters") } # Warn users about anticipation and never-treated units diff --git a/R/compute.aggte.R b/R/compute.aggte.R index b9526adb..09b4f717 100644 --- a/R/compute.aggte.R +++ b/R/compute.aggte.R @@ -35,6 +35,11 @@ compute.aggte <- function(MP, inffunc1 <- MP$inffunc n <- MP$n + validate_logical_scalar(na.rm, "na.rm") + validate_numeric_scalar(min_e, "min_e") + validate_numeric_scalar(max_e, "max_e") + if (!is.null(balance_e)) validate_numeric_scalar(balance_e, "balance_e") + # aggte() needs the influence functions to aggregate and to compute standard errors. # They are absent when att_gt() was run with compute_inffunc = FALSE (point estimates only). if (is.null(inffunc1)) { @@ -93,6 +98,10 @@ compute.aggte <- function(MP, if (is.null(cband)) { cband <- dp$cband } + validate_logical_scalar(bstrap, "bstrap") + validate_logical_scalar(cband, "cband") + validate_alp(alp) + if (bstrap || cband) validate_positive_whole_number(biters, "biters") if (isTRUE(dp$faster_mode)) { tlist <- dp$time_periods glist <- dp$treated_groups diff --git a/R/pre_process_did.R b/R/pre_process_did.R index 7945d1b9..ec145a87 100644 --- a/R/pre_process_did.R +++ b/R/pre_process_did.R @@ -46,13 +46,17 @@ pre_process_did <- function(yname, if (!(base_period %in% c("universal", "varying"))) { stop("base_period must be either 'universal' or 'varying'.") } - # Check if anticipation is numeric and non-negative (same contract as the fast path) - if (!is.numeric(anticipation)) { - stop("anticipation must be numeric. Please convert it.") - } - if (anticipation < 0) { - stop("anticipation must be non-negative. Please check your arguments.") - } + validate_logical_scalar(panel, "panel") + validate_logical_scalar(allow_unbalanced_panel, "allow_unbalanced_panel") + validate_logical_scalar(bstrap, "bstrap") + validate_logical_scalar(cband, "cband") + validate_logical_scalar(faster_mode, "faster_mode") + validate_logical_scalar(print_details, "print_details") + validate_logical_scalar(pl, "pl") + validate_positive_whole_number(cores, "cores") + validate_anticipation(anticipation) + validate_alp(alp) + if (bstrap) validate_positive_whole_number(biters, "biters") check_reserved_did_names(yname = yname, tname = tname, idname = idname, gname = gname, xformla = xformla, weightsname = weightsname, diff --git a/R/pre_process_did2.R b/R/pre_process_did2.R index 7669e240..a7033a4c 100644 --- a/R/pre_process_did2.R +++ b/R/pre_process_did2.R @@ -107,15 +107,16 @@ validate_args <- function(args, data){ } } - # Check if anticipation is numeric using - if (!is.numeric(args$anticipation)) { - stop("anticipation must be numeric. Please convert it.") - } - - # Check if anticipation is positive - if (args$anticipation < 0) { - stop("anticipation must be non-negative. Please check your arguments.") - } + validate_logical_scalar(args$panel, "panel") + validate_logical_scalar(args$allow_unbalanced_panel, "allow_unbalanced_panel") + validate_logical_scalar(args$bstrap, "bstrap") + validate_logical_scalar(args$cband, "cband") + validate_logical_scalar(args$print_details, "print_details") + validate_logical_scalar(args$pl, "pl") + validate_positive_whole_number(args$cores, "cores") + validate_anticipation(args$anticipation) + validate_alp(args$alp) + if (args$bstrap) validate_positive_whole_number(args$biters, "biters") } @@ -713,6 +714,7 @@ pre_process_did2 <- function(yname, if (!(args$base_period %in% c("universal", "varying"))) { stop("base_period must be either 'universal' or 'varying'.") } + validate_logical_scalar(args$faster_mode, "faster_mode") check_reserved_did_names(yname = args$yname, tname = args$tname, idname = args$idname, gname = args$gname, xformla = args$xformla, diff --git a/R/utility_functions.R b/R/utility_functions.R index 9e67a926..8de5e0bd 100644 --- a/R/utility_functions.R +++ b/R/utility_functions.R @@ -117,6 +117,48 @@ check_reserved_did_names <- function(yname, tname, idname, gname, xformla, } } +validate_anticipation <- function(anticipation) { + if (!is.numeric(anticipation)) { + stop("anticipation must be numeric. Please convert it.") + } + if (length(anticipation) != 1L || is.na(anticipation)) { + stop("anticipation must be a single non-missing number. Please check your arguments.") + } + if (anticipation < 0) { + stop("anticipation must be non-negative. Please check your arguments.") + } + invisible(anticipation) +} + +validate_logical_scalar <- function(x, name) { + if (!is.logical(x) || length(x) != 1L || is.na(x)) { + stop(name, " must be a single logical (TRUE or FALSE).") + } + invisible(x) +} + +validate_numeric_scalar <- function(x, name) { + if (!is.numeric(x) || length(x) != 1L || is.na(x)) { + stop(name, " must be a single non-missing number.") + } + invisible(x) +} + +validate_alp <- function(alp) { + if (!is.numeric(alp) || length(alp) != 1 || is.na(alp) || alp <= 0 || alp >= 1) { + stop("alp must be a single number strictly between 0 and 1.") + } + invisible(alp) +} + +validate_positive_whole_number <- function(x, name) { + if (!is.numeric(x) || length(x) != 1 || is.na(x) || + x < 1 || x != round(x)) { + stop(name, " must be a single positive whole number.") + } + invisible(x) +} + #' @title get_wide_data #' @description A utility function to convert long data to wide data, i.e., takes a 2 period dataset and turns it into a cross sectional dataset. #' diff --git a/tests/testthat/test-error-handling.R b/tests/testthat/test-error-handling.R index 77991118..27e2837b 100644 --- a/tests/testthat/test-error-handling.R +++ b/tests/testthat/test-error-handling.R @@ -64,6 +64,49 @@ test_that("att_gt rejects negative or non-numeric anticipation in both modes", { gname = "G", anticipation = "1", faster_mode = fm, bstrap = FALSE), "anticipation must be numeric" ) + expect_error( + att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", + gname = "G", anticipation = c(0, 1), faster_mode = fm, bstrap = FALSE), + "anticipation must be a single non-missing number" + ) + expect_error( + att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", + gname = "G", anticipation = NA_real_, faster_mode = fm, bstrap = FALSE), + "anticipation must be a single non-missing number" + ) + } +}) + +test_that("att_gt rejects invalid scalar logical controls before base R errors", { + bad_args <- list( + panel = NA, + allow_unbalanced_panel = NA, + bstrap = NA, + cband = NA, + faster_mode = NA, + print_details = NA, + pl = "yes" + ) + + for (nm in names(bad_args)) { + args <- list(yname = "Y", data = data_eh, tname = "period", + idname = "id", gname = "G", bstrap = FALSE) + args[[nm]] <- bad_args[[nm]] + expect_error( + do.call(att_gt, args), + paste0(nm, " must be a single logical"), + info = nm + ) + } +}) + +test_that("att_gt rejects invalid cores before parallel code sees it", { + for (bad_cores in list(0, -1, 1.5, c(1, 2), "2", NA_real_)) { + expect_error( + att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", + gname = "G", cores = bad_cores, bstrap = FALSE), + "cores must be a single positive whole number" + ) } }) @@ -148,6 +191,27 @@ test_that("att_gt errors on invalid biters when bootstrapping", { expect_s3_class(res, "MP") }) +test_that("aggte rejects invalid scalar controls before base R errors", { + mp <- suppressWarnings(suppressMessages( + att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", + gname = "G", bstrap = FALSE) + )) + expect_error(aggte(mp, type = "simple", na.rm = NA), + "na.rm must be a single logical") + expect_error(aggte(mp, type = "simple", bstrap = NA), + "bstrap must be a single logical") + expect_error(aggte(mp, type = "simple", cband = NA), + "cband must be a single logical") + expect_error(aggte(mp, type = "simple", alp = NA_real_), + "alp must be a single number strictly between 0 and 1") + expect_error(aggte(mp, type = "simple", bstrap = TRUE, biters = 0), + "biters must be a single positive whole number") + expect_error(aggte(mp, type = "dynamic", min_e = NA_real_), + "min_e must be a single non-missing number") + expect_error(aggte(mp, type = "dynamic", balance_e = c(0, 1)), + "balance_e must be a single non-missing number") +}) + test_that("att_gt errors on fix_weights with panel=FALSE", { expect_error( att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", From 9d161ff2f834ca51b7a79d559e6247d5f1508e53 Mon Sep 17 00:00:00 2001 From: pedrohcgs Date: Fri, 19 Jun 2026 10:52:15 -0400 Subject: [PATCH 2/4] Expand scalar validation hardening --- R/att_gt.R | 14 ++++ R/compute.aggte.R | 10 ++- R/conditional_did_pretest.R | 6 ++ R/ggdid.R | 11 +-- R/gplot.R | 26 ++++-- R/honest_did/honest_did.R | 12 ++- R/mboot.R | 10 +++ R/pre_process_did.R | 21 +++-- R/pre_process_did2.R | 31 ++++--- R/simulate_data.R | 20 +++++ R/utility_functions.R | 43 ++++++++-- tests/testthat/test-error-handling.R | 119 +++++++++++++++++++++++++-- 12 files changed, 272 insertions(+), 51 deletions(-) diff --git a/R/att_gt.R b/R/att_gt.R index 24d3d75d..b75ba6d2 100644 --- a/R/att_gt.R +++ b/R/att_gt.R @@ -302,6 +302,20 @@ att_gt <- function(yname, # Capture extra arguments for custom est_method extra_args <- list(...) + if (missing(control_group)) control_group <- "nevertreated" + validate_choice_scalar( + control_group, + "control_group", + c("nevertreated", "notyettreated"), + "control_group must be either 'nevertreated' or 'notyettreated'" + ) + validate_choice_scalar( + base_period, + "base_period", + c("universal", "varying"), + "base_period must be either 'universal' or 'varying'." + ) + # Validate compute_inffunc (point-estimates-only switch) if (!is.logical(compute_inffunc) || length(compute_inffunc) != 1 || is.na(compute_inffunc)) { stop("compute_inffunc must be a single logical (TRUE or FALSE).") diff --git a/R/compute.aggte.R b/R/compute.aggte.R index 09b4f717..71c6145b 100644 --- a/R/compute.aggte.R +++ b/R/compute.aggte.R @@ -36,6 +36,12 @@ compute.aggte <- function(MP, n <- MP$n validate_logical_scalar(na.rm, "na.rm") + validate_choice_scalar( + type, + "type", + c("simple", "dynamic", "group", "calendar"), + '`type` must be one of c("simple", "dynamic", "group", "calendar")' + ) validate_numeric_scalar(min_e, "min_e") validate_numeric_scalar(max_e, "max_e") if (!is.null(balance_e)) validate_numeric_scalar(balance_e, "balance_e") @@ -130,10 +136,6 @@ compute.aggte <- function(MP, MP$DIDparams$cband <- cband dp <- MP$DIDparams - if (!(type %in% c("simple", "dynamic", "group", "calendar"))) { - stop('`type` must be one of c("simple", "dynamic", "group", "calendar")') - } - if (na.rm) { notna <- !is.na(att) if (!any(notna)) { diff --git a/R/conditional_did_pretest.R b/R/conditional_did_pretest.R index 8f84efd7..754b935e 100644 --- a/R/conditional_did_pretest.R +++ b/R/conditional_did_pretest.R @@ -66,6 +66,8 @@ conditional_did_pretest <- function(yname, message("We are no longer updating this function. It should continue to work, but most users find the pre-tests already reported by the `att_gt` function to be sufficient for most empirical applications.") + if (missing(control_group)) control_group <- "nevertreated" + # this is a DIDparams object dp <- pre_process_did(yname=yname, tname=tname, @@ -364,6 +366,7 @@ indicator <- function(X, u) { #' #' @export test.mboot <- function(inf.func, DIDparams, cores=1) { + validate_positive_whole_number(cores, "cores") # setup needed variables data <- DIDparams$data @@ -374,6 +377,9 @@ test.mboot <- function(inf.func, DIDparams, cores=1) { tlist <- unique(data[,tname])[order(unique(data[,tname]))] alp <- DIDparams$alp panel <- DIDparams$panel + validate_positive_whole_number(biters, "biters") + validate_alp(alp) + validate_logical_scalar(panel, "DIDparams$panel") # just get n obsevations (for clustering below...) if (panel) { diff --git a/R/ggdid.R b/R/ggdid.R index 1e998e3e..2490bdd4 100644 --- a/R/ggdid.R +++ b/R/ggdid.R @@ -76,11 +76,12 @@ ggdid.MP <- function(object, legend=TRUE, group=NULL, ref_line = 0, - theming = TRUE, - grtitle = "Group", - ...) { - - mpobj <- object + theming = TRUE, + grtitle = "Group", + ...) { + validate_positive_whole_number(ncol, "ncol") + + mpobj <- object G <- length(unique(mpobj$group)) Y <- length(unique(mpobj$t))## drop 1 period bc DID diff --git a/R/gplot.R b/R/gplot.R index 87db6fda..d50c791d 100644 --- a/R/gplot.R +++ b/R/gplot.R @@ -10,11 +10,16 @@ #' #' @keywords internal #' -#' @export -gplot <- function(ssresults, ylim=NULL, xlab=NULL, ylab=NULL, title="Group", xgap=1, - legend=TRUE, ref_line = 0, theming = TRUE) { - unique_years <- sort(unique(as.numeric(as.character(ssresults$year)))) - xgap_int <- max(1L, as.integer(round(xgap))) +#' @export +gplot <- function(ssresults, ylim=NULL, xlab=NULL, ylab=NULL, title="Group", xgap=1, + legend=TRUE, ref_line = 0, theming = TRUE) { + validate_positive_numeric_scalar(xgap, "xgap") + validate_logical_scalar(legend, "legend") + validate_logical_scalar(theming, "theming") + validate_optional_numeric_scalar(ref_line, "ref_line") + + unique_years <- sort(unique(as.numeric(as.character(ssresults$year)))) + xgap_int <- max(1L, as.integer(round(xgap))) dabreaks <- unique_years[seq(1, length(unique_years), by = xgap_int)] c.point <- qnorm(1 - ssresults$alp/2) @@ -64,10 +69,13 @@ gplot <- function(ssresults, ylim=NULL, xlab=NULL, ylab=NULL, title="Group", xga #' @keywords internal #' #' @export -splot <- function(ssresults, ylim=NULL, xlab=NULL, ylab=NULL, title="Group", - legend=TRUE, ref_line = 0, theming = TRUE) { - - # names of variables are "weird" for this function because this code builds +splot <- function(ssresults, ylim=NULL, xlab=NULL, ylab=NULL, title="Group", + legend=TRUE, ref_line = 0, theming = TRUE) { + validate_logical_scalar(legend, "legend") + validate_logical_scalar(theming, "theming") + validate_optional_numeric_scalar(ref_line, "ref_line") + + # names of variables are "weird" for this function because this code builds # on the same infrastructure as for plotting group-time average treatment # effects and aggregations using event time or calendar time diff --git a/R/honest_did/honest_did.R b/R/honest_did/honest_did.R index e6895cbe..fa3fb413 100644 --- a/R/honest_did/honest_did.R +++ b/R/honest_did/honest_did.R @@ -46,7 +46,17 @@ honest_did.AGGTEobj <- function(object, ...) { - type <- type[1] + if (missing(type)) type <- "smoothness" + validate_choice_scalar( + type, + "type", + c("smoothness", "relative_magnitude"), + 'type must be either "smoothness" or "relative_magnitude".' + ) + validate_numeric_scalar(e_time, "e_time") + validate_alp(alpha, "alpha") + validate_logical_scalar(parallel, "parallel") + validate_positive_whole_number(gridPoints, "gridPoints") # make sure that user is passing in an event study if (object$type != "dynamic") { diff --git a/R/mboot.R b/R/mboot.R index 30e453cc..5cd4c90d 100644 --- a/R/mboot.R +++ b/R/mboot.R @@ -23,6 +23,9 @@ #' #' @export mboot <- function(inf.func, DIDparams, pl = FALSE, cores = 1, return_V = TRUE) { + validate_logical_scalar(pl, "pl") + validate_positive_whole_number(cores, "cores") + validate_logical_scalar(return_V, "return_V") # setup needed variables according to faster_mode; This returns different type of objects # depending on whether we are in faster_mode or not that has to be handled in the code below @@ -32,6 +35,9 @@ mboot <- function(inf.func, DIDparams, pl = FALSE, cores = 1, return_V = TRUE) { tname <- DIDparams$tname alp <- DIDparams$alp panel <- DIDparams$panel + validate_positive_whole_number(biters, "biters") + validate_alp(alp) + validate_logical_scalar(panel, "DIDparams$panel") true_repeated_cross_sections <- DIDparams$true_repeated_cross_sections unbalanced_panel <- DIDparams$allow_unbalanced_panel # Reuse the per-unit cluster vector that att_gt() stored in DIDparams when it @@ -179,6 +185,10 @@ mboot <- function(inf.func, DIDparams, pl = FALSE, cores = 1, return_V = TRUE) { } run_multiplier_bootstrap <- function(inf.func, biters, pl = FALSE, cores = 1) { + validate_positive_whole_number(biters, "biters") + validate_logical_scalar(pl, "pl") + validate_positive_whole_number(cores, "cores") + # Split biters into per-core chunks that are always non-negative and sum to # biters. The previous rep(ceiling(biters/cores), cores) + correction made # chunks[1] negative when biters < cores (e.g. biters=2, cores=4 -> [-1,1,1,1]), diff --git a/R/pre_process_did.R b/R/pre_process_did.R index ec145a87..87400c33 100644 --- a/R/pre_process_did.R +++ b/R/pre_process_did.R @@ -38,14 +38,19 @@ pre_process_did <- function(yname, # Data pre-processing and error checking #----------------------------------------------------------------------------- # set control group - control_group <- control_group[1] - if(!(control_group %in% c("nevertreated","notyettreated"))){ - stop("control_group must be either 'nevertreated' or 'notyettreated'") - } - base_period <- base_period[1] - if (!(base_period %in% c("universal", "varying"))) { - stop("base_period must be either 'universal' or 'varying'.") - } + if (missing(control_group)) control_group <- "nevertreated" + validate_choice_scalar( + control_group, + "control_group", + c("nevertreated", "notyettreated"), + "control_group must be either 'nevertreated' or 'notyettreated'" + ) + validate_choice_scalar( + base_period, + "base_period", + c("universal", "varying"), + "base_period must be either 'universal' or 'varying'." + ) validate_logical_scalar(panel, "panel") validate_logical_scalar(allow_unbalanced_panel, "allow_unbalanced_panel") validate_logical_scalar(bstrap, "bstrap") diff --git a/R/pre_process_did2.R b/R/pre_process_did2.R index a7033a4c..caf486d5 100644 --- a/R/pre_process_did2.R +++ b/R/pre_process_did2.R @@ -10,10 +10,11 @@ validate_args <- function(args, data){ data_names <- names(data) # ---------------------- Error Checking ---------------------- - args$control_group <- args$control_group[1] # Flag for control group types control_group_message <- "control_group must be either 'nevertreated' or 'notyettreated'" - dreamerr::check_set_arg(args$control_group, "match", .choices = c("nevertreated", "notyettreated"), .message = control_group_message, .up = 1) + validate_choice_scalar(args$control_group, "control_group", + c("nevertreated", "notyettreated"), + control_group_message) # Flag for tname, gname, yname name_message <- "__ARG__ must be a character scalar and a name of a column from the dataset." @@ -85,9 +86,10 @@ validate_args <- function(args, data){ } # Flag for base period: not in c("universal", "varying"), stop - args$base_period <- args$base_period[1] base_period_message <- "base_period must be either 'universal' or 'varying'." - dreamerr::check_set_arg(args$base_period, "match", .choices = c("universal", "varying"), .message = base_period_message, .up = 1) + validate_choice_scalar(args$base_period, "base_period", + c("universal", "varying"), + base_period_message) # Flags for cluster variable # Note: idname was already stripped from clustervars and the at-most-one check @@ -706,14 +708,19 @@ pre_process_did2 <- function(yname, args <- mget(args_names, sys.frame(sys.nframe())) # pick a control_group by default - args$control_group <- control_group[1] - if (!(args$control_group %in% c("nevertreated", "notyettreated"))) { - stop("control_group must be either 'nevertreated' or 'notyettreated'") - } - args$base_period <- base_period[1] - if (!(args$base_period %in% c("universal", "varying"))) { - stop("base_period must be either 'universal' or 'varying'.") - } + if (missing(control_group)) args$control_group <- "nevertreated" + validate_choice_scalar( + args$control_group, + "control_group", + c("nevertreated", "notyettreated"), + "control_group must be either 'nevertreated' or 'notyettreated'" + ) + validate_choice_scalar( + args$base_period, + "base_period", + c("universal", "varying"), + "base_period must be either 'universal' or 'varying'." + ) validate_logical_scalar(args$faster_mode, "faster_mode") check_reserved_did_names(yname = args$yname, tname = args$tname, idname = args$idname, gname = args$gname, diff --git a/R/simulate_data.R b/R/simulate_data.R index 532206e3..ff14599e 100644 --- a/R/simulate_data.R +++ b/R/simulate_data.R @@ -27,6 +27,11 @@ #' #' @export reset.sim <- function(time.periods=4, n=5000, ipw=TRUE, reg=TRUE) { + validate_positive_whole_number(time.periods, "time.periods") + validate_positive_whole_number(n, "n") + validate_logical_scalar(ipw, "ipw") + validate_logical_scalar(reg, "reg") + #----------------------------------------------------------------------------- # set parameters #----------------------------------------------------------------------------- @@ -90,6 +95,8 @@ reset.sim <- function(time.periods=4, n=5000, ipw=TRUE, reg=TRUE) { #' #' @export build_sim_dataset <- function(sp_list, panel=TRUE) { + validate_logical_scalar(panel, "panel") + #----------------------------------------------------------------------------- # build dataset #----------------------------------------------------------------------------- @@ -109,6 +116,10 @@ build_sim_dataset <- function(sp_list, panel=TRUE) { gamG <- sp_list$gamG ipw <- sp_list$ipw reg <- sp_list$reg + validate_positive_whole_number(time.periods, "sp_list$time.periods") + validate_positive_whole_number(n, "sp_list$n") + validate_logical_scalar(ipw, "sp_list$ipw") + validate_logical_scalar(reg, "sp_list$reg") X <- rnorm(n) @@ -259,6 +270,15 @@ sim <- function(sp_list, est_method="dr", clustervars=NULL, panel=TRUE) { + validate_logical_scalar(bstrap, "bstrap") + validate_logical_scalar(cband, "cband") + validate_logical_scalar(panel, "panel") + validate_optional_choice_scalar( + ret, + "ret", + c("Wpval", "cband", "simple", "dynamic", "notyettreated"), + "ret must be NULL or one of 'Wpval', 'cband', 'simple', 'dynamic', or 'notyettreated'." + ) ddf <- build_sim_dataset(sp_list=sp_list, panel=panel) diff --git a/R/utility_functions.R b/R/utility_functions.R index 8de5e0bd..96e1a315 100644 --- a/R/utility_functions.R +++ b/R/utility_functions.R @@ -121,11 +121,12 @@ validate_anticipation <- function(anticipation) { if (!is.numeric(anticipation)) { stop("anticipation must be numeric. Please convert it.") } - if (length(anticipation) != 1L || is.na(anticipation)) { - stop("anticipation must be a single non-missing number. Please check your arguments.") + if (length(anticipation) != 1L || is.na(anticipation) || + !is.finite(anticipation)) { + stop("anticipation must be a single finite non-missing number. Please check your arguments.") } - if (anticipation < 0) { - stop("anticipation must be non-negative. Please check your arguments.") + if (anticipation < 0 || anticipation != round(anticipation)) { + stop("anticipation must be a non-negative whole number. Please check your arguments.") } invisible(anticipation) } @@ -144,21 +145,49 @@ validate_numeric_scalar <- function(x, name) { invisible(x) } -validate_alp <- function(alp) { +validate_positive_numeric_scalar <- function(x, name) { + if (!is.numeric(x) || length(x) != 1L || is.na(x) || + !is.finite(x) || x <= 0) { + stop(name, " must be a single positive finite number.") + } + invisible(x) +} + +validate_alp <- function(alp, name = "alp") { if (!is.numeric(alp) || length(alp) != 1 || is.na(alp) || alp <= 0 || alp >= 1) { - stop("alp must be a single number strictly between 0 and 1.") + stop(name, " must be a single number strictly between 0 and 1.") } invisible(alp) } validate_positive_whole_number <- function(x, name) { if (!is.numeric(x) || length(x) != 1 || is.na(x) || - x < 1 || x != round(x)) { + !is.finite(x) || x < 1 || x != round(x)) { stop(name, " must be a single positive whole number.") } invisible(x) } +validate_choice_scalar <- function(x, name, choices, message = NULL) { + if (!is.character(x) || length(x) != 1L || is.na(x) || !(x %in% choices)) { + if (is.null(message)) { + message <- paste0(name, " must be one of: ", paste(choices, collapse = ", "), ".") + } + stop(message) + } + invisible(x) +} + +validate_optional_choice_scalar <- function(x, name, choices, message = NULL) { + if (is.null(x)) return(invisible(x)) + validate_choice_scalar(x, name, choices, message) +} + +validate_optional_numeric_scalar <- function(x, name) { + if (is.null(x)) return(invisible(x)) + validate_numeric_scalar(x, name) +} + #' @title get_wide_data #' @description A utility function to convert long data to wide data, i.e., takes a 2 period dataset and turns it into a cross sectional dataset. #' diff --git a/tests/testthat/test-error-handling.R b/tests/testthat/test-error-handling.R index 27e2837b..fa22e3b2 100644 --- a/tests/testthat/test-error-handling.R +++ b/tests/testthat/test-error-handling.R @@ -43,12 +43,24 @@ test_that("att_gt rejects non-exact control_group and base_period values in both bstrap = FALSE), "control_group must be either" ) + expect_error( + att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", + gname = "G", control_group = c("nevertreated", "notyettreated"), + faster_mode = fm, bstrap = FALSE), + "control_group must be either" + ) expect_error( att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", gname = "G", base_period = "Universal", faster_mode = fm, bstrap = FALSE), "base_period must be either" ) + expect_error( + att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", + gname = "G", base_period = c("varying", "universal"), + faster_mode = fm, bstrap = FALSE), + "base_period must be either" + ) } }) @@ -57,7 +69,7 @@ test_that("att_gt rejects negative or non-numeric anticipation in both modes", { expect_error( att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", gname = "G", anticipation = -1, faster_mode = fm, bstrap = FALSE), - "anticipation must be non-negative" + "anticipation must be a non-negative whole number" ) expect_error( att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", @@ -67,12 +79,22 @@ test_that("att_gt rejects negative or non-numeric anticipation in both modes", { expect_error( att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", gname = "G", anticipation = c(0, 1), faster_mode = fm, bstrap = FALSE), - "anticipation must be a single non-missing number" + "anticipation must be a single finite non-missing number" ) expect_error( att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", gname = "G", anticipation = NA_real_, faster_mode = fm, bstrap = FALSE), - "anticipation must be a single non-missing number" + "anticipation must be a single finite non-missing number" + ) + expect_error( + att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", + gname = "G", anticipation = Inf, faster_mode = fm, bstrap = FALSE), + "anticipation must be a single finite non-missing number" + ) + expect_error( + att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", + gname = "G", anticipation = 1.5, faster_mode = fm, bstrap = FALSE), + "anticipation must be a non-negative whole number" ) } }) @@ -101,7 +123,7 @@ test_that("att_gt rejects invalid scalar logical controls before base R errors", }) test_that("att_gt rejects invalid cores before parallel code sees it", { - for (bad_cores in list(0, -1, 1.5, c(1, 2), "2", NA_real_)) { + for (bad_cores in list(0, -1, 1.5, c(1, 2), "2", NA_real_, Inf)) { expect_error( att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", gname = "G", cores = bad_cores, bstrap = FALSE), @@ -176,7 +198,7 @@ test_that("att_gt errors on invalid alp", { }) test_that("att_gt errors on invalid biters when bootstrapping", { - for (bad_biters in list(-5, 0, 2.5, c(100, 200), "100", NA_real_)) { + for (bad_biters in list(-5, 0, 2.5, c(100, 200), "100", NA_real_, Inf)) { expect_error( att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", gname = "G", bstrap = TRUE, biters = bad_biters), @@ -191,6 +213,34 @@ test_that("att_gt errors on invalid biters when bootstrapping", { expect_s3_class(res, "MP") }) +test_that("simulation helpers reject invalid scalar controls before raw R errors", { + expect_error(did::reset.sim(time.periods = NA_integer_), + "time.periods must be a single positive whole number") + expect_error(did::reset.sim(n = 0), + "n must be a single positive whole number") + expect_error(did::reset.sim(ipw = NA), + "ipw must be a single logical") + expect_error(did::reset.sim(reg = c(TRUE, FALSE)), + "reg must be a single logical") + + expect_error(did::build_sim_dataset(sp, panel = NA), + "panel must be a single logical") + sp_bad <- sp + sp_bad$ipw <- NA + expect_error(did::build_sim_dataset(sp_bad), + "sp_list\\$ipw must be a single logical") + + expect_error(did::sim(sp, ret = NA, bstrap = FALSE, cband = FALSE), + "ret must be NULL or one of") + expect_error(did::sim(sp, ret = c("Wpval", "cband"), + bstrap = FALSE, cband = FALSE), + "ret must be NULL or one of") + expect_error(did::sim(sp, bstrap = NA, cband = FALSE), + "bstrap must be a single logical") + expect_error(did::sim(sp, bstrap = FALSE, cband = NA), + "cband must be a single logical") +}) + test_that("aggte rejects invalid scalar controls before base R errors", { mp <- suppressWarnings(suppressMessages( att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", @@ -212,6 +262,57 @@ test_that("aggte rejects invalid scalar controls before base R errors", { "balance_e must be a single non-missing number") }) +test_that("plotting helpers reject invalid scalar controls before ggplot errors", { + mp <- suppressWarnings(suppressMessages( + att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", + gname = "G", bstrap = FALSE) + )) + expect_error(ggdid(mp, legend = NA), + "legend must be a single logical") + expect_error(ggdid(mp, theming = NA), + "theming must be a single logical") + expect_error(ggdid(mp, xgap = NA_real_), + "xgap must be a single positive finite number") + expect_error(ggdid(mp, ncol = NA_real_), + "ncol must be a single positive whole number") + + agg <- aggte(mp, type = "group", cband = FALSE) + expect_error(ggdid(agg, legend = NA), + "legend must be a single logical") + expect_error(ggdid(agg, ref_line = c(0, 1)), + "ref_line must be a single non-missing number") +}) + +test_that("mboot rejects invalid scalar controls before bootstrap internals", { + mp <- suppressWarnings(suppressMessages( + att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", + gname = "G", bstrap = FALSE) + )) + inf <- mp$inffunc[, 1, drop = FALSE] + dp <- mp$DIDparams + dp$biters <- 10 + + expect_error(mboot(inf, dp, pl = NA), + "pl must be a single logical") + expect_error(mboot(inf, dp, cores = NA_real_), + "cores must be a single positive whole number") + expect_error(mboot(inf, dp, return_V = NA), + "return_V must be a single logical") + + dp_bad <- dp + dp_bad$biters <- Inf + expect_error(mboot(inf, dp_bad), + "biters must be a single positive whole number") + dp_bad <- dp + dp_bad$alp <- NA_real_ + expect_error(mboot(inf, dp_bad), + "alp must be a single number strictly between 0 and 1") + dp_bad <- dp + dp_bad$panel <- NA + expect_error(mboot(inf, dp_bad), + "DIDparams\\$panel must be a single logical") +}) + test_that("att_gt errors on fix_weights with panel=FALSE", { expect_error( att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", @@ -465,6 +566,14 @@ test_that("aggte errors on invalid type", { aggte(mp_tmp, type = "invalid"), "must be one of" ) + expect_error( + aggte(mp_tmp, type = c("simple", "group")), + "must be one of" + ) + expect_error( + aggte(mp_tmp, type = NA_character_), + "must be one of" + ) }) test_that("aggte errors when ATTs contain NA and na.rm=FALSE", { From 1835bb0966503a77cb609e5fe52abf72954ad0b1 Mon Sep 17 00:00:00 2001 From: pedrohcgs Date: Fri, 19 Jun 2026 11:25:06 -0400 Subject: [PATCH 3/4] Harden validation and preprocessing edge cases --- R/compute.aggte.R | 15 +- R/conditional_did_pretest.R | 16 ++ R/mboot.R | 9 +- R/pre_process_did.R | 32 ++-- R/pre_process_did2.R | 18 +- R/process_attgt.R | 43 +++-- R/simulate_data.R | 13 ++ R/utility_functions.R | 115 ++++++++++++- tests/testthat/test-error-handling.R | 219 +++++++++++++++++++++++- tests/testthat/test-modelmatrix-hoist.R | 20 +++ tests/testthat/test-mutation-safety.R | 33 ++++ tests/testthat/test-robustness-guards.R | 19 +- 12 files changed, 498 insertions(+), 54 deletions(-) create mode 100644 tests/testthat/test-mutation-safety.R diff --git a/R/compute.aggte.R b/R/compute.aggte.R index 71c6145b..47395a89 100644 --- a/R/compute.aggte.R +++ b/R/compute.aggte.R @@ -24,6 +24,10 @@ compute.aggte <- function(MP, alp = NULL, clustervars = NULL, call = NULL) { + if (!inherits(MP, "MP")) { + stop("MP must be an MP object produced by att_gt().") + } + #----------------------------------------------------------------------------- # unpack MP object #----------------------------------------------------------------------------- @@ -44,7 +48,7 @@ compute.aggte <- function(MP, ) validate_numeric_scalar(min_e, "min_e") validate_numeric_scalar(max_e, "max_e") - if (!is.null(balance_e)) validate_numeric_scalar(balance_e, "balance_e") + if (!is.null(balance_e)) validate_nonnegative_whole_number(balance_e, "balance_e") # aggte() needs the influence functions to aggregate and to compute standard errors. # They are absent when att_gt() was run with compute_inffunc = FALSE (point estimates only). @@ -53,6 +57,15 @@ compute.aggte <- function(MP, "only), so it has no influence functions and cannot be aggregated by aggte(). ", "Re-run att_gt() with compute_inffunc = TRUE (the default) to use aggte().") } + if (length(group) != length(t) || length(att) != length(group)) { + stop("MP object has inconsistent group, time, and att lengths.") + } + if (NCOL(inffunc1) != length(att)) { + stop("MP object has inconsistent influence-function columns and att estimates.") + } + if (!is.null(n) && NROW(inffunc1) != n) { + stop("MP object has inconsistent influence-function rows and n.") + } gname <- dp$gname diff --git a/R/conditional_did_pretest.R b/R/conditional_did_pretest.R index 754b935e..79a977b0 100644 --- a/R/conditional_did_pretest.R +++ b/R/conditional_did_pretest.R @@ -367,6 +367,13 @@ indicator <- function(X, u) { #' @export test.mboot <- function(inf.func, DIDparams, cores=1) { validate_positive_whole_number(cores, "cores") + if (!is.numeric(inf.func) || length(dim(inf.func)) != 3L || + any(dim(inf.func) <= 0L)) { + stop("inf.func must be a numeric three-dimensional array with positive dimensions.") + } + if (!is.list(DIDparams)) { + stop("DIDparams must be a list or DIDparams object.") + } # setup needed variables data <- DIDparams$data @@ -374,6 +381,12 @@ test.mboot <- function(inf.func, DIDparams, cores=1) { clustervars <- DIDparams$clustervars biters <- DIDparams$biters tname <- DIDparams$tname + if (!is.data.frame(data)) { + stop("DIDparams$data must be a data.frame.") + } + validate_column_name(idname, "DIDparams$idname", names(data)) + validate_column_name(tname, "DIDparams$tname", names(data)) + validate_column_names(clustervars, "DIDparams$clustervars", names(data), allow_null = TRUE) tlist <- unique(data[,tname])[order(unique(data[,tname]))] alp <- DIDparams$alp panel <- DIDparams$panel @@ -388,6 +401,9 @@ test.mboot <- function(inf.func, DIDparams, cores=1) { dta <- data } n <- nrow(dta) + if (dim(inf.func)[1] != n) { + stop("inf.func first dimension must match the number of bootstrap observations.") + } # if include id as variable to cluster on # drop it as we do this automatically diff --git a/R/mboot.R b/R/mboot.R index 5cd4c90d..b8a78643 100644 --- a/R/mboot.R +++ b/R/mboot.R @@ -64,17 +64,21 @@ mboot <- function(inf.func, DIDparams, pl = FALSE, cores = 1, return_V = TRUE) { dta <- data } } + validate_column_names(clustervars, "clustervars", names(dta), allow_null = TRUE) } # Convert sparse matrix to dense for bootstrap computation inf.func <- as.matrix(inf.func) + if (!is.numeric(inf.func) || nrow(inf.func) < 1L || ncol(inf.func) < 1L) { + stop("inf.func must be a numeric matrix with at least one row and one column.") + } # set correct number of units n <- nrow(inf.func) # if include id as variable to cluster on # drop it as we do this automatically - if (idname %in% clustervars) { + if (!is.null(idname) && idname %in% clustervars) { clustervars <- clustervars[-which(clustervars==idname)] } @@ -120,6 +124,9 @@ mboot <- function(inf.func, DIDparams, pl = FALSE, cores = 1, return_V = TRUE) { n_clusters <- length(unique(dta[,clustervars])) cluster <- unique(dta[,c(idname,clustervars)])[,2] } + if (length(cluster) != n) { + stop("cluster vector length must match the number of influence-function rows.") + } cluster_sum_if <- rowsum(inf.func, cluster, reorder=TRUE) bres <- sqrt(n_clusters) * run_multiplier_bootstrap(cluster_sum_if, biters, pl, cores) } diff --git a/R/pre_process_did.R b/R/pre_process_did.R index 87400c33..e0de8968 100644 --- a/R/pre_process_did.R +++ b/R/pre_process_did.R @@ -62,16 +62,26 @@ pre_process_did <- function(yname, validate_anticipation(anticipation) validate_alp(alp) if (bstrap) validate_positive_whole_number(biters, "biters") - check_reserved_did_names(yname = yname, tname = tname, idname = idname, - gname = gname, xformla = xformla, - weightsname = weightsname, - clustervars = clustervars) + validate_xformla(xformla) # make sure dataset is a data.frame # this gets around RStudio's default of reading data as tibble if (!all( class(data) == "data.frame")) { data <- as.data.frame(data) } + data_names <- names(data) + validate_column_name(yname, "yname", data_names) + validate_column_name(tname, "tname", data_names) + validate_column_name(gname, "gname", data_names) + validate_column_name(idname, "idname", data_names, allow_null = !panel) + validate_column_name(weightsname, "weightsname", data_names, allow_null = TRUE) + validate_column_names(clustervars, "clustervars", data_names, allow_null = TRUE) + + check_reserved_did_names(yname = yname, tname = tname, idname = idname, + gname = gname, xformla = xformla, + weightsname = weightsname, + clustervars = clustervars) + # validate that all required column names exist in the data required_cols <- c(yname, tname, idname, gname, weightsname, clustervars) missing_cols <- setdiff(required_cols, colnames(data)) @@ -145,26 +155,26 @@ pre_process_did <- function(yname, # check if any covariates were missing n_orig <- nrow(data) - # drop rows with any missing id / time / outcome / group / weight / cluster or any - # missing RAW covariate value - data <- data[complete.cases(data), ] - # also drop rows whose EVALUATED design is non-finite (e.g. log of a non-positive + # drop rows with any missing or non-finite id / time / outcome / group / weight / + # cluster or RAW covariate value + data <- data[complete_finite_cases(data), ] + # also drop rows whose EVALUATED design is missing/non-finite (e.g. log of a non-positive # covariate), preserving the previous model.frame-based row dropping. We use # model.frame (NOT model.matrix) with na.action = na.pass: model.frame keeps EVERY # row -- including those where a term evaluates to NA/NaN -- so complete.cases() # flags them and the indicator stays aligned with `data`. (model.matrix would # instead silently drop the NaN rows, making the mask shorter than `data` and the - # offending rows survive.) Inf-valued terms are kept, matching the prior behavior. + # offending rows survive.) # Safe to evaluate now that raw-covariate NAs have been removed (so poly()/ns()/... # will not error on NA input). if (length(xvars) > 0L && nrow(data) > 0L) { mf_check <- suppressWarnings(model.frame(xformla, data = data, na.action = na.pass)) - finite_rows <- complete.cases(mf_check) + finite_rows <- complete_finite_cases(mf_check) if (!all(finite_rows)) data <- data[finite_rows, ] } n_diff <- n_orig - nrow(data) if (n_diff != 0) { - warning(paste0("dropped ", n_diff, " rows from original data due to missing data")) + warning(paste0("dropped ", n_diff, " rows from original data due to missing or non-finite data")) } # weights if null diff --git a/R/pre_process_did2.R b/R/pre_process_did2.R index caf486d5..a2b7ad06 100644 --- a/R/pre_process_did2.R +++ b/R/pre_process_did2.R @@ -71,14 +71,16 @@ validate_args <- function(args, data){ # Check if gname is unique by idname: irreversibility of the treatment # Use direct column access instead of get() for speed - id_g_unique <- unique(data[, c(args$idname, args$gname), with = FALSE]) + nonmissing_g <- !is.na(data[[args$idname]]) & !is.na(data[[args$gname]]) + id_g_unique <- unique(data[nonmissing_g, c(args$idname, args$gname), with = FALSE]) check_treatment_uniqueness <- anyDuplicated(id_g_unique[[1]]) == 0L if (!check_treatment_uniqueness) { stop("The value of gname (treatment variable) must be the same across all periods for each particular unit. The treatment must be irreversible.") } # Check if any combination of idname and tname is duplicated - n_id_year <- anyDuplicated(data, by = c(args$idname, args$tname)) + nonmissing_id_time <- !is.na(data[[args$idname]]) & !is.na(data[[args$tname]]) + n_id_year <- anyDuplicated(data[nonmissing_id_time], by = c(args$idname, args$tname)) # If any combination is duplicated, stop execution and throw an error if (n_id_year > 0) { stop("The value of idname must be unique (by tname). Some units are observed more than once in a period.") @@ -143,23 +145,22 @@ did_standardization <- function(data, args){ # Check if any covariates were missing n_orig <- data[, .N] - data <- data[complete.cases(data)] - # also drop rows whose EVALUATED design is non-finite (e.g. log of a non-positive + data <- data[complete_finite_cases(data)] + # also drop rows whose EVALUATED design is missing/non-finite (e.g. log of a non-positive # covariate); safe now that raw-covariate NAs are removed (so poly()/ns()/... will # not error on NA input). Use model.frame (NOT model.matrix) with na.action = # na.pass: model.frame keeps every row -- including NA/NaN-valued terms -- so the # complete.cases() mask stays aligned with `data` (model.matrix would silently drop - # NaN rows, shortening the mask and letting the offending rows survive). Inf-valued - # terms are kept, matching the prior behavior. + # NaN rows, shortening the mask and letting the offending rows survive). if (length(xvars) > 0L && data[, .N] > 0L) { mf_check <- suppressWarnings(model.frame(args$xformla, data = data, na.action = na.pass)) - finite_rows <- complete.cases(mf_check) + finite_rows <- complete_finite_cases(mf_check) if (!all(finite_rows)) data <- data[finite_rows] } n_new <- data[, .N] n_diff <- n_orig - n_new if (n_diff != 0) { - warning(paste0("dropped ", n_diff, " rows from original data due to missing data")) + warning(paste0("dropped ", n_diff, " rows from original data due to missing or non-finite data")) } # Set weights @@ -684,6 +685,7 @@ pre_process_did2 <- function(yname, cores = 1, call = NULL) { + validate_xformla(xformla) # coerce data to data.table first, keeping only the columns the pipeline uses # (id/time/group/outcome/weights/cluster plus the raw xformla variables) so wide diff --git a/R/process_attgt.R b/R/process_attgt.R index 49c9fcd3..10dd5e7b 100644 --- a/R/process_attgt.R +++ b/R/process_attgt.R @@ -2,16 +2,33 @@ #' #' @param attgt.list list of results from [compute.att_gt()] #' -#' @return list with elements: -#' \item{group}{which group a set of results belongs to} -#' \item{tt}{which time period a set of results belongs to} -#' \item{att}{the group time average treatment effect} -#' -#' @export -process_attgt <- function(attgt.list) { - group <- vapply(attgt.list, function(x) as.numeric(x[["group"]]), numeric(1)) - att <- vapply(attgt.list, function(x) as.numeric(x[["att"]]), numeric(1)) - tt <- vapply(attgt.list, function(x) as.numeric(x[["year"]]), numeric(1)) - - list(group=group, att=att, tt=tt) -} +#' @return list with elements: +#' \item{group}{which group a set of results belongs to} +#' \item{tt}{which time period a set of results belongs to} +#' \item{att}{the group time average treatment effect} +#' +#' @export +process_attgt <- function(attgt.list) { + if (!is.list(attgt.list) || length(attgt.list) == 0L) { + stop("attgt.list must be a non-empty list of group-time result objects.") + } + get_cell_value <- function(x, field, allow_na = FALSE) { + if (!is.list(x)) { + stop("Each attgt.list element must be a list-like group-time result object.") + } + value <- x[[field]] + if (allow_na && length(value) == 1L && is.na(value)) { + return(as.numeric(value)) + } + if (!is.numeric(value) || length(value) != 1L || + (!allow_na && is.na(value))) { + stop("Each attgt.list element must contain a numeric scalar '", field, "'.") + } + value + } + group <- vapply(attgt.list, get_cell_value, numeric(1), field = "group") + att <- vapply(attgt.list, get_cell_value, numeric(1), field = "att", allow_na = TRUE) + tt <- vapply(attgt.list, get_cell_value, numeric(1), field = "year") + + list(group=group, att=att, tt=tt) +} diff --git a/R/simulate_data.R b/R/simulate_data.R index ff14599e..0fd69d77 100644 --- a/R/simulate_data.R +++ b/R/simulate_data.R @@ -96,6 +96,9 @@ reset.sim <- function(time.periods=4, n=5000, ipw=TRUE, reg=TRUE) { #' @export build_sim_dataset <- function(sp_list, panel=TRUE) { validate_logical_scalar(panel, "panel") + if (!is.list(sp_list)) { + stop("sp_list must be a list of simulation parameters.") + } #----------------------------------------------------------------------------- # build dataset @@ -120,6 +123,16 @@ build_sim_dataset <- function(sp_list, panel=TRUE) { validate_positive_whole_number(n, "sp_list$n") validate_logical_scalar(ipw, "sp_list$ipw") validate_logical_scalar(reg, "sp_list$reg") + validate_finite_numeric_vector(bett, "sp_list$bett", time.periods) + validate_finite_numeric_vector(thet, "sp_list$thet", time.periods) + validate_finite_numeric_vector(theu, "sp_list$theu", time.periods) + validate_finite_numeric_vector(betu, "sp_list$betu", time.periods) + validate_finite_numeric_vector(te.bet.ind, "sp_list$te.bet.ind", time.periods) + validate_finite_numeric_vector(te.bet.X, "sp_list$te.bet.X", time.periods) + validate_finite_numeric_vector(te.t, "sp_list$te.t", time.periods) + validate_finite_numeric_vector(te.e, "sp_list$te.e", time.periods) + validate_finite_numeric_vector(gamG, "sp_list$gamG", time.periods + 1L) + validate_finite_numeric_scalar(te, "sp_list$te") X <- rnorm(n) diff --git a/R/utility_functions.R b/R/utility_functions.R index 96e1a315..7bf2f5cb 100644 --- a/R/utility_functions.R +++ b/R/utility_functions.R @@ -14,19 +14,34 @@ #' #' @export trimmer <- function(g, tname, idname, gname, xformla, data, control_group="notyettreated", threshold=.999) { + if (!all(class(data) == "data.frame")) { + data <- as.data.frame(data) + } + validate_finite_numeric_scalar(g, "g") + validate_column_name(tname, "tname", names(data)) + validate_column_name(idname, "idname", names(data)) + validate_column_name(gname, "gname", names(data)) + validate_xformla(xformla) + validate_choice_scalar( + control_group, + "control_group", + c("nevertreated", "notyettreated"), + "control_group must be either 'nevertreated' or 'notyettreated'." + ) + validate_probability_scalar(threshold, "threshold") - time.period <- data[,tname] + time.period <- data[[tname]] this.data <- data[time.period == (g-1),] if (control_group == "notyettreated") { # not yet treated - this.data <- this.data[(this.data[,gname] >= g) | - (this.data[,gname] == 0), ] + this.data <- this.data[(this.data[[gname]] >= g) | + (this.data[[gname]] == 0), ] } else { # never treated - this.data <- this.data[(this.data[,gname] == g) | - (this.data[,gname] == 0), ] + this.data <- this.data[(this.data[[gname]] == g) | + (this.data[[gname]] == 0), ] } - this.data$D <- 1*this.data[,gname]==g + this.data$D <- 1 * this.data[[gname]] == g this.pscore_reg <- glm(BMisc::toformula("D", BMisc::rhs_vars(xformla)), data=this.data, family=binomial(link="logit")) @@ -34,8 +49,8 @@ trimmer <- function(g, tname, idname, gname, xformla, data, control_group="notye dropper <- (this.pscore > threshold) & (this.data$D==1) if (sum(dropper) > 0) { print("hard to match treated observations: ") - print(this.data[dropper,idname]) - return(this.data[dropper,idname]) + print(this.data[dropper, idname, drop = FALSE]) + return(this.data[dropper, idname, drop = FALSE]) } } @@ -117,6 +132,59 @@ check_reserved_did_names <- function(yname, tname, idname, gname, xformla, } } +validate_xformla <- function(xformla) { + if (!is.null(xformla) && !inherits(xformla, "formula")) { + stop("xformla must be NULL or a formula.") + } + invisible(xformla) +} + +validate_character_scalar <- function(x, name, allow_null = FALSE) { + if (allow_null && is.null(x)) return(invisible(x)) + if (!is.character(x) || length(x) != 1L || is.na(x) || !nzchar(x)) { + stop(name, " must be a single non-missing character string.") + } + invisible(x) +} + +validate_column_name <- function(x, name, data_names, allow_null = FALSE) { + validate_character_scalar(x, name, allow_null = allow_null) + if (is.null(x)) return(invisible(x)) + if (!(x %in% data_names)) { + stop(name, " must be a character scalar and a name of a column from the dataset.") + } + invisible(x) +} + +validate_column_names <- function(x, name, data_names, allow_null = FALSE) { + if (allow_null && is.null(x)) return(invisible(x)) + if (!is.character(x) || length(x) == 0L || anyNA(x) || any(!nzchar(x))) { + stop(name, " must be NULL or a character vector naming column(s) from the dataset.") + } + missing <- setdiff(x, data_names) + if (length(missing) > 0L) { + stop(name, " contains column name(s) not found in the dataset: ", + paste(missing, collapse = ", "), ".") + } + invisible(x) +} + +complete_finite_cases <- function(data) { + keep <- stats::complete.cases(data) + if (!length(keep)) return(keep) + for (nm in names(data)) { + x <- data[[nm]] + if (is.numeric(x)) { + finite_x <- is.finite(x) + if (!is.null(dim(finite_x)) && NROW(finite_x) == length(keep)) { + finite_x <- rowSums(!finite_x) == 0L + } + keep <- keep & as.vector(finite_x) + } + } + keep +} + validate_anticipation <- function(anticipation) { if (!is.numeric(anticipation)) { stop("anticipation must be numeric. Please convert it.") @@ -145,6 +213,21 @@ validate_numeric_scalar <- function(x, name) { invisible(x) } +validate_finite_numeric_scalar <- function(x, name) { + if (!is.numeric(x) || length(x) != 1L || is.na(x) || !is.finite(x)) { + stop(name, " must be a single finite non-missing number.") + } + invisible(x) +} + +validate_finite_numeric_vector <- function(x, name, len) { + if (!is.numeric(x) || length(x) != len || anyNA(x) || any(!is.finite(x))) { + stop(name, " must be a numeric vector of length ", len, + " with only finite non-missing values.") + } + invisible(x) +} + validate_positive_numeric_scalar <- function(x, name) { if (!is.numeric(x) || length(x) != 1L || is.na(x) || !is.finite(x) || x <= 0) { @@ -160,6 +243,14 @@ validate_alp <- function(alp, name = "alp") { invisible(alp) } +validate_probability_scalar <- function(x, name) { + if (!is.numeric(x) || length(x) != 1L || is.na(x) || + !is.finite(x) || x <= 0 || x >= 1) { + stop(name, " must be a single finite number strictly between 0 and 1.") + } + invisible(x) +} + validate_positive_whole_number <- function(x, name) { if (!is.numeric(x) || length(x) != 1 || is.na(x) || !is.finite(x) || x < 1 || x != round(x)) { @@ -168,6 +259,14 @@ validate_positive_whole_number <- function(x, name) { invisible(x) } +validate_nonnegative_whole_number <- function(x, name) { + if (!is.numeric(x) || length(x) != 1 || is.na(x) || + !is.finite(x) || x < 0 || x != round(x)) { + stop(name, " must be a single non-negative whole number.") + } + invisible(x) +} + validate_choice_scalar <- function(x, name, choices, message = NULL) { if (!is.character(x) || length(x) != 1L || is.na(x) || !(x %in% choices)) { if (is.null(message)) { diff --git a/tests/testthat/test-error-handling.R b/tests/testthat/test-error-handling.R index fa22e3b2..2aff4bd5 100644 --- a/tests/testthat/test-error-handling.R +++ b/tests/testthat/test-error-handling.R @@ -165,6 +165,71 @@ test_that("att_gt rejects argument-referenced internal variable names in both mo } }) +test_that("att_gt rejects invalid xformla before formula internals in both modes", { + for (fm in c(FALSE, TRUE)) { + for (bad_xformla in list(NA, 1, "~X", list(~X))) { + expect_error( + att_gt(yname = "Y", data = data_eh, tname = "period", + idname = "id", gname = "G", xformla = bad_xformla, + faster_mode = fm, bstrap = FALSE), + "xformla must be NULL or a formula", + info = paste("faster_mode", fm) + ) + } + } +}) + +test_that("slow path rejects malformed column-name arguments before ambiguous indexing", { + bad_args <- list( + yname = c("Y", "X"), + tname = NA_character_, + idname = c("id", "id"), + gname = c("G", "G"), + weightsname = c("w1", "w2"), + clustervars = NA_character_ + ) + + for (nm in names(bad_args)) { + args <- list(yname = "Y", data = data_eh, tname = "period", + idname = "id", gname = "G", bstrap = FALSE, + faster_mode = FALSE) + args[[nm]] <- bad_args[[nm]] + expect_error( + do.call(att_gt, args), + paste0(nm, " must|", nm, " contains"), + info = nm + ) + } +}) + +test_that("att_gt drops rows with missing gname and non-finite numeric inputs in both modes", { + cases <- list( + gname_missing = within(data_eh, G[1] <- NA_real_), + outcome_infinite = within(data_eh, Y[1] <- Inf), + weight_infinite = within(data_eh, { + w <- rep(1, nrow(data_eh)) + w[1] <- Inf + }), + covariate_infinite = within(data_eh, X[1] <- Inf) + ) + + for (fm in c(FALSE, TRUE)) { + for (nm in names(cases)) { + args <- list(yname = "Y", data = cases[[nm]], tname = "period", + idname = "id", gname = "G", bstrap = FALSE, + faster_mode = fm, panel = FALSE) + if (nm == "weight_infinite") args$weightsname <- "w" + if (nm == "covariate_infinite") args$xformla <- ~X + expect_warning( + res <- do.call(att_gt, args), + "missing or non-finite data", + info = paste(nm, "faster_mode", fm) + ) + expect_s3_class(res, "MP") + } + } +}) + test_that("att_gt errors on panel=TRUE without idname in both modes", { for (fm in c(FALSE, TRUE)) { expect_error( @@ -225,10 +290,28 @@ test_that("simulation helpers reject invalid scalar controls before raw R errors expect_error(did::build_sim_dataset(sp, panel = NA), "panel must be a single logical") + expect_error(did::build_sim_dataset(1), + "sp_list must be a list") sp_bad <- sp sp_bad$ipw <- NA expect_error(did::build_sim_dataset(sp_bad), "sp_list\\$ipw must be a single logical") + sp_bad <- sp + sp_bad$bett <- 1 + expect_error(did::build_sim_dataset(sp_bad), + "sp_list\\$bett must be a numeric vector of length") + sp_bad <- sp + sp_bad$te.e[1] <- Inf + expect_error(did::build_sim_dataset(sp_bad), + "sp_list\\$te\\.e must be a numeric vector of length") + sp_bad <- sp + sp_bad$gamG <- sp_bad$gamG[-1] + expect_error(did::build_sim_dataset(sp_bad), + "sp_list\\$gamG must be a numeric vector of length") + sp_bad <- sp + sp_bad$te <- NA_real_ + expect_error(did::build_sim_dataset(sp_bad), + "sp_list\\$te must be a single finite non-missing number") expect_error(did::sim(sp, ret = NA, bstrap = FALSE, cband = FALSE), "ret must be NULL or one of") @@ -241,11 +324,128 @@ test_that("simulation helpers reject invalid scalar controls before raw R errors "cband must be a single logical") }) +test_that("trimmer rejects malformed exported utility arguments", { + bad_control_groups <- list(NA_character_, c("notyettreated", "nevertreated"), "bad") + for (bad_control_group in bad_control_groups) { + expect_error( + trimmer(3, "period", "id", "G", ~X, data_eh, + control_group = bad_control_group), + "control_group must be either" + ) + } + + bad_thresholds <- list(NA_real_, c(0.9, 0.99), Inf, -1, "0.9") + for (bad_threshold in bad_thresholds) { + expect_error( + trimmer(3, "period", "id", "G", ~X, data_eh, + threshold = bad_threshold), + "threshold must be a single finite number strictly between 0 and 1" + ) + } + + for (bad_xformla in list(NA, "~X", 1, list(~X))) { + expect_error( + trimmer(3, "period", "id", "G", bad_xformla, data_eh), + "xformla must be NULL or a formula" + ) + } + + expect_error(trimmer(c(3, 4), "period", "id", "G", ~X, data_eh), + "g must be a single finite non-missing number") + expect_error(trimmer(NA_real_, "period", "id", "G", ~X, data_eh), + "g must be a single finite non-missing number") + expect_error(trimmer(3, c("period", "period"), "id", "G", ~X, data_eh), + "tname must be a single non-missing character string") + expect_error(trimmer(3, "period", NA_character_, "G", ~X, data_eh), + "idname must be a single non-missing character string") + expect_error(trimmer(3, "period", "id", "missing", ~X, data_eh), + "gname must be a character scalar and a name of a column") +}) + +test_that("test.mboot rejects malformed bootstrap inputs before recycling", { + inf_func <- array(rnorm(10 * 2 * 5), c(10, 2, 5)) + dp <- list(data = data.frame(id = 1:10, period = 1L, cl = rep(1:2, each = 5)), + idname = "id", clustervars = NULL, biters = 20, + tname = "period", alp = 0.05, panel = TRUE) + + expect_error(test.mboot(matrix(rnorm(20), 10, 2), dp), + "inf.func must be a numeric three-dimensional array") + expect_error(test.mboot(array(numeric(0), c(0, 2, 5)), dp), + "inf.func must be a numeric three-dimensional array") + expect_error(test.mboot("bad", dp), + "inf.func must be a numeric three-dimensional array") + expect_error(test.mboot(inf_func, 1), + "DIDparams must be a list") + + dp_bad <- dp + dp_bad$idname <- "missing" + expect_error(test.mboot(inf_func, dp_bad), + "DIDparams\\$idname must be a character scalar and a name of a column") + dp_bad <- dp + dp_bad$clustervars <- 1 + expect_error(test.mboot(inf_func, dp_bad), + "DIDparams\\$clustervars must be NULL or a character vector") + dp_bad <- dp + dp_bad$data <- dp_bad$data[-1, ] + expect_error(test.mboot(inf_func, dp_bad), + "inf.func first dimension must match") +}) + +test_that("mboot rejects malformed direct helper inputs before raw errors", { + inf_func <- matrix(rnorm(10 * 2), 10, 2) + dp <- list(data = data.frame(id = 1:10, period = 1L, cl = rep(1:2, each = 5)), + idname = "id", clustervars = NULL, biters = 20, + tname = "period", alp = 0.05, panel = TRUE, + true_repeated_cross_sections = FALSE, + allow_unbalanced_panel = FALSE, faster_mode = FALSE) + + expect_error(mboot(numeric(0), dp, return_V = FALSE), + "inf.func must be a numeric matrix") + expect_error(mboot(matrix(numeric(0), 0, 2), dp, return_V = FALSE), + "inf.func must be a numeric matrix") + expect_error(mboot("bad", dp, return_V = FALSE), + "inf.func must be a numeric matrix") + + dp_bad <- dp + dp_bad$clustervars <- 1 + expect_error(mboot(inf_func, dp_bad, return_V = FALSE), + "clustervars must be NULL or a character vector") + dp_bad <- dp + dp_bad$clustervars <- "missing" + expect_error(mboot(inf_func, dp_bad, return_V = FALSE), + "clustervars contains column name") + dp_bad <- dp + dp_bad$clustervars <- "cl" + dp_bad$data <- dp_bad$data[-1, ] + expect_error(mboot(inf_func, dp_bad, return_V = FALSE), + "cluster vector length must match") +}) + +test_that("process_attgt rejects malformed group-time result lists", { + expect_error(process_attgt(1), + "attgt.list must be a non-empty list") + expect_error(process_attgt(list()), + "attgt.list must be a non-empty list") + expect_error(process_attgt(list(1)), + "Each attgt.list element must be a list-like") + expect_error(process_attgt(list(list(group = c(1, 2), year = 1, att = 0))), + "numeric scalar 'group'") + expect_error(process_attgt(list(list(group = 1, year = NA_real_, att = 0))), + "numeric scalar 'year'") + + out <- process_attgt(list(list(group = 1, year = 2, att = NA_real_))) + expect_equal(out$group, 1) + expect_equal(out$tt, 2) + expect_true(is.na(out$att)) +}) + test_that("aggte rejects invalid scalar controls before base R errors", { mp <- suppressWarnings(suppressMessages( att_gt(yname = "Y", data = data_eh, tname = "period", idname = "id", gname = "G", bstrap = FALSE) )) + expect_error(aggte(1), + "MP must be an MP object produced by att_gt") expect_error(aggte(mp, type = "simple", na.rm = NA), "na.rm must be a single logical") expect_error(aggte(mp, type = "simple", bstrap = NA), @@ -259,7 +459,22 @@ test_that("aggte rejects invalid scalar controls before base R errors", { expect_error(aggte(mp, type = "dynamic", min_e = NA_real_), "min_e must be a single non-missing number") expect_error(aggte(mp, type = "dynamic", balance_e = c(0, 1)), - "balance_e must be a single non-missing number") + "balance_e must be a single non-negative whole number") + expect_error(aggte(mp, type = "dynamic", balance_e = -1), + "balance_e must be a single non-negative whole number") + expect_error(aggte(mp, type = "dynamic", balance_e = 0.5), + "balance_e must be a single non-negative whole number") + expect_error(aggte(mp, type = "dynamic", balance_e = Inf), + "balance_e must be a single non-negative whole number") + + mp_bad <- mp + mp_bad$inffunc <- mp_bad$inffunc[, -1, drop = FALSE] + expect_error(aggte(mp_bad, type = "simple"), + "inconsistent influence-function columns") + mp_bad <- mp + mp_bad$inffunc <- mp_bad$inffunc[-1, , drop = FALSE] + expect_error(aggte(mp_bad, type = "simple"), + "inconsistent influence-function rows") }) test_that("plotting helpers reject invalid scalar controls before ggplot errors", { @@ -361,7 +576,7 @@ test_that("att_gt errors on missing column name (slower mode)", { expect_error( att_gt(yname = "nonexistent", data = data_eh, tname = "period", idname = "id", gname = "G", bstrap = FALSE, faster_mode = FALSE), - "not found" + "character scalar and a name of a column" ) }) diff --git a/tests/testthat/test-modelmatrix-hoist.R b/tests/testthat/test-modelmatrix-hoist.R index 32087ce9..877ef044 100644 --- a/tests/testthat/test-modelmatrix-hoist.R +++ b/tests/testthat/test-modelmatrix-hoist.R @@ -210,6 +210,26 @@ test_that("transform formulae that evaluate to NaN drop those rows instead of cr expect_equal(rs$att, rref$att, tolerance = 1e-12) }) +test_that("matrix-valued transformed formula terms drop non-finite rows row-wise", { + set.seed(20260619) + data <- did::build_sim_dataset(did::reset.sim(n = 500)) + data$Xpos <- exp(data$X) + data$Xpos[data$id == unique(data$id)[1]] <- 0 + f <- ~I(cbind(log(Xpos), X^2)) + + for (fm in c(FALSE, TRUE)) { + expect_warning( + res <- att_gt(yname = "Y", xformla = f, data = data, + tname = "period", idname = "id", gname = "G", + bstrap = FALSE, faster_mode = fm), + "missing or non-finite data", + info = paste("faster_mode", fm) + ) + expect_s3_class(res, "MP") + expect_false(anyNA(res$att)) + } +}) + test_that("a globally-empty factor level is dropped instead of NA-failing every cell", { # Regression: factor(levels = c('a','b','c')) where 'c' never occurs in the data # (common after users subset their data, since R keeps empty levels) used to emit diff --git a/tests/testthat/test-mutation-safety.R b/tests/testthat/test-mutation-safety.R new file mode 100644 index 00000000..bca3a691 --- /dev/null +++ b/tests/testthat/test-mutation-safety.R @@ -0,0 +1,33 @@ +test_that("att_gt does not mutate caller data in either implementation", { + set.seed(20260619) + sp <- did::reset.sim(n = 500) + panel_data <- did::build_sim_dataset(sp) + rc_data <- did::build_sim_dataset(sp, panel = FALSE) + + cases <- list( + panel_df = list(data = as.data.frame(panel_data), panel = TRUE), + panel_dt = list(data = data.table::as.data.table(panel_data), panel = TRUE), + rc_df = list(data = as.data.frame(rc_data), panel = FALSE), + rc_dt = list(data = data.table::as.data.table(rc_data), panel = FALSE) + ) + + for (case_name in names(cases)) { + for (fm in c(FALSE, TRUE)) { + d <- cases[[case_name]]$data + before_names <- names(d) + before_data <- as.data.frame(d) + + suppressWarnings(suppressMessages( + att_gt(yname = "Y", tname = "period", idname = "id", gname = "G", + xformla = ~X, data = d, panel = cases[[case_name]]$panel, + bstrap = FALSE, faster_mode = fm) + )) + + expect_identical(names(d), before_names, + info = paste(case_name, "faster_mode", fm)) + expect_equal(as.data.frame(d), before_data, + ignore_attr = TRUE, + info = paste(case_name, "faster_mode", fm)) + } + } +}) diff --git a/tests/testthat/test-robustness-guards.R b/tests/testthat/test-robustness-guards.R index 9a27b587..26fa4aff 100644 --- a/tests/testthat/test-robustness-guards.R +++ b/tests/testthat/test-robustness-guards.R @@ -139,12 +139,12 @@ test_that("fast path preserves user columns named weights", { expect_equal(slow_x$se, fast_x$se, tolerance = 1e-8) }) -test_that("slow RC path NA-cells a throwing preliminary logit instead of aborting att_gt", { +test_that("transformed non-finite covariates are dropped before RC overlap checks", { # Regression test: a -Inf covariate (log(0), reachable via transform-formula - # support) makes overlap_logit_fit() throw. The slow RC branch used to run the - # overlap/rcond guards OUTSIDE the per-cell tryCatch, hard-aborting the whole - # att_gt() call while the fast path and the slow panel path degraded to NA - # cells with a warning. Both modes must now fail identically, cell by cell. + # support) used to reach overlap_logit_fit() and degrade affected cells to NA. + # Preprocessing now drops those rows before either implementation builds 2x2 + # cells, so both modes should warn once, estimate the remaining cells, and + # stay numerically aligned. set.seed(20260609) sp <- did::reset.sim(time.periods = 4, n = 400) d <- did::build_sim_dataset(sp) @@ -160,11 +160,10 @@ test_that("slow RC path NA-cells a throwing preliminary logit instead of abortin tname = "period", idname = "id", gname = "G", panel = FALSE, est_method = "dr", faster_mode = TRUE, bstrap = FALSE))) - expect_true(any(grepl("Error computing internal 2x2 DiD", w_slow))) - expect_true(any(grepl("Error computing internal 2x2 DiD", w_fast))) - expect_true(any(is.na(slow$att))) # affected cells degrade to NA - expect_true(any(is.finite(slow$att))) # healthy cells still estimated - expect_equal(is.na(slow$att), is.na(fast$att)) + expect_identical(w_slow, "dropped 4 rows from original data due to missing or non-finite data") + expect_identical(w_fast, w_slow) + expect_false(any(grepl("Error computing internal 2x2 DiD", w_slow))) + expect_false(any(is.na(slow$att))) expect_equal(slow$att, fast$att, tolerance = 1e-10) expect_equal(slow$se, fast$se, tolerance = 1e-10) }) From 622d7cec474790934cdaeb68c82c5c38c0711426 Mon Sep 17 00:00:00 2001 From: pedrohcgs Date: Fri, 19 Jun 2026 12:27:05 -0400 Subject: [PATCH 4/4] Preserve gname = Inf never-treated units in finite-data filter The hardening pass replaced complete.cases() with complete_finite_cases() in both preprocessing paths, which dropped any row with a non-finite value in a numeric column. gname == Inf is a documented never-treated code ("group status 0 or Inf"), so that filter silently deleted every never-treated unit: under control_group = "notyettreated" it warned and dropped them, and under control_group = "nevertreated" it returned plausible-looking but wrong ATTs with no error. Add a finite_exclude argument to complete_finite_cases() and pass gname in both pre_process_did() and pre_process_did2(). Excluded columns still get the NA/NaN check via complete.cases(); only legitimate Inf is preserved. Restores parity with master, where gname = Inf is bit-identical to gname = 0. Add regression tests: gname = Inf equals gname = 0 (ATT and influence functions) across both code paths and both control groups, plus a complete_finite_cases() unit test confirming NA/NaN gname is still dropped. --- R/pre_process_did.R | 8 +++-- R/pre_process_did2.R | 4 ++- R/utility_functions.R | 7 ++++- tests/testthat/test-robustness-guards.R | 40 +++++++++++++++++++++++++ 4 files changed, 54 insertions(+), 5 deletions(-) diff --git a/R/pre_process_did.R b/R/pre_process_did.R index e0de8968..72746341 100644 --- a/R/pre_process_did.R +++ b/R/pre_process_did.R @@ -155,9 +155,11 @@ pre_process_did <- function(yname, # check if any covariates were missing n_orig <- nrow(data) - # drop rows with any missing or non-finite id / time / outcome / group / weight / - # cluster or RAW covariate value - data <- data[complete_finite_cases(data), ] + # drop rows with any missing or non-finite id / time / outcome / weight / + # cluster or RAW covariate value. gname is excluded from the finite check + # because Inf is a valid never-treated code there (see complete_finite_cases); + # missing/NaN gname is still dropped via complete.cases(). + data <- data[complete_finite_cases(data, finite_exclude = gname), ] # also drop rows whose EVALUATED design is missing/non-finite (e.g. log of a non-positive # covariate), preserving the previous model.frame-based row dropping. We use # model.frame (NOT model.matrix) with na.action = na.pass: model.frame keeps EVERY diff --git a/R/pre_process_did2.R b/R/pre_process_did2.R index a2b7ad06..2638b2fe 100644 --- a/R/pre_process_did2.R +++ b/R/pre_process_did2.R @@ -145,7 +145,9 @@ did_standardization <- function(data, args){ # Check if any covariates were missing n_orig <- data[, .N] - data <- data[complete_finite_cases(data)] + # gname is excluded from the finite check because Inf is a valid never-treated + # code there (see complete_finite_cases); missing/NaN gname is still dropped. + data <- data[complete_finite_cases(data, finite_exclude = args$gname)] # also drop rows whose EVALUATED design is missing/non-finite (e.g. log of a non-positive # covariate); safe now that raw-covariate NAs are removed (so poly()/ns()/... will # not error on NA input). Use model.frame (NOT model.matrix) with na.action = diff --git a/R/utility_functions.R b/R/utility_functions.R index 7bf2f5cb..16fa1fdf 100644 --- a/R/utility_functions.R +++ b/R/utility_functions.R @@ -169,10 +169,15 @@ validate_column_names <- function(x, name, data_names, allow_null = FALSE) { invisible(x) } -complete_finite_cases <- function(data) { +complete_finite_cases <- function(data, finite_exclude = character(0)) { keep <- stats::complete.cases(data) if (!length(keep)) return(keep) for (nm in names(data)) { + # Columns in finite_exclude still get the NA/NaN check via complete.cases() + # above, but skip the is.finite() check below. This preserves Inf in such + # columns -- notably gname, where Inf is a documented never-treated code + # ("group status 0 or Inf") that must NOT be dropped as if it were bad data. + if (nm %in% finite_exclude) next x <- data[[nm]] if (is.numeric(x)) { finite_x <- is.finite(x) diff --git a/tests/testthat/test-robustness-guards.R b/tests/testthat/test-robustness-guards.R index 26fa4aff..7e1f4c0d 100644 --- a/tests/testthat/test-robustness-guards.R +++ b/tests/testthat/test-robustness-guards.R @@ -216,3 +216,43 @@ test_that("slow panel path converts estimator NaN cells to NA like fast mode", { expect_false(any(is.nan(slow$att))) expect_equal(is.na(slow$att), is.na(fast$att)) }) + +test_that("never-treated units coded as gname = Inf are NOT dropped (Inf is a valid never-treated code)", { + # Regression test: complete_finite_cases() must exclude gname from its + # is.finite() filter. Inf is a documented never-treated code (att_gt() reports + # "group status 0 or Inf"); on master gname = Inf produces results identical to + # gname = 0. A naive "drop all non-finite numeric rows" filter silently deletes + # every never-treated unit -- erroring or, worse (control_group="nevertreated"), + # returning plausible-looking but WRONG estimates with no error. + data(mpdta, package = "did") + d_inf <- mpdta + d_inf$first.treat[d_inf$first.treat == 0] <- Inf + + for (fm in c(TRUE, FALSE)) { + for (cg in c("nevertreated", "notyettreated")) { + ref <- suppressWarnings(suppressMessages(att_gt(yname = "lemp", tname = "year", + idname = "countyreal", gname = "first.treat", xformla = ~lpop, data = mpdta, + control_group = cg, faster_mode = fm, bstrap = FALSE, cband = FALSE))) + inf <- suppressWarnings(suppressMessages(att_gt(yname = "lemp", tname = "year", + idname = "countyreal", gname = "first.treat", xformla = ~lpop, data = d_inf, + control_group = cg, faster_mode = fm, bstrap = FALSE, cband = FALSE))) + # never-treated units must survive: same number of influence-function rows + expect_equal(nrow(inf$inffunc), nrow(ref$inffunc)) + expect_equal(inf$att, ref$att, tolerance = 1e-10) + expect_equal(inf$inffunc, ref$inffunc, tolerance = 1e-10) + } + } +}) + +test_that("NA / NaN gname rows are still dropped while Inf is preserved", { + # The finite-exclude carve-out for gname must not also disable the NA/NaN check: + # complete.cases() still removes missing/NaN gname rows. + df <- data.frame(g = c(0, Inf, NA, NaN, 5), + y = c(1, 2, 3, 4, Inf), + x = c(1, 2, 3, 4, 5)) + expect_equal(complete_finite_cases(df, finite_exclude = "g"), + c(TRUE, TRUE, FALSE, FALSE, FALSE)) + # without the carve-out, the Inf-coded never-treated row would also be dropped + expect_equal(complete_finite_cases(df), + c(TRUE, FALSE, FALSE, FALSE, FALSE)) +})