From b864446a633f8123494637e452db2c548db5b62e Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 17:41:38 -0400 Subject: [PATCH 01/64] add failing tests for refusing a bare continuous conditional mean --- tests/testthat/_snaps/ps_trunc.md | 2 +- tests/testthat/test-ps_trim.R | 60 +++ tests/testthat/test-ps_trunc.R | 39 +- tests/testthat/test-psw-records.R | 42 ++- tests/testthat/test-weights-continuous.R | 345 +++++++++--------- .../testthat/test-weights-stabilize-default.R | 33 +- 6 files changed, 310 insertions(+), 211 deletions(-) diff --git a/tests/testthat/_snaps/ps_trunc.md b/tests/testthat/_snaps/ps_trunc.md index 22c4c9f8..9bf4ec20 100644 --- a/tests/testthat/_snaps/ps_trunc.md +++ b/tests/testthat/_snaps/ps_trunc.md @@ -116,7 +116,7 @@ expr Condition Error in `ps_trunc()`: - ! No method for objects of class lm + ! No method for objects of class not_a_model # ps_trunc() refuses scores that are not numbers diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index b1d88865..a0326acc 100644 --- a/tests/testthat/test-ps_trim.R +++ b/tests/testthat/test-ps_trim.R @@ -810,6 +810,37 @@ test_that("ps_refit() refuses a ps_trim whose record was dropped", { ) }) +test_that("ps_refit() refuses a model of a dose for a trimmed score", { + set.seed(37) + n <- 60 + x <- rnorm(n) + dose <- 0.5 * x + rnorm(n) + dose_data <- data.frame(dose = dose, x = x) + + # Means that happen to lie in (0, 1) can be trimmed as if they were scores, + # but a model of the dose never produced scores, so it cannot refit them. The + # dose model itself is what to trim. + trimmed <- ps_trim(plogis(0.5 * x), method = "ps", lower = 0.2, upper = 0.8) + + fits <- list( + lm = lm(dose ~ x, data = dose_data), + gaussian = glm(dose ~ x, data = dose_data, family = gaussian()) + ) + + for (kind in names(fits)) { + cnd <- expect_error( + ps_refit(trimmed, fits[[kind]], .data = dose_data), + class = "propensity_model_family_error", + info = kind + ) + message <- gsub("[[:space:]]+", " ", conditionMessage(cnd)) + expect_match(message, "ps_trim(method = \"density\")", fixed = TRUE) + } + + expect_propensity_error(ps_refit(trimmed, fits$lm, .data = dose_data)) + expect_propensity_error(ps_refit(trimmed, fits$gaussian, .data = dose_data)) +}) + test_that("combining ps_trim objects drops the trimming record", { x <- trim_record_fixture() @@ -948,6 +979,35 @@ test_that("ps_trim rejects the categorical-only optimal method on a vector", { expect_propensity_error(ps_trim(ps, method = "optimal", .exposure = z)) }) +test_that("ps_trim() refuses the density methods on a vector of fitted means", { + set.seed(29) + n <- 40 + x <- rnorm(n) + dose <- 0.5 * x + rnorm(n) + mu <- as.numeric(fitted(lm(dose ~ x))) + + # A density needs the model's residuals and its family, and a vector of + # fitted means carries neither, so the dose model itself has to be supplied. + for (method in c("density", "resid")) { + expect_error( + ps_trim(mu, method = method), + class = "propensity_method_error", + info = method + ) + + # The refusal is for what was asked rather than for the values, so means + # that leave the unit interval hear the same thing and not the range check. + expect_error( + ps_trim(mu + 5, method = method), + class = "propensity_method_error", + info = method + ) + } + + expect_propensity_error(ps_trim(mu, method = "density")) + expect_propensity_error(ps_trim(mu + 5, method = "resid")) +}) + test_that("ps_trim names `.exposure` when the method requires one", { ps <- c(0.2, 0.4, 0.6, 0.8) diff --git a/tests/testthat/test-ps_trunc.R b/tests/testthat/test-ps_trunc.R index 18609f66..edf3b239 100644 --- a/tests/testthat/test-ps_trunc.R +++ b/tests/testthat/test-ps_trunc.R @@ -1803,12 +1803,6 @@ test_that("ps_trunc() reads a two-level multinomial fit on the binary path", { }) test_that("ps_trunc() refuses a fit it cannot read propensity scores from", { - linear <- lm(z ~ x1 + x2, data = trunc_model_data) - - expect_error( - ps_trunc(linear, method = "ps"), - class = "propensity_method_error" - ) expect_error( ps_trunc(structure(list(), class = "not_a_model"), method = "ps"), class = "propensity_method_error" @@ -1817,10 +1811,41 @@ test_that("ps_trunc() refuses a fit it cannot read propensity scores from", { test_that("ps_trunc() names the class of a fit it has no reading for", { expect_propensity_error( - ps_trunc(lm(z ~ x1 + x2, data = trunc_model_data), method = "ps") + ps_trunc(structure(list(), class = "not_a_model"), method = "ps") ) }) +test_that("ps_trunc() refuses a model of a dose and names the routes that work", { + set.seed(31) + n <- 60 + x <- rnorm(n) + dose <- 0.5 * x + rnorm(n) + dose_data <- data.frame(dose = dose, x = x) + + # A linear model and a gaussian glm both fit conditional means rather than + # probabilities, so there is no propensity score to bound. The refusal is the + # same for both, and it points at trimming the dose model on the density + # scale or bounding the weights built from it. + fits <- list( + lm = lm(dose ~ x, data = dose_data), + gaussian = glm(dose ~ x, data = dose_data, family = gaussian()) + ) + + for (kind in names(fits)) { + cnd <- expect_error( + ps_trunc(fits[[kind]], method = "ps"), + class = "propensity_model_family_error", + info = kind + ) + message <- gsub("[[:space:]]+", " ", conditionMessage(cnd)) + expect_match(message, "ps_trim(method = \"density\")", fixed = TRUE) + expect_match(message, "wt_trunc()", fixed = TRUE) + } + + expect_propensity_error(ps_trunc(fits$lm, method = "ps")) + expect_propensity_error(ps_trunc(fits$gaussian, method = "ps")) +}) + # The exposure is announced when it is read and not otherwise, so the message # reports a reading that happened. Bounding at a fixed threshold or a quantile # reads no exposure; the common range does, and so does every truncation of a diff --git a/tests/testthat/test-psw-records.R b/tests/testthat/test-psw-records.R index b996b78b..51faf1f2 100644 --- a/tests/testthat/test-psw-records.R +++ b/tests/testthat/test-psw-records.R @@ -850,18 +850,19 @@ test_that("weights that differ only in these records cast to each other", { # ---- weights built from a modified propensity score ------------------------- test_that("weights from a trimmed propensity score carry the records", { + # A conditional mean in (0, 1) trimmed as if it were a propensity score is not + # one, so no continuous weights, and no records, are built from it. trimmed <- ps_trim(records_mu, method = "ps", lower = 0.25, upper = 0.8) - w <- muffle_variance_warning(muffle_refit_warning(wt_ate( - trimmed, - records_exposure, - exposure_type = "continuous", - stabilize = TRUE - ))) - - expect_identical(estimand(w), "ate; trimmed") - expect_identical(exposure_type(w), "continuous") - expect_identical(density_meta_summary(w), marginal_normal_record) + expect_error( + wt_ate( + trimmed, + records_exposure, + exposure_type = "continuous", + stabilize = TRUE + ), + class = "propensity_modified_continuous_error" + ) binary <- muffle_refit_warning(wt_ate( ps_trim(records_binary_ps, method = "ps", lower = 0.25, upper = 0.65), @@ -875,18 +876,19 @@ test_that("weights from a trimmed propensity score carry the records", { }) test_that("weights from a truncated propensity score carry the records", { + # The same holds for a conditional mean bounded as if it were a propensity + # score. truncated <- ps_trunc(records_mu, method = "ps", lower = 0.25, upper = 0.8) - w <- muffle_variance_warning(wt_ate( - truncated, - records_exposure, - exposure_type = "continuous", - stabilize = TRUE - )) - - expect_identical(estimand(w), "ate; truncated") - expect_identical(exposure_type(w), "continuous") - expect_identical(density_meta_summary(w), marginal_normal_record) + expect_error( + wt_ate( + truncated, + records_exposure, + exposure_type = "continuous", + stabilize = TRUE + ), + class = "propensity_modified_continuous_error" + ) binary <- wt_ate( ps_trunc(records_binary_ps, method = "ps", lower = 0.25, upper = 0.65), diff --git a/tests/testthat/test-weights-continuous.R b/tests/testthat/test-weights-continuous.R index ff17ac5a..1188da22 100644 --- a/tests/testthat/test-weights-continuous.R +++ b/tests/testthat/test-weights-continuous.R @@ -847,44 +847,61 @@ test_that("the density reaches the weights through a data frame", { expect_identical(format(density_meta(from_frame)$density), "laplace") }) -test_that("the density reaches the weights through a modified score", { +test_that("a density does not reach the weights through a modified score", { set.seed(13) n <- 40 x <- rnorm(n) exposure <- 0.5 * x + rnorm(n) - model_data <- data.frame(exposure = exposure, x = x) - fit <- glm(exposure ~ x, data = model_data, family = gaussian()) - # A score a modification can be applied to has to lie in (0, 1); it stands in - # for the fitted conditional mean here. + # A score a modification can be applied to has to lie in (0, 1), and a + # conditional mean that happens to lie there is still not a propensity score. + # Trimming, truncating, or calibrating it selects or moves units by their + # predicted dose, which says nothing about positivity, so no weights are built + # from the result whatever density is asked for. scores <- plogis(0.5 * x) - refit <- ps_refit( - ps_trim(scores, method = "ps", lower = 0.2, upper = 0.8), - model = fit + modified <- list( + trimmed = ps_trim(scores, method = "ps", lower = 0.2, upper = 0.8), + truncated = ps_trunc(scores, method = "ps", lower = 0.2, upper = 0.8), + calibrated = ps_calibrate(scores, rbinom(n, 1, scores)) ) - truncated <- ps_trunc(scores, method = "ps", lower = 0.2, upper = 0.8) - calibrated <- ps_calibrate(scores, rbinom(n, 1, scores)) - for (modified in list(refit, truncated, calibrated)) { - weights <- wt_ate( - modified, - exposure, - exposure_type = "continuous", - stabilize = TRUE, - .density = dens_t(df = 4) - ) - plain <- wt_ate( - as.numeric(modified), - exposure, - exposure_type = "continuous", - stabilize = TRUE, - .density = dens_t(df = 4) + for (modification in names(modified)) { + expect_error( + wt_ate( + modified[[modification]], + exposure, + exposure_type = "continuous", + stabilize = TRUE, + .density = dens_t(df = 4) + ), + class = "propensity_modified_continuous_error", + info = modification ) - - expect_equal(as.numeric(weights), as.numeric(plain), tolerance = 1e-12) - expect_identical(format(density_meta(weights)$density), "t(df = 4)") } + + # The refusal names the modification and the weight function it came from. + expect_propensity_error(wt_ate( + modified$trimmed, + exposure, + exposure_type = "continuous", + stabilize = TRUE, + .density = dens_t(df = 4) + )) + expect_propensity_error(wt_ate( + modified$truncated, + exposure, + exposure_type = "continuous", + stabilize = TRUE, + .density = dens_t(df = 4) + )) + expect_propensity_error(wt_ate( + modified$calibrated, + exposure, + exposure_type = "continuous", + stabilize = TRUE, + .density = dens_t(df = 4) + )) }) test_that("censoring weights take a density of their own", { @@ -924,11 +941,6 @@ test_that("censoring weights take a density of their own", { }) test_that("censoring weights carry a density through their other methods", { - set.seed(17) - n <- 40 - x <- rnorm(n) - exposure <- 0.5 * x + rnorm(n) - from_frame <- wt_cens( data.frame(mu = continuous_density_data$mu), continuous_density_data$exposure, @@ -944,42 +956,105 @@ test_that("censoring weights carry a density through their other methods", { ) expect_identical(estimand(from_frame), "uncensored") expect_identical(format(density_meta(from_frame)$density), "laplace") +}) + +test_that("censoring weights do not carry a density through a modified score", { + set.seed(17) + n <- 40 + x <- rnorm(n) + exposure <- 0.5 * x + rnorm(n) - # A score a modification can be applied to has to lie in (0, 1); it stands in - # for the fitted conditional mean here. + # A conditional mean that happens to lie in (0, 1) can be trimmed as if it + # were a propensity score, but the trimmed means were never scores, so a model + # of the dose cannot refit them. scores <- plogis(0.5 * x) + trimmed <- ps_trim(scores, method = "ps", lower = 0.2, upper = 0.8) - modified_scores <- list( + expect_error( ps_refit( - ps_trim(scores, method = "ps", lower = 0.2, upper = 0.8), + trimmed, model = glm( exposure ~ x, data = data.frame(exposure = exposure, x = x), family = gaussian() ) ), - ps_trunc(scores, method = "ps", lower = 0.2, upper = 0.8), - ps_calibrate(scores, rbinom(n, 1, scores)) + class = "propensity_model_family_error" ) - for (modified in modified_scores) { - weights <- wt_cens( - modified, - exposure, - exposure_type = "continuous", - stabilize = TRUE, - .density = dens_t(df = 4) - ) - plain <- wt_cens( - as.numeric(modified), - exposure, - exposure_type = "continuous", - stabilize = TRUE, - .density = dens_t(df = 4) + # Censoring weights for a dose are the same density ratio as the ATE weights, + # so they refuse a modified score on the same grounds. + modified <- list( + trimmed = trimmed, + truncated = ps_trunc(scores, method = "ps", lower = 0.2, upper = 0.8), + calibrated = ps_calibrate(scores, rbinom(n, 1, scores)) + ) + + for (modification in names(modified)) { + expect_error( + wt_cens( + modified[[modification]], + exposure, + exposure_type = "continuous", + stabilize = TRUE, + .density = dens_t(df = 4) + ), + class = "propensity_modified_continuous_error", + info = modification ) + } - expect_equal(as.numeric(weights), as.numeric(plain), tolerance = 1e-12) - expect_identical(format(density_meta(weights)$density), "t(df = 4)") + # The refusal names the modification and the weight function it came from. + expect_propensity_error(wt_cens( + modified$trimmed, + exposure, + exposure_type = "continuous", + stabilize = TRUE, + .density = dens_t(df = 4) + )) + expect_propensity_error(wt_cens( + modified$truncated, + exposure, + exposure_type = "continuous", + stabilize = TRUE, + .density = dens_t(df = 4) + )) + expect_propensity_error(wt_cens( + modified$calibrated, + exposure, + exposure_type = "continuous", + stabilize = TRUE, + .density = dens_t(df = 4) + )) +}) + +test_that("the modified-score methods refuse an exposure they resolve as continuous", { + set.seed(19) + n <- 40 + x <- rnorm(n) + exposure <- 0.5 * x + rnorm(n) + scores <- plogis(0.5 * x) + + modified <- list( + trimmed = ps_trim(scores, method = "ps", lower = 0.2, upper = 0.8), + truncated = ps_trunc(scores, method = "ps", lower = 0.2, upper = 0.8), + calibrated = ps_calibrate(scores, rbinom(n, 1, scores)) + ) + + # Nothing names the type here, and a numeric exposure of many values resolves + # to continuous. The refusal reads the type the exposure resolved to rather + # than the one the caller declared. + for (modification in names(modified)) { + expect_error( + wt_ate(modified[[modification]], exposure), + class = "propensity_modified_continuous_error", + info = modification + ) + expect_error( + wt_cens(modified[[modification]], exposure), + class = "propensity_modified_continuous_error", + info = modification + ) } }) @@ -1050,20 +1125,17 @@ test_that("a missing exposure is left out of the numerator as well", { expect_equal(weights[present], f_num / f_den, tolerance = 1e-12) }) -test_that("a trimmed propensity score leaves the units it set aside missing", { +test_that("missing conditional means leave those weights missing in every family", { set.seed(18) n <- 40 x <- rnorm(n) exposure <- 0.5 * x + rnorm(n) - # A score a modification can be applied to has to lie in (0, 1); it stands in - # for the fitted conditional mean here. Trimmed and not refit, it carries a - # missing value at every unit it set aside, which is the ordinary way a - # standardized residual goes missing. - trimmed <- ps_trim(plogis(0.9 * x), method = "ps", lower = 0.2, upper = 0.8) - mu <- as.numeric(trimmed) - missing_at <- which(is.na(mu)) - expect_gt(length(missing_at), 1) + # Several units have no fitted mean, so several have no standardized + # residual, and the rest are weighted as the problem they make on their own. + mu <- 0.5 * x + missing_at <- c(3L, 12L, 26L, 38L) + mu[missing_at] <- NA_real_ present <- setdiff(seq_len(n), missing_at) sigma <- sqrt(mean((exposure[present] - mu[present])^2)) @@ -1081,18 +1153,13 @@ test_that("a trimmed propensity score leaves the units it set aside missing", { ) for (family in families) { - weights <- NULL - expect_warning( - weights <- wt_ate( - trimmed, - exposure, - exposure_type = "continuous", - stabilize = TRUE, - .density = family$input - ), - class = "propensity_no_refit_warning" - ) - weights <- as.numeric(weights) + weights <- as.numeric(wt_ate( + mu, + exposure, + exposure_type = "continuous", + stabilize = TRUE, + .density = family$input + )) expect_identical(which(is.na(weights)), missing_at) @@ -1898,13 +1965,10 @@ test_that("the integrated numerator reads only the units with a residual", { x <- rnorm(n) exposure <- 0.5 * x + rnorm(n) - # A score a modification can be applied to has to lie in (0, 1); it stands in - # for the fitted conditional mean here. Trimmed and not refit, it carries a - # missing value at every unit it set aside. - trimmed <- ps_trim(plogis(0.9 * x), method = "ps", lower = 0.2, upper = 0.8) - mu <- as.numeric(trimmed) - missing_at <- which(is.na(mu)) - expect_gt(length(missing_at), 1) + # Several units have no fitted mean, so several have no residual. + mu <- 0.5 * x + missing_at <- c(2L, 9L, 21L, 33L, 47L) + mu[missing_at] <- NA_real_ present <- setdiff(seq_len(n), missing_at) @@ -1928,19 +1992,14 @@ test_that("the integrated numerator reads only the units with a residual", { ) for (family in families) { - weights <- NULL - expect_warning( - weights <- wt_ate( - trimmed, - exposure, - exposure_type = "continuous", - stabilize = TRUE, - .density = family$input, - numerator = "integrated" - ), - class = "propensity_no_refit_warning" - ) - weights <- as.numeric(weights) + weights <- as.numeric(wt_ate( + mu, + exposure, + exposure_type = "continuous", + stabilize = TRUE, + .density = family$input, + numerator = "integrated" + )) expect_identical(which(is.na(weights)), missing_at) expect_equal( @@ -2367,67 +2426,46 @@ test_that("censoring weights take an integrated numerator of their own", { expect_identical(density_meta(weights)$numerator, "integrated") }) -# The three modified propensity scores the numerator has to reach through, -# built on one seeded problem. A score a modification can be applied to has to -# lie in (0, 1); it stands in for the fitted conditional mean here. -# -# The seed is chosen so that the scores all lie inside the trimming bounds and -# nothing is trimmed away: with no unit set aside, none of the three leaves a -# missing value, and the grid marginalization reads every unit. That is a -# property of this fixture rather than of trimming, and it keeps these tests -# about the numerator reaching each route. What the marginalization does when a -# unit has no residual is a separate question, and the trimmed weights already -# have tests of their own above. +# The three modified propensity scores the numerator is refused through, built +# on one seeded problem. A score a modification can be applied to has to lie in +# (0, 1), and these stand where a conditional mean in (0, 1) would, which is the +# pairing the modified-score methods refuse for a continuous exposure. continuous_modified_scores <- function() { set.seed(23) n <- 40 x <- rnorm(n) exposure <- 0.5 * x + rnorm(n) - fit <- glm( - exposure ~ x, - data = data.frame(exposure = exposure, x = x), - family = gaussian() - ) scores <- plogis(0.5 * x) - trimmed <- ps_trim(scores, method = "ps", lower = 0.2, upper = 0.8) - stopifnot(!anyNA(as.numeric(trimmed))) list( n = n, x = x, exposure = exposure, scores = list( - refit = ps_refit(trimmed, model = fit), + trimmed = ps_trim(scores, method = "ps", lower = 0.2, upper = 0.8), truncated = ps_trunc(scores, method = "ps", lower = 0.2, upper = 0.8), calibrated = ps_calibrate(scores, rbinom(n, 1, scores)) ) ) } -test_that("the numerator reaches the weights through a modified score", { +test_that("the numerator does not reach the weights through a modified score", { problem <- continuous_modified_scores() - for (modified in problem$scores) { - weights <- wt_ate( - modified, - problem$exposure, - exposure_type = "continuous", - stabilize = TRUE, - .density = dens_t(df = 4, sigma_method = "rms"), - numerator = "integrated" - ) - - expect_equal( - as.numeric(weights), - continuous_integrated_wt( - function(z) stats::dt(z, df = 4), - exposure = problem$exposure, - mu = as.numeric(modified) + for (modification in names(problem$scores)) { + expect_error( + wt_ate( + problem$scores[[modification]], + problem$exposure, + exposure_type = "continuous", + stabilize = TRUE, + .density = dens_t(df = 4, sigma_method = "rms"), + numerator = "integrated" ), - tolerance = 1e-12 + class = "propensity_modified_continuous_error", + info = modification ) - expect_identical(density_meta(weights)$numerator, "integrated") } }) @@ -2473,41 +2511,22 @@ test_that("censoring weights carry a numerator through their other methods", { expect_identical(density_meta(from_model)$numerator, "integrated") }) -test_that("censoring weights carry a numerator through a modified score", { +test_that("censoring weights do not carry a numerator through a modified score", { problem <- continuous_modified_scores() - # A modification is recorded on the estimand after the censoring weights have - # named themselves, so each of the three reads as the estimand and then the - # modification. - estimands <- c( - refit = "uncensored; trimmed", - truncated = "uncensored; truncated", - calibrated = "uncensored; calibrated" - ) - for (modification in names(problem$scores)) { - modified <- problem$scores[[modification]] - - weights <- wt_cens( - modified, - problem$exposure, - exposure_type = "continuous", - stabilize = TRUE, - .density = dens_t(df = 4, sigma_method = "rms"), - numerator = "integrated" - ) - - expect_equal( - as.numeric(weights), - continuous_integrated_wt( - function(z) stats::dt(z, df = 4), - exposure = problem$exposure, - mu = as.numeric(modified) + expect_error( + wt_cens( + problem$scores[[modification]], + problem$exposure, + exposure_type = "continuous", + stabilize = TRUE, + .density = dens_t(df = 4, sigma_method = "rms"), + numerator = "integrated" ), - tolerance = 1e-12 + class = "propensity_modified_continuous_error", + info = modification ) - expect_identical(estimand(weights), estimands[[modification]]) - expect_identical(density_meta(weights)$numerator, "integrated") } }) diff --git a/tests/testthat/test-weights-stabilize-default.R b/tests/testthat/test-weights-stabilize-default.R index b0c12a9e..d07b9b35 100644 --- a/tests/testthat/test-weights-stabilize-default.R +++ b/tests/testthat/test-weights-stabilize-default.R @@ -331,13 +331,13 @@ test_that("the data frame method resolves the continuous default", { ) }) -test_that("the modified-score methods resolve the continuous default", { +test_that("the modified-score methods refuse a continuous exposure under the default", { dat <- stabilize_default_data - # A score a modification can be applied to has to lie in (0, 1), so the - # conditional mean these routes are handed is one that does. What is being - # read here is the default, not the arithmetic, which is the same as the - # numeric route's on the same numbers. + # A conditional mean that happens to lie in (0, 1) can be modified as if it + # were a propensity score, but no weights for a dose are built from the + # result, so the continuous default is never reached through these methods. + # The numeric route pins that default. scores <- plogis(0.5 * dat$x) fit <- glm( trt ~ x, @@ -355,21 +355,14 @@ test_that("the modified-score methods resolve the continuous default", { ) for (route in names(modified)) { - ps <- modified[[route]] - - weights <- wt_ate(ps, dat$dose, exposure_type = "continuous") - - expect_true(is_stabilized(weights), info = route) - expect_identical(density_meta(weights)$numerator, "marginal", info = route) - expect_equal( - as.numeric(weights), - as.numeric(wt_ate( - ps, - dat$dose, - exposure_type = "continuous", - stabilize = TRUE - )), - tolerance = 1e-12, + expect_error( + wt_ate(modified[[route]], dat$dose, exposure_type = "continuous"), + class = "propensity_modified_continuous_error", + info = route + ) + expect_error( + wt_cens(modified[[route]], dat$dose, exposure_type = "continuous"), + class = "propensity_modified_continuous_error", info = route ) } From dc18decb4cc0cc145213fcc42ece38c5e0579882 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 18:04:44 -0400 Subject: [PATCH 02/64] refuse a bare continuous conditional mean in the modified score routes --- NAMESPACE | 1 + NEWS.md | 23 +++ R/categorical-models.R | 3 +- R/continuous-models.R | 23 ++- R/ps_trim.R | 162 +++++++++++++++++++- R/ps_trunc.R | 69 ++++++++- R/weights-utils.R | 146 +++++++++++++++++- man/ps_refit.Rd | 6 +- man/ps_trim.Rd | 7 +- man/ps_trunc.Rd | 5 +- tests/testthat/_snaps/ps_trim.md | 40 +++++ tests/testthat/_snaps/ps_trunc.md | 20 +++ tests/testthat/_snaps/weights-continuous.md | 60 ++++++++ 13 files changed, 542 insertions(+), 23 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 48164df7..afe027c4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -113,6 +113,7 @@ S3method(ps_trim,ps_trim) S3method(ps_trunc,data.frame) S3method(ps_trunc,default) S3method(ps_trunc,glm) +S3method(ps_trunc,lm) S3method(ps_trunc,matrix) S3method(ps_trunc,multinom) S3method(ps_trunc,ps_trunc) diff --git a/NEWS.md b/NEWS.md index 8a4ccfef..1b497b3f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,28 @@ # propensity 0.1.0.9000 (development version) +* Weights for a continuous exposure can no longer be built from a trimmed, + truncated, or calibrated score. A conditional mean whose values happened to + fall in (0, 1) could be passed through `ps_trim()`, `ps_trunc()`, or + `ps_calibrate()` as if it were a propensity score and then weighted with + `wt_ate()` or `wt_cens()`, which selected or moved units by their predicted + dose and said nothing about positivity. Those six methods now refuse an + exposure they resolve as continuous, including one resolved from + `exposure_type = "auto"`, with an error of class + `propensity_modified_continuous_error`. A model of a conditional mean, a + least squares fit or a `glm` of any family but the binomial ones, is refused + by `ps_trunc()` and by `ps_refit()` on trimmed scores with an error of class + `propensity_model_family_error`, where `ps_refit()` previously refit + whatever model it was handed. `ps_trim()` reserves `method = "density"` and + `method = "resid"` for trimming a dose model on the scale of its conditional + density, and refuses both for a vector of values with an error of class + `propensity_method_error`, since a vector carries neither the residuals nor + the family a density is read from. Each refusal names the + routes for a dose: trimming the dose model with + `ps_trim(method = "density")`, or building its weights with `wt_ate()` and + bounding the weights with `wt_trunc()`. Until those routes are available, + build the weights of a continuous exposure from the dose model or its fitted + means directly, without a score modification. + * `dens_t()` now estimates the scale of the t under the t itself by default, as `dens_laplace()` estimates the scale of the Laplace. Both densities of a continuous exposure's weights are read at a residual standardized by a spread diff --git a/R/categorical-models.R b/R/categorical-models.R index 8756711c..79b6b4c1 100644 --- a/R/categorical-models.R +++ b/R/categorical-models.R @@ -166,7 +166,7 @@ model_levels.multinom <- function(model) { # that leave nothing to read as the probability of the exposure, which is what a # binary exposure needs. # -# `remedy` goes unread here. What is wrong with a `multinom` of more than two +# `remedy` and `problem` go unread here. What is wrong with a `multinom` of more than two # levels is the number of levels rather than the family, so the remedy is the # one written below whichever argument the model arrived in. A `multinom` # supplied as a numerator model never reaches this method at all: @@ -178,6 +178,7 @@ check_binary_model_family.multinom <- function( model, arg = ".propensity", remedy = NULL, + problem = NULL, call = rlang::caller_env() ) { n_levels <- length(model$lev) diff --git a/R/continuous-models.R b/R/continuous-models.R index 4dc0d040..19eff75d 100644 --- a/R/continuous-models.R +++ b/R/continuous-models.R @@ -101,12 +101,16 @@ extract_continuous_ps.gam <- function(model, call = rlang::caller_env()) { # `arg` is the argument the model arrived in, and `remedy` the advice that goes # with it: a propensity score model's fitted means can be passed directly # instead, and a numerator model a caller stabilizes on is a model or nothing. +# `problem` states what the caller needed the model for, since a refit of a +# trimmed dose model needs the same model for a different purpose. check_continuous_model_family <- function( model, arg = ".propensity", remedy = "Fit the propensity score model with {.fun gaussian}, {.fun lm}, {.fun mgcv::gam}, or {.fun MASS::rlm}, or pass fitted conditional means to {.arg .propensity} directly.", + problem = "Weights for a continuous exposure need a model of its conditional + mean with a single spread.", call = rlang::caller_env() ) { family <- model[["family"]] @@ -137,8 +141,7 @@ check_continuous_model_family <- function( abort( c( - "Weights for a continuous exposure need a model of its conditional mean - with a single spread.", + problem, x = fit_with, i = remedy ), @@ -154,14 +157,19 @@ check_continuous_model_family <- function( # own. # # `arg` names the argument the model arrived in and `remedy` says what to do -# about it, because the same question is asked of two models: the propensity -# score model of a binary exposure, and the numerator model that estimates the -# probability the weights are stabilized on. +# about it, because the same question is asked of more than one model: the +# propensity score model of a binary exposure, the numerator model that +# estimates the probability the weights are stabilized on, and the model a +# modified score is read from or refit with. `problem` states what the caller +# needed a probability for, which differs between building weights, bounding +# scores, and refitting them. check_binary_model_family <- function( model, arg = ".propensity", remedy = "Fit the propensity score model with {.fun binomial}, or pass fitted probabilities to {.arg .propensity} directly.", + problem = "Weights for a binary exposure need a model of the probability of + the exposure.", call = rlang::caller_env() ) { UseMethod("check_binary_model_family") @@ -178,6 +186,8 @@ check_binary_model_family.default <- function( arg = ".propensity", remedy = "Fit the propensity score model with {.fun binomial}, or pass fitted probabilities to {.arg .propensity} directly.", + problem = "Weights for a binary exposure need a model of the probability of + the exposure.", call = rlang::caller_env() ) { family <- model[["family"]] @@ -214,8 +224,7 @@ check_binary_model_family.default <- function( abort( c( - "Weights for a binary exposure need a model of the probability of the - exposure.", + problem, x = fitted_by, i = remedy ), diff --git a/R/ps_trim.R b/R/ps_trim.R index 06ad6d21..480c618d 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -52,6 +52,11 @@ #' because there is no range left to bound the scores to. #' * **`"optimal"`**: Multi-category optimal trimming (Yang et al., 2016). #' Categorical exposures only. Requires `.exposure`. +#' * **`"density"`**, **`"resid"`**: Trimming on the scale of the conditional +#' density of a continuous exposure. A density needs the residuals and the +#' family of the model that fit the exposure's conditional mean, so these +#' methods refuse a vector or matrix of values with an error of class +#' `propensity_method_error`. #' #' For categorical exposures, only `"ps"` and `"optimal"` are supported. #' @param lower,upper Numeric thresholds whose interpretation depends on @@ -302,7 +307,16 @@ #' @export ps_trim <- function( .propensity, - method = c("ps", "adaptive", "pctl", "pref", "cr", "optimal"), + method = c( + "ps", + "adaptive", + "pctl", + "pref", + "cr", + "optimal", + "density", + "resid" + ), lower = NULL, upper = NULL, .exposure = NULL, @@ -325,7 +339,16 @@ ps_trim <- function( #' @export ps_trim.default <- function( .propensity, - method = c("ps", "adaptive", "pctl", "pref", "cr", "optimal"), + method = c( + "ps", + "adaptive", + "pctl", + "pref", + "cr", + "optimal", + "density", + "resid" + ), lower = NULL, upper = NULL, .exposure = NULL, @@ -378,6 +401,26 @@ ps_trim.default <- function( ) } + # The density methods read the conditional density of a continuous exposure, + # which takes the residuals and the family of the model that fit its mean. A + # vector of fitted means carries neither. The refusal comes before the range + # check, so that means outside the unit interval are refused for the method + # asked of them rather than for their values. + if (method %in% c("density", "resid")) { + abort( + c( + "Method {.val {method}} cannot trim a vector of values.", + x = "It reads the conditional density of a continuous exposure, which + needs the residuals and the family of the model that fit its + conditional mean, and {.arg .propensity} carries neither.", + i = "Supply the fitted model of the exposure itself as + {.arg .propensity}." + ), + error_class = "propensity_method_error", + call = call + ) + } + check_ps_range(.propensity, call = call) # Handle deprecation @@ -553,7 +596,16 @@ ps_trim.default <- function( #' @export ps_trim.matrix <- function( .propensity, - method = c("ps", "adaptive", "pctl", "pref", "cr", "optimal"), + method = c( + "ps", + "adaptive", + "pctl", + "pref", + "cr", + "optimal", + "density", + "resid" + ), lower = NULL, upper = NULL, .exposure = NULL, @@ -573,7 +625,16 @@ ps_trim.matrix <- function( # reject the ones the categorical path does not define. method <- rlang::arg_match( method, - values = c("ps", "adaptive", "pctl", "pref", "cr", "optimal"), + values = c( + "ps", + "adaptive", + "pctl", + "pref", + "cr", + "optimal", + "density", + "resid" + ), error_call = call ) if (!method %in% c("ps", "optimal")) { @@ -755,7 +816,16 @@ ps_trim.matrix <- function( #' @export ps_trim.data.frame <- function( .propensity, - method = c("ps", "adaptive", "pctl", "pref", "cr", "optimal"), + method = c( + "ps", + "adaptive", + "pctl", + "pref", + "cr", + "optimal", + "density", + "resid" + ), lower = NULL, upper = NULL, .exposure = NULL, @@ -981,7 +1051,16 @@ ps_trim_from_model <- function( #' @export ps_trim.ps_trim <- function( .propensity, - method = c("ps", "adaptive", "pctl", "pref", "cr", "optimal"), + method = c( + "ps", + "adaptive", + "pctl", + "pref", + "cr", + "optimal", + "density", + "resid" + ), lower = NULL, upper = NULL, .exposure = NULL, @@ -1814,6 +1893,10 @@ diff.ps_trim <- function(x, lag = 1L, differences = 1L, ...) { #' @param model The original fitted model used to estimate the propensity #' scores (e.g. a [glm][stats::glm] or [multinom][nnet::multinom] object). #' The model is refit via [update()][stats::update] on the retained subset. +#' Trimmed propensity scores are refit only by a model of the probability of +#' the exposure; a model of a conditional mean, such as a [stats::lm()] fit +#' or a gaussian [stats::glm()], never produced them and raises an error of +#' class `propensity_model_family_error`. #' @param .data A data frame with one row per observation in `trimmed_ps`, in #' the same order. If `NULL` (the default), the data are recovered from #' `model`: its [model.frame()][stats::model.frame] when that already holds @@ -1899,6 +1982,11 @@ ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { ) } + # Checked before any data are recovered or any model is refit, so that a + # model that could never have produced the trimmed values is refused for that + # rather than for whatever refitting it would run into. + check_refit_model(meta, model) + from_model <- is.null(.data) if (from_model) { .data <- refit_data(model) @@ -1990,6 +2078,68 @@ ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { ) } +# Whether `model` can refit what the trimming record was made from. A record of +# trimmed propensity scores needs a model that fits a probability: one that fits +# a probability for every level, or one whose family fits the probability of a +# binary exposure, which a two-level `multinom` also answers. A model of a +# conditional mean never produced those scores, however close to the unit +# interval its fitted values fall. +# +# A record of a trimmed dose model needs the other kind. A `multinom` is refused +# by its class before the family is read, because the continuous family check +# reads a model that carries no family as a least squares fit, and a two-level +# `multinom` carries none and does not answer to `model_fits_levels()` either. +check_refit_model <- function(meta, model, call = rlang::caller_env()) { + density_record <- isTRUE(meta$method %in% c("density", "resid")) + + if (!density_record) { + if (model_fits_levels(model)) { + return(invisible(NULL)) + } + + check_binary_model_family( + model, + arg = "model", + problem = "Trimmed propensity scores can only be refit with a model of + the probability of the exposure.", + remedy = "{.arg trimmed_ps} holds propensity scores this model never + produced. To set aside the units whose dose is implausible + under a model of a continuous exposure, trim that model itself + with {.code ps_trim(method = \"density\")}.", + call = call + ) + return(invisible(NULL)) + } + + dose_problem <- "A trimmed dose model can only be refit with a model of the + exposure's conditional mean." + + if (inherits(model, "multinom") || model_fits_levels(model)) { + abort( + c( + dose_problem, + x = "The trimming record holds a dose model's conditional means, and + {.arg model} fits a probability for each of its levels.", + i = "Refit with the model of the continuous exposure the trimming was + made from." + ), + error_class = "propensity_model_family_error", + call = call + ) + } + + check_continuous_model_family( + model, + arg = "model", + problem = dose_problem, + remedy = "The trimming record holds a dose model's conditional means, so + refit with the model of the continuous exposure the trimming was + made from, fit with {.fun lm} or + {.code glm(family = gaussian())}.", + call = call + ) +} + # The variables the refit call reads: the ones the formula names, plus any named # by `weights` or `offset`, which are evaluated against whatever data the refit # is handed. The original `subset` is dropped from that call, so the variables it diff --git a/R/ps_trunc.R b/R/ps_trunc.R index e94993db..63eca9eb 100644 --- a/R/ps_trunc.R +++ b/R/ps_trunc.R @@ -107,7 +107,10 @@ #' read as one score per unit; a `nnet::multinom()` of three or more levels is #' read as one column per level. Those are the shapes `predict(fit, type = #' "response")` and `fitted(fit)` give, and truncating a fit bounds exactly what -#' bounding those values would. +#' bounding those values would. A model of a continuous exposure's conditional +#' mean, such as a [stats::lm()] fit or a gaussian [stats::glm()], has no +#' propensity score to bound and raises an error of class +#' `propensity_model_family_error`. #' #' The methods that read an exposure (`"cr"`, and every method on the #' categorical route) take it from the model when `.exposure` is not supplied, @@ -718,9 +721,8 @@ ps_trunc.data.frame <- function( # The fitted propensity score models truncation reads, registered for the same # classes the weight functions read: a `glm`, whose binomial families fit the # probability of a binary exposure, and a `multinom`, which fits a probability -# for every level. A `lm` is not among them, its fitted values being conditional -# means rather than probabilities, and it reaches the default method, which -# reports that it has no scores to bound. +# for every level. A `glm` of any other family fits a conditional mean, and is +# refused by the family check on the way in. #' @export ps_trunc.glm <- function( .propensity, @@ -755,6 +757,63 @@ ps_trunc.glm <- function( ) } +# A least squares fit is a model of a continuous exposure's conditional mean, +# which has no propensity score to bound. It is registered only to be refused +# with the same message a gaussian `glm` gets, naming the routes that do work +# for a dose, rather than falling to the default method's report that the class +# has no reading at all. It takes the model route so that the refusal is the +# one that route writes: the family check reads a model with no family as a +# model of a conditional mean, so a `lm` goes no further than that check. +#' @export +ps_trunc.lm <- function( + .propensity, + method = c("ps", "pctl", "cr"), + lower = NULL, + upper = NULL, + .exposure = NULL, + .focal_level = NULL, + .reference_level = NULL, + ..., + .treated = NULL, + .untreated = NULL, + ps = lifecycle::deprecated(), + call = rlang::current_env() +) { + check_call_arg(call) + .propensity <- read_method_propensity(rlang::maybe_missing(.propensity), ps) + + ps_trunc_from_model( + .propensity, + method = method, + lower = lower, + upper = upper, + .exposure = .exposure, + .focal_level = .focal_level, + .reference_level = .reference_level, + ..., + .treated = .treated, + .untreated = .untreated, + call = call, + user_env = rlang::caller_env() + ) +} + +# What truncation needs of a fitted model, and what a dose model can do +# instead. Truncation bounds a probability, and a model of a continuous +# exposure fits none; a dose is either trimmed on the scale of its conditional +# density or weighted and then bounded on the scale of its weights. +ps_trunc_family_problem <- function() { + "Truncation needs a model of the probability of the exposure." +} + +ps_trunc_dose_remedy <- function() { + "A continuous exposure has no propensity score to bound. To set aside the + units whose dose is implausible under the model, trim the dose model with + {.code ps_trim(method = \"density\")}; to hold down extreme weights while + keeping every unit, build them with {.fun wt_ate} and bound them with + {.fun wt_trunc}." +} + # A `multinom` is `c("multinom", "nnet")` and inherits from neither `glm` nor # `lm`, so it reaches a method of its own. What it was fit to is checked before # anything reads it, so that a fit the route cannot read is reported as such @@ -834,6 +893,8 @@ ps_trunc_from_model <- function( .treated = .treated, .untreated = .untreated, fn_name = "ps_trunc", + remedy = ps_trunc_dose_remedy(), + problem = ps_trunc_family_problem(), call = call, user_env = user_env ) diff --git a/R/weights-utils.R b/R/weights-utils.R index 7b948066..a88b1575 100644 --- a/R/weights-utils.R +++ b/R/weights-utils.R @@ -1335,6 +1335,17 @@ calculate_weight_from_modified_ps <- function( modification_type <- rlang::arg_match(modification_type) + # Read before the refit check, so that a pairing that is refused outright is + # not also advised to refit. + check_modified_ps_exposure( + .propensity, + .exposure, + weight_fn = weight_fn, + modification_type = modification_type, + exposure_type = list(...)[["exposure_type"]], + call = call + ) + # Only check refit for trim if (modification_type == "trim") { check_refit(.propensity, call = call) @@ -1397,6 +1408,111 @@ calculate_weight_from_modified_ps <- function( base_wt } +# Whether a modified score and the exposure it is weighted against describe the +# same route. A continuous exposure has no propensity score, so a trimmed, +# truncated, or calibrated vector weighted against one was a conditional mean +# modified as if it were a probability, which selects or moves units by their +# predicted dose and says nothing about positivity. The one record that does +# describe a dose is a density trim of a dose model, which in turn describes no +# binary or categorical exposure. +# +# Only the ATE and censoring weights read a continuous exposure, so only they +# are gated here; the other estimands refuse a continuous exposure on their own. +# The type is the resolved one, since `"auto"` reaches continuous from a numeric +# exposure of many values. It is resolved quietly because the numeric method +# resolves it again and announces it there, and resolved against every type +# because an unsupported one is refused by the method that does not support it. +check_modified_ps_exposure <- function( + .propensity, + .exposure, + weight_fn, + modification_type, + exposure_type, + call = rlang::caller_env() +) { + fn <- if (identical(weight_fn, wt_ate.numeric)) { + "wt_ate" + } else if (identical(weight_fn, wt_cens.numeric)) { + "wt_cens" + } + + if (is.null(fn) || is.null(exposure_type)) { + return(invisible(NULL)) + } + + # An unmatched argument arrives as the method's own set of choices, whose + # first is `"auto"`. A value that names no type at all is left for the + # numeric method to refuse, where every other malformed argument is refused. + if (length(exposure_type) > 1) { + exposure_type <- "auto" + } + exposure_types <- c("auto", "binary", "categorical", "continuous") + if (!rlang::is_string(exposure_type) || !exposure_type %in% exposure_types) { + return(invisible(NULL)) + } + + exposure_type <- causalgenerics::match_exposure_type( + exposure_type, + .exposure, + announce = FALSE, + call = call + ) + + meta <- if (identical(modification_type, "trim")) { + attr(.propensity, "ps_trim_meta") + } + density_record <- isTRUE(meta$method %in% c("density", "resid")) + continuous <- identical(exposure_type, "continuous") + + if (continuous && !density_record) { + verb <- switch( + modification_type, + trim = "trimmed", + trunc = "truncated", + calib = "calibrated" + ) + modifier <- switch( + modification_type, + trim = "ps_trim", + trunc = "ps_trunc", + calib = "ps_calibrate" + ) + + abort( + c( + "Weights for a continuous exposure cannot be built from {verb} + propensity scores.", + x = "A continuous exposure has no propensity score, so the values + {.fun {modifier}} {verb} were conditional means rather than + probabilities.", + i = "Trim the dose model itself with + {.code ps_trim(method = \"density\")}, or build weights from the + dose model with {.fun {fn}} and hold down extreme weights with + {.fun wt_trunc}." + ), + error_class = "propensity_modified_continuous_error", + call = call + ) + } + + if (!continuous && density_record) { + abort( + c( + "Weights for a {exposure_type} exposure cannot be built from a + density-trimmed dose model.", + x = "The trimming record holds conditional means and a density family, + not propensity scores.", + i = "Pass the dose as {.arg .exposure}, or trim a propensity score + model for the {exposure_type} exposure instead." + ), + error_class = "propensity_modified_continuous_error", + call = call + ) + } + + invisible(NULL) +} + # What the weights record about the exposure they were built for. The type is # the one the weight function resolved, and the density record is read off the # weights the formula returned: only the continuous ATE formula writes one, and @@ -1661,14 +1777,28 @@ extract_binary_ps.default <- function(model, call = rlang::caller_env()) { # `exposure_levels` carries the levels of the exposure being weighted, so that a # categorical model fit to some other set of them is reported against the model # rather than against the shape of what it returns. +# +# `remedy` and `problem` replace the advice and the statement of need in the +# binary family refusal when they are supplied, so that a route that reads a +# probability for some other purpose than weighting, such as bounding it, can +# say what it needed and what works instead. Left `NULL`, the refusal keeps the +# wording written for the weight functions. extract_model_propensity <- function( model, exposure_type, exposure_levels = NULL, + remedy = NULL, + problem = NULL, call = rlang::caller_env() ) { if (identical(exposure_type, "binary")) { - check_binary_model_family(model, call = call) + family_text <- list(remedy = remedy, problem = problem) + rlang::exec( + check_binary_model_family, + model, + !!!family_text[!vapply(family_text, is.null, logical(1))], + call = call + ) return(extract_binary_ps(model, call = call)) } @@ -1978,6 +2108,10 @@ prepare_model_weight_args <- function( # level requires it too, because the fitted values report the probability of the # level the response's default coding treats as focal, so naming the other level # means inverting them, exactly as `prepare_model_weight_args()` does. +# +# `remedy` and `problem` are handed to the binary family refusal, so that a +# modifier refusing a model of a conditional mean can say what it needed the +# probability for and name the routes that work for a dose. prepare_model_ps <- function( model, .exposure = NULL, @@ -1987,6 +2121,8 @@ prepare_model_ps <- function( .treated = NULL, .untreated = NULL, fn_name, + remedy = NULL, + problem = NULL, call = rlang::caller_env(), user_env = rlang::caller_env(2) ) { @@ -2039,7 +2175,13 @@ prepare_model_ps <- function( # Read before the exposure, so that a fit whose scores cannot be read at all # is reported as such rather than after an announcement about an exposure # nothing goes on to use. - ps_vec <- extract_model_propensity(model, "binary", call = call) + ps_vec <- extract_model_propensity( + model, + "binary", + remedy = remedy, + problem = problem, + call = call + ) focal_named <- !is.null(focal_params$.focal_level) || !is.null(focal_params$.reference_level) diff --git a/man/ps_refit.Rd b/man/ps_refit.Rd index d96fa29f..41c20a29 100644 --- a/man/ps_refit.Rd +++ b/man/ps_refit.Rd @@ -14,7 +14,11 @@ record was dropped or no longer covers it raises an error of class \item{model}{The original fitted model used to estimate the propensity scores (e.g. a \link[stats:glm]{glm} or \link[nnet:multinom]{multinom} object). -The model is refit via \link[stats:update]{update()} on the retained subset.} +The model is refit via \link[stats:update]{update()} on the retained subset. +Trimmed propensity scores are refit only by a model of the probability of +the exposure; a model of a conditional mean, such as a \code{\link[stats:lm]{stats::lm()}} fit +or a gaussian \code{\link[stats:glm]{stats::glm()}}, never produced them and raises an error of +class \code{propensity_model_family_error}.} \item{.data}{A data frame with one row per observation in \code{trimmed_ps}, in the same order. If \code{NULL} (the default), the data are recovered from diff --git a/man/ps_trim.Rd b/man/ps_trim.Rd index 20f2f1c6..7c129199 100644 --- a/man/ps_trim.Rd +++ b/man/ps_trim.Rd @@ -6,7 +6,7 @@ \usage{ ps_trim( .propensity, - method = c("ps", "adaptive", "pctl", "pref", "cr", "optimal"), + method = c("ps", "adaptive", "pctl", "pref", "cr", "optimal", "density", "resid"), lower = NULL, upper = NULL, .exposure = NULL, @@ -65,6 +65,11 @@ the same data with an error of class \code{propensity_no_overlap_error} because there is no range left to bound the scores to. \item \strong{\code{"optimal"}}: Multi-category optimal trimming (Yang et al., 2016). Categorical exposures only. Requires \code{.exposure}. +\item \strong{\code{"density"}}, \strong{\code{"resid"}}: Trimming on the scale of the conditional +density of a continuous exposure. A density needs the residuals and the +family of the model that fit the exposure's conditional mean, so these +methods refuse a vector or matrix of values with an error of class +\code{propensity_method_error}. } For categorical exposures, only \code{"ps"} and \code{"optimal"} are supported.} diff --git a/man/ps_trunc.Rd b/man/ps_trunc.Rd index 3fee45a3..94c2349d 100644 --- a/man/ps_trunc.Rd +++ b/man/ps_trunc.Rd @@ -146,7 +146,10 @@ return a plain numeric vector. it reports. A binomial \code{\link[stats:glm]{stats::glm()}} and a two-level \code{nnet::multinom()} are read as one score per unit; a \code{nnet::multinom()} of three or more levels is read as one column per level. Those are the shapes \code{predict(fit, type = "response")} and \code{fitted(fit)} give, and truncating a fit bounds exactly what -bounding those values would. +bounding those values would. A model of a continuous exposure's conditional +mean, such as a \code{\link[stats:lm]{stats::lm()}} fit or a gaussian \code{\link[stats:glm]{stats::glm()}}, has no +propensity score to bound and raises an error of class +\code{propensity_model_family_error}. The methods that read an exposure (\code{"cr"}, and every method on the categorical route) take it from the model when \code{.exposure} is not supplied, diff --git a/tests/testthat/_snaps/ps_trim.md b/tests/testthat/_snaps/ps_trim.md index 4773d514..9b0799cd 100644 --- a/tests/testthat/_snaps/ps_trim.md +++ b/tests/testthat/_snaps/ps_trim.md @@ -138,6 +138,26 @@ i Metadata cannot be preserved when combining incompatible objects i Use identical objects or explicitly cast to numeric to avoid this warning +# ps_refit() refuses a model of a dose for a trimmed score + + Code + expr + Condition + Error in `ps_refit()`: + ! Trimmed propensity scores can only be refit with a model of the probability of the exposure. + x `model` is , whose fitted values are conditional means rather than probabilities. + i `trimmed_ps` holds propensity scores this model never produced. To set aside the units whose dose is implausible under a model of a continuous exposure, trim that model itself with `ps_trim(method = "density")`. + +--- + + Code + expr + Condition + Error in `ps_refit()`: + ! Trimmed propensity scores can only be refit with a model of the probability of the exposure. + x `model` was fit with `gaussian()`, whose fitted values are conditional means rather than probabilities. + i `trimmed_ps` holds propensity scores this model never produced. To set aside the units whose dose is implausible under a model of a continuous exposure, trim that model itself with `ps_trim(method = "density")`. + # ps_trim rejects the categorical-only optimal method on a vector Code @@ -147,6 +167,26 @@ ! Method "optimal" is only supported for categorical exposures. i Supply the propensity scores as a matrix or data frame with one column per exposure level. +# ps_trim() refuses the density methods on a vector of fitted means + + Code + expr + Condition + Error in `ps_trim()`: + ! Method "density" cannot trim a vector of values. + x It reads the conditional density of a continuous exposure, which needs the residuals and the family of the model that fit its conditional mean, and `.propensity` carries neither. + i Supply the fitted model of the exposure itself as `.propensity`. + +--- + + Code + expr + Condition + Error in `ps_trim()`: + ! Method "resid" cannot trim a vector of values. + x It reads the conditional density of a continuous exposure, which needs the residuals and the family of the model that fit its conditional mean, and `.propensity` carries neither. + i Supply the fitted model of the exposure itself as `.propensity`. + # ps_trim names `.exposure` when the method requires one Code diff --git a/tests/testthat/_snaps/ps_trunc.md b/tests/testthat/_snaps/ps_trunc.md index 9bf4ec20..a81c58d0 100644 --- a/tests/testthat/_snaps/ps_trunc.md +++ b/tests/testthat/_snaps/ps_trunc.md @@ -118,6 +118,26 @@ Error in `ps_trunc()`: ! No method for objects of class not_a_model +# ps_trunc() refuses a model of a dose and names the routes that work + + Code + expr + Condition + Error in `ps_trunc()`: + ! Truncation needs a model of the probability of the exposure. + x `.propensity` is , whose fitted values are conditional means rather than probabilities. + i A continuous exposure has no propensity score to bound. To set aside the units whose dose is implausible under the model, trim the dose model with `ps_trim(method = "density")`; to hold down extreme weights while keeping every unit, build them with `wt_ate()` and bound them with `wt_trunc()`. + +--- + + Code + expr + Condition + Error in `ps_trunc()`: + ! Truncation needs a model of the probability of the exposure. + x `.propensity` was fit with `gaussian()`, whose fitted values are conditional means rather than probabilities. + i A continuous exposure has no propensity score to bound. To set aside the units whose dose is implausible under the model, trim the dose model with `ps_trim(method = "density")`; to hold down extreme weights while keeping every unit, build them with `wt_ate()` and bound them with `wt_trunc()`. + # ps_trunc() refuses scores that are not numbers Code diff --git a/tests/testthat/_snaps/weights-continuous.md b/tests/testthat/_snaps/weights-continuous.md index 9d9705af..7cde5dc0 100644 --- a/tests/testthat/_snaps/weights-continuous.md +++ b/tests/testthat/_snaps/weights-continuous.md @@ -68,6 +68,66 @@ x `.propensity` is , a fit of 2 responses, whose fitted values are 60 by 2. i Fit the exposure on its own, or pass the conditional means of this exposure to `.propensity` as a numeric vector. +# a density does not reach the weights through a modified score + + Code + expr + Condition + Error in `wt_ate()`: + ! Weights for a continuous exposure cannot be built from trimmed propensity scores. + x A continuous exposure has no propensity score, so the values `ps_trim()` trimmed were conditional means rather than probabilities. + i Trim the dose model itself with `ps_trim(method = "density")`, or build weights from the dose model with `wt_ate()` and hold down extreme weights with `wt_trunc()`. + +--- + + Code + expr + Condition + Error in `wt_ate()`: + ! Weights for a continuous exposure cannot be built from truncated propensity scores. + x A continuous exposure has no propensity score, so the values `ps_trunc()` truncated were conditional means rather than probabilities. + i Trim the dose model itself with `ps_trim(method = "density")`, or build weights from the dose model with `wt_ate()` and hold down extreme weights with `wt_trunc()`. + +--- + + Code + expr + Condition + Error in `wt_ate()`: + ! Weights for a continuous exposure cannot be built from calibrated propensity scores. + x A continuous exposure has no propensity score, so the values `ps_calibrate()` calibrated were conditional means rather than probabilities. + i Trim the dose model itself with `ps_trim(method = "density")`, or build weights from the dose model with `wt_ate()` and hold down extreme weights with `wt_trunc()`. + +# censoring weights do not carry a density through a modified score + + Code + expr + Condition + Error in `wt_cens()`: + ! Weights for a continuous exposure cannot be built from trimmed propensity scores. + x A continuous exposure has no propensity score, so the values `ps_trim()` trimmed were conditional means rather than probabilities. + i Trim the dose model itself with `ps_trim(method = "density")`, or build weights from the dose model with `wt_cens()` and hold down extreme weights with `wt_trunc()`. + +--- + + Code + expr + Condition + Error in `wt_cens()`: + ! Weights for a continuous exposure cannot be built from truncated propensity scores. + x A continuous exposure has no propensity score, so the values `ps_trunc()` truncated were conditional means rather than probabilities. + i Trim the dose model itself with `ps_trim(method = "density")`, or build weights from the dose model with `wt_cens()` and hold down extreme weights with `wt_trunc()`. + +--- + + Code + expr + Condition + Error in `wt_cens()`: + ! Weights for a continuous exposure cannot be built from calibrated propensity scores. + x A continuous exposure has no propensity score, so the values `ps_calibrate()` calibrated were conditional means rather than probabilities. + i Trim the dose model itself with `ps_trim(method = "density")`, or build weights from the dose model with `wt_cens()` and hold down extreme weights with `wt_trunc()`. + # an infinite exposure or fitted value is refused where it arrives Code From 72fb640f937f0d56fdb4bb3f5c8ad016c1d5c821 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 18:27:25 -0400 Subject: [PATCH 03/64] add failing tests for modified scores in the data-frame weight route --- tests/testthat/_snaps/ps_trim-categorical.md | 9 + tests/testthat/_snaps/ps_trunc.md | 10 ++ tests/testthat/test-ps_trim-categorical.R | 22 +++ tests/testthat/test-ps_trim.R | 40 +++++ tests/testthat/test-ps_trunc.R | 23 +++ tests/testthat/test-weights-continuous.R | 145 +++++++++++++++ tests/testthat/test-weights.R | 178 +++++++++++++++++++ 7 files changed, 427 insertions(+) diff --git a/tests/testthat/_snaps/ps_trim-categorical.md b/tests/testthat/_snaps/ps_trim-categorical.md index 61dc205a..6a4cd138 100644 --- a/tests/testthat/_snaps/ps_trim-categorical.md +++ b/tests/testthat/_snaps/ps_trim-categorical.md @@ -34,6 +34,15 @@ ! Method "pctl" is not supported for categorical exposures. i Use "ps" or "optimal". +# ps_trim refuses the density method for a matrix of scores + + Code + expr + Condition + Error in `ps_trim()`: + ! Method "density" is not supported for categorical exposures. + i Use "ps" or "optimal". + # ps_trim requires exposure for categorical Code diff --git a/tests/testthat/_snaps/ps_trunc.md b/tests/testthat/_snaps/ps_trunc.md index a81c58d0..bb0d2abf 100644 --- a/tests/testthat/_snaps/ps_trunc.md +++ b/tests/testthat/_snaps/ps_trunc.md @@ -138,6 +138,16 @@ x `.propensity` was fit with `gaussian()`, whose fitted values are conditional means rather than probabilities. i A continuous exposure has no propensity score to bound. To set aside the units whose dose is implausible under the model, trim the dose model with `ps_trim(method = "density")`; to hold down extreme weights while keeping every unit, build them with `wt_ate()` and bound them with `wt_trunc()`. +# ps_trunc() refuses a robust linear model of a dose + + Code + expr + Condition + Error in `ps_trunc()`: + ! Truncation needs a model of the probability of the exposure. + x `.propensity` is , whose fitted values are conditional means rather than probabilities. + i A continuous exposure has no propensity score to bound. To set aside the units whose dose is implausible under the model, trim the dose model with `ps_trim(method = "density")`; to hold down extreme weights while keeping every unit, build them with `wt_ate()` and bound them with `wt_trunc()`. + # ps_trunc() refuses scores that are not numbers Code diff --git a/tests/testthat/test-ps_trim-categorical.R b/tests/testthat/test-ps_trim-categorical.R index 087d07da..57638425 100644 --- a/tests/testthat/test-ps_trim-categorical.R +++ b/tests/testthat/test-ps_trim-categorical.R @@ -174,6 +174,28 @@ test_that("ps_trim errors for unsupported methods with categorical", { ) }) +test_that("ps_trim refuses the density method for a matrix of scores", { + fixture <- valid_trim_matrix_fixture() + + # A matrix holds a probability for each level, and the density methods read + # the conditional density of a continuous exposure, which a matrix of + # categorical scores does not describe. + expect_error( + ps_trim(fixture$ps_matrix, method = "density"), + class = "propensity_method_error" + ) + expect_error( + ps_trim( + fixture$ps_matrix, + .exposure = fixture$exposure, + method = "density" + ), + class = "propensity_method_error" + ) + + expect_propensity_error(ps_trim(fixture$ps_matrix, method = "density")) +}) + test_that("ps_trim requires exposure for categorical", { n <- 20 ps_matrix <- matrix(runif(n * 3), nrow = n, ncol = 3) diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index a0326acc..4d3cd1bf 100644 --- a/tests/testthat/test-ps_trim.R +++ b/tests/testthat/test-ps_trim.R @@ -841,6 +841,46 @@ test_that("ps_refit() refuses a model of a dose for a trimmed score", { expect_propensity_error(ps_refit(trimmed, fits$gaussian, .data = dose_data)) }) +test_that("ps_refit() still refits a trimmed score with any model of a probability", { + skip_if_not_installed("mgcv") + + set.seed(39) + n <- 80 + x <- rnorm(n) + z <- rbinom(n, 1, plogis(0.5 * x)) + score_data <- data.frame(z = z, x = x) + trimmed <- ps_trim(plogis(0.5 * x), method = "ps", lower = 0.3, upper = 0.7) + meta <- ps_trim_meta(trimmed) + expect_gt(length(meta$trimmed_idx), 0) + + # Refusing a model of a dose reads the family, and the families that fit a + # probability pass whatever class carries them. + fits <- list( + gam = mgcv::gam(z ~ s(x), family = binomial(), data = score_data), + quasibinomial = glm(z ~ x, family = quasibinomial(), data = score_data) + ) + + for (kind in names(fits)) { + refit <- ps_refit(trimmed, fits[[kind]], .data = score_data) + + expect_s3_class(refit, "ps_trim") + expect_true(is_refit(refit), info = kind) + expect_true(all(is.na(refit[meta$trimmed_idx])), info = kind) + expect_false(anyNA(refit[meta$keep_idx]), info = kind) + } + + # A quasibinomial fit estimates the same mean as a binomial one. + binomial_refit <- ps_refit( + trimmed, + glm(z ~ x, family = binomial(), data = score_data), + .data = score_data + ) + expect_equal( + as.numeric(ps_refit(trimmed, fits$quasibinomial, .data = score_data)), + as.numeric(binomial_refit) + ) +}) + test_that("combining ps_trim objects drops the trimming record", { x <- trim_record_fixture() diff --git a/tests/testthat/test-ps_trunc.R b/tests/testthat/test-ps_trunc.R index edf3b239..5b82bbf5 100644 --- a/tests/testthat/test-ps_trunc.R +++ b/tests/testthat/test-ps_trunc.R @@ -1846,6 +1846,29 @@ test_that("ps_trunc() refuses a model of a dose and names the routes that work", expect_propensity_error(ps_trunc(fits$gaussian, method = "ps")) }) +test_that("ps_trunc() refuses a robust linear model of a dose", { + skip_if_not_installed("MASS") + + set.seed(33) + n <- 60 + x <- rnorm(n) + dose <- 0.5 * x + rnorm(n) + dose_data <- data.frame(dose = dose, x = x) + fit <- MASS::rlm(dose ~ x, data = dose_data) + + # A robust fit is still a fit of the conditional mean, and it inherits from + # `lm`, so it is refused with the same remedy as a least squares fit. + cnd <- expect_error( + ps_trunc(fit, method = "ps"), + class = "propensity_model_family_error" + ) + message <- gsub("[[:space:]]+", " ", conditionMessage(cnd)) + expect_match(message, "ps_trim(method = \"density\")", fixed = TRUE) + expect_match(message, "wt_trunc()", fixed = TRUE) + + expect_propensity_error(ps_trunc(fit, method = "ps")) +}) + # The exposure is announced when it is read and not otherwise, so the message # reports a reading that happened. Bounding at a fixed threshold or a quantile # reads no exposure; the common range does, and so does every truncation of a diff --git a/tests/testthat/test-weights-continuous.R b/tests/testthat/test-weights-continuous.R index 1188da22..6dca63aa 100644 --- a/tests/testthat/test-weights-continuous.R +++ b/tests/testthat/test-weights-continuous.R @@ -1058,6 +1058,151 @@ test_that("the modified-score methods refuse an exposure they resolve as continu } }) +test_that("a modified score in a data frame is refused for a continuous exposure", { + set.seed(23) + n <- 40 + x <- rnorm(n) + exposure <- 0.5 * x + rnorm(n) + scores <- plogis(0.5 * x) + + modified <- list( + trimmed = ps_trim(scores, method = "ps", lower = 0.2, upper = 0.8), + truncated = ps_trunc(scores, method = "ps", lower = 0.2, upper = 0.8), + calibrated = ps_calibrate(scores, rbinom(n, 1, scores)) + ) + weight_fns <- list(wt_ate = wt_ate, wt_cens = wt_cens) + + # A data frame column keeps the class of the score it holds, so the frame + # carries the same conditional mean modified as if it were a probability, and + # is refused on the same grounds as the score itself. That holds whether the + # type is declared or resolved, and whether the column is the only one or is + # selected from several. + for (modification in names(modified)) { + score <- modified[[modification]] + frames <- list( + alone = data.frame(ps = score), + selected = data.frame(other = scores, ps = score) + ) + + for (fn_name in names(weight_fns)) { + weight_fn <- weight_fns[[fn_name]] + + for (exposure_type in c("continuous", "auto")) { + info <- paste(fn_name, modification, exposure_type) + + expect_error( + weight_fn(frames$alone, exposure, exposure_type = exposure_type), + class = "propensity_modified_continuous_error", + info = info + ) + expect_error( + weight_fn( + frames$selected, + exposure, + .propensity_col = "ps", + exposure_type = exposure_type + ), + class = "propensity_modified_continuous_error", + info = info + ) + } + } + } + + # The refusal names the modification and the weight function called, as it + # does for the score on its own. + expect_propensity_error(wt_ate( + data.frame(ps = modified$trimmed), + exposure, + exposure_type = "continuous" + )) + expect_propensity_error(wt_ate( + data.frame(ps = modified$truncated), + exposure, + exposure_type = "continuous" + )) + expect_propensity_error(wt_ate( + data.frame(ps = modified$calibrated), + exposure, + exposure_type = "continuous" + )) + expect_propensity_error(wt_cens( + data.frame(ps = modified$trimmed), + exposure, + exposure_type = "continuous" + )) + expect_propensity_error(wt_cens( + data.frame(ps = modified$truncated), + exposure, + exposure_type = "continuous" + )) + expect_propensity_error(wt_cens( + data.frame(ps = modified$calibrated), + exposure, + exposure_type = "continuous" + )) +}) + +test_that("a malformed exposure_type on a modified score is reported as malformed", { + set.seed(29) + n <- 40 + x <- rnorm(n) + exposure <- 0.5 * x + rnorm(n) + scores <- plogis(0.5 * x) + + modified <- list( + trimmed = ps_trim(scores, method = "ps", lower = 0.2, upper = 0.8), + truncated = ps_trunc(scores, method = "ps", lower = 0.2, upper = 0.8), + calibrated = ps_calibrate(scores, rbinom(n, 1, scores)) + ) + malformed <- c("continuous", "binary") + + # Two types name no type, so the argument is at fault before anything is + # read from the score or the exposure. The modified-score methods report it + # the way the plain score's route does, rather than reading the argument as + # unset and refusing the score for the exposure it would then resolve to. + weight_fns <- list(wt_ate = wt_ate, wt_cens = wt_cens) + for (fn_name in names(weight_fns)) { + weight_fn <- weight_fns[[fn_name]] + plain <- rlang::catch_cnd( + weight_fn(scores, exposure, exposure_type = malformed), + classes = "error" + ) + expect_match( + conditionMessage(plain), + "`exposure_type` must be one of", + fixed = TRUE, + info = fn_name + ) + + for (modification in names(modified)) { + info <- paste(fn_name, modification) + # Nothing is read before the argument is refused, so the unrefit trim + # does not get as far as warning that it was not refit. + cnd <- expect_no_warning(rlang::catch_cnd( + weight_fn( + modified[[modification]], + exposure, + exposure_type = malformed + ), + classes = "error" + )) + + expect_s3_class(cnd, "error") + expect_false( + inherits(cnd, "propensity_modified_continuous_error"), + info = info + ) + expect_identical(class(cnd), class(plain), info = info) + expect_identical( + conditionMessage(cnd), + conditionMessage(plain), + info = info + ) + } + } +}) + # ---- missing values --------------------------------------------------------- # A unit with no standardized residual has no weight, and the density is asked diff --git a/tests/testthat/test-weights.R b/tests/testthat/test-weights.R index 223a3266..5b2dd0f6 100644 --- a/tests/testthat/test-weights.R +++ b/tests/testthat/test-weights.R @@ -2378,6 +2378,184 @@ test_that("all wt_* functions work with data frames", { expect_equal(weights_entropy, expected_entropy) }) +# Weights from `weight_fn`, recording whether they warned that a trimmed score +# was not refit. Any other warning is left to reach the test. +weights_and_refit_warning <- function(weight_fn, ...) { + warned <- FALSE + weights <- withCallingHandlers( + weight_fn(...), + propensity_no_refit_warning = function(w) { + warned <<- TRUE + invokeRestart("muffleWarning") + } + ) + + list(weights = weights, warned = warned) +} + +test_that("a modified score in a data frame keeps its record for a binary exposure", { + set.seed(41) + n <- 60 + x <- rnorm(n) + scores <- plogis(0.5 * x) + exposure <- rbinom(n, 1, scores) + + # The bounds sit inside the range of the scores, so units are set aside and + # moved, and the frames below carry missing scores in the modified column + # while the other column stays whole. + trimmed <- ps_trim(scores, method = "ps", lower = 0.35, upper = 0.65) + truncated <- ps_trunc(scores, method = "ps", lower = 0.35, upper = 0.65) + trimmed_idx <- ps_trim_meta(trimmed)$trimmed_idx + expect_gt(length(trimmed_idx), 0) + expect_gt(length(ps_trunc_meta(truncated)$truncated_idx), 0) + + refit <- ps_refit(trimmed, glm(exposure ~ x, family = binomial())) + expect_true(is_refit(refit)) + expect_identical(which(is.na(refit)), trimmed_idx) + + modified <- list( + trimmed = trimmed, + refit = refit, + truncated = truncated, + calibrated = ps_calibrate(scores, exposure) + ) + weight_fns <- list( + wt_ate = wt_ate, + wt_att = wt_att, + wt_atu = wt_atu, + wt_atm = wt_atm, + wt_ato = wt_ato, + wt_entropy = wt_entropy, + wt_cens = wt_cens + ) + + # A data frame column keeps the class of the score it holds, so weights built + # from the frame were built from the same modified score as weights built + # from the column itself, and say so the same way: the estimand names the + # modification, the record travels, the units set aside have no weight, and + # a trimmed score that was not refit warns that it was not. That holds + # whether the type is declared or resolved by the frame route itself. + for (modification in names(modified)) { + score <- modified[[modification]] + set_aside <- modification %in% c("trimmed", "refit") + frames <- list( + alone = data.frame(ps = score), + positional = data.frame(control = 1 - scores, treated = score), + selected = data.frame(ps = score, other = scores) + ) + + for (fn_name in names(weight_fns)) { + weight_fn <- weight_fns[[fn_name]] + + for (exposure_type in c("binary", "auto")) { + from_vector <- weights_and_refit_warning( + weight_fn, + score, + exposure, + exposure_type = exposure_type + ) + vector_info <- paste(fn_name, modification, exposure_type, "vector") + expect_identical( + from_vector$warned, + identical(modification, "trimmed"), + info = vector_info + ) + expect_identical( + which(is.na(from_vector$weights)), + if (set_aside) trimmed_idx else integer(0), + info = vector_info + ) + + for (frame in names(frames)) { + info <- paste(fn_name, modification, exposure_type, frame) + args <- list(frames[[frame]], exposure, exposure_type = exposure_type) + if (identical(frame, "selected")) { + args$.propensity_col <- "ps" + } + from_frame <- rlang::exec( + weights_and_refit_warning, + weight_fn, + !!!args + ) + + expect_identical(from_frame$warned, from_vector$warned, info = info) + expect_identical( + estimand(from_frame$weights), + estimand(from_vector$weights), + info = info + ) + expect_identical( + is_ps_trimmed(from_frame$weights), + is_ps_trimmed(from_vector$weights), + info = info + ) + expect_identical( + is_ps_truncated(from_frame$weights), + is_ps_truncated(from_vector$weights), + info = info + ) + expect_identical( + is_ps_calibrated(from_frame$weights), + is_ps_calibrated(from_vector$weights), + info = info + ) + expect_identical( + which(is.na(from_frame$weights)), + which(is.na(from_vector$weights)), + info = info + ) + expect_equal(from_frame$weights, from_vector$weights, info = info) + } + } + } + } +}) + +test_that("a data frame of trimmed categorical scores still gives weights", { + set.seed(43) + n <- 100 + exposure <- factor(sample(c("A", "B", "C"), n, replace = TRUE)) + ps_matrix <- matrix(runif(n * 3), nrow = n, ncol = 3) + ps_matrix <- ps_matrix / rowSums(ps_matrix) + colnames(ps_matrix) <- levels(exposure) + + modified <- list( + trimmed = ps_trim(ps_matrix, .exposure = exposure, lower = 0.1), + truncated = ps_trunc(ps_matrix, .exposure = exposure, lower = 0.1) + ) + + # A matrix of modified scores converts to a data frame of plain columns, so + # the frame holds the modified values without the record. The frame is still + # a categorical frame of scores, and its weights are the matrix's weights. + for (modification in names(modified)) { + score <- modified[[modification]] + from_matrix <- weights_and_refit_warning( + wt_ate, + score, + exposure, + exposure_type = "categorical" + ) + expect_identical( + from_matrix$warned, + identical(modification, "trimmed"), + info = modification + ) + + from_frame <- wt_ate( + as.data.frame(score), + exposure, + exposure_type = "categorical" + ) + + expect_s3_class(from_frame, "psw") + expect_equal( + as.numeric(from_frame), + as.numeric(from_matrix$weights), + info = modification + ) + } +}) + # ---- data frame columns resolve by focal level name ------------------------ # A data frame of per-level probabilities whose columns are named for the From c99d2418c19cd7ce26ba5d30a2ee9e287d6b0d9b Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 18:44:25 -0400 Subject: [PATCH 04/64] keep modified score records in the data-frame weight route and refuse them for a continuous exposure --- NEWS.md | 10 ++++ R/weights-utils.R | 50 ++++++++++++++--- tests/testthat/_snaps/weights-continuous.md | 60 +++++++++++++++++++++ 3 files changed, 113 insertions(+), 7 deletions(-) diff --git a/NEWS.md b/NEWS.md index 1b497b3f..4c0f0759 100644 --- a/NEWS.md +++ b/NEWS.md @@ -23,6 +23,16 @@ build the weights of a continuous exposure from the dose model or its fitted means directly, without a score modification. + A data frame of scores now behaves as the vector it holds does. A trimmed, + truncated, or calibrated column in a data frame passed to any `wt_*()` + function reached the weights as plain scores, so for a binary exposure its + trimming, truncation, or calibration record was silently dropped, along with + the warning that a trimmed score was not refit. The column now keeps its + record for a binary exposure, and is refused for a continuous exposure as + the vector is. A malformed `exposure_type` naming several types is now + reported as a malformed argument on the modified-score methods, rather than + read as unset and refused as a continuous exposure. + * `dens_t()` now estimates the scale of the t under the t itself by default, as `dens_laplace()` estimates the scale of the Laplace. Both densities of a continuous exposure's weights are read at a residual standardized by a spread diff --git a/R/weights-utils.R b/R/weights-utils.R index a88b1575..b13cd26a 100644 --- a/R/weights-utils.R +++ b/R/weights-utils.R @@ -1335,6 +1335,19 @@ calculate_weight_from_modified_ps <- function( modification_type <- rlang::arg_match(modification_type) + # An argument of several types is either the method's own unmatched set of + # choices or malformed. It is matched against the choices the numeric method + # matches it against, so a malformed one is refused as the plain score's + # route refuses it, before anything is read from the score. + exposure_type <- list(...)[["exposure_type"]] + if (length(exposure_type) > 1) { + exposure_type <- rlang::arg_match( + exposure_type, + eval(formals(weight_fn)[["exposure_type"]]), + error_call = call + ) + } + # Read before the refit check, so that a pairing that is refused outright is # not also advised to refit. check_modified_ps_exposure( @@ -1342,7 +1355,7 @@ calculate_weight_from_modified_ps <- function( .exposure, weight_fn = weight_fn, modification_type = modification_type, - exposure_type = list(...)[["exposure_type"]], + exposure_type = exposure_type, call = call ) @@ -1440,12 +1453,9 @@ check_modified_ps_exposure <- function( return(invisible(NULL)) } - # An unmatched argument arrives as the method's own set of choices, whose - # first is `"auto"`. A value that names no type at all is left for the - # numeric method to refuse, where every other malformed argument is refused. - if (length(exposure_type) > 1) { - exposure_type <- "auto" - } + # The argument arrives matched when it held several types. A single value + # that names no type at all is left for the numeric method to refuse, where + # every other malformed argument is refused. exposure_types <- c("auto", "binary", "categorical", "continuous") if (!rlang::is_string(exposure_type) || !exposure_type %in% exposure_types) { return(invisible(NULL)) @@ -1906,6 +1916,32 @@ handle_data_frame_weight_calculation <- function( call = call ) + # A column keeps the class of the score it holds, so a trimmed, truncated, + # or calibrated column takes the route that score takes on its own: its + # record travels to the weights, and it is refused for an exposure it does + # not describe. + modification_type <- if (inherits(ps_vec, "ps_trim")) { + "trim" + } else if (inherits(ps_vec, "ps_trunc")) { + "trunc" + } else if (inherits(ps_vec, "ps_calib")) { + "calib" + } + + if (!is.null(modification_type)) { + return(calculate_weight_from_modified_ps( + .propensity = ps_vec, + .exposure = .exposure, + weight_fn = weight_fn_numeric, + modification_type = modification_type, + exposure_type = exposure_type_check, + .focal_level = focal_params$.focal_level, + .reference_level = focal_params$.reference_level, + ..., + call = call + )) + } + # The numeric method is reached by value here, so its own frame deparses as # `weight_fn_numeric()`. Hand it the call the route was entered on. weight_fn_numeric( diff --git a/tests/testthat/_snaps/weights-continuous.md b/tests/testthat/_snaps/weights-continuous.md index 7cde5dc0..7103b31c 100644 --- a/tests/testthat/_snaps/weights-continuous.md +++ b/tests/testthat/_snaps/weights-continuous.md @@ -128,6 +128,66 @@ x A continuous exposure has no propensity score, so the values `ps_calibrate()` calibrated were conditional means rather than probabilities. i Trim the dose model itself with `ps_trim(method = "density")`, or build weights from the dose model with `wt_cens()` and hold down extreme weights with `wt_trunc()`. +# a modified score in a data frame is refused for a continuous exposure + + Code + expr + Condition + Error in `wt_ate()`: + ! Weights for a continuous exposure cannot be built from trimmed propensity scores. + x A continuous exposure has no propensity score, so the values `ps_trim()` trimmed were conditional means rather than probabilities. + i Trim the dose model itself with `ps_trim(method = "density")`, or build weights from the dose model with `wt_ate()` and hold down extreme weights with `wt_trunc()`. + +--- + + Code + expr + Condition + Error in `wt_ate()`: + ! Weights for a continuous exposure cannot be built from truncated propensity scores. + x A continuous exposure has no propensity score, so the values `ps_trunc()` truncated were conditional means rather than probabilities. + i Trim the dose model itself with `ps_trim(method = "density")`, or build weights from the dose model with `wt_ate()` and hold down extreme weights with `wt_trunc()`. + +--- + + Code + expr + Condition + Error in `wt_ate()`: + ! Weights for a continuous exposure cannot be built from calibrated propensity scores. + x A continuous exposure has no propensity score, so the values `ps_calibrate()` calibrated were conditional means rather than probabilities. + i Trim the dose model itself with `ps_trim(method = "density")`, or build weights from the dose model with `wt_ate()` and hold down extreme weights with `wt_trunc()`. + +--- + + Code + expr + Condition + Error in `wt_cens()`: + ! Weights for a continuous exposure cannot be built from trimmed propensity scores. + x A continuous exposure has no propensity score, so the values `ps_trim()` trimmed were conditional means rather than probabilities. + i Trim the dose model itself with `ps_trim(method = "density")`, or build weights from the dose model with `wt_cens()` and hold down extreme weights with `wt_trunc()`. + +--- + + Code + expr + Condition + Error in `wt_cens()`: + ! Weights for a continuous exposure cannot be built from truncated propensity scores. + x A continuous exposure has no propensity score, so the values `ps_trunc()` truncated were conditional means rather than probabilities. + i Trim the dose model itself with `ps_trim(method = "density")`, or build weights from the dose model with `wt_cens()` and hold down extreme weights with `wt_trunc()`. + +--- + + Code + expr + Condition + Error in `wt_cens()`: + ! Weights for a continuous exposure cannot be built from calibrated propensity scores. + x A continuous exposure has no propensity score, so the values `ps_calibrate()` calibrated were conditional means rather than probabilities. + i Trim the dose model itself with `ps_trim(method = "density")`, or build weights from the dose model with `wt_cens()` and hold down extreme weights with `wt_trunc()`. + # an infinite exposure or fitted value is refused where it arrives Code From 8ed16e96306db94a9ce66e0196520ffe6ad57586 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 19:04:32 -0400 Subject: [PATCH 05/64] add failing tests for trimming a dose model on the density scale --- tests/testthat/helper-dose-trim.R | 159 ++++ tests/testthat/test-ps_trim-density.R | 1006 +++++++++++++++++++++++++ 2 files changed, 1165 insertions(+) create mode 100644 tests/testthat/helper-dose-trim.R create mode 100644 tests/testthat/test-ps_trim-density.R diff --git a/tests/testthat/helper-dose-trim.R b/tests/testthat/helper-dose-trim.R new file mode 100644 index 00000000..2ecd109f --- /dev/null +++ b/tests/testthat/helper-dose-trim.R @@ -0,0 +1,159 @@ +# Fixtures and oracles for trimming a dose model on the scale of its conditional +# density. +# +# The dose is drawn with t(3) residuals so that a few units sit far enough from +# their predicted dose for a trim to find, and so that the scale estimators the +# density families take disagree by enough to move a fixed residual bound. +sim_dose_trim <- function(seed = 1234, n = 60) { + withr::local_seed(seed) + x1 <- rnorm(n) + x2 <- rnorm(n) + a <- 1 + 0.6 * x1 - 0.4 * x2 + stats::rt(n, df = 3) + data.frame(a = a, x1 = x1, x2 = x2) +} + +# The spread a density family reads its residuals at, computed here without the +# package's estimators. The root mean square is uncentered, because the +# residuals of a fitted model already average to zero. The Laplace scale is the +# mean absolute residual. The t scale is the root of the estimating equation +# `mean((df + 1) r^2 / (df s^2 + r^2)) = 1`, bracketed between a scale far +# below the root mean square, where the left side tends to `df + 1`, and one +# far above it, where it tends to zero. +dose_trim_sigma <- function( + residuals, + family = c("normal", "t", "laplace", "kernel", "function"), + sigma_method = "rms", + df = NULL +) { + family <- match.arg(family) + r <- residuals[!is.na(residuals)] + rms <- sqrt(mean(r^2)) + + if (!identical(sigma_method, "mle")) { + return(rms) + } + + switch( + family, + laplace = mean(abs(r)), + t = stats::uniroot( + function(s) mean((df + 1) * r^2 / (df * s^2 + r^2)) - 1, + interval = rms * c(1e-3, 10), + tol = 1e-14, + maxiter = 1000 + )$root, + stop("No maximum likelihood scale for this family.") + ) +} + +# The standardized density `g` of each family, written out. +dose_trim_g <- function(z, family, df = NULL, fn = NULL) { + switch( + family, + normal = stats::dnorm(z), + t = stats::dt(z, df = df), + laplace = exp(-abs(z)) / 2, + "function" = fn(z) + ) +} + +# A Gaussian kernel estimate of the standardized residuals that are present, fit +# over their range at the `stats::density()` defaults and interpolated to each. +dose_trim_kernel <- function(z) { + present <- !is.na(z) + fit <- stats::density( + z[present], + bw = "nrd0", + adjust = 1, + kernel = "gaussian", + n = 512, + from = min(z[present]), + to = max(z[present]) + ) + out <- rep(NA_real_, length(z)) + out[present] <- stats::approxfun(fit$x, fit$y)(z[present]) + out +} + +# What a density trim of the dose `a` around the conditional means `mu` keeps, +# worked out by hand. `"density"` keeps the units whose conditional density +# `g(z) / sigma` is at least its `lower` quantile; `"resid"` keeps those whose +# absolute standardized residual is at most `upper`, and records the density +# floor `g(upper) / sigma` that bound is equivalent to. A unit with a missing +# mean or dose takes no part in either. +dose_trim_oracle <- function( + a, + mu, + method = c("density", "resid"), + family = "normal", + sigma_method = "rms", + df = NULL, + fn = NULL, + sigma = NULL, + lower = 0.01, + upper = NULL +) { + method <- match.arg(method) + a <- as.numeric(a) + mu <- as.numeric(mu) + r <- a - mu + if (is.null(sigma)) { + sigma <- dose_trim_sigma(r, family, sigma_method, df) + } + z <- r / sigma + + g <- if (identical(family, "kernel")) { + dose_trim_kernel(z) + } else { + dose_trim_g(z, family, df = df, fn = fn) + } + f <- g / sigma + observed <- !is.na(f) + + if (method == "density") { + threshold <- unname(stats::quantile(f, probs = lower, na.rm = TRUE)) + keep_idx <- which(f >= threshold) + } else { + threshold <- dose_trim_g(upper, family, df = df, fn = fn) / sigma + keep_idx <- which(abs(z) <= upper) + } + + list( + mu = mu, + sigma = sigma, + z = z, + f = f, + threshold = threshold, + keep_idx = keep_idx, + trimmed_idx = setdiff(which(observed), keep_idx) + ) +} + +# Holds a density trim against its oracle: the retained and trimmed positions, +# the retained values, which are the conditional means, and the realized floor. +expect_dose_trim <- function(trimmed, oracle, n) { + meta <- ps_trim_meta(trimmed) + + testthat::expect_s3_class(trimmed, "ps_trim") + testthat::expect_identical(as.integer(meta$keep_idx), oracle$keep_idx) + testthat::expect_identical( + as.integer(meta$trimmed_idx), + as.integer(oracle$trimmed_idx) + ) + testthat::expect_identical(meta$n_obs, n) + testthat::expect_equal(meta$sigma, oracle$sigma, tolerance = 1e-8) + testthat::expect_equal(meta$threshold, oracle$threshold, tolerance = 1e-8) + + values <- as.numeric(trimmed) + testthat::expect_true(all(is.na(values[oracle$trimmed_idx]))) + testthat::expect_equal( + values[oracle$keep_idx], + oracle$mu[oracle$keep_idx], + tolerance = 1e-12 + ) + + # A fixture that trims nothing, or everything, would pass the comparisons + # above without exercising the rule. + testthat::expect_gt(length(oracle$trimmed_idx), 0) + testthat::expect_gt(length(oracle$keep_idx), 0) +} diff --git a/tests/testthat/test-ps_trim-density.R b/tests/testthat/test-ps_trim-density.R new file mode 100644 index 00000000..0bfe5f48 --- /dev/null +++ b/tests/testthat/test-ps_trim-density.R @@ -0,0 +1,1006 @@ +# Trimming a dose model on the scale of its conditional density +# +# For a continuous exposure the generalized propensity score is the conditional +# density f(a | x), and a unit whose observed dose the model finds implausible +# has a small one. `ps_trim()` on a dose model sets those units aside, by a +# quantile floor on the density (`"density"`) or by a bound on the absolute +# standardized residual (`"resid"`), and keeps the conditional means of the rest. +# Every expectation below is held against a density worked out by hand in +# helper-dose-trim.R from the model's residuals, the family's density, and the +# family's own scale. + +# ---- "density": a quantile floor -------------------------------------------- + +test_that("ps_trim() floors the conditional density of a lm fit at a quantile", { + dat <- sim_dose_trim() + n <- nrow(dat) + fit <- lm(a ~ x1 + x2, data = dat) + + trimmed <- ps_trim(fit, method = "density") + oracle <- dose_trim_oracle(dat$a, fitted(fit), method = "density") + expect_dose_trim(trimmed, oracle, n) + + # The default floor is the first percentile, which on sixty units sets one + # aside. + meta <- ps_trim_meta(trimmed) + expect_identical(meta$method, "density") + expect_identical(meta$lower, 0.01) + expect_null(meta$upper) + expect_length(meta$trimmed_idx, 1) + + # The spread is the pooled root mean square, the one a normal density is + # read at, and the family is the default normal, resolved to a specification. + expect_identical(meta$sigma_kind, "pooled") + expect_s3_class(meta$density, "propensity_density") + expect_identical(meta$density$family, "normal") + + # A higher floor sets more aside, and at the tenth percentile it is six. + trimmed_10 <- ps_trim(fit, method = "density", lower = 0.1) + oracle_10 <- dose_trim_oracle( + dat$a, + fitted(fit), + method = "density", + lower = 0.1 + ) + expect_dose_trim(trimmed_10, oracle_10, n) + expect_length(ps_trim_meta(trimmed_10)$trimmed_idx, 6) + expect_identical(ps_trim_meta(trimmed_10)$lower, 0.1) + + expect_true(is_ps_trimmed(trimmed)) + expect_identical( + is_unit_trimmed(trimmed_10), + seq_len(n) %in% oracle_10$trimmed_idx + ) +}) + +test_that("ps_trim() reads a t density at its own scale unless asked for the root mean square", { + dat <- sim_dose_trim() + n <- nrow(dat) + fit <- lm(a ~ x1 + x2, data = dat) + + mle <- ps_trim(fit, method = "density", lower = 0.05, .density = dens_t(4)) + oracle_mle <- dose_trim_oracle( + dat$a, + fitted(fit), + method = "density", + family = "t", + df = 4, + sigma_method = "mle", + lower = 0.05 + ) + expect_dose_trim(mle, oracle_mle, n) + expect_identical(ps_trim_meta(mle)$sigma_kind, "mle") + expect_identical(ps_trim_meta(mle)$density$family, "t") + expect_identical(ps_trim_meta(mle)$density$params$df, 4) + expect_identical(ps_trim_meta(mle)$density$sigma_method, "mle") + + rms <- ps_trim( + fit, + method = "density", + lower = 0.05, + .density = dens_t(4, sigma_method = "rms") + ) + oracle_rms <- dose_trim_oracle( + dat$a, + fitted(fit), + method = "density", + family = "t", + df = 4, + sigma_method = "rms", + lower = 0.05 + ) + expect_dose_trim(rms, oracle_rms, n) + expect_identical(ps_trim_meta(rms)$sigma_kind, "pooled") + expect_identical(ps_trim_meta(rms)$density$sigma_method, "rms") + + # The two scales are different numbers, so the floors are too. A quantile + # floor on a symmetric unimodal density ranks the units by their absolute + # residual whatever the scale, so the two agree on which units go; the fixed + # residual bound below is where the scale decides membership. + expect_gt(abs(oracle_mle$sigma - oracle_rms$sigma), 0.1) + expect_false(isTRUE(all.equal( + ps_trim_meta(mle)$threshold, + ps_trim_meta(rms)$threshold + ))) +}) + +test_that("ps_trim() reads a Laplace density at its mean absolute residual", { + dat <- sim_dose_trim() + n <- nrow(dat) + fit <- lm(a ~ x1 + x2, data = dat) + + trimmed <- ps_trim( + fit, + method = "density", + lower = 0.05, + .density = dens_laplace() + ) + oracle <- dose_trim_oracle( + dat$a, + fitted(fit), + method = "density", + family = "laplace", + sigma_method = "mle", + lower = 0.05 + ) + expect_dose_trim(trimmed, oracle, n) + expect_equal(ps_trim_meta(trimmed)$sigma, mean(abs(residuals(fit)))) + expect_identical(ps_trim_meta(trimmed)$sigma_kind, "mle") + + # The name of a family resolves to the specification the constructor builds, + # which for the Laplace carries its own scale estimator. + by_name <- ps_trim( + fit, + method = "density", + lower = 0.05, + .density = "laplace" + ) + expect_dose_trim(by_name, oracle, n) + expect_s3_class(ps_trim_meta(by_name)$density, "propensity_density") + expect_identical(ps_trim_meta(by_name)$density$family, "laplace") + expect_identical(ps_trim_meta(by_name)$density$sigma_method, "mle") +}) + +test_that("ps_trim() floors a kernel or user-written density on the same rule", { + dat <- sim_dose_trim() + n <- nrow(dat) + fit <- lm(a ~ x1 + x2, data = dat) + + # A kernel is fit to the standardized residuals, so the quantile floor + # composes with a density no family describes. + kernel <- ps_trim( + fit, + method = "density", + lower = 0.1, + .density = dens_kernel() + ) + oracle_kernel <- dose_trim_oracle( + dat$a, + fitted(fit), + method = "density", + family = "kernel", + lower = 0.1 + ) + expect_dose_trim(kernel, oracle_kernel, n) + expect_identical(ps_trim_meta(kernel)$sigma_kind, "pooled") + expect_identical(ps_trim_meta(kernel)$density$family, "kernel") + + t4 <- function(z) stats::dt(z, df = 4) + written <- ps_trim( + fit, + method = "density", + lower = 0.1, + .density = dens_fn(t4) + ) + oracle_written <- dose_trim_oracle( + dat$a, + fitted(fit), + method = "density", + family = "function", + fn = t4, + lower = 0.1 + ) + expect_dose_trim(written, oracle_written, n) + expect_identical(ps_trim_meta(written)$sigma_kind, "pooled") + expect_identical(ps_trim_meta(written)$density$family, "function") + + # A bare function is wrapped the way the weight functions wrap one. + bare <- ps_trim(fit, method = "density", lower = 0.1, .density = t4) + expect_dose_trim(bare, oracle_written, n) + expect_identical(ps_trim_meta(bare)$density$family, "function") +}) + +test_that("ps_trim() trims a gaussian glm as it trims the lm it matches", { + dat <- sim_dose_trim() + n <- nrow(dat) + fit_lm <- lm(a ~ x1 + x2, data = dat) + fit_glm <- glm(a ~ x1 + x2, data = dat, family = gaussian()) + + from_glm <- ps_trim(fit_glm, method = "density", lower = 0.05) + oracle <- dose_trim_oracle( + dat$a, + fitted(fit_glm), + method = "density", + lower = 0.05 + ) + expect_dose_trim(from_glm, oracle, n) + expect_identical( + ps_trim_meta(from_glm)$keep_idx, + ps_trim_meta(ps_trim(fit_lm, method = "density", lower = 0.05))$keep_idx + ) + + resid <- ps_trim(fit_glm, method = "resid", upper = 2) + expect_dose_trim( + resid, + dose_trim_oracle(dat$a, fitted(fit_glm), method = "resid", upper = 2), + n + ) + + # A family estimating its own scale reads it off the glm's residuals too. + t_glm <- ps_trim( + fit_glm, + method = "density", + lower = 0.05, + .density = dens_t(4) + ) + expect_dose_trim( + t_glm, + dose_trim_oracle( + dat$a, + fitted(fit_glm), + method = "density", + family = "t", + df = 4, + sigma_method = "mle", + lower = 0.05 + ), + n + ) + expect_identical(ps_trim_meta(t_glm)$sigma_kind, "mle") +}) + +test_that("ps_trim() reads a gaussian glm under a log link on the dose's own scale", { + dat <- sim_dose_trim() + dat$a <- dat$a + 10 + n <- nrow(dat) + fit <- glm(a ~ x1 + x2, data = dat, family = gaussian(link = "log")) + + # `fitted()` is on the scale of the dose whatever the link, so the residuals + # are the dose less its fitted mean, not anything on the linear predictor. + trimmed <- ps_trim(fit, method = "density", lower = 0.05) + oracle <- dose_trim_oracle( + dat$a, + fitted(fit), + method = "density", + lower = 0.05 + ) + expect_dose_trim(trimmed, oracle, n) + + resid <- ps_trim(fit, method = "resid", upper = 2) + expect_dose_trim( + resid, + dose_trim_oracle(dat$a, fitted(fit), method = "resid", upper = 2), + n + ) +}) + +test_that("ps_trim() trims the dose models wt_ate() reads by inheritance", { + dat <- sim_dose_trim() + n <- nrow(dat) + + skip_if_not_installed("MASS") + fit_rlm <- MASS::rlm(a ~ x1 + x2, data = dat) + # The spread is the family's estimator on the residuals, not the robust + # scale `rlm` reports, which a caller passes as `.sigma` if they want it. + expect_dose_trim( + ps_trim(fit_rlm, method = "density", lower = 0.05), + dose_trim_oracle(dat$a, fitted(fit_rlm), method = "density", lower = 0.05), + n + ) + expect_dose_trim( + ps_trim(fit_rlm, method = "resid", upper = 2, .density = dens_t(4)), + dose_trim_oracle( + dat$a, + fitted(fit_rlm), + method = "resid", + family = "t", + df = 4, + sigma_method = "mle", + upper = 2 + ), + n + ) + + skip_if_not_installed("mgcv") + fit_gam <- mgcv::gam(a ~ s(x1) + x2, data = dat, family = gaussian()) + expect_dose_trim( + ps_trim(fit_gam, method = "density", lower = 0.05), + dose_trim_oracle(dat$a, fitted(fit_gam), method = "density", lower = 0.05), + n + ) + expect_dose_trim( + ps_trim(fit_gam, method = "resid", upper = 2, .density = dens_laplace()), + dose_trim_oracle( + dat$a, + fitted(fit_gam), + method = "resid", + family = "laplace", + sigma_method = "mle", + upper = 2 + ), + n + ) +}) + +# ---- "resid": a standardized-residual bound ---------------------------------- + +test_that("ps_trim() bounds the absolute standardized residual under each symmetric family", { + dat <- sim_dose_trim() + n <- nrow(dat) + fit <- lm(a ~ x1 + x2, data = dat) + + cases <- list( + normal = list( + density = dens_normal(), + family = "normal", + sigma_method = "rms", + kind = "pooled" + ), + t_mle = list( + density = dens_t(4), + family = "t", + sigma_method = "mle", + kind = "mle" + ), + t_rms = list( + density = dens_t(4, sigma_method = "rms"), + family = "t", + sigma_method = "rms", + kind = "pooled" + ), + laplace_mle = list( + density = dens_laplace(), + family = "laplace", + sigma_method = "mle", + kind = "mle" + ), + laplace_rms = list( + density = dens_laplace(sigma_method = "rms"), + family = "laplace", + sigma_method = "rms", + kind = "pooled" + ) + ) + + kept <- list() + for (case in names(cases)) { + spec <- cases[[case]] + trimmed <- ps_trim( + fit, + method = "resid", + upper = 2, + .density = spec$density + ) + oracle <- dose_trim_oracle( + dat$a, + fitted(fit), + method = "resid", + family = spec$family, + df = 4, + sigma_method = spec$sigma_method, + upper = 2 + ) + expect_dose_trim(trimmed, oracle, n) + + meta <- ps_trim_meta(trimmed) + expect_identical(meta$method, "resid", info = case) + expect_identical(meta$upper, 2, info = case) + expect_null(meta$lower) + expect_identical(meta$sigma_kind, spec$kind, info = case) + + # The bound is a density floor written in residual units: the record keeps + # that floor, g(k) / sigma, and it keeps exactly the units whose density + # reaches it. + expect_equal( + meta$threshold, + oracle$threshold, + tolerance = 1e-12, + info = case + ) + expect_identical( + as.integer(meta$keep_idx), + which(oracle$f >= meta$threshold), + info = case + ) + + kept[[case]] <- as.integer(meta$keep_idx) + } + + # At a fixed bound the scale decides membership: the t and Laplace scales a + # family estimates for itself are smaller than the root mean square, so the + # same bound reaches a unit the root mean square leaves in. + expect_gt(length(setdiff(kept$t_rms, kept$t_mle)), 0) + expect_gt(length(setdiff(kept$laplace_rms, kept$laplace_mle)), 0) + expect_identical(kept$normal, kept$t_rms) +}) + +test_that("ps_trim() reads a supplied spread and records it as supplied", { + dat <- sim_dose_trim() + n <- nrow(dat) + fit <- lm(a ~ x1 + x2, data = dat) + + resid <- ps_trim(fit, method = "resid", upper = 2, .sigma = 1.5) + oracle_resid <- dose_trim_oracle( + dat$a, + fitted(fit), + method = "resid", + sigma = 1.5, + upper = 2 + ) + expect_dose_trim(resid, oracle_resid, n) + expect_identical(ps_trim_meta(resid)$sigma, 1.5) + expect_identical(ps_trim_meta(resid)$sigma_kind, "supplied") + + # A family asked for the root mean square takes a spread of the caller's in + # its place; only a family estimating its own scale refuses one. + density <- ps_trim( + fit, + method = "density", + lower = 0.05, + .sigma = 0.8, + .density = dens_t(4, sigma_method = "rms") + ) + oracle_density <- dose_trim_oracle( + dat$a, + fitted(fit), + method = "density", + family = "t", + df = 4, + sigma = 0.8, + lower = 0.05 + ) + expect_dose_trim(density, oracle_density, n) + expect_identical(ps_trim_meta(density)$sigma_kind, "supplied") +}) + +# ---- missing values ---------------------------------------------------------- + +test_that("ps_trim() leaves a unit with a missing mean or dose out of a density trim", { + dat <- sim_dose_trim() + n <- nrow(dat) + missing_x <- c(4L, 30L) + dat$x1[missing_x] <- NA + fit <- lm(a ~ x1 + x2, data = dat, na.action = na.exclude) + + # A covariate the model dropped leaves a missing mean, padded back to the + # length of the data. + mu <- fitted(fit) + expect_true(all(is.na(mu[missing_x]))) + + trimmed <- ps_trim(fit, method = "density", lower = 0.05) + oracle <- dose_trim_oracle(dat$a, mu, method = "density", lower = 0.05) + expect_dose_trim(trimmed, oracle, n) + meta <- ps_trim_meta(trimmed) + expect_false(any(missing_x %in% meta$keep_idx)) + expect_false(any(missing_x %in% meta$trimmed_idx)) + expect_false(any(is_unit_trimmed(trimmed)[missing_x])) + + # The floor is the one the complete units alone give. + complete <- setdiff(seq_len(n), missing_x) + oracle_complete <- dose_trim_oracle( + dat$a[complete], + mu[complete], + method = "density", + lower = 0.05 + ) + expect_equal(meta$threshold, oracle_complete$threshold, tolerance = 1e-12) + + # A dose missing from the exposure supplied beside a complete fit leaves a + # missing residual in the same way. + fit_full <- lm(a ~ x2, data = sim_dose_trim()) + dose <- sim_dose_trim()$a + missing_a <- c(9L, 51L) + dose[missing_a] <- NA + resid <- ps_trim(fit_full, method = "resid", upper = 1.5, .exposure = dose) + oracle_resid <- dose_trim_oracle( + dose, + fitted(fit_full), + method = "resid", + upper = 1.5 + ) + expect_dose_trim(resid, oracle_resid, n) + meta_resid <- ps_trim_meta(resid) + expect_false(any(missing_a %in% meta_resid$keep_idx)) + expect_false(any(missing_a %in% meta_resid$trimmed_idx)) +}) + +# ---- the record -------------------------------------------------------------- + +# The record names all ten fields whichever method made it, holding `NULL` for +# the bound the method does not read, as `list()` keeps a `NULL` entry by name. +test_that("the density trim record carries the fields that describe the cut", { + dat <- sim_dose_trim() + fit <- lm(a ~ x1 + x2, data = dat) + + for (method in c("density", "resid")) { + trimmed <- if (method == "density") { + ps_trim(fit, method = method) + } else { + ps_trim(fit, method = method, upper = 2) + } + meta <- ps_trim_meta(trimmed) + expect_true( + all( + c( + "method", + "lower", + "upper", + "threshold", + "sigma", + "sigma_kind", + "density", + "keep_idx", + "trimmed_idx", + "n_obs" + ) %in% + names(meta) + ), + info = method + ) + expect_true(is.numeric(meta$threshold) && length(meta$threshold) == 1) + expect_true(meta$threshold > 0) + expect_true(is.numeric(meta$sigma) && length(meta$sigma) == 1) + expect_null(meta$refit) + } +}) + +test_that("trim_parameters() tells apart density trims cut at different places", { + dat <- sim_dose_trim() + fit <- lm(a ~ x1 + x2, data = dat) + meta <- ps_trim_meta( + ps_trim(fit, method = "resid", upper = 2, .density = dens_t(4)) + ) + params <- trim_parameters(meta) + + for (field in c("threshold", "sigma", "sigma_kind", "density")) { + expect_true(field %in% names(params), info = field) + } + + differs <- function(changed) { + !identical(params, trim_parameters(changed)) + } + + other_spread <- meta + other_spread$sigma <- meta$sigma * 1.1 + expect_true(differs(other_spread)) + + other_threshold <- meta + other_threshold$threshold <- meta$threshold * 1.1 + expect_true(differs(other_threshold)) + + other_kind <- meta + other_kind$sigma_kind <- "supplied" + expect_true(differs(other_kind)) + + other_family <- meta + other_family$density <- dens_laplace() + expect_true(differs(other_family)) + + other_df <- meta + other_df$density <- dens_t(5) + expect_true(differs(other_df)) + + other_method <- meta + other_method$density <- dens_t(4, sigma_method = "rms") + expect_true(differs(other_method)) + + # Each constructor call writes a fresh function, so a specification built + # again is compared on what identifies it rather than on its closure. + same_family <- meta + same_family$density <- dens_t(4) + expect_false(differs(same_family)) + + # A density written by the caller is identified by the function itself. + meta_fn <- ps_trim_meta( + ps_trim( + fit, + method = "density", + .density = dens_fn(function(z) stats::dt(z, df = 4)) + ) + ) + other_fn <- meta_fn + other_fn$density <- dens_fn(function(z) stats::dt(z, df = 6)) + expect_false(identical(trim_parameters(meta_fn), trim_parameters(other_fn))) +}) + +test_that("c() keeps a density trim only when the two cuts agree", { + dat <- sim_dose_trim() + fit <- lm(a ~ x1 + x2, data = dat) + + base <- ps_trim(fit, method = "resid", upper = 2, .density = dens_t(4)) + again <- ps_trim(fit, method = "resid", upper = 2, .density = dens_t(4)) + + combined <- c(base, again) + expect_s3_class(combined, "ps_trim") + meta <- ps_trim_meta(combined) + expect_identical(meta$method, "resid") + expect_identical(meta$sigma, ps_trim_meta(base)$sigma) + expect_identical(meta$threshold, ps_trim_meta(base)$threshold) + expect_identical(meta$sigma_kind, "mle") + expect_identical(meta$density$family, "t") + + # Trims of the same model under the same bound that differ in how the spread + # was arrived at, in the spread itself, or in the family are different cuts. + others <- list( + sigma_method = ps_trim( + fit, + method = "resid", + upper = 2, + .density = dens_t(4, sigma_method = "rms") + ), + spread = ps_trim( + fit, + method = "resid", + upper = 2, + .sigma = 1, + .density = dens_t(4, sigma_method = "rms") + ), + family = ps_trim( + fit, + method = "resid", + upper = 2, + .density = dens_laplace() + ) + ) + + for (kind in names(others)) { + expect_warning( + mixed <- c(base, others[[kind]]), + class = "propensity_coercion_warning" + ) + expect_false(inherits(mixed, "ps_trim"), info = kind) + expect_type(mixed, "double") + } + + # Two floors at the same quantile under different spreads trim the same + # units, and still describe different cuts. + spread_a <- ps_trim(fit, method = "density", .sigma = 1) + spread_b <- ps_trim(fit, method = "density", .sigma = 2) + expect_identical( + ps_trim_meta(spread_a)$keep_idx, + ps_trim_meta(spread_b)$keep_idx + ) + expect_warning( + mixed <- c(spread_a, spread_b), + class = "propensity_coercion_warning" + ) + expect_false(inherits(mixed, "ps_trim")) +}) + +test_that("a density trim keeps its description through subsetting and loses its class to arithmetic", { + dat <- sim_dose_trim() + n <- nrow(dat) + fit <- lm(a ~ x1 + x2, data = dat) + trimmed <- ps_trim(fit, method = "density", lower = 0.1, .density = dens_t(4)) + meta <- ps_trim_meta(trimmed) + trimmed_units <- is_unit_trimmed(trimmed) + expect_identical(which(trimmed_units), as.integer(meta$trimmed_idx)) + + sub <- trimmed[10:n] + sub_meta <- ps_trim_meta(sub) + expect_s3_class(sub, "ps_trim") + expect_identical(is_unit_trimmed(sub), trimmed_units[10:n]) + expect_identical(sub_meta$n_obs, length(10:n)) + for (field in c("method", "lower", "threshold", "sigma", "sigma_kind")) { + expect_identical(sub_meta[[field]], meta[[field]], info = field) + } + expect_identical(sub_meta$density$family, "t") + expect_identical(sub_meta$density$params, meta$density$params) + expect_identical(sub_meta$density$sigma_method, meta$density$sigma_method) + + # A transformed conditional mean is not a dose model. + inverse <- 1 / trimmed + expect_false(inherits(inverse, "ps_trim")) + expect_type(inverse, "double") + expect_identical(which(is.na(inverse)), which(trimmed_units)) + expect_false(inherits(trimmed + 1, "ps_trim")) + + expect_identical( + vctrs::vec_ptype_full(trimmed), + paste0("ps_trim; trimmed ", length(meta$trimmed_idx), " of ", n) + ) + expect_output(print(trimmed), "ps_trim; trimmed 6 of 60", fixed = TRUE) +}) + +# ---- refusals ---------------------------------------------------------------- + +test_that("ps_trim() refuses an upper bound on a density floor", { + fit <- lm(a ~ x1 + x2, data = sim_dose_trim()) + + # A large conditional density is a plausible dose, so the floor has one side. + expect_error( + ps_trim(fit, method = "density", upper = 0.99), + class = "propensity_unsupported_arg_error" + ) + expect_propensity_error(ps_trim(fit, method = "density", upper = 0.99)) +}) + +test_that("ps_trim() refuses a lower bound on a residual bound, and needs an upper one", { + fit <- lm(a ~ x1 + x2, data = sim_dose_trim()) + + # The bound is on the absolute residual, so it has no lower end. + expect_error( + ps_trim(fit, method = "resid", lower = 1, upper = 3), + class = "propensity_unsupported_arg_error" + ) + expect_propensity_error(ps_trim(fit, method = "resid", lower = 1, upper = 3)) + + # There is no default bound: it is the analyst's to state. + expect_error( + ps_trim(fit, method = "resid"), + class = "propensity_missing_arg_error" + ) + expect_propensity_error(ps_trim(fit, method = "resid")) +}) + +test_that("ps_trim() refuses a density floor outside (0, 0.5) and a residual bound that is not positive", { + fit <- lm(a ~ x1 + x2, data = sim_dose_trim()) + + for (lower in list(0, 0.5, 0.7, -0.1, NA_real_, c(0.01, 0.02))) { + expect_error( + ps_trim(fit, method = "density", lower = lower), + class = "propensity_range_error", + info = deparse(lower) + ) + } + expect_propensity_error(ps_trim(fit, method = "density", lower = 0.5)) + + for (upper in list(0, -2, NA_real_, Inf, c(2, 3))) { + expect_error( + ps_trim(fit, method = "resid", upper = upper), + class = "propensity_range_error", + info = deparse(upper) + ) + } + expect_propensity_error(ps_trim(fit, method = "resid", upper = -2)) +}) + +test_that("ps_trim() refuses a residual bound under a density that need not be symmetric", { + fit <- lm(a ~ x1 + x2, data = sim_dose_trim()) + + # Only for a symmetric unimodal family is a residual bound a density floor, + # so a kernel or a function of the caller's is pointed at "density". + densities <- list( + kernel = dens_kernel(), + kernel_name = "kernel", + written = dens_fn(function(z) stats::dt(z, df = 4)) + ) + for (kind in names(densities)) { + cnd <- expect_error( + ps_trim(fit, method = "resid", upper = 2, .density = densities[[kind]]), + class = "propensity_density_error", + info = kind + ) + message <- gsub("[[:space:]]+", " ", cli::ansi_strip(conditionMessage(cnd))) + expect_match(message, "\"density\"", fixed = TRUE, info = kind) + } + + expect_propensity_error( + ps_trim(fit, method = "resid", upper = 2, .density = dens_kernel()) + ) +}) + +test_that("ps_trim() refuses a spread it cannot record on a dose model", { + dat <- sim_dose_trim() + fit <- lm(a ~ x1 + x2, data = dat) + + # One spread is a constant a refit can keep; one per unit is not. + expect_error( + ps_trim(fit, method = "density", .sigma = rep(1, nrow(dat))), + class = "propensity_sigma_error" + ) + expect_propensity_error( + ps_trim(fit, method = "density", .sigma = rep(1, nrow(dat))) + ) + + # A spread of the caller's and a family estimating its own scale are two + # instructions about the same quantity, refused as `wt_ate()` refuses them. + expect_error( + ps_trim(fit, method = "resid", upper = 2, .sigma = 1, .density = dens_t(4)), + class = "propensity_density_error" + ) + expect_propensity_error( + ps_trim(fit, method = "resid", upper = 2, .sigma = 1, .density = dens_t(4)) + ) +}) + +test_that("ps_trim() refuses a dose model fit with a spread that moves with its mean", { + withr::local_seed(5) + dat <- sim_dose_trim() + dat$count <- rpois(nrow(dat), lambda = exp(0.3 * dat$x1 + 1)) + fits <- list( + poisson = glm(count ~ x1, data = dat, family = poisson()), + quasi_mu = glm( + count ~ x1, + data = dat, + family = quasi(link = "log", variance = "mu") + ) + ) + fit <- fits$poisson + + for (kind in names(fits)) { + for (method in c("density", "resid")) { + expect_error( + ps_trim( + fits[[kind]], + method = method, + upper = if (method == "resid") 2 + ), + class = "propensity_model_family_error", + info = paste(kind, method) + ) + } + } + expect_propensity_error(ps_trim(fit, method = "density")) +}) + +test_that("ps_trim() refuses a score method on a dose model and names the dose methods", { + dat <- sim_dose_trim() + fits <- list( + lm = lm(a ~ x1 + x2, data = dat), + gaussian = glm(a ~ x1 + x2, data = dat, family = gaussian()) + ) + + for (kind in names(fits)) { + for (method in c("ps", "adaptive", "pctl", "pref", "cr", "optimal")) { + cnd <- expect_error( + ps_trim(fits[[kind]], method = method), + class = "propensity_method_error", + info = paste(kind, method) + ) + message <- cli::ansi_strip(conditionMessage(cnd)) + expect_match(message, "\"density\"", fixed = TRUE, info = kind) + expect_match(message, "\"resid\"", fixed = TRUE, info = kind) + } + + # Left unnamed, the method is the generic's first choice, a score method, so + # a dose model is refused rather than trimmed on a scale nobody asked for. + implicit <- expect_error( + ps_trim(fits[[kind]]), + class = "propensity_method_error", + info = kind + ) + implicit_message <- cli::ansi_strip(conditionMessage(implicit)) + expect_match(implicit_message, "\"density\"", fixed = TRUE, info = kind) + expect_match(implicit_message, "\"resid\"", fixed = TRUE, info = kind) + explicit <- rlang::catch_cnd(ps_trim(fits[[kind]], method = "ps")) + expect_identical( + implicit_message, + cli::ansi_strip(conditionMessage(explicit)), + info = kind + ) + } + + expect_propensity_error(ps_trim(fits$lm, method = "ps")) + expect_propensity_error(ps_trim(fits$gaussian, method = "adaptive")) +}) + +test_that("ps_trim() refuses levels on a dose model", { + fit <- lm(a ~ x1 + x2, data = sim_dose_trim()) + + # A dose has no levels to name. + expect_error( + ps_trim(fit, method = "density", .focal_level = 1), + class = "propensity_focal_level_error" + ) + expect_error( + ps_trim(fit, method = "resid", upper = 2, .reference_level = 0), + class = "propensity_focal_level_error" + ) + expect_propensity_error(ps_trim(fit, method = "density", .focal_level = 1)) +}) + +test_that("ps_trim() refuses the deprecated level arguments on a dose model", { + fit <- lm(a ~ x1 + x2, data = sim_dose_trim()) + + # The deprecated pair names levels too, and is refused the same way once its + # deprecation has been reported. + deprecated <- list( + treated = quote(ps_trim(fit, method = "density", .treated = 1)), + untreated = quote( + ps_trim(fit, method = "resid", upper = 2, .untreated = 0) + ) + ) + for (kind in names(deprecated)) { + warned <- 0L + with_always_deprecated({ + expect_error( + withCallingHandlers( + eval(deprecated[[kind]]), + lifecycle_warning_deprecated = function(cnd) { + warned <<- warned + 1L + invokeRestart("muffleWarning") + } + ), + class = "propensity_focal_level_error", + info = kind + ) + }) + expect_identical(warned, 1L, info = kind) + } +}) + +test_that("ps_trim() refuses a density or a spread on the score routes", { + withr::local_seed(8) + n <- 60 + x <- rnorm(n) + z <- rbinom(n, 1, plogis(0.5 * x)) + fit <- glm(z ~ x, family = binomial()) + ps <- as.numeric(fitted(fit)) + + # The score routes read no density, so a family or a spread given to them + # would be an instruction silently ignored. + expect_error( + ps_trim(ps, method = "ps", .density = dens_t(4)), + class = "propensity_density_error" + ) + expect_error( + ps_trim(ps, method = "pctl", .density = "laplace"), + class = "propensity_density_error" + ) + expect_error( + ps_trim(fit, method = "ps", .density = dens_t(4)), + class = "propensity_density_error" + ) + expect_error( + ps_trim(ps, method = "ps", .sigma = 1), + class = "propensity_sigma_error" + ) + expect_error( + ps_trim(fit, method = "adaptive", .sigma = 1), + class = "propensity_sigma_error" + ) + + # The default family is no instruction at all. + expect_s3_class(ps_trim(ps, method = "ps", .density = "normal"), "ps_trim") + + expect_propensity_error(ps_trim(ps, method = "ps", .density = dens_t(4))) + expect_propensity_error(ps_trim(ps, method = "ps", .sigma = 1)) +}) + +test_that("ps_trim() refuses the density methods on a model of a probability", { + withr::local_seed(9) + n <- 90 + x <- rnorm(n) + z <- rbinom(n, 1, plogis(0.5 * x)) + score_data <- data.frame(z = z, x = x) + + fits <- list( + binomial = glm(z ~ x, family = binomial(), data = score_data), + quasibinomial = glm(z ~ x, family = quasibinomial(), data = score_data) + ) + + if (rlang::is_installed("nnet")) { + score_data$z2 <- factor(z) + score_data$z3 <- factor(sample(c("a", "b", "c"), n, replace = TRUE)) + fits$multinom_two <- nnet::multinom( + z2 ~ x, + data = score_data, + trace = FALSE + ) + fits$multinom_three <- nnet::multinom( + z3 ~ x, + data = score_data, + trace = FALSE + ) + } + + # A model of a probability has no conditional density to trim, and the + # refusal says so rather than listing the methods a score takes. + for (kind in names(fits)) { + for (method in c("density", "resid")) { + cnd <- expect_error( + ps_trim( + fits[[kind]], + method = method, + upper = if (method == "resid") 2 + ), + class = "propensity_method_error", + info = paste(kind, method) + ) + message <- cli::ansi_strip(conditionMessage(cnd)) + expect_no_match(message, "must be one of", fixed = TRUE) + } + } + + expect_propensity_error(ps_trim(fits$binomial, method = "density")) + expect_propensity_error(ps_trim(fits$binomial, method = "resid", upper = 2)) + + skip_if_not_installed("nnet") + expect_propensity_error(ps_trim(fits$multinom_two, method = "density")) + expect_propensity_error(ps_trim( + fits$multinom_three, + method = "resid", + upper = 2 + )) +}) From 34a2cd5e2c0029205b39c2b02bd5cac70928d225 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 19:58:01 -0400 Subject: [PATCH 06/64] trim a dose model on the scale of its conditional density --- NAMESPACE | 1 + NEWS.md | 14 + R/continuous-models.R | 33 +- R/ipw.R | 5 +- R/ps_trim.R | 673 +++++++++++++++++++++-- man/ps_trim.Rd | 107 +++- tests/testthat/_snaps/ps_trim-density.md | 211 +++++++ tests/testthat/_snaps/ps_trim.md | 2 +- tests/testthat/test-ps_trim-density.R | 99 +++- tests/testthat/test-ps_trim.R | 8 +- 10 files changed, 1082 insertions(+), 71 deletions(-) create mode 100644 tests/testthat/_snaps/ps_trim-density.md diff --git a/NAMESPACE b/NAMESPACE index afe027c4..dba0485d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -107,6 +107,7 @@ S3method(ps_tilt,numeric) S3method(ps_trim,data.frame) S3method(ps_trim,default) S3method(ps_trim,glm) +S3method(ps_trim,lm) S3method(ps_trim,matrix) S3method(ps_trim,multinom) S3method(ps_trim,ps_trim) diff --git a/NEWS.md b/NEWS.md index 4c0f0759..123546a9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,19 @@ # propensity 0.1.0.9000 (development version) +* `ps_trim()` now trims a model of a continuous exposure on the scale of its + conditional density. A `lm`, a `glm` whose variance is constant, a + `MASS::rlm()`, or an `mgcv::gam()` of the dose can be trimmed with + `method = "density"`, which sets aside the units whose conditional density at + their observed dose falls below a quantile floor (`lower`, default 0.01), or + with `method = "resid"`, which sets aside the units more than `upper` spreads + from their predicted dose. The new `.density` and `.sigma` arguments choose + the density family and the spread, which is otherwise the one the family + estimates from the residuals, as in `wt_ate()`. The trim record keeps the + realized floor, the spread, how the spread was found, and the family, and + trims that differ in any of them do not combine. A dose model asked for any + other method, a model of a probability asked for either density method, and a + level argument on a dose model are refused with informative errors. + * Weights for a continuous exposure can no longer be built from a trimmed, truncated, or calibrated score. A conditional mean whose values happened to fall in (0, 1) could be passed through `ps_trim()`, `ps_trunc()`, or diff --git a/R/continuous-models.R b/R/continuous-models.R index 19eff75d..31f5301c 100644 --- a/R/continuous-models.R +++ b/R/continuous-models.R @@ -36,8 +36,15 @@ extract_continuous_ps.lm <- function(model, call = rlang::caller_env()) { # route says which, so the fit is refused here rather than downstream, where a # matrix with a row for each unit is only ever described by a length that the # caller never wrote. +# +# `problem` and `remedy` say what the caller needed the single mean for and what +# to do instead, since trimming a dose model cannot take the means on their own. check_continuous_model_response <- function( model, + problem = "Weights for a continuous exposure need a model of one conditional + mean for each unit.", + remedy = "Fit the exposure on its own, or pass the conditional means of this + exposure to {.arg .propensity} as a numeric vector.", call = rlang::caller_env() ) { fitted_values <- stats::fitted(model) @@ -50,13 +57,11 @@ check_continuous_model_response <- function( abort( c( - "Weights for a continuous exposure need a model of one conditional mean - for each unit.", + problem, x = "{.arg .propensity} is {.cls {class(model)[[1]]}}, a fit of {dims[[2]]} response{?s}, whose fitted values are {dims[[1]]} by {dims[[2]]}.", - i = "Fit the exposure on its own, or pass the conditional means of this - exposure to {.arg .propensity} as a numeric vector." + i = remedy ), error_class = "propensity_ps_shape_error", call = call @@ -195,16 +200,11 @@ check_binary_model_family.default <- function( # A family object is a list. An element that is not one is not a family, and # `$` on an atomic vector raises an error of base R's rather than one of this # package's, so what the element is gets read before anything is asked of it. - # - # `isTRUE()` because a family object that carries no name answers the test - # with nothing at all, which `&&` can read as neither true nor false. A - # family like that is not one of the two, and is refused below by what it is - # missing. + # A family object that carries no name is not one of the binomial two, and is + # refused below by what it is missing. family_object <- is.list(family) - binomial_family <- family_object && - isTRUE(family$family %in% c("binomial", "quasibinomial")) - if (binomial_family) { + if (is_binomial_family(family)) { return(invisible(NULL)) } @@ -233,6 +233,15 @@ check_binary_model_family.default <- function( ) } +# Whether a family fits the probability of a binary exposure. A family object is +# a list, and an element that is not one is not a family. `isTRUE()` because a +# family object that carries no name answers the test with nothing at all, which +# `&&` can read as neither true nor false. +is_binomial_family <- function(family) { + is.list(family) && + isTRUE(family$family %in% c("binomial", "quasibinomial")) +} + # Whether a family object names itself. Every family built by `binomial()` and # its neighbors holds its name in `$family`, and a message about one is written # from that string; an object that carries a link and no name has nothing to be diff --git a/R/ipw.R b/R/ipw.R index 0baf7ac0..be36d469 100644 --- a/R/ipw.R +++ b/R/ipw.R @@ -2067,10 +2067,7 @@ ipw_continuous_estimate <- function( # for. check_ipw_model_family <- function(wt_mod, call = rlang::caller_env()) { family <- wt_mod[["family"]] - binomial_family <- is.list(family) && - isTRUE(family$family %in% c("binomial", "quasibinomial")) - - if (binomial_family) { + if (is_binomial_family(family)) { return(invisible(TRUE)) } diff --git a/R/ps_trim.R b/R/ps_trim.R index 480c618d..0c14a4c6 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -8,11 +8,12 @@ #' observations with [ps_refit()]. #' #' @param .propensity A numeric vector of propensity scores in (0, 1) for binary -#' exposures, or a matrix / data frame where each column gives the propensity -#' score for one level of a categorical exposure. A data frame trimmed for a -#' binary exposure is reduced to a single column: the second column of a two -#' column data frame, which is the probability of the second level in the -#' layout model predictions come in, and the first column otherwise. The +#' exposures, a matrix / data frame where each column gives the propensity +#' score for one level of a categorical exposure, or a fitted model (see +#' **Fitted models** and **Dose models** in Details). A data frame trimmed +#' for a binary exposure is reduced to a single column: the second column of +#' a two column data frame, which is the probability of the second level in +#' the layout model predictions come in, and the first column otherwise. The #' column taken is announced; `options(propensity.quiet = TRUE)` silences the #' announcement. A matrix is held to the same open interval as a vector, so a #' score of exactly 0 or 1 in any cell is refused and a separated multinomial @@ -52,11 +53,21 @@ #' because there is no range left to bound the scores to. #' * **`"optimal"`**: Multi-category optimal trimming (Yang et al., 2016). #' Categorical exposures only. Requires `.exposure`. -#' * **`"density"`**, **`"resid"`**: Trimming on the scale of the conditional -#' density of a continuous exposure. A density needs the residuals and the -#' family of the model that fit the exposure's conditional mean, so these -#' methods refuse a vector or matrix of values with an error of class -#' `propensity_method_error`. +#' * **`"density"`**: Quantile floor on the conditional density of a +#' continuous exposure. Units whose conditional density at their observed +#' dose falls below its `lower` quantile are trimmed. Default: +#' `lower = 0.01`. +#' * **`"resid"`**: Bound on the absolute standardized residual of a +#' continuous exposure. Units more than `upper` spreads from their +#' predicted dose are trimmed. `upper` has no default. +#' +#' `"density"` and `"resid"` need the residuals and the family of the model +#' that fit the exposure's conditional mean, so they accept only a dose model +#' (see **Dose models** in Details). They refuse a vector or matrix of values, +#' a binomial or quasibinomial `glm`, and a `multinom` with an error of class +#' `propensity_method_error`. A dose model accepts only these two methods, and +#' refuses every other one, including the default `"ps"` when `method` is not +#' supplied, with the same class. #' #' For categorical exposures, only `"ps"` and `"optimal"` are supported. #' @param lower,upper Numeric thresholds whose interpretation depends on @@ -74,9 +85,20 @@ #' * `"pctl"`: quantile probabilities (defaults: 0.05, 0.95). #' * `"pref"`: preference score bounds (defaults: 0.3, 0.7). #' * `"adaptive"`, `"cr"`, `"optimal"`: ignored (thresholds are data-driven). +#' * `"density"`: `lower` is the quantile probability of the floor, in +#' (0, 0.5) (default 0.01). `upper` is refused with an error of class +#' `propensity_unsupported_arg_error`. +#' * `"resid"`: `upper` is the bound on the absolute standardized residual, a +#' single positive finite number, and is required (an error of class +#' `propensity_missing_arg_error` without it). `lower` is refused with an +#' error of class `propensity_unsupported_arg_error`. +#' +#' A `"density"` `lower` or `"resid"` `upper` out of range is refused with an +#' error of class `propensity_range_error`. #' @param .exposure An exposure variable. Required for `"pref"`, `"cr"` (binary -#' vector), and `"optimal"` (factor or character). Not required for other -#' methods. +#' vector), and `"optimal"` (factor or character). For `"density"` and +#' `"resid"`, the dose is read from the model's response unless supplied here. +#' Not required for other methods. #' @inheritParams wt_ate #' @param .focal_level The value of `.exposure` representing the focal #' (treated) group, used by `"pref"` and `"cr"`. Every binary coding honors @@ -93,6 +115,22 @@ #' the same consequence for `.propensity`, and a level the exposure never #' takes is an error. Automatically detected if not supplied. #' @param ... Additional arguments passed to methods. +#' @param .sigma For `"density"` and `"resid"`, a single residual spread to +#' read the conditional density at, recorded as `"supplied"`. With none +#' supplied, the spread is the one the density family estimates from the +#' residuals, as in [wt_ate()]: the root mean square, unless the family +#' estimates a scale of its own. A spread for each unit is refused with an +#' error of class `propensity_sigma_error`, and a spread supplied with a +#' family that estimates its own scale is refused with an error of class +#' `propensity_density_error`. The other methods refuse any `.sigma` with an +#' error of class `propensity_sigma_error`. +#' @param .density For `"density"` and `"resid"`, the family of the conditional +#' density, in any form [wt_ate()] accepts: `"normal"` (the default), +#' `"laplace"`, `"kernel"`, a specification such as [dens_t()], or a function +#' of the standardized residual. `"resid"` accepts only [dens_normal()], +#' [dens_t()], and [dens_laplace()], and refuses a kernel or user-written +#' density with an error of class `propensity_density_error`. The other +#' methods refuse any family but the normal with the same class. #' @param ps `r lifecycle::badge("deprecated")` Use `.propensity` instead. A #' call that names `ps` must name the arguments after it as well, since a #' positional argument binds to `.propensity`. @@ -119,6 +157,7 @@ #' groups have observed propensity scores. #' * Use `"optimal"` for multi-category (3+) exposures; this is the only #' data-driven method available for categorical treatments. +#' * Use `"density"` or `"resid"` for a continuous exposure, on its dose model. #' #' ## Typical workflow #' @@ -144,6 +183,31 @@ #' whose levels are ordered differently is still trimmed against the right #' column. #' +#' ## Dose models +#' +#' For a continuous exposure, `.propensity` can be the model of the exposure's +#' conditional mean: a [stats::lm()], a `glm` of the `gaussian()` family (or +#' another family whose variance is constant), a `MASS::rlm()`, or an +#' `mgcv::gam()`, the models [wt_ate()] reads a dose from. A `glm` whose spread +#' changes with its mean, such as `poisson()`, is refused with an error of +#' class `propensity_model_family_error`. Only `"density"` and `"resid"` apply. +#' +#' Both read the fitted conditional mean `mu`, the spread `sigma` of the +#' residuals under the family in `.density`, the standardized residual +#' `z = (a - mu) / sigma`, and the conditional density `f = g(z) / sigma`, +#' where `g` is the family's standardized density. `"density"` keeps the units +#' whose `f` is at least its `lower` quantile. `"resid"` keeps those whose +#' `|z|` is at most `upper`; for the symmetric unimodal families it accepts, +#' that is the floor `g(upper) / sigma` on `f`, which is the threshold it +#' records. +#' +#' The retained values are the conditional means, and the trimmed ones are +#' `NA`. A unit with a missing mean or dose takes no part in the trim. The +#' population a trimmed analysis describes is the units whose observed dose +#' was plausible under the model, not the full sample. `.focal_level`, +#' `.reference_level`, and their deprecated forms are refused with an error of +#' class `propensity_focal_level_error`, since a dose has no levels. +#' #' ## Object behavior #' #' Arithmetic operations on `ps_trim` objects return plain numeric vectors, @@ -250,6 +314,12 @@ #' (pctl), `cr_lower`/`cr_upper` (cr), `delta` (categorical ps), #' or `lambda` (optimal) #' +#' A trim of a dose model records `method`, `lower` (`"density"`, else +#' `NULL`), `upper` (`"resid"`, else `NULL`), `threshold` (the realized floor +#' on the conditional density), `sigma` (the spread it was read at), +#' `sigma_kind` (`"pooled"`, `"mle"`, or `"supplied"`), `density` (the +#' density specification), `keep_idx`, `trimmed_idx`, and `n_obs`. +#' #' @references #' Crump, R. K., Hotz, V. J., Imbens, G. W., & Mitnik, O. A. (2009). Dealing #' with limited overlap in estimation of average treatment effects. @@ -298,6 +368,12 @@ #' # Trim the scores a fitted model reports, reading the exposure off the model #' ps_trim(fit, method = "cr") #' +#' # Trim a dose model on the scale of its conditional density +#' dose <- 1 + 0.5 * x + rt(n, df = 3) +#' dose_fit <- lm(dose ~ x) +#' ps_trim(dose_fit, method = "density", lower = 0.05) +#' ps_trim(dose_fit, method = "resid", upper = 3, .density = dens_t(4)) +#' #' if (rlang::is_installed("nnet")) { #' trt <- factor(sample(c("a", "b", "c"), n, replace = TRUE)) #' multinomial_fit <- nnet::multinom(trt ~ x, trace = FALSE) @@ -323,6 +399,8 @@ ps_trim <- function( .focal_level = NULL, .reference_level = NULL, ..., + .sigma = NULL, + .density = "normal", .treated = NULL, .untreated = NULL, ps = lifecycle::deprecated() @@ -355,6 +433,8 @@ ps_trim.default <- function( .focal_level = NULL, .reference_level = NULL, ..., + .sigma = NULL, + .density = "normal", .treated = NULL, .untreated = NULL, ps = lifecycle::deprecated(), @@ -421,6 +501,7 @@ ps_trim.default <- function( ) } + check_score_trim_density(.sigma, .density, call = call) check_ps_range(.propensity, call = call) # Handle deprecation @@ -612,6 +693,8 @@ ps_trim.matrix <- function( .focal_level = NULL, .reference_level = NULL, ..., + .sigma = NULL, + .density = "normal", .treated = NULL, .untreated = NULL, ps = lifecycle::deprecated(), @@ -648,6 +731,8 @@ ps_trim.matrix <- function( ) } + check_score_trim_density(.sigma, .density, call = call) + check_no_focal_levels( .focal_level, .reference_level, @@ -832,6 +917,8 @@ ps_trim.data.frame <- function( .focal_level = NULL, .reference_level = NULL, ..., + .sigma = NULL, + .density = "normal", .treated = NULL, .untreated = NULL, ps = lifecycle::deprecated(), @@ -866,6 +953,8 @@ ps_trim.data.frame <- function( .focal_level = .focal_level, .reference_level = .reference_level, ..., + .sigma = .sigma, + .density = .density, .treated = .treated, .untreated = .untreated, call = call @@ -887,6 +976,8 @@ ps_trim.data.frame <- function( .focal_level = .focal_level, .reference_level = .reference_level, ..., + .sigma = .sigma, + .density = .density, .treated = .treated, .untreated = .untreated, user_env = rlang::caller_env(), @@ -894,22 +985,32 @@ ps_trim.data.frame <- function( ) } -# The fitted propensity score models trimming reads, registered for the same -# classes the weight functions read: a `glm`, whose binomial families fit the -# probability of a binary exposure, and a `multinom`, which fits a probability -# for every level. A `lm` is not among them, its fitted values being conditional -# means rather than probabilities, and it reaches the default method, which -# reports that it has no scores to trim. +# The fitted models trimming reads. A `glm` of a binomial family fits the +# probability of a binary exposure and a `multinom` fits a probability for every +# level, so both are trimmed on the scale of that probability. A `lm`, and a +# `glm` of any other family, fits the conditional mean of a dose, which is +# trimmed on the scale of its conditional density. #' @export ps_trim.glm <- function( .propensity, - method = c("ps", "adaptive", "pctl", "pref", "cr", "optimal"), + method = c( + "ps", + "adaptive", + "pctl", + "pref", + "cr", + "optimal", + "density", + "resid" + ), lower = NULL, upper = NULL, .exposure = NULL, .focal_level = NULL, .reference_level = NULL, ..., + .sigma = NULL, + .density = "normal", .treated = NULL, .untreated = NULL, ps = lifecycle::deprecated(), @@ -918,7 +1019,62 @@ ps_trim.glm <- function( check_call_arg(call) .propensity <- read_method_propensity(rlang::maybe_missing(.propensity), ps) - ps_trim_from_model( + trim <- if (is_binomial_family(.propensity[["family"]])) { + ps_trim_from_model + } else { + ps_trim_dose + } + + trim( + .propensity, + method = method, + lower = lower, + upper = upper, + .exposure = .exposure, + .focal_level = .focal_level, + .reference_level = .reference_level, + ..., + .sigma = .sigma, + .density = .density, + .treated = .treated, + .untreated = .untreated, + call = call, + user_env = rlang::caller_env() + ) +} + +# A `lm` has no family, and its fitted values are the conditional mean of a +# dose. `MASS::rlm()` fits and other subclasses arrive here by inheritance. +#' @export +ps_trim.lm <- function( + .propensity, + method = c( + "ps", + "adaptive", + "pctl", + "pref", + "cr", + "optimal", + "density", + "resid" + ), + lower = NULL, + upper = NULL, + .exposure = NULL, + .focal_level = NULL, + .reference_level = NULL, + ..., + .sigma = NULL, + .density = "normal", + .treated = NULL, + .untreated = NULL, + ps = lifecycle::deprecated(), + call = rlang::current_env() +) { + check_call_arg(call) + .propensity <- read_method_propensity(rlang::maybe_missing(.propensity), ps) + + ps_trim_dose( .propensity, method = method, lower = lower, @@ -927,6 +1083,8 @@ ps_trim.glm <- function( .focal_level = .focal_level, .reference_level = .reference_level, ..., + .sigma = .sigma, + .density = .density, .treated = .treated, .untreated = .untreated, call = call, @@ -941,13 +1099,24 @@ ps_trim.glm <- function( #' @export ps_trim.multinom <- function( .propensity, - method = c("ps", "adaptive", "pctl", "pref", "cr", "optimal"), + method = c( + "ps", + "adaptive", + "pctl", + "pref", + "cr", + "optimal", + "density", + "resid" + ), lower = NULL, upper = NULL, .exposure = NULL, .focal_level = NULL, .reference_level = NULL, ..., + .sigma = NULL, + .density = "normal", .treated = NULL, .untreated = NULL, ps = lifecycle::deprecated(), @@ -966,6 +1135,8 @@ ps_trim.multinom <- function( .focal_level = .focal_level, .reference_level = .reference_level, ..., + .sigma = .sigma, + .density = .density, .treated = .treated, .untreated = .untreated, call = call, @@ -973,12 +1144,12 @@ ps_trim.multinom <- function( ) } -# The model methods differ only in the class they are registered for and in what -# that class needs checked before it is read, so both route through here. The -# method is resolved first because it decides whether the trimming reads an -# exposure at all, and a method the vector route does not define is left to the -# route that does not define it, so that the refusal is the same one a vector of -# scores gets. +# The model methods of the score route differ only in the class they are +# registered for and in what that class needs checked before it is read, so +# both route through here. The method is resolved first because it decides +# whether the trimming reads an exposure at all, and a score method the vector +# route does not define is left to the route that does not define it, so that +# the refusal is the same one a vector of scores gets. # # The vector and matrix methods are reached by a call rather than by dispatch, # so they are handed the frame the route was entered on. Left to their own, a @@ -992,6 +1163,8 @@ ps_trim_from_model <- function( .focal_level, .reference_level, ..., + .sigma, + .density, .treated, .untreated, call, @@ -999,10 +1172,29 @@ ps_trim_from_model <- function( ) { method <- rlang::arg_match( method, - values = c("ps", "adaptive", "pctl", "pref", "cr", "optimal"), + values = ps_trim_methods, error_call = call ) + # Checked before anything is read off the fit, so that a refusal is never + # preceded by an announcement about an exposure nothing goes on to use. + if (method %in% ps_trim_dose_methods) { + abort( + c( + "Method {.val {method}} cannot trim a model of a probability.", + x = "{.arg .propensity} is {.cls {class(model)[[1]]}}, whose fitted + values are probabilities of the exposure, and a model of a + probability has no conditional density to trim.", + i = "Trim its propensity scores with a score method such as + {.val ps}, or supply the model of a continuous exposure's + conditional mean to trim with {.val {method}}." + ), + error_class = "propensity_method_error", + call = call + ) + } + check_score_trim_density(.sigma, .density, call = call) + args <- prepare_model_ps( model, .exposure, @@ -1048,6 +1240,391 @@ ps_trim_from_model <- function( ) } +ps_trim_score_methods <- c("ps", "adaptive", "pctl", "pref", "cr", "optimal") +ps_trim_dose_methods <- c("density", "resid") +ps_trim_methods <- c(ps_trim_score_methods, ps_trim_dose_methods) + +# The score routes read no density, so a family or a spread handed to them +# would be an instruction silently ignored. The default family is accepted, so +# that a caller who writes out the family they were getting anyway is not +# refused for saying so, which is how the weight functions treat a binary +# exposure. +check_score_trim_density <- function( + .sigma, + .density, + call = rlang::caller_env() +) { + if (!is.null(.sigma)) { + abort( + c( + "{.arg .sigma} applies only to trimming a dose model.", + x = "The trimming method bounds propensity scores, which have no + spread to read.", + i = "Leave {.arg .sigma} unset, or supply the model of a continuous + exposure with {.code method = \"density\"} or + {.code method = \"resid\"}." + ), + error_class = "propensity_sigma_error", + call = call + ) + } + + spec <- as_density_spec(.density, arg = ".density", call = call) + if (identical(spec$family, "normal")) { + return(invisible(NULL)) + } + + abort( + c( + "{.arg .density} applies only to trimming a dose model.", + x = "The trimming method bounds propensity scores, which have no + conditional density to read.", + i = "Leave {.arg .density} unset, or supply the model of a continuous + exposure with {.code method = \"density\"} or + {.code method = \"resid\"}." + ), + error_class = "propensity_density_error", + call = call + ) +} + +# Trimming a dose model on the scale of its conditional density. The fitted +# values are the conditional mean of the dose, the residuals are spread by the +# estimator the density family asks for, as the weights spread them, and each +# unit's conditional density at its own dose decides whether it is kept. +# +# Every argument is checked before the exposure is read, so a refusal is never +# preceded by an announcement about an exposure nothing goes on to use. +ps_trim_dose <- function( + model, + method, + lower, + upper, + .exposure, + .focal_level, + .reference_level, + ..., + .sigma, + .density, + .treated, + .untreated, + call, + user_env +) { + rlang::check_dots_empty(call = call) + method <- rlang::arg_match( + method, + values = ps_trim_methods, + error_call = call + ) + + check_continuous_model_family( + model, + problem = "Trimming a dose model needs a model of its conditional mean + with a single spread.", + remedy = "Fit the dose model with {.fun gaussian}, {.fun lm}, + {.fun mgcv::gam}, or {.fun MASS::rlm}.", + call = call + ) + check_continuous_model_response( + model, + problem = "Trimming a dose model needs a model of one conditional mean for + each unit.", + remedy = "Fit the dose on its own and trim that model.", + call = call + ) + + if (!method %in% ps_trim_dose_methods) { + abort( + c( + "Method {.val {method}} cannot trim a dose model.", + x = "{.arg .propensity} is {.cls {class(model)[[1]]}}, a model of a + continuous exposure's conditional mean, which has no propensity + score in (0, 1) for {.val {method}} to bound.", + i = "Trim it on the scale of its conditional density with + {.code method = \"density\"} or {.code method = \"resid\"}." + ), + error_class = "propensity_method_error", + call = call + ) + } + + focal_params <- handle_focal_deprecation( + .focal_level, + .reference_level, + .treated, + .untreated, + "ps_trim", + user_env = user_env + ) + check_dose_no_levels( + focal_params$.focal_level, + focal_params$.reference_level, + call = call + ) + + density <- as_density_spec(.density, arg = ".density", call = call) + check_dose_trim_sigma(.sigma, call = call) + check_sigma_method(.sigma, density, call = call) + + if (method == "density") { + if (!is.null(upper)) { + abort( + c( + "{.arg upper} is not used by {.code method = \"density\"}.", + x = "The method sets aside the units whose conditional density falls + below a quantile floor, and a large conditional density is a + plausible dose, so there is no upper tail to trim.", + i = "Drop {.arg upper}, and set the floor with {.arg lower}." + ), + error_class = "propensity_unsupported_arg_error", + call = call + ) + } + if (is.null(lower)) { + lower <- 0.01 + } + check_density_trim_lower(lower, call = call) + } else { + if (!is.null(lower)) { + abort( + c( + "{.arg lower} is not used by {.code method = \"resid\"}.", + x = "The method bounds the absolute standardized residual, which has + no lower end to trim.", + i = "Drop {.arg lower}, and set the bound with {.arg upper}." + ), + error_class = "propensity_unsupported_arg_error", + call = call + ) + } + if (is.null(upper)) { + abort( + c( + "{.code method = \"resid\"} needs {.arg upper}.", + x = "The bound on the absolute standardized residual has no + default.", + i = "Supply the number of spreads from the predicted dose beyond + which a unit is trimmed, such as {.code upper = 3}." + ), + error_class = "propensity_missing_arg_error", + call = call + ) + } + check_resid_trim_upper(upper, call = call) + check_resid_trim_density(density, call = call) + } + + mu <- as.numeric(extract_continuous_ps(model, call = call)$mu) + exposure <- extract_exposure_from_model(model, .exposure) + check_dose_trim_exposure(exposure, length(mu), call = call) + + n <- length(mu) + sigma <- continuous_sigma(exposure, mu, .sigma, density, call = call) + z <- (exposure - mu) / sigma + f <- density_eval_present(density, z, call = call) / sigma + + # A unit with a missing mean or dose has no density to place against the + # floor, so it takes no part in working the floor out and no part in the + # record, as a missing score takes none in a trim of scores. + observed <- !is.na(f) + + if (method == "density") { + # `quantile()` names its result for the probability it was asked for, which + # says nothing about the floor. + threshold <- unname(stats::quantile(f, probs = lower, na.rm = TRUE)) + keep_idx <- which(f >= threshold) + } else { + # For a symmetric unimodal density the bound on `|z|` is a floor on the + # density written in residual units, and the floor is what is recorded, so + # that both methods describe the same kind of cut. + threshold <- density_eval(density, upper, call = call) / sigma + keep_idx <- which(abs(z) <= upper) + } + + trimmed_idx <- setdiff(which(observed), keep_idx) + + values <- mu + values[trimmed_idx] <- NA_real_ + + # Every field is named whichever method made the record, and the bound a + # method does not read is `NULL`, so that two records compare field by field. + new_trimmed_ps( + x = values, + ps_trim_meta = list( + method = method, + lower = if (method == "density") lower, + upper = if (method == "resid") upper, + threshold = threshold, + sigma = sigma, + sigma_kind = density_sigma_source(.sigma, density), + density = density, + keep_idx = keep_idx, + trimmed_idx = trimmed_idx, + n_obs = n + ) + ) +} + +# A dose has no levels, so an argument naming one describes a coding the dose +# route never reads. +check_dose_no_levels <- function( + .focal_level, + .reference_level, + call = rlang::caller_env() +) { + supplied <- c( + ".focal_level" = !is.null(.focal_level), + ".reference_level" = !is.null(.reference_level) + ) + + if (!any(supplied)) { + return(invisible(NULL)) + } + + named <- names(supplied)[supplied] + abort( + c( + "{.arg {named}} cannot be used when trimming a dose model.", + x = "A continuous exposure has no levels, so none is focal and none is + reference.", + i = "Drop {.arg {named}}." + ), + error_class = "propensity_focal_level_error", + call = call + ) +} + +# A dose trim is recorded with the single spread it was read at, which a refit +# can keep. A spread for each unit describes a density no refit could +# reproduce, so it is refused here rather than accepted as the weights accept +# it. +check_dose_trim_sigma <- function(.sigma, call = rlang::caller_env()) { + if (is.null(.sigma)) { + return(invisible(NULL)) + } + + if (is.numeric(.sigma) && is.null(dim(.sigma)) && length(.sigma) != 1) { + abort( + c( + "{.arg .sigma} must be a single spread when trimming a dose model.", + x = "It holds {length(.sigma)} value{?s}.", + i = "A trim is recorded at one spread, which a refit of the dose model + can keep; a spread for each unit cannot be refit. Supply one + value, or leave {.arg .sigma} unset to estimate it." + ), + error_class = "propensity_sigma_error", + call = call + ) + } + + check_sigma(.sigma, "continuous", n = 1, call = call) +} + +check_density_trim_lower <- function(lower, call = rlang::caller_env()) { + if ( + is.numeric(lower) && + length(lower) == 1 && + !is.na(lower) && + lower > 0 && + lower < 0.5 + ) { + return(invisible(NULL)) + } + + abort( + c( + "For {.code method = \"density\"}, {.arg lower} must be a single + probability between 0 and 0.5.", + x = "{.arg lower} is {.val {lower}}.", + i = "{.arg lower} is the quantile of the conditional density below which + units are trimmed, such as the default {.code lower = 0.01}." + ), + error_class = "propensity_range_error", + call = call + ) +} + +check_resid_trim_upper <- function(upper, call = rlang::caller_env()) { + if ( + is.numeric(upper) && + length(upper) == 1 && + is.finite(upper) && + upper > 0 + ) { + return(invisible(NULL)) + } + + abort( + c( + "For {.code method = \"resid\"}, {.arg upper} must be a single positive, + finite number.", + x = "{.arg upper} is {.val {upper}}.", + i = "{.arg upper} is the number of spreads from the predicted dose + beyond which a unit is trimmed, such as {.code upper = 3}." + ), + error_class = "propensity_range_error", + call = call + ) +} + +# A bound on the absolute residual is a floor on the density only for a +# symmetric unimodal family. A kernel estimate or a function of the caller's +# need be neither, and the bound and the floor would then keep different units. +check_resid_trim_density <- function(density, call = rlang::caller_env()) { + if (density$family %in% c("normal", "t", "laplace")) { + return(invisible(NULL)) + } + + family <- density$family + abort( + c( + "{.code method = \"resid\"} needs a symmetric unimodal density.", + x = "{.arg .density} is a {.val {family}} density, which need not be + symmetric or unimodal, so a bound on the absolute residual is not a + floor on it.", + i = "Use {.code method = \"density\"}, which trims on the density itself + under any family, or a {.fun dens_normal}, {.fun dens_t}, or + {.fun dens_laplace} density." + ), + error_class = "propensity_density_error", + call = call + ) +} + +# The dose is read against the model's fitted means one unit at a time, so it +# has to be a number for each of them. +check_dose_trim_exposure <- function(exposure, n, call = rlang::caller_env()) { + if (!is.numeric(exposure) || !is.null(dim(exposure))) { + abort( + c( + "{.arg .exposure} must be a numeric vector when trimming a dose model.", + x = "It is {.obj_type_friendly {exposure}}.", + i = "Supply the dose the model was fit to, one value per unit." + ), + error_class = "propensity_type_error", + call = call + ) + } + + if (length(exposure) != n) { + abort( + c( + "{.arg .exposure} must have one value for each fitted mean.", + x = "It has {length(exposure)} value{?s}, and the model reports + {n} fitted mean{?s}.", + i = "Supply the dose for the rows the model was fit to, or refit it + with {.code na.action = na.exclude}, which reports a mean for + every row of its data." + ), + error_class = "propensity_length_error", + call = call + ) + } + + invisible(NULL) +} + #' @export ps_trim.ps_trim <- function( .propensity, @@ -1067,6 +1644,8 @@ ps_trim.ps_trim <- function( .focal_level = NULL, .reference_level = NULL, ..., + .sigma = NULL, + .density = "normal", .treated = NULL, .untreated = NULL, ps = lifecycle::deprecated() @@ -1492,7 +2071,8 @@ vec_arith.ps_trim.list <- function(op, x, y, ...) { # How a trimming is described, as opposed to which units it touched: the # method, the bounds it was given, and the cutoffs it settled on. A cutoff is # read off the scores, so two objects that agree on the method and the bounds -# can still have been trimmed at different places. +# can still have been trimmed at different places. A trim of a dose model is +# also described by the spread and the density family it was read at. trim_parameters <- function(meta) { fields <- c( "method", @@ -1503,10 +2083,41 @@ trim_parameters <- function(meta) { "q_upper", "P", "cr_lower", - "cr_upper" + "cr_upper", + "threshold", + "sigma", + "sigma_kind", + "density" + ) + + params <- rlang::set_names( + lapply(fields, function(field) meta[[field]]), + fields + ) + params["density"] <- list(trim_density_parameters(meta$density)) + + params +} + +# What identifies a density specification, as `density_specs_agree()` reads +# it. Each constructor writes a fresh function, so two specifications built the +# same way hold functions that are not `identical()`; only a function the caller +# wrote is the specification's identity. +trim_density_parameters <- function(density) { + if (is.null(density)) { + return(NULL) + } + + params <- list( + family = density$family, + params = density$params, + sigma_method = density$sigma_method ) + if (identical(density$family, "function")) { + params$fn <- density$fn + } - rlang::set_names(lapply(fields, function(field) meta[[field]]), fields) + params } #' @export diff --git a/man/ps_trim.Rd b/man/ps_trim.Rd index 7c129199..79e8ce20 100644 --- a/man/ps_trim.Rd +++ b/man/ps_trim.Rd @@ -13,6 +13,8 @@ ps_trim( .focal_level = NULL, .reference_level = NULL, ..., + .sigma = NULL, + .density = "normal", .treated = NULL, .untreated = NULL, ps = lifecycle::deprecated() @@ -20,11 +22,12 @@ ps_trim( } \arguments{ \item{.propensity}{A numeric vector of propensity scores in (0, 1) for binary -exposures, or a matrix / data frame where each column gives the propensity -score for one level of a categorical exposure. A data frame trimmed for a -binary exposure is reduced to a single column: the second column of a two -column data frame, which is the probability of the second level in the -layout model predictions come in, and the first column otherwise. The +exposures, a matrix / data frame where each column gives the propensity +score for one level of a categorical exposure, or a fitted model (see +\strong{Fitted models} and \strong{Dose models} in Details). A data frame trimmed +for a binary exposure is reduced to a single column: the second column of +a two column data frame, which is the probability of the second level in +the layout model predictions come in, and the first column otherwise. The column taken is announced; \code{options(propensity.quiet = TRUE)} silences the announcement. A matrix is held to the same open interval as a vector, so a score of exactly 0 or 1 in any cell is refused and a separated multinomial @@ -65,13 +68,23 @@ the same data with an error of class \code{propensity_no_overlap_error} because there is no range left to bound the scores to. \item \strong{\code{"optimal"}}: Multi-category optimal trimming (Yang et al., 2016). Categorical exposures only. Requires \code{.exposure}. -\item \strong{\code{"density"}}, \strong{\code{"resid"}}: Trimming on the scale of the conditional -density of a continuous exposure. A density needs the residuals and the -family of the model that fit the exposure's conditional mean, so these -methods refuse a vector or matrix of values with an error of class -\code{propensity_method_error}. +\item \strong{\code{"density"}}: Quantile floor on the conditional density of a +continuous exposure. Units whose conditional density at their observed +dose falls below its \code{lower} quantile are trimmed. Default: +\code{lower = 0.01}. +\item \strong{\code{"resid"}}: Bound on the absolute standardized residual of a +continuous exposure. Units more than \code{upper} spreads from their +predicted dose are trimmed. \code{upper} has no default. } +\code{"density"} and \code{"resid"} need the residuals and the family of the model +that fit the exposure's conditional mean, so they accept only a dose model +(see \strong{Dose models} in Details). They refuse a vector or matrix of values, +a binomial or quasibinomial \code{glm}, and a \code{multinom} with an error of class +\code{propensity_method_error}. A dose model accepts only these two methods, and +refuses every other one, including the default \code{"ps"} when \code{method} is not +supplied, with the same class. + For categorical exposures, only \code{"ps"} and \code{"optimal"} are supported.} \item{lower, upper}{Numeric thresholds whose interpretation depends on @@ -89,11 +102,22 @@ an error. \item \code{"pctl"}: quantile probabilities (defaults: 0.05, 0.95). \item \code{"pref"}: preference score bounds (defaults: 0.3, 0.7). \item \code{"adaptive"}, \code{"cr"}, \code{"optimal"}: ignored (thresholds are data-driven). -}} +\item \code{"density"}: \code{lower} is the quantile probability of the floor, in +(0, 0.5) (default 0.01). \code{upper} is refused with an error of class +\code{propensity_unsupported_arg_error}. +\item \code{"resid"}: \code{upper} is the bound on the absolute standardized residual, a +single positive finite number, and is required (an error of class +\code{propensity_missing_arg_error} without it). \code{lower} is refused with an +error of class \code{propensity_unsupported_arg_error}. +} + +A \code{"density"} \code{lower} or \code{"resid"} \code{upper} out of range is refused with an +error of class \code{propensity_range_error}.} \item{.exposure}{An exposure variable. Required for \code{"pref"}, \code{"cr"} (binary -vector), and \code{"optimal"} (factor or character). Not required for other -methods.} +vector), and \code{"optimal"} (factor or character). For \code{"density"} and +\code{"resid"}, the dose is read from the model's response unless supplied here. +Not required for other methods.} \item{.focal_level}{The value of \code{.exposure} representing the focal (treated) group, used by \code{"pref"} and \code{"cr"}. Every binary coding honors @@ -113,6 +137,24 @@ takes is an error. Automatically detected if not supplied.} \item{...}{Additional arguments passed to methods.} +\item{.sigma}{For \code{"density"} and \code{"resid"}, a single residual spread to +read the conditional density at, recorded as \code{"supplied"}. With none +supplied, the spread is the one the density family estimates from the +residuals, as in \code{\link[=wt_ate]{wt_ate()}}: the root mean square, unless the family +estimates a scale of its own. A spread for each unit is refused with an +error of class \code{propensity_sigma_error}, and a spread supplied with a +family that estimates its own scale is refused with an error of class +\code{propensity_density_error}. The other methods refuse any \code{.sigma} with an +error of class \code{propensity_sigma_error}.} + +\item{.density}{For \code{"density"} and \code{"resid"}, the family of the conditional +density, in any form \code{\link[=wt_ate]{wt_ate()}} accepts: \code{"normal"} (the default), +\code{"laplace"}, \code{"kernel"}, a specification such as \code{\link[=dens_t]{dens_t()}}, or a function +of the standardized residual. \code{"resid"} accepts only \code{\link[=dens_normal]{dens_normal()}}, +\code{\link[=dens_t]{dens_t()}}, and \code{\link[=dens_laplace]{dens_laplace()}}, and refuses a kernel or user-written +density with an error of class \code{propensity_density_error}. The other +methods refuse any family but the normal with the same class.} + \item{.treated}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Use \code{.focal_level} instead.} \item{.untreated}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Use \code{.reference_level} instead.} @@ -135,6 +177,12 @@ with \code{\link[=ps_trim_meta]{ps_trim_meta()}}. Key fields include: (pctl), \code{cr_lower}/\code{cr_upper} (cr), \code{delta} (categorical ps), or \code{lambda} (optimal) } + +A trim of a dose model records \code{method}, \code{lower} (\code{"density"}, else +\code{NULL}), \code{upper} (\code{"resid"}, else \code{NULL}), \code{threshold} (the realized floor +on the conditional density), \code{sigma} (the spread it was read at), +\code{sigma_kind} (\code{"pooled"}, \code{"mle"}, or \code{"supplied"}), \code{density} (the +density specification), \code{keep_idx}, \code{trimmed_idx}, and \code{n_obs}. } \description{ Trim observations with extreme propensity scores by replacing them with \code{NA}, @@ -166,6 +214,7 @@ equipoise based on the preference score. groups have observed propensity scores. \item Use \code{"optimal"} for multi-category (3+) exposures; this is the only data-driven method available for categorical treatments. +\item Use \code{"density"} or \code{"resid"} for a continuous exposure, on its dose model. } } @@ -195,6 +244,32 @@ whose levels are ordered differently is still trimmed against the right column. } +\subsection{Dose models}{ + +For a continuous exposure, \code{.propensity} can be the model of the exposure's +conditional mean: a \code{\link[stats:lm]{stats::lm()}}, a \code{glm} of the \code{gaussian()} family (or +another family whose variance is constant), a \code{MASS::rlm()}, or an +\code{mgcv::gam()}, the models \code{\link[=wt_ate]{wt_ate()}} reads a dose from. A \code{glm} whose spread +changes with its mean, such as \code{poisson()}, is refused with an error of +class \code{propensity_model_family_error}. Only \code{"density"} and \code{"resid"} apply. + +Both read the fitted conditional mean \code{mu}, the spread \code{sigma} of the +residuals under the family in \code{.density}, the standardized residual +\code{z = (a - mu) / sigma}, and the conditional density \code{f = g(z) / sigma}, +where \code{g} is the family's standardized density. \code{"density"} keeps the units +whose \code{f} is at least its \code{lower} quantile. \code{"resid"} keeps those whose +\verb{|z|} is at most \code{upper}; for the symmetric unimodal families it accepts, +that is the floor \code{g(upper) / sigma} on \code{f}, which is the threshold it +records. + +The retained values are the conditional means, and the trimmed ones are +\code{NA}. A unit with a missing mean or dose takes no part in the trim. The +population a trimmed analysis describes is the units whose observed dose +was plausible under the model, not the full sample. \code{.focal_level}, +\code{.reference_level}, and their deprecated forms are refused with an error of +class \code{propensity_focal_level_error}, since a dose has no levels. +} + \subsection{Object behavior}{ Arithmetic operations on \code{ps_trim} objects return plain numeric vectors, @@ -320,6 +395,12 @@ wt_ate(refitted, .exposure = z) # Trim the scores a fitted model reports, reading the exposure off the model ps_trim(fit, method = "cr") +# Trim a dose model on the scale of its conditional density +dose <- 1 + 0.5 * x + rt(n, df = 3) +dose_fit <- lm(dose ~ x) +ps_trim(dose_fit, method = "density", lower = 0.05) +ps_trim(dose_fit, method = "resid", upper = 3, .density = dens_t(4)) + if (rlang::is_installed("nnet")) { trt <- factor(sample(c("a", "b", "c"), n, replace = TRUE)) multinomial_fit <- nnet::multinom(trt ~ x, trace = FALSE) diff --git a/tests/testthat/_snaps/ps_trim-density.md b/tests/testthat/_snaps/ps_trim-density.md new file mode 100644 index 00000000..d4b06359 --- /dev/null +++ b/tests/testthat/_snaps/ps_trim-density.md @@ -0,0 +1,211 @@ +# ps_trim() refuses an upper bound on a density floor + + Code + expr + Condition + Error in `ps_trim()`: + ! `upper` is not used by `method = "density"`. + x The method sets aside the units whose conditional density falls below a quantile floor, and a large conditional density is a plausible dose, so there is no upper tail to trim. + i Drop `upper`, and set the floor with `lower`. + +# ps_trim() refuses a lower bound on a residual bound, and needs an upper one + + Code + expr + Condition + Error in `ps_trim()`: + ! `lower` is not used by `method = "resid"`. + x The method bounds the absolute standardized residual, which has no lower end to trim. + i Drop `lower`, and set the bound with `upper`. + +--- + + Code + expr + Condition + Error in `ps_trim()`: + ! `method = "resid"` needs `upper`. + x The bound on the absolute standardized residual has no default. + i Supply the number of spreads from the predicted dose beyond which a unit is trimmed, such as `upper = 3`. + +# ps_trim() refuses a density floor outside (0, 0.5) and a residual bound that is not positive + + Code + expr + Condition + Error in `ps_trim()`: + ! For `method = "density"`, `lower` must be a single probability between 0 and 0.5. + x `lower` is 0.5. + i `lower` is the quantile of the conditional density below which units are trimmed, such as the default `lower = 0.01`. + +--- + + Code + expr + Condition + Error in `ps_trim()`: + ! For `method = "resid"`, `upper` must be a single positive, finite number. + x `upper` is -2. + i `upper` is the number of spreads from the predicted dose beyond which a unit is trimmed, such as `upper = 3`. + +# ps_trim() refuses a residual bound under a density that need not be symmetric + + Code + expr + Condition + Error in `ps_trim()`: + ! `method = "resid"` needs a symmetric unimodal density. + x `.density` is a "kernel" density, which need not be symmetric or unimodal, so a bound on the absolute residual is not a floor on it. + i Use `method = "density"`, which trims on the density itself under any family, or a `dens_normal()`, `dens_t()`, or `dens_laplace()` density. + +# ps_trim() refuses a spread it cannot record on a dose model + + Code + expr + Condition + Error in `ps_trim()`: + ! `.sigma` must be a single spread when trimming a dose model. + x It holds 60 values. + i A trim is recorded at one spread, which a refit of the dose model can keep; a spread for each unit cannot be refit. Supply one value, or leave `.sigma` unset to estimate it. + +--- + + Code + expr + Condition + Error in `ps_trim()`: + ! `sigma_method = "mle"` cannot be used with `.sigma`. + x `sigma_method = "mle"` estimates the scale of the "t" conditional density from the residuals of the propensity score model, and `.sigma` is a spread of your own that replaces it. + i A "t" density is spread by its own estimator unless you ask for another, so `sigma_method = "mle"` is what it carries whether or not you wrote it. + i Drop `.sigma` to estimate the scale under the "t" density, or build the density with `sigma_method = "rms"` to spread the one you supplied. + +# ps_trim() refuses a dose that does not line up with the fitted means + + Code + expr + Condition + Error in `ps_trim()`: + ! `.exposure` must have one value for each fitted mean. + x It has 60 values, and the model reports 58 fitted means. + i Supply the dose for the rows the model was fit to, or refit it with `na.action = na.exclude`, which reports a mean for every row of its data. + +--- + + Code + expr + Condition + Error in `ps_trim()`: + ! `.exposure` must be a numeric vector when trimming a dose model. + x It is a character vector. + i Supply the dose the model was fit to, one value per unit. + +# ps_trim() refuses a dose model of several responses + + Code + expr + Condition + Error in `ps_trim()`: + ! Trimming a dose model needs a model of one conditional mean for each unit. + x `.propensity` is , a fit of 2 responses, whose fitted values are 60 by 2. + i Fit the dose on its own and trim that model. + +# ps_trim() refuses a dose model fit with a spread that moves with its mean + + Code + expr + Condition + Error in `ps_trim()`: + ! Trimming a dose model needs a model of its conditional mean with a single spread. + x `.propensity` was fit with `poisson()`, whose spread changes with its fitted values. + i Fit the dose model with `gaussian()`, `lm()`, `mgcv::gam()`, or `MASS::rlm()`. + +# ps_trim() refuses a score method on a dose model and names the dose methods + + Code + expr + Condition + Error in `ps_trim()`: + ! Method "ps" cannot trim a dose model. + x `.propensity` is , a model of a continuous exposure's conditional mean, which has no propensity score in (0, 1) for "ps" to bound. + i Trim it on the scale of its conditional density with `method = "density"` or `method = "resid"`. + +--- + + Code + expr + Condition + Error in `ps_trim()`: + ! Method "adaptive" cannot trim a dose model. + x `.propensity` is , a model of a continuous exposure's conditional mean, which has no propensity score in (0, 1) for "adaptive" to bound. + i Trim it on the scale of its conditional density with `method = "density"` or `method = "resid"`. + +# ps_trim() refuses levels on a dose model + + Code + expr + Condition + Error in `ps_trim()`: + ! `.focal_level` cannot be used when trimming a dose model. + x A continuous exposure has no levels, so none is focal and none is reference. + i Drop `.focal_level`. + +# ps_trim() refuses a density or a spread on the score routes + + Code + expr + Condition + Error in `ps_trim()`: + ! `.density` applies only to trimming a dose model. + x The trimming method bounds propensity scores, which have no conditional density to read. + i Leave `.density` unset, or supply the model of a continuous exposure with `method = "density"` or `method = "resid"`. + +--- + + Code + expr + Condition + Error in `ps_trim()`: + ! `.sigma` applies only to trimming a dose model. + x The trimming method bounds propensity scores, which have no spread to read. + i Leave `.sigma` unset, or supply the model of a continuous exposure with `method = "density"` or `method = "resid"`. + +# ps_trim() refuses the density methods on a model of a probability + + Code + expr + Condition + Error in `ps_trim()`: + ! Method "density" cannot trim a model of a probability. + x `.propensity` is , whose fitted values are probabilities of the exposure, and a model of a probability has no conditional density to trim. + i Trim its propensity scores with a score method such as "ps", or supply the model of a continuous exposure's conditional mean to trim with "density". + +--- + + Code + expr + Condition + Error in `ps_trim()`: + ! Method "resid" cannot trim a model of a probability. + x `.propensity` is , whose fitted values are probabilities of the exposure, and a model of a probability has no conditional density to trim. + i Trim its propensity scores with a score method such as "ps", or supply the model of a continuous exposure's conditional mean to trim with "resid". + +--- + + Code + expr + Condition + Error in `ps_trim()`: + ! Method "density" cannot trim a model of a probability. + x `.propensity` is , whose fitted values are probabilities of the exposure, and a model of a probability has no conditional density to trim. + i Trim its propensity scores with a score method such as "ps", or supply the model of a continuous exposure's conditional mean to trim with "density". + +--- + + Code + expr + Condition + Error in `ps_trim()`: + ! Method "resid" cannot trim a model of a probability. + x `.propensity` is , whose fitted values are probabilities of the exposure, and a model of a probability has no conditional density to trim. + i Trim its propensity scores with a score method such as "ps", or supply the model of a continuous exposure's conditional mean to trim with "resid". + diff --git a/tests/testthat/_snaps/ps_trim.md b/tests/testthat/_snaps/ps_trim.md index 9b0799cd..03f1bc2b 100644 --- a/tests/testthat/_snaps/ps_trim.md +++ b/tests/testthat/_snaps/ps_trim.md @@ -280,7 +280,7 @@ expr Condition Error in `ps_trim()`: - ! No method for objects of class lm + ! No method for objects of class not_a_model # ps_trim() refuses scores that are not numbers diff --git a/tests/testthat/test-ps_trim-density.R b/tests/testthat/test-ps_trim-density.R index 0bfe5f48..7e697ada 100644 --- a/tests/testthat/test-ps_trim-density.R +++ b/tests/testthat/test-ps_trim-density.R @@ -794,6 +794,52 @@ test_that("ps_trim() refuses a spread it cannot record on a dose model", { ) }) +test_that("ps_trim() refuses a dose that does not line up with the fitted means", { + dat <- sim_dose_trim() + n <- nrow(dat) + + # A fit that omits the rows it dropped reports fewer means than the data has + # doses, so the full dose cannot be read against them. + dat_missing <- dat + dat_missing$x1[c(4L, 30L)] <- NA + fit_omit <- lm(a ~ x1 + x2, data = dat_missing, na.action = na.omit) + expect_length(fitted(fit_omit), n - 2L) + expect_error( + ps_trim(fit_omit, method = "density", .exposure = dat_missing$a), + class = "propensity_length_error" + ) + expect_propensity_error( + ps_trim(fit_omit, method = "density", .exposure = dat_missing$a) + ) + + # The dose is read as a number for each unit, so neither text nor a matrix + # will do. + fit <- lm(a ~ x1 + x2, data = dat) + expect_error( + ps_trim(fit, method = "density", .exposure = as.character(dat$a)), + class = "propensity_type_error" + ) + expect_error( + ps_trim(fit, method = "resid", upper = 2, .exposure = matrix(dat$a)), + class = "propensity_type_error" + ) + expect_propensity_error( + ps_trim(fit, method = "density", .exposure = as.character(dat$a)) + ) +}) + +test_that("ps_trim() refuses a dose model of several responses", { + dat <- sim_dose_trim() + dat$b <- dat$a + dat$x1 + fit <- lm(cbind(a, b) ~ x1 + x2, data = dat) + + expect_error( + ps_trim(fit, method = "density"), + class = "propensity_ps_shape_error" + ) + expect_propensity_error(ps_trim(fit, method = "density")) +}) + test_that("ps_trim() refuses a dose model fit with a spread that moves with its mean", { withr::local_seed(5) dat <- sim_dose_trim() @@ -881,15 +927,19 @@ test_that("ps_trim() refuses levels on a dose model", { }) test_that("ps_trim() refuses the deprecated level arguments on a dose model", { - fit <- lm(a ~ x1 + x2, data = sim_dose_trim()) + dat <- sim_dose_trim() + fit <- lm(a ~ x1 + x2, data = dat) + fit_glm <- glm(a ~ x1 + x2, data = dat, family = gaussian()) # The deprecated pair names levels too, and is refused the same way once its - # deprecation has been reported. + # deprecation has been reported. A gaussian glm reaches the dose route by its + # own method, so it is held to the same refusal. deprecated <- list( treated = quote(ps_trim(fit, method = "density", .treated = 1)), untreated = quote( ps_trim(fit, method = "resid", upper = 2, .untreated = 0) - ) + ), + glm_treated = quote(ps_trim(fit_glm, method = "density", .treated = 1)) ) for (kind in names(deprecated)) { warned <- 0L @@ -941,8 +991,51 @@ test_that("ps_trim() refuses a density or a spread on the score routes", { class = "propensity_sigma_error" ) + # A matrix of scores for a categorical exposure, and a data frame of them, + # are score routes too. + trt <- factor(sample(c("a", "b", "c"), n, replace = TRUE)) + ps_matrix <- matrix( + c(rep(0.3, n), rep(0.3, n), rep(0.4, n)), + ncol = 3, + dimnames = list(NULL, levels(trt)) + ) + expect_error( + ps_trim(ps_matrix, method = "ps", .exposure = trt, .sigma = 1), + class = "propensity_sigma_error" + ) + expect_error( + ps_trim(ps_matrix, method = "ps", .exposure = trt, .density = "laplace"), + class = "propensity_density_error" + ) + expect_error( + ps_trim( + as.data.frame(ps_matrix), + method = "ps", + .exposure = trt, + .sigma = 1 + ), + class = "propensity_sigma_error" + ) + expect_error( + ps_trim( + as.data.frame(ps_matrix), + method = "ps", + .exposure = trt, + .density = "laplace" + ), + class = "propensity_density_error" + ) + expect_error( + ps_trim(data.frame(ps = ps), method = "ps", .density = dens_t(4)), + class = "propensity_density_error" + ) + # The default family is no instruction at all. expect_s3_class(ps_trim(ps, method = "ps", .density = "normal"), "ps_trim") + expect_s3_class( + ps_trim(ps_matrix, method = "ps", .exposure = trt, .density = "normal"), + "ps_trim" + ) expect_propensity_error(ps_trim(ps, method = "ps", .density = dens_t(4))) expect_propensity_error(ps_trim(ps, method = "ps", .sigma = 1)) diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index 4d3cd1bf..5606fde2 100644 --- a/tests/testthat/test-ps_trim.R +++ b/tests/testthat/test-ps_trim.R @@ -2861,12 +2861,6 @@ test_that("ps_trim() reads a two-level multinomial fit on the binary path", { }) test_that("ps_trim() refuses a fit it cannot read propensity scores from", { - linear <- lm(z ~ x1 + x2, data = trim_model_data) - - expect_error( - ps_trim(linear, method = "ps"), - class = "propensity_method_error" - ) expect_error( ps_trim(structure(list(), class = "not_a_model"), method = "ps"), class = "propensity_method_error" @@ -2917,7 +2911,7 @@ test_that("ps_refit() refits a multinomial fit trimmed through the model route", test_that("ps_trim() names the class of a fit it has no reading for", { expect_propensity_error( - ps_trim(lm(z ~ x1 + x2, data = trim_model_data), method = "ps") + ps_trim(structure(list(), class = "not_a_model"), method = "ps") ) }) From 1afcd7f3df1e7a27518c3f48830e47d29fbeb3b3 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 20:29:59 -0400 Subject: [PATCH 07/64] add failing tests for the dose-aware refit and weights from a density trim --- tests/testthat/_snaps/ps_refit-density.md | 49 ++ tests/testthat/helper-dose-trim.R | 49 ++ tests/testthat/test-ps_refit-density.R | 991 ++++++++++++++++++++++ 3 files changed, 1089 insertions(+) create mode 100644 tests/testthat/_snaps/ps_refit-density.md create mode 100644 tests/testthat/test-ps_refit-density.R diff --git a/tests/testthat/_snaps/ps_refit-density.md b/tests/testthat/_snaps/ps_refit-density.md new file mode 100644 index 00000000..1908be6b --- /dev/null +++ b/tests/testthat/_snaps/ps_refit-density.md @@ -0,0 +1,49 @@ +# ps_refit() refuses a model of level probabilities for a density trim + + Code + expr + Condition + Error in `ps_refit()`: + ! A trimmed dose model can only be refit with a model of the exposure's conditional mean. + x The trimming record holds a dose model's conditional means, and `model` fits a probability for each of its levels. + i Refit with the model of the continuous exposure the trimming was made from. + +--- + + Code + expr + Condition + Error in `ps_refit()`: + ! A trimmed dose model can only be refit with a model of the exposure's conditional mean. + x The trimming record holds a dose model's conditional means, and `model` fits a probability for each of its levels. + i Refit with the model of the continuous exposure the trimming was made from. + +# an unrefit density trim warns that it was not refit + + Code + out <- wt_ate(fx$trimmed, fx$dat$a, exposure_type = "continuous") + Condition + Warning in `wt_ate()`: + It appears you trimmed your propensity score but did not refit the model. + i Use `ps_refit()` for more accurate re-estimation. + +# weights from a density trim are refused for an exposure that is not a dose + + Code + expr + Condition + Error in `wt_ate()`: + ! Weights for a binary exposure cannot be built from a density-trimmed dose model. + x The trimming record holds conditional means and a density family, not propensity scores. + i Pass the dose as `.exposure`, or trim a propensity score model for the binary exposure instead. + +--- + + Code + expr + Condition + Error in `wt_ate()`: + ! Weights for a binary exposure cannot be built from a density-trimmed dose model. + x The trimming record holds conditional means and a density family, not propensity scores. + i Pass the dose as `.exposure`, or trim a propensity score model for the binary exposure instead. + diff --git a/tests/testthat/helper-dose-trim.R b/tests/testthat/helper-dose-trim.R index 2ecd109f..abf905ad 100644 --- a/tests/testthat/helper-dose-trim.R +++ b/tests/testthat/helper-dose-trim.R @@ -157,3 +157,52 @@ expect_dose_trim <- function(trimmed, oracle, n) { testthat::expect_gt(length(oracle$trimmed_idx), 0) testthat::expect_gt(length(oracle$keep_idx), 0) } + +# The density-ratio weights a trimmed dose model describes, worked out by hand +# on the units with a conditional mean. `mu` holds `NA` at the trimmed +# positions, and `sigma` is the one spread the conditional density is read at. +# Without a numerator the weight is the inverse conditional density. The +# marginal numerator is the same family read at the mean of the retained doses +# and at the family's own spread of them. The integrated numerator averages the +# conditional density over the retained units at 50 points spanning their +# doses and interpolates back to each dose with a cubic spline. +dose_trim_weights <- function( + a, + mu, + sigma, + numerator = c("none", "marginal", "integrated"), + family = "normal", + sigma_method = "rms", + df = NULL +) { + numerator <- match.arg(numerator) + g <- function(z) dose_trim_g(z, family, df = df) + + present <- !is.na(a) & !is.na(mu) + a_p <- a[present] + mu_p <- mu[present] + f_den <- g((a_p - mu_p) / sigma) / sigma + + f_num <- switch( + numerator, + none = 1, + marginal = { + center <- mean(a_p) + spread <- dose_trim_sigma(a_p - center, family, sigma_method, df) + g((a_p - center) / spread) / spread + }, + integrated = { + grid <- seq(min(a_p), max(a_p), length.out = 50L) + on_grid <- rowMeans(matrix( + g(as.vector(outer(grid, mu_p, "-") / sigma)), + nrow = length(grid) + )) / + sigma + stats::spline(grid, on_grid, xout = a_p, method = "fmm")$y + } + ) + + out <- rep(NA_real_, length(a)) + out[present] <- f_num / f_den + out +} diff --git a/tests/testthat/test-ps_refit-density.R b/tests/testthat/test-ps_refit-density.R new file mode 100644 index 00000000..f4b8ec14 --- /dev/null +++ b/tests/testthat/test-ps_refit-density.R @@ -0,0 +1,991 @@ +# Refitting a trimmed dose model, and the weights its record describes +# +# A density trim keeps the conditional means of the units whose observed dose +# the model finds plausible, together with the family and the spread the +# conditional density was read at. `ps_refit()` refits the mean on the retained +# rows and re-estimates the spread from their residuals, and the weight +# functions read the family and the spread from the record rather than from +# their own arguments. Every expectation below is held against a refit and a +# density ratio worked out by hand in helper-dose-trim.R. + +# The dose model, its density trim, and the same model refit by hand on the +# rows the trim kept. +dose_refit_fixture <- function( + density = dens_normal(), + family = "normal", + sigma_method = "rms", + df = NULL, + lower = 0.05 +) { + dat <- sim_dose_trim() + fit <- lm(a ~ x1 + x2, data = dat) + trimmed <- ps_trim(fit, method = "density", lower = lower, .density = density) + oracle <- dose_trim_oracle( + dat$a, + fitted(fit), + method = "density", + family = family, + sigma_method = sigma_method, + df = df, + lower = lower + ) + keep <- oracle$keep_idx + + refit_fit <- lm(a ~ x1 + x2, data = dat[keep, , drop = FALSE]) + refit_mu <- rep(NA_real_, nrow(dat)) + refit_mu[keep] <- fitted(refit_fit) + + full_mu <- as.numeric(fitted(fit)) + full_mu[oracle$trimmed_idx] <- NA_real_ + + list( + dat = dat, + n = nrow(dat), + fit = fit, + trimmed = trimmed, + oracle = oracle, + keep = keep, + refit_fit = refit_fit, + refit_mu = refit_mu, + full_mu = full_mu, + refit_sigma = if (family %in% c("normal", "t", "laplace")) { + dose_trim_sigma( + dat$a[keep] - fitted(refit_fit), + family, + sigma_method, + df + ) + } + ) +} + +# ---- ps_refit(): the mean and the spread on the retained rows ---------------- + +test_that("ps_refit() refits a density trim's mean and spread on the retained rows", { + cases <- list( + normal = list(density = dens_normal(), family = "normal"), + t_mle = list( + density = dens_t(4), + family = "t", + sigma_method = "mle", + df = 4 + ), + t_rms = list( + density = dens_t(4, sigma_method = "rms"), + family = "t", + df = 4 + ), + laplace = list( + density = dens_laplace(), + family = "laplace", + sigma_method = "mle" + ) + ) + + for (case in names(cases)) { + fx <- do.call(dose_refit_fixture, cases[[case]]) + expect_dose_trim(fx$trimmed, fx$oracle, fx$n) + + refit <- ps_refit(fx$trimmed, fx$fit) + before <- ps_trim_meta(fx$trimmed) + after <- ps_trim_meta(refit) + + expect_s3_class(refit, "ps_trim") + expect_true(is_refit(refit), info = case) + + # The retained values are the refit model's conditional means, and the + # trimmed units stay set aside. + values <- as.numeric(refit) + expect_true(all(is.na(values[fx$oracle$trimmed_idx])), info = case) + expect_equal( + values[fx$keep], + fx$refit_mu[fx$keep], + tolerance = 1e-10, + info = case + ) + + # The spread is the family's own estimate on the retained residuals, which + # is not the full-sample spread the trim was decided at. + expect_equal(after$sigma, fx$refit_sigma, tolerance = 1e-8, info = case) + expect_gt(abs(after$sigma - before$sigma), 1e-3) + + # What describes the cut that was made is left as it was. + expect_identical(after$threshold, before$threshold, info = case) + expect_identical(after$keep_idx, before$keep_idx, info = case) + expect_identical(after$trimmed_idx, before$trimmed_idx, info = case) + expect_identical(after$sigma_kind, before$sigma_kind, info = case) + expect_identical(after$method, "density", info = case) + expect_identical(after$lower, before$lower, info = case) + expect_true( + density_specs_agree(after$density, before$density), + info = case + ) + } +}) + +test_that("a refit density trim reads the density the refit model gives", { + fx <- dose_refit_fixture( + density = dens_t(4), + family = "t", + sigma_method = "mle", + df = 4 + ) + refit <- ps_refit(fx$trimmed, fx$fit) + meta <- ps_trim_meta(refit) + + # The density the refit record describes, read from its means, its spread, + # and its family, is the inverse of the unstabilized weight the refit model + # gives on the retained rows, which is how the simulation read it. + a_kept <- fx$dat$a[fx$keep] + from_record <- stats::dt( + (a_kept - as.numeric(refit)[fx$keep]) / meta$sigma, + df = 4 + ) / + meta$sigma + from_model <- 1 / + as.numeric(wt_ate( + fx$refit_fit, + stabilize = FALSE, + .density = dens_t(4) + )) + + expect_equal(from_record, from_model, tolerance = 1e-10) +}) + +test_that("ps_refit() refits a gaussian glm trim on the retained rows", { + dat <- sim_dose_trim() + n <- nrow(dat) + + fit_glm <- glm(a ~ x1 + x2, data = dat, family = gaussian()) + trimmed <- ps_trim( + fit_glm, + method = "resid", + upper = 2, + .density = dens_laplace() + ) + oracle <- dose_trim_oracle( + dat$a, + fitted(fit_glm), + method = "resid", + family = "laplace", + sigma_method = "mle", + upper = 2 + ) + expect_dose_trim(trimmed, oracle, n) + + refit <- ps_refit(trimmed, fit_glm) + by_hand <- glm( + a ~ x1 + x2, + data = dat[oracle$keep_idx, ], + family = gaussian() + ) + expect_equal( + as.numeric(refit)[oracle$keep_idx], + as.numeric(fitted(by_hand)), + tolerance = 1e-10 + ) + expect_equal( + ps_trim_meta(refit)$sigma, + mean(abs(residuals(by_hand, type = "response"))), + tolerance = 1e-10 + ) + expect_identical(ps_trim_meta(refit)$upper, 2) + expect_identical( + ps_trim_meta(refit)$threshold, + ps_trim_meta(trimmed)$threshold + ) +}) + +test_that("ps_refit() refits a robust dose model's trim", { + skip_if_not_installed("MASS") + dat <- sim_dose_trim() + n <- nrow(dat) + + fit_rlm <- MASS::rlm(a ~ x1 + x2, data = dat) + trimmed_rlm <- ps_trim(fit_rlm, method = "density", lower = 0.05) + oracle_rlm <- dose_trim_oracle( + dat$a, + fitted(fit_rlm), + method = "density", + lower = 0.05 + ) + expect_dose_trim(trimmed_rlm, oracle_rlm, n) + + refit_rlm <- ps_refit(trimmed_rlm, fit_rlm) + by_hand_rlm <- MASS::rlm(a ~ x1 + x2, data = dat[oracle_rlm$keep_idx, ]) + expect_equal( + as.numeric(refit_rlm)[oracle_rlm$keep_idx], + as.numeric(fitted(by_hand_rlm)), + tolerance = 1e-8 + ) + expect_equal( + ps_trim_meta(refit_rlm)$sigma, + dose_trim_sigma(dat$a[oracle_rlm$keep_idx] - fitted(by_hand_rlm)), + tolerance = 1e-8 + ) +}) + +test_that("ps_refit() refits an additive dose model's trim", { + skip_if_not_installed("mgcv") + dat <- sim_dose_trim() + n <- nrow(dat) + + fit_gam <- mgcv::gam(a ~ s(x1) + x2, data = dat, family = gaussian()) + trimmed_gam <- ps_trim(fit_gam, method = "density", lower = 0.05) + oracle_gam <- dose_trim_oracle( + dat$a, + fitted(fit_gam), + method = "density", + lower = 0.05 + ) + expect_dose_trim(trimmed_gam, oracle_gam, n) + + refit_gam <- ps_refit(trimmed_gam, fit_gam) + by_hand_gam <- mgcv::gam( + a ~ s(x1) + x2, + data = dat[oracle_gam$keep_idx, ], + family = gaussian() + ) + expect_equal( + as.numeric(refit_gam)[oracle_gam$keep_idx], + as.numeric(fitted(by_hand_gam)), + tolerance = 1e-8 + ) + expect_equal( + ps_trim_meta(refit_gam)$sigma, + dose_trim_sigma(dat$a[oracle_gam$keep_idx] - fitted(by_hand_gam)), + tolerance = 1e-8 + ) +}) + +test_that("ps_refit() keeps a spread the caller supplied", { + dat <- sim_dose_trim() + n <- nrow(dat) + fit <- lm(a ~ x1 + x2, data = dat) + + trimmed <- ps_trim(fit, method = "resid", upper = 2, .sigma = 1.5) + oracle <- dose_trim_oracle( + dat$a, + fitted(fit), + method = "resid", + sigma = 1.5, + upper = 2 + ) + expect_dose_trim(trimmed, oracle, n) + + refit <- ps_refit(trimmed, fit) + meta <- ps_trim_meta(refit) + by_hand <- lm(a ~ x1 + x2, data = dat[oracle$keep_idx, ]) + + expect_identical(meta$sigma, 1.5) + expect_identical(meta$sigma_kind, "supplied") + expect_true(is_refit(refit)) + expect_equal( + as.numeric(refit)[oracle$keep_idx], + as.numeric(fitted(by_hand)), + tolerance = 1e-10 + ) +}) + +# ---- ps_refit(): refusals ---------------------------------------------------- + +test_that("ps_refit() refuses a model of level probabilities for a density trim", { + skip_if_not_installed("nnet") + dat <- sim_dose_trim() + fit <- lm(a ~ x1 + x2, data = dat) + trimmed <- ps_trim(fit, method = "density", lower = 0.05) + expect_gt(length(ps_trim_meta(trimmed)$trimmed_idx), 0) + + withr::local_seed(31) + dat$z2 <- factor(sample(c("a", "b"), nrow(dat), replace = TRUE)) + dat$z3 <- factor(sample(c("a", "b", "c"), nrow(dat), replace = TRUE)) + fits <- list( + two = nnet::multinom(z2 ~ x1 + x2, data = dat, trace = FALSE), + three = nnet::multinom(z3 ~ x1 + x2, data = dat, trace = FALSE) + ) + + # A two-level `multinom` answers as a single probability rather than one per + # level, and is still refused for a record of conditional means. + for (kind in names(fits)) { + expect_true( + inherits(fits[[kind]], "multinom") || model_fits_levels(fits[[kind]]), + info = kind + ) + expect_error( + ps_refit(trimmed, fits[[kind]]), + class = "propensity_model_family_error", + info = kind + ) + } + + expect_propensity_error(ps_refit(trimmed, fits$two)) + expect_propensity_error(ps_refit(trimmed, fits$three)) +}) + +test_that("ps_refit() refuses a model of a probability for a density trim and names every dose model", { + dat <- sim_dose_trim() + fit <- lm(a ~ x1 + x2, data = dat) + trimmed <- ps_trim(fit, method = "density", lower = 0.05) + expect_gt(length(ps_trim_meta(trimmed)$trimmed_idx), 0) + + withr::local_seed(37) + dat$z <- rbinom(nrow(dat), 1, 0.5) + dat$k <- rpois(nrow(dat), 2) + fits <- list( + binomial = glm(z ~ x1 + x2, data = dat, family = binomial()), + poisson = glm(k ~ x1 + x2, data = dat, family = poisson()) + ) + + # The remedy names the dose models the density trim and the weights accept, + # which include the robust and additive fits read by inheritance. + for (kind in names(fits)) { + cnd <- expect_error( + ps_refit(trimmed, fits[[kind]]), + class = "propensity_model_family_error", + info = kind + ) + message <- cli::ansi_strip(conditionMessage(cnd)) + expect_match(message, "mgcv::gam", fixed = TRUE, info = kind) + expect_match(message, "MASS::rlm", fixed = TRUE, info = kind) + } + + expect_propensity_error(ps_refit(trimmed, fits$binomial)) +}) + +# ---- weights read from the record -------------------------------------------- + +test_that("weights from a refit density trim are the refit model's weights", { + dat <- sim_dose_trim() + fit <- lm(a ~ x1 + x2, data = dat) + t4 <- function(z) stats::dt(z, df = 4) + + densities <- list( + normal = dens_normal(), + t_mle = dens_t(4), + t_rms = dens_t(4, sigma_method = "rms"), + laplace = dens_laplace(), + kernel = dens_kernel(), + written = dens_fn(t4) + ) + settings <- list( + none = list(stabilize = FALSE, numerator = "marginal"), + marginal = list(stabilize = TRUE, numerator = "marginal"), + integrated = list(stabilize = TRUE, numerator = "integrated") + ) + weight_fns <- list(wt_ate = wt_ate, wt_cens = wt_cens) + + for (family in names(densities)) { + density <- densities[[family]] + trimmed <- ps_trim(fit, method = "density", lower = 0.1, .density = density) + meta <- ps_trim_meta(trimmed) + keep <- meta$keep_idx + expect_gt(length(meta$trimmed_idx), 0) + + refit <- ps_refit(trimmed, fit) + refit_fit <- lm(a ~ x1 + x2, data = dat[keep, ]) + + for (setting in names(settings)) { + args <- settings[[setting]] + for (fn_name in names(weight_fns)) { + weight_fn <- weight_fns[[fn_name]] + info <- paste(family, setting, fn_name) + + from_record <- weight_fn( + refit, + dat$a, + exposure_type = "continuous", + stabilize = args$stabilize, + numerator = args$numerator + ) + from_model <- weight_fn( + refit_fit, + exposure_type = "continuous", + stabilize = args$stabilize, + numerator = args$numerator, + .density = density + ) + + expect_length(from_record, nrow(dat)) + expect_true(all(is.na(as.numeric(from_record)[-keep])), info = info) + expect_equal( + as.numeric(from_record)[keep], + as.numeric(from_model), + tolerance = 1e-12, + info = info + ) + + recorded <- density_meta(from_record) + expect_true( + density_specs_agree(recorded$density, meta$density), + info = info + ) + expect_identical(recorded$sigma, meta$sigma_kind, info = info) + expect_identical( + recorded$numerator, + if (args$stabilize) args$numerator else "none", + info = info + ) + } + } + } +}) + +test_that("weights from a refit density trim are the density ratio worked out by hand", { + cases <- list( + normal = list( + density = dens_normal(), + family = "normal", + sigma_method = "rms" + ), + t_mle = list( + density = dens_t(4), + family = "t", + sigma_method = "mle", + df = 4 + ), + laplace = list( + density = dens_laplace(), + family = "laplace", + sigma_method = "mle" + ) + ) + + for (case in names(cases)) { + spec <- cases[[case]] + fx <- do.call(dose_refit_fixture, spec) + expect_gt(length(fx$oracle$trimmed_idx), 0) + refit <- ps_refit(fx$trimmed, fx$fit) + sigma_kind <- if (identical(spec$sigma_method, "mle")) "mle" else "pooled" + + for (numerator in c("none", "marginal", "integrated")) { + info <- paste(case, numerator) + weights <- wt_ate( + refit, + fx$dat$a, + exposure_type = "continuous", + stabilize = numerator != "none", + numerator = if (numerator == "none") "marginal" else numerator + ) + by_hand <- dose_trim_weights( + fx$dat$a, + fx$refit_mu, + sigma = fx$refit_sigma, + numerator = numerator, + family = spec$family, + sigma_method = spec$sigma_method, + df = spec$df + ) + + expect_equal( + as.numeric(weights), + by_hand, + tolerance = 1e-8, + info = info + ) + + recorded <- density_meta(weights) + expect_identical(recorded$density$family, spec$family, info = info) + expect_identical(recorded$sigma, sigma_kind, info = info) + expect_equal( + recorded$sigma_value, + ps_trim_meta(refit)$sigma, + tolerance = 1e-12, + info = info + ) + } + } + + # The heavy-tailed record is the one a normal default would misread, so its + # record is spelled out. + fx <- do.call(dose_refit_fixture, cases$t_mle) + weights <- wt_ate( + ps_refit(fx$trimmed, fx$fit), + fx$dat$a, + exposure_type = "continuous" + ) + recorded <- density_meta(weights) + expect_identical(recorded$density$family, "t") + expect_identical(recorded$density$params$df, 4) + expect_identical(recorded$density$sigma_method, "mle") + expect_identical(recorded$sigma, "mle") + expect_identical(recorded$numerator, "marginal") +}) + +test_that("weights from a refit density trim reproduce the simulation's trimming arm", { + dat <- sim_dose_trim() + fit <- lm(a ~ x1 + x2, data = dat) + + # The arm read each unit's conditional density as the inverse of its + # unstabilized weight, kept the units at or above a quantile of it, refit the + # dose model on them, and weighted by the refit model's stabilized weights. + density <- 1 / as.numeric(wt_ate(fit, stabilize = FALSE)) + keep <- density >= stats::quantile(density, 0.05, names = FALSE) + expect_gt(sum(!keep), 0) + arm_fit <- lm(a ~ x1 + x2, data = dat[keep, ]) + arm_weights <- as.numeric(wt_ate(arm_fit)) + + trimmed <- ps_trim(fit, method = "density", lower = 0.05) + expect_identical(is_unit_trimmed(trimmed), !keep) + + weights <- wt_ate( + ps_refit(trimmed, fit), + dat$a, + exposure_type = "continuous" + ) + + expect_equal(as.numeric(weights)[keep], arm_weights, tolerance = 1e-12) + expect_true(all(is.na(as.numeric(weights)[!keep]))) + + mu <- rep(NA_real_, nrow(dat)) + mu[keep] <- fitted(arm_fit) + expect_equal( + as.numeric(weights), + dose_trim_weights( + dat$a, + mu, + sigma = sqrt(mean(residuals(arm_fit)^2)), + numerator = "marginal" + ), + tolerance = 1e-10 + ) + + # The weights say what was done to them: trimmed, refit, and which units. + expect_identical(estimand(weights), "ate; trimmed") + expect_true(is_ps_trimmed(weights)) + expect_true(isTRUE(attr(weights, "trimmed"))) + expect_true(is_refit(weights)) + expect_true(is_stabilized(weights)) + expect_identical(is_unit_trimmed(weights), !keep) + expect_identical(ps_trim_meta(weights)$method, "density") + expect_identical( + ps_trim_meta(weights)$sigma, + ps_trim_meta(ps_refit(trimmed, fit))$sigma + ) +}) + +test_that("weights from a density trim that was not refit read the record's full-sample spread", { + cases <- list( + normal = list( + density = dens_normal(), + family = "normal", + sigma_method = "rms" + ), + t_mle = list( + density = dens_t(4), + family = "t", + sigma_method = "mle", + df = 4 + ) + ) + + for (case in names(cases)) { + spec <- cases[[case]] + fx <- do.call(dose_refit_fixture, spec) + expect_gt(length(fx$oracle$trimmed_idx), 0) + sigma_kind <- if (identical(spec$sigma_method, "mle")) "mle" else "pooled" + + for (numerator in c("none", "marginal", "integrated")) { + info <- paste(case, numerator) + expect_warning( + weights <- wt_ate( + fx$trimmed, + fx$dat$a, + exposure_type = "continuous", + stabilize = numerator != "none", + numerator = if (numerator == "none") "marginal" else numerator + ), + class = "propensity_no_refit_warning" + ) + + # The same object that made the cut makes the weights: the full-sample + # means of the retained units, read at the full-sample spread. + by_hand <- dose_trim_weights( + fx$dat$a, + fx$full_mu, + sigma = fx$oracle$sigma, + numerator = numerator, + family = spec$family, + sigma_method = spec$sigma_method, + df = spec$df + ) + expect_equal( + as.numeric(weights), + by_hand, + tolerance = 1e-8, + info = info + ) + + # Re-estimating the spread from the retained residuals alone gives other + # weights, so the comparison above tells the two readings apart. + reestimated <- wt_ate( + fx$full_mu, + fx$dat$a, + exposure_type = "continuous", + stabilize = numerator != "none", + numerator = if (numerator == "none") "marginal" else numerator, + .density = spec$density + ) + expect_gt( + max(abs(as.numeric(reestimated) - by_hand), na.rm = TRUE), + 1e-4 + ) + + recorded <- density_meta(weights) + expect_identical(recorded$density$family, spec$family, info = info) + expect_identical(recorded$sigma, sigma_kind, info = info) + expect_equal( + recorded$sigma_value, + fx$oracle$sigma, + tolerance = 1e-8, + info = info + ) + + expect_identical(estimand(weights), "ate; trimmed", info = info) + expect_true(is_ps_trimmed(weights), info = info) + expect_false(is_refit(weights), info = info) + expect_identical( + is_unit_trimmed(weights), + seq_len(fx$n) %in% fx$oracle$trimmed_idx, + info = info + ) + } + } +}) + +test_that("an unrefit density trim warns that it was not refit", { + fx <- dose_refit_fixture() + expect_gt(length(fx$oracle$trimmed_idx), 0) + + expect_propensity_warning(wt_ate( + fx$trimmed, + fx$dat$a, + exposure_type = "continuous" + )) + expect_warning( + wt_cens(fx$trimmed, fx$dat$a, exposure_type = "continuous"), + class = "propensity_no_refit_warning" + ) + expect_no_warning(wt_ate( + ps_refit(fx$trimmed, fx$fit), + fx$dat$a, + exposure_type = "continuous" + )) +}) + +test_that("censoring weights from a density trim carry the trimmed label", { + fx <- dose_refit_fixture( + density = dens_t(4), + family = "t", + sigma_method = "mle", + df = 4 + ) + refit <- ps_refit(fx$trimmed, fx$fit) + + weights <- wt_cens(refit, fx$dat$a, exposure_type = "continuous") + expect_identical(estimand(weights), "uncensored; trimmed") + expect_true(is_ps_trimmed(weights)) + expect_true(is_refit(weights)) + expect_identical( + is_unit_trimmed(weights), + seq_len(fx$n) %in% fx$oracle$trimmed_idx + ) + expect_identical(density_meta(weights)$density$family, "t") + expect_identical(density_meta(weights)$sigma, "mle") + expect_equal( + as.numeric(weights), + dose_trim_weights( + fx$dat$a, + fx$refit_mu, + sigma = fx$refit_sigma, + numerator = "marginal", + family = "t", + sigma_method = "mle", + df = 4 + ), + tolerance = 1e-8 + ) +}) + +test_that("the integrated numerator reads a record's spread and still refuses a caller's", { + dat <- sim_dose_trim() + n <- nrow(dat) + fit <- lm(a ~ x1 + x2, data = dat) + + trimmed <- ps_trim(fit, method = "resid", upper = 2, .sigma = 1.5) + oracle <- dose_trim_oracle( + dat$a, + fitted(fit), + method = "resid", + sigma = 1.5, + upper = 2 + ) + expect_dose_trim(trimmed, oracle, n) + refit <- ps_refit(trimmed, fit) + keep <- oracle$keep_idx + + mu <- rep(NA_real_, n) + mu[keep] <- fitted(lm(a ~ x1 + x2, data = dat[keep, ])) + + # A spread the caller fixed when trimming is the record's, so the integrated + # numerator marginalizes over it rather than refusing it. + for (fn in list(wt_ate, wt_cens)) { + for (numerator in c("marginal", "integrated")) { + weights <- fn( + refit, + dat$a, + exposure_type = "continuous", + numerator = numerator + ) + expect_equal( + as.numeric(weights), + dose_trim_weights(dat$a, mu, sigma = 1.5, numerator = numerator), + tolerance = 1e-8, + info = numerator + ) + expect_identical(density_meta(weights)$sigma, "supplied") + expect_identical(density_meta(weights)$sigma_value, 1.5) + expect_identical(density_meta(weights)$numerator, numerator) + } + } + + # The same spread handed to the numeric route by the caller is still refused + # under the integrated numerator, so only a record opens it. + expect_error( + wt_ate( + mu, + dat$a, + exposure_type = "continuous", + .sigma = 1.5, + numerator = "integrated" + ), + class = "propensity_numerator_error" + ) + expect_error( + wt_cens( + mu, + dat$a, + exposure_type = "continuous", + .sigma = 1.5, + numerator = "integrated" + ), + class = "propensity_numerator_error" + ) +}) + +test_that("a density trim in a data frame is weighted as the trim on its own", { + fx <- dose_refit_fixture( + density = dens_t(4), + family = "t", + sigma_method = "mle", + df = 4 + ) + refit <- ps_refit(fx$trimmed, fx$fit) + by_hand <- dose_trim_weights( + fx$dat$a, + fx$refit_mu, + sigma = fx$refit_sigma, + numerator = "marginal", + family = "t", + sigma_method = "mle", + df = 4 + ) + + frames <- list( + alone = data.frame(ps = refit), + selected = data.frame(other = fx$refit_mu, ps = refit) + ) + for (frame in names(frames)) { + weights <- wt_ate( + frames[[frame]], + fx$dat$a, + exposure_type = "continuous", + .propensity_col = "ps" + ) + expect_equal(as.numeric(weights), by_hand, tolerance = 1e-8, info = frame) + expect_identical(estimand(weights), "ate; trimmed", info = frame) + expect_identical(density_meta(weights)$density$family, "t", info = frame) + expect_identical(density_meta(weights)$sigma, "mle", info = frame) + } +}) + +# ---- weights from the record: refusals --------------------------------------- + +test_that("weights from a density trim refuse a density the record does not hold", { + normal <- dose_refit_fixture() + normal_refit <- ps_refit(normal$trimmed, normal$fit) + heavy <- dose_refit_fixture( + density = dens_t(4), + family = "t", + sigma_method = "mle", + df = 4 + ) + heavy_refit <- ps_refit(heavy$trimmed, heavy$fit) + + conflicts <- list( + list(refit = normal_refit, density = "laplace"), + list(refit = normal_refit, density = dens_t(4)), + list(refit = heavy_refit, density = "normal"), + list(refit = heavy_refit, density = dens_t(5)), + list(refit = heavy_refit, density = dens_t(4, sigma_method = "rms")) + ) + + for (i in seq_along(conflicts)) { + conflict <- conflicts[[i]] + for (fn in list(wt_ate, wt_cens)) { + expect_error( + fn( + conflict$refit, + normal$dat$a, + exposure_type = "continuous", + .density = conflict$density + ), + class = "propensity_density_error", + info = paste("conflict", i) + ) + } + } + + # A density that agrees with the record is the record's, and changes + # nothing. + expect_equal( + wt_ate( + normal_refit, + normal$dat$a, + exposure_type = "continuous", + .density = "normal" + ), + wt_ate(normal_refit, normal$dat$a, exposure_type = "continuous") + ) + agreeing <- wt_ate( + heavy_refit, + heavy$dat$a, + exposure_type = "continuous", + .density = dens_t(4) + ) + expect_equal( + as.numeric(agreeing), + dose_trim_weights( + heavy$dat$a, + heavy$refit_mu, + sigma = heavy$refit_sigma, + numerator = "marginal", + family = "t", + sigma_method = "mle", + df = 4 + ), + tolerance = 1e-8 + ) + + expect_propensity_error(wt_ate( + normal_refit, + normal$dat$a, + exposure_type = "continuous", + .density = "laplace" + )) +}) + +test_that("weights from a density trim refuse a spread of the caller's", { + estimated <- dose_refit_fixture() + estimated_refit <- ps_refit(estimated$trimmed, estimated$fit) + + dat <- estimated$dat + fit <- estimated$fit + supplied <- ps_trim(fit, method = "resid", upper = 2, .sigma = 1.5) + expect_gt(length(ps_trim_meta(supplied)$trimmed_idx), 0) + supplied_refit <- ps_refit(supplied, fit) + + # The record holds the spread the trim was made at, so a second one is + # refused even when it repeats the recorded number. + for (fn in list(wt_ate, wt_cens)) { + expect_error( + fn(estimated_refit, dat$a, exposure_type = "continuous", .sigma = 1), + class = "propensity_sigma_error" + ) + expect_error( + fn(supplied_refit, dat$a, exposure_type = "continuous", .sigma = 1.5), + class = "propensity_sigma_error" + ) + expect_error( + fn( + supplied_refit, + dat$a, + exposure_type = "continuous", + .sigma = rep(1.5, nrow(dat)) + ), + class = "propensity_sigma_error" + ) + } + + expect_propensity_error(wt_ate( + estimated_refit, + dat$a, + exposure_type = "continuous", + .sigma = 1 + )) +}) + +test_that("weights from a density trim are refused for an exposure that is not a dose", { + fx <- dose_refit_fixture() + refit <- ps_refit(fx$trimmed, fx$fit) + expect_gt(length(fx$oracle$trimmed_idx), 0) + + withr::local_seed(41) + z <- rbinom(fx$n, 1, 0.5) + + for (fn in list(wt_ate, wt_cens)) { + for (exposure_type in c("binary", "auto")) { + expect_error( + fn(refit, z, exposure_type = exposure_type), + class = "propensity_modified_continuous_error", + info = exposure_type + ) + expect_error( + fn(data.frame(ps = refit), z, exposure_type = exposure_type), + class = "propensity_modified_continuous_error", + info = exposure_type + ) + expect_error( + fn( + data.frame(other = fx$refit_mu, ps = refit), + z, + exposure_type = exposure_type, + .propensity_col = "ps" + ), + class = "propensity_modified_continuous_error", + info = exposure_type + ) + } + } + + expect_propensity_error(wt_ate(refit, z, exposure_type = "binary")) + expect_propensity_error(wt_ate( + data.frame(ps = refit), + z, + exposure_type = "binary" + )) +}) + +test_that("ipw() refuses weights built from a density trim", { + fx <- dose_refit_fixture( + density = dens_t(4), + family = "t", + sigma_method = "mle", + df = 4 + ) + expect_gt(length(fx$oracle$trimmed_idx), 0) + dat <- fx$dat + withr::local_seed(43) + dat$y <- 0.5 * dat$a + dat$x1 + rnorm(nrow(dat)) + + weights <- wt_ate( + ps_refit(fx$trimmed, fx$fit), + dat$a, + exposure_type = "continuous" + ) + outcome_mod <- lm(y ~ a, data = dat, weights = weights) + + expect_error( + ipw(fx$fit, outcome_mod, .data = dat), + class = "propensity_ipw_trimmed_error" + ) +}) From 7ec5daeca24454275892bff119168034fda10af3 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 21:00:59 -0400 Subject: [PATCH 08/64] refit a dose model on the kept rows and build weights from its trim record --- NEWS.md | 19 +++- R/density.R | 6 +- R/ps_trim.R | 104 +++++++++++++++++-- R/psw.R | 18 ++-- R/weights-utils.R | 119 ++++++++++++++++++++++ R/weights.R | 44 +++++++- man/exposure_type.Rd | 18 ++-- man/ps_refit.Rd | 14 ++- man/wt_ate.Rd | 13 ++- tests/testthat/_snaps/ps_refit-density.md | 38 ++++++- tests/testthat/test-ps_refit-density.R | 37 +++++++ tests/testthat/test-weights-continuous.R | 15 +-- 12 files changed, 401 insertions(+), 44 deletions(-) diff --git a/NEWS.md b/NEWS.md index 123546a9..2dc3fb20 100644 --- a/NEWS.md +++ b/NEWS.md @@ -13,6 +13,18 @@ trims that differ in any of them do not combine. A dose model asked for any other method, a model of a probability asked for either density method, and a level argument on a dose model are refused with informative errors. + `ps_refit()` refits a trimmed dose model's conditional mean on the retained + rows and re-estimates its spread there under the recorded family, keeping a + spread the caller supplied. `wt_ate()` and `wt_cens()` build weights from the + trim under the family and spread its record holds, refuse a `.density` that + disagrees with the record or any `.sigma`, and label the result as trimmed; + `ipw()` refuses those weights as it refuses other trimmed weights. + +* The marginal numerator of a `dens_kernel()` density is now fit only on the + units that have a conditional mean. A unit whose fitted mean was missing but + whose dose was present already took no part in the numerator's center and + spread and got no weight, yet its standardized dose still entered the kernel + fit, which changed the weights of every other unit. * Weights for a continuous exposure can no longer be built from a trimmed, truncated, or calibrated score. A conditional mean whose values happened to @@ -33,9 +45,10 @@ the family a density is read from. Each refusal names the routes for a dose: trimming the dose model with `ps_trim(method = "density")`, or building its weights with `wt_ate()` and - bounding the weights with `wt_trunc()`. Until those routes are available, - build the weights of a continuous exposure from the dose model or its fitted - means directly, without a score modification. + bounding the weights with `wt_trunc()`. The first is described above; + `wt_trunc()` is not yet available, so until it is, a dose's weights that + should keep every unit are built from the dose model or its fitted means + directly. A data frame of scores now behaves as the vector it holds does. A trimmed, truncated, or calibrated column in a data frame passed to any `wt_*()` diff --git a/R/density.R b/R/density.R index 108b4f99..eb642356 100644 --- a/R/density.R +++ b/R/density.R @@ -984,8 +984,12 @@ continuous_density_ratio <- function( # The marginal density is the same family read at the exposure's own center # and spread, so it is standardized by those rather than by the conditional - # spread. A kernel numerator is therefore fit on its own values. + # spread. A kernel numerator is therefore fit on its own values, and only on + # those of the units the conditional density reads: a unit with no fitted + # mean, such as one a trim set aside, is outside the population the moments + # were read over and carries no weight, so it has no part in the fit either. z_a <- (exposure - mu_a) / sigma_a + z_a[is.na(z)] <- NA_real_ f_num <- density_eval_present(density, z_a, call = call) / sigma_a f_num / f_den diff --git a/R/ps_trim.R b/R/ps_trim.R index 0c14a4c6..73f03e31 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -2507,7 +2507,11 @@ diff.ps_trim <- function(x, lag = 1L, differences = 1L, ...) { #' Trimmed propensity scores are refit only by a model of the probability of #' the exposure; a model of a conditional mean, such as a [stats::lm()] fit #' or a gaussian [stats::glm()], never produced them and raises an error of -#' class `propensity_model_family_error`. +#' class `propensity_model_family_error`. A dose model trimmed with +#' `method = "density"` or `method = "resid"` is refit only by a model of +#' the dose's conditional mean, such as a gaussian [stats::glm()], +#' [stats::lm()], [mgcv::gam()], or [MASS::rlm()] fit, and any other model, +#' such as one of a probability, raises the same error. #' @param .data A data frame with one row per observation in `trimmed_ps`, in #' the same order. If `NULL` (the default), the data are recovered from #' `model`: its [model.frame()][stats::model.frame] when that already holds @@ -2553,6 +2557,14 @@ diff.ps_trim <- function(x, lag = 1L, differences = 1L, ...) { #' [ps_calibrate()] is no longer calibrated and [is_ps_calibrated()] answers #' `FALSE` for the result. #' +#' For a trimmed dose model, the retained values are the refit model's +#' conditional means, and the spread in the record is re-estimated from the +#' retained residuals under the recorded density family, unless the trim was +#' made at a `.sigma` the caller supplied, which is kept. The recorded +#' threshold describes the cut that was made and is left as it was, so the +#' refit model can place a retained unit's conditional density below it; +#' nothing is trimmed again. +#' #' @seealso [ps_trim()] for the trimming step, [is_refit()] to check refit #' status, [wt_ate()] and other weight functions for the next step in the #' pipeline. @@ -2597,6 +2609,7 @@ ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { # model that could never have produced the trimmed values is refused for that # rather than for whatever refitting it would run into. check_refit_model(meta, model) + density_record <- is_density_trim_record(meta) from_model <- is.null(.data) if (from_model) { @@ -2632,10 +2645,15 @@ ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { # to work again would choose among rows it was never about. It is dropped # unless the caller names one, which is an instruction of its own. data_sub <- .data[meta$keep_idx, , drop = FALSE] - refit_model <- if ("subset" %in% ...names()) { - stats::update(model, data = data_sub, ...) + refit_call <- if ("subset" %in% ...names()) { + stats::update(model, data = data_sub, ..., evaluate = FALSE) } else { - stats::update(model, data = data_sub, subset = NULL, ...) + stats::update(model, data = data_sub, subset = NULL, ..., evaluate = FALSE) + } + refit_model <- eval(refit_call_function(refit_call, model)) + + if (density_record) { + return(refit_dose_trim(meta, refit_model, data_sub, n_obs)) } # predict new PS for all rows @@ -2701,7 +2719,7 @@ ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { # reads a model that carries no family as a least squares fit, and a two-level # `multinom` carries none and does not answer to `model_fits_levels()` either. check_refit_model <- function(meta, model, call = rlang::caller_env()) { - density_record <- isTRUE(meta$method %in% c("density", "resid")) + density_record <- is_density_trim_record(meta) if (!density_record) { if (model_fits_levels(model)) { @@ -2730,9 +2748,11 @@ check_refit_model <- function(meta, model, call = rlang::caller_env()) { c( dose_problem, x = "The trimming record holds a dose model's conditional means, and - {.arg model} fits a probability for each of its levels.", + {.arg model} is {.cls {class(model)[[1]]}}, a model of the + probabilities of a discrete exposure's levels.", i = "Refit with the model of the continuous exposure the trimming was - made from." + made from, such as one fit with {.fun gaussian}, {.fun lm}, + {.fun mgcv::gam}, or {.fun MASS::rlm}." ), error_class = "propensity_model_family_error", call = call @@ -2745,12 +2765,78 @@ check_refit_model <- function(meta, model, call = rlang::caller_env()) { problem = dose_problem, remedy = "The trimming record holds a dose model's conditional means, so refit with the model of the continuous exposure the trimming was - made from, fit with {.fun lm} or - {.code glm(family = gaussian())}.", + made from, such as one fit with {.fun gaussian}, {.fun lm}, + {.fun mgcv::gam}, or {.fun MASS::rlm}.", call = call ) } +# Whether a trimming record was made by trimming a dose model, whose values are +# conditional means read under a density family rather than propensity scores. +is_density_trim_record <- function(meta) { + isTRUE(meta$method %in% ps_trim_dose_methods) +} + +# A refit call names the fitting function the way the original fit recorded it. +# `MASS::rlm()` records itself as a bare `rlm`, which cannot be found unless its +# package is attached, so a bare name that does not resolve is qualified with +# the namespace that defines the methods for the model's class. +refit_call_function <- function(refit_call, model) { + # `predict()` is the generic looked up, because every model class a refit + # accepts has to answer it. + fn <- refit_call[[1]] + if (!is.symbol(fn) || exists(as.character(fn), mode = "function")) { + return(refit_call) + } + + fn_name <- as.character(fn) + for (cls in class(model)) { + method <- utils::getS3method("predict", cls, optional = TRUE) + home <- if (is.function(method)) environment(method) + if ( + isNamespace(home) && + exists(fn_name, envir = home, mode = "function", inherits = FALSE) + ) { + refit_call[[1]] <- call("::", as.symbol(getNamespaceName(home)), fn) + return(refit_call) + } + } + + refit_call +} + +# The refit of a trimmed dose model. The retained values are the refit model's +# conditional means, and the spread the density is read at is re-estimated from +# the retained residuals under the recorded family, because the density ratio +# takes the spread as an argument of its own. A spread the caller supplied is +# theirs whatever the residuals would estimate, and is kept. The threshold +# describes the cut that was made, so it is left as recorded even where the +# refit model puts a retained unit's density below it. +refit_dose_trim <- function(meta, refit_model, data_sub, n_obs) { + keep_idx <- meta$keep_idx + new_mu <- rep(NA_real_, n_obs) + new_mu[keep_idx] <- stats::predict( + refit_model, + newdata = data_sub, + type = "response" + ) + + # The spread is read from the refit model's own residuals, which cover + # exactly the rows it analyzed. A `subset` or a covariate missing on a kept + # row leaves fewer of those than there are kept rows. + if (!identical(meta$sigma_kind, "supplied")) { + residuals <- as.numeric(stats::residuals(refit_model, type = "response")) + meta$sigma <- density_scale_estimate( + residuals[!is.na(residuals)], + meta$density + ) + } + + meta$refit <- TRUE + + new_trimmed_ps(x = new_mu, ps_trim_meta = meta) +} + # The variables the refit call reads: the ones the formula names, plus any named # by `weights` or `offset`, which are evaluated against whatever data the refit # is handed. The original `subset` is dropped from that call, so the variables it diff --git a/R/psw.R b/R/psw.R index 19022874..11737b87 100644 --- a/R/psw.R +++ b/R/psw.R @@ -338,13 +338,17 @@ stabilization_score <- function(wt) { #' `"pooled"` for the pooled residual root mean square, `"mle"` for a scale #' estimated under the family that reads it, which [dens_t()] and #' [dens_laplace()] take with `sigma_method = "mle"`, and `"supplied"` for a -#' `.sigma` the caller gave. -#' * `sigma_value`, the single spread the caller supplied, and `NULL` for a -#' spread estimated from the residuals, by either estimator, and for one -#' supplied per observation. A spread that is one -#' number is a constant the weights can be rebuilt from, which is what -#' [ipw()] needs of it; a spread that changes with the observation is not, -#' so the record holds where it came from and nothing more. +#' `.sigma` the caller gave. Weights built from a dose model trimmed with +#' [ps_trim()] record where the trim's spread came from. +#' * `sigma_value`, the single spread the weights were read at when it was not +#' estimated by the weight function itself: one the caller supplied, or the +#' spread a dose model trimmed with [ps_trim()] holds in its record, which is +#' recorded whatever its source. It is `NULL` for a spread estimated from the +#' residuals, by either estimator, and for one supplied per observation. A +#' spread that is one number is a constant the weights can be rebuilt from, +#' which is what [ipw()] needs of it; a spread that changes with the +#' observation is not, so the record holds where it came from and nothing +#' more. #' #' Weights that carry a density record print it under their values, as the #' lines `format()` renders: the density family, the numerator, and the spread, diff --git a/R/weights-utils.R b/R/weights-utils.R index b13cd26a..cd7d1d88 100644 --- a/R/weights-utils.R +++ b/R/weights-utils.R @@ -1321,6 +1321,7 @@ calculate_weight_from_modified_ps <- function( weight_fn, modification_type = c("trim", "trunc", "calib"), ..., + density_supplied = TRUE, call = rlang::caller_env(), user_env = rlang::caller_env(2) ) { @@ -1375,6 +1376,16 @@ calculate_weight_from_modified_ps <- function( user_env = user_env, ... ) + } else if (is_density_trim_record(attr(.propensity, "ps_trim_meta"))) { + base_wt <- weight_from_density_trim( + .propensity, + .exposure = .exposure, + weight_fn = weight_fn, + ..., + density_supplied = density_supplied, + call = call, + user_env = user_env + ) } else { # Convert to numeric for vector propensity scores numeric_ps <- as.numeric(.propensity) @@ -1421,6 +1432,112 @@ calculate_weight_from_modified_ps <- function( base_wt } +# The weights a density trim of a dose model describes. The record holds the +# family and the spread the trim was decided at, and the weights are read under +# both, so that the retained units and the density ratio describe the same +# density. A family or a spread the caller also supplies is a second instruction +# about the same quantity and is refused rather than silently set aside; a +# family that agrees with the record changes nothing. `density_supplied` says +# whether the caller wrote `.density`, since the method's default is not an +# instruction. +weight_from_density_trim <- function( + .propensity, + .exposure, + weight_fn, + ..., + density_supplied, + call, + user_env +) { + meta <- attr(.propensity, "ps_trim_meta") + args <- rlang::list2(...) + + if (!is.null(args$.sigma)) { + abort( + c( + "{.arg .sigma} cannot be used with a density-trimmed dose model.", + x = "The trimming record holds the spread the conditional density was + read at, and {.arg .sigma} would be a second spread for the same + density.", + i = "Drop {.arg .sigma}. To read the density at a spread of your own, + pass it to {.fun ps_trim} when trimming, and {.fun ps_refit} + keeps it." + ), + error_class = "propensity_sigma_error", + call = call + ) + } + + if (density_supplied && !is.null(args$.density)) { + density <- as_density_spec(args$.density, arg = ".density", call = call) + if (!density_specs_agree(density, meta$density)) { + recorded <- density_record_label(meta$density) + supplied <- density_record_label(density) + abort( + c( + "{.arg .density} must be the density the dose model was trimmed + under.", + x = "The trimming record holds {recorded}, and {.arg .density} is + {supplied}.", + i = "The units were kept by how plausible their dose is under the + recorded density, so the weights are read under it too. Drop + {.arg .density}, or trim the dose model again under the density + you want." + ), + error_class = "propensity_density_error", + call = call + ) + } + } + + args$.sigma <- meta$sigma + args$.density <- meta$density + args$sigma_source <- meta$sigma_kind + + rlang::inject(weight_fn( + as.numeric(.propensity), + .exposure = .exposure, + call = call, + user_env = user_env, + !!!args + )) +} + +# A density as a refusal names it: the constructor call that builds it, with the +# estimator of its scale when the specification names one, since two +# specifications of one family can differ in that alone. +density_record_label <- function(density) { + constructor <- switch( + density$family, + normal = "dens_normal", + t = "dens_t", + laplace = "dens_laplace", + kernel = "dens_kernel", + "function" = "dens_fn", + density$family + ) + arguments <- if (identical(density$family, "function")) { + "" + } else if (length(density$params) > 0) { + paste0( + names(density$params), + " = ", + vapply(density$params, format_density_param, character(1)) + ) + } + if (!is.null(density$sigma_method)) { + arguments <- c( + arguments, + paste0( + "sigma_method = ", + encodeString(density$sigma_method, quote = "\"") + ) + ) + } + label <- paste0(constructor, "(", paste(arguments, collapse = ", "), ")") + cli::format_inline("{.code {label}}") +} + # Whether a modified score and the exposure it is weighted against describe the # same route. A continuous exposure has no propensity score, so a trimmed, # truncated, or calibrated vector weighted against one was a conditional mean @@ -1841,6 +1958,7 @@ handle_data_frame_weight_calculation <- function( .untreated = NULL, fn_name, ..., + density_supplied = TRUE, call = rlang::caller_env(), user_env = rlang::caller_env(2) ) { @@ -1938,6 +2056,7 @@ handle_data_frame_weight_calculation <- function( .focal_level = focal_params$.focal_level, .reference_level = focal_params$.reference_level, ..., + density_supplied = density_supplied, call = call )) } diff --git a/R/weights.R b/R/weights.R index e92f716f..93c22982 100644 --- a/R/weights.R +++ b/R/weights.R @@ -510,6 +510,12 @@ #' nothing more, and [ipw()] refuses such weights; see **Continuous #' exposures** in Details. #' +#' A dose model trimmed with [ps_trim()] holds the spread its trim was read +#' at, and weights built from it are read at that spread, which +#' `density_meta()` records as `sigma_value` as well. A `.sigma` supplied +#' with such a trim would be a second spread for the same density and is +#' refused with an error of class `propensity_sigma_error`. +#' #' Must be numeric, and applies only to continuous exposures. `.sigma` sits in #' the third position, which is where a value meant for `exposure_type` #' arrives when it is supplied without a name, so anything else is refused @@ -537,6 +543,11 @@ #' `.density` sits after `...` and so can only be supplied by name. The family #' the weights were built from is recorded on the result and read back with #' [density_meta()]. +#' +#' Weights built from a dose model trimmed with [ps_trim()] are read under the +#' family the trim recorded, whatever the default says. A `.density` that +#' names another family, other parameters, or another `sigma_method` is +#' refused with an error of class `propensity_density_error`. #' @param numerator How the marginal density that stabilizes a continuous #' exposure's weights is obtained, described under **Stabilization** in #' Details. Either `"marginal"`, the default, which reads the family @@ -919,7 +930,8 @@ wt_ate.numeric <- function( .treated = NULL, .untreated = NULL, call = rlang::current_env(), - user_env = rlang::caller_env() + user_env = rlang::caller_env(), + sigma_source = NULL ) { check_call_arg(call) rlang::check_dots_empty(call = call) @@ -960,7 +972,16 @@ wt_ate.numeric <- function( # in the same place and for the same reason. .density <- as_density_spec(.density, arg = ".density", call = call) check_density_arg(.density, exposure_type, call = call) - check_sigma_method(.sigma, .density, call = call) + + # `sigma_source` says the spread in `.sigma` is one a trimming record holds + # rather than one the caller wrote, and names how the record came by it. The + # two checks below exist to keep a caller's spread from replacing the one the + # family estimates, so a recorded spread, which is the family's own or one the + # caller fixed when trimming, is not held to them. + sigma_from_record <- !is.null(sigma_source) + if (!sigma_from_record) { + check_sigma_method(.sigma, .density, call = call) + } numerator <- rlang::arg_match(numerator, error_call = call) check_numerator( @@ -968,7 +989,7 @@ wt_ate.numeric <- function( exposure_type, stabilize = stabilize, stabilization_score = stabilization_score, - .sigma = .sigma, + .sigma = if (!sigma_from_record) .sigma, numerator_model = numerator_model, call = call ) @@ -1042,6 +1063,7 @@ wt_ate.numeric <- function( numerator_model = numerator_model, stabilize = stabilize, stabilization_score = stabilization_score, + sigma_source = sigma_source, call = call ) } else { @@ -1109,6 +1131,7 @@ wt_ate.data.frame <- function( stabilize = stabilize, stabilization_score = stabilization_score, .density = .density, + density_supplied = !missing(.density), numerator = numerator, .treated = .treated, .untreated = .untreated, @@ -1332,6 +1355,7 @@ ate_continuous <- function( numerator_model = NULL, stabilize = FALSE, stabilization_score = NULL, + sigma_source = NULL, call = rlang::caller_env() ) { # Every quantity below is computed from the exposure and the fitted means @@ -1442,7 +1466,12 @@ ate_continuous <- function( attr(wt, "density_meta") <- new_density_meta( density = .density, numerator = numerator, - sigma = density_sigma_source(.sigma, .density), + # A spread read from a trimming record keeps the source the record gave it. + sigma = if (is.null(sigma_source)) { + density_sigma_source(.sigma, .density) + } else { + sigma_source + }, # A spread of one number describes the conditional density of every unit, so # it is a constant the ratio can be rebuilt from and the record keeps it. One # number per observation describes each unit's density separately, and there @@ -2714,7 +2743,8 @@ wt_cens.numeric <- function( .treated = NULL, .untreated = NULL, call = rlang::current_env(), - user_env = rlang::caller_env() + user_env = rlang::caller_env(), + sigma_source = NULL ) { check_call_arg(call) @@ -2761,6 +2791,7 @@ wt_cens.numeric <- function( .density = .density, numerator = numerator, call = call, + sigma_source = sigma_source, ... ) @@ -2804,6 +2835,7 @@ wt_cens.data.frame <- function( stabilize = stabilize, stabilization_score = stabilization_score, .density = .density, + density_supplied = !missing(.density), numerator = numerator, ... ) @@ -2935,6 +2967,7 @@ wt_ate.ps_trim <- function( .exposure = .exposure, weight_fn = wt_ate.numeric, modification_type = "trim", + density_supplied = !missing(.density), .sigma = .sigma, exposure_type = exposure_type, .focal_level = .focal_level, @@ -3255,6 +3288,7 @@ wt_cens.ps_trim <- function( .exposure = .exposure, weight_fn = wt_cens.numeric, modification_type = "trim", + density_supplied = !missing(.density), .sigma = .sigma, exposure_type = exposure_type, .focal_level = .focal_level, diff --git a/man/exposure_type.Rd b/man/exposure_type.Rd index 9517410b..0b67a07e 100644 --- a/man/exposure_type.Rd +++ b/man/exposure_type.Rd @@ -74,13 +74,17 @@ combined the way any other disagreeing records are. \code{"pooled"} for the pooled residual root mean square, \code{"mle"} for a scale estimated under the family that reads it, which \code{\link[=dens_t]{dens_t()}} and \code{\link[=dens_laplace]{dens_laplace()}} take with \code{sigma_method = "mle"}, and \code{"supplied"} for a -\code{.sigma} the caller gave. -\item \code{sigma_value}, the single spread the caller supplied, and \code{NULL} for a -spread estimated from the residuals, by either estimator, and for one -supplied per observation. A spread that is one -number is a constant the weights can be rebuilt from, which is what -\code{\link[=ipw]{ipw()}} needs of it; a spread that changes with the observation is not, -so the record holds where it came from and nothing more. +\code{.sigma} the caller gave. Weights built from a dose model trimmed with +\code{\link[=ps_trim]{ps_trim()}} record where the trim's spread came from. +\item \code{sigma_value}, the single spread the weights were read at when it was not +estimated by the weight function itself: one the caller supplied, or the +spread a dose model trimmed with \code{\link[=ps_trim]{ps_trim()}} holds in its record, which is +recorded whatever its source. It is \code{NULL} for a spread estimated from the +residuals, by either estimator, and for one supplied per observation. A +spread that is one number is a constant the weights can be rebuilt from, +which is what \code{\link[=ipw]{ipw()}} needs of it; a spread that changes with the +observation is not, so the record holds where it came from and nothing +more. } Weights that carry a density record print it under their values, as the diff --git a/man/ps_refit.Rd b/man/ps_refit.Rd index 41c20a29..35af6cc2 100644 --- a/man/ps_refit.Rd +++ b/man/ps_refit.Rd @@ -18,7 +18,11 @@ The model is refit via \link[stats:update]{update()} on the retained subset. Trimmed propensity scores are refit only by a model of the probability of the exposure; a model of a conditional mean, such as a \code{\link[stats:lm]{stats::lm()}} fit or a gaussian \code{\link[stats:glm]{stats::glm()}}, never produced them and raises an error of -class \code{propensity_model_family_error}.} +class \code{propensity_model_family_error}. A dose model trimmed with +\code{method = "density"} or \code{method = "resid"} is refit only by a model of +the dose's conditional mean, such as a gaussian \code{\link[stats:glm]{stats::glm()}}, +\code{\link[stats:lm]{stats::lm()}}, \code{\link[mgcv:gam]{mgcv::gam()}}, or \code{\link[MASS:rlm]{MASS::rlm()}} fit, and any other model, +such as one of a probability, raises the same error.} \item{.data}{A data frame with one row per observation in \code{trimmed_ps}, in the same order. If \code{NULL} (the default), the data are recovered from @@ -41,6 +45,14 @@ confirm refitting was applied. Refitting replaces the values a calibrated score held with predictions from the refit model, so a score trimmed after \code{\link[=ps_calibrate]{ps_calibrate()}} is no longer calibrated and \code{\link[=is_ps_calibrated]{is_ps_calibrated()}} answers \code{FALSE} for the result. + +For a trimmed dose model, the retained values are the refit model's +conditional means, and the spread in the record is re-estimated from the +retained residuals under the recorded density family, unless the trim was +made at a \code{.sigma} the caller supplied, which is kept. The recorded +threshold describes the cut that was made and is left as it was, so the +refit model can place a retained unit's conditional density below it; +nothing is trimmed again. } \description{ Re-estimates a propensity score model using only the observations retained diff --git a/man/wt_ate.Rd b/man/wt_ate.Rd index 20669486..01dfea6c 100644 --- a/man/wt_ate.Rd +++ b/man/wt_ate.Rd @@ -287,6 +287,12 @@ data that nothing rebuilds, so the record holds where it came from and nothing more, and \code{\link[=ipw]{ipw()}} refuses such weights; see \strong{Continuous exposures} in Details. +A dose model trimmed with \code{\link[=ps_trim]{ps_trim()}} holds the spread its trim was read +at, and weights built from it are read at that spread, which +\code{density_meta()} records as \code{sigma_value} as well. A \code{.sigma} supplied +with such a trim would be a second spread for the same density and is +refused with an error of class \code{propensity_sigma_error}. + Must be numeric, and applies only to continuous exposures. \code{.sigma} sits in the third position, which is where a value meant for \code{exposure_type} arrives when it is supplied without a name, so anything else is refused @@ -415,7 +421,12 @@ ignored outside a continuous one. \code{.density} sits after \code{...} and so can only be supplied by name. The family the weights were built from is recorded on the result and read back with -\code{\link[=density_meta]{density_meta()}}.} +\code{\link[=density_meta]{density_meta()}}. + +Weights built from a dose model trimmed with \code{\link[=ps_trim]{ps_trim()}} are read under the +family the trim recorded, whatever the default says. A \code{.density} that +names another family, other parameters, or another \code{sigma_method} is +refused with an error of class \code{propensity_density_error}.} \item{numerator}{How the marginal density that stabilizes a continuous exposure's weights is obtained, described under \strong{Stabilization} in diff --git a/tests/testthat/_snaps/ps_refit-density.md b/tests/testthat/_snaps/ps_refit-density.md index 1908be6b..c2fd0708 100644 --- a/tests/testthat/_snaps/ps_refit-density.md +++ b/tests/testthat/_snaps/ps_refit-density.md @@ -5,8 +5,8 @@ Condition Error in `ps_refit()`: ! A trimmed dose model can only be refit with a model of the exposure's conditional mean. - x The trimming record holds a dose model's conditional means, and `model` fits a probability for each of its levels. - i Refit with the model of the continuous exposure the trimming was made from. + x The trimming record holds a dose model's conditional means, and `model` is , a model of the probabilities of a discrete exposure's levels. + i Refit with the model of the continuous exposure the trimming was made from, such as one fit with `gaussian()`, `lm()`, `mgcv::gam()`, or `MASS::rlm()`. --- @@ -15,8 +15,18 @@ Condition Error in `ps_refit()`: ! A trimmed dose model can only be refit with a model of the exposure's conditional mean. - x The trimming record holds a dose model's conditional means, and `model` fits a probability for each of its levels. - i Refit with the model of the continuous exposure the trimming was made from. + x The trimming record holds a dose model's conditional means, and `model` is , a model of the probabilities of a discrete exposure's levels. + i Refit with the model of the continuous exposure the trimming was made from, such as one fit with `gaussian()`, `lm()`, `mgcv::gam()`, or `MASS::rlm()`. + +# ps_refit() refuses a model of a probability for a density trim and names every dose model + + Code + expr + Condition + Error in `ps_refit()`: + ! A trimmed dose model can only be refit with a model of the exposure's conditional mean. + x `model` was fit with `binomial()`, whose spread changes with its fitted values. + i The trimming record holds a dose model's conditional means, so refit with the model of the continuous exposure the trimming was made from, such as one fit with `gaussian()`, `lm()`, `mgcv::gam()`, or `MASS::rlm()`. # an unrefit density trim warns that it was not refit @@ -27,6 +37,26 @@ It appears you trimmed your propensity score but did not refit the model. i Use `ps_refit()` for more accurate re-estimation. +# weights from a density trim refuse a density the record does not hold + + Code + expr + Condition + Error in `wt_ate()`: + ! `.density` must be the density the dose model was trimmed under. + x The trimming record holds `dens_normal()`, and `.density` is `dens_laplace(sigma_method = "mle")`. + i The units were kept by how plausible their dose is under the recorded density, so the weights are read under it too. Drop `.density`, or trim the dose model again under the density you want. + +# weights from a density trim refuse a spread of the caller's + + Code + expr + Condition + Error in `wt_ate()`: + ! `.sigma` cannot be used with a density-trimmed dose model. + x The trimming record holds the spread the conditional density was read at, and `.sigma` would be a second spread for the same density. + i Drop `.sigma`. To read the density at a spread of your own, pass it to `ps_trim()` when trimming, and `ps_refit()` keeps it. + # weights from a density trim are refused for an exposure that is not a dose Code diff --git a/tests/testthat/test-ps_refit-density.R b/tests/testthat/test-ps_refit-density.R index f4b8ec14..f45db6d1 100644 --- a/tests/testthat/test-ps_refit-density.R +++ b/tests/testthat/test-ps_refit-density.R @@ -287,6 +287,43 @@ test_that("ps_refit() keeps a spread the caller supplied", { ) }) +test_that("ps_refit() reads a density trim's spread over the rows the refit analyzed", { + dat <- sim_dose_trim() + n <- nrow(dat) + fit <- lm(a ~ x1 + x2, data = dat) + trimmed <- ps_trim(fit, method = "density", lower = 0.05) + keep <- ps_trim_meta(trimmed)$keep_idx + expect_gt(length(ps_trim_meta(trimmed)$trimmed_idx), 0) + + # A `subset` passed through narrows the rows the refit analyzes below the + # rows the trim kept, and the spread describes the analyzed rows alone. It + # indexes the kept rows, which are the data the refit is handed. + positive <- dat$x1[keep] > 0 + expect_no_warning(refit <- ps_refit(trimmed, fit, subset = positive)) + by_hand <- lm(a ~ x1 + x2, data = dat[keep, ], subset = positive) + expect_lt(length(fitted(by_hand)), length(keep)) + expect_equal( + ps_trim_meta(refit)$sigma, + sqrt(mean(residuals(by_hand)^2)), + tolerance = 1e-10 + ) + + # A covariate the refit formula adds, missing on some kept rows, leaves those + # rows out of the refit, and so out of the spread. + withr::local_seed(53) + dat$x3 <- rnorm(n) + dat$x3[keep[c(2, 5, 9)]] <- NA_real_ + expect_no_warning( + refit_x3 <- ps_refit(trimmed, fit, .data = dat, formula. = ~ . + x3) + ) + by_hand_x3 <- lm(a ~ x1 + x2 + x3, data = dat[keep, ]) + expect_equal( + ps_trim_meta(refit_x3)$sigma, + sqrt(mean(residuals(by_hand_x3)^2)), + tolerance = 1e-10 + ) +}) + # ---- ps_refit(): refusals ---------------------------------------------------- test_that("ps_refit() refuses a model of level probabilities for a density trim", { diff --git a/tests/testthat/test-weights-continuous.R b/tests/testthat/test-weights-continuous.R index 6dca63aa..590267d1 100644 --- a/tests/testthat/test-weights-continuous.R +++ b/tests/testthat/test-weights-continuous.R @@ -1233,11 +1233,14 @@ test_that("a missing fitted value leaves a weight the density was not asked abou z <- (exposure[present] - mu[present]) / sigma f_den <- continuous_density_kde(z) / sigma - # The exposure is whole, so the marginal density is still fit on all of it. - f_num <- continuous_density_kde(continuous_density_z_a()) / - continuous_density_sd_a() + # The marginal density is read over the units with a fitted mean, which are + # the only ones weighted: its moments and the kernel fit on it both skip the + # units whose mean is missing, although their exposure is present. + mu_a <- mean(exposure[present]) + sd_a <- sqrt(mean((exposure[present] - mu_a)^2)) + f_num <- continuous_density_kde((exposure[present] - mu_a) / sd_a) / sd_a - expect_equal(weights[present], f_num[present] / f_den, tolerance = 1e-12) + expect_equal(weights[present], f_num / f_den, tolerance = 1e-12) }) test_that("a missing exposure is left out of the numerator as well", { @@ -1309,9 +1312,9 @@ test_that("missing conditional means leave those weights missing in every family expect_identical(which(is.na(weights)), missing_at) f_den <- family$g(z) / sigma - f_num <- family$g(z_a) / sd_a + f_num <- family$g(z_a[present]) / sd_a - expect_equal(weights[present], f_num[present] / f_den, tolerance = 1e-12) + expect_equal(weights[present], f_num / f_den, tolerance = 1e-12) } }) From 007e6741048cc77da707f3dd134c798a292c112e Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 21:08:41 -0400 Subject: [PATCH 09/64] add failing tests for the psw truncation record --- tests/testthat/test-psw-wt-trunc.R | 531 +++++++++++++++++++++++++++++ 1 file changed, 531 insertions(+) create mode 100644 tests/testthat/test-psw-wt-trunc.R diff --git a/tests/testthat/test-psw-wt-trunc.R b/tests/testthat/test-psw-wt-trunc.R new file mode 100644 index 00000000..2022b944 --- /dev/null +++ b/tests/testthat/test-psw-wt-trunc.R @@ -0,0 +1,531 @@ +# The record a weight truncation leaves on a psw ------------------------------ + +# Truncating the weights themselves is recorded apart from truncating the +# propensity scores they were built from. The `wt_truncated` flag says the +# weights were bounded, and the `psw_trunc_meta` record says at what bound and +# which units it moved. The record is positional, so it follows the rules the +# trimming record follows: kept through any operation that preserves the +# length, dropped without comment on a length change, and left off the prototype +# a combine builds. The flag describes the vector as a whole and survives all +# of those. + +# Units 2 and 5 sit at the bound, so the positional query has something to +# report and a result that lost the record reports something visibly different. +wt_trunc_record <- function( + method = "wt", + upper_value = 3, + truncated_idx = c(2L, 5L), + n_obs = 5L +) { + new_psw_trunc_meta( + method = method, + lower = NULL, + upper = upper_value, + lower_value = NULL, + upper_value = upper_value, + truncated_idx = truncated_idx, + n_obs = n_obs + ) +} + +wt_truncated_psw <- function( + x = c(1.2, 3, 1.5, 2.1, 3), + record = wt_trunc_record() +) { + w <- psw(x, estimand = "ate", wt_truncated = TRUE) + attr(w, "psw_trunc_meta") <- record + w +} + +# The same five observations bounded lower, so the two records disagree on the +# bound as well as on the units it moved. +alt_wt_truncated_psw <- function() { + wt_truncated_psw( + x = c(1.2, 2.5, 1.5, 2.1, 2.5), + record = wt_trunc_record(upper_value = 2.5, truncated_idx = c(2L, 4L, 5L)) + ) +} + +wt_truncated_units <- c(FALSE, TRUE, FALSE, FALSE, TRUE) + +test_that("the truncation record holds the bound and the units it moved", { + meta <- new_psw_trunc_meta( + method = "pctl", + lower = 0.01, + upper = 0.99, + lower_value = 0.2, + upper_value = 7.5, + truncated_idx = c(1L, 4L), + n_obs = 10L + ) + + expect_s3_class(meta, "propensity_psw_trunc_meta") + expect_named( + meta, + c( + "method", + "lower", + "upper", + "lower_value", + "upper_value", + "truncated_idx", + "n_obs" + ) + ) + expect_identical(meta$method, "pctl") + expect_identical(meta$lower, 0.01) + expect_identical(meta$upper, 0.99) + expect_identical(meta$lower_value, 0.2) + expect_identical(meta$upper_value, 7.5) + expect_identical(meta$truncated_idx, c(1L, 4L)) + expect_identical(meta$n_obs, 10L) +}) + +test_that("psw() records whether the weights were truncated", { + expect_true(is_wt_truncated(psw(c(1, 2), wt_truncated = TRUE))) + expect_false(is_wt_truncated(psw(c(1, 2)))) + expect_false(is_wt_truncated(new_psw(c(1, 2)))) + expect_true(is_wt_truncated(new_psw(c(1, 2), wt_truncated = TRUE))) +}) + +test_that("weight truncation is recorded apart from score truncation", { + # A score truncation and a weight truncation are different operations, so a + # psw can carry either one or both without one answering for the other. + weights_only <- psw(c(1, 2), wt_truncated = TRUE) + expect_true(is_wt_truncated(weights_only)) + expect_false(is_ps_truncated(weights_only)) + + scores_only <- psw(c(1, 2), truncated = TRUE) + expect_true(is_ps_truncated(scores_only)) + expect_false(is_wt_truncated(scores_only)) + + both <- psw(c(1, 2), truncated = TRUE, wt_truncated = TRUE) + expect_true(is_ps_truncated(both)) + expect_true(is_wt_truncated(both)) +}) + +test_that("is_unit_wt_truncated() reads the units the record names", { + w <- wt_truncated_psw() + + expect_true(is_wt_truncated(w)) + expect_identical(attr(w, "psw_trunc_meta"), wt_trunc_record()) + expect_identical(expect_silent(is_unit_wt_truncated(w)), wt_truncated_units) + + # The score-scale query knows nothing of a weight truncation. + expect_identical(is_unit_truncated(w), rep(FALSE, 5)) +}) + +test_that("is_unit_wt_truncated() answers once per unit of untruncated weights", { + expect_identical( + expect_silent(is_unit_wt_truncated(psw(c(1, 2, 3)))), + c(FALSE, FALSE, FALSE) + ) + + # No observations, no answers. + expect_identical(is_unit_wt_truncated(psw(double())), logical(0)) + expect_identical( + is_unit_wt_truncated(wt_truncated_psw()[0]), + logical(0) + ) +}) + +test_that("length-preserving psw arithmetic keeps the weight truncation record", { + w <- wt_truncated_psw() + meta <- attr(w, "psw_trunc_meta") + + results <- list( + `w * 1` = expect_silent(w * 1), + `w / sum(w)` = expect_silent(w / sum(w)), + `-w` = expect_silent(-w), + `2 * w` = expect_silent(2 * w), + `w * 1L` = expect_silent(w * 1L) + ) + + for (label in names(results)) { + out <- results[[label]] + expect_s3_class(out, "psw") + expect_identical(attr(out, "psw_trunc_meta"), meta, info = label) + expect_true(is_wt_truncated(out), info = label) + expect_identical( + is_unit_wt_truncated(out), + wt_truncated_units, + info = label + ) + } +}) + +test_that("a full-length psw subset keeps the weight truncation record", { + w <- wt_truncated_psw() + meta <- attr(w, "psw_trunc_meta") + + whole <- expect_silent(w[seq_along(w)]) + expect_identical(attr(whole, "psw_trunc_meta"), meta) + expect_identical(is_unit_wt_truncated(whole), wt_truncated_units) + + sliced <- expect_silent(vec_slice(w, seq_along(w))) + expect_identical(attr(sliced, "psw_trunc_meta"), meta) + expect_true(is_wt_truncated(sliced)) +}) + +test_that("shortening a psw drops the weight truncation record and keeps the flag", { + w <- wt_truncated_psw() + + sub <- expect_silent(w[1:2]) + expect_s3_class(sub, "psw") + expect_length(sub, 2) + expect_null(attr(sub, "psw_trunc_meta")) + expect_true(is_wt_truncated(sub)) + expect_identical(estimand(sub), "ate") + + sliced <- expect_silent(vec_slice(w, 1:2)) + expect_null(attr(sliced, "psw_trunc_meta")) + expect_true(is_wt_truncated(sliced)) + + # The record is gone, so the positional query has nothing to answer from and + # refuses rather than reporting every unit as untouched. + expect_error( + is_unit_wt_truncated(sub), + class = "propensity_missing_meta_error" + ) +}) + +test_that("is_unit_wt_truncated() refuses flagged weights with no record", { + w <- psw(c(1, 2, 3), estimand = "ate", wt_truncated = TRUE) + + cnd <- expect_error( + is_unit_wt_truncated(w), + class = "propensity_missing_meta_error" + ) + expect_s3_class(cnd, "propensity_error") + expect_propensity_error(is_unit_wt_truncated(w)) +}) + +test_that("growing a weight-truncated psw leaves a record that no longer covers it", { + # `[<-` casts the replacement and then leaves base R to preserve the target's + # attributes, so the record crosses a length change no restore ever sees. It + # describes five observations and the weights now hold seven. + w <- wt_truncated_psw() + expect_silent({ + w[7] <- 2 + }) + + expect_length(w, 7) + expect_identical(attr(w, "psw_trunc_meta"), wt_trunc_record()) + expect_true(is_wt_truncated(w)) + expect_error( + is_unit_wt_truncated(w), + class = "propensity_missing_meta_error" + ) + expect_propensity_error(is_unit_wt_truncated(w)) +}) + +test_that("weights read out of an outcome model's frame refuse the weight query", { + # `model.frame()` drops the `NA`-weighted rows in C and re-attaches the + # original attributes to the shortened column, so the weights arrive carrying + # a record written for rows that are gone. + w <- wt_truncated_psw(x = c(1.2, 3, NA, 2.1, 3)) + dat <- data.frame(y = c(1, 2, 3, 4, 5), x = c(1, 3, 2, 5, 4)) + + fit <- lm(y ~ x, data = dat, weights = w) + model_wts <- model.frame(fit)[["(weights)"]] + + expect_s3_class(model_wts, "psw") + expect_length(model_wts, 4) + expect_identical(attr(model_wts, "psw_trunc_meta"), wt_trunc_record()) + expect_true(is_wt_truncated(model_wts)) + expect_error( + is_unit_wt_truncated(model_wts), + class = "propensity_missing_meta_error" + ) +}) + +test_that("a psw product carries a weight truncation record only one operand has", { + w <- wt_truncated_psw() + meta <- attr(w, "psw_trunc_meta") + cens <- wt_cens( + c(0.8, 0.7, 0.9, 0.6, 0.75), + c(1, 1, 0, 1, 1), + exposure_type = "binary" + ) + + out <- expect_silent(w * cens) + expect_s3_class(out, "psw") + expect_identical(attr(out, "psw_trunc_meta"), meta) + expect_true(is_wt_truncated(out)) + expect_identical(is_unit_wt_truncated(out), wt_truncated_units) + + # The record and the flag travel from whichever operand holds them. + reversed <- expect_silent(cens * w) + expect_identical(attr(reversed, "psw_trunc_meta"), meta) + expect_true(is_wt_truncated(reversed)) + expect_identical(is_unit_wt_truncated(reversed), wt_truncated_units) + + ones <- expect_silent(w * psw(rep(1, 5), estimand = "ate")) + expect_identical(attr(ones, "psw_trunc_meta"), meta) + expect_true(is_wt_truncated(ones)) +}) + +test_that("a psw product carries a weight truncation record both operands share", { + w <- wt_truncated_psw() + + out <- expect_silent(w * wt_truncated_psw()) + expect_identical(attr(out, "psw_trunc_meta"), wt_trunc_record()) + expect_true(is_wt_truncated(out)) + expect_identical(is_unit_wt_truncated(out), wt_truncated_units) +}) + +test_that("a psw product drops conflicting weight truncation records with one warning", { + w <- wt_truncated_psw() + alt <- alt_wt_truncated_psw() + + classes <- character() + out <- withCallingHandlers( + w * alt, + warning = function(cnd) { + classes <<- c(classes, class(cnd)[[1]]) + invokeRestart("muffleWarning") + } + ) + expect_identical(classes, "propensity_metadata_conflict_warning") + + expect_s3_class(out, "psw") + expect_null(attr(out, "psw_trunc_meta")) + expect_true(is_wt_truncated(out)) + expect_error( + is_unit_wt_truncated(out), + class = "propensity_missing_meta_error" + ) + + cnd <- expect_warning( + w * alt, + class = "propensity_metadata_conflict_warning" + ) + expect_true(grepl("psw_trunc_meta", conditionMessage(cnd), fixed = TRUE)) +}) + +test_that("combining a weight-truncated and an untruncated psw downgrades to numeric", { + w <- wt_truncated_psw() + untruncated <- psw(c(1, 2), estimand = "ate") + + cnd <- expect_warning( + out <- c(w, untruncated), + class = "propensity_coercion_warning" + ) + expect_true(grepl( + "different weight truncation status", + conditionMessage(cnd), + fixed = TRUE + )) + expect_false(is_psw(out)) + expect_type(out, "double") + expect_equal(out, c(1.2, 3, 1.5, 2.1, 3, 1, 2)) + + expect_warning( + reversed <- c(untruncated, w), + class = "propensity_coercion_warning" + ) + expect_false(is_psw(reversed)) +}) + +test_that("weights that differ in weight truncation status do not cast to each other", { + w <- wt_truncated_psw() + untruncated <- psw(c(1, 2), estimand = "ate") + + cnd <- expect_error( + vec_cast(untruncated, w), + class = "vctrs_error_incompatible_type" + ) + expect_true(grepl( + "different weight truncation status", + conditionMessage(cnd), + fixed = TRUE + )) + expect_error( + vec_cast(w, untruncated), + class = "vctrs_error_incompatible_type" + ) +}) + +test_that("combining weight-truncated psw objects keeps the flag and drops the record", { + w <- wt_truncated_psw() + + out <- expect_silent(c(w, w)) + expect_s3_class(out, "psw") + expect_length(out, 10) + expect_true(is_wt_truncated(out)) + expect_null(attr(out, "psw_trunc_meta")) + + # The record's positions describe one input, so the combined weights have no + # positional answer to give. + expect_error( + is_unit_wt_truncated(out), + class = "propensity_missing_meta_error" + ) + + proto <- expect_silent(vec_ptype2(w, w)) + expect_s3_class(proto, "psw") + expect_true(is_wt_truncated(proto)) + expect_null(attr(proto, "psw_trunc_meta")) +}) + +test_that("subassigning into weight-truncated weights keeps the record", { + # Subassignment casts the replacement to the target's own type, which has + # already dropped nothing it compares, so it must not read as a disagreement. + w <- wt_truncated_psw() + expect_silent({ + w[1] <- w[3] + }) + + expect_s3_class(w, "psw") + expect_identical(attr(w, "psw_trunc_meta"), wt_trunc_record()) + expect_identical(is_unit_wt_truncated(w), wt_truncated_units) +}) + +# The reason a bound mismatch gives, which tells it apart from weights that +# differ in whether they were truncated at all. Returns the combined value. +expect_bound_mismatch <- function(expr) { + value <- NULL + cnd <- expect_warning( + value <- expr, + class = "propensity_coercion_warning" + ) + expect_true(grepl( + "different weight truncation bounds", + conditionMessage(cnd), + fixed = TRUE + )) + invisible(value) +} + +test_that("combining weights truncated at different bounds downgrades to numeric", { + w <- wt_truncated_psw() + alt <- alt_wt_truncated_psw() + + out <- expect_bound_mismatch(c(w, alt)) + expect_false(is_psw(out)) + expect_type(out, "double") + + reversed <- expect_bound_mismatch(c(alt, w)) + expect_false(is_psw(reversed)) + + proto <- expect_bound_mismatch(vec_ptype2(w, alt)) + expect_identical(proto, double()) +}) + +test_that("each bound parameter is compared when weight-truncated psw objects combine", { + w <- wt_truncated_psw() + + other_method <- wt_truncated_psw( + record = wt_trunc_record(method = "count") + ) + expect_bound_mismatch(c(w, other_method)) + + lower_bounded <- wt_truncated_psw( + record = new_psw_trunc_meta( + method = "wt", + lower = 0.5, + upper = 3, + lower_value = 0.5, + upper_value = 3, + truncated_idx = c(2L, 5L), + n_obs = 5L + ) + ) + expect_bound_mismatch(c(w, lower_bounded)) +}) + +test_that("a bound mismatch is caught whichever pair of the fold meets it", { + # vctrs folds the prototype over the inputs two at a time, and the prototype + # carries no positional record, so the bound the earlier inputs agreed on has + # to reach the pair that meets the disagreeing one. + w <- wt_truncated_psw() + alt <- alt_wt_truncated_psw() + + out <- expect_bound_mismatch(c(w, w, alt)) + expect_false(is_psw(out)) + + # A slice has no record, so its pair agrees and passes the bound on. + out <- expect_bound_mismatch(c(w[1:2], w, alt)) + expect_false(is_psw(out)) + + agreed <- expect_silent(c(w, w[1:2], w)) + expect_s3_class(agreed, "psw") + expect_true(is_wt_truncated(agreed)) +}) + +test_that("weights bounded differently still cast to each other", { + # The bounds are compared only where two inputs are combined. A cast is also + # how subassignment and a type's own prototype are checked, and comparing + # there would refuse weights their own dropped-record prototype. + w <- wt_truncated_psw() + alt <- alt_wt_truncated_psw() + + expect_silent(vec_cast(alt, w)) + expect_silent({ + w[seq_along(w)] <- alt + }) + expect_identical(attr(w, "psw_trunc_meta"), wt_trunc_record()) + expect_true(is_wt_truncated(w)) +}) + +test_that("weights bounded alike combine whichever units the bound moved", { + # The comparison is of the bound, not of the units it moved: two samples + # truncated at the same value have moved different units and still describe + # the same operation. + w <- wt_truncated_psw() + other_units <- wt_truncated_psw( + x = c(3, 1.1, 2.2, 3, 0.9, 1.4), + record = wt_trunc_record(truncated_idx = c(1L, 4L), n_obs = 6L) + ) + + out <- expect_silent(c(w, other_units)) + expect_s3_class(out, "psw") + expect_length(out, 11) + expect_true(is_wt_truncated(out)) + expect_null(attr(out, "psw_trunc_meta")) +}) + +test_that("a weight-truncated psw with no record agrees with any bound", { + # A record already dropped, by a slice or by an earlier combine, has nothing + # to disagree with, so only the flag is compared. + w <- wt_truncated_psw() + alt_slice <- alt_wt_truncated_psw()[1:2] + expect_null(attr(alt_slice, "psw_trunc_meta")) + expect_true(is_wt_truncated(alt_slice)) + + out <- expect_silent(c(w, alt_slice)) + expect_s3_class(out, "psw") + expect_length(out, 7) + expect_true(is_wt_truncated(out)) + + reversed <- expect_silent(c(alt_slice, w)) + expect_s3_class(reversed, "psw") + expect_true(is_wt_truncated(reversed)) + + bare <- psw(c(1, 2), estimand = "ate", wt_truncated = TRUE) + proto <- expect_silent(vec_ptype2(bare, w)) + expect_s3_class(proto, "psw") + expect_true(is_wt_truncated(proto)) + expect_null(attr(proto, "psw_trunc_meta")) +}) + +test_that("is_wt_truncated() answers FALSE for anything that is not a psw", { + expect_false(is_wt_truncated(c(1, 2))) + expect_false(is_wt_truncated(NULL)) + + scores <- ps_trunc( + c(0.05, 0.3, 0.5, 0.7, 0.95), + method = "ps", + lower = 0.1, + upper = 0.9 + ) + expect_false(is_wt_truncated(scores)) +}) + +test_that("is_unit_wt_truncated() refuses anything that is not a psw", { + expect_error( + is_unit_wt_truncated(c(1, 2)), + class = "propensity_method_error" + ) + expect_propensity_error(is_unit_wt_truncated(c(1, 2))) +}) From 4cfa3488e393a8eac8cc49aa262cc64bb410cd2c Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 21:31:41 -0400 Subject: [PATCH 10/64] add a truncation record to propensity score weights --- NAMESPACE | 6 + R/psw.R | 263 ++++++++++++++++++++++++-- _pkgdown.yml | 1 + man/is_wt_truncated.Rd | 60 ++++++ man/psw.Rd | 25 ++- tests/testthat/_snaps/psw-wt-trunc.md | 28 +++ tests/testthat/test-psw.R | 1 + 7 files changed, 363 insertions(+), 21 deletions(-) create mode 100644 man/is_wt_truncated.Rd create mode 100644 tests/testthat/_snaps/psw-wt-trunc.md diff --git a/NAMESPACE b/NAMESPACE index dba0485d..acea32ac 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -74,6 +74,10 @@ S3method(is_unit_truncated,default) S3method(is_unit_truncated,ps_trunc) S3method(is_unit_truncated,ps_trunc_matrix) S3method(is_unit_truncated,psw) +S3method(is_unit_wt_truncated,default) +S3method(is_unit_wt_truncated,psw) +S3method(is_wt_truncated,default) +S3method(is_wt_truncated,psw) S3method(max,ps_calib) S3method(max,ps_trim) S3method(max,ps_trunc) @@ -319,6 +323,8 @@ export(is_refit) export(is_stabilized) export(is_unit_trimmed) export(is_unit_truncated) +export(is_unit_wt_truncated) +export(is_wt_truncated) export(joint_wt_meta) export(joint_wt_models) export(new_psw) diff --git a/R/psw.R b/R/psw.R index 11737b87..f6c5c341 100644 --- a/R/psw.R +++ b/R/psw.R @@ -23,6 +23,9 @@ #' #' * `is_psw()` tests whether an object is a `psw` vector. #' * `is_stabilized()` returns `TRUE` if the weights are stabilized. +#' * [is_wt_truncated()] returns `TRUE` if the weights themselves were +#' truncated, which is recorded apart from whether the propensity scores they +#' were built from were. #' * `stabilization_score()` returns the user-supplied stabilization score, or #' `NULL` when none was recorded or when a per-observation score was dropped #' because an operation changed the length of the weights. @@ -71,8 +74,8 @@ #' An operation between two `psw` objects merges what each of them records. Two #' different estimands are pasted together, and an estimand only one operand #' names stands for the result; the result is stabilized only when both operands -#' are, and it is marked as trimmed, truncated, or calibrated when either -#' operand is. The remaining attributes, the `stabilization_score`, the records +#' are, and it is marked as trimmed, truncated, calibrated, or weight-truncated +#' when either operand is. The remaining attributes, the `stabilization_score`, the records #' left by a modified propensity score, the attributes describing a categorical #' exposure, and the exposure records, are carried by agreement: one only a #' single operand records carries, and one both record with the same value @@ -104,7 +107,10 @@ #' plain numeric vector. Concatenation appends one set of observations to #' another, so the positions a modification record names would describe units #' from the other input; those records are dropped from the result whether or -#' not the inputs agree on them. The categorical attributes name exposure levels +#' not the inputs agree on them. Weights whose own values were truncated are +#' combined only when the records they carry name the same bound, since weights +#' bounded differently describe different estimands; a record already dropped +#' agrees with any bound. The categorical attributes name exposure levels #' rather than positions, and the exposure records describe the exposure rather #' than any unit, so both carry when the inputs agree. #' @@ -112,7 +118,8 @@ #' Two kinds of attribute hold one value per observation and so cannot be #' re-indexed for a subset: a `stabilization_score` with more than one value, #' and the records left by a modified propensity score (`ps_trim_meta`, -#' `ps_trunc_meta`, and `ps_calib_meta`). Where an operation goes through +#' `ps_trunc_meta`, and `ps_calib_meta`) or by truncating the weights +#' themselves (`psw_trunc_meta`). Where an operation goes through #' vctrs, these are carried when the result comes back at the length they were #' recorded on and dropped when it does not. Any same-length operation keeps #' them, a reordering or a subscript with duplicates included, so the positions @@ -132,7 +139,7 @@ #' longer there. #' #' Honesty therefore lives at query time. [is_unit_trimmed()] and -#' [is_unit_truncated()] answer by position, so each checks that the record +#' [is_unit_truncated()] answer by position, as does [is_unit_wt_truncated()], so each checks that the record #' covers the vector it is given and raises an error of class #' `propensity_missing_meta_error` when it does not, or when weights marked as #' modified carry no record at all, rather than name modified units at stale @@ -167,6 +174,9 @@ #' scores? Defaults to `FALSE`. #' @param calibrated Logical. Were the weights derived from calibrated #' propensity scores? Defaults to `FALSE`. +#' @param wt_truncated Logical. Were the weights themselves truncated? This is +#' separate from `truncated`, which describes the propensity scores the +#' weights were built from. Defaults to `FALSE`. #' @param stabilization_score Optional numeric stabilization score to record on #' the object, either a single value or one value per observation. Every value #' must be positive and finite. Defaults to `NULL`, meaning no fixed score was @@ -227,6 +237,7 @@ new_psw <- function( truncated = FALSE, calibrated = FALSE, stabilization_score = NULL, + wt_truncated = FALSE, ... ) { vec_assert(x, ptype = double()) @@ -239,6 +250,7 @@ new_psw <- function( trimmed = trimmed, truncated = truncated, calibrated = calibrated, + wt_truncated = wt_truncated, stabilization_score = stabilization_score, ..., class = c("psw", "causal_wts"), @@ -256,7 +268,8 @@ psw <- function( trimmed = FALSE, truncated = FALSE, calibrated = FALSE, - stabilization_score = NULL + stabilization_score = NULL, + wt_truncated = FALSE ) { x <- vec_cast(x, to = double()) attributes(x) <- NULL @@ -272,7 +285,8 @@ psw <- function( trimmed = trimmed, truncated = truncated, calibrated = calibrated, - stabilization_score = stabilization_score + stabilization_score = stabilization_score, + wt_truncated = wt_truncated ) } @@ -805,6 +819,180 @@ is_refit.psw <- function(x) { isTRUE(ps_trim_meta(x)$refit) } +#' Test whether the weights themselves have been truncated +#' +#' @description +#' `is_wt_truncated()` returns `TRUE` for a [psw] vector whose own values were +#' bounded, and `is_unit_wt_truncated()` returns which of its weights the bound +#' moved. +#' +#' Truncating the weights is recorded apart from truncating the propensity +#' scores they were built from, which [is_ps_truncated()] and +#' [is_unit_truncated()] report. The two are different operations, and a set of +#' weights can carry either, both, or neither. +#' +#' @details +#' The truncation leaves a record on the weights, the `psw_trunc_meta` +#' attribute, holding the method, the bound as given and as applied, and the +#' positions of the weights it moved. `is_unit_wt_truncated()` answers from +#' those positions, so the record follows the rules [psw] describes for the +#' records a modified propensity score leaves: it is kept through arithmetic +#' and anything else that keeps the length of the weights, and dropped when a +#' subset or [c()] changes it. The `wt_truncated` flag describes the weights as +#' a whole and is kept through all of those, so `is_wt_truncated()` keeps its +#' answer where `is_unit_wt_truncated()` has none to give. +#' +#' `is_unit_wt_truncated()` therefore checks that the record covers the weights +#' it is given, and raises an error of class `propensity_missing_meta_error` +#' when it does not, or when weights marked as truncated carry no record at +#' all, rather than name truncated weights at stale positions. Weights that +#' were not truncated have no record to read, and every weight is reported as +#' untouched. +#' +#' @param x An object. `is_unit_wt_truncated()` accepts only a [psw] vector. +#' +#' @return +#' * `is_wt_truncated()`: a single `TRUE` or `FALSE`. It is `FALSE` for +#' anything that is not a [psw] vector. +#' * `is_unit_wt_truncated()`: a logical vector the same length as `x`, `TRUE` +#' for each weight the bound moved. +#' +#' @seealso [psw] for the weight vector class, and [is_ps_truncated()] for +#' truncation of the propensity scores. +#' +#' @examples +#' w <- psw(c(1.2, 0.8, 1.5), estimand = "ate") +#' is_wt_truncated(w) +#' is_unit_wt_truncated(w) +#' +#' @export +is_wt_truncated <- function(x) { + UseMethod("is_wt_truncated") +} + +#' @export +is_wt_truncated.default <- function(x) { + FALSE +} + +#' @export +is_wt_truncated.psw <- function(x) { + isTRUE(attr(x, "wt_truncated")) +} + +#' @rdname is_wt_truncated +#' @export +is_unit_wt_truncated <- function(x) { + UseMethod("is_unit_wt_truncated") +} + +#' @export +is_unit_wt_truncated.default <- function(x) { + abort( + "{.code is_unit_wt_truncated()} not supported for class {.val {class(x)}}", + error_class = "propensity_method_error" + ) +} + +#' @export +is_unit_wt_truncated.psw <- function(x) { + # No observations, no answers. A record kept on an empty vector describes + # observations it does not have, and indexing an empty logical by the + # positions it names would grow one padded with `NA`. + if (length(x) == 0) { + return(logical(0)) + } + + out <- vector("logical", length = length(x)) + if (!is_wt_truncated(x)) { + return(out) + } + + check_psw_trunc_meta_covers(x, "is_unit_wt_truncated()") + + meta <- attr(x, "psw_trunc_meta") + out[meta$truncated_idx] <- TRUE + + out +} + +# What truncating the weights leaves on them: the method, the bound as the +# caller gave it and as it was applied, and the positions of the weights it +# moved, counted against the number of observations those positions describe. +new_psw_trunc_meta <- function( + method, + lower, + upper, + lower_value, + upper_value, + truncated_idx, + n_obs +) { + structure( + list( + method = method, + lower = lower, + upper = upper, + lower_value = lower_value, + upper_value = upper_value, + truncated_idx = truncated_idx, + n_obs = n_obs + ), + class = "propensity_psw_trunc_meta" + ) +} + +# The part of a weight truncation record that says what operation was applied, +# as opposed to which units it happened to move. Two samples truncated the same +# way move different units and still describe the same estimand. +wt_trunc_parameters <- function(meta) { + meta[c("method", "lower", "upper", "lower_value", "upper_value")] +} + +# The bound a psw was truncated at, read from its record or, on a prototype in +# the middle of a combine, from the bound the inputs before it agreed on. `NULL` +# when neither is present, which agrees with any bound. +psw_trunc_bound <- function(x) { + meta <- attr(x, "psw_trunc_meta") + if (!is.null(meta)) { + return(wt_trunc_parameters(unclass(meta))) + } + + attr(x, psw_trunc_bound_attr) +} + +# The weight truncation record travels the routes the score-scale records +# travel and can outlive the observations it describes the same way, so the +# positional query refuses where they do. +check_psw_trunc_meta_covers <- function(x, fn, call = rlang::caller_env()) { + meta <- attr(x, "psw_trunc_meta") + n <- length(x) + + if (record_covers(meta, n)) { + return(invisible(x)) + } + + recorded <- meta$n_obs + problem <- if (is.null(recorded)) { + "These weights are marked as truncated but carry no record of which + weights were truncated." + } else { + "The record covers {recorded} observation{?s} and these weights have {n}, + so its positions do not describe them." + } + + abort( + c( + "{.code {fn}} has no usable weight truncation record for these weights.", + x = problem, + i = "Call {.code {fn}} on the weights the truncation returned, before + subsetting or combining them." + ), + error_class = "propensity_missing_meta_error", + call = call + ) +} + #' @export vec_ptype_abbr.psw <- function(x, ...) { estimand <- estimand(x) @@ -882,6 +1070,7 @@ vec_arith.psw.psw <- function(op, x, y, ...) { trimmed <- is_ps_trimmed(x) || is_ps_trimmed(y) truncated <- is_ps_truncated(x) || is_ps_truncated(y) calibrated <- is_ps_calibrated(x) || is_ps_calibrated(y) + wt_truncated <- is_wt_truncated(x) || is_wt_truncated(y) rslts <- vec_cast(vec_arith_base(op, x, y), to = double()) attributes(rslts) <- NULL @@ -931,6 +1120,7 @@ vec_arith.psw.psw <- function(op, x, y, ...) { trimmed = trimmed, truncated = truncated, calibrated = calibrated, + wt_truncated = wt_truncated, attrs = attrs ) } @@ -1102,10 +1292,16 @@ check_stabilization_score <- function(score, n, call = rlang::caller_env()) { as.double(score) } -# The records a modified propensity score leaves on the weights built from it. -# Each holds indices into the observations it was recorded on, so like a -# per-observation stabilization score, each is only meaningful at that length. -psw_modification_meta <- c("ps_trim_meta", "ps_trunc_meta", "ps_calib_meta") +# The records a modified propensity score leaves on the weights built from it, +# and the record truncating the weights themselves leaves. Each holds indices +# into the observations it was recorded on, so like a per-observation +# stabilization score, each is only meaningful at that length. +psw_modification_meta <- c( + "ps_trim_meta", + "ps_trunc_meta", + "ps_calib_meta", + "psw_trunc_meta" +) # Attributes describing a categorical exposure. These name the exposure levels # rather than the units, so they carry no length of their own. @@ -1222,6 +1418,13 @@ psw_carried_attrs <- c( # recorded here rather than guarded against. psw_conflicted_attr <- "psw_conflicted_attrs" +# The bound parameters a fold has found its inputs to agree on so far. A +# prototype carries no weight truncation record, since the record names +# positions, so without this the third input of a combine would be compared +# against a prototype with nothing to disagree with. It is copied and dropped +# exactly as `psw_conflicted_attr` is. +psw_trunc_bound_attr <- "psw_trunc_bound" + conflicted_psw_attrs <- function(x) { out <- attr(x, psw_conflicted_attr) if (is.null(out)) character() else out @@ -1253,8 +1456,12 @@ aligned_psw_attrs <- function(to, n) { # result that holds no observations is the one thing vctrs cannot tell apart # from the prototype it was built from, so it keeps the record; it names # nothing about observations there are none of. + # + # The bound a fold has agreed on is the same kind of record and is carried the + # same way, for the same reason. if (n == 0) { attrs[psw_conflicted_attr] <- list(attr(to, psw_conflicted_attr)) + attrs[psw_trunc_bound_attr] <- list(attr(to, psw_trunc_bound_attr)) } attrs @@ -1271,6 +1478,7 @@ build_psw <- function( trimmed, truncated, calibrated, + wt_truncated, attrs ) { out <- new_psw( @@ -1280,7 +1488,8 @@ build_psw <- function( trimmed = trimmed, truncated = truncated, calibrated = calibrated, - stabilization_score = attrs$stabilization_score + stabilization_score = attrs$stabilization_score, + wt_truncated = wt_truncated ) for (attribute in setdiff(names(attrs), "stabilization_score")) { @@ -1298,6 +1507,7 @@ carry_psw_metadata <- function(x, to) { trimmed = is_ps_trimmed(to), truncated = is_ps_truncated(to), calibrated = is_ps_calibrated(to), + wt_truncated = is_wt_truncated(to), attrs = aligned_psw_attrs(to, length(x)) ) } @@ -1555,7 +1765,10 @@ vec_restore.psw <- function(x, to, ...) { # What a psw is, as opposed to which observations it holds: the estimand the # weights answer, whether they were stabilized and against what score, and which -# modification of the propensity scores they were built from. `vec_ptype2()` and +# modification of the propensity scores they were built from, and whether the +# weights themselves were truncated. The bound a truncation applied is left out: +# a cast is also how a psw is checked against its own prototype, which carries +# no record, so the bound is compared only where two inputs combine. `vec_ptype2()` and # `vec_cast()` read the same set, so weights that combine without complaint are # also each other's type. psw_type_fields <- function(x) { @@ -1565,7 +1778,8 @@ psw_type_fields <- function(x) { stabilization_score = stabilization_score(x), trimmed = is_ps_trimmed(x), truncated = is_ps_truncated(x), - calibrated = is_ps_calibrated(x) + calibrated = is_ps_calibrated(x), + wt_truncated = is_wt_truncated(x) ) } @@ -1576,7 +1790,8 @@ psw_type_field_problems <- c( stabilization_score = "different stabilization scores", trimmed = "different trimming status", truncated = "different truncation status", - calibrated = "different calibration status" + calibrated = "different calibration status", + wt_truncated = "different weight truncation status" ) # The first field the two objects describe differently, named the way the @@ -1614,6 +1829,16 @@ vec_ptype2.psw.psw <- function(x, y, ...) { return(double()) } + # Weights truncated at different bounds target different estimands, so they + # have no common type. Only a combine sees both inputs' records, which is why + # the bound is compared here and not in `psw_type_disagreement()`. + x_bound <- psw_trunc_bound(x) + y_bound <- psw_trunc_bound(y) + if (!is.null(x_bound) && !is.null(y_bound) && !identical(x_bound, y_bound)) { + warn_incompatible_metadata(x, y, "different weight truncation bounds") + return(double()) + } + # The prototype is shared by inputs whose observations are appended one after # another, so the positions a modification record names would describe units # from the other input. Nothing rebuilding the combined vector is handed the @@ -1639,6 +1864,7 @@ vec_ptype2.psw.psw <- function(x, y, ...) { trimmed = is_ps_trimmed(x), truncated = is_ps_truncated(x), calibrated = is_ps_calibrated(x), + wt_truncated = is_wt_truncated(x), attrs = c( list(stabilization_score = stabilization_score(x)), merged$attrs @@ -1649,6 +1875,13 @@ vec_ptype2.psw.psw <- function(x, y, ...) { attr(out, psw_conflicted_attr) <- merged$conflicted } + # The prototype drops the record, so the bound the two inputs agreed on is + # handed on separately for the next pair of the fold to compare against. + if (is.null(x_bound)) { + x_bound <- y_bound + } + attr(out, psw_trunc_bound_attr) <- x_bound + out } diff --git a/_pkgdown.yml b/_pkgdown.yml index 4cee7819..550ddeca 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -26,6 +26,7 @@ reference: - psw - exposure_type - numerator_model + - is_wt_truncated - title: Joint treatments desc: Weights for a sequence of two treatments, from a factorized pair of treatment models. diff --git a/man/is_wt_truncated.Rd b/man/is_wt_truncated.Rd new file mode 100644 index 00000000..2f08c68b --- /dev/null +++ b/man/is_wt_truncated.Rd @@ -0,0 +1,60 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/psw.R +\name{is_wt_truncated} +\alias{is_wt_truncated} +\alias{is_unit_wt_truncated} +\title{Test whether the weights themselves have been truncated} +\usage{ +is_wt_truncated(x) + +is_unit_wt_truncated(x) +} +\arguments{ +\item{x}{An object. \code{is_unit_wt_truncated()} accepts only a \link{psw} vector.} +} +\value{ +\itemize{ +\item \code{is_wt_truncated()}: a single \code{TRUE} or \code{FALSE}. It is \code{FALSE} for +anything that is not a \link{psw} vector. +\item \code{is_unit_wt_truncated()}: a logical vector the same length as \code{x}, \code{TRUE} +for each weight the bound moved. +} +} +\description{ +\code{is_wt_truncated()} returns \code{TRUE} for a \link{psw} vector whose own values were +bounded, and \code{is_unit_wt_truncated()} returns which of its weights the bound +moved. + +Truncating the weights is recorded apart from truncating the propensity +scores they were built from, which \code{\link[=is_ps_truncated]{is_ps_truncated()}} and +\code{\link[=is_unit_truncated]{is_unit_truncated()}} report. The two are different operations, and a set of +weights can carry either, both, or neither. +} +\details{ +The truncation leaves a record on the weights, the \code{psw_trunc_meta} +attribute, holding the method, the bound as given and as applied, and the +positions of the weights it moved. \code{is_unit_wt_truncated()} answers from +those positions, so the record follows the rules \link{psw} describes for the +records a modified propensity score leaves: it is kept through arithmetic +and anything else that keeps the length of the weights, and dropped when a +subset or \code{\link[=c]{c()}} changes it. The \code{wt_truncated} flag describes the weights as +a whole and is kept through all of those, so \code{is_wt_truncated()} keeps its +answer where \code{is_unit_wt_truncated()} has none to give. + +\code{is_unit_wt_truncated()} therefore checks that the record covers the weights +it is given, and raises an error of class \code{propensity_missing_meta_error} +when it does not, or when weights marked as truncated carry no record at +all, rather than name truncated weights at stale positions. Weights that +were not truncated have no record to read, and every weight is reported as +untouched. +} +\examples{ +w <- psw(c(1.2, 0.8, 1.5), estimand = "ate") +is_wt_truncated(w) +is_unit_wt_truncated(w) + +} +\seealso{ +\link{psw} for the weight vector class, and \code{\link[=is_ps_truncated]{is_ps_truncated()}} for +truncation of the propensity scores. +} diff --git a/man/psw.Rd b/man/psw.Rd index afec0153..fe48f734 100644 --- a/man/psw.Rd +++ b/man/psw.Rd @@ -17,6 +17,7 @@ new_psw( truncated = FALSE, calibrated = FALSE, stabilization_score = NULL, + wt_truncated = FALSE, ... ) @@ -27,7 +28,8 @@ psw( trimmed = FALSE, truncated = FALSE, calibrated = FALSE, - stabilization_score = NULL + stabilization_score = NULL, + wt_truncated = FALSE ) is_psw(x) @@ -62,6 +64,10 @@ the object, either a single value or one value per observation. Every value must be positive and finite. Defaults to \code{NULL}, meaning no fixed score was supplied.} +\item{wt_truncated}{Logical. Were the weights themselves truncated? This is +separate from \code{truncated}, which describes the propensity scores the +weights were built from. Defaults to \code{FALSE}.} + \item{...}{Additional attributes stored on the object (developer use only).} \item{wt}{A \code{psw} or \code{causal_wts} object.} @@ -98,6 +104,9 @@ assumes \code{x} is already a double vector and performs minimal validation. \itemize{ \item \code{is_psw()} tests whether an object is a \code{psw} vector. \item \code{is_stabilized()} returns \code{TRUE} if the weights are stabilized. +\item \code{\link[=is_wt_truncated]{is_wt_truncated()}} returns \code{TRUE} if the weights themselves were +truncated, which is recorded apart from whether the propensity scores they +were built from were. \item \code{stabilization_score()} returns the user-supplied stabilization score, or \code{NULL} when none was recorded or when a per-observation score was dropped because an operation changed the length of the weights. @@ -150,8 +159,8 @@ so operations like normalization (\code{weights / sum(weights)}) retain metadata An operation between two \code{psw} objects merges what each of them records. Two different estimands are pasted together, and an estimand only one operand names stands for the result; the result is stabilized only when both operands -are, and it is marked as trimmed, truncated, or calibrated when either -operand is. The remaining attributes, the \code{stabilization_score}, the records +are, and it is marked as trimmed, truncated, calibrated, or weight-truncated +when either operand is. The remaining attributes, the \code{stabilization_score}, the records left by a modified propensity score, the attributes describing a categorical exposure, and the exposure records, are carried by agreement: one only a single operand records carries, and one both record with the same value @@ -183,7 +192,10 @@ metadata matches; mismatched metadata produces a warning and falls back to a plain numeric vector. Concatenation appends one set of observations to another, so the positions a modification record names would describe units from the other input; those records are dropped from the result whether or -not the inputs agree on them. The categorical attributes name exposure levels +not the inputs agree on them. Weights whose own values were truncated are +combined only when the records they carry name the same bound, since weights +bounded differently describe different estimands; a record already dropped +agrees with any bound. The categorical attributes name exposure levels rather than positions, and the exposure records describe the exposure rather than any unit, so both carry when the inputs agree. @@ -191,7 +203,8 @@ Subsetting with \code{[} preserves class and attributes for vector subscripts. Two kinds of attribute hold one value per observation and so cannot be re-indexed for a subset: a \code{stabilization_score} with more than one value, and the records left by a modified propensity score (\code{ps_trim_meta}, -\code{ps_trunc_meta}, and \code{ps_calib_meta}). Where an operation goes through +\code{ps_trunc_meta}, and \code{ps_calib_meta}) or by truncating the weights +themselves (\code{psw_trunc_meta}). Where an operation goes through vctrs, these are carried when the result comes back at the length they were recorded on and dropped when it does not. Any same-length operation keeps them, a reordering or a subscript with duplicates included, so the positions @@ -211,7 +224,7 @@ model fit on them still carrying a record written for rows that are no longer there. Honesty therefore lives at query time. \code{\link[=is_unit_trimmed]{is_unit_trimmed()}} and -\code{\link[=is_unit_truncated]{is_unit_truncated()}} answer by position, so each checks that the record +\code{\link[=is_unit_truncated]{is_unit_truncated()}} answer by position, as does \code{\link[=is_unit_wt_truncated]{is_unit_wt_truncated()}}, so each checks that the record covers the vector it is given and raises an error of class \code{propensity_missing_meta_error} when it does not, or when weights marked as modified carry no record at all, rather than name modified units at stale diff --git a/tests/testthat/_snaps/psw-wt-trunc.md b/tests/testthat/_snaps/psw-wt-trunc.md new file mode 100644 index 00000000..5104cced --- /dev/null +++ b/tests/testthat/_snaps/psw-wt-trunc.md @@ -0,0 +1,28 @@ +# is_unit_wt_truncated() refuses flagged weights with no record + + Code + expr + Condition + Error in `is_unit_wt_truncated()`: + ! `is_unit_wt_truncated()` has no usable weight truncation record for these weights. + x These weights are marked as truncated but carry no record of which weights were truncated. + i Call `is_unit_wt_truncated()` on the weights the truncation returned, before subsetting or combining them. + +# growing a weight-truncated psw leaves a record that no longer covers it + + Code + expr + Condition + Error in `is_unit_wt_truncated()`: + ! `is_unit_wt_truncated()` has no usable weight truncation record for these weights. + x The record covers 5 observations and these weights have 7, so its positions do not describe them. + i Call `is_unit_wt_truncated()` on the weights the truncation returned, before subsetting or combining them. + +# is_unit_wt_truncated() refuses anything that is not a psw + + Code + expr + Condition + Error in `is_unit_wt_truncated()`: + ! `is_unit_wt_truncated()` not supported for class "numeric" + diff --git a/tests/testthat/test-psw.R b/tests/testthat/test-psw.R index 5a947b8e..2eb41a58 100644 --- a/tests/testthat/test-psw.R +++ b/tests/testthat/test-psw.R @@ -1545,6 +1545,7 @@ test_that("the record of what an operation dropped stays off its result", { "trimmed", "truncated", "calibrated", + "wt_truncated", "class", "n_categories", "category_names", From 16aeb047597152b9a9821be5fe2e1ff4e3af50e8 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 21:50:34 -0400 Subject: [PATCH 11/64] add failing tests for wt_trunc() --- tests/testthat/test-wt-trunc.R | 1116 ++++++++++++++++++++++++++++++++ 1 file changed, 1116 insertions(+) create mode 100644 tests/testthat/test-wt-trunc.R diff --git a/tests/testthat/test-wt-trunc.R b/tests/testthat/test-wt-trunc.R new file mode 100644 index 00000000..a9e231fc --- /dev/null +++ b/tests/testthat/test-wt-trunc.R @@ -0,0 +1,1116 @@ +# Truncating the weights themselves ------------------------------------------ + +# `wt_trunc()` winsorizes a psw at a bound read on the scale of the weights and +# leaves a record of the bound and the units it moved. Every bound below is +# worked out from the data by hand, never read back from the function. + +# The record the truncation should leave, written out. +expected_wt_trunc_record <- function( + method, + lower = NULL, + upper = NULL, + lower_value = NULL, + upper_value = NULL, + truncated_idx = integer(), + n_obs +) { + new_psw_trunc_meta( + method = method, + lower = lower, + upper = upper, + lower_value = lower_value, + upper_value = upper_value, + truncated_idx = truncated_idx, + n_obs = n_obs + ) +} + +# Winsorizing by hand. A missing weight is neither above nor below a bound, so +# it stays missing and is not among the units moved. +winsorize_by_hand <- function(x, lower_value = -Inf, upper_value = Inf) { + x <- as.numeric(x) + low <- which(x < lower_value) + high <- which(x > upper_value) + x[low] <- lower_value + x[high] <- upper_value + list(values = x, idx = sort(c(low, high))) +} + +# The Gruber et al. bound, with `n` the number of weights present. +gruber_bound <- function(x) { + n <- sum(!is.na(x)) + sqrt(n) * log(n) / 5 +} + +# Quantile type 7, the `quantile()` default that `ps_trunc(method = "pctl")` +# uses, written out: the order statistic at `h = (n - 1) p + 1`, interpolated +# linearly when `h` falls between two of them. +type7_quantile <- function(x, p) { + x <- sort(x[!is.na(x)]) + h <- (length(x) - 1) * p + 1 + lo <- floor(h) + hi <- ceiling(h) + x[lo] + (h - lo) * (x[hi] - x[lo]) +} + +# The message a refusal carries, with the line wrapping cli adds squeezed out +# so that a phrase can be searched for whatever the console width. +refusal_message <- function(expr) { + cnd <- rlang::catch_cnd(expr, classes = "error") + if (is.null(cnd)) { + return(NA_character_) + } + gsub("\\s+", " ", conditionMessage(cnd)) +} + +# Weights from real fits for each exposure type the verb accepts. The +# continuous weights are stabilized by a fitted numerator model, so they carry +# a density record and the model it names. +wt_trunc_data <- function(n = 60, seed = 20260916) { + withr::local_seed(seed) + dat <- data.frame(x1 = rnorm(n), x2 = rnorm(n)) + dat$z <- rbinom(n, 1, stats::plogis(1.2 * dat$x1)) + dat$k <- factor( + sample(c("low", "mid", "high"), n, replace = TRUE), + levels = c("low", "mid", "high") + ) + dat$a <- 1 + 0.6 * dat$x1 - 0.4 * dat$x2 + rnorm(n) + dat +} + +binary_wt_trunc_fit <- function(dat = wt_trunc_data()) { + stats::glm(z ~ x1 + x2, data = dat, family = stats::binomial()) +} + +binary_wt_trunc_weights <- function(dat = wt_trunc_data()) { + wt_ate(binary_wt_trunc_fit(dat), .exposure = dat$z) +} + +stabilized_binary_wt_trunc_weights <- function(dat = wt_trunc_data()) { + numerator <- stats::glm(z ~ 1, data = dat, family = stats::binomial()) + wt_ate(binary_wt_trunc_fit(dat), .exposure = dat$z, stabilize = numerator) +} + +categorical_wt_trunc_weights <- function(dat = wt_trunc_data()) { + fit <- nnet::multinom(k ~ x1 + x2, data = dat, trace = FALSE) + wt_ate(fit, .exposure = dat$k) +} + +continuous_wt_trunc_weights <- function(dat = wt_trunc_data()) { + dose <- stats::lm(a ~ x1 + x2, data = dat) + numerator <- stats::lm(a ~ x1, data = dat) + muffle_variance_warning(wt_ate(dose, stabilize = numerator)) +} + +# The attributes a truncation has no business changing: everything but the +# label, the flag, and the record it writes. +untouched_attrs <- function(x) { + attrs <- attributes(x) + attrs[setdiff(names(attrs), c("estimand", "wt_truncated", "psw_trunc_meta"))] +} + +# ---- the adaptive bound ------------------------------------------------------ + +test_that("the adaptive bound is sqrt(n) log(n) / 5 on the upper tail only", { + # Twenty weights put the bound at 2.679, so the two largest are pulled down to + # it and the smallest, far below any sensible lower bound, is left alone. + x <- c(rep(1.5, 16), 0.01, 2, 5, 9) + w <- psw(x, estimand = "ate") + bound <- sqrt(20) * log(20) / 5 + by_hand <- winsorize_by_hand(x, upper_value = bound) + + out <- expect_silent(wt_trunc(w)) + + expect_s3_class(out, "psw") + expect_equal(as.numeric(out), by_hand$values) + expect_identical(by_hand$idx, c(19L, 20L)) + expect_true(is_wt_truncated(out)) + meta <- attr(out, "psw_trunc_meta") + expect_s3_class(meta, "propensity_psw_trunc_meta") + expect_equal(meta$upper_value, bound) + expect_identical( + unclass(meta)[c("method", "lower", "upper", "lower_value")], + list(method = "adaptive", lower = NULL, upper = NULL, lower_value = NULL) + ) + expect_identical(meta$truncated_idx, by_hand$idx) + expect_identical(meta$n_obs, 20L) + expect_identical( + is_unit_wt_truncated(out), + seq_along(x) %in% by_hand$idx + ) +}) + +test_that("adaptive is the default method", { + x <- c(rep(1.5, 16), 0.01, 2, 5, 9) + w <- psw(x, estimand = "ate") + + expect_identical(wt_trunc(w), wt_trunc(w, method = "adaptive")) +}) + +test_that("the adaptive bound counts only the weights that are present", { + # With 20 of 22 weights present the bound is 2.679; counting the two missing + # weights would put it at 2.720 and leave the weight of 2.7 alone. + x <- c(rep(1.5, 16), NA, 2.7, 1, NA, 9, 2) + w <- psw(x, estimand = "ate") + bound <- sqrt(20) * log(20) / 5 + expect_lt(bound, 2.7) + expect_gt(sqrt(22) * log(22) / 5, 2.7) + + out <- wt_trunc(w) + meta <- attr(out, "psw_trunc_meta") + + expect_equal(meta$upper_value, bound) + expect_identical(meta$truncated_idx, c(18L, 21L)) + expect_identical(meta$n_obs, 22L) + expect_equal( + as.numeric(out), + winsorize_by_hand(x, upper_value = bound)$values + ) + # A missing weight stays missing and is not a unit the bound moved. + expect_true(all(is.na(out[c(17, 20)]))) + expect_false(any(is_unit_wt_truncated(out)[c(17, 20)])) +}) + +test_that("the adaptive bound on weights from a trimmed score counts the kept units", { + # The trim keeps 77 of 80 units, which puts the bound at 7.62 rather than the + # 7.84 all 80 would give. Two weights exceed it, and one of those lies + # between the two bounds, so counting the trimmed units would move only one. + dat <- wt_trunc_data(n = 80) + fit <- binary_wt_trunc_fit(dat) + trimmed <- ps_trim(fit, method = "ps", lower = 0.05, upper = 0.95) + refit <- ps_refit(trimmed, fit) + w <- wt_ate(refit, .exposure = dat$z) + expect_identical(sum(!is.na(w)), 77L) + + bound <- gruber_bound(as.numeric(w)) + expect_equal(bound, sqrt(77) * log(77) / 5) + by_hand <- winsorize_by_hand(w, upper_value = bound) + expect_length(by_hand$idx, 2) + all_units_bound <- sqrt(80) * log(80) / 5 + expect_identical( + sum(as.numeric(w) > bound & as.numeric(w) <= all_units_bound, na.rm = TRUE), + 1L + ) + + out <- wt_trunc(w) + + expect_equal(attr(out, "psw_trunc_meta")$upper_value, bound) + expect_identical(attr(out, "psw_trunc_meta")$truncated_idx, by_hand$idx) + expect_equal(as.numeric(out), by_hand$values) +}) + +test_that("bounds supplied to the adaptive method are ignored with a warning", { + x <- c(rep(1.5, 16), 0.01, 2, 5, 9) + w <- psw(x, estimand = "ate") + plain <- wt_trunc(w) + + expect_warning( + with_upper <- wt_trunc(w, upper = 3), + class = "propensity_warning", + regexp = "ignored" + ) + expect_warning( + with_lower <- wt_trunc(w, lower = 0.5), + class = "propensity_warning", + regexp = "ignored" + ) + expect_warning( + with_both <- wt_trunc(w, method = "adaptive", lower = 0.5, upper = 3), + class = "propensity_warning", + regexp = "ignored" + ) + + # Nothing the caller wrote reaches the bound or the record. + expect_identical(with_upper, plain) + expect_identical(with_lower, plain) + expect_identical(with_both, plain) + + expect_propensity_warning(wt_trunc(w, method = "adaptive", upper = 3)) +}) + +# ---- an absolute bound ------------------------------------------------------- + +test_that("method = 'wt' winsorizes the upper tail at the value given", { + x <- c(0.5, 1, 4, 2, 25, NA, 0.02) + w <- psw(x, estimand = "ate") + by_hand <- winsorize_by_hand(x, upper_value = 20) + + out <- wt_trunc(w, method = "wt", upper = 20) + + expect_equal(as.numeric(out), c(0.5, 1, 4, 2, 20, NA, 0.02)) + expect_equal(as.numeric(out), by_hand$values) + expect_identical( + attr(out, "psw_trunc_meta"), + expected_wt_trunc_record( + method = "wt", + upper = 20, + upper_value = 20, + truncated_idx = 5L, + n_obs = 7L + ) + ) +}) + +test_that("method = 'wt' bounds the lower tail only when asked to", { + x <- c(0.5, 1, 4, 2, 25, NA, 0.02) + w <- psw(x, estimand = "ate") + + out <- wt_trunc(w, method = "wt", lower = 0.05, upper = 20) + + expect_equal(as.numeric(out), c(0.5, 1, 4, 2, 20, NA, 0.05)) + expect_identical( + attr(out, "psw_trunc_meta"), + expected_wt_trunc_record( + method = "wt", + lower = 0.05, + upper = 20, + lower_value = 0.05, + upper_value = 20, + truncated_idx = c(5L, 7L), + n_obs = 7L + ) + ) + expect_identical( + is_unit_wt_truncated(out), + c(FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, TRUE) + ) +}) + +test_that("method = 'wt' accepts a floor of zero", { + # Weights are never negative, so a floor of zero is a valid bound that + # moves nothing. + x <- c(0.5, 1, 4, 2, 25) + w <- psw(x, estimand = "ate") + + out <- expect_silent(wt_trunc(w, method = "wt", lower = 0, upper = 20)) + + expect_equal(as.numeric(out), c(0.5, 1, 4, 2, 20)) + meta <- attr(out, "psw_trunc_meta") + expect_identical(meta$lower, 0) + expect_identical(meta$lower_value, 0) + expect_identical(meta$truncated_idx, 5L) +}) + +test_that("integer weights come back as doubles", { + out <- wt_trunc(c(1L, 5L, 30L), method = "wt", upper = 2.5) + + expect_s3_class(out, "psw") + expect_type(vctrs::vec_data(out), "double") + expect_identical(as.numeric(out), c(1, 2.5, 2.5)) + expect_identical(attr(out, "psw_trunc_meta")$truncated_idx, c(2L, 3L)) +}) + +test_that("a bound that moves nothing still leaves a record", { + x <- c(0.5, 1, 4, 2) + w <- psw(x, estimand = "ate") + + out <- wt_trunc(w, method = "wt", upper = 20) + + expect_equal(as.numeric(out), x) + expect_true(is_wt_truncated(out)) + expect_identical(attr(out, "psw_trunc_meta")$truncated_idx, integer()) + expect_identical(is_unit_wt_truncated(out), rep(FALSE, 4)) +}) + +test_that("an integer bound is recorded as the same double as its numeric twin", { + w <- psw(c(1.2, 4, 1.5, 2.1, 3.5), estimand = "ate") + + from_integer <- wt_trunc(w, method = "wt", upper = 3L) + from_double <- wt_trunc(w, method = "wt", upper = 3) + meta <- attr(from_integer, "psw_trunc_meta") + + expect_identical(meta, attr(from_double, "psw_trunc_meta")) + expect_identical(meta$upper, 3) + expect_identical(meta$upper_value, 3) + expect_identical(from_integer, from_double) + + # Two truncations at the same bound describe the same operation. + combined <- expect_silent(c(from_integer, from_double)) + expect_true(is_wt_truncated(combined)) + + lower_integer <- wt_trunc(w, method = "wt", lower = 2L, upper = 3L) + lower_double <- wt_trunc(w, method = "wt", lower = 2, upper = 3) + expect_identical( + attr(lower_integer, "psw_trunc_meta"), + attr(lower_double, "psw_trunc_meta") + ) + expect_identical(attr(lower_integer, "psw_trunc_meta")$lower, 2) + expect_silent(c(lower_integer, lower_double)) +}) + +test_that("method = 'wt' refuses a bound it cannot apply", { + w <- psw(c(1.2, 4, 1.5, 2.1, 3.5), estimand = "ate") + + expect_error( + wt_trunc(w, method = "wt"), + class = "propensity_missing_arg_error" + ) + expect_error( + wt_trunc(w, method = "wt", lower = 1), + class = "propensity_missing_arg_error" + ) + expect_error( + wt_trunc(w, method = "wt", upper = NA), + class = "propensity_missing_value_error" + ) + for (upper in list(0, -1, Inf, c(2, 3))) { + expect_error( + wt_trunc(w, method = "wt", upper = upper), + class = "propensity_range_error" + ) + } + expect_error( + wt_trunc(w, method = "wt", upper = "3"), + class = "propensity_type_error" + ) + expect_error( + wt_trunc(w, method = "wt", lower = 3, upper = 3), + class = "propensity_range_error" + ) + expect_error( + wt_trunc(w, method = "wt", lower = 4, upper = 3), + class = "propensity_range_error" + ) + expect_error( + wt_trunc(w, method = "wt", lower = -1, upper = 3), + class = "propensity_range_error" + ) + + expect_propensity_error(wt_trunc(w, method = "wt")) + expect_propensity_error(wt_trunc(w, method = "wt", upper = 0)) + expect_propensity_error(wt_trunc(w, method = "wt", lower = 4, upper = 3)) +}) + +# ---- a percentile bound ------------------------------------------------------ + +# 101 distinct weights and two missing ones, in no particular order. +pctl_weights <- function() { + withr::local_seed(99) + x <- sample(round(0.5 + stats::rexp(101), 6)) + x <- c(x[1:40], NA, x[41:90], NA, x[91:101]) + psw(x, estimand = "ate") +} + +test_that("method = 'pctl' reads the bound at a type 7 quantile of the weights present", { + w <- pctl_weights() + x <- as.numeric(w) + present <- sort(x[!is.na(x)]) + expect_length(present, 101) + expect_identical(anyDuplicated(present), 0L) + + # 0.99 of 101 falls on an order statistic, h = 100 * 0.99 + 1 = 100. + exact <- wt_trunc(w, method = "pctl", upper = 0.99) + expect_identical(attr(exact, "psw_trunc_meta")$upper_value, present[100]) + expect_identical( + attr(exact, "psw_trunc_meta")$truncated_idx, + which(x > present[100]) + ) + expect_equal( + as.numeric(exact), + winsorize_by_hand(x, upper_value = present[100])$values + ) + + # 0.975 of 101 falls between two, h = 98.5, so the bound is interpolated. + between <- present[98] + 0.5 * (present[99] - present[98]) + expect_equal(type7_quantile(x, 0.975), between) + interpolated <- wt_trunc(w, method = "pctl", upper = 0.975) + meta <- attr(interpolated, "psw_trunc_meta") + expect_equal(meta$upper_value, between) + expect_identical(meta$truncated_idx, which(x > between)) + expect_length(meta$truncated_idx, 3) + expect_identical( + unclass(meta)[c("method", "lower", "upper", "lower_value", "n_obs")], + list( + method = "pctl", + lower = NULL, + upper = 0.975, + lower_value = NULL, + n_obs = 103L + ) + ) + expect_null(names(meta$upper_value)) +}) + +test_that("method = 'pctl' bounds the lower tail only when asked to", { + w <- pctl_weights() + x <- as.numeric(w) + present <- sort(x[!is.na(x)]) + + # h = 100 * 0.025 + 1 = 3.5 at the bottom, 98.5 at the top. + lower_value <- present[3] + 0.5 * (present[4] - present[3]) + upper_value <- present[98] + 0.5 * (present[99] - present[98]) + by_hand <- winsorize_by_hand(x, lower_value, upper_value) + + out <- wt_trunc(w, method = "pctl", lower = 0.025, upper = 0.975) + meta <- attr(out, "psw_trunc_meta") + + expect_identical(meta$method, "pctl") + expect_identical(meta$lower, 0.025) + expect_identical(meta$upper, 0.975) + expect_equal(meta$lower_value, lower_value) + expect_equal(meta$upper_value, upper_value) + expect_identical(meta$truncated_idx, by_hand$idx) + expect_length(meta$truncated_idx, 6) + expect_equal(as.numeric(out), by_hand$values) + expect_true(all(is.na(out[c(41, 92)]))) +}) + +test_that("method = 'pctl' refuses an upper probability below one half and names both readings", { + w <- pctl_weights() + + expect_error( + wt_trunc(w, method = "pctl", upper = 0.1), + class = "propensity_range_error" + ) + message <- refusal_message(wt_trunc(w, method = "pctl", upper = 0.1)) + expect_match(message, "upper = 0.9", fixed = TRUE) + expect_match(message, "lower = 0.1", fixed = TRUE) + + expect_propensity_error(wt_trunc(w, method = "pctl", upper = 0.1)) +}) + +test_that("method = 'pctl' refuses probabilities outside their half of the unit interval", { + w <- pctl_weights() + + expect_error( + wt_trunc(w, method = "pctl"), + class = "propensity_missing_arg_error" + ) + expect_error( + wt_trunc(w, method = "pctl", lower = 0.05), + class = "propensity_missing_arg_error" + ) + expect_error( + wt_trunc(w, method = "pctl", upper = NA), + class = "propensity_missing_value_error" + ) + for (upper in list(1, 1.5, -0.2, c(0.9, 0.95))) { + expect_error( + wt_trunc(w, method = "pctl", upper = upper), + class = "propensity_range_error" + ) + } + for (lower in list(0, 0.5, 0.6, -0.1)) { + expect_error( + wt_trunc(w, method = "pctl", lower = lower, upper = 0.95), + class = "propensity_range_error" + ) + } + + expect_propensity_error(wt_trunc(w, method = "pctl", upper = 1.5)) + expect_propensity_error( + wt_trunc(w, method = "pctl", lower = 0.6, upper = 0.95) + ) +}) + +# ---- a count ----------------------------------------------------------------- + +test_that("method = 'count' bounds the largest weights at the next one down", { + x <- c(3, 9, 1, 7, 2, 7.5, 4, NA, 0.5, 6) + w <- psw(x, estimand = "ate") + + # The two largest are 9 and 7.5; the next one down is 7. + out <- wt_trunc(w, method = "count", upper = 2) + + expect_equal(as.numeric(out), c(3, 7, 1, 7, 2, 7, 4, NA, 0.5, 6)) + expect_identical( + attr(out, "psw_trunc_meta"), + expected_wt_trunc_record( + method = "count", + upper = 2, + upper_value = 7, + truncated_idx = c(2L, 6L), + n_obs = 10L + ) + ) +}) + +test_that("method = 'count' bounds the smallest weights at the next one up", { + x <- c(3, 9, 1, 7, 2, 7.5, 4, NA, 0.5, 6) + w <- psw(x, estimand = "ate") + + # The smallest is 0.5, the next one up is 1; the two largest go to 7. + out <- wt_trunc(w, method = "count", lower = 1, upper = 2) + + expect_equal(as.numeric(out), c(3, 7, 1, 7, 2, 7, 4, NA, 1, 6)) + expect_identical( + attr(out, "psw_trunc_meta"), + expected_wt_trunc_record( + method = "count", + lower = 1, + upper = 2, + lower_value = 1, + upper_value = 7, + truncated_idx = c(2L, 6L, 9L), + n_obs = 10L + ) + ) + + # Two smallest: 0.5 and 1 go to 2, the next one up. + two_low <- wt_trunc(w, method = "count", lower = 2L, upper = 1L) + expect_equal(as.numeric(two_low), c(3, 7.5, 2, 7, 2, 7.5, 4, NA, 2, 6)) + expect_identical( + attr(two_low, "psw_trunc_meta")$truncated_idx, + c(2L, 3L, 9L) + ) + expect_identical(attr(two_low, "psw_trunc_meta")$lower, 2) + expect_identical(attr(two_low, "psw_trunc_meta")$upper, 1) +}) + +test_that("method = 'count' moves only the weights above a tied bound", { + # The largest weight ties with the next one down, so a count of one moves + # nothing: the bound is 8 and no weight exceeds it. + x <- c(4, 8, 8, 2, 5) + w <- psw(x, estimand = "ate") + + one <- wt_trunc(w, method = "count", upper = 1) + expect_equal(as.numeric(one), x) + expect_identical(attr(one, "psw_trunc_meta")$upper_value, 8) + expect_identical(attr(one, "psw_trunc_meta")$truncated_idx, integer()) + + # A count of two reaches past the tie, to 5. + two <- wt_trunc(w, method = "count", upper = 2) + expect_equal(as.numeric(two), c(4, 5, 5, 2, 5)) + expect_identical(attr(two, "psw_trunc_meta")$upper_value, 5) + expect_identical(attr(two, "psw_trunc_meta")$truncated_idx, c(2L, 3L)) +}) + +test_that("method = 'count' refuses counts that meet or cross", { + # Nine weights are present. Bounding the four smallest and the four largest + # leaves one weight, which would have to be both the next one up and the + # next one down. + x <- c(3, 9, 1, 7, 2, 7.5, 4, NA, 0.5, 6) + w <- psw(x, estimand = "ate") + + expect_error( + wt_trunc(w, method = "count", lower = 4, upper = 4), + class = "propensity_range_error" + ) + expect_error( + wt_trunc(w, method = "count", lower = 5, upper = 5), + class = "propensity_range_error" + ) + + # Three smallest (0.5, 1, 2) go to 3; four largest (9, 7.5, 7, 6) go to 4. + out <- expect_silent(wt_trunc(w, method = "count", lower = 3, upper = 4)) + expect_equal(as.numeric(out), c(3, 4, 3, 4, 3, 4, 4, NA, 3, 4)) + meta <- attr(out, "psw_trunc_meta") + expect_identical(meta$lower_value, 3) + expect_identical(meta$upper_value, 4) + expect_identical(meta$truncated_idx, c(2L, 3L, 4L, 5L, 6L, 9L, 10L)) + + expect_propensity_error(wt_trunc(w, method = "count", lower = 4, upper = 4)) +}) + +test_that("method = 'count' refuses a count it cannot apply", { + # Nine weights are present, so a count of nine leaves no next one down. + w <- psw(c(3, 9, 1, 7, 2, 7.5, 4, NA, 0.5, 6), estimand = "ate") + + expect_error( + wt_trunc(w, method = "count"), + class = "propensity_missing_arg_error" + ) + expect_error( + wt_trunc(w, method = "count", upper = NA), + class = "propensity_missing_value_error" + ) + for (upper in list(0, -1, 1.5, 9, 10, c(1, 2), Inf)) { + expect_error( + wt_trunc(w, method = "count", upper = upper), + class = "propensity_range_error" + ) + } + for (lower in list(0, 2.5, -1)) { + expect_error( + wt_trunc(w, method = "count", lower = lower, upper = 2), + class = "propensity_range_error" + ) + } + expect_silent(wt_trunc(w, method = "count", upper = 8)) + + expect_propensity_error(wt_trunc(w, method = "count", upper = 1.5)) + expect_propensity_error(wt_trunc(w, method = "count", upper = 9)) +}) + +# ---- methods and arguments --------------------------------------------------- + +test_that("wt_trunc() refuses a method it does not have", { + w <- psw(c(1.2, 4, 1.5), estimand = "ate") + + # The score-scale methods belong to `ps_trunc()`. + expect_error(wt_trunc(w, method = "ps", upper = 3), class = "rlang_error") + expect_error(wt_trunc(w, method = "cr"), class = "rlang_error") + expect_error(wt_trunc(w, method = "auto"), class = "rlang_error") +}) + +test_that("wt_trunc() refuses an argument it does not read", { + # A misspelled bound would otherwise truncate at a bound the caller believed + # they had replaced. + w <- psw(c(1.2, 4, 1.5), estimand = "ate") + + expect_error( + wt_trunc(w, method = "wt", uper = 3), + class = "rlib_error_dots_nonempty" + ) +}) + +# ---- the input and its label ------------------------------------------------- + +test_that("the estimand gains a weights-truncated label", { + dat <- wt_trunc_data() + fit <- binary_wt_trunc_fit(dat) + + ate <- wt_trunc(wt_ate(fit, .exposure = dat$z), method = "wt", upper = 2) + expect_identical(estimand(ate), "ate; weights truncated") + + att <- wt_trunc(wt_att(fit, .exposure = dat$z), method = "wt", upper = 2) + expect_identical(estimand(att), "att; weights truncated") + + ato <- wt_trunc(wt_ato(fit, .exposure = dat$z), method = "wt", upper = 0.4) + expect_identical(estimand(ato), "ato; weights truncated") +}) + +test_that("the label and the records stack on weights from a trimmed score", { + dat <- wt_trunc_data(n = 200) + fit <- binary_wt_trunc_fit(dat) + trimmed <- ps_trim(fit, method = "ps", lower = 0.2, upper = 0.8) + w <- wt_ate(ps_refit(trimmed, fit), .exposure = dat$z) + expect_identical(estimand(w), "ate; trimmed") + + # Stacking a weight truncation on a trim is allowed, and says so. + out <- expect_silent(wt_trunc(w, method = "wt", upper = 3)) + + expect_identical(estimand(out), "ate; trimmed; weights truncated") + expect_true(is_ps_trimmed(out)) + expect_true(is_wt_truncated(out)) + expect_false(is_ps_truncated(out)) + expect_identical(attr(out, "ps_trim_meta"), attr(w, "ps_trim_meta")) + expect_identical(is_unit_trimmed(out), is_unit_trimmed(w)) + expect_identical(untouched_attrs(out), untouched_attrs(w)) + + # The trimmed units stay missing and are not among those the bound moved. + expect_identical(is.na(as.numeric(out)), is.na(as.numeric(w))) + expect_false(any(is_unit_wt_truncated(out)[is.na(w)])) + expect_equal( + as.numeric(out), + winsorize_by_hand(w, upper_value = 3)$values + ) +}) + +test_that("the label and the records stack on weights from a truncated score", { + dat <- wt_trunc_data() + fit <- binary_wt_trunc_fit(dat) + truncated <- ps_trunc(fit, method = "ps", lower = 0.2, upper = 0.8) + w <- wt_ate(truncated, .exposure = dat$z) + expect_identical(estimand(w), "ate; truncated") + + out <- expect_silent(wt_trunc(w, method = "wt", upper = 3)) + + expect_identical(estimand(out), "ate; truncated; weights truncated") + expect_true(is_ps_truncated(out)) + expect_true(is_wt_truncated(out)) + expect_identical(is_unit_truncated(out), is_unit_truncated(w)) + expect_identical(untouched_attrs(out), untouched_attrs(w)) +}) + +test_that("the label and the records stack on weights from a calibrated score", { + dat <- wt_trunc_data(n = 200) + ps <- stats::fitted(binary_wt_trunc_fit(dat)) + calibrated <- expect_silent(ps_calibrate(ps, dat$z)) + w <- wt_ate(calibrated, .exposure = dat$z) + expect_identical(estimand(w), "ate; calibrated") + + out <- expect_silent(wt_trunc(w, method = "wt", upper = 3)) + + expect_identical(estimand(out), "ate; calibrated; weights truncated") + expect_true(is_ps_calibrated(out)) + expect_true(is_wt_truncated(out)) + expect_identical(untouched_attrs(out), untouched_attrs(w)) + expect_equal( + as.numeric(out), + winsorize_by_hand(w, upper_value = 3)$values + ) +}) + +test_that("a bare numeric vector becomes a truncated psw with no estimand", { + x <- c(0.5, 1, 4, 2, 25) + + out <- expect_silent(wt_trunc(x, method = "wt", upper = 20)) + + expect_s3_class(out, "psw") + expect_null(estimand(out)) + expect_true(is_wt_truncated(out)) + expect_equal(as.numeric(out), c(0.5, 1, 4, 2, 20)) + expect_identical( + attr(out, "psw_trunc_meta"), + expected_wt_trunc_record( + method = "wt", + upper = 20, + upper_value = 20, + truncated_idx = 5L, + n_obs = 5L + ) + ) + + adaptive <- wt_trunc(c(rep(1.5, 16), 0.01, 2, 5, 9)) + expect_s3_class(adaptive, "psw") + expect_null(estimand(adaptive)) +}) + +test_that("wt_trunc() refuses input that is not weights", { + expect_error(wt_trunc(c("a", "b")), class = "propensity_type_error") + expect_error(wt_trunc(list(1, 2)), class = "propensity_error") + + expect_propensity_error(wt_trunc(c("a", "b"))) +}) + +test_that("wt_trunc() refuses propensity scores", { + # A trimmed, truncated, or calibrated score is a score rather than a weight. + # The refusal points to building weights from it first, or to bounding the + # score itself with `ps_trunc()`. + dat <- wt_trunc_data(n = 200) + ps <- stats::fitted(binary_wt_trunc_fit(dat)) + scores <- list( + ps_trim = ps_trim(ps, method = "ps", lower = 0.1, upper = 0.9), + ps_trunc = ps_trunc(ps, method = "ps", lower = 0.1, upper = 0.9), + ps_calib = ps_calibrate(ps, dat$z) + ) + + for (label in names(scores)) { + score <- scores[[label]] + expect_s3_class(score, label) + expect_error( + wt_trunc(score, method = "wt", upper = 3), + class = "propensity_type_error", + info = label + ) + } + + message <- refusal_message( + wt_trunc(scores$ps_trim, method = "wt", upper = 3) + ) + expect_match(message, "wt_ate()", fixed = TRUE) + expect_match(message, "ps_trunc()", fixed = TRUE) + + trimmed <- scores$ps_trim + expect_propensity_error(wt_trunc(trimmed, method = "wt", upper = 3)) +}) + +test_that("the data-driven methods refuse fewer than two weights", { + inputs <- list( + empty = psw(double(), estimand = "ate"), + all_missing = psw(c(NA_real_, NA_real_), estimand = "ate"), + one_present = psw(c(NA, 2.5, NA), estimand = "ate") + ) + + for (label in names(inputs)) { + w <- inputs[[label]] + expect_error( + wt_trunc(w), + class = "propensity_range_error", + info = label + ) + expect_error( + wt_trunc(w, method = "pctl", upper = 0.95), + class = "propensity_range_error", + info = label + ) + } + + # A count must stay below the number of weights present, which none are. + expect_error( + wt_trunc(inputs$all_missing, method = "count", upper = 1), + class = "propensity_range_error" + ) + + one_present <- inputs$one_present + expect_propensity_error(wt_trunc(one_present)) +}) + +test_that("an absolute bound on no weights leaves an empty record", { + out <- expect_silent( + wt_trunc(psw(double(), estimand = "ate"), method = "wt", upper = 3) + ) + + expect_s3_class(out, "psw") + expect_length(out, 0) + expect_true(is_wt_truncated(out)) + expect_identical(estimand(out), "ate; weights truncated") + meta <- attr(out, "psw_trunc_meta") + expect_identical(meta$truncated_idx, integer()) + expect_identical(meta$n_obs, 0L) +}) + +test_that("truncating truncated weights warns and returns them unchanged", { + w <- psw(c(1.2, 4, 1.5, 2.1, 3.5), estimand = "ate") + once <- wt_trunc(w, method = "wt", upper = 3) + + expect_warning( + twice <- wt_trunc(once, method = "wt", upper = 2), + class = "propensity_already_modified_warning" + ) + expect_identical(twice, once) + + expect_warning( + again <- wt_trunc(once), + class = "propensity_already_modified_warning" + ) + expect_identical(again, once) + + expect_propensity_warning(wt_trunc(once, method = "wt", upper = 2)) +}) + +# ---- what the truncation keeps ----------------------------------------------- + +test_that("truncating binary weights keeps their records", { + w <- stabilized_binary_wt_trunc_weights() + expect_true(is_stabilized(w)) + expect_false(is.null(numerator_model(w))) + bound <- stats::median(as.numeric(w)) + + out <- wt_trunc(w, method = "wt", upper = bound) + + expect_identical(untouched_attrs(out), untouched_attrs(w)) + expect_identical(numerator_model(out), numerator_model(w)) + expect_true(is_stabilized(out)) + expect_identical(exposure_type(out), "binary") + expect_identical(estimand(out), "ate; weights truncated") + expect_equal( + as.numeric(out), + winsorize_by_hand(w, upper_value = bound)$values + ) +}) + +test_that("truncating categorical weights keeps their records", { + w <- categorical_wt_trunc_weights() + bound <- stats::quantile(as.numeric(w), 0.9, names = FALSE) + by_hand <- winsorize_by_hand(w, upper_value = bound) + expect_gt(length(by_hand$idx), 0) + + out <- wt_trunc(w, method = "wt", upper = bound) + + expect_identical(untouched_attrs(out), untouched_attrs(w)) + expect_identical(exposure_type(out), "categorical") + expect_identical(attr(out, "category_names"), attr(w, "category_names")) + expect_identical(estimand(out), "ate; weights truncated") + expect_equal(as.numeric(out), by_hand$values) + expect_identical(attr(out, "psw_trunc_meta")$truncated_idx, by_hand$idx) +}) + +test_that("truncating continuous weights keeps the density record and numerator model", { + w <- continuous_wt_trunc_weights() + expect_false(is.null(density_meta(w))) + expect_s3_class(numerator_model(w), "lm") + bound <- stats::quantile(as.numeric(w), 0.9, names = FALSE) + by_hand <- winsorize_by_hand(w, upper_value = bound) + + out <- wt_trunc(w, method = "wt", upper = bound) + + expect_identical(density_meta(out), density_meta(w)) + expect_identical(numerator_model(out), numerator_model(w)) + expect_identical(untouched_attrs(out), untouched_attrs(w)) + expect_true(is_stabilized(out)) + expect_identical(exposure_type(out), "continuous") + expect_identical(estimand(out), "ate; weights truncated") + expect_equal(as.numeric(out), by_hand$values) + + # Every method keeps them, the default included. + for (method in c("adaptive", "pctl", "count")) { + upper <- switch(method, adaptive = NULL, pctl = 0.95, count = 3) + kept <- wt_trunc(w, method = method, upper = upper) + expect_identical(untouched_attrs(kept), untouched_attrs(w), info = method) + } +}) + +test_that("the count method moves the largest weights from a real fit", { + w <- binary_wt_trunc_weights() + x <- as.numeric(w) + ranked <- sort(x, decreasing = TRUE) + expect_gt(ranked[3], ranked[4]) + + out <- wt_trunc(w, method = "count", upper = 3) + meta <- attr(out, "psw_trunc_meta") + + expect_identical(meta$upper_value, ranked[4]) + expect_identical(meta$truncated_idx, sort(order(x, decreasing = TRUE)[1:3])) + expect_equal( + as.numeric(out), + winsorize_by_hand(x, upper_value = ranked[4])$values + ) +}) + +# ---- the printed record ------------------------------------------------------ + +# The footer prints each bound to three significant digits, as 43.69 prints +# as 43.7. +footer_number <- function(x) { + format(x, digits = 3) +} + +test_that("the footer reports the truncation", { + # A thousand weights put the adaptive bound at 43.69, which two exceed. + x <- c(rep(1, 997), 50, 60, 2) + w <- psw(x, estimand = "ate") + expect_equal(sqrt(1000) * log(1000) / 5, 43.69, tolerance = 1e-4) + expect_identical(footer_number(sqrt(1000) * log(1000) / 5), "43.7") + + lines <- capture_output_lines(print(wt_trunc(w))) + + expect_identical( + lines[[length(lines)]], + paste0( + "truncation: adaptive (upper ", + footer_number(sqrt(1000) * log(1000) / 5), + "), 2 of 1000 weights truncated" + ) + ) +}) + +test_that("the truncation line follows the density record", { + w <- continuous_wt_trunc_weights() + untruncated <- capture_output_lines(print(w)) + expect_false(any(grepl("^truncation:", untruncated))) + + upper_value <- sort(as.numeric(w), decreasing = TRUE)[4] + lines <- capture_output_lines(print(wt_trunc(w, method = "count", upper = 3))) + footer <- lines[seq(length(lines) - 4, length(lines))] + + expect_match(footer[[1]], "^density:") + expect_match(footer[[4]], "^stabilize:") + expect_identical( + footer[[5]], + paste0( + "truncation: count 3 (upper ", + footer_number(upper_value), + "), 3 of 60 weights truncated" + ) + ) +}) + +test_that("the footer names each method's argument and its realized bounds", { + last_line <- function(x) { + lines <- capture_output_lines(print(x)) + lines[[length(lines)]] + } + + w <- psw(c(0.5, 1, 4, 2, 25, NA, 0.02), estimand = "ate") + expect_identical( + last_line(wt_trunc(w, method = "wt", upper = 3)), + "truncation: wt (upper 3), 2 of 7 weights truncated" + ) + expect_identical( + last_line(wt_trunc(w, method = "wt", lower = 0.05, upper = 3)), + "truncation: wt (lower 0.05, upper 3), 3 of 7 weights truncated" + ) + + p <- pctl_weights() + present <- sort(as.numeric(p)[!is.na(p)]) + low <- present[3] + 0.5 * (present[4] - present[3]) + high <- present[98] + 0.5 * (present[99] - present[98]) + expect_identical( + last_line(wt_trunc(p, method = "pctl", upper = 0.99)), + paste0( + "truncation: pctl 0.99 (upper ", + footer_number(present[100]), + "), 1 of 103 weights truncated" + ) + ) + expect_identical( + last_line(wt_trunc(p, method = "pctl", lower = 0.025, upper = 0.975)), + paste0( + "truncation: pctl 0.025/0.975 (lower ", + footer_number(low), + ", upper ", + footer_number(high), + "), 6 of 103 weights truncated" + ) + ) + + counted <- psw(c(3, 9, 1, 7, 2, 7.5, 4, NA, 0.5, 6), estimand = "ate") + expect_identical( + last_line(wt_trunc(counted, method = "count", upper = 3)), + "truncation: count 3 (upper 6), 3 of 10 weights truncated" + ) + expect_identical( + last_line(wt_trunc(counted, method = "count", lower = 2, upper = 3)), + "truncation: count 2/3 (lower 2, upper 6), 5 of 10 weights truncated" + ) +}) + +test_that("truncated weights print their bound and count", { + w <- psw(c(0.5, 1, 4, 2, 25, NA, 0.02), estimand = "ate") + + expect_snapshot({ + wt_trunc(w, method = "wt", upper = 20) + wt_trunc(w, method = "wt", lower = 0.05, upper = 20) + wt_trunc(c(0.5, 1, 4, 2, 25), method = "count", upper = 1) + }) + + dat <- wt_trunc_data(n = 12) + dose <- stats::lm(a ~ x1, data = dat) + weights <- muffle_variance_warning(wt_ate(dose)) + expect_snapshot(wt_trunc(weights, method = "pctl", upper = 0.9)) +}) + +# ---- agreement with WeightIt ------------------------------------------------- + +# WeightIt's `trim()` winsorizes a weight vector as well, and its conventions +# match this verb's in two places only, which the two tests below use: +# +# * A count of the largest weights (`at` >= 1, `lower = FALSE`). Both sort the +# weights and bound the `at` largest at the next one down, moving only those +# strictly above it. WeightIt folds the count, `at <- min(at, n - at)`, where +# this verb refuses a count that leaves no weight below it; WeightIt warns and +# returns the weights unchanged for `at >= n`; its `lower = TRUE` trims the +# same count at both ends, where this verb takes a separate `lower`; and its +# `n` includes missing weights, where this verb counts the weights present. +# * An upper percentile where the two quantile rules pick the same order +# statistic. WeightIt reads quantiles with `type = 3`; this verb follows +# `ps_trunc(method = "pctl")`, which uses the `quantile()` default, +# `type = 7`. At `n = 101` and `upper = 0.99` both select the 100th order +# statistic. Where type 7 lands on an order statistic in the lower tail, +# type 3 selects the one below it, so the two never agree on a lower bound +# there. WeightIt also folds `at <- max(at, 1 - at)`, reading `at = 0.01` as +# the upper tail, where this verb refuses an `upper` below one half; and in +# WeightIt 2.0.0 its `quantile()` call errors on a missing weight. +# +# WeightIt has no absolute bound (an `at` of 1 or more is a count) and no +# Gruber bound, so `"wt"` and `"adaptive"` have no oracle there. WeightIt +# reports what it did with a message, which is muffled around the oracle only. + +weightit_trim <- function(x, ...) { + as.numeric(suppressMessages(WeightIt::trim(as.numeric(x), ...))) +} + +test_that("a count of the largest weights agrees with WeightIt::trim()", { + skip_if_not_installed("WeightIt") + w <- binary_wt_trunc_weights() + expect_false(anyNA(w)) + + for (k in c(1, 3, 5)) { + expect_equal( + as.numeric(wt_trunc(w, method = "count", upper = k)), + weightit_trim(w, at = k), + info = k + ) + } +}) + +test_that("an upper percentile agrees with WeightIt::trim() where the quantile rules coincide", { + skip_if_not_installed("WeightIt") + dat <- wt_trunc_data(n = 101) + w <- continuous_wt_trunc_weights(dat) + expect_false(anyNA(w)) + expect_length(w, 101) + x <- as.numeric(w) + expect_identical( + stats::quantile(x, 0.99, type = 3, names = FALSE), + sort(x)[100] + ) + expect_identical(type7_quantile(x, 0.99), sort(x)[100]) + + expect_equal( + as.numeric(wt_trunc(w, method = "pctl", upper = 0.99)), + weightit_trim(w, at = 0.99) + ) +}) From a234747dbc889899a101e23e3d514a6e8be5afdd Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 22:14:04 -0400 Subject: [PATCH 12/64] add wt_trunc() to bound extreme weights --- NAMESPACE | 7 + NEWS.md | 15 + R/psw.R | 57 +-- R/wt_trunc.R | 625 ++++++++++++++++++++++++++++++ _pkgdown.yml | 4 +- inst/WORDLIST | 2 + man/psw.Rd | 28 +- man/wt_trunc.Rd | 200 ++++++++++ tests/testthat/_snaps/wt-trunc.md | 172 ++++++++ tests/testthat/test-wt-trunc.R | 38 ++ 10 files changed, 1107 insertions(+), 41 deletions(-) create mode 100644 R/wt_trunc.R create mode 100644 man/wt_trunc.Rd create mode 100644 tests/testthat/_snaps/wt-trunc.md diff --git a/NAMESPACE b/NAMESPACE index acea32ac..868ecdc1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -297,6 +297,12 @@ S3method(wt_entropy,numeric) S3method(wt_entropy,ps_calib) S3method(wt_entropy,ps_trim) S3method(wt_entropy,ps_trunc) +S3method(wt_trunc,default) +S3method(wt_trunc,numeric) +S3method(wt_trunc,ps_calib) +S3method(wt_trunc,ps_trim) +S3method(wt_trunc,ps_trunc) +S3method(wt_trunc,psw) export("estimand<-") export(as_conditional) export(as_marginal) @@ -349,6 +355,7 @@ export(wt_atu) export(wt_cens) export(wt_entropy) export(wt_joint) +export(wt_trunc) import(vctrs) importFrom(causalgenerics, "estimand<-", diff --git a/NEWS.md b/NEWS.md index 2dc3fb20..e1e0a7c1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,20 @@ # propensity 0.1.0.9000 (development version) +* New `wt_trunc()` bounds extreme weights on the scale of the weights + themselves, so it applies to weights for any exposure type, including the + density-ratio weights of a continuous exposure. It offers four methods: + `"adaptive"` (the default), an upper bound of `sqrt(n) * log(n) / 5` after + Gruber et al. (2022); `"wt"`, bounds given as weight values; `"pctl"`, bounds + read at sample quantiles; and `"count"`, which bounds a given number of the + most extreme weights at the next one in. Each bounds only the upper tail + unless `lower` is supplied. The result keeps every attribute of the weights, + gains the estimand label `"; weights truncated"`, and records the method, + the bounds as given and as applied, and the weights moved, which the printed + weights report. The new `is_wt_truncated()` and `is_unit_wt_truncated()` + read that record, apart from `is_ps_truncated()` and `is_unit_truncated()`, + which describe a truncated propensity score. Weights truncated at different + bounds do not combine. + * `ps_trim()` now trims a model of a continuous exposure on the scale of its conditional density. A `lm`, a `glm` whose variance is constant, a `MASS::rlm()`, or an `mgcv::gam()` of the dose can be trimmed with diff --git a/R/psw.R b/R/psw.R index f6c5c341..5a8f4ab0 100644 --- a/R/psw.R +++ b/R/psw.R @@ -75,12 +75,12 @@ #' different estimands are pasted together, and an estimand only one operand #' names stands for the result; the result is stabilized only when both operands #' are, and it is marked as trimmed, truncated, calibrated, or weight-truncated -#' when either operand is. The remaining attributes, the `stabilization_score`, the records -#' left by a modified propensity score, the attributes describing a categorical -#' exposure, and the exposure records, are carried by agreement: one only a -#' single operand records carries, and one both record with the same value -#' carries. One they record differently is dropped, since neither value -#' describes the result, and a warning of class +#' when either operand is. The remaining attributes, the +#' `stabilization_score`, the records left by a modified propensity score, the +#' attributes describing a categorical exposure, and the exposure records, are +#' carried by agreement: one only a single operand records carries, and one +#' both record with the same value carries. One they record differently is +#' dropped, since neither value describes the result, and a warning of class #' `propensity_metadata_conflict_warning` names it, once for each attribute #' dropped that way and whatever order the inputs were given in. The rule is #' applied per operation, so an attribute one operation drops for a @@ -138,14 +138,14 @@ #' model fit on them still carrying a record written for rows that are no #' longer there. #' -#' Honesty therefore lives at query time. [is_unit_trimmed()] and -#' [is_unit_truncated()] answer by position, as does [is_unit_wt_truncated()], so each checks that the record -#' covers the vector it is given and raises an error of class -#' `propensity_missing_meta_error` when it does not, or when weights marked as -#' modified carry no record at all, rather than name modified units at stale -#' positions. [is_refit()] reads a single flag rather than a position, so it -#' answers from any record present and refuses only when the record is absent -#' entirely. +#' Honesty therefore lives at query time. [is_unit_trimmed()], +#' [is_unit_truncated()], and [is_unit_wt_truncated()] answer by position, so +#' each checks that the record covers the vector it is given and raises an +#' error of class `propensity_missing_meta_error` when it does not, or when +#' weights marked as modified carry no record at all, rather than name modified +#' units at stale positions. [is_refit()] reads a single flag rather than a +#' position, so it answers from any record present and refuses only when the +#' record is absent entirely. #' #' The result of any of these operations stays a `psw` and keeps every other #' attribute, including its stabilized, trimmed, truncated, and calibrated @@ -1030,17 +1030,22 @@ obj_print_footer.psw <- function(x, ...) { # estimated the numerator is named there, among the rest of the ratio. if (!is.null(meta)) { writeLines(format(meta)) - - return(invisible(x)) + } else { + # Weights that are not a ratio of densities record no ratio and print none. + # A numerator the caller's model estimated is still worth naming, the + # reader's question being the same one either way: which numerator are + # these weights divided by. + formula <- density_meta_model_formula(numerator_model(x)) + if (!is.null(formula)) { + writeLines(paste("stabilize:", formula)) + } } - # Weights that are not a ratio of densities record no ratio and print none. - # A numerator the caller's model estimated is still worth naming, the - # reader's question being the same one either way: which numerator are these - # weights divided by. - formula <- density_meta_model_formula(numerator_model(x)) - if (!is.null(formula)) { - writeLines(paste("stabilize:", formula)) + # A bound on the weights themselves is reported after whatever describes how + # they were built, since it was applied to them afterwards. + truncation <- format_psw_trunc_line(x) + if (!is.null(truncation)) { + writeLines(truncation) } invisible(x) @@ -1768,9 +1773,9 @@ vec_restore.psw <- function(x, to, ...) { # modification of the propensity scores they were built from, and whether the # weights themselves were truncated. The bound a truncation applied is left out: # a cast is also how a psw is checked against its own prototype, which carries -# no record, so the bound is compared only where two inputs combine. `vec_ptype2()` and -# `vec_cast()` read the same set, so weights that combine without complaint are -# also each other's type. +# no record, so the bound is compared only where two inputs combine. +# `vec_ptype2()` and `vec_cast()` read the same set, so weights that combine +# without complaint are also each other's type. psw_type_fields <- function(x) { list( estimand = estimand(x), diff --git a/R/wt_trunc.R b/R/wt_trunc.R new file mode 100644 index 00000000..8c3675dd --- /dev/null +++ b/R/wt_trunc.R @@ -0,0 +1,625 @@ +#' Truncate (Winsorize) Propensity Score Weights +#' +#' `wt_trunc()` bounds extreme weights at a limit read on the scale of the +#' weights themselves, replacing each weight beyond the limit with the limit. +#' No unit is removed. Where [ps_trunc()] bounds the propensity scores the +#' weights are built from, `wt_trunc()` bounds the weights after they are +#' built, so it applies to weights for any exposure type, including the +#' density-ratio weights of a continuous exposure, which have no propensity +#' score to bound. +#' +#' @param .weights A [psw] vector, such as one returned by [wt_ate()], or a +#' numeric vector of weights. A numeric vector is returned as a [psw] vector +#' with no estimand. Propensity scores, including those returned by +#' [ps_trim()], [ps_trunc()], and [ps_calibrate()], are refused with an error +#' of class `propensity_type_error`: build weights from them first. +#' @param method The rule that sets the bound: +#' * `"adaptive"` (default): an upper bound of \eqn{\sqrt{n} \log(n) / 5} +#' (Gruber et al., 2022), where \eqn{n} is the number of weights present. +#' * `"wt"`: bounds given as weight values. +#' * `"pctl"`: bounds read at sample quantiles of the weights. +#' * `"count"`: bounds that move a given number of the most extreme weights. +#' @param lower,upper The bounds, read according to `method`: +#' * `"adaptive"`: not used. Supplying either is ignored with a warning. +#' * `"wt"`: `upper` is required and must be a positive finite number. +#' `lower` is optional and must be a finite number of at least 0 and below +#' `upper`. +#' * `"pctl"`: `upper` is required and must lie in (0.5, 1). `lower` is +#' optional and must lie in (0, 0.5). +#' * `"count"`: `upper` is required and must be a whole number of at least 1; +#' the `upper` largest weights are bounded at the next largest. `lower` is +#' optional and bounds the `lower` smallest weights at the next smallest in +#' the same way. +#' @param ... Not used. Any argument supplied here is an error, so that a +#' misspelled bound is not silently ignored. +#' +#' @details +#' ## Methods +#' +#' `"adaptive"` is the default. Its bound depends on the sample size alone and +#' loosens as the sample grows: at \eqn{n = 1000} it is 43.7. Gruber et al. +#' (2022) derived it for the propensity score of a binary treatment, choosing a +#' bound that loosens with the sample so that its bias shrinks. Whether the +#' rule carries over to the density-ratio weights of a continuous exposure has +#' not been established in the literature. Here \eqn{n} counts the weights that +#' are present, so for weights built from a trimmed propensity score, whose +#' trimmed units are `NA`, it is the number of units kept by the trim. The +#' bound is below 1 for \eqn{n \le 6} (0.72 at \eqn{n = 5}), so for a sample +#' that small `"adaptive"` pulls every weight above that value down to a +#' constant below 1. +#' +#' `"wt"` winsorizes at the values given, and `"count"` at the order statistic +#' next to the weights it bounds. Under `"count"`, a weight tied with that +#' order statistic is not moved, so fewer weights than `upper` may change. The +#' two counts must leave at least two weights between them, and `upper` alone +#' must leave at least one weight below it. +#' +#' `"pctl"` reads its bounds with [stats::quantile()] at its default type, as +#' `ps_trunc(method = "pctl")` does. Because such a rule moves a fixed share of +#' the units however the weights are distributed, it is best used to check how +#' sensitive an analysis is to its bound rather than as the bound itself. An +#' `upper` below 0.5 is refused rather than read as the other tail: write +#' `upper = 0.9` to bound the upper tail at the 0.9 quantile, or +#' `lower = 0.1` to bound the lower tail at the 0.1 quantile. +#' +#' `"adaptive"` and `"pctl"` need at least two weights present, and every +#' method leaves a missing weight missing. +#' +#' ## One-sided by default +#' +#' Each method bounds only the upper tail unless `lower` is supplied, and +#' `"adaptive"`, which takes no `lower`, always bounds only the upper tail. +#' The largest weights are the ones that dominate an estimate; small weights +#' contribute little to it, so bounding them changes little. `lower` bounds the +#' lower tail when that is wanted. +#' +#' ## What is recorded +#' +#' The result keeps every attribute of `.weights`: the stabilization status and +#' any numerator model, the density record of a continuous exposure, the +#' attributes of a categorical exposure, and the records left by [ps_trim()], +#' [ps_trunc()], or [ps_calibrate()]. It gains a `wt_truncated` flag, read by +#' [is_wt_truncated()], and a record of the method, the bounds as given and as +#' applied, and the positions of the weights moved, read by +#' [is_unit_wt_truncated()]. The record is positional and is dropped by any +#' operation that changes the length of the weights; see [psw]. +#' +#' The estimand gains the label `"; weights truncated"`, as in +#' `"ate; weights truncated"`. A truncated weight targets a different quantity +#' from the weight before truncation: any fixed bound introduces a bias (Ma and +#' Wang, 2020; Gruber et al., 2022), and an interval computed with the +#' truncated weights held fixed is an interval for that quantity. A weight +#' truncation does not describe the same operation as truncating the propensity +#' score, which is labeled `"; truncated"` and reported by [is_ps_truncated()]. +#' +#' Weights that have already been truncated are returned unchanged with a +#' warning of class `propensity_already_modified_warning`. One record describes +#' one truncation, so to truncate at a different bound, call `wt_trunc()` on +#' the original weights. +#' +#' ## Weights from a trimmed, truncated, or calibrated score +#' +#' Weights built from a score modified by [ps_trim()], [ps_trunc()], or +#' [ps_calibrate()] can be truncated as well. The result carries both records, +#' and the labels stack, as in `"ate; trimmed; weights truncated"`. The package +#' does not prevent combining these tools. +#' +#' ## Effect estimation +#' +#' [ipw()] does not accept weights whose values were truncated, because its +#' standard errors do not account for the bound. An analysis with truncated +#' weights needs an interval built another way: one computed with the weights +#' held fixed, which conditions on the bound applied, or a bootstrap that +#' repeats the truncation in every resample, which a percentile bound in +#' particular needs, since that bound is itself estimated from the weights. +#' +#' To see how much a truncation changed the effective sample size, add the +#' weights before and after it to a data frame as separate columns and pass +#' both to `halfmoon::check_ess()`. +#' +#' @return A [psw] vector of the same length as `.weights`, with the bounded +#' values, the estimand labeled as truncated, and a record of the truncation. +#' +#' @references +#' Gruber, S., Phillips, R. V., Lee, H., & van der Laan, M. J. (2022). +#' Data-adaptive selection of the propensity score truncation level for +#' inverse-probability-weighted and targeted maximum likelihood estimators of +#' marginal point treatment effects. *American Journal of Epidemiology*, +#' 191(9), 1640--1651. +#' +#' Ma, X., & Wang, J. (2020). Robust inference using inverse probability +#' weighting. *Journal of the American Statistical Association*, 115(532), +#' 1851--1860. +#' +#' @seealso [is_wt_truncated()] and [is_unit_wt_truncated()] to read the +#' record, [ps_trunc()] to bound propensity scores instead, and [ps_trim()] +#' to remove units. +#' +#' @examples +#' set.seed(1) +#' n <- 50 +#' x <- rnorm(n) +#' z <- rbinom(n, 1, plogis(2 * x)) +#' fit <- glm(z ~ x, family = binomial) +#' w <- wt_ate(fit, .exposure = z) +#' +#' # The adaptive bound, on the upper tail +#' w_adaptive <- wt_trunc(w) +#' w_adaptive +#' is_wt_truncated(w_adaptive) +#' which(is_unit_wt_truncated(w_adaptive)) +#' +#' # A bound given as a weight, on one tail or both +#' wt_trunc(w, method = "wt", upper = 5) +#' wt_trunc(w, method = "wt", lower = 1.05, upper = 5) +#' +#' # The 99th percentile, as a sensitivity check +#' wt_trunc(w, method = "pctl", upper = 0.99) +#' +#' # The three largest weights, bounded at the fourth largest +#' wt_trunc(w, method = "count", upper = 3) +#' +#' # Weights for a continuous exposure +#' a <- 1 + 0.5 * x + rnorm(n) +#' dose <- lm(a ~ x) +#' w_dose <- wt_ate(dose, .exposure = a) +#' wt_trunc(w_dose) +#' +#' # Weights from a trimmed propensity score carry both records +#' trimmed <- ps_refit(ps_trim(fit, lower = 0.05, upper = 0.95), fit) +#' wt_trunc(wt_ate(trimmed, .exposure = z), method = "wt", upper = 5) +#' +#' @export +wt_trunc <- function( + .weights, + method = c("adaptive", "wt", "pctl", "count"), + lower = NULL, + upper = NULL, + ... +) { + UseMethod("wt_trunc") +} + +#' @export +wt_trunc.default <- function( + .weights, + method = c("adaptive", "wt", "pctl", "count"), + lower = NULL, + upper = NULL, + ... +) { + abort( + c( + "{.arg .weights} must be a numeric vector of weights.", + x = "It is {.cls {class(.weights)[[1]]}}, which holds no weights to + bound.", + i = "Pass a {.cls psw} vector, such as one {.fun wt_ate} returns." + ), + error_class = "propensity_type_error", + call = rlang::current_env() + ) +} + +#' @export +wt_trunc.numeric <- function( + .weights, + method = c("adaptive", "wt", "pctl", "count"), + lower = NULL, + upper = NULL, + ... +) { + call <- rlang::current_env() + rlang::check_dots_empty(call = call) + method <- rlang::arg_match(method, error_call = call) + + # `psw()` drops every attribute of what it is given, names included, and the + # names identify the units the weights belong to. + weights <- psw(.weights) + names(weights) <- names(.weights) + + truncate_weights(weights, method, lower, upper, call = call) +} + +#' @export +wt_trunc.psw <- function( + .weights, + method = c("adaptive", "wt", "pctl", "count"), + lower = NULL, + upper = NULL, + ... +) { + call <- rlang::current_env() + rlang::check_dots_empty(call = call) + method <- rlang::arg_match(method, error_call = call) + + if (is_wt_truncated(.weights)) { + warn( + c( + "These weights have already been truncated. Returning them unchanged.", + i = "To truncate at a different bound, call {.fun wt_trunc} on the + original weights." + ), + warning_class = "propensity_already_modified_warning", + call = call + ) + return(.weights) + } + + truncate_weights(.weights, method, lower, upper, call = call) +} + +#' @export +wt_trunc.ps_trim <- function(.weights, ...) { + abort_wt_trunc_scores(.weights, call = rlang::current_env()) +} + +#' @export +wt_trunc.ps_trunc <- function(.weights, ...) { + abort_wt_trunc_scores(.weights, call = rlang::current_env()) +} + +#' @export +wt_trunc.ps_calib <- function(.weights, ...) { + abort_wt_trunc_scores(.weights, call = rlang::current_env()) +} + +# A modified propensity score is a vector of numbers between 0 and 1, and +# bounding it as though it were a weight would bound the wrong quantity without +# complaint. +abort_wt_trunc_scores <- function(.weights, call = rlang::caller_env()) { + abort( + c( + "{.arg .weights} must be weights, not propensity scores.", + x = "It is {.cls {class(.weights)[[1]]}}, a modified propensity score.", + i = "Build weights from it with a weight function such as {.fun wt_ate} + and truncate those, or bound the scores themselves with + {.fun ps_trunc}." + ), + error_class = "propensity_type_error", + call = call + ) +} + +# Winsorize a psw at the bounds `method` reads from `lower` and `upper`, and +# write the result back over the original so that every attribute the +# truncation does not describe is kept. +truncate_weights <- function(.weights, method, lower, upper, call) { + # A psw holds doubles, and `vec_data()` keeps the names the weights carry. + x <- vec_data(.weights) + present <- x[!is.na(x)] + + bounds <- switch( + method, + adaptive = wt_trunc_adaptive_bounds(present, lower, upper, call = call), + wt = wt_trunc_wt_bounds(lower, upper, call = call), + pctl = wt_trunc_pctl_bounds(present, lower, upper, call = call), + count = wt_trunc_count_bounds(present, lower, upper, call = call) + ) + + # A missing weight compares as neither above nor below a bound, and `which()` + # drops it, so it is left missing and is not among the weights moved. + low <- integer() + if (!is.null(bounds$lower_value)) { + low <- which(x < bounds$lower_value) + x[low] <- bounds$lower_value + } + high <- which(x > bounds$upper_value) + x[high] <- bounds$upper_value + + meta <- new_psw_trunc_meta( + method = method, + lower = bounds$lower, + upper = bounds$upper, + lower_value = bounds$lower_value, + upper_value = bounds$upper_value, + truncated_idx = sort(c(low, high)), + n_obs = length(x) + ) + + out <- vec_restore(x, .weights) + estimand <- estimand(.weights) + if (!is.null(estimand)) { + attr(out, "estimand") <- paste0(estimand, "; weights truncated") + } + attr(out, "wt_truncated") <- TRUE + attr(out, "psw_trunc_meta") <- meta + + # The restore rebuilds the attributes in its own order. Putting them back in + # the order the weights arrived with leaves the attributes the truncation did + # not touch exactly as they were, with the record following them. + attrs <- attributes(out) + arrived <- intersect(names(attributes(.weights)), names(attrs)) + attributes(out) <- attrs[union(arrived, names(attrs))] + + out +} + +wt_trunc_adaptive_bounds <- function(present, lower, upper, call) { + if (!is.null(lower) || !is.null(upper)) { + warn( + c( + "For {.code method = 'adaptive'}, {.arg lower} and {.arg upper} are + ignored.", + i = "The adaptive bound is set by the number of weights. To give a + bound yourself, use {.code method = 'wt'}." + ), + call = call + ) + } + + check_wt_trunc_n_present(present, "adaptive", call = call) + n <- length(present) + + list( + lower = NULL, + upper = NULL, + lower_value = NULL, + upper_value = sqrt(n) * log(n) / 5 + ) +} + +wt_trunc_wt_bounds <- function(lower, upper, call) { + upper <- wt_trunc_bound_arg(upper, "upper", "wt", call = call) + lower <- wt_trunc_bound_arg(lower, "lower", "wt", call = call) + + if (upper <= 0) { + abort_wt_trunc_range( + "For {.code method = 'wt'}, {.arg upper} must be a positive weight.", + "{.arg upper} is {upper}.", + call = call + ) + } + + if (!is.null(lower)) { + if (lower < 0) { + abort_wt_trunc_range( + "For {.code method = 'wt'}, {.arg lower} must be zero or more.", + "{.arg lower} is {lower}, and a weight is never negative.", + call = call + ) + } + if (lower >= upper) { + abort_wt_trunc_range( + "{.arg lower} must be smaller than {.arg upper}.", + "{.arg lower} is {lower} and {.arg upper} is {upper}.", + call = call + ) + } + } + + list(lower = lower, upper = upper, lower_value = lower, upper_value = upper) +} + +wt_trunc_pctl_bounds <- function(present, lower, upper, call) { + upper <- wt_trunc_bound_arg(upper, "upper", "pctl", call = call) + lower <- wt_trunc_bound_arg(lower, "lower", "pctl", call = call) + + # Read as a lower tail, a probability below one half names a real request, + # so both readings are offered rather than one chosen for the caller. + if (upper > 0 && upper < 0.5) { + abort( + c( + "For {.code method = 'pctl'}, {.arg upper} must be between 0.5 and 1.", + x = "{.arg upper} is {upper}, which is in the lower tail.", + i = "To bound the upper tail write {.code upper = {1 - upper}}; to + bound the lower tail write {.code lower = {upper}}." + ), + error_class = "propensity_range_error", + call = call + ) + } + if (!(upper > 0.5 && upper < 1)) { + abort_wt_trunc_range( + "For {.code method = 'pctl'}, {.arg upper} must be between 0.5 and 1.", + "{.arg upper} is {upper}.", + call = call + ) + } + if (!is.null(lower) && !(lower > 0 && lower < 0.5)) { + abort_wt_trunc_range( + "For {.code method = 'pctl'}, {.arg lower} must be between 0 and 0.5.", + "{.arg lower} is {lower}.", + call = call + ) + } + + check_wt_trunc_n_present(present, "pctl", call = call) + + # `quantile()` names its result for the probability, which says nothing + # about the bound and would reappear wherever the bound is compared. + lower_value <- NULL + if (!is.null(lower)) { + lower_value <- unname(quantile(present, probs = lower)) + } + + list( + lower = lower, + upper = upper, + lower_value = lower_value, + upper_value = unname(quantile(present, probs = upper)) + ) +} + +wt_trunc_count_bounds <- function(present, lower, upper, call) { + upper <- wt_trunc_bound_arg(upper, "upper", "count", call = call) + lower <- wt_trunc_bound_arg(lower, "lower", "count", call = call) + + check_wt_trunc_count(upper, "upper", call = call) + check_wt_trunc_count(lower, "lower", call = call) + + n <- length(present) + if (is.null(lower) && upper > n - 1) { + abort_wt_trunc_range( + "For {.code method = 'count'}, {.arg upper} must leave a weight below + the ones it bounds.", + "{.arg upper} is {upper} and {n} weight{?s} {?is/are} present.", + call = call + ) + } + if (!is.null(lower) && lower + upper > n - 2) { + abort_wt_trunc_range( + "For {.code method = 'count'}, {.arg lower} and {.arg upper} must leave + at least two weights between them.", + "{.arg lower} is {lower}, {.arg upper} is {upper}, and {n} weight{?s} + {?is/are} present.", + call = call + ) + } + + sorted <- sort(present) + lower_value <- NULL + if (!is.null(lower)) { + lower_value <- sorted[[lower + 1]] + } + + list( + lower = lower, + upper = upper, + lower_value = lower_value, + upper_value = sorted[[n - upper]] + ) +} + +check_wt_trunc_count <- function(value, arg, call) { + if (is.null(value) || (value >= 1 && value == round(value))) { + return(invisible(TRUE)) + } + + abort_wt_trunc_range( + "For {.code method = 'count'}, {.arg {arg}} must be a whole number of at + least 1.", + "{.arg {arg}} is {value}.", + call = call + ) +} + +# A bound as the caller gave it, checked for the things every method needs and +# stored as a double: the record's bounds are compared with `identical()` when +# truncated weights are combined, so an integer and a double giving the same +# bound must be recorded the same way. +wt_trunc_bound_arg <- function(value, arg, method, call) { + if (is.null(value)) { + if (arg == "lower") { + return(NULL) + } + abort( + c( + "For {.code method = '{method}'}, {.arg upper} is required.", + i = "Supply the bound, or use {.code method = 'adaptive'} to have it + set from the number of weights." + ), + error_class = "propensity_missing_arg_error", + call = call + ) + } + + if (anyNA(value)) { + abort( + c( + "{.arg {arg}} must not be missing.", + i = "A missing bound decides nothing about which weights to move. + Supply a value, or leave {.arg lower} unset to bound only the + upper tail." + ), + error_class = "propensity_missing_value_error", + call = call + ) + } + + if (!is.numeric(value)) { + abort( + c( + "{.arg {arg}} must be a number.", + x = "It is {.cls {class(value)[[1]]}}." + ), + error_class = "propensity_type_error", + call = call + ) + } + + if (length(value) == 0L) { + abort_wt_trunc_range( + "{.arg {arg}} must be a single finite number.", + "{.arg {arg}} has length 0.", + call = call + ) + } + if (length(value) != 1L || !is.finite(value)) { + abort_wt_trunc_range( + "{.arg {arg}} must be a single finite number.", + "{.arg {arg}} has length {length(value)} and value{?s} {value}.", + call = call + ) + } + + as.double(value) +} + +check_wt_trunc_n_present <- function(present, method, call) { + n <- length(present) + if (n >= 2) { + return(invisible(TRUE)) + } + + abort_wt_trunc_range( + "For {.code method = '{method}'}, at least two weights must be present.", + "{n} weight{?s} {?is/are} present.", + call = call + ) +} + +abort_wt_trunc_range <- function( + problem, + detail, + call, + .envir = parent.frame() +) { + abort( + c(problem, x = detail), + error_class = "propensity_range_error", + call = call, + .envir = .envir + ) +} + +# One line describing the truncation for the printed footer, or `NULL` for +# weights that were not truncated. The counts come from the record's positions, +# so a record that no longer covers the weights is not read for them. +format_psw_trunc_line <- function(x) { + if (!is_wt_truncated(x)) { + return(NULL) + } + + meta <- attr(x, "psw_trunc_meta") + if (!record_covers(meta, length(x))) { + return("truncation: weights truncated") + } + + given <- c(meta$lower, meta$upper) + label <- meta$method + if (meta$method %in% c("pctl", "count")) { + label <- paste( + label, + paste(vapply(given, format, character(1)), collapse = "/") + ) + } + + realized <- c( + if (!is.null(meta$lower_value)) { + paste("lower", format(meta$lower_value, digits = 3)) + }, + paste("upper", format(meta$upper_value, digits = 3)) + ) + + paste0( + "truncation: ", + label, + " (", + paste(realized, collapse = ", "), + "), ", + length(meta$truncated_idx), + " of ", + meta$n_obs, + " weights truncated" + ) +} diff --git a/_pkgdown.yml b/_pkgdown.yml index 550ddeca..41d7bc85 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -48,12 +48,14 @@ reference: - ps_refit - is_refit - title: Truncation - desc: Bound extreme propensity scores in place rather than dropping them. + desc: Bound extreme propensity scores, or the weights built from them, in + place rather than dropping them. contents: - ps_trunc - ps_trunc_meta - is_ps_truncated - is_unit_truncated + - wt_trunc - title: Calibration and tilting desc: Recalibrate fitted propensity scores, and evaluate the tilting function an estimand implies. diff --git a/inst/WORDLIST b/inst/WORDLIST index da26b2e9..d21687c1 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -23,6 +23,7 @@ Feng Gerke Geskus Greifer +Gruber HC Hajage Hajek @@ -37,6 +38,7 @@ JK JM Kadziola Kostouraki +Laan Lauer Leyrat Lunceford diff --git a/man/psw.Rd b/man/psw.Rd index fe48f734..235d383a 100644 --- a/man/psw.Rd +++ b/man/psw.Rd @@ -160,12 +160,12 @@ An operation between two \code{psw} objects merges what each of them records. Tw different estimands are pasted together, and an estimand only one operand names stands for the result; the result is stabilized only when both operands are, and it is marked as trimmed, truncated, calibrated, or weight-truncated -when either operand is. The remaining attributes, the \code{stabilization_score}, the records -left by a modified propensity score, the attributes describing a categorical -exposure, and the exposure records, are carried by agreement: one only a -single operand records carries, and one both record with the same value -carries. One they record differently is dropped, since neither value -describes the result, and a warning of class +when either operand is. The remaining attributes, the +\code{stabilization_score}, the records left by a modified propensity score, the +attributes describing a categorical exposure, and the exposure records, are +carried by agreement: one only a single operand records carries, and one +both record with the same value carries. One they record differently is +dropped, since neither value describes the result, and a warning of class \code{propensity_metadata_conflict_warning} names it, once for each attribute dropped that way and whatever order the inputs were given in. The rule is applied per operation, so an attribute one operation drops for a @@ -223,14 +223,14 @@ weights built on trimmed propensity scores come back out of every outcome model fit on them still carrying a record written for rows that are no longer there. -Honesty therefore lives at query time. \code{\link[=is_unit_trimmed]{is_unit_trimmed()}} and -\code{\link[=is_unit_truncated]{is_unit_truncated()}} answer by position, as does \code{\link[=is_unit_wt_truncated]{is_unit_wt_truncated()}}, so each checks that the record -covers the vector it is given and raises an error of class -\code{propensity_missing_meta_error} when it does not, or when weights marked as -modified carry no record at all, rather than name modified units at stale -positions. \code{\link[=is_refit]{is_refit()}} reads a single flag rather than a position, so it -answers from any record present and refuses only when the record is absent -entirely. +Honesty therefore lives at query time. \code{\link[=is_unit_trimmed]{is_unit_trimmed()}}, +\code{\link[=is_unit_truncated]{is_unit_truncated()}}, and \code{\link[=is_unit_wt_truncated]{is_unit_wt_truncated()}} answer by position, so +each checks that the record covers the vector it is given and raises an +error of class \code{propensity_missing_meta_error} when it does not, or when +weights marked as modified carry no record at all, rather than name modified +units at stale positions. \code{\link[=is_refit]{is_refit()}} reads a single flag rather than a +position, so it answers from any record present and refuses only when the +record is absent entirely. The result of any of these operations stays a \code{psw} and keeps every other attribute, including its stabilized, trimmed, truncated, and calibrated diff --git a/man/wt_trunc.Rd b/man/wt_trunc.Rd new file mode 100644 index 00000000..ec3c6844 --- /dev/null +++ b/man/wt_trunc.Rd @@ -0,0 +1,200 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/wt_trunc.R +\name{wt_trunc} +\alias{wt_trunc} +\title{Truncate (Winsorize) Propensity Score Weights} +\usage{ +wt_trunc( + .weights, + method = c("adaptive", "wt", "pctl", "count"), + lower = NULL, + upper = NULL, + ... +) +} +\arguments{ +\item{.weights}{A \link{psw} vector, such as one returned by \code{\link[=wt_ate]{wt_ate()}}, or a +numeric vector of weights. A numeric vector is returned as a \link{psw} vector +with no estimand. Propensity scores, including those returned by +\code{\link[=ps_trim]{ps_trim()}}, \code{\link[=ps_trunc]{ps_trunc()}}, and \code{\link[=ps_calibrate]{ps_calibrate()}}, are refused with an error +of class \code{propensity_type_error}: build weights from them first.} + +\item{method}{The rule that sets the bound: +\itemize{ +\item \code{"adaptive"} (default): an upper bound of \eqn{\sqrt{n} \log(n) / 5} +(Gruber et al., 2022), where \eqn{n} is the number of weights present. +\item \code{"wt"}: bounds given as weight values. +\item \code{"pctl"}: bounds read at sample quantiles of the weights. +\item \code{"count"}: bounds that move a given number of the most extreme weights. +}} + +\item{lower, upper}{The bounds, read according to \code{method}: +\itemize{ +\item \code{"adaptive"}: not used. Supplying either is ignored with a warning. +\item \code{"wt"}: \code{upper} is required and must be a positive finite number. +\code{lower} is optional and must be a finite number of at least 0 and below +\code{upper}. +\item \code{"pctl"}: \code{upper} is required and must lie in (0.5, 1). \code{lower} is +optional and must lie in (0, 0.5). +\item \code{"count"}: \code{upper} is required and must be a whole number of at least 1; +the \code{upper} largest weights are bounded at the next largest. \code{lower} is +optional and bounds the \code{lower} smallest weights at the next smallest in +the same way. +}} + +\item{...}{Not used. Any argument supplied here is an error, so that a +misspelled bound is not silently ignored.} +} +\value{ +A \link{psw} vector of the same length as \code{.weights}, with the bounded +values, the estimand labeled as truncated, and a record of the truncation. +} +\description{ +\code{wt_trunc()} bounds extreme weights at a limit read on the scale of the +weights themselves, replacing each weight beyond the limit with the limit. +No unit is removed. Where \code{\link[=ps_trunc]{ps_trunc()}} bounds the propensity scores the +weights are built from, \code{wt_trunc()} bounds the weights after they are +built, so it applies to weights for any exposure type, including the +density-ratio weights of a continuous exposure, which have no propensity +score to bound. +} +\details{ +\subsection{Methods}{ + +\code{"adaptive"} is the default. Its bound depends on the sample size alone and +loosens as the sample grows: at \eqn{n = 1000} it is 43.7. Gruber et al. +(2022) derived it for the propensity score of a binary treatment, choosing a +bound that loosens with the sample so that its bias shrinks. Whether the +rule carries over to the density-ratio weights of a continuous exposure has +not been established in the literature. Here \eqn{n} counts the weights that +are present, so for weights built from a trimmed propensity score, whose +trimmed units are \code{NA}, it is the number of units kept by the trim. The +bound is below 1 for \eqn{n \le 6} (0.72 at \eqn{n = 5}), so for a sample +that small \code{"adaptive"} pulls every weight above that value down to a +constant below 1. + +\code{"wt"} winsorizes at the values given, and \code{"count"} at the order statistic +next to the weights it bounds. Under \code{"count"}, a weight tied with that +order statistic is not moved, so fewer weights than \code{upper} may change. The +two counts must leave at least two weights between them, and \code{upper} alone +must leave at least one weight below it. + +\code{"pctl"} reads its bounds with \code{\link[stats:quantile]{stats::quantile()}} at its default type, as +\code{ps_trunc(method = "pctl")} does. Because such a rule moves a fixed share of +the units however the weights are distributed, it is best used to check how +sensitive an analysis is to its bound rather than as the bound itself. An +\code{upper} below 0.5 is refused rather than read as the other tail: write +\code{upper = 0.9} to bound the upper tail at the 0.9 quantile, or +\code{lower = 0.1} to bound the lower tail at the 0.1 quantile. + +\code{"adaptive"} and \code{"pctl"} need at least two weights present, and every +method leaves a missing weight missing. +} + +\subsection{One-sided by default}{ + +Each method bounds only the upper tail unless \code{lower} is supplied, and +\code{"adaptive"}, which takes no \code{lower}, always bounds only the upper tail. +The largest weights are the ones that dominate an estimate; small weights +contribute little to it, so bounding them changes little. \code{lower} bounds the +lower tail when that is wanted. +} + +\subsection{What is recorded}{ + +The result keeps every attribute of \code{.weights}: the stabilization status and +any numerator model, the density record of a continuous exposure, the +attributes of a categorical exposure, and the records left by \code{\link[=ps_trim]{ps_trim()}}, +\code{\link[=ps_trunc]{ps_trunc()}}, or \code{\link[=ps_calibrate]{ps_calibrate()}}. It gains a \code{wt_truncated} flag, read by +\code{\link[=is_wt_truncated]{is_wt_truncated()}}, and a record of the method, the bounds as given and as +applied, and the positions of the weights moved, read by +\code{\link[=is_unit_wt_truncated]{is_unit_wt_truncated()}}. The record is positional and is dropped by any +operation that changes the length of the weights; see \link{psw}. + +The estimand gains the label \code{"; weights truncated"}, as in +\code{"ate; weights truncated"}. A truncated weight targets a different quantity +from the weight before truncation: any fixed bound introduces a bias (Ma and +Wang, 2020; Gruber et al., 2022), and an interval computed with the +truncated weights held fixed is an interval for that quantity. A weight +truncation does not describe the same operation as truncating the propensity +score, which is labeled \code{"; truncated"} and reported by \code{\link[=is_ps_truncated]{is_ps_truncated()}}. + +Weights that have already been truncated are returned unchanged with a +warning of class \code{propensity_already_modified_warning}. One record describes +one truncation, so to truncate at a different bound, call \code{wt_trunc()} on +the original weights. +} + +\subsection{Weights from a trimmed, truncated, or calibrated score}{ + +Weights built from a score modified by \code{\link[=ps_trim]{ps_trim()}}, \code{\link[=ps_trunc]{ps_trunc()}}, or +\code{\link[=ps_calibrate]{ps_calibrate()}} can be truncated as well. The result carries both records, +and the labels stack, as in \code{"ate; trimmed; weights truncated"}. The package +does not prevent combining these tools. +} + +\subsection{Effect estimation}{ + +\code{\link[=ipw]{ipw()}} does not accept weights whose values were truncated, because its +standard errors do not account for the bound. An analysis with truncated +weights needs an interval built another way: one computed with the weights +held fixed, which conditions on the bound applied, or a bootstrap that +repeats the truncation in every resample, which a percentile bound in +particular needs, since that bound is itself estimated from the weights. + +To see how much a truncation changed the effective sample size, add the +weights before and after it to a data frame as separate columns and pass +both to \code{halfmoon::check_ess()}. +} +} +\examples{ +set.seed(1) +n <- 50 +x <- rnorm(n) +z <- rbinom(n, 1, plogis(2 * x)) +fit <- glm(z ~ x, family = binomial) +w <- wt_ate(fit, .exposure = z) + +# The adaptive bound, on the upper tail +w_adaptive <- wt_trunc(w) +w_adaptive +is_wt_truncated(w_adaptive) +which(is_unit_wt_truncated(w_adaptive)) + +# A bound given as a weight, on one tail or both +wt_trunc(w, method = "wt", upper = 5) +wt_trunc(w, method = "wt", lower = 1.05, upper = 5) + +# The 99th percentile, as a sensitivity check +wt_trunc(w, method = "pctl", upper = 0.99) + +# The three largest weights, bounded at the fourth largest +wt_trunc(w, method = "count", upper = 3) + +# Weights for a continuous exposure +a <- 1 + 0.5 * x + rnorm(n) +dose <- lm(a ~ x) +w_dose <- wt_ate(dose, .exposure = a) +wt_trunc(w_dose) + +# Weights from a trimmed propensity score carry both records +trimmed <- ps_refit(ps_trim(fit, lower = 0.05, upper = 0.95), fit) +wt_trunc(wt_ate(trimmed, .exposure = z), method = "wt", upper = 5) + +} +\references{ +Gruber, S., Phillips, R. V., Lee, H., & van der Laan, M. J. (2022). +Data-adaptive selection of the propensity score truncation level for +inverse-probability-weighted and targeted maximum likelihood estimators of +marginal point treatment effects. \emph{American Journal of Epidemiology}, +191(9), 1640--1651. + +Ma, X., & Wang, J. (2020). Robust inference using inverse probability +weighting. \emph{Journal of the American Statistical Association}, 115(532), +1851--1860. +} +\seealso{ +\code{\link[=is_wt_truncated]{is_wt_truncated()}} and \code{\link[=is_unit_wt_truncated]{is_unit_wt_truncated()}} to read the +record, \code{\link[=ps_trunc]{ps_trunc()}} to bound propensity scores instead, and \code{\link[=ps_trim]{ps_trim()}} +to remove units. +} diff --git a/tests/testthat/_snaps/wt-trunc.md b/tests/testthat/_snaps/wt-trunc.md new file mode 100644 index 00000000..f7459d69 --- /dev/null +++ b/tests/testthat/_snaps/wt-trunc.md @@ -0,0 +1,172 @@ +# bounds supplied to the adaptive method are ignored with a warning + + Code + out <- wt_trunc(w, method = "adaptive", upper = 3) + Condition + Warning in `wt_trunc()`: + For `method = 'adaptive'`, `lower` and `upper` are ignored. + i The adaptive bound is set by the number of weights. To give a bound yourself, use `method = 'wt'`. + +# method = 'wt' refuses a bound it cannot apply + + Code + expr + Condition + Error in `wt_trunc()`: + ! For `method = 'wt'`, `upper` is required. + i Supply the bound, or use `method = 'adaptive'` to have it set from the number of weights. + +--- + + Code + expr + Condition + Error in `wt_trunc()`: + ! For `method = 'wt'`, `upper` must be a positive weight. + x `upper` is 0. + +--- + + Code + expr + Condition + Error in `wt_trunc()`: + ! `lower` must be smaller than `upper`. + x `lower` is 4 and `upper` is 3. + +# method = 'pctl' refuses an upper probability below one half and names both readings + + Code + expr + Condition + Error in `wt_trunc()`: + ! For `method = 'pctl'`, `upper` must be between 0.5 and 1. + x `upper` is 0.1, which is in the lower tail. + i To bound the upper tail write `upper = 0.9`; to bound the lower tail write `lower = 0.1`. + +# method = 'pctl' refuses probabilities outside their half of the unit interval + + Code + expr + Condition + Error in `wt_trunc()`: + ! For `method = 'pctl'`, `upper` must be between 0.5 and 1. + x `upper` is 1.5. + +--- + + Code + expr + Condition + Error in `wt_trunc()`: + ! For `method = 'pctl'`, `lower` must be between 0 and 0.5. + x `lower` is 0.6. + +# method = 'count' refuses counts that meet or cross + + Code + expr + Condition + Error in `wt_trunc()`: + ! For `method = 'count'`, `lower` and `upper` must leave at least two weights between them. + x `lower` is 4, `upper` is 4, and 9 weights are present. + +# method = 'count' refuses a count it cannot apply + + Code + expr + Condition + Error in `wt_trunc()`: + ! For `method = 'count'`, `upper` must be a whole number of at least 1. + x `upper` is 1.5. + +--- + + Code + expr + Condition + Error in `wt_trunc()`: + ! For `method = 'count'`, `upper` must leave a weight below the ones it bounds. + x `upper` is 9 and 9 weights are present. + +# a subset that drops the record prints a truncation line without counts + + Code + wt_trunc(w, method = "wt", upper = 3)[1:3] + Output + + [1] 0.5 1.0 3.0 + truncation: weights truncated + +# wt_trunc() refuses input that is not weights + + Code + expr + Condition + Error in `wt_trunc()`: + ! `.weights` must be a numeric vector of weights. + x It is , which holds no weights to bound. + i Pass a vector, such as one `wt_ate()` returns. + +# wt_trunc() refuses propensity scores + + Code + expr + Condition + Error in `wt_trunc()`: + ! `.weights` must be weights, not propensity scores. + x It is , a modified propensity score. + i Build weights from it with a weight function such as `wt_ate()` and truncate those, or bound the scores themselves with `ps_trunc()`. + +# the data-driven methods refuse fewer than two weights + + Code + expr + Condition + Error in `wt_trunc()`: + ! For `method = 'adaptive'`, at least two weights must be present. + x 1 weight is present. + +# truncating truncated weights warns and returns them unchanged + + Code + out <- wt_trunc(once, method = "wt", upper = 2) + Condition + Warning in `wt_trunc()`: + These weights have already been truncated. Returning them unchanged. + i To truncate at a different bound, call `wt_trunc()` on the original weights. + +# truncated weights print their bound and count + + Code + wt_trunc(w, method = "wt", upper = 20) + Output + + [1] 0.50 1.00 4.00 2.00 20.00 NA 0.02 + truncation: wt (upper 20), 1 of 7 weights truncated + Code + wt_trunc(w, method = "wt", lower = 0.05, upper = 20) + Output + + [1] 0.50 1.00 4.00 2.00 20.00 NA 0.05 + truncation: wt (lower 0.05, upper 20), 2 of 7 weights truncated + Code + wt_trunc(c(0.5, 1, 4, 2, 25), method = "count", upper = 1) + Output + + [1] 0.5 1.0 4.0 2.0 4.0 + truncation: count 1 (upper 4), 1 of 5 weights truncated + +--- + + Code + wt_trunc(weights, method = "pctl", upper = 0.9) + Output + + [1] 1.2601667 0.8158751 0.2876066 0.4445126 0.8514472 0.8062735 0.8305737 + [8] 1.2601667 0.6685880 0.7727881 0.6170081 0.8400276 + density: normal + numerator: marginal + sigma: pooled + truncation: pctl 0.9 (upper 1.26), 2 of 12 weights truncated + diff --git a/tests/testthat/test-wt-trunc.R b/tests/testthat/test-wt-trunc.R index a9e231fc..8ebb7307 100644 --- a/tests/testthat/test-wt-trunc.R +++ b/tests/testthat/test-wt-trunc.R @@ -757,6 +757,44 @@ test_that("a bare numeric vector becomes a truncated psw with no estimand", { expect_null(estimand(adaptive)) }) +test_that("the names on the weights are kept", { + unit_names <- paste0("u", 1:5) + x <- stats::setNames(c(0.5, 1, 4, 2, 25), unit_names) + w <- psw(x, estimand = "ate") + names(w) <- unit_names + + from_psw <- list( + wt = wt_trunc(w, method = "wt", upper = 3), + count = wt_trunc(w, method = "count", upper = 1) + ) + from_numeric <- list( + wt = wt_trunc(x, method = "wt", upper = 3), + count = wt_trunc(x, method = "count", upper = 1) + ) + + for (method in names(from_psw)) { + expect_identical(names(from_psw[[method]]), unit_names, info = method) + expect_identical(names(from_numeric[[method]]), unit_names, info = method) + } + expect_equal(unname(as.numeric(from_psw$wt)), c(0.5, 1, 3, 2, 3)) + expect_equal(unname(as.numeric(from_numeric$count)), c(0.5, 1, 4, 2, 4)) + + # Integer input still becomes doubles when it is named. + named_integer <- wt_trunc( + c(a = 1L, b = 5L, c = 30L), + method = "wt", + upper = 2.5 + ) + expect_type(vctrs::vec_data(named_integer), "double") + expect_identical(names(named_integer), c("a", "b", "c")) +}) + +test_that("a subset that drops the record prints a truncation line without counts", { + w <- psw(c(0.5, 1, 4, 2, 25), estimand = "ate") + + expect_snapshot(wt_trunc(w, method = "wt", upper = 3)[1:3]) +}) + test_that("wt_trunc() refuses input that is not weights", { expect_error(wt_trunc(c("a", "b")), class = "propensity_type_error") expect_error(wt_trunc(list(1, 2)), class = "propensity_error") From afa76a522eb95505ce6e1a605240080669322f76 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 22:20:44 -0400 Subject: [PATCH 13/64] add failing tests for ipw() refusing truncated weights --- tests/testthat/test-ipw-wt-trunc.R | 416 +++++++++++++++++++++++++++++ 1 file changed, 416 insertions(+) create mode 100644 tests/testthat/test-ipw-wt-trunc.R diff --git a/tests/testthat/test-ipw-wt-trunc.R b/tests/testthat/test-ipw-wt-trunc.R new file mode 100644 index 00000000..5a6332eb --- /dev/null +++ b/tests/testthat/test-ipw-wt-trunc.R @@ -0,0 +1,416 @@ +# ipw() refuses weights whose values were bounded by wt_trunc(). +# +# A weight truncation is a hard bound on the weights, not a smooth function of +# the propensity score model's parameters, so no sandwich `ipw()` can build +# accounts for it. The refusal has its own class, fires on the `wt_truncated` +# flag alone, and fires on every exposure route before the estimand is read, +# since the truncation label would otherwise surface as an unrecognized +# estimand. Weights that are also trimmed, truncated on the score scale, or +# calibrated meet those refusals first. + +# ---- fixtures --------------------------------------------------------------- + +wt_trunc_ipw_binary_data <- function(seed = 2024, n = 400) { + withr::local_seed(seed) + x1 <- rnorm(n) + x2 <- rbinom(n, 1, 0.4) + z <- rbinom(n, 1, plogis(0.3 * x1 - 0.5 * x2)) + y <- rbinom(n, 1, plogis(-0.5 + 0.8 * z + 0.4 * x1 - 0.3 * x2)) + data.frame(x1, x2, z, y) +} + +wt_trunc_ipw_continuous_data <- function(seed = 2024, n = 400) { + withr::local_seed(seed) + x1 <- rnorm(n) + x2 <- rbinom(n, 1, 0.5) + A <- 0.5 + 0.8 * x1 - 0.4 * x2 + rnorm(n) + yc <- 1 + 0.6 * A + 0.5 * x1 - 0.3 * x2 + rnorm(n) + data.frame(x1, x2, A, yc) +} + +wt_trunc_ipw_categorical_data <- function(seed = 2024, n = 500) { + withr::local_seed(seed) + x1 <- rnorm(n) + x2 <- rbinom(n, 1, 0.5) + eta_b <- -0.2 + 0.5 * x1 + 0.3 * x2 + eta_c <- 0.1 - 0.4 * x1 + 0.6 * x2 + denom <- 1 + exp(eta_b) + exp(eta_c) + u <- runif(n) + lab <- ifelse( + u < 1 / denom, + "a", + ifelse(u < (1 + exp(eta_b)) / denom, "b", "c") + ) + a <- factor(lab, levels = c("a", "b", "c")) + y <- rbinom(n, 1, plogis(-0.3 + 0.4 * (a == "b") + 0.5 * x1)) + data.frame(x1, x2, a, y) +} + +wt_trunc_ipw_joint_data <- function(seed = 6401, n = 600) { + withr::local_seed(seed) + x1 <- rnorm(n) + x2 <- rbinom(n, 1, 0.5) + a <- rbinom(n, 1, plogis(0.3 * x1 - 0.4 * x2)) + e <- rbinom(n, 1, plogis(-0.2 + 0.5 * x1 + 0.3 * x2 - 0.8 * a)) + y <- rbinom(n, 1, plogis(-0.5 + 0.7 * a + 0.5 * e + 0.6 * x1)) + data.frame(x1, x2, a, e, y) +} + +# Fit the weighted outcome model, recording the formula itself in the call so a +# printed call reads the same on every R version. The formula is rebound to this +# frame so the model frame finds `wts` here, whatever the caller named them. +wt_trunc_ipw_outcome <- function(fmla, dat, wts, family = "binomial") { + environment(fmla) <- environment() + mod <- if (family == "binomial") { + glm(fmla, data = dat, family = quasibinomial(), weights = wts) + } else { + lm(fmla, data = dat, weights = wts) + } + mod$call$formula <- fmla + mod +} + +wt_trunc_ipw_binary <- function(modify = c("none", "trim", "trunc", "calib")) { + modify <- rlang::arg_match(modify) + withr::local_options(propensity.quiet = TRUE) + dat <- wt_trunc_ipw_binary_data() + ps_mod <- glm(z ~ x1 + x2, data = dat, family = binomial()) + ps <- predict(ps_mod, type = "response") + + score <- switch( + modify, + none = ps, + trim = ps_refit( + ps_trim(ps, method = "ps", lower = 0.3, upper = 0.7), + model = ps_mod + ), + trunc = ps_trunc(ps, method = "ps", lower = 0.3, upper = 0.7), + calib = ps_calibrate(ps, .exposure = dat$z, .focal_level = 1) + ) + base <- wt_ate( + score, + .exposure = dat$z, + exposure_type = "binary", + .focal_level = 1 + ) + wts <- wt_trunc(base, method = "wt", upper = 2) + + list( + dat = dat, + ps_mod = ps_mod, + base = base, + wts = wts, + outcome_mod = wt_trunc_ipw_outcome(y ~ z, dat, wts) + ) +} + +wt_trunc_ipw_continuous <- function(stabilize = TRUE) { + withr::local_options(propensity.quiet = TRUE) + dat <- wt_trunc_ipw_continuous_data() + ps_mod <- lm(A ~ x1 + x2, data = dat) + base <- wt_ate( + as.double(fitted(ps_mod)), + dat$A, + exposure_type = "continuous", + stabilize = stabilize + ) + wts <- wt_trunc(base, method = "count", upper = 5) + + list( + dat = dat, + ps_mod = ps_mod, + wts = wts, + outcome_mod = wt_trunc_ipw_outcome(yc ~ A, dat, wts, family = "gaussian") + ) +} + +wt_trunc_ipw_categorical <- function() { + withr::local_options(propensity.quiet = TRUE) + dat <- wt_trunc_ipw_categorical_data() + ps_mod <- nnet::multinom( + a ~ x1 + x2, + data = dat, + trace = FALSE, + reltol = 1e-14, + maxit = 2000 + ) + ps <- unname(predict(ps_mod, type = "probs")) + colnames(ps) <- ps_mod$lev + base <- wt_ate(ps, dat$a, exposure_type = "categorical") + wts <- wt_trunc(base, method = "count", upper = 5) + + list( + dat = dat, + ps_mod = ps_mod, + wts = wts, + outcome_mod = wt_trunc_ipw_outcome(y ~ a + x1, dat, wts) + ) +} + +wt_trunc_ipw_joint <- function() { + withr::local_options(propensity.quiet = TRUE) + dat <- wt_trunc_ipw_joint_data() + ps_a <- glm(a ~ x1 + x2, data = dat, family = binomial()) + ps_e <- glm(e ~ a * x1 + x2, data = dat, family = binomial()) + base <- wt_joint( + wt_ate(ps_a), + wt_ate(ps_e), + exposure_type = c("binary", "binary") + ) + wts <- wt_trunc(base, method = "count", upper = 5) + + list( + dat = dat, + models = joint_wt_models(a = ps_a, e = ps_e), + wts = wts, + outcome_mod = wt_trunc_ipw_outcome(y ~ a * e + x1, dat, wts) + ) +} + +# ---- the fixtures bound weights as the tests assume -------------------------- + +test_that("every fixture carries weights that wt_trunc() moved", { + fixtures <- list( + binary = wt_trunc_ipw_binary(), + continuous_stabilized = wt_trunc_ipw_continuous(stabilize = TRUE), + continuous_unstabilized = wt_trunc_ipw_continuous(stabilize = FALSE), + categorical = wt_trunc_ipw_categorical(), + joint = wt_trunc_ipw_joint() + ) + + for (fx in fixtures) { + expect_true(is_wt_truncated(fx$wts)) + expect_gt(sum(is_unit_wt_truncated(fx$wts)), 0) + expect_false(is_ps_trimmed(fx$wts)) + expect_false(is_ps_truncated(fx$wts)) + expect_false(is_ps_calibrated(fx$wts)) + expect_true(is_wt_truncated(extract_weights(fx$outcome_mod))) + } +}) + +# ---- one refusal on every route --------------------------------------------- + +test_that("ipw() refuses weight-truncated binary weights on both SE paths", { + fx <- wt_trunc_ipw_binary() + + expect_error( + ipw(fx$ps_mod, fx$outcome_mod, .data = fx$dat), + class = "propensity_ipw_wt_truncated_error" + ) + expect_error( + ipw( + fx$ps_mod, + fx$outcome_mod, + .data = fx$dat, + se_method = "linearization" + ), + class = "propensity_ipw_wt_truncated_error" + ) +}) + +test_that("ipw() refuses weight-truncated stabilized continuous weights", { + fx <- wt_trunc_ipw_continuous(stabilize = TRUE) + expect_true(is_stabilized(fx$wts)) + + expect_error( + ipw(fx$ps_mod, fx$outcome_mod, .data = fx$dat), + class = "propensity_ipw_wt_truncated_error" + ) +}) + +test_that("ipw() refuses weight-truncated unstabilized continuous weights", { + fx <- wt_trunc_ipw_continuous(stabilize = FALSE) + expect_false(is_stabilized(fx$wts)) + + expect_error( + ipw(fx$ps_mod, fx$outcome_mod, .data = fx$dat), + class = "propensity_ipw_wt_truncated_error" + ) +}) + +test_that("ipw() refuses weight-truncated categorical weights", { + fx <- wt_trunc_ipw_categorical() + + expect_error( + ipw(fx$ps_mod, fx$outcome_mod, .data = fx$dat), + class = "propensity_ipw_wt_truncated_error" + ) +}) + +test_that("ipw() refuses weight-truncated joint weights", { + fx <- wt_trunc_ipw_joint() + + expect_error( + ipw(fx$models, fx$outcome_mod), + class = "propensity_ipw_wt_truncated_error" + ) +}) + +# ---- the refusal comes before the estimand is read --------------------------- + +test_that("the weight-truncation refusal fires before estimand parsing", { + # A deliberately wrong estimand argument must not win over the guard. + binary <- wt_trunc_ipw_binary() + expect_error( + ipw( + binary$ps_mod, + binary$outcome_mod, + .data = binary$dat, + estimand = "att" + ), + class = "propensity_ipw_wt_truncated_error" + ) + + continuous <- wt_trunc_ipw_continuous() + expect_error( + ipw( + continuous$ps_mod, + continuous$outcome_mod, + .data = continuous$dat, + estimand = "att" + ), + class = "propensity_ipw_wt_truncated_error" + ) + + categorical <- wt_trunc_ipw_categorical() + expect_error( + ipw( + categorical$ps_mod, + categorical$outcome_mod, + .data = categorical$dat, + estimand = "ato" + ), + class = "propensity_ipw_wt_truncated_error" + ) +}) + +# ---- the flag alone is enough ------------------------------------------------ + +test_that("a weight-truncated flag whose record was dropped is still refused", { + fx <- wt_trunc_ipw_binary() + n <- length(fx$wts) + recombined <- c(fx$wts[seq_len(n / 2)], fx$wts[seq(n / 2 + 1, n)]) + + # Recombining drops the positional record but keeps the flag. + expect_true(is_wt_truncated(recombined)) + expect_error(is_unit_wt_truncated(recombined)) + + outcome_mod <- wt_trunc_ipw_outcome(y ~ z, fx$dat, recombined) + expect_error( + ipw(fx$ps_mod, outcome_mod, .data = fx$dat), + class = "propensity_ipw_wt_truncated_error" + ) +}) + +test_that("the flag is refused even under an unlabeled estimand", { + # Weights that match the propensity score model exactly and carry the plain + # "ate" label: only the flag says they were truncated, and it must suffice. + fx <- wt_trunc_ipw_binary() + flagged <- psw( + as.double(fx$base), + estimand = "ate", + wt_truncated = TRUE + ) + expect_true(is_wt_truncated(flagged)) + + outcome_mod <- wt_trunc_ipw_outcome(y ~ z, fx$dat, flagged) + expect_error( + ipw(fx$ps_mod, outcome_mod, .data = fx$dat), + class = "propensity_ipw_wt_truncated_error" + ) +}) + +# ---- order against the other modified-weight refusals ------------------------ + +test_that("trimmed weights that were also weight-truncated meet the trim refusal", { + fx <- wt_trunc_ipw_binary("trim") + expect_true(is_ps_trimmed(fx$wts)) + expect_true(is_wt_truncated(fx$wts)) + + expect_error( + ipw(fx$ps_mod, fx$outcome_mod, .data = fx$dat), + class = "propensity_ipw_trimmed_error" + ) +}) + +test_that("score-truncated weights that were also weight-truncated meet the score refusal", { + fx <- wt_trunc_ipw_binary("trunc") + expect_true(is_ps_truncated(fx$wts)) + expect_true(is_wt_truncated(fx$wts)) + + expect_error( + ipw(fx$ps_mod, fx$outcome_mod, .data = fx$dat), + class = "propensity_ipw_truncated_error" + ) +}) + +test_that("calibrated weights that were also weight-truncated meet the calibration refusal", { + fx <- wt_trunc_ipw_binary("calib") + expect_true(is_ps_calibrated(fx$wts)) + expect_true(is_wt_truncated(fx$wts)) + + expect_error( + ipw(fx$ps_mod, fx$outcome_mod, .data = fx$dat), + class = "propensity_ipw_calibrated_error" + ) +}) + +# ---- the message ------------------------------------------------------------- + +test_that("the weight-truncation refusal names both honest routes", { + fx <- wt_trunc_ipw_binary() + + cnd <- rlang::catch_cnd(ipw(fx$ps_mod, fx$outcome_mod, .data = fx$dat)) + expect_s3_class(cnd, "propensity_ipw_wt_truncated_error") + msg <- cli::ansi_strip(conditionMessage(cnd)) + expect_match(msg, "truncated propensity score weights", fixed = TRUE) + expect_match(msg, "wt_trunc()", fixed = TRUE) + expect_match(msg, "M-estimation", fixed = TRUE) + expect_match(msg, "fixed-weight", fixed = TRUE) + + # Record the snapshot only once the dedicated refusal is the one raised, so + # the message of another refusal is never written down as this one's. + skip_if_not(inherits(cnd, "propensity_ipw_wt_truncated_error")) + expect_propensity_error(ipw(fx$ps_mod, fx$outcome_mod, .data = fx$dat)) +}) + +test_that("the weight-truncation refusal reads the same on every route", { + continuous <- wt_trunc_ipw_continuous() + categorical <- wt_trunc_ipw_categorical() + joint <- wt_trunc_ipw_joint() + + cnds <- list( + rlang::catch_cnd(ipw( + continuous$ps_mod, + continuous$outcome_mod, + .data = continuous$dat + )), + rlang::catch_cnd(ipw( + categorical$ps_mod, + categorical$outcome_mod, + .data = categorical$dat + )), + rlang::catch_cnd(ipw(joint$models, joint$outcome_mod)) + ) + for (cnd in cnds) { + expect_s3_class(cnd, "propensity_ipw_wt_truncated_error") + } + + skip_if_not(all(vapply( + cnds, + inherits, + logical(1), + what = "propensity_ipw_wt_truncated_error" + ))) + expect_propensity_error(ipw( + continuous$ps_mod, + continuous$outcome_mod, + .data = continuous$dat + )) + expect_propensity_error(ipw( + categorical$ps_mod, + categorical$outcome_mod, + .data = categorical$dat + )) + expect_propensity_error(ipw(joint$models, joint$outcome_mod)) +}) From 3baa21643d6ea90d0971c4b338dcc4ba1e6e6568 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 22:34:36 -0400 Subject: [PATCH 14/64] refuse truncated weights in ipw() --- NEWS.md | 6 ++ R/ipw.R | 67 ++++++++++++--- man/ipw-methods.Rd | 38 ++++++--- tests/testthat/_snaps/ipw-wt-trunc.md | 40 +++++++++ tests/testthat/test-ipw-wt-trunc.R | 112 ++++++++++++++++++++++---- 5 files changed, 226 insertions(+), 37 deletions(-) create mode 100644 tests/testthat/_snaps/ipw-wt-trunc.md diff --git a/NEWS.md b/NEWS.md index e1e0a7c1..633ef6fb 100644 --- a/NEWS.md +++ b/NEWS.md @@ -15,6 +15,12 @@ which describe a truncated propensity score. Weights truncated at different bounds do not combine. +* `ipw()` refuses weights bounded with `wt_trunc()` on every exposure route, + with the dedicated error class `propensity_ipw_wt_truncated_error`. The + message names the two supported alternatives: rebuild the weights without + the truncation and report the M-estimation interval, or report a + fixed-weight sandwich that conditions on the bound. + * `ps_trim()` now trims a model of a continuous exposure on the scale of its conditional density. A `lm`, a `glm` whose variance is constant, a `MASS::rlm()`, or an `mgcv::gam()` of the dose can be trimmed with diff --git a/R/ipw.R b/R/ipw.R index be36d469..ed5a2ce6 100644 --- a/R/ipw.R +++ b/R/ipw.R @@ -1309,11 +1309,30 @@ #' the propensity score model on every evaluation, so a weight that is no longer #' a deterministic function of that model breaks the sandwich variance. Supplying #' weights built from a modified score errors on either standard error method; -#' refit the weights from the unmodified propensity score model. An outcome model -#' fit without weights also errors on either method. The outcome model must not -#' carry an offset term on either method, since neither the stacked outcome score -#' nor the linearization influence functions thread an offset; supplying one -#' errors. +#' refit the weights from the unmodified propensity score model. +#' Density-trimmed weights for a continuous exposure (`ps_trim()` with +#' `method = "density"` or `method = "resid"`) carry the trim record and are +#' refused as trimmed weights. +#' +#' Weights bounded with [wt_trunc()] are refused as well, with their own error, +#' for a different reason. A bound on the weights is not a smooth function of the +#' propensity score model's parameters, so the stacked sandwich would report an +#' interval for the truncated estimand without saying so. The four methods also +#' differ in kind. A fixed bound (`"wt"`, or `"adaptive"`, which depends only on +#' the sample size) is known before the weights are seen, while a percentile +#' bound (`"pctl"`, or `"count"`, which bounds at an observed weight) is estimated +#' from the weights it modifies and would need an estimating equation of its own. +#' Only the fixed case is a candidate for support, and relaxing the refusal for +#' it first requires a simulation that measures the coverage of the M-estimation +#' interval with the bound inside the stack. Until then, rebuild the weights +#' without [wt_trunc()] and report the M-estimation interval, or fit the outcome +#' model with the truncated weights and report a fixed-weight sandwich, stating +#' that it conditions on the bound. +#' +#' An outcome model fit without weights also errors on either method. The +#' outcome model must not carry an offset term on either method, since neither +#' the stacked outcome score nor the linearization influence functions thread an +#' offset; supplying one errors. #' #' For a binary or categorical exposure, the outcome model formula must contain #' the exposure. The counterfactual designs are built by setting the exposure to @@ -1415,10 +1434,11 @@ #' repairs such a matrix, its categorical matrix method reading the closed #' interval so that a cell at an endpoint is bounded rather than refused, while #' [ps_trim()] holds the open interval as the weight functions do. Weights built -#' from a truncated score are their own refusal here, since [ipw()] cannot yet -#' account for a modified propensity score, so a separated fit is repaired for -#' the weight functions rather than for this one. See **Propensity scores at 0 -#' and 1** in [wt_ate()] for the remedy. +#' from a trimmed or truncated score are their own refusal here, as are weights +#' bounded with [wt_trunc()], since [ipw()] cannot yet account for a modified +#' propensity score or a truncated weight, so a separated fit is repaired for the +#' weight functions rather than for this one. See **Propensity scores at 0 and +#' 1** in [wt_ate()] for the remedy. #' #' The propensity score model must also be fit without case weights, since the #' stacked propensity score equations are unweighted and a weighted fit would not @@ -2299,9 +2319,9 @@ ipw_model_prior_weights <- function(fit) { # Guard the weights that fit the outcome model. ipw() cannot yet account for # propensity scores that were trimmed, truncated, or calibrated before -# weighting, so detect them here and direct the user to refit from the -# unmodified model. An outcome model fit without weights cannot yield an IPW -# estimate at all. +# weighting, or for weights truncated with wt_trunc(), so detect them here and +# tell the user which weights to rebuild or which variance to report instead. +# An outcome model fit without weights cannot yield an IPW estimate at all. check_ipw_weights <- function(wts, call = rlang::caller_env()) { if (is.null(wts)) { abort( @@ -2355,6 +2375,29 @@ check_ipw_weights <- function(wts, call = rlang::caller_env()) { ) } + # A bound on the weights is not a smooth function of the propensity score + # model's parameters, and a percentile bound is itself estimated from the + # weights it modifies, so no stacked sandwich accounts for either. + if (is_wt_truncated(wts)) { + abort( + c( + "{.arg outcome_mod} was fit with weights truncated on the weight \\ + scale with {.fun wt_trunc}.", + x = "{.fun ipw} cannot yet account for truncated propensity score \\ + weights: a hard \\ + bound is not a smooth function of the propensity score model's \\ + parameters, so the stacked sandwich would report an interval for the \\ + truncated estimand without saying so.", + i = "Rebuild the weights without {.fun wt_trunc} and report the \\ + M-estimation interval, or fit {.arg outcome_mod} with the truncated \\ + weights and report the fixed-weight sandwich yourself, stating that it \\ + conditions on the bound." + ), + error_class = "propensity_ipw_wt_truncated_error", + call = call + ) + } + invisible(wts) } diff --git a/man/ipw-methods.Rd b/man/ipw-methods.Rd index 3bdf43f7..049441ce 100644 --- a/man/ipw-methods.Rd +++ b/man/ipw-methods.Rd @@ -1577,11 +1577,30 @@ before weighting. The stacked estimating equations rebuild the weights from the propensity score model on every evaluation, so a weight that is no longer a deterministic function of that model breaks the sandwich variance. Supplying weights built from a modified score errors on either standard error method; -refit the weights from the unmodified propensity score model. An outcome model -fit without weights also errors on either method. The outcome model must not -carry an offset term on either method, since neither the stacked outcome score -nor the linearization influence functions thread an offset; supplying one -errors. +refit the weights from the unmodified propensity score model. +Density-trimmed weights for a continuous exposure (\code{ps_trim()} with +\code{method = "density"} or \code{method = "resid"}) carry the trim record and are +refused as trimmed weights. + +Weights bounded with \code{\link[=wt_trunc]{wt_trunc()}} are refused as well, with their own error, +for a different reason. A bound on the weights is not a smooth function of the +propensity score model's parameters, so the stacked sandwich would report an +interval for the truncated estimand without saying so. The four methods also +differ in kind. A fixed bound (\code{"wt"}, or \code{"adaptive"}, which depends only on +the sample size) is known before the weights are seen, while a percentile +bound (\code{"pctl"}, or \code{"count"}, which bounds at an observed weight) is estimated +from the weights it modifies and would need an estimating equation of its own. +Only the fixed case is a candidate for support, and relaxing the refusal for +it first requires a simulation that measures the coverage of the M-estimation +interval with the bound inside the stack. Until then, rebuild the weights +without \code{\link[=wt_trunc]{wt_trunc()}} and report the M-estimation interval, or fit the outcome +model with the truncated weights and report a fixed-weight sandwich, stating +that it conditions on the bound. + +An outcome model fit without weights also errors on either method. The +outcome model must not carry an offset term on either method, since neither +the stacked outcome score nor the linearization influence functions thread an +offset; supplying one errors. For a binary or categorical exposure, the outcome model formula must contain the exposure. The counterfactual designs are built by setting the exposure to @@ -1683,10 +1702,11 @@ therefore stopped where its weights are built rather than here. \code{\link[=ps_ repairs such a matrix, its categorical matrix method reading the closed interval so that a cell at an endpoint is bounded rather than refused, while \code{\link[=ps_trim]{ps_trim()}} holds the open interval as the weight functions do. Weights built -from a truncated score are their own refusal here, since \code{\link[=ipw]{ipw()}} cannot yet -account for a modified propensity score, so a separated fit is repaired for -the weight functions rather than for this one. See \strong{Propensity scores at 0 -and 1} in \code{\link[=wt_ate]{wt_ate()}} for the remedy. +from a trimmed or truncated score are their own refusal here, as are weights +bounded with \code{\link[=wt_trunc]{wt_trunc()}}, since \code{\link[=ipw]{ipw()}} cannot yet account for a modified +propensity score or a truncated weight, so a separated fit is repaired for the +weight functions rather than for this one. See \strong{Propensity scores at 0 and +1} in \code{\link[=wt_ate]{wt_ate()}} for the remedy. The propensity score model must also be fit without case weights, since the stacked propensity score equations are unweighted and a weighted fit would not diff --git a/tests/testthat/_snaps/ipw-wt-trunc.md b/tests/testthat/_snaps/ipw-wt-trunc.md new file mode 100644 index 00000000..04d27e36 --- /dev/null +++ b/tests/testthat/_snaps/ipw-wt-trunc.md @@ -0,0 +1,40 @@ +# the weight-truncation refusal names both honest routes + + Code + expr + Condition + Error in `ipw()`: + ! `outcome_mod` was fit with weights truncated on the weight scale with `wt_trunc()`. + x `ipw()` cannot yet account for truncated propensity score weights: a hard bound is not a smooth function of the propensity score model's parameters, so the stacked sandwich would report an interval for the truncated estimand without saying so. + i Rebuild the weights without `wt_trunc()` and report the M-estimation interval, or fit `outcome_mod` with the truncated weights and report the fixed-weight sandwich yourself, stating that it conditions on the bound. + +# the weight-truncation refusal reads the same on every route + + Code + expr + Condition + Error in `ipw()`: + ! `outcome_mod` was fit with weights truncated on the weight scale with `wt_trunc()`. + x `ipw()` cannot yet account for truncated propensity score weights: a hard bound is not a smooth function of the propensity score model's parameters, so the stacked sandwich would report an interval for the truncated estimand without saying so. + i Rebuild the weights without `wt_trunc()` and report the M-estimation interval, or fit `outcome_mod` with the truncated weights and report the fixed-weight sandwich yourself, stating that it conditions on the bound. + +--- + + Code + expr + Condition + Error in `ipw()`: + ! `outcome_mod` was fit with weights truncated on the weight scale with `wt_trunc()`. + x `ipw()` cannot yet account for truncated propensity score weights: a hard bound is not a smooth function of the propensity score model's parameters, so the stacked sandwich would report an interval for the truncated estimand without saying so. + i Rebuild the weights without `wt_trunc()` and report the M-estimation interval, or fit `outcome_mod` with the truncated weights and report the fixed-weight sandwich yourself, stating that it conditions on the bound. + +--- + + Code + expr + Condition + Error in `ipw()`: + ! `outcome_mod` was fit with weights truncated on the weight scale with `wt_trunc()`. + x `ipw()` cannot yet account for truncated propensity score weights: a hard bound is not a smooth function of the propensity score model's parameters, so the stacked sandwich would report an interval for the truncated estimand without saying so. + i Rebuild the weights without `wt_trunc()` and report the M-estimation interval, or fit `outcome_mod` with the truncated weights and report the fixed-weight sandwich yourself, stating that it conditions on the bound. + diff --git a/tests/testthat/test-ipw-wt-trunc.R b/tests/testthat/test-ipw-wt-trunc.R index 5a6332eb..f6c07ba9 100644 --- a/tests/testthat/test-ipw-wt-trunc.R +++ b/tests/testthat/test-ipw-wt-trunc.R @@ -19,11 +19,15 @@ wt_trunc_ipw_binary_data <- function(seed = 2024, n = 400) { data.frame(x1, x2, z, y) } -wt_trunc_ipw_continuous_data <- function(seed = 2024, n = 400) { +wt_trunc_ipw_continuous_data <- function( + seed = 2024, + n = 400, + x1_effect = 0.8 +) { withr::local_seed(seed) x1 <- rnorm(n) x2 <- rbinom(n, 1, 0.5) - A <- 0.5 + 0.8 * x1 - 0.4 * x2 + rnorm(n) + A <- 0.5 + x1_effect * x1 - 0.4 * x2 + rnorm(n) yc <- 1 + 0.6 * A + 0.5 * x1 - 0.3 * x2 + rnorm(n) data.frame(x1, x2, A, yc) } @@ -104,9 +108,13 @@ wt_trunc_ipw_binary <- function(modify = c("none", "trim", "trunc", "calib")) { ) } -wt_trunc_ipw_continuous <- function(stabilize = TRUE) { +wt_trunc_ipw_continuous <- function( + stabilize = TRUE, + method = "count", + x1_effect = 0.8 +) { withr::local_options(propensity.quiet = TRUE) - dat <- wt_trunc_ipw_continuous_data() + dat <- wt_trunc_ipw_continuous_data(x1_effect = x1_effect) ps_mod <- lm(A ~ x1 + x2, data = dat) base <- wt_ate( as.double(fitted(ps_mod)), @@ -114,7 +122,11 @@ wt_trunc_ipw_continuous <- function(stabilize = TRUE) { exposure_type = "continuous", stabilize = stabilize ) - wts <- wt_trunc(base, method = "count", upper = 5) + wts <- if (method == "adaptive") { + wt_trunc(base, method = "adaptive") + } else { + wt_trunc(base, method = method, upper = 5) + } list( dat = dat, @@ -167,6 +179,32 @@ wt_trunc_ipw_joint <- function() { ) } +# The declared joint route: the crossing of two binary treatments as one +# factor, weighted through one multinomial propensity score model. +wt_trunc_ipw_joint_exposure <- function() { + withr::local_options(propensity.quiet = TRUE) + dat <- wt_trunc_ipw_joint_data() + dat$joint <- causalgenerics::joint_exposure(a = dat$a, e = dat$e) + ps_mod <- nnet::multinom( + joint ~ x1 + x2, + data = dat, + trace = FALSE, + reltol = 1e-14, + maxit = 2000 + ) + ps <- unname(predict(ps_mod, type = "probs")) + colnames(ps) <- ps_mod$lev + base <- wt_ate(ps, dat$joint, exposure_type = "categorical") + wts <- wt_trunc(base, method = "count", upper = 5) + + list( + dat = dat, + ps_mod = ps_mod, + wts = wts, + outcome_mod = wt_trunc_ipw_outcome(y ~ joint + x1, dat, wts) + ) +} + # ---- the fixtures bound weights as the tests assume -------------------------- test_that("every fixture carries weights that wt_trunc() moved", { @@ -174,8 +212,13 @@ test_that("every fixture carries weights that wt_trunc() moved", { binary = wt_trunc_ipw_binary(), continuous_stabilized = wt_trunc_ipw_continuous(stabilize = TRUE), continuous_unstabilized = wt_trunc_ipw_continuous(stabilize = FALSE), + continuous_adaptive = wt_trunc_ipw_continuous( + stabilize = FALSE, + method = "adaptive" + ), categorical = wt_trunc_ipw_categorical(), - joint = wt_trunc_ipw_joint() + joint = wt_trunc_ipw_joint(), + joint_exposure = wt_trunc_ipw_joint_exposure() ) for (fx in fixtures) { @@ -190,7 +233,7 @@ test_that("every fixture carries weights that wt_trunc() moved", { # ---- one refusal on every route --------------------------------------------- -test_that("ipw() refuses weight-truncated binary weights on both SE paths", { +test_that("ipw() refuses weight-truncated binary weights on every SE path", { fx <- wt_trunc_ipw_binary() expect_error( @@ -206,6 +249,15 @@ test_that("ipw() refuses weight-truncated binary weights on both SE paths", { ), class = "propensity_ipw_wt_truncated_error" ) + expect_error( + ipw( + fx$ps_mod, + fx$outcome_mod, + .data = fx$dat, + se_method = "robust" + ), + class = "propensity_ipw_wt_truncated_error" + ) }) test_that("ipw() refuses weight-truncated stabilized continuous weights", { @@ -228,6 +280,33 @@ test_that("ipw() refuses weight-truncated unstabilized continuous weights", { ) }) +test_that("ipw() refuses adaptively weight-truncated continuous weights", { + fx <- wt_trunc_ipw_continuous(stabilize = FALSE, method = "adaptive") + expect_gt(sum(is_unit_wt_truncated(fx$wts)), 0) + + expect_error( + ipw(fx$ps_mod, fx$outcome_mod, .data = fx$dat), + class = "propensity_ipw_wt_truncated_error" + ) +}) + +test_that("an adaptive bound that moved no weight is still refused", { + # Under weak confounding the stabilized weights never reach the adaptive + # bound, so the truncation is recorded without changing a single value. + fx <- wt_trunc_ipw_continuous( + stabilize = TRUE, + method = "adaptive", + x1_effect = 0.2 + ) + expect_true(is_wt_truncated(fx$wts)) + expect_equal(sum(is_unit_wt_truncated(fx$wts)), 0) + + expect_error( + ipw(fx$ps_mod, fx$outcome_mod, .data = fx$dat), + class = "propensity_ipw_wt_truncated_error" + ) +}) + test_that("ipw() refuses weight-truncated categorical weights", { fx <- wt_trunc_ipw_categorical() @@ -246,6 +325,16 @@ test_that("ipw() refuses weight-truncated joint weights", { ) }) +test_that("ipw() refuses weight-truncated weights for a declared joint exposure", { + fx <- wt_trunc_ipw_joint_exposure() + expect_true(causalgenerics::is_joint_exposure(fx$dat$joint)) + + expect_error( + ipw(fx$ps_mod, fx$outcome_mod, .data = fx$dat), + class = "propensity_ipw_wt_truncated_error" + ) +}) + # ---- the refusal comes before the estimand is read --------------------------- test_that("the weight-truncation refusal fires before estimand parsing", { @@ -368,9 +457,6 @@ test_that("the weight-truncation refusal names both honest routes", { expect_match(msg, "M-estimation", fixed = TRUE) expect_match(msg, "fixed-weight", fixed = TRUE) - # Record the snapshot only once the dedicated refusal is the one raised, so - # the message of another refusal is never written down as this one's. - skip_if_not(inherits(cnd, "propensity_ipw_wt_truncated_error")) expect_propensity_error(ipw(fx$ps_mod, fx$outcome_mod, .data = fx$dat)) }) @@ -396,12 +482,6 @@ test_that("the weight-truncation refusal reads the same on every route", { expect_s3_class(cnd, "propensity_ipw_wt_truncated_error") } - skip_if_not(all(vapply( - cnds, - inherits, - logical(1), - what = "propensity_ipw_wt_truncated_error" - ))) expect_propensity_error(ipw( continuous$ps_mod, continuous$outcome_mod, From 281f5f5043edcefeb90e4859cc49c81cb0df13df Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 22:41:52 -0400 Subject: [PATCH 15/64] add failing tests for the truncation sensitivity grid --- tests/testthat/test-wt-trunc-sensitivity.R | 649 +++++++++++++++++++++ 1 file changed, 649 insertions(+) create mode 100644 tests/testthat/test-wt-trunc-sensitivity.R diff --git a/tests/testthat/test-wt-trunc-sensitivity.R b/tests/testthat/test-wt-trunc-sensitivity.R new file mode 100644 index 00000000..39a1b2c1 --- /dev/null +++ b/tests/testthat/test-wt-trunc-sensitivity.R @@ -0,0 +1,649 @@ +# The truncation sensitivity grid ---------------------------------------------- + +# `wt_trunc_sensitivity()` reports, for each bound in a grid, what `wt_trunc()` +# does to the weights at that bound: the bounds as given and as applied, the +# number of weights moved, and the range and mean of the weights that result. +# The first row is the untruncated reference, with missing bounds. There is no +# effective sample size column; that comes from `halfmoon::check_ess()`. + +grid_columns <- c( + "lower", + "upper", + "lower_value", + "upper_value", + "n_truncated", + "min", + "max", + "range_ratio", + "mean" +) + +# One row of the grid, built from the weights and the bounds that produced +# them. A missing weight takes no part in the summaries. +grid_row <- function( + values, + lower = NA_real_, + upper = NA_real_, + lower_value = NA_real_, + upper_value = NA_real_, + n_truncated = 0L +) { + values <- as.numeric(values) + values <- values[!is.na(values)] + tibble::tibble( + lower = as.double(lower), + upper = as.double(upper), + lower_value = as.double(lower_value), + upper_value = as.double(upper_value), + n_truncated = as.integer(n_truncated), + min = min(values), + max = max(values), + range_ratio = max(values) / min(values), + mean = mean(values) + ) +} + +null_to_na <- function(x) { + if (is.null(x)) NA_real_ else x +} + +# The row `wt_trunc()` implies at one bound, read from the weights it returns +# and the record it leaves. +grid_row_from_wt_trunc <- function(.weights, method, lower, upper) { + out <- wt_trunc(.weights, method = method, lower = lower, upper = upper) + meta <- attr(out, "psw_trunc_meta") + grid_row( + out, + lower = null_to_na(lower), + upper = upper, + lower_value = null_to_na(meta$lower_value), + upper_value = meta$upper_value, + n_truncated = length(meta$truncated_idx) + ) +} + +# The whole grid `wt_trunc()` implies: the untruncated row, then one row per +# bound in the order given, with a single `lower` paired with every `upper`. +grid_from_wt_trunc <- function(.weights, method, upper, lower = NULL) { + if (length(lower) == 1L) { + lower <- rep(lower, length(upper)) + } + rows <- lapply(seq_along(upper), function(i) { + grid_row_from_wt_trunc(.weights, method, lower[i], upper[[i]]) + }) + vctrs::vec_rbind(grid_row(.weights), !!!rows) +} + +# Quantile type 7, the `quantile()` default that `wt_trunc(method = "pctl")` +# uses, written out. +type7_quantile <- function(x, p) { + x <- sort(x[!is.na(x)]) + h <- (length(x) - 1) * p + 1 + lo <- floor(h) + hi <- ceiling(h) + x[lo] + (h - lo) * (x[hi] - x[lo]) +} + +# Ten weights whose truncated summaries are simple enough to work out by hand. +# Their sum is 30, so the untruncated mean is 3. +hand_weights <- function() { + psw(c(0.5, 0.8, 1, 1.2, 1.5, 2, 3, 4, 6, 10), estimand = "ate") +} + +sensitivity_data <- function(n = 80, seed = 20260917) { + withr::local_seed(seed) + dat <- data.frame(x1 = rnorm(n), x2 = rnorm(n)) + dat$z <- rbinom(n, 1, stats::plogis(1.4 * dat$x1)) + dat$a <- 1 + 0.6 * dat$x1 - 0.4 * dat$x2 + rnorm(n) + dat +} + +binary_sensitivity_fit <- function(dat = sensitivity_data()) { + stats::glm(z ~ x1 + x2, data = dat, family = stats::binomial()) +} + +binary_sensitivity_weights <- function(dat = sensitivity_data()) { + wt_ate(binary_sensitivity_fit(dat), .exposure = dat$z) +} + +continuous_sensitivity_weights <- function(dat = sensitivity_data()) { + dose <- stats::lm(a ~ x1 + x2, data = dat) + numerator <- stats::lm(a ~ x1, data = dat) + muffle_variance_warning(wt_ate(dose, stabilize = numerator)) +} + +# ---- the shape of the grid --------------------------------------------------- + +test_that("the grid is a tibble with the documented columns in order", { + out <- wt_trunc_sensitivity(hand_weights()) + + expect_s3_class(out, "tbl_df") + expect_identical(names(out), grid_columns) + expect_false("ess" %in% tolower(names(out))) + expect_identical( + vapply(out, typeof, character(1)), + c( + lower = "double", + upper = "double", + lower_value = "double", + upper_value = "double", + n_truncated = "integer", + min = "double", + max = "double", + range_ratio = "double", + mean = "double" + ) + ) + # The summaries are plain numbers, not weights. + for (column in c("min", "max", "range_ratio", "mean")) { + expect_false(inherits(out[[column]], "psw"), info = column) + } +}) + +test_that("the first row is the untruncated reference with missing bounds", { + # The reference comes first so that every truncated row below it reads as a + # departure from it. + w <- hand_weights() + + out <- wt_trunc_sensitivity(w, method = "wt", upper = c(5, 2.5)) + + expect_identical(nrow(out), 3L) + expect_identical(out$lower[[1]], NA_real_) + expect_identical(out$upper[[1]], NA_real_) + expect_identical(out$lower_value[[1]], NA_real_) + expect_identical(out$upper_value[[1]], NA_real_) + expect_identical(out$n_truncated[[1]], 0L) + expect_equal(out$min[[1]], 0.5) + expect_equal(out$max[[1]], 10) + expect_equal(out$range_ratio[[1]], 20) + expect_equal(out$mean[[1]], 3) + # Only the reference row has missing bounds. + expect_false(anyNA(out$upper[-1])) +}) + +test_that("the rows follow the grid in the order given", { + w <- hand_weights() + + out <- wt_trunc_sensitivity(w, method = "wt", upper = c(2.5, 5, 4)) + + expect_identical(out$upper, c(NA, 2.5, 5, 4)) +}) + +# ---- the values in each row -------------------------------------------------- + +test_that("an absolute grid gives the summaries worked out by hand", { + # At 5, the weights 6 and 10 are moved to 5: the sum becomes 24. At 2.5, the + # weights 3, 4, 6, and 10 are moved to 2.5: the sum becomes 17. + w <- hand_weights() + + out <- wt_trunc_sensitivity(w, method = "wt", upper = c(5, 2.5)) + + expected <- tibble::tibble( + lower = c(NA_real_, NA_real_, NA_real_), + upper = c(NA, 5, 2.5), + lower_value = c(NA_real_, NA_real_, NA_real_), + upper_value = c(NA, 5, 2.5), + n_truncated = c(0L, 2L, 4L), + min = c(0.5, 0.5, 0.5), + max = c(10, 5, 2.5), + range_ratio = c(20, 10, 5), + mean = c(3, 2.4, 1.7) + ) + expect_equal(out, expected) +}) + +test_that("a two-sided absolute grid gives the summaries worked out by hand", { + # A lower bound of 1 also moves 0.5 and 0.8 up to 1. With the upper bound at + # 5 the sum is 24.7. + w <- hand_weights() + + out <- wt_trunc_sensitivity(w, method = "wt", lower = 1, upper = 5) + + expect_equal(out$lower, c(NA, 1)) + expect_equal(out$lower_value, c(NA, 1)) + expect_identical(out$n_truncated, c(0L, 4L)) + expect_equal(out$min, c(0.5, 1)) + expect_equal(out$max, c(10, 5)) + expect_equal(out$range_ratio, c(20, 5)) + expect_equal(out$mean, c(3, 2.47)) +}) + +test_that("a percentile grid reads its bounds at the type 7 quantiles", { + # For ten weights the 0.9 quantile sits a tenth of the way from 6 to 10, at + # 6.4, and the 0.99 quantile 91 hundredths of the way, at 9.64. Each moves + # only the largest weight. + w <- hand_weights() + expect_equal(type7_quantile(as.numeric(w), 0.9), 6.4) + expect_equal(type7_quantile(as.numeric(w), 0.99), 9.64) + + out <- wt_trunc_sensitivity(w, method = "pctl", upper = c(0.99, 0.9)) + + expect_equal(out$upper, c(NA, 0.99, 0.9)) + expect_equal(out$upper_value, c(NA, 9.64, 6.4)) + expect_identical(out$n_truncated, c(0L, 1L, 1L)) + expect_equal(out$max, c(10, 9.64, 6.4)) + expect_equal(out$range_ratio, c(20, 19.28, 12.8)) + expect_equal(out$mean, c(3, 2.964, 2.64)) +}) + +test_that("a count grid bounds the largest weights at the next one down", { + # The two largest, 6 and 10, are bounded at 4, the third largest. + w <- hand_weights() + + out <- wt_trunc_sensitivity(w, method = "count", upper = 2) + + expect_equal(out$upper, c(NA, 2)) + expect_equal(out$upper_value, c(NA, 4)) + expect_identical(out$n_truncated, c(0L, 2L)) + expect_equal(out$max, c(10, 4)) + expect_equal(out$range_ratio, c(20, 8)) + expect_equal(out$mean, c(3, 2.2)) +}) + +test_that("every row agrees with wt_trunc() at its bound", { + w <- binary_sensitivity_weights() + grids <- list( + wt = list(upper = c(8, 5, 3, 2), lower = NULL), + wt_two_sided = list(upper = c(8, 5, 3), lower = 1.05), + pctl = list(upper = c(0.99, 0.95, 0.8), lower = c(0.01, 0.05, 0.2)), + count = list(upper = c(1, 3, 10), lower = 2) + ) + + for (label in names(grids)) { + method <- sub("_two_sided", "", label, fixed = TRUE) + grid <- grids[[label]] + out <- wt_trunc_sensitivity( + w, + method = method, + lower = grid$lower, + upper = grid$upper + ) + expected <- grid_from_wt_trunc(w, method, grid$upper, grid$lower) + expect_equal(out, expected, info = label) + # Each grid point moves at least one weight, so no row is the reference + # repeated. + expect_true(all(out$n_truncated[-1] > 0), info = label) + } +}) + +test_that("an integer grid is recorded as doubles", { + w <- hand_weights() + + out <- wt_trunc_sensitivity(w, method = "wt", lower = 1L, upper = c(5L, 3L)) + + expect_identical(out$upper, c(NA, 5, 3)) + expect_identical(out$lower, c(NA, 1, 1)) +}) + +# ---- the default grid -------------------------------------------------------- + +test_that("the default is a percentile grid at 0.99, 0.975, 0.95, and 0.90", { + w <- binary_sensitivity_weights() + default_grid <- c(0.99, 0.975, 0.95, 0.90) + + out <- wt_trunc_sensitivity(w) + + expect_identical(out$upper, c(NA, default_grid)) + expect_identical(out$lower, rep(NA_real_, 5)) + expect_identical(out, wt_trunc_sensitivity(w, method = "pctl")) + expect_identical( + out, + wt_trunc_sensitivity(w, method = "pctl", upper = default_grid) + ) + expect_equal(out, grid_from_wt_trunc(w, "pctl", default_grid)) +}) + +# ---- pairing lower with upper ------------------------------------------------ + +test_that("a single lower bound is paired with every upper bound", { + w <- binary_sensitivity_weights() + + out <- wt_trunc_sensitivity(w, lower = 0.05) + + expect_identical(out$lower, c(NA, rep(0.05, 4))) + expect_equal( + out, + grid_from_wt_trunc(w, "pctl", c(0.99, 0.975, 0.95, 0.90), lower = 0.05) + ) +}) + +test_that("a lower grid of matching length is paired element by element", { + w <- binary_sensitivity_weights() + lower <- c(0.01, 0.025, 0.05, 0.10) + upper <- c(0.99, 0.975, 0.95, 0.90) + + out <- wt_trunc_sensitivity(w, method = "pctl", lower = lower, upper = upper) + + expect_identical(out$lower, c(NA, lower)) + expect_identical(out$upper, c(NA, upper)) + for (i in seq_along(upper)) { + expect_equal( + out[i + 1, ], + grid_row_from_wt_trunc(w, "pctl", lower[[i]], upper[[i]]), + info = i + ) + } +}) + +test_that("a lower grid of any other length is refused", { + w <- hand_weights() + + expect_error( + wt_trunc_sensitivity(w, lower = c(0.01, 0.05)), + class = "propensity_length_error" + ) + # `lower` is recycled to the length of `upper`, never the other way round. + expect_error( + wt_trunc_sensitivity( + w, + method = "wt", + lower = c(0.6, 0.7), + upper = 5 + ), + class = "propensity_length_error" + ) + + expect_propensity_error(wt_trunc_sensitivity(w, lower = c(0.01, 0.05))) +}) + +# ---- the bounds refused ------------------------------------------------------ + +test_that("the absolute and count grids need upper, as wt_trunc() does", { + w <- hand_weights() + + for (method in c("wt", "count")) { + expect_error( + wt_trunc_sensitivity(w, method = method), + class = "propensity_missing_arg_error", + info = method + ) + expect_error( + wt_trunc_sensitivity(w, method = method, lower = 1), + class = "propensity_missing_arg_error", + info = method + ) + } + + expect_propensity_error(wt_trunc_sensitivity(w, method = "wt")) +}) + +test_that("one invalid bound refuses the whole grid with wt_trunc()'s class", { + # A grid is refused as a whole rather than reported with a missing row, so a + # typo in one bound cannot pass unnoticed in a table of many. + w <- hand_weights() + + refused <- list( + list(method = "pctl", lower = NULL, upper = c(0.99, 1.5)), + list(method = "pctl", lower = NULL, upper = c(0.95, 0.1)), + list(method = "pctl", lower = c(0.05, 0.6), upper = c(0.99, 0.95)), + list(method = "wt", lower = NULL, upper = c(5, -1)), + list(method = "wt", lower = NULL, upper = c(5, Inf)), + list(method = "wt", lower = c(1, 6), upper = c(5, 5)), + list(method = "count", lower = NULL, upper = c(2, 1.5)), + list(method = "count", lower = NULL, upper = c(2, 10)), + list(method = "count", lower = 5, upper = c(2, 4)) + ) + for (i in seq_along(refused)) { + args <- refused[[i]] + expect_error( + wt_trunc_sensitivity( + w, + method = args$method, + lower = args$lower, + upper = args$upper + ), + class = "propensity_range_error", + info = i + ) + } + + expect_error( + wt_trunc_sensitivity(w, method = "wt", upper = c(5, NA)), + class = "propensity_missing_value_error" + ) + expect_error( + wt_trunc_sensitivity(w, method = "wt", lower = c(1, NA), upper = c(5, 5)), + class = "propensity_missing_value_error" + ) + expect_error( + wt_trunc_sensitivity(w, method = "wt", upper = c("5", "3")), + class = "propensity_type_error" + ) + + expect_propensity_error( + wt_trunc_sensitivity(w, method = "pctl", upper = c(0.99, 1.5)) + ) + expect_propensity_error( + wt_trunc_sensitivity(w, method = "wt", upper = c(5, NA)) + ) +}) + +test_that("an empty grid is refused", { + w <- hand_weights() + + expect_error( + wt_trunc_sensitivity(w, method = "wt", upper = double()), + class = "propensity_length_error" + ) + expect_error( + wt_trunc_sensitivity(w, method = "pctl", upper = double()), + class = "propensity_length_error" + ) + expect_error( + wt_trunc_sensitivity(w, method = "count", lower = 1, upper = integer()), + class = "propensity_length_error" + ) + + expect_propensity_error( + wt_trunc_sensitivity(w, method = "wt", upper = double()) + ) +}) + +test_that("a misspelled argument is an error", { + # There is no `...`, so a misspelled bound cannot be silently ignored. + w <- hand_weights() + + expect_error(wt_trunc_sensitivity(w, uper = 0.9)) + expect_error(wt_trunc_sensitivity(w, method = "wt", upper = 5, lowr = 1)) +}) + +test_that("the adaptive method is not a grid method", { + # The adaptive rule fixes a single bound from the number of weights, so there + # is nothing to vary over. + w <- hand_weights() + + expect_error( + wt_trunc_sensitivity(w, method = "adaptive"), + class = "rlang_error" + ) + expect_error( + wt_trunc_sensitivity(w, method = "ps", upper = 0.9), + class = "rlang_error" + ) + + expect_propensity_error(wt_trunc_sensitivity(w, method = "adaptive")) +}) + +# ---- the weights accepted ---------------------------------------------------- + +test_that("a bare numeric vector gives the same grid as a psw", { + x <- as.numeric(hand_weights()) + + out <- wt_trunc_sensitivity(x, method = "wt", upper = c(5, 2.5)) + + expect_identical( + out, + wt_trunc_sensitivity(hand_weights(), method = "wt", upper = c(5, 2.5)) + ) + expect_equal(out, grid_from_wt_trunc(x, "wt", c(5, 2.5))) + expect_identical(wt_trunc_sensitivity(x), wt_trunc_sensitivity(psw(x))) +}) + +test_that("missing weights are left out of every row", { + # The present weights are the hand weights, so every summary matches theirs, + # and the missing weights are never counted as moved. + x <- c(0.5, NA, 0.8, 1, 1.2, 1.5, NA, 2, 3, 4, 6, 10) + w <- psw(x, estimand = "ate") + + out <- expect_silent( + wt_trunc_sensitivity(w, method = "wt", upper = c(5, 2.5)) + ) + + expect_equal( + out, + wt_trunc_sensitivity(hand_weights(), method = "wt", upper = c(5, 2.5)) + ) + expect_identical(out$n_truncated, c(0L, 2L, 4L)) + expect_false(anyNA(out[c("min", "max", "range_ratio", "mean")])) + expect_equal(out, grid_from_wt_trunc(w, "wt", c(5, 2.5))) + + # A percentile grid reads its quantiles from the present weights alone. + pctl <- wt_trunc_sensitivity(w, method = "pctl", upper = 0.9) + expect_equal(pctl$upper_value, c(NA, 6.4)) + expect_equal(pctl, grid_from_wt_trunc(w, "pctl", 0.9)) +}) + +test_that("weights from a trimmed score give a grid over the kept units", { + dat <- sensitivity_data() + fit <- binary_sensitivity_fit(dat) + trimmed <- ps_refit( + ps_trim(fit, method = "ps", lower = 0.05, upper = 0.95), + fit + ) + w <- wt_ate(trimmed, .exposure = dat$z) + expect_true(anyNA(w)) + + out <- expect_silent(wt_trunc_sensitivity(w)) + + expect_equal(out, grid_from_wt_trunc(w, "pctl", c(0.99, 0.975, 0.95, 0.90))) + expect_equal(out$mean[[1]], mean(as.numeric(w), na.rm = TRUE)) +}) + +test_that("a pctl grid refuses fewer than two weights present, as wt_trunc() does", { + w <- psw(c(NA, 2.5, NA), estimand = "ate") + + expect_error(wt_trunc_sensitivity(w), class = "propensity_range_error") +}) + +test_that("a grid over no weights is refused under every method", { + # With no weight present there is no range or mean to report, so the grid is + # refused before any summary is taken, whatever the method. + inputs <- list( + all_missing = psw(c(NA_real_, NA_real_), estimand = "ate"), + empty = psw(double(), estimand = "ate"), + empty_numeric = double() + ) + grids <- list( + pctl = NULL, + wt = 5, + count = 1 + ) + + for (label in names(inputs)) { + for (method in names(grids)) { + expect_error( + wt_trunc_sensitivity( + inputs[[label]], + method = method, + upper = grids[[method]] + ), + class = "propensity_range_error", + info = paste(label, method) + ) + } + } + + empty <- inputs$empty + expect_propensity_error(wt_trunc_sensitivity(empty, method = "wt", upper = 5)) +}) + +test_that("continuous weights with a density record give the grid wt_trunc() implies", { + w <- continuous_sensitivity_weights() + expect_false(is.null(density_meta(w))) + expect_identical(exposure_type(w), "continuous") + + out <- expect_silent(wt_trunc_sensitivity(w)) + expect_equal(out, grid_from_wt_trunc(w, "pctl", c(0.99, 0.975, 0.95, 0.90))) + + by_weight <- wt_trunc_sensitivity(w, method = "wt", upper = c(3, 2, 1.5)) + expect_equal(by_weight, grid_from_wt_trunc(w, "wt", c(3, 2, 1.5))) + expect_equal(by_weight$mean[[1]], mean(as.numeric(w))) + + by_count <- wt_trunc_sensitivity(w, method = "count", lower = 1, upper = 1:3) + expect_equal(by_count, grid_from_wt_trunc(w, "count", 1:3, lower = 1)) +}) + +test_that("a zero weight makes the range ratio infinite", { + # Weights can be zero. The ratio is then the largest weight over zero, which + # is Inf, and it stays Inf in every row that leaves the zero in place. + x <- c(0, 1, 2, 3, 20) + w <- psw(x, estimand = "ate") + + out <- expect_silent(wt_trunc_sensitivity(w, method = "wt", upper = 10)) + + expect_identical(out$min, c(0, 0)) + expect_equal(out$max, c(20, 10)) + expect_identical(out$range_ratio, c(Inf, Inf)) + expect_equal(out$mean, c(26 / 5, 16 / 5)) + + # A lower bound above zero moves the zero and gives a finite ratio. + two_sided <- wt_trunc_sensitivity(w, method = "wt", lower = 0.5, upper = 10) + expect_equal(two_sided$range_ratio, c(Inf, 20)) +}) + +# ---- inputs refused ---------------------------------------------------------- + +test_that("propensity scores are refused, as wt_trunc() refuses them", { + dat <- sensitivity_data(n = 200) + ps <- stats::fitted(binary_sensitivity_fit(dat)) + scores <- list( + ps_trim = ps_trim(ps, method = "ps", lower = 0.1, upper = 0.9), + ps_trunc = ps_trunc(ps, method = "ps", lower = 0.1, upper = 0.9), + ps_calib = ps_calibrate(ps, dat$z) + ) + + for (label in names(scores)) { + expect_error( + wt_trunc_sensitivity(scores[[label]]), + class = "propensity_type_error", + info = label + ) + } + + trimmed <- scores$ps_trim + expect_propensity_error(wt_trunc_sensitivity(trimmed)) +}) + +test_that("input that is not weights is refused", { + expect_error( + wt_trunc_sensitivity(c("a", "b")), + class = "propensity_type_error" + ) + expect_error(wt_trunc_sensitivity(list(1, 2)), class = "propensity_error") +}) + +test_that("weights that are already truncated are refused", { + # A grid over weights that were already bounded would report a reference row + # that is not the untruncated weights, so it is refused rather than + # returned. The refusal points back to the original weights. + once <- wt_trunc(hand_weights(), method = "wt", upper = 5) + + expect_error( + wt_trunc_sensitivity(once), + class = "propensity_already_modified_error" + ) + expect_error( + wt_trunc_sensitivity(once, method = "wt", upper = c(4, 3)), + class = "propensity_already_modified_error" + ) + + message <- gsub( + "\\s+", + " ", + conditionMessage(rlang::catch_cnd(wt_trunc_sensitivity(once), "error")) + ) + expect_match(message, "already", fixed = TRUE) + expect_match(message, "wt_trunc()", fixed = TRUE) + + expect_propensity_error(wt_trunc_sensitivity(once)) +}) From b1dd098eb7b5fb3dc2beaa1843b8da4e16abbe8c Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 22:50:13 -0400 Subject: [PATCH 16/64] add wt_trunc_sensitivity() to tabulate weights over a grid of bounds --- NAMESPACE | 1 + NEWS.md | 6 + R/wt_trunc.R | 18 + R/wt_trunc_sensitivity.R | 320 ++++++++++++++++++ _pkgdown.yml | 1 + inst/WORDLIST | 1 + man/wt_trunc_sensitivity.Rd | 112 ++++++ tests/testthat/_snaps/wt-trunc-sensitivity.md | 113 +++++++ tests/testthat/_snaps/wt-trunc.md | 10 + tests/testthat/test-wt-trunc-sensitivity.R | 113 +++++++ tests/testthat/test-wt-trunc.R | 12 + 11 files changed, 707 insertions(+) create mode 100644 R/wt_trunc_sensitivity.R create mode 100644 man/wt_trunc_sensitivity.Rd create mode 100644 tests/testthat/_snaps/wt-trunc-sensitivity.md diff --git a/NAMESPACE b/NAMESPACE index 868ecdc1..835d95f4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -356,6 +356,7 @@ export(wt_cens) export(wt_entropy) export(wt_joint) export(wt_trunc) +export(wt_trunc_sensitivity) import(vctrs) importFrom(causalgenerics, "estimand<-", diff --git a/NEWS.md b/NEWS.md index 633ef6fb..eb4df772 100644 --- a/NEWS.md +++ b/NEWS.md @@ -15,6 +15,12 @@ which describe a truncated propensity score. Weights truncated at different bounds do not combine. +* New `wt_trunc_sensitivity()` truncates weights with `wt_trunc()` at each + bound in a grid and returns a tibble of the bounds as given and as applied, + the number of weights moved, and the range, range ratio, and mean of the + result, after a first row that describes the untruncated weights. The + default is a percentile grid at 0.99, 0.975, 0.95, and 0.90. + * `ipw()` refuses weights bounded with `wt_trunc()` on every exposure route, with the dedicated error class `propensity_ipw_wt_truncated_error`. The message names the two supported alternatives: rebuild the weights without diff --git a/R/wt_trunc.R b/R/wt_trunc.R index 8c3675dd..2dafb113 100644 --- a/R/wt_trunc.R +++ b/R/wt_trunc.R @@ -211,6 +211,9 @@ wt_trunc.numeric <- function( call <- rlang::current_env() rlang::check_dots_empty(call = call) method <- rlang::arg_match(method, error_call = call) + if (!is.null(dim(.weights))) { + abort_wt_trunc_dims(.weights, call = call) + } # `psw()` drops every attribute of what it is given, names included, and the # names identify the units the weights belong to. @@ -280,6 +283,21 @@ abort_wt_trunc_scores <- function(.weights, call = rlang::caller_env()) { ) } +# Weights are one per unit, so a matrix or array has no single reading as a +# vector of them. +abort_wt_trunc_dims <- function(.weights, call = rlang::caller_env()) { + abort( + c( + "{.arg .weights} must be a vector of weights, one per unit.", + x = "It has dimensions {paste(dim(.weights), collapse = ' x ')}.", + i = "Pass a {.cls psw} vector, such as one {.fun wt_ate} returns, or a + plain numeric vector." + ), + error_class = "propensity_type_error", + call = call + ) +} + # Winsorize a psw at the bounds `method` reads from `lower` and `upper`, and # write the result back over the original so that every attribute the # truncation does not describe is kept. diff --git a/R/wt_trunc_sensitivity.R b/R/wt_trunc_sensitivity.R new file mode 100644 index 00000000..6c934675 --- /dev/null +++ b/R/wt_trunc_sensitivity.R @@ -0,0 +1,320 @@ +#' Tabulate Truncated Weights Over a Grid of Bounds +#' +#' `wt_trunc_sensitivity()` truncates a set of weights with [wt_trunc()] at +#' each bound in a grid and tabulates what each truncation does to them: the +#' bound as given and as applied, the number of weights moved, and the range +#' and mean of the weights that result. The first row describes the weights +#' before any truncation, so every other row can be read against it. This is +#' the weight side of the sensitivity table Cole and Hernán (2008) recommend +#' for choosing a bound. +#' +#' @param .weights A [psw] vector, such as one returned by [wt_ate()], or a +#' numeric vector of weights. Propensity scores, including those returned by +#' [ps_trim()], [ps_trunc()], and [ps_calibrate()], are refused with an error +#' of class `propensity_type_error`, and weights that have already been +#' truncated with an error of class `propensity_already_modified_error`. +#' @param method The rule that reads each bound, one of `"pctl"` (the +#' default), `"wt"`, or `"count"`, as in [wt_trunc()]. The `"adaptive"` +#' method sets a single bound from the number of weights, so it has no grid +#' to vary and is not accepted. +#' @param lower An optional grid of lower bounds, read according to `method` +#' as `wt_trunc()` reads `lower`. A single value is used with every upper +#' bound; otherwise `lower` must have the same length as `upper`, and the two +#' are paired element by element. +#' @param upper The grid of upper bounds, read according to `method` as +#' `wt_trunc()` reads `upper`. For `"pctl"` it defaults to +#' `c(0.99, 0.975, 0.95, 0.90)`; for `"wt"` and `"count"` it is required. +#' +#' @details +#' Each row after the first is computed by calling [wt_trunc()] with that +#' row's bounds, so it describes exactly the weights that call returns. Every +#' bound in the grid must be one `wt_trunc()` accepts: a single invalid bound +#' refuses the whole grid, with the error `wt_trunc()` would raise for it, +#' rather than leaving a gap in the table. The rows follow the grid in the +#' order given. +#' +#' The summaries are taken over the weights that are present, so missing +#' weights, such as those of units set aside by [ps_trim()], take no part in +#' them and are never counted as truncated. A grid over weights of which none +#' are present is refused with an error of class `propensity_range_error`. +#' Weights can be zero, and a zero weight makes `range_ratio` infinite. +#' +#' Weights that have already been truncated are refused, because the first +#' row would then describe weights that were already bounded rather than the +#' weights before truncation. Pass the weights as they were before +#' `wt_trunc()` instead. +#' +#' ## What is left to the caller +#' +#' The table does not include effect estimates or effective sample sizes. +#' propensity fits no outcome models, so to add estimates to the table, map +#' over the grid, truncate the weights at each bound with `wt_trunc()`, and fit +#' the outcome model with each set of weights. For the effective sample size, +#' add the weights before and after truncation to a data frame as separate +#' columns and pass them to `halfmoon::check_ess()`. +#' +#' @return A [tibble][tibble::tibble] with one row for the untruncated weights +#' followed by one row per bound, and the columns: +#' * `lower`, `upper`: the bounds as given, `NA` in the first row and `lower` +#' `NA` when no lower bound was given. +#' * `lower_value`, `upper_value`: the bounds as applied, on the scale of the +#' weights, recorded by `wt_trunc()`. Both are `NA` in the first row, and +#' `lower_value` is `NA` when no lower bound was given. +#' * `n_truncated`: the number of weights moved, 0 in the first row. +#' * `min`, `max`, `mean`: the smallest, largest, and mean weight present. +#' * `range_ratio`: `max / min`. +#' +#' @references +#' Cole, S. R., & Hernán, M. A. (2008). Constructing inverse probability +#' weights for marginal structural models. *American Journal of +#' Epidemiology*, 168(6), 656--664. +#' +#' @seealso [wt_trunc()] to truncate the weights at a chosen bound. +#' +#' @examples +#' set.seed(1) +#' n <- 200 +#' x <- rnorm(n) +#' z <- rbinom(n, 1, plogis(2 * x)) +#' fit <- glm(z ~ x, family = binomial) +#' w <- wt_ate(fit, .exposure = z) +#' +#' # The default percentile grid. The first row is the untruncated weights. +#' wt_trunc_sensitivity(w) +#' +#' # A grid of absolute bounds, and a lower tail bounded at every one of them +#' wt_trunc_sensitivity(w, method = "wt", upper = c(20, 10, 5)) +#' wt_trunc_sensitivity(w, method = "wt", lower = 1.05, upper = c(20, 10, 5)) +#' +#' # The largest one, three, and ten weights +#' wt_trunc_sensitivity(w, method = "count", upper = c(1, 3, 10)) +#' +#' @export +wt_trunc_sensitivity <- function( + .weights, + method = c("pctl", "wt", "count"), + lower = NULL, + upper = NULL +) { + call <- rlang::current_env() + method <- rlang::arg_match(method, error_call = call) + + check_wt_trunc_sensitivity_weights(.weights, call = call) + + check_wt_trunc_sensitivity_grid(lower, "lower", call = call) + check_wt_trunc_sensitivity_grid(upper, "upper", call = call) + + if (is.null(upper)) { + upper <- wt_trunc_sensitivity_default_grid(method, call = call) + } + lower <- recycle_wt_trunc_sensitivity_lower(lower, upper, call = call) + + x <- vec_data(.weights) + present <- x[!is.na(x)] + if (length(present) == 0L) { + abort( + c( + "{.arg .weights} must have at least one weight present.", + x = "Of the {length(x)} weight{?s} given, none {?is/are} + present, so there is no range or mean to report." + ), + error_class = "propensity_range_error", + call = call + ) + } + + rows <- lapply(seq_along(upper), function(i) { + wt_trunc_sensitivity_row( + .weights, + i = i, + method = method, + lower = if (is.null(lower)) NULL else lower[[i]], + upper = upper[[i]], + call = call + ) + }) + + reference <- wt_trunc_sensitivity_summary( + present, + lower = NA_real_, + upper = NA_real_, + lower_value = NA_real_, + upper_value = NA_real_, + n_truncated = 0L + ) + + vec_rbind(reference, !!!rows) +} + +check_wt_trunc_sensitivity_weights <- function(.weights, call) { + if (inherits(.weights, c("ps_trim", "ps_trunc", "ps_calib"))) { + abort_wt_trunc_scores(.weights, call = call) + } + + if (!inherits(.weights, "psw") && !is.numeric(.weights)) { + abort( + c( + "{.arg .weights} must be a numeric vector of weights.", + x = "It is {.cls {class(.weights)[[1]]}}, which holds no weights to + bound.", + i = "Pass a {.cls psw} vector, such as one {.fun wt_ate} returns." + ), + error_class = "propensity_type_error", + call = call + ) + } + + if (!is.null(dim(.weights))) { + abort_wt_trunc_dims(.weights, call = call) + } + + if (inherits(.weights, "psw") && is_wt_truncated(.weights)) { + abort( + c( + "{.arg .weights} must not already be truncated.", + x = "The weights have already been bounded with {.fun wt_trunc}, so + the first row of the grid would describe weights that were + already bounded rather than the weights before truncation.", + i = "Pass the weights as they were before {.fun wt_trunc}." + ), + error_class = "propensity_already_modified_error", + call = call + ) + } + + invisible(TRUE) +} + +# A list would be split into bounds of any type by `[[`, so a grid must be an +# atomic vector before its elements are handed to `wt_trunc()`. +check_wt_trunc_sensitivity_grid <- function(value, arg, call) { + if (is.null(value) || is.atomic(value)) { + return(invisible(TRUE)) + } + + abort( + c( + "{.arg {arg}} must be a numeric vector of bounds.", + x = "It is {.cls {class(value)[[1]]}}." + ), + error_class = "propensity_type_error", + call = call + ) +} + +wt_trunc_sensitivity_default_grid <- function(method, call) { + if (method == "pctl") { + return(c(0.99, 0.975, 0.95, 0.90)) + } + + abort( + c( + "For {.code method = '{method}'}, {.arg upper} is required.", + i = "Supply the grid of upper bounds, or use {.code method = 'pctl'} to + read a default grid of quantiles." + ), + error_class = "propensity_missing_arg_error", + call = call + ) +} + +# `lower` is recycled to the length of `upper` and never the other way round: +# `upper` is the grid, and `lower` a bound paired with it. +recycle_wt_trunc_sensitivity_lower <- function(lower, upper, call) { + if (length(upper) == 0L) { + abort( + c( + "{.arg upper} must have at least one bound.", + x = "{.arg upper} has length 0, so there is no grid to tabulate." + ), + error_class = "propensity_length_error", + call = call + ) + } + + if (is.null(lower)) { + return(NULL) + } + if (length(lower) == 1L) { + return(rep(lower, length(upper))) + } + if (length(lower) != length(upper)) { + abort( + c( + "{.arg lower} must have length 1 or the length of {.arg upper}.", + x = "{.arg lower} has length {length(lower)} and {.arg upper} has + length {length(upper)}." + ), + error_class = "propensity_length_error", + call = call + ) + } + + lower +} + +# One truncated row. `wt_trunc()` validates the bounds and applies them, and a +# refusal it raises is reported against the grid the caller asked for. +wt_trunc_sensitivity_row <- function( + .weights, + i, + method, + lower, + upper, + call +) { + truncated <- rlang::try_fetch( + wt_trunc(.weights, method = method, lower = lower, upper = upper), + propensity_error = function(cnd) { + cnd$call <- call + # The position rather than the argument: a recycled `lower` can be the + # bound refused as well as `upper`. + cnd$body <- c( + cnd$body, + i = cli::format_inline( + "The refused bound is at position {i} of the grid." + ) + ) + rlang::cnd_signal(cnd) + } + ) + + meta <- attr(truncated, "psw_trunc_meta") + values <- vec_data(truncated) + + wt_trunc_sensitivity_summary( + values[!is.na(values)], + lower = na_if_null(meta$lower), + upper = meta$upper, + lower_value = na_if_null(meta$lower_value), + upper_value = meta$upper_value, + n_truncated = length(meta$truncated_idx) + ) +} + +wt_trunc_sensitivity_summary <- function( + present, + lower, + upper, + lower_value, + upper_value, + n_truncated +) { + # The names a psw carries identify units, not rows of the table. + present <- unname(present) + tibble::tibble( + lower = lower, + upper = upper, + lower_value = lower_value, + upper_value = upper_value, + n_truncated = n_truncated, + min = min(present), + max = max(present), + range_ratio = max(present) / min(present), + mean = mean(present) + ) +} + +na_if_null <- function(x) { + if (is.null(x)) NA_real_ else x +} diff --git a/_pkgdown.yml b/_pkgdown.yml index 41d7bc85..271bd8a4 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -56,6 +56,7 @@ reference: - is_ps_truncated - is_unit_truncated - wt_trunc + - wt_trunc_sensitivity - title: Calibration and tilting desc: Recalibrate fitted propensity scores, and evaluate the tilting function an estimand implies. diff --git a/inst/WORDLIST b/inst/WORDLIST index d21687c1..279c338d 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -138,6 +138,7 @@ unexamined ungrouped unstabilized untestable +untruncated validator vctrs winsorization diff --git a/man/wt_trunc_sensitivity.Rd b/man/wt_trunc_sensitivity.Rd new file mode 100644 index 00000000..32779a1c --- /dev/null +++ b/man/wt_trunc_sensitivity.Rd @@ -0,0 +1,112 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/wt_trunc_sensitivity.R +\name{wt_trunc_sensitivity} +\alias{wt_trunc_sensitivity} +\title{Tabulate Truncated Weights Over a Grid of Bounds} +\usage{ +wt_trunc_sensitivity( + .weights, + method = c("pctl", "wt", "count"), + lower = NULL, + upper = NULL +) +} +\arguments{ +\item{.weights}{A \link{psw} vector, such as one returned by \code{\link[=wt_ate]{wt_ate()}}, or a +numeric vector of weights. Propensity scores, including those returned by +\code{\link[=ps_trim]{ps_trim()}}, \code{\link[=ps_trunc]{ps_trunc()}}, and \code{\link[=ps_calibrate]{ps_calibrate()}}, are refused with an error +of class \code{propensity_type_error}, and weights that have already been +truncated with an error of class \code{propensity_already_modified_error}.} + +\item{method}{The rule that reads each bound, one of \code{"pctl"} (the +default), \code{"wt"}, or \code{"count"}, as in \code{\link[=wt_trunc]{wt_trunc()}}. The \code{"adaptive"} +method sets a single bound from the number of weights, so it has no grid +to vary and is not accepted.} + +\item{lower}{An optional grid of lower bounds, read according to \code{method} +as \code{wt_trunc()} reads \code{lower}. A single value is used with every upper +bound; otherwise \code{lower} must have the same length as \code{upper}, and the two +are paired element by element.} + +\item{upper}{The grid of upper bounds, read according to \code{method} as +\code{wt_trunc()} reads \code{upper}. For \code{"pctl"} it defaults to +\code{c(0.99, 0.975, 0.95, 0.90)}; for \code{"wt"} and \code{"count"} it is required.} +} +\value{ +A \link[tibble:tibble]{tibble} with one row for the untruncated weights +followed by one row per bound, and the columns: +\itemize{ +\item \code{lower}, \code{upper}: the bounds as given, \code{NA} in the first row and \code{lower} +\code{NA} when no lower bound was given. +\item \code{lower_value}, \code{upper_value}: the bounds as applied, on the scale of the +weights, recorded by \code{wt_trunc()}. Both are \code{NA} in the first row, and +\code{lower_value} is \code{NA} when no lower bound was given. +\item \code{n_truncated}: the number of weights moved, 0 in the first row. +\item \code{min}, \code{max}, \code{mean}: the smallest, largest, and mean weight present. +\item \code{range_ratio}: \code{max / min}. +} +} +\description{ +\code{wt_trunc_sensitivity()} truncates a set of weights with \code{\link[=wt_trunc]{wt_trunc()}} at +each bound in a grid and tabulates what each truncation does to them: the +bound as given and as applied, the number of weights moved, and the range +and mean of the weights that result. The first row describes the weights +before any truncation, so every other row can be read against it. This is +the weight side of the sensitivity table Cole and Hernán (2008) recommend +for choosing a bound. +} +\details{ +Each row after the first is computed by calling \code{\link[=wt_trunc]{wt_trunc()}} with that +row's bounds, so it describes exactly the weights that call returns. Every +bound in the grid must be one \code{wt_trunc()} accepts: a single invalid bound +refuses the whole grid, with the error \code{wt_trunc()} would raise for it, +rather than leaving a gap in the table. The rows follow the grid in the +order given. + +The summaries are taken over the weights that are present, so missing +weights, such as those of units set aside by \code{\link[=ps_trim]{ps_trim()}}, take no part in +them and are never counted as truncated. A grid over weights of which none +are present is refused with an error of class \code{propensity_range_error}. +Weights can be zero, and a zero weight makes \code{range_ratio} infinite. + +Weights that have already been truncated are refused, because the first +row would then describe weights that were already bounded rather than the +weights before truncation. Pass the weights as they were before +\code{wt_trunc()} instead. +\subsection{What is left to the caller}{ + +The table does not include effect estimates or effective sample sizes. +propensity fits no outcome models, so to add estimates to the table, map +over the grid, truncate the weights at each bound with \code{wt_trunc()}, and fit +the outcome model with each set of weights. For the effective sample size, +add the weights before and after truncation to a data frame as separate +columns and pass them to \code{halfmoon::check_ess()}. +} +} +\examples{ +set.seed(1) +n <- 200 +x <- rnorm(n) +z <- rbinom(n, 1, plogis(2 * x)) +fit <- glm(z ~ x, family = binomial) +w <- wt_ate(fit, .exposure = z) + +# The default percentile grid. The first row is the untruncated weights. +wt_trunc_sensitivity(w) + +# A grid of absolute bounds, and a lower tail bounded at every one of them +wt_trunc_sensitivity(w, method = "wt", upper = c(20, 10, 5)) +wt_trunc_sensitivity(w, method = "wt", lower = 1.05, upper = c(20, 10, 5)) + +# The largest one, three, and ten weights +wt_trunc_sensitivity(w, method = "count", upper = c(1, 3, 10)) + +} +\references{ +Cole, S. R., & Hernán, M. A. (2008). Constructing inverse probability +weights for marginal structural models. \emph{American Journal of +Epidemiology}, 168(6), 656--664. +} +\seealso{ +\code{\link[=wt_trunc]{wt_trunc()}} to truncate the weights at a chosen bound. +} diff --git a/tests/testthat/_snaps/wt-trunc-sensitivity.md b/tests/testthat/_snaps/wt-trunc-sensitivity.md new file mode 100644 index 00000000..f1b098cf --- /dev/null +++ b/tests/testthat/_snaps/wt-trunc-sensitivity.md @@ -0,0 +1,113 @@ +# a lower grid of any other length is refused + + Code + expr + Condition + Error in `wt_trunc_sensitivity()`: + ! `lower` must have length 1 or the length of `upper`. + x `lower` has length 2 and `upper` has length 4. + +# the absolute and count grids need upper, as wt_trunc() does + + Code + expr + Condition + Error in `wt_trunc_sensitivity()`: + ! For `method = 'wt'`, `upper` is required. + i Supply the grid of upper bounds, or use `method = 'pctl'` to read a default grid of quantiles. + +# one invalid bound refuses the whole grid with wt_trunc()'s class + + Code + expr + Condition + Error in `wt_trunc_sensitivity()`: + ! For `method = 'pctl'`, `upper` must be between 0.5 and 1. + x `upper` is 1.5. + i The refused bound is at position 2 of the grid. + +--- + + Code + expr + Condition + Error in `wt_trunc_sensitivity()`: + ! `lower` must be smaller than `upper`. + x `lower` is 3 and `upper` is 2.5. + i The refused bound is at position 2 of the grid. + +--- + + Code + expr + Condition + Error in `wt_trunc_sensitivity()`: + ! `upper` must not be missing. + i A missing bound decides nothing about which weights to move. Supply a value, or leave `lower` unset to bound only the upper tail. + i The refused bound is at position 2 of the grid. + +# an empty grid is refused + + Code + expr + Condition + Error in `wt_trunc_sensitivity()`: + ! `upper` must have at least one bound. + x `upper` has length 0, so there is no grid to tabulate. + +# the adaptive method is not a grid method + + Code + expr + Condition + Error in `wt_trunc_sensitivity()`: + ! `method` must be one of "pctl", "wt", or "count", not "adaptive". + +# a grid over no weights is refused under every method + + Code + expr + Condition + Error in `wt_trunc_sensitivity()`: + ! `.weights` must have at least one weight present. + x Of the 0 weights given, none are present, so there is no range or mean to report. + +# propensity scores are refused, as wt_trunc() refuses them + + Code + expr + Condition + Error in `wt_trunc_sensitivity()`: + ! `.weights` must be weights, not propensity scores. + x It is , a modified propensity score. + i Build weights from it with a weight function such as `wt_ate()` and truncate those, or bound the scores themselves with `ps_trunc()`. + +# a matrix of weights is refused + + Code + expr + Condition + Error in `wt_trunc_sensitivity()`: + ! `.weights` must be a vector of weights, one per unit. + x It has dimensions 2 x 2. + i Pass a vector, such as one `wt_ate()` returns, or a plain numeric vector. + +# a grid that is not an atomic vector is refused + + Code + expr + Condition + Error in `wt_trunc_sensitivity()`: + ! `upper` must be a numeric vector of bounds. + x It is . + +# weights that are already truncated are refused + + Code + expr + Condition + Error in `wt_trunc_sensitivity()`: + ! `.weights` must not already be truncated. + x The weights have already been bounded with `wt_trunc()`, so the first row of the grid would describe weights that were already bounded rather than the weights before truncation. + i Pass the weights as they were before `wt_trunc()`. + diff --git a/tests/testthat/_snaps/wt-trunc.md b/tests/testthat/_snaps/wt-trunc.md index f7459d69..b3d98177 100644 --- a/tests/testthat/_snaps/wt-trunc.md +++ b/tests/testthat/_snaps/wt-trunc.md @@ -108,6 +108,16 @@ x It is , which holds no weights to bound. i Pass a vector, such as one `wt_ate()` returns. +# wt_trunc() refuses a matrix of weights + + Code + expr + Condition + Error in `wt_trunc()`: + ! `.weights` must be a vector of weights, one per unit. + x It has dimensions 2 x 2. + i Pass a vector, such as one `wt_ate()` returns, or a plain numeric vector. + # wt_trunc() refuses propensity scores Code diff --git a/tests/testthat/test-wt-trunc-sensitivity.R b/tests/testthat/test-wt-trunc-sensitivity.R index 39a1b2c1..0323f2f4 100644 --- a/tests/testthat/test-wt-trunc-sensitivity.R +++ b/tests/testthat/test-wt-trunc-sensitivity.R @@ -410,9 +410,31 @@ test_that("one invalid bound refuses the whole grid with wt_trunc()'s class", { class = "propensity_type_error" ) + # The refusal names where in the grid the bound sits, including a lower + # bound that was recycled. + position <- function(expr) { + cnd <- rlang::catch_cnd(expr, classes = "error") + gsub("\\s+", " ", conditionMessage(cnd)) + } + expect_match( + position(wt_trunc_sensitivity(w, method = "pctl", upper = c(0.99, 1.5))), + "position 2 of the grid", + fixed = TRUE + ) + expect_match( + position( + wt_trunc_sensitivity(w, method = "wt", lower = 3, upper = c(5, 2.5)) + ), + "position 2 of the grid", + fixed = TRUE + ) + expect_propensity_error( wt_trunc_sensitivity(w, method = "pctl", upper = c(0.99, 1.5)) ) + expect_propensity_error( + wt_trunc_sensitivity(w, method = "wt", lower = 3, upper = c(5, 2.5)) + ) expect_propensity_error( wt_trunc_sensitivity(w, method = "wt", upper = c(5, NA)) ) @@ -622,6 +644,39 @@ test_that("input that is not weights is refused", { expect_error(wt_trunc_sensitivity(list(1, 2)), class = "propensity_error") }) +test_that("a matrix of weights is refused", { + weights <- matrix(c(1, 2, 3, 40), nrow = 2) + + expect_error(wt_trunc_sensitivity(weights), class = "propensity_type_error") + expect_error( + wt_trunc_sensitivity(weights, method = "wt", upper = 5), + class = "propensity_type_error" + ) + + expect_propensity_error(wt_trunc_sensitivity(weights)) +}) + +test_that("a grid that is not an atomic vector is refused", { + w <- hand_weights() + + expect_error( + wt_trunc_sensitivity(w, method = "wt", upper = list(5, 2)), + class = "propensity_type_error" + ) + expect_error( + wt_trunc_sensitivity(w, method = "wt", lower = list(1), upper = 5), + class = "propensity_type_error" + ) + expect_error( + wt_trunc_sensitivity(w, lower = list(0.01, 0.02, 0.03, 0.04)), + class = "propensity_type_error" + ) + + expect_propensity_error( + wt_trunc_sensitivity(w, method = "wt", upper = list(5, 2)) + ) +}) + test_that("weights that are already truncated are refused", { # A grid over weights that were already bounded would report a reference row # that is not the untruncated weights, so it is refused rather than @@ -647,3 +702,61 @@ test_that("weights that are already truncated are refused", { expect_propensity_error(wt_trunc_sensitivity(once)) }) + +# ---- conditions from wt_trunc() ---------------------------------------------- + +test_that("a warning raised inside wt_trunc() passes through unchanged", { + w <- hand_weights() + expected <- wt_trunc_sensitivity(w, method = "wt", upper = c(5, 2.5)) + real_wt_trunc <- wt_trunc + local_mocked_bindings( + wt_trunc = function(...) { + rlang::warn( + "A warning from inside.", + class = "inner_warning", + call = quote(inner()) + ) + real_wt_trunc(...) + } + ) + + warnings <- list() + out <- withCallingHandlers( + wt_trunc_sensitivity(w, method = "wt", upper = c(5, 2.5)), + warning = function(cnd) { + warnings[[length(warnings) + 1]] <<- cnd + invokeRestart("muffleWarning") + } + ) + + expect_identical(out, expected) + expect_length(warnings, 2) + for (cnd in warnings) { + expect_s3_class(cnd, "inner_warning") + expect_identical(conditionMessage(cnd), "A warning from inside.") + expect_identical(conditionCall(cnd), quote(inner())) + } +}) + +test_that("an error from inside wt_trunc() that is not a propensity error passes through unchanged", { + w <- hand_weights() + local_mocked_bindings( + wt_trunc = function(...) { + rlang::abort( + "An error from inside.", + class = "inner_error", + call = quote(inner()) + ) + } + ) + + cnd <- rlang::catch_cnd( + wt_trunc_sensitivity(w, method = "wt", upper = c(5, 2.5)), + classes = "error" + ) + + expect_s3_class(cnd, "inner_error") + expect_false(inherits(cnd, "propensity_error")) + expect_identical(conditionMessage(cnd), "An error from inside.") + expect_identical(conditionCall(cnd), quote(inner())) +}) diff --git a/tests/testthat/test-wt-trunc.R b/tests/testthat/test-wt-trunc.R index 8ebb7307..09c5f44c 100644 --- a/tests/testthat/test-wt-trunc.R +++ b/tests/testthat/test-wt-trunc.R @@ -802,6 +802,18 @@ test_that("wt_trunc() refuses input that is not weights", { expect_propensity_error(wt_trunc(c("a", "b"))) }) +test_that("wt_trunc() refuses a matrix of weights", { + weights <- matrix(c(1, 2, 3, 40), nrow = 2) + + expect_error( + wt_trunc(weights, method = "wt", upper = 5), + class = "propensity_type_error" + ) + expect_error(wt_trunc(weights), class = "propensity_type_error") + + expect_propensity_error(wt_trunc(weights, method = "wt", upper = 5)) +}) + test_that("wt_trunc() refuses propensity scores", { # A trimmed, truncated, or calibrated score is a score rather than a weight. # The refusal points to building weights from it first, or to bounding the From 6b01ec6879da800cc7af298d9a47f9da52471535 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 23:08:14 -0400 Subject: [PATCH 17/64] add failing tests for ps_trunc(method = "adaptive") on binary scores --- tests/testthat/test-ps_trunc-adaptive.R | 505 ++++++++++++++++++++++++ 1 file changed, 505 insertions(+) create mode 100644 tests/testthat/test-ps_trunc-adaptive.R diff --git a/tests/testthat/test-ps_trunc-adaptive.R b/tests/testthat/test-ps_trunc-adaptive.R new file mode 100644 index 00000000..354f9c50 --- /dev/null +++ b/tests/testthat/test-ps_trunc-adaptive.R @@ -0,0 +1,505 @@ +# The Gruber et al. (2022) bound, c = sqrt(n) log(n) / 5, written out here so +# that every oracle below is computed independently of the package. +gruber_c <- function(n) { + sqrt(n) * log(n) / 5 +} + +# Twenty scores, ten treated and ten untreated. No treated score lies above +# 1 - 1/c and no untreated score below 1/c, so the only bound either arm meets +# is the one that caps its own weights. Units 1 to 3 fall below 1/c = 0.373 and +# units 11 to 13 above 1 - 1/c = 0.627. +# fmt: skip +adaptive_ps <- c( + 0.05, 0.2, 0.3, 0.5, 0.6, 0.62, 0.45, 0.55, 0.4, 0.5, + 0.95, 0.8, 0.7, 0.5, 0.4, 0.38, 0.45, 0.55, 0.6, 0.39 +) +adaptive_z <- rep(c(1, 0), each = 10) + +# The same scores with a treated unit at 0.9 (unit 10) and an untreated one at +# 0.1 (unit 20). Each meets the bound that caps the other arm's weights. +nudged_ps <- replace(adaptive_ps, c(10, 20), c(0.9, 0.1)) + +# Winsorize by hand at [1/c, 1 - 1/c]. +bound_by_hand <- function(ps, c) { + pmin(pmax(ps, 1 / c), 1 - 1 / c) +} + +# Unstabilized binary ATE weights, by hand. +ate_by_hand <- function(ps, z) { + ifelse(z == 1, 1 / ps, 1 / (1 - ps)) +} + +adaptive_fit_data <- local({ + set.seed(4172) + n <- 200 + x1 <- rnorm(n) + x2 <- rnorm(n) + data.frame( + x1 = x1, + x2 = x2, + z = rbinom(n, 1, plogis(2.2 * x1 - 1.4 * x2)), + trt = factor(sample(c("a", "b", "c"), n, replace = TRUE)), + a2 = factor(ifelse( + runif(n) < plogis(2 * x1 - x2), + "control", + "treated" + )) + ) +}) + +adaptive_binary_fit <- function() { + glm(z ~ x1 + x2, data = adaptive_fit_data, family = binomial()) +} + +# ---- the bound --------------------------------------------------------------- + +test_that("method = 'adaptive' bounds binary scores at [1/c, 1 - 1/c]", { + c20 <- gruber_c(20) + expect_equal(1 / c20, 0.3732089, tolerance = 1e-6) + + out <- expect_silent(ps_trunc(adaptive_ps, method = "adaptive")) + + expect_s3_class(out, "ps_trunc") + expect_equal( + as.numeric(out), + bound_by_hand(adaptive_ps, c20), + tolerance = 1e-12 + ) + expect_identical(which(is_unit_truncated(out)), c(1L, 2L, 3L, 11L, 12L, 13L)) + # The scores inside the bounds are handed back exactly as they arrived. + untouched <- setdiff(seq_along(adaptive_ps), c(1:3, 11:13)) + expect_identical(as.numeric(out)[untouched], adaptive_ps[untouched]) +}) + +test_that("the adaptive record names the method, both bounds, and the units", { + c20 <- gruber_c(20) + out <- ps_trunc(adaptive_ps, method = "adaptive") + meta <- ps_trunc_meta(out) + + expect_identical( + names(meta), + c("method", "lower_bound", "upper_bound", "truncated_idx", "n_obs") + ) + expect_identical(meta$method, "adaptive") + expect_equal(meta$lower_bound, 1 / c20, tolerance = 1e-12) + expect_equal(meta$upper_bound, 1 - 1 / c20, tolerance = 1e-12) + expect_identical(meta$truncated_idx, c(1L, 2L, 3L, 11L, 12L, 13L)) + expect_identical(meta$n_obs, 20L) + expect_true(is_ps_truncated(out)) +}) + +test_that("the adaptive bound on a vector prints its method and bounds", { + expect_snapshot(print(ps_trunc(adaptive_ps, method = "adaptive"))) +}) + +test_that("the adaptive bound loosens as the number of scores grows", { + # At n = 200 the bound is [0.0667, 0.9333], far wider than at n = 20. + set.seed(52) + ps <- plogis(rnorm(200, sd = 2.5)) + c200 <- gruber_c(200) + + out <- ps_trunc(ps, method = "adaptive") + meta <- ps_trunc_meta(out) + + expect_equal(meta$lower_bound, 1 / c200, tolerance = 1e-12) + expect_equal(meta$upper_bound, 1 - 1 / c200, tolerance = 1e-12) + expect_equal(as.numeric(out), bound_by_hand(ps, c200), tolerance = 1e-12) + expect_identical( + meta$truncated_idx, + which(ps < 1 / c200 | ps > 1 - 1 / c200) + ) + expect_gt(length(meta$truncated_idx), 0) +}) + +test_that("the adaptive bound counts only the scores that are present", { + # Twenty of 22 scores are present, so the floor is 1/c(20) = 0.3732. Counting + # the two missing scores would put it at 1/c(22) = 0.3449 and leave the score + # of 0.36 at unit 9 alone. + ps <- c(replace(adaptive_ps, 9, 0.36), NA, NA) + c20 <- gruber_c(20) + expect_lt(1 / gruber_c(22), 0.36) + expect_gt(1 / c20, 0.36) + + out <- ps_trunc(ps, method = "adaptive") + meta <- ps_trunc_meta(out) + + expect_equal(meta$lower_bound, 1 / c20, tolerance = 1e-12) + expect_equal(meta$upper_bound, 1 - 1 / c20, tolerance = 1e-12) + expect_identical(meta$truncated_idx, c(1L, 2L, 3L, 9L, 11L, 12L, 13L)) + expect_identical(meta$n_obs, 22L) + expect_equal(as.numeric(out), bound_by_hand(ps, c20), tolerance = 1e-12) + # A missing score stays missing and is not a unit the bound moved. + expect_true(all(is.na(out[21:22]))) + expect_false(any(is_unit_truncated(out)[21:22])) +}) + +# ---- the equivalence with a weight bound ------------------------------------- + +test_that("adaptive score bounds cap unstabilized ATE weights at c", { + c20 <- gruber_c(20) + w_raw <- ate_by_hand(adaptive_ps, adaptive_z) + expect_gt(max(w_raw), c20) + + bounded <- ps_trunc(adaptive_ps, method = "adaptive") + wts <- wt_ate(bounded, .exposure = adaptive_z, .focal_level = 1) + + expect_equal(as.numeric(wts), pmin(w_raw, c20), tolerance = 1e-12) + expect_equal(max(as.numeric(wts)), c20, tolerance = 1e-12) +}) + +test_that("the adaptive score bound agrees with the adaptive weight bound", { + # With no unit meeting the bound on the other arm's side, the two routes give + # the same weights: the score bound and the weight bound share c. + bounded <- ps_trunc(adaptive_ps, method = "adaptive") + on_scores <- wt_ate(bounded, .exposure = adaptive_z, .focal_level = 1) + on_weights <- wt_trunc( + wt_ate(adaptive_ps, .exposure = adaptive_z, .focal_level = 1), + method = "adaptive" + ) + + expect_equal( + as.numeric(on_scores), + as.numeric(on_weights), + tolerance = 1e-12 + ) + expect_equal( + attr(on_weights, "psw_trunc_meta")$upper_value, + 1 / ps_trunc_meta(bounded)$lower_bound, + tolerance = 1e-12 + ) +}) + +test_that("the score bound also nudges units near the smallest weight", { + # Unit 10 is treated at 0.9 and unit 20 untreated at 0.1, so each has a + # weight of 1.11. The score bound moves both to the bound on the other side, + # giving each a weight of c / (c - 1) = 1.595, where the weight bound leaves + # them alone. Every other unit gets the same weight either way. + c20 <- gruber_c(20) + nudge <- c20 / (c20 - 1) + w_raw <- ate_by_hand(nudged_ps, adaptive_z) + + bounded <- ps_trunc(nudged_ps, method = "adaptive") + on_scores <- wt_ate(bounded, .exposure = adaptive_z, .focal_level = 1) + on_weights <- wt_trunc( + wt_ate(nudged_ps, .exposure = adaptive_z, .focal_level = 1), + method = "adaptive" + ) + + expect_identical( + ps_trunc_meta(bounded)$truncated_idx, + c(1L, 2L, 3L, 10L, 11L, 12L, 13L, 20L) + ) + + others <- setdiff(seq_along(nudged_ps), c(10, 20)) + expect_equal( + as.numeric(on_scores)[others], + pmin(w_raw, c20)[others], + tolerance = 1e-12 + ) + expect_equal( + as.numeric(on_scores)[others], + as.numeric(on_weights)[others], + tolerance = 1e-12 + ) + + expect_equal( + as.numeric(on_scores)[c(10, 20)], + c(nudge, nudge), + tolerance = 1e-12 + ) + expect_equal( + as.numeric(on_weights)[c(10, 20)], + w_raw[c(10, 20)], + tolerance = 1e-12 + ) + # The nudge raises a weight that was already below c / (c - 1) up to it, and + # every weight above c / (c - 1) is the same under either bound. + expect_true(all(w_raw[c(10, 20)] < nudge)) + large <- as.numeric(on_scores) > nudge + 1e-12 + expect_equal( + as.numeric(on_scores)[large], + as.numeric(on_weights)[large], + tolerance = 1e-12 + ) +}) + +test_that("the adaptive bound on a fitted model's scores caps ATE weights at c", { + fit <- adaptive_binary_fit() + ps <- unname(predict(fit, type = "response")) + z <- adaptive_fit_data$z + c200 <- gruber_c(200) + w_raw <- ate_by_hand(ps, z) + expect_gt(max(w_raw), c200) + + bounded <- ps_trunc(ps, method = "adaptive") + wts <- as.numeric(wt_ate(bounded, .exposure = z, .focal_level = 1)) + + # The units a bound on the other arm's side moves are the treated units above + # 1 - 1/c and the untreated units below 1/c. Everywhere else the weights are + # the capped weights, and there they are c / (c - 1). + nudged <- (z == 1 & ps > 1 - 1 / c200) | (z == 0 & ps < 1 / c200) + expect_true(any(nudged)) + expect_equal(wts[!nudged], pmin(w_raw, c200)[!nudged], tolerance = 1e-12) + expect_equal( + wts[nudged], + rep(c200 / (c200 - 1), sum(nudged)), + tolerance = 1e-12 + ) + expect_equal( + wts, + ate_by_hand(bound_by_hand(ps, c200), z), + tolerance = 1e-12 + ) +}) + +test_that("stabilized weights from the adaptive bound are capped per arm", { + # Stabilizing multiplies each arm's weights by its prevalence, so the treated + # weights are capped at p1 * c and the untreated at p0 * c. Unit 15 is moved + # to the treated arm, which puts p1 at 0.55 and p0 at 0.45. + z <- replace(adaptive_z, 15, 1) + c20 <- gruber_c(20) + p1 <- mean(z) + expect_equal(p1, 0.55) + + bounded <- ps_trunc(adaptive_ps, method = "adaptive") + wts <- as.numeric(wt_ate(bounded, .exposure = z, stabilize = TRUE)) + + expect_equal( + wts, + ifelse( + z == 1, + p1 / bound_by_hand(adaptive_ps, c20), + (1 - p1) / (1 - bound_by_hand(adaptive_ps, c20)) + ), + tolerance = 1e-12 + ) + expect_equal(max(wts[z == 1]), p1 * c20, tolerance = 1e-12) + expect_equal(max(wts[z == 0]), (1 - p1) * c20, tolerance = 1e-12) +}) + +# ---- weights built from the result ------------------------------------------- + +test_that("weights from adaptive scores are labelled as built from truncated scores", { + bounded <- ps_trunc(adaptive_ps, method = "adaptive") + + ate <- wt_ate(bounded, .exposure = adaptive_z, .focal_level = 1) + expect_identical(estimand(ate), "ate; truncated") + expect_true(is_ps_truncated(ate)) + expect_false(is_wt_truncated(ate)) + expect_identical(ps_trunc_meta(ate), ps_trunc_meta(bounded)) + expect_identical(is_unit_truncated(ate), is_unit_truncated(bounded)) + + att <- wt_att(bounded, .exposure = adaptive_z, .focal_level = 1) + expect_identical(estimand(att), "att; truncated") + expect_true(is_ps_truncated(att)) + expect_identical(ps_trunc_meta(att)$method, "adaptive") + + # The weight bound labels the weights, not the scores. + on_weights <- wt_trunc( + wt_ate(adaptive_ps, .exposure = adaptive_z, .focal_level = 1), + method = "adaptive" + ) + expect_identical(estimand(on_weights), "ate; weights truncated") + expect_false(is_ps_truncated(on_weights)) + expect_true(is_wt_truncated(on_weights)) +}) + +# ---- the record is told apart from "ps" -------------------------------------- + +test_that("an adaptive bound is not the same truncation as an equal 'ps' bound", { + c20 <- gruber_c(20) + adaptive <- ps_trunc(adaptive_ps, method = "adaptive") + fixed <- ps_trunc( + adaptive_ps, + method = "ps", + lower = 1 / c20, + upper = 1 - 1 / c20 + ) + + expect_equal(as.numeric(adaptive), as.numeric(fixed), tolerance = 1e-12) + expect_equal( + ps_trunc_meta(adaptive)$lower_bound, + ps_trunc_meta(fixed)$lower_bound + ) + + params_adaptive <- trunc_parameters(ps_trunc_meta(adaptive)) + params_fixed <- trunc_parameters(ps_trunc_meta(fixed)) + expect_identical(params_adaptive$method, "adaptive") + expect_identical(params_fixed$method, "ps") + expect_false(identical(params_adaptive, params_fixed)) + + expect_warning( + combined <- c(adaptive, fixed), + class = "propensity_coercion_warning" + ) + expect_false(inherits(combined, "ps_trunc")) +}) + +test_that("two adaptive bounds over the same number of scores combine", { + first <- ps_trunc(adaptive_ps, method = "adaptive") + second <- ps_trunc(rev(adaptive_ps), method = "adaptive") + + expect_identical( + trunc_parameters(ps_trunc_meta(first)), + trunc_parameters(ps_trunc_meta(second)) + ) + combined <- expect_no_warning(c(first, second)) + expect_s3_class(combined, "ps_trunc") + expect_identical(ps_trunc_meta(combined)$method, "adaptive") +}) + +# ---- supplied bounds --------------------------------------------------------- + +test_that("bounds supplied to the adaptive method are ignored with a warning", { + plain <- ps_trunc(adaptive_ps, method = "adaptive") + + expect_warning( + with_lower <- ps_trunc(adaptive_ps, method = "adaptive", lower = 0.2), + class = "propensity_warning", + regexp = "ignored" + ) + expect_warning( + with_upper <- ps_trunc(adaptive_ps, method = "adaptive", upper = 0.8), + class = "propensity_warning", + regexp = "ignored" + ) + expect_warning( + with_both <- ps_trunc( + adaptive_ps, + method = "adaptive", + lower = 0.2, + upper = 0.8 + ), + class = "propensity_warning", + regexp = "ignored" + ) + + # Nothing the caller wrote reaches the bounds or the record. + expect_identical(with_lower, plain) + expect_identical(with_upper, plain) + expect_identical(with_both, plain) + + expect_propensity_warning( + ps_trunc(adaptive_ps, method = "adaptive", lower = 0.2, upper = 0.8) + ) +}) + +# ---- too few scores ---------------------------------------------------------- + +test_that("the adaptive bound needs at least 15 scores", { + # Below c = 2 the floor 1/c lies above the ceiling 1 - 1/c, so there is no + # interval to bound the scores to. c first exceeds 2 at n = 15. + expect_lt(gruber_c(14), 2) + expect_gt(gruber_c(15), 2) + expect_lt(gruber_c(6), 1) + + ps15 <- seq(0.2, 0.8, length.out = 15) + c15 <- gruber_c(15) + out <- ps_trunc(ps15, method = "adaptive") + expect_equal(as.numeric(out), bound_by_hand(ps15, c15), tolerance = 1e-12) + expect_lt(ps_trunc_meta(out)$lower_bound, ps_trunc_meta(out)$upper_bound) + + expect_error( + ps_trunc(ps15[-1], method = "adaptive"), + class = "propensity_range_error" + ) + expect_error( + ps_trunc(ps15[1:6], method = "adaptive"), + class = "propensity_range_error" + ) + expect_error( + ps_trunc(0.5, method = "adaptive"), + class = "propensity_range_error" + ) + # A missing score does not count toward the fifteen. + expect_error( + ps_trunc(replace(ps15, 3, NA), method = "adaptive"), + class = "propensity_range_error" + ) + + expect_propensity_error(ps_trunc(ps15[1:14], method = "adaptive")) + expect_propensity_error(ps_trunc(ps15[1:6], method = "adaptive")) +}) + +# ---- routes ------------------------------------------------------------------ + +test_that("the adaptive bound reads a binary data frame's score column", { + df <- data.frame(control = 1 - adaptive_ps, treated = adaptive_ps) + + from_df <- ps_trunc(df, method = "adaptive") + oracle <- ps_trunc(adaptive_ps, method = "adaptive") + + expect_equal(as.numeric(from_df), as.numeric(oracle), tolerance = 1e-12) + expect_identical(class(from_df), class(oracle)) + expect_identical(ps_trunc_meta(from_df), ps_trunc_meta(oracle)) + + from_df_z <- ps_trunc(df, method = "adaptive", .exposure = adaptive_z) + expect_identical(ps_trunc_meta(from_df_z), ps_trunc_meta(oracle)) +}) + +test_that("the adaptive bound on a binomial fit bounds the scores it reports", { + fit <- adaptive_binary_fit() + scores <- predict(fit, type = "response") + + from_fit <- expect_silent(ps_trunc(fit, method = "adaptive")) + oracle <- ps_trunc(scores, method = "adaptive") + + expect_equal(as.numeric(from_fit), as.numeric(oracle), tolerance = 1e-12) + expect_identical(class(from_fit), class(oracle)) + expect_identical(ps_trunc_meta(from_fit), ps_trunc_meta(oracle)) + expect_identical(ps_trunc_meta(from_fit)$method, "adaptive") + expect_equal( + ps_trunc_meta(from_fit)$lower_bound, + 1 / gruber_c(200), + tolerance = 1e-12 + ) +}) + +test_that("the adaptive bound reads a two-level multinomial fit as binary", { + skip_if_not_installed("nnet") + + fit <- nnet::multinom(a2 ~ x1 + x2, data = adaptive_fit_data, trace = FALSE) + scores <- as.numeric(fitted(fit)) + + from_fit <- ps_trunc(fit, method = "adaptive") + oracle <- ps_trunc(scores, method = "adaptive") + + expect_equal(as.numeric(from_fit), as.numeric(oracle), tolerance = 1e-12) + expect_identical(ps_trunc_meta(from_fit), ps_trunc_meta(oracle)) +}) + +# ---- categorical refusals ---------------------------------------------------- + +test_that("the adaptive bound refuses a categorical score matrix", { + ps_mat <- matrix( + c(0.02, 0.49, 0.49, 0.3, 0.4, 0.3, 0.6, 0.2, 0.2), + ncol = 3, + byrow = TRUE, + dimnames = list(NULL, c("a", "b", "c")) + ) + trt <- factor(c("a", "b", "c")) + + expect_error( + ps_trunc(ps_mat, method = "adaptive", .exposure = trt), + class = "propensity_method_error" + ) + expect_error( + ps_trunc(as.data.frame(ps_mat), method = "adaptive", .exposure = trt), + class = "propensity_method_error" + ) + expect_propensity_error( + ps_trunc(ps_mat, method = "adaptive", .exposure = trt) + ) +}) + +test_that("the adaptive bound refuses a multinomial fit of three levels", { + skip_if_not_installed("nnet") + + fit <- nnet::multinom(trt ~ x1 + x2, data = adaptive_fit_data, trace = FALSE) + + expect_error( + ps_trunc(fit, method = "adaptive"), + class = "propensity_method_error" + ) + expect_propensity_error(ps_trunc(fit, method = "adaptive")) +}) From e0f7a17c38d52dc22f1fdfee32fdc896d2c629b7 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 23:27:20 -0400 Subject: [PATCH 18/64] add an adaptive bound to ps_trunc() for binary scores --- NEWS.md | 10 ++ R/ps_trunc.R | 150 +++++++++++++++++++-- R/wt_trunc.R | 11 +- man/ps_trunc.Rd | 61 ++++++++- man/ps_trunc_meta.Rd | 3 +- tests/testthat/_snaps/ps_trunc-adaptive.md | 61 +++++++++ tests/testthat/test-ps_trunc-adaptive.R | 61 ++++++++- 7 files changed, 337 insertions(+), 20 deletions(-) create mode 100644 tests/testthat/_snaps/ps_trunc-adaptive.md diff --git a/NEWS.md b/NEWS.md index eb4df772..a525d94d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -21,6 +21,16 @@ result, after a first row that describes the untruncated weights. The default is a percentile grid at 0.99, 0.975, 0.95, and 0.90. +* `ps_trunc()` gains `method = "adaptive"` for binary propensity scores. It + bounds the scores at `[1/c, 1 - 1/c]` with `c = sqrt(n) * log(n) / 5`, the + bound `wt_trunc(method = "adaptive")` places on the weights, where `n` counts + the scores present. For unstabilized ATE weights the two agree on every + weight above `c / (c - 1)`. `lower` and `upper` are ignored with a warning, + fewer than 15 scores are refused with an error of class + `propensity_range_error`, and a categorical score matrix or a multinomial + fit of three or more levels is refused with an error of class + `propensity_method_error`. + * `ipw()` refuses weights bounded with `wt_trunc()` on every exposure route, with the dedicated error class `propensity_ipw_wt_truncated_error`. The message names the two supported alternatives: rebuild the weights without diff --git a/R/ps_trunc.R b/R/ps_trunc.R index 63eca9eb..e002d695 100644 --- a/R/ps_trunc.R +++ b/R/ps_trunc.R @@ -28,11 +28,15 @@ #' @param .exposure An exposure vector. Required for method `"cr"` (binary #' exposure vector) and for categorical exposures (factor or character vector) #' with any method. -#' @param method One of `"ps"`, `"pctl"`, or `"cr"`: +#' @param method One of `"ps"`, `"adaptive"`, `"pctl"`, or `"cr"`: #' * `"ps"` (default): Truncate directly on propensity score values. Values #' outside `[lower, upper]` are set to the nearest bound. For categorical #' exposures, applies symmetric truncation using `lower` as the threshold #' (delta) and renormalizes rows to sum to 1. +#' * `"adaptive"`: Truncate at \eqn{[1/c, 1 - 1/c]} with +#' \eqn{c = \sqrt{n} \log(n) / 5} (Gruber et al., 2022), where \eqn{n} is +#' the number of propensity scores present (binary exposures only). See +#' **The adaptive bound** below. #' * `"pctl"`: Truncate at quantiles of the propensity score distribution. #' The `lower` and `upper` arguments specify quantile probabilities. For #' categorical exposures, quantiles are computed across all columns. @@ -47,6 +51,8 @@ #' #' For categorical exposures, only `"ps"` and `"pctl"` are supported. #' @param lower,upper Bounds for truncation. Interpretation depends on `method`: +#' * `method = "adaptive"`: Not used. Supplying either is ignored with a +#' warning. #' * `method = "ps"`: Propensity score values (defaults: 0.1 and 0.9). For #' categorical exposures, `lower` is the truncation threshold delta #' (default: 0.01) and `upper` is ignored. That default deliberately differs @@ -92,6 +98,46 @@ #' For **categorical exposures**, values below the threshold are set to the #' threshold and each row is renormalized to sum to 1. #' +#' ## The adaptive bound +#' +#' `method = "adaptive"` bounds a binary propensity score at +#' \eqn{[1/c, 1 - 1/c]}, where \eqn{c = \sqrt{n} \log(n) / 5} is the weight +#' bound of Gruber et al. (2022) and \eqn{n} counts the scores that are present, +#' as in [wt_trunc()]. At \eqn{n = 1000}, \eqn{c} is 43.7 and the bounds are +#' 0.023 and 0.977. The bound adapts to the sample size alone, loosening as +#' \eqn{n} grows, and leaves the estimand alone. `ps_trim(method = "adaptive")` +#' instead adapts to the estimated scores, tightening under poor overlap, and +#' changes the estimand to the population it keeps. +#' +#' For **unstabilized ATE weights** the bound is the weight bound written on the +#' score scale. A treated unit's weight is \eqn{1/e}, so the floor \eqn{1/c} +#' caps the treated weights at \eqn{c}; an untreated unit's weight is +#' \eqn{1/(1 - e)}, so the ceiling \eqn{1 - 1/c} caps the untreated weights at +#' \eqn{c}. `wt_ate()` on the result therefore gives the weights +#' `wt_trunc(wt_ate(ps, .exposure), method = "adaptive")` gives, with one +#' difference, provided every unit's exposure is observed. (A unit with a +#' present score and a missing exposure counts toward \eqn{n} here but has no +#' weight for [wt_trunc()] to count, so the two bounds then differ.) The +#' difference is this: a treated unit above \eqn{1 - 1/c} or an untreated unit below +#' \eqn{1/c}, whose weight is already close to 1, is moved to that bound too, +#' and its weight rises to \eqn{c / (c - 1)}. Every weight above +#' \eqn{c / (c - 1)} is the same under either route. A lower bound alone would +#' not do the same work, since no floor on \eqn{e} bounds an untreated unit's +#' weight. +#' +#' For **stabilized ATE weights** the equivalence does not carry over as it +#' stands. Stabilizing multiplies each arm's weights by that arm's prevalence, +#' so the treated weights are capped at \eqn{P(A = 1) c} and the untreated +#' weights at \eqn{P(A = 0) c}, which agree only when the two arms are equally +#' common. +#' +#' The bounds cross when \eqn{c < 2}, which holds for fewer than 15 scores, so +#' `"adaptive"` needs at least 15 scores present and raises an error of class +#' `propensity_range_error` otherwise. It is refused for categorical exposures +#' with an error of class `propensity_method_error`: truncating a categorical +#' score renormalizes each row, which moves scores the bound never reached, so +#' the bound no longer caps the weights. +#' #' **Arithmetic behavior**: Arithmetic operations on `ps_trunc` objects return #' plain numeric vectors. Once propensity scores are transformed (e.g., into #' weights), the result is no longer a propensity score. @@ -196,6 +242,12 @@ #' with limited overlap in estimation of average treatment effects. #' *Biometrika*, 96(1), 187--199. #' +#' Gruber, S., Phillips, R. V., Lee, H., & van der Laan, M. J. (2022). +#' Data-adaptive selection of the propensity score truncation level for +#' inverse-probability-weighted and targeted maximum likelihood estimators of +#' marginal point treatment effects. *American Journal of Epidemiology*, +#' 191(9), 1640--1651. +#' #' Walker, A. M., Patrick, A. R., Lauer, M. S., et al. (2013). A tool for #' assessing the feasibility of comparative effectiveness research. #' *Comparative Effectiveness Research*, 3, 11--20. @@ -216,6 +268,10 @@ #' ps_t <- ps_trunc(ps, method = "ps", lower = 0.1, upper = 0.9) #' ps_t #' +#' # Bound at [1/c, 1 - 1/c], c = sqrt(n) log(n) / 5, which caps the +#' # unstabilized ATE weights at c +#' ps_trunc(ps, method = "adaptive") +#' #' # Truncate at the 1st and 99th percentiles #' ps_trunc(ps, method = "pctl", lower = 0.01, upper = 0.99) #' @@ -237,7 +293,7 @@ #' @export ps_trunc <- function( .propensity, - method = c("ps", "pctl", "cr"), + method = c("ps", "adaptive", "pctl", "cr"), lower = NULL, upper = NULL, .exposure = NULL, @@ -260,7 +316,7 @@ ps_trunc <- function( #' @export ps_trunc.default <- function( .propensity, - method = c("ps", "pctl", "cr"), + method = c("ps", "adaptive", "pctl", "cr"), lower = NULL, upper = NULL, .exposure = NULL, @@ -331,6 +387,10 @@ ps_trunc.default <- function( lb <- lower ub <- upper + } else if (method == "adaptive") { + bounds <- ps_trunc_adaptive_bounds(.propensity, lower, upper, call = call) + lb <- bounds$lower + ub <- bounds$upper } else if (method == "pctl") { if (is.null(lower)) { lower <- 0.05 @@ -405,7 +465,7 @@ ps_trunc.default <- function( #' @export ps_trunc.matrix <- function( .propensity, - method = c("ps", "pctl", "cr"), + method = c("ps", "adaptive", "pctl", "cr"), lower = NULL, upper = NULL, .exposure = NULL, @@ -425,9 +485,12 @@ ps_trunc.matrix <- function( # reject the ones the categorical path does not define. method <- rlang::arg_match( method, - values = c("ps", "pctl", "cr"), + values = c("ps", "adaptive", "pctl", "cr"), error_call = call ) + if (method == "adaptive") { + abort_adaptive_categorical(call = call) + } if (!method %in% c("ps", "pctl")) { abort( c( @@ -649,7 +712,7 @@ check_truncated_matrix_interior <- function( #' @export ps_trunc.data.frame <- function( .propensity, - method = c("ps", "pctl", "cr"), + method = c("ps", "adaptive", "pctl", "cr"), lower = NULL, upper = NULL, .exposure = NULL, @@ -726,7 +789,7 @@ ps_trunc.data.frame <- function( #' @export ps_trunc.glm <- function( .propensity, - method = c("ps", "pctl", "cr"), + method = c("ps", "adaptive", "pctl", "cr"), lower = NULL, upper = NULL, .exposure = NULL, @@ -767,7 +830,7 @@ ps_trunc.glm <- function( #' @export ps_trunc.lm <- function( .propensity, - method = c("ps", "pctl", "cr"), + method = c("ps", "adaptive", "pctl", "cr"), lower = NULL, upper = NULL, .exposure = NULL, @@ -821,7 +884,7 @@ ps_trunc_dose_remedy <- function() { #' @export ps_trunc.multinom <- function( .propensity, - method = c("ps", "pctl", "cr"), + method = c("ps", "adaptive", "pctl", "cr"), lower = NULL, upper = NULL, .exposure = NULL, @@ -877,10 +940,16 @@ ps_trunc_from_model <- function( ) { method <- rlang::arg_match( method, - values = c("ps", "pctl", "cr"), + values = c("ps", "adaptive", "pctl", "cr"), error_call = call ) + # A fit with a column for every level is refused before its exposure is read, + # so the refusal is not preceded by an announcement of what was read. + if (method == "adaptive" && model_fits_levels(model)) { + abort_adaptive_categorical(call = call) + } + args <- prepare_model_ps( model, .exposure, @@ -930,7 +999,7 @@ ps_trunc_from_model <- function( #' @export ps_trunc.ps_trunc <- function( .propensity, - method = c("ps", "pctl", "cr"), + method = c("ps", "adaptive", "pctl", "cr"), lower = NULL, upper = NULL, .exposure = NULL, @@ -950,6 +1019,62 @@ ps_trunc.ps_trunc <- function( .propensity } +abort_adaptive_categorical <- function(call = rlang::caller_env()) { + abort( + c( + "Method {.val adaptive} is not supported for categorical exposures.", + i = "Bounding a categorical score renormalizes each row, which moves the + scores the bound never reached, so a bound on the scores is no + longer a bound on the weights.", + i = "Use {.fun ps_trim} with {.code method = \"optimal\"}, or build the + weights and bound them with {.fun wt_trunc}." + ), + error_class = "propensity_method_error", + call = call + ) +} + +# Gruber et al. (2022) cap the weights at c = sqrt(n) log(n) / 5. Flooring a +# binary score at 1/c caps the treated units' unstabilized ATE weights at c, and +# capping it at 1 - 1/c does the same for the untreated units, so the bound is +# two-sided. `n` counts the scores present, as `wt_trunc()` counts the weights. +ps_trunc_adaptive_bounds <- function(.propensity, lower, upper, call) { + if (!is.null(lower) || !is.null(upper)) { + warn( + c( + "For {.code method = 'adaptive'}, {.arg lower} and {.arg upper} are + ignored.", + i = "The adaptive bounds are set by the number of propensity scores. To + give bounds yourself, use {.code method = 'ps'}." + ), + call = call + ) + } + + n <- sum(!is.na(.propensity)) + c_bound <- adaptive_weight_bound(n) + + # Below c = 2 the floor lies above the ceiling, and at n = 1 or fewer c is not + # positive at all. The bound first exceeds 2 at 15 scores. + if (n < 2 || c_bound <= 2) { + abort( + c( + "For {.code method = 'adaptive'}, at least 15 propensity scores must be + present.", + x = "{n} score{?s} {?is/are} present.", + i = "The bounds are 1/c and 1 - 1/c with c = sqrt(n) log(n) / 5, and + below 15 scores c is under 2, so the lower bound would lie above + the upper one.", + i = "Supply bounds yourself with {.code method = 'ps'}." + ), + error_class = "propensity_range_error", + call = call + ) + } + + list(lower = 1 / c_bound, upper = 1 - 1 / c_bound) +} + # The common range is the region both exposure groups reach, which is empty when # the lowest score among the focal units sits above the highest among the # reference ones. Winsorizing to a crossed pair of bounds pins every score to the @@ -1097,7 +1222,8 @@ check_trunc_record <- function(meta, n, fn, call = rlang::caller_env()) { #' #' @param x A `ps_trunc` object created by [ps_trunc()]. #' @return A named list with truncation metadata, including: -#' * `method` -- the truncation method used (`"ps"`, `"pctl"`, or `"cr"`) +#' * `method` -- the truncation method used (`"ps"`, `"adaptive"`, +#' `"pctl"`, or `"cr"`) #' * `lower_bound`, `upper_bound` -- the applied bounds #' * `truncated_idx` -- integer positions of values that were winsorized #' * `n_obs` -- the number of observations those positions describe diff --git a/R/wt_trunc.R b/R/wt_trunc.R index 2dafb113..1b7d8305 100644 --- a/R/wt_trunc.R +++ b/R/wt_trunc.R @@ -366,16 +366,23 @@ wt_trunc_adaptive_bounds <- function(present, lower, upper, call) { } check_wt_trunc_n_present(present, "adaptive", call = call) - n <- length(present) list( lower = NULL, upper = NULL, lower_value = NULL, - upper_value = sqrt(n) * log(n) / 5 + upper_value = adaptive_weight_bound(length(present)) ) } +# The weight bound of Gruber et al. (2022) for `n` observed units. It is shared +# by `wt_trunc()`, which caps the weights at it, and `ps_trunc()`, which bounds +# binary scores at its reciprocal on both sides and so caps unstabilized ATE +# weights at the same value. +adaptive_weight_bound <- function(n) { + sqrt(n) * log(n) / 5 +} + wt_trunc_wt_bounds <- function(lower, upper, call) { upper <- wt_trunc_bound_arg(upper, "upper", "wt", call = call) lower <- wt_trunc_bound_arg(lower, "lower", "wt", call = call) diff --git a/man/ps_trunc.Rd b/man/ps_trunc.Rd index 94c2349d..69fe6338 100644 --- a/man/ps_trunc.Rd +++ b/man/ps_trunc.Rd @@ -6,7 +6,7 @@ \usage{ ps_trunc( .propensity, - method = c("ps", "pctl", "cr"), + method = c("ps", "adaptive", "pctl", "cr"), lower = NULL, upper = NULL, .exposure = NULL, @@ -38,12 +38,16 @@ returns when no prediction type is named, carries predicted levels rather than probabilities and is refused with an error of class \code{propensity_df_class_column_error}.} -\item{method}{One of \code{"ps"}, \code{"pctl"}, or \code{"cr"}: +\item{method}{One of \code{"ps"}, \code{"adaptive"}, \code{"pctl"}, or \code{"cr"}: \itemize{ \item \code{"ps"} (default): Truncate directly on propensity score values. Values outside \verb{[lower, upper]} are set to the nearest bound. For categorical exposures, applies symmetric truncation using \code{lower} as the threshold (delta) and renormalizes rows to sum to 1. +\item \code{"adaptive"}: Truncate at \eqn{[1/c, 1 - 1/c]} with +\eqn{c = \sqrt{n} \log(n) / 5} (Gruber et al., 2022), where \eqn{n} is +the number of propensity scores present (binary exposures only). See +\strong{The adaptive bound} below. \item \code{"pctl"}: Truncate at quantiles of the propensity score distribution. The \code{lower} and \code{upper} arguments specify quantile probabilities. For categorical exposures, quantiles are computed across all columns. @@ -61,6 +65,8 @@ For categorical exposures, only \code{"ps"} and \code{"pctl"} are supported.} \item{lower, upper}{Bounds for truncation. Interpretation depends on \code{method}: \itemize{ +\item \code{method = "adaptive"}: Not used. Supplying either is ignored with a +warning. \item \code{method = "ps"}: Propensity score values (defaults: 0.1 and 0.9). For categorical exposures, \code{lower} is the truncation threshold delta (default: 0.01) and \code{upper} is ignored. That default deliberately differs @@ -132,6 +138,45 @@ For \strong{binary exposures}, each propensity score \eqn{e_i} is bounded: For \strong{categorical exposures}, values below the threshold are set to the threshold and each row is renormalized to sum to 1. +\subsection{The adaptive bound}{ + +\code{method = "adaptive"} bounds a binary propensity score at +\eqn{[1/c, 1 - 1/c]}, where \eqn{c = \sqrt{n} \log(n) / 5} is the weight +bound of Gruber et al. (2022) and \eqn{n} counts the scores that are present, +as in \code{\link[=wt_trunc]{wt_trunc()}}. At \eqn{n = 1000}, \eqn{c} is 43.7 and the bounds are +0.023 and 0.977. The bound adapts to the sample size alone, loosening as +\eqn{n} grows, and leaves the estimand alone. \code{ps_trim(method = "adaptive")} +instead adapts to the estimated scores, tightening under poor overlap, and +changes the estimand to the population it keeps. + +For \strong{unstabilized ATE weights} the bound is the weight bound written on the +score scale. A treated unit's weight is \eqn{1/e}, so the floor \eqn{1/c} +caps the treated weights at \eqn{c}; an untreated unit's weight is +\eqn{1/(1 - e)}, so the ceiling \eqn{1 - 1/c} caps the untreated weights at +\eqn{c}. \code{wt_ate()} on the result therefore gives the weights +\code{wt_trunc(wt_ate(ps, .exposure), method = "adaptive")} gives, with one +difference, provided every unit's exposure is observed. (A unit with a +present score and a missing exposure counts toward \eqn{n} here but has no +weight for \code{\link[=wt_trunc]{wt_trunc()}} to count, so the two bounds then differ.) The +difference is this: a treated unit above \eqn{1 - 1/c} or an untreated unit below +\eqn{1/c}, whose weight is already close to 1, is moved to that bound too, +and its weight rises to \eqn{c / (c - 1)}. Every weight above +\eqn{c / (c - 1)} is the same under either route. A lower bound alone would +not do the same work, since no floor on \eqn{e} bounds an untreated unit's +weight. + +For \strong{stabilized ATE weights} the equivalence does not carry over as it +stands. Stabilizing multiplies each arm's weights by that arm's prevalence, +so the treated weights are capped at \eqn{P(A = 1) c} and the untreated +weights at \eqn{P(A = 0) c}, which agree only when the two arms are equally +common. + +The bounds cross when \eqn{c < 2}, which holds for fewer than 15 scores, so +\code{"adaptive"} needs at least 15 scores present and raises an error of class +\code{propensity_range_error} otherwise. It is refused for categorical exposures +with an error of class \code{propensity_method_error}: truncating a categorical +score renormalizes each row, which moves scores the bound never reached, so +the bound no longer caps the weights. \strong{Arithmetic behavior}: Arithmetic operations on \code{ps_trunc} objects return plain numeric vectors. Once propensity scores are transformed (e.g., into @@ -140,6 +185,8 @@ weights), the result is no longer a propensity score. \strong{Combining behavior}: Combining \code{ps_trunc} objects with \code{c()} requires matching truncation parameters. Mismatched parameters produce a warning and return a plain numeric vector. +} + \subsection{Fitted models}{ \code{.propensity} can be the fitted propensity score model instead of the scores @@ -239,6 +286,10 @@ ps <- predict(fit, type = "response") ps_t <- ps_trunc(ps, method = "ps", lower = 0.1, upper = 0.9) ps_t +# Bound at [1/c, 1 - 1/c], c = sqrt(n) log(n) / 5, which caps the +# unstabilized ATE weights at c +ps_trunc(ps, method = "adaptive") + # Truncate at the 1st and 99th percentiles ps_trunc(ps, method = "pctl", lower = 0.01, upper = 0.99) @@ -263,6 +314,12 @@ Crump, R. K., Hotz, V. J., Imbens, G. W., & Mitnik, O. A. (2009). Dealing with limited overlap in estimation of average treatment effects. \emph{Biometrika}, 96(1), 187--199. +Gruber, S., Phillips, R. V., Lee, H., & van der Laan, M. J. (2022). +Data-adaptive selection of the propensity score truncation level for +inverse-probability-weighted and targeted maximum likelihood estimators of +marginal point treatment effects. \emph{American Journal of Epidemiology}, +191(9), 1640--1651. + Walker, A. M., Patrick, A. R., Lauer, M. S., et al. (2013). A tool for assessing the feasibility of comparative effectiveness research. \emph{Comparative Effectiveness Research}, 3, 11--20. diff --git a/man/ps_trunc_meta.Rd b/man/ps_trunc_meta.Rd index 2daef2c8..ccc08fe1 100644 --- a/man/ps_trunc_meta.Rd +++ b/man/ps_trunc_meta.Rd @@ -12,7 +12,8 @@ ps_trunc_meta(x) \value{ A named list with truncation metadata, including: \itemize{ -\item \code{method} -- the truncation method used (\code{"ps"}, \code{"pctl"}, or \code{"cr"}) +\item \code{method} -- the truncation method used (\code{"ps"}, \code{"adaptive"}, +\code{"pctl"}, or \code{"cr"}) \item \code{lower_bound}, \code{upper_bound} -- the applied bounds \item \code{truncated_idx} -- integer positions of values that were winsorized \item \code{n_obs} -- the number of observations those positions describe diff --git a/tests/testthat/_snaps/ps_trunc-adaptive.md b/tests/testthat/_snaps/ps_trunc-adaptive.md new file mode 100644 index 00000000..d7b5c8ba --- /dev/null +++ b/tests/testthat/_snaps/ps_trunc-adaptive.md @@ -0,0 +1,61 @@ +# the adaptive bound on a vector prints its method and bounds + + Code + print(ps_trunc(adaptive_ps, method = "adaptive")) + Output + + [1] 0.3732089 0.3732089 0.3732089 0.5000000 0.6000000 0.6200000 0.4500000 + [8] 0.5500000 0.4000000 0.5000000 0.6267911 0.6267911 0.6267911 0.5000000 + [15] 0.4000000 0.3800000 0.4500000 0.5500000 0.6000000 0.3900000 + +# bounds supplied to the adaptive method are ignored with a warning + + Code + out <- ps_trunc(adaptive_ps, method = "adaptive", lower = 0.2, upper = 0.8) + Condition + Warning in `ps_trunc()`: + For `method = 'adaptive'`, `lower` and `upper` are ignored. + i The adaptive bounds are set by the number of propensity scores. To give bounds yourself, use `method = 'ps'`. + +# the adaptive bound needs at least 15 scores + + Code + expr + Condition + Error in `ps_trunc()`: + ! For `method = 'adaptive'`, at least 15 propensity scores must be present. + x 14 scores are present. + i The bounds are 1/c and 1 - 1/c with c = sqrt(n) log(n) / 5, and below 15 scores c is under 2, so the lower bound would lie above the upper one. + i Supply bounds yourself with `method = 'ps'`. + +--- + + Code + expr + Condition + Error in `ps_trunc()`: + ! For `method = 'adaptive'`, at least 15 propensity scores must be present. + x 6 scores are present. + i The bounds are 1/c and 1 - 1/c with c = sqrt(n) log(n) / 5, and below 15 scores c is under 2, so the lower bound would lie above the upper one. + i Supply bounds yourself with `method = 'ps'`. + +# the adaptive bound refuses a categorical score matrix + + Code + expr + Condition + Error in `ps_trunc()`: + ! Method "adaptive" is not supported for categorical exposures. + i Bounding a categorical score renormalizes each row, which moves the scores the bound never reached, so a bound on the scores is no longer a bound on the weights. + i Use `ps_trim()` with `method = "optimal"`, or build the weights and bound them with `wt_trunc()`. + +# the adaptive bound refuses a multinomial fit of three levels + + Code + expr + Condition + Error in `ps_trunc()`: + ! Method "adaptive" is not supported for categorical exposures. + i Bounding a categorical score renormalizes each row, which moves the scores the bound never reached, so a bound on the scores is no longer a bound on the weights. + i Use `ps_trim()` with `method = "optimal"`, or build the weights and bound them with `wt_trunc()`. + diff --git a/tests/testthat/test-ps_trunc-adaptive.R b/tests/testthat/test-ps_trunc-adaptive.R index 354f9c50..8d21ad33 100644 --- a/tests/testthat/test-ps_trunc-adaptive.R +++ b/tests/testthat/test-ps_trunc-adaptive.R @@ -335,6 +335,25 @@ test_that("an adaptive bound is not the same truncation as an equal 'ps' bound", expect_false(inherits(combined, "ps_trunc")) }) +test_that("adaptive bounds over different numbers of scores do not combine", { + # Twenty scores put the floor at 1/c(20) = 0.373 and thirty at + # 1/c(30) = 0.265, so the two are different truncations. + first <- ps_trunc(adaptive_ps, method = "adaptive") + second <- ps_trunc(seq(0.1, 0.9, length.out = 30), method = "adaptive") + expect_equal( + ps_trunc_meta(second)$lower_bound, + 1 / gruber_c(30), + tolerance = 1e-12 + ) + + expect_warning( + combined <- c(first, second), + class = "propensity_coercion_warning" + ) + expect_false(inherits(combined, "ps_trunc")) + expect_equal(combined, c(as.numeric(first), as.numeric(second))) +}) + test_that("two adaptive bounds over the same number of scores combine", { first <- ps_trunc(adaptive_ps, method = "adaptive") second <- ps_trunc(rev(adaptive_ps), method = "adaptive") @@ -455,6 +474,37 @@ test_that("the adaptive bound on a binomial fit bounds the scores it reports", { ) }) +test_that("the adaptive bound on a fit with excluded rows counts its fitted values", { + # Two of 22 rows are missing a covariate, and `na.exclude` pads the scores + # back to 22 with `NA`. The bound counts the 20 fitted values, so the floor + # is 1/c(20) = 0.373 rather than 1/c(22) = 0.345. + dat <- adaptive_fit_data[1:22, ] + dat$x1[c(3, 9)] <- NA + fit <- glm( + z ~ x1 + x2, + data = dat, + family = binomial(), + na.action = na.exclude + ) + scores <- predict(fit, type = "response") + expect_length(scores, 22) + expect_identical(sum(!is.na(scores)), 20L) + + from_fit <- ps_trunc(fit, method = "adaptive") + meta <- ps_trunc_meta(from_fit) + + expect_equal(meta$lower_bound, 1 / gruber_c(20), tolerance = 1e-12) + expect_equal(meta$upper_bound, 1 - 1 / gruber_c(20), tolerance = 1e-12) + expect_identical(meta$n_obs, 22L) + expect_true(all(is.na(from_fit[c(3, 9)]))) + expect_equal( + unname(as.numeric(from_fit)), + unname(bound_by_hand(scores, gruber_c(20))), + tolerance = 1e-12 + ) + expect_identical(meta, ps_trunc_meta(ps_trunc(scores, method = "adaptive"))) +}) + test_that("the adaptive bound reads a two-level multinomial fit as binary", { skip_if_not_installed("nnet") @@ -497,9 +547,14 @@ test_that("the adaptive bound refuses a multinomial fit of three levels", { fit <- nnet::multinom(trt ~ x1 + x2, data = adaptive_fit_data, trace = FALSE) - expect_error( - ps_trunc(fit, method = "adaptive"), - class = "propensity_method_error" + # The refusal comes before the exposure is read off the fit, so nothing is + # announced even with announcements switched on. + withr::local_options(propensity.quiet = FALSE) + expect_no_message( + expect_error( + ps_trunc(fit, method = "adaptive"), + class = "propensity_method_error" + ) ) expect_propensity_error(ps_trunc(fit, method = "adaptive")) }) From 0d8322dc81de9b210df3d779fcb10e64e19ca189 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 23:29:27 -0400 Subject: [PATCH 19/64] add a failing test for ps_refit() on a two-level multinom fit --- tests/testthat/test-ps_trim.R | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index 5606fde2..8f81e520 100644 --- a/tests/testthat/test-ps_trim.R +++ b/tests/testthat/test-ps_trim.R @@ -2909,6 +2909,36 @@ test_that("ps_refit() refits a multinomial fit trimmed through the model route", ) }) +test_that("ps_refit() refits a two-level multinomial fit on the binary path", { + skip_if_not_installed("nnet") + + fit <- trim_two_level_fit() + trimmed <- ps_trim(fit, method = "ps", lower = 0.3, upper = 0.7) + meta <- ps_trim_meta(trimmed) + expect_gt(length(meta$trimmed_idx), 0) + + expect_no_warning( + refitted <- ps_refit(trimmed, fit, .data = trim_model_data) + ) + + # The retained scores are the refit model's probability of the level the + # binary path reads as focal, which is the one column a two-level fit reports. + by_hand <- nnet::multinom( + a2 ~ x1 + x2, + data = trim_model_data[meta$keep_idx, ], + trace = FALSE + ) + expected <- rep(NA_real_, nrow(trim_model_data)) + expected[meta$keep_idx] <- as.numeric(fitted(by_hand)) + + expect_s3_class(refitted, "ps_trim") + expect_true(is_refit(refitted)) + expect_null(dim(refitted)) + expect_type(vctrs::vec_data(refitted), "double") + expect_equal(as.numeric(refitted), expected, tolerance = 1e-8) + expect_identical(ps_trim_meta(refitted)$keep_idx, meta$keep_idx) +}) + test_that("ps_trim() names the class of a fit it has no reading for", { expect_propensity_error( ps_trim(structure(list(), class = "not_a_model"), method = "ps") From b5c38731995e00706f777203f1bb1f93c78faf73 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 23:29:58 -0400 Subject: [PATCH 20/64] refit a two-level multinom through its probability prediction --- NAMESPACE | 2 ++ NEWS.md | 6 ++++++ R/categorical-models.R | 8 ++++++++ R/ps_trim.R | 6 +----- R/weights-utils.R | 11 +++++++++++ 5 files changed, 28 insertions(+), 5 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 835d95f4..79112322 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -92,6 +92,8 @@ S3method(model_fits_levels,multinom) S3method(model_levels,multinom) S3method(na.omit,ps_trim) S3method(obj_print_footer,psw) +S3method(predict_binary_ps,default) +S3method(predict_binary_ps,multinom) S3method(print,ipw_diagnostic_se) S3method(print,propensity_density) S3method(print,propensity_density_meta) diff --git a/NEWS.md b/NEWS.md index a525d94d..ebc6563d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,11 @@ # propensity 0.1.0.9000 (development version) +* `ps_refit()` now refits a binary score trimmed from a two-level + `nnet::multinom()` fit. It previously failed with an error from + `predict()`, which offers no `"response"` type for a `multinom`; the refit + now reads the probability of the second level, as the model route of + `ps_trim()` does. + * New `wt_trunc()` bounds extreme weights on the scale of the weights themselves, so it applies to weights for any exposure type, including the density-ratio weights of a continuous exposure. It offers four methods: diff --git a/R/categorical-models.R b/R/categorical-models.R index 79b6b4c1..1fa605a2 100644 --- a/R/categorical-models.R +++ b/R/categorical-models.R @@ -212,6 +212,14 @@ extract_binary_ps.multinom <- function(model, call = rlang::caller_env()) { as.numeric(stats::fitted(model)) } +# `predict()` on a `multinom` offers no response type. Its probabilities for a +# two-level fit are the one column `fitted()` reports, the probability of the +# second level. +#' @export +predict_binary_ps.multinom <- function(model, newdata) { + as.numeric(stats::predict(model, newdata = newdata, type = "probs")) +} + # A `multinom` keeps no model frame, so `model.frame()` rebuilds one by # re-evaluating the fitting call in the environment the formula came from. That # environment no longer holds the arguments of a fit made inside a function, and diff --git a/R/ps_trim.R b/R/ps_trim.R index 73f03e31..f61b418d 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -2686,11 +2686,7 @@ ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { } else { # For vector propensity scores (binary exposures) new_ps <- rep(NA_real_, n_obs) - new_ps[meta$keep_idx] <- stats::predict( - refit_model, - newdata = data_sub, - type = "response" - ) + new_ps[meta$keep_idx] <- predict_binary_ps(refit_model, data_sub) } meta$refit <- TRUE diff --git a/R/weights-utils.R b/R/weights-utils.R index cd7d1d88..c26cf423 100644 --- a/R/weights-utils.R +++ b/R/weights-utils.R @@ -1893,6 +1893,17 @@ extract_binary_ps.default <- function(model, call = rlang::caller_env()) { stats::predict(model, type = "response") } +# The probability of a binary exposure a fitted model predicts for `newdata`, +# the counterpart of `extract_binary_ps()` for rows the model was not read over. +predict_binary_ps <- function(model, newdata) { + UseMethod("predict_binary_ps") +} + +#' @export +predict_binary_ps.default <- function(model, newdata) { + stats::predict(model, newdata = newdata, type = "response") +} + # The propensity score a fitted model reports, read according to the exposure it # is a model of. A binary exposure needs the probability of the exposure, which # only the binomial families fit; a continuous exposure needs a conditional mean From 48614423440a17e79efa6d34e76d84dabdd5b159 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 23:30:52 -0400 Subject: [PATCH 21/64] add failing tests for trimming a binomial gam --- tests/testthat/test-ps_trim.R | 76 ++++++++++++++++++++++++++++++++++ tests/testthat/test-ps_trunc.R | 60 +++++++++++++++++++++++++++ 2 files changed, 136 insertions(+) diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index 8f81e520..995345c8 100644 --- a/tests/testthat/test-ps_trim.R +++ b/tests/testthat/test-ps_trim.R @@ -2939,6 +2939,82 @@ test_that("ps_refit() refits a two-level multinomial fit on the binary path", { expect_identical(ps_trim_meta(refitted)$keep_idx, meta$keep_idx) }) +# A binomial additive fit reports its scores as a one-dimensional array. With +# only parametric terms it fits the same model as the binomial `glm`, so the two +# trim the same units. +trim_gam_fit <- function() { + mgcv::gam(z ~ x1 + x2, data = trim_model_data, family = binomial()) +} + +test_that("ps_trim() trims a binomial additive fit like the equivalent glm", { + skip_if_not_installed("mgcv") + + gam_fit <- trim_gam_fit() + glm_fit <- trim_binary_fit() + gam_scores <- as.numeric(fitted(gam_fit)) + z <- trim_model_data$z + + trims <- list( + ps = list(method = "ps"), + adaptive = list(method = "adaptive"), + pctl = list(method = "pctl"), + pref = list(method = "pref", .exposure = z), + cr = list(method = "cr", .exposure = z) + ) + + for (kind in names(trims)) { + args <- trims[[kind]] + from_gam <- rlang::exec(ps_trim, gam_fit, !!!args) + from_glm <- rlang::exec(ps_trim, glm_fit, !!!args) + + expect_s3_class(from_gam, "ps_trim") + expect_null(dim(from_gam)) + expect_null(dim(vctrs::vec_data(from_gam))) + expect_same_trim(from_gam, rlang::exec(ps_trim, gam_scores, !!!args)) + expect_identical( + ps_trim_meta(from_gam)$keep_idx, + ps_trim_meta(from_glm)$keep_idx, + info = kind + ) + expect_identical( + ps_trim_meta(from_gam)$trimmed_idx, + ps_trim_meta(from_glm)$trimmed_idx, + info = kind + ) + expect_equal( + as.numeric(from_gam), + as.numeric(from_glm), + tolerance = 1e-6, + info = kind + ) + } +}) + +test_that("ps_refit() refits a score trimmed from a binomial additive fit", { + skip_if_not_installed("mgcv") + + fit <- trim_gam_fit() + trimmed <- ps_trim(fit, method = "ps", lower = 0.2, upper = 0.8) + meta <- ps_trim_meta(trimmed) + expect_gt(length(meta$trimmed_idx), 0) + + expect_no_warning( + refitted <- ps_refit(trimmed, fit, .data = trim_model_data) + ) + + by_hand <- mgcv::gam( + z ~ x1 + x2, + data = trim_model_data[meta$keep_idx, ], + family = binomial() + ) + expected <- rep(NA_real_, nrow(trim_model_data)) + expected[meta$keep_idx] <- as.numeric(fitted(by_hand)) + + expect_true(is_refit(refitted)) + expect_null(dim(vctrs::vec_data(refitted))) + expect_equal(as.numeric(refitted), expected, tolerance = 1e-8) +}) + test_that("ps_trim() names the class of a fit it has no reading for", { expect_propensity_error( ps_trim(structure(list(), class = "not_a_model"), method = "ps") diff --git a/tests/testthat/test-ps_trunc.R b/tests/testthat/test-ps_trunc.R index 5b82bbf5..8d63c5a4 100644 --- a/tests/testthat/test-ps_trunc.R +++ b/tests/testthat/test-ps_trunc.R @@ -2050,3 +2050,63 @@ test_that("ps_trunc() hands its own call to exposure-type detection", { expect_identical(detection_call, quote(outer_caller())) }) + +# A binomial additive fit reports its scores as a one-dimensional array. With +# only parametric terms it fits the same model as the binomial `glm`, so the two +# bound the same units. +test_that("ps_trunc() bounds a binomial additive fit like the equivalent glm", { + skip_if_not_installed("mgcv") + + set.seed(1187) + n <- 250 + gam_data <- data.frame(x1 = rnorm(n), x2 = rnorm(n)) + gam_data$z <- rbinom(n, 1, plogis(2 * gam_data$x1 - 1.2 * gam_data$x2)) + + gam_fit <- mgcv::gam(z ~ x1 + x2, data = gam_data, family = binomial()) + glm_fit <- glm(z ~ x1 + x2, data = gam_data, family = binomial()) + gam_scores <- as.numeric(fitted(gam_fit)) + + truncs <- list( + ps = list(method = "ps"), + pctl = list(method = "pctl"), + cr = list(method = "cr", .exposure = gam_data$z), + adaptive = list(method = "adaptive") + ) + + for (kind in names(truncs)) { + args <- truncs[[kind]] + from_gam <- rlang::exec(ps_trunc, gam_fit, !!!args) + from_glm <- rlang::exec(ps_trunc, glm_fit, !!!args) + from_scores <- rlang::exec(ps_trunc, gam_scores, !!!args) + + expect_s3_class(from_gam, "ps_trunc") + expect_null(dim(vctrs::vec_data(from_gam))) + expect_equal( + as.numeric(from_gam), + as.numeric(from_scores), + tolerance = 1e-12, + info = kind + ) + expect_identical( + ps_trunc_meta(from_gam), + ps_trunc_meta(from_scores), + info = kind + ) + expect_identical( + ps_trunc_meta(from_gam)$truncated_idx, + ps_trunc_meta(from_glm)$truncated_idx, + info = kind + ) + expect_equal( + as.numeric(from_gam), + as.numeric(from_glm), + tolerance = 1e-6, + info = kind + ) + } + + expect_gt( + length(ps_trunc_meta(ps_trunc(gam_fit, method = "adaptive"))$truncated_idx), + 0 + ) +}) From e37106e59875c01fec5338f603e773d05f970043 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 23:32:29 -0400 Subject: [PATCH 22/64] drop the dim attribute of a gam's fitted values --- NEWS.md | 6 ++++++ R/weights-utils.R | 16 +++++++++++++--- tests/testthat/test-ps_trim.R | 3 ++- tests/testthat/test-ps_trunc.R | 3 ++- 4 files changed, 23 insertions(+), 5 deletions(-) diff --git a/NEWS.md b/NEWS.md index ebc6563d..34424fc5 100644 --- a/NEWS.md +++ b/NEWS.md @@ -6,6 +6,12 @@ now reads the probability of the second level, as the model route of `ps_trim()` does. +* `ps_trim()` and `ps_trunc()` now read a binomial `mgcv::gam()` fit, whose + predicted probabilities are a one-dimensional array. Both previously failed + with an internal vctrs type error; the scores are now read as plain doubles + wherever a fitted model's scores are extracted, so the result matches the + equivalent binomial `glm()`, and `ps_refit()` refits such a trimmed score. + * New `wt_trunc()` bounds extreme weights on the scale of the weights themselves, so it applies to weights for any exposure type, including the density-ratio weights of a continuous exposure. It offers four methods: diff --git a/R/weights-utils.R b/R/weights-utils.R index c26cf423..b6cce040 100644 --- a/R/weights-utils.R +++ b/R/weights-utils.R @@ -1901,7 +1901,17 @@ predict_binary_ps <- function(model, newdata) { #' @export predict_binary_ps.default <- function(model, newdata) { - stats::predict(model, newdata = newdata, type = "response") + drop_1d_dim(stats::predict(model, newdata = newdata, type = "response")) +} + +# Some classes, such as `mgcv::gam()`, report one value per unit as a +# one-dimensional array. The score classes are built on plain doubles, so the +# dimension is dropped and the unit names it carried are kept as names. +drop_1d_dim <- function(x) { + if (length(dim(x)) != 1L) { + return(x) + } + stats::setNames(as.vector(x), names(x)) } # The propensity score a fitted model reports, read according to the exposure it @@ -1938,11 +1948,11 @@ extract_model_propensity <- function( call = call ) - return(extract_binary_ps(model, call = call)) + return(drop_1d_dim(extract_binary_ps(model, call = call))) } if (identical(exposure_type, "continuous")) { - return(extract_continuous_ps(model, call = call)$mu) + return(drop_1d_dim(extract_continuous_ps(model, call = call)$mu)) } extract_categorical_ps(model, exposure_levels, call = call) diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index 995345c8..7f3fae97 100644 --- a/tests/testthat/test-ps_trim.R +++ b/tests/testthat/test-ps_trim.R @@ -2951,7 +2951,8 @@ test_that("ps_trim() trims a binomial additive fit like the equivalent glm", { gam_fit <- trim_gam_fit() glm_fit <- trim_binary_fit() - gam_scores <- as.numeric(fitted(gam_fit)) + gam_scores <- predict(gam_fit, type = "response") + gam_scores <- setNames(as.vector(gam_scores), names(gam_scores)) z <- trim_model_data$z trims <- list( diff --git a/tests/testthat/test-ps_trunc.R b/tests/testthat/test-ps_trunc.R index 8d63c5a4..02038678 100644 --- a/tests/testthat/test-ps_trunc.R +++ b/tests/testthat/test-ps_trunc.R @@ -2064,7 +2064,8 @@ test_that("ps_trunc() bounds a binomial additive fit like the equivalent glm", { gam_fit <- mgcv::gam(z ~ x1 + x2, data = gam_data, family = binomial()) glm_fit <- glm(z ~ x1 + x2, data = gam_data, family = binomial()) - gam_scores <- as.numeric(fitted(gam_fit)) + gam_scores <- predict(gam_fit, type = "response") + gam_scores <- setNames(as.vector(gam_scores), names(gam_scores)) truncs <- list( ps = list(method = "ps"), From cdc10140f533a132876b29f7e4d578f23ec0296f Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 23:34:04 -0400 Subject: [PATCH 23/64] add failing tests for ps_refit() with a subset expression --- tests/testthat/test-ps_refit-density.R | 30 +++++++++ tests/testthat/test-ps_trim.R | 90 ++++++++++++++++++++++++++ 2 files changed, 120 insertions(+) diff --git a/tests/testthat/test-ps_refit-density.R b/tests/testthat/test-ps_refit-density.R index f45db6d1..e98b6711 100644 --- a/tests/testthat/test-ps_refit-density.R +++ b/tests/testthat/test-ps_refit-density.R @@ -324,6 +324,36 @@ test_that("ps_refit() reads a density trim's spread over the rows the refit anal ) }) +test_that("ps_refit() evaluates a subset expression against a density trim's retained rows", { + dat <- sim_dose_trim() + fit <- lm(a ~ x1 + x2, data = dat) + trimmed <- ps_trim(fit, method = "density", lower = 0.05) + keep <- ps_trim_meta(trimmed)$keep_idx + expect_gt(length(ps_trim_meta(trimmed)$trimmed_idx), 0) + + by_hand <- lm(a ~ x1 + x2, data = dat[keep, ], subset = x1 > 0) + expect_lt(length(fitted(by_hand)), length(keep)) + expected_mu <- rep(NA_real_, nrow(dat)) + expected_mu[keep] <- predict(by_hand, newdata = dat[keep, ]) + + expect_no_warning(refit <- ps_refit(trimmed, fit, subset = x1 > 0)) + expect_true(is_refit(refit)) + expect_equal(as.numeric(refit), expected_mu, tolerance = 1e-10) + expect_equal( + ps_trim_meta(refit)$sigma, + sqrt(mean(residuals(by_hand)^2)), + tolerance = 1e-10 + ) + + # The expression and the logical vector it evaluates to over the retained + # rows describe the same refit. + positive <- dat$x1[keep] > 0 + expect_identical( + ps_refit(trimmed, fit, subset = positive), + refit + ) +}) + # ---- ps_refit(): refusals ---------------------------------------------------- test_that("ps_refit() refuses a model of level probabilities for a density trim", { diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index 7f3fae97..0a1af233 100644 --- a/tests/testthat/test-ps_trim.R +++ b/tests/testthat/test-ps_trim.R @@ -3016,6 +3016,96 @@ test_that("ps_refit() refits a score trimmed from a binomial additive fit", { expect_equal(as.numeric(refitted), expected, tolerance = 1e-8) }) +# A `subset` or `weights` passed through `ps_refit()` is read the way +# `update()` reads it for a model fit on the retained rows: a column of those +# rows is found first, and any other name is found where the call was made. +test_that("ps_refit() evaluates a subset expression against the retained rows", { + fit <- trim_binary_fit() + trimmed <- ps_trim(fit, method = "ps", lower = 0.2, upper = 0.8) + keep <- ps_trim_meta(trimmed)$keep_idx + kept_rows <- trim_model_data[keep, ] + expect_gt(length(ps_trim_meta(trimmed)$trimmed_idx), 0) + + by_hand <- glm( + z ~ x1 + x2, + data = kept_rows, + family = binomial(), + subset = x1 > 0 + ) + expect_lt(length(fitted(by_hand)), length(keep)) + expected <- rep(NA_real_, nrow(trim_model_data)) + expected[keep] <- predict(by_hand, newdata = kept_rows, type = "response") + + expect_no_warning( + from_expr <- ps_refit( + trimmed, + fit, + .data = trim_model_data, + subset = x1 > 0 + ) + ) + expect_true(is_refit(from_expr)) + expect_equal(as.numeric(from_expr), expected, tolerance = 1e-10) + + # A name the retained rows do not carry is read from the calling frame, and a + # column the rows do carry masks a variable of the same name there. + cutoff <- 0 + x1 <- rep(-1, 3) + expect_equal( + as.numeric(ps_refit( + trimmed, + fit, + .data = trim_model_data, + subset = x1 > cutoff + )), + expected, + tolerance = 1e-10 + ) + + # A logical vector indexes the retained rows, which are the data the refit is + # handed, as it always has. + positive <- kept_rows$x1 > 0 + expect_equal( + as.numeric(ps_refit( + trimmed, + fit, + .data = trim_model_data, + subset = positive + )), + expected, + tolerance = 1e-10 + ) +}) + +test_that("ps_refit() evaluates subset and weights expressions from a function", { + weighted_data <- trim_model_data + weighted_data$w <- rep(1:3, length.out = nrow(weighted_data)) + fit <- glm(z ~ x1 + x2, data = weighted_data, family = binomial()) + trimmed <- ps_trim(fit, method = "ps", lower = 0.2, upper = 0.8) + keep <- ps_trim_meta(trimmed)$keep_idx + kept_rows <- weighted_data[keep, ] + + by_hand <- glm( + z ~ x1 + x2, + data = kept_rows, + family = binomial(), + weights = w, + subset = x2 < 0.5 + ) + expected <- rep(NA_real_, nrow(weighted_data)) + expected[keep] <- predict(by_hand, newdata = kept_rows, type = "response") + + # Neither the columns nor the threshold are visible where the model was fit, + # only in the frame of the function that asks for the refit. + refit_within <- function(trimmed, fit, data) { + threshold <- 0.5 + ps_refit(trimmed, fit, .data = data, weights = w, subset = x2 < threshold) + } + + expect_no_warning(refitted <- refit_within(trimmed, fit, weighted_data)) + expect_equal(as.numeric(refitted), expected, tolerance = 1e-10) +}) + test_that("ps_trim() names the class of a fit it has no reading for", { expect_propensity_error( ps_trim(structure(list(), class = "not_a_model"), method = "ps") From b6906cc6a1050b55e3a29ba226144aa37c659b58 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Wed, 16 Sep 2026 23:35:19 -0400 Subject: [PATCH 24/64] evaluate expressions passed to ps_refit() against the retained data --- NEWS.md | 7 +++++++ R/ps_trim.R | 38 +++++++++++++++++++++++++++++++++----- man/ps_refit.Rd | 8 +++++++- 3 files changed, 47 insertions(+), 6 deletions(-) diff --git a/NEWS.md b/NEWS.md index 34424fc5..7bd3d599 100644 --- a/NEWS.md +++ b/NEWS.md @@ -12,6 +12,13 @@ wherever a fitted model's scores are extracted, so the result matches the equivalent binomial `glm()`, and `ps_refit()` refits such a trimmed score. +* `ps_refit()` now evaluates an expression passed through `...`, such as + `subset = x1 > 0` or `weights = w`, against the retained rows, reading a + column of those rows first and any other name from the calling environment. + It previously failed with "object not found" unless the argument was an + already evaluated vector. A logical or index vector still indexes the + retained rows. + * New `wt_trunc()` bounds extreme weights on the scale of the weights themselves, so it applies to weights for any exposure type, including the density-ratio weights of a continuous exposure. It offers four methods: diff --git a/R/ps_trim.R b/R/ps_trim.R index f61b418d..044942eb 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -2523,7 +2523,13 @@ diff.ps_trim <- function(x, lag = 1L, differences = 1L, ...) { #' underlying variables let the transformation be recomputed from the retained #' rows. Pass `.data` when the data the model was fit on can no longer be #' reached. -#' @param ... Additional arguments passed to [update()][stats::update]. +#' @param ... Additional arguments passed to [update()][stats::update], such +#' as `subset` or `weights`. Each is evaluated against the retained rows, the +#' data the refit is handed: a name is read from their columns first and +#' otherwise from the environment `ps_refit()` was called from, so +#' `subset = x1 > 0` refits on the retained rows where `x1` is positive. A +#' logical or index vector supplied instead indexes the retained rows, not +#' the full data. #' #' @details #' ## Composing with a `subset` @@ -2645,11 +2651,13 @@ ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { # to work again would choose among rows it was never about. It is dropped # unless the caller names one, which is an instruction of its own. data_sub <- .data[meta$keep_idx, , drop = FALSE] - refit_call <- if ("subset" %in% ...names()) { - stats::update(model, data = data_sub, ..., evaluate = FALSE) - } else { - stats::update(model, data = data_sub, subset = NULL, ..., evaluate = FALSE) + refit_args <- refit_extra_args(rlang::enquos(...), data_sub) + if (!"subset" %in% names(refit_args)) { + refit_args <- c(refit_args, list(subset = NULL)) } + refit_call <- rlang::inject( + stats::update(model, data = data_sub, !!!refit_args, evaluate = FALSE) + ) refit_model <- eval(refit_call_function(refit_call, model)) if (density_record) { @@ -2703,6 +2711,26 @@ ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { ) } +# The arguments a caller passes to `ps_refit()` for `update()`, evaluated +# before the refit call is built. The call is evaluated in the frame of +# `ps_refit()`, where an expression such as `subset = x1 > 0` names nothing, so +# each argument is read here the way the fitting function would read it on the +# retained rows: a column of `data` first, and otherwise a name in the frame the +# argument was written in. `formula.` is a formula to update the model's own +# with rather than something to read from the rows, so it is read without them. +refit_extra_args <- function(dots, data) { + arg_names <- names(dots) + values <- lapply(seq_along(dots), function(i) { + if (identical(arg_names[[i]], "formula.")) { + rlang::eval_tidy(dots[[i]]) + } else { + rlang::eval_tidy(dots[[i]], data = data) + } + }) + names(values) <- arg_names + values +} + # Whether `model` can refit what the trimming record was made from. A record of # trimmed propensity scores needs a model that fits a probability: one that fits # a probability for every level, or one whose family fits the probability of a diff --git a/man/ps_refit.Rd b/man/ps_refit.Rd index 35af6cc2..137d533b 100644 --- a/man/ps_refit.Rd +++ b/man/ps_refit.Rd @@ -36,7 +36,13 @@ underlying variables let the transformation be recomputed from the retained rows. Pass \code{.data} when the data the model was fit on can no longer be reached.} -\item{...}{Additional arguments passed to \link[stats:update]{update()}.} +\item{...}{Additional arguments passed to \link[stats:update]{update()}, such +as \code{subset} or \code{weights}. Each is evaluated against the retained rows, the +data the refit is handed: a name is read from their columns first and +otherwise from the environment \code{ps_refit()} was called from, so +\code{subset = x1 > 0} refits on the retained rows where \code{x1} is positive. A +logical or index vector supplied instead indexes the retained rows, not +the full data.} } \value{ A \code{ps_trim} object with re-estimated propensity scores for retained From 503807a18b35b4b602b676364293225bb2ab40bb Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 07:09:24 -0400 Subject: [PATCH 25/64] refuse a refit whose model does not match the shape of the trimmed scores --- R/ps_trim.R | 77 +++++++++++++-- man/ps_refit.Rd | 5 +- tests/testthat/_snaps/ps_trim.md | 31 ++++++ tests/testthat/test-ps_trim.R | 158 +++++++++++++++++++++++++++++++ 4 files changed, 260 insertions(+), 11 deletions(-) diff --git a/R/ps_trim.R b/R/ps_trim.R index 044942eb..ef3d7a0b 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -2529,7 +2529,10 @@ diff.ps_trim <- function(x, lag = 1L, differences = 1L, ...) { #' otherwise from the environment `ps_refit()` was called from, so #' `subset = x1 > 0` refits on the retained rows where `x1` is positive. A #' logical or index vector supplied instead indexes the retained rows, not -#' the full data. +#' the full data. The `.data` and `.env` pronouns are available to tell a +#' column from a variable of the same name. Without `.data`, the retained +#' rows hold only the variables `model` reads, so an argument naming any +#' other column needs the data frame passed to `.data`. #' #' @details #' ## Composing with a `subset` @@ -2614,7 +2617,7 @@ ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { # Checked before any data are recovered or any model is refit, so that a # model that could never have produced the trimmed values is refused for that # rather than for whatever refitting it would run into. - check_refit_model(meta, model) + check_refit_model(meta, model, is.matrix(trimmed_ps)) density_record <- is_density_trim_record(meta) from_model <- is.null(.data) @@ -2651,7 +2654,7 @@ ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { # to work again would choose among rows it was never about. It is dropped # unless the caller names one, which is an instruction of its own. data_sub <- .data[meta$keep_idx, , drop = FALSE] - refit_args <- refit_extra_args(rlang::enquos(...), data_sub) + refit_args <- refit_extra_args(rlang::enquos(...), data_sub, from_model) if (!"subset" %in% names(refit_args)) { refit_args <- c(refit_args, list(subset = NULL)) } @@ -2718,14 +2721,40 @@ ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { # retained rows: a column of `data` first, and otherwise a name in the frame the # argument was written in. `formula.` is a formula to update the model's own # with rather than something to read from the rows, so it is read without them. -refit_extra_args <- function(dots, data) { +# +# Data recovered from the model hold only the variables the model itself reads, +# so an argument naming any other column fails there, and the error says how to +# make that column available. +refit_extra_args <- function( + dots, + data, + from_model, + call = rlang::caller_env() +) { arg_names <- names(dots) values <- lapply(seq_along(dots), function(i) { if (identical(arg_names[[i]], "formula.")) { - rlang::eval_tidy(dots[[i]]) - } else { - rlang::eval_tidy(dots[[i]], data = data) + return(rlang::eval_tidy(dots[[i]])) + } + if (!from_model) { + return(rlang::eval_tidy(dots[[i]], data = data)) } + tryCatch( + rlang::eval_tidy(dots[[i]], data = data), + error = function(cnd) { + abort( + c( + "Can't evaluate {.arg {arg_names[[i]]}} against the retained rows.", + i = "Without {.arg .data}, only the variables {.arg model} reads + are available as columns. Pass the data frame to + {.arg .data} to use any other column." + ), + error_class = "propensity_no_data_error", + call = call, + parent = cnd + ) + } + ) }) names(values) <- arg_names values @@ -2742,14 +2771,42 @@ refit_extra_args <- function(dots, data) { # by its class before the family is read, because the continuous family check # reads a model that carries no family as a least squares fit, and a two-level # `multinom` carries none and does not answer to `model_fits_levels()` either. -check_refit_model <- function(meta, model, call = rlang::caller_env()) { +# +# The shape of the trimmed scores decides which kind of probability model is +# needed: a matrix has a column for every level and a vector holds one +# probability, so `matrix_record` is read from `trimmed_ps` itself. +check_refit_model <- function( + meta, + model, + matrix_record, + call = rlang::caller_env() +) { density_record <- is_density_trim_record(meta) if (!density_record) { - if (model_fits_levels(model)) { - return(invisible(NULL)) + if (matrix_record) { + if (model_fits_levels(model)) { + return(invisible(NULL)) + } + + abort( + c( + "A matrix of trimmed propensity scores can only be refit with a + model of the probability of every exposure level.", + x = "{.arg trimmed_ps} holds one column per level, and + {.arg model} is {.cls {class(model)[[1]]}}, which fits a single + probability.", + i = "Refit with the model the scores were read from, such as a + {.fun nnet::multinom} fit to all of the exposure's levels." + ), + error_class = "propensity_model_family_error", + call = call + ) } + # A vector of scores is the probability of one level, so a model that + # reports a probability for every level of three or more has nothing to + # refit it with, and the binary family check refuses such a model. check_binary_model_family( model, arg = "model", diff --git a/man/ps_refit.Rd b/man/ps_refit.Rd index 137d533b..130a5338 100644 --- a/man/ps_refit.Rd +++ b/man/ps_refit.Rd @@ -42,7 +42,10 @@ data the refit is handed: a name is read from their columns first and otherwise from the environment \code{ps_refit()} was called from, so \code{subset = x1 > 0} refits on the retained rows where \code{x1} is positive. A logical or index vector supplied instead indexes the retained rows, not -the full data.} +the full data. The \code{.data} and \code{.env} pronouns are available to tell a +column from a variable of the same name. Without \code{.data}, the retained +rows hold only the variables \code{model} reads, so an argument naming any +other column needs the data frame passed to \code{.data}.} } \value{ A \code{ps_trim} object with re-estimated propensity scores for retained diff --git a/tests/testthat/_snaps/ps_trim.md b/tests/testthat/_snaps/ps_trim.md index 03f1bc2b..ad32fccb 100644 --- a/tests/testthat/_snaps/ps_trim.md +++ b/tests/testthat/_snaps/ps_trim.md @@ -274,6 +274,37 @@ i Scores predicted from a fit with `na.action = na.exclude` are padded back to the full length of the data, so they outnumber the rows the model analyzed. i Trim scores from a fit whose `na.action` drops those rows, such as `stats::na.omit()`. +# ps_refit() says how to reach a column the model does not read + + Code + expr + Condition + Error in `ps_refit()`: + ! Can't evaluate `subset` against the retained rows. + i Without `.data`, only the variables `model` reads are available as columns. Pass the data frame to `.data` to use any other column. + Caused by error: + ! object 'x2' not found + +# ps_refit() refuses a model of every level for a vector of scores + + Code + expr + Condition + Error in `ps_refit()`: + ! A binary propensity score needs the probability of one of the exposure's two levels. + x `model` was fit to 3 levels ("a", "b", and "c"), so it fits no single probability to read against a binary exposure. + i Fit the propensity score model to the exposure being weighted, or weight the exposure the model was fit to with `exposure_type = "categorical"`. + +# ps_refit() refuses a model of one probability for a matrix of scores + + Code + expr + Condition + Error in `ps_refit()`: + ! A matrix of trimmed propensity scores can only be refit with a model of the probability of every exposure level. + x `trimmed_ps` holds one column per level, and `model` is , which fits a single probability. + i Refit with the model the scores were read from, such as a `nnet::multinom()` fit to all of the exposure's levels. + # ps_trim() names the class of a fit it has no reading for Code diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index 0a1af233..e9409ea7 100644 --- a/tests/testthat/test-ps_trim.R +++ b/tests/testthat/test-ps_trim.R @@ -3106,6 +3106,164 @@ test_that("ps_refit() evaluates subset and weights expressions from a function", expect_equal(as.numeric(refitted), expected, tolerance = 1e-10) }) +test_that("ps_refit() removes the model's weights when passed weights = NULL", { + weighted_data <- trim_model_data + weighted_data$w <- rep(1:3, length.out = nrow(weighted_data)) + fit <- glm( + z ~ x1 + x2, + data = weighted_data, + family = binomial(), + weights = w + ) + trimmed <- ps_trim(fit, method = "ps", lower = 0.2, upper = 0.8) + keep <- ps_trim_meta(trimmed)$keep_idx + kept_rows <- weighted_data[keep, ] + + unweighted <- glm(z ~ x1 + x2, data = kept_rows, family = binomial()) + weighted <- glm( + z ~ x1 + x2, + data = kept_rows, + family = binomial(), + weights = w + ) + expect_false(isTRUE(all.equal(coef(unweighted), coef(weighted)))) + + by_hand <- function(model) { + expected <- rep(NA_real_, nrow(weighted_data)) + expected[keep] <- predict(model, newdata = kept_rows, type = "response") + expected + } + + expect_equal( + as.numeric(ps_refit(trimmed, fit, .data = weighted_data)), + by_hand(weighted), + tolerance = 1e-10 + ) + expect_equal( + as.numeric(ps_refit(trimmed, fit, .data = weighted_data, weights = NULL)), + by_hand(unweighted), + tolerance = 1e-10 + ) +}) + +test_that("ps_refit() updates the model's formula with formula.", { + fit <- trim_binary_fit() + trimmed <- ps_trim(fit, method = "ps", lower = 0.2, upper = 0.8) + keep <- ps_trim_meta(trimmed)$keep_idx + kept_rows <- trim_model_data[keep, ] + + by_hand <- glm(z ~ x1, data = kept_rows, family = binomial()) + expected <- rep(NA_real_, nrow(trim_model_data)) + expected[keep] <- predict(by_hand, newdata = kept_rows, type = "response") + + expect_equal( + as.numeric(ps_refit( + trimmed, + fit, + .data = trim_model_data, + formula. = ~ . - x2 + )), + expected, + tolerance = 1e-10 + ) + + # A formula held in a variable of the calling function is read there. + refit_within <- function(trimmed, fit) { + drop_x2 <- ~ . - x2 + ps_refit(trimmed, fit, .data = trim_model_data, formula. = drop_x2) + } + expect_equal( + as.numeric(refit_within(trimmed, fit)), + expected, + tolerance = 1e-10 + ) +}) + +test_that("ps_refit() reads the .data and .env pronouns in its arguments", { + fit <- trim_binary_fit() + trimmed <- ps_trim(fit, method = "ps", lower = 0.2, upper = 0.8) + keep <- ps_trim_meta(trimmed)$keep_idx + kept_rows <- trim_model_data[keep, ] + + x1 <- 0.25 + by_hand <- glm( + z ~ x1 + x2, + data = kept_rows, + family = binomial(), + subset = x1 > 0.25 + ) + expected <- rep(NA_real_, nrow(trim_model_data)) + expected[keep] <- predict(by_hand, newdata = kept_rows, type = "response") + + expect_equal( + as.numeric(ps_refit( + trimmed, + fit, + .data = trim_model_data, + subset = .data$x1 > .env$x1 + )), + expected, + tolerance = 1e-10 + ) +}) + +test_that("ps_refit() says how to reach a column the model does not read", { + fit <- glm(z ~ x1, data = trim_model_data, family = binomial()) + trimmed <- ps_trim(fit, method = "ps", lower = 0.3, upper = 0.7) + + expect_error( + ps_refit(trimmed, fit, subset = x2 > 0), + class = "propensity_no_data_error" + ) + expect_propensity_error(ps_refit(trimmed, fit, subset = x2 > 0)) + + # With the data passed, the column is found. + expect_no_error( + ps_refit(trimmed, fit, .data = trim_model_data, subset = x2 > 0) + ) +}) + +test_that("ps_refit() refuses a model of every level for a vector of scores", { + skip_if_not_installed("nnet") + + trimmed <- ps_trim( + predict(trim_binary_fit(), type = "response"), + method = "ps", + lower = 0.2, + upper = 0.8 + ) + + expect_error( + ps_refit(trimmed, trim_categorical_fit(), .data = trim_model_data), + class = "propensity_model_family_error" + ) + expect_propensity_error( + ps_refit(trimmed, trim_categorical_fit(), .data = trim_model_data) + ) +}) + +test_that("ps_refit() refuses a model of one probability for a matrix of scores", { + skip_if_not_installed("nnet") + + trimmed <- ps_trim( + fitted(trim_categorical_fit()), + method = "ps", + .exposure = trim_model_data$trt + ) + + expect_error( + ps_refit(trimmed, trim_two_level_fit(), .data = trim_model_data), + class = "propensity_model_family_error" + ) + expect_propensity_error( + ps_refit(trimmed, trim_two_level_fit(), .data = trim_model_data) + ) + expect_error( + ps_refit(trimmed, trim_binary_fit(), .data = trim_model_data), + class = "propensity_model_family_error" + ) +}) + test_that("ps_trim() names the class of a fit it has no reading for", { expect_propensity_error( ps_trim(structure(list(), class = "not_a_model"), method = "ps") From 309918534361381d03fdf9da0c5342369bea8971 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 07:10:07 -0400 Subject: [PATCH 26/64] add failing tests for refitting a trim with a first-level focal level --- tests/testthat/test-ps_trim.R | 55 +++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index e9409ea7..a62c64a7 100644 --- a/tests/testthat/test-ps_trim.R +++ b/tests/testthat/test-ps_trim.R @@ -3264,6 +3264,61 @@ test_that("ps_refit() refuses a model of one probability for a matrix of scores" ) }) +# A trim that names the first level as focal holds the probability of that +# level, one minus what the fit reports, and a refit keeps reporting the same +# level's probability. +expect_refit_keeps_focal_level <- function(fit, refit_by_hand, ...) { + trimmed <- ps_trim(fit, method = "ps", lower = 0.25, upper = 0.8, ...) + keep <- ps_trim_meta(trimmed)$keep_idx + expect_gt(length(ps_trim_meta(trimmed)$trimmed_idx), 0) + + by_hand <- refit_by_hand(trim_model_data[keep, ]) + expected <- rep(NA_real_, nrow(trim_model_data)) + expected[keep] <- 1 - as.numeric(fitted(by_hand)) + + expect_no_warning( + refitted <- ps_refit(trimmed, fit, .data = trim_model_data) + ) + expect_true(is_refit(refitted)) + expect_equal(as.numeric(refitted), expected, tolerance = 1e-8) +} + +test_that("ps_refit() keeps a first-level focal level of a binomial fit", { + refit_by_hand <- function(rows) { + glm(z ~ x1 + x2, data = rows, family = binomial()) + } + + expect_refit_keeps_focal_level( + trim_binary_fit(), + refit_by_hand, + .focal_level = 0 + ) + expect_refit_keeps_focal_level( + trim_binary_fit(), + refit_by_hand, + .reference_level = 1 + ) +}) + +test_that("ps_refit() keeps a first-level focal level of a two-level multinomial fit", { + skip_if_not_installed("nnet") + + refit_by_hand <- function(rows) { + nnet::multinom(a2 ~ x1 + x2, data = rows, trace = FALSE) + } + + expect_refit_keeps_focal_level( + trim_two_level_fit(), + refit_by_hand, + .focal_level = "control" + ) + expect_refit_keeps_focal_level( + trim_two_level_fit(), + refit_by_hand, + .reference_level = "treated" + ) +}) + test_that("ps_trim() names the class of a fit it has no reading for", { expect_propensity_error( ps_trim(structure(list(), class = "not_a_model"), method = "ps") From 6507fc93737ad0449204bc3015b2242f0addc56b Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 07:22:35 -0400 Subject: [PATCH 27/64] keep the focal level when refitting a trimmed score --- NEWS.md | 8 ++++ R/ps_trim.R | 36 +++++++++++++-- R/weights-utils.R | 3 +- man/ps_refit.Rd | 8 ++++ man/ps_trim.Rd | 4 ++ man/ps_trim_meta.Rd | 3 ++ tests/testthat/_snaps/ps_trim.md | 10 +++++ tests/testthat/test-ps_trim.R | 75 +++++++++++++++++++++++++++----- 8 files changed, 132 insertions(+), 15 deletions(-) diff --git a/NEWS.md b/NEWS.md index 7bd3d599..fbb6af02 100644 --- a/NEWS.md +++ b/NEWS.md @@ -19,6 +19,14 @@ already evaluated vector. A logical or index vector still indexes the retained rows. +* `ps_refit()` now keeps the focal level of a score trimmed from a fitted + model with its first level named as focal, through `.focal_level` or + `.reference_level`. Such scores are one minus the probability the model + reports, and the refit previously returned the model's own probability, the + other level's. The trim record gains a `focal_inverted` field that + `ps_refit()` reads, and combining an inverted trim with one that is not + inverted falls back to numeric with a warning. + * New `wt_trunc()` bounds extreme weights on the scale of the weights themselves, so it applies to weights for any exposure type, including the density-ratio weights of a continuous exposure. It offers four methods: diff --git a/R/ps_trim.R b/R/ps_trim.R index ef3d7a0b..35dc8399 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -313,6 +313,10 @@ #' * Method-specific fields such as `cutoff` (adaptive), `q_lower`/`q_upper` #' (pctl), `cr_lower`/`cr_upper` (cr), `delta` (categorical ps), #' or `lambda` (optimal) +#' * `focal_inverted` (vector scores only): `TRUE` when the scores are one +#' minus the probability a fitted model reports, because the model was +#' trimmed with its first level named as focal, and `FALSE` otherwise, +#' including for every vector of scores supplied directly #' #' A trim of a dose model records `method`, `lower` (`"density"`, else #' `NULL`), `upper` (`"resid"`, else `NULL`), `threshold` (the realized floor @@ -438,6 +442,10 @@ ps_trim.default <- function( .treated = NULL, .untreated = NULL, ps = lifecycle::deprecated(), + # Whether `.propensity` is one minus the probability a fitted model reports, + # which the model route decides when the caller names the model's first + # level as focal. Supplied scores are taken as given. + focal_inverted = FALSE, # Two frames arrive here because two condition systems read them. # `user_env` is the frame lifecycle reports a deprecation from, which decides # whether the reader is told to change their own call or to report an issue. @@ -574,6 +582,10 @@ ps_trim.default <- function( meta_list$calibrated <- TRUE } + # A refit predicts the probability the fitted model reports, and this says + # whether the retained scores are that probability or its complement. + meta_list$focal_inverted <- focal_inverted + # A score that arrived missing is not one this function can place against a # cutoff, so it takes no part in working the cutoff out and no part in the # record. Every rule below compares scores with `which()`, which leaves a @@ -1235,6 +1247,7 @@ ps_trim_from_model <- function( .focal_level = args$focal_level, .reference_level = args$reference_level, ..., + focal_inverted = args$focal_inverted, user_env = user_env, call = call ) @@ -2072,7 +2085,9 @@ vec_arith.ps_trim.list <- function(op, x, y, ...) { # method, the bounds it was given, and the cutoffs it settled on. A cutoff is # read off the scores, so two objects that agree on the method and the bounds # can still have been trimmed at different places. A trim of a dose model is -# also described by the spread and the density family it was read at. +# also described by the spread and the density family it was read at, and a +# vector of scores by whether they are the complement of what the model reports, +# since scores for different levels are not scores of one trimming. trim_parameters <- function(meta) { fields <- c( "method", @@ -2087,7 +2102,8 @@ trim_parameters <- function(meta) { "threshold", "sigma", "sigma_kind", - "density" + "density", + "focal_inverted" ) params <- rlang::set_names( @@ -2544,6 +2560,13 @@ diff.ps_trim <- function(x, lag = 1L, differences = 1L, ...) { #' put to work a second time on rows it was never about. A `subset` passed #' through `...` is an instruction of its own and is honored. #' +#' ## Which level a refit predicts +#' +#' For a vector of scores, the refit predicts the probability of the level the +#' scores describe: when [ps_trim()] was given a model with its first level +#' named as focal, the refit reports one minus the model's prediction, and for +#' scores supplied directly it reports the level the model predicts by default. +#' #' ## Arguments read from outside the formula #' #' `weights`, `offset`, and `na.action` in the original call are re-evaluated @@ -2697,7 +2720,11 @@ ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { } else { # For vector propensity scores (binary exposures) new_ps <- rep(NA_real_, n_obs) - new_ps[meta$keep_idx] <- predict_binary_ps(refit_model, data_sub) + refit_ps <- predict_binary_ps(refit_model, data_sub) + if (isTRUE(meta$focal_inverted)) { + refit_ps <- 1 - refit_ps + } + new_ps[meta$keep_idx] <- refit_ps } meta$refit <- TRUE @@ -3063,6 +3090,9 @@ is_refit.ps_trim <- function(x) { #' \item{`n_obs`}{The number of observations those indices describe.} #' \item{`lower`, `upper`}{Numeric cutoffs, when applicable.} #' \item{`refit`}{Logical, `TRUE` if the model was refit via [ps_refit()].} +#' \item{`focal_inverted`}{For a vector of scores, logical, `TRUE` if the +#' scores are one minus the probability the fitted model reports, which +#' [ps_refit()] reads to predict the same level.} #' } #' Additional method-specific elements (e.g. `cutoff`, `delta`, `lambda`) may #' also be present. diff --git a/R/weights-utils.R b/R/weights-utils.R index b6cce040..ea12994f 100644 --- a/R/weights-utils.R +++ b/R/weights-utils.R @@ -2382,6 +2382,7 @@ prepare_model_ps <- function( exposure = .exposure, exposure_type = "binary", focal_level = focal_params$.focal_level, - reference_level = focal_params$.reference_level + reference_level = focal_params$.reference_level, + focal_inverted = invert ) } diff --git a/man/ps_refit.Rd b/man/ps_refit.Rd index 130a5338..9029e657 100644 --- a/man/ps_refit.Rd +++ b/man/ps_refit.Rd @@ -87,6 +87,14 @@ put to work a second time on rows it was never about. A \code{subset} passed through \code{...} is an instruction of its own and is honored. } +\subsection{Which level a refit predicts}{ + +For a vector of scores, the refit predicts the probability of the level the +scores describe: when \code{\link[=ps_trim]{ps_trim()}} was given a model with its first level +named as focal, the refit reports one minus the model's prediction, and for +scores supplied directly it reports the level the model predicts by default. +} + \subsection{Arguments read from outside the formula}{ \code{weights}, \code{offset}, and \code{na.action} in the original call are re-evaluated diff --git a/man/ps_trim.Rd b/man/ps_trim.Rd index 79e8ce20..47d5ddce 100644 --- a/man/ps_trim.Rd +++ b/man/ps_trim.Rd @@ -176,6 +176,10 @@ with \code{\link[=ps_trim_meta]{ps_trim_meta()}}. Key fields include: \item Method-specific fields such as \code{cutoff} (adaptive), \code{q_lower}/\code{q_upper} (pctl), \code{cr_lower}/\code{cr_upper} (cr), \code{delta} (categorical ps), or \code{lambda} (optimal) +\item \code{focal_inverted} (vector scores only): \code{TRUE} when the scores are one +minus the probability a fitted model reports, because the model was +trimmed with its first level named as focal, and \code{FALSE} otherwise, +including for every vector of scores supplied directly } A trim of a dose model records \code{method}, \code{lower} (\code{"density"}, else diff --git a/man/ps_trim_meta.Rd b/man/ps_trim_meta.Rd index 4b7b420d..7a0fd18d 100644 --- a/man/ps_trim_meta.Rd +++ b/man/ps_trim_meta.Rd @@ -18,6 +18,9 @@ A named list with elements: \item{\code{n_obs}}{The number of observations those indices describe.} \item{\code{lower}, \code{upper}}{Numeric cutoffs, when applicable.} \item{\code{refit}}{Logical, \code{TRUE} if the model was refit via \code{\link[=ps_refit]{ps_refit()}}.} +\item{\code{focal_inverted}}{For a vector of scores, logical, \code{TRUE} if the +scores are one minus the probability the fitted model reports, which +\code{\link[=ps_refit]{ps_refit()}} reads to predict the same level.} } Additional method-specific elements (e.g. \code{cutoff}, \code{delta}, \code{lambda}) may also be present. diff --git a/tests/testthat/_snaps/ps_trim.md b/tests/testthat/_snaps/ps_trim.md index ad32fccb..4f654fba 100644 --- a/tests/testthat/_snaps/ps_trim.md +++ b/tests/testthat/_snaps/ps_trim.md @@ -305,6 +305,16 @@ x `trimmed_ps` holds one column per level, and `model` is , which fits a single probability. i Refit with the model the scores were read from, such as a `nnet::multinom()` fit to all of the exposure's levels. +# the record of an inverted trim follows the scores + + Code + out <- vctrs::vec_c(inverted, as_given) + Condition + Warning in `vec_ptype2.ps_trim.ps_trim()`: + Converting ps_trim to numeric: different trimming parameters + i Metadata cannot be preserved when combining incompatible objects + i Use identical objects or explicitly cast to numeric to avoid this warning + # ps_trim() names the class of a fit it has no reading for Code diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index a62c64a7..48bf4fd3 100644 --- a/tests/testthat/test-ps_trim.R +++ b/tests/testthat/test-ps_trim.R @@ -3319,6 +3319,61 @@ test_that("ps_refit() keeps a first-level focal level of a two-level multinomial ) }) +test_that("a trim records whether its scores are the complement of the fit's", { + fit <- trim_binary_fit() + scores <- predict(fit, type = "response") + + expect_false(ps_trim_meta(ps_trim(fit, method = "ps"))$focal_inverted) + expect_false( + ps_trim_meta(ps_trim(fit, method = "ps", .focal_level = 1))$focal_inverted + ) + expect_true( + ps_trim_meta(ps_trim(fit, method = "ps", .focal_level = 0))$focal_inverted + ) + + # Supplied scores are taken as given, whichever level is named. + expect_false( + ps_trim_meta(ps_trim( + scores, + method = "pref", + .exposure = trim_model_data$z, + .focal_level = 0 + ))$focal_inverted + ) + + # A matrix of scores and a trimmed dose model have no single level to invert. + expect_null( + ps_trim_meta(ps_trim( + fitted(trim_categorical_fit()), + method = "ps", + .exposure = trim_model_data$trt + ))$focal_inverted + ) +}) + +test_that("the record of an inverted trim follows the scores", { + fit <- trim_binary_fit() + inverted <- ps_trim( + fit, + method = "ps", + lower = 0.25, + upper = 0.8, + .focal_level = 0 + ) + as_given <- ps_trim(fit, method = "ps", lower = 0.25, upper = 0.8) + + expect_true(ps_trim_meta(inverted[1:10])$focal_inverted) + expect_true(ps_trim_meta(vctrs::vec_c(inverted, inverted))$focal_inverted) + refitted <- ps_refit(inverted, fit, .data = trim_model_data) + expect_true(ps_trim_meta(refitted)$focal_inverted) + weights <- wt_ate(refitted, .exposure = trim_model_data$z, .focal_level = 0) + expect_true(ps_trim_meta(weights)$focal_inverted) + + # Scores of different levels are not scores of one trimming. + combined <- expect_propensity_warning(vctrs::vec_c(inverted, as_given)) + expect_type(combined, "double") +}) + test_that("ps_trim() names the class of a fit it has no reading for", { expect_propensity_error( ps_trim(structure(list(), class = "not_a_model"), method = "ps") @@ -3364,10 +3419,9 @@ test_that("ps_trim() inverts a fit's scores for a named focal level", { fit <- trim_binary_fit() inverted <- 1 - predict(fit, type = "response") - expect_same_trim( - trim_pref(fit, .focal_level = 0), - trim_pref(inverted, .exposure = trim_model_data$z, .focal_level = 0) - ) + oracle <- trim_pref(inverted, .exposure = trim_model_data$z, .focal_level = 0) + attr(oracle, "ps_trim_meta")$focal_inverted <- TRUE + expect_same_trim(trim_pref(fit, .focal_level = 0), oracle) expect_false(identical( ps_trim_meta(trim_pref(fit, .focal_level = 0))$keep_idx, ps_trim_meta(trim_pref(fit))$keep_idx @@ -3380,14 +3434,13 @@ test_that("ps_trim() inverts a two-level multinomial fit for a named level", { fit <- trim_two_level_fit() inverted <- 1 - as.numeric(fitted(fit)) - expect_same_trim( - trim_pref(fit, .focal_level = "control"), - trim_pref( - inverted, - .exposure = trim_model_data$a2, - .focal_level = "control" - ) + oracle <- trim_pref( + inverted, + .exposure = trim_model_data$a2, + .focal_level = "control" ) + attr(oracle, "ps_trim_meta")$focal_inverted <- TRUE + expect_same_trim(trim_pref(fit, .focal_level = "control"), oracle) expect_false(identical( ps_trim_meta(trim_pref(fit, .focal_level = "control"))$keep_idx, ps_trim_meta(trim_pref(fit))$keep_idx From 286d299e4db9441442cb4dce13f5dae65266d769 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 07:32:29 -0400 Subject: [PATCH 28/64] add failing tests for the ps_trunc(method = "ps") default bounds --- tests/testthat/test-ps_trunc-default-bounds.R | 230 ++++++++++++++++++ 1 file changed, 230 insertions(+) create mode 100644 tests/testthat/test-ps_trunc-default-bounds.R diff --git a/tests/testthat/test-ps_trunc-default-bounds.R b/tests/testthat/test-ps_trunc-default-bounds.R new file mode 100644 index 00000000..71fabe70 --- /dev/null +++ b/tests/testthat/test-ps_trunc-default-bounds.R @@ -0,0 +1,230 @@ +# A bound the caller supplies to `ps_trunc(method = "ps")` implies its mirror +# on the vector path, and both paths share one default floor of 0.1. + +bounds_of <- function(x) { + meta <- ps_trunc_meta(x) + c(lower = meta$lower_bound, upper = meta$upper_bound) +} + +default_bounds_ps <- c(0.01, 0.04, 0.07, 0.2, 0.5, 0.8, 0.93, 0.96, 0.99) + +# Vector path --------------------------------------------------------------- + +test_that("a lower bound alone is mirrored to 1 - lower", { + out <- ps_trunc(default_bounds_ps, method = "ps", lower = 0.05) + + expect_equal(bounds_of(out), c(lower = 0.05, upper = 0.95)) + expect_equal( + as.numeric(out), + c(0.05, 0.05, 0.07, 0.2, 0.5, 0.8, 0.93, 0.95, 0.95) + ) +}) + +test_that("an upper bound alone is mirrored to 1 - upper", { + out <- ps_trunc(default_bounds_ps, method = "ps", upper = 0.95) + + expect_equal(bounds_of(out), c(lower = 0.05, upper = 0.95)) + expect_equal( + as.numeric(out), + c(0.05, 0.05, 0.07, 0.2, 0.5, 0.8, 0.93, 0.95, 0.95) + ) +}) + +test_that("neither bound supplied keeps the defaults of 0.1 and 0.9", { + out <- ps_trunc(default_bounds_ps, method = "ps") + + expect_equal(bounds_of(out), c(lower = 0.1, upper = 0.9)) + expect_equal( + as.numeric(out), + c(0.1, 0.1, 0.1, 0.2, 0.5, 0.8, 0.9, 0.9, 0.9) + ) +}) + +test_that("both bounds supplied are used as written, even when asymmetric", { + out <- ps_trunc(default_bounds_ps, method = "ps", lower = 0.05, upper = 0.8) + + expect_equal(bounds_of(out), c(lower = 0.05, upper = 0.8)) + expect_equal( + as.numeric(out), + c(0.05, 0.05, 0.07, 0.2, 0.5, 0.8, 0.8, 0.8, 0.8) + ) +}) + +test_that("a lone bound whose mirror crosses it is refused", { + expect_propensity_error( + ps_trunc(default_bounds_ps, method = "ps", lower = 0.6) + ) + expect_propensity_error( + ps_trunc(default_bounds_ps, method = "ps", upper = 0.4) + ) + + # A bound of exactly one half is its own mirror, which leaves no interval. + cnd <- rlang::catch_cnd( + ps_trunc(default_bounds_ps, method = "ps", lower = 0.5), + classes = "error" + ) + expect_s3_class(cnd, "propensity_range_error") + + cnd <- rlang::catch_cnd( + ps_trunc(default_bounds_ps, method = "ps", upper = 0.5), + classes = "error" + ) + expect_s3_class(cnd, "propensity_range_error") +}) + +test_that("a lower bound of 1/c gives the bounds the adaptive method computes", { + set.seed(4211) + ps <- runif(200, 0.01, 0.99) + n <- length(ps) + c_bound <- sqrt(n) * log(n) / 5 + + by_hand <- ps_trunc(ps, method = "ps", lower = 1 / c_bound) + adaptive <- ps_trunc(ps, method = "adaptive") + + expect_equal(bounds_of(by_hand), bounds_of(adaptive), tolerance = 1e-12) + expect_equal(as.numeric(by_hand), as.numeric(adaptive), tolerance = 1e-12) + expect_equal( + ps_trunc_meta(by_hand)$truncated_idx, + ps_trunc_meta(adaptive)$truncated_idx + ) +}) + +test_that("the data frame route mirrors a lone bound", { + ps_df <- data.frame( + `0` = 1 - default_bounds_ps, + `1` = default_bounds_ps, + check.names = FALSE + ) + + withr::local_options(propensity.quiet = TRUE) + from_lower <- ps_trunc(ps_df, method = "ps", lower = 0.05) + from_upper <- ps_trunc(ps_df, method = "ps", upper = 0.95) + from_neither <- ps_trunc(ps_df, method = "ps") + + expect_equal(bounds_of(from_lower), c(lower = 0.05, upper = 0.95)) + expect_equal(bounds_of(from_upper), c(lower = 0.05, upper = 0.95)) + expect_equal(bounds_of(from_neither), c(lower = 0.1, upper = 0.9)) + expect_equal( + as.numeric(from_lower), + as.numeric(ps_trunc(default_bounds_ps, method = "ps", lower = 0.05)) + ) +}) + +test_that("the glm route mirrors a lone bound", { + set.seed(52) + x <- rnorm(200) + z <- rbinom(200, 1, plogis(2 * x)) + fit <- glm(z ~ x, family = binomial) + + from_lower <- ps_trunc(fit, method = "ps", lower = 0.05) + from_upper <- ps_trunc(fit, method = "ps", upper = 0.95) + from_neither <- ps_trunc(fit, method = "ps") + + expect_equal(bounds_of(from_lower), c(lower = 0.05, upper = 0.95)) + expect_equal(bounds_of(from_upper), c(lower = 0.05, upper = 0.95)) + expect_equal(bounds_of(from_neither), c(lower = 0.1, upper = 0.9)) + expect_equal( + as.numeric(from_lower), + as.numeric(ps_trunc(unname(fitted(fit)), method = "ps", lower = 0.05)) + ) +}) + +test_that("the glm route refuses a lone bound whose mirror crosses it", { + set.seed(52) + x <- rnorm(50) + z <- rbinom(50, 1, plogis(x)) + fit <- glm(z ~ x, family = binomial) + + cnd <- rlang::catch_cnd( + ps_trunc(fit, method = "ps", lower = 0.7), + classes = "error" + ) + expect_s3_class(cnd, "propensity_range_error") +}) + +# Matrix path --------------------------------------------------------------- + +many_level_trunc_fixture <- function(k) { + lvls <- letters[seq_len(k)] + exposure <- factor(rep(lvls, length.out = 2 * k), levels = lvls) + ps_matrix <- matrix(1 / k, nrow = 2 * k, ncol = k) + # One row with a cell below every threshold these tests use. + ps_matrix[1, ] <- c(0.001, rep((1 - 0.001) / (k - 1), k - 1)) + colnames(ps_matrix) <- lvls + + list(exposure = exposure, ps_matrix = ps_matrix) +} + +test_that("the matrix path defaults the threshold to 0.1", { + exposure <- factor(c("a", "b", "c", "a", "b", "c")) + ps_matrix <- rbind( + c(0.05, 0.45, 0.50), + c(0.30, 0.50, 0.20), + c(0.20, 0.30, 0.50), + c(0.40, 0.40, 0.20), + c(0.25, 0.35, 0.40), + c(0.34, 0.33, 0.33) + ) + colnames(ps_matrix) <- levels(exposure) + + out <- ps_trunc(ps_matrix, .exposure = exposure, method = "ps") + meta <- ps_trunc_meta(out) + + expect_equal(meta$lower_bound, 0.1) + expect_true(is.na(meta$upper_bound)) + expect_equal(meta$truncated_idx, 1L) + + expected_row <- c(0.1, 0.45, 0.50) / sum(c(0.1, 0.45, 0.50)) + expect_equal(unname(as.matrix(out)[1, ]), expected_row) + + # The same floor reaches a data frame with the method left at its default. + from_df <- ps_trunc(as.data.frame(ps_matrix), .exposure = exposure) + expect_equal(ps_trunc_meta(from_df)$lower_bound, 0.1) +}) + +test_that("the matrix path ignores a lone upper bound", { + fixture <- many_level_trunc_fixture(3) + + out <- ps_trunc( + fixture$ps_matrix, + .exposure = fixture$exposure, + method = "ps", + upper = 0.8 + ) + meta <- ps_trunc_meta(out) + + expect_equal(meta$lower_bound, 0.1) + expect_true(is.na(meta$upper_bound)) +}) + +test_that("the default floor is accepted below ten levels", { + fixture <- many_level_trunc_fixture(9) + + out <- ps_trunc(fixture$ps_matrix, .exposure = fixture$exposure) + + expect_equal(ps_trunc_meta(out)$lower_bound, 0.1) + expect_equal(ps_trunc_meta(out)$truncated_idx, 1L) +}) + +test_that("the default floor meets the 1/k refusal at ten or more levels", { + ten <- many_level_trunc_fixture(10) + expect_propensity_error( + ps_trunc(ten$ps_matrix, .exposure = ten$exposure, method = "ps") + ) + + twelve <- many_level_trunc_fixture(12) + cnd <- rlang::catch_cnd( + ps_trunc(twelve$ps_matrix, .exposure = twelve$exposure), + classes = "error" + ) + expect_s3_class(cnd, "propensity_range_error") + + # An explicit threshold below 1/k is the way through. + out <- ps_trunc( + ten$ps_matrix, + .exposure = ten$exposure, + method = "ps", + lower = 0.05 + ) + expect_equal(ps_trunc_meta(out)$lower_bound, 0.05) +}) From dcfb36a82367fb408cfd45beeca5512cb94d24e1 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 07:37:17 -0400 Subject: [PATCH 29/64] mirror a single supplied bound in ps_trunc(method = "ps") --- NEWS.md | 11 +++ R/ps_trim.R | 10 +-- R/ps_trunc.R | 72 ++++++++++++++----- R/weights-utils.R | 10 ++- man/ps_trim.Rd | 10 +-- man/ps_trunc.Rd | 33 ++++++--- .../_snaps/ps_trunc-default-bounds.md | 31 ++++++++ tests/testthat/test-ps_trunc-categorical.R | 15 ++-- tests/testthat/test-ps_trunc-default-bounds.R | 2 +- 9 files changed, 142 insertions(+), 52 deletions(-) create mode 100644 tests/testthat/_snaps/ps_trunc-default-bounds.md diff --git a/NEWS.md b/NEWS.md index fbb6af02..4c7ef785 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,16 @@ # propensity 0.1.0.9000 (development version) +* Breaking change: `ps_trunc(method = "ps")` now mirrors a bound supplied + alone. `lower` alone bounds a binary score at `[lower, 1 - lower]`, and + `upper` alone at `[1 - upper, upper]`; previously the other bound took its + default of 0.1 or 0.9, so `lower = 0.05` bounded at `[0.05, 0.9]`. With + neither supplied the bounds stay `[0.1, 0.9]`, and with both supplied both + are used as written. A lone bound whose mirror crosses it, such as + `lower = 0.6`, is refused with an error of class `propensity_range_error`. + The default threshold for a categorical score matrix rises from 0.01 to 0.1, + matching the binary default and `ps_trim()`, so a matrix of ten or more + columns now needs an explicit `lower`. + * `ps_refit()` now refits a binary score trimmed from a two-level `nnet::multinom()` fit. It previously failed with an error from `predict()`, which offers no `"response"` type for a `multinom`; the refit diff --git a/R/ps_trim.R b/R/ps_trim.R index 35dc8399..a0684b4d 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -75,13 +75,9 @@ #' #' * `"ps"`: absolute propensity score bounds (defaults: 0.1, 0.9). For #' categorical exposures, only `lower` is used, as the symmetric threshold -#' delta, and it defaults to 0.1. That default deliberately differs from the -#' 0.01 threshold [ps_trunc()] uses for categorical exposures: trimming -#' discards the units it selects, so its default follows common-support -#' trimming practice, whereas truncation keeps every unit and only pins the -#' most extreme scores back. With `k` exposure levels, a threshold of `1/k` -#' or larger cannot be met by every column of a row that sums to one, and is -#' an error. +#' delta, and it defaults to 0.1, the default [ps_trunc()] uses as well. +#' With `k` exposure levels, a threshold of `1/k` or larger cannot be met by +#' every column of a row that sums to one, and is an error. #' * `"pctl"`: quantile probabilities (defaults: 0.05, 0.95). #' * `"pref"`: preference score bounds (defaults: 0.3, 0.7). #' * `"adaptive"`, `"cr"`, `"optimal"`: ignored (thresholds are data-driven). diff --git a/R/ps_trunc.R b/R/ps_trunc.R index e002d695..40f95c03 100644 --- a/R/ps_trunc.R +++ b/R/ps_trunc.R @@ -53,15 +53,8 @@ #' @param lower,upper Bounds for truncation. Interpretation depends on `method`: #' * `method = "adaptive"`: Not used. Supplying either is ignored with a #' warning. -#' * `method = "ps"`: Propensity score values (defaults: 0.1 and 0.9). For -#' categorical exposures, `lower` is the truncation threshold delta -#' (default: 0.01) and `upper` is ignored. That default deliberately differs -#' from the 0.1 threshold [ps_trim()] uses for categorical exposures: -#' truncation keeps every unit and only pins the most extreme scores back to -#' the threshold, so its default is a gentle winsorization, whereas trimming -#' discards the units it selects and follows common-support trimming -#' practice. With `k` exposure levels, a threshold of `1/k` or larger cannot -#' be met by every column of a row that sums to one, and is an error. +#' * `method = "ps"`: Propensity score values. See **The `"ps"` bounds** +#' below. #' * `method = "pctl"`: Quantile probabilities (defaults: 0.05 and 0.95; #' categorical defaults: 0.01 and 0.99). #' * `method = "cr"`: Ignored; bounds are determined by the data. @@ -98,6 +91,27 @@ #' For **categorical exposures**, values below the threshold are set to the #' threshold and each row is renormalized to sum to 1. #' +#' ## The `"ps"` bounds +#' +#' With `method = "ps"`, both paths default to a floor of 0.1. For a **binary +#' exposure**, a bound supplied alone implies its mirror: `lower` alone bounds +#' the scores at `[lower, 1 - lower]`, and `upper` alone at +#' `[1 - upper, upper]`. With neither supplied, the bounds are `[0.1, 0.9]`; +#' with both supplied, both are used as written, so an asymmetric bound must be +#' given in full. The mirror follows from the weights: an untreated unit's ATE +#' weight is \eqn{1/(1 - e)}, so a floor on \eqn{e} alone would bound the +#' treated weights and leave the untreated ones unbounded. A lone `lower` of +#' 0.5 or more, or a lone `upper` of 0.5 or less, meets or crosses its own +#' mirror and is an error of class `propensity_range_error`. `lower = 1/c` gives the bounds +#' `method = "adaptive"` computes for the same \eqn{c}. +#' +#' For a **categorical exposure**, `lower` is the threshold \eqn{\delta} +#' (default 0.1) applied to every column, after which each row is renormalized, +#' and `upper` is not read and is recorded as `NA`. With `k` exposure levels, a +#' threshold of `1/k` or larger cannot be met by every column of a row that +#' sums to one and is an error, so an exposure with ten or more levels needs an +#' explicit `lower` below `1/k`. +#' #' ## The adaptive bound #' #' `method = "adaptive"` bounds a binary propensity score at @@ -377,13 +391,27 @@ ps_trunc.default <- function( check_ps_range(.propensity, call = call) if (method == "ps") { - if (is.null(lower)) { + # A bound supplied alone implies its mirror. An untreated unit's weight is + # 1 / (1 - e), so a floor on the score with no matching ceiling would leave + # one arm's weights bounded and the other's not. + mirror_hint <- NULL + if (is.null(lower) && is.null(upper)) { lower <- 0.1 - } - if (is.null(upper)) { upper <- 0.9 + } else if (is.null(upper)) { + check_bounds_not_missing(lower, 0, call = call) + upper <- 1 - lower + mirror_hint <- "{.arg upper} was not supplied, so it is the mirror of + {.arg lower}, 1 - {.arg lower}. Supply both to bound the scores + asymmetrically." + } else if (is.null(lower)) { + check_bounds_not_missing(1, upper, call = call) + lower <- 1 - upper + mirror_hint <- "{.arg lower} was not supplied, so it is the mirror of + {.arg upper}, 1 - {.arg upper}. Supply both to bound the scores + asymmetrically." } - check_lower_upper(lower, upper, call = call) + check_lower_upper(lower, upper, hint = mirror_hint, call = call) lb <- lower ub <- upper @@ -548,10 +576,14 @@ ps_trunc.matrix <- function( if (method == "ps") { # Symmetric truncation - if (is.null(lower)) { - lower <- 0.01 - } # Default threshold - delta <- lower # Use lower as delta for consistency + # The same default floor as the vector path and as `ps_trim()`'s matrix + # path. `upper` is not read: a column floor followed by renormalization + # has no upper bound. + defaulted <- is.null(lower) + if (defaulted) { + lower <- 0.1 + } + delta <- lower # A threshold at or above 1/k cannot be met by every column of a row that # sums to one, so there is no truncation rule left to apply. Both numbers @@ -566,7 +598,11 @@ ps_trunc.matrix <- function( x = "{.arg lower} is {.val {delta}}, and 1/k is {limit} for the {k} column{?s} the scores hold.", i = "No row summing to one can hold every score above 1/k, so a - threshold there leaves no rule to apply." + threshold there leaves no rule to apply.", + i = if (defaulted) { + "{.arg lower} was not supplied, and {.val {delta}} is its default. + Supply a {.arg lower} below {limit}." + } ), error_class = "propensity_range_error", call = call diff --git a/R/weights-utils.R b/R/weights-utils.R index ea12994f..269cfeaa 100644 --- a/R/weights-utils.R +++ b/R/weights-utils.R @@ -773,14 +773,20 @@ check_bounds_not_missing <- function( ) } -check_lower_upper <- function(lower, upper, call = rlang::caller_env()) { +check_lower_upper <- function( + lower, + upper, + hint = NULL, + call = rlang::caller_env() +) { check_bounds_not_missing(lower, upper, call = call) if (lower >= upper) { abort( c( "{.arg lower} must be smaller than {.arg upper}", - x = "{.arg lower} is {lower} and {.arg upper} is {upper}" + x = "{.arg lower} is {lower} and {.arg upper} is {upper}", + i = hint ), call = call, error_class = "propensity_range_error" diff --git a/man/ps_trim.Rd b/man/ps_trim.Rd index 47d5ddce..26891d8c 100644 --- a/man/ps_trim.Rd +++ b/man/ps_trim.Rd @@ -92,13 +92,9 @@ For categorical exposures, only \code{"ps"} and \code{"optimal"} are supported.} \itemize{ \item \code{"ps"}: absolute propensity score bounds (defaults: 0.1, 0.9). For categorical exposures, only \code{lower} is used, as the symmetric threshold -delta, and it defaults to 0.1. That default deliberately differs from the -0.01 threshold \code{\link[=ps_trunc]{ps_trunc()}} uses for categorical exposures: trimming -discards the units it selects, so its default follows common-support -trimming practice, whereas truncation keeps every unit and only pins the -most extreme scores back. With \code{k} exposure levels, a threshold of \code{1/k} -or larger cannot be met by every column of a row that sums to one, and is -an error. +delta, and it defaults to 0.1, the default \code{\link[=ps_trunc]{ps_trunc()}} uses as well. +With \code{k} exposure levels, a threshold of \code{1/k} or larger cannot be met by +every column of a row that sums to one, and is an error. \item \code{"pctl"}: quantile probabilities (defaults: 0.05, 0.95). \item \code{"pref"}: preference score bounds (defaults: 0.3, 0.7). \item \code{"adaptive"}, \code{"cr"}, \code{"optimal"}: ignored (thresholds are data-driven). diff --git a/man/ps_trunc.Rd b/man/ps_trunc.Rd index 69fe6338..c462a9a6 100644 --- a/man/ps_trunc.Rd +++ b/man/ps_trunc.Rd @@ -67,15 +67,8 @@ For categorical exposures, only \code{"ps"} and \code{"pctl"} are supported.} \itemize{ \item \code{method = "adaptive"}: Not used. Supplying either is ignored with a warning. -\item \code{method = "ps"}: Propensity score values (defaults: 0.1 and 0.9). For -categorical exposures, \code{lower} is the truncation threshold delta -(default: 0.01) and \code{upper} is ignored. That default deliberately differs -from the 0.1 threshold \code{\link[=ps_trim]{ps_trim()}} uses for categorical exposures: -truncation keeps every unit and only pins the most extreme scores back to -the threshold, so its default is a gentle winsorization, whereas trimming -discards the units it selects and follows common-support trimming -practice. With \code{k} exposure levels, a threshold of \code{1/k} or larger cannot -be met by every column of a row that sums to one, and is an error. +\item \code{method = "ps"}: Propensity score values. See \strong{The \code{"ps"} bounds} +below. \item \code{method = "pctl"}: Quantile probabilities (defaults: 0.05 and 0.95; categorical defaults: 0.01 and 0.99). \item \code{method = "cr"}: Ignored; bounds are determined by the data. @@ -138,6 +131,28 @@ For \strong{binary exposures}, each propensity score \eqn{e_i} is bounded: For \strong{categorical exposures}, values below the threshold are set to the threshold and each row is renormalized to sum to 1. +\subsection{The \code{"ps"} bounds}{ + +With \code{method = "ps"}, both paths default to a floor of 0.1. For a \strong{binary +exposure}, a bound supplied alone implies its mirror: \code{lower} alone bounds +the scores at \verb{[lower, 1 - lower]}, and \code{upper} alone at +\verb{[1 - upper, upper]}. With neither supplied, the bounds are \verb{[0.1, 0.9]}; +with both supplied, both are used as written, so an asymmetric bound must be +given in full. The mirror follows from the weights: an untreated unit's ATE +weight is \eqn{1/(1 - e)}, so a floor on \eqn{e} alone would bound the +treated weights and leave the untreated ones unbounded. A lone \code{lower} of +0.5 or more, or a lone \code{upper} of 0.5 or less, meets or crosses its own +mirror and is an error of class \code{propensity_range_error}. \code{lower = 1/c} gives the bounds +\code{method = "adaptive"} computes for the same \eqn{c}. + +For a \strong{categorical exposure}, \code{lower} is the threshold \eqn{\delta} +(default 0.1) applied to every column, after which each row is renormalized, +and \code{upper} is not read and is recorded as \code{NA}. With \code{k} exposure levels, a +threshold of \code{1/k} or larger cannot be met by every column of a row that +sums to one and is an error, so an exposure with ten or more levels needs an +explicit \code{lower} below \code{1/k}. +} + \subsection{The adaptive bound}{ \code{method = "adaptive"} bounds a binary propensity score at diff --git a/tests/testthat/_snaps/ps_trunc-default-bounds.md b/tests/testthat/_snaps/ps_trunc-default-bounds.md new file mode 100644 index 00000000..4a5cf599 --- /dev/null +++ b/tests/testthat/_snaps/ps_trunc-default-bounds.md @@ -0,0 +1,31 @@ +# a lone bound whose mirror crosses it is refused + + Code + expr + Condition + Error in `ps_trunc()`: + ! `lower` must be smaller than `upper` + x `lower` is 0.6 and `upper` is 0.4 + i `upper` was not supplied, so it is the mirror of `lower`, 1 - `lower`. Supply both to bound the scores asymmetrically. + +--- + + Code + expr + Condition + Error in `ps_trunc()`: + ! `lower` must be smaller than `upper` + x `lower` is 0.6 and `upper` is 0.4 + i `lower` was not supplied, so it is the mirror of `upper`, 1 - `upper`. Supply both to bound the scores asymmetrically. + +# the default floor meets the 1/k refusal at ten or more levels + + Code + expr + Condition + Error in `ps_trunc()`: + ! The truncation threshold must fall below 1/k, for k columns of propensity scores. + x `lower` is 0.1, and 1/k is 0.1 for the 10 columns the scores hold. + i No row summing to one can hold every score above 1/k, so a threshold there leaves no rule to apply. + i `lower` was not supplied, and 0.1 is its default. Supply a `lower` below 0.1. + diff --git a/tests/testthat/test-ps_trunc-categorical.R b/tests/testthat/test-ps_trunc-categorical.R index 6693dbf2..f8a263cb 100644 --- a/tests/testthat/test-ps_trunc-categorical.R +++ b/tests/testthat/test-ps_trunc-categorical.R @@ -1,6 +1,6 @@ valid_trunc_matrix_fixture <- function() { exposure <- factor(c("a", "b", "c", "a", "b", "c")) - # every row sums to 1 and no cell falls below 0.01, so the default threshold + # every row sums to 1 and no cell falls below 0.1, so the default threshold # leaves the scores as they are ps_matrix <- rbind( c(0.50, 0.30, 0.20), @@ -743,21 +743,20 @@ test_that("ps_trunc aborts when the categorical threshold reaches 1/k", { expect_s3_class(cnd, "propensity_range_error") }) -test_that("ps_trunc defaults the categorical threshold to 0.01", { +test_that("ps_trunc defaults the categorical threshold to 0.1", { fixture <- valid_trunc_matrix_fixture() - # Truncation and trimming deliberately default to different thresholds: 0.01 - # here against 0.1 in ps_trim(), because truncation only bounds units and - # trimming drops them. + # Truncation and trimming share the default threshold of 0.1, which is also + # the floor the binary path defaults to. explicit <- ps_trunc( fixture$ps_matrix, .exposure = fixture$exposure, method = "ps" ) - expect_equal(ps_trunc_meta(explicit)$lower_bound, 0.01) + expect_equal(ps_trunc_meta(explicit)$lower_bound, 0.1) defaulted <- ps_trunc(fixture$ps_matrix, .exposure = fixture$exposure) - expect_equal(ps_trunc_meta(defaulted)$lower_bound, 0.01) + expect_equal(ps_trunc_meta(defaulted)$lower_bound, 0.1) }) test_that("ps_trunc truncates a data frame with the method left at its default", { @@ -776,7 +775,7 @@ test_that("ps_trunc truncates a data frame with the method left at its default", exact = TRUE ) expect_equal(ps_trunc_meta(truncated)$method, "ps") - expect_equal(ps_trunc_meta(truncated)$lower_bound, 0.01) + expect_equal(ps_trunc_meta(truncated)$lower_bound, 0.1) }) # Missing values ------------------------------------------------------------ diff --git a/tests/testthat/test-ps_trunc-default-bounds.R b/tests/testthat/test-ps_trunc-default-bounds.R index 71fabe70..745b217e 100644 --- a/tests/testthat/test-ps_trunc-default-bounds.R +++ b/tests/testthat/test-ps_trunc-default-bounds.R @@ -124,7 +124,7 @@ test_that("the glm route mirrors a lone bound", { expect_equal(bounds_of(from_upper), c(lower = 0.05, upper = 0.95)) expect_equal(bounds_of(from_neither), c(lower = 0.1, upper = 0.9)) expect_equal( - as.numeric(from_lower), + unname(as.numeric(from_lower)), as.numeric(ps_trunc(unname(fitted(fit)), method = "ps", lower = 0.05)) ) }) From 53afe8fb101d13fbb65bfbff28c4b59a4391ff11 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 07:40:34 -0400 Subject: [PATCH 30/64] add failing tests for combining a single modified vector --- tests/testthat/test-combine-single-modified.R | 174 ++++++++++++++++++ 1 file changed, 174 insertions(+) create mode 100644 tests/testthat/test-combine-single-modified.R diff --git a/tests/testthat/test-combine-single-modified.R b/tests/testthat/test-combine-single-modified.R new file mode 100644 index 00000000..fa5778f3 --- /dev/null +++ b/tests/testthat/test-combine-single-modified.R @@ -0,0 +1,174 @@ +# Combining a single vector returns that vector's observations at its own length +# and in its own order, so every record naming those observations still +# describes them. Combining two or more vectors appends observations from +# different sources, and a positional record describes none of the result. + +# fmt: skip +single_combine_ps <- c( + 0.05, 0.15, 0.3, 0.45, 0.6, 0.72, 0.85, 0.95, 0.4, 0.55, + 0.08, 0.22, 0.35, 0.5, 0.65, 0.78, 0.9, 0.12, 0.62, 0.33 +) +single_combine_z <- rep(c(1, 0, 1, 0, 1), times = 4) + +single_trimmed_psw <- function() { + trimmed <- ps_trim(single_combine_ps, lower = 0.1, upper = 0.9) + withr::local_options(propensity.quiet = TRUE) + suppressWarnings( + wt_ate(trimmed, single_combine_z), + classes = "propensity_no_refit_warning" + ) +} + +single_truncated_psw <- function() { + withr::local_options(propensity.quiet = TRUE) + wt_ate( + ps_trunc(single_combine_ps, lower = 0.1, upper = 0.9), + single_combine_z + ) +} + +single_wt_truncated_psw <- function() { + withr::local_options(propensity.quiet = TRUE) + wt_trunc( + wt_ate(single_combine_ps, single_combine_z), + method = "pctl", + upper = 0.9 + ) +} + +single_calibrated_psw <- function() { + withr::local_options(propensity.quiet = TRUE) + calibrated <- ps_calibrate( + single_combine_ps, + single_combine_z, + smooth = FALSE + ) + wt_ate(calibrated, single_combine_z) +} + +# Weights built from a trimmed score ----------------------------------------- + +test_that("c() of one trimmed psw keeps its trimming record", { + w <- single_trimmed_psw() + expect_false(is.null(ps_trim_meta(w)$trimmed_idx)) + + combined <- expect_silent(c(w)) + + expect_identical(ps_trim_meta(combined), ps_trim_meta(w)) + expect_identical(is_unit_trimmed(combined), is_unit_trimmed(w)) + expect_identical(combined, w) +}) + +test_that("vec_c() and list_unchop() of one trimmed psw keep the record", { + w <- single_trimmed_psw() + + expect_identical(ps_trim_meta(vctrs::vec_c(w)), ps_trim_meta(w)) + expect_identical( + ps_trim_meta(vctrs::list_unchop(list(w))), + ps_trim_meta(w) + ) + expect_identical( + is_unit_trimmed(vctrs::list_unchop(list(w))), + is_unit_trimmed(w) + ) +}) + +test_that("c() of one truncated-score psw keeps its truncation record", { + w <- single_truncated_psw() + expect_false(is.null(ps_trunc_meta(w)$truncated_idx)) + + combined <- expect_silent(c(w)) + + expect_identical(ps_trunc_meta(combined), ps_trunc_meta(w)) + expect_identical(is_unit_truncated(combined), is_unit_truncated(w)) + expect_identical(combined, w) +}) + +test_that("c() of one weight-truncated psw keeps the weight truncation record", { + w <- single_wt_truncated_psw() + expect_true(any(is_unit_wt_truncated(w))) + + combined <- expect_silent(c(w)) + + expect_identical( + attr(combined, "psw_trunc_meta"), + attr(w, "psw_trunc_meta") + ) + expect_identical(is_unit_wt_truncated(combined), is_unit_wt_truncated(w)) + expect_identical(combined, w) +}) + +test_that("c() of one calibrated-score psw keeps its calibration record", { + w <- single_calibrated_psw() + expect_false(is.null(ps_calib_meta(w))) + + combined <- expect_silent(c(w)) + + expect_identical(ps_calib_meta(combined), ps_calib_meta(w)) + expect_identical(combined, w) +}) + +# Two or more inputs --------------------------------------------------------- + +test_that("c() of two trimmed psw drops the positional records", { + w <- single_trimmed_psw() + + combined <- c(w, w) + + expect_length(combined, 2 * length(w)) + expect_null(attr(combined, "ps_trim_meta")) + expect_true(is_ps_trimmed(combined)) +}) + +test_that("c() of a psw split in two drops the records at the original length", { + # The pieces add back up to the length the records were written for, but the + # result is appended from two inputs, which nothing re-indexes. + w <- single_trimmed_psw() + first <- suppressWarnings(w[1:10]) + second <- suppressWarnings(w[11:20]) + + combined <- c(first, second) + + expect_length(combined, length(w)) + expect_null(attr(combined, "ps_trim_meta")) +}) + +test_that("c() of two weight-truncated psw drops the weight truncation record", { + w <- single_wt_truncated_psw() + + combined <- c(w, w) + + expect_null(attr(combined, "psw_trunc_meta")) + expect_true(is_wt_truncated(combined)) +}) + +test_that("c() of two truncated-score psw drops the truncation record", { + w <- single_truncated_psw() + + combined <- c(w, w) + + expect_null(attr(combined, "ps_trunc_meta")) +}) + +# The propensity score classes ----------------------------------------------- + +test_that("c() of one ps_trim or ps_trunc keeps its record", { + trimmed <- ps_trim(single_combine_ps, lower = 0.1, upper = 0.9) + expect_identical(ps_trim_meta(c(trimmed)), ps_trim_meta(trimmed)) + expect_identical(is_unit_trimmed(c(trimmed)), is_unit_trimmed(trimmed)) + + truncated <- ps_trunc(single_combine_ps, lower = 0.1, upper = 0.9) + expect_identical(ps_trunc_meta(c(truncated)), ps_trunc_meta(truncated)) + expect_identical( + is_unit_truncated(c(truncated)), + is_unit_truncated(truncated) + ) +}) + +test_that("c() of two ps_trim or ps_trunc drops the positions", { + trimmed <- ps_trim(single_combine_ps, lower = 0.1, upper = 0.9) + expect_null(ps_trim_meta(c(trimmed, trimmed))$trimmed_idx) + + truncated <- ps_trunc(single_combine_ps, lower = 0.1, upper = 0.9) + expect_null(ps_trunc_meta(c(truncated, truncated))$truncated_idx) +}) From b85cb925f0cc48c9976193c3eceff1fed03578f1 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 07:44:27 -0400 Subject: [PATCH 31/64] keep the records of a single modified vector through c() --- NEWS.md | 7 +++++++ R/psw.R | 42 +++++++++++++++++++++++++++++++----------- 2 files changed, 38 insertions(+), 11 deletions(-) diff --git a/NEWS.md b/NEWS.md index 4c7ef785..e6b62bdd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,12 @@ # propensity 0.1.0.9000 (development version) +* Combining a single `psw` with `c()`, `vctrs::vec_c()`, or + `vctrs::list_unchop()` now keeps its trimming, truncation, calibration, and + weight truncation records, so `c(w)` returns `w` unchanged, as it already + did for `ps_trim` and `ps_trunc` vectors. Each positional record is now + judged against the number of observations it was written for. A combine of + two or more inputs still drops the positional records. + * Breaking change: `ps_trunc(method = "ps")` now mirrors a bound supplied alone. `lower` alone bounds a binary score at `[lower, 1 - lower]`, and `upper` alone at `[1 - upper, upper]`; previously the other bound took its diff --git a/R/psw.R b/R/psw.R index 5a8f4ab0..c949d7dc 100644 --- a/R/psw.R +++ b/R/psw.R @@ -1318,13 +1318,22 @@ psw_categorical_attrs <- c("n_categories", "category_names", "focal_category") # their own and hold at any length. psw_exposure_attrs <- c("exposure_type", "density_meta", "numerator_model") -# A modification record is judged against `to`, the object supplying it: the -# record was written for `to`'s observations, so data arriving at `to`'s length -# is the only data those indices describe. `n` is the number of observations the -# data arrives at. Zero-length data is exempt for the reason a stabilization -# score is: it lines up with nothing and so contradicts nothing, and a prototype -# that keeps the record lets the restore building the real result carry it on to -# the observations. +# A modification record is judged against the number of observations it was +# written for, which a positional record writes down as `n_obs`. `n` is the +# number of observations the data arrives at. Zero-length data is exempt for the +# reason a stabilization score is: it lines up with nothing and so contradicts +# nothing, and a prototype that keeps the record lets the restore building the +# real result carry it on to the observations. +# +# Reading the record's own length rather than `to`'s is what lets a combine of +# a single vector keep the record. vctrs builds that result by restoring +# against a zero-length prototype sliced from the input, which carries the +# input's records, and the data arriving at the recorded length is the input's +# own, in its own order. A combine of two or more vectors restores against the +# prototype `vec_ptype2()` builds, which carries no modification record, so +# nothing reaches the appended result. A record that writes down no length, +# such as a calibration record, names no positions; it is judged against `to`, +# and a prototype holding one has no observations for it to contradict. # # Any same-length operation keeps indices that may no longer point where they # did, a reordering or a subscript with duplicates included. Nothing rebuilding @@ -1333,8 +1342,17 @@ psw_exposure_attrs <- c("exposure_type", "density_meta", "numerator_model") # given, which catches a length change from any route, but a same-length # rearrangement is beyond what either can see and is documented rather than # guarded. -modification_meta_aligns <- function(n, to) { - n == 0 || n == length(to) +modification_meta_aligns <- function(meta, n, to) { + if (n == 0) { + return(TRUE) + } + + recorded <- meta$n_obs + if (is.null(recorded)) { + return(length(to) == 0 || n == length(to)) + } + + n == recorded } # What the joint record can still say once data has arrived at `n` observations. @@ -1447,8 +1465,10 @@ aligned_psw_attrs <- function(to, n) { attrs["stabilization_score"] <- list(NULL) } - if (!modification_meta_aligns(n, to)) { - attrs[psw_modification_meta] <- list(NULL) + for (record in psw_modification_meta) { + if (!modification_meta_aligns(attrs[[record]], n, to)) { + attrs[record] <- list(NULL) + } } attrs[psw_joint_attr] <- list( From f5244f6bea5cebb5cc24658fc60d224974b37412 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 07:44:27 -0400 Subject: [PATCH 32/64] tidy the trim parameter comparison and the refit data hint --- R/ps_trim.R | 34 +++++++++++++++- tests/testthat/test-ps_trim.R | 77 +++++++++++++++++++++++++++++++++++ 2 files changed, 110 insertions(+), 1 deletion(-) diff --git a/R/ps_trim.R b/R/ps_trim.R index a0684b4d..e1a90cf8 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -2107,6 +2107,9 @@ trim_parameters <- function(meta) { fields ) params["density"] <- list(trim_density_parameters(meta$density)) + # A record written without the field describes scores as the model reports + # them, which is what `FALSE` says. + params$focal_inverted <- isTRUE(meta$focal_inverted) params } @@ -2747,7 +2750,8 @@ ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { # # Data recovered from the model hold only the variables the model itself reads, # so an argument naming any other column fails there, and the error says how to -# make that column available. +# make that column available. Only a failure to find a name is relabeled: any +# other error the argument raises is the caller's own and passes through. refit_extra_args <- function( dots, data, @@ -2765,6 +2769,9 @@ refit_extra_args <- function( tryCatch( rlang::eval_tidy(dots[[i]], data = data), error = function(cnd) { + if (!is_unfound_name_error(cnd, dots[[i]], data)) { + rlang::cnd_signal(cnd) + } abort( c( "Can't evaluate {.arg {arg_names[[i]]}} against the retained rows.", @@ -2783,6 +2790,31 @@ refit_extra_args <- function( values } +# Whether evaluating `quo` against `data` failed because a name it reads is +# found neither among the columns nor in the environment it was written in. +# Base R gives that failure no class of its own, so it is recognized by its +# message, compared in the session's language against each name the +# expression reads and cannot find. A `.data$` lookup of a missing column +# raises rlang's own class. +is_unfound_name_error <- function(cnd, quo, data) { + if (inherits(cnd, "rlang_error_data_pronoun_not_found")) { + return(TRUE) + } + + env <- rlang::quo_get_env(quo) + read <- all.vars(rlang::quo_get_expr(quo)) + unfound <- read[ + !read %in% names(data) & + !vapply(read, exists, logical(1), envir = env) + ] + if (length(unfound) == 0) { + return(FALSE) + } + + messages <- gettextf("object '%s' not found", unfound, domain = "R") + conditionMessage(cnd) %in% messages +} + # Whether `model` can refit what the trimming record was made from. A record of # trimmed propensity scores needs a model that fits a probability: one that fits # a probability for every level, or one whose family fits the probability of a diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index 48bf4fd3..f467077c 100644 --- a/tests/testthat/test-ps_trim.R +++ b/tests/testthat/test-ps_trim.R @@ -3223,6 +3223,57 @@ test_that("ps_refit() says how to reach a column the model does not read", { ) }) +test_that("ps_refit() passes through an argument's own error", { + fit <- glm(z ~ x1, data = trim_model_data, family = binomial()) + trimmed <- ps_trim(fit, method = "ps", lower = 0.3, upper = 0.7) + + # Only a name the retained rows lack is a reason to pass `.data`. An error + # the expression raises for any other reason reaches the caller as written. + cnd <- rlang::catch_cnd( + ps_refit(trimmed, fit, weights = stop("boom")), + classes = "error" + ) + expect_false(inherits(cnd, "propensity_no_data_error")) + expect_identical(conditionMessage(cnd), "boom") + + # A name the expression reads that is available does not turn another error + # into a missing column. + expect_error( + ps_refit(trimmed, fit, weights = x1 + stop("boom")), + "boom", + class = "simpleError" + ) + cnd <- rlang::catch_cnd( + ps_refit(trimmed, fit, weights = x1 + stop("boom")), + classes = "error" + ) + expect_false(inherits(cnd, "propensity_no_data_error")) + + # A function the caller calls that cannot be found is not a column either. + cnd <- rlang::catch_cnd( + ps_refit(trimmed, fit, weights = no_such_function_zz(x1)), + classes = "error" + ) + expect_false(inherits(cnd, "propensity_no_data_error")) + + # A `.data` lookup of a missing column is relabeled like a bare name. + expect_error( + ps_refit(trimmed, fit, subset = .data$x2 > 0), + class = "propensity_no_data_error" + ) +}) + +test_that("ps_refit() relabels a missing name in the caller's language", { + fit <- glm(z ~ x1, data = trim_model_data, family = binomial()) + trimmed <- ps_trim(fit, method = "ps", lower = 0.3, upper = 0.7) + + withr::local_language("fr") + expect_error( + ps_refit(trimmed, fit, subset = x2 > 0), + class = "propensity_no_data_error" + ) +}) + test_that("ps_refit() refuses a model of every level for a vector of scores", { skip_if_not_installed("nnet") @@ -3374,6 +3425,32 @@ test_that("the record of an inverted trim follows the scores", { expect_type(combined, "double") }) +test_that("a vector trim record without focal_inverted reads as not inverted", { + trimmed <- ps_trim(c(0.05, 0.3, 0.5, 0.7, 0.95), lower = 0.1, upper = 0.9) + expect_false(ps_trim_meta(trimmed)$focal_inverted) + + bare_meta <- ps_trim_meta(trimmed) + bare_meta$focal_inverted <- NULL + bare <- new_trimmed_ps(vctrs::vec_data(trimmed), ps_trim_meta = bare_meta) + + expect_identical( + trim_parameters(bare_meta), + trim_parameters(ps_trim_meta(trimmed)) + ) + + combined <- expect_no_warning(vctrs::vec_c(bare, trimmed)) + expect_s3_class(combined, "ps_trim") + expect_no_error(vctrs::vec_cast(bare, trimmed)) + + # A record that says the scores are inverted still differs. + inverted_meta <- bare_meta + inverted_meta$focal_inverted <- TRUE + expect_false(identical( + trim_parameters(inverted_meta), + trim_parameters(bare_meta) + )) +}) + test_that("ps_trim() names the class of a fit it has no reading for", { expect_propensity_error( ps_trim(structure(list(), class = "not_a_model"), method = "ps") From ff5b5574b3a0e53f30e9a80b605599d9658464e6 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 07:56:52 -0400 Subject: [PATCH 33/64] keep records through c() of a single modified psw only --- NAMESPACE | 1 + NEWS.md | 11 +- R/psw.R | 63 +++++----- tests/testthat/test-combine-single-modified.R | 112 ++++++++++++++++-- 4 files changed, 138 insertions(+), 49 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 79112322..e6a91d85 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,6 +18,7 @@ S3method(anyDuplicated,ps_trim) S3method(anyDuplicated,ps_trunc) S3method(as.data.frame,ipw_diagnostic_se) S3method(as.double,ps_calib) +S3method(c,psw) S3method(causalgenerics::ipw,default) S3method(causalgenerics::ipw,glm) S3method(causalgenerics::ipw,joint_wt_models) diff --git a/NEWS.md b/NEWS.md index e6b62bdd..c593fc38 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,11 +1,10 @@ # propensity 0.1.0.9000 (development version) -* Combining a single `psw` with `c()`, `vctrs::vec_c()`, or - `vctrs::list_unchop()` now keeps its trimming, truncation, calibration, and - weight truncation records, so `c(w)` returns `w` unchanged, as it already - did for `ps_trim` and `ps_trunc` vectors. Each positional record is now - judged against the number of observations it was written for. A combine of - two or more inputs still drops the positional records. +* `c()` of a single `psw` now returns it unchanged, keeping its trimming, + truncation, calibration, and weight truncation records, as `c()` already + did for a single `ps_trim` or `ps_trunc` vector. Every other combine, + including `vctrs::vec_c()` and `vctrs::list_unchop()` of a single `psw`, + still drops those records. * Breaking change: `ps_trunc(method = "ps")` now mirrors a bound supplied alone. `lower` alone bounds a binary score at `[lower, 1 - lower]`, and diff --git a/R/psw.R b/R/psw.R index c949d7dc..27b1ec0a 100644 --- a/R/psw.R +++ b/R/psw.R @@ -1318,22 +1318,13 @@ psw_categorical_attrs <- c("n_categories", "category_names", "focal_category") # their own and hold at any length. psw_exposure_attrs <- c("exposure_type", "density_meta", "numerator_model") -# A modification record is judged against the number of observations it was -# written for, which a positional record writes down as `n_obs`. `n` is the -# number of observations the data arrives at. Zero-length data is exempt for the -# reason a stabilization score is: it lines up with nothing and so contradicts -# nothing, and a prototype that keeps the record lets the restore building the -# real result carry it on to the observations. -# -# Reading the record's own length rather than `to`'s is what lets a combine of -# a single vector keep the record. vctrs builds that result by restoring -# against a zero-length prototype sliced from the input, which carries the -# input's records, and the data arriving at the recorded length is the input's -# own, in its own order. A combine of two or more vectors restores against the -# prototype `vec_ptype2()` builds, which carries no modification record, so -# nothing reaches the appended result. A record that writes down no length, -# such as a calibration record, names no positions; it is judged against `to`, -# and a prototype holding one has no observations for it to contradict. +# A modification record is judged against `to`, the object supplying it: the +# record was written for `to`'s observations, so data arriving at `to`'s length +# is the only data those indices describe. `n` is the number of observations the +# data arrives at. Zero-length data is exempt for the reason a stabilization +# score is: it lines up with nothing and so contradicts nothing, and a prototype +# that keeps the record lets the restore building the real result carry it on to +# the observations. # # Any same-length operation keeps indices that may no longer point where they # did, a reordering or a subscript with duplicates included. Nothing rebuilding @@ -1342,17 +1333,8 @@ psw_exposure_attrs <- c("exposure_type", "density_meta", "numerator_model") # given, which catches a length change from any route, but a same-length # rearrangement is beyond what either can see and is documented rather than # guarded. -modification_meta_aligns <- function(meta, n, to) { - if (n == 0) { - return(TRUE) - } - - recorded <- meta$n_obs - if (is.null(recorded)) { - return(length(to) == 0 || n == length(to)) - } - - n == recorded +modification_meta_aligns <- function(n, to) { + n == 0 || n == length(to) } # What the joint record can still say once data has arrived at `n` observations. @@ -1465,10 +1447,8 @@ aligned_psw_attrs <- function(to, n) { attrs["stabilization_score"] <- list(NULL) } - for (record in psw_modification_meta) { - if (!modification_meta_aligns(attrs[[record]], n, to)) { - attrs[record] <- list(NULL) - } + if (!modification_meta_aligns(n, to)) { + attrs[psw_modification_meta] <- list(NULL) } attrs[psw_joint_attr] <- list( @@ -1746,6 +1726,27 @@ warn_conflicting_psw_attrs <- function(fields, call = rlang::caller_env()) { ) } +# Combining a single set of weights hands back that set, so every record naming +# its observations still describes them. vctrs cannot keep the records itself: +# its restore sees a zero-length prototype whether that prototype was sliced +# from the one input or supplied by a caller for data from somewhere else, so +# every combine through vctrs drops them. Only base `c()` knows it was handed +# one unnamed input and nothing more. Anything else, a second input, a name, +# or a `recursive` or `use.names` value vctrs refuses, goes to vctrs unchanged. +#' @export +c.psw <- function(..., recursive = FALSE, use.names = TRUE) { + if ( + ...length() == 1L && + is.null(...names()) && + isFALSE(recursive) && + isTRUE(use.names) + ) { + return(..1) + } + + NextMethod() +} + #' @export vec_restore.psw <- function(x, to, ...) { # Extract numeric data if needed diff --git a/tests/testthat/test-combine-single-modified.R b/tests/testthat/test-combine-single-modified.R index fa5778f3..3f0c98a6 100644 --- a/tests/testthat/test-combine-single-modified.R +++ b/tests/testthat/test-combine-single-modified.R @@ -1,7 +1,7 @@ -# Combining a single vector returns that vector's observations at its own length -# and in its own order, so every record naming those observations still -# describes them. Combining two or more vectors appends observations from -# different sources, and a positional record describes none of the result. +# Combining a single set of weights with base `c()` returns that set, so every +# record naming its observations still describes them. Every other combine goes +# through vctrs, which cannot tell the input's own prototype from one a caller +# supplied, and drops the positional records. # fmt: skip single_combine_ps <- c( @@ -59,17 +59,44 @@ test_that("c() of one trimmed psw keeps its trimming record", { expect_identical(combined, w) }) -test_that("vec_c() and list_unchop() of one trimmed psw keep the record", { +test_that("c() of one psw keeps its names, and a NULL alongside it", { w <- single_trimmed_psw() + named <- w + names(named) <- paste0("u", seq_along(w)) - expect_identical(ps_trim_meta(vctrs::vec_c(w)), ps_trim_meta(w)) - expect_identical( - ps_trim_meta(vctrs::list_unchop(list(w))), - ps_trim_meta(w) + expect_identical(c(named), named) + + # Base R discards a NULL argument before dispatch, so this is a combine of + # one set of weights. + expect_identical(c(w, NULL), w) +}) + +test_that("c() of one psw still refuses what vctrs refuses", { + w <- single_trimmed_psw() + + expect_error(c(w, recursive = TRUE), "recursive") + expect_error(c(w, use.names = FALSE), "use.names") + expect_error(c(x = w), "outer name") +}) + +test_that("vec_c() and list_unchop() of one trimmed psw drop the record", { + # vctrs restores the result against a zero-length prototype, which cannot be + # told apart from one a caller supplied for data from elsewhere. + w <- single_trimmed_psw() + + from_vec_c <- vctrs::vec_c(w) + expect_null(attr(from_vec_c, "ps_trim_meta")) + expect_true(is_ps_trimmed(from_vec_c)) + expect_error( + is_unit_trimmed(from_vec_c), + class = "propensity_missing_meta_error" ) - expect_identical( - is_unit_trimmed(vctrs::list_unchop(list(w))), - is_unit_trimmed(w) + + from_unchop <- vctrs::list_unchop(list(w)) + expect_null(attr(from_unchop, "ps_trim_meta")) + expect_error( + is_unit_trimmed(from_unchop), + class = "propensity_missing_meta_error" ) }) @@ -150,6 +177,67 @@ test_that("c() of two truncated-score psw drops the truncation record", { expect_null(attr(combined, "ps_trunc_meta")) }) +# A prototype or cast target supplied by the caller ------------------------- + +# Each of these restores data that is not the weights' own, in their order, +# against a zero-length prototype carrying the weights' records. None of the +# records describes the result. + +expect_trim_record_dropped <- function(x) { + expect_null(attr(x, "ps_trim_meta")) + expect_error(is_unit_trimmed(x), class = "propensity_missing_meta_error") +} + +test_that("reordered pieces combined at a supplied prototype drop the record", { + w <- single_trimmed_psw() + first <- suppressWarnings(w[1:10]) + second <- suppressWarnings(w[11:20]) + + expect_trim_record_dropped( + vctrs::list_unchop(list(second, first), ptype = vctrs::vec_ptype(w)) + ) + expect_trim_record_dropped(vctrs::vec_c(second, first, .ptype = w)) +}) + +test_that("other weights combined at a supplied prototype drop the record", { + w <- single_trimmed_psw() + other <- suppressWarnings(rev(w)) + + expect_trim_record_dropped(vctrs::vec_c(other, .ptype = w)) +}) + +test_that("a cast to or an initialization at the prototype drops the record", { + w <- single_trimmed_psw() + + expect_trim_record_dropped( + vctrs::vec_cast(seq(1, 2, length.out = 20), vctrs::vec_ptype(w)) + ) + expect_trim_record_dropped(vctrs::vec_init(w[0], 20)) +}) + +test_that("a supplied prototype drops the weight truncation record", { + w <- single_wt_truncated_psw() + first <- suppressWarnings(w[1:10]) + second <- suppressWarnings(w[11:20]) + + unchopped <- vctrs::list_unchop( + list(second, first), + ptype = vctrs::vec_ptype(w) + ) + expect_null(attr(unchopped, "psw_trunc_meta")) + expect_error( + is_unit_wt_truncated(unchopped), + class = "propensity_missing_meta_error" + ) + + cast <- vctrs::vec_cast(seq(1, 2, length.out = 20), vctrs::vec_ptype(w)) + expect_null(attr(cast, "psw_trunc_meta")) + expect_error( + is_unit_wt_truncated(cast), + class = "propensity_missing_meta_error" + ) +}) + # The propensity score classes ----------------------------------------------- test_that("c() of one ps_trim or ps_trunc keeps its record", { From 2e84eaa557e47cd101f74144a8d7bc3cb4974631 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 07:58:46 -0400 Subject: [PATCH 34/64] validate a lone ps_trunc bound and tighten the refit data hint --- NEWS.md | 4 ++ R/ps_trim.R | 51 ++++++++++++-- R/ps_trunc.R | 70 ++++++++++++++++++- R/psw.R | 2 +- man/ps_trunc.Rd | 3 +- .../_snaps/ps_trunc-default-bounds.md | 27 +++++++ tests/testthat/test-combine-single-modified.R | 19 +++++ tests/testthat/test-ps_trim.R | 33 +++++++++ tests/testthat/test-ps_trunc-default-bounds.R | 43 ++++++++++++ tests/testthat/test-ps_trunc.R | 63 +++++++++++++++++ 10 files changed, 303 insertions(+), 12 deletions(-) diff --git a/NEWS.md b/NEWS.md index c593fc38..34a3cf40 100644 --- a/NEWS.md +++ b/NEWS.md @@ -13,6 +13,10 @@ neither supplied the bounds stay `[0.1, 0.9]`, and with both supplied both are used as written. A lone bound whose mirror crosses it, such as `lower = 0.6`, is refused with an error of class `propensity_range_error`. + Each supplied bound must be a single number strictly between 0 and 1; one + outside that interval is refused with an error of class + `propensity_range_error`, and one of any other length with an error of class + `propensity_length_error`. The default threshold for a categorical score matrix rises from 0.01 to 0.1, matching the binary default and `ps_trim()`, so a matrix of ten or more columns now needs an explicit `lower`. diff --git a/R/ps_trim.R b/R/ps_trim.R index e1a90cf8..045718a1 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -2313,7 +2313,7 @@ vec_cast.ps_trim.ps_trunc <- function(x, to, ...) { #' @export vec_cast.ps_trunc.ps_trim <- function(x, to, ...) { # Convert ps_trim to ps_trunc (ignore NAs) - ps_trunc(vec_data(x), method = "ps", lower = 0, upper = 1) + cast_to_unbounded_ps_trunc(vec_data(x)) } #' @export @@ -2791,18 +2791,19 @@ refit_extra_args <- function( } # Whether evaluating `quo` against `data` failed because a name it reads is -# found neither among the columns nor in the environment it was written in. -# Base R gives that failure no class of its own, so it is recognized by its -# message, compared in the session's language against each name the -# expression reads and cannot find. A `.data$` lookup of a missing column -# raises rlang's own class. +# found neither among the columns nor in the environment it was written in, +# which is the failure passing `.data` can repair. Base R gives that failure no +# class of its own, so it is recognized by its message, compared in the +# session's language against each such name. A `.data$` lookup of a missing +# column raises rlang's own class. A `.env$` lookup is never a column, so the +# names it reads are left out and its failure passes through. is_unfound_name_error <- function(cnd, quo, data) { if (inherits(cnd, "rlang_error_data_pronoun_not_found")) { return(TRUE) } env <- rlang::quo_get_env(quo) - read <- all.vars(rlang::quo_get_expr(quo)) + read <- unique(column_candidate_names(rlang::quo_get_expr(quo))) unfound <- read[ !read %in% names(data) & !vapply(read, exists, logical(1), envir = env) @@ -2815,6 +2816,42 @@ is_unfound_name_error <- function(cnd, quo, data) { conditionMessage(cnd) %in% messages } +# The bare names an expression reads as variables, which are the names that +# could be columns. A function's name, the field after `$` or `@`, and a +# lookup through either pronoun are not. +column_candidate_names <- function(expr) { + if (is.symbol(expr)) { + name <- as.character(expr) + if (name %in% c("", ".data", ".env")) { + return(character()) + } + return(name) + } + if (!is.call(expr)) { + return(character()) + } + + head <- expr[[1]] + args <- as.list(expr)[-1] + if (identical(head, quote(`$`)) || identical(head, quote(`@`))) { + args <- args[1] + } + if ( + (identical(head, quote(`$`)) || identical(head, quote(`[[`))) && + identical(args[[1]], quote(.env)) + ) { + args <- args[-1] + if (identical(head, quote(`$`))) { + args <- list() + } + } + if (!is.symbol(head)) { + args <- c(list(head), args) + } + + unlist(lapply(args, column_candidate_names), use.names = FALSE) +} + # Whether `model` can refit what the trimming record was made from. A record of # trimmed propensity scores needs a model that fits a probability: one that fits # a probability for every level, or one whose family fits the probability of a diff --git a/R/ps_trunc.R b/R/ps_trunc.R index 40f95c03..6f70201e 100644 --- a/R/ps_trunc.R +++ b/R/ps_trunc.R @@ -94,7 +94,8 @@ #' ## The `"ps"` bounds #' #' With `method = "ps"`, both paths default to a floor of 0.1. For a **binary -#' exposure**, a bound supplied alone implies its mirror: `lower` alone bounds +#' exposure**, each bound supplied must be a single number strictly between 0 +#' and 1, and a bound supplied alone implies its mirror: `lower` alone bounds #' the scores at `[lower, 1 - lower]`, and `upper` alone at #' `[1 - upper, upper]`. With neither supplied, the bounds are `[0.1, 0.9]`; #' with both supplied, both are used as written, so an asymmetric bound must be @@ -394,18 +395,18 @@ ps_trunc.default <- function( # A bound supplied alone implies its mirror. An untreated unit's weight is # 1 / (1 - e), so a floor on the score with no matching ceiling would leave # one arm's weights bounded and the other's not. + check_ps_trunc_bound(lower, "lower", call = call) + check_ps_trunc_bound(upper, "upper", call = call) mirror_hint <- NULL if (is.null(lower) && is.null(upper)) { lower <- 0.1 upper <- 0.9 } else if (is.null(upper)) { - check_bounds_not_missing(lower, 0, call = call) upper <- 1 - lower mirror_hint <- "{.arg upper} was not supplied, so it is the mirror of {.arg lower}, 1 - {.arg lower}. Supply both to bound the scores asymmetrically." } else if (is.null(lower)) { - check_bounds_not_missing(1, upper, call = call) lower <- 1 - upper mirror_hint <- "{.arg lower} was not supplied, so it is the mirror of {.arg upper}, 1 - {.arg upper}. Supply both to bound the scores @@ -1070,6 +1071,49 @@ abort_adaptive_categorical <- function(call = rlang::caller_env()) { ) } +# A `"ps"` bound is a propensity score, and the one supplied alone is also +# mirrored, so anything other than a single score inside the unit interval +# would bound the scores somewhere the caller did not mean, or be recycled +# across them. A missing bound keeps the refusal every method gives it. An +# unset bound takes its default or its mirror and is not checked here. +check_ps_trunc_bound <- function(bound, arg, call = rlang::caller_env()) { + if (is.null(bound)) { + return(invisible(NULL)) + } + + if (length(bound) != 1) { + abort( + c( + "For {.code method = \"ps\"}, {.arg {arg}} must be a single + propensity score.", + x = "{.arg {arg}} has {length(bound)} value{?s}." + ), + error_class = "propensity_length_error", + call = call + ) + } + + if (arg == "lower") { + check_bounds_not_missing(bound, 0.5, call = call) + } else { + check_bounds_not_missing(0.5, bound, call = call) + } + + if (is.numeric(bound) && bound > 0 && bound < 1) { + return(invisible(NULL)) + } + + abort( + c( + "For {.code method = \"ps\"}, {.arg {arg}} must be a propensity score + strictly between 0 and 1.", + x = "{.arg {arg}} is {.val {bound}}." + ), + error_class = "propensity_range_error", + call = call + ) +} + # Gruber et al. (2022) cap the weights at c = sqrt(n) log(n) / 5. Flooring a # binary score at 1/c caps the treated units' unstabilized ATE weights at c, and # capping it at 1 - 1/c does the same for the untreated units, so the bound is @@ -1160,6 +1204,26 @@ new_ps_trunc <- function(x, meta) { } } +# A propensity score cast to a `ps_trunc` from a class that records no +# truncation arrives unbounded: its record names the whole unit interval and no +# unit pinned to it. The scores are still read as propensity scores. The public +# bound check refuses an endpoint as a `"ps"` bound, so the record is written +# here rather than by truncating at 0 and 1. +cast_to_unbounded_ps_trunc <- function(x, call = rlang::caller_env()) { + check_ps_range(x, call = call) + + new_ps_trunc( + x, + meta = list( + method = "ps", + lower_bound = 0, + upper_bound = 1, + truncated_idx = integer(0), + n_obs = length(x) + ) + ) +} + # The positional half of a truncation record. The rest of it, the method and its # bounds, describes the truncation rather than the units and means the same # thing at any length. diff --git a/R/psw.R b/R/psw.R index 27b1ec0a..f83ca6cf 100644 --- a/R/psw.R +++ b/R/psw.R @@ -2020,5 +2020,5 @@ vec_cast.psw.ps_trunc <- function(x, to, ...) cast_to_psw(x, to) #' @export vec_cast.ps_trunc.psw <- function(x, to, ...) { - ps_trunc(vec_data(x), method = "ps", lower = 0, upper = 1) + cast_to_unbounded_ps_trunc(vec_data(x)) } diff --git a/man/ps_trunc.Rd b/man/ps_trunc.Rd index c462a9a6..7e34b05a 100644 --- a/man/ps_trunc.Rd +++ b/man/ps_trunc.Rd @@ -134,7 +134,8 @@ threshold and each row is renormalized to sum to 1. \subsection{The \code{"ps"} bounds}{ With \code{method = "ps"}, both paths default to a floor of 0.1. For a \strong{binary -exposure}, a bound supplied alone implies its mirror: \code{lower} alone bounds +exposure}, each bound supplied must be a single number strictly between 0 +and 1, and a bound supplied alone implies its mirror: \code{lower} alone bounds the scores at \verb{[lower, 1 - lower]}, and \code{upper} alone at \verb{[1 - upper, upper]}. With neither supplied, the bounds are \verb{[0.1, 0.9]}; with both supplied, both are used as written, so an asymmetric bound must be diff --git a/tests/testthat/_snaps/ps_trunc-default-bounds.md b/tests/testthat/_snaps/ps_trunc-default-bounds.md index 4a5cf599..1ba7c6cc 100644 --- a/tests/testthat/_snaps/ps_trunc-default-bounds.md +++ b/tests/testthat/_snaps/ps_trunc-default-bounds.md @@ -18,6 +18,33 @@ x `lower` is 0.6 and `upper` is 0.4 i `lower` was not supplied, so it is the mirror of `upper`, 1 - `upper`. Supply both to bound the scores asymmetrically. +# a supplied bound must be a single score inside the unit interval + + Code + expr + Condition + Error in `ps_trunc()`: + ! For `method = "ps"`, `lower` must be a propensity score strictly between 0 and 1. + x `lower` is -0.1. + +--- + + Code + expr + Condition + Error in `ps_trunc()`: + ! For `method = "ps"`, `upper` must be a propensity score strictly between 0 and 1. + x `upper` is 1.2. + +--- + + Code + expr + Condition + Error in `ps_trunc()`: + ! For `method = "ps"`, `lower` must be a single propensity score. + x `lower` has 2 values. + # the default floor meets the 1/k refusal at ten or more levels Code diff --git a/tests/testthat/test-combine-single-modified.R b/tests/testthat/test-combine-single-modified.R index 3f0c98a6..5aae0f4c 100644 --- a/tests/testthat/test-combine-single-modified.R +++ b/tests/testthat/test-combine-single-modified.R @@ -71,6 +71,25 @@ test_that("c() of one psw keeps its names, and a NULL alongside it", { expect_identical(c(w, NULL), w) }) +test_that("c() of one psw whose record no longer covers it returns it unchanged", { + # A model frame shortens a weights column and re-attaches the attributes, so + # the record describes more observations than the weights hold. + w <- single_trimmed_psw() + stale <- w + attributes(stale) <- NULL + stale <- stale[1:15] + attributes(stale) <- attributes(w) + + combined <- expect_silent(c(stale)) + + expect_identical(combined, stale) + expect_identical(ps_trim_meta(combined), ps_trim_meta(w)) + expect_error( + is_unit_trimmed(combined), + class = "propensity_missing_meta_error" + ) +}) + test_that("c() of one psw still refuses what vctrs refuses", { w <- single_trimmed_psw() diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index f467077c..753913a4 100644 --- a/tests/testthat/test-ps_trim.R +++ b/tests/testthat/test-ps_trim.R @@ -3263,11 +3263,44 @@ test_that("ps_refit() passes through an argument's own error", { ) }) +test_that("ps_refit() passes through a missing name read through .env", { + fit <- glm(z ~ x1, data = trim_model_data, family = binomial()) + trimmed <- ps_trim(fit, method = "ps", lower = 0.3, upper = 0.7) + + # `.env` never reads a column, so passing `.data` cannot help. + cnd <- rlang::catch_cnd( + ps_refit(trimmed, fit, subset = x1 > .env$no_such_cutoff_zz), + classes = "error" + ) + expect_s3_class(cnd, "error") + expect_false(inherits(cnd, "propensity_no_data_error")) + expect_match(conditionMessage(cnd), "no_such_cutoff_zz", fixed = TRUE) + + # The same holds with the data passed. + cnd <- rlang::catch_cnd( + ps_refit( + trimmed, + fit, + .data = trim_model_data, + subset = x1 > .env$no_such_cutoff_zz + ), + classes = "error" + ) + expect_false(inherits(cnd, "propensity_no_data_error")) +}) + test_that("ps_refit() relabels a missing name in the caller's language", { fit <- glm(z ~ x1, data = trim_model_data, family = binomial()) trimmed <- ps_trim(fit, method = "ps", lower = 0.3, upper = 0.7) withr::local_language("fr") + skip_if( + identical( + gettext("object '%s' not found", domain = "R"), + "object '%s' not found" + ), + "R's French message catalog is not installed" + ) expect_error( ps_refit(trimmed, fit, subset = x2 > 0), class = "propensity_no_data_error" diff --git a/tests/testthat/test-ps_trunc-default-bounds.R b/tests/testthat/test-ps_trunc-default-bounds.R index 745b217e..d7cb9110 100644 --- a/tests/testthat/test-ps_trunc-default-bounds.R +++ b/tests/testthat/test-ps_trunc-default-bounds.R @@ -72,6 +72,49 @@ test_that("a lone bound whose mirror crosses it is refused", { expect_s3_class(cnd, "propensity_range_error") }) +test_that("a supplied bound must be a single score inside the unit interval", { + expect_propensity_error( + ps_trunc(default_bounds_ps, method = "ps", lower = -0.1) + ) + expect_propensity_error( + ps_trunc(default_bounds_ps, method = "ps", upper = 1.2) + ) + expect_propensity_error( + ps_trunc(default_bounds_ps, method = "ps", lower = c(0.1, 0.2)) + ) + + # Both bounds supplied are checked as well, before they are compared. + expect_error( + ps_trunc(default_bounds_ps, method = "ps", lower = 0, upper = 0.9), + class = "propensity_range_error" + ) + expect_error( + ps_trunc(default_bounds_ps, method = "ps", lower = 0.1, upper = 1), + class = "propensity_range_error" + ) + expect_error( + ps_trunc(default_bounds_ps, method = "ps", lower = "0.1"), + class = "propensity_range_error" + ) + expect_error( + ps_trunc(default_bounds_ps, method = "ps", upper = c(0.8, 0.9)), + class = "propensity_length_error" + ) + expect_error( + ps_trunc(default_bounds_ps, method = "ps", upper = numeric()), + class = "propensity_length_error" + ) + + # A missing bound keeps the refusal it has under every method, and names + # only the bound that is missing. + cnd <- rlang::catch_cnd( + ps_trunc(default_bounds_ps, method = "ps", lower = NA_real_), + classes = "error" + ) + expect_s3_class(cnd, "propensity_missing_value_error") + expect_no_match(conditionMessage(cnd), "upper", fixed = TRUE) +}) + test_that("a lower bound of 1/c gives the bounds the adaptive method computes", { set.seed(4211) ps <- runif(200, 0.01, 0.99) diff --git a/tests/testthat/test-ps_trunc.R b/tests/testthat/test-ps_trunc.R index 02038678..2e09fd2c 100644 --- a/tests/testthat/test-ps_trunc.R +++ b/tests/testthat/test-ps_trunc.R @@ -1095,6 +1095,69 @@ test_that("casting a double to a ps_trunc keeps the truncation of the target", { expect_equal(meta$n_obs, 2L) }) +# A score from a class that records no truncation is cast to a `ps_trunc` +# unbounded: the record names the whole unit interval and no pinned unit. +expect_unbounded_trunc_record <- function(x, n) { + expect_identical( + ps_trunc_meta(x), + list( + method = "ps", + lower_bound = 0, + upper_bound = 1, + truncated_idx = integer(0), + n_obs = n + ) + ) +} + +cast_fixture_ps <- c(0.05, 0.15, 0.3, 0.45, 0.6, 0.72, 0.85, 0.95, 0.4, 0.55) + +test_that("assigning a trimmed score into a ps_trunc keeps its record", { + trimmed <- ps_trim(cast_fixture_ps, lower = 0.1, upper = 0.9) + truncated <- ps_trunc(cast_fixture_ps, lower = 0.1, upper = 0.9) + + x <- truncated + x[2] <- trimmed[2] + expect_s3_class(x, "ps_trunc") + expect_equal(vctrs::vec_data(x), vctrs::vec_data(truncated)) + expect_identical(ps_trunc_meta(x), ps_trunc_meta(truncated)) + + assigned <- vctrs::vec_assign(truncated, 2, trimmed[2]) + expect_identical(assigned, x) +}) + +test_that("casting a ps_trim to a ps_trunc records no bound", { + trimmed <- ps_trim(cast_fixture_ps, lower = 0.1, upper = 0.9) + truncated <- ps_trunc(cast_fixture_ps, lower = 0.1, upper = 0.9) + + out <- vctrs::vec_cast(trimmed, truncated) + expect_s3_class(out, "ps_trunc") + expect_identical(vctrs::vec_data(out), vctrs::vec_data(trimmed)) + expect_unbounded_trunc_record(out, 10L) + + # A score that arrived missing passes through as well. + with_missing <- ps_trim(c(cast_fixture_ps, NA), lower = 0.1, upper = 0.9) + out <- vctrs::vec_cast(with_missing, truncated) + expect_identical(vctrs::vec_data(out), vctrs::vec_data(with_missing)) + expect_unbounded_trunc_record(out, 11L) +}) + +test_that("casting a psw to a ps_trunc records no bound", { + truncated <- ps_trunc(cast_fixture_ps, lower = 0.1, upper = 0.9) + w <- psw(c(0.2, 0.5, 0.7), estimand = "ate") + + out <- vctrs::vec_cast(w, truncated) + expect_s3_class(out, "ps_trunc") + expect_identical(vctrs::vec_data(out), c(0.2, 0.5, 0.7)) + expect_unbounded_trunc_record(out, 3L) + + # Weights outside the unit interval are not propensity scores. + expect_error( + vctrs::vec_cast(psw(c(2, 3), estimand = "ate"), truncated), + class = "propensity_range_error" + ) +}) + test_that("combining a ps_trunc with an integer keeps the propensity scores", { x <- ps_trunc(c(0.2, 0.5, 0.85), method = "ps", lower = 0.1, upper = 0.9) From 796704c1c323a83fd1ce6748540c2357a3e26ac4 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 08:10:34 -0400 Subject: [PATCH 35/64] add failing tests for modified scores combined under an explicit prototype --- .../test-combine-explicit-prototype-scores.R | 203 ++++++++++++++++++ 1 file changed, 203 insertions(+) create mode 100644 tests/testthat/test-combine-explicit-prototype-scores.R diff --git a/tests/testthat/test-combine-explicit-prototype-scores.R b/tests/testthat/test-combine-explicit-prototype-scores.R new file mode 100644 index 00000000..dc2dd754 --- /dev/null +++ b/tests/testthat/test-combine-explicit-prototype-scores.R @@ -0,0 +1,203 @@ +# A zero-length prototype carries the record of the scores it was taken from, +# and vctrs restores a combined or initialized result against it whether the +# prototype was sliced from the one input or supplied by the caller for data +# from elsewhere. The positions in that record describe none of the result, so +# the result keeps its class and the description of the modification, and the +# positional queries refuse. Base `c()` of a single score vector is the one +# combine that knows it was handed that vector alone, and it keeps the record. + +# fmt: skip +prototype_ps <- c( + 0.05, 0.15, 0.3, 0.45, 0.6, 0.72, 0.85, 0.95, 0.4, 0.55, + 0.08, 0.22, 0.35, 0.5, 0.65, 0.78, 0.92, 0.12, 0.62, 0.33 +) + +prototype_trim <- function() { + ps_trim(prototype_ps, lower = 0.1, upper = 0.9) +} + +prototype_trunc <- function() { + ps_trunc(prototype_ps, lower = 0.1, upper = 0.9) +} + +expect_trim_positions_dropped <- function(x, like) { + expect_s3_class(x, "ps_trim") + meta <- ps_trim_meta(x) + expect_null(meta$keep_idx) + expect_null(meta$trimmed_idx) + expect_null(meta$n_obs) + expect_identical(meta, drop_trim_record(ps_trim_meta(like))) + expect_error(is_unit_trimmed(x), class = "propensity_missing_meta_error") +} + +expect_trunc_positions_dropped <- function(x, like) { + expect_s3_class(x, "ps_trunc") + meta <- ps_trunc_meta(x) + expect_null(meta$truncated_idx) + expect_null(meta$n_obs) + expect_identical(meta, drop_trunc_record(ps_trunc_meta(like))) + expect_error(is_unit_truncated(x), class = "propensity_missing_meta_error") +} + +# The trimmed units are 1, 8, 11, and 17. Reordered as units 11 to 20 then 1 +# to 10, they sit at 1, 7, 11, and 18, which no record written for the input +# order names. +reordered_pieces <- function(x) { + list(x[11:20], x[1:10]) +} + +# ps_trim --------------------------------------------------------------------- + +test_that("reordered trimmed pieces at a supplied prototype drop the positions", { + t <- prototype_trim() + pieces <- reordered_pieces(t) + + unchopped <- expect_silent( + vctrs::list_unchop(pieces, ptype = vctrs::vec_ptype(t)) + ) + expect_identical(which(is.na(unchopped)), c(1L, 7L, 11L, 18L)) + expect_trim_positions_dropped(unchopped, t) + + combined <- expect_silent(vctrs::vec_c(!!!pieces, .ptype = t)) + expect_identical(vctrs::vec_data(combined), vctrs::vec_data(unchopped)) + expect_trim_positions_dropped(combined, t) +}) + +test_that("other trimmed scores at a supplied prototype drop the positions", { + t <- prototype_trim() + other <- rev(t) + + expect_trim_positions_dropped(vctrs::vec_c(other, .ptype = t), t) +}) + +test_that("vec_c() and list_unchop() of one ps_trim drop the positions", { + t <- prototype_trim() + + expect_trim_positions_dropped(vctrs::vec_c(t), t) + expect_trim_positions_dropped(vctrs::list_unchop(list(t)), t) +}) + +test_that("a double cast or initialized at a trimmed prototype names no unit", { + t <- prototype_trim() + + # A cast writes a record for the values it was handed, none of them trimmed. + cast <- vctrs::vec_cast(seq(0.2, 0.8, length.out = 20), vctrs::vec_ptype(t)) + expect_identical(ps_trim_meta(cast)$trimmed_idx, integer(0)) + expect_identical(ps_trim_meta(cast)$keep_idx, 1:20) + expect_identical(ps_trim_meta(cast)$n_obs, 20L) + expect_identical(is_unit_trimmed(cast), rep(FALSE, 20)) + + expect_trim_positions_dropped(vctrs::vec_init(t[0], 20), t) +}) + +test_that("c() of one ps_trim returns it unchanged", { + t <- prototype_trim() + named <- t + names(named) <- paste0("u", seq_along(t)) + + expect_identical(expect_silent(c(t)), t) + expect_identical(c(named), named) + expect_identical(c(t, NULL), t) + expect_identical(is_unit_trimmed(c(t)), is_unit_trimmed(t)) + + expect_error(c(t, recursive = TRUE), "recursive") + expect_error(c(t, use.names = FALSE), "use.names") +}) + +test_that("c() of two ps_trim still drops the positions", { + t <- prototype_trim() + + combined <- c(t, t) + + expect_length(combined, 40) + expect_trim_positions_dropped(combined, t) +}) + +test_that("slicing, subassignment, and arithmetic on a ps_trim are unchanged", { + t <- prototype_trim() + + sliced <- t[c(1, 2, 8)] + expect_identical(ps_trim_meta(sliced)$trimmed_idx, c(1L, 3L)) + expect_identical(ps_trim_meta(sliced)$n_obs, 3L) + + assigned <- t + assigned[2] <- 0.5 + expect_identical(ps_trim_meta(assigned), ps_trim_meta(t)) + expect_identical(is_unit_trimmed(assigned), is_unit_trimmed(t)) + + expect_identical(t + 0, vctrs::vec_data(t)) +}) + +# ps_trunc -------------------------------------------------------------------- + +test_that("reordered truncated pieces at a supplied prototype drop the positions", { + tr <- prototype_trunc() + pieces <- reordered_pieces(tr) + + unchopped <- expect_silent( + vctrs::list_unchop(pieces, ptype = vctrs::vec_ptype(tr)) + ) + expect_trunc_positions_dropped(unchopped, tr) + + combined <- expect_silent(vctrs::vec_c(!!!pieces, .ptype = tr)) + expect_trunc_positions_dropped(combined, tr) +}) + +test_that("other truncated scores at a supplied prototype drop the positions", { + tr <- prototype_trunc() + other <- rev(tr) + + expect_trunc_positions_dropped(vctrs::vec_c(other, .ptype = tr), tr) +}) + +test_that("vec_c() and list_unchop() of one ps_trunc drop the positions", { + tr <- prototype_trunc() + + expect_trunc_positions_dropped(vctrs::vec_c(tr), tr) + expect_trunc_positions_dropped(vctrs::list_unchop(list(tr)), tr) +}) + +test_that("a double cast or initialized at a truncated prototype names no unit", { + tr <- prototype_trunc() + + cast <- vctrs::vec_cast(seq(0.2, 0.8, length.out = 20), vctrs::vec_ptype(tr)) + expect_identical(ps_trunc_meta(cast)$truncated_idx, integer(0)) + expect_identical(ps_trunc_meta(cast)$n_obs, 20L) + expect_identical(is_unit_truncated(cast), rep(FALSE, 20)) + + expect_trunc_positions_dropped(vctrs::vec_init(tr[0], 20), tr) +}) + +test_that("c() of one ps_trunc returns it unchanged", { + tr <- prototype_trunc() + named <- tr + names(named) <- paste0("u", seq_along(tr)) + + expect_identical(expect_silent(c(tr)), tr) + expect_identical(c(named), named) + expect_identical(c(tr, NULL), tr) + expect_identical(is_unit_truncated(c(tr)), is_unit_truncated(tr)) + + expect_error(c(tr, recursive = TRUE), "recursive") + expect_error(c(tr, use.names = FALSE), "use.names") +}) + +test_that("c() of two ps_trunc still drops the positions", { + tr <- prototype_trunc() + + expect_trunc_positions_dropped(c(tr, tr), tr) +}) + +test_that("slicing, subassignment, and arithmetic on a ps_trunc are unchanged", { + tr <- prototype_trunc() + + sliced <- tr[c(1, 2, 8)] + expect_identical(ps_trunc_meta(sliced)$truncated_idx, c(1L, 3L)) + expect_identical(ps_trunc_meta(sliced)$n_obs, 3L) + + assigned <- tr + assigned[2] <- 0.5 + expect_identical(ps_trunc_meta(assigned), ps_trunc_meta(tr)) + + expect_type(tr + 0, "double") +}) From af9ac5b760374e8446adf0496c2ff4de573faab5 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 08:14:13 -0400 Subject: [PATCH 36/64] drop a score record restored against an explicit prototype --- NAMESPACE | 2 ++ NEWS.md | 10 ++++++ R/ps_trim.R | 35 +++++++++++++++++-- R/ps_trunc.R | 35 +++++++++++++++++-- .../test-combine-explicit-prototype-scores.R | 21 +++++++++++ 5 files changed, 97 insertions(+), 6 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index e6a91d85..6d5a24d2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,6 +18,8 @@ S3method(anyDuplicated,ps_trim) S3method(anyDuplicated,ps_trunc) S3method(as.data.frame,ipw_diagnostic_se) S3method(as.double,ps_calib) +S3method(c,ps_trim) +S3method(c,ps_trunc) S3method(c,psw) S3method(causalgenerics::ipw,default) S3method(causalgenerics::ipw,glm) diff --git a/NEWS.md b/NEWS.md index 34a3cf40..d80cf2b6 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,15 @@ # propensity 0.1.0.9000 (development version) +* A `ps_trim` or `ps_trunc` vector restored against a zero-length prototype + now drops the positions in its record, keeping its class and the description + of the trimming or truncation. Combining reordered pieces with + `vctrs::list_unchop(ptype = )` or `vctrs::vec_c(.ptype = )` previously kept a + record naming the wrong units; `is_unit_trimmed()`, `is_unit_truncated()`, + and `ps_refit()` now refuse such a result with an error of class + `propensity_missing_meta_error`. `vctrs::vec_c()` and `vctrs::list_unchop()` + of a single vector drop the positions as well, while `c()` of a single + vector returns it unchanged. + * `c()` of a single `psw` now returns it unchanged, keeping its trimming, truncation, calibration, and weight truncation records, as `c()` already did for a single `ps_trim` or `ps_trunc` vector. Every other combine, diff --git a/R/ps_trim.R b/R/ps_trim.R index 045718a1..ff0d25ce 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -2463,6 +2463,27 @@ na.omit.ps_trim <- function(object, ...) { result } +# Combining a single `ps_trim` hands back that vector, so its record still +# describes it. Every combine through vctrs restores against a zero-length +# prototype that cannot be told apart from one a caller supplied, and drops the +# positions. Anything other than one unnamed input with the default +# `recursive` and `use.names` goes to vctrs unchanged, and a matrix of scores, +# which is not a vctrs vector, keeps base `c()`'s flattening. +#' @export +c.ps_trim <- function(..., recursive = FALSE, use.names = TRUE) { + if ( + ...length() == 1L && + !is.matrix(..1) && + is.null(...names()) && + isFALSE(recursive) && + isTRUE(use.names) + ) { + return(..1) + } + + NextMethod() +} + #' @export vec_restore.ps_trim <- function(x, to, ...) { # vec_data in case x is already a vctr @@ -2473,9 +2494,17 @@ vec_restore.ps_trim <- function(x, to, ...) { # change, so a record written for a different number of observations cannot be # re-indexed onto the data arriving here. Zero-length data is exempt: a # prototype or an empty slice holds no observations, so no position in the - # record contradicts it, and the record rides along to the restore that builds - # the real result. - if (length(data) > 0 && !record_covers(meta, length(data))) { + # record contradicts it. + # + # Data restored against a zero-length `to` did not come from `to`: a + # prototype, whether sliced from the one input of a combine or supplied by the + # caller, is restored onto observations it was never written for, in an order + # nothing here is told. Its positions are dropped without comment, as a + # combine of several inputs drops them, and base `c()` of a single vector keeps + # them by returning that vector. + if (length(data) > 0 && length(to) == 0) { + meta <- drop_trim_record(meta) + } else if (length(data) > 0 && !record_covers(meta, length(data))) { meta <- discard_trim_record(meta, length(data)) } diff --git a/R/ps_trunc.R b/R/ps_trunc.R index 6f70201e..9bc46293 100644 --- a/R/ps_trunc.R +++ b/R/ps_trunc.R @@ -1917,6 +1917,27 @@ sort.ps_trunc <- function(x, decreasing = FALSE, na.last = NA, ...) { new_ps_trunc(x_data[ord], carry_trunc_record(meta, length(x), ord)) } +# Combining a single `ps_trunc` hands back that vector, so its record still +# describes it. Every combine through vctrs restores against a zero-length +# prototype that cannot be told apart from one a caller supplied, and drops the +# positions. Anything other than one unnamed input with the default +# `recursive` and `use.names` goes to vctrs unchanged, and a matrix of scores, +# which is not a vctrs vector, keeps base `c()`'s flattening. +#' @export +c.ps_trunc <- function(..., recursive = FALSE, use.names = TRUE) { + if ( + ...length() == 1L && + !is.matrix(..1) && + is.null(...names()) && + isFALSE(recursive) && + isTRUE(use.names) + ) { + return(..1) + } + + NextMethod() +} + #' @export vec_restore.ps_trunc <- function(x, to, ...) { # vec_data in case x is already a vctr @@ -1927,9 +1948,17 @@ vec_restore.ps_trunc <- function(x, to, ...) { # change, so a record written for a different number of observations cannot be # re-indexed onto the data arriving here. Zero-length data is exempt: a # prototype or an empty slice holds no observations, so no position in the - # record contradicts it, and the record rides along to the restore that builds - # the real result. - if (length(data) > 0 && !record_covers(meta, length(data))) { + # record contradicts it. + # + # Data restored against a zero-length `to` did not come from `to`: a + # prototype, whether sliced from the one input of a combine or supplied by the + # caller, is restored onto observations it was never written for, in an order + # nothing here is told. Its positions are dropped without comment, as a + # combine of several inputs drops them, and base `c()` of a single vector keeps + # them by returning that vector. + if (length(data) > 0 && length(to) == 0) { + meta <- drop_trunc_record(meta) + } else if (length(data) > 0 && !record_covers(meta, length(data))) { meta <- discard_trunc_record(meta, length(data)) } diff --git a/tests/testthat/test-combine-explicit-prototype-scores.R b/tests/testthat/test-combine-explicit-prototype-scores.R index dc2dd754..96f8b726 100644 --- a/tests/testthat/test-combine-explicit-prototype-scores.R +++ b/tests/testthat/test-combine-explicit-prototype-scores.R @@ -201,3 +201,24 @@ test_that("slicing, subassignment, and arithmetic on a ps_trunc are unchanged", expect_type(tr + 0, "double") }) + +# Matrices --------------------------------------------------------------------- + +test_that("c() of a trimmed or truncated matrix still flattens it", { + exposure <- factor(c("a", "b", "c", "a")) + ps_matrix <- rbind( + c(0.60, 0.20, 0.20), + c(0.20, 0.60, 0.20), + c(0.30, 0.40, 0.30), + c(0.05, 0.50, 0.45) + ) + colnames(ps_matrix) <- levels(exposure) + + trimmed <- ps_trim(ps_matrix, .exposure = exposure, method = "ps") + expect_identical(c(trimmed), c(unclass(trimmed))) + expect_null(attributes(c(trimmed))) + + truncated <- ps_trunc(ps_matrix, .exposure = exposure, method = "ps") + expect_identical(c(truncated), c(unclass(truncated))) + expect_null(attributes(c(truncated))) +}) From ad4623b067e7696bde98e53e158e278123fd90f3 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 08:27:25 -0400 Subject: [PATCH 37/64] add failing tests for keeping the calibration record on weights --- tests/testthat/test-psw.R | 142 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 138 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-psw.R b/tests/testthat/test-psw.R index 2eb41a58..e5fbd399 100644 --- a/tests/testthat/test-psw.R +++ b/tests/testthat/test-psw.R @@ -552,7 +552,7 @@ test_that("psw works with ggplot2", { }) # Weights built from a modified propensity score carry the modification's -# record: `ps_trim_meta`, `ps_trunc_meta`, or `ps_calib_meta`. Those records are +# record: `ps_trim_meta` or `ps_trunc_meta`. Those records are # indexed by observation, so where an operation goes through vctrs they are kept # whenever the weights come back at the length the record was written for, # dropped when they do not, and left alone at zero length. @@ -749,16 +749,148 @@ test_that("shortening a psw drops the trimming record silently", { expect_true(is_ps_trimmed(sliced)) }) -test_that("shortening a psw drops truncation and calibration records silently", { +test_that("shortening a psw drops the truncation record silently", { truncated <- truncated_psw() sub <- expect_silent(truncated[1:2]) expect_null(ps_trunc_meta(sub)) expect_true(is_ps_truncated(sub)) +}) + +# A calibration record names the curve the scores were calibrated with and +# whether it was smoothed. It holds no positions, so like the categorical +# attributes it means the same thing at any length. +unsmoothed_calibrated_psw <- function() { + exposure <- c(0, 1, 0, 0, 1, 0, 1, 1, 0, 1) + ps <- ps_calibrate( + c(0.14, 0.22, 0.31, 0.4, 0.48, 0.55, 0.62, 0.7, 0.78, 0.86), + exposure, + smooth = FALSE + ) + + wt_ate(ps, exposure, exposure_type = "binary", .focal_level = 1) +} + +test_that("shortening a psw keeps the calibration record", { calibrated <- calibrated_psw() + calib_meta <- ps_calib_meta(calibrated) + sub <- expect_silent(calibrated[1:2]) - expect_null(ps_calib_meta(sub)) + expect_identical(ps_calib_meta(sub), calib_meta) expect_true(is_ps_calibrated(sub)) + + sliced <- expect_silent(vec_slice(calibrated, c(3, 1, 1))) + expect_identical(ps_calib_meta(sliced), calib_meta) + + repeated <- expect_silent(rep(calibrated, 2)) + expect_identical(ps_calib_meta(repeated), calib_meta) +}) + +test_that("arithmetic on a shortened calibrated psw keeps the calibration record", { + calibrated <- calibrated_psw() + calib_meta <- ps_calib_meta(calibrated) + + sub <- calibrated[1:4] + out <- expect_silent(sub * sub) + expect_identical(ps_calib_meta(out), calib_meta) +}) + +test_that("combining calibrated psw objects keeps a calibration record they share", { + calibrated <- calibrated_psw() + calib_meta <- ps_calib_meta(calibrated) + + combined <- expect_silent(c(calibrated, calibrated[1:3])) + expect_length(combined, 13) + expect_identical(ps_calib_meta(combined), calib_meta) + expect_true(is_ps_calibrated(combined)) + + combined <- expect_silent(vec_c(calibrated)) + expect_identical(ps_calib_meta(combined), calib_meta) + + unchopped <- expect_silent( + list_unchop(list(calibrated[4:10], calibrated[1:3])) + ) + expect_identical(ps_calib_meta(unchopped), calib_meta) + + # Two separately built sets of weights describe the same calibration. + separate <- expect_silent(c(calibrated, calibrated_psw())) + expect_identical(ps_calib_meta(separate), calib_meta) +}) + +test_that("combining psw objects keeps a calibration record only one records", { + calibrated <- calibrated_psw() + calib_meta <- ps_calib_meta(calibrated) + unrecorded <- psw( + rep(1, 3), + estimand = estimand(calibrated), + calibrated = TRUE + ) + attr(unrecorded, "exposure_type") <- attr(calibrated, "exposure_type") + expect_null(ps_calib_meta(unrecorded)) + + out <- expect_silent(c(calibrated, unrecorded)) + expect_identical(ps_calib_meta(out), calib_meta) + + out <- expect_silent(c(unrecorded, calibrated)) + expect_identical(ps_calib_meta(out), calib_meta) +}) + +test_that("combining psw objects drops calibration records that disagree", { + smoothed <- calibrated_psw() + unsmoothed <- unsmoothed_calibrated_psw() + expect_false( + identical(ps_calib_meta(smoothed), ps_calib_meta(unsmoothed)) + ) + + out <- collect_warning_classes(c(smoothed, unsmoothed)) + expect_identical(out$classes, "propensity_metadata_conflict_warning") + expect_s3_class(out$value, "psw") + expect_length(out$value, 20) + expect_null(ps_calib_meta(out$value)) + expect_true(is_ps_calibrated(out$value)) + + # The drop is reported once and holds whatever order the inputs come in. + out <- collect_warning_classes(c(smoothed, unsmoothed, smoothed)) + expect_identical(out$classes, "propensity_metadata_conflict_warning") + expect_null(ps_calib_meta(out$value)) + + out <- collect_warning_classes(c(smoothed, smoothed, unsmoothed)) + expect_identical(out$classes, "propensity_metadata_conflict_warning") + expect_null(ps_calib_meta(out$value)) +}) + +test_that("a psw product drops calibration records that disagree", { + out <- collect_warning_classes(calibrated_psw() * unsmoothed_calibrated_psw()) + expect_identical(out$classes, "propensity_metadata_conflict_warning") + expect_null(ps_calib_meta(out$value)) + expect_true(is_ps_calibrated(out$value)) +}) + +test_that("a cast into a calibrated psw carries the calibration record", { + calibrated <- calibrated_psw() + + cast <- expect_silent(vec_cast(c(1, 2, 3), vec_ptype(calibrated))) + expect_identical(ps_calib_meta(cast), ps_calib_meta(calibrated)) +}) + +test_that("a ps_calib keeps its record at any length", { + calibrated <- ps_calibrate( + c(0.14, 0.22, 0.31, 0.4, 0.48, 0.55, 0.62, 0.7, 0.78, 0.86), + c(0, 1, 0, 0, 1, 0, 1, 1, 0, 1) + ) + calib_meta <- ps_calib_meta(calibrated) + + expect_identical(ps_calib_meta(calibrated[1:3]), calib_meta) + expect_identical(ps_calib_meta(vec_slice(calibrated, 1:3)), calib_meta) + expect_identical(ps_calib_meta(unique(calibrated)), calib_meta) + expect_identical( + ps_calib_meta(c(calibrated, calibrated[1:3])), + calib_meta + ) + expect_identical( + ps_calib_meta(list_unchop(list(calibrated[4:10], calibrated[1:3]))), + calib_meta + ) }) test_that("a zero-length psw restore keeps the trimming record silently", { @@ -1429,9 +1561,11 @@ test_that("combining psw objects drops the modification records", { expect_null(ps_trunc_meta(combined)) expect_true(is_ps_truncated(combined)) + # The calibration record holds no positions, so it survives the + # concatenation. calibrated <- calibrated_psw() combined <- expect_silent(c(calibrated, calibrated)) - expect_null(ps_calib_meta(combined)) + expect_identical(ps_calib_meta(combined), ps_calib_meta(calibrated)) expect_true(is_ps_calibrated(combined)) }) From 304d183d15f0f97405bd5557481c93cd115a18d8 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 08:28:30 -0400 Subject: [PATCH 38/64] keep the calibration record through subsetting and combining --- NEWS.md | 12 ++++++++- R/psw.R | 75 ++++++++++++++++++++++++++++++++---------------------- man/psw.Rd | 20 +++++++++------ 3 files changed, 68 insertions(+), 39 deletions(-) diff --git a/NEWS.md b/NEWS.md index d80cf2b6..d4a5e0a3 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,15 @@ # propensity 0.1.0.9000 (development version) +* Weights built from a calibrated propensity score now keep their calibration + record (`ps_calib_meta`) through subsetting, `rep()`, and combining, as a + `ps_calib` vector already did. The record names the calibration method and + whether it was smoothed rather than any unit, but it was dropped along with + the positional trimming and truncation records whenever the length changed, + while the weights stayed marked as calibrated. Combining weights whose + calibration records disagree drops the record with a warning of class + `propensity_metadata_conflict_warning`, and a record only one input carries + is kept. + * A `ps_trim` or `ps_trunc` vector restored against a zero-length prototype now drops the positions in its record, keeping its class and the description of the trimming or truncation. Combining reordered pieces with @@ -11,7 +21,7 @@ vector returns it unchanged. * `c()` of a single `psw` now returns it unchanged, keeping its trimming, - truncation, calibration, and weight truncation records, as `c()` already + truncation, and weight truncation records, as `c()` already did for a single `ps_trim` or `ps_trunc` vector. Every other combine, including `vctrs::vec_c()` and `vctrs::list_unchop()` of a single `psw`, still drops those records. diff --git a/R/psw.R b/R/psw.R index f83ca6cf..66684828 100644 --- a/R/psw.R +++ b/R/psw.R @@ -110,15 +110,18 @@ #' not the inputs agree on them. Weights whose own values were truncated are #' combined only when the records they carry name the same bound, since weights #' bounded differently describe different estimands; a record already dropped -#' agrees with any bound. The categorical attributes name exposure levels -#' rather than positions, and the exposure records describe the exposure rather -#' than any unit, so both carry when the inputs agree. +#' agrees with any bound. The calibration record (`ps_calib_meta`) names the +#' curve the scores were calibrated with rather than any position, the +#' categorical attributes name exposure levels, and the exposure records +#' describe the exposure rather than any unit, so all of them carry by the +#' agreement rule above: two calibration records agree when they name the same +#' method and smoothing. #' #' Subsetting with `[` preserves class and attributes for vector subscripts. #' Two kinds of attribute hold one value per observation and so cannot be #' re-indexed for a subset: a `stabilization_score` with more than one value, -#' and the records left by a modified propensity score (`ps_trim_meta`, -#' `ps_trunc_meta`, and `ps_calib_meta`) or by truncating the weights +#' and the records left by a trimmed or truncated propensity score +#' (`ps_trim_meta` and `ps_trunc_meta`) or by truncating the weights #' themselves (`psw_trunc_meta`). Where an operation goes through #' vctrs, these are carried when the result comes back at the length they were #' recorded on and dropped when it does not. Any same-length operation keeps @@ -149,10 +152,11 @@ #' #' The result of any of these operations stays a `psw` and keeps every other #' attribute, including its stabilized, trimmed, truncated, and calibrated -#' status, the attributes describing a categorical exposure, which name the +#' status, the calibration record, which names a calibration curve rather than +#' any unit, the attributes describing a categorical exposure, which name the #' exposure levels rather than the units, and the exposure records, which -#' describe the exposure rather than any unit, so both mean the same thing at -#' any length. +#' describe the exposure rather than any unit, so all of them mean the same +#' thing at any length. #' #' Matrix or array subscripts intentionally drop the `psw` class and return #' a plain numeric vector via base R linear indexing; this is required so @@ -1297,17 +1301,21 @@ check_stabilization_score <- function(score, n, call = rlang::caller_env()) { as.double(score) } -# The records a modified propensity score leaves on the weights built from it, -# and the record truncating the weights themselves leaves. Each holds indices -# into the observations it was recorded on, so like a per-observation -# stabilization score, each is only meaningful at that length. +# The records a trimmed or truncated propensity score leaves on the weights +# built from it, and the record truncating the weights themselves leaves. Each +# holds indices into the observations it was recorded on, so like a +# per-observation stabilization score, each is only meaningful at that length. psw_modification_meta <- c( "ps_trim_meta", "ps_trunc_meta", - "ps_calib_meta", "psw_trunc_meta" ) +# The record a calibrated propensity score leaves on the weights built from it. +# It names the curve the scores were calibrated with and whether that curve was +# smoothed, and no unit, so it carries no length of its own. +psw_calib_attr <- "ps_calib_meta" + # Attributes describing a categorical exposure. These name the exposure levels # rather than the units, so they carry no length of their own. psw_categorical_attrs <- c("n_categories", "category_names", "focal_category") @@ -1386,18 +1394,23 @@ psw_stabilization_scores <- function(x) { psw_joint_attr <- "joint_wt_meta" # Everything a psw carries beyond the six fields describing the weights as a -# whole. The score and the modification records are indexed by observation; the -# categorical attributes name exposure levels, the exposure records describe the -# exposure, and the joint record names the two components, so all of those hold -# at any length. -psw_carried_attrs <- c( - "stabilization_score", - psw_modification_meta, +# whole. The score and the positional modification records are indexed by +# observation; the calibration record names a curve, the categorical attributes +# name exposure levels, the exposure records describe the exposure, and the +# joint record names the two components, so all of those hold at any length. +psw_length_free_attrs <- c( + psw_calib_attr, psw_categorical_attrs, psw_exposure_attrs, psw_joint_attr ) +psw_carried_attrs <- c( + "stabilization_score", + psw_modification_meta, + psw_length_free_attrs +) + # The attributes a disagreement has already dropped from a prototype under # construction. vctrs folds `vec_ptype2()` over the inputs two at a time, so a # prototype meets the third input carrying no trace of the second: without this @@ -1644,6 +1657,12 @@ psw_attrs_agree <- function(field, x, y) { return(joint_wt_meta_agrees(x, y)) } + # A calibration record is compared on what describes the calibration, the + # comparison two calibrated scores are combined on. + if (identical(field, psw_calib_attr)) { + return(identical(calib_parameters(x), calib_parameters(y))) + } + identical(x, y) } @@ -1869,16 +1888,12 @@ vec_ptype2.psw.psw <- function(x, y, ...) { # another, so the positions a modification record names would describe units # from the other input. Nothing rebuilding the combined vector is handed the # offsets, so the records are left off the prototype whether or not the inputs - # agree on them. The categorical attributes name exposure levels rather than - # positions, the exposure records describe the exposure rather than any unit, - # and the joint record names the two components a product was built from, so - # all of them mean the same thing at the combined length. - merged <- merge_psw_attrs( - x, - y, - 0, - fields = c(psw_categorical_attrs, psw_exposure_attrs, psw_joint_attr) - ) + # agree on them. The calibration record names a curve rather than positions, + # the categorical attributes name exposure levels, the exposure records + # describe the exposure rather than any unit, and the joint record names the + # two components a product was built from, so all of them mean the same thing + # at the combined length. + merged <- merge_psw_attrs(x, y, 0, fields = psw_length_free_attrs) if (length(merged$conflicts) > 0) { warn_conflicting_psw_attrs(merged$conflicts) } diff --git a/man/psw.Rd b/man/psw.Rd index 235d383a..2421e196 100644 --- a/man/psw.Rd +++ b/man/psw.Rd @@ -195,15 +195,18 @@ from the other input; those records are dropped from the result whether or not the inputs agree on them. Weights whose own values were truncated are combined only when the records they carry name the same bound, since weights bounded differently describe different estimands; a record already dropped -agrees with any bound. The categorical attributes name exposure levels -rather than positions, and the exposure records describe the exposure rather -than any unit, so both carry when the inputs agree. +agrees with any bound. The calibration record (\code{ps_calib_meta}) names the +curve the scores were calibrated with rather than any position, the +categorical attributes name exposure levels, and the exposure records +describe the exposure rather than any unit, so all of them carry by the +agreement rule above: two calibration records agree when they name the same +method and smoothing. Subsetting with \code{[} preserves class and attributes for vector subscripts. Two kinds of attribute hold one value per observation and so cannot be re-indexed for a subset: a \code{stabilization_score} with more than one value, -and the records left by a modified propensity score (\code{ps_trim_meta}, -\code{ps_trunc_meta}, and \code{ps_calib_meta}) or by truncating the weights +and the records left by a trimmed or truncated propensity score +(\code{ps_trim_meta} and \code{ps_trunc_meta}) or by truncating the weights themselves (\code{psw_trunc_meta}). Where an operation goes through vctrs, these are carried when the result comes back at the length they were recorded on and dropped when it does not. Any same-length operation keeps @@ -234,10 +237,11 @@ record is absent entirely. The result of any of these operations stays a \code{psw} and keeps every other attribute, including its stabilized, trimmed, truncated, and calibrated -status, the attributes describing a categorical exposure, which name the +status, the calibration record, which names a calibration curve rather than +any unit, the attributes describing a categorical exposure, which name the exposure levels rather than the units, and the exposure records, which -describe the exposure rather than any unit, so both mean the same thing at -any length. +describe the exposure rather than any unit, so all of them mean the same +thing at any length. Matrix or array subscripts intentionally drop the \code{psw} class and return a plain numeric vector via base R linear indexing; this is required so From 5c513c058124b9b8f86ad91cb3bd2b7a071a3a65 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 08:29:34 -0400 Subject: [PATCH 39/64] add failing tests for grouped mutate and unique on modified scores --- tests/testthat/test-modified-score-records.R | 168 +++++++++++++++++++ 1 file changed, 168 insertions(+) create mode 100644 tests/testthat/test-modified-score-records.R diff --git a/tests/testthat/test-modified-score-records.R b/tests/testthat/test-modified-score-records.R new file mode 100644 index 00000000..6e0de42d --- /dev/null +++ b/tests/testthat/test-modified-score-records.R @@ -0,0 +1,168 @@ +# A trimming or truncation record names units by position. Operations that +# regroup or collapse the units must hand back a record that describes the +# result exactly, or none at all. + +# Units 1 and 4 fall outside the bounds. +record_trim_fixture <- function() { + ps_trim(c(0.05, 0.3, 0.5, 0.95, 0.7, 0.2), lower = 0.1, upper = 0.9) +} + +# Units 1 and 4 fall outside the bounds. +record_trunc_fixture <- function() { + ps_trunc(c(0.05, 0.3, 0.5, 0.95, 0.7, 0.2), lower = 0.1, upper = 0.9) +} + +record_frame <- function(scores) { + df <- data.frame(g = c(1, 2, 1, 2, 1, 2)) + df$ps <- scores + df +} + +# Grouped mutate ------------------------------------------------------------- + +test_that("a grouped mutate copying a ps_trim column keeps its record silently", { + skip_if_not_installed("dplyr") + x <- record_trim_fixture() + grouped <- dplyr::group_by(record_frame(x), g) + + out <- expect_silent(dplyr::mutate(grouped, copy = ps)) + + expect_s3_class(out$copy, "ps_trim") + expect_identical(ps_trim_meta(out$copy), ps_trim_meta(x)) + expect_identical(is_unit_trimmed(out$copy), is_unit_trimmed(x)) + expect_identical(ps_trim_meta(out$ps), ps_trim_meta(x)) +}) + +test_that("a grouped mutate recombining a ps_trim column drops its positions silently", { + skip_if_not_installed("dplyr") + x <- record_trim_fixture() + grouped <- dplyr::group_by(record_frame(x), g) + + out <- expect_silent(dplyr::mutate(grouped, copy = identity(ps))) + + expect_s3_class(out$copy, "ps_trim") + expect_identical(vctrs::vec_data(out$copy), vctrs::vec_data(x)) + meta <- ps_trim_meta(out$copy) + expect_null(meta$keep_idx) + expect_null(meta$trimmed_idx) + expect_null(meta$n_obs) + expect_identical(meta$method, "ps") + expect_true(is_ps_trimmed(out$copy)) + expect_error( + is_unit_trimmed(out$copy), + class = "propensity_missing_meta_error" + ) + + # The column the mutate read is untouched. + expect_identical(ps_trim_meta(out$ps), ps_trim_meta(x)) +}) + +test_that("a grouped mutate copying a ps_trunc column keeps its record silently", { + skip_if_not_installed("dplyr") + x <- record_trunc_fixture() + grouped <- dplyr::group_by(record_frame(x), g) + + out <- expect_silent(dplyr::mutate(grouped, copy = ps)) + + expect_s3_class(out$copy, "ps_trunc") + expect_identical(ps_trunc_meta(out$copy), ps_trunc_meta(x)) + expect_identical(is_unit_truncated(out$copy), is_unit_truncated(x)) +}) + +test_that("a grouped mutate recombining a ps_trunc column drops its positions silently", { + skip_if_not_installed("dplyr") + x <- record_trunc_fixture() + grouped <- dplyr::group_by(record_frame(x), g) + + out <- expect_silent(dplyr::mutate(grouped, copy = identity(ps))) + + expect_s3_class(out$copy, "ps_trunc") + expect_identical(vctrs::vec_data(out$copy), vctrs::vec_data(x)) + meta <- ps_trunc_meta(out$copy) + expect_null(meta$truncated_idx) + expect_null(meta$n_obs) + expect_identical(meta$method, "ps") + expect_true(is_ps_truncated(out$copy)) + expect_error( + is_unit_truncated(out$copy), + class = "propensity_missing_meta_error" + ) +}) + +# unique() ------------------------------------------------------------------- + +test_that("unique() of a ps_trim re-indexes a record every kept unit agrees with", { + x <- ps_trim(c(0.05, 0.5, 0.95, 0.5, 0.3), lower = 0.1, upper = 0.9) + + out <- expect_silent(unique(x)) + + expect_identical(vctrs::vec_data(out), c(NA, 0.5, 0.3)) + meta <- ps_trim_meta(out) + expect_identical(meta$trimmed_idx, 1L) + expect_identical(meta$keep_idx, c(2L, 3L)) + expect_identical(meta$n_obs, 3L) + expect_identical(is_unit_trimmed(out), c(TRUE, FALSE, FALSE)) +}) + +test_that("unique() of a ps_trim drops a record a missing score shares with a trimmed one", { + # The one `NA` left stands for a score that arrived missing and for scores + # the trimming removed, so no single status describes it. + missing_first <- ps_trim(c(NA, 0.05, 0.5, 0.95), lower = 0.1, upper = 0.9) + trimmed_first <- ps_trim(c(0.05, NA, 0.5, 0.95), lower = 0.1, upper = 0.9) + + for (x in list(missing_first, trimmed_first)) { + expect_warning( + out <- unique(x), + class = "propensity_trim_record_warning" + ) + + expect_s3_class(out, "ps_trim") + expect_length(out, 2) + meta <- ps_trim_meta(out) + expect_null(meta$keep_idx) + expect_null(meta$trimmed_idx) + expect_null(meta$n_obs) + expect_identical(meta$method, "ps") + expect_error( + is_unit_trimmed(out), + class = "propensity_missing_meta_error" + ) + } +}) + +test_that("unique() of a ps_trunc re-indexes a record every kept unit agrees with", { + x <- ps_trunc(c(0.05, 0.5, 0.95, 0.5, 0.01), lower = 0.1, upper = 0.9) + + out <- expect_silent(unique(x)) + + expect_identical(vctrs::vec_data(out), c(0.1, 0.5, 0.9)) + meta <- ps_trunc_meta(out) + expect_identical(meta$truncated_idx, c(1L, 3L)) + expect_identical(meta$n_obs, 3L) + expect_identical(is_unit_truncated(out), c(TRUE, FALSE, TRUE)) +}) + +test_that("unique() of a ps_trunc drops a record a bounded score shares with an untouched one", { + # A score already at the bound and a score moved onto it collapse to one + # value, and no single status describes it. + untouched_first <- ps_trunc(c(0.1, 0.05, 0.5), lower = 0.1, upper = 0.9) + bounded_first <- ps_trunc(c(0.05, 0.1, 0.5), lower = 0.1, upper = 0.9) + + for (x in list(untouched_first, bounded_first)) { + expect_warning( + out <- unique(x), + class = "propensity_trunc_record_warning" + ) + + expect_s3_class(out, "ps_trunc") + expect_identical(vctrs::vec_data(out), c(0.1, 0.5)) + meta <- ps_trunc_meta(out) + expect_null(meta$truncated_idx) + expect_null(meta$n_obs) + expect_identical(meta$method, "ps") + expect_error( + is_unit_truncated(out), + class = "propensity_missing_meta_error" + ) + } +}) From 79db8fdfff91c04f188f3df90875eae3419bc8e9 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 08:44:45 -0400 Subject: [PATCH 40/64] drop score records silently and keep them consistent through unique() --- NEWS.md | 22 +++- R/ps_trim.R | 108 ++++++++++--------- R/ps_trunc.R | 91 ++++++++-------- R/utils.R | 10 ++ man/ps_trim.Rd | 35 +++--- man/ps_trunc.Rd | 27 +++-- tests/testthat/helper-conditions.R | 34 ------ tests/testthat/test-modified-score-records.R | 14 +-- tests/testthat/test-ps_trim.R | 34 ++---- tests/testthat/test-ps_trunc.R | 22 ++-- tests/testthat/test-tidyr-compat.R | 18 ++-- 11 files changed, 199 insertions(+), 216 deletions(-) diff --git a/NEWS.md b/NEWS.md index d4a5e0a3..8b0bc87b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,22 @@ # propensity 0.1.0.9000 (development version) +* A `ps_trim` or `ps_trunc` vector now drops the positions in its record + without a warning whenever an operation through vctrs changes its length, as + a `psw` already did. A grouped `dplyr::mutate()` or `dplyr::summarise()` + that read such a column, and printing one in a tibble, previously warned + about the pieces built along the way even when the result kept its record. + `is_unit_trimmed()`, `is_unit_truncated()`, and `ps_refit()` still refuse a + result whose record was dropped, with an error of class + `propensity_missing_meta_error`. + +* `unique()` of a `ps_trim` or `ps_trunc` now drops the positions in its + record when it merges units whose status differs, such as a trimmed score and + one that arrived missing, or a score already at a truncation bound and one + moved onto it. It previously returned a record that left the merged units + out, so `is_unit_trimmed()` reported a trimmed `NA` as retained. When every + merged unit shares one status the record is re-indexed onto the result as + before. + * Weights built from a calibrated propensity score now keep their calibration record (`ps_calib_meta`) through subsetting, `rep()`, and combining, as a `ps_calib` vector already did. The record names the calibration method and @@ -2306,9 +2323,8 @@ `dplyr::filter()`, joins, and group-wise summaries, returned a short column whose record still described the rows before the filter: `is_unit_trimmed()` on a two-element result answered with a four-element vector naming rows that - were no longer there. The record is now dropped when it cannot be re-indexed, - with a warning of class `propensity_trim_record_warning` or - `propensity_trunc_record_warning`, and `is_unit_trimmed()`, + were no longer there. The record is now dropped silently when it cannot be + re-indexed, and `is_unit_trimmed()`, `is_unit_truncated()`, and `ps_refit()` raise an error of class `propensity_missing_meta_error` on an object whose record is absent or was written for a different number of observations, rather than answer from stale diff --git a/R/ps_trim.R b/R/ps_trim.R index ff0d25ce..853276aa 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -249,29 +249,30 @@ #' A `ps_trim` records which units were trimmed as positions among the #' observations it was written for, along with how many observations that was. #' Operations that hand this package the subscript re-index those positions onto -#' the result: subsetting with `[`, [sort()], [unique()], [rep()], and -#' [na.omit()] all return a record written for what they return, and a subscript -#' naming a position more than once reports that unit at every place it now -#' holds. +#' the result: subsetting with `[`, [sort()], [rep()], and [na.omit()] all +#' return a record written for what they return, and a subscript naming a +#' position more than once reports that unit at every place it now holds. +#' [unique()] does the same when it can, as described below. #' #' Operations that change how many observations there are without supplying a #' subscript cannot re-index the record, and it is dropped rather than worked #' out from the values, since reading membership back from the `NA` pattern #' would report a propensity score that arrived missing as one this package #' removed. [vctrs::vec_slice()], which is how filtering, joining, and grouped -#' summaries in dplyr reach a column, is the usual route, and dropping the -#' record there raises a warning of class `propensity_trim_record_warning`. -#' Combining with [c()] drops it without comment, because concatenation appends -#' one set of observations to another and the prototype it builds the result -#' from holds no positions to lose. The values, the class, and the method and -#' its cutoffs are untouched either way. -#' -#' Printing a `ps_trim` column inside a tibble takes the same route: a tibble -#' prints the first few rows and slices the column to get them, so a column -#' longer than what is shown raises the record-drop warning as it is printed. -#' The warning is truthful, and it describes the vector built for the display -#' rather than the column, which is unchanged. Print `as.numeric()` of the -#' column, or widen the print with `options(pillar.print_max)`, to avoid it. +#' verbs in dplyr reach a column, is the usual route, and combining two or more +#' vectors with [c()] is another, because concatenation appends one set of +#' observations to another. The record is dropped without comment on every +#' route: most of these length changes build vectors the caller never holds, +#' such as the pieces a grouped verb slices a column into or the rows a tibble +#' slices off to print, so a warning would mostly describe something that is not +#' the result. The values, the class, and the method and its cutoffs are +#' untouched. +#' +#' [unique()] keeps one element for each distinct value, and that element +#' stands for every unit holding the value. The record is re-indexed onto the +#' result when all of those units share one status, and dropped otherwise: a +#' trimmed score and one that arrived missing are both `NA`, so a vector holding +#' both returns a single `NA` that neither status describes. #' #' A record can also outlive the observations it describes, because it travels #' by routes vctrs does not see: growing a `ps_trim` by subassignment carries it @@ -1698,44 +1699,33 @@ reindex_trim_record <- function(meta, i) { meta } -drop_trim_record <- function(meta) { - meta[["keep_idx"]] <- NULL - meta[["trimmed_idx"]] <- NULL - meta[["n_obs"]] <- NULL - - meta -} - # A record that no longer describes the observations in front of it is dropped # rather than guessed at. Nothing in the values says which units a shorter or a # longer vector once trimmed, and reading membership back from the `NA` pattern # would report a propensity score that arrived missing as one this package # removed. # -# A record over no observations names no unit, so replacing it costs the caller -# nothing and goes without comment. That is the record every prototype carries, -# which is what concatenation builds its result from. -discard_trim_record <- function(meta, n) { - recorded <- meta$n_obs +# The drop is silent. Most of the length changes that reach it are vectors +# built along the way to a result, such as the pieces a grouped dplyr verb +# slices a column into or the rows a tibble slices off to print, so a warning +# would mostly describe something the caller never holds. A positional query on +# the result refuses to answer from a record that is gone, which is where the +# loss matters. +drop_trim_record <- function(meta) { + meta[["keep_idx"]] <- NULL + meta[["trimmed_idx"]] <- NULL + meta[["n_obs"]] <- NULL - if (!is.null(recorded) && recorded > 0) { - warn( - c( - "Dropping the record of which units were trimmed.", - i = "The record describes {recorded} observation{?s} and this result - has {n}, so its positions do not describe them.", - i = "The values are unchanged and the result is still a - {.cls ps_trim}. Trim the propensity scores you want to work with - to get a record written for them." - ), - warning_class = "propensity_trim_record_warning", - # One of the routes here is vctrs' internal dispatch, whose call would be - # reported and names nothing the caller wrote, so no call is attributed. - call = NULL - ) - } + meta +} - drop_trim_record(meta) +# Each unit's standing in a record that covers it: retained, trimmed, or +# neither, which is a score that arrived missing. +trim_unit_status <- function(meta) { + status <- rep("missing", meta$n_obs) + status[meta$keep_idx] <- "kept" + status[meta$trimmed_idx] <- "trimmed" + status } # A positional query reads its answer out of the record, so a record that does @@ -1946,7 +1936,7 @@ is_unit_trimmed.ps_trim_matrix <- function(x) { new_meta <- if (length(rows) == nrow(result)) { carry_trim_record(meta, nrow(x), rows) } else { - discard_trim_record(meta, nrow(result)) + drop_trim_record(meta) } attr(result, "ps_trim_meta") <- new_meta @@ -2394,7 +2384,7 @@ carry_trim_record <- function(meta, n_obs, i) { if (record_covers(meta, n_obs)) { reindex_trim_record(meta, i) } else { - discard_trim_record(meta, length(i)) + drop_trim_record(meta) } } @@ -2421,7 +2411,23 @@ unique.ps_trim <- function(x, incomparables = FALSE, ...) { # `vec_unique_loc()` names the position each retained value came from, which # is the subscript re-indexing the record takes. Without this the restore # behind vctrs' own method sees only a shorter vector and drops the record. - x[vec_unique_loc(x)] + loc <- vec_unique_loc(x) + meta <- ps_trim_meta(x) + + # A retained value stands for every unit holding it, and the record can speak + # for it only when all of those units share one standing. A trimmed score and + # one that arrived missing are both `NA`, so they merge into one element that + # neither status describes, and the record is dropped rather than left to + # report that element as one of them. + if ( + !is.matrix(x) && + record_covers(meta, length(x)) && + !merged_units_agree(vec_data(x), trim_unit_status(meta)) + ) { + return(new_trimmed_ps(vec_data(x)[loc], drop_trim_record(meta))) + } + + x[loc] } #' @export @@ -2505,7 +2511,7 @@ vec_restore.ps_trim <- function(x, to, ...) { if (length(data) > 0 && length(to) == 0) { meta <- drop_trim_record(meta) } else if (length(data) > 0 && !record_covers(meta, length(data))) { - meta <- discard_trim_record(meta, length(data)) + meta <- drop_trim_record(meta) } new_trimmed_ps(data, ps_trim_meta = meta) diff --git a/R/ps_trunc.R b/R/ps_trunc.R index 9bc46293..b43d4a47 100644 --- a/R/ps_trunc.R +++ b/R/ps_trunc.R @@ -206,21 +206,28 @@ #' A `ps_trunc` records which units were winsorized as positions among the #' observations it was written for, along with how many observations that was. #' Operations that hand this package the subscript re-index those positions onto -#' the result: subsetting with `[`, [sort()], [unique()], and [rep()] all return -#' a record written for what they return, and a subscript naming a position more -#' than once reports that unit at every place it now holds. +#' the result: subsetting with `[`, [sort()], and [rep()] all return a record +#' written for what they return, and a subscript naming a position more than +#' once reports that unit at every place it now holds. [unique()] does the same +#' when it can, as described below. #' #' Operations that change how many observations there are without supplying a #' subscript cannot re-index the record, and it is dropped rather than worked #' out from the values, since a score that arrived equal to a bound is #' indistinguishable from one this function pinned there. [vctrs::vec_slice()], -#' which is how filtering, joining, and grouped summaries in dplyr reach a -#' column, is the usual route, and dropping the record there raises a warning -#' of class `propensity_trunc_record_warning`. Combining with [c()] drops it -#' without comment, because concatenation appends one set of observations to -#' another and the prototype it builds the result from holds no positions to -#' lose. The values, the class, and the method and its bounds are untouched -#' either way. +#' which is how filtering, joining, and grouped verbs in dplyr reach a column, +#' is the usual route, and combining two or more vectors with [c()] is another, +#' because concatenation appends one set of observations to another. The record +#' is dropped without comment on every route, since most of these length changes +#' build vectors the caller never holds, such as the pieces a grouped verb +#' slices a column into. The values, the class, and the method and its bounds +#' are untouched. +#' +#' [unique()] keeps one element for each distinct value, and that element +#' stands for every unit holding the value. The record is re-indexed onto the +#' result when all of those units share one status, and dropped otherwise: a +#' score that arrived at a bound and one moved onto it merge into a single +#' element that neither status describes. #' #' A record can also outlive the observations it describes, because it travels #' by routes vctrs does not see: growing a `ps_trunc` by subassignment carries @@ -1234,42 +1241,19 @@ reindex_trunc_record <- function(meta, i) { meta } -drop_trunc_record <- function(meta) { - meta[["truncated_idx"]] <- NULL - meta[["n_obs"]] <- NULL - - meta -} - # A record that no longer describes the observations in front of it is dropped # rather than guessed at. Nothing in the values says which units a shorter or a # longer vector once had winsorized: a score that arrived equal to a bound is # indistinguishable from one this package pinned there. # -# A record over no observations names no unit, so replacing it costs the caller -# nothing and goes without comment. That is the record every prototype carries, -# which is what concatenation builds its result from. -discard_trunc_record <- function(meta, n) { - recorded <- meta$n_obs - - if (!is.null(recorded) && recorded > 0) { - warn( - c( - "Dropping the record of which units were truncated.", - i = "The record describes {recorded} observation{?s} and this result - has {n}, so its positions do not describe them.", - i = "The values are unchanged and the result is still a - {.cls ps_trunc}. Truncate the propensity scores you want to work - with to get a record written for them." - ), - warning_class = "propensity_trunc_record_warning", - # One of the routes here is vctrs' internal dispatch, whose call would be - # reported and names nothing the caller wrote, so no call is attributed. - call = NULL - ) - } +# The drop is silent, for the reason a trimming record's is: most of the length +# changes that reach it build vectors the caller never holds, and a positional +# query on the result refuses to answer from a record that is gone. +drop_trunc_record <- function(meta) { + meta[["truncated_idx"]] <- NULL + meta[["n_obs"]] <- NULL - drop_trunc_record(meta) + meta } # `i` holds the old positions the result is built from, in the order it holds @@ -1280,7 +1264,7 @@ carry_trunc_record <- function(meta, n_obs, i) { if (record_covers(meta, n_obs)) { reindex_trunc_record(meta, i) } else { - discard_trunc_record(meta, length(i)) + drop_trunc_record(meta) } } @@ -1511,7 +1495,7 @@ is_unit_truncated.ps_trunc_matrix <- function(x) { new_meta <- if (length(rows) == nrow(result)) { carry_trunc_record(meta, nrow(x), rows) } else { - discard_trunc_record(meta, nrow(result)) + drop_trunc_record(meta) } attr(result, "ps_trunc_meta") <- new_meta @@ -1889,7 +1873,26 @@ unique.ps_trunc <- function(x, incomparables = FALSE, ...) { # `vec_unique_loc()` names the position each retained value came from, which # is the subscript re-indexing the record takes. Without this the restore # behind vctrs' own method sees only a shorter vector and drops the record. - x[vec_unique_loc(x)] + loc <- vec_unique_loc(x) + meta <- ps_trunc_meta(x) + + # A retained value stands for every unit holding it, and the record can speak + # for it only when all of those units share one standing. A score that arrived + # at a bound and one moved onto it merge into one element that neither status + # describes, so the record is dropped rather than left to report it as one of + # them. + if ( + !is.matrix(x) && + record_covers(meta, length(x)) && + !merged_units_agree( + vec_data(x), + seq_along(x) %in% meta$truncated_idx + ) + ) { + return(new_ps_trunc(vec_data(x)[loc], drop_trunc_record(meta))) + } + + x[loc] } #' @export @@ -1959,7 +1962,7 @@ vec_restore.ps_trunc <- function(x, to, ...) { if (length(data) > 0 && length(to) == 0) { meta <- drop_trunc_record(meta) } else if (length(data) > 0 && !record_covers(meta, length(data))) { - meta <- discard_trunc_record(meta, length(data)) + meta <- drop_trunc_record(meta) } new_ps_trunc(data, meta) diff --git a/R/utils.R b/R/utils.R index 1068f126..b9e8498d 100644 --- a/R/utils.R +++ b/R/utils.R @@ -260,6 +260,16 @@ record_covers <- function(meta, n) { !is.null(meta$n_obs) && meta$n_obs == n } +# Whether every set of units `unique()` merges into one element shares a single +# status. `vec_group_id()` groups values the way `vec_unique_loc()` keeps them, +# missing values included, so each group is one element of the result. +merged_units_agree <- function(values, status) { + groups <- vctrs::vec_group_id(values) + pairs <- data.frame(group = as.integer(groups), status = status) + + vctrs::vec_unique_count(pairs) == attr(groups, "n") +} + # `[` knows the subscript, which is what re-indexing a record takes. Every # occurrence of a recorded position is mapped onto the position it now holds, so # a subscript naming a position twice reports that unit twice. `NA` names no diff --git a/man/ps_trim.Rd b/man/ps_trim.Rd index 26891d8c..02e79bdc 100644 --- a/man/ps_trim.Rd +++ b/man/ps_trim.Rd @@ -317,29 +317,30 @@ undefined. Remove or impute the missing exposure values first. A \code{ps_trim} records which units were trimmed as positions among the observations it was written for, along with how many observations that was. Operations that hand this package the subscript re-index those positions onto -the result: subsetting with \code{[}, \code{\link[=sort]{sort()}}, \code{\link[=unique]{unique()}}, \code{\link[=rep]{rep()}}, and -\code{\link[=na.omit]{na.omit()}} all return a record written for what they return, and a subscript -naming a position more than once reports that unit at every place it now -holds. +the result: subsetting with \code{[}, \code{\link[=sort]{sort()}}, \code{\link[=rep]{rep()}}, and \code{\link[=na.omit]{na.omit()}} all +return a record written for what they return, and a subscript naming a +position more than once reports that unit at every place it now holds. +\code{\link[=unique]{unique()}} does the same when it can, as described below. Operations that change how many observations there are without supplying a subscript cannot re-index the record, and it is dropped rather than worked out from the values, since reading membership back from the \code{NA} pattern would report a propensity score that arrived missing as one this package removed. \code{\link[vctrs:vec_slice]{vctrs::vec_slice()}}, which is how filtering, joining, and grouped -summaries in dplyr reach a column, is the usual route, and dropping the -record there raises a warning of class \code{propensity_trim_record_warning}. -Combining with \code{\link[=c]{c()}} drops it without comment, because concatenation appends -one set of observations to another and the prototype it builds the result -from holds no positions to lose. The values, the class, and the method and -its cutoffs are untouched either way. - -Printing a \code{ps_trim} column inside a tibble takes the same route: a tibble -prints the first few rows and slices the column to get them, so a column -longer than what is shown raises the record-drop warning as it is printed. -The warning is truthful, and it describes the vector built for the display -rather than the column, which is unchanged. Print \code{as.numeric()} of the -column, or widen the print with \code{options(pillar.print_max)}, to avoid it. +verbs in dplyr reach a column, is the usual route, and combining two or more +vectors with \code{\link[=c]{c()}} is another, because concatenation appends one set of +observations to another. The record is dropped without comment on every +route: most of these length changes build vectors the caller never holds, +such as the pieces a grouped verb slices a column into or the rows a tibble +slices off to print, so a warning would mostly describe something that is not +the result. The values, the class, and the method and its cutoffs are +untouched. + +\code{\link[=unique]{unique()}} keeps one element for each distinct value, and that element +stands for every unit holding the value. The record is re-indexed onto the +result when all of those units share one status, and dropped otherwise: a +trimmed score and one that arrived missing are both \code{NA}, so a vector holding +both returns a single \code{NA} that neither status describes. A record can also outlive the observations it describes, because it travels by routes vctrs does not see: growing a \code{ps_trim} by subassignment carries it diff --git a/man/ps_trunc.Rd b/man/ps_trunc.Rd index 7e34b05a..a4853aa9 100644 --- a/man/ps_trunc.Rd +++ b/man/ps_trunc.Rd @@ -249,21 +249,28 @@ Remove or impute the missing exposure values first. A \code{ps_trunc} records which units were winsorized as positions among the observations it was written for, along with how many observations that was. Operations that hand this package the subscript re-index those positions onto -the result: subsetting with \code{[}, \code{\link[=sort]{sort()}}, \code{\link[=unique]{unique()}}, and \code{\link[=rep]{rep()}} all return -a record written for what they return, and a subscript naming a position more -than once reports that unit at every place it now holds. +the result: subsetting with \code{[}, \code{\link[=sort]{sort()}}, and \code{\link[=rep]{rep()}} all return a record +written for what they return, and a subscript naming a position more than +once reports that unit at every place it now holds. \code{\link[=unique]{unique()}} does the same +when it can, as described below. Operations that change how many observations there are without supplying a subscript cannot re-index the record, and it is dropped rather than worked out from the values, since a score that arrived equal to a bound is indistinguishable from one this function pinned there. \code{\link[vctrs:vec_slice]{vctrs::vec_slice()}}, -which is how filtering, joining, and grouped summaries in dplyr reach a -column, is the usual route, and dropping the record there raises a warning -of class \code{propensity_trunc_record_warning}. Combining with \code{\link[=c]{c()}} drops it -without comment, because concatenation appends one set of observations to -another and the prototype it builds the result from holds no positions to -lose. The values, the class, and the method and its bounds are untouched -either way. +which is how filtering, joining, and grouped verbs in dplyr reach a column, +is the usual route, and combining two or more vectors with \code{\link[=c]{c()}} is another, +because concatenation appends one set of observations to another. The record +is dropped without comment on every route, since most of these length changes +build vectors the caller never holds, such as the pieces a grouped verb +slices a column into. The values, the class, and the method and its bounds +are untouched. + +\code{\link[=unique]{unique()}} keeps one element for each distinct value, and that element +stands for every unit holding the value. The record is re-indexed onto the +result when all of those units share one status, and dropped otherwise: a +score that arrived at a bound and one moved onto it merge into a single +element that neither status describes. A record can also outlive the observations it describes, because it travels by routes vctrs does not see: growing a \code{ps_trunc} by subassignment carries diff --git a/tests/testthat/helper-conditions.R b/tests/testthat/helper-conditions.R index a26b7e00..5c2dc9ae 100644 --- a/tests/testthat/helper-conditions.R +++ b/tests/testthat/helper-conditions.R @@ -13,40 +13,6 @@ condition_call_name <- function(expr, classes = "error") { paste(deparse(conditionCall(cnd)[[1]]), collapse = " ") } -# Runs `expr` with the dropped-record warnings muffled and reports how many were -# raised, so a test can assert that an operation dropped a record without the -# warnings reaching the test run. -# -# The count is of warnings, not of drops. dplyr collects the warnings raised -# inside a verb and re-emits one summary of them per verb, so several drops in a -# grouped call arrive as one warning and count as one. Assert that the count is -# positive, or that it is zero, rather than that it equals a number of drops. -count_record_drops <- function(expr) { - drops <- 0L - count <- function(cnd) { - drops <<- drops + 1L - invokeRestart("muffleWarning") - } - - # dplyr collects the warnings raised inside a verb and re-emits one plain - # summary of them, so a drop that happens there arrives without its class and - # is recognized by what it says instead. - count_rewrapped <- function(cnd) { - if (grepl("Dropping the record of which units", conditionMessage(cnd))) { - count(cnd) - } - } - - value <- withCallingHandlers( - expr, - propensity_trim_record_warning = count, - propensity_trunc_record_warning = count, - warning = count_rewrapped - ) - - list(value = value, drops = drops) -} - # Runs `expr` with the finite-variance report muffled. Stabilized normal weights # have no finite second moment once the marginal variance of the exposure # reaches twice the conditional one, and a fixture whose fitted means track the diff --git a/tests/testthat/test-modified-score-records.R b/tests/testthat/test-modified-score-records.R index 6e0de42d..a3fc82b1 100644 --- a/tests/testthat/test-modified-score-records.R +++ b/tests/testthat/test-modified-score-records.R @@ -104,17 +104,14 @@ test_that("unique() of a ps_trim re-indexes a record every kept unit agrees with expect_identical(is_unit_trimmed(out), c(TRUE, FALSE, FALSE)) }) -test_that("unique() of a ps_trim drops a record a missing score shares with a trimmed one", { +test_that("unique() of a ps_trim silently drops a record a missing score shares with a trimmed one", { # The one `NA` left stands for a score that arrived missing and for scores # the trimming removed, so no single status describes it. missing_first <- ps_trim(c(NA, 0.05, 0.5, 0.95), lower = 0.1, upper = 0.9) trimmed_first <- ps_trim(c(0.05, NA, 0.5, 0.95), lower = 0.1, upper = 0.9) for (x in list(missing_first, trimmed_first)) { - expect_warning( - out <- unique(x), - class = "propensity_trim_record_warning" - ) + out <- expect_silent(unique(x)) expect_s3_class(out, "ps_trim") expect_length(out, 2) @@ -142,17 +139,14 @@ test_that("unique() of a ps_trunc re-indexes a record every kept unit agrees wit expect_identical(is_unit_truncated(out), c(TRUE, FALSE, TRUE)) }) -test_that("unique() of a ps_trunc drops a record a bounded score shares with an untouched one", { +test_that("unique() of a ps_trunc silently drops a record a bounded score shares with an untouched one", { # A score already at the bound and a score moved onto it collapse to one # value, and no single status describes it. untouched_first <- ps_trunc(c(0.1, 0.05, 0.5), lower = 0.1, upper = 0.9) bounded_first <- ps_trunc(c(0.05, 0.1, 0.5), lower = 0.1, upper = 0.9) for (x in list(untouched_first, bounded_first)) { - expect_warning( - out <- unique(x), - class = "propensity_trunc_record_warning" - ) + out <- expect_silent(unique(x)) expect_s3_class(out, "ps_trunc") expect_identical(vctrs::vec_data(out), c(0.1, 0.5)) diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index 753913a4..f6f0f2be 100644 --- a/tests/testthat/test-ps_trim.R +++ b/tests/testthat/test-ps_trim.R @@ -513,16 +513,15 @@ test_that("ps_trim works with summarize(mean = mean(ps))", { ps_refit(fit) # A grouped summary slices the column once per group, and each slice holds - # scores the trimming record was not written for, so the record is dropped and - # says so. The summary itself reads values rather than positions. - summarized <- count_record_drops( + # scores the trimming record was not written for, so the record is dropped + # from the slices without comment. The summary itself reads values rather + # than positions. + out <- expect_silent( tibble(x, z, ps) |> group_by(trimmed = is_unit_trimmed(ps)) |> summarize(mean = mean(ps), .groups = "drop") ) - expect_gt(summarized$drops, 0) - out <- summarized$value expect_s3_class(out, "tbl_df") expect_named(out, c("trimmed", "mean")) expect_type(out$mean, "double") @@ -676,14 +675,10 @@ test_that("ps_trim() records how many observations its positions describe", { expect_equal(meta$n_obs, 5L) }) -test_that("slicing a ps_trim shorter drops the trimming record with a warning", { +test_that("slicing a ps_trim shorter drops the trimming record silently", { x <- trim_record_fixture() - cnd <- expect_warning( - sliced <- vec_slice(x, 2:3), - class = "propensity_trim_record_warning" - ) - expect_s3_class(cnd, "propensity_warning") + sliced <- expect_silent(vec_slice(x, 2:3)) expect_s3_class(sliced, "ps_trim") expect_equal(as.numeric(sliced), c(0.3, 0.5)) @@ -705,16 +700,13 @@ test_that("slicing a ps_trim shorter drops the trimming record with a warning", ) }) -test_that("filtering a ps_trim column drops the trimming record with a warning", { +test_that("filtering a ps_trim column drops the trimming record silently", { skip_if_not_installed("dplyr") df <- data.frame(id = 1:5) df$ps <- trim_record_fixture() - expect_warning( - filtered <- dplyr::filter(df, id %in% 2:3), - class = "propensity_trim_record_warning" - ) + filtered <- expect_silent(dplyr::filter(df, id %in% 2:3)) expect_s3_class(filtered$ps, "ps_trim") expect_equal(as.numeric(filtered$ps), c(0.3, 0.5)) @@ -799,10 +791,7 @@ test_that("ps_refit() refuses a ps_trim whose record was dropped", { upper = 0.7 ) - expect_warning( - sliced <- vec_slice(trimmed, 1:20), - class = "propensity_trim_record_warning" - ) + sliced <- expect_silent(vec_slice(trimmed, 1:20)) expect_error( ps_refit(sliced, model), @@ -925,10 +914,7 @@ test_that("combining ps_trim objects does not read trimmed units off the NAs", { test_that("a ps_trim that lost its record says so instead of reporting none", { x <- trim_record_fixture() - expect_warning( - sliced <- vec_slice(x, 2:3), - class = "propensity_trim_record_warning" - ) + sliced <- expect_silent(vec_slice(x, 2:3)) expect_match(vec_ptype_full(x), "trimmed 2 of", fixed = TRUE) expect_match(vec_ptype_full(sliced), "record dropped", fixed = TRUE) diff --git a/tests/testthat/test-ps_trunc.R b/tests/testthat/test-ps_trunc.R index 2e09fd2c..190cba95 100644 --- a/tests/testthat/test-ps_trunc.R +++ b/tests/testthat/test-ps_trunc.R @@ -348,15 +348,14 @@ test_that("ps_trunc works with summarize(mean = mean(ps))", { # A grouped summary slices the column once per group, and each slice holds # scores the truncation record was not written for, so the record is dropped - # and says so. The summary itself reads values rather than positions. - summarized <- count_record_drops( + # from the slices without comment. The summary itself reads values rather + # than positions. + out <- expect_silent( tibble(x, z, ps) |> group_by(truncated = is_unit_truncated(ps)) |> summarize(mean = mean(ps), .groups = "drop") ) - expect_gt(summarized$drops, 0) - out <- summarized$value expect_s3_class(out, "tbl_df") expect_named(out, c("truncated", "mean")) expect_type(out$mean, "double") @@ -557,14 +556,10 @@ test_that("ps_trunc() records how many observations its positions describe", { expect_equal(meta$n_obs, 5L) }) -test_that("slicing a ps_trunc shorter drops the truncation record with a warning", { +test_that("slicing a ps_trunc shorter drops the truncation record silently", { x <- trunc_record_fixture() - cnd <- expect_warning( - sliced <- vec_slice(x, 2:3), - class = "propensity_trunc_record_warning" - ) - expect_s3_class(cnd, "propensity_warning") + sliced <- expect_silent(vec_slice(x, 2:3)) expect_s3_class(sliced, "ps_trunc") expect_equal(as.numeric(sliced), c(0.3, 0.5)) @@ -585,16 +580,13 @@ test_that("slicing a ps_trunc shorter drops the truncation record with a warning ) }) -test_that("filtering a ps_trunc column drops the truncation record with a warning", { +test_that("filtering a ps_trunc column drops the truncation record silently", { skip_if_not_installed("dplyr") df <- data.frame(id = 1:5) df$ps <- trunc_record_fixture() - expect_warning( - filtered <- dplyr::filter(df, id %in% 2:3), - class = "propensity_trunc_record_warning" - ) + filtered <- expect_silent(dplyr::filter(df, id %in% 2:3)) expect_s3_class(filtered$ps, "ps_trunc") expect_equal(as.numeric(filtered$ps), c(0.3, 0.5)) diff --git a/tests/testthat/test-tidyr-compat.R b/tests/testthat/test-tidyr-compat.R index 5f5ebc12..3e7096cf 100644 --- a/tests/testthat/test-tidyr-compat.R +++ b/tests/testthat/test-tidyr-compat.R @@ -209,16 +209,16 @@ test_that("tidyr operations with NAs in ps_trim work correctly", { # pivot_wider should preserve the ps_trim structure. Widening spreads four # observations across two columns of four and fills the gaps, so neither # column holds the observations the trimming record was written for and each - # drops it. - pivoted <- count_record_drops( + # drops it without comment. + result <- expect_silent( tidyr::pivot_wider( df, names_from = group, values_from = weights ) ) - expect_gt(pivoted$drops, 0) - result <- pivoted$value + expect_null(ps_trim_meta(result$A)$n_obs) + expect_null(ps_trim_meta(result$B)$n_obs) # Check structure - 4 rows for 4 unique ids expect_equal(nrow(result), 4) @@ -328,15 +328,17 @@ test_that("tidyr with all NA weights works", { # All values should be NA expect_true(all(is.na(df$weight))) - # Pivot should still work, dropping the trimming record with each new column - pivoted <- count_record_drops( + # Pivot should still work, silently dropping the trimming record from each + # new column + pivoted <- expect_silent( tidyr::pivot_wider( df, names_from = group, values_from = weight ) ) - expect_gt(pivoted$drops, 0) + expect_null(ps_trim_meta(pivoted$A)$n_obs) + expect_null(ps_trim_meta(pivoted$B)$n_obs) - expect_equal(nrow(pivoted$value), 4) + expect_equal(nrow(pivoted), 4) }) From e62813034eb6741ddc84d29fc64e5ab77feb478b Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 08:54:25 -0400 Subject: [PATCH 41/64] add failing tests for unique() on modified score matrices --- .../test-modified-score-matrix-unique.R | 187 ++++++++++++++++++ 1 file changed, 187 insertions(+) create mode 100644 tests/testthat/test-modified-score-matrix-unique.R diff --git a/tests/testthat/test-modified-score-matrix-unique.R b/tests/testthat/test-modified-score-matrix-unique.R new file mode 100644 index 00000000..19a24d95 --- /dev/null +++ b/tests/testthat/test-modified-score-matrix-unique.R @@ -0,0 +1,187 @@ +# `unique()` of a matrix of scores keeps one row for each distinct row. The +# result is a matrix of the same class, and its record is re-indexed onto the +# kept rows only when every set of merged rows shares one status. + +# fmt: skip +unique_matrix_scores <- matrix( + c( + 0.8, 0.1, 0.1, + 0.4, 0.3, 0.3, + 0.02, 0.49, 0.49, + 0.4, 0.3, 0.3, + 0.98, 0.01, 0.01, + 0.2, 0.4, 0.4, + 0.3, 0.3, 0.4, + NA, NA, NA + ), + ncol = 3, + byrow = TRUE, + dimnames = list(NULL, c("a", "b", "c")) +) +unique_matrix_exposure <- factor(c("a", "b", "c", "a", "b", "c", "a", "b")) + +# Rows 3 and 5 fall below the threshold. Row 4 repeats row 2, and row 8 arrived +# missing. +unique_trim_matrix <- function(rows = 1:8) { + ps_trim( + unique_matrix_scores[rows, , drop = FALSE], + .exposure = unique_matrix_exposure[rows], + method = "ps", + lower = 0.05 + ) +} + +unique_trunc_matrix <- function(rows = 1:8) { + ps_trunc( + unique_matrix_scores[rows, , drop = FALSE], + .exposure = unique_matrix_exposure[rows], + method = "ps", + lower = 0.05 + ) +} + +# ps_trim_matrix -------------------------------------------------------------- + +test_that("unique() of a ps_trim_matrix with distinct rows returns it whole", { + x <- unique_trim_matrix(c(1, 2, 3, 6, 7)) + + out <- expect_silent(unique(x)) + + expect_s3_class(out, "ps_trim_matrix") + expect_identical(dim(out), c(5L, 3L)) + expect_identical(dimnames(out), dimnames(x)) + expect_identical(unclass(out)[,], unclass(x)[,]) + expect_identical(ps_trim_meta(out), ps_trim_meta(x)) + expect_identical(is_unit_trimmed(out), is_unit_trimmed(x)) +}) + +test_that("unique() of a ps_trim_matrix re-indexes a record the merged rows agree on", { + # Rows 2 and 4 are both retained, and rows 3 and 5 are both trimmed. + x <- unique_trim_matrix(1:7) + + out <- expect_silent(unique(x)) + + expect_s3_class(out, "ps_trim_matrix") + expect_identical(dim(out), c(5L, 3L)) + expect_identical(colnames(out), c("a", "b", "c")) + expect_identical( + unclass(out)[,], + unclass(x)[c(1, 2, 3, 6, 7), ] + ) + + meta <- ps_trim_meta(out) + expect_identical(meta$trimmed_idx, 3L) + expect_identical(meta$keep_idx, c(1L, 2L, 4L, 5L)) + expect_identical(meta$n_obs, 5L) + expect_identical(meta$method, "ps") + expect_identical(is_unit_trimmed(out), c(FALSE, FALSE, TRUE, FALSE, FALSE)) +}) + +test_that("unique() of a ps_trim_matrix drops a record a missing row shares with a trimmed one", { + # A trimmed row is all `NA`, so it merges with a row that arrived missing, + # and neither status describes the row left. + trimmed_first <- unique_trim_matrix(1:8) + missing_first <- unique_trim_matrix(c(8, 1:7)) + + for (x in list(trimmed_first, missing_first)) { + out <- expect_silent(unique(x)) + + expect_s3_class(out, "ps_trim_matrix") + expect_identical(dim(out), c(5L, 3L)) + expect_identical(colnames(out), c("a", "b", "c")) + + meta <- ps_trim_meta(out) + expect_null(meta$keep_idx) + expect_null(meta$trimmed_idx) + expect_null(meta$n_obs) + expect_identical(meta$method, "ps") + expect_true(is_ps_trimmed(out)) + expect_error( + is_unit_trimmed(out), + class = "propensity_missing_meta_error" + ) + } +}) + +# ps_trunc_matrix ------------------------------------------------------------- + +test_that("unique() of a ps_trunc_matrix with distinct rows returns it whole", { + x <- unique_trunc_matrix(c(1, 2, 3, 6, 7)) + + out <- expect_silent(unique(x)) + + expect_s3_class(out, "ps_trunc_matrix") + expect_identical(dim(out), c(5L, 3L)) + expect_identical(dimnames(out), dimnames(x)) + expect_identical(unclass(out)[,], unclass(x)[,]) + expect_identical(ps_trunc_meta(out), ps_trunc_meta(x)) + expect_identical(is_unit_truncated(out), is_unit_truncated(x)) +}) + +test_that("unique() of a ps_trunc_matrix re-indexes a record the merged rows agree on", { + # Rows 2 and 4 are identical and both unmoved. Row 8 arrived missing and + # merges with nothing. + x <- unique_trunc_matrix(1:8) + + out <- expect_silent(unique(x)) + + expect_s3_class(out, "ps_trunc_matrix") + expect_identical(dim(out), c(7L, 3L)) + expect_identical(colnames(out), c("a", "b", "c")) + expect_identical( + unclass(out)[,], + unclass(x)[c(1, 2, 3, 5, 6, 7, 8), ] + ) + + meta <- ps_trunc_meta(out) + expect_identical(meta$truncated_idx, c(3L, 4L)) + expect_identical(meta$n_obs, 7L) + expect_identical(meta$method, "ps") + expect_identical( + is_unit_truncated(out), + c(FALSE, FALSE, TRUE, TRUE, FALSE, FALSE, FALSE) + ) +}) + +test_that("unique() of a ps_trunc_matrix drops a record a moved row shares with an unmoved one", { + # The record says row 1 was moved and row 2, which holds the same scores, was + # not, so the one row left has no single status. + template <- unique_trunc_matrix(1:3) + # fmt: skip + scores <- matrix( + c( + 0.5, 0.25, 0.25, + 0.5, 0.25, 0.25, + 0.2, 0.4, 0.4 + ), + ncol = 3, + byrow = TRUE, + dimnames = list(NULL, c("a", "b", "c")) + ) + meta <- ps_trunc_meta(template) + meta$truncated_idx <- 1L + meta$n_obs <- 3L + moved_first <- new_ps_trunc(scores, meta) + + meta$truncated_idx <- 2L + unmoved_first <- new_ps_trunc(scores, meta) + + for (x in list(moved_first, unmoved_first)) { + out <- expect_silent(unique(x)) + + expect_s3_class(out, "ps_trunc_matrix") + expect_identical(dim(out), c(2L, 3L)) + expect_identical(colnames(out), c("a", "b", "c")) + expect_identical(unclass(out)[,], scores[c(1, 3), ]) + + out_meta <- ps_trunc_meta(out) + expect_null(out_meta$truncated_idx) + expect_null(out_meta$n_obs) + expect_identical(out_meta$method, "ps") + expect_true(is_ps_truncated(out)) + expect_error( + is_unit_truncated(out), + class = "propensity_missing_meta_error" + ) + } +}) From 4c6109c99be7643a5845e87bcb71ffa6dc4882f8 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 08:58:47 -0400 Subject: [PATCH 42/64] keep unique() on score matrices row-wise --- NEWS.md | 8 ++++++++ R/ps_trim.R | 40 +++++++++++++++++++++++----------------- R/ps_trunc.R | 34 +++++++++++++++++++--------------- R/utils.R | 24 ++++++++++++++++++++++++ man/ps_trim.Rd | 13 ++++++++----- man/ps_trunc.Rd | 12 +++++++----- 6 files changed, 89 insertions(+), 42 deletions(-) diff --git a/NEWS.md b/NEWS.md index 8b0bc87b..e297be67 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,13 @@ # propensity 0.1.0.9000 (development version) +* `unique()` of a `ps_trim` or `ps_trunc` matrix of categorical propensity + scores now keeps one row for each distinct row and returns a matrix of the + same class, with its column names and a trimming or truncation record + re-indexed onto the kept rows. It previously indexed the matrix as one long + vector and returned a plain numeric vector taken from the first column. As + for a vector, the record is dropped when merged rows differ in status, such + as a trimmed row and a row that arrived missing. + * A `ps_trim` or `ps_trunc` vector now drops the positions in its record without a warning whenever an operation through vctrs changes its length, as a `psw` already did. A grouped `dplyr::mutate()` or `dplyr::summarise()` diff --git a/R/ps_trim.R b/R/ps_trim.R index 853276aa..70b43952 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -268,11 +268,14 @@ #' the result. The values, the class, and the method and its cutoffs are #' untouched. #' -#' [unique()] keeps one element for each distinct value, and that element -#' stands for every unit holding the value. The record is re-indexed onto the -#' result when all of those units share one status, and dropped otherwise: a -#' trimmed score and one that arrived missing are both `NA`, so a vector holding -#' both returns a single `NA` that neither status describes. +#' [unique()] keeps one element for each distinct value, or one row for each +#' distinct row of a matrix of scores, and that element or row stands for every +#' unit holding the same scores. A matrix comes back as a matrix of the same +#' class with its column names. The record is re-indexed onto the result when +#' all of the merged units share one status, and dropped otherwise: a trimmed +#' score and one that arrived missing are both `NA`, and a trimmed row is `NA` +#' throughout, so a vector or matrix holding both returns a single `NA` element +#' or row that neither status describes. #' #' A record can also outlive the observations it describes, because it travels #' by routes vctrs does not see: growing a `ps_trim` by subassignment carries it @@ -2408,26 +2411,29 @@ sort.ps_trim <- function(x, decreasing = FALSE, na.last = NA, ...) { unique.ps_trim <- function(x, incomparables = FALSE, ...) { check_incomparables(incomparables, "ps_trim") - # `vec_unique_loc()` names the position each retained value came from, which - # is the subscript re-indexing the record takes. Without this the restore - # behind vctrs' own method sees only a shorter vector and drops the record. - loc <- vec_unique_loc(x) + # The positions `vec_unique_loc()` names are the subscript re-indexing the + # record takes, rows for a matrix and elements otherwise. Without this the + # restore behind vctrs' own method sees only a shorter vector and drops the + # record. + values <- score_values(x) + loc <- vec_unique_loc(values) + out <- subset_score_units(x, loc) meta <- ps_trim_meta(x) # A retained value stands for every unit holding it, and the record can speak # for it only when all of those units share one standing. A trimmed score and - # one that arrived missing are both `NA`, so they merge into one element that - # neither status describes, and the record is dropped rather than left to - # report that element as one of them. + # one that arrived missing are both `NA`, and a trimmed row is `NA` + # throughout, so they merge into one element that neither status describes, + # and the record is dropped rather than left to report that element as one of + # them. if ( - !is.matrix(x) && - record_covers(meta, length(x)) && - !merged_units_agree(vec_data(x), trim_unit_status(meta)) + record_covers(meta, vec_size(values)) && + !merged_units_agree(values, trim_unit_status(meta)) ) { - return(new_trimmed_ps(vec_data(x)[loc], drop_trim_record(meta))) + attr(out, "ps_trim_meta") <- drop_trim_record(meta) } - x[loc] + out } #' @export diff --git a/R/ps_trunc.R b/R/ps_trunc.R index b43d4a47..74dc19fc 100644 --- a/R/ps_trunc.R +++ b/R/ps_trunc.R @@ -223,11 +223,13 @@ #' slices a column into. The values, the class, and the method and its bounds #' are untouched. #' -#' [unique()] keeps one element for each distinct value, and that element -#' stands for every unit holding the value. The record is re-indexed onto the -#' result when all of those units share one status, and dropped otherwise: a -#' score that arrived at a bound and one moved onto it merge into a single -#' element that neither status describes. +#' [unique()] keeps one element for each distinct value, or one row for each +#' distinct row of a matrix of scores, and that element or row stands for every +#' unit holding the same scores. A matrix comes back as a matrix of the same +#' class with its column names. The record is re-indexed onto the result when +#' all of the merged units share one status, and dropped otherwise: a score or +#' row that arrived where truncation would put it and one truncation moved +#' there merge into a single element or row that neither status describes. #' #' A record can also outlive the observations it describes, because it travels #' by routes vctrs does not see: growing a `ps_trunc` by subassignment carries @@ -1870,10 +1872,13 @@ quantile.ps_trunc <- function(x, probs = seq(0, 1, 0.25), na.rm = FALSE, ...) { unique.ps_trunc <- function(x, incomparables = FALSE, ...) { check_incomparables(incomparables, "ps_trunc") - # `vec_unique_loc()` names the position each retained value came from, which - # is the subscript re-indexing the record takes. Without this the restore - # behind vctrs' own method sees only a shorter vector and drops the record. - loc <- vec_unique_loc(x) + # The positions `vec_unique_loc()` names are the subscript re-indexing the + # record takes, rows for a matrix and elements otherwise. Without this the + # restore behind vctrs' own method sees only a shorter vector and drops the + # record. + values <- score_values(x) + loc <- vec_unique_loc(values) + out <- subset_score_units(x, loc) meta <- ps_trunc_meta(x) # A retained value stands for every unit holding it, and the record can speak @@ -1882,17 +1887,16 @@ unique.ps_trunc <- function(x, incomparables = FALSE, ...) { # describes, so the record is dropped rather than left to report it as one of # them. if ( - !is.matrix(x) && - record_covers(meta, length(x)) && + record_covers(meta, vec_size(values)) && !merged_units_agree( - vec_data(x), - seq_along(x) %in% meta$truncated_idx + values, + seq_len(vec_size(values)) %in% meta$truncated_idx ) ) { - return(new_ps_trunc(vec_data(x)[loc], drop_trunc_record(meta))) + attr(out, "ps_trunc_meta") <- drop_trunc_record(meta) } - x[loc] + out } #' @export diff --git a/R/utils.R b/R/utils.R index b9e8498d..747435fe 100644 --- a/R/utils.R +++ b/R/utils.R @@ -260,6 +260,30 @@ record_covers <- function(meta, n) { !is.null(meta$n_obs) && meta$n_obs == n } +# The scores a modified propensity score holds, one unit per element or, for a +# matrix, one unit per row. vctrs compares a bare matrix row by row, which is +# what `unique()` of a matrix of scores merges. +score_values <- function(x) { + if (is.matrix(x)) { + out <- unclass(x)[,, drop = FALSE] + dimnames(out) <- NULL + out + } else { + vctrs::vec_data(x) + } +} + +# The units at `loc`, taken through the class's own subsetting so the result +# keeps its class and a record re-indexed onto them. A matrix is subset by row; +# a single subscript would index it as one long vector. +subset_score_units <- function(x, loc) { + if (is.matrix(x)) { + x[loc, , drop = FALSE] + } else { + x[loc] + } +} + # Whether every set of units `unique()` merges into one element shares a single # status. `vec_group_id()` groups values the way `vec_unique_loc()` keeps them, # missing values included, so each group is one element of the result. diff --git a/man/ps_trim.Rd b/man/ps_trim.Rd index 02e79bdc..4cb81a9b 100644 --- a/man/ps_trim.Rd +++ b/man/ps_trim.Rd @@ -336,11 +336,14 @@ slices off to print, so a warning would mostly describe something that is not the result. The values, the class, and the method and its cutoffs are untouched. -\code{\link[=unique]{unique()}} keeps one element for each distinct value, and that element -stands for every unit holding the value. The record is re-indexed onto the -result when all of those units share one status, and dropped otherwise: a -trimmed score and one that arrived missing are both \code{NA}, so a vector holding -both returns a single \code{NA} that neither status describes. +\code{\link[=unique]{unique()}} keeps one element for each distinct value, or one row for each +distinct row of a matrix of scores, and that element or row stands for every +unit holding the same scores. A matrix comes back as a matrix of the same +class with its column names. The record is re-indexed onto the result when +all of the merged units share one status, and dropped otherwise: a trimmed +score and one that arrived missing are both \code{NA}, and a trimmed row is \code{NA} +throughout, so a vector or matrix holding both returns a single \code{NA} element +or row that neither status describes. A record can also outlive the observations it describes, because it travels by routes vctrs does not see: growing a \code{ps_trim} by subassignment carries it diff --git a/man/ps_trunc.Rd b/man/ps_trunc.Rd index a4853aa9..9e2ff2fd 100644 --- a/man/ps_trunc.Rd +++ b/man/ps_trunc.Rd @@ -266,11 +266,13 @@ build vectors the caller never holds, such as the pieces a grouped verb slices a column into. The values, the class, and the method and its bounds are untouched. -\code{\link[=unique]{unique()}} keeps one element for each distinct value, and that element -stands for every unit holding the value. The record is re-indexed onto the -result when all of those units share one status, and dropped otherwise: a -score that arrived at a bound and one moved onto it merge into a single -element that neither status describes. +\code{\link[=unique]{unique()}} keeps one element for each distinct value, or one row for each +distinct row of a matrix of scores, and that element or row stands for every +unit holding the same scores. A matrix comes back as a matrix of the same +class with its column names. The record is re-indexed onto the result when +all of the merged units share one status, and dropped otherwise: a score or +row that arrived where truncation would put it and one truncation moved +there merge into a single element or row that neither status describes. A record can also outlive the observations it describes, because it travels by routes vctrs does not see: growing a \code{ps_trunc} by subassignment carries From 499e451093c08bf55b24392251bc21cd437e5497 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 09:20:54 -0400 Subject: [PATCH 43/64] document wt_trunc(), density-scale trimming, and when to use each --- NEWS.md | 280 ++++++++++---------- R/density.R | 4 +- R/ps_trim.R | 108 ++++++-- R/ps_trunc.R | 17 +- R/psw.R | 7 + R/wt_trunc.R | 52 ++++ inst/WORDLIST | 4 + man/ps_trim.Rd | 104 ++++++-- man/ps_trunc.Rd | 17 +- man/psw.Rd | 7 + man/wt_trunc.Rd | 53 ++++ tests/testthat/_snaps/ps_trim-density.md | 2 +- tests/testthat/_snaps/ps_trim.md | 4 +- tests/testthat/_snaps/weights-continuous.md | 4 +- vignettes/propensity.Rmd | 67 ++++- 15 files changed, 537 insertions(+), 193 deletions(-) diff --git a/NEWS.md b/NEWS.md index e297be67..38403a5c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,55 +1,95 @@ # propensity 0.1.0.9000 (development version) -* `unique()` of a `ps_trim` or `ps_trunc` matrix of categorical propensity - scores now keeps one row for each distinct row and returns a matrix of the - same class, with its column names and a trimming or truncation record - re-indexed onto the kept rows. It previously indexed the matrix as one long - vector and returned a plain numeric vector taken from the first column. As - for a vector, the record is dropped when merged rows differ in status, such - as a trimmed row and a row that arrived missing. +* New `wt_trunc()` bounds extreme weights on the scale of the weights + themselves, so it applies to weights for any exposure type, including the + density-ratio weights of a continuous exposure. It offers four methods: + `"adaptive"` (the default), an upper bound of `sqrt(n) * log(n) / 5` after + Gruber et al. (2022), where `n` counts the weights present; `"wt"`, bounds + given as weight values; `"pctl"`, bounds read at sample quantiles; and + `"count"`, which bounds a given number of the most extreme weights at the + next one in. Each bounds only the upper tail unless `lower` is supplied. The + result keeps every attribute of the weights, gains the estimand label + `"; weights truncated"`, and records the method, the bounds as given and as + applied, and the weights moved, which the printed weights report. The new + `is_wt_truncated()` and `is_unit_wt_truncated()` read that record, apart + from `is_ps_truncated()` and `is_unit_truncated()`, which describe a + truncated propensity score. Weights truncated at different bounds do not + combine. Weights built from a trimmed, truncated, or calibrated score can be + truncated too, and carry both records. The documentation of `wt_trunc()` + and `ps_trim()` compares bounding a dose's weights with trimming its dose + model, using the results of a simulation study, and says when to use each. -* A `ps_trim` or `ps_trunc` vector now drops the positions in its record - without a warning whenever an operation through vctrs changes its length, as - a `psw` already did. A grouped `dplyr::mutate()` or `dplyr::summarise()` - that read such a column, and printing one in a tibble, previously warned - about the pieces built along the way even when the result kept its record. - `is_unit_trimmed()`, `is_unit_truncated()`, and `ps_refit()` still refuse a - result whose record was dropped, with an error of class - `propensity_missing_meta_error`. +* New `wt_trunc_sensitivity()` truncates weights with `wt_trunc()` at each + bound in a grid and returns a tibble of the bounds as given and as applied, + the number of weights moved, and the range, range ratio, and mean of the + result, after a first row that describes the untruncated weights. The + default is a percentile grid at 0.99, 0.975, 0.95, and 0.90. -* `unique()` of a `ps_trim` or `ps_trunc` now drops the positions in its - record when it merges units whose status differs, such as a trimmed score and - one that arrived missing, or a score already at a truncation bound and one - moved onto it. It previously returned a record that left the merged units - out, so `is_unit_trimmed()` reported a trimmed `NA` as retained. When every - merged unit shares one status the record is re-indexed onto the result as - before. +* `ps_trim()` now trims a model of a continuous exposure on the scale of its + conditional density. An `lm`, a `glm` whose variance is constant, a + `MASS::rlm()`, or an `mgcv::gam()` of the dose can be trimmed with + `method = "density"`, which sets aside the units whose conditional density at + their observed dose falls below a quantile floor (`lower`, default 0.01), or + with `method = "resid"`, which sets aside the units more than `upper` spreads + from their predicted dose. The new `.density` and `.sigma` arguments choose + the density family and the spread, which is otherwise the one the family + estimates from the residuals, as in `wt_ate()`. The trim record keeps the + realized floor, the spread, how the spread was found, and the family, and + trims that differ in any of them do not combine. A dose model asked for any + other method, including the default `"ps"`, a model of a probability asked + for either density method, and a level argument on a dose model are refused + with informative errors. `ps_refit()` refits a trimmed dose model's + conditional mean on the retained rows and re-estimates its spread there + under the recorded family, keeping a spread the caller supplied. `wt_ate()` + and `wt_cens()` build weights from the trim under the family and spread its + record holds, refuse a `.density` that disagrees with the record or any + `.sigma`, and label the result as trimmed. -* Weights built from a calibrated propensity score now keep their calibration - record (`ps_calib_meta`) through subsetting, `rep()`, and combining, as a - `ps_calib` vector already did. The record names the calibration method and - whether it was smoothed rather than any unit, but it was dropped along with - the positional trimming and truncation records whenever the length changed, - while the weights stayed marked as calibrated. Combining weights whose - calibration records disagree drops the record with a warning of class - `propensity_metadata_conflict_warning`, and a record only one input carries - is kept. +* `ps_trunc()` gains `method = "adaptive"` for binary propensity scores. It + bounds the scores at `[1/c, 1 - 1/c]` with `c = sqrt(n) * log(n) / 5`, the + bound `wt_trunc(method = "adaptive")` places on the weights, where `n` counts + the scores present. For unstabilized ATE weights the two agree on every + weight above `c / (c - 1)`. `lower` and `upper` are ignored with a warning, + fewer than 15 scores are refused with an error of class + `propensity_range_error`, a two-level `nnet::multinom()` fit is read as a + binary score, and a categorical score matrix or a multinomial fit of three + or more levels is refused with an error of class `propensity_method_error`. -* A `ps_trim` or `ps_trunc` vector restored against a zero-length prototype - now drops the positions in its record, keeping its class and the description - of the trimming or truncation. Combining reordered pieces with - `vctrs::list_unchop(ptype = )` or `vctrs::vec_c(.ptype = )` previously kept a - record naming the wrong units; `is_unit_trimmed()`, `is_unit_truncated()`, - and `ps_refit()` now refuse such a result with an error of class - `propensity_missing_meta_error`. `vctrs::vec_c()` and `vctrs::list_unchop()` - of a single vector drop the positions as well, while `c()` of a single - vector returns it unchanged. +* `ipw()` refuses weights bounded with `wt_trunc()` on every exposure route, + with the dedicated error class `propensity_ipw_wt_truncated_error`. The + message names the two supported alternatives: rebuild the weights without + the truncation and report the M-estimation interval, or report a + fixed-weight sandwich that conditions on the bound. Weights from a trimmed + dose model are refused as other trimmed weights are. + +* Breaking change: weights for a continuous exposure can no longer be built + from a trimmed, truncated, or calibrated score. A conditional mean whose + values happened to fall in (0, 1) could be passed through `ps_trim()`, + `ps_trunc()`, or `ps_calibrate()` as if it were a propensity score and then + weighted with `wt_ate()` or `wt_cens()`, which selected or moved units by + their predicted dose and said nothing about positivity. Those six weight + methods now refuse an exposure they resolve as continuous, including one + resolved from `exposure_type = "auto"`, with an error of class + `propensity_modified_continuous_error`. A model of a conditional mean, a + least squares fit or a `glm` of any family but the binomial ones, is refused + by `ps_trunc()` and by `ps_refit()` on trimmed scores with an error of class + `propensity_model_family_error`, where `ps_refit()` previously refit + whatever model it was handed. `ps_trim()` refuses `method = "density"` and + `method = "resid"` for a vector of values with an error of class + `propensity_method_error`, since a vector carries neither the residuals nor + the family a density is read from. Each refusal names the two routes for a + dose, both described above: trim the dose model with + `ps_trim(method = "density")`, or build its weights with `wt_ate()` and + bound them with `wt_trunc()`. -* `c()` of a single `psw` now returns it unchanged, keeping its trimming, - truncation, and weight truncation records, as `c()` already - did for a single `ps_trim` or `ps_trunc` vector. Every other combine, - including `vctrs::vec_c()` and `vctrs::list_unchop()` of a single `psw`, - still drops those records. + A data frame of scores now behaves as the vector it holds does. A trimmed, + truncated, or calibrated column in a data frame passed to any `wt_*()` + function reached the weights as plain scores, so for a binary exposure its + trimming, truncation, or calibration record was silently dropped, along with + the warning that a trimmed score was not refit. The column now keeps its + record for a binary exposure, and is refused for a continuous exposure as + the vector is. On the modified-score methods, an `exposure_type` naming + several types is reported as a malformed argument whatever the exposure. * Breaking change: `ps_trunc(method = "ps")` now mirrors a bound supplied alone. `lower` alone bounds a binary score at `[lower, 1 - lower]`, and @@ -61,10 +101,15 @@ Each supplied bound must be a single number strictly between 0 and 1; one outside that interval is refused with an error of class `propensity_range_error`, and one of any other length with an error of class - `propensity_length_error`. - The default threshold for a categorical score matrix rises from 0.01 to 0.1, - matching the binary default and `ps_trim()`, so a matrix of ten or more - columns now needs an explicit `lower`. + `propensity_length_error`. The default threshold for a categorical score + matrix rises from 0.01 to 0.1, matching the binary default and `ps_trim()`, + so a matrix of ten or more columns now needs an explicit `lower`. + +* The marginal numerator of a `dens_kernel()` density is now fit only on the + units that have a conditional mean. A unit whose fitted mean was missing but + whose dose was present already took no part in the numerator's center and + spread and got no weight, yet its standardized dose still entered the kernel + fit, which changed the weights of every other unit. * `ps_refit()` now refits a binary score trimmed from a two-level `nnet::multinom()` fit. It previously failed with an error from @@ -93,102 +138,57 @@ `ps_refit()` reads, and combining an inverted trim with one that is not inverted falls back to numeric with a warning. -* New `wt_trunc()` bounds extreme weights on the scale of the weights - themselves, so it applies to weights for any exposure type, including the - density-ratio weights of a continuous exposure. It offers four methods: - `"adaptive"` (the default), an upper bound of `sqrt(n) * log(n) / 5` after - Gruber et al. (2022); `"wt"`, bounds given as weight values; `"pctl"`, bounds - read at sample quantiles; and `"count"`, which bounds a given number of the - most extreme weights at the next one in. Each bounds only the upper tail - unless `lower` is supplied. The result keeps every attribute of the weights, - gains the estimand label `"; weights truncated"`, and records the method, - the bounds as given and as applied, and the weights moved, which the printed - weights report. The new `is_wt_truncated()` and `is_unit_wt_truncated()` - read that record, apart from `is_ps_truncated()` and `is_unit_truncated()`, - which describe a truncated propensity score. Weights truncated at different - bounds do not combine. - -* New `wt_trunc_sensitivity()` truncates weights with `wt_trunc()` at each - bound in a grid and returns a tibble of the bounds as given and as applied, - the number of weights moved, and the range, range ratio, and mean of the - result, after a first row that describes the untruncated weights. The - default is a percentile grid at 0.99, 0.975, 0.95, and 0.90. - -* `ps_trunc()` gains `method = "adaptive"` for binary propensity scores. It - bounds the scores at `[1/c, 1 - 1/c]` with `c = sqrt(n) * log(n) / 5`, the - bound `wt_trunc(method = "adaptive")` places on the weights, where `n` counts - the scores present. For unstabilized ATE weights the two agree on every - weight above `c / (c - 1)`. `lower` and `upper` are ignored with a warning, - fewer than 15 scores are refused with an error of class - `propensity_range_error`, and a categorical score matrix or a multinomial - fit of three or more levels is refused with an error of class - `propensity_method_error`. +* A `ps_trim` or `ps_trunc` vector now drops the positions in its record + without a warning whenever an operation through vctrs changes its length, as + a `psw` already did. A grouped `dplyr::mutate()` or `dplyr::summarise()` + that read such a column, and printing one in a tibble, previously warned + about the pieces built along the way even when the result kept its record. + `is_unit_trimmed()`, `is_unit_truncated()`, and `ps_refit()` still refuse a + result whose record was dropped, with an error of class + `propensity_missing_meta_error`. -* `ipw()` refuses weights bounded with `wt_trunc()` on every exposure route, - with the dedicated error class `propensity_ipw_wt_truncated_error`. The - message names the two supported alternatives: rebuild the weights without - the truncation and report the M-estimation interval, or report a - fixed-weight sandwich that conditions on the bound. +* Combining drops the positions in a record even when it is handed a single + vector, unless the combine is base `c()`. `c()` of a single `ps_trim`, + `ps_trunc`, or `psw` returns it unchanged, keeping its trimming, truncation, + and weight truncation records; `c()` of a single `psw` previously dropped + them. `vctrs::vec_c(x)`, `vctrs::list_unchop()`, `dplyr::bind_rows(df)`, + `vctrs::vec_rbind(df)`, and an ungrouped `dplyr::reframe()` of a single such + column drop the positions, so a later `ps_refit()`, `is_unit_trimmed()`, + `is_unit_truncated()`, or `is_unit_wt_truncated()` refuses the result. -* `ps_trim()` now trims a model of a continuous exposure on the scale of its - conditional density. A `lm`, a `glm` whose variance is constant, a - `MASS::rlm()`, or an `mgcv::gam()` of the dose can be trimmed with - `method = "density"`, which sets aside the units whose conditional density at - their observed dose falls below a quantile floor (`lower`, default 0.01), or - with `method = "resid"`, which sets aside the units more than `upper` spreads - from their predicted dose. The new `.density` and `.sigma` arguments choose - the density family and the spread, which is otherwise the one the family - estimates from the residuals, as in `wt_ate()`. The trim record keeps the - realized floor, the spread, how the spread was found, and the family, and - trims that differ in any of them do not combine. A dose model asked for any - other method, a model of a probability asked for either density method, and a - level argument on a dose model are refused with informative errors. - `ps_refit()` refits a trimmed dose model's conditional mean on the retained - rows and re-estimates its spread there under the recorded family, keeping a - spread the caller supplied. `wt_ate()` and `wt_cens()` build weights from the - trim under the family and spread its record holds, refuse a `.density` that - disagrees with the record or any `.sigma`, and label the result as trimmed; - `ipw()` refuses those weights as it refuses other trimmed weights. +* A `ps_trim` or `ps_trunc` vector restored against a zero-length prototype + now drops the positions in its record, keeping its class and the description + of the trimming or truncation. Combining reordered pieces with + `vctrs::list_unchop(ptype = )` or `vctrs::vec_c(.ptype = )` previously kept a + record naming the wrong units; `is_unit_trimmed()`, `is_unit_truncated()`, + and `ps_refit()` now refuse such a result with an error of class + `propensity_missing_meta_error`. -* The marginal numerator of a `dens_kernel()` density is now fit only on the - units that have a conditional mean. A unit whose fitted mean was missing but - whose dose was present already took no part in the numerator's center and - spread and got no weight, yet its standardized dose still entered the kernel - fit, which changed the weights of every other unit. +* `unique()` of a `ps_trim` or `ps_trunc` now drops the positions in its + record when it merges units whose status differs, such as a trimmed score and + one that arrived missing, or a score already at a truncation bound and one + moved onto it. It previously returned a record that left the merged units + out, so `is_unit_trimmed()` reported a trimmed `NA` as retained. When every + merged unit shares one status the record is re-indexed onto the result as + before. -* Weights for a continuous exposure can no longer be built from a trimmed, - truncated, or calibrated score. A conditional mean whose values happened to - fall in (0, 1) could be passed through `ps_trim()`, `ps_trunc()`, or - `ps_calibrate()` as if it were a propensity score and then weighted with - `wt_ate()` or `wt_cens()`, which selected or moved units by their predicted - dose and said nothing about positivity. Those six methods now refuse an - exposure they resolve as continuous, including one resolved from - `exposure_type = "auto"`, with an error of class - `propensity_modified_continuous_error`. A model of a conditional mean, a - least squares fit or a `glm` of any family but the binomial ones, is refused - by `ps_trunc()` and by `ps_refit()` on trimmed scores with an error of class - `propensity_model_family_error`, where `ps_refit()` previously refit - whatever model it was handed. `ps_trim()` reserves `method = "density"` and - `method = "resid"` for trimming a dose model on the scale of its conditional - density, and refuses both for a vector of values with an error of class - `propensity_method_error`, since a vector carries neither the residuals nor - the family a density is read from. Each refusal names the - routes for a dose: trimming the dose model with - `ps_trim(method = "density")`, or building its weights with `wt_ate()` and - bounding the weights with `wt_trunc()`. The first is described above; - `wt_trunc()` is not yet available, so until it is, a dose's weights that - should keep every unit are built from the dose model or its fitted means - directly. +* `unique()` of a `ps_trim` or `ps_trunc` matrix of categorical propensity + scores now keeps one row for each distinct row and returns a matrix of the + same class, with its column names and a trimming or truncation record + re-indexed onto the kept rows. It previously indexed the matrix as one long + vector and returned a plain numeric vector taken from the first column. As + for a vector, the record is dropped when merged rows differ in status, such + as a trimmed row and a row that arrived missing. - A data frame of scores now behaves as the vector it holds does. A trimmed, - truncated, or calibrated column in a data frame passed to any `wt_*()` - function reached the weights as plain scores, so for a binary exposure its - trimming, truncation, or calibration record was silently dropped, along with - the warning that a trimmed score was not refit. The column now keeps its - record for a binary exposure, and is refused for a continuous exposure as - the vector is. A malformed `exposure_type` naming several types is now - reported as a malformed argument on the modified-score methods, rather than - read as unset and refused as a continuous exposure. +* Weights built from a calibrated propensity score now keep their calibration + record (`ps_calib_meta`) through subsetting, `rep()`, and combining, as a + `ps_calib` vector already did. The record names the calibration method and + whether it was smoothed rather than any unit, but it was dropped along with + the positional trimming and truncation records whenever the length changed, + while the weights stayed marked as calibrated. Combining weights whose + calibration records disagree drops the record with a warning of class + `propensity_metadata_conflict_warning`, and a record only one input carries + is kept. * `dens_t()` now estimates the scale of the t under the t itself by default, as `dens_laplace()` estimates the scale of the Laplace. Both densities of a diff --git a/R/density.R b/R/density.R index eb642356..11f9f98e 100644 --- a/R/density.R +++ b/R/density.R @@ -856,7 +856,7 @@ t_sigma_mle <- function(residuals, df, call = rlang::caller_env()) { c( "The scale of a {.val t} density cannot be estimated by maximum likelihood from these residuals.", - x = "{n_zero} of the {n} residuals of the propensity score model + x = "{n_zero} of the {n} residuals of the model of the exposure {?is/are} exactly zero, and with {df} degrees of freedom that leaves the likelihood no maximum at a positive scale.", i = "Use {.code sigma_method = \"rms\"}, or supply a spread with @@ -902,7 +902,7 @@ check_sigma_method <- function(.sigma, density, call = rlang::caller_env()) { "{.code sigma_method = \"mle\"} cannot be used with {.arg .sigma}.", x = "{.code sigma_method = \"mle\"} estimates the scale of the {.val {family}} conditional density from the residuals of the - propensity score model, and {.arg .sigma} is a spread of your own + model of the exposure, and {.arg .sigma} is a spread of your own that replaces it.", i = "A {.val {family}} density is spread by its own estimator unless you ask for another, so {.code sigma_method = \"mle\"} is what it diff --git a/R/ps_trim.R b/R/ps_trim.R index 70b43952..a53bf4d3 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -10,7 +10,7 @@ #' @param .propensity A numeric vector of propensity scores in (0, 1) for binary #' exposures, a matrix / data frame where each column gives the propensity #' score for one level of a categorical exposure, or a fitted model (see -#' **Fitted models** and **Dose models** in Details). A data frame trimmed +#' **Fitted models** and **Trimming a dose model** in Details). A data frame trimmed #' for a binary exposure is reduced to a single column: the second column of #' a two column data frame, which is the probability of the second level in #' the layout model predictions come in, and the first column otherwise. The @@ -33,7 +33,10 @@ #' threshold delta) are trimmed. #' * **`"adaptive"`**: Data-driven threshold that minimizes the asymptotic #' variance of the IPW estimator (Crump et al., 2009). The `lower` and -#' `upper` arguments are ignored. +#' `upper` arguments are ignored. The threshold adapts to the estimated +#' scores, tightening under poor overlap, and the estimand becomes the +#' population it keeps. `ps_trunc(method = "adaptive")` instead adapts to +#' the sample size alone and keeps every unit. #' * **`"pctl"`**: Quantile-based. Observations outside the `[lower, upper]` #' quantiles of the propensity score distribution are trimmed. Defaults: #' `lower = 0.05`, `upper = 0.95`. @@ -63,7 +66,7 @@ #' #' `"density"` and `"resid"` need the residuals and the family of the model #' that fit the exposure's conditional mean, so they accept only a dose model -#' (see **Dose models** in Details). They refuse a vector or matrix of values, +#' (see **Trimming a dose model** in Details). They refuse a vector or matrix of values, #' a binomial or quasibinomial `glm`, and a `multinom` with an error of class #' `propensity_method_error`. A dose model accepts only these two methods, and #' refuses every other one, including the default `"ps"` when `method` is not @@ -155,6 +158,12 @@ #' data-driven method available for categorical treatments. #' * Use `"density"` or `"resid"` for a continuous exposure, on its dose model. #' +#' For a binary or categorical exposure, trimming and refitting is the first +#' recourse when the analysis can accept a change of estimand. When every unit +#' must be kept, bound the scores with [ps_trunc()] instead, for a binary +#' exposure with `method = "adaptive"`, or bound the weights with +#' [wt_trunc()]. +#' #' ## Typical workflow #' #' 1. Fit a propensity score model @@ -179,7 +188,7 @@ #' whose levels are ordered differently is still trimmed against the right #' column. #' -#' ## Dose models +#' ## Trimming a dose model #' #' For a continuous exposure, `.propensity` can be the model of the exposure's #' conditional mean: a [stats::lm()], a `glm` of the `gaussian()` family (or @@ -188,21 +197,68 @@ #' changes with its mean, such as `poisson()`, is refused with an error of #' class `propensity_model_family_error`. Only `"density"` and `"resid"` apply. #' -#' Both read the fitted conditional mean `mu`, the spread `sigma` of the -#' residuals under the family in `.density`, the standardized residual -#' `z = (a - mu) / sigma`, and the conditional density `f = g(z) / sigma`, -#' where `g` is the family's standardized density. `"density"` keeps the units -#' whose `f` is at least its `lower` quantile. `"resid"` keeps those whose -#' `|z|` is at most `upper`; for the symmetric unimodal families it accepts, -#' that is the floor `g(upper) / sigma` on `f`, which is the threshold it -#' records. +#' For a dose, the generalized propensity score is the conditional density +#' \eqn{f(a \mid x)} (Hirano and Imbens, 2004), and a unit whose observed dose +#' has a small conditional density gets a large weight, as a unit with a +#' propensity score near 0 does for a binary exposure. Both methods read the +#' fitted conditional mean `mu`, the spread `sigma` of the residuals under the +#' family in `.density`, the standardized residual `z = (a - mu) / sigma`, and +#' the conditional density `f = g(z) / sigma`, where `g` is the family's +#' standardized density. `"density"` keeps the units whose `f` is at least its +#' `lower` quantile. `"resid"` keeps those whose `|z|` is at most `upper`; for +#' the symmetric unimodal families it accepts, that is the floor +#' `g(upper) / sigma` on `f`, which is the threshold it records. The trim is +#' one-sided, at the low end of the density, since only a small density makes +#' a large weight (Branson et al., 2024). #' #' The retained values are the conditional means, and the trimmed ones are -#' `NA`. A unit with a missing mean or dose takes no part in the trim. The -#' population a trimmed analysis describes is the units whose observed dose -#' was plausible under the model, not the full sample. `.focal_level`, -#' `.reference_level`, and their deprecated forms are refused with an error of -#' class `propensity_focal_level_error`, since a dose has no levels. +#' `NA`. A unit with a missing mean or dose takes no part in the trim. +#' `.focal_level`, `.reference_level`, and their deprecated forms are refused +#' with an error of class `propensity_focal_level_error`, since a dose has no +#' levels. +#' +#' A trim changes the estimand. The analysis describes the units whose +#' observed dose was plausible under the model, not the full sample, and which +#' units those are depends on the threshold. Branson et al. (2024) define the +#' trimmed dose response at each dose among the units whose conditional +#' density at that dose exceeds the threshold, a population that changes with +#' the dose; this trim is its sample analogue at each unit's own observed dose +#' rather than the same population. A dose-response curve fit to the trimmed +#' sample is a curve for the units it keeps. +#' +#' After trimming, [ps_refit()] refits the conditional mean on the retained +#' rows and re-estimates the spread there under the recorded family, and +#' [wt_ate()] builds the weights from the refit under the family and spread +#' the record holds. [ipw()] refuses those weights, as it refuses every +#' weight built from a trimmed score. +#' +#' The other way to hold down extreme weights for a dose is [wt_trunc()], +#' which bounds the weights and keeps every unit; see **Truncating weights or +#' trimming the density** there for the simulation results behind this +#' summary. With a density family that fits the residuals, a density trim at +#' `lower = 0.01` did not help: at an effective sample size of 64% of the +#' sample, its interval covered 0.843, against 0.933 for the untrimmed +#' weights under the same fixed-weight interval. A loose bound on the weights +#' left that coverage where it was and lowered the root mean squared error. +#' With heavy-tailed residuals read through a normal density, or a residual +#' spread the model left out, the trim covered 0.979 to 0.989, against 0.618 +#' to 0.881 for the untrimmed weights and 0.644 to 0.906 for the bound, +#' because it removed the units the misspecified density fit worst. Two +#' cautions go with those numbers. The trim's intervals were computed on the +#' trimmed sample, held the weights fixed, and were conservative, and its bias +#' was measured against the effect in the full population, so part of that +#' bias is the change of estimand. `"resid"` was not simulated; the results +#' carry over to it only because a bound on the standardized residual is a +#' floor on the conditional density. +#' +#' A family that fits the residuals is the better repair where it applies. +#' Under heavy tails, [dens_t()] with 4 degrees of freedom at its default +#' scale had about a third of the root mean squared error of the bounded +#' normal weights and an M-estimation interval that covered 0.926 to 0.939 +#' with standard errors close to right, and it kept every unit. The trim's +#' coverage was higher, but its interval was conservative. Check the family +#' first; trim when the units at the low-density end are ones the analysis +#' should not describe, and say so when reporting the estimand. #' #' ## Object behavior #' @@ -268,6 +324,12 @@ #' the result. The values, the class, and the method and its cutoffs are #' untouched. #' +#' A combine drops the positions even when it is handed a single vector. `c()` +#' of one `ps_trim` returns it unchanged, record included, but +#' `vctrs::vec_c(x)`, `dplyr::bind_rows(df)`, `vctrs::vec_rbind(df)`, and an +#' ungrouped `dplyr::reframe()` rebuild the column, so a later [ps_refit()] or +#' [is_unit_trimmed()] on the result refuses it. +#' #' [unique()] keeps one element for each distinct value, or one row for each #' distinct row of a matrix of scores, and that element or row stands for every #' unit holding the same scores. A matrix comes back as a matrix of the same @@ -325,10 +387,18 @@ #' density specification), `keep_idx`, `trimmed_idx`, and `n_obs`. #' #' @references +#' Branson, Z., Kennedy, E. H., Balakrishnan, S., & Wasserman, L. (2024). +#' Causal effect estimation after propensity score trimming with continuous +#' treatments. *arXiv preprint* arXiv:2309.00706. +#' #' Crump, R. K., Hotz, V. J., Imbens, G. W., & Mitnik, O. A. (2009). Dealing #' with limited overlap in estimation of average treatment effects. #' *Biometrika*, 96(1), 187--199. #' +#' Hirano, K., & Imbens, G. W. (2004). The propensity score with continuous +#' treatments. In *Applied Bayesian Modeling and Causal Inference from +#' Incomplete-Data Perspectives* (pp. 73--84). +#' #' Walker, A. M., Patrick, A. R., Lauer, M. S., et al. (2013). A tool for #' assessing the feasibility of comparative effectiveness research. #' *Comparative Effectiveness Research*, 3, 11--20. @@ -501,8 +571,8 @@ ps_trim.default <- function( x = "It reads the conditional density of a continuous exposure, which needs the residuals and the family of the model that fit its conditional mean, and {.arg .propensity} carries neither.", - i = "Supply the fitted model of the exposure itself as - {.arg .propensity}." + i = "Supply the model of the exposure's conditional mean, such as an + {.fun lm} fit, as {.arg .propensity}." ), error_class = "propensity_method_error", call = call diff --git a/R/ps_trunc.R b/R/ps_trunc.R index 74dc19fc..b99f499e 100644 --- a/R/ps_trunc.R +++ b/R/ps_trunc.R @@ -151,7 +151,8 @@ #' `propensity_range_error` otherwise. It is refused for categorical exposures #' with an error of class `propensity_method_error`: truncating a categorical #' score renormalizes each row, which moves scores the bound never reached, so -#' the bound no longer caps the weights. +#' the bound no longer caps the weights. A two-level `nnet::multinom()` fit is +#' read as one binary score and accepted. #' #' **Arithmetic behavior**: Arithmetic operations on `ps_trunc` objects return #' plain numeric vectors. Once propensity scores are transformed (e.g., into @@ -171,7 +172,13 @@ #' bounding those values would. A model of a continuous exposure's conditional #' mean, such as a [stats::lm()] fit or a gaussian [stats::glm()], has no #' propensity score to bound and raises an error of class -#' `propensity_model_family_error`. +#' `propensity_model_family_error`. A dose has two routes instead: trim the +#' dose model with `ps_trim(method = "density")`, which sets aside the units +#' whose dose is implausible under the model, or build the weights with +#' [wt_ate()] and bound them with [wt_trunc()], which keeps every unit. There +#' is no density method here: a floor on a dose's conditional density is a +#' bound on its unstabilized weights, the ones `wt_ate(stabilize = FALSE)` +#' builds, which [wt_trunc()] already applies. #' #' The methods that read an exposure (`"cr"`, and every method on the #' categorical route) take it from the model when `.exposure` is not supplied, @@ -223,6 +230,12 @@ #' slices a column into. The values, the class, and the method and its bounds #' are untouched. #' +#' A combine drops the positions even when it is handed a single vector. `c()` +#' of one `ps_trunc` returns it unchanged, record included, but +#' `vctrs::vec_c(x)`, `dplyr::bind_rows(df)`, `vctrs::vec_rbind(df)`, and an +#' ungrouped `dplyr::reframe()` rebuild the column, so a later +#' [is_unit_truncated()] on the result refuses it. +#' #' [unique()] keeps one element for each distinct value, or one row for each #' distinct row of a matrix of scores, and that element or row stands for every #' unit holding the same scores. A matrix comes back as a matrix of the same diff --git a/R/psw.R b/R/psw.R index 66684828..66b28465 100644 --- a/R/psw.R +++ b/R/psw.R @@ -117,6 +117,13 @@ #' agreement rule above: two calibration records agree when they name the same #' method and smoothing. #' +#' `c()` of a single `psw` returns it unchanged, with every record. A combine +#' through vctrs drops the positional records even when it is handed a single +#' input: `vctrs::vec_c(x)`, `dplyr::bind_rows(df)`, `vctrs::vec_rbind(df)`, +#' and an ungrouped `dplyr::reframe()` all rebuild the column, so a later +#' [is_unit_trimmed()], [is_unit_truncated()], or [is_unit_wt_truncated()] on +#' the result refuses it. +#' #' Subsetting with `[` preserves class and attributes for vector subscripts. #' Two kinds of attribute hold one value per observation and so cannot be #' re-indexed for a subset: a `stabilization_score` with more than one value, diff --git a/R/wt_trunc.R b/R/wt_trunc.R index 1b7d8305..b927cee2 100644 --- a/R/wt_trunc.R +++ b/R/wt_trunc.R @@ -117,6 +117,58 @@ #' weights before and after it to a data frame as separate columns and pass #' both to `halfmoon::check_ess()`. #' +#' ## Truncating weights or trimming the density +#' +#' For a continuous exposure there are two ways to hold down extreme weights. +#' `wt_trunc()` bounds the weights once they are built and keeps every unit. +#' [ps_trim()] with `method = "density"` or `method = "resid"` sets aside the +#' units whose observed dose is implausible under the dose model, and +#' [ps_refit()] refits the model on the units that remain; see **Trimming a +#' dose model** in [ps_trim()]. Both change the estimand. A fixed bound +#' introduces a bias that does not vanish however large the sample, while a +#' bound that loosens with the sample, as `"adaptive"` does, leaves the +#' estimand alone in the limit. A trim describes only the units it keeps. +#' `wt_trunc()` applies to weights from any density family, and so does +#' `"density"`; `"resid"` accepts the normal, t, and Laplace families only. +#' [ipw()] refuses the weights from either tool. +#' +#' A simulation study run for this package (samples of 1000, 1000 +#' replications, a correctly specified mean for the dose) found that which +#' tool helps depends on whether the density family fits the residuals. The +#' coverage figures below are for a sandwich interval that holds the weights +#' fixed, unless stated. With normal residuals, a normal density, and an +#' effective sample size of 64% of the sample, the `"adaptive"` bound moved almost no +#' weight and covered 0.933, as the untruncated weights did under the same +#' interval. The M-estimation interval on the untruncated weights covered +#' 0.863, so the gain in coverage there comes from the interval, not the +#' bound. What the bound bought was precision: a root mean squared error of +#' 0.084 against 0.096, for a bias of 0.015 (3% of the effect) against 0.012. +#' At an effective sample size of 53% it covered 0.847 against 0.839 +#' untruncated, and at 81% it changed nothing. A density trim at +#' `lower = 0.01` covered 0.843 at 64%, below the untruncated weights. +#' +#' With t(4) or Laplace residuals, or a residual spread that varied with a +#' covariate, the normal density fit some units badly. The bound then helped +#' little (coverage 0.822, 0.906, and 0.644, against 0.788, 0.881, and 0.618 +#' untruncated), while the 1% density trim covered **0.989**, **0.980**, and +#' **0.979**, because it removed the units that density fit worst. The trim's +#' intervals were computed on the trimmed sample and were conservative, and +#' its bias was measured against the effect in the full population, so part +#' of that bias is the change of estimand. The `"resid"` method was not +#' simulated; these results carry over to it only because a bound on the +#' standardized residual is a floor on the conditional density. +#' +#' Neither tool is the first step. Under the same heavy-tailed residuals, +#' `dens_t(4)` at its default scale covered 0.926 to 0.939 with the +#' M-estimation interval, whose standard errors were close to right, with +#' about a third of the root mean squared error of the bounded normal +#' weights, and kept every unit. So first check the density family against the +#' residuals, for instance by comparing the weights to those of a +#' [dens_kernel()] density or a heavier tail. If the weights are still heavy +#' under a family that fits, bound them with `wt_trunc()`. Trim the dose model +#' when the units at the low-density end are ones the analysis should not +#' describe, and state the population the trimmed analysis describes. +#' #' @return A [psw] vector of the same length as `.weights`, with the bounded #' values, the estimand labeled as truncated, and a record of the truncation. #' diff --git a/inst/WORDLIST b/inst/WORDLIST index 279c338d..9b1f765b 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -3,10 +3,12 @@ ATO ATT ATU BYOM +Balakrishnan Biometrics Biometrika Biostatistics Boca +Branson Brumback CMD CRC @@ -61,6 +63,7 @@ Subassignment Toh Unstabilized Wal +Wasserman WeightIt Winsorize Zadrozny @@ -110,6 +113,7 @@ pctl poisson positionally positivity +preprint ps quasibinomial quasipoisson diff --git a/man/ps_trim.Rd b/man/ps_trim.Rd index 4cb81a9b..79792e89 100644 --- a/man/ps_trim.Rd +++ b/man/ps_trim.Rd @@ -24,7 +24,7 @@ ps_trim( \item{.propensity}{A numeric vector of propensity scores in (0, 1) for binary exposures, a matrix / data frame where each column gives the propensity score for one level of a categorical exposure, or a fitted model (see -\strong{Fitted models} and \strong{Dose models} in Details). A data frame trimmed +\strong{Fitted models} and \strong{Trimming a dose model} in Details). A data frame trimmed for a binary exposure is reduced to a single column: the second column of a two column data frame, which is the probability of the second level in the layout model predictions come in, and the first column otherwise. The @@ -48,7 +48,10 @@ observations where \emph{any} column falls below \code{lower} (the symmetric threshold delta) are trimmed. \item \strong{\code{"adaptive"}}: Data-driven threshold that minimizes the asymptotic variance of the IPW estimator (Crump et al., 2009). The \code{lower} and -\code{upper} arguments are ignored. +\code{upper} arguments are ignored. The threshold adapts to the estimated +scores, tightening under poor overlap, and the estimand becomes the +population it keeps. \code{ps_trunc(method = "adaptive")} instead adapts to +the sample size alone and keeps every unit. \item \strong{\code{"pctl"}}: Quantile-based. Observations outside the \verb{[lower, upper]} quantiles of the propensity score distribution are trimmed. Defaults: \code{lower = 0.05}, \code{upper = 0.95}. @@ -79,7 +82,7 @@ predicted dose are trimmed. \code{upper} has no default. \code{"density"} and \code{"resid"} need the residuals and the family of the model that fit the exposure's conditional mean, so they accept only a dose model -(see \strong{Dose models} in Details). They refuse a vector or matrix of values, +(see \strong{Trimming a dose model} in Details). They refuse a vector or matrix of values, a binomial or quasibinomial \code{glm}, and a \code{multinom} with an error of class \code{propensity_method_error}. A dose model accepts only these two methods, and refuses every other one, including the default \code{"ps"} when \code{method} is not @@ -216,6 +219,12 @@ groups have observed propensity scores. data-driven method available for categorical treatments. \item Use \code{"density"} or \code{"resid"} for a continuous exposure, on its dose model. } + +For a binary or categorical exposure, trimming and refitting is the first +recourse when the analysis can accept a change of estimand. When every unit +must be kept, bound the scores with \code{\link[=ps_trunc]{ps_trunc()}} instead, for a binary +exposure with \code{method = "adaptive"}, or bound the weights with +\code{\link[=wt_trunc]{wt_trunc()}}. } \subsection{Typical workflow}{ @@ -244,7 +253,7 @@ whose levels are ordered differently is still trimmed against the right column. } -\subsection{Dose models}{ +\subsection{Trimming a dose model}{ For a continuous exposure, \code{.propensity} can be the model of the exposure's conditional mean: a \code{\link[stats:lm]{stats::lm()}}, a \code{glm} of the \code{gaussian()} family (or @@ -253,21 +262,68 @@ another family whose variance is constant), a \code{MASS::rlm()}, or an changes with its mean, such as \code{poisson()}, is refused with an error of class \code{propensity_model_family_error}. Only \code{"density"} and \code{"resid"} apply. -Both read the fitted conditional mean \code{mu}, the spread \code{sigma} of the -residuals under the family in \code{.density}, the standardized residual -\code{z = (a - mu) / sigma}, and the conditional density \code{f = g(z) / sigma}, -where \code{g} is the family's standardized density. \code{"density"} keeps the units -whose \code{f} is at least its \code{lower} quantile. \code{"resid"} keeps those whose -\verb{|z|} is at most \code{upper}; for the symmetric unimodal families it accepts, -that is the floor \code{g(upper) / sigma} on \code{f}, which is the threshold it -records. +For a dose, the generalized propensity score is the conditional density +\eqn{f(a \mid x)} (Hirano and Imbens, 2004), and a unit whose observed dose +has a small conditional density gets a large weight, as a unit with a +propensity score near 0 does for a binary exposure. Both methods read the +fitted conditional mean \code{mu}, the spread \code{sigma} of the residuals under the +family in \code{.density}, the standardized residual \code{z = (a - mu) / sigma}, and +the conditional density \code{f = g(z) / sigma}, where \code{g} is the family's +standardized density. \code{"density"} keeps the units whose \code{f} is at least its +\code{lower} quantile. \code{"resid"} keeps those whose \verb{|z|} is at most \code{upper}; for +the symmetric unimodal families it accepts, that is the floor +\code{g(upper) / sigma} on \code{f}, which is the threshold it records. The trim is +one-sided, at the low end of the density, since only a small density makes +a large weight (Branson et al., 2024). The retained values are the conditional means, and the trimmed ones are -\code{NA}. A unit with a missing mean or dose takes no part in the trim. The -population a trimmed analysis describes is the units whose observed dose -was plausible under the model, not the full sample. \code{.focal_level}, -\code{.reference_level}, and their deprecated forms are refused with an error of -class \code{propensity_focal_level_error}, since a dose has no levels. +\code{NA}. A unit with a missing mean or dose takes no part in the trim. +\code{.focal_level}, \code{.reference_level}, and their deprecated forms are refused +with an error of class \code{propensity_focal_level_error}, since a dose has no +levels. + +A trim changes the estimand. The analysis describes the units whose +observed dose was plausible under the model, not the full sample, and which +units those are depends on the threshold. Branson et al. (2024) define the +trimmed dose response at each dose among the units whose conditional +density at that dose exceeds the threshold, a population that changes with +the dose; this trim is its sample analogue at each unit's own observed dose +rather than the same population. A dose-response curve fit to the trimmed +sample is a curve for the units it keeps. + +After trimming, \code{\link[=ps_refit]{ps_refit()}} refits the conditional mean on the retained +rows and re-estimates the spread there under the recorded family, and +\code{\link[=wt_ate]{wt_ate()}} builds the weights from the refit under the family and spread +the record holds. \code{\link[=ipw]{ipw()}} refuses those weights, as it refuses every +weight built from a trimmed score. + +The other way to hold down extreme weights for a dose is \code{\link[=wt_trunc]{wt_trunc()}}, +which bounds the weights and keeps every unit; see \strong{Truncating weights or +trimming the density} there for the simulation results behind this +summary. With a density family that fits the residuals, a density trim at +\code{lower = 0.01} did not help: at an effective sample size of 64\% of the +sample, its interval covered 0.843, against 0.933 for the untrimmed +weights under the same fixed-weight interval. A loose bound on the weights +left that coverage where it was and lowered the root mean squared error. +With heavy-tailed residuals read through a normal density, or a residual +spread the model left out, the trim covered 0.979 to 0.989, against 0.618 +to 0.881 for the untrimmed weights and 0.644 to 0.906 for the bound, +because it removed the units the misspecified density fit worst. Two +cautions go with those numbers. The trim's intervals were computed on the +trimmed sample, held the weights fixed, and were conservative, and its bias +was measured against the effect in the full population, so part of that +bias is the change of estimand. \code{"resid"} was not simulated; the results +carry over to it only because a bound on the standardized residual is a +floor on the conditional density. + +A family that fits the residuals is the better repair where it applies. +Under heavy tails, \code{\link[=dens_t]{dens_t()}} with 4 degrees of freedom at its default +scale had about a third of the root mean squared error of the bounded +normal weights and an M-estimation interval that covered 0.926 to 0.939 +with standard errors close to right, and it kept every unit. The trim's +coverage was higher, but its interval was conservative. Check the family +first; trim when the units at the low-density end are ones the analysis +should not describe, and say so when reporting the estimand. } \subsection{Object behavior}{ @@ -336,6 +392,12 @@ slices off to print, so a warning would mostly describe something that is not the result. The values, the class, and the method and its cutoffs are untouched. +A combine drops the positions even when it is handed a single vector. \code{c()} +of one \code{ps_trim} returns it unchanged, record included, but +\code{vctrs::vec_c(x)}, \code{dplyr::bind_rows(df)}, \code{vctrs::vec_rbind(df)}, and an +ungrouped \code{dplyr::reframe()} rebuild the column, so a later \code{\link[=ps_refit]{ps_refit()}} or +\code{\link[=is_unit_trimmed]{is_unit_trimmed()}} on the result refuses it. + \code{\link[=unique]{unique()}} keeps one element for each distinct value, or one row for each distinct row of a matrix of scores, and that element or row stands for every unit holding the same scores. A matrix comes back as a matrix of the same @@ -413,10 +475,18 @@ if (rlang::is_installed("nnet")) { } \references{ +Branson, Z., Kennedy, E. H., Balakrishnan, S., & Wasserman, L. (2024). +Causal effect estimation after propensity score trimming with continuous +treatments. \emph{arXiv preprint} arXiv:2309.00706. + Crump, R. K., Hotz, V. J., Imbens, G. W., & Mitnik, O. A. (2009). Dealing with limited overlap in estimation of average treatment effects. \emph{Biometrika}, 96(1), 187--199. +Hirano, K., & Imbens, G. W. (2004). The propensity score with continuous +treatments. In \emph{Applied Bayesian Modeling and Causal Inference from +Incomplete-Data Perspectives} (pp. 73--84). + Walker, A. M., Patrick, A. R., Lauer, M. S., et al. (2013). A tool for assessing the feasibility of comparative effectiveness research. \emph{Comparative Effectiveness Research}, 3, 11--20. diff --git a/man/ps_trunc.Rd b/man/ps_trunc.Rd index 9e2ff2fd..9e7ee19f 100644 --- a/man/ps_trunc.Rd +++ b/man/ps_trunc.Rd @@ -192,7 +192,8 @@ The bounds cross when \eqn{c < 2}, which holds for fewer than 15 scores, so \code{propensity_range_error} otherwise. It is refused for categorical exposures with an error of class \code{propensity_method_error}: truncating a categorical score renormalizes each row, which moves scores the bound never reached, so -the bound no longer caps the weights. +the bound no longer caps the weights. A two-level \code{nnet::multinom()} fit is +read as one binary score and accepted. \strong{Arithmetic behavior}: Arithmetic operations on \code{ps_trunc} objects return plain numeric vectors. Once propensity scores are transformed (e.g., into @@ -212,7 +213,13 @@ read as one column per level. Those are the shapes \code{predict(fit, type = "re bounding those values would. A model of a continuous exposure's conditional mean, such as a \code{\link[stats:lm]{stats::lm()}} fit or a gaussian \code{\link[stats:glm]{stats::glm()}}, has no propensity score to bound and raises an error of class -\code{propensity_model_family_error}. +\code{propensity_model_family_error}. A dose has two routes instead: trim the +dose model with \code{ps_trim(method = "density")}, which sets aside the units +whose dose is implausible under the model, or build the weights with +\code{\link[=wt_ate]{wt_ate()}} and bound them with \code{\link[=wt_trunc]{wt_trunc()}}, which keeps every unit. There +is no density method here: a floor on a dose's conditional density is a +bound on its unstabilized weights, the ones \code{wt_ate(stabilize = FALSE)} +builds, which \code{\link[=wt_trunc]{wt_trunc()}} already applies. The methods that read an exposure (\code{"cr"}, and every method on the categorical route) take it from the model when \code{.exposure} is not supplied, @@ -266,6 +273,12 @@ build vectors the caller never holds, such as the pieces a grouped verb slices a column into. The values, the class, and the method and its bounds are untouched. +A combine drops the positions even when it is handed a single vector. \code{c()} +of one \code{ps_trunc} returns it unchanged, record included, but +\code{vctrs::vec_c(x)}, \code{dplyr::bind_rows(df)}, \code{vctrs::vec_rbind(df)}, and an +ungrouped \code{dplyr::reframe()} rebuild the column, so a later +\code{\link[=is_unit_truncated]{is_unit_truncated()}} on the result refuses it. + \code{\link[=unique]{unique()}} keeps one element for each distinct value, or one row for each distinct row of a matrix of scores, and that element or row stands for every unit holding the same scores. A matrix comes back as a matrix of the same diff --git a/man/psw.Rd b/man/psw.Rd index 2421e196..55c9b90d 100644 --- a/man/psw.Rd +++ b/man/psw.Rd @@ -202,6 +202,13 @@ describe the exposure rather than any unit, so all of them carry by the agreement rule above: two calibration records agree when they name the same method and smoothing. +\code{c()} of a single \code{psw} returns it unchanged, with every record. A combine +through vctrs drops the positional records even when it is handed a single +input: \code{vctrs::vec_c(x)}, \code{dplyr::bind_rows(df)}, \code{vctrs::vec_rbind(df)}, +and an ungrouped \code{dplyr::reframe()} all rebuild the column, so a later +\code{\link[=is_unit_trimmed]{is_unit_trimmed()}}, \code{\link[=is_unit_truncated]{is_unit_truncated()}}, or \code{\link[=is_unit_wt_truncated]{is_unit_wt_truncated()}} on +the result refuses it. + Subsetting with \code{[} preserves class and attributes for vector subscripts. Two kinds of attribute hold one value per observation and so cannot be re-indexed for a subset: a \code{stabilization_score} with more than one value, diff --git a/man/wt_trunc.Rd b/man/wt_trunc.Rd index ec3c6844..81eae4ac 100644 --- a/man/wt_trunc.Rd +++ b/man/wt_trunc.Rd @@ -146,6 +146,59 @@ To see how much a truncation changed the effective sample size, add the weights before and after it to a data frame as separate columns and pass both to \code{halfmoon::check_ess()}. } + +\subsection{Truncating weights or trimming the density}{ + +For a continuous exposure there are two ways to hold down extreme weights. +\code{wt_trunc()} bounds the weights once they are built and keeps every unit. +\code{\link[=ps_trim]{ps_trim()}} with \code{method = "density"} or \code{method = "resid"} sets aside the +units whose observed dose is implausible under the dose model, and +\code{\link[=ps_refit]{ps_refit()}} refits the model on the units that remain; see \strong{Trimming a +dose model} in \code{\link[=ps_trim]{ps_trim()}}. Both change the estimand. A fixed bound +introduces a bias that does not vanish however large the sample, while a +bound that loosens with the sample, as \code{"adaptive"} does, leaves the +estimand alone in the limit. A trim describes only the units it keeps. +\code{wt_trunc()} applies to weights from any density family, and so does +\code{"density"}; \code{"resid"} accepts the normal, t, and Laplace families only. +\code{\link[=ipw]{ipw()}} refuses the weights from either tool. + +A simulation study run for this package (samples of 1000, 1000 +replications, a correctly specified mean for the dose) found that which +tool helps depends on whether the density family fits the residuals. The +coverage figures below are for a sandwich interval that holds the weights +fixed, unless stated. With normal residuals, a normal density, and an +effective sample size of 64\% of the sample, the \code{"adaptive"} bound moved almost no +weight and covered 0.933, as the untruncated weights did under the same +interval. The M-estimation interval on the untruncated weights covered +0.863, so the gain in coverage there comes from the interval, not the +bound. What the bound bought was precision: a root mean squared error of +0.084 against 0.096, for a bias of 0.015 (3\% of the effect) against 0.012. +At an effective sample size of 53\% it covered 0.847 against 0.839 +untruncated, and at 81\% it changed nothing. A density trim at +\code{lower = 0.01} covered 0.843 at 64\%, below the untruncated weights. + +With t(4) or Laplace residuals, or a residual spread that varied with a +covariate, the normal density fit some units badly. The bound then helped +little (coverage 0.822, 0.906, and 0.644, against 0.788, 0.881, and 0.618 +untruncated), while the 1\% density trim covered \strong{0.989}, \strong{0.980}, and +\strong{0.979}, because it removed the units that density fit worst. The trim's +intervals were computed on the trimmed sample and were conservative, and +its bias was measured against the effect in the full population, so part +of that bias is the change of estimand. The \code{"resid"} method was not +simulated; these results carry over to it only because a bound on the +standardized residual is a floor on the conditional density. + +Neither tool is the first step. Under the same heavy-tailed residuals, +\code{dens_t(4)} at its default scale covered 0.926 to 0.939 with the +M-estimation interval, whose standard errors were close to right, with +about a third of the root mean squared error of the bounded normal +weights, and kept every unit. So first check the density family against the +residuals, for instance by comparing the weights to those of a +\code{\link[=dens_kernel]{dens_kernel()}} density or a heavier tail. If the weights are still heavy +under a family that fits, bound them with \code{wt_trunc()}. Trim the dose model +when the units at the low-density end are ones the analysis should not +describe, and state the population the trimmed analysis describes. +} } \examples{ set.seed(1) diff --git a/tests/testthat/_snaps/ps_trim-density.md b/tests/testthat/_snaps/ps_trim-density.md index d4b06359..e35a9f32 100644 --- a/tests/testthat/_snaps/ps_trim-density.md +++ b/tests/testthat/_snaps/ps_trim-density.md @@ -75,7 +75,7 @@ Condition Error in `ps_trim()`: ! `sigma_method = "mle"` cannot be used with `.sigma`. - x `sigma_method = "mle"` estimates the scale of the "t" conditional density from the residuals of the propensity score model, and `.sigma` is a spread of your own that replaces it. + x `sigma_method = "mle"` estimates the scale of the "t" conditional density from the residuals of the model of the exposure, and `.sigma` is a spread of your own that replaces it. i A "t" density is spread by its own estimator unless you ask for another, so `sigma_method = "mle"` is what it carries whether or not you wrote it. i Drop `.sigma` to estimate the scale under the "t" density, or build the density with `sigma_method = "rms"` to spread the one you supplied. diff --git a/tests/testthat/_snaps/ps_trim.md b/tests/testthat/_snaps/ps_trim.md index 4f654fba..a5922351 100644 --- a/tests/testthat/_snaps/ps_trim.md +++ b/tests/testthat/_snaps/ps_trim.md @@ -175,7 +175,7 @@ Error in `ps_trim()`: ! Method "density" cannot trim a vector of values. x It reads the conditional density of a continuous exposure, which needs the residuals and the family of the model that fit its conditional mean, and `.propensity` carries neither. - i Supply the fitted model of the exposure itself as `.propensity`. + i Supply the model of the exposure's conditional mean, such as an `lm()` fit, as `.propensity`. --- @@ -185,7 +185,7 @@ Error in `ps_trim()`: ! Method "resid" cannot trim a vector of values. x It reads the conditional density of a continuous exposure, which needs the residuals and the family of the model that fit its conditional mean, and `.propensity` carries neither. - i Supply the fitted model of the exposure itself as `.propensity`. + i Supply the model of the exposure's conditional mean, such as an `lm()` fit, as `.propensity`. # ps_trim names `.exposure` when the method requires one diff --git a/tests/testthat/_snaps/weights-continuous.md b/tests/testthat/_snaps/weights-continuous.md index 7103b31c..7b9fc74c 100644 --- a/tests/testthat/_snaps/weights-continuous.md +++ b/tests/testthat/_snaps/weights-continuous.md @@ -307,7 +307,7 @@ Condition Error in `wt_ate()`: ! `sigma_method = "mle"` cannot be used with `.sigma`. - x `sigma_method = "mle"` estimates the scale of the "t" conditional density from the residuals of the propensity score model, and `.sigma` is a spread of your own that replaces it. + x `sigma_method = "mle"` estimates the scale of the "t" conditional density from the residuals of the model of the exposure, and `.sigma` is a spread of your own that replaces it. i A "t" density is spread by its own estimator unless you ask for another, so `sigma_method = "mle"` is what it carries whether or not you wrote it. i Drop `.sigma` to estimate the scale under the "t" density, or build the density with `sigma_method = "rms"` to spread the one you supplied. @@ -318,7 +318,7 @@ Condition Error in `wt_ate()`: ! The scale of a "t" density cannot be estimated by maximum likelihood from these residuals. - x 9 of the 10 residuals of the propensity score model are exactly zero, and with 4 degrees of freedom that leaves the likelihood no maximum at a positive scale. + x 9 of the 10 residuals of the model of the exposure are exactly zero, and with 4 degrees of freedom that leaves the likelihood no maximum at a positive scale. i Use `sigma_method = "rms"`, or supply a spread with `.sigma`. # the numerator model refusals read as the refusals they are diff --git a/vignettes/propensity.Rmd b/vignettes/propensity.Rmd index 1b2b7495..955a7b52 100644 --- a/vignettes/propensity.Rmd +++ b/vignettes/propensity.Rmd @@ -224,13 +224,27 @@ wts_truncated <- wt_ate(ps_truncated, dat$z) summary(wts_truncated) ``` +`method = "adaptive"` chooses the bounds from the sample size alone: it bounds +the scores at `[1/c, 1 - 1/c]` with `c = sqrt(n) * log(n) / 5` (Gruber et al., +2022), which caps unstabilized ATE weights at `c`. `wt_trunc()` places that +bound on the weights themselves: + +```{r truncate-adaptive} +ps_trunc_adapt <- ps_trunc(ps, method = "adaptive") +wts_bounded_ate <- wt_trunc(wts_ate) +``` + ### Which approach? These aren't mutually exclusive. In general: overlap estimands like `wt_ato()` are the easiest path if your research question allows it. -Trimming (followed by `ps_refit()`) is the standard choice when you need ATE -but have near-violations of positivity. Truncation is a lighter touch when -you want to keep the full sample. +Trimming (followed by `ps_refit()`) is the standard choice for +near-violations of positivity, but it changes the target population: the +estimate describes the units the trim keeps, not the whole sample, so report +it as such. Truncation, with `ps_trunc(method = "adaptive")` on +the scores or `wt_trunc()` on the weights, is the choice when you must keep +the full sample. `ipw()` accepts neither trimmed nor truncated weights, so an +analysis that uses them needs its interval computed another way. ## Interpreting results @@ -327,6 +341,45 @@ resample the rows, refit the dose model, rebuild the weights with `wt_ate()`, and refit the marginal structural model on each resample, then read the spread of the slope across the resamples. +A dose has no propensity score in (0, 1), so `ps_trunc()` has nothing to bound. +Extreme dose weights have two remedies instead. `wt_trunc()` bounds the weights +once they are built and keeps every unit; its default bound, +`sqrt(n) * log(n) / 5` (Gruber et al., 2022), loosens as the sample grows. +`ps_trim()` with `method = "density"` works on the dose model itself: it sets +aside the units whose observed dose has the lowest conditional density, here +the lowest 1%, and `ps_refit()` refits the model on the rest: + +```{r continuous-extreme} +# Keep every unit and bound the weights. With 100 units the bound is 9.2, +# above every weight here, so no weight moves. +wts_bounded <- wt_trunc(wts_dose) +sum(is_unit_wt_truncated(wts_bounded)) + +# Set aside the units whose dose the model finds least plausible +dose_trimmed <- ps_trim(ps_dose, method = "density", lower = 0.01) +dose_refit <- ps_refit(dose_trimmed, ps_dose) +wts_dose_trimmed <- wt_ate(dose_refit, dat$a) +summary(wts_dose_trimmed) +``` + +Both change the estimand. The bound adds a bias that shrinks only as it +loosens, and the trim describes only the units it keeps. `ipw()` refuses the +weights from either, so report an interval computed another way, such as a +sandwich that holds the weights fixed. A heavy weight can also mean the density +family is wrong, and then a family that fits the residuals, such as +`dens_t()` above, is the better remedy. See `?wt_trunc` for when to reach for +which. + +To see what either remedy recovered, compare effective sample sizes with +`halfmoon::check_ess()`. It reads weights as columns of a data frame, so add the +weights before and after as separate columns: + +```{r continuous-ess, eval = FALSE} +dat$w_dose <- wts_dose +dat$w_bounded <- wts_bounded +halfmoon::check_ess(dat, .weights = c(w_dose, w_bounded), .exposure = a) +``` + ### Categorical exposures For multi-level treatments, pass a matrix or data frame of predicted @@ -380,7 +433,9 @@ estimand(wts_cens) # "uncensored" See the function reference for details: -- `?wt_ate` -- Weight calculation for all estimands -- `?ps_trim`, `?ps_trunc`, `?ps_calibrate` -- Handling extreme propensity +- `?wt_ate`: Weight calculation for all estimands +- `?ps_trim`, `?ps_trunc`, `?ps_calibrate`: Handling extreme propensity scores -- `?ipw` -- Inverse probability weighted estimation +- `?wt_trunc`: Bounding extreme weights, including those of a continuous + exposure +- `?ipw`: Inverse probability weighted estimation From 91b4c4a46452a965c6d3bc072012ad91c1459d4e Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 09:45:47 -0400 Subject: [PATCH 44/64] test unique() on one-row and empty score matrices --- .../test-modified-score-matrix-unique.R | 60 +++++++++++++++++++ 1 file changed, 60 insertions(+) diff --git a/tests/testthat/test-modified-score-matrix-unique.R b/tests/testthat/test-modified-score-matrix-unique.R index 19a24d95..b5d206d4 100644 --- a/tests/testthat/test-modified-score-matrix-unique.R +++ b/tests/testthat/test-modified-score-matrix-unique.R @@ -185,3 +185,63 @@ test_that("unique() of a ps_trunc_matrix drops a record a moved row shares with ) } }) + +# One row and no rows ---------------------------------------------------------- + +test_that("unique() of a score matrix whose rows are all identical returns one row", { + # Rows 2 and 4 hold the same scores, and both were retained and left unmoved. + trimmed <- unique_trim_matrix(1:7)[c(2, 4), , drop = FALSE] + truncated <- unique_trunc_matrix(1:7)[c(2, 4), , drop = FALSE] + + out_trim <- expect_silent(unique(trimmed)) + + expect_s3_class(out_trim, "ps_trim_matrix") + expect_identical(dim(out_trim), c(1L, 3L)) + expect_identical(colnames(out_trim), c("a", "b", "c")) + expect_identical( + unclass(out_trim)[,], + unclass(trimmed)[1, , drop = FALSE][,] + ) + trim_meta <- ps_trim_meta(out_trim) + expect_identical(trim_meta$n_obs, 1L) + expect_identical(trim_meta$keep_idx, 1L) + expect_identical(trim_meta$trimmed_idx, integer(0)) + expect_true(is_ps_trimmed(out_trim)) + expect_identical(is_unit_trimmed(out_trim), FALSE) + + out_trunc <- expect_silent(unique(truncated)) + + expect_s3_class(out_trunc, "ps_trunc_matrix") + expect_identical(dim(out_trunc), c(1L, 3L)) + expect_identical(colnames(out_trunc), c("a", "b", "c")) + expect_identical( + unclass(out_trunc)[,], + unclass(truncated)[1, , drop = FALSE][,] + ) + trunc_meta <- ps_trunc_meta(out_trunc) + expect_identical(trunc_meta$n_obs, 1L) + expect_identical(trunc_meta$truncated_idx, integer(0)) + expect_true(is_ps_truncated(out_trunc)) + expect_identical(is_unit_truncated(out_trunc), FALSE) +}) + +test_that("unique() of a score matrix with no rows returns no rows", { + trimmed <- unique_trim_matrix(1:7)[integer(0), , drop = FALSE] + truncated <- unique_trunc_matrix(1:7)[integer(0), , drop = FALSE] + + out_trim <- expect_silent(unique(trimmed)) + + expect_s3_class(out_trim, "ps_trim_matrix") + expect_identical(dim(out_trim), c(0L, 3L)) + expect_identical(colnames(out_trim), c("a", "b", "c")) + expect_identical(ps_trim_meta(out_trim)$n_obs, 0L) + expect_identical(is_unit_trimmed(out_trim), logical(0)) + + out_trunc <- expect_silent(unique(truncated)) + + expect_s3_class(out_trunc, "ps_trunc_matrix") + expect_identical(dim(out_trunc), c(0L, 3L)) + expect_identical(colnames(out_trunc), c("a", "b", "c")) + expect_identical(ps_trunc_meta(out_trunc)$n_obs, 0L) + expect_identical(is_unit_truncated(out_trunc), logical(0)) +}) From c3aeca48080ff5934b748ea77fcb53bed99fbe5a Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 10:15:44 -0400 Subject: [PATCH 45/64] add failing tests for reordering weights with position records --- tests/testthat/_snaps/wt-trunc.md | 11 +- tests/testthat/test-base-methods-summary.R | 11 +- tests/testthat/test-causal-wts-provenance.R | 50 ++- tests/testthat/test-psw-reorder-records.R | 398 ++++++++++++++++++++ tests/testthat/test-psw-wt-trunc.R | 29 +- tests/testthat/test-psw.R | 49 ++- tests/testthat/test-wt-trunc.R | 8 +- 7 files changed, 509 insertions(+), 47 deletions(-) create mode 100644 tests/testthat/test-psw-reorder-records.R diff --git a/tests/testthat/_snaps/wt-trunc.md b/tests/testthat/_snaps/wt-trunc.md index b3d98177..11b30891 100644 --- a/tests/testthat/_snaps/wt-trunc.md +++ b/tests/testthat/_snaps/wt-trunc.md @@ -92,12 +92,21 @@ # a subset that drops the record prints a truncation line without counts Code - wt_trunc(w, method = "wt", upper = 3)[1:3] + vctrs::vec_slice(wt_trunc(w, method = "wt", upper = 3), 1:3) Output [1] 0.5 1.0 3.0 truncation: weights truncated +# a subset re-indexes the record and prints the truncation counts + + Code + wt_trunc(w, method = "wt", upper = 3)[c(5, 1, 3)] + Output + + [1] 3.0 0.5 3.0 + truncation: wt (upper 3), 2 of 3 weights truncated + # wt_trunc() refuses input that is not weights Code diff --git a/tests/testthat/test-base-methods-summary.R b/tests/testthat/test-base-methods-summary.R index 5a5cad4e..19bb8514 100644 --- a/tests/testthat/test-base-methods-summary.R +++ b/tests/testthat/test-base-methods-summary.R @@ -122,9 +122,11 @@ test_that("Summary: Key differences and missing methods", { generics[vapply(generics, defines_method, logical(1), class = class)] } - # psw takes `[`, summary(), min(), max(), range(), median(), quantile(), + # psw takes summary(), min(), max(), range(), median(), quantile(), # anyDuplicated(), and diff() from causalgenerics' causal_wts methods; - # ps_trim and ps_trunc each define their own. + # ps_trim and ps_trunc each define their own. psw defines `[` so that its + # position records follow the subscript, and passes the subsetting itself on + # to causal_wts. inherited <- c( "[", "summary", @@ -136,14 +138,15 @@ test_that("Summary: Key differences and missing methods", { "anyDuplicated", "diff" ) - expect_equal(defined_for(inherited, "psw"), character(0)) + expect_equal(defined_for(inherited, "psw"), "[") expect_equal(defined_for(inherited, "causal_wts"), inherited) expect_equal(defined_for(inherited, "ps_trim"), inherited) expect_equal(defined_for(inherited, "ps_trunc"), inherited) # ps_trim and ps_trunc implement sort(), unique(), and rep() so that the # record of which units were modified follows the result. psw implements - # none of the three and takes the vctrs defaults. + # none of the three: sort() reaches its `[`, and unique() and rep() take the + # vctrs defaults, which drop the position records. record_keeping <- c("sort", "unique", "rep") expect_equal(defined_for(record_keeping, "psw"), character(0)) expect_equal(defined_for(record_keeping, "causal_wts"), character(0)) diff --git a/tests/testthat/test-causal-wts-provenance.R b/tests/testthat/test-causal-wts-provenance.R index 2ec731db..9ee02aa0 100644 --- a/tests/testthat/test-causal-wts-provenance.R +++ b/tests/testthat/test-causal-wts-provenance.R @@ -96,9 +96,8 @@ method_owners <- function(methods) { # Accessors the abstract layer registers directly on `causal_wts`. causal_wts_accessors <- c("estimand", "estimand<-", "is_causal_wt") -# Methods the abstract layer supplies on `causal_wts` and that a `psw` object -# reaches by inheritance rather than through a method of its own. -psw_layer_generics <- c( +# Methods the abstract layer supplies on `causal_wts`. +causal_wts_layer_generics <- c( "vec_math", "Summary", "min", @@ -118,6 +117,12 @@ psw_layer_generics <- c( ">=" ) +# The subset of those a `psw` object reaches by inheritance rather than through +# a method of its own. `[.psw` carries the position records a psw holds through +# the subscript, which the abstract layer knows nothing about, and hands the +# subsetting itself to `[.causal_wts`. +psw_layer_generics <- setdiff(causal_wts_layer_generics, "[") + # Methods propensity must keep on `psw`. `vec_ptype2`, `vec_cast`, # `vec_ptype_abbr`, and `vec_ptype_full` cannot be inherited at all: vctrs # resolves them on `class(x)[[1]]` and never walks the class vector. @@ -130,6 +135,7 @@ psw_layer_generics <- c( # other test passes a `psw` to it, so its loss only shows up as # `is_unit_truncated.default` aborting in a user's session. psw_retained_methods <- c( + `[` = "psw", vec_restore = "psw", vec_arith = "psw", `vec_arith.numeric` = "psw", @@ -175,7 +181,7 @@ psw_retained_methods <- c( test_that("causalgenerics supplies the abstract layer on causal_wts", { owners <- vapply( - psw_layer_generics, + causal_wts_layer_generics, method_owner, character(1), cls = "causal_wts" @@ -184,8 +190,8 @@ test_that("causalgenerics supplies the abstract layer on causal_wts", { expect_identical( owners, stats::setNames( - rep("causalgenerics", length(psw_layer_generics)), - psw_layer_generics + rep("causalgenerics", length(causal_wts_layer_generics)), + causal_wts_layer_generics ) ) }) @@ -301,7 +307,7 @@ test_that("subsetting a psw preserves trimming, truncation, and calibration", { expect_equal(metadata(w[]), expected) }) -test_that("subsetting a trimmed psw drops the unit-level trimming index", { +test_that("subsetting a trimmed psw re-indexes the unit-level trimming index", { set.seed(42) n <- 60 z <- rnorm(n) @@ -323,22 +329,26 @@ test_that("subsetting a trimmed psw drops the unit-level trimming index", { expect_true(is_ps_trimmed(wt)) expect_length(is_unit_trimmed(wt), n) - # The trimming index is written against the full vector and nothing rebuilding - # a psw is handed the subscript, so a subset cannot re-index it and the index - # is dropped. The drop is silent because vctrs sees only some of the routes - # these weights take: base R re-attaches the index to a shortened weights - # column inside `model.frame()`, so a warning here would be neither complete - # nor about anything in the user's code. What the assertion guards on the other - # side is the blind-attribute-copy regression, which would re-attach an index - # built against the original vector and return a length-`n` logical for a - # length-2 subset. Whether the index is missing or merely does not cover these - # weights, `is_unit_trimmed()` reports that it cannot answer rather than - # answering from it. + # The trimming index is written against the full vector. `[` knows its + # subscript and re-indexes the index onto it, so a length-2 subset answers + # for its own two units rather than returning a length-`n` logical, the + # blind-attribute-copy regression. first_two <- expect_silent(wt[1:2]) expect_true(is_ps_trimmed(first_two)) - expect_null(ps_trim_meta(first_two)) + expect_identical(is_unit_trimmed(first_two), is_unit_trimmed(wt)[1:2]) + + # A slice is not handed its subscript, so it drops the index silently: vctrs + # sees only some of the routes these weights take, since base R re-attaches + # the index to a shortened weights column inside `model.frame()`, and a + # warning would be neither complete nor about anything in the user's code. + # Whether the index is missing or merely does not cover these weights, + # `is_unit_trimmed()` reports that it cannot answer rather than answering + # from it. + sliced <- expect_silent(vctrs::vec_slice(wt, 1:2)) + expect_true(is_ps_trimmed(sliced)) + expect_null(ps_trim_meta(sliced)) expect_error( - is_unit_trimmed(first_two), + is_unit_trimmed(sliced), class = "propensity_missing_meta_error" ) }) diff --git a/tests/testthat/test-psw-reorder-records.R b/tests/testthat/test-psw-reorder-records.R new file mode 100644 index 00000000..449fc1da --- /dev/null +++ b/tests/testthat/test-psw-reorder-records.R @@ -0,0 +1,398 @@ +# Reordering weights that carry position records ----------------------------- + +# A trimming, truncation, or weight truncation record names units by position. +# A subscript moves units to new positions, so `[` and everything built on it +# (`rev()`, `sort()`, `x[order(x)]`) carry each record through the subscript. +# A slice that reaches the restore without its subscript, such as `vec_slice()` +# or `dplyr::arrange()`, cannot place the record and drops it silently. + +# Units 1 and 4 fall outside (0.1, 0.9); their weights are missing. +reorder_trimmed_psw <- function() { + w <- psw( + c(NA, 2, 1.6, NA, 3.3), + estimand = "ate; trimmed", + trimmed = TRUE + ) + attr(w, "ps_trim_meta") <- list( + method = "ps", + lower = 0.1, + upper = 0.9, + focal_inverted = FALSE, + keep_idx = c(2L, 3L, 5L), + trimmed_idx = c(1L, 4L), + n_obs = 5L + ) + w +} + +# Units 1 and 4 were pinned to the bounds. +reorder_truncated_psw <- function() { + w <- psw( + c(10, 2, 1.6, 10, 3.3), + estimand = "ate; truncated", + truncated = TRUE + ) + attr(w, "ps_trunc_meta") <- list( + method = "ps", + lower_bound = 0.1, + upper_bound = 0.9, + truncated_idx = c(1L, 4L), + n_obs = 5L + ) + w +} + +# Units 3 and 10 were brought down to the second largest weight, which unit 2 +# already held, so the bound value appears at a unit the truncation never moved. +reorder_wt_truncated_psw <- function() { + wt_trunc(psw(c(1, 2, 50, 3, 4, 5, 6, 7, 8, 100)), "count", upper = 2) +} + +reorder_fixtures <- function() { + list( + trimmed = list( + weights = reorder_trimmed_psw(), + attr = "ps_trim_meta", + query = is_unit_trimmed + ), + truncated = list( + weights = reorder_truncated_psw(), + attr = "ps_trunc_meta", + query = is_unit_truncated + ), + wt_truncated = list( + weights = reorder_wt_truncated_psw(), + attr = "psw_trunc_meta", + query = is_unit_wt_truncated + ) + ) +} + +# The units a record names after the subscript `i`, read off the units it named +# before. A missing position names no unit. +expected_units <- function(units, i) { + out <- units[i] + out[is.na(out)] <- FALSE + out +} + +expect_reindexed <- function(out, fixture, i, label) { + units <- fixture$query(fixture$weights) + expect_s3_class(out, "psw") + expect_identical( + fixture$query(out), + expected_units(units, i), + info = label + ) + expect_identical( + attr(out, fixture$attr)$n_obs, + length(i), + info = label + ) +} + +expect_record_dropped <- function(out, fixture, label) { + expect_s3_class(out, "psw") + expect_null(attr(out, fixture$attr), info = label) + expect_error( + fixture$query(out), + class = "propensity_missing_meta_error", + info = label + ) +} + +test_that("the fixtures name the units they were built to name", { + fixtures <- reorder_fixtures() + + expect_identical( + which(fixtures$trimmed$query(fixtures$trimmed$weights)), + c(1L, 4L) + ) + expect_identical( + which(fixtures$truncated$query(fixtures$truncated$weights)), + c(1L, 4L) + ) + expect_identical( + which(fixtures$wt_truncated$query(fixtures$wt_truncated$weights)), + c(3L, 10L) + ) +}) + +test_that("rev() carries each position record onto the reversed weights", { + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + + out <- expect_silent(rev(w)) + expect_reindexed(out, fixture, rev(seq_along(w)), label) + expect_identical(vec_data(out), rev(vec_data(w)), info = label) + } +}) + +test_that("rev() on the reported examples names the units that moved", { + t <- reorder_wt_truncated_psw() + expect_identical(which(is_unit_wt_truncated(rev(t))), c(1L, 8L)) + + tr <- reorder_trimmed_psw() + expect_identical(which(is_unit_trimmed(rev(tr))), c(2L, 5L)) + expect_identical(which(is.na(rev(tr))), c(2L, 5L)) +}) + +test_that("sort() carries each position record through the order it sorts by", { + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + data <- vec_data(w) + + # `sort()` drops missing weights by default, so the record follows a + # subscript shorter than the weights. + out <- expect_silent(sort(w)) + expect_reindexed(out, fixture, order(data, na.last = NA), label) + + out <- expect_silent(sort(w, decreasing = TRUE, na.last = TRUE)) + expect_reindexed( + out, + fixture, + order(data, decreasing = TRUE, na.last = TRUE), + label + ) + } +}) + +test_that("subsetting by an order carries each position record", { + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + ord <- order(-vec_data(w)) + + out <- expect_silent(w[ord]) + expect_reindexed(out, fixture, ord, label) + } +}) + +test_that("a positive permutation carries each position record", { + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + i <- c(2L, seq_along(w)[-2]) + + out <- expect_silent(w[i]) + expect_reindexed(out, fixture, i, label) + expect_identical(vec_data(out), vec_data(w)[i], info = label) + } +}) + +test_that("a negative subscript carries each position record", { + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + + out <- expect_silent(w[-1]) + expect_reindexed(out, fixture, seq_along(w)[-1], label) + + # A zero in a negative subscript removes nothing. + out <- expect_silent(w[-0]) + expect_length(out, 0) + } +}) + +test_that("a logical subscript carries each position record", { + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + keep <- rep_len(c(TRUE, FALSE), length(w)) + keep[4] <- TRUE + + out <- expect_silent(w[keep]) + expect_reindexed(out, fixture, which(keep), label) + + out <- expect_silent(w[TRUE]) + expect_identical(attr(out, fixture$attr), attr(w, fixture$attr)) + } +}) + +test_that("a character subscript carries each position record", { + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + names(w) <- letters[seq_along(w)] + i <- rev(names(w)) + + out <- expect_silent(w[i]) + expect_reindexed(out, fixture, rev(seq_along(w)), label) + expect_identical(names(out), i, info = label) + } +}) + +test_that("a subscript naming a unit twice or no unit reindexes element by element", { + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + # Unit 2 is untouched in every fixture. + flagged <- which(fixture$query(w)) + i <- c(flagged[2], flagged[2], NA, 2L, flagged[1]) + + out <- expect_silent(w[i]) + expect_reindexed(out, fixture, i, label) + expect_identical(fixture$query(out), c(TRUE, TRUE, FALSE, FALSE, TRUE)) + } +}) + +test_that("an identity subscript keeps each position record unchanged", { + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + + out <- expect_silent(w[seq_along(w)]) + expect_identical(attr(out, fixture$attr), attr(w, fixture$attr)) + + out <- expect_silent(w[]) + expect_identical(attr(out, fixture$attr), attr(w, fixture$attr)) + } +}) + +test_that("an empty subscript leaves the prototype as the restore builds it", { + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + + expect_identical( + attributes(w[integer()]), + attributes(vctrs::vec_slice(w, integer())), + info = label + ) + expect_identical( + attributes(w[0]), + attributes(vctrs::vec_ptype(w)), + info = label + ) + } +}) + +test_that("a record that does not cover the weights is dropped by a subscript", { + w <- reorder_wt_truncated_psw() + w[12] <- 2 + expect_length(w, 12) + + out <- expect_silent(w[rev(seq_along(w))]) + expect_null(attr(out, "psw_trunc_meta")) + expect_true(is_wt_truncated(out)) + expect_error( + is_unit_wt_truncated(out), + class = "propensity_missing_meta_error" + ) +}) + +test_that("vec_slice() at the same length drops each position record silently", { + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + + out <- expect_silent(vctrs::vec_slice(w, rev(seq_along(w)))) + expect_record_dropped(out, fixture, label) + expect_identical(estimand(out), estimand(w), info = label) + expect_identical(vec_data(out), rev(vec_data(w)), info = label) + } + + w <- reorder_wt_truncated_psw() + out <- vctrs::vec_slice(w, rev(seq_along(w))) + expect_true(is_wt_truncated(out)) +}) + +test_that("dplyr::arrange() on a psw column drops each position record silently", { + skip_if_not_installed("dplyr") + + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + df <- data.frame(o = rev(seq_along(w))) + df$w <- w + + out <- expect_silent(dplyr::arrange(df, o)) + expect_record_dropped(out$w, fixture, label) + expect_identical(vec_data(out$w), rev(vec_data(w)), info = label) + } +}) + +test_that("reordering a data frame with base subsetting carries each record", { + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + df <- data.frame(o = rev(seq_along(w))) + df$w <- w + + out <- expect_silent(df[order(df$o), , drop = FALSE]) + expect_reindexed(out$w, fixture, rev(seq_along(w)), label) + } +}) + +test_that("same-length arithmetic keeps each position record", { + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + meta <- attr(w, fixture$attr) + + results <- list( + `w * 2` = expect_silent(w * 2), + `2 * w` = expect_silent(2 * w), + `w * 1L` = expect_silent(w * 1L), + `-w` = expect_silent(-w), + `w * w` = expect_silent(w * w), + `w / sum(w, na.rm = TRUE)` = expect_silent(w / sum(w, na.rm = TRUE)) + ) + + for (op in names(results)) { + out <- results[[op]] + expect_s3_class(out, "psw") + expect_identical(attr(out, fixture$attr), meta, info = c(label, op)) + } + } +}) + +test_that("same-length subassignment keeps each position record", { + for (label in names(reorder_fixtures())) { + fixture <- reorder_fixtures()[[label]] + w <- fixture$weights + meta <- attr(w, fixture$attr) + units <- fixture$query(w) + + expect_silent({ + w[2] <- 5 + }) + expect_identical(attr(w, fixture$attr), meta, info = label) + expect_identical(fixture$query(w), units, info = label) + + expect_silent({ + w[] <- rev(vec_data(w)) + }) + expect_identical(attr(w, fixture$attr), meta, info = label) + } +}) + +test_that("truncating reordered weights records the units at their new positions", { + w <- psw(c(1, 2, 50, 3, 4, 5, 6, 7, 8, 100)) + out <- wt_trunc(rev(w), "count", upper = 2) + + expect_identical(which(is_unit_wt_truncated(out)), c(1L, 8L)) + expect_identical( + which(is_unit_wt_truncated(rev(out))), + which(is_unit_wt_truncated(wt_trunc(w, "count", upper = 2))) + ) +}) + +test_that("a combine of reordered weights still compares their bounds", { + a <- reorder_wt_truncated_psw() + b <- wt_trunc(psw(c(1, 2, 50, 3, 4, 5, 6, 7, 8, 100)), "count", upper = 1) + + out <- expect_silent(vctrs::vec_c(rev(a), a)) + expect_true(is_wt_truncated(out)) + expect_null(attr(out, "psw_trunc_meta")) + expect_null(attr(out, "psw_trunc_bound")) + expect_null(attr(out, "psw_conflicted_attrs")) + + expect_warning( + out <- vctrs::vec_c(rev(a), a, rev(b)), + class = "propensity_coercion_warning" + ) + expect_false(inherits(out, "psw")) +}) diff --git a/tests/testthat/test-psw-wt-trunc.R b/tests/testthat/test-psw-wt-trunc.R index 2022b944..4e3d20c7 100644 --- a/tests/testthat/test-psw-wt-trunc.R +++ b/tests/testthat/test-psw-wt-trunc.R @@ -4,10 +4,10 @@ # propensity scores they were built from. The `wt_truncated` flag says the # weights were bounded, and the `psw_trunc_meta` record says at what bound and # which units it moved. The record is positional, so it follows the rules the -# trimming record follows: kept through any operation that preserves the -# length, dropped without comment on a length change, and left off the prototype -# a combine builds. The flag describes the vector as a whole and survives all -# of those. +# trimming record follows: kept through elementwise arithmetic and +# subassignment, carried through the subscript of `[`, dropped without comment +# by any other slice or length change, and left off the prototype a combine +# builds. The flag describes the vector as a whole and survives all of those. # Units 2 and 5 sit at the bound, so the positional query has something to # report and a result that lost the record reports something visibly different. @@ -162,29 +162,40 @@ test_that("a full-length psw subset keeps the weight truncation record", { expect_identical(attr(whole, "psw_trunc_meta"), meta) expect_identical(is_unit_wt_truncated(whole), wt_truncated_units) + # A slice is not handed to anything that knows its subscript, so even one + # that leaves every unit in place cannot vouch for the record. sliced <- expect_silent(vec_slice(w, seq_along(w))) - expect_identical(attr(sliced, "psw_trunc_meta"), meta) + expect_null(attr(sliced, "psw_trunc_meta")) expect_true(is_wt_truncated(sliced)) }) -test_that("shortening a psw drops the weight truncation record and keeps the flag", { +test_that("shortening a psw re-indexes the weight truncation record through `[`", { w <- wt_truncated_psw() sub <- expect_silent(w[1:2]) expect_s3_class(sub, "psw") expect_length(sub, 2) - expect_null(attr(sub, "psw_trunc_meta")) + expect_identical( + attr(sub, "psw_trunc_meta"), + wt_trunc_record(truncated_idx = 2L, n_obs = 2L) + ) expect_true(is_wt_truncated(sub)) expect_identical(estimand(sub), "ate") + expect_identical(is_unit_wt_truncated(sub), c(FALSE, TRUE)) +}) + +test_that("shortening a psw by a slice drops the weight truncation record and keeps the flag", { + w <- wt_truncated_psw() sliced <- expect_silent(vec_slice(w, 1:2)) expect_null(attr(sliced, "psw_trunc_meta")) expect_true(is_wt_truncated(sliced)) + expect_identical(estimand(sliced), "ate") # The record is gone, so the positional query has nothing to answer from and # refuses rather than reporting every unit as untouched. expect_error( - is_unit_wt_truncated(sub), + is_unit_wt_truncated(sliced), class = "propensity_missing_meta_error" ) }) @@ -489,7 +500,7 @@ test_that("a weight-truncated psw with no record agrees with any bound", { # A record already dropped, by a slice or by an earlier combine, has nothing # to disagree with, so only the flag is compared. w <- wt_truncated_psw() - alt_slice <- alt_wt_truncated_psw()[1:2] + alt_slice <- vec_slice(alt_wt_truncated_psw(), 1:2) expect_null(attr(alt_slice, "psw_trunc_meta")) expect_true(is_wt_truncated(alt_slice)) diff --git a/tests/testthat/test-psw.R b/tests/testthat/test-psw.R index e5fbd399..e6cb2d06 100644 --- a/tests/testthat/test-psw.R +++ b/tests/testthat/test-psw.R @@ -713,8 +713,11 @@ test_that("a full-length psw subset keeps the trimming record", { expect_identical(ps_trim_meta(whole), meta) expect_identical(is_unit_trimmed(whole), c(TRUE, FALSE, FALSE, FALSE, TRUE)) + # A slice is not handed to anything that knows its subscript, so even one + # that leaves every unit in place cannot vouch for the record. sliced <- expect_silent(vec_slice(w, seq_along(w))) - expect_identical(ps_trim_meta(sliced), meta) + expect_null(ps_trim_meta(sliced)) + expect_true(is_ps_trimmed(sliced)) }) test_that("length-preserving psw arithmetic keeps truncation and calibration records", { @@ -731,29 +734,45 @@ test_that("length-preserving psw arithmetic keeps truncation and calibration rec expect_true(is_ps_calibrated(out)) }) -test_that("shortening a psw drops the trimming record silently", { +test_that("shortening a psw with `[` re-indexes the trimming record", { w <- trimmed_psw() sub <- expect_silent(w[1:2]) expect_s3_class(sub, "psw") expect_length(sub, 2) - expect_null(ps_trim_meta(sub)) - expect_null(attr(sub, "ps_trim_meta")) - - # Everything that is not indexed by observation is untouched by the drop. + expect_identical(ps_trim_meta(sub)$n_obs, 2L) + expect_identical(is_unit_trimmed(sub), c(TRUE, FALSE)) expect_true(is_ps_trimmed(sub)) expect_identical(estimand(sub), "ate; trimmed") +}) + +test_that("shortening a psw by a slice drops the trimming record silently", { + w <- trimmed_psw() sliced <- expect_silent(vec_slice(w, 1:2)) + expect_s3_class(sliced, "psw") + expect_length(sliced, 2) expect_null(ps_trim_meta(sliced)) + expect_null(attr(sliced, "ps_trim_meta")) + + # Everything that is not indexed by observation is untouched by the drop. expect_true(is_ps_trimmed(sliced)) + expect_identical(estimand(sliced), "ate; trimmed") }) -test_that("shortening a psw drops the truncation record silently", { +test_that("shortening a psw re-indexes the truncation record through `[` and a slice drops it", { truncated <- truncated_psw() + meta <- ps_trunc_meta(truncated) + sub <- expect_silent(truncated[1:2]) - expect_null(ps_trunc_meta(sub)) + expect_identical(ps_trunc_meta(sub)$n_obs, 2L) + expect_identical(is_unit_truncated(sub), is_unit_truncated(truncated)[1:2]) expect_true(is_ps_truncated(sub)) + + sliced <- expect_silent(vec_slice(truncated, 1:2)) + expect_null(ps_trunc_meta(sliced)) + expect_true(is_ps_truncated(sliced)) + expect_identical(ps_trunc_meta(truncated), meta) }) # A calibration record names the curve the scores were calibrated with and @@ -920,16 +939,22 @@ test_that("shortening a psw with a score and a trimming record warns only for th expect_identical(stabilization_score(w), score) expect_false(is.null(ps_trim_meta(w))) - out <- collect_warning_classes(w[1:2]) - # A user who recorded a score can recompute the weights on the subset, so that - # drop is worth saying. The trimming record has a query-time guard instead, and - # announcing it here would fire on every outcome model fit on these weights. + # drop is worth saying. The trimming record is either re-indexed or has a + # query-time guard instead, and announcing its drop would fire on every + # outcome model fit on these weights. + out <- collect_warning_classes(vec_slice(w, 1:2)) expect_identical(out$classes, "propensity_stabilization_score_warning") expect_null(stabilization_score(out$value)) expect_null(ps_trim_meta(out$value)) expect_true(is_stabilized(out$value)) expect_true(is_ps_trimmed(out$value)) + + out <- collect_warning_classes(w[1:2]) + expect_identical(out$classes, "propensity_stabilization_score_warning") + expect_null(stabilization_score(out$value)) + expect_identical(is_unit_trimmed(out$value), c(TRUE, FALSE)) + expect_true(is_stabilized(out$value)) }) test_that("the trimmed flag survives operations that drop the trimming record", { diff --git a/tests/testthat/test-wt-trunc.R b/tests/testthat/test-wt-trunc.R index 09c5f44c..5ea2c88f 100644 --- a/tests/testthat/test-wt-trunc.R +++ b/tests/testthat/test-wt-trunc.R @@ -792,7 +792,13 @@ test_that("the names on the weights are kept", { test_that("a subset that drops the record prints a truncation line without counts", { w <- psw(c(0.5, 1, 4, 2, 25), estimand = "ate") - expect_snapshot(wt_trunc(w, method = "wt", upper = 3)[1:3]) + expect_snapshot(vctrs::vec_slice(wt_trunc(w, method = "wt", upper = 3), 1:3)) +}) + +test_that("a subset re-indexes the record and prints the truncation counts", { + w <- psw(c(0.5, 1, 4, 2, 25), estimand = "ate") + + expect_snapshot(wt_trunc(w, method = "wt", upper = 3)[c(5, 1, 3)]) }) test_that("wt_trunc() refuses input that is not weights", { From e99a23c4df0d28296f604448f5b960aae1b505af Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 10:16:43 -0400 Subject: [PATCH 46/64] reindex position records when weights are reordered --- NAMESPACE | 1 + NEWS.md | 13 ++++ R/ps_trim.R | 6 +- R/ps_trunc.R | 6 +- R/psw.R | 125 +++++++++++++++++++++++++++++---------- R/wt_trunc.R | 2 +- man/is_unit_trimmed.Rd | 6 +- man/is_unit_truncated.Rd | 6 +- man/is_wt_truncated.Rd | 4 +- man/psw.Rd | 23 ++++--- 10 files changed, 136 insertions(+), 56 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 6d5a24d2..d5334234 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,6 +11,7 @@ S3method("[",ps_trim) S3method("[",ps_trim_matrix) S3method("[",ps_trunc) S3method("[",ps_trunc_matrix) +S3method("[",psw) S3method(Summary,ps_calib) S3method(Summary,ps_trim) S3method(Summary,ps_trunc) diff --git a/NEWS.md b/NEWS.md index 38403a5c..1d7d5142 100644 --- a/NEWS.md +++ b/NEWS.md @@ -164,6 +164,19 @@ and `ps_refit()` now refuse such a result with an error of class `propensity_missing_meta_error`. +* Reordering or subsetting a `psw` with `[` now carries its trimming, + truncation, and weight truncation records through the subscript, as `[` + already did for a `ps_trim` or `ps_trunc`. `rev()`, `sort()`, and + `x[order(x)]` previously kept the records unchanged whenever the length was + unchanged, so `is_unit_trimmed()`, `is_unit_truncated()`, and + `is_unit_wt_truncated()` named the units that had been at those positions + before; a shorter subset previously dropped them. A slice that is not handed + its subscript, such as `vctrs::vec_slice()`, `dplyr::arrange()`, or + `dplyr::filter()`, now drops the positions silently at any length, and the + positional queries refuse the result with an error of class + `propensity_missing_meta_error`. Elementwise arithmetic and subassignment + keep the records. + * `unique()` of a `ps_trim` or `ps_trunc` now drops the positions in its record when it merges units whose status differs, such as a trimmed score and one that arrived missing, or a score already at a truncation bound and one diff --git a/R/ps_trim.R b/R/ps_trim.R index a53bf4d3..f0ee3751 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -1895,9 +1895,9 @@ is_ps_trimmed.ps_trim_matrix <- function(x) { #' That check counts observations, which a reordering does not change, so it #' does not catch one. A `ps_trim` reordered through vctrs rather than through #' `[`, by `vctrs::vec_slice(x, 5:1)` or `dplyr::arrange()`, keeps a record -#' written for the old order, and a `psw` keeps one through any same-length -#' operation, a reordering included. `is_unit_trimmed()` answers from those -#' positions and names the wrong units. See [ps_trim()] and [psw] for the +#' written for the old order, and `is_unit_trimmed()` answers from those +#' positions and names the wrong units. A `psw` drops its record on those +#' routes instead. See [ps_trim()] and [psw] for the #' whole contract. #' #' @param x A `ps_trim` object created by [ps_trim()], or a [psw] vector built diff --git a/R/ps_trunc.R b/R/ps_trunc.R index b99f499e..6af6b6ab 100644 --- a/R/ps_trunc.R +++ b/R/ps_trunc.R @@ -1403,9 +1403,9 @@ is_ps_truncated.ps_trunc_matrix <- function(x) { #' That check counts observations, which a reordering does not change, so it #' does not catch one. An operation that reorders through vctrs rather than #' through `[`, such as `vctrs::vec_slice(x, 5:1)` or `dplyr::arrange()`, -#' keeps a record written for the old order, and a `psw` keeps one through any -#' same-length operation, a reordering included. `is_unit_truncated()` answers -#' from those positions and names the wrong units. See [ps_trunc()] and [psw] +#' keeps a record written for the old order, and `is_unit_truncated()` +#' answers from those positions and names the wrong units. A `psw` drops its +#' record on those routes instead. See [ps_trunc()] and [psw] #' for the whole contract. #' #' @param x A `ps_trunc` object created by [ps_trunc()], or a [psw] vector built diff --git a/R/psw.R b/R/psw.R index 66b28465..d641ed84 100644 --- a/R/psw.R +++ b/R/psw.R @@ -125,15 +125,20 @@ #' the result refuses it. #' #' Subsetting with `[` preserves class and attributes for vector subscripts. -#' Two kinds of attribute hold one value per observation and so cannot be -#' re-indexed for a subset: a `stabilization_score` with more than one value, -#' and the records left by a trimmed or truncated propensity score -#' (`ps_trim_meta` and `ps_trunc_meta`) or by truncating the weights -#' themselves (`psw_trunc_meta`). Where an operation goes through -#' vctrs, these are carried when the result comes back at the length they were -#' recorded on and dropped when it does not. Any same-length operation keeps -#' them, a reordering or a subscript with duplicates included, so the positions -#' a record names can end up describing different observations than they did. +#' Two kinds of attribute hold one value per observation. The records left by +#' a trimmed or truncated propensity score (`ps_trim_meta` and +#' `ps_trunc_meta`) or by truncating the weights themselves +#' (`psw_trunc_meta`) name units by position, and `[` is handed the subscript, +#' so it re-indexes each record onto the result: `rev()`, `sort()`, +#' `x[order(x)]`, and a shorter subset all return records naming the units at +#' their new positions. Any other operation through vctrs is not handed a +#' subscript, so it keeps the records only where every unit stays at its +#' position, as in elementwise arithmetic, and otherwise drops them, at any +#' length: `vctrs::vec_slice()`, `dplyr::arrange()`, `dplyr::filter()`, and +#' `unique()` all return weights without them. Subassignment with `[<-` moves +#' no unit and keeps them. A `stabilization_score` with more than one value is +#' carried when the result comes back at the length it was recorded on and +#' dropped when it does not. #' #' Dropping the `stabilization_score` warns, because the score was supplied by #' the user and the weights can be recomputed on the subset. Dropping a @@ -848,8 +853,8 @@ is_refit.psw <- function(x) { #' positions of the weights it moved. `is_unit_wt_truncated()` answers from #' those positions, so the record follows the rules [psw] describes for the #' records a modified propensity score leaves: it is kept through arithmetic -#' and anything else that keeps the length of the weights, and dropped when a -#' subset or [c()] changes it. The `wt_truncated` flag describes the weights as +#' and subassignment, re-indexed through the subscript of `[`, and dropped by +#' any other slice and by a combine of several inputs. The `wt_truncated` flag describes the weights as #' a whole and is kept through all of those, so `is_wt_truncated()` keeps its #' answer where `is_unit_wt_truncated()` has none to give. #' @@ -1146,7 +1151,7 @@ vec_arith.psw.psw <- function(op, x, y, ...) { vec_arith.psw.MISSING <- function(op, x, y, ...) { switch( op, - `-` = vec_restore(-1 * vec_data(x), x), # Returns psw (preserves class) + `-` = restore_psw(-1 * vec_data(x), x, in_place = TRUE), `+` = x, # Returns psw unchanged stop_incompatible_op(op, x, y) ) @@ -1156,21 +1161,21 @@ vec_arith.psw.MISSING <- function(op, x, y, ...) { #' @method vec_arith.psw numeric vec_arith.psw.numeric <- function(op, x, y, ...) { result <- vec_arith_base(op, x, y) - vec_restore(result, x) + restore_psw(result, x, in_place = TRUE) } #' @export #' @method vec_arith.numeric psw vec_arith.numeric.psw <- function(op, x, y, ...) { result <- vec_arith_base(op, x, y) - vec_restore(result, y) + restore_psw(result, y, in_place = TRUE) } #' @export #' @method vec_arith.psw integer vec_arith.psw.integer <- function(op, x, y, ...) { result <- vec_arith_base(op, x, y) - vec_restore(result, x) + restore_psw(result, x, in_place = TRUE) } # The estimand a caller records, checked where it is recorded. It names the @@ -1341,15 +1346,36 @@ psw_exposure_attrs <- c("exposure_type", "density_meta", "numerator_model") # that keeps the record lets the restore building the real result carry it on to # the observations. # -# Any same-length operation keeps indices that may no longer point where they -# did, a reordering or a subscript with duplicates included. Nothing rebuilding -# a psw is handed the subscript, so neither can be told apart from an untouched -# vector here. `is_unit_trimmed()` checks the record covers the vector it is -# given, which catches a length change from any route, but a same-length -# rearrangement is beyond what either can see and is documented rather than -# guarded. -modification_meta_aligns <- function(n, to) { - n == 0 || n == length(to) +# Data at `to`'s length is not enough on its own. A slice that reorders the +# units arrives at the same length as one that leaves them where they were, and +# a restore is not handed the subscript that would tell the two apart. So the +# indices are kept only where the caller vouches that every unit is still at its +# position (`in_place`): elementwise arithmetic, and truncating the weights +# themselves. `[` knows its subscript and re-indexes the records itself +# (`reindex_psw_records()`). Every other restore of observations drops them. +modification_meta_aligns <- function(n, to, in_place = FALSE) { + n == 0 || (in_place && n == length(to)) +} + +# `i` holds the positions in `x` the result is built from, in the order it holds +# them. A record that covers `x` is re-indexed onto them; one that does not +# cannot be placed and is dropped, as a restore drops it. +reindex_psw_records <- function(attrs, x, i) { + n_obs <- length(x) + reindex <- list( + ps_trim_meta = reindex_trim_record, + ps_trunc_meta = reindex_trunc_record, + psw_trunc_meta = reindex_trunc_record + ) + + for (field in psw_modification_meta) { + meta <- attr(x, field) + attrs[field] <- list( + if (record_covers(meta, n_obs)) reindex[[field]](meta, i) + ) + } + + attrs } # What the joint record can still say once data has arrived at `n` observations. @@ -1459,7 +1485,7 @@ conflicted_psw_attrs <- function(x) { # observations. One indexed by observation that does not describe `n` of them is # reported as absent, so a later read sees nothing rather than a record silently # misaligned with the weights. -aligned_psw_attrs <- function(to, n) { +aligned_psw_attrs <- function(to, n, in_place = FALSE, i = NULL) { attrs <- lapply(psw_carried_attrs, function(attribute) attr(to, attribute)) names(attrs) <- psw_carried_attrs @@ -1467,7 +1493,9 @@ aligned_psw_attrs <- function(to, n) { attrs["stabilization_score"] <- list(NULL) } - if (!modification_meta_aligns(n, to)) { + if (!is.null(i)) { + attrs <- reindex_psw_records(attrs, to, i) + } else if (!modification_meta_aligns(n, to, in_place)) { attrs[psw_modification_meta] <- list(NULL) } @@ -1524,7 +1552,9 @@ build_psw <- function( out } -carry_psw_metadata <- function(x, to) { +# `in_place` and `i` say how the data relates to `to`'s units; see +# `modification_meta_aligns()` and `reindex_psw_records()`. +carry_psw_metadata <- function(x, to, in_place = FALSE, i = NULL) { build_psw( x, estimand = estimand(to), @@ -1533,7 +1563,7 @@ carry_psw_metadata <- function(x, to) { truncated = is_ps_truncated(to), calibrated = is_ps_calibrated(to), wt_truncated = is_wt_truncated(to), - attrs = aligned_psw_attrs(to, length(x)) + attrs = aligned_psw_attrs(to, length(x), in_place = in_place, i = i) ) } @@ -1585,8 +1615,9 @@ psw_numerator_record <- function(x, attrs) { # dropped, and is named in `conflicted` rather than `conflicts` so it is not # reported a second time. merge_psw_attrs <- function(x, y, n, fields = psw_carried_attrs) { - x_attrs <- aligned_psw_attrs(x, n) - y_attrs <- aligned_psw_attrs(y, n) + # Two operands combine elementwise, so each unit stays at its position. + x_attrs <- aligned_psw_attrs(x, n, in_place = TRUE) + y_attrs <- aligned_psw_attrs(y, n, in_place = TRUE) x_attrs["numerator_model"] <- list(psw_numerator_record(x, x_attrs)) y_attrs["numerator_model"] <- list(psw_numerator_record(y, y_attrs)) dropped <- union(conflicted_psw_attrs(x), conflicted_psw_attrs(y)) @@ -1775,6 +1806,13 @@ c.psw <- function(..., recursive = FALSE, use.names = TRUE) { #' @export vec_restore.psw <- function(x, to, ...) { + restore_psw(x, to) +} + +# The restore, for callers that can say more about the data than vctrs can: +# `in_place` vouches that every unit is still at its position, so the position +# records stay. +restore_psw <- function(x, to, in_place = FALSE) { # Extract numeric data if needed if (inherits(x, "psw")) { x <- vec_data(x) @@ -1812,7 +1850,27 @@ vec_restore.psw <- function(x, to, ...) { ) } - carry_psw_metadata(x, to) + carry_psw_metadata(x, to, in_place = in_place) +} + +# `[` is the one slice that knows its subscript, so it carries the position +# records through it rather than leaving the restore behind `NextMethod()` to +# drop them. An empty result is left as that restore builds it, since a +# prototype keeps the records it was sliced with. +#' @export +`[.psw` <- function(x, i, ...) { + out <- NextMethod() + if (!inherits(out, "psw") || length(out) == 0) { + return(out) + } + + i <- if (missing(i)) { + seq_along(x) + } else { + vec_as_location(i, n = length(x), names = names(x)) + } + + carry_psw_metadata(vec_data(out), x, i = i) } # What a psw is, as opposed to which observations it holds: the estimand the @@ -1951,7 +2009,10 @@ cast_to_psw <- function(x, to) { x <- vec_cast(vec_data(x), to = double()) attributes(x) <- NULL - carry_psw_metadata(x, to) + # A cast moves no unit, so it leaves the records as it found them. Outside + # subassignment, where base R keeps the target's own attributes regardless, + # `to` is a prototype and holds no observations for a record to describe. + carry_psw_metadata(x, to, in_place = TRUE) } # A cast returns `x`'s values in `to`'s type, and a psw's type is the whole diff --git a/R/wt_trunc.R b/R/wt_trunc.R index b927cee2..097b4003 100644 --- a/R/wt_trunc.R +++ b/R/wt_trunc.R @@ -386,7 +386,7 @@ truncate_weights <- function(.weights, method, lower, upper, call) { n_obs = length(x) ) - out <- vec_restore(x, .weights) + out <- restore_psw(x, .weights, in_place = TRUE) estimand <- estimand(.weights) if (!is.null(estimand)) { attr(out, "estimand") <- paste0(estimand, "; weights truncated") diff --git a/man/is_unit_trimmed.Rd b/man/is_unit_trimmed.Rd index e7885142..529401c4 100644 --- a/man/is_unit_trimmed.Rd +++ b/man/is_unit_trimmed.Rd @@ -37,9 +37,9 @@ object the record was written for instead. That check counts observations, which a reordering does not change, so it does not catch one. A \code{ps_trim} reordered through vctrs rather than through \code{[}, by \code{vctrs::vec_slice(x, 5:1)} or \code{dplyr::arrange()}, keeps a record -written for the old order, and a \code{psw} keeps one through any same-length -operation, a reordering included. \code{is_unit_trimmed()} answers from those -positions and names the wrong units. See \code{\link[=ps_trim]{ps_trim()}} and \link{psw} for the +written for the old order, and \code{is_unit_trimmed()} answers from those +positions and names the wrong units. A \code{psw} drops its record on those +routes instead. See \code{\link[=ps_trim]{ps_trim()}} and \link{psw} for the whole contract. } \examples{ diff --git a/man/is_unit_truncated.Rd b/man/is_unit_truncated.Rd index 691bad92..0e85c5ca 100644 --- a/man/is_unit_truncated.Rd +++ b/man/is_unit_truncated.Rd @@ -36,9 +36,9 @@ all, rather than name truncated units at stale positions. Query the That check counts observations, which a reordering does not change, so it does not catch one. An operation that reorders through vctrs rather than through \code{[}, such as \code{vctrs::vec_slice(x, 5:1)} or \code{dplyr::arrange()}, -keeps a record written for the old order, and a \code{psw} keeps one through any -same-length operation, a reordering included. \code{is_unit_truncated()} answers -from those positions and names the wrong units. See \code{\link[=ps_trunc]{ps_trunc()}} and \link{psw} +keeps a record written for the old order, and \code{is_unit_truncated()} +answers from those positions and names the wrong units. A \code{psw} drops its +record on those routes instead. See \code{\link[=ps_trunc]{ps_trunc()}} and \link{psw} for the whole contract. } \examples{ diff --git a/man/is_wt_truncated.Rd b/man/is_wt_truncated.Rd index 2f08c68b..7aca6bdf 100644 --- a/man/is_wt_truncated.Rd +++ b/man/is_wt_truncated.Rd @@ -36,8 +36,8 @@ attribute, holding the method, the bound as given and as applied, and the positions of the weights it moved. \code{is_unit_wt_truncated()} answers from those positions, so the record follows the rules \link{psw} describes for the records a modified propensity score leaves: it is kept through arithmetic -and anything else that keeps the length of the weights, and dropped when a -subset or \code{\link[=c]{c()}} changes it. The \code{wt_truncated} flag describes the weights as +and subassignment, re-indexed through the subscript of \code{[}, and dropped by +any other slice and by a combine of several inputs. The \code{wt_truncated} flag describes the weights as a whole and is kept through all of those, so \code{is_wt_truncated()} keeps its answer where \code{is_unit_wt_truncated()} has none to give. diff --git a/man/psw.Rd b/man/psw.Rd index 55c9b90d..2afb59f3 100644 --- a/man/psw.Rd +++ b/man/psw.Rd @@ -210,15 +210,20 @@ and an ungrouped \code{dplyr::reframe()} all rebuild the column, so a later the result refuses it. Subsetting with \code{[} preserves class and attributes for vector subscripts. -Two kinds of attribute hold one value per observation and so cannot be -re-indexed for a subset: a \code{stabilization_score} with more than one value, -and the records left by a trimmed or truncated propensity score -(\code{ps_trim_meta} and \code{ps_trunc_meta}) or by truncating the weights -themselves (\code{psw_trunc_meta}). Where an operation goes through -vctrs, these are carried when the result comes back at the length they were -recorded on and dropped when it does not. Any same-length operation keeps -them, a reordering or a subscript with duplicates included, so the positions -a record names can end up describing different observations than they did. +Two kinds of attribute hold one value per observation. The records left by +a trimmed or truncated propensity score (\code{ps_trim_meta} and +\code{ps_trunc_meta}) or by truncating the weights themselves +(\code{psw_trunc_meta}) name units by position, and \code{[} is handed the subscript, +so it re-indexes each record onto the result: \code{rev()}, \code{sort()}, +\code{x[order(x)]}, and a shorter subset all return records naming the units at +their new positions. Any other operation through vctrs is not handed a +subscript, so it keeps the records only where every unit stays at its +position, as in elementwise arithmetic, and otherwise drops them, at any +length: \code{vctrs::vec_slice()}, \code{dplyr::arrange()}, \code{dplyr::filter()}, and +\code{unique()} all return weights without them. Subassignment with \verb{[<-} moves +no unit and keeps them. A \code{stabilization_score} with more than one value is +carried when the result comes back at the length it was recorded on and +dropped when it does not. Dropping the \code{stabilization_score} warns, because the score was supplied by the user and the weights can be recomputed on the subset. Dropping a From 0e2965d1811d50c5aa8d67f5504c40cc2915fdda Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 10:25:56 -0400 Subject: [PATCH 47/64] speed up record reindexing, dose trimming and wt_trunc() --- R/ps_trim.R | 62 +++++++++++++++++++++++----------------- R/ps_trunc.R | 12 +++++--- R/psw.R | 9 ++++-- R/utils.R | 11 +++++-- R/wt_trunc.R | 33 +++++++++++++-------- R/wt_trunc_sensitivity.R | 24 ++++++++++++---- man/wt_trunc.Rd | 3 +- 7 files changed, 101 insertions(+), 53 deletions(-) diff --git a/R/ps_trim.R b/R/ps_trim.R index f0ee3751..26c94e78 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -658,14 +658,14 @@ ps_trim.default <- function( # A score that arrived missing is not one this function can place against a # cutoff, so it takes no part in working the cutoff out and no part in the - # record. Every rule below compares scores with `which()`, which leaves a - # missing comparison out of the retained positions on its own; the trimmed - # positions are then everything else that was observed. + # record. Every rule below compares scores, and `which()` leaves a missing + # comparison out of the retained positions on its own. The trimmed positions + # are then everything else that was observed. observed <- !is.na(.propensity) # Decide which indices are kept if (method == "ps") { - keep_idx <- which(.propensity >= lower & .propensity <= upper) + keep <- .propensity >= lower & .propensity <= upper } else if (method == "adaptive") { sum_wt <- 1 / (.propensity[observed] * (1 - .propensity[observed])) k <- 2 * mean(sum_wt) - max(sum_wt) @@ -682,7 +682,7 @@ ps_trim.default <- function( cutoff <- 0.5 - sqrt(0.25 - 1 / lambda) } meta_list$cutoff <- cutoff - keep_idx <- which(pmin(.propensity, 1 - .propensity) > cutoff) + keep <- pmin(.propensity, 1 - .propensity) > cutoff } else if (method == "pctl") { # `quantile()` names its result for the probability it was asked for, which # says nothing about the cutoff and reappears wherever the cutoff is printed @@ -691,7 +691,7 @@ ps_trim.default <- function( q_upper <- unname(quantile(.propensity, probs = upper, na.rm = TRUE)) meta_list$q_lower <- q_lower meta_list$q_upper <- q_upper - keep_idx <- which(.propensity >= q_lower & .propensity <= q_upper) + keep <- .propensity >= q_lower & .propensity <= q_upper } else if (method == "pref") { if (is.null(.exposure)) { abort( @@ -710,7 +710,7 @@ ps_trim.default <- function( prop_exposure <- mean(.exposure, na.rm = TRUE) pref_score <- plogis(qlogis(.propensity) - qlogis(prop_exposure)) meta_list$P <- prop_exposure - keep_idx <- which(pref_score >= lower & pref_score <= upper) + keep <- pref_score >= lower & pref_score <= upper } else if (method == "cr") { if (is.null(.exposure)) { abort( @@ -734,10 +734,13 @@ ps_trim.default <- function( meta_list$cr_lower <- cr_lower meta_list$cr_upper <- cr_upper - keep_idx <- which(.propensity >= cr_lower & .propensity <= cr_upper) + keep <- .propensity >= cr_lower & .propensity <= cr_upper } - trimmed_idx <- setdiff(seq_len(n), c(keep_idx, which(!observed))) + # `keep` is missing only where the score is, which `observed` already rules + # out. + keep_idx <- which(keep) + trimmed_idx <- which(observed & !keep) # Replace trimmed entries with NA ps_na <- .propensity @@ -847,11 +850,10 @@ ps_trim.matrix <- function( # A row with a missing score has no complete probability vector to place # against a threshold, so it takes no part in working the threshold out and no - # part in the record. Both rules below compare rows with `which()`, which - # leaves a missing comparison out of the retained positions on its own, and the + # part in the record. Both rules below compare rows, and `which()` leaves a + # missing comparison out of the retained positions on its own. The # group-preservation reset falls back to the complete rows for the same reason. - incomplete_rows <- which(apply(.propensity, 1, anyNA)) - complete_rows <- setdiff(seq_len(n), incomplete_rows) + complete <- !apply(.propensity, 1, anyNA) # Initialize metadata meta_list <- list(method = method, is_matrix = TRUE) @@ -884,16 +886,16 @@ ps_trim.matrix <- function( } # Apply symmetric trimming rule: keep if min(propensity scores) > delta - keep_idx <- which(apply(.propensity, 1, function(x) min(x) > delta)) + keep <- apply(.propensity, 1, function(x) min(x) > delta) # Check if all treatment groups are preserved - if (length(unique(.exposure[keep_idx])) < k) { + if (length(unique(.exposure[which(keep)])) < k) { warn( "One or more groups removed after trimming; returning original data", warning_class = "propensity_no_data_warning", call = call ) - keep_idx <- complete_rows + keep <- complete } meta_list$delta <- delta @@ -902,7 +904,7 @@ ps_trim.matrix <- function( # Multi-category optimal trimming (Yang et al., 2016) # Calculate sum of inverse propensity scores sum_inv_ps <- rowSums(1 / .propensity) - sum_inv_complete <- sum_inv_ps[complete_rows] + sum_inv_complete <- sum_inv_ps[complete] # Define trimming function trim_fun <- function(x) { @@ -917,7 +919,7 @@ ps_trim.matrix <- function( if (trim_fun(max(sum_inv_complete)) < 0) { # No valid solution, use maximum + 1 lambda <- max(sum_inv_complete) + 1 - keep_idx <- complete_rows # Keep all + keep <- complete # Keep all } else { # Find optimal lambda result <- tryCatch( @@ -940,20 +942,20 @@ ps_trim.matrix <- function( if (!is.null(result)) { lambda <- result - keep_idx <- which(sum_inv_ps <= lambda) + keep <- sum_inv_ps <= lambda # Check if all treatment groups are preserved - if (length(unique(.exposure[keep_idx])) < k) { + if (length(unique(.exposure[which(keep)])) < k) { warn( "One or more groups removed after trimming; returning original data", warning_class = "propensity_no_data_warning", call = call ) - keep_idx <- complete_rows + keep <- complete lambda <- NULL } } else { - keep_idx <- complete_rows + keep <- complete lambda <- NULL } } @@ -961,7 +963,10 @@ ps_trim.matrix <- function( meta_list$lambda <- lambda } - trimmed_idx <- setdiff(seq_len(n), c(keep_idx, incomplete_rows)) + # `keep` is missing only on an incomplete row, which `complete` already rules + # out. + keep_idx <- which(keep) + trimmed_idx <- which(complete & !keep) # Replace trimmed entries with NA ps_na <- .propensity @@ -1516,16 +1521,19 @@ ps_trim_dose <- function( # `quantile()` names its result for the probability it was asked for, which # says nothing about the floor. threshold <- unname(stats::quantile(f, probs = lower, na.rm = TRUE)) - keep_idx <- which(f >= threshold) + keep <- f >= threshold } else { # For a symmetric unimodal density the bound on `|z|` is a floor on the # density written in residual units, and the floor is what is recorded, so # that both methods describe the same kind of cut. threshold <- density_eval(density, upper, call = call) / sigma - keep_idx <- which(abs(z) <= upper) + keep <- abs(z) <= upper } - trimmed_idx <- setdiff(which(observed), keep_idx) + # `keep` is missing only where the density is, which `observed` already rules + # out. + keep_idx <- which(keep) + trimmed_idx <- which(observed & !keep) values <- mu values[trimmed_idx] <- NA_real_ @@ -3109,7 +3117,7 @@ refit_dose_trim <- function(meta, refit_model, data_sub, n_obs) { # exactly the rows it analyzed. A `subset` or a covariate missing on a kept # row leaves fewer of those than there are kept rows. if (!identical(meta$sigma_kind, "supplied")) { - residuals <- as.numeric(stats::residuals(refit_model, type = "response")) + residuals <- unname(stats::residuals(refit_model, type = "response")) meta$sigma <- density_scale_estimate( residuals[!is.na(residuals)], meta$density diff --git a/R/ps_trunc.R b/R/ps_trunc.R index 6af6b6ab..ffcbecef 100644 --- a/R/ps_trunc.R +++ b/R/ps_trunc.R @@ -1283,6 +1283,13 @@ carry_trunc_record <- function(meta, n_obs, i) { } } +# Whether each unit a covering record describes was moved onto a bound. +trunc_unit_status <- function(meta) { + status <- logical(meta$n_obs) + status[meta$truncated_idx] <- TRUE + status +} + # A positional query reads its answer out of the record, so a record that does # not cover the object in front of it has no answer to give: reporting every # unit as untouched would be a wrong answer rather than a missing one. @@ -1901,10 +1908,7 @@ unique.ps_trunc <- function(x, incomparables = FALSE, ...) { # them. if ( record_covers(meta, vec_size(values)) && - !merged_units_agree( - values, - seq_len(vec_size(values)) %in% meta$truncated_idx - ) + !merged_units_agree(values, trunc_unit_status(meta)) ) { attr(out, "ps_trunc_meta") <- drop_trunc_record(meta) } diff --git a/R/psw.R b/R/psw.R index d641ed84..852e7b45 100644 --- a/R/psw.R +++ b/R/psw.R @@ -1856,11 +1856,16 @@ restore_psw <- function(x, to, in_place = FALSE) { # `[` is the one slice that knows its subscript, so it carries the position # records through it rather than leaving the restore behind `NextMethod()` to # drop them. An empty result is left as that restore builds it, since a -# prototype keeps the records it was sliced with. +# prototype keeps the records it was sliced with, and so are weights with no +# position record to carry. #' @export `[.psw` <- function(x, i, ...) { out <- NextMethod() - if (!inherits(out, "psw") || length(out) == 0) { + if ( + !inherits(out, "psw") || + length(out) == 0 || + !any(psw_modification_meta %in% names(attributes(x))) + ) { return(out) } diff --git a/R/utils.R b/R/utils.R index 747435fe..eeee07cd 100644 --- a/R/utils.R +++ b/R/utils.R @@ -297,9 +297,16 @@ merged_units_agree <- function(values, status) { # `[` knows the subscript, which is what re-indexing a record takes. Every # occurrence of a recorded position is mapped onto the position it now holds, so # a subscript naming a position twice reports that unit twice. `NA` names no -# position, so an element taken by one falls in neither set. +# position, so an element taken by one falls in neither set, and neither does +# one taken from past the last recorded position. +# +# `i` holds positions as `vec_as_location()` returns them, positive or `NA`. A +# zero or negative value would drop or exclude elements of the mask rather than +# name a position. reindex_positions <- function(positions, i) { - which(i %in% positions) + mask <- logical(max(c(positions, 0L))) + mask[positions] <- TRUE + which(mask[i]) } # The rows `x[i, ]` is built from, as positions in `x`, which is the form a diff --git a/R/wt_trunc.R b/R/wt_trunc.R index 097b4003..7181a09e 100644 --- a/R/wt_trunc.R +++ b/R/wt_trunc.R @@ -144,7 +144,8 @@ #' bound. What the bound bought was precision: a root mean squared error of #' 0.084 against 0.096, for a bias of 0.015 (3% of the effect) against 0.012. #' At an effective sample size of 53% it covered 0.847 against 0.839 -#' untruncated, and at 81% it changed nothing. A density trim at +#' untruncated, and at 81% it changed almost nothing (it applied in 0.2% of +#' replications, leaving coverage and RMSE unchanged). A density trim at #' `lower = 0.01` covered 0.843 at 64%, below the untruncated weights. #' #' With t(4) or Laplace residuals, or a residual spread that varied with a @@ -356,14 +357,20 @@ abort_wt_trunc_dims <- function(.weights, call = rlang::caller_env()) { truncate_weights <- function(.weights, method, lower, upper, call) { # A psw holds doubles, and `vec_data()` keeps the names the weights carry. x <- vec_data(.weights) - present <- x[!is.na(x)] + # The adaptive bound reads only how many weights are present, so only the + # methods that read their values pay for collecting them. bounds <- switch( method, - adaptive = wt_trunc_adaptive_bounds(present, lower, upper, call = call), + adaptive = wt_trunc_adaptive_bounds( + sum(!is.na(x)), + lower, + upper, + call = call + ), wt = wt_trunc_wt_bounds(lower, upper, call = call), - pctl = wt_trunc_pctl_bounds(present, lower, upper, call = call), - count = wt_trunc_count_bounds(present, lower, upper, call = call) + pctl = wt_trunc_pctl_bounds(x[!is.na(x)], lower, upper, call = call), + count = wt_trunc_count_bounds(x[!is.na(x)], lower, upper, call = call) ) # A missing weight compares as neither above nor below a bound, and `which()` @@ -404,7 +411,7 @@ truncate_weights <- function(.weights, method, lower, upper, call) { out } -wt_trunc_adaptive_bounds <- function(present, lower, upper, call) { +wt_trunc_adaptive_bounds <- function(n_present, lower, upper, call) { if (!is.null(lower) || !is.null(upper)) { warn( c( @@ -417,13 +424,13 @@ wt_trunc_adaptive_bounds <- function(present, lower, upper, call) { ) } - check_wt_trunc_n_present(present, "adaptive", call = call) + check_wt_trunc_n_present(n_present, "adaptive", call = call) list( lower = NULL, upper = NULL, lower_value = NULL, - upper_value = adaptive_weight_bound(length(present)) + upper_value = adaptive_weight_bound(n_present) ) } @@ -500,7 +507,7 @@ wt_trunc_pctl_bounds <- function(present, lower, upper, call) { ) } - check_wt_trunc_n_present(present, "pctl", call = call) + check_wt_trunc_n_present(length(present), "pctl", call = call) # `quantile()` names its result for the probability, which says nothing # about the bound and would reappear wherever the bound is compared. @@ -543,7 +550,10 @@ wt_trunc_count_bounds <- function(present, lower, upper, call) { ) } - sorted <- sort(present) + # Only the order statistics at the two bounds are read, and a partial sort + # places exactly those, ties included, where a full sort would. + at <- c(if (!is.null(lower)) lower + 1, n - upper) + sorted <- sort(present, partial = at) lower_value <- NULL if (!is.null(lower)) { lower_value <- sorted[[lower + 1]] @@ -632,8 +642,7 @@ wt_trunc_bound_arg <- function(value, arg, method, call) { as.double(value) } -check_wt_trunc_n_present <- function(present, method, call) { - n <- length(present) +check_wt_trunc_n_present <- function(n, method, call) { if (n >= 2) { return(invisible(TRUE)) } diff --git a/R/wt_trunc_sensitivity.R b/R/wt_trunc_sensitivity.R index 6c934675..c40f5e22 100644 --- a/R/wt_trunc_sensitivity.R +++ b/R/wt_trunc_sensitivity.R @@ -143,7 +143,19 @@ wt_trunc_sensitivity <- function( n_truncated = 0L ) - vec_rbind(reference, !!!rows) + wt_trunc_sensitivity_table(c(list(reference), rows)) +} + +# The rows are summarised as plain lists and stacked once. Every row holds the +# same fields, each a single value, and the first row's missing bounds are +# doubles, so a column holds doubles wherever any row does. +wt_trunc_sensitivity_table <- function(rows) { + columns <- lapply(names(rows[[1]]), function(field) { + unlist(lapply(rows, `[[`, field), use.names = FALSE) + }) + names(columns) <- names(rows[[1]]) + + tibble::new_tibble(columns, nrow = length(rows)) } check_wt_trunc_sensitivity_weights <- function(.weights, call) { @@ -302,15 +314,17 @@ wt_trunc_sensitivity_summary <- function( ) { # The names a psw carries identify units, not rows of the table. present <- unname(present) - tibble::tibble( + min <- min(present) + max <- max(present) + list( lower = lower, upper = upper, lower_value = lower_value, upper_value = upper_value, n_truncated = n_truncated, - min = min(present), - max = max(present), - range_ratio = max(present) / min(present), + min = min, + max = max, + range_ratio = max / min, mean = mean(present) ) } diff --git a/man/wt_trunc.Rd b/man/wt_trunc.Rd index 81eae4ac..c7bca1ae 100644 --- a/man/wt_trunc.Rd +++ b/man/wt_trunc.Rd @@ -174,7 +174,8 @@ interval. The M-estimation interval on the untruncated weights covered bound. What the bound bought was precision: a root mean squared error of 0.084 against 0.096, for a bias of 0.015 (3\% of the effect) against 0.012. At an effective sample size of 53\% it covered 0.847 against 0.839 -untruncated, and at 81\% it changed nothing. A density trim at +untruncated, and at 81\% it changed almost nothing (it applied in 0.2\% of +replications, leaving coverage and RMSE unchanged). A density trim at \code{lower = 0.01} covered 0.843 at 64\%, below the untruncated weights. With t(4) or Laplace residuals, or a residual spread that varied with a From a0a9fe59fe431cae306fe41f10552fdad544330a Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 10:56:41 -0400 Subject: [PATCH 48/64] keep the non-positional part of a weight record when its positions are dropped --- NAMESPACE | 1 + NEWS.md | 16 +- R/psw.R | 82 +++++- R/wt_trunc.R | 22 +- man/psw.Rd | 18 +- tests/testthat/_snaps/wt-trunc.md | 4 +- tests/testthat/helper-records.R | 17 ++ tests/testthat/test-causal-wts-provenance.R | 2 +- tests/testthat/test-combine-single-modified.R | 38 ++- tests/testthat/test-psw-record-positions.R | 275 ++++++++++++++++++ tests/testthat/test-psw-reorder-records.R | 18 +- tests/testthat/test-psw-wt-trunc.R | 21 +- tests/testthat/test-psw.R | 17 +- tests/testthat/test-wt-trunc.R | 2 +- 14 files changed, 461 insertions(+), 72 deletions(-) create mode 100644 tests/testthat/helper-records.R create mode 100644 tests/testthat/test-psw-record-positions.R diff --git a/NAMESPACE b/NAMESPACE index d5334234..7615b8d7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,7 @@ S3method("[",ps_trim_matrix) S3method("[",ps_trunc) S3method("[",ps_trunc_matrix) S3method("[",psw) +S3method("is.na<-",psw) S3method(Summary,ps_calib) S3method(Summary,ps_trim) S3method(Summary,ps_trunc) diff --git a/NEWS.md b/NEWS.md index 1d7d5142..5a190b04 100644 --- a/NEWS.md +++ b/NEWS.md @@ -171,11 +171,17 @@ unchanged, so `is_unit_trimmed()`, `is_unit_truncated()`, and `is_unit_wt_truncated()` named the units that had been at those positions before; a shorter subset previously dropped them. A slice that is not handed - its subscript, such as `vctrs::vec_slice()`, `dplyr::arrange()`, or - `dplyr::filter()`, now drops the positions silently at any length, and the - positional queries refuse the result with an error of class - `propensity_missing_meta_error`. Elementwise arithmetic and subassignment - keep the records. + its subscript, such as `vctrs::vec_slice()`, `dplyr::arrange()`, + `dplyr::filter()`, `rep_len()`, or `vctrs::vec_c()` of a single input, now + drops the positions silently at any length, and the positional queries + refuse the result with an error of class `propensity_missing_meta_error`. A + record whose positions are dropped keeps its method, bounds, and refit flag, + so `is_refit()`, the printed footer, and the bound check of a later combine + still read it. Elementwise arithmetic, `[<-`, and `is.na<-` keep the records + whole. `vctrs::vec_assign()` cannot be told apart from a slice, so it and the + helpers built on it or on a combine, such as `tidyr::replace_na()`, + `dplyr::coalesce()`, `dplyr::if_else()`, and `dplyr::case_when()`, drop the + positions. * `unique()` of a `ps_trim` or `ps_trunc` now drops the positions in its record when it merges units whose status differs, such as a trimmed score and diff --git a/R/psw.R b/R/psw.R index 852e7b45..1c5f4dd1 100644 --- a/R/psw.R +++ b/R/psw.R @@ -132,11 +132,19 @@ #' so it re-indexes each record onto the result: `rev()`, `sort()`, #' `x[order(x)]`, and a shorter subset all return records naming the units at #' their new positions. Any other operation through vctrs is not handed a -#' subscript, so it keeps the records only where every unit stays at its -#' position, as in elementwise arithmetic, and otherwise drops them, at any -#' length: `vctrs::vec_slice()`, `dplyr::arrange()`, `dplyr::filter()`, and -#' `unique()` all return weights without them. Subassignment with `[<-` moves -#' no unit and keeps them. A `stabilization_score` with more than one value is +#' subscript, so it keeps the positions only where every unit stays at its +#' place, as in elementwise arithmetic, and otherwise drops them, at any +#' length: `vctrs::vec_slice()`, `dplyr::arrange()`, `dplyr::filter()`, +#' `unique()`, `rep_len()`, and `vctrs::vec_c()` of a single input all return +#' weights whose records name no units. A dropped record keeps its method, its +#' bounds, and whether the model was refit, so [is_refit()], the printed +#' footer, and the bound comparison of a later combine still read it. +#' Subassignment with `[<-` and `is.na<-` moves no unit and keeps the records +#' whole. vctrs' own assignment, [vctrs::vec_assign()], reaches the same restore +#' a slice does and cannot be told apart from one, so it drops the positions, +#' and so do the helpers built on it or on a combine, such as +#' `tidyr::replace_na()`, `dplyr::coalesce()`, `dplyr::if_else()`, and +#' `dplyr::case_when()`. A `stabilization_score` with more than one value is #' carried when the result comes back at the length it was recorded on and #' dropped when it does not. #' @@ -1352,27 +1360,60 @@ psw_exposure_attrs <- c("exposure_type", "density_meta", "numerator_model") # indices are kept only where the caller vouches that every unit is still at its # position (`in_place`): elementwise arithmetic, and truncating the weights # themselves. `[` knows its subscript and re-indexes the records itself -# (`reindex_psw_records()`). Every other restore of observations drops them. +# (`reindex_psw_records()`). Every other restore of observations drops their +# positions. modification_meta_aligns <- function(n, to, in_place = FALSE) { n == 0 || (in_place && n == length(to)) } +# How each positional record is re-indexed onto a subscript, and how its +# positions are dropped. What a record says about the modification itself, its +# method, bounds, and whether the model was refit, names no unit and holds at +# any length and in any order, so a drop leaves it for the flags, the footer, and +# the bound comparison of a later combine to read. +reindex_psw_record <- function(field, meta, i) { + if (identical(field, "ps_trim_meta")) { + reindex_trim_record(meta, i) + } else { + reindex_trunc_record(meta, i) + } +} + +drop_psw_record <- function(field, meta) { + if (identical(field, "ps_trim_meta")) { + drop_trim_record(meta) + } else { + drop_trunc_record(meta) + } +} + +drop_psw_record_positions <- function(attrs) { + for (field in psw_modification_meta) { + meta <- attrs[[field]] + if (!is.null(meta)) { + attrs[[field]] <- drop_psw_record(field, meta) + } + } + + attrs +} + # `i` holds the positions in `x` the result is built from, in the order it holds # them. A record that covers `x` is re-indexed onto them; one that does not -# cannot be placed and is dropped, as a restore drops it. +# cannot be placed and loses its positions, as a restore drops them. reindex_psw_records <- function(attrs, x, i) { n_obs <- length(x) - reindex <- list( - ps_trim_meta = reindex_trim_record, - ps_trunc_meta = reindex_trunc_record, - psw_trunc_meta = reindex_trunc_record - ) for (field in psw_modification_meta) { meta <- attr(x, field) - attrs[field] <- list( - if (record_covers(meta, n_obs)) reindex[[field]](meta, i) - ) + if (is.null(meta)) { + next + } + attrs[[field]] <- if (record_covers(meta, n_obs)) { + reindex_psw_record(field, meta, i) + } else { + drop_psw_record(field, meta) + } } attrs @@ -1496,7 +1537,7 @@ aligned_psw_attrs <- function(to, n, in_place = FALSE, i = NULL) { if (!is.null(i)) { attrs <- reindex_psw_records(attrs, to, i) } else if (!modification_meta_aligns(n, to, in_place)) { - attrs[psw_modification_meta] <- list(NULL) + attrs <- drop_psw_record_positions(attrs) } attrs[psw_joint_attr] <- list( @@ -1878,6 +1919,15 @@ restore_psw <- function(x, to, in_place = FALSE) { carry_psw_metadata(vec_data(out), x, i = i) } +# Marking weights as missing moves no unit, so it goes through base `[<-`, which +# keeps every attribute of the weights, rather than through vctrs' method, whose +# restore cannot tell an assignment from a reordering and drops the positions. +#' @export +`is.na<-.psw` <- function(x, value) { + x[value] <- NA_real_ + x +} + # What a psw is, as opposed to which observations it holds: the estimand the # weights answer, whether they were stabilized and against what score, and which # modification of the propensity scores they were built from, and whether the diff --git a/R/wt_trunc.R b/R/wt_trunc.R index 7181a09e..3ed04cc4 100644 --- a/R/wt_trunc.R +++ b/R/wt_trunc.R @@ -670,14 +670,15 @@ abort_wt_trunc_range <- function( # One line describing the truncation for the printed footer, or `NULL` for # weights that were not truncated. The counts come from the record's positions, -# so a record that no longer covers the weights is not read for them. +# so a record that no longer covers the weights is read for its method and +# bounds alone. format_psw_trunc_line <- function(x) { if (!is_wt_truncated(x)) { return(NULL) } meta <- attr(x, "psw_trunc_meta") - if (!record_covers(meta, length(x))) { + if (is.null(meta)) { return("truncation: weights truncated") } @@ -697,15 +698,22 @@ format_psw_trunc_line <- function(x) { paste("upper", format(meta$upper_value, digits = 3)) ) + counts <- if (record_covers(meta, length(x))) { + paste0( + ", ", + length(meta$truncated_idx), + " of ", + meta$n_obs, + " weights truncated" + ) + } + paste0( "truncation: ", label, " (", paste(realized, collapse = ", "), - "), ", - length(meta$truncated_idx), - " of ", - meta$n_obs, - " weights truncated" + ")", + counts ) } diff --git a/man/psw.Rd b/man/psw.Rd index 2afb59f3..a049888e 100644 --- a/man/psw.Rd +++ b/man/psw.Rd @@ -217,11 +217,19 @@ a trimmed or truncated propensity score (\code{ps_trim_meta} and so it re-indexes each record onto the result: \code{rev()}, \code{sort()}, \code{x[order(x)]}, and a shorter subset all return records naming the units at their new positions. Any other operation through vctrs is not handed a -subscript, so it keeps the records only where every unit stays at its -position, as in elementwise arithmetic, and otherwise drops them, at any -length: \code{vctrs::vec_slice()}, \code{dplyr::arrange()}, \code{dplyr::filter()}, and -\code{unique()} all return weights without them. Subassignment with \verb{[<-} moves -no unit and keeps them. A \code{stabilization_score} with more than one value is +subscript, so it keeps the positions only where every unit stays at its +place, as in elementwise arithmetic, and otherwise drops them, at any +length: \code{vctrs::vec_slice()}, \code{dplyr::arrange()}, \code{dplyr::filter()}, +\code{unique()}, \code{rep_len()}, and \code{vctrs::vec_c()} of a single input all return +weights whose records name no units. A dropped record keeps its method, its +bounds, and whether the model was refit, so \code{\link[=is_refit]{is_refit()}}, the printed +footer, and the bound comparison of a later combine still read it. +Subassignment with \verb{[<-} and \verb{is.na<-} moves no unit and keeps the records +whole. vctrs' own assignment, \code{\link[vctrs:vec_assign]{vctrs::vec_assign()}}, reaches the same restore +a slice does and cannot be told apart from one, so it drops the positions, +and so do the helpers built on it or on a combine, such as +\code{tidyr::replace_na()}, \code{dplyr::coalesce()}, \code{dplyr::if_else()}, and +\code{dplyr::case_when()}. A \code{stabilization_score} with more than one value is carried when the result comes back at the length it was recorded on and dropped when it does not. diff --git a/tests/testthat/_snaps/wt-trunc.md b/tests/testthat/_snaps/wt-trunc.md index 11b30891..1e742372 100644 --- a/tests/testthat/_snaps/wt-trunc.md +++ b/tests/testthat/_snaps/wt-trunc.md @@ -89,14 +89,14 @@ ! For `method = 'count'`, `upper` must leave a weight below the ones it bounds. x `upper` is 9 and 9 weights are present. -# a subset that drops the record prints a truncation line without counts +# a slice that drops the record's positions prints the bound without counts Code vctrs::vec_slice(wt_trunc(w, method = "wt", upper = 3), 1:3) Output [1] 0.5 1.0 3.0 - truncation: weights truncated + truncation: wt (upper 3) # a subset re-indexes the record and prints the truncation counts diff --git a/tests/testthat/helper-records.R b/tests/testthat/helper-records.R new file mode 100644 index 00000000..cdaa739b --- /dev/null +++ b/tests/testthat/helper-records.R @@ -0,0 +1,17 @@ +# The fields of a trimming or truncation record that name units by position. +record_position_fields <- c("keep_idx", "trimmed_idx", "truncated_idx", "n_obs") + +# A record whose positions were dropped keeps everything it says about the +# modification itself, its method, bounds, and refit flag, and nothing about +# the units. +without_positions <- function(meta) { + for (field in record_position_fields) { + meta[[field]] <- NULL + } + meta +} + +expect_positions_dropped <- function(meta, original, info = NULL) { + expect_false(is.null(meta), info = info) + expect_identical(meta, without_positions(original), info = info) +} diff --git a/tests/testthat/test-causal-wts-provenance.R b/tests/testthat/test-causal-wts-provenance.R index 9ee02aa0..444dc1f2 100644 --- a/tests/testthat/test-causal-wts-provenance.R +++ b/tests/testthat/test-causal-wts-provenance.R @@ -346,7 +346,7 @@ test_that("subsetting a trimmed psw re-indexes the unit-level trimming index", { # from it. sliced <- expect_silent(vctrs::vec_slice(wt, 1:2)) expect_true(is_ps_trimmed(sliced)) - expect_null(ps_trim_meta(sliced)) + expect_positions_dropped(ps_trim_meta(sliced), ps_trim_meta(wt)) expect_error( is_unit_trimmed(sliced), class = "propensity_missing_meta_error" diff --git a/tests/testthat/test-combine-single-modified.R b/tests/testthat/test-combine-single-modified.R index 5aae0f4c..b7f1c28f 100644 --- a/tests/testthat/test-combine-single-modified.R +++ b/tests/testthat/test-combine-single-modified.R @@ -98,13 +98,16 @@ test_that("c() of one psw still refuses what vctrs refuses", { expect_error(c(x = w), "outer name") }) -test_that("vec_c() and list_unchop() of one trimmed psw drop the record", { +test_that("vec_c() and list_unchop() of one trimmed psw drop the record's positions", { # vctrs restores the result against a zero-length prototype, which cannot be # told apart from one a caller supplied for data from elsewhere. w <- single_trimmed_psw() from_vec_c <- vctrs::vec_c(w) - expect_null(attr(from_vec_c, "ps_trim_meta")) + expect_positions_dropped( + attr(from_vec_c, "ps_trim_meta"), + attr(w, "ps_trim_meta") + ) expect_true(is_ps_trimmed(from_vec_c)) expect_error( is_unit_trimmed(from_vec_c), @@ -112,7 +115,10 @@ test_that("vec_c() and list_unchop() of one trimmed psw drop the record", { ) from_unchop <- vctrs::list_unchop(list(w)) - expect_null(attr(from_unchop, "ps_trim_meta")) + expect_positions_dropped( + attr(from_unchop, "ps_trim_meta"), + attr(w, "ps_trim_meta") + ) expect_error( is_unit_trimmed(from_unchop), class = "propensity_missing_meta_error" @@ -200,14 +206,18 @@ test_that("c() of two truncated-score psw drops the truncation record", { # Each of these restores data that is not the weights' own, in their order, # against a zero-length prototype carrying the weights' records. None of the -# records describes the result. +# records' positions describes the result; what the records say about the +# trimming still does. expect_trim_record_dropped <- function(x) { - expect_null(attr(x, "ps_trim_meta")) + expect_positions_dropped( + attr(x, "ps_trim_meta"), + attr(single_trimmed_psw(), "ps_trim_meta") + ) expect_error(is_unit_trimmed(x), class = "propensity_missing_meta_error") } -test_that("reordered pieces combined at a supplied prototype drop the record", { +test_that("reordered pieces combined at a supplied prototype drop the record's positions", { w <- single_trimmed_psw() first <- suppressWarnings(w[1:10]) second <- suppressWarnings(w[11:20]) @@ -218,14 +228,14 @@ test_that("reordered pieces combined at a supplied prototype drop the record", { expect_trim_record_dropped(vctrs::vec_c(second, first, .ptype = w)) }) -test_that("other weights combined at a supplied prototype drop the record", { +test_that("other weights combined at a supplied prototype drop the record's positions", { w <- single_trimmed_psw() other <- suppressWarnings(rev(w)) expect_trim_record_dropped(vctrs::vec_c(other, .ptype = w)) }) -test_that("a cast to or an initialization at the prototype drops the record", { +test_that("a cast to or an initialization at the prototype drops the record's positions", { w <- single_trimmed_psw() expect_trim_record_dropped( @@ -234,7 +244,7 @@ test_that("a cast to or an initialization at the prototype drops the record", { expect_trim_record_dropped(vctrs::vec_init(w[0], 20)) }) -test_that("a supplied prototype drops the weight truncation record", { +test_that("a supplied prototype drops the weight truncation record's positions", { w <- single_wt_truncated_psw() first <- suppressWarnings(w[1:10]) second <- suppressWarnings(w[11:20]) @@ -243,14 +253,20 @@ test_that("a supplied prototype drops the weight truncation record", { list(second, first), ptype = vctrs::vec_ptype(w) ) - expect_null(attr(unchopped, "psw_trunc_meta")) + expect_positions_dropped( + attr(unchopped, "psw_trunc_meta"), + attr(w, "psw_trunc_meta") + ) expect_error( is_unit_wt_truncated(unchopped), class = "propensity_missing_meta_error" ) cast <- vctrs::vec_cast(seq(1, 2, length.out = 20), vctrs::vec_ptype(w)) - expect_null(attr(cast, "psw_trunc_meta")) + expect_positions_dropped( + attr(cast, "psw_trunc_meta"), + attr(w, "psw_trunc_meta") + ) expect_error( is_unit_wt_truncated(cast), class = "propensity_missing_meta_error" diff --git a/tests/testthat/test-psw-record-positions.R b/tests/testthat/test-psw-record-positions.R new file mode 100644 index 00000000..171f0535 --- /dev/null +++ b/tests/testthat/test-psw-record-positions.R @@ -0,0 +1,275 @@ +# What a weight record keeps when its positions are dropped ------------------ + +# A trimming, truncation, or weight truncation record says two kinds of thing: +# how the modification was made (its method, bounds, and refit flag) and which +# units it touched. A route that cannot place the units drops only the second. +# The first still describes the weights, so a later combine compares bounds +# against it, `is_refit()` reads it, and the footer prints it. + +count_truncated_psw <- function(upper) { + wt_trunc(psw(c(1, 2, 50, 3, 4, 5, 6, 7, 8, 100)), "count", upper = upper) +} + +# Units 1 and 4 fall outside the bounds; their weights are missing. +positions_trimmed_psw <- function() { + w <- psw(c(NA, 2, 1.6, NA, 3.3), estimand = "ate; trimmed", trimmed = TRUE) + attr(w, "ps_trim_meta") <- list( + method = "ps", + lower = 0.1, + upper = 0.9, + focal_inverted = FALSE, + keep_idx = c(2L, 3L, 5L), + trimmed_idx = c(1L, 4L), + n_obs = 5L, + refit = TRUE + ) + w +} + +positions_truncated_psw <- function() { + w <- psw( + c(10, 2, 1.6, 10, 3.3), + estimand = "ate; truncated", + truncated = TRUE + ) + attr(w, "ps_trunc_meta") <- list( + method = "ps", + lower_bound = 0.1, + upper_bound = 0.9, + truncated_idx = c(1L, 4L), + n_obs = 5L + ) + w +} + +positions_fixtures <- function() { + list( + trimmed = list( + weights = positions_trimmed_psw(), + attr = "ps_trim_meta", + query = is_unit_trimmed + ), + truncated = list( + weights = positions_truncated_psw(), + attr = "ps_trunc_meta", + query = is_unit_truncated + ), + wt_truncated = list( + weights = count_truncated_psw(2), + attr = "psw_trunc_meta", + query = is_unit_wt_truncated + ) + ) +} + +expect_fixture_positions_dropped <- function(out, fixture, label) { + expect_s3_class(out, "psw") + expect_positions_dropped( + attr(out, fixture$attr), + attr(fixture$weights, fixture$attr), + info = label + ) + expect_error( + fixture$query(out), + class = "propensity_missing_meta_error", + info = label + ) +} + +footer_lines <- function(x) { + utils::capture.output(print(x)) +} + +test_that("a combine still compares bounds after vec_slice() reorders one input", { + a <- count_truncated_psw(2) + b <- count_truncated_psw(1) + + expect_warning( + out <- vctrs::vec_c(vctrs::vec_slice(a, 10:1), b), + class = "propensity_coercion_warning" + ) + expect_false(is_psw(out)) + expect_type(out, "double") + + expect_warning( + out <- vctrs::vec_c(b, vctrs::vec_slice(a, 1:5)), + class = "propensity_coercion_warning" + ) + expect_false(is_psw(out)) +}) + +test_that("a combine still compares bounds after dplyr::arrange()", { + skip_if_not_installed("dplyr") + da <- data.frame(o = 10:1) + da$w <- count_truncated_psw(2) + db <- data.frame(o = 1:10) + db$w <- count_truncated_psw(1) + + expect_warning( + out <- dplyr::bind_rows(dplyr::arrange(da, o), db), + class = "propensity_coercion_warning" + ) + expect_false(is_psw(out$w)) +}) + +test_that("weights bounded alike still combine after a reordering slice", { + a <- count_truncated_psw(2) + + out <- expect_silent(vctrs::vec_c(vctrs::vec_slice(a, 10:1), a)) + expect_s3_class(out, "psw") + expect_true(is_wt_truncated(out)) +}) + +test_that("is_refit() answers for weights reordered by dplyr::arrange()", { + skip_if_not_installed("dplyr") + w <- positions_trimmed_psw() + expect_true(is_refit(w)) + + d <- data.frame(X = c(3, 1, 2, 5, 4)) + d$w <- w + out <- expect_silent(dplyr::arrange(d, X)) + + expect_true(is_refit(out$w)) + expect_true(is_refit(vctrs::vec_slice(w, 5:1))) + expect_error( + is_unit_trimmed(out$w), + class = "propensity_missing_meta_error" + ) +}) + +test_that("is_refit() answers for weights from a refit model after a reordering", { + skip_if_not_installed("dplyr") + set.seed(42) + n <- 60 + z <- rnorm(n) + x <- rbinom(n, 1, plogis(2 * z)) + fit <- glm(x ~ z, family = binomial()) + trimmed <- ps_trim( + predict(fit, type = "response"), + method = "ps", + lower = 0.2, + upper = 0.8 + ) + wt <- wt_ate( + ps_refit(trimmed, model = fit), + .exposure = x, + exposure_type = "binary", + .focal_level = 1 + ) + d <- data.frame(X = z) + d$w <- wt + + expect_true(is_refit(dplyr::arrange(d, X)$w)) +}) + +test_that("the footer prints the bound of a record whose positions were dropped", { + skip_if_not_installed("dplyr") + w <- count_truncated_psw(2) + expect_true(any( + footer_lines(w) == + "truncation: count 2 (upper 8), 2 of 10 weights truncated" + )) + + d <- data.frame(o = 10:1) + d$w <- w + arranged <- dplyr::arrange(d, o)$w + expect_true(any(footer_lines(arranged) == "truncation: count 2 (upper 8)")) + + sliced <- vctrs::vec_slice(w, 10:1) + expect_true(any(footer_lines(sliced) == "truncation: count 2 (upper 8)")) +}) + +test_that("the footer of flagged weights with no record names no bound", { + w <- psw(c(1, 2, 3), estimand = "ate", wt_truncated = TRUE) + + expect_true(any(footer_lines(w) == "truncation: weights truncated")) +}) + +# Assignment ------------------------------------------------------------------- + +test_that("is.na<- keeps each record, since every unit stays in place", { + for (label in names(positions_fixtures())) { + fixture <- positions_fixtures()[[label]] + w <- fixture$weights + meta <- attr(w, fixture$attr) + units <- fixture$query(w) + + expect_silent({ + is.na(w) <- 2 + }) + expect_s3_class(w, "psw") + expect_true(is.na(w[[2]]), info = label) + expect_identical(attr(w, fixture$attr), meta, info = label) + expect_identical(fixture$query(w), units, info = label) + + expect_silent({ + is.na(w) <- c(FALSE, FALSE, TRUE, rep(FALSE, length(w) - 3)) + }) + expect_true(is.na(w[[3]]), info = label) + expect_identical(attr(w, fixture$attr), meta, info = label) + } +}) + +test_that("is.na<- keeps the other attributes of the weights", { + w <- positions_trimmed_psw() + before <- attributes(w) + + is.na(w) <- 3 + + expect_identical(attributes(w)[names(before)], before) + expect_identical(vec_data(w), c(NA, 2, NA, NA, 3.3)) +}) + +test_that("vec_assign() drops each record's positions, since it cannot vouch for them", { + for (label in names(positions_fixtures())) { + fixture <- positions_fixtures()[[label]] + w <- fixture$weights + + out <- expect_silent(vctrs::vec_assign(w, 1L, 3)) + expect_fixture_positions_dropped(out, fixture, label) + expect_identical(vec_data(out)[[1]], 3, info = label) + } +}) + +test_that("vec_assign() based helpers drop the record's positions", { + skip_if_not_installed("dplyr") + skip_if_not_installed("tidyr") + fixture <- positions_fixtures()$trimmed + w <- fixture$weights + + replaced <- expect_silent(tidyr::replace_na(w, 0)) + expect_fixture_positions_dropped(replaced, fixture, "replace_na") + expect_identical(vec_data(replaced), c(0, 2, 1.6, 0, 3.3)) + + # These first combine their inputs into a common type, and a combined type + # carries no positional record at all. + combined <- list( + coalesce = expect_silent(dplyr::coalesce(w, w * 0)), + if_else = expect_silent(dplyr::if_else(is.na(w), w, w * 2)), + case_when = expect_silent(dplyr::case_when(is.na(w) ~ w, .default = w)) + ) + for (label in names(combined)) { + out <- combined[[label]] + expect_s3_class(out, "psw") + expect_true(is_ps_trimmed(out), info = label) + expect_null(attr(out, "ps_trim_meta")$trimmed_idx, info = label) + expect_error( + is_unit_trimmed(out), + class = "propensity_missing_meta_error", + info = label + ) + } +}) + +test_that("rep_len() and vec_c() of one input drop each record's positions", { + for (label in names(positions_fixtures())) { + fixture <- positions_fixtures()[[label]] + w <- fixture$weights + + out <- expect_silent(rep_len(w, length(w))) + expect_fixture_positions_dropped(out, fixture, label) + + out <- expect_silent(vctrs::vec_c(w)) + expect_fixture_positions_dropped(out, fixture, label) + } +}) diff --git a/tests/testthat/test-psw-reorder-records.R b/tests/testthat/test-psw-reorder-records.R index 449fc1da..f424f092 100644 --- a/tests/testthat/test-psw-reorder-records.R +++ b/tests/testthat/test-psw-reorder-records.R @@ -4,7 +4,8 @@ # A subscript moves units to new positions, so `[` and everything built on it # (`rev()`, `sort()`, `x[order(x)]`) carry each record through the subscript. # A slice that reaches the restore without its subscript, such as `vec_slice()` -# or `dplyr::arrange()`, cannot place the record and drops it silently. +# or `dplyr::arrange()`, cannot place the record and drops its positions +# silently, keeping what the record says about the modification itself. # Units 1 and 4 fall outside (0.1, 0.9); their weights are missing. reorder_trimmed_psw <- function() { @@ -93,7 +94,11 @@ expect_reindexed <- function(out, fixture, i, label) { expect_record_dropped <- function(out, fixture, label) { expect_s3_class(out, "psw") - expect_null(attr(out, fixture$attr), info = label) + expect_positions_dropped( + attr(out, fixture$attr), + attr(fixture$weights, fixture$attr), + info = label + ) expect_error( fixture$query(out), class = "propensity_missing_meta_error", @@ -269,13 +274,14 @@ test_that("an empty subscript leaves the prototype as the restore builds it", { } }) -test_that("a record that does not cover the weights is dropped by a subscript", { +test_that("a record that does not cover the weights loses its positions to a subscript", { w <- reorder_wt_truncated_psw() + meta <- attr(w, "psw_trunc_meta") w[12] <- 2 expect_length(w, 12) out <- expect_silent(w[rev(seq_along(w))]) - expect_null(attr(out, "psw_trunc_meta")) + expect_positions_dropped(attr(out, "psw_trunc_meta"), meta) expect_true(is_wt_truncated(out)) expect_error( is_unit_wt_truncated(out), @@ -283,7 +289,7 @@ test_that("a record that does not cover the weights is dropped by a subscript", ) }) -test_that("vec_slice() at the same length drops each position record silently", { +test_that("vec_slice() at the same length drops each record's positions silently", { for (label in names(reorder_fixtures())) { fixture <- reorder_fixtures()[[label]] w <- fixture$weights @@ -299,7 +305,7 @@ test_that("vec_slice() at the same length drops each position record silently", expect_true(is_wt_truncated(out)) }) -test_that("dplyr::arrange() on a psw column drops each position record silently", { +test_that("dplyr::arrange() on a psw column drops each record's positions silently", { skip_if_not_installed("dplyr") for (label in names(reorder_fixtures())) { diff --git a/tests/testthat/test-psw-wt-trunc.R b/tests/testthat/test-psw-wt-trunc.R index 4e3d20c7..75437790 100644 --- a/tests/testthat/test-psw-wt-trunc.R +++ b/tests/testthat/test-psw-wt-trunc.R @@ -163,9 +163,9 @@ test_that("a full-length psw subset keeps the weight truncation record", { expect_identical(is_unit_wt_truncated(whole), wt_truncated_units) # A slice is not handed to anything that knows its subscript, so even one - # that leaves every unit in place cannot vouch for the record. + # that leaves every unit in place cannot vouch for the record's positions. sliced <- expect_silent(vec_slice(w, seq_along(w))) - expect_null(attr(sliced, "psw_trunc_meta")) + expect_positions_dropped(attr(sliced, "psw_trunc_meta"), meta) expect_true(is_wt_truncated(sliced)) }) @@ -184,16 +184,19 @@ test_that("shortening a psw re-indexes the weight truncation record through `[`" expect_identical(is_unit_wt_truncated(sub), c(FALSE, TRUE)) }) -test_that("shortening a psw by a slice drops the weight truncation record and keeps the flag", { +test_that("shortening a psw by a slice drops the record's positions and keeps the flag", { w <- wt_truncated_psw() sliced <- expect_silent(vec_slice(w, 1:2)) - expect_null(attr(sliced, "psw_trunc_meta")) + expect_positions_dropped( + attr(sliced, "psw_trunc_meta"), + attr(w, "psw_trunc_meta") + ) expect_true(is_wt_truncated(sliced)) expect_identical(estimand(sliced), "ate") - # The record is gone, so the positional query has nothing to answer from and - # refuses rather than reporting every unit as untouched. + # The positions are gone, so the positional query has nothing to answer from + # and refuses rather than reporting every unit as untouched. expect_error( is_unit_wt_truncated(sliced), class = "propensity_missing_meta_error" @@ -497,10 +500,10 @@ test_that("weights bounded alike combine whichever units the bound moved", { }) test_that("a weight-truncated psw with no record agrees with any bound", { - # A record already dropped, by a slice or by an earlier combine, has nothing - # to disagree with, so only the flag is compared. + # Weights flagged as truncated with no record, as an earlier combine leaves + # them, have no bound to disagree with, so only the flag is compared. w <- wt_truncated_psw() - alt_slice <- vec_slice(alt_wt_truncated_psw(), 1:2) + alt_slice <- psw(c(1.2, 2.5), estimand = "ate", wt_truncated = TRUE) expect_null(attr(alt_slice, "psw_trunc_meta")) expect_true(is_wt_truncated(alt_slice)) diff --git a/tests/testthat/test-psw.R b/tests/testthat/test-psw.R index e6cb2d06..f4b9eabb 100644 --- a/tests/testthat/test-psw.R +++ b/tests/testthat/test-psw.R @@ -714,9 +714,9 @@ test_that("a full-length psw subset keeps the trimming record", { expect_identical(is_unit_trimmed(whole), c(TRUE, FALSE, FALSE, FALSE, TRUE)) # A slice is not handed to anything that knows its subscript, so even one - # that leaves every unit in place cannot vouch for the record. + # that leaves every unit in place cannot vouch for the record's positions. sliced <- expect_silent(vec_slice(w, seq_along(w))) - expect_null(ps_trim_meta(sliced)) + expect_positions_dropped(ps_trim_meta(sliced), meta) expect_true(is_ps_trimmed(sliced)) }) @@ -746,14 +746,13 @@ test_that("shortening a psw with `[` re-indexes the trimming record", { expect_identical(estimand(sub), "ate; trimmed") }) -test_that("shortening a psw by a slice drops the trimming record silently", { +test_that("shortening a psw by a slice drops the trimming record's positions silently", { w <- trimmed_psw() sliced <- expect_silent(vec_slice(w, 1:2)) expect_s3_class(sliced, "psw") expect_length(sliced, 2) - expect_null(ps_trim_meta(sliced)) - expect_null(attr(sliced, "ps_trim_meta")) + expect_positions_dropped(ps_trim_meta(sliced), ps_trim_meta(w)) # Everything that is not indexed by observation is untouched by the drop. expect_true(is_ps_trimmed(sliced)) @@ -770,7 +769,7 @@ test_that("shortening a psw re-indexes the truncation record through `[` and a s expect_true(is_ps_truncated(sub)) sliced <- expect_silent(vec_slice(truncated, 1:2)) - expect_null(ps_trunc_meta(sliced)) + expect_positions_dropped(ps_trunc_meta(sliced), meta) expect_true(is_ps_truncated(sliced)) expect_identical(ps_trunc_meta(truncated), meta) }) @@ -946,7 +945,7 @@ test_that("shortening a psw with a score and a trimming record warns only for th out <- collect_warning_classes(vec_slice(w, 1:2)) expect_identical(out$classes, "propensity_stabilization_score_warning") expect_null(stabilization_score(out$value)) - expect_null(ps_trim_meta(out$value)) + expect_positions_dropped(ps_trim_meta(out$value), ps_trim_meta(w)) expect_true(is_stabilized(out$value)) expect_true(is_ps_trimmed(out$value)) @@ -978,11 +977,11 @@ test_that("casting to a psw keeps a length-matched trimming record and drops a s # A cast takes its whole type from `to`, whose record describes `to`'s own # observations rather than the incoming data. A length it does not match is - # nothing the caller can act on, so the record goes without comment. + # nothing the caller can act on, so the record's positions go without comment. shorter <- expect_silent(vec_cast(c(1, 2), to = w)) expect_s3_class(shorter, "psw") expect_length(shorter, 2) - expect_null(ps_trim_meta(shorter)) + expect_positions_dropped(ps_trim_meta(shorter), meta) # Zero-length data takes the same exemption a per-observation score takes: it # lines up with nothing and so contradicts nothing, and the result is itself a diff --git a/tests/testthat/test-wt-trunc.R b/tests/testthat/test-wt-trunc.R index 5ea2c88f..d2620f02 100644 --- a/tests/testthat/test-wt-trunc.R +++ b/tests/testthat/test-wt-trunc.R @@ -789,7 +789,7 @@ test_that("the names on the weights are kept", { expect_identical(names(named_integer), c("a", "b", "c")) }) -test_that("a subset that drops the record prints a truncation line without counts", { +test_that("a slice that drops the record's positions prints the bound without counts", { w <- psw(c(0.5, 1, 4, 2, 25), estimand = "ate") expect_snapshot(vctrs::vec_slice(wt_trunc(w, method = "wt", upper = 3), 1:3)) From 69b7e690522b97c9922cebb7c09d3e530717318d Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 11:00:19 -0400 Subject: [PATCH 49/64] drop weight record positions when other data is cast onto them --- R/psw.R | 9 +++++---- tests/testthat/test-psw-record-positions.R | 10 ++++++++++ tests/testthat/test-psw.R | 10 +++++----- 3 files changed, 20 insertions(+), 9 deletions(-) diff --git a/R/psw.R b/R/psw.R index 1c5f4dd1..c7b2c31d 100644 --- a/R/psw.R +++ b/R/psw.R @@ -2064,10 +2064,11 @@ cast_to_psw <- function(x, to) { x <- vec_cast(vec_data(x), to = double()) attributes(x) <- NULL - # A cast moves no unit, so it leaves the records as it found them. Outside - # subassignment, where base R keeps the target's own attributes regardless, - # `to` is a prototype and holds no observations for a record to describe. - carry_psw_metadata(x, to, in_place = TRUE) + # `to`'s records describe `to`'s units, not the data being cast, so their + # positions are dropped whatever the length. Subassignment casts the + # replacement too, but base `[<-` then keeps the target's own attributes, so + # the records the cast carries never reach its result. + carry_psw_metadata(x, to) } # A cast returns `x`'s values in `to`'s type, and a psw's type is the whole diff --git a/tests/testthat/test-psw-record-positions.R b/tests/testthat/test-psw-record-positions.R index 171f0535..bff95546 100644 --- a/tests/testthat/test-psw-record-positions.R +++ b/tests/testthat/test-psw-record-positions.R @@ -273,3 +273,13 @@ test_that("rep_len() and vec_c() of one input drop each record's positions", { expect_fixture_positions_dropped(out, fixture, label) } }) + +test_that("casting other data onto full-length weights drops each record's positions", { + for (label in names(positions_fixtures())) { + fixture <- positions_fixtures()[[label]] + w <- fixture$weights + + out <- expect_silent(vctrs::vec_cast(rev(vec_data(w)), w)) + expect_fixture_positions_dropped(out, fixture, label) + } +}) diff --git a/tests/testthat/test-psw.R b/tests/testthat/test-psw.R index f4b9eabb..4a939bd4 100644 --- a/tests/testthat/test-psw.R +++ b/tests/testthat/test-psw.R @@ -967,17 +967,17 @@ test_that("the trimmed flag survives operations that drop the trimming record", expect_true(is_ps_trimmed(w[integer(0)])) }) -test_that("casting to a psw keeps a length-matched trimming record and drops a shorter one silently", { +test_that("casting to a psw drops the trimming record's positions silently", { w <- trimmed_psw() meta <- ps_trim_meta(w) + # A cast takes its whole type from `to`, whose record describes `to`'s own + # observations rather than the incoming data, even at the same length. That + # is nothing the caller can act on, so the positions go without comment. matched <- expect_silent(vec_cast(c(1, 2, 3, 4, 5), to = w)) expect_s3_class(matched, "psw") - expect_identical(ps_trim_meta(matched), meta) + expect_positions_dropped(ps_trim_meta(matched), meta) - # A cast takes its whole type from `to`, whose record describes `to`'s own - # observations rather than the incoming data. A length it does not match is - # nothing the caller can act on, so the record's positions go without comment. shorter <- expect_silent(vec_cast(c(1, 2), to = w)) expect_s3_class(shorter, "psw") expect_length(shorter, 2) From caa0f6ff1ede71be1fffa1dd96014c6d23d4adf8 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 11:01:01 -0400 Subject: [PATCH 50/64] add failing tests for slicing modified scores at the same length --- tests/testthat/test-score-slice-records.R | 156 ++++++++++++++++++++++ 1 file changed, 156 insertions(+) create mode 100644 tests/testthat/test-score-slice-records.R diff --git a/tests/testthat/test-score-slice-records.R b/tests/testthat/test-score-slice-records.R new file mode 100644 index 00000000..0c59053e --- /dev/null +++ b/tests/testthat/test-score-slice-records.R @@ -0,0 +1,156 @@ +# Slicing a modified propensity score without its subscript ------------------- + +# A `ps_trim` or `ps_trunc` record names units by position. `[`, `sort()`, +# `unique()`, and `c()` of one input place the record themselves. A slice that +# reaches the restore without a subscript, such as `vctrs::vec_slice()` or +# `dplyr::arrange()`, cannot tell a reordering from an identity, so it drops the +# positions at any length and keeps what the record says about the modification. + +# Units 1 and 4 fall outside (0.1, 0.9). +slice_scores <- c(0.05, 0.5, 0.6, 0.95, 0.4) + +slice_fixtures <- function() { + list( + trim = list( + scores = ps_trim(slice_scores, lower = 0.1, upper = 0.9), + meta = ps_trim_meta, + query = is_unit_trimmed, + flag = is_ps_trimmed + ), + trunc = list( + scores = ps_trunc(slice_scores, lower = 0.1, upper = 0.9), + meta = ps_trunc_meta, + query = is_unit_truncated, + flag = is_ps_truncated + ) + ) +} + +expect_score_positions_dropped <- function(out, fixture, label) { + expect_s3_class(out, class(fixture$scores)[[1]]) + expect_positions_dropped( + fixture$meta(out), + fixture$meta(fixture$scores), + info = label + ) + expect_true(fixture$flag(out), info = label) + expect_error( + fixture$query(out), + class = "propensity_missing_meta_error", + info = label + ) +} + +test_that("vec_slice() reordering a modified score drops the positions", { + for (label in names(slice_fixtures())) { + fixture <- slice_fixtures()[[label]] + x <- fixture$scores + + out <- expect_silent(vctrs::vec_slice(x, 5:1)) + expect_score_positions_dropped(out, fixture, label) + expect_identical(vec_data(out), rev(vec_data(x)), info = label) + } +}) + +test_that("the reported trim slice no longer names the wrong units", { + x <- ps_trim(slice_scores, lower = 0.1, upper = 0.9) + out <- vctrs::vec_slice(x, 5:1) + + expect_identical(which(is.na(out)), c(2L, 5L)) + expect_error(is_unit_trimmed(out), class = "propensity_missing_meta_error") +}) + +test_that("vec_slice() at the same length in the same order drops the positions", { + for (label in names(slice_fixtures())) { + fixture <- slice_fixtures()[[label]] + x <- fixture$scores + + out <- expect_silent(vctrs::vec_slice(x, seq_along(x))) + expect_score_positions_dropped(out, fixture, label) + } +}) + +test_that("dplyr::arrange() on a modified score column drops the positions", { + skip_if_not_installed("dplyr") + + for (label in names(slice_fixtures())) { + fixture <- slice_fixtures()[[label]] + df <- data.frame(o = 5:1) + df$ps <- fixture$scores + + out <- expect_silent(dplyr::arrange(df, o)) + expect_score_positions_dropped(out$ps, fixture, label) + } +}) + +test_that("weights built from a reordering slice carry no stale positions", { + exposure <- c(1, 0, 1, 0, 1) + + for (label in names(slice_fixtures())) { + fixture <- slice_fixtures()[[label]] + sliced <- vctrs::vec_slice(fixture$scores, 5:1) + + w <- suppressWarnings( + wt_ate(sliced, .exposure = rev(exposure), exposure_type = "binary"), + classes = "propensity_no_refit_warning" + ) + expect_error( + fixture$query(w), + class = "propensity_missing_meta_error", + info = label + ) + } +}) + +test_that("vec_assign() and vec_fill_missing() drop the positions", { + for (label in names(slice_fixtures())) { + fixture <- slice_fixtures()[[label]] + x <- fixture$scores + + assigned <- expect_silent(vctrs::vec_assign(x, 2L, 0.55)) + expect_score_positions_dropped(assigned, fixture, label) + + filled <- expect_silent(vctrs::vec_fill_missing(x)) + expect_score_positions_dropped(filled, fixture, label) + } +}) + +test_that("subassignment and is.na<- keep the record, since no unit moves", { + for (label in names(slice_fixtures())) { + fixture <- slice_fixtures()[[label]] + x <- fixture$scores + meta <- fixture$meta(x) + units <- fixture$query(x) + + expect_silent({ + x[2] <- 0.55 + }) + expect_identical(fixture$meta(x), meta, info = label) + expect_identical(fixture$query(x), units, info = label) + + expect_silent({ + is.na(x) <- 3 + }) + expect_s3_class(x, class(fixture$scores)[[1]]) + expect_true(is.na(x[[3]]), info = label) + expect_identical(fixture$meta(x), meta, info = label) + expect_identical(fixture$query(x), units, info = label) + } +}) + +test_that("the routes that place the record still re-index it", { + for (label in names(slice_fixtures())) { + fixture <- slice_fixtures()[[label]] + x <- fixture$scores + units <- fixture$query(x) + + expect_identical(fixture$query(x[5:1]), rev(units), info = label) + expect_identical(fixture$query(rev(x)), rev(units), info = label) + expect_identical(fixture$query(c(x)), units, info = label) + expect_identical( + fixture$meta(vctrs::vec_slice(x, integer())), + fixture$meta(x), + info = label + ) + } +}) From 0928aed5957e734e30363714143efddd144961d6 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 11:09:04 -0400 Subject: [PATCH 51/64] drop score positions when a slice cannot place them --- NAMESPACE | 2 + NEWS.md | 13 +++++++ R/ps_trim.R | 67 ++++++++++++++++++---------------- R/ps_trunc.R | 66 +++++++++++++++++---------------- man/is_unit_trimmed.Rd | 12 +++--- man/is_unit_truncated.Rd | 12 +++--- man/ps_trim.Rd | 19 +++++----- man/ps_trunc.Rd | 18 ++++----- tests/testthat/test-ps_trim.R | 26 ++++++------- tests/testthat/test-ps_trunc.R | 33 ++++++++++------- 10 files changed, 146 insertions(+), 122 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 7615b8d7..a39ae9aa 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,8 @@ S3method("[",ps_trim_matrix) S3method("[",ps_trunc) S3method("[",ps_trunc_matrix) S3method("[",psw) +S3method("is.na<-",ps_trim) +S3method("is.na<-",ps_trunc) S3method("is.na<-",psw) S3method(Summary,ps_calib) S3method(Summary,ps_trim) diff --git a/NEWS.md b/NEWS.md index 5a190b04..1f95f40d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -164,6 +164,19 @@ and `ps_refit()` now refuse such a result with an error of class `propensity_missing_meta_error`. +* A `ps_trim` or `ps_trunc` vector sliced without its subscript now drops the + positions in its record at any length, keeping the method and bounds. + `vctrs::vec_slice(x, 5:1)` and `dplyr::arrange()` previously returned the + scores in a new order under a record still naming the old positions, so + `is_unit_trimmed()` and `is_unit_truncated()` named the wrong units, and + `wt_ate()`, `ps_refit()`, and the weights built from the result carried the + same wrong units on. `is_unit_trimmed()`, `is_unit_truncated()`, and + `ps_refit()` now refuse such a result with an error of class + `propensity_missing_meta_error`. `vctrs::vec_assign()` and the helpers built + on it drop the positions too. `[`, `sort()`, `unique()`, `rep()`, and `c()` + of one input still re-index the record, and `[<-`, `x[]`, and `is.na<-` keep + it. + * Reordering or subsetting a `psw` with `[` now carries its trimming, truncation, and weight truncation records through the subscript, as `[` already did for a `ps_trim` or `ps_trunc`. `rev()`, `sort()`, and diff --git a/R/ps_trim.R b/R/ps_trim.R index 26c94e78..61ef6977 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -347,15 +347,16 @@ #' trimmed units at stale positions. #' #' That check compares how many observations the record was written for against -#' how many the object holds, which a reordering does not change. An operation -#' that reorders the observations through vctrs, rather than through `[`, -#' therefore keeps a record written for the order they used to be in: -#' `vctrs::vec_slice(x, 5:1)` and `dplyr::arrange()` both return the values in -#' a new order under positions still naming the old one. [is_unit_trimmed()] -#' answers from those positions and names the wrong units, and [ps_refit()] -#' refits on the wrong rows. Subsetting with `[` is handed the subscript and -#' re-indexes, so reorder with `[`, or put the propensity scores in the order -#' you want before trimming them. +#' how many the object holds, which a reordering does not change, so a route +#' that could reorder the observations without saying how drops the positions +#' instead, at any length: `vctrs::vec_slice()`, `dplyr::arrange()`, +#' `dplyr::filter()`, and [vctrs::vec_assign()] and the helpers built on it +#' return a `ps_trim` whose record keeps its method and cutoffs and names no +#' units, and [is_unit_trimmed()] and [ps_refit()] refuse it. Subsetting with +#' `[`, `sort()`, `unique()`, and `rep()` know where the units went and +#' re-index the record, and `[<-` and `is.na<-` move no unit and keep it, so +#' reorder with `[`, or put the propensity scores in the order you want before +#' trimming them. #' #' Casting a numeric vector into a `ps_trim` with [vctrs::vec_cast()] is a type #' operation and not a trimming. The result is described by the method and @@ -1900,13 +1901,11 @@ is_ps_trimmed.ps_trim_matrix <- function(x) { #' rather than name trimmed units at stale positions. Query the `ps_trim` #' object the record was written for instead. #' -#' That check counts observations, which a reordering does not change, so it -#' does not catch one. A `ps_trim` reordered through vctrs rather than through -#' `[`, by `vctrs::vec_slice(x, 5:1)` or `dplyr::arrange()`, keeps a record -#' written for the old order, and `is_unit_trimmed()` answers from those -#' positions and names the wrong units. A `psw` drops its record on those -#' routes instead. See [ps_trim()] and [psw] for the -#' whole contract. +#' That check counts observations, which a reordering does not change, so a +#' `ps_trim` or `psw` reordered through vctrs rather than through `[`, by +#' `vctrs::vec_slice(x, 5:1)` or `dplyr::arrange()`, drops the positions +#' instead, and `is_unit_trimmed()` refuses the result. See [ps_trim()] and +#' [psw] for the whole contract. #' #' @param x A `ps_trim` object created by [ps_trim()], or a [psw] vector built #' from one. @@ -2427,11 +2426,21 @@ median.ps_trim <- function(x, na.rm = FALSE, ...) { } +# Marking scores as missing moves no unit, so it goes through base `[<-`, which +# keeps the record, rather than through vctrs' method, whose restore cannot tell +# an assignment from a reordering and drops the positions. +#' @export +`is.na<-.ps_trim` <- function(x, value) { + x[value] <- NA_real_ + x +} + #' @export `[.ps_trim` <- function(x, i, ...) { - # If i is missing, just call NextMethod + # `x[]` takes every unit where it is, so the record still describes it. The + # restore behind `NextMethod()` would see a slice and drop the positions. if (missing(i)) { - return(NextMethod()) + return(x) } # Get original metadata @@ -2582,19 +2591,15 @@ vec_restore.ps_trim <- function(x, to, ...) { # Nothing rebuilding a `ps_trim` is handed the subscript behind a length # change, so a record written for a different number of observations cannot be - # re-indexed onto the data arriving here. Zero-length data is exempt: a - # prototype or an empty slice holds no observations, so no position in the - # record contradicts it. - # - # Data restored against a zero-length `to` did not come from `to`: a - # prototype, whether sliced from the one input of a combine or supplied by the - # caller, is restored onto observations it was never written for, in an order - # nothing here is told. Its positions are dropped without comment, as a - # combine of several inputs drops them, and base `c()` of a single vector keeps - # them by returning that vector. - if (length(data) > 0 && length(to) == 0) { - meta <- drop_trim_record(meta) - } else if (length(data) > 0 && !record_covers(meta, length(data))) { + # re-indexed onto the data arriving here, and nor is the subscript behind a + # slice at the same length, which may have reordered the units. Every restore + # that holds observations therefore drops the positions, silently, and keeps + # what the record says about the modification. The routes that know where the + # units went place the record themselves: `[`, `sort()`, `unique()`, `rep()`, + # and base `c()` of a single vector, which returns it. Zero-length data is + # exempt: a prototype or an empty slice holds no observations, so no position + # in the record contradicts it. + if (length(data) > 0) { meta <- drop_trim_record(meta) } diff --git a/R/ps_trunc.R b/R/ps_trunc.R index ffcbecef..44762516 100644 --- a/R/ps_trunc.R +++ b/R/ps_trunc.R @@ -252,15 +252,15 @@ #' units at stale positions. #' #' That check compares how many observations the record was written for against -#' how many the object holds, which a reordering does not change. An operation -#' that reorders the observations through vctrs, rather than through `[`, -#' therefore keeps a record written for the order they used to be in: -#' `vctrs::vec_slice(x, 5:1)` and `dplyr::arrange()` both return the values in -#' a new order under positions still naming the old one, and -#' [is_unit_truncated()] answers from those positions and names the wrong -#' units. Subsetting with `[` is handed the subscript and re-indexes, so -#' reorder with `[`, or put the propensity scores in the order you want before -#' truncating them. +#' how many the object holds, which a reordering does not change, so a route +#' that could reorder the observations without saying how drops the positions +#' instead, at any length: `vctrs::vec_slice()`, `dplyr::arrange()`, +#' `dplyr::filter()`, and [vctrs::vec_assign()] and the helpers built on it +#' return a `ps_trunc` whose record keeps its method and bounds and names no +#' units, and [is_unit_truncated()] refuses it. Subsetting with `[`, `sort()`, +#' `unique()`, and `rep()` know where the units went and re-index the record, +#' and `[<-` and `is.na<-` move no unit and keep it, so reorder with `[`, or +#' put the propensity scores in the order you want before truncating them. #' #' Casting a numeric vector into a `ps_trunc` with [vctrs::vec_cast()] is a type #' operation and not a truncation. The result is described by the method and @@ -1407,13 +1407,11 @@ is_ps_truncated.ps_trunc_matrix <- function(x) { #' all, rather than name truncated units at stale positions. Query the #' `ps_trunc` object the record was written for instead. #' -#' That check counts observations, which a reordering does not change, so it -#' does not catch one. An operation that reorders through vctrs rather than -#' through `[`, such as `vctrs::vec_slice(x, 5:1)` or `dplyr::arrange()`, -#' keeps a record written for the old order, and `is_unit_truncated()` -#' answers from those positions and names the wrong units. A `psw` drops its -#' record on those routes instead. See [ps_trunc()] and [psw] -#' for the whole contract. +#' That check counts observations, which a reordering does not change, so a +#' `ps_trunc` or `psw` reordered through vctrs rather than through `[`, such +#' as by `vctrs::vec_slice(x, 5:1)` or `dplyr::arrange()`, drops the +#' positions instead, and `is_unit_truncated()` refuses the result. See +#' [ps_trunc()] and [psw] for the whole contract. #' #' @param x A `ps_trunc` object created by [ps_trunc()], or a [psw] vector built #' from one. @@ -1861,11 +1859,21 @@ quantile.ps_trunc <- function(x, probs = seq(0, 1, 0.25), na.rm = FALSE, ...) { # vctrs handles combination internally through vec_ptype2 and vec_cast # When combining ps_trunc objects with same parameters, indices won't be preserved +# Marking scores as missing moves no unit, so it goes through base `[<-`, which +# keeps the record, rather than through vctrs' method, whose restore cannot tell +# an assignment from a reordering and drops the positions. +#' @export +`is.na<-.ps_trunc` <- function(x, value) { + x[value] <- NA_real_ + x +} + #' @export `[.ps_trunc` <- function(x, i, ...) { - # If i is missing, just call NextMethod + # `x[]` takes every unit where it is, so the record still describes it. The + # restore behind `NextMethod()` would see a slice and drop the positions. if (missing(i)) { - return(NextMethod()) + return(x) } # Get original metadata @@ -1970,19 +1978,15 @@ vec_restore.ps_trunc <- function(x, to, ...) { # Nothing rebuilding a `ps_trunc` is handed the subscript behind a length # change, so a record written for a different number of observations cannot be - # re-indexed onto the data arriving here. Zero-length data is exempt: a - # prototype or an empty slice holds no observations, so no position in the - # record contradicts it. - # - # Data restored against a zero-length `to` did not come from `to`: a - # prototype, whether sliced from the one input of a combine or supplied by the - # caller, is restored onto observations it was never written for, in an order - # nothing here is told. Its positions are dropped without comment, as a - # combine of several inputs drops them, and base `c()` of a single vector keeps - # them by returning that vector. - if (length(data) > 0 && length(to) == 0) { - meta <- drop_trunc_record(meta) - } else if (length(data) > 0 && !record_covers(meta, length(data))) { + # re-indexed onto the data arriving here, and nor is the subscript behind a + # slice at the same length, which may have reordered the units. Every restore + # that holds observations therefore drops the positions, silently, and keeps + # what the record says about the modification. The routes that know where the + # units went place the record themselves: `[`, `sort()`, `unique()`, `rep()`, + # and base `c()` of a single vector, which returns it. Zero-length data is + # exempt: a prototype or an empty slice holds no observations, so no position + # in the record contradicts it. + if (length(data) > 0) { meta <- drop_trunc_record(meta) } diff --git a/man/is_unit_trimmed.Rd b/man/is_unit_trimmed.Rd index 529401c4..2f2de8c6 100644 --- a/man/is_unit_trimmed.Rd +++ b/man/is_unit_trimmed.Rd @@ -34,13 +34,11 @@ it does not, or when an object marked as trimmed carries no record at all, rather than name trimmed units at stale positions. Query the \code{ps_trim} object the record was written for instead. -That check counts observations, which a reordering does not change, so it -does not catch one. A \code{ps_trim} reordered through vctrs rather than through -\code{[}, by \code{vctrs::vec_slice(x, 5:1)} or \code{dplyr::arrange()}, keeps a record -written for the old order, and \code{is_unit_trimmed()} answers from those -positions and names the wrong units. A \code{psw} drops its record on those -routes instead. See \code{\link[=ps_trim]{ps_trim()}} and \link{psw} for the -whole contract. +That check counts observations, which a reordering does not change, so a +\code{ps_trim} or \code{psw} reordered through vctrs rather than through \code{[}, by +\code{vctrs::vec_slice(x, 5:1)} or \code{dplyr::arrange()}, drops the positions +instead, and \code{is_unit_trimmed()} refuses the result. See \code{\link[=ps_trim]{ps_trim()}} and +\link{psw} for the whole contract. } \examples{ ps <- c(0.05, 0.3, 0.6, 0.95) diff --git a/man/is_unit_truncated.Rd b/man/is_unit_truncated.Rd index 0e85c5ca..8ba3bf4c 100644 --- a/man/is_unit_truncated.Rd +++ b/man/is_unit_truncated.Rd @@ -33,13 +33,11 @@ it does not, or when an object marked as truncated carries no record at all, rather than name truncated units at stale positions. Query the \code{ps_trunc} object the record was written for instead. -That check counts observations, which a reordering does not change, so it -does not catch one. An operation that reorders through vctrs rather than -through \code{[}, such as \code{vctrs::vec_slice(x, 5:1)} or \code{dplyr::arrange()}, -keeps a record written for the old order, and \code{is_unit_truncated()} -answers from those positions and names the wrong units. A \code{psw} drops its -record on those routes instead. See \code{\link[=ps_trunc]{ps_trunc()}} and \link{psw} -for the whole contract. +That check counts observations, which a reordering does not change, so a +\code{ps_trunc} or \code{psw} reordered through vctrs rather than through \code{[}, such +as by \code{vctrs::vec_slice(x, 5:1)} or \code{dplyr::arrange()}, drops the +positions instead, and \code{is_unit_truncated()} refuses the result. See +\code{\link[=ps_trunc]{ps_trunc()}} and \link{psw} for the whole contract. } \examples{ ps <- c(0.02, 0.3, 0.5, 0.7, 0.98) diff --git a/man/ps_trim.Rd b/man/ps_trim.Rd index 79792e89..08ea2a90 100644 --- a/man/ps_trim.Rd +++ b/man/ps_trim.Rd @@ -415,15 +415,16 @@ class \code{propensity_missing_meta_error} when it does not, rather than name trimmed units at stale positions. That check compares how many observations the record was written for against -how many the object holds, which a reordering does not change. An operation -that reorders the observations through vctrs, rather than through \code{[}, -therefore keeps a record written for the order they used to be in: -\code{vctrs::vec_slice(x, 5:1)} and \code{dplyr::arrange()} both return the values in -a new order under positions still naming the old one. \code{\link[=is_unit_trimmed]{is_unit_trimmed()}} -answers from those positions and names the wrong units, and \code{\link[=ps_refit]{ps_refit()}} -refits on the wrong rows. Subsetting with \code{[} is handed the subscript and -re-indexes, so reorder with \code{[}, or put the propensity scores in the order -you want before trimming them. +how many the object holds, which a reordering does not change, so a route +that could reorder the observations without saying how drops the positions +instead, at any length: \code{vctrs::vec_slice()}, \code{dplyr::arrange()}, +\code{dplyr::filter()}, and \code{\link[vctrs:vec_assign]{vctrs::vec_assign()}} and the helpers built on it +return a \code{ps_trim} whose record keeps its method and cutoffs and names no +units, and \code{\link[=is_unit_trimmed]{is_unit_trimmed()}} and \code{\link[=ps_refit]{ps_refit()}} refuse it. Subsetting with +\code{[}, \code{sort()}, \code{unique()}, and \code{rep()} know where the units went and +re-index the record, and \verb{[<-} and \verb{is.na<-} move no unit and keep it, so +reorder with \code{[}, or put the propensity scores in the order you want before +trimming them. Casting a numeric vector into a \code{ps_trim} with \code{\link[vctrs:vec_cast]{vctrs::vec_cast()}} is a type operation and not a trimming. The result is described by the method and diff --git a/man/ps_trunc.Rd b/man/ps_trunc.Rd index 9e7ee19f..9db4df54 100644 --- a/man/ps_trunc.Rd +++ b/man/ps_trunc.Rd @@ -295,15 +295,15 @@ record covers the object it is given and raises an error of class units at stale positions. That check compares how many observations the record was written for against -how many the object holds, which a reordering does not change. An operation -that reorders the observations through vctrs, rather than through \code{[}, -therefore keeps a record written for the order they used to be in: -\code{vctrs::vec_slice(x, 5:1)} and \code{dplyr::arrange()} both return the values in -a new order under positions still naming the old one, and -\code{\link[=is_unit_truncated]{is_unit_truncated()}} answers from those positions and names the wrong -units. Subsetting with \code{[} is handed the subscript and re-indexes, so -reorder with \code{[}, or put the propensity scores in the order you want before -truncating them. +how many the object holds, which a reordering does not change, so a route +that could reorder the observations without saying how drops the positions +instead, at any length: \code{vctrs::vec_slice()}, \code{dplyr::arrange()}, +\code{dplyr::filter()}, and \code{\link[vctrs:vec_assign]{vctrs::vec_assign()}} and the helpers built on it +return a \code{ps_trunc} whose record keeps its method and bounds and names no +units, and \code{\link[=is_unit_truncated]{is_unit_truncated()}} refuses it. Subsetting with \code{[}, \code{sort()}, +\code{unique()}, and \code{rep()} know where the units went and re-index the record, +and \verb{[<-} and \verb{is.na<-} move no unit and keep it, so reorder with \code{[}, or +put the propensity scores in the order you want before truncating them. Casting a numeric vector into a \code{ps_trunc} with \code{\link[vctrs:vec_cast]{vctrs::vec_cast()}} is a type operation and not a truncation. The result is described by the method and diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index f6f0f2be..96de9fde 100644 --- a/tests/testthat/test-ps_trim.R +++ b/tests/testthat/test-ps_trim.R @@ -717,14 +717,16 @@ test_that("filtering a ps_trim column drops the trimming record silently", { ) }) -test_that("a length-preserving ps_trim restore keeps the trimming record", { +test_that("a whole ps_trim keeps its trimming record through `[` and `[<-`", { x <- trim_record_fixture() meta <- ps_trim_meta(x) trimmed_units <- c(TRUE, FALSE, FALSE, TRUE, FALSE) + # A slice is handed no subscript, so even one that leaves every unit in place + # cannot vouch for the positions. whole <- expect_silent(vec_slice(x, seq_along(x))) - expect_identical(ps_trim_meta(whole), meta) - expect_identical(is_unit_trimmed(whole), trimmed_units) + expect_positions_dropped(ps_trim_meta(whole), meta) + expect_error(is_unit_trimmed(whole), class = "propensity_missing_meta_error") empty_subscript <- expect_silent(x[]) expect_identical(ps_trim_meta(empty_subscript), meta) @@ -920,22 +922,18 @@ test_that("a ps_trim that lost its record says so instead of reporting none", { expect_match(vec_ptype_full(sliced), "record dropped", fixed = TRUE) }) -test_that("a ps_trim reordered through vctrs keeps the record for the old order", { - # The documented limit of the coverage check, which counts observations and so - # sees nothing in a reordering. No subscript reaches the restore, so the - # record survives naming where the observations used to be. +test_that("a ps_trim reordered through vctrs drops the record's positions", { + # The coverage check counts observations and so sees nothing in a + # reordering. No subscript reaches the restore, so the positions are dropped + # rather than left naming where the observations used to be. x <- trim_record_fixture() reordered <- expect_silent(vec_slice(x, 5:1)) expect_equal(as.numeric(reordered), c(0.6, NA, 0.5, 0.3, NA)) - expect_identical(ps_trim_meta(reordered), ps_trim_meta(x)) - - # The trimmed units now hold positions 2 and 5, and the record still names 1 - # and 4, so the answer is the one the record gives rather than the one the - # values show. - expect_identical( + expect_positions_dropped(ps_trim_meta(reordered), ps_trim_meta(x)) + expect_error( is_unit_trimmed(reordered), - c(TRUE, FALSE, FALSE, TRUE, FALSE) + class = "propensity_missing_meta_error" ) # `[` is handed the subscript and re-indexes, so the same reordering through diff --git a/tests/testthat/test-ps_trunc.R b/tests/testthat/test-ps_trunc.R index 190cba95..6fa4eeb5 100644 --- a/tests/testthat/test-ps_trunc.R +++ b/tests/testthat/test-ps_trunc.R @@ -597,14 +597,19 @@ test_that("filtering a ps_trunc column drops the truncation record silently", { ) }) -test_that("a length-preserving ps_trunc restore keeps the truncation record", { +test_that("a whole ps_trunc keeps its truncation record through `[` and `[<-`", { x <- trunc_record_fixture() meta <- ps_trunc_meta(x) truncated_units <- c(TRUE, FALSE, FALSE, FALSE, FALSE) + # A slice is handed no subscript, so even one that leaves every unit in place + # cannot vouch for the positions. whole <- expect_silent(vec_slice(x, seq_along(x))) - expect_identical(ps_trunc_meta(whole), meta) - expect_identical(is_unit_truncated(whole), truncated_units) + expect_positions_dropped(ps_trunc_meta(whole), meta) + expect_error( + is_unit_truncated(whole), + class = "propensity_missing_meta_error" + ) empty_subscript <- expect_silent(x[]) expect_identical(ps_trunc_meta(empty_subscript), meta) @@ -700,21 +705,18 @@ test_that("casting to ps_trunc records positions and a length", { expect_equal(ps_trunc_meta(from_integer)$n_obs, 2L) }) -test_that("a ps_trunc reordered through vctrs keeps the record for the old order", { - # The documented limit of the coverage check, which counts observations and so - # sees nothing in a reordering. No subscript reaches the restore, so the - # record survives naming where the observations used to be. +test_that("a ps_trunc reordered through vctrs drops the record's positions", { + # The coverage check counts observations and so sees nothing in a + # reordering. No subscript reaches the restore, so the positions are dropped + # rather than left naming where the observations used to be. x <- trunc_record_fixture() reordered <- expect_silent(vec_slice(x, 5:1)) expect_equal(as.numeric(reordered), c(0.6, 0.9, 0.5, 0.3, 0.1)) - expect_identical(ps_trunc_meta(reordered), ps_trunc_meta(x)) - - # The winsorized unit now holds position 5, and the record still names 1, so - # the answer is the one the record gives rather than the one the values show. - expect_identical( + expect_positions_dropped(ps_trunc_meta(reordered), ps_trunc_meta(x)) + expect_error( is_unit_truncated(reordered), - c(TRUE, FALSE, FALSE, FALSE, FALSE) + class = "propensity_missing_meta_error" ) # `[` is handed the subscript and re-indexes, so the same reordering through @@ -1114,8 +1116,11 @@ test_that("assigning a trimmed score into a ps_trunc keeps its record", { expect_equal(vctrs::vec_data(x), vctrs::vec_data(truncated)) expect_identical(ps_trunc_meta(x), ps_trunc_meta(truncated)) + # vctrs' assignment reaches the same restore a slice does, so it keeps the + # values and drops the positions. assigned <- vctrs::vec_assign(truncated, 2, trimmed[2]) - expect_identical(assigned, x) + expect_equal(vctrs::vec_data(assigned), vctrs::vec_data(x)) + expect_positions_dropped(ps_trunc_meta(assigned), ps_trunc_meta(truncated)) }) test_that("casting a ps_trim to a ps_trunc records no bound", { From 36cdddfd89b050131f239c88afb3e621fc14afa8 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 11:10:34 -0400 Subject: [PATCH 52/64] add failing tests for reordering a per-observation stabilization score --- tests/testthat/test-psw-reorder-score.R | 202 ++++++++++++++++++++++++ 1 file changed, 202 insertions(+) create mode 100644 tests/testthat/test-psw-reorder-score.R diff --git a/tests/testthat/test-psw-reorder-score.R b/tests/testthat/test-psw-reorder-score.R new file mode 100644 index 00000000..1cd96d1c --- /dev/null +++ b/tests/testthat/test-psw-reorder-score.R @@ -0,0 +1,202 @@ +# Reordering weights stabilized on a per-observation score -------------------- + +# A per-observation stabilization score holds one value per unit, in the order +# of the units, like a position record. `[` knows where each unit went and +# reorders the score with the weights. A slice that is not handed its subscript +# cannot, so it drops the score with a warning, as a length change does. + +reorder_score_data <- function(n = 300) { + set.seed(2024) + x <- rnorm(n) + a <- 0.5 * x + rnorm(n) + b <- rbinom(n, 1, plogis(0.4 * x)) + y <- a + b + x + rnorm(n) + data.frame(x = x, a = a, b = b, y = y) +} + +reorder_score <- function(dat) { + stats::dnorm(dat$a, mean(dat$a), stats::sd(dat$a)) +} + +continuous_score_psw <- function(dat) { + withr::with_options( + list(propensity.quiet = TRUE), + wt_ate( + lm(a ~ x, data = dat), + stabilize = TRUE, + stabilization_score = reorder_score(dat) + ) + ) +} + +joint_score_psw <- function(dat) { + withr::with_options( + list(propensity.quiet = TRUE), + wt_joint( + wt_ate(glm(b ~ x, data = dat, family = binomial())), + wt_ate( + lm(a ~ b + x, data = dat), + stabilize = TRUE, + stabilization_score = reorder_score(dat) + ), + exposure_type = c("binary", "continuous") + ) + ) +} + +joint_scores <- function(w) { + joint_wt_meta(w)$stabilization_score +} + +expect_scores_follow <- function(out, w, i) { + expect_identical(stabilization_score(out), stabilization_score(w)[i]) + expected <- joint_scores(w) + if (!is.null(expected)) { + expected <- lapply(expected, function(score) { + if (length(score) > 1) score[i] else score + }) + } + expect_identical(joint_scores(out), expected) +} + +test_that("the fixtures carry a per-observation score", { + dat <- reorder_score_data() + + w <- continuous_score_psw(dat) + expect_identical(stabilization_score(w), reorder_score(dat)) + + joint <- joint_score_psw(dat) + expect_true(any(lengths(joint_scores(joint)) == nrow(dat))) +}) + +test_that("`[` reorders a per-observation score with the weights", { + dat <- reorder_score_data() + + for (w in list(continuous_score_psw(dat), joint_score_psw(dat))) { + i <- c(5:1, 6:length(w)) + + out <- expect_silent(w[i]) + expect_scores_follow(out, w, i) + expect_identical(vec_data(out), vec_data(w)[i]) + + shorter <- expect_silent(w[c(3, 1)]) + expect_scores_follow(shorter, w, c(3, 1)) + } +}) + +test_that("rev() reorders a per-observation score with the weights", { + dat <- reorder_score_data() + + for (w in list(continuous_score_psw(dat), joint_score_psw(dat))) { + out <- expect_silent(rev(w)) + expect_scores_follow(out, w, rev(seq_along(w))) + } +}) + +test_that("reordering a data frame with order() reorders the score", { + dat <- reorder_score_data() + dat$w <- continuous_score_psw(dat) + dat$j <- joint_score_psw(dat) + ord <- order(dat$x) + + out <- expect_silent(dat[ord, ]) + + expect_scores_follow(out$w, dat$w, ord) + expect_scores_follow(out$j, dat$j, ord) +}) + +test_that("an identity subscript keeps the score unchanged", { + dat <- reorder_score_data() + w <- continuous_score_psw(dat) + + expect_identical(stabilization_score(w[seq_along(w)]), stabilization_score(w)) + expect_identical(stabilization_score(w[]), stabilization_score(w)) +}) + +test_that("a scalar score is kept by any reordering", { + w <- psw(c(1, 2, 3), estimand = "ate", stabilized = TRUE) + attr(w, "stabilization_score") <- 0.4 + + expect_identical(stabilization_score(w[3:1]), 0.4) + expect_identical(stabilization_score(vctrs::vec_slice(w, 3:1)), 0.4) +}) + +test_that("vec_slice() at the same length drops the score with a warning", { + dat <- reorder_score_data() + + for (w in list(continuous_score_psw(dat), joint_score_psw(dat))) { + expect_warning( + out <- vctrs::vec_slice(w, rev(seq_along(w))), + class = "propensity_stabilization_score_warning" + ) + expect_null(stabilization_score(out)) + expect_true(is_stabilized(out)) + expect_false(any(lengths(joint_scores(out)) > 1)) + } +}) + +test_that("dplyr::arrange() drops the score with a warning", { + skip_if_not_installed("dplyr") + dat <- reorder_score_data() + dat$w <- continuous_score_psw(dat) + + expect_warning( + out <- dplyr::arrange(dat, x), + class = "propensity_stabilization_score_warning" + ) + expect_null(stabilization_score(out$w)) +}) + +test_that("arithmetic keeps a per-observation score in place", { + dat <- reorder_score_data() + w <- continuous_score_psw(dat) + + expect_identical( + stabilization_score(expect_silent(w * 2)), + reorder_score(dat) + ) + expect_identical( + stabilization_score(expect_silent(w * w)), + reorder_score(dat) + ) +}) + +test_that("ipw() accepts weights reordered with their data", { + dat <- reorder_score_data() + dat$w <- continuous_score_psw(dat) + sorted <- dat[order(dat$x), ] + + ps_mod <- lm(a ~ x, data = sorted) + outcome_mod <- lm(y ~ a, data = sorted, weights = w) + + res <- expect_no_error(ipw(ps_mod, outcome_mod)) + expect_s3_class(res, "ipw") + + # The same weights built on the sorted data give the same estimate. + rebuilt <- withr::with_options( + list(propensity.quiet = TRUE), + wt_ate( + ps_mod, + stabilize = TRUE, + stabilization_score = reorder_score(dat)[order(dat$x)] + ) + ) + expect_equal(as.numeric(sorted$w), as.numeric(rebuilt)) + expected <- ipw(ps_mod, lm(y ~ a, data = sorted, weights = rebuilt)) + expect_equal(res$estimates, expected$estimates) +}) + +test_that("ipw() accepts joint weights reordered with their data", { + dat <- reorder_score_data() + dat$j <- joint_score_psw(dat) + sorted <- dat[order(dat$x), ] + + models <- joint_wt_models( + b = glm(b ~ x, data = sorted, family = binomial()), + a = lm(a ~ b + x, data = sorted) + ) + outcome_mod <- lm(y ~ a + b, data = sorted, weights = j) + + res <- expect_no_error(ipw(models, outcome_mod)) + expect_s3_class(res, "ipw") +}) From 500246e5306b4ae0409b027467b39dda7ef438d6 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 11:21:41 -0400 Subject: [PATCH 53/64] reorder the per-observation stabilization score with the weights --- NEWS.md | 11 + R/ipw-continuous-models.R | 7 +- R/ipw.R | 7 +- R/psw.R | 224 +++++++++++++++------ man/ipw-methods.Rd | 7 +- man/psw.Rd | 11 +- tests/testthat/test-ipw-continuous.R | 47 +++-- tests/testthat/test-ipw-joint-continuous.R | 22 +- tests/testthat/test-ipw-se-method.R | 6 +- tests/testthat/test-psw-reorder-score.R | 4 +- tests/testthat/test-psw.R | 7 +- tests/testthat/test-weights.R | 13 +- tests/testthat/test-wt-joint.R | 20 +- 13 files changed, 259 insertions(+), 127 deletions(-) diff --git a/NEWS.md b/NEWS.md index 1f95f40d..45654997 100644 --- a/NEWS.md +++ b/NEWS.md @@ -164,6 +164,17 @@ and `ps_refit()` now refuse such a result with an error of class `propensity_missing_meta_error`. +* A per-observation `stabilization_score`, on a `psw` or inside the record of a + `wt_joint()` product, now follows the weights through `[`, so `rev()`, + `sort()`, and a data frame reordered with `order()` keep each unit's score + with its weight, and a shorter subset keeps the scores of the units it + holds. The score previously kept its old order whenever the length was + unchanged, so `ipw()` refused weights reordered with their data with a + misleading `propensity_ipw_weights_mismatch_error`, and a shorter subset + dropped the score. A slice that is not handed its subscript, such as + `vctrs::vec_slice()` or `dplyr::arrange()`, now drops the score with a + `propensity_stabilization_score_warning` at any length. + * A `ps_trim` or `ps_trunc` vector sliced without its subscript now drops the positions in its record at any length, keeping the method and bounds. `vctrs::vec_slice(x, 5:1)` and `dplyr::arrange()` previously returned the diff --git a/R/ipw-continuous-models.R b/R/ipw-continuous-models.R index aeea2ee2..6a6e6b50 100644 --- a/R/ipw-continuous-models.R +++ b/R/ipw-continuous-models.R @@ -911,9 +911,10 @@ check_ipw_stabilization_score <- function( c( headline, x = paste("They weight {n} observation{?s} and", held), - i = "A per-observation score is one value for each unit, so it does not \\ - survive the rows being restricted: subsetting the weights drops it, and \\ - a model frame that drops incomplete rows leaves it at the length the \\ + i = "A per-observation score is one value for each unit. Subsetting the \\ + weights with {.code [} keeps it aligned, but a slice that cannot place \\ + it, such as {.fn vctrs::vec_slice} or {.fn dplyr::arrange}, drops it, \\ + and a model frame that drops incomplete rows leaves it at the length the \\ weights were built at.", i = "Rebuild the weights on the rows being analyzed, or stabilize on a \\ single {.arg stabilization_score}, which scales every weight and \\ diff --git a/R/ipw.R b/R/ipw.R index ed5a2ce6..f3ad86b9 100644 --- a/R/ipw.R +++ b/R/ipw.R @@ -1377,9 +1377,10 @@ #' weights with the pooled default or with one number to use `ipw()`. #' #' It bears on a `stabilization_score` in the same way. A score written per -#' observation is one value per unit, so it does not survive the rows being -#' restricted: subsetting the weights drops it, and a model frame that drops -#' incomplete rows leaves it at the length the weights were built at. Either way +#' observation is one value per unit. Subsetting or reordering the weights with +#' `[` carries it along, but a slice that cannot place it, such as +#' `vctrs::vec_slice()` or `dplyr::arrange()`, drops it, and a model frame that +#' drops incomplete rows leaves it at the length the weights were built at. Either way #' the record still names a score as the numerator and the score in hand no #' longer describes the observations being weighted, so `ipw()` refuses before #' anything is solved, with an error of class diff --git a/R/psw.R b/R/psw.R index c7b2c31d..e637b147 100644 --- a/R/psw.R +++ b/R/psw.R @@ -144,9 +144,14 @@ #' a slice does and cannot be told apart from one, so it drops the positions, #' and so do the helpers built on it or on a combine, such as #' `tidyr::replace_na()`, `dplyr::coalesce()`, `dplyr::if_else()`, and -#' `dplyr::case_when()`. A `stabilization_score` with more than one value is -#' carried when the result comes back at the length it was recorded on and -#' dropped when it does not. +#' `dplyr::case_when()`. +#' +#' A `stabilization_score` with more than one value, on the weights or on a +#' component of a [wt_joint()] product, is in the order of the units too. `[` +#' subsets it with the weights, elementwise arithmetic keeps it, and any other +#' route through vctrs that brings back observations drops it with a warning of +#' class `propensity_stabilization_score_warning`, since the score may no longer +#' line up with the weights. #' #' Dropping the `stabilization_score` warns, because the score was supplied by #' the user and the weights can be recomputed on the subset. Dropping a @@ -1217,9 +1222,9 @@ check_estimand_type <- function(estimand, call = rlang::caller_env()) { } # A stabilization score of length > 1 is indexed by observation, so it is only -# meaningful at the length it was recorded on. Nothing rebuilding a psw is given -# the indices behind a length change, and the subscript method for this class is -# owned upstream, so per-observation metadata cannot be re-indexed here. +# meaningful at the length it was recorded on. This checks a score against the +# observations it is supplied for; `place_stabilization_score()` decides what an +# operation on the weights does with one. # # Zero-length data is exempt. A prototype or empty subset carries no # observations, so a score on it lines up with nothing and misleads no one, and @@ -1229,6 +1234,31 @@ stabilization_score_aligns <- function(score, n) { n == 0 || length(score) <= 1 || length(score) == n } +# The score a result holds once data has arrived at `n` observations. A scalar +# scales every weight and holds anywhere. A per-observation score is in the +# order of the units, so it follows the rules a position record follows: `[` +# hands over `i`, the positions among the `n_obs` units of the source the result +# is built from, and the score is subset with them when it covers the source; +# otherwise it is kept only where the caller vouches that every unit is still at +# its place (`in_place`), or where the data holds no observations at all. +place_stabilization_score <- function( + score, + n, + in_place = FALSE, + i = NULL, + n_obs = NULL +) { + if (length(score) <= 1) { + return(score) + } + + if (!is.null(i)) { + return(if (length(score) == n_obs) score[i]) + } + + if (n == 0 || (in_place && length(score) == n)) score +} + # The score a caller supplies, checked where it is recorded. It multiplies the # weights, so a value that is not a positive finite number produces something # that is not a set of weights, and a length that is neither one nor one per @@ -1424,23 +1454,33 @@ reindex_psw_records <- function(attrs, x, i) { # exception a stabilization score is: it holds a value per observation, and a # score that no longer describes the observations the result holds is reported # as absent, for the reason the score on the weights themselves is. -aligned_joint_wt_meta <- function(meta, n) { +aligned_joint_wt_meta <- function( + meta, + n, + in_place = FALSE, + i = NULL, + n_obs = NULL +) { if (is.null(meta) || is.null(meta$stabilization_score)) { return(meta) } - aligned <- vapply( - meta$stabilization_score, - stabilization_score_aligns, - logical(1), - n = n + scores <- meta$stabilization_score + placed <- lapply( + scores, + place_stabilization_score, + n = n, + in_place = in_place, + i = i, + n_obs = n_obs ) + meta$stabilization_score[] <- placed + aligned <- lengths(scores) == 0 | lengths(placed) > 0 if (all(aligned)) { return(meta) } - meta$stabilization_score[!aligned] <- list(NULL) # The emptied slot is the slot a component the caller never stabilized on a # score has, so the drop is recorded rather than left to be read off an # absence. A component whose score is gone was stabilized on a numerator @@ -1530,9 +1570,14 @@ aligned_psw_attrs <- function(to, n, in_place = FALSE, i = NULL) { attrs <- lapply(psw_carried_attrs, function(attribute) attr(to, attribute)) names(attrs) <- psw_carried_attrs - if (!stabilization_score_aligns(attrs$stabilization_score, n)) { - attrs["stabilization_score"] <- list(NULL) - } + n_obs <- length(to) + attrs["stabilization_score"] <- list(place_stabilization_score( + attrs$stabilization_score, + n, + in_place = in_place, + i = i, + n_obs = n_obs + )) if (!is.null(i)) { attrs <- reindex_psw_records(attrs, to, i) @@ -1540,9 +1585,13 @@ aligned_psw_attrs <- function(to, n, in_place = FALSE, i = NULL) { attrs <- drop_psw_record_positions(attrs) } - attrs[psw_joint_attr] <- list( - aligned_joint_wt_meta(attrs[[psw_joint_attr]], n) - ) + attrs[psw_joint_attr] <- list(aligned_joint_wt_meta( + attrs[[psw_joint_attr]], + n, + in_place = in_place, + i = i, + n_obs = n_obs + )) # The record of what a fold has already dropped belongs to the prototype being # folded and goes no further. Data arriving at observations is the result the @@ -1866,57 +1915,113 @@ restore_psw <- function(x, to, in_place = FALSE) { # than the incoming data. Outside vctrs' subassignment intermediates, where # the restore that follows reattaches the target's score anyway, a cast's `to` # is a prototype, which cannot carry a score misaligned with itself. + warn_dropped_scores(to, length(x), in_place = in_place) + + carry_psw_metadata(x, to, in_place = in_place) +} + +# The per-observation scores on `to` that an operation bringing data at `n` +# observations drops, announced once for the operation. A score kept, placed +# by a subscript, or held as a scalar is not mentioned. +warn_dropped_scores <- function(to, n, in_place = FALSE, i = NULL) { scores <- psw_stabilization_scores(to) - dropped <- !vapply( + dropped <- vapply( scores, - stabilization_score_aligns, - logical(1), - n = length(x) + function(score) { + length(score) > 1 && + is.null(place_stabilization_score( + score, + n, + in_place = in_place, + i = i, + n_obs = length(to) + )) + }, + logical(1) ) - if (any(dropped)) { - lengths <- unique(lengths(scores[dropped])) - warn( - c( - "Dropping the per-observation {.arg stabilization_score}.", - i = "A score of length {lengths} cannot be carried through an - operation that changes the length of the weights to - {length(x)}.", - i = "The result is still marked as stabilized. Recompute the weights - on the subset if you need a score aligned with them." - ), - warning_class = "propensity_stabilization_score_warning", - # Restore is reached through vctrs' internal dispatch, whose call would - # be reported here and names nothing the caller wrote. - call = NULL + if (!any(dropped)) { + return(invisible()) + } + + lengths <- unique(lengths(scores[dropped])) + problem <- if (all(lengths == n)) { + "A score cannot be carried through an operation that may reorder the + weights without saying how, such as {.fn vctrs::vec_slice} or + {.fn dplyr::arrange}." + } else { + "A score of length {lengths} cannot be carried through an operation that + changes the length of the weights to {n}." + } + + warn( + c( + "Dropping the per-observation {.arg stabilization_score}.", + i = problem, + i = "The result is still marked as stabilized. Subset with {.code [}, + which reorders the score with the weights, or recompute the weights + on the result if you need a score aligned with them." + ), + warning_class = "propensity_stabilization_score_warning", + # Restore is reached through vctrs' internal dispatch, whose call would + # be reported here and names nothing the caller wrote. + call = NULL + ) +} + +# The weights with every per-observation score removed, so that a slice built +# from them has no score for its restore to drop and announce. +without_observation_scores <- function(x) { + if (length(attr(x, "stabilization_score")) > 1) { + attr(x, "stabilization_score") <- NULL + } + + meta <- attr(x, psw_joint_attr) + if (any(lengths(meta$stabilization_score) > 1)) { + meta$stabilization_score[lengths(meta$stabilization_score) > 1] <- list( + NULL ) + attr(x, psw_joint_attr) <- meta } - carry_psw_metadata(x, to, in_place = in_place) + x } # `[` is the one slice that knows its subscript, so it carries the position -# records through it rather than leaving the restore behind `NextMethod()` to -# drop them. An empty result is left as that restore builds it, since a -# prototype keeps the records it was sliced with, and so are weights with no -# position record to carry. +# records and the per-observation scores through it rather than leaving the +# restore behind `NextMethod()` to drop them. `x[]` takes every unit where it +# is. The slice itself is taken from weights without their per-observation +# scores, so its restore has nothing to drop and announce; the result is then +# rebuilt from the weights as given. An empty result is built as a restore +# builds it, since a prototype keeps what it was sliced with. #' @export `[.psw` <- function(x, i, ...) { + if (missing(i)) { + return(x) + } + + source <- x + has_scores <- any(lengths(psw_stabilization_scores(x)) > 1) + if (has_scores) { + x <- without_observation_scores(x) + } + out <- NextMethod() - if ( - !inherits(out, "psw") || - length(out) == 0 || - !any(psw_modification_meta %in% names(attributes(x))) - ) { + if (!inherits(out, "psw")) { return(out) } - i <- if (missing(i)) { - seq_along(x) - } else { - vec_as_location(i, n = length(x), names = names(x)) + has_records <- any(psw_modification_meta %in% names(attributes(source))) + if (!has_records && !has_scores) { + return(out) + } + + if (length(out) == 0) { + return(carry_psw_metadata(vec_data(out), source)) } - carry_psw_metadata(vec_data(out), x, i = i) + loc <- vec_as_location(i, n = length(source), names = names(source)) + warn_dropped_scores(source, length(loc), i = loc) + carry_psw_metadata(vec_data(out), source, i = loc) } # Marking weights as missing moves no unit, so it goes through base `[<-`, which @@ -2064,11 +2169,14 @@ cast_to_psw <- function(x, to) { x <- vec_cast(vec_data(x), to = double()) attributes(x) <- NULL - # `to`'s records describe `to`'s units, not the data being cast, so their - # positions are dropped whatever the length. Subassignment casts the - # replacement too, but base `[<-` then keeps the target's own attributes, so - # the records the cast carries never reach its result. - carry_psw_metadata(x, to) + # A full-length `to` describes its own units, not the data being cast, so its + # position records and per-observation scores are dropped whatever the + # length. Subassignment casts the replacement too, but base `[<-` then keeps + # the target's own attributes, so what the cast carries never reaches its + # result. A prototype holds no units; a score it carries is kept for data of + # the score's length, as the restore that follows expects, while its + # positions, which name units of their own, are dropped. + carry_psw_metadata(x, to, in_place = length(to) == 0) } # A cast returns `x`'s values in `to`'s type, and a psw's type is the whole diff --git a/man/ipw-methods.Rd b/man/ipw-methods.Rd index 049441ce..85dce43c 100644 --- a/man/ipw-methods.Rd +++ b/man/ipw-methods.Rd @@ -1645,9 +1645,10 @@ solved, with an error of class \code{propensity_ipw_sigma_error}. Rebuild the weights with the pooled default or with one number to use \code{ipw()}. It bears on a \code{stabilization_score} in the same way. A score written per -observation is one value per unit, so it does not survive the rows being -restricted: subsetting the weights drops it, and a model frame that drops -incomplete rows leaves it at the length the weights were built at. Either way +observation is one value per unit. Subsetting or reordering the weights with +\code{[} carries it along, but a slice that cannot place it, such as +\code{vctrs::vec_slice()} or \code{dplyr::arrange()}, drops it, and a model frame that +drops incomplete rows leaves it at the length the weights were built at. Either way the record still names a score as the numerator and the score in hand no longer describes the observations being weighted, so \code{ipw()} refuses before anything is solved, with an error of class diff --git a/man/psw.Rd b/man/psw.Rd index a049888e..2a2b207d 100644 --- a/man/psw.Rd +++ b/man/psw.Rd @@ -229,9 +229,14 @@ whole. vctrs' own assignment, \code{\link[vctrs:vec_assign]{vctrs::vec_assign()} a slice does and cannot be told apart from one, so it drops the positions, and so do the helpers built on it or on a combine, such as \code{tidyr::replace_na()}, \code{dplyr::coalesce()}, \code{dplyr::if_else()}, and -\code{dplyr::case_when()}. A \code{stabilization_score} with more than one value is -carried when the result comes back at the length it was recorded on and -dropped when it does not. +\code{dplyr::case_when()}. + +A \code{stabilization_score} with more than one value, on the weights or on a +component of a \code{\link[=wt_joint]{wt_joint()}} product, is in the order of the units too. \code{[} +subsets it with the weights, elementwise arithmetic keeps it, and any other +route through vctrs that brings back observations drops it with a warning of +class \code{propensity_stabilization_score_warning}, since the score may no longer +line up with the weights. Dropping the \code{stabilization_score} warns, because the score was supplied by the user and the weights can be recomputed on the subset. Dropping a diff --git a/tests/testthat/test-ipw-continuous.R b/tests/testthat/test-ipw-continuous.R index 6405c865..c67b4ce7 100644 --- a/tests/testthat/test-ipw-continuous.R +++ b/tests/testthat/test-ipw-continuous.R @@ -3103,9 +3103,9 @@ continuous_seed_fits <- function( # A numerator the caller fixed rather than one anything estimates, which is the # third thing a set of continuous weights can be stabilized on. The score is the # single value that scales every weight rather than one value per observation: -# an outcome model that drops a row subsets the weights, and a per-observation -# score is dropped when it does, so only a scalar reaches `ipw()` intact from a -# frame with a gap in it. +# the model frame of an outcome model that drops a row leaves a per-observation +# score at the length the weights were built at, so only a scalar reaches +# `ipw()` intact from a frame with a gap in it. continuous_seed_score <- 0.4 # `sim_continuous_numerator_gap()` drops a single row, and the exposure moments @@ -3411,12 +3411,11 @@ test_that("a gam numerator model is seeded at its own residual moment", { # ---- weights whose per-observation stabilization score was dropped ---------- # -# A `stabilization_score` the caller wrote per observation is one value per unit, -# so an operation that changes the length of the weights cannot re-index it and -# drops it. That drop is reported where it happens: a marginal structural model -# fit over a frame with a gap in it subsets the weights while it builds its own -# model frame, and the weights that come back out of that frame carry no score -# aligned with them. +# A `stabilization_score` the caller wrote per observation is one value per unit. +# `[` re-indexes it with the weights, a slice that cannot place it drops it with +# a warning, and a marginal structural model fit over a frame with a gap in it +# builds a model frame whose weights come back shorter than the score they +# still carry, so none of the score is aligned with them. # # What the record still says is that a score is what stabilized them, because # the density record describes how the weights were built rather than what @@ -3438,15 +3437,14 @@ test_that("ipw() refuses weights whose per-observation score was dropped", { dat <- sim_continuous_seed_gap() kept <- !is.na(dat$w) - # The drop happens where the marginal structural model subsets the weights, - # and is asserted here so that the only condition left for the call below is - # the one being pinned. - expect_warning( + # The fit itself is silent: whatever it subsets with `[` keeps the score + # aligned, and the model frame leaves it stale without passing through a + # restore. Asserting that here leaves the refusal below as the only condition. + expect_no_warning( fits <- continuous_seed_fits( dat, stab_score = continuous_seed_score_vector(dat) - ), - class = "propensity_stabilization_score_warning" + ) ) # What this block pins is the refusal itself. Whether anything is raised on @@ -3466,12 +3464,11 @@ test_that("weights whose per-observation score was dropped raise nothing raw", { dat <- sim_continuous_seed_gap() kept <- !is.na(dat$w) - expect_warning( + expect_no_warning( fits <- continuous_seed_fits( dat, stab_score = continuous_seed_score_vector(dat) - ), - class = "propensity_stabilization_score_warning" + ) ) # The refusal has to come before the ratio is built. A score of the length the @@ -3498,9 +3495,10 @@ test_that("ipw() refuses weights whose score the subset dropped outright", { kept <- !is.na(dat$w) sub <- dat[kept, ] - # The second shape the same drop arrives in. Restricting the rows by hand - # subsets the weights rather than shortening them behind their record, so the - # score is gone rather than stale, and the record still names it. Nothing + # The second shape the same drop arrives in. Restricting the rows with a + # slice that cannot place the score, rather than shortening the weights behind + # their record, leaves the score gone rather than stale, and the record still + # names it. Nothing # recycles here and nothing raw is raised, so what a caller who wrote this # would otherwise be told is that the weights disagree with the models they # were built from, which is not what happened. @@ -3511,8 +3509,13 @@ test_that("ipw() refuses weights whose score the subset dropped outright", { stabilize = TRUE, stab_score = continuous_seed_score_vector(dat) ) + # `[` places the score with the weights, so only a slice drops it. + expect_identical( + stabilization_score(wts[kept]), + continuous_seed_score_vector(dat)[kept] + ) expect_warning( - wts_kept <- wts[kept], + wts_kept <- vctrs::vec_slice(wts, kept), class = "propensity_stabilization_score_warning" ) expect_null(stabilization_score(wts_kept)) diff --git a/tests/testthat/test-ipw-joint-continuous.R b/tests/testthat/test-ipw-joint-continuous.R index 9628b1c1..6133c0c2 100644 --- a/tests/testthat/test-ipw-joint-continuous.R +++ b/tests/testthat/test-ipw-joint-continuous.R @@ -2336,8 +2336,8 @@ test_that("the joint route rebuilds a binary component stabilized on a score", { test_that("the weights mismatch names a component whose score was dropped", { dat <- sim_joint_continuous() - # A score holds one value per observation, so an operation that changes the - # length of the weights drops it. What is left is a component the record says + # A score holds one value per observation, so a slice that cannot place it + # drops it. What is left is a component the record says # was stabilized and holds no vector for, which is what a component # stabilized on the marginal proportion looks like: the system stands the # marginal proportion in, reaches a different product, and the preflight is @@ -2348,11 +2348,11 @@ test_that("the weights mismatch names a component whose score was dropped", { half <- seq_len(floor(nrow(dat) / 2)) expect_warning( - first <- fx$wts[half], + first <- vctrs::vec_slice(fx$wts, half), class = "propensity_stabilization_score_warning" ) expect_warning( - second <- fx$wts[-half], + second <- vctrs::vec_slice(fx$wts, -half), class = "propensity_stabilization_score_warning" ) @@ -2380,8 +2380,8 @@ test_that("a component's score left stale by a model frame is refused", { dat$w[order(dat$e, decreasing = TRUE)[seq_len(10)]] <- NA kept <- !is.na(dat$w) - # The other way the same drop arrives. Subsetting the weights empties the - # slot and marks it, which the block above pins; a model frame instead drops + # The other way the same drop arrives. A slice empties the slot and marks + # it, which the block above pins; a model frame instead drops # the incomplete rows in C and re-attaches the record whole, so the score # reaches `ipw()` at the length the product was built at rather than at the # length of the rows it is about to weight. Multiplying that score into a @@ -2390,16 +2390,14 @@ test_that("a component's score left stale by a model frame is refused", { # the component whose score is the wrong length. dose_score <- dnorm(dat$e, mean(dat$e), stats::sd(dat$e)) - # The drop is reported where the outcome model restricts the rows, and is - # asserted here so that the only condition left for the call below is the one - # being pinned. - expect_warning( + # The fit is silent: whatever it subsets with `[` keeps the score aligned, + # and the model frame leaves it stale without passing through a restore. + expect_no_warning( fx <- fit_joint_continuous( dat, dose_score = dose_score, outcome_rhs = "a * e + w" - ), - class = "propensity_stabilization_score_warning" + ) ) seen <- character() diff --git a/tests/testthat/test-ipw-se-method.R b/tests/testthat/test-ipw-se-method.R index dae4bf71..ed3afb40 100644 --- a/tests/testthat/test-ipw-se-method.R +++ b/tests/testthat/test-ipw-se-method.R @@ -2168,13 +2168,13 @@ test_that("linearization rejects stabilized weights whose score was dropped", { stabilization_score = score ) - # Slicing a psw drops a per-observation score it can no longer align, and says - # so, but leaves the weights marked stabilized. That is the state below: the + # A slice that cannot place a per-observation score drops it, and says so, + # but leaves the weights marked stabilized. That is the state below: the # values are still the score-stabilized ones, and nothing records which score # produced them. sliced <- NULL expect_warning( - sliced <- wts[1:200], + sliced <- vctrs::vec_slice(wts, 1:200), class = "propensity_stabilization_score_warning" ) expect_true(is_stabilized(sliced)) diff --git a/tests/testthat/test-psw-reorder-score.R b/tests/testthat/test-psw-reorder-score.R index 1cd96d1c..e3f1377f 100644 --- a/tests/testthat/test-psw-reorder-score.R +++ b/tests/testthat/test-psw-reorder-score.R @@ -183,7 +183,9 @@ test_that("ipw() accepts weights reordered with their data", { ) expect_equal(as.numeric(sorted$w), as.numeric(rebuilt)) expected <- ipw(ps_mod, lm(y ~ a, data = sorted, weights = rebuilt)) - expect_equal(res$estimates, expected$estimates) + # The two fits solve the same system from the same start, so they agree to + # the solver's tolerance rather than bit for bit. + expect_equal(res$estimates, expected$estimates, tolerance = 1e-6) }) test_that("ipw() accepts joint weights reordered with their data", { diff --git a/tests/testthat/test-psw.R b/tests/testthat/test-psw.R index 4a939bd4..0ba6d751 100644 --- a/tests/testthat/test-psw.R +++ b/tests/testthat/test-psw.R @@ -932,7 +932,7 @@ test_that("a zero-length psw restore keeps the trimming record silently", { expect_identical(is_unit_trimmed(proto), logical(0)) }) -test_that("shortening a psw with a score and a trimming record warns only for the score", { +test_that("slicing a psw with a score and a trimming record warns only for the score", { score <- c(0.51, 0.52, 0.53, 0.54, 0.55) w <- trimmed_psw(stabilization_score = score) expect_identical(stabilization_score(w), score) @@ -949,9 +949,10 @@ test_that("shortening a psw with a score and a trimming record warns only for th expect_true(is_stabilized(out$value)) expect_true(is_ps_trimmed(out$value)) + # `[` places both, so it has nothing to announce. out <- collect_warning_classes(w[1:2]) - expect_identical(out$classes, "propensity_stabilization_score_warning") - expect_null(stabilization_score(out$value)) + expect_identical(out$classes, character()) + expect_identical(stabilization_score(out$value), score[1:2]) expect_identical(is_unit_trimmed(out$value), c(TRUE, FALSE)) expect_true(is_stabilized(out$value)) }) diff --git a/tests/testthat/test-weights.R b/tests/testthat/test-weights.R index 5b2dd0f6..0cf9928c 100644 --- a/tests/testthat/test-weights.R +++ b/tests/testthat/test-weights.R @@ -421,23 +421,18 @@ count_score_warnings <- function(expr) { list(value = value, count = count) } -test_that("vector stabilization_score is dropped with a warning when `[` shortens a psw", { +test_that("vector stabilization_score is subset with the weights when `[` shortens a psw", { score <- c(0.51, 0.52, 0.53, 0.54, 0.55, 0.56) w <- stabilized_psw(score) expect_equal(stabilization_score(w), score) - cnd <- expect_warning( - w_sub <- w[1:3], - class = "propensity_stabilization_score_warning" - ) - expect_s3_class(cnd, "propensity_warning") + w_sub <- expect_silent(w[1:3]) expect_s3_class(w_sub, "psw") expect_length(w_sub, 3) - expect_null(stabilization_score(w_sub)) - expect_null(attr(w_sub, "stabilization_score")) + expect_equal(stabilization_score(w_sub), score[1:3]) - # Every other piece of metadata is unaffected by the drop. + # Every other piece of metadata is unaffected. expect_equal(estimand(w_sub), "ate") expect_true(is_stabilized(w_sub)) expect_equal(vec_data(w_sub), vec_data(w)[1:3]) diff --git a/tests/testthat/test-wt-joint.R b/tests/testthat/test-wt-joint.R index 3088a12f..dec975de 100644 --- a/tests/testthat/test-wt-joint.R +++ b/tests/testthat/test-wt-joint.R @@ -379,14 +379,14 @@ test_that("wt_joint() records each component's stabilization score", { ) }) -test_that("a length-changing operation drops a per-observation joint score", { +test_that("a slice that cannot place it drops a per-observation joint score", { fx <- joint_wt_fixture() # The joint record names the components rather than the units, with the one # exception a score is: it holds a value per observation, and a subset it no # longer describes would be rebuilt from a numerator belonging to units the - # result does not hold. The score on the weights themselves is dropped for - # that reason, and the one inside the record is the same vector. + # result does not hold. `[` subsets it with the weights; a slice handed no + # subscript drops it, as it drops the score on the weights themselves. score_a <- seq(0.3, 0.5, length.out = nrow(fx$dat)) w_a <- withr::with_options( list(propensity.quiet = TRUE), @@ -396,8 +396,14 @@ test_that("a length-changing operation drops a per-observation joint score", { expect_identical(joint_wt_meta(joint)$stabilization_score[[1]], score_a) + subset <- expect_silent(joint[1:10]) + expect_identical( + joint_wt_meta(subset)$stabilization_score[[1]], + score_a[1:10] + ) + expect_warning( - subset <- joint[1:10], + subset <- vctrs::vec_slice(joint, 1:10), class = "propensity_stabilization_score_warning" ) expect_null(joint_wt_meta(subset)$stabilization_score[[1]]) @@ -437,7 +443,7 @@ test_that("a dropped joint score is marked apart from one never supplied", { reported <- list() subset <- withCallingHandlers( - joint[1:10], + vctrs::vec_slice(joint, 1:10), propensity_stabilization_score_warning = function(cnd) { reported <<- c(reported, list(cnd)) rlang::cnd_muffle(cnd) @@ -482,7 +488,7 @@ test_that("a dropped score and a score never supplied are different records", { wt_ate(fx$mods$a, stabilize = TRUE, stabilization_score = score_a) ) expect_warning( - marked <- wt_joint(w_a, fx$w$e)[1:10], + marked <- vctrs::vec_slice(wt_joint(w_a, fx$w$e), 1:10), class = "propensity_stabilization_score_warning" ) @@ -510,7 +516,7 @@ test_that("an unstabilized product keeps no mark of a dropped score", { wt_ate(fx$mods$a, stabilize = TRUE, stabilization_score = score_a) ) expect_warning( - marked <- wt_joint(w_a, fx$w$e)[1:10], + marked <- vctrs::vec_slice(wt_joint(w_a, fx$w$e), 1:10), class = "propensity_stabilization_score_warning" ) expect_identical(joint_wt_meta(marked)$score_dropped, c(TRUE, FALSE)) From 1d58b56dbab9620154bb502ee3c13c6f7b8f7d4f Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 11:35:18 -0400 Subject: [PATCH 54/64] add failing tests for record settings through weight combines --- tests/testthat/test-psw-combine-records.R | 293 ++++++++++++++++++++++ 1 file changed, 293 insertions(+) create mode 100644 tests/testthat/test-psw-combine-records.R diff --git a/tests/testthat/test-psw-combine-records.R b/tests/testthat/test-psw-combine-records.R new file mode 100644 index 00000000..33cf147e --- /dev/null +++ b/tests/testthat/test-psw-combine-records.R @@ -0,0 +1,293 @@ +# What combined weights keep of their modification records -------------------- + +# Weights built from differently trimmed or truncated scores, or truncated at +# different bounds, target different estimands, so they have no common type. +# The combine compares what each record says about the modification, its method, +# bounds, and refit flag, and keeps that part on the result, so a later combine, +# `is_refit()`, and the footer can still read it. The positions are dropped, +# since nothing tells the combine where each input's units land. + +combine_wt_truncated <- function(upper) { + wt_trunc(psw(c(1, 2, 50, 3, 4, 5, 6, 7, 8, 100)), "count", upper = upper) +} + +combine_trimmed <- function(lower = 0.2, upper = 0.8, refit = FALSE) { + w <- psw( + c(NA, 2, 1.6, NA, 3.3), + estimand = "ate; trimmed", + trimmed = TRUE + ) + meta <- list( + method = "ps", + lower = lower, + upper = upper, + focal_inverted = FALSE, + keep_idx = c(2L, 3L, 5L), + trimmed_idx = c(1L, 4L), + n_obs = 5L + ) + if (refit) { + meta$refit <- TRUE + } + attr(w, "ps_trim_meta") <- meta + w +} + +combine_truncated <- function(lower = 0.1, upper = 0.9) { + w <- psw( + c(10, 2, 1.6, 10, 3.3), + estimand = "ate; truncated", + truncated = TRUE + ) + attr(w, "ps_trunc_meta") <- list( + method = "ps", + lower_bound = lower, + upper_bound = upper, + truncated_idx = c(1L, 4L), + n_obs = 5L + ) + w +} + +# Every order of a list of inputs. +input_orders <- function(inputs) { + orders <- list(integer()) + for (k in seq_along(inputs)) { + orders <- unlist( + lapply(orders, function(o) { + lapply(setdiff(seq_along(inputs), o), function(j) c(o, j)) + }), + recursive = FALSE + ) + } + lapply(orders, function(o) inputs[o]) +} + +# A nested combine can downgrade twice, once inside and once when the numeric +# result meets the remaining weights, so every downgrade warning is collected +# and at least one of them must name the incompatible records. +expect_combine_downgrades <- function(expr, label = NULL) { + classes <- character() + out <- withCallingHandlers( + expr, + propensity_warning = function(cnd) { + classes <<- c(classes, class(cnd)) + rlang::cnd_muffle(cnd) + } + ) + expect_true("propensity_coercion_warning" %in% classes, info = label) + expect_false(is_psw(out), info = label) + expect_type(out, "double") +} + +# Weight truncation bounds -------------------------------------------------------- + +test_that("nested combines compare weight truncation bounds", { + a <- combine_wt_truncated(2) + b <- combine_wt_truncated(1) + + expect_combine_downgrades(vctrs::vec_c(vctrs::vec_c(a, a), b)) + expect_combine_downgrades(vctrs::vec_c(b, vctrs::vec_c(a, a))) + expect_combine_downgrades(c(c(a, a), b)) + expect_combine_downgrades(c(b, c(a, a))) +}) + +test_that("nested bind_rows() compares weight truncation bounds", { + skip_if_not_installed("dplyr") + da <- data.frame(id = 1:10) + da$w <- combine_wt_truncated(2) + db <- data.frame(id = 1:10) + db$w <- combine_wt_truncated(1) + + expect_warning( + out <- dplyr::bind_rows(dplyr::bind_rows(da, da), db), + class = "propensity_coercion_warning" + ) + expect_false(is_psw(out$w)) + + expect_warning( + out <- dplyr::bind_rows(db, dplyr::bind_rows(da, da)), + class = "propensity_coercion_warning" + ) + expect_false(is_psw(out$w)) +}) + +test_that("agreeing weight truncation records survive a combine without positions", { + a <- combine_wt_truncated(2) + + out <- expect_silent(vctrs::vec_c(a, a)) + expect_s3_class(out, "psw") + expect_positions_dropped( + attr(out, "psw_trunc_meta"), + attr(a, "psw_trunc_meta") + ) + expect_error( + is_unit_wt_truncated(out), + class = "propensity_missing_meta_error" + ) + expect_true(any( + utils::capture.output(print(out)) == "truncation: count 2 (upper 8)" + )) + + again <- expect_silent(c(out, a)) + expect_positions_dropped( + attr(again, "psw_trunc_meta"), + attr(a, "psw_trunc_meta") + ) +}) + +# Trimming records ---------------------------------------------------------------- + +test_that("weights trimmed at different cutoffs do not combine", { + t1 <- combine_trimmed(0.2, 0.8) + t2 <- combine_trimmed(0.3, 0.7) + + expect_combine_downgrades(vctrs::vec_c(t1, t2)) + expect_combine_downgrades(vctrs::vec_c(t2, t1)) + expect_combine_downgrades(c(t1, t2)) + expect_combine_downgrades(vctrs::vec_c(vctrs::vec_c(t1, t1), t2)) + expect_combine_downgrades(vctrs::vec_c(t2, vctrs::vec_c(t1, t1))) + expect_combine_downgrades(c(c(t1, t1), t2)) +}) + +test_that("weights from a refit and an unrefit trim do not combine", { + refit <- combine_trimmed(refit = TRUE) + plain <- combine_trimmed(refit = FALSE) + + expect_combine_downgrades(vctrs::vec_c(refit, plain)) + expect_combine_downgrades(vctrs::vec_c(plain, refit)) + expect_combine_downgrades(vctrs::vec_c(vctrs::vec_c(refit, refit), plain)) + expect_combine_downgrades(c(plain, c(refit, refit))) +}) + +test_that("agreeing trimming records survive a combine without positions", { + refit <- combine_trimmed(refit = TRUE) + + out <- expect_silent(vctrs::vec_c(refit, refit)) + expect_s3_class(out, "psw") + expect_positions_dropped(ps_trim_meta(out), ps_trim_meta(refit)) + expect_true(is_refit(out)) + expect_error(is_unit_trimmed(out), class = "propensity_missing_meta_error") + + plain <- expect_silent(c(combine_trimmed(), combine_trimmed())) + expect_false(is_refit(plain)) +}) + +test_that("is_refit() answers for combined weights from a refit model", { + set.seed(42) + n <- 60 + z <- rnorm(n) + x <- rbinom(n, 1, plogis(2 * z)) + fit <- glm(x ~ z, family = binomial()) + trimmed <- ps_trim( + predict(fit, type = "response"), + method = "ps", + lower = 0.2, + upper = 0.8 + ) + w2 <- wt_ate( + ps_refit(trimmed, model = fit), + .exposure = x, + exposure_type = "binary", + .focal_level = 1 + ) + + expect_true(is_refit(vctrs::vec_c(w2, w2))) +}) + +# Truncation records of the scores ------------------------------------------------ + +test_that("weights from scores truncated at different bounds do not combine", { + u1 <- combine_truncated(0.1, 0.9) + u2 <- combine_truncated(0.05, 0.95) + + expect_combine_downgrades(vctrs::vec_c(u1, u2)) + expect_combine_downgrades(vctrs::vec_c(vctrs::vec_c(u1, u1), u2)) + expect_combine_downgrades(c(u2, c(u1, u1))) + + out <- expect_silent(vctrs::vec_c(u1, u1)) + expect_positions_dropped(ps_trunc_meta(out), ps_trunc_meta(u1)) +}) + +# Folds of three ------------------------------------------------------------------ + +test_that("a disagreement is caught in every order of a three-input fold", { + sets <- list( + wt = list( + combine_wt_truncated(2), + combine_wt_truncated(2), + combine_wt_truncated(1) + ), + trim = list( + combine_trimmed(0.2, 0.8), + combine_trimmed(0.2, 0.8), + combine_trimmed(0.3, 0.7) + ), + refit = list( + combine_trimmed(refit = TRUE), + combine_trimmed(refit = TRUE), + combine_trimmed(refit = FALSE) + ), + trunc = list( + combine_truncated(0.1, 0.9), + combine_truncated(0.1, 0.9), + combine_truncated(0.05, 0.95) + ) + ) + + for (label in names(sets)) { + for (inputs in input_orders(sets[[label]])) { + expect_combine_downgrades(vctrs::vec_c(!!!inputs), label) + expect_combine_downgrades( + vctrs::vec_c(vctrs::vec_c(!!!inputs[1:2]), inputs[[3]]), + label + ) + expect_combine_downgrades( + vctrs::vec_c(inputs[[1]], vctrs::vec_c(!!!inputs[2:3])), + label + ) + } + } +}) + +test_that("agreeing records survive every order of a three-input fold", { + a <- combine_wt_truncated(2) + # Flagged as truncated with no record, which agrees with any bound. + bare <- psw(c(1, 2), wt_truncated = TRUE) + + for (inputs in input_orders(list(a, a, bare))) { + out <- expect_silent(vctrs::vec_c(!!!inputs)) + expect_s3_class(out, "psw") + expect_positions_dropped( + attr(out, "psw_trunc_meta"), + attr(a, "psw_trunc_meta") + ) + + nested <- expect_silent( + vctrs::vec_c(vctrs::vec_c(!!!inputs[1:2]), inputs[[3]]) + ) + expect_positions_dropped( + attr(nested, "psw_trunc_meta"), + attr(a, "psw_trunc_meta") + ) + } +}) + +test_that("a record without settings to compare still conflicts through a bare input", { + a <- combine_wt_truncated(2) + b <- combine_wt_truncated(1) + bare <- psw(c(1, 2), wt_truncated = TRUE) + + for (inputs in input_orders(list(a, bare, b))) { + expect_combine_downgrades(vctrs::vec_c(!!!inputs)) + } +}) + +test_that("a flagged psw with no trimming record takes the other record", { + t1 <- combine_trimmed(refit = TRUE) + bare <- psw(c(1, 2), estimand = "ate; trimmed", trimmed = TRUE) + + out <- expect_silent(vctrs::vec_c(bare, t1)) + expect_positions_dropped(ps_trim_meta(out), ps_trim_meta(t1)) + expect_true(is_refit(out)) +}) From 726ee5cb378576347bc065052e0d1af1696c1c58 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 11:43:16 -0400 Subject: [PATCH 55/64] compare and keep record settings when weights are combined --- NEWS.md | 11 ++ R/ps_trim.R | 6 +- R/psw.R | 129 +++++++++++------- man/is_wt_truncated.Rd | 5 +- man/psw.Rd | 16 ++- tests/testthat/test-combine-single-modified.R | 28 ++-- tests/testthat/test-psw-reorder-records.R | 6 +- tests/testthat/test-psw-wt-trunc.R | 13 +- tests/testthat/test-psw.R | 25 ++-- 9 files changed, 155 insertions(+), 84 deletions(-) diff --git a/NEWS.md b/NEWS.md index 45654997..a3cbd292 100644 --- a/NEWS.md +++ b/NEWS.md @@ -164,6 +164,17 @@ and `ps_refit()` now refuse such a result with an error of class `propensity_missing_meta_error`. +* Combining `psw` objects now compares the trimming and truncation records of + the scores they were built from, including whether the trimmed model was + refit, as well as the weight truncation bound, and keeps each record without + its positions on the result. Weights trimmed at different cutoffs, or from a + refit and an unrefit trim, previously combined silently, and a combined result + lost its records entirely, so a later combine merged weights truncated at + different bounds without a warning and `is_refit()` refused the result. + Such combines now warn with a `propensity_coercion_warning` and return a + numeric vector, in one call or across nested ones, and `is_refit()` and the + printed footer read a combined result's records. + * A per-observation `stabilization_score`, on a `psw` or inside the record of a `wt_joint()` product, now follows the weights through `[`, so `rev()`, `sort()`, and a data frame reordered with `order()` keep each unit's score diff --git a/R/ps_trim.R b/R/ps_trim.R index 61ef6977..e2a1afa9 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -2153,12 +2153,16 @@ vec_arith.ps_trim.list <- function(op, x, y, ...) { # can still have been trimmed at different places. A trim of a dose model is # also described by the spread and the density family it was read at, and a # vector of scores by whether they are the complement of what the model reports, -# since scores for different levels are not scores of one trimming. +# since scores for different levels are not scores of one trimming. A trim of a +# categorical score matrix is described by its threshold (`delta`) or by the +# optimal cutoff it found (`lambda`). trim_parameters <- function(meta) { fields <- c( "method", "lower", "upper", + "delta", + "lambda", "cutoff", "q_lower", "q_upper", diff --git a/R/psw.R b/R/psw.R index e637b147..5bcb7265 100644 --- a/R/psw.R +++ b/R/psw.R @@ -104,13 +104,15 @@ #' #' Combining `psw` objects with [c()] preserves the class only when all #' metadata matches; mismatched metadata produces a warning and falls back to a -#' plain numeric vector. Concatenation appends one set of observations to -#' another, so the positions a modification record names would describe units -#' from the other input; those records are dropped from the result whether or -#' not the inputs agree on them. Weights whose own values were truncated are -#' combined only when the records they carry name the same bound, since weights -#' bounded differently describe different estimands; a record already dropped -#' agrees with any bound. The calibration record (`ps_calib_meta`) names the +#' plain numeric vector. The trimming, truncation, and weight truncation +#' records are compared by what they say about the modification: weights built +#' from scores trimmed or truncated differently, from a refit and an unrefit +#' trim, or truncated at different bounds describe different estimands and are +#' combined only as numbers. Weights flagged as modified with no record agree +#' with any record. Concatenation appends one set of observations to another, so +#' the positions a record names would describe units from the other input; the +#' result keeps each record without its positions, which [is_refit()], the +#' printed footer, and a later combine still read. The calibration record (`ps_calib_meta`) names the #' curve the scores were calibrated with rather than any position, the #' categorical attributes name exposure levels, and the exposure records #' describe the exposure rather than any unit, so all of them carry by the @@ -866,8 +868,9 @@ is_refit.psw <- function(x) { #' positions of the weights it moved. `is_unit_wt_truncated()` answers from #' those positions, so the record follows the rules [psw] describes for the #' records a modified propensity score leaves: it is kept through arithmetic -#' and subassignment, re-indexed through the subscript of `[`, and dropped by -#' any other slice and by a combine of several inputs. The `wt_truncated` flag describes the weights as +#' and subassignment, re-indexed through the subscript of `[`, and loses its +#' positions to any other slice and to a combine, which keeps the method and +#' bounds. The `wt_truncated` flag describes the weights as #' a whole and is kept through all of those, so `is_wt_truncated()` keeps its #' answer where `is_unit_wt_truncated()` has none to give. #' @@ -978,16 +981,63 @@ wt_trunc_parameters <- function(meta) { meta[c("method", "lower", "upper", "lower_value", "upper_value")] } -# The bound a psw was truncated at, read from its record or, on a prototype in -# the middle of a combine, from the bound the inputs before it agreed on. `NULL` -# when neither is present, which agrees with any bound. -psw_trunc_bound <- function(x) { - meta <- attr(x, "psw_trunc_meta") - if (!is.null(meta)) { - return(wt_trunc_parameters(unclass(meta))) +# How each modification record a psw carries is described, as opposed to which +# units it touched, and how a disagreement on it is named. A combine compares +# these, since weights modified differently target different estimands. The +# refit flag is part of a trimming's description: weights from a refit model and +# from the model the trim was read off are different weights. +psw_record_settings <- function(field, meta) { + switch( + field, + ps_trim_meta = c(trim_parameters(meta), list(refit = isTRUE(meta$refit))), + ps_trunc_meta = trunc_parameters(meta), + psw_trunc_meta = wt_trunc_parameters(unclass(meta)) + ) +} + +psw_record_problems <- c( + ps_trim_meta = "different trimming parameters", + ps_trunc_meta = "different truncation parameters", + psw_trunc_meta = "different weight truncation bounds" +) + +# The first record the two sets of weights describe differently, named the way +# the coercion warning names it, or `NULL` when they agree. A record only one of +# them carries has nothing to disagree with, as for the other carried +# attributes: weights flagged as modified with no record agree with any record. +psw_record_disagreement <- function(x, y) { + for (field in psw_modification_meta) { + x_meta <- attr(x, field) + y_meta <- attr(y, field) + if ( + !is.null(x_meta) && + !is.null(y_meta) && + !identical( + psw_record_settings(field, x_meta), + psw_record_settings(field, y_meta) + ) + ) { + return(psw_record_problems[[field]]) + } } - attr(x, psw_trunc_bound_attr) + NULL +} + +# The records a combined prototype carries: each input's description of its +# modification, without the positions, which would name units of one input +# among the combined observations. The inputs agree wherever both carry one, so +# the first present is the one kept. +combined_psw_records <- function(x, y) { + records <- lapply(psw_modification_meta, function(field) { + meta <- attr(x, field) + if (is.null(meta)) { + meta <- attr(y, field) + } + if (!is.null(meta)) drop_psw_record(field, meta) + }) + names(records) <- psw_modification_meta + records } # The weight truncation record travels the routes the score-scale records @@ -1550,12 +1600,6 @@ psw_carried_attrs <- c( # recorded here rather than guarded against. psw_conflicted_attr <- "psw_conflicted_attrs" -# The bound parameters a fold has found its inputs to agree on so far. A -# prototype carries no weight truncation record, since the record names -# positions, so without this the third input of a combine would be compared -# against a prototype with nothing to disagree with. It is copied and dropped -# exactly as `psw_conflicted_attr` is. -psw_trunc_bound_attr <- "psw_trunc_bound" conflicted_psw_attrs <- function(x) { out <- attr(x, psw_conflicted_attr) @@ -1599,12 +1643,8 @@ aligned_psw_attrs <- function(to, n, in_place = FALSE, i = NULL) { # result that holds no observations is the one thing vctrs cannot tell apart # from the prototype it was built from, so it keeps the record; it names # nothing about observations there are none of. - # - # The bound a fold has agreed on is the same kind of record and is carried the - # same way, for the same reason. if (n == 0) { attrs[psw_conflicted_attr] <- list(attr(to, psw_conflicted_attr)) - attrs[psw_trunc_bound_attr] <- list(attr(to, psw_trunc_bound_attr)) } attrs @@ -2099,25 +2139,26 @@ vec_ptype2.psw.psw <- function(x, y, ...) { return(double()) } - # Weights truncated at different bounds target different estimands, so they - # have no common type. Only a combine sees both inputs' records, which is why - # the bound is compared here and not in `psw_type_disagreement()`. - x_bound <- psw_trunc_bound(x) - y_bound <- psw_trunc_bound(y) - if (!is.null(x_bound) && !is.null(y_bound) && !identical(x_bound, y_bound)) { - warn_incompatible_metadata(x, y, "different weight truncation bounds") + # Weights trimmed or truncated differently, or truncated at different bounds, + # target different estimands, so they have no common type. Only a combine + # sees both inputs' records, which is why they are compared here and not in + # `psw_type_disagreement()`, which a cast also reads. + problem <- psw_record_disagreement(x, y) + if (!is.null(problem)) { + warn_incompatible_metadata(x, y, problem) return(double()) } # The prototype is shared by inputs whose observations are appended one after # another, so the positions a modification record names would describe units # from the other input. Nothing rebuilding the combined vector is handed the - # offsets, so the records are left off the prototype whether or not the inputs - # agree on them. The calibration record names a curve rather than positions, - # the categorical attributes name exposure levels, the exposure records - # describe the exposure rather than any unit, and the joint record names the - # two components a product was built from, so all of them mean the same thing - # at the combined length. + # offsets, so the records reach the prototype without their positions, which + # keeps what they say about the modification for the next pair of a fold to + # compare and for the result to report. The calibration record names a curve + # rather than positions, the categorical attributes name exposure levels, the + # exposure records describe the exposure rather than any unit, and the joint + # record names the two components a product was built from, so all of them + # mean the same thing at the combined length. merged <- merge_psw_attrs(x, y, 0, fields = psw_length_free_attrs) if (length(merged$conflicts) > 0) { warn_conflicting_psw_attrs(merged$conflicts) @@ -2133,6 +2174,7 @@ vec_ptype2.psw.psw <- function(x, y, ...) { wt_truncated = is_wt_truncated(x), attrs = c( list(stabilization_score = stabilization_score(x)), + combined_psw_records(x, y), merged$attrs ) ) @@ -2141,13 +2183,6 @@ vec_ptype2.psw.psw <- function(x, y, ...) { attr(out, psw_conflicted_attr) <- merged$conflicted } - # The prototype drops the record, so the bound the two inputs agreed on is - # handed on separately for the next pair of the fold to compare against. - if (is.null(x_bound)) { - x_bound <- y_bound - } - attr(out, psw_trunc_bound_attr) <- x_bound - out } diff --git a/man/is_wt_truncated.Rd b/man/is_wt_truncated.Rd index 7aca6bdf..2de2f2f0 100644 --- a/man/is_wt_truncated.Rd +++ b/man/is_wt_truncated.Rd @@ -36,8 +36,9 @@ attribute, holding the method, the bound as given and as applied, and the positions of the weights it moved. \code{is_unit_wt_truncated()} answers from those positions, so the record follows the rules \link{psw} describes for the records a modified propensity score leaves: it is kept through arithmetic -and subassignment, re-indexed through the subscript of \code{[}, and dropped by -any other slice and by a combine of several inputs. The \code{wt_truncated} flag describes the weights as +and subassignment, re-indexed through the subscript of \code{[}, and loses its +positions to any other slice and to a combine, which keeps the method and +bounds. The \code{wt_truncated} flag describes the weights as a whole and is kept through all of those, so \code{is_wt_truncated()} keeps its answer where \code{is_unit_wt_truncated()} has none to give. diff --git a/man/psw.Rd b/man/psw.Rd index 2a2b207d..af7a8570 100644 --- a/man/psw.Rd +++ b/man/psw.Rd @@ -189,13 +189,15 @@ comment. Combining \code{psw} objects with \code{\link[=c]{c()}} preserves the class only when all metadata matches; mismatched metadata produces a warning and falls back to a -plain numeric vector. Concatenation appends one set of observations to -another, so the positions a modification record names would describe units -from the other input; those records are dropped from the result whether or -not the inputs agree on them. Weights whose own values were truncated are -combined only when the records they carry name the same bound, since weights -bounded differently describe different estimands; a record already dropped -agrees with any bound. The calibration record (\code{ps_calib_meta}) names the +plain numeric vector. The trimming, truncation, and weight truncation +records are compared by what they say about the modification: weights built +from scores trimmed or truncated differently, from a refit and an unrefit +trim, or truncated at different bounds describe different estimands and are +combined only as numbers. Weights flagged as modified with no record agree +with any record. Concatenation appends one set of observations to another, so +the positions a record names would describe units from the other input; the +result keeps each record without its positions, which \code{\link[=is_refit]{is_refit()}}, the +printed footer, and a later combine still read. The calibration record (\code{ps_calib_meta}) names the curve the scores were calibrated with rather than any position, the categorical attributes name exposure levels, and the exposure records describe the exposure rather than any unit, so all of them carry by the diff --git a/tests/testthat/test-combine-single-modified.R b/tests/testthat/test-combine-single-modified.R index b7f1c28f..b099d5cd 100644 --- a/tests/testthat/test-combine-single-modified.R +++ b/tests/testthat/test-combine-single-modified.R @@ -162,17 +162,20 @@ test_that("c() of one calibrated-score psw keeps its calibration record", { # Two or more inputs --------------------------------------------------------- -test_that("c() of two trimmed psw drops the positional records", { +test_that("c() of two trimmed psw drops the records' positions", { w <- single_trimmed_psw() combined <- c(w, w) expect_length(combined, 2 * length(w)) - expect_null(attr(combined, "ps_trim_meta")) + expect_positions_dropped( + attr(combined, "ps_trim_meta"), + attr(w, "ps_trim_meta") + ) expect_true(is_ps_trimmed(combined)) }) -test_that("c() of a psw split in two drops the records at the original length", { +test_that("c() of a psw split in two drops the records' positions at the original length", { # The pieces add back up to the length the records were written for, but the # result is appended from two inputs, which nothing re-indexes. w <- single_trimmed_psw() @@ -182,24 +185,33 @@ test_that("c() of a psw split in two drops the records at the original length", combined <- c(first, second) expect_length(combined, length(w)) - expect_null(attr(combined, "ps_trim_meta")) + expect_positions_dropped( + attr(combined, "ps_trim_meta"), + attr(w, "ps_trim_meta") + ) }) -test_that("c() of two weight-truncated psw drops the weight truncation record", { +test_that("c() of two weight-truncated psw drops the weight truncation record's positions", { w <- single_wt_truncated_psw() combined <- c(w, w) - expect_null(attr(combined, "psw_trunc_meta")) + expect_positions_dropped( + attr(combined, "psw_trunc_meta"), + attr(w, "psw_trunc_meta") + ) expect_true(is_wt_truncated(combined)) }) -test_that("c() of two truncated-score psw drops the truncation record", { +test_that("c() of two truncated-score psw drops the truncation record's positions", { w <- single_truncated_psw() combined <- c(w, w) - expect_null(attr(combined, "ps_trunc_meta")) + expect_positions_dropped( + attr(combined, "ps_trunc_meta"), + attr(w, "ps_trunc_meta") + ) }) # A prototype or cast target supplied by the caller ------------------------- diff --git a/tests/testthat/test-psw-reorder-records.R b/tests/testthat/test-psw-reorder-records.R index f424f092..434eeaeb 100644 --- a/tests/testthat/test-psw-reorder-records.R +++ b/tests/testthat/test-psw-reorder-records.R @@ -392,8 +392,10 @@ test_that("a combine of reordered weights still compares their bounds", { out <- expect_silent(vctrs::vec_c(rev(a), a)) expect_true(is_wt_truncated(out)) - expect_null(attr(out, "psw_trunc_meta")) - expect_null(attr(out, "psw_trunc_bound")) + expect_positions_dropped( + attr(out, "psw_trunc_meta"), + attr(a, "psw_trunc_meta") + ) expect_null(attr(out, "psw_conflicted_attrs")) expect_warning( diff --git a/tests/testthat/test-psw-wt-trunc.R b/tests/testthat/test-psw-wt-trunc.R index 75437790..19b06d16 100644 --- a/tests/testthat/test-psw-wt-trunc.R +++ b/tests/testthat/test-psw-wt-trunc.R @@ -360,14 +360,14 @@ test_that("weights that differ in weight truncation status do not cast to each o ) }) -test_that("combining weight-truncated psw objects keeps the flag and drops the record", { +test_that("combining weight-truncated psw objects keeps the flag and the bound", { w <- wt_truncated_psw() out <- expect_silent(c(w, w)) expect_s3_class(out, "psw") expect_length(out, 10) expect_true(is_wt_truncated(out)) - expect_null(attr(out, "psw_trunc_meta")) + expect_positions_dropped(attr(out, "psw_trunc_meta"), wt_trunc_record()) # The record's positions describe one input, so the combined weights have no # positional answer to give. @@ -379,7 +379,7 @@ test_that("combining weight-truncated psw objects keeps the flag and drops the r proto <- expect_silent(vec_ptype2(w, w)) expect_s3_class(proto, "psw") expect_true(is_wt_truncated(proto)) - expect_null(attr(proto, "psw_trunc_meta")) + expect_positions_dropped(attr(proto, "psw_trunc_meta"), wt_trunc_record()) }) test_that("subassigning into weight-truncated weights keeps the record", { @@ -496,7 +496,7 @@ test_that("weights bounded alike combine whichever units the bound moved", { expect_s3_class(out, "psw") expect_length(out, 11) expect_true(is_wt_truncated(out)) - expect_null(attr(out, "psw_trunc_meta")) + expect_positions_dropped(attr(out, "psw_trunc_meta"), wt_trunc_record()) }) test_that("a weight-truncated psw with no record agrees with any bound", { @@ -511,16 +511,19 @@ test_that("a weight-truncated psw with no record agrees with any bound", { expect_s3_class(out, "psw") expect_length(out, 7) expect_true(is_wt_truncated(out)) + expect_positions_dropped(attr(out, "psw_trunc_meta"), wt_trunc_record()) reversed <- expect_silent(c(alt_slice, w)) expect_s3_class(reversed, "psw") expect_true(is_wt_truncated(reversed)) + expect_positions_dropped(attr(reversed, "psw_trunc_meta"), wt_trunc_record()) + # The prototype takes the one record there is. bare <- psw(c(1, 2), estimand = "ate", wt_truncated = TRUE) proto <- expect_silent(vec_ptype2(bare, w)) expect_s3_class(proto, "psw") expect_true(is_wt_truncated(proto)) - expect_null(attr(proto, "psw_trunc_meta")) + expect_positions_dropped(attr(proto, "psw_trunc_meta"), wt_trunc_record()) }) test_that("is_wt_truncated() answers FALSE for anything that is not a psw", { diff --git a/tests/testthat/test-psw.R b/tests/testthat/test-psw.R index 0ba6d751..3b5c7fb0 100644 --- a/tests/testthat/test-psw.R +++ b/tests/testthat/test-psw.R @@ -1567,13 +1567,13 @@ test_that("a psw product records an estimand only one operand names", { expect_null(estimand(expect_silent(unnamed * unnamed))) }) -test_that("combining psw objects drops the modification records", { +test_that("combining psw objects drops the modification records' positions", { w <- trimmed_psw() out <- expect_silent(c(w, w)) expect_s3_class(out, "psw") expect_length(out, 10) - expect_null(ps_trim_meta(out)) + expect_positions_dropped(ps_trim_meta(out), ps_trim_meta(w)) # Everything that is not indexed by observation survives the concatenation. expect_true(is_ps_trimmed(out)) @@ -1583,7 +1583,7 @@ test_that("combining psw objects drops the modification records", { truncated <- truncated_psw() combined <- expect_silent(c(truncated, truncated)) - expect_null(ps_trunc_meta(combined)) + expect_positions_dropped(ps_trunc_meta(combined), ps_trunc_meta(truncated)) expect_true(is_ps_truncated(combined)) # The calibration record holds no positions, so it survives the @@ -1594,20 +1594,21 @@ test_that("combining psw objects drops the modification records", { expect_true(is_ps_calibrated(combined)) }) -test_that("combining psw objects drops modification records that disagree without comment", { +test_that("combining psw objects trimmed at different cutoffs downgrades to numeric", { w <- trimmed_psw() alt <- alt_trimmed_psw() expect_false(identical(ps_trim_meta(w), ps_trim_meta(alt))) - # Concatenation drops every modification record for a reason that has nothing - # to do with whether the inputs agree, so two that disagree leave nothing to - # report. A warning here would name a record the result would have lost had - # the two been identical. - out <- expect_silent(c(w, alt)) - expect_s3_class(out, "psw") + # Weights from scores trimmed at different cutoffs target different + # estimands, so they have no common type, as for any other disagreement + # about how the weights were built. + expect_warning( + out <- c(w, alt), + class = "propensity_coercion_warning" + ) + expect_false(is_psw(out)) + expect_type(out, "double") expect_length(out, 10) - expect_null(ps_trim_meta(out)) - expect_true(is_ps_trimmed(out)) }) test_that("combining psw objects carries categorical attributes the inputs share", { From 1bd2760b5019fa0434b17bd8742d860a42e26163 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 11:48:50 -0400 Subject: [PATCH 56/64] tidy score handling on casts, assignment and is.na<- --- NEWS.md | 10 +- R/ps_trim.R | 12 ++- R/ps_trunc.R | 14 ++- R/psw.R | 48 ++++++--- R/utils.R | 16 +++ man/psw.Rd | 6 +- .../_snaps/score-assignment-records.md | 11 ++ tests/testthat/test-psw.R | 11 +- .../testthat/test-score-assignment-records.R | 102 ++++++++++++++++++ tests/testthat/test-score-slice-records.R | 7 +- 10 files changed, 211 insertions(+), 26 deletions(-) create mode 100644 tests/testthat/_snaps/score-assignment-records.md create mode 100644 tests/testthat/test-score-assignment-records.R diff --git a/NEWS.md b/NEWS.md index a3cbd292..3843662c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -168,9 +168,10 @@ the scores they were built from, including whether the trimmed model was refit, as well as the weight truncation bound, and keeps each record without its positions on the result. Weights trimmed at different cutoffs, or from a - refit and an unrefit trim, previously combined silently, and a combined result - lost its records entirely, so a later combine merged weights truncated at - different bounds without a warning and `is_refit()` refused the result. + trim that was refit and one that was not, previously combined silently, and + a combined result lost its records entirely, so a later combine merged + weights truncated at different bounds without a warning and `is_refit()` + refused the result. Such combines now warn with a `propensity_coercion_warning` and return a numeric vector, in one call or across nested ones, and `is_refit()` and the printed footer read a combined result's records. @@ -197,7 +198,8 @@ `propensity_missing_meta_error`. `vctrs::vec_assign()` and the helpers built on it drop the positions too. `[`, `sort()`, `unique()`, `rep()`, and `c()` of one input still re-index the record, and `[<-`, `x[]`, and `is.na<-` keep - it. + it; `is.na<-` moves a score it marks missing out of the retained or + truncated units, as for a score that arrived missing. * Reordering or subsetting a `psw` with `[` now carries its trimming, truncation, and weight truncation records through the subscript, as `[` diff --git a/R/ps_trim.R b/R/ps_trim.R index e2a1afa9..69f3b04e 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -2432,10 +2432,20 @@ median.ps_trim <- function(x, na.rm = FALSE, ...) { # Marking scores as missing moves no unit, so it goes through base `[<-`, which # keeps the record, rather than through vctrs' method, whose restore cannot tell -# an assignment from a reordering and drops the positions. +# an assignment from a reordering and drops the positions. A score that is now +# missing was not retained, as a score that arrived missing is not, so it leaves +# the retained set; a trimmed score is missing already and stays trimmed. #' @export `is.na<-.ps_trim` <- function(x, value) { x[value] <- NA_real_ + + meta <- ps_trim_meta(x) + if (record_covers(meta, missing_unit_count(x))) { + missing <- missing_units(x) + meta$keep_idx <- meta$keep_idx[!meta$keep_idx %in% missing] + attr(x, "ps_trim_meta") <- meta + } + x } diff --git a/R/ps_trunc.R b/R/ps_trunc.R index 44762516..abdb67c6 100644 --- a/R/ps_trunc.R +++ b/R/ps_trunc.R @@ -1861,10 +1861,22 @@ quantile.ps_trunc <- function(x, probs = seq(0, 1, 0.25), na.rm = FALSE, ...) { # Marking scores as missing moves no unit, so it goes through base `[<-`, which # keeps the record, rather than through vctrs' method, whose restore cannot tell -# an assignment from a reordering and drops the positions. +# an assignment from a reordering and drops the positions. A score that is now +# missing was moved onto no bound, as a score that arrived missing was not, so +# it leaves the truncated set. #' @export `is.na<-.ps_trunc` <- function(x, value) { x[value] <- NA_real_ + + meta <- ps_trunc_meta(x) + if (record_covers(meta, missing_unit_count(x))) { + missing <- missing_units(x) + meta$truncated_idx <- meta$truncated_idx[ + !meta$truncated_idx %in% missing + ] + attr(x, "ps_trunc_meta") <- meta + } + x } diff --git a/R/psw.R b/R/psw.R index 5bcb7265..03a89339 100644 --- a/R/psw.R +++ b/R/psw.R @@ -106,9 +106,9 @@ #' metadata matches; mismatched metadata produces a warning and falls back to a #' plain numeric vector. The trimming, truncation, and weight truncation #' records are compared by what they say about the modification: weights built -#' from scores trimmed or truncated differently, from a refit and an unrefit -#' trim, or truncated at different bounds describe different estimands and are -#' combined only as numbers. Weights flagged as modified with no record agree +#' from scores trimmed or truncated differently, from a trim that was refit +#' and one that was not, or truncated at different bounds describe different +#' estimands and are combined only as numbers. Weights flagged as modified with no record agree #' with any record. Concatenation appends one set of observations to another, so #' the positions a record names would describe units from the other input; the #' result keeps each record without its positions, which [is_refit()], the @@ -2204,14 +2204,12 @@ cast_to_psw <- function(x, to) { x <- vec_cast(vec_data(x), to = double()) attributes(x) <- NULL - # A full-length `to` describes its own units, not the data being cast, so its - # position records and per-observation scores are dropped whatever the - # length. Subassignment casts the replacement too, but base `[<-` then keeps - # the target's own attributes, so what the cast carries never reaches its - # result. A prototype holds no units; a score it carries is kept for data of - # the score's length, as the restore that follows expects, while its - # positions, which name units of their own, are dropped. - carry_psw_metadata(x, to, in_place = length(to) == 0) + # `to` describes its own units, or none if it is a prototype, and not the + # data being cast, so its position records and per-observation scores are + # dropped for any data with observations. Subassignment casts the replacement + # too, but base `[<-` then keeps the target's own attributes, so what the cast + # carries never reaches its result. + carry_psw_metadata(x, to) } # A cast returns `x`'s values in `to`'s type, and a psw's type is the whole @@ -2234,13 +2232,39 @@ vec_cast.psw.psw <- function(x, to, ...) { to, x_arg = "", to_arg = "", - details = problem + details = cast_problem_details(problem, x, to) ) } x } +# A disagreement about the score is the one a caller meets most when assigning +# weights into weights stabilized per observation, and the bare field name says +# nothing about what to do. The score belongs to the units of each vector, so +# the value's cannot be written under the target's. +cast_problem_details <- function(problem, x, to) { + scores <- list(stabilization_score(x), stabilization_score(to)) + if ( + !identical(problem, psw_type_field_problems[["stabilization_score"]]) || + !any(lengths(scores) > 1) + ) { + return(problem) + } + + c( + problem, + i = paste( + "The value's per-observation `stabilization_score` does not match the", + "target's, and a score describes the units of the weights that carry it." + ), + i = paste( + "Assign `vec_data()` of the value to keep the target's score, or rebuild", + "the weights once the values are assigned." + ) + ) +} + #' @export vec_cast.psw.double <- function(x, to, ...) cast_to_psw(x, to) diff --git a/R/utils.R b/R/utils.R index eeee07cd..3b378441 100644 --- a/R/utils.R +++ b/R/utils.R @@ -294,6 +294,22 @@ merged_units_agree <- function(values, status) { vctrs::vec_unique_count(pairs) == attr(groups, "n") } +# The units a modified score holds, one per element or, for a matrix, one per +# row, and those of them with a missing score. A row with any missing score has +# no complete probability vector, so the whole unit is missing. +missing_unit_count <- function(x) { + if (is.matrix(x)) nrow(x) else length(x) +} + +missing_units <- function(x) { + values <- score_values(x) + if (is.matrix(values)) { + which(rowSums(is.na(values)) > 0) + } else { + which(is.na(values)) + } +} + # `[` knows the subscript, which is what re-indexing a record takes. Every # occurrence of a recorded position is mapped onto the position it now holds, so # a subscript naming a position twice reports that unit twice. `NA` names no diff --git a/man/psw.Rd b/man/psw.Rd index af7a8570..6ebb1af4 100644 --- a/man/psw.Rd +++ b/man/psw.Rd @@ -191,9 +191,9 @@ Combining \code{psw} objects with \code{\link[=c]{c()}} preserves the class only metadata matches; mismatched metadata produces a warning and falls back to a plain numeric vector. The trimming, truncation, and weight truncation records are compared by what they say about the modification: weights built -from scores trimmed or truncated differently, from a refit and an unrefit -trim, or truncated at different bounds describe different estimands and are -combined only as numbers. Weights flagged as modified with no record agree +from scores trimmed or truncated differently, from a trim that was refit +and one that was not, or truncated at different bounds describe different +estimands and are combined only as numbers. Weights flagged as modified with no record agree with any record. Concatenation appends one set of observations to another, so the positions a record names would describe units from the other input; the result keeps each record without its positions, which \code{\link[=is_refit]{is_refit()}}, the diff --git a/tests/testthat/_snaps/score-assignment-records.md b/tests/testthat/_snaps/score-assignment-records.md new file mode 100644 index 00000000..05ed1ae5 --- /dev/null +++ b/tests/testthat/_snaps/score-assignment-records.md @@ -0,0 +1,11 @@ +# assigning weights with a different score explains the refusal + + Code + y[1:3] <- rev(w) + Condition + Error in `vec_cast.psw.psw()`: + ! Can't convert to . + different stabilization scores + The value's per-observation `stabilization_score` does not match the target's, and a score describes the units of the weights that carry it. + Assign `vec_data()` of the value to keep the target's score, or rebuild the weights once the values are assigned. + diff --git a/tests/testthat/test-psw.R b/tests/testthat/test-psw.R index 3b5c7fb0..29def5a7 100644 --- a/tests/testthat/test-psw.R +++ b/tests/testthat/test-psw.R @@ -169,14 +169,16 @@ test_that("vec_cast from ps_trunc carries every metadata field of the psw protot expect_equal(stabilization_score(out), 0.42) }) -test_that("vec_cast keeps a per-observation stabilization score at a matching length", { +test_that("vec_cast drops a prototype's per-observation score even at a matching length", { + # The score describes the units of the weights it was recorded on, not the + # data being cast. score <- c(0.51, 0.52, 0.53) to <- psw_cast_prototype(stabilization_score = score) out <- expect_no_warning(vec_cast(c(1, 2, 3), to = to)) expect_s3_class(out, "psw") - expect_equal(stabilization_score(out), score) + expect_null(stabilization_score(out)) expect_true(is_stabilized(out)) }) @@ -1928,7 +1930,8 @@ test_that("an integer and a double stabilization score are the same score", { test_that("a psw prototype records a score for observations it does not hold", { # A zero-length psw carries metadata for observations that have not arrived, # so there is no length for a per-observation score to be checked against. - # `vec_cast()` checks it against the length the data does arrive at. + # Data cast to it is not the data the score was recorded for, so the score is + # not carried onto it at any length. score <- c(0.51, 0.52, 0.53) proto <- expect_silent(psw( double(), @@ -1938,7 +1941,7 @@ test_that("a psw prototype records a score for observations it does not hold", { )) expect_identical(stabilization_score(proto), score) - expect_identical(stabilization_score(vec_cast(c(1, 2, 3), to = proto)), score) + expect_null(stabilization_score(vec_cast(c(1, 2, 3), to = proto))) expect_null(stabilization_score(vec_cast(c(1, 2), to = proto))) # The value checks apply to a prototype like anything else. diff --git a/tests/testthat/test-score-assignment-records.R b/tests/testthat/test-score-assignment-records.R new file mode 100644 index 00000000..b1bbd797 --- /dev/null +++ b/tests/testthat/test-score-assignment-records.R @@ -0,0 +1,102 @@ +# Scores and records through casts, subassignment, and is.na<- ---------------- + +score_stabilized_psw <- function() { + psw( + c(1, 2, 3), + estimand = "ate", + stabilized = TRUE, + stabilization_score = c(0.5, 0.6, 0.7) + ) +} + +muffle_score_warnings <- function(expr) { + withCallingHandlers( + expr, + propensity_stabilization_score_warning = function(cnd) { + rlang::cnd_muffle(cnd) + } + ) +} + +test_that("a prototype's per-observation score is not cast onto other data", { + w <- score_stabilized_psw() + + cast <- expect_silent(vctrs::vec_cast(runif(3), vctrs::vec_ptype(w))) + expect_s3_class(cast, "psw") + expect_null(stabilization_score(cast)) + expect_true(is_stabilized(cast)) + + combined <- muffle_score_warnings(vctrs::vec_c(runif(3), .ptype = w)) + expect_null(stabilization_score(combined)) + + # A single value scales every weight and still holds. + scalar <- psw(c(1, 2), estimand = "ate", stabilized = TRUE) + attr(scalar, "stabilization_score") <- 0.4 + cast <- vctrs::vec_cast(runif(3), vctrs::vec_ptype(scalar)) + expect_identical(stabilization_score(cast), 0.4) +}) + +test_that("assigning weights with a different score explains the refusal", { + w <- score_stabilized_psw() + y <- w + + expect_error( + y[1:3] <- rev(w), + class = "vctrs_error_cast" + ) + expect_snapshot(error = TRUE, { + y[1:3] <- rev(w) + }) + + # The values alone carry no score, so they are assigned under the target's. + y[1:3] <- vec_data(rev(w)) + expect_identical(vec_data(y), c(3, 2, 1)) + expect_identical(stabilization_score(y), c(0.5, 0.6, 0.7)) +}) + +test_that("is.na<- moves a retained score out of the trimming record", { + set.seed(11) + n <- 40 + z <- rnorm(n) + exposure <- rbinom(n, 1, plogis(z)) + fit <- glm(exposure ~ z, family = binomial()) + x <- ps_trim(fitted(fit), lower = 0.2, upper = 0.8) + meta <- ps_trim_meta(x) + retained <- meta$keep_idx[[1]] + trimmed <- meta$trimmed_idx + + expect_silent({ + is.na(x) <- retained + }) + + after <- ps_trim_meta(x) + expect_identical(after$keep_idx, meta$keep_idx[meta$keep_idx != retained]) + expect_identical(after$trimmed_idx, trimmed) + expect_identical(after$n_obs, meta$n_obs) + expect_false(is_unit_trimmed(x)[[retained]]) + expect_true(is.na(x[[retained]])) + + # Marking a trimmed score missing changes neither set. + expect_silent({ + is.na(x) <- trimmed[[1]] + }) + expect_identical(ps_trim_meta(x)$trimmed_idx, trimmed) + + refit <- expect_no_error(ps_refit(x, model = fit)) + expect_true(is.na(refit[[retained]])) + expect_identical(is_unit_trimmed(refit), is_unit_trimmed(x)) + expect_false(anyNA(vec_data(refit)[after$keep_idx])) +}) + +test_that("is.na<- moves a truncated score out of the truncation record", { + x <- ps_trunc(c(0.05, 0.3, 0.5, 0.95, 0.4), lower = 0.1, upper = 0.9) + expect_identical(ps_trunc_meta(x)$truncated_idx, c(1L, 4L)) + + expect_silent({ + is.na(x) <- c(TRUE, FALSE, TRUE, FALSE, FALSE) + }) + + expect_identical(ps_trunc_meta(x)$truncated_idx, 4L) + expect_identical(ps_trunc_meta(x)$n_obs, 5L) + expect_identical(is_unit_truncated(x), c(FALSE, FALSE, FALSE, TRUE, FALSE)) +}) diff --git a/tests/testthat/test-score-slice-records.R b/tests/testthat/test-score-slice-records.R index 0c59053e..85f2260d 100644 --- a/tests/testthat/test-score-slice-records.R +++ b/tests/testthat/test-score-slice-records.R @@ -133,7 +133,12 @@ test_that("subassignment and is.na<- keep the record, since no unit moves", { }) expect_s3_class(x, class(fixture$scores)[[1]]) expect_true(is.na(x[[3]]), info = label) - expect_identical(fixture$meta(x), meta, info = label) + # Unit 3 was retained and untruncated; a missing score is in neither set. + expected <- meta + if (!is.null(expected$keep_idx)) { + expected$keep_idx <- setdiff(expected$keep_idx, 3L) + } + expect_identical(fixture$meta(x), expected, info = label) expect_identical(fixture$query(x), units, info = label) } }) From 672467bda0689e1784793d5ddc38f492f1a32bdd Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 12:01:36 -0400 Subject: [PATCH 57/64] add failing tests for converting modified score matrices to data frames --- .../test-modified-score-matrix-frame.R | 271 ++++++++++++++++++ 1 file changed, 271 insertions(+) create mode 100644 tests/testthat/test-modified-score-matrix-frame.R diff --git a/tests/testthat/test-modified-score-matrix-frame.R b/tests/testthat/test-modified-score-matrix-frame.R new file mode 100644 index 00000000..7935ade9 --- /dev/null +++ b/tests/testthat/test-modified-score-matrix-frame.R @@ -0,0 +1,271 @@ +# A modified score matrix as a data frame ------------------------------------- + +# A row of a score matrix is a unit, and so is a row of the data frame it +# becomes, so each column carries the matrix's trimming or truncation record and +# the weight functions read the frame as they read the matrix. + +frame_scores_data <- function(n = 150) { + set.seed(3) + x <- rnorm(n) + lp <- cbind(0, 2 * x, -2 * x) + pr <- exp(lp) / rowSums(exp(lp)) + z <- factor( + apply(pr, 1, function(p) sample(c("a", "b", "c"), 1, prob = p)), + levels = c("a", "b", "c") + ) + dat <- data.frame(x = x, z = z, y = rnorm(n) + as.integer(z)) + fit <- nnet::multinom(z ~ x, data = dat, trace = FALSE) + + list(dat = dat, fit = fit, p = predict(fit, type = "probs")) +} + +frame_trimmed <- function(fx) { + ps_trim(fx$p, method = "ps", lower = 0.05, .exposure = fx$dat$z) +} + +frame_truncated <- function(fx) { + ps_trunc(fx$p, method = "ps", lower = 0.05, .exposure = fx$dat$z) +} + +# Every condition an expression signals, by class, and its value. +frame_conditions <- function(expr) { + seen <- character() + value <- withCallingHandlers( + expr, + warning = function(cnd) { + seen <<- c(seen, paste("warning", class(cnd)[[1]])) + invokeRestart("muffleWarning") + }, + message = function(cnd) { + seen <<- c(seen, paste("message", conditionMessage(cnd))) + invokeRestart("muffleMessage") + } + ) + list(value = value, seen = seen) +} + +test_that("the fixtures modify some units", { + fx <- frame_scores_data() + + expect_true(any(is_unit_trimmed(frame_trimmed(fx)))) + expect_false(all(is_unit_trimmed(frame_trimmed(fx)))) + expect_true(any(is_unit_truncated(frame_truncated(fx)))) +}) + +test_that("as.data.frame() keeps the trimming record on every column", { + fx <- frame_scores_data() + tr <- frame_trimmed(fx) + + out <- expect_silent(as.data.frame(tr)) + + expect_s3_class(out, "data.frame") + expect_identical(names(out), colnames(tr)) + expect_identical(rownames(out), rownames(tr)) + for (column in names(out)) { + expect_s3_class(out[[column]], "ps_trim") + expect_identical(ps_trim_meta(out[[column]]), ps_trim_meta(tr)) + expect_identical( + vec_data(out[[column]]), + unname(unclass(tr)[, column]) + ) + expect_identical(is_unit_trimmed(out[[column]]), is_unit_trimmed(tr)) + } +}) + +test_that("as.data.frame() keeps the truncation record on every column", { + fx <- frame_scores_data() + tc <- frame_truncated(fx) + + out <- expect_silent(as.data.frame(tc)) + + expect_identical(names(out), colnames(tc)) + for (column in names(out)) { + expect_s3_class(out[[column]], "ps_trunc") + expect_identical(ps_trunc_meta(out[[column]]), ps_trunc_meta(tc)) + expect_identical(is_unit_truncated(out[[column]]), is_unit_truncated(tc)) + } +}) + +test_that("as.data.frame() honours row names and unnamed matrices", { + fx <- frame_scores_data() + tr <- frame_trimmed(fx) + labels <- paste0("unit", seq_len(nrow(tr))) + + out <- as.data.frame(tr, row.names = labels) + expect_identical(rownames(out), labels) + + bare <- fx$p + dimnames(bare) <- NULL + expect_warning( + unnamed <- ps_trim(bare, method = "ps", lower = 0.05, .exposure = fx$dat$z), + class = "propensity_matrix_no_names_warning" + ) + out <- as.data.frame(unnamed) + expect_identical(names(out), c("V1", "V2", "V3")) + expect_s3_class(out$V1, "ps_trim") +}) + +test_that("tibble::as_tibble() keeps the record on every column", { + fx <- frame_scores_data() + tr <- frame_trimmed(fx) + tc <- frame_truncated(fx) + + out <- expect_silent(tibble::as_tibble(tr)) + expect_s3_class(out, "tbl_df") + expect_identical(names(out), colnames(tr)) + expect_s3_class(out$a, "ps_trim") + expect_identical(ps_trim_meta(out$a), ps_trim_meta(tr)) + + out <- expect_silent(tibble::as_tibble(tc)) + expect_s3_class(out$b, "ps_trunc") + expect_identical(ps_trunc_meta(out$b), ps_trunc_meta(tc)) +}) + +test_that("weights from the data frame match weights from the trimmed matrix", { + fx <- frame_scores_data() + tr <- frame_trimmed(fx) + df <- as.data.frame(tr) + z <- fx$dat$z + + calls <- list( + ate = function(p) wt_ate(p, .exposure = z), + att = function(p) wt_att(p, .exposure = z, .focal_level = "a"), + atu = function(p) wt_atu(p, .exposure = z, .focal_level = "a"), + atm = function(p) wt_atm(p, .exposure = z), + ato = function(p) wt_ato(p, .exposure = z), + entropy = function(p) wt_entropy(p, .exposure = z) + ) + + for (label in names(calls)) { + from_matrix <- frame_conditions(calls[[label]](tr)) + from_frame <- frame_conditions(calls[[label]](df)) + + expect_identical(from_frame$seen, from_matrix$seen, info = label) + expect_true( + "warning propensity_no_refit_warning" %in% from_frame$seen, + info = label + ) + expect_identical(from_frame$value, from_matrix$value, info = label) + expect_true(is_ps_trimmed(from_frame$value), info = label) + expect_match(estimand(from_frame$value), "; trimmed$", info = label) + expect_identical( + is_unit_trimmed(from_frame$value), + is_unit_trimmed(tr), + info = label + ) + } +}) + +test_that("weights from the data frame match weights from the truncated matrix", { + fx <- frame_scores_data() + tc <- frame_truncated(fx) + df <- as.data.frame(tc) + z <- fx$dat$z + + from_matrix <- frame_conditions(wt_ate(tc, .exposure = z)) + from_frame <- frame_conditions(wt_ate(df, .exposure = z)) + + expect_identical(from_frame$seen, from_matrix$seen) + expect_identical(from_frame$value, from_matrix$value) + expect_true(is_ps_truncated(from_frame$value)) + expect_identical( + is_unit_truncated(from_frame$value), + is_unit_truncated(tc) + ) + + from_matrix <- frame_conditions(wt_ato(tc, .exposure = z)) + from_frame <- frame_conditions(wt_ato(df, .exposure = z)) + expect_identical(from_frame$value, from_matrix$value) +}) + +test_that("weights from a refit trimmed matrix's data frame match its matrix", { + fx <- frame_scores_data() + refit <- ps_refit(frame_trimmed(fx), model = fx$fit) + df <- as.data.frame(refit) + z <- fx$dat$z + + expect_true(is_refit(df$a)) + + from_matrix <- frame_conditions(wt_ate(refit, .exposure = z)) + from_frame <- frame_conditions(wt_ate(df, .exposure = z)) + + expect_identical(from_frame$seen, from_matrix$seen) + expect_false("warning propensity_no_refit_warning" %in% from_frame$seen) + expect_identical(from_frame$value, from_matrix$value) + expect_true(is_refit(from_frame$value)) +}) + +test_that("a subset of the data frame's rows matches the same subset of the matrix", { + fx <- frame_scores_data() + tr <- frame_trimmed(fx) + df <- as.data.frame(tr) + rows <- c(40:1, 100:120) + z <- fx$dat$z[rows] + + sub <- df[rows, ] + expect_identical(ps_trim_meta(sub$a), ps_trim_meta(tr[rows, ])) + expect_identical(is_unit_trimmed(sub$c), is_unit_trimmed(tr)[rows]) + + from_matrix <- frame_conditions(wt_ate(tr[rows, ], .exposure = z)) + from_frame <- frame_conditions(wt_ate(sub, .exposure = z)) + expect_identical(from_frame$value, from_matrix$value) +}) + +test_that("ipw() refuses weights from the data frame as it refuses the matrix's", { + fx <- frame_scores_data() + dat <- fx$dat + z <- dat$z + + trimmed <- frame_trimmed(fx) + truncated <- frame_truncated(fx) + cases <- list( + trimmed = list(scores = trimmed, class = "propensity_ipw_trimmed_error"), + truncated = list( + scores = truncated, + class = "propensity_ipw_truncated_error" + ) + ) + + for (label in names(cases)) { + case <- cases[[label]] + withr::local_options(propensity.quiet = TRUE) + dat$w_matrix <- suppressWarnings( + wt_ate(case$scores, .exposure = z), + classes = "propensity_no_refit_warning" + ) + dat$w_frame <- suppressWarnings( + wt_ate(as.data.frame(case$scores), .exposure = z), + classes = "propensity_no_refit_warning" + ) + + expect_error( + ipw(fx$fit, lm(y ~ z, data = dat, weights = w_matrix)), + class = case$class, + info = label + ) + expect_error( + ipw(fx$fit, lm(y ~ z, data = dat, weights = w_frame)), + class = case$class, + info = label + ) + } +}) + +test_that("a frame whose columns disagree about the record is refused", { + fx <- frame_scores_data() + tr <- frame_trimmed(fx) + df <- as.data.frame(tr) + df$b <- vctrs::vec_slice(df$b, seq_len(nrow(df))) + + expect_error( + wt_ate(df, .exposure = fx$dat$z), + class = "propensity_matrix_type_error" + ) + + mixed <- as.data.frame(tr) + mixed$c <- vec_data(mixed$c) + expect_error( + wt_ate(mixed, .exposure = fx$dat$z), + class = "propensity_matrix_type_error" + ) +}) From b16c9ea4c98d30afb6248348e843cf58f086660e Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 12:06:27 -0400 Subject: [PATCH 58/64] keep the record when a modified score matrix becomes a data frame --- NAMESPACE | 4 ++ NEWS.md | 10 ++++ R/ps_trim.R | 34 +++++++++++++ R/ps_trunc.R | 32 ++++++++++++ R/utils.R | 92 +++++++++++++++++++++++++++++++++++ R/weights-utils.R | 18 +++++++ man/ps_trim.Rd | 7 +++ man/ps_trunc.Rd | 7 +++ tests/testthat/test-weights.R | 20 ++++---- 9 files changed, 215 insertions(+), 9 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a39ae9aa..f6d5ad23 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -21,6 +21,8 @@ S3method(Summary,ps_trunc) S3method(anyDuplicated,ps_trim) S3method(anyDuplicated,ps_trunc) S3method(as.data.frame,ipw_diagnostic_se) +S3method(as.data.frame,ps_trim_matrix) +S3method(as.data.frame,ps_trunc_matrix) S3method(as.double,ps_calib) S3method(c,ps_trim) S3method(c,ps_trunc) @@ -142,6 +144,8 @@ S3method(sort,ps_trim) S3method(sort,ps_trunc) S3method(summary,ps_trim) S3method(summary,ps_trunc) +S3method(tibble::as_tibble,ps_trim_matrix) +S3method(tibble::as_tibble,ps_trunc_matrix) S3method(unique,ps_trim) S3method(unique,ps_trunc) S3method(vec_arith,ps_calib) diff --git a/NEWS.md b/NEWS.md index 3843662c..5e20988d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -164,6 +164,16 @@ and `ps_refit()` now refuse such a result with an error of class `propensity_missing_meta_error`. +* `as.data.frame()` and `tibble::as_tibble()` of a trimmed or truncated + categorical score matrix now return columns of class `ps_trim` or + `ps_trunc` that carry the matrix's record. They previously returned plain + numeric columns, so `wt_ate()` and the other weight functions built weights + from the data frame with no trimming or truncation flag, record, or no-refit + warning. The weight functions now read such a data frame as they read the + matrix, and `ipw()` refuses the weights in the same way. A data frame whose + columns disagree about the record is refused with an error of class + `propensity_matrix_type_error`. + * Combining `psw` objects now compares the trimming and truncation records of the scores they were built from, including whether the trimmed model was refit, as well as the weight truncation bound, and keeps each record without diff --git a/R/ps_trim.R b/R/ps_trim.R index 69f3b04e..37fe410f 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -339,6 +339,13 @@ #' throughout, so a vector or matrix holding both returns a single `NA` element #' or row that neither status describes. #' +#' [as.data.frame()] and `tibble::as_tibble()` turn a matrix of scores into a +#' data frame whose columns are `ps_trim` vectors carrying the matrix's record, one +#' row per unit, so the weight functions read the data frame as they read the +#' matrix and a subset of its rows re-indexes the record. A data frame whose +#' columns are not all trimmed with the same record is refused by the weight +#' functions with an error of class `propensity_matrix_type_error`. +#' #' A record can also outlive the observations it describes, because it travels #' by routes vctrs does not see: growing a `ps_trim` by subassignment carries it #' across the length change. [is_unit_trimmed()] and [ps_refit()] therefore @@ -1973,6 +1980,33 @@ is_unit_trimmed.ps_trim_matrix <- function(x) { } +# Each column of the frame is a `ps_trim` vector carrying the matrix's record, +# so the weight functions read the frame as they read the matrix and a subset +# of its rows re-indexes the record through each column. +#' @export +as.data.frame.ps_trim_matrix <- function( + x, + row.names = NULL, + optional = FALSE, + ... +) { + modified_score_matrix_frame( + x, + row.names = row.names, + optional = optional, + record_attr = "ps_trim_meta", + build_column = function(values, meta) { + new_trimmed_ps(values, ps_trim_meta = meta) + }, + ... + ) +} + +#' @exportS3Method tibble::as_tibble +as_tibble.ps_trim_matrix <- function(x, ...) { + tibble::as_tibble(as.data.frame(x), ...) +} + #' @export `[.ps_trim_matrix` <- function(x, i, j, ..., drop = TRUE) { # Get metadata diff --git a/R/ps_trunc.R b/R/ps_trunc.R index abdb67c6..8c3302dc 100644 --- a/R/ps_trunc.R +++ b/R/ps_trunc.R @@ -244,6 +244,13 @@ #' row that arrived where truncation would put it and one truncation moved #' there merge into a single element or row that neither status describes. #' +#' [as.data.frame()] and `tibble::as_tibble()` turn a matrix of scores into a +#' data frame whose columns are `ps_trunc` vectors carrying the matrix's record, one +#' row per unit, so the weight functions read the data frame as they read the +#' matrix and a subset of its rows re-indexes the record. A data frame whose +#' columns are not all truncated with the same record is refused by the weight +#' functions with an error of class `propensity_matrix_type_error`. +#' #' A record can also outlive the observations it describes, because it travels #' by routes vctrs does not see: growing a `ps_trunc` by subassignment carries #' it across the length change. [is_unit_truncated()] therefore checks that the @@ -1472,6 +1479,31 @@ is_unit_truncated.ps_trunc_matrix <- function(x) { } +# Each column of the frame is a `ps_trunc` vector carrying the matrix's record, +# so the weight functions read the frame as they read the matrix and a subset +# of its rows re-indexes the record through each column. +#' @export +as.data.frame.ps_trunc_matrix <- function( + x, + row.names = NULL, + optional = FALSE, + ... +) { + modified_score_matrix_frame( + x, + row.names = row.names, + optional = optional, + record_attr = "ps_trunc_meta", + build_column = function(values, meta) new_ps_trunc(values, meta), + ... + ) +} + +#' @exportS3Method tibble::as_tibble +as_tibble.ps_trunc_matrix <- function(x, ...) { + tibble::as_tibble(as.data.frame(x), ...) +} + #' @export `[.ps_trunc_matrix` <- function(x, i, j, ..., drop = TRUE) { # Get metadata diff --git a/R/utils.R b/R/utils.R index 3b378441..4c1f7ecf 100644 --- a/R/utils.R +++ b/R/utils.R @@ -294,6 +294,98 @@ merged_units_agree <- function(values, status) { vctrs::vec_unique_count(pairs) == attr(groups, "n") } +# A modified score matrix as a data frame. A row of the matrix is a unit, and so +# is a row of the frame, so every column is a score vector of the matrix's class +# carrying the matrix's record unchanged: its positions name rows, which are the +# elements of each column. The frame's own rows and names are the ones base R +# gives the plain matrix. +modified_score_matrix_frame <- function( + x, + row.names = NULL, + optional = FALSE, + record_attr, + build_column, + ... +) { + meta <- attr(x, record_attr) + values <- unclass(x) + attr(values, record_attr) <- NULL + out <- as.data.frame(values, row.names = row.names, optional = optional, ...) + + for (j in seq_along(out)) { + out[[j]] <- build_column(unname(as.double(out[[j]])), meta) + } + + out +} + +# The score matrix a data frame of modified score columns stands for, or `NULL` +# when no column is modified. The frame describes one matrix only when every +# column is the same class and carries the same record, as `as.data.frame()` +# leaves them and as row subsetting keeps them; anything else mixes scores that +# were modified differently, or not at all, into one set of units. +frame_as_modified_score_matrix <- function(frame, call = rlang::caller_env()) { + columns <- unclass(frame) + kinds <- vapply( + columns, + function(column) { + if (inherits(column, "ps_trim")) { + "trim" + } else if (inherits(column, "ps_trunc")) { + "trunc" + } else { + "plain" + } + }, + character(1) + ) + + if (all(kinds == "plain")) { + return(NULL) + } + + kind <- kinds[[1]] + record_attr <- if (identical(kind, "trim")) { + "ps_trim_meta" + } else { + "ps_trunc_meta" + } + records <- lapply(columns, attr, record_attr) + agree <- all(kinds == kind) && + all(vapply(records, identical, logical(1), records[[1]])) + + if (!agree) { + abort( + c( + "The columns of {.arg .propensity} must be modified alike.", + x = "Some columns are trimmed or truncated propensity scores and the + others are not, or their records differ, so the columns do not + describe one set of units.", + i = "Build the data frame from a single trimmed or truncated score + matrix with {.fn as.data.frame}, or pass the matrix itself." + ), + error_class = "propensity_matrix_type_error", + call = call + ) + } + + values <- do.call(cbind, lapply(columns, vctrs::vec_data)) + row_names <- if (.row_names_info(frame) > 0) rownames(frame) + dimnames(values) <- list(row_names, names(frame)) + + if (identical(kind, "trim")) { + list( + scores = new_trimmed_ps(values, ps_trim_meta = records[[1]]), + modification_type = "trim" + ) + } else { + list( + scores = new_ps_trunc(values, records[[1]]), + modification_type = "trunc" + ) + } +} + # The units a modified score holds, one per element or, for a matrix, one per # row, and those of them with a missing score. A row with any missing score has # no complete probability vector, so the whole unit is missing. diff --git a/R/weights-utils.R b/R/weights-utils.R index 269cfeaa..051e1cc9 100644 --- a/R/weights-utils.R +++ b/R/weights-utils.R @@ -2038,6 +2038,24 @@ handle_data_frame_weight_calculation <- function( # was resolved from. Resolving it twice makes the same decision twice and # announces it twice, once for a call that made one decision. if (exposure_type_check == "categorical") { + # A frame of trimmed or truncated score columns is the matrix it was made + # from, and takes that matrix's route so its record reaches the weights. + modified <- frame_as_modified_score_matrix(.propensity, call = call) + if (!is.null(modified)) { + return(calculate_weight_from_modified_ps( + .propensity = modified$scores, + .exposure = .exposure, + weight_fn = weight_fn_numeric, + modification_type = modified$modification_type, + exposure_type = exposure_type_check, + .focal_level = focal_params$.focal_level, + .reference_level = focal_params$.reference_level, + ..., + density_supplied = density_supplied, + call = call + )) + } + # For categorical exposures, pass the whole data frame return(weight_fn_numeric( .propensity = .propensity, diff --git a/man/ps_trim.Rd b/man/ps_trim.Rd index 08ea2a90..5e92f744 100644 --- a/man/ps_trim.Rd +++ b/man/ps_trim.Rd @@ -407,6 +407,13 @@ score and one that arrived missing are both \code{NA}, and a trimmed row is \cod throughout, so a vector or matrix holding both returns a single \code{NA} element or row that neither status describes. +\code{\link[=as.data.frame]{as.data.frame()}} and \code{tibble::as_tibble()} turn a matrix of scores into a +data frame whose columns are \code{ps_trim} vectors carrying the matrix's record, one +row per unit, so the weight functions read the data frame as they read the +matrix and a subset of its rows re-indexes the record. A data frame whose +columns are not all trimmed with the same record is refused by the weight +functions with an error of class \code{propensity_matrix_type_error}. + A record can also outlive the observations it describes, because it travels by routes vctrs does not see: growing a \code{ps_trim} by subassignment carries it across the length change. \code{\link[=is_unit_trimmed]{is_unit_trimmed()}} and \code{\link[=ps_refit]{ps_refit()}} therefore diff --git a/man/ps_trunc.Rd b/man/ps_trunc.Rd index 9db4df54..2e32ed89 100644 --- a/man/ps_trunc.Rd +++ b/man/ps_trunc.Rd @@ -287,6 +287,13 @@ all of the merged units share one status, and dropped otherwise: a score or row that arrived where truncation would put it and one truncation moved there merge into a single element or row that neither status describes. +\code{\link[=as.data.frame]{as.data.frame()}} and \code{tibble::as_tibble()} turn a matrix of scores into a +data frame whose columns are \code{ps_trunc} vectors carrying the matrix's record, one +row per unit, so the weight functions read the data frame as they read the +matrix and a subset of its rows re-indexes the record. A data frame whose +columns are not all truncated with the same record is refused by the weight +functions with an error of class \code{propensity_matrix_type_error}. + A record can also outlive the observations it describes, because it travels by routes vctrs does not see: growing a \code{ps_trunc} by subassignment carries it across the length change. \code{\link[=is_unit_truncated]{is_unit_truncated()}} therefore checks that the diff --git a/tests/testthat/test-weights.R b/tests/testthat/test-weights.R index 0cf9928c..eb445059 100644 --- a/tests/testthat/test-weights.R +++ b/tests/testthat/test-weights.R @@ -2506,7 +2506,7 @@ test_that("a modified score in a data frame keeps its record for a binary exposu } }) -test_that("a data frame of trimmed categorical scores still gives weights", { +test_that("a data frame of trimmed categorical scores gives the matrix's weights", { set.seed(43) n <- 100 exposure <- factor(sample(c("A", "B", "C"), n, replace = TRUE)) @@ -2519,9 +2519,9 @@ test_that("a data frame of trimmed categorical scores still gives weights", { truncated = ps_trunc(ps_matrix, .exposure = exposure, lower = 0.1) ) - # A matrix of modified scores converts to a data frame of plain columns, so - # the frame holds the modified values without the record. The frame is still - # a categorical frame of scores, and its weights are the matrix's weights. + # A matrix of modified scores converts to a data frame whose columns carry + # the matrix's record, so the frame's weights are the matrix's weights, with + # the same record and the same advice to refit. for (modification in names(modified)) { score <- modified[[modification]] from_matrix <- weights_and_refit_warning( @@ -2536,16 +2536,18 @@ test_that("a data frame of trimmed categorical scores still gives weights", { info = modification ) - from_frame <- wt_ate( + from_frame <- weights_and_refit_warning( + wt_ate, as.data.frame(score), exposure, exposure_type = "categorical" ) - expect_s3_class(from_frame, "psw") - expect_equal( - as.numeric(from_frame), - as.numeric(from_matrix$weights), + expect_s3_class(from_frame$weights, "psw") + expect_identical(from_frame$warned, from_matrix$warned, info = modification) + expect_identical( + from_frame$weights, + from_matrix$weights, info = modification ) } From db1867ac6e5471ab5d5320a3f6fcc134a62230f5 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 12:07:01 -0400 Subject: [PATCH 59/64] add a failing test for refusing a refit of truncated scores --- tests/testthat/test-ps_refit-truncated.R | 51 ++++++++++++++++++++++++ 1 file changed, 51 insertions(+) create mode 100644 tests/testthat/test-ps_refit-truncated.R diff --git a/tests/testthat/test-ps_refit-truncated.R b/tests/testthat/test-ps_refit-truncated.R new file mode 100644 index 00000000..2bdbdea9 --- /dev/null +++ b/tests/testthat/test-ps_refit-truncated.R @@ -0,0 +1,51 @@ +# ps_refit() refuses truncated scores ------------------------------------------ + +# Truncation keeps every unit, so refitting on the kept units is refitting the +# original model on every row, and would hand back the scores before they were +# bounded. The refusal says so rather than naming a class. + +test_that("ps_refit() refuses a truncated score vector and says why", { + set.seed(5) + n <- 80 + x <- rnorm(n) + z <- rbinom(n, 1, plogis(1.5 * x)) + fit <- glm(z ~ x, family = binomial()) + truncated <- ps_trunc(fitted(fit), lower = 0.2, upper = 0.8) + + expect_error( + ps_refit(truncated, model = fit), + class = "propensity_method_error" + ) + expect_propensity_error(ps_refit(truncated, model = fit)) +}) + +test_that("ps_refit() refuses a truncated score matrix and says why", { + set.seed(6) + n <- 90 + x <- rnorm(n) + z <- factor(sample(c("a", "b", "c"), n, replace = TRUE)) + fit <- nnet::multinom(z ~ x, trace = FALSE) + truncated <- ps_trunc( + predict(fit, type = "probs"), + method = "ps", + lower = 0.3, + .exposure = z + ) + + expect_error( + ps_refit(truncated, model = fit), + class = "propensity_method_error" + ) + expect_propensity_error(ps_refit(truncated, model = fit)) +}) + +test_that("ps_refit() keeps the generic refusal for other classes", { + fit <- glm(c(0, 1, 0, 1) ~ c(1, 2, 3, 4), family = binomial()) + + cnd <- expect_error( + ps_refit(c(0.2, 0.4, 0.6, 0.8), model = fit), + class = "propensity_class_error" + ) + expect_false(inherits(cnd, "propensity_method_error")) + expect_match(conditionMessage(cnd), "ps_trim") +}) From 15a2b91eff231e85bd798d15980cb1ed2eacfa16 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 12:07:40 -0400 Subject: [PATCH 60/64] explain why ps_refit() refuses truncated scores --- NEWS.md | 5 ++++ R/ps_trim.R | 29 ++++++++++++++++++++- man/ps_refit.Rd | 5 +++- tests/testthat/_snaps/ps_refit-truncated.md | 20 ++++++++++++++ 4 files changed, 57 insertions(+), 2 deletions(-) create mode 100644 tests/testthat/_snaps/ps_refit-truncated.md diff --git a/NEWS.md b/NEWS.md index 5e20988d..41a06bb9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -164,6 +164,11 @@ and `ps_refit()` now refuse such a result with an error of class `propensity_missing_meta_error`. +* `ps_refit()` on truncated scores, a vector or a matrix, now raises an error + of class `propensity_method_error` that explains why: truncation keeps every + unit, so a refit would reproduce the original model, and the model should be + refit before truncating. It previously raised a generic class error. + * `as.data.frame()` and `tibble::as_tibble()` of a trimmed or truncated categorical score matrix now return columns of class `ps_trim` or `ps_trunc` that carry the matrix's record. They previously returned plain diff --git a/R/ps_trim.R b/R/ps_trim.R index 37fe410f..0f537f82 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -2669,6 +2669,29 @@ diff.ps_trim <- function(x, lag = 1L, differences = 1L, ...) { diff(vec_data(x), lag = lag, differences = differences, ...) } +# Truncation keeps every unit, so the retained sample a refit reads is the whole +# sample: refitting would reproduce the original model and hand back the scores +# before they were bounded. A class check would say only that the object is not +# a trim, which is not what the caller needs to know. +check_refit_not_truncated <- function(x, call = rlang::caller_env()) { + if (!inherits(x, "ps_trunc")) { + return(invisible(x)) + } + + abort( + c( + "{.fn ps_refit} cannot refit truncated propensity scores.", + x = "Truncation bounds the scores and keeps every unit, so a refit on the + kept units is the original model, and it would return the scores + before they were bounded.", + i = "To refit the model, refit it before truncating, then call + {.fn ps_trunc} on the refit model's scores." + ), + error_class = "propensity_method_error", + call = call + ) +} + #' Refit a Propensity Score Model on Retained Observations #' #' @description @@ -2687,7 +2710,10 @@ diff.ps_trim <- function(x, lag = 1L, differences = 1L, ...) { #' @param trimmed_ps A `ps_trim` object returned by [ps_trim()]. Refitting reads #' the retained positions out of the trimming record, so an object whose #' record was dropped or no longer covers it raises an error of class -#' `propensity_missing_meta_error`; see [ps_trim()]. +#' `propensity_missing_meta_error`; see [ps_trim()]. Truncated scores from +#' [ps_trunc()] keep every unit, so refitting them would return the original +#' model's scores, and they raise an error of class +#' `propensity_method_error`. #' @param model The original fitted model used to estimate the propensity #' scores (e.g. a [glm][stats::glm] or [multinom][nnet::multinom] object). #' The model is refit via [update()][stats::update] on the retained subset. @@ -2791,6 +2817,7 @@ diff.ps_trim <- function(x, lag = 1L, differences = 1L, ...) { #' #' @export ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { + check_refit_not_truncated(trimmed_ps) assert_class(trimmed_ps, "ps_trim") meta <- ps_trim_meta(trimmed_ps) diff --git a/man/ps_refit.Rd b/man/ps_refit.Rd index 9029e657..43e8f05f 100644 --- a/man/ps_refit.Rd +++ b/man/ps_refit.Rd @@ -10,7 +10,10 @@ ps_refit(trimmed_ps, model, .data = NULL, ...) \item{trimmed_ps}{A \code{ps_trim} object returned by \code{\link[=ps_trim]{ps_trim()}}. Refitting reads the retained positions out of the trimming record, so an object whose record was dropped or no longer covers it raises an error of class -\code{propensity_missing_meta_error}; see \code{\link[=ps_trim]{ps_trim()}}.} +\code{propensity_missing_meta_error}; see \code{\link[=ps_trim]{ps_trim()}}. Truncated scores from +\code{\link[=ps_trunc]{ps_trunc()}} keep every unit, so refitting them would return the original +model's scores, and they raise an error of class +\code{propensity_method_error}.} \item{model}{The original fitted model used to estimate the propensity scores (e.g. a \link[stats:glm]{glm} or \link[nnet:multinom]{multinom} object). diff --git a/tests/testthat/_snaps/ps_refit-truncated.md b/tests/testthat/_snaps/ps_refit-truncated.md new file mode 100644 index 00000000..e18e8619 --- /dev/null +++ b/tests/testthat/_snaps/ps_refit-truncated.md @@ -0,0 +1,20 @@ +# ps_refit() refuses a truncated score vector and says why + + Code + expr + Condition + Error in `ps_refit()`: + ! `ps_refit()` cannot refit truncated propensity scores. + x Truncation bounds the scores and keeps every unit, so a refit on the kept units is the original model, and it would return the scores before they were bounded. + i To refit the model, refit it before truncating, then call `ps_trunc()` on the refit model's scores. + +# ps_refit() refuses a truncated score matrix and says why + + Code + expr + Condition + Error in `ps_refit()`: + ! `ps_refit()` cannot refit truncated propensity scores. + x Truncation bounds the scores and keeps every unit, so a refit on the kept units is the original model, and it would return the scores before they were bounded. + i To refit the model, refit it before truncating, then call `ps_trunc()` on the refit model's scores. + From d28fe58b233d695bdcdfc640c6242a7b68aa6ee0 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 12:18:12 -0400 Subject: [PATCH 61/64] add failing tests for assigning weights with different records --- tests/testthat/test-psw-assign-records.R | 149 +++++++++++++++++++++++ 1 file changed, 149 insertions(+) create mode 100644 tests/testthat/test-psw-assign-records.R diff --git a/tests/testthat/test-psw-assign-records.R b/tests/testthat/test-psw-assign-records.R new file mode 100644 index 00000000..f42f9b39 --- /dev/null +++ b/tests/testthat/test-psw-assign-records.R @@ -0,0 +1,149 @@ +# Assigning weights into weights with a modification record ------------------- + +# `[<-` keeps the target's attributes, so weights modified differently would be +# written in under a record that does not describe them. The cast behind `[<-` +# compares the records the way a combine does, by what they say about the +# modification rather than which units they name. + +assign_wt_truncated <- function(upper) { + wt_trunc(psw(c(1, 2, 50, 3, 4, 5, 6, 7, 8, 100)), "count", upper = upper) +} + +assign_trimmed <- function(lower = 0.2, upper = 0.8, refit = FALSE) { + w <- psw(c(NA, 2, 1.6, NA, 3.3), estimand = "ate; trimmed", trimmed = TRUE) + meta <- list( + method = "ps", + lower = lower, + upper = upper, + focal_inverted = FALSE, + keep_idx = c(2L, 3L, 5L), + trimmed_idx = c(1L, 4L), + n_obs = 5L + ) + if (refit) { + meta$refit <- TRUE + } + attr(w, "ps_trim_meta") <- meta + w +} + +assign_truncated <- function(lower = 0.1, upper = 0.9) { + w <- psw( + c(10, 2, 1.6, 10, 3.3), + estimand = "ate; truncated", + truncated = TRUE + ) + attr(w, "ps_trunc_meta") <- list( + method = "ps", + lower_bound = lower, + upper_bound = upper, + truncated_idx = c(1L, 4L), + n_obs = 5L + ) + w +} + +test_that("assigning weights truncated at another bound is refused", { + target <- assign_wt_truncated(2) + value <- assign_wt_truncated(1) + meta <- attr(target, "psw_trunc_meta") + + cnd <- expect_error( + { + target[1:3] <- value[1:3] + }, + class = "vctrs_error_cast" + ) + expect_match(conditionMessage(cnd), "different weight truncation bounds") + expect_identical(attr(target, "psw_trunc_meta"), meta) + + expect_error( + vctrs::vec_cast(value, target), + class = "vctrs_error_cast" + ) +}) + +test_that("assigning weights trimmed differently is refused", { + target <- assign_trimmed(0.2, 0.8) + + cnd <- expect_error( + { + target[2] <- assign_trimmed(0.3, 0.7)[2] + }, + class = "vctrs_error_cast" + ) + expect_match(conditionMessage(cnd), "different trimming parameters") + + cnd <- expect_error( + { + target[2] <- assign_trimmed(refit = TRUE)[2] + }, + class = "vctrs_error_cast" + ) + expect_match(conditionMessage(cnd), "different trimming parameters") +}) + +test_that("assigning weights from differently truncated scores is refused", { + target <- assign_truncated(0.1, 0.9) + + cnd <- expect_error( + { + target[2:3] <- assign_truncated(0.05, 0.95)[2:3] + }, + class = "vctrs_error_cast" + ) + expect_match(conditionMessage(cnd), "different truncation parameters") +}) + +test_that("assigning values that carry no record is allowed", { + target <- assign_wt_truncated(2) + meta <- attr(target, "psw_trunc_meta") + + expect_silent({ + target[1:2] <- c(1.5, 1.5) + }) + expect_silent({ + target[3] <- vec_data(assign_wt_truncated(1))[3] + }) + expect_identical(attr(target, "psw_trunc_meta"), meta) + + # Weights flagged as truncated with no record agree with any bound. + bare <- psw(c(1.2, 1.3), wt_truncated = TRUE) + expect_silent({ + target[4:5] <- bare + }) + expect_identical(attr(target, "psw_trunc_meta"), meta) +}) + +test_that("assigning weights with the same settings keeps the target's record", { + target <- assign_trimmed() + meta <- attr(target, "ps_trim_meta") + + # A value with the same settings is allowed wherever its own units were + # trimmed. The target's record describes the target's positions, which do + # not move, so it is kept as is: here unit 2 is now missing but the record + # still lists it as retained, as `is.na<-` leaves a psw's score records. + value <- assign_trimmed() + expect_silent({ + target[2] <- value[1] + }) + expect_true(is.na(target[[2]])) + expect_identical(attr(target, "ps_trim_meta"), meta) + expect_identical( + is_unit_trimmed(target), + c(TRUE, FALSE, FALSE, TRUE, FALSE) + ) + + target[1] <- value[2] + expect_identical(vec_data(target)[[1]], 2) + expect_identical(attr(target, "ps_trim_meta"), meta) +}) + +test_that("combines still cast their inputs to the prototype", { + a <- assign_wt_truncated(2) + + out <- expect_silent(vctrs::vec_c(a, a)) + expect_s3_class(out, "psw") + expect_silent(vctrs::vec_cast(a, vctrs::vec_ptype(a))) + expect_silent(vctrs::vec_cast(a, out)) +}) From dd5302860b839d8ff34a998d0160e42abab11ac2 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 12:22:35 -0400 Subject: [PATCH 62/64] refuse assigning weights whose records differ --- NEWS.md | 8 ++++++++ R/psw.R | 11 ++++++++++- man/psw.Rd | 3 ++- tests/testthat/test-psw-wt-trunc.R | 22 ++++++++++++++-------- 4 files changed, 34 insertions(+), 10 deletions(-) diff --git a/NEWS.md b/NEWS.md index 41a06bb9..9191d83a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -164,6 +164,14 @@ and `ps_refit()` now refuse such a result with an error of class `propensity_missing_meta_error`. +* Assigning weights into a `psw` with `[<-` now refuses a value whose + trimming, truncation, or weight truncation record describes a different + modification from the target's, with the cast error that a differing + trimming or truncation flag already raises, naming the record that differs. + Such values were previously written under the target's record. A value that + carries no record, such as a plain number, is still accepted, and a value + modified the same way keeps the target's record unchanged. + * `ps_refit()` on truncated scores, a vector or a matrix, now raises an error of class `propensity_method_error` that explains why: truncation keeps every unit, so a refit would reproduce the original model, and the model should be diff --git a/R/psw.R b/R/psw.R index 03a89339..0573f01c 100644 --- a/R/psw.R +++ b/R/psw.R @@ -142,7 +142,8 @@ #' bounds, and whether the model was refit, so [is_refit()], the printed #' footer, and the bound comparison of a later combine still read it. #' Subassignment with `[<-` and `is.na<-` moves no unit and keeps the records -#' whole. vctrs' own assignment, [vctrs::vec_assign()], reaches the same restore +#' whole; `[<-` refuses a value whose records describe a different +#' modification, and accepts one with no record. vctrs' own assignment, [vctrs::vec_assign()], reaches the same restore #' a slice does and cannot be told apart from one, so it drops the positions, #' and so do the helpers built on it or on a combine, such as #' `tidyr::replace_na()`, `dplyr::coalesce()`, `dplyr::if_else()`, and @@ -2225,7 +2226,15 @@ cast_to_psw <- function(x, to) { # be converted to itself. The disagreeing field is named alongside them. #' @export vec_cast.psw.psw <- function(x, to, ...) { + # The modification records are compared too, by what they say about the + # modification, as a combine compares them: subassignment would otherwise + # write weights modified one way under a record describing another. A value + # with no record, and a prototype that took its record from agreeing inputs, + # has nothing to disagree with. problem <- psw_type_disagreement(x, to) + if (is.null(problem)) { + problem <- psw_record_disagreement(x, to) + } if (!is.null(problem)) { vctrs::stop_incompatible_cast( x, diff --git a/man/psw.Rd b/man/psw.Rd index 6ebb1af4..629c2e15 100644 --- a/man/psw.Rd +++ b/man/psw.Rd @@ -227,7 +227,8 @@ weights whose records name no units. A dropped record keeps its method, its bounds, and whether the model was refit, so \code{\link[=is_refit]{is_refit()}}, the printed footer, and the bound comparison of a later combine still read it. Subassignment with \verb{[<-} and \verb{is.na<-} moves no unit and keeps the records -whole. vctrs' own assignment, \code{\link[vctrs:vec_assign]{vctrs::vec_assign()}}, reaches the same restore +whole; \verb{[<-} refuses a value whose records describe a different +modification, and accepts one with no record. vctrs' own assignment, \code{\link[vctrs:vec_assign]{vctrs::vec_assign()}}, reaches the same restore a slice does and cannot be told apart from one, so it drops the positions, and so do the helpers built on it or on a combine, such as \code{tidyr::replace_na()}, \code{dplyr::coalesce()}, \code{dplyr::if_else()}, and diff --git a/tests/testthat/test-psw-wt-trunc.R b/tests/testthat/test-psw-wt-trunc.R index 19b06d16..081017ff 100644 --- a/tests/testthat/test-psw-wt-trunc.R +++ b/tests/testthat/test-psw-wt-trunc.R @@ -467,19 +467,25 @@ test_that("a bound mismatch is caught whichever pair of the fold meets it", { expect_true(is_wt_truncated(agreed)) }) -test_that("weights bounded differently still cast to each other", { - # The bounds are compared only where two inputs are combined. A cast is also - # how subassignment and a type's own prototype are checked, and comparing - # there would refuse weights their own dropped-record prototype. +test_that("weights bounded differently do not cast to each other", { + # Subassignment casts the value to the target and keeps the target's record, + # so a value bounded differently would be written under a bound that does not + # describe it. A prototype carries its inputs' bound without positions, so + # weights still cast to their own. w <- wt_truncated_psw() alt <- alt_wt_truncated_psw() - expect_silent(vec_cast(alt, w)) - expect_silent({ - w[seq_along(w)] <- alt - }) + expect_error(vec_cast(alt, w), class = "vctrs_error_cast") + expect_error( + { + w[seq_along(w)] <- alt + }, + class = "vctrs_error_cast" + ) expect_identical(attr(w, "psw_trunc_meta"), wt_trunc_record()) expect_true(is_wt_truncated(w)) + + expect_silent(vec_cast(w, vec_ptype(w))) }) test_that("weights bounded alike combine whichever units the bound moved", { From 858a9e8f6dd7ac3974813699993e6c29f65e7143 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 12:28:40 -0400 Subject: [PATCH 63/64] refuse refitting one column of a trimmed score matrix --- NEWS.md | 3 +- R/ps_trim.R | 37 ++++++++++++++++++- R/ps_trunc.R | 5 ++- man/ps_refit.Rd | 5 ++- man/ps_trim.Rd | 5 ++- man/ps_trunc.Rd | 5 ++- .../_snaps/modified-score-matrix-frame.md | 10 +++++ .../test-modified-score-matrix-frame.R | 34 +++++++++++++++++ 8 files changed, 97 insertions(+), 7 deletions(-) create mode 100644 tests/testthat/_snaps/modified-score-matrix-frame.md diff --git a/NEWS.md b/NEWS.md index 9191d83a..ae30f29a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -185,7 +185,8 @@ warning. The weight functions now read such a data frame as they read the matrix, and `ipw()` refuses the weights in the same way. A data frame whose columns disagree about the record is refused with an error of class - `propensity_matrix_type_error`. + `propensity_matrix_type_error`, and `ps_refit()` refuses a single column of + such a data frame with an error of class `propensity_method_error`. * Combining `psw` objects now compares the trimming and truncation records of the scores they were built from, including whether the trimmed model was diff --git a/R/ps_trim.R b/R/ps_trim.R index 0f537f82..bd02f555 100644 --- a/R/ps_trim.R +++ b/R/ps_trim.R @@ -344,7 +344,10 @@ #' row per unit, so the weight functions read the data frame as they read the #' matrix and a subset of its rows re-indexes the record. A data frame whose #' columns are not all trimmed with the same record is refused by the weight -#' functions with an error of class `propensity_matrix_type_error`. +#' functions with an error of class `propensity_matrix_type_error`. A matrix +#' without column names gives columns named `V1`, `V2`, and so on, which the +#' weight functions then refuse because they name no exposure level, so name +#' the columns after the exposure levels before converting. #' #' A record can also outlive the observations it describes, because it travels #' by routes vctrs does not see: growing a `ps_trim` by subassignment carries it @@ -2669,6 +2672,32 @@ diff.ps_trim <- function(x, lag = 1L, differences = 1L, ...) { diff(vec_data(x), lag = lag, differences = differences, ...) } +# A column of a data frame made from a trimmed score matrix carries the +# matrix's record, whose retained rows were chosen by a rule on every column at +# once. Refitting the column alone would fit a model of one level on rows no +# rule about that level chose, so the matrix is refit instead. +check_refit_not_matrix_column <- function( + x, + meta, + call = rlang::caller_env() +) { + if (is.matrix(x) || !isTRUE(meta$is_matrix)) { + return(invisible(x)) + } + + abort( + c( + "{.fn ps_refit} cannot refit one column of a trimmed score matrix.", + x = "These scores carry the record of a categorical trim, which chose the + retained rows from every column at once.", + i = "Refit the trimmed matrix with {.fn ps_refit} before converting it + with {.fn as.data.frame}." + ), + error_class = "propensity_method_error", + call = call + ) +} + # Truncation keeps every unit, so the retained sample a refit reads is the whole # sample: refitting would reproduce the original model and hand back the scores # before they were bounded. A class check would say only that the object is not @@ -2710,7 +2739,10 @@ check_refit_not_truncated <- function(x, call = rlang::caller_env()) { #' @param trimmed_ps A `ps_trim` object returned by [ps_trim()]. Refitting reads #' the retained positions out of the trimming record, so an object whose #' record was dropped or no longer covers it raises an error of class -#' `propensity_missing_meta_error`; see [ps_trim()]. Truncated scores from +#' `propensity_missing_meta_error`; see [ps_trim()]. A single column of a data +#' frame made from a trimmed score matrix raises an error of class +#' `propensity_method_error`; refit the matrix before converting it. +#' Truncated scores from #' [ps_trunc()] keep every unit, so refitting them would return the original #' model's scores, and they raise an error of class #' `propensity_method_error`. @@ -2820,6 +2852,7 @@ ps_refit <- function(trimmed_ps, model, .data = NULL, ...) { check_refit_not_truncated(trimmed_ps) assert_class(trimmed_ps, "ps_trim") meta <- ps_trim_meta(trimmed_ps) + check_refit_not_matrix_column(trimmed_ps, meta) # Get the number of observations n_obs <- if (is.matrix(trimmed_ps)) nrow(trimmed_ps) else length(trimmed_ps) diff --git a/R/ps_trunc.R b/R/ps_trunc.R index 8c3302dc..08f6b962 100644 --- a/R/ps_trunc.R +++ b/R/ps_trunc.R @@ -249,7 +249,10 @@ #' row per unit, so the weight functions read the data frame as they read the #' matrix and a subset of its rows re-indexes the record. A data frame whose #' columns are not all truncated with the same record is refused by the weight -#' functions with an error of class `propensity_matrix_type_error`. +#' functions with an error of class `propensity_matrix_type_error`. A matrix +#' without column names gives columns named `V1`, `V2`, and so on, which the +#' weight functions then refuse because they name no exposure level, so name +#' the columns after the exposure levels before converting. #' #' A record can also outlive the observations it describes, because it travels #' by routes vctrs does not see: growing a `ps_trunc` by subassignment carries diff --git a/man/ps_refit.Rd b/man/ps_refit.Rd index 43e8f05f..25c56954 100644 --- a/man/ps_refit.Rd +++ b/man/ps_refit.Rd @@ -10,7 +10,10 @@ ps_refit(trimmed_ps, model, .data = NULL, ...) \item{trimmed_ps}{A \code{ps_trim} object returned by \code{\link[=ps_trim]{ps_trim()}}. Refitting reads the retained positions out of the trimming record, so an object whose record was dropped or no longer covers it raises an error of class -\code{propensity_missing_meta_error}; see \code{\link[=ps_trim]{ps_trim()}}. Truncated scores from +\code{propensity_missing_meta_error}; see \code{\link[=ps_trim]{ps_trim()}}. A single column of a data +frame made from a trimmed score matrix raises an error of class +\code{propensity_method_error}; refit the matrix before converting it. +Truncated scores from \code{\link[=ps_trunc]{ps_trunc()}} keep every unit, so refitting them would return the original model's scores, and they raise an error of class \code{propensity_method_error}.} diff --git a/man/ps_trim.Rd b/man/ps_trim.Rd index 5e92f744..724cabfd 100644 --- a/man/ps_trim.Rd +++ b/man/ps_trim.Rd @@ -412,7 +412,10 @@ data frame whose columns are \code{ps_trim} vectors carrying the matrix's record row per unit, so the weight functions read the data frame as they read the matrix and a subset of its rows re-indexes the record. A data frame whose columns are not all trimmed with the same record is refused by the weight -functions with an error of class \code{propensity_matrix_type_error}. +functions with an error of class \code{propensity_matrix_type_error}. A matrix +without column names gives columns named \code{V1}, \code{V2}, and so on, which the +weight functions then refuse because they name no exposure level, so name +the columns after the exposure levels before converting. A record can also outlive the observations it describes, because it travels by routes vctrs does not see: growing a \code{ps_trim} by subassignment carries it diff --git a/man/ps_trunc.Rd b/man/ps_trunc.Rd index 2e32ed89..fd8e4216 100644 --- a/man/ps_trunc.Rd +++ b/man/ps_trunc.Rd @@ -292,7 +292,10 @@ data frame whose columns are \code{ps_trunc} vectors carrying the matrix's recor row per unit, so the weight functions read the data frame as they read the matrix and a subset of its rows re-indexes the record. A data frame whose columns are not all truncated with the same record is refused by the weight -functions with an error of class \code{propensity_matrix_type_error}. +functions with an error of class \code{propensity_matrix_type_error}. A matrix +without column names gives columns named \code{V1}, \code{V2}, and so on, which the +weight functions then refuse because they name no exposure level, so name +the columns after the exposure levels before converting. A record can also outlive the observations it describes, because it travels by routes vctrs does not see: growing a \code{ps_trunc} by subassignment carries diff --git a/tests/testthat/_snaps/modified-score-matrix-frame.md b/tests/testthat/_snaps/modified-score-matrix-frame.md new file mode 100644 index 00000000..fbf58645 --- /dev/null +++ b/tests/testthat/_snaps/modified-score-matrix-frame.md @@ -0,0 +1,10 @@ +# ps_refit() refuses a single column of a trimmed matrix's data frame + + Code + expr + Condition + Error in `ps_refit()`: + ! `ps_refit()` cannot refit one column of a trimmed score matrix. + x These scores carry the record of a categorical trim, which chose the retained rows from every column at once. + i Refit the trimmed matrix with `ps_refit()` before converting it with `as.data.frame()`. + diff --git a/tests/testthat/test-modified-score-matrix-frame.R b/tests/testthat/test-modified-score-matrix-frame.R index 7935ade9..222d9c96 100644 --- a/tests/testthat/test-modified-score-matrix-frame.R +++ b/tests/testthat/test-modified-score-matrix-frame.R @@ -269,3 +269,37 @@ test_that("a frame whose columns disagree about the record is refused", { class = "propensity_matrix_type_error" ) }) + +test_that("ps_refit() refuses a single column of a trimmed matrix's data frame", { + fx <- frame_scores_data() + df <- as.data.frame(frame_trimmed(fx)) + binary_fit <- glm( + I(z == "a") ~ x, + data = fx$dat, + family = binomial() + ) + + expect_error( + ps_refit(df$a, model = binary_fit), + class = "propensity_method_error" + ) + expect_propensity_error(ps_refit(df$a, model = fx$fit)) +}) + +test_that("weights refuse the data frame of an unnamed matrix", { + fx <- frame_scores_data() + bare <- fx$p + dimnames(bare) <- NULL + expect_warning( + unnamed <- ps_trim(bare, method = "ps", lower = 0.05, .exposure = fx$dat$z), + class = "propensity_matrix_no_names_warning" + ) + + expect_error( + suppressWarnings( + wt_ate(as.data.frame(unnamed), .exposure = fx$dat$z), + classes = "propensity_no_refit_warning" + ), + class = "propensity_matrix_names_error" + ) +}) From a05c3345c23f8a9e17a03073c57eab5a9b5414c2 Mon Sep 17 00:00:00 2001 From: Malcolm Barrett Date: Thu, 17 Sep 2026 12:37:45 -0400 Subject: [PATCH 64/64] explain refused record casts and document assignment of missing values --- NEWS.md | 8 +++++--- R/psw.R | 21 ++++++++++++++++++++- man/psw.Rd | 5 ++++- tests/testthat/_snaps/psw-assign-records.md | 10 ++++++++++ tests/testthat/test-psw-assign-records.R | 9 +++++++++ 5 files changed, 48 insertions(+), 5 deletions(-) create mode 100644 tests/testthat/_snaps/psw-assign-records.md diff --git a/NEWS.md b/NEWS.md index ae30f29a..e70a3b2f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -168,9 +168,11 @@ trimming, truncation, or weight truncation record describes a different modification from the target's, with the cast error that a differing trimming or truncation flag already raises, naming the record that differs. - Such values were previously written under the target's record. A value that - carries no record, such as a plain number, is still accepted, and a value - modified the same way keeps the target's record unchanged. + `vctrs::vec_c(..., .ptype = )` with a prototype whose record differs from + an input's now refuses in the same way. Such values were previously written + under the target's record. A value that carries no record, such as a plain + number, is still accepted, and a value modified the same way keeps the + target's record unchanged. * `ps_refit()` on truncated scores, a vector or a matrix, now raises an error of class `propensity_method_error` that explains why: truncation keeps every diff --git a/R/psw.R b/R/psw.R index 0573f01c..c4280298 100644 --- a/R/psw.R +++ b/R/psw.R @@ -143,7 +143,10 @@ #' footer, and the bound comparison of a later combine still read it. #' Subassignment with `[<-` and `is.na<-` moves no unit and keeps the records #' whole; `[<-` refuses a value whose records describe a different -#' modification, and accepts one with no record. vctrs' own assignment, [vctrs::vec_assign()], reaches the same restore +#' modification, and accepts one with no record. A `[<-` of a value modified +#' the same way that writes a missing weight leaves that unit listed as +#' retained in the record, as `is.na<-` on a `psw` does; `is.na<-` on a +#' `ps_trim` score instead removes the unit from its retained set. vctrs' own assignment, [vctrs::vec_assign()], reaches the same restore #' a slice does and cannot be told apart from one, so it drops the positions, #' and so do the helpers built on it or on a combine, such as #' `tidyr::replace_na()`, `dplyr::coalesce()`, `dplyr::if_else()`, and @@ -2253,6 +2256,22 @@ vec_cast.psw.psw <- function(x, to, ...) { # nothing about what to do. The score belongs to the units of each vector, so # the value's cannot be written under the target's. cast_problem_details <- function(problem, x, to) { + # A record disagreement is not visible in the type labels, which can read the + # same on both sides, so the refusal says what to do about it. + if ( + problem %in% + psw_record_problems && + identical(vec_ptype_full(x), vec_ptype_full(to)) + ) { + return(c( + problem, + i = paste( + "Assign `vec_data()` of the value to keep the target's record, or", + "rebuild the weights from one modification." + ) + )) + } + scores <- list(stabilization_score(x), stabilization_score(to)) if ( !identical(problem, psw_type_field_problems[["stabilization_score"]]) || diff --git a/man/psw.Rd b/man/psw.Rd index 629c2e15..f6c02d9a 100644 --- a/man/psw.Rd +++ b/man/psw.Rd @@ -228,7 +228,10 @@ bounds, and whether the model was refit, so \code{\link[=is_refit]{is_refit()}}, footer, and the bound comparison of a later combine still read it. Subassignment with \verb{[<-} and \verb{is.na<-} moves no unit and keeps the records whole; \verb{[<-} refuses a value whose records describe a different -modification, and accepts one with no record. vctrs' own assignment, \code{\link[vctrs:vec_assign]{vctrs::vec_assign()}}, reaches the same restore +modification, and accepts one with no record. A \verb{[<-} of a value modified +the same way that writes a missing weight leaves that unit listed as +retained in the record, as \verb{is.na<-} on a \code{psw} does; \verb{is.na<-} on a +\code{ps_trim} score instead removes the unit from its retained set. vctrs' own assignment, \code{\link[vctrs:vec_assign]{vctrs::vec_assign()}}, reaches the same restore a slice does and cannot be told apart from one, so it drops the positions, and so do the helpers built on it or on a combine, such as \code{tidyr::replace_na()}, \code{dplyr::coalesce()}, \code{dplyr::if_else()}, and diff --git a/tests/testthat/_snaps/psw-assign-records.md b/tests/testthat/_snaps/psw-assign-records.md new file mode 100644 index 00000000..12942e1d --- /dev/null +++ b/tests/testthat/_snaps/psw-assign-records.md @@ -0,0 +1,10 @@ +# assigning weights truncated at another bound is refused + + Code + target[1:3] <- value[1:3] + Condition + Error in `vec_cast.psw.psw()`: + ! Can't convert to . + different weight truncation bounds + Assign `vec_data()` of the value to keep the target's record, or rebuild the weights from one modification. + diff --git a/tests/testthat/test-psw-assign-records.R b/tests/testthat/test-psw-assign-records.R index f42f9b39..12e8473b 100644 --- a/tests/testthat/test-psw-assign-records.R +++ b/tests/testthat/test-psw-assign-records.R @@ -61,6 +61,15 @@ test_that("assigning weights truncated at another bound is refused", { vctrs::vec_cast(value, target), class = "vctrs_error_cast" ) + expect_error( + vctrs::vec_c(value, .ptype = target), + class = "vctrs_error_cast" + ) + + # The two types print alike, so the refusal says what to do. + expect_snapshot(error = TRUE, { + target[1:3] <- value[1:3] + }) }) test_that("assigning weights trimmed differently is refused", {