diff --git a/NAMESPACE b/NAMESPACE index 48164df7..f6d5ad23 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,13 +11,22 @@ S3method("[",ps_trim) 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) 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) +S3method(c,psw) S3method(causalgenerics::ipw,default) S3method(causalgenerics::ipw,glm) S3method(causalgenerics::ipw,joint_wt_models) @@ -74,6 +83,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) @@ -88,6 +101,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) @@ -107,12 +122,14 @@ 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) 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) @@ -127,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) @@ -291,6 +310,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) @@ -317,6 +342,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) @@ -341,6 +368,8 @@ export(wt_atu) 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 8a4ccfef..e70a3b2f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,277 @@ # 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), 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. + +* 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_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. + +* `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`. + +* `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()`. + + 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 + `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`. + 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`. + +* 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 + `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. + +* `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. + +* `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. + +* `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. + +* 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`. + +* 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. + +* 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`. + +* 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. + `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 + 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 + 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`, 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 + 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 + 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. + +* 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 + 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; `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 `[` + 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()`, + `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 + 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. + +* `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. + +* 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 continuous exposure's weights are read at a residual standardized by a spread @@ -2141,9 +2413,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/categorical-models.R b/R/categorical-models.R index 8756711c..1fa605a2 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) @@ -211,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/continuous-models.R b/R/continuous-models.R index 4dc0d040..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 @@ -101,12 +106,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 +146,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 +162,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 +191,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"]] @@ -185,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)) } @@ -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 ), @@ -224,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/density.R b/R/density.R index 108b4f99..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 @@ -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/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 0baf7ac0..f3ad86b9 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 @@ -1358,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 @@ -1415,10 +1435,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 @@ -2067,10 +2088,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)) } @@ -2302,9 +2320,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( @@ -2358,6 +2376,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/R/ps_trim.R b/R/ps_trim.R index 06ad6d21..bd02f555 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 **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 #' 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 @@ -32,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`. @@ -52,6 +56,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"`**: 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 **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 +#' supplied, with the same class. #' #' For categorical exposures, only `"ps"` and `"optimal"` are supported. #' @param lower,upper Numeric thresholds whose interpretation depends on @@ -59,19 +78,26 @@ #' #' * `"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). +#' * `"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 @@ -88,6 +114,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`. @@ -114,6 +156,13 @@ #' 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. +#' +#' 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 #' @@ -139,6 +188,78 @@ #' whose levels are ordered differently is still trimmed against the right #' column. #' +#' ## 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 +#' 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. +#' +#' 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. +#' `.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 #' #' Arithmetic operations on `ps_trim` objects return plain numeric vectors, @@ -184,29 +305,49 @@ #' 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. +#' +#' 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 +#' 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. +#' +#' [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 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 @@ -216,15 +357,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 @@ -244,12 +386,30 @@ #' * 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 +#' 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 +#' 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. @@ -293,6 +453,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) @@ -302,13 +468,24 @@ #' @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, .focal_level = NULL, .reference_level = NULL, ..., + .sigma = NULL, + .density = "normal", .treated = NULL, .untreated = NULL, ps = lifecycle::deprecated() @@ -325,16 +502,31 @@ 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, .focal_level = NULL, .reference_level = NULL, ..., + .sigma = NULL, + .density = "normal", .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. @@ -378,6 +570,27 @@ 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 model of the exposure's conditional mean, such as an + {.fun lm} fit, as {.arg .propensity}." + ), + error_class = "propensity_method_error", + call = call + ) + } + + check_score_trim_density(.sigma, .density, call = call) check_ps_range(.propensity, call = call) # Handle deprecation @@ -450,16 +663,20 @@ 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 - # 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) @@ -476,7 +693,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 @@ -485,7 +702,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( @@ -504,7 +721,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( @@ -528,10 +745,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 @@ -553,13 +773,24 @@ 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, .focal_level = NULL, .reference_level = NULL, ..., + .sigma = NULL, + .density = "normal", .treated = NULL, .untreated = NULL, ps = lifecycle::deprecated(), @@ -573,7 +804,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")) { @@ -587,6 +827,8 @@ ps_trim.matrix <- function( ) } + check_score_trim_density(.sigma, .density, call = call) + check_no_focal_levels( .focal_level, .reference_level, @@ -619,11 +861,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) @@ -656,16 +897,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 @@ -674,7 +915,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) { @@ -689,7 +930,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( @@ -712,20 +953,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 } } @@ -733,7 +974,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 @@ -755,13 +999,24 @@ 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, .focal_level = NULL, .reference_level = NULL, ..., + .sigma = NULL, + .density = "normal", .treated = NULL, .untreated = NULL, ps = lifecycle::deprecated(), @@ -796,6 +1051,8 @@ ps_trim.data.frame <- function( .focal_level = .focal_level, .reference_level = .reference_level, ..., + .sigma = .sigma, + .density = .density, .treated = .treated, .untreated = .untreated, call = call @@ -817,6 +1074,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(), @@ -824,22 +1083,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(), @@ -848,7 +1117,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, @@ -857,6 +1181,8 @@ ps_trim.glm <- function( .focal_level = .focal_level, .reference_level = .reference_level, ..., + .sigma = .sigma, + .density = .density, .treated = .treated, .untreated = .untreated, call = call, @@ -871,13 +1197,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(), @@ -896,6 +1233,8 @@ ps_trim.multinom <- function( .focal_level = .focal_level, .reference_level = .reference_level, ..., + .sigma = .sigma, + .density = .density, .treated = .treated, .untreated = .untreated, call = call, @@ -903,12 +1242,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 @@ -922,6 +1261,8 @@ ps_trim_from_model <- function( .focal_level, .reference_level, ..., + .sigma, + .density, .treated, .untreated, call, @@ -929,10 +1270,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, @@ -973,21 +1333,421 @@ 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 ) } +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 <- 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 <- abs(z) <= upper + } + + # `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_ + + # 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, - 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() @@ -1031,44 +1791,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 @@ -1162,13 +1911,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 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 -#' 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. @@ -1236,6 +1983,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 @@ -1279,7 +2053,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 @@ -1413,21 +2187,63 @@ 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, 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. 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", "P", "cr_lower", - "cr_upper" + "cr_upper", + "threshold", + "sigma", + "sigma_kind", + "density", + "focal_inverted" + ) + + params <- rlang::set_names( + lapply(fields, function(field) meta[[field]]), + 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) - rlang::set_names(lapply(fields, function(field) meta[[field]]), fields) + 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 + } + + params } #' @export @@ -1608,7 +2424,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 @@ -1651,11 +2467,31 @@ 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. 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 +} + #' @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 @@ -1689,7 +2525,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) } } @@ -1713,10 +2549,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. - x[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`, 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 ( + record_covers(meta, vec_size(values)) && + !merged_units_agree(values, trim_unit_status(meta)) + ) { + attr(out, "ps_trim_meta") <- drop_trim_record(meta) + } + + out } #' @export @@ -1758,6 +2613,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 @@ -1766,12 +2642,16 @@ 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, and the record rides along to the restore that builds - # the real result. - if (length(data) > 0 && !record_covers(meta, length(data))) { - meta <- discard_trim_record(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) } new_trimmed_ps(data, ps_trim_meta = meta) @@ -1792,6 +2672,55 @@ 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 +# 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 @@ -1810,10 +2739,24 @@ 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()]. 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`. #' @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`. 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 @@ -1825,7 +2768,16 @@ 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. 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` @@ -1837,6 +2789,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 @@ -1859,6 +2818,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. @@ -1882,8 +2849,10 @@ 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) + 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) @@ -1899,6 +2868,12 @@ 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, is.matrix(trimmed_ps)) + density_record <- is_density_trim_record(meta) + from_model <- is.null(.data) if (from_model) { .data <- refit_data(model) @@ -1933,10 +2908,17 @@ 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, ...) - } else { - stats::update(model, data = data_sub, subset = NULL, ...) + 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)) + } + 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) { + return(refit_dose_trim(meta, refit_model, data_sub, n_obs)) } # predict new PS for all rows @@ -1969,11 +2951,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] <- stats::predict( - refit_model, - newdata = data_sub, - type = "response" - ) + 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 @@ -1990,6 +2972,276 @@ 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. +# +# 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. 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, + from_model, + call = rlang::caller_env() +) { + arg_names <- names(dots) + values <- lapply(seq_along(dots), function(i) { + if (identical(arg_names[[i]], "formula.")) { + 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) { + 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.", + 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 +} + +# 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, +# 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 <- unique(column_candidate_names(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 +} + +# 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 +# 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. +# +# 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 (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", + 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} 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, such as one fit with {.fun gaussian}, {.fun lm}, + {.fun mgcv::gam}, or {.fun MASS::rlm}." + ), + 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, 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 <- unname(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 @@ -2135,6 +3387,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/ps_trunc.R b/R/ps_trunc.R index e94993db..08f6b962 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,15 +51,10 @@ #' #' For categorical exposures, only `"ps"` and `"pctl"` are supported. #' @param lower,upper Bounds for truncation. Interpretation depends on `method`: -#' * `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 = "adaptive"`: Not used. Supplying either is ignored with a +#' warning. +#' * `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. @@ -92,6 +91,69 @@ #' 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**, 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 +#' 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 +#' \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. 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 #' weights), the result is no longer a propensity score. @@ -107,7 +169,16 @@ #' 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`. 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, @@ -142,21 +213,46 @@ #' 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. +#' +#' 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 +#' 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. +#' +#' [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 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 @@ -166,15 +262,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 @@ -193,6 +289,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. @@ -213,6 +315,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) #' @@ -234,7 +340,7 @@ #' @export ps_trunc <- function( .propensity, - method = c("ps", "pctl", "cr"), + method = c("ps", "adaptive", "pctl", "cr"), lower = NULL, upper = NULL, .exposure = NULL, @@ -257,7 +363,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, @@ -318,16 +424,34 @@ 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. + 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 - } - if (is.null(upper)) { upper <- 0.9 + } else if (is.null(upper)) { + 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)) { + 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 + } 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 @@ -402,7 +526,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, @@ -422,9 +546,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( @@ -482,10 +609,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 @@ -500,7 +631,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 @@ -646,7 +781,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, @@ -718,13 +853,12 @@ 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, - method = c("ps", "pctl", "cr"), + method = c("ps", "adaptive", "pctl", "cr"), lower = NULL, upper = NULL, .exposure = NULL, @@ -755,6 +889,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", "adaptive", "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 @@ -762,7 +953,7 @@ ps_trunc.glm <- function( #' @export ps_trunc.multinom <- function( .propensity, - method = c("ps", "pctl", "cr"), + method = c("ps", "adaptive", "pctl", "cr"), lower = NULL, upper = NULL, .exposure = NULL, @@ -818,10 +1009,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, @@ -834,6 +1031,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 ) @@ -869,7 +1068,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, @@ -889,6 +1088,105 @@ 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 + ) +} + +# 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 +# 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 @@ -938,6 +1236,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. @@ -948,42 +1266,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 @@ -994,10 +1289,17 @@ 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) } } +# 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. @@ -1036,7 +1338,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 @@ -1114,13 +1417,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 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] -#' 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. @@ -1181,6 +1482,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 @@ -1224,7 +1550,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 @@ -1568,11 +1894,33 @@ 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. 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 +} + #' @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 @@ -1599,10 +1947,28 @@ 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. - x[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 + # 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 ( + record_covers(meta, vec_size(values)) && + !merged_units_agree(values, trunc_unit_status(meta)) + ) { + attr(out, "ps_trunc_meta") <- drop_trunc_record(meta) + } + + out } #' @export @@ -1630,6 +1996,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 @@ -1638,12 +2025,16 @@ 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, and the record rides along to the restore that builds - # the real result. - if (length(data) > 0 && !record_covers(meta, length(data))) { - meta <- discard_trunc_record(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) } new_ps_trunc(data, meta) diff --git a/R/psw.R b/R/psw.R index 19022874..c4280298 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,13 +74,13 @@ #' 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 -#' 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 +#' 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 #' `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 @@ -101,22 +104,60 @@ #' #' 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. 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. +#' 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 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 +#' 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 +#' 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, -#' and the records left by a modified propensity score (`ps_trim_meta`, -#' `ps_trunc_meta`, and `ps_calib_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 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; `[<-` refuses a value whose records describe a different +#' 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 +#' `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 @@ -131,21 +172,22 @@ #' 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, 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 -#' 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 @@ -167,6 +209,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 +272,7 @@ new_psw <- function( truncated = FALSE, calibrated = FALSE, stabilization_score = NULL, + wt_truncated = FALSE, ... ) { vec_assert(x, ptype = double()) @@ -239,6 +285,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 +303,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 +320,8 @@ psw <- function( trimmed = trimmed, truncated = truncated, calibrated = calibrated, - stabilization_score = stabilization_score + stabilization_score = stabilization_score, + wt_truncated = wt_truncated ) } @@ -338,13 +387,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, @@ -801,6 +854,228 @@ 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 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. +#' +#' `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")] +} + +# 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]]) + } + } + + 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 +# 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) @@ -838,17 +1113,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) @@ -878,6 +1158,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 @@ -927,6 +1208,7 @@ vec_arith.psw.psw <- function(op, x, y, ...) { trimmed = trimmed, truncated = truncated, calibrated = calibrated, + wt_truncated = wt_truncated, attrs = attrs ) } @@ -936,7 +1218,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) ) @@ -946,21 +1228,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 @@ -994,9 +1276,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 @@ -1006,6 +1288,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 @@ -1098,10 +1405,20 @@ 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 +# 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_modification_meta <- c( + "ps_trim_meta", + "ps_trunc_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. @@ -1121,15 +1438,69 @@ 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 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 loses its positions, as a restore drops them. +reindex_psw_records <- function(attrs, x, i) { + n_obs <- length(x) + + for (field in psw_modification_meta) { + meta <- attr(x, field) + 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 } # What the joint record can still say once data has arrived at `n` observations. @@ -1137,23 +1508,33 @@ modification_meta_aligns <- function(n, to) { # 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 @@ -1181,18 +1562,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 @@ -1218,6 +1604,7 @@ psw_carried_attrs <- c( # recorded here rather than guarded against. psw_conflicted_attr <- "psw_conflicted_attrs" + conflicted_psw_attrs <- function(x) { out <- attr(x, psw_conflicted_attr) if (is.null(out)) character() else out @@ -1227,21 +1614,32 @@ 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 - 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 (!modification_meta_aligns(n, to)) { - attrs[psw_modification_meta] <- list(NULL) + if (!is.null(i)) { + attrs <- reindex_psw_records(attrs, to, i) + } else if (!modification_meta_aligns(n, to, in_place)) { + 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 @@ -1267,6 +1665,7 @@ build_psw <- function( trimmed, truncated, calibrated, + wt_truncated, attrs ) { out <- new_psw( @@ -1276,7 +1675,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")) { @@ -1286,7 +1686,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), @@ -1294,7 +1696,8 @@ carry_psw_metadata <- function(x, to) { trimmed = is_ps_trimmed(to), truncated = is_ps_truncated(to), calibrated = is_ps_calibrated(to), - attrs = aligned_psw_attrs(to, length(x)) + wt_truncated = is_wt_truncated(to), + attrs = aligned_psw_attrs(to, length(x), in_place = in_place, i = i) ) } @@ -1346,8 +1749,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)) @@ -1425,6 +1829,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) } @@ -1507,8 +1917,36 @@ 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, ...) { + 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) @@ -1521,39 +1959,132 @@ vec_restore.psw <- function(x, to, ...) { # 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) + x +} + +# `[` is the one slice that knows its subscript, so it carries the position +# 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")) { + return(out) + } + + 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)) + } + + 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 +# 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. `vec_ptype2()` and -# `vec_cast()` read the same set, so weights that combine without complaint are -# also each other's type. +# 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) { list( estimand = estimand(x), @@ -1561,7 +2092,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) ) } @@ -1572,7 +2104,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 @@ -1610,20 +2143,27 @@ vec_ptype2.psw.psw <- function(x, y, ...) { return(double()) } + # 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 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) - ) + # 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) } @@ -1635,8 +2175,10 @@ 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)), + combined_psw_records(x, y), merged$attrs ) ) @@ -1666,6 +2208,11 @@ cast_to_psw <- function(x, to) { x <- vec_cast(vec_data(x), to = double()) attributes(x) <- NULL + # `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) } @@ -1682,20 +2229,70 @@ 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, 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) { + # 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"]]) || + !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) @@ -1757,5 +2354,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/R/utils.R b/R/utils.R index 1068f126..4c1f7ecf 100644 --- a/R/utils.R +++ b/R/utils.R @@ -260,12 +260,161 @@ 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. +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") +} + +# 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. +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 -# 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/weights-utils.R b/R/weights-utils.R index 7b948066..051e1cc9 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" @@ -1321,6 +1327,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) ) { @@ -1335,6 +1342,30 @@ 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( + .propensity, + .exposure, + weight_fn = weight_fn, + modification_type = modification_type, + exposure_type = exposure_type, + call = call + ) + # Only check refit for trim if (modification_type == "trim") { check_refit(.propensity, call = call) @@ -1351,6 +1382,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) @@ -1397,6 +1438,214 @@ 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 +# 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)) + } + + # 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)) + } + + 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 @@ -1650,6 +1899,27 @@ 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) { + 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 # 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 @@ -1661,20 +1931,34 @@ 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)) + 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) @@ -1701,6 +1985,7 @@ handle_data_frame_weight_calculation <- function( .untreated = NULL, fn_name, ..., + density_supplied = TRUE, call = rlang::caller_env(), user_env = rlang::caller_env(2) ) { @@ -1753,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, @@ -1776,6 +2079,33 @@ 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, + ..., + density_supplied = density_supplied, + 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( @@ -1978,6 +2308,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 +2321,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 +2375,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) @@ -2064,6 +2406,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/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/R/wt_trunc.R b/R/wt_trunc.R new file mode 100644 index 00000000..3ed04cc4 --- /dev/null +++ b/R/wt_trunc.R @@ -0,0 +1,719 @@ +#' 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()`. +#' +#' ## 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 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 +#' 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. +#' +#' @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) + 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. + 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 + ) +} + +# 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. +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) + + # 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( + sum(!is.na(x)), + lower, + upper, + call = call + ), + wt = wt_trunc_wt_bounds(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()` + # 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 <- restore_psw(x, .weights, in_place = TRUE) + 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(n_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(n_present, "adaptive", call = call) + + list( + lower = NULL, + upper = NULL, + lower_value = NULL, + upper_value = adaptive_weight_bound(n_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) + + 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(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. + 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 + ) + } + + # 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]] + } + + 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(n, method, call) { + 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 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 (is.null(meta)) { + 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)) + ) + + counts <- if (record_covers(meta, length(x))) { + paste0( + ", ", + length(meta$truncated_idx), + " of ", + meta$n_obs, + " weights truncated" + ) + } + + paste0( + "truncation: ", + label, + " (", + paste(realized, collapse = ", "), + ")", + counts + ) +} diff --git a/R/wt_trunc_sensitivity.R b/R/wt_trunc_sensitivity.R new file mode 100644 index 00000000..c40f5e22 --- /dev/null +++ b/R/wt_trunc_sensitivity.R @@ -0,0 +1,334 @@ +#' 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 + ) + + 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) { + 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) + 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, + max = max, + range_ratio = max / min, + 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 4cee7819..271bd8a4 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. @@ -47,12 +48,15 @@ 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 + - 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 da26b2e9..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 @@ -23,6 +25,7 @@ Feng Gerke Geskus Greifer +Gruber HC Hajage Hajek @@ -37,6 +40,7 @@ JK JM Kadziola Kostouraki +Laan Lauer Leyrat Lunceford @@ -59,6 +63,7 @@ Subassignment Toh Unstabilized Wal +Wasserman WeightIt Winsorize Zadrozny @@ -108,6 +113,7 @@ pctl poisson positionally positivity +preprint ps quasibinomial quasipoisson @@ -136,6 +142,7 @@ unexamined ungrouped unstabilized untestable +untruncated validator vctrs winsorization 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/ipw-methods.Rd b/man/ipw-methods.Rd index 3bdf43f7..85dce43c 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 @@ -1626,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 @@ -1683,10 +1703,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/man/is_unit_trimmed.Rd b/man/is_unit_trimmed.Rd index e7885142..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 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 -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 691bad92..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 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} -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/is_wt_truncated.Rd b/man/is_wt_truncated.Rd new file mode 100644 index 00000000..2de2f2f0 --- /dev/null +++ b/man/is_wt_truncated.Rd @@ -0,0 +1,61 @@ +% 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 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. + +\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/ps_refit.Rd b/man/ps_refit.Rd index d96fa29f..25c56954 100644 --- a/man/ps_refit.Rd +++ b/man/ps_refit.Rd @@ -10,11 +10,25 @@ 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()}}. 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}.} \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}. 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 @@ -28,7 +42,16 @@ 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. 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 @@ -37,6 +60,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 @@ -62,6 +93,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 20f2f1c6..724cabfd 100644 --- a/man/ps_trim.Rd +++ b/man/ps_trim.Rd @@ -6,13 +6,15 @@ \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, .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{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 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 @@ -45,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}. @@ -65,8 +71,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"}}: 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{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 +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 @@ -74,21 +95,28 @@ 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). -}} +\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 @@ -108,6 +136,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.} @@ -129,7 +175,17 @@ 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 +\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}, @@ -161,7 +217,14 @@ 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. } + +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}{ @@ -190,6 +253,79 @@ whose levels are ordered differently is still trimmed against the right column. } +\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 +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. + +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. +\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}{ Arithmetic operations on \code{ps_trim} objects return plain numeric vectors, @@ -237,29 +373,49 @@ 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. + +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 +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. + +\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 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 @@ -269,15 +425,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 @@ -315,6 +472,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) @@ -323,10 +486,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_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/man/ps_trunc.Rd b/man/ps_trunc.Rd index 3fee45a3..fd8e4216 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,15 +65,10 @@ 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 = "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 = "adaptive"}: Not used. Supplying either is ignored with a +warning. +\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. @@ -132,6 +131,69 @@ 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}, 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 +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 +\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. 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 @@ -140,13 +202,24 @@ 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 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}. 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, @@ -183,21 +256,46 @@ 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. + +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 +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. + +\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 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 @@ -207,15 +305,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 @@ -236,6 +334,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) @@ -260,6 +362,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/man/psw.Rd b/man/psw.Rd index afec0153..f6c02d9a 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,13 +159,13 @@ 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 -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 +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 \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 @@ -180,22 +189,60 @@ 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. 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. +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 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 +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 +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, -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 -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 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; \verb{[<-} refuses a value whose records describe a different +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 +\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 @@ -210,21 +257,22 @@ 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, 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 -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 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/man/wt_trunc.Rd b/man/wt_trunc.Rd new file mode 100644 index 00000000..c7bca1ae --- /dev/null +++ b/man/wt_trunc.Rd @@ -0,0 +1,254 @@ +% 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()}. +} + +\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 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 +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) +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/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/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/_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/_snaps/ps_refit-density.md b/tests/testthat/_snaps/ps_refit-density.md new file mode 100644 index 00000000..c2fd0708 --- /dev/null +++ b/tests/testthat/_snaps/ps_refit-density.md @@ -0,0 +1,79 @@ +# 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` 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()`. + +--- + + 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` 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 + + 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 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 + 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/_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. + 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_trim-density.md b/tests/testthat/_snaps/ps_trim-density.md new file mode 100644 index 00000000..e35a9f32 --- /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 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. + +# 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 4773d514..a5922351 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 model of the exposure's conditional mean, such as an `lm()` fit, 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 model of the exposure's conditional mean, such as an `lm()` fit, as `.propensity`. + # ps_trim names `.exposure` when the method requires one Code @@ -234,13 +274,54 @@ 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. + +# 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 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/_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/_snaps/ps_trunc-default-bounds.md b/tests/testthat/_snaps/ps_trunc-default-bounds.md new file mode 100644 index 00000000..1ba7c6cc --- /dev/null +++ b/tests/testthat/_snaps/ps_trunc-default-bounds.md @@ -0,0 +1,58 @@ +# 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. + +# 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 + 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/_snaps/ps_trunc.md b/tests/testthat/_snaps/ps_trunc.md index 22c4c9f8..bb0d2abf 100644 --- a/tests/testthat/_snaps/ps_trunc.md +++ b/tests/testthat/_snaps/ps_trunc.md @@ -116,7 +116,37 @@ 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 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 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 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/_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/_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/_snaps/weights-continuous.md b/tests/testthat/_snaps/weights-continuous.md index 9d9705af..7b9fc74c 100644 --- a/tests/testthat/_snaps/weights-continuous.md +++ b/tests/testthat/_snaps/weights-continuous.md @@ -68,6 +68,126 @@ 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()`. + +# 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 @@ -187,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. @@ -198,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/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 new file mode 100644 index 00000000..1e742372 --- /dev/null +++ b/tests/testthat/_snaps/wt-trunc.md @@ -0,0 +1,191 @@ +# 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 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: wt (upper 3) + +# 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 + 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 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 + 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/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/helper-dose-trim.R b/tests/testthat/helper-dose-trim.R new file mode 100644 index 00000000..abf905ad --- /dev/null +++ b/tests/testthat/helper-dose-trim.R @@ -0,0 +1,208 @@ +# 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) +} + +# 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/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-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..444dc1f2 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_positions_dropped(ps_trim_meta(sliced), ps_trim_meta(wt)) expect_error( - is_unit_trimmed(first_two), + is_unit_trimmed(sliced), class = "propensity_missing_meta_error" ) }) 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..96f8b726 --- /dev/null +++ b/tests/testthat/test-combine-explicit-prototype-scores.R @@ -0,0 +1,224 @@ +# 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") +}) + +# 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))) +}) diff --git a/tests/testthat/test-combine-single-modified.R b/tests/testthat/test-combine-single-modified.R new file mode 100644 index 00000000..b099d5cd --- /dev/null +++ b/tests/testthat/test-combine-single-modified.R @@ -0,0 +1,309 @@ +# 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( + 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("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(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 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() + + 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'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_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), + class = "propensity_missing_meta_error" + ) + + from_unchop <- vctrs::list_unchop(list(w)) + 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" + ) +}) + +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 records' positions", { + w <- single_trimmed_psw() + + combined <- c(w, w) + + expect_length(combined, 2 * length(w)) + 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' 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() + first <- suppressWarnings(w[1:10]) + second <- suppressWarnings(w[11:20]) + + combined <- c(first, second) + + expect_length(combined, length(w)) + 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's positions", { + w <- single_wt_truncated_psw() + + combined <- c(w, w) + + 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's positions", { + w <- single_truncated_psw() + + combined <- c(w, w) + + expect_positions_dropped( + attr(combined, "ps_trunc_meta"), + attr(w, "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' positions describes the result; what the records say about the +# trimming still does. + +expect_trim_record_dropped <- function(x) { + 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's positions", { + 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'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's positions", { + 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's positions", { + 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_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_positions_dropped( + attr(cast, "psw_trunc_meta"), + attr(w, "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", { + 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) +}) 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-ipw-wt-trunc.R b/tests/testthat/test-ipw-wt-trunc.R new file mode 100644 index 00000000..f6c07ba9 --- /dev/null +++ b/tests/testthat/test-ipw-wt-trunc.R @@ -0,0 +1,496 @@ +# 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, + x1_effect = 0.8 +) { + withr::local_seed(seed) + x1 <- rnorm(n) + x2 <- rbinom(n, 1, 0.5) + 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) +} + +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, + method = "count", + x1_effect = 0.8 +) { + withr::local_options(propensity.quiet = TRUE) + 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)), + dat$A, + exposure_type = "continuous", + stabilize = stabilize + ) + wts <- if (method == "adaptive") { + wt_trunc(base, method = "adaptive") + } else { + wt_trunc(base, method = method, 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 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", { + fixtures <- list( + 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_exposure = wt_trunc_ipw_joint_exposure() + ) + + 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 every SE path", { + 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" + ) + 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", { + 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 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() + + 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" + ) +}) + +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", { + # 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) + + 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") + } + + 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)) +}) 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..222d9c96 --- /dev/null +++ b/tests/testthat/test-modified-score-matrix-frame.R @@ -0,0 +1,305 @@ +# 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" + ) +}) + +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" + ) +}) 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..b5d206d4 --- /dev/null +++ b/tests/testthat/test-modified-score-matrix-unique.R @@ -0,0 +1,247 @@ +# `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" + ) + } +}) + +# 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)) +}) diff --git a/tests/testthat/test-modified-score-records.R b/tests/testthat/test-modified-score-records.R new file mode 100644 index 00000000..a3fc82b1 --- /dev/null +++ b/tests/testthat/test-modified-score-records.R @@ -0,0 +1,162 @@ +# 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 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)) { + out <- expect_silent(unique(x)) + + 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 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)) { + out <- expect_silent(unique(x)) + + 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" + ) + } +}) diff --git a/tests/testthat/test-ps_refit-density.R b/tests/testthat/test-ps_refit-density.R new file mode 100644 index 00000000..e98b6711 --- /dev/null +++ b/tests/testthat/test-ps_refit-density.R @@ -0,0 +1,1058 @@ +# 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 + ) +}) + +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 + ) +}) + +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", { + 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" + ) +}) 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") +}) 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-density.R b/tests/testthat/test-ps_trim-density.R new file mode 100644 index 00000000..7e697ada --- /dev/null +++ b/tests/testthat/test-ps_trim-density.R @@ -0,0 +1,1099 @@ +# 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 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() + 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", { + 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. 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 + 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" + ) + + # 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)) +}) + +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 + )) +}) diff --git a/tests/testthat/test-ps_trim.R b/tests/testthat/test-ps_trim.R index b1d88865..96de9fde 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)) @@ -725,14 +717,16 @@ test_that("filtering a ps_trim column drops the trimming record with a warning", ) }) -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) @@ -799,10 +793,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), @@ -810,6 +801,77 @@ 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("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() @@ -854,31 +916,24 @@ 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) }) -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 @@ -948,6 +1003,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) @@ -2761,12 +2845,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" @@ -2815,9 +2893,584 @@ 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) +}) + +# 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 <- predict(gam_fit, type = "response") + gam_scores <- setNames(as.vector(gam_scores), names(gam_scores)) + 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) +}) + +# 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_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() 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() 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" + ) +}) + +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" + ) +}) + +# 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("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("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(lm(z ~ x1 + x2, data = trim_model_data), method = "ps") + ps_trim(structure(list(), class = "not_a_model"), method = "ps") ) }) @@ -2860,10 +3513,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 @@ -2876,14 +3528,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 diff --git a/tests/testthat/test-ps_trunc-adaptive.R b/tests/testthat/test-ps_trunc-adaptive.R new file mode 100644 index 00000000..8d21ad33 --- /dev/null +++ b/tests/testthat/test-ps_trunc-adaptive.R @@ -0,0 +1,560 @@ +# 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("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") + + 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 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") + + 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) + + # 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")) +}) 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 new file mode 100644 index 00000000..d7cb9110 --- /dev/null +++ b/tests/testthat/test-ps_trunc-default-bounds.R @@ -0,0 +1,273 @@ +# 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 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) + 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( + unname(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) +}) diff --git a/tests/testthat/test-ps_trunc.R b/tests/testthat/test-ps_trunc.R index 18609f66..6fa4eeb5 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)) @@ -605,14 +597,19 @@ test_that("filtering a ps_trunc column drops the truncation record with a warnin ) }) -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) @@ -708,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 @@ -1095,6 +1089,72 @@ 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)) + + # 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_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", { + 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) @@ -1803,12 +1863,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 +1871,64 @@ 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")) +}) + +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 @@ -2002,3 +2110,64 @@ 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 <- predict(gam_fit, type = "response") + gam_scores <- setNames(as.vector(gam_scores), names(gam_scores)) + + 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 + ) +}) diff --git a/tests/testthat/test-psw-assign-records.R b/tests/testthat/test-psw-assign-records.R new file mode 100644 index 00000000..12e8473b --- /dev/null +++ b/tests/testthat/test-psw-assign-records.R @@ -0,0 +1,158 @@ +# 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" + ) + 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", { + 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)) +}) 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)) +}) diff --git a/tests/testthat/test-psw-record-positions.R b/tests/testthat/test-psw-record-positions.R new file mode 100644 index 00000000..bff95546 --- /dev/null +++ b/tests/testthat/test-psw-record-positions.R @@ -0,0 +1,285 @@ +# 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) + } +}) + +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-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-psw-reorder-records.R b/tests/testthat/test-psw-reorder-records.R new file mode 100644 index 00000000..434eeaeb --- /dev/null +++ b/tests/testthat/test-psw-reorder-records.R @@ -0,0 +1,406 @@ +# 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 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() { + 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_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 + ) +} + +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 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_positions_dropped(attr(out, "psw_trunc_meta"), 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 record's positions 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 record's positions 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_positions_dropped( + attr(out, "psw_trunc_meta"), + attr(a, "psw_trunc_meta") + ) + 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-reorder-score.R b/tests/testthat/test-psw-reorder-score.R new file mode 100644 index 00000000..e3f1377f --- /dev/null +++ b/tests/testthat/test-psw-reorder-score.R @@ -0,0 +1,204 @@ +# 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)) + # 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", { + 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") +}) diff --git a/tests/testthat/test-psw-wt-trunc.R b/tests/testthat/test-psw-wt-trunc.R new file mode 100644 index 00000000..081017ff --- /dev/null +++ b/tests/testthat/test-psw-wt-trunc.R @@ -0,0 +1,554 @@ +# 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 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. +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) + + # 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's positions. + sliced <- expect_silent(vec_slice(w, seq_along(w))) + expect_positions_dropped(attr(sliced, "psw_trunc_meta"), meta) + expect_true(is_wt_truncated(sliced)) +}) + +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_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 record's positions and keeps the flag", { + w <- wt_truncated_psw() + + sliced <- expect_silent(vec_slice(w, 1:2)) + 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 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" + ) +}) + +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 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_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. + 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_positions_dropped(attr(proto, "psw_trunc_meta"), wt_trunc_record()) +}) + +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 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_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", { + # 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_positions_dropped(attr(out, "psw_trunc_meta"), wt_trunc_record()) +}) + +test_that("a weight-truncated psw with no record agrees with any bound", { + # 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 <- 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)) + + out <- expect_silent(c(w, alt_slice)) + 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_positions_dropped(attr(proto, "psw_trunc_meta"), wt_trunc_record()) +}) + +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))) +}) diff --git a/tests/testthat/test-psw.R b/tests/testthat/test-psw.R index 5a947b8e..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)) }) @@ -552,7 +554,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. @@ -713,8 +715,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's positions. sliced <- expect_silent(vec_slice(w, seq_along(w))) - expect_identical(ps_trim_meta(sliced), meta) + expect_positions_dropped(ps_trim_meta(sliced), meta) + expect_true(is_ps_trimmed(sliced)) }) test_that("length-preserving psw arithmetic keeps truncation and calibration records", { @@ -731,34 +736,181 @@ 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's positions silently", { + w <- trimmed_psw() sliced <- expect_silent(vec_slice(w, 1:2)) - expect_null(ps_trim_meta(sliced)) + expect_s3_class(sliced, "psw") + expect_length(sliced, 2) + 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)) + expect_identical(estimand(sliced), "ate; trimmed") }) -test_that("shortening a psw drops truncation and calibration records 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_positions_dropped(ps_trunc_meta(sliced), meta) + 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 +# 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", { @@ -782,22 +934,29 @@ 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) 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_positions_dropped(ps_trim_meta(out$value), ps_trim_meta(w)) 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, 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)) }) test_that("the trimmed flag survives operations that drop the trimming record", { @@ -811,21 +970,21 @@ 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 goes 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 @@ -1410,13 +1569,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)) @@ -1426,29 +1585,32 @@ 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 + # 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)) }) -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", { @@ -1545,6 +1707,7 @@ test_that("the record of what an operation dropped stays off its result", { "trimmed", "truncated", "calibrated", + "wt_truncated", "class", "n_categories", "category_names", @@ -1767,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(), @@ -1777,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 new file mode 100644 index 00000000..85f2260d --- /dev/null +++ b/tests/testthat/test-score-slice-records.R @@ -0,0 +1,161 @@ +# 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) + # 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) + } +}) + +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 + ) + } +}) 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) }) diff --git a/tests/testthat/test-weights-continuous.R b/tests/testthat/test-weights-continuous.R index ff17ac5a..590267d1 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,250 @@ 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") +}) - # A score a modification can be applied to has to lie in (0, 1); it stands in - # for the fitted conditional mean here. +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 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) + # 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 ) - plain <- wt_cens( - as.numeric(modified), - exposure, - exposure_type = "continuous", - stabilize = TRUE, - .density = dens_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 + ) + } +}) + +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) ) - expect_equal(as.numeric(weights), as.numeric(plain), tolerance = 1e-12) - expect_identical(format(density_meta(weights)$density), "t(df = 4)") + 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 + ) + } } }) @@ -1013,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", { @@ -1050,20 +1273,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,25 +1301,20 @@ 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) 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) } }) @@ -1898,13 +2113,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 +2140,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 +2574,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 +2659,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 ) } diff --git a/tests/testthat/test-weights.R b/tests/testthat/test-weights.R index 223a3266..eb445059 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]) @@ -2378,6 +2373,186 @@ 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 gives the matrix's 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 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( + wt_ate, + score, + exposure, + exposure_type = "categorical" + ) + expect_identical( + from_matrix$warned, + identical(modification, "trimmed"), + info = modification + ) + + from_frame <- weights_and_refit_warning( + wt_ate, + as.data.frame(score), + exposure, + exposure_type = "categorical" + ) + + 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 + ) + } +}) + # ---- data frame columns resolve by focal level name ------------------------ # A data frame of per-level probabilities whose columns are named for the 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)) diff --git a/tests/testthat/test-wt-trunc-sensitivity.R b/tests/testthat/test-wt-trunc-sensitivity.R new file mode 100644 index 00000000..0323f2f4 --- /dev/null +++ b/tests/testthat/test-wt-trunc-sensitivity.R @@ -0,0 +1,762 @@ +# 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" + ) + + # 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)) + ) +}) + +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("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 + # 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)) +}) + +# ---- 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 new file mode 100644 index 00000000..d2620f02 --- /dev/null +++ b/tests/testthat/test-wt-trunc.R @@ -0,0 +1,1172 @@ +# 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("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 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)) +}) + +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", { + 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 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 + # 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) + ) +}) 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