diff --git a/DESCRIPTION b/DESCRIPTION index 3932c1c..20de041 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -39,7 +39,7 @@ Suggests: optweight, osqp, pkgload, - propensity, + propensity (>= 0.1.0.9000), quadprog, rmarkdown, testthat (>= 3.0.0), @@ -49,7 +49,8 @@ VignetteBuilder: knitr Remotes: r-causal/causalgenerics, - r-causal/deli + r-causal/deli, + r-causal/propensity Config/roxygen2/version: 8.1.0 Config/testthat/edition: 3 Encoding: UTF-8 diff --git a/R/aaa-classes.R b/R/aaa-classes.R index e870699..b7a0fb9 100644 --- a/R/aaa-classes.R +++ b/R/aaa-classes.R @@ -25,10 +25,14 @@ cat_cli <- function(expr) { #' stable balancing weights) subclasses `quadratic_program_method`. None of the #' abstract classes can be constructed directly. #' -#' @param convergence_tolerance The solver convergence tolerance, or `NULL` for -#' the core default. -#' @param max_iterations The maximum solver iterations, or `NULL` for the core -#' default. +#' @param convergence_tolerance The solver convergence tolerance, or `NULL` to +#' leave it to the solver. The value resolved for `NULL` differs by family: +#' `1e-10` on the gradient for the estimating-equation methods, and `1e-8` as +#' both the absolute and the relative tolerance for the quadratic-program +#' methods. +#' @param max_iterations The maximum solver iterations, or `NULL` to leave the +#' cap to the solver. The value resolved for `NULL` is 1000 for the +#' estimating-equation methods and 200000 for the quadratic-program methods. #' @param weight_penalty The L2 penalty on the weights. #' @param min_weight The smallest permitted weight. #' @@ -222,6 +226,16 @@ fit_method <- new_generic("fit_method", "method", function(method, prepared) { #' value selects the inexact problem for entropy balancing and is the central #' tuning parameter for stable balancing weights. #' +#' For a continuous exposure there are no groups to equate, so a constraint +#' column is instead held within `tolerance` of zero weighted correlation with +#' the exposure. On the continuous energy path this is what `moments` and +#' `interactions` request, and there the correlation is held exactly whatever +#' `tolerance` says, for the reason [bw_energy()] records. The marginal +#' distribution of the exposure and of the covariates is a separate matter, +#' held by `distribution_moments` in [bw_energy()] and [bw_entropy()]; asking +#' for correlation constraints does not add marginal rows, and raising +#' `distribution_moments` adds no correlation constraint. +#' #' A factor covariate contributes one indicator per level rather than the #' reference coding a model formula would use. Those indicators sum to the #' constant every balancing method carries, so one of them is redundant and the @@ -232,6 +246,8 @@ fit_method <- new_generic("fit_method", "method", function(method, prepared) { #' #' @param moments The highest covariate power to balance. A single whole number #' or a named integer vector; `NULL` (the default) resolves to first moments. +#' For a continuous exposure each power is held at zero weighted correlation +#' with the exposure instead. #' @param interactions Whether to add pairwise interactions of the base columns. #' These expand the constraint set the weights must balance, adding the #' pairwise products of the base columns to the covariate functions a fit @@ -417,7 +433,8 @@ balancing_estimating_equations <- new_class( #' energy or kernel balancing with no moment constraints, therefore records no #' covariates even though its objective reads every selected one. #' @param focal_level The focal exposure level for `"att"` and `"atc"`, or -#' `NULL`. +#' `NULL`. This is the fitted object's property, set from the `.focal_level` +#' argument of [balance()]. #' @param n The number of observations. #' @param constraints The resolved [balance_terms] specification, or `NULL`. #' @param recipe The covariate expansion recipe, a list of per-column records. @@ -425,7 +442,15 @@ balancing_estimating_equations <- new_class( #' @param duals Solver dual variables for diagnostics, or `NULL`. #' @param coefficients The fitted coefficients or dual variables, or `NULL`. #' @param converged Whether the solver met its convergence criterion. -#' @param iterations The solver iteration count. +#' @param iterations The solver iteration count. An energy fit that could not +#' reach its tolerance re-solves at a reachable one, and when that re-solve +#' converges this sums the original and the fallback solve, so it can exceed +#' the requested `max_iterations`. When the re-solve does not converge the +#' fit reports the original solve alone, so the count stays within the cap. +#' A continuous energy or stable balancing fit with a positive tolerance +#' refines the bound it hands the solver over several passes, each a solve of +#' its own, and this sums every one of them. See [bw_energy()] and [bw_sbw()] +#' for the fuller account. #' @param objective The solved objective value. #' @param solver_status The solver that produced the result. #' @param estimating_equations The [balancing_estimating_equations] container, @@ -506,6 +531,10 @@ method(print, balancing) <- function(x, ...) { # constraint's statistic is undefined, and printing "NaN" as the largest # imbalance states a distance that was never measured. Saying the # assessment is what failed is the same ruling the balance warning follows. + # The figure is rendered to three significant digits, matching the balance + # warning, because a well-solved fit can leave an imbalance far below the + # fourth decimal and a fixed format prints that as a zero, contradicting + # the warning that names the same number. statistic <- x@balance_table$statistic[1] largest <- max(abs(x@balance_table$weighted)) if (is.finite(largest)) { @@ -515,7 +544,7 @@ method(print, balancing) <- function(x, ...) { "standardized mean difference" } cli::cli_text( - "Largest imbalance: {formatC(largest, format = 'f', digits = 4)} ({label})" + "Largest imbalance: {formatC(largest, format = 'g', digits = 3)} ({label})" ) } else { cli::cli_text("Largest imbalance: could not be assessed") diff --git a/R/balance-table.R b/R/balance-table.R index 8bd3d6d..2587c7b 100644 --- a/R/balance-table.R +++ b/R/balance-table.R @@ -19,6 +19,55 @@ balance_margin <- function(tolerance) { 1e-6 + 0.02 * tolerance } +# The largest number of correlation-refinement passes a continuous +# quadratic-program fit takes, and the fraction of the room to its target the +# effective tolerance is tightened to on each pass, held just under one so a +# converged fit sits inside the band rather than on its edge. +# +# Both continuous quadratic programs need this loop and they run the same one. +# Each bounds a linearized correlation whose exposure and covariate scales are +# fixed at the sample, so reweighting to meet the bound shrinks both weighted +# standard deviations and the reported Pearson correlation runs above the bound. +# The two stop against the same statistic, they rescale a binding column the +# same way, and a pass that runs out of iterations falls back to the last +# converged iterate in both, while a pass the backend certifies infeasible is +# left to surface as the infeasible condition. They take the same cap for the +# same reason: a pass costs a whole solve, and eight of them is where the +# tightening has converged in every case measured. +# +# One thing does differ, and deliberately: the slack a column may exceed its +# target by before the pass counts it as binding. Energy uses +# `balance_margin()`, the same slack the balance table's verdict allows, so it +# stops refining exactly when the table would stop complaining. Stable balancing +# weights use a flat 1e-8, which is tighter than the verdict, so they keep +# tightening through a band the table would already accept. Neither reports a +# column the table judges out of balance; the tighter margin only buys passes. +correlation_refinement_passes <- 8L +correlation_refinement_safety <- 0.98 + +# Absolute weighted exposure-covariate Pearson correlations under weights `w`, +# the statistic a continuous fit is judged on and the quantity the balance table +# reports, so a refinement loop measures the same thing the specs assert. A +# column with no weighted spread has no correlation to report: it is met by +# every weighting, so it reads as zero rather than carrying an undefined value +# into the comparison that decides which tolerances still bind. The table itself +# leaves that case missing instead, where it becomes a verdict of out of balance +# rather than a row the loop would chase forever. +weighted_exposure_correlations <- function(exposure, z, w) { + vapply( + seq_len(ncol(z)), + function(j) { + correlation <- stats::cov.wt( + cbind(exposure, z[, j]), + wt = w, + cor = TRUE + )$cor[1, 2] + if (is.finite(correlation)) abs(correlation) else 0 + }, + numeric(1) + ) +} + # Build a bare tibble without a tibble dependency, matching how positively and # the tidyverse store display tables on result objects. new_balancing_tibble <- function(cols) { @@ -34,21 +83,123 @@ new_balancing_tibble <- function(cols) { # mean differences against. Without sampling weights the weighted statistics reduce # to the unweighted ones. The re-standardization expect_balanced() applies uses the # same convention. +# +# The centers and scales are taken as column arithmetic over the whole matrix +# rather than column by column, since the balance table is assembled once per fit +# over as many columns as the fit has constraints. `colSums()` accumulates in the +# same extended precision `sum()` does, so the weighted branch reproduces the +# per-column `weighted_center()` and `weighted_scale()` values (R/utils.R) bit for +# bit rather than merely approximating them: the reliability denominator and the +# zero-scale guard are both carried over unchanged, the former as a single scalar +# because it depends only on the weights. +# +# The unweighted scale takes its sum of squares about a corrected two-pass +# center, the first column mean plus the mean of the residuals from it. +# `stats::sd()` applies the same correction, but carries it entirely in long +# double, whereas this reproduction rounds to double between the two passes. The +# two therefore agree to rounding rather than exactly, occasionally differing by +# a final unit in the last place. The correction still earns its pass: without it +# the plain two-pass form matches `stats::sd()` only while a column's values are +# comparable to their spread, and its error grows with the ratio of the column's +# offset to that spread, whereas the corrected form tracks `stats::sd()` to +# rounding at any offset. The reported centering stays on the plain column mean, +# as before. standardize_columns <- function(m, sampling_weights = NULL) { if (is.null(sampling_weights)) { centers <- colMeans(m) - scales <- apply(m, 2, stats::sd) + centered <- sweep(m, 2, centers, "-") + corrected <- sweep(m, 2, centers + colMeans(centered), "-") + scales <- sqrt(colSums(corrected^2) / (nrow(m) - 1)) } else { - centers <- apply(m, 2, weighted_center, w = sampling_weights) - scales <- apply(m, 2, weighted_scale, w = sampling_weights) + centers <- column_weighted_means(m, sampling_weights) + centered <- sweep(m, 2, centers, "-") + scales <- centered_column_scales(centered, sampling_weights) } - scales[scales == 0] <- 1 - sweep(sweep(m, 2, centers, "-"), 2, scales, "/") + constant <- column_is_constant(m) + centered[, constant] <- 0 + scales[constant | scales == 0] <- 1 + sweep(centered, 2, scales, "/") +} + +# Which columns hold one value repeated, read from the values rather than from +# the scale computed above. +# +# A column with no spread is supposed to come out of the centering as zeros and +# be left unscaled, and on the unweighted path with a well-behaved value it +# does. It need not. Both centers round: the weighted one divides a sum of +# products by a sum of weights, the unweighted one a sum by a count, and unless +# the repeated value survives that arithmetic exactly the centered column holds a +# rounding residual instead of a zero. The scale then reports the residual as the +# column's spread and the column standardizes to arbitrary order-one values: a +# constant 0.98 under non-uniform sampling weights comes out at 0.97 in every +# row. The reported balance for such a column is then a report on the rounding. +# +# The reading is exact equality rather than a floor on the computed scale, and +# that is the point. A floor has to be calibrated against a residual whose size +# depends on the column's magnitude, on the sample size, and on whether the +# platform's `long double` is wider than its `double`, and any floor wide enough +# to cover the residual at five thousand rows is wide enough to flatten a column +# offset far from its own spread, which is a column the corrected two-pass center +# above exists to standardize correctly. Equality needs no calibration and +# cannot reach a column that varies at all. +# +# The comparison is against the first row broadcast down the matrix, which reads +# every column in one vectorized pass. The covariate columns carry no missing +# values, which the fit validates before a constraint matrix is built, so the +# missing-value branch below governs only the direct callers. +# +# A column carrying one is read as not constant. The comparison answers a +# missing value with a missing value, and both consumers of this reading index +# with it: `standardize_columns()` writes `centered[, constant] <- 0` and +# `solver_box()` (R/method-entropy.R) writes `column_sd[...] <- 1`. A missing +# subscript makes each of those a silent no-op, so which columns the guards +# reached would depend on a value the guards say nothing about. Reading such a +# column as varying makes that explicit and leaves the standardization behaving +# as it did: the column keeps its computed center and scale, and the missing +# value carries through them into the standardized column. +# +# A matrix with no rows is answered before the comparison, which has no first +# row to read and would fail on the subscript with a base error. Nothing can be +# constant over no rows, so every column reads as varying, and both consumers +# then write into a zero-length selection and change nothing. +column_is_constant <- function(m) { + if (nrow(m) == 0L) { + return(stats::setNames(rep(FALSE, ncol(m)), colnames(m))) + } + differences <- colSums(m != rep(m[1L, ], each = nrow(m))) + !is.na(differences) & differences == 0L +} + +# Weighted mean of every column of a matrix, as one pass of column arithmetic. +column_weighted_means <- function(z, w) { + colSums(z * w) / sum(w) +} + +# Sampling-weighted standard deviation of every column of an already-centered +# matrix, with the reliability denominator `weighted_scale()` (R/utils.R) uses. +# The caller centers because both callers hold the centered matrix already: the +# standardization sweeps by the centers it just took, and the solver's tolerance +# box takes them for this alone. +# +# This is the same arithmetic in the same order as the per-column form, so it +# reproduces it bit for bit rather than approximating it. `colSums()` accumulates +# the way `sum()` does, and the products it accumulates are the same products. +# What it saves is the per-column dispatch: on a 20000 by 30 matrix it takes 5.0 +# milliseconds where `apply(z, 2, weighted_scale, w = )` takes 7.0. +centered_column_scales <- function(centered, w) { + total <- sum(w) + denominator <- total - sum(w * w) / total + variances <- if (denominator > 0) { + colSums(centered^2 * w) / denominator + } else { + rep(0, ncol(centered)) + } + sqrt(pmax(variances, 0)) } # Weighted mean of every column of `z` over the rows in `idx`. weighted_column_means <- function(z, idx, w) { - apply(z[idx, , drop = FALSE], 2, stats::weighted.mean, w = w[idx]) + column_weighted_means(z[idx, , drop = FALSE], w[idx]) } compute_balance_table <- function( @@ -63,22 +214,41 @@ compute_balance_table <- function( tolerance, reference = NULL, constraint_target = c("pooled", "arms"), - sampling_weights = NULL + sampling_weights = NULL, + matrix = NULL, + enforced_tolerance = NULL ) { if (is.null(reference)) { reference <- rep(1, length(weights)) } constraint_target <- match.arg(constraint_target) - matrix <- rebuild_constraint_matrix(recipe, data) + # A caller that already holds the constraint matrix passes it rather than + # letting the table rebuild one. Rebuilding costs about as much as the fit + # itself on a wide constraint set, and the recipe reproduces the matrix + # exactly, so the second build only repeats work. A caller holding nothing but + # the recipe, such as a diagnostic run against a stored result, leaves this + # NULL and gets the rebuild. + if (is.null(matrix)) { + matrix <- rebuild_constraint_matrix(recipe, data) + } z <- standardize_columns(matrix, sampling_weights) p <- ncol(z) terms <- vapply(recipe, function(term) term$term, character(1)) kinds <- vapply(recipe, function(term) term$kind, character(1)) - tolerances <- vapply( - recipe, - function(term) term$tolerance %||% tolerance, - numeric(1) - ) + # A method that holds its rows at a value of its own reports that value rather + # than the one requested. An energy fit that added no constraint rows is the + # case: it enforced nothing, so a table reading the requested band would judge + # the fit against a box no row of the program was ever given, and would print + # that band as the fit's tolerance. + tolerances <- if (is.null(enforced_tolerance)) { + vapply( + recipe, + function(term) term$tolerance %||% tolerance, + numeric(1) + ) + } else { + rep(enforced_tolerance, p) + } if (identical(exposure_type, "continuous")) { unweighted <- vapply( @@ -154,7 +324,7 @@ compute_balance_table <- function( constraint_residual <- if ( identical(estimand, "ate") && identical(constraint_target, "pooled") ) { - pooled_target <- apply(z, 2, stats::weighted.mean, w = reference) + pooled_target <- column_weighted_means(z, reference) per_arm <- lapply(names(groups), function(level) { abs(weighted_column_means(z, groups[[level]], weights) - pooled_target) }) diff --git a/R/balance.R b/R/balance.R index 45efff2..b867fa1 100644 --- a/R/balance.R +++ b/R/balance.R @@ -18,7 +18,7 @@ #' estimand vocabulary matches propensity: `"atc"` is accepted as a synonym for #' the untreated target and stored as `"atu"`. `"att"` and `"atc"` reweight #' toward a focal exposure level, inferred for a binary exposure and required -#' through `focal_level` for a categorical exposure. Continuous exposures permit +#' through `.focal_level` for a categorical exposure. Continuous exposures permit #' only `"ate"`. #' #' Constraints default to first-moment balance. Pass a [balance_terms()] @@ -33,6 +33,21 @@ #' `@covariates`, and `@balance_table` reports the surviving levels rather than #' the full set. #' +#' A fit can be interrupted between solver iterations, so a long solve stops at +#' the next iteration rather than at the end of the fit. On Unix the poll reads +#' R's interrupt flag directly and does not service R's event loop, so a +#' [setTimeLimit()] set around the call fires when the call returns rather than +#' partway through the solve. +#' +#' A `difftime` covariate balances as the number it stores, in the unit its own +#' column declares. Nothing rescales it and nothing reinterprets the unit, so its +#' constraints, its recipe, and its balance table match those of the same +#' durations supplied as bare numbers. A `Date` or `POSIXt` covariate balances +#' the same way, as the number `as.numeric()` gives it: days since 1970-01-01 for +#' a date, seconds since then for a date-time. Both date-time representations +#' are read that way, so a `POSIXlt` column balances exactly as the `POSIXct` +#' column holding the same instants does. +#' #' @param .data A data frame. #' @param .exposure The exposure column, selected with data-masking. Exactly one #' column. @@ -47,7 +62,7 @@ #' default. #' @param exposure_type One of `"auto"` (the default), `"binary"`, #' `"categorical"`, or `"continuous"`. -#' @param focal_level The focal exposure level for `"att"` and `"atc"`. Inferred +#' @param .focal_level The focal exposure level for `"att"` and `"atc"`. Inferred #' for a binary exposure; required for a categorical exposure. #' @param sampling_weights Sampling weights, given as a bare column name or an #' external numeric vector, or `NULL`. @@ -77,7 +92,7 @@ balance <- function( ..., constraints = NULL, exposure_type = c("auto", "binary", "categorical", "continuous"), - focal_level = NULL, + .focal_level = NULL, sampling_weights = NULL ) { the_call <- match.call() @@ -169,7 +184,7 @@ balance <- function( estimand, exposure_type, levels, - focal_level + .focal_level ) constraints <- constraints %||% default_constraints(method) @@ -182,6 +197,15 @@ balance <- function( # rescaled to the weighted scale in `solver_box()` regardless of the column # scale, so both are unaffected. Either way the balance table reports on the # weighted scale. + # + # The `NULL` this leaves for every other method is the value the constraint + # build was given rather than a stand-in for absent weights, which is why the + # prepared list carries it alongside the uniform fill-in the rest of a fit + # reads. Two fits need this one: the continuous energy and entropy marginals + # build columns of their own to the scale the constraint matrix is on, and no + # other fit reads it. Handing them the fill-in would put their columns on a + # different scale, since `stats::sd()` and `weighted_scale()` agree on a + # uniform vector only to rounding. constraint_sampling_weights <- if ( S7::S7_inherits(method, quadratic_program_method) ) { @@ -222,6 +246,10 @@ balance <- function( estimand = estimand, focal_level = focal_level, sampling_weights = sampling_weights_value %||% rep(1, n), + # The null-able sampling weights the constraint columns were built under, + # for the fits that build columns of their own to the same scale. The + # resolution above says why they cannot read the uniform fill-in instead. + constraint_sampling_weights = constraint_sampling_weights, n = n, constraints = constraints, tolerances = column_tolerances(built$recipe) @@ -270,7 +298,9 @@ balance <- function( tolerance = 0, reference = base_measure, constraint_target = fit$constraint_target %||% "pooled", - sampling_weights = sampling_weights_value + sampling_weights = sampling_weights_value, + matrix = built$matrix, + enforced_tolerance = fit$enforced_tolerance ) # A fit warns when a constraint sits outside its tolerance box, judged on the @@ -319,7 +349,10 @@ balance <- function( # measured. That case reports the assessment as the thing that failed, since no # tolerance the caller could raise would answer it. Requiring every exposure level # to carry base-measure mass removes the reachable cause, so this is the guard -# behind that rather than a case a fit reaches. +# behind that rather than a case a fit reaches. The imbalance prints to significant +# digits rather than to a fixed number of decimals because a tolerance can sit far +# below the fourth decimal, and a fixed-decimal format would then round the value +# that triggered the warning down to a zero that contradicts it. warn_balance_exceeded <- function(worst, call = rlang::caller_env()) { if (!is.finite(worst)) { warn( @@ -336,7 +369,7 @@ warn_balance_exceeded <- function(worst, call = rlang::caller_env()) { warn( c( "The achieved balance exceeds the requested tolerance.", - x = "The largest imbalance is {formatC(worst, format = 'f', digits = 4)}.", + x = "The largest imbalance is {formatC(worst, format = 'g', digits = 3)}.", i = "Raise {.arg tolerance} in {.fn balance_terms}, lower the moments, or drop interactions." ), warning_class = "balancing_balance_warning", @@ -345,6 +378,63 @@ warn_balance_exceeded <- function(worst, call = rlang::caller_env()) { invisible() } +# The tolerance a quadratic-program method asks of its backend. A method that +# leaves the property NULL takes the core default, which the solver applies as +# both its absolute and its relative tolerance. +qp_default_tolerance <- 1e-8 + +# A tolerance the quadratic programs reach on problems where the core default +# does not. The energy objective matrix is indefinite, and on a small sample the +# negative curvature it carries puts the alternating-direction residual floor +# above the core default, so a fit asking for more than the iteration can deliver +# spends its whole budget and returns an iterate that has left the optimum. This +# value is the one the sweeps in that regime reach, and it is what the +# non-convergence advice names. +qp_reachable_tolerance <- 1e-6 + +resolved_qp_tolerance <- function(method) { + tolerance <- method@convergence_tolerance + if (is.null(tolerance)) qp_default_tolerance else tolerance +} + +# The non-convergence advice for the quadratic-program family, which fails its +# criterion for a reason the estimating-equation family does not share. A descent +# method that spends its iteration cap stopped short of the answer and is helped +# by a larger cap; an alternating-direction iteration on an indefinite form that +# spends its cap has usually passed the residual floor of its problem, past which +# each further iteration moves away from the optimum rather than toward it. So +# the advice leads with the tolerance, names a value the problem can usually +# reach when the fit asked for something tighter, and keeps the cap for last. +# +# Only the indefinite forms carry that floor, so only they call the cap a last +# resort. A positive-semidefinite form keeps descending toward its tolerance for +# as long as the cap allows, and a run that spent the cap there really did stop +# short, so the cap is named as an ordinary lever. +# +# The weights caveat is about a solve that met no tolerance at all rather than +# about one that missed the tolerance asked for. An energy fit that could not +# reach its tolerance reports the iterate of a re-solve at a reachable one and +# still calls itself unconverged, and telling that caller the weights are +# worthless would contradict the advice above it. +quadratic_program_convergence_bullets <- function(method) { + loosen <- if (resolved_qp_tolerance(method) < qp_reachable_tolerance) { + "Loosen {.arg convergence_tolerance} in {.fn {class(method)[1]}}, which the problem can usually reach at {.val {qp_reachable_tolerance}}." + } else { + "Loosen {.arg convergence_tolerance} in {.fn {class(method)[1]}}." + } + cap <- if (has_indefinite_objective(method)) { + "Raising {.arg max_iterations} is the last resort, and helps only a solve that stopped short of the residual floor rather than past it." + } else { + "Raising {.arg max_iterations} is the other lever, since this objective descends toward its tolerance for as long as the cap allows." + } + c( + "The solver did not reach its convergence tolerance.", + i = loosen, + x = "The weights of a solve that met no tolerance at all should not be relied on.", + i = cap + ) +} + # Raise or warn on the solver outcome. The quadratic-program family reports a # terminal status the backend assigns, so an infeasible constraint set raises # `balancing_infeasible_error` and a hard solver failure raises @@ -357,9 +447,9 @@ warn_balance_exceeded <- function(worst, call = rlang::caller_env()) { # # Which knob a failure names is chosen by the status, so every status a backend # can assign is routed here. Only a status that genuinely means the solve ran out -# of iterations falls through to the closing warning, whose advice is to raise the -# cap; a solve that broke down numerically or stalled would not be helped by more -# iterations, so it reports the conditioning of the problem instead. +# of iterations falls through to the closing warning; a solve that broke down +# numerically or stalled would not be helped by either knob, so it reports the +# conditioning of the problem instead. check_solver_status <- function(fit, method, call = rlang::caller_env()) { if (!is.null(fit$status)) { if (isTRUE(fit$converged)) { @@ -414,10 +504,14 @@ check_solver_status <- function(fit, method, call = rlang::caller_env()) { } if (!isTRUE(fit$converged)) { tried <- solver_labels(fit$solvers_tried) - bullets <- c( - "The solver did not reach its convergence tolerance.", - i = "Increase {.arg max_iterations} or loosen {.arg convergence_tolerance} in {.fn {class(method)[1]}}." - ) + bullets <- if (S7::S7_inherits(method, quadratic_program_method)) { + quadratic_program_convergence_bullets(method) + } else { + c( + "The solver did not reach its convergence tolerance.", + i = "Increase {.arg max_iterations} or loosen {.arg convergence_tolerance} in {.fn {class(method)[1]}}." + ) + } if (length(tried) > 1L) { bullets[[1L]] <- "Neither solver reached its convergence tolerance." bullets <- append(bullets, c(x = "The fit tried {tried}."), after = 1L) @@ -506,6 +600,20 @@ method(tunes_weight_penalty, balance_method) <- function(method) { FALSE } +# Whether a method assembles an indefinite quadratic form, which decides whether +# the non-convergence advice may speak of a residual floor. Energy balancing and +# the characteristic function distance energy kernel build their objective from +# the negative pairwise distance, which is conditionally positive semidefinite +# alone and indefinite as a quadratic form; every other objective the package +# assembles is positive semidefinite. The distinction is a property of the +# objective rather than of the family, so it is dispatched on the method and the +# kernel rather than read off the quadratic-program parent. +has_indefinite_objective <- new_generic("has_indefinite_objective", "method") + +method(has_indefinite_objective, balance_method) <- function(method) { + FALSE +} + # The default constraint set for a method with no explicit constraints, dispatched # on the method so each family states its own default. The estimating-equation # family balances first moments, its identifying conditions; the objective-driven @@ -617,7 +725,7 @@ constrained_covariates <- function(recipe, covariates) { # Resolve the focal exposure level for att and atc. A binary exposure infers the # treated level (the second level) for att and the control level (the first) for -# atc; a categorical exposure requires an explicit focal_level. The average +# atc; a categorical exposure requires an explicit `.focal_level`. The average # treatment effect and the overlap estimand reweight every group rather than hold # one fixed, so they carry no focal level. resolve_focal_level <- function( @@ -637,7 +745,7 @@ resolve_focal_level <- function( if (!is.null(focal_level)) { warn( c( - "{.arg focal_level} applies to the {.val att} and {.val atc} estimands and is ignored.", + "{.arg .focal_level} applies to the {.val att} and {.val atc} estimands and is ignored.", i = "The {.val {estimand}} estimand reweights every exposure group rather than holding one fixed." ), warning_class = "balancing_ignored_argument_warning", @@ -659,7 +767,7 @@ resolve_focal_level <- function( if (is.null(focal_level)) { abort( c( - "{.arg focal_level} is required for the {.val {estimand}} estimand with a categorical exposure.", + "{.arg .focal_level} is required for the {.val {estimand}} estimand with a categorical exposure.", i = "Supply the exposure level to target, one of {.val {levels}}." ), error_class = "balancing_estimand_error", @@ -672,7 +780,7 @@ resolve_focal_level <- function( if (!resolved %in% levels) { abort( c( - "{.arg focal_level} must be an exposure level.", + "{.arg .focal_level} must be an exposure level.", x = "{.val {resolved}} is not one of {.val {levels}}." ), error_class = "balancing_estimand_error", diff --git a/R/balancing-package.R b/R/balancing-package.R index 0886bdd..db554e9 100644 --- a/R/balancing-package.R +++ b/R/balancing-package.R @@ -25,7 +25,9 @@ NULL #' - `balancing.threads`: the number of worker threads the Rust core may use. #' When unset, the count is resolved automatically from the physical core #' count, capped by `OMP_THREAD_LIMIT` and `OMP_NUM_THREADS`, and forced to two -#' under `R CMD check`. +#' under `R CMD check`. The count is decided in R and handed to the core, which +#' sizes its worker pool from it: `RAYON_NUM_THREADS` is never read, so setting +#' that environment variable changes nothing about how a fit runs. #' - `balancing.entropy_solver`: the solver for the exact entropy problem, one #' of `"newton"` (the default), `"lbfgs"`, or `"lbfgs_then_newton"`. Newton is #' the only solver that drives the estimating equations to machine precision; diff --git a/R/constraints.R b/R/constraints.R index 8d3dabd..e134712 100644 --- a/R/constraints.R +++ b/R/constraints.R @@ -44,10 +44,43 @@ new_recipe_record <- function( ) } +# One covariate column, as every part of the expansion reads it. A duration is a +# number in the unit its own column declares, and every statistic the expansion +# computes from a column, a moment, a quantile cutpoint, a standardization +# constant, is unit-agnostic, so such a column enters as that number and balances +# exactly as the same durations written as bare numbers would. Base R also +# refuses `^` on the class and answers `is.numeric()` with FALSE for it, so the +# power and quantile records could not be built from the column as it stands. +# +# A date and a date-time are the same case: each stores a number on a fixed +# origin, each refuses `^`, and neither answers `is.numeric()`. They enter as the +# number `as.numeric()` gives, which is days since 1970-01-01 for a date and +# seconds since then for a date-time, and nothing rescales or reinterprets it. +# What the coercion settles is only how the column is read; which branch of the +# expansion it then takes is decided from the numbers, exactly as it is for a +# duration and for a column of bare numbers. +# +# The date-time test is on `POSIXt`, the class both date-time representations +# share, rather than on `POSIXct` alone. A `POSIXlt` column holds the same +# instant split into calendar components and `as.numeric()` gives it the same +# seconds since 1970-01-01, so reading only the seconds-count representation +# left the other one to fall through as an ordinary column and meet base R's own +# error from raising a difftime to a power, which names neither the covariate +# nor the class that could not be read. +# +# A column of any other class passes through unchanged. +covariate_values <- function(data, name) { + column <- data[[name]] + if (inherits(column, c("difftime", "Date", "POSIXt"))) { + return(as.numeric(column)) + } + column +} + # Raw representation of one base column, used to form interactions and to rebuild # a column from the data. base_values <- function(source, level, data) { - column <- data[[source]] + column <- covariate_values(data, source) if (is.na(level)) { as.numeric(column) } else { @@ -60,7 +93,7 @@ rebuild_column <- function(record, data) { switch( record$type, numeric = { - x <- as.numeric(data[[record$source]]) + x <- as.numeric(covariate_values(data, record$source)) ((x - record$base_center)^record$power - record$center) / record$scale }, indicator = base_values(record$source, record$level, data), @@ -69,7 +102,9 @@ rebuild_column <- function(record, data) { right <- base_values(record$partner, record$partner_level, data) (left * right - record$center) / record$scale }, - quantile = as.numeric(as.numeric(data[[record$source]]) <= record$cutpoint) + quantile = as.numeric( + as.numeric(covariate_values(data, record$source)) <= record$cutpoint + ) ) } @@ -303,7 +338,7 @@ build_constraint_matrix <- function( interaction_bases <- list() for (cov in .covariates) { - v <- .data[[cov]] + v <- covariate_values(.data, cov) if (is.factor(v) || is.character(v)) { levels <- if (is.factor(v)) levels(v) else sort(unique(as.character(v))) for (level in levels) { @@ -498,7 +533,7 @@ interaction_term <- function(left, right) { quantile_records <- function(covariates, data, quantiles, tolerances) { records <- list() for (cov in covariates) { - v <- data[[cov]] + v <- covariate_values(data, cov) if (!is.numeric(v) || is_binary_numeric(v)) { next } @@ -567,12 +602,26 @@ constant_columns <- function(columns) { # augmented matrix, falls beyond the rank. The later member of an affine set is # therefore the one dropped, which for a factor is its last level, and the choice # is deterministic rather than a function of column ordering within the pivot. +# +# Rank is a tolerance question rather than an exact one, so the tolerance is +# named here rather than left to the default: a column whose residual, after the +# constant and the columns ahead of it are projected out, falls below `tol` times +# that column's own norm is moved beyond the rank and dropped as aliased. The +# default 1e-07 is the right order for this matrix because every column arrives +# at unit scale, the numeric and interaction columns standardized and the +# indicator and quantile columns zero or one, so the relative test reads against +# the same magnitude column by column. It sits far above the residual that +# rounding leaves on a set that is dependent in exact arithmetic and far below +# the residual a column that varies on its own keeps. A separate rank tolerance +# lives in `measure_jacobian_rank()` (R/ipw-deli.R), a relative singular-value +# cutoff on an estimating-equation Jacobian, and the two values are set +# independently on purpose because they read different matrices. aliased_columns <- function(columns) { if (ncol(columns) == 0L) { return(integer(0)) } augmented <- cbind(1, columns) - decomposition <- qr(augmented) + decomposition <- qr(augmented, tol = 1e-07) if (decomposition$rank == ncol(augmented)) { return(integer(0)) } diff --git a/R/ipw-deli.R b/R/ipw-deli.R index 3290e26..d5a84e4 100644 --- a/R/ipw-deli.R +++ b/R/ipw-deli.R @@ -7,6 +7,18 @@ # already found, and the closure only re-evaluates the estimating functions # around that point. # +# The one class of row that costs nothing to difference is not differenced. A +# contrast row is a deterministic function of parameters the stack already +# carries, so it is one constant repeated across the sample, and no row outside +# the deterministic block reads a parameter that block estimates. Perturbing one +# of those parameters therefore leaves every other row sum at the value the +# fitted parameters produced, and those coordinates are answered from the +# recorded sums rather than by assembling the stack again, which is what +# `make_stacked_system()` below arranges. The deterministic rows do read one +# another, so the whole block is recomputed at the perturbed vector. The numbers +# are the ones the fully differenced system reports, to the bit; what changes is +# how many times the outcome model is scored to reach them. +# # The stack is ordered [theta_w | beta | means | contrasts]. The weight # parameters come first because everything downstream depends on them and # nothing upstream does. The outcome-model coefficients follow, coupled to the @@ -258,7 +270,12 @@ ipw_deli_sandwich <- function( as.numeric(weight_parameters) ) - stacked_equations <- function(theta) { + # The blocks of the stacked estimating function at one parameter vector, + # returned unstacked. Two consumers read them, and only one of them wants a + # matrix: the engine's meat is built from the S-by-n stack, while its bread + # reads nothing but the row sums. Returning the blocks lets each take what it + # needs, which is what `make_stacked_system()` below arranges. + stacked_blocks <- function(theta) { beta <- theta[p + seq_len(q)] mean_theta <- theta[p + q + seq_len(m)] contrast_theta <- theta[p + q + m + seq_len(k)] @@ -292,37 +309,40 @@ ipw_deli_sandwich <- function( # rather than over every unit. A marginal model predicts one value per # exposure level, which makes the weighted row a constant multiple of the # unweighted one and leaves the sandwich exactly where it was. - mean_rows <- do.call( - rbind, - lapply(seq_len(m), function(j) tilt * (fixed[[j]] - mean_theta[[j]])) + # + # Each row is handed over on its own rather than stacked into a block + # first. The assembly writes each of them into the destination row it + # belongs in, so a block of them would be built only to be copied there. + mean_rows <- lapply( + seq_len(m), + function(j) tilt * (fixed[[j]] - mean_theta[[j]]) ) # The contrasts are deterministic functions of the means, so their rows are # the same value for every unit. They contribute nothing to the meat at the # solution, where that value is zero, and everything to the bread, which is - # what carries their standard errors without a delta method. - contrast_rows <- if (is.null(joint)) { - matrix( - ipw_contrast_values(mean_theta, continuous) - contrast_theta, - nrow = k, - ncol = n - ) - } else { - ipw_joint_rows(joint, mean_theta, contrast_theta, continuous, n) - } + # what carries their standard errors without a delta method. The values + # those rows repeat are named on their own because the summed system below + # reads them without assembling a stack, and the two readings of a contrast + # row have to be one reading. + # + # The rows are handed over as those values rather than as a block repeating + # each of them across the sample. The assembly writes a row from the value + # it repeats, so the wide block would exist only to be read once. + contrast_rows <- constant_psi_rows( + ipw_contrast_row_values(joint, mean_theta, contrast_theta, continuous) + ) by_rows <- ipw_by_rows( by_stack = by_stack, fixed = fixed, mean_theta = theta[p + q + m + k + seq_len(m_by)], contrast_theta = theta[p + q + m + k + m_by + seq_len(k_by)], - continuous = continuous, - n = n + continuous = continuous ) - rbind( - hooks$psi, - score, + c( + list(hooks$psi, score), mean_rows, contrast_rows, by_rows$mean, @@ -330,6 +350,41 @@ ipw_deli_sandwich <- function( ) } + # The value each deterministic row repeats across the sample, in stacked + # order: the whole-sample contrast block, whichever surface it is written + # under, then every stratum and stratum-against-stratum block a `.by` request + # appends. These are the rows the bread does not have to assemble a stack to + # difference, and `deterministic` holds the coordinates they sit at, which are + # the coordinates of the parameters they carry. + deterministic_values <- function(theta) { + c( + ipw_contrast_row_values( + joint, + theta[p + q + seq_len(m)], + theta[p + q + m + seq_len(k)], + continuous + ), + ipw_by_contrast_row_values( + by_stack = by_stack, + mean_theta = theta[p + q + m + k + seq_len(m_by)], + contrast_theta = theta[p + q + m + k + m_by + seq_len(k_by)], + continuous = continuous, + n_levels = m + ) + ) + } + deterministic <- c( + p + q + m + seq_len(k), + p + q + m + k + m_by + seq_len(k_by) + ) + stacked <- make_stacked_system( + stacked_blocks, + deterministic_values, + deterministic, + theta, + n + ) + validate_stacked_bread( container@jacobian, weights_at, @@ -340,10 +395,11 @@ ipw_deli_sandwich <- function( list( theta = theta, vcov = stacked_covariance( - stacked_equations, + stacked$psi, theta, n, container@jacobian, + summed = stacked$summed, call = call ) ) @@ -435,7 +491,7 @@ ipw_deli_msm_sandwich <- function( weights = hooks$weights * sampling, offset = offset ) - rbind(hooks$psi, score) + stack_psi_blocks(list(hooks$psi, score), n) } validate_stacked_bread( @@ -445,6 +501,11 @@ ipw_deli_msm_sandwich <- function( call = call ) + # The surface travels back with the variance system because naming the stacked + # parameters already required working it out. A caller reporting rows off this + # stack needs the same description, and deriving it a second time would let the + # names in `theta` and the rows read against them disagree about which columns + # carried the dose response. list( theta = theta, vcov = stacked_covariance( @@ -453,7 +514,8 @@ ipw_deli_msm_sandwich <- function( n, container@jacobian, call = call - ) + ), + surface = surface ) } @@ -511,6 +573,353 @@ make_hooks_cache <- function(container, rescale, parameters) { } } +# The stacked estimating function, assembled from its blocks into the S-by-n +# matrix the sandwich differentiates. +# +# `blocks` holds the stack in order. An entry is either a block that already +# exists as a matrix, which is what the container's estimating functions and the +# outcome model's score arrive as, or a single row: a vector carrying one value +# per observation, or the one value a deterministic row repeats across the whole +# sample. An entry may also be `NULL`, which is what a route carrying no block +# of that kind passes, and a matrix entry may have no rows, which is what a +# block the fit turned out to have nothing to put in comes back as. Both +# contribute nothing, exactly as they contribute nothing to `rbind()`. +# +# What this returns is what `rbind()` returns for the same entries, to the bit, +# values and dimnames alike, for any stack carrying at least one entry of the +# full width; `rbind()` reads the width off its arguments, and every stack the +# package builds opens with a block that gives it one. The only reason not to +# write `rbind()` is cost. `rbind()` has to work the result's type, shape, and +# row names out from the arguments it was handed before it can copy anything, +# and it pays that per argument; a caller that already knows the shape can +# allocate once and write each entry where it belongs. +# +# This runs once per sandwich, for the evaluation the meat is built from. The +# `2(S - k)` evaluations the bread differences never reach here, because the +# bread reads only row sums and `sum_psi_blocks()` below takes those from the +# same blocks without assembling anything. +# +# The entries are written in place for the memory rather than for the time. A +# caller that stacked its rows into a block of their own before handing that +# block over paid for those values twice, once where the block was built and +# once where it was copied into the destination, and a caller that hands its +# rows over unstacked allocates neither the block nor the copy. That is what the +# mean rows and the stratum mean rows do, and a deterministic block goes +# further: its rows repeat one value each, so passing the value writes the row +# without a destination-width vector existing anywhere. Measured while this ran +# on every evaluation of the sandwich, writing the rows in place removed 8 to 11 +# percent of everything an `ipw()` call at n = 20000 allocated on the widest +# surfaces. What it does for the time is inside the noise of the measurement, +# and it is not free: every assignment materializes a column index the length of +# the sample to stand in for the subscript it was not given, whether it writes +# one row or many. Writing that subscript out as `seq_len(n)` does not remove +# the index, and assigning through a single linear index computed by hand is far +# worse on both counts. +# +# All but one of those evaluations has since moved to `sum_psi_blocks()`, which +# reads the same unstacked entries and is where that reasoning now mostly pays. +# Handing the rows over unstacked is what lets it read them at all. +# +# The buffer is filled with `NA_real_` rather than zero. The two measure the +# same, since either way the allocation writes a value into every cell, so the +# choice falls to what an unwritten row should look like: an unwritten `NA` row +# reaches deli, which refuses a non-finite psi return with +# `deli_psi_return_error` before it forms either half of the sandwich, where a +# zero row would read as a coordinate the system does not depend on and quietly +# return a wrong variance. +stack_psi_blocks <- function(blocks, n) { + here <- rlang::current_env() + blocks <- blocks[!vapply(blocks, is.null, logical(1))] + rows <- vapply( + seq_along(blocks), + function(i) psi_block_rows(blocks[[i]], i, n, call = here), + integer(1) + ) + starts <- cumsum(rows) - rows + stacked <- matrix(NA_real_, nrow = sum(rows), ncol = n) + + for (i in seq_along(blocks)) { + if (rows[[i]] > 0L) { + stacked[starts[[i]] + seq_len(rows[[i]]), ] <- blocks[[i]] + } + } + + # `rbind()` leaves the result unnamed when no block that contributed a row + # carried a name, and otherwise names every row, padding the blocks that + # carried none with the empty string. A zero-row block never forces names, + # since it contributes no row to name, but it does still offer its column + # names, and the first block offering any is the one they come from. An entry + # that is a single row offers neither, which is `rbind()`'s reading of it too: + # a row is placed by position and named by nothing. + named <- vapply( + blocks, + function(block) !is.null(rownames(block)), + logical(1) + ) + if (any(named & rows > 0L)) { + row_names <- character(sum(rows)) + for (i in which(named & rows > 0L)) { + row_names[starts[[i]] + seq_len(rows[[i]])] <- rownames(blocks[[i]]) + } + rownames(stacked) <- row_names + } + for (block in blocks) { + if (!is.null(colnames(block))) { + colnames(stacked) <- colnames(block) + break + } + } + + stacked +} + +# The row sums of the stack the same entries assemble to, taken block by block +# so that the stack itself is never built. +# +# The bread reads nothing but these sums. The engine derives them from the +# estimating functions by summing the matrix it was handed, which means every +# differenced coordinate allocates an S-by-n destination whose only use is to be +# reduced to S numbers and dropped. Supplying the reduction instead removes that +# destination from all but the one evaluation the meat keeps, which is 2(S - k) +# of the 2(S - k) + 1 assemblies a sandwich performs. +# +# The earlier attempt at the same saving refilled one destination across +# evaluations rather than removing it, and saved nothing: the matrix reaches the +# engine as an argument, so it arrives at the next evaluation already shared and +# the first row written to it duplicates it. Reducing here is what makes that +# moot, because on this path the matrix never exists to be shared. +# +# What this is worth is allocation. Measured over three rounds of ten `ipw()` +# calls at n = 20000, the `.by` shape falls from 403.2 MB to 283.5 MB and the +# declared-crossing shape from 487.7 MB to 358.0 MB, the same figure to the byte +# in every round, and the collections a caller waits through fall by about a +# third. The destinations are more than their own size, because an assignment +# into a row of one also materializes a column index the length of the sample, +# and nothing here writes into a matrix. What it is worth for the time is not +# established: over those rounds neither shape's median separates from the +# assembling build's by more than the rounds differ among themselves. +# +# Each block's sum is taken by the same accumulation `rowSums()` would apply to +# the rows that block fills: `rowSums()` on a matrix entry, `sum()` on a row +# given as one value per observation, and `constant_row_sums()` on the rows a +# deterministic block repeats, all of which accumulate the same values in the +# same order in the same extended precision. So the reduction is the row sums of +# the assembled stack to the bit, which is the only footing on which the bread +# may take this route while the meat takes the other. +# +# The deterministic rows are summed together rather than one at a time because +# `constant_row_sums()` builds a matrix to accumulate over and one of those is +# cheaper than one per row. They need not be contiguous in the stack for that: +# the block they are gathered from is built here and read back by position. +sum_psi_blocks <- function(blocks, n) { + here <- rlang::current_env() + blocks <- blocks[!vapply(blocks, is.null, logical(1))] + rows <- vapply( + seq_along(blocks), + function(i) psi_block_rows(blocks[[i]], i, n, call = here), + integer(1) + ) + starts <- cumsum(rows) - rows + sums <- numeric(sum(rows)) + + constant <- vapply( + blocks, + function(block) !is.matrix(block) && length(block) == 1L, + logical(1) + ) + for (i in which(!constant & rows > 0L)) { + block <- blocks[[i]] + sums[starts[[i]] + seq_len(rows[[i]])] <- if (is.matrix(block)) { + rowSums(block) + } else { + sum(block) + } + } + if (any(constant)) { + sums[starts[constant] + 1L] <- constant_row_sums( + unlist(blocks[constant], use.names = FALSE), + n + ) + } + + sums +} + +# The number of rows an entry of the stack contributes, and the point at which +# that count is committed, so it is also where the entry's width is checked +# rather than trusted. The destination is allocated at the width the caller +# declares, and assigning into its rows recycles anything narrower instead of +# refusing it, so an entry of the wrong width would be spread over the rows it +# was meant to fill and the stack would carry values belonging to no unit. +# `rbind()` recycles the same way, so this is a guard the assembly adds rather +# than one it inherits. +# +# A matrix contributes its rows and has to be exactly `n` wide. Anything else is +# a single row, which is either one value per observation or the one value a +# deterministic row repeats. Those are the only two widths a row may have: a row +# of any other length is the mistake this refuses, and a row of length one is +# recycled deliberately. +# +# The refusal is worded from what the entry is. Only a matrix entry has columns; +# an entry given as a bare vector is one row, and what it carries is values, so +# saying it carries the wrong number of columns would send a reader looking for +# a dimension it does not have. +# +# The storage is checked here for the same reason the width is. The assembly and +# the reduction have to agree to the bit, and they only do while every entry +# holds doubles: `rowSums()` on the assembled stack returns a double whatever +# the block was, while the reduction takes a per-observation row with `sum()`, +# which returns an integer for an integer row and can overflow it to `NA`. No +# route builds a block of any other storage today, so this is an invariant of +# the assembly rather than a conversion it performs. +# +# `call` is the assembly the entries were handed to, passed in rather than read +# off the stack. These counts are taken inside a `vapply()` closure, so a +# refusal left to find its own caller would report that closure, which is not a +# call anyone wrote and not the one holding the block that is wrong. +psi_block_rows <- function(block, index, n, call = rlang::caller_env()) { + if (!is.double(block)) { + abort( + c( + "Every block of the stacked estimating function must hold doubles.", + x = "Block {index} holds {.cls {typeof(block)}} values." + ), + error_class = "balancing_internal_error", + call = call + ) + } + + if (is.matrix(block)) { + width <- ncol(block) + if (width == n) { + return(nrow(block)) + } + carries <- "carries {width} column{?s}" + } else { + width <- length(block) + if (width == n || width == 1L) { + return(1L) + } + carries <- "holds {width} value{?s}" + } + + abort( + c( + "Every block of the stacked estimating function must cover every observation.", + x = paste0("Block {index} ", carries, " for a sample of {n}.") + ), + error_class = "balancing_internal_error", + call = call + ) +} + +# The rows of a deterministic block, one entry per row holding the value that +# row repeats across the sample. The values arrive named, since they are read +# off the named parameter vector, and the names are dropped here: the assembly +# writes a row by position, and the block these rows replace carried no names +# either. +constant_psi_rows <- function(values) { + as.list(unname(values)) +} + +# The stacked estimating functions and the summed system its bread is +# differentiated from, built as a pair so the second never pays for what the +# first already knows. +# +# `deli::compute_sandwich()` builds the meat from one evaluation of the +# estimating functions and the bread from the row sums of the same system at two +# perturbed parameter vectors per coordinate. Left to itself it derives those +# row sums by evaluating the estimating functions again, and that is the only +# reason a deterministic row costs anything. Such a row is one constant repeated +# across the sample, and no row outside the deterministic block reads a +# parameter that block estimates, so perturbing one of those parameters leaves +# every non-deterministic row sum at the value the fitted parameters produced. +# What the perturbation does move is the deterministic block itself, whose rows +# read each other, so the whole of it is recomputed from the perturbed vector. +# +# So the summed system is supplied rather than derived. A perturbation that +# moves any parameter the rest of the stack reads is answered by building the +# blocks at that vector and reducing them where they are built, which is the +# same arithmetic on the same values the engine would have summed and therefore +# the same numbers to the last bit. A perturbation that moves only a +# deterministic parameter is answered from the recorded sums and +# `constant_row_sums()`, without building any block at all. The saving is two +# evaluations of the whole system per deterministic row, and each of those +# evaluations scores the outcome model and predicts every fixed-exposure design +# over the sample. +# +# Supplying it also decides which of the two systems allocates the S-by-n +# matrix. Only `psi_at()` assembles one, for the single evaluation the meat is +# built from and keeps; the bread's evaluations come through `summed_at()`, +# which returns S numbers and lets the blocks they were reduced from go. That +# takes 2(S - k) destinations out of every call, and it is the reason the +# estimating functions are built as a list of blocks rather than as a matrix. +# +# `index` names the deterministic rows, which are also the coordinates of the +# parameters they carry. No row outside that block reads one of those +# parameters, which is what lets the recorded sums of the rest of the system +# stand through a deterministic perturbation. Inside the block the rows do read +# each other: a stratum-against-stratum row differences two stratum contrast +# parameters (`ipw_by_contrast_row_values()`), and the interaction rows of a +# declared crossing difference two simple-effect parameters +# (`ipw_joint_interaction_values()`). `summed_at()` therefore recomputes every +# deterministic row from the perturbed vector rather than only the row whose +# parameter moved, and narrowing it to that row would zero the bread entries the +# others carry. +make_stacked_system <- function( + stacked_blocks, + deterministic_values, + index, + parameters, + n +) { + moving <- setdiff(seq_along(parameters), index) + anchor <- as.numeric(parameters)[moving] + anchor_sums <- NULL + + psi_at <- function(theta) { + psi <- stack_psi_blocks(stacked_blocks(theta), n) + if (is.null(anchor_sums) && identical(as.numeric(theta)[moving], anchor)) { + anchor_sums <<- unname(rowSums(psi)) + } + psi + } + + summed_at <- function(theta) { + at_anchor <- identical(as.numeric(theta)[moving], anchor) + if (!is.null(anchor_sums) && at_anchor) { + sums <- anchor_sums + sums[index] <- constant_row_sums(deterministic_values(theta), n) + return(sums) + } + + sums <- sum_psi_blocks(stacked_blocks(theta), n) + if (at_anchor) { + anchor_sums <<- sums + } + sums + } + + list(psi = psi_at, summed = summed_at) +} + +# The row sums of a block whose every row is one value repeated across the +# sample. +# +# `rowSums()` accumulates each row over the columns on its own, so a constant +# row's sum is a function of that value and the sample size and of nothing else +# in the matrix it was read from. Building the block here therefore reaches the +# same double the assembled stack would have, which is what lets the bread take +# this route for the rows that need it and the estimating functions for the rest +# without the two disagreeing. +# +# The sum is not the value times the sample size. Adding n copies of a double +# rounds at every step, and on the values these rows carry the two answers part +# company well above the last bit, by up to 7e-7 on the package's own fixtures. +constant_row_sums <- function(values, n) { + rowSums(matrix(values, nrow = length(values), ncol = n)) +} + # The empirical sandwich covariance of a stacked system at its root, named by # stacked block. # @@ -546,11 +955,26 @@ make_hooks_cache <- function(container, rescale, parameters) { # condition, which would otherwise surface much later as a complaint about # dimnames applied to a non-array. Name the real cause here instead, at the point # where it is still legible. + +# A stack that is not finite at the fitted parameters is refused by the engine +# before it differences anything, under a class of its own. Nothing about that +# refusal is the caller's to read: it is written about `stacked_equations`, an +# argument they never passed, in a frame they never wrote. So it is translated +# too, into the same class and the same shape as the bread refusal, with deli's +# condition chained underneath. The aliased-coefficient preflight closes the one +# route known to reach it; the translation is what covers the rest. +# +# `summed` is the same system reduced over the observations, which the engine +# differentiates in place of deriving the reduction from the estimating +# functions. A route carrying deterministic rows supplies one so those rows are +# never assembled; a route carrying none passes nothing and the engine derives +# the reduction as it always did. stacked_covariance <- function( stacked_equations, theta, n, jacobian, + summed = NULL, call = rlang::caller_env() ) { covariance <- rlang::try_fetch( @@ -559,7 +983,8 @@ stacked_covariance <- function( theta, deriv_method = "capprox", dx = 1e-6, - allow_pinv = FALSE + allow_pinv = FALSE, + summed_equations = summed ) / n, deli_bread_not_invertible = function(cnd) { @@ -587,6 +1012,19 @@ stacked_covariance <- function( call = call, .envir = environment() ) + }, + deli_psi_return_error = function(cnd) { + abort( + c( + "The stacked variance could not be computed for this outcome model.", + x = "The stacked estimating functions are not finite at the fitted parameters.", + i = "The stack carries the balancing fit's estimating equations alongside the outcome model's score, so a non-finite weight, or an outcome the model cannot score at those weights, reaches it as one of these values.", + i = "See the inference vignette for a bootstrap workflow." + ), + error_class = "balancing_ipw_unsupported_error", + call = call, + parent = cnd + ) } ) @@ -709,7 +1147,10 @@ msm_effect_name <- function( # produces and far above the rounding a deficient one leaves. Both readers of a # deficiency, the check made before the stack is differenced and the refusal # raised when the engine cannot invert it, measure it here so the two never -# disagree about whether a given fit is deficient. +# disagree about whether a given fit is deficient. A separate rank tolerance +# lives in `aliased_columns()` (R/constraints.R), a column-norm-relative cutoff +# on the constraint matrix, and the two values are set independently on purpose +# because they read different matrices. measure_jacobian_rank <- function(jacobian) { decomposition <- svd(jacobian) deficient <- decomposition$d <= decomposition$d[[1]] * 1e-8 @@ -729,9 +1170,11 @@ measure_jacobian_rank <- function(jacobian) { # Jacobian is. The converse needs the stack's other diagonal blocks to be # nonsingular, which holds for a converged glm with estimable coefficients and, # on the discrete path, for the mean and contrast blocks, whose diagonals are -# minus the standardization total and minus one. -# Asking the finite difference to report that is asking too much of -# it. A deficiency that is a second-order cancellation comes back as a pivot of +# minus the standardization total and minus one. With those blocks nonsingular a +# singular stack means a singular weight block and nothing else, so the +# deficiency this check has to detect is exactly the one the fit's own Jacobian +# carries. Asking the finite difference to report that is asking too much of it. +# A deficiency that is a second-order cancellation comes back as a pivot of # rounding size rather than as a zero, and `solve()` accepts it, so # `allow_pinv = FALSE` refuses only the deficiencies that survive to the last bit # and answers the rest with standard errors resting on rounding error. The check @@ -841,6 +1284,27 @@ ipw_contrast_values <- function(means, continuous, collapsible_only = FALSE) { unlist(values, use.names = FALSE) } +# The value each whole-sample contrast row repeats across the sample, which is +# the contrast the mean parameters imply less the parameter the row estimates. +# A declared crossing writes the same block over the same means in the two +# treatments, so which surface is in play decides the arithmetic and nothing +# else about the row. +# +# The stacked psi matrix and the summed system both read a contrast row from +# here, so a row and its reduction are one expression rather than two that have +# to agree. +ipw_contrast_row_values <- function( + joint, + mean_theta, + contrast_theta, + continuous +) { + if (is.null(joint)) { + return(ipw_contrast_values(mean_theta, continuous) - contrast_theta) + } + ipw_joint_row_values(joint, mean_theta, contrast_theta, continuous) +} + ipw_contrast_names <- function( continuous, levels = NULL, @@ -926,7 +1390,10 @@ ipw_by_stack <- function(by, pieces, tilt, continuous, levels, categorical) { ) } -# The stratum blocks of one evaluation of the stacked estimating functions. +# The stratum rows of one evaluation of the stacked estimating functions, in the +# two groups the stack carries them as: the mean rows one vector each, and the +# contrast rows the single value each of them repeats. The assembly writes both +# straight into the stack, so neither group is built as a block of its own here. # # The mean rows are the whole-sample mean rows restricted to a stratum: the root # of the row weighted by that stratum's tilt is the tilt-weighted mean of the @@ -945,24 +1412,54 @@ ipw_by_rows <- function( fixed, mean_theta, contrast_theta, - continuous, - n + continuous ) { if (is.null(by_stack)) { return(list(mean = NULL, contrast = NULL)) } n_levels <- length(fixed) - per_stratum <- by_stack$per_stratum - mean_rows <- do.call( - rbind, - lapply(seq_along(mean_theta), function(row) { - stratum <- (row - 1L) %/% n_levels + 1L - level <- (row - 1L) %% n_levels + 1L - by_stack$tilts[[stratum]] * (fixed[[level]] - mean_theta[[row]]) - }) + mean_rows <- lapply(seq_along(mean_theta), function(row) { + stratum <- (row - 1L) %/% n_levels + 1L + level <- (row - 1L) %% n_levels + 1L + by_stack$tilts[[stratum]] * (fixed[[level]] - mean_theta[[row]]) + }) + + list( + mean = mean_rows, + contrast = constant_psi_rows( + ipw_by_contrast_row_values( + by_stack = by_stack, + mean_theta = mean_theta, + contrast_theta = contrast_theta, + continuous = continuous, + n_levels = n_levels + ) + ) ) +} + +# The value each stratum contrast row repeats across the sample: a stratum's own +# contrasts less the parameters estimating them, then the stratum-against- +# stratum rows, which difference two stratum contrast parameters rather than +# recomputing anything from the means and so carry an exact derivative. +# +# `NULL` when no `.by` request was made, which is what the two callers pass on +# as a block that contributes nothing. Both the stacked psi matrix and the +# summed system read these rows from here, on the same footing as the +# whole-sample block. +ipw_by_contrast_row_values <- function( + by_stack, + mean_theta, + contrast_theta, + continuous, + n_levels +) { + if (is.null(by_stack)) { + return(NULL) + } + per_stratum <- by_stack$per_stratum stratum_values <- unlist( lapply(seq_len(by_stack$strata), function(s) { ipw_contrast_values( @@ -981,14 +1478,7 @@ ipw_by_rows <- function( use.names = FALSE ) - list( - mean = mean_rows, - contrast = matrix( - c(stratum_values, em_values) - contrast_theta, - nrow = length(contrast_theta), - ncol = n - ) - ) + c(stratum_values, em_values) - contrast_theta } # The names of the marginal-mean block. A categorical exposure names each mean diff --git a/R/ipw-joint.R b/R/ipw-joint.R index 373e4f4..efcfba3 100644 --- a/R/ipw-joint.R +++ b/R/ipw-joint.R @@ -184,25 +184,29 @@ ipw_joint_values <- function(joint, means, continuous) { c(simple, ipw_joint_interaction_values(joint, simple)) } -# The joint contrast rows of one evaluation of the stacked estimating functions. -# They are deterministic functions of the means and of each other, so each row -# is the same value for every unit: nothing at the solution, where that value is -# zero, and everything to the bread, which is what carries their standard errors -# without a delta method. +# The value each joint contrast row repeats across the sample, which is the +# whole of what the row is. The rows are deterministic functions of the means +# and of each other, so each is the same value for every unit: nothing to the +# meat at the solution, where that value is zero, and everything to the bread, +# which is what carries their standard errors without a delta method. The +# stacked psi matrix and the summed system the bread is differentiated from both +# read the value from here, so a row and its reduction over the sample cannot +# describe different contrasts. # # The simple effects are read off the mean parameters and the interactions off # the simple-effect parameters rather than off the means again. That is what # makes an interaction row the difference of two parameters the system already # carries: its derivative is exact, and the row equals the double difference by # construction rather than to within the accuracy of a finite difference. -ipw_joint_rows <- function(joint, mean_theta, contrast_theta, continuous, n) { +ipw_joint_row_values <- function( + joint, + mean_theta, + contrast_theta, + continuous +) { simple <- ipw_joint_simple_values(joint, mean_theta, continuous) - matrix( - c(simple, ipw_joint_interaction_values(joint, contrast_theta)) - - contrast_theta, - nrow = length(contrast_theta), - ncol = n - ) + c(simple, ipw_joint_interaction_values(joint, contrast_theta)) - + contrast_theta } # The identity columns of the rows a declared crossing reports, and the stacked diff --git a/R/ipw.R b/R/ipw.R index d2124b2..e1c0dd2 100644 --- a/R/ipw.R +++ b/R/ipw.R @@ -867,8 +867,10 @@ method(causalgenerics_ipw, balancing) <- function( # One description of the reported surface serves both the reading the # result declares and the rows it stores, so the branch below and the # estimates table cannot disagree about how many columns the exposure - # entered through. - identity <- msm_coefficient_identity(outcome_mod, exposure_name) + # entered through. It is the same description the sandwich named the stacked + # parameters from, taken from what that call returned rather than worked out + # again, which extends the agreement to those names. + identity <- variance_system$surface # An exposure entering through several columns leaves the marginal reading # without a surface: a curve has a different slope at every dose, so no @@ -1030,7 +1032,11 @@ method(causalgenerics_ipw, balancing) <- function( ), estimates = estimates, se_method = "mestimation", - fit = variance_system, + # The surface a continuous stack also returns was consumed above, in naming + # the rows this result reports, and is no part of the fitted variance system + # a caller reads off `fit`, so only the two elements every route produces + # are stored. + fit = variance_system[c("theta", "vcov")], effects = effects, readings = readings ) @@ -1404,6 +1410,9 @@ validate_ipw_outcome_model <- function( # An offset carrying the exposure spoils both exposure types, so the check runs # before the branch rather than inside it. validate_ipw_exposure_offset(outcome_mod, exposure_name, call = call) + # An aliased coefficient spoils both exposure types as well, since the stack + # reads the whole coefficient vector back whichever route builds it. + validate_ipw_outcome_coefficients(outcome_mod, call = call) if (continuous_exposure) { validate_ipw_exposure_terms(outcome_mod, exposure_name, call = call) # The link names the reported effect, so a link no effect name describes is @@ -1630,6 +1639,38 @@ validate_ipw_exposure_offset <- function( ) } +# A design matrix whose columns are linearly dependent leaves the fit with a +# missing coefficient for every column the pivoting dropped, and the fit itself +# reports those coefficients rather than refusing: the columns it kept are +# estimable and their predictions are unaffected. The stack has no such +# latitude. It reads the whole coefficient vector back as the outcome block's +# starting parameters, so a missing entry enters as a non-finite theta, every +# stacked estimating function it touches comes back non-finite, and the variance +# engine refuses the system under a class of its own from a frame the caller +# never wrote. That refusal names neither the outcome model nor the column that +# caused it, and the caller can only see the model they passed, so the aliasing +# is read off the coefficients here and the redundant columns are named. +validate_ipw_outcome_coefficients <- function( + outcome_mod, + call = rlang::caller_env() +) { + coefficients <- stats::coef(outcome_mod) + if (!anyNA(coefficients)) { + return(invisible(NULL)) + } + aliased <- names(coefficients)[is.na(coefficients)] + abort( + c( + "{.arg outcome_mod} must have an estimate for every coefficient.", + x = "{cli::qty(aliased)}It is rank deficient, so the coefficient{?s} {.val {aliased}} {?is/are} not estimable.", + i = "{cli::qty(aliased)}Drop the aliased term{?s} from {.arg outcome_mod} and fit it again before calling {.fun ipw}." + ), + error_class = "balancing_ipw_input_error", + call = call, + .envir = environment() + ) +} + # The stacked variance differentiates the outcome-model score through the # weights the fit produced, so it describes the system that was actually solved # only when the outcome model was fitted at those weights. Fitted at any other diff --git a/R/method-cbps.R b/R/method-cbps.R index f7ed7fc..2009988 100644 --- a/R/method-cbps.R +++ b/R/method-cbps.R @@ -82,9 +82,10 @@ #' `"cloglog"`. Binary and categorical exposures both fit a propensity model #' and consume it. A continuous exposure fits none, so the setting is ignored, #' with a warning, there. -#' @param convergence_tolerance The solver convergence tolerance. -#' @param max_iterations The maximum solver iterations, or `NULL` for the core -#' default. +#' @param convergence_tolerance The solver convergence tolerance. `1e-10` is +#' both this argument's default and the value the solver resolves for `NULL`. +#' @param max_iterations The maximum solver iterations, or `NULL` for the +#' resolved default of 1000. #' @param ... Reserved for future extensions; must be empty. Tuning parameters #' must be passed by name. #' diff --git a/R/method-cfd.R b/R/method-cfd.R index 654f023..19671d7 100644 --- a/R/method-cfd.R +++ b/R/method-cfd.R @@ -113,10 +113,15 @@ snap_smoothness <- function(smoothness) { #' @param weight_penalty The L2 penalty on the weights, which stabilizes the #' quadratic program. #' @param min_weight The smallest permitted weight. -#' @param convergence_tolerance The quadratic-program solver tolerance, or `NULL` -#' for the core default. -#' @param max_iterations The maximum solver iterations, or `NULL` for the core -#' default. +#' @param convergence_tolerance The quadratic-program solver tolerance, or +#' `NULL` for the resolved default of `1e-8`, which the solver applies as both +#' its absolute and its relative tolerance. Under the alternating-direction +#' backend, which the other kernels take by default and which the `"energy"` +#' kernel always takes because its quadratic form is indefinite, a tolerance +#' below what the problem can reach spends the full iteration cap and then +#' warns. +#' @param max_iterations The maximum solver iterations, or `NULL` for the +#' resolved default of 200000. #' @param ... Reserved for future extensions; must be empty. Tuning parameters #' must be passed by name. #' @@ -288,6 +293,12 @@ method(tunes_weight_penalty, bw_cfd) <- function(method) { TRUE } +# Only the energy kernel assembles an indefinite quadratic form here; the +# distance-based and spectral kernels are positive semidefinite. +method(has_indefinite_objective, bw_cfd) <- function(method) { + identical(method@kernel, "energy") +} + # Assemble the Rust option list. The worker-thread count and the quadratic-program # backend are resolved on the R side and passed on every call; tuning parameters # left at the core default are dropped so the solver applies its own. @@ -461,7 +472,14 @@ method(fit_method, bw_cfd) <- function(method, prepared) { } duals <- energy_duals_frame(result$duals, nvar, n_group_rows) - assemble_cfd(result, method, prepared, duals, approximate = !enforce) + assemble_cfd( + result, + method, + prepared, + duals, + approximate = !enforce, + enforced_tolerance = if (enforce) NULL else 0 + ) } # Renormalize each exposure group to its estimand target total, map the solver @@ -478,7 +496,14 @@ method(fit_method, bw_cfd) <- function(method, prepared) { # balance when no moment constraints are enforced, so the fit is flagged # approximate in that case and the balance warning does not fire against a # tolerance the fit does not target. -assemble_cfd <- function(result, method, prepared, duals, approximate) { +assemble_cfd <- function( + result, + method, + prepared, + duals, + approximate, + enforced_tolerance = NULL +) { s <- prepared$sampling_weights estimand <- prepared$estimand focal <- prepared$focal_level @@ -523,6 +548,15 @@ assemble_cfd <- function(result, method, prepared, duals, approximate) { status = result$status, estimating_equations = NULL, approximate = approximate, + # The tolerance the fit held its rows at, where that is the method's own + # value rather than the one the specification asked for, so the balance + # table reports what the program enforced. A fit that added no constraint + # rows is the case: a tolerance reached no row of the program, so what it + # enforced is zero, and reporting the requested band instead would print a + # box nothing was placed in. A fit that did add rows holds them inside the + # requested band, so it leaves this `NULL` and the table reads the + # per-column tolerances the specification named. + enforced_tolerance = enforced_tolerance, groups = groups ) } diff --git a/R/method-energy.R b/R/method-energy.R index 9dcc257..188cf4c 100644 --- a/R/method-energy.R +++ b/R/method-energy.R @@ -35,19 +35,54 @@ #' `dimension_adjustment` reweights the covariate energy distance by the #' covariate dimensionality. #' +#' The two knobs a continuous fit carries are separate. `moments` in +#' [balance_terms()] adds a constraint that holds the weighted correlation of +#' the exposure with each covariate power within its tolerance, which defaults +#' to zero, and `distribution_moments` pins the marginal moments of the +#' exposure and of the covariates. Neither sets the other: a fit that wants +#' both asks for both. The correlation rows are held within the tolerance +#' [balance_terms()] carries, and reaching that band takes more than one solve. +#' The quadratic program bounds a linearized correlation whose exposure and +#' covariate scales are fixed at the sample, and the spread of energy weights +#' shrinks both weighted standard deviations, so a single solve at the requested +#' band overshoots it: a band of `0.05` lands between 0.070 and 0.086 at 200 to +#' 1000 observations. The fit therefore tightens the bound it hands the program +#' and re-solves, up to eight passes, until the reported correlation sits inside +#' the band. A band of `0.05` took two passes at 350 and at 1000 observations, so +#' it costs about two solves against the one the same fit at exact balance takes, +#' exact balance having nothing to tighten. A band the passes cannot reach is +#' reported at its last iterate, and the balance warning judges it as it judges +#' any other fit. +#' +#' Without those rows the continuous objective targets distributional +#' independence between the exposure and the covariates rather than zero +#' correlations, and it does not drive the correlations to zero. A residual +#' weighted correlation of roughly 0.1 to 0.3 is ordinary at a few hundred to a +#' few thousand observations. What holds it up is `weight_penalty`, which trades that +#' residual against effective sample size: at its default of `1e-4` the penalty +#' term is about three quarters of the objective at 1000 observations, leaving a +#' largest correlation near 0.22 to 0.25 at an effective sample size near 71 +#' percent, while a penalty of zero brings the correlation down to 0.05 to 0.07 +#' and the effective sample size down to about 20 percent. Ask for +#' `balance_terms(moments = 1)` to remove the correlation outright, at a cost in +#' effective sample size of its own. +#' #' Energy balancing belongs to the quadratic-program family, which has no #' estimating equations, so a fit produces no estimating-equations container and -#' the tolerance in [balance_terms()] relaxes any added moment constraints rather -#' than selecting an inexact solver. A tolerance supplied without moment -#' constraints has nothing to relax, so it is warned and ignored. +#' the tolerance in [balance_terms()] relaxes the constraints a fit added rather +#' than selecting an inexact solver. A tolerance supplied without those +#' constraints has nothing to relax, so it is warned and ignored, and the balance +#' table reports the tolerance the fit enforced, which is zero. #' #' @param distance The covariate distance definition the energy objective is -#' built on, one of `"scaled_euclidean"` (each covariate divided by its -#' standard deviation), `"mahalanobis"`, or `"euclidean"`. +#' built on, one of `"scaled_euclidean"` (each covariate centered at its +#' weighted mean and divided by its weighted standard deviation), +#' `"mahalanobis"`, or `"euclidean"`. #' @param improved Whether to add the between-group energy distance of the #' improved variant for the average treatment effect with a discrete exposure. #' @param weight_penalty The L2 penalty on the weights, which stabilizes the -#' quadratic program. +#' quadratic program. For a continuous exposure it is also what sets the +#' residual exposure-covariate correlation, as the details section explains. #' @param min_weight The smallest permitted weight. The reported weights average #' one within each exposure group, so a floor approaching one leaves almost no #' room above it: the weight spread shrinks in proportion to the headroom @@ -58,16 +93,32 @@ #' refuses the same floor as infeasible instead. #' @param distribution_moments For a continuous exposure, the number of exposure #' and covariate marginal moments held equal to the sample under the base -#' measure, or `NULL` for the constraint moments. Raised automatically when -#' smaller than the constraint moments. Energy balancing carries no base -#' weights, so the base measure is the sampling weights, and without them the -#' marginals are held equal to the unweighted sample. +#' measure, or `NULL` for the first moments. This is the only route to those +#' rows: the `moments` in [balance_terms()] asks for exposure-covariate +#' correlation constraints instead and leaves the marginals here. Energy balancing carries no base weights, so the base +#' measure is the sampling weights, and without them the marginals are held +#' equal to the unweighted sample. #' @param dimension_adjustment For a continuous exposure, whether to weight the #' covariate energy distance by the covariate dimensionality adjustment. -#' @param convergence_tolerance The quadratic-program solver tolerance, or `NULL` -#' for the core default. -#' @param max_iterations The maximum solver iterations, or `NULL` for the core -#' default. +#' @param convergence_tolerance The quadratic-program solver tolerance, which +#' the solver applies as both its absolute and its relative tolerance, or +#' `NULL` for the family default of `1e-8`. Energy balancing defaults to +#' `1e-6` rather than to that family default because its quadratic form is +#' indefinite: on a small sample the alternating-direction residual floors +#' above `1e-8`, and a run that keeps going past that floor walks away from +#' the optimum instead of stalling at it. The energy objective always solves +#' through the alternating-direction backend, whatever `balancing.qp_backend` +#' names, so there is no backend to choose here: a tolerance below what the +#' problem can reach spends the full iteration cap, then warns and reports the +#' iterate of a re-solve at a tolerance the problem does reach, provided that +#' re-solve converges within the same `max_iterations`. When it does not, the +#' fit reports the iterate of the original solve. +#' @param max_iterations The maximum solver iterations, or `NULL` for the +#' resolved default of 200000. The re-solve above is given the same cap, and +#' when it converges the reported `@iterations` sums the two solves, so an +#' energy fit that could not reach its tolerance can report more iterations +#' than this. The refinement passes of a continuous fit with a positive +#' tolerance are summed the same way, each pass being a solve of its own. #' @param ... Reserved for future extensions; must be empty. Tuning parameters #' must be passed by name. #' @@ -111,7 +162,7 @@ bw_energy <- new_class( min_weight = 1e-8, distribution_moments = NULL, dimension_adjustment = TRUE, - convergence_tolerance = NULL, + convergence_tolerance = 1e-6, max_iterations = NULL ) { check_method_dots(...) @@ -213,6 +264,12 @@ method(tunes_weight_penalty, bw_energy) <- function(method) { TRUE } +# The energy objective is built from the negative pairwise distance, so its +# quadratic form is indefinite. +method(has_indefinite_objective, bw_energy) <- function(method) { + TRUE +} + # Assemble the Rust option list, dropping the tuning parameters left at the core # default so the quadratic-program solver applies its own. The worker-thread # count and the quadratic-program backend are resolved on the R side and passed @@ -228,6 +285,38 @@ energy_options <- function(method, backend) { options } +# Solve, and on a run that spent its iteration cap solve once more at a +# tolerance the objective can reach. The energy quadratic form is indefinite, so +# the alternating-direction iteration is a contraction only until its residuals +# reach the floor of the problem; a tolerance below that floor keeps the run +# going, and the iterate it carries at the cap has left the optimum rather than +# stopped short of it. Renormalizing that iterate per group gives it the shape of +# a real answer, so it must not be what the fit reports. The retry costs one +# extra solve, and only on a fit that already failed. The fit still reports +# itself as unconverged, because the tolerance the caller asked for was not met, +# and the convergence warning that follows names the tolerance to ask for +# instead. A run that ends on any other terminal status is diagnosed by +# check_solver_status() and is not retried, and neither is a fit whose tolerance +# is already at or above the reachable one, where the retry would repeat the +# solve that just failed. +solve_energy_with_fallback <- function(method, options, solve) { + result <- solve(options) + reached_cap <- !isTRUE(result$converged) && + identical(result$status, "max_iter") + if (!reached_cap || resolved_qp_tolerance(method) >= qp_reachable_tolerance) { + return(result) + } + options$convergence_tolerance <- qp_reachable_tolerance + retry <- solve(options) + if (!isTRUE(retry$converged)) { + return(result) + } + retry$converged <- FALSE + retry$status <- result$status + retry$iterations <- result$iterations + retry$iterations + retry +} + # Whether the constraint set requests moment, quantile, or interaction balance, # which energy balancing enforces as quadratic-program moment rows. For the # quadratic-program family a bare tolerance requests no constraints of its own, @@ -251,9 +340,13 @@ has_positive_tolerance <- function(constraints) { # indicator column per level, since each level is a coordinate of the covariate # distance. The Rust core forms the pairwise distance from these columns under # the named distance definition. +# +# The column is read through the same accessor the constraint builder uses, so a +# duration reaches the distance as the number it stores rather than falling to +# the categorical branch and becoming one indicator per distinct duration. distance_covariates <- function(data, covariates) { columns <- lapply(covariates, function(covariate) { - values <- data[[covariate]] + values <- covariate_values(data, covariate) if (is.numeric(values) || is.logical(values)) { matrix(as.numeric(values), ncol = 1) } else { @@ -269,16 +362,17 @@ distance_covariates <- function(data, covariates) { do.call(cbind, columns) } -# The tolerance in a balance_terms() specification relaxes added moment -# constraints; with none present it has nothing to act on, so warn and proceed -# with the pure energy objective. A continuous fit holds its distribution moments -# exactly as identifying conditions and never adds relaxable constraints, so any -# positive tolerance is ignored there as well. +# The tolerance in a balance_terms() specification relaxes added constraints; +# with none present it has nothing to act on, so warn and proceed with the pure +# objective. Both `moments` and `interactions` add constraints for either +# exposure type: moment rows for a discrete exposure, exposure-covariate +# correlation rows on the continuous energy path. Only `quantiles` is confined to +# a discrete exposure, so it is the only one the advice qualifies. warn_ignored_tolerance <- function(call = rlang::caller_env()) { warn( c( - "{.arg tolerance} relaxes added moment constraints, but this fit has none to relax.", - i = "Drop {.arg tolerance} from {.fn balance_terms}, or add moment constraints with {.arg moments}, {.arg quantiles}, or {.arg interactions} for a discrete exposure." + "{.arg tolerance} relaxes added constraints, but this fit has none to relax.", + i = "Drop {.arg tolerance} from {.fn balance_terms}, or add constraints with {.arg moments} or {.arg interactions}, or with {.arg quantiles} for a discrete exposure." ), warning_class = "balancing_ignored_argument_warning", call = call @@ -316,18 +410,16 @@ resolve_energy_backend <- function(call = rlang::caller_env()) { method(fit_method, bw_energy) <- function(method, prepared) { backend <- resolve_energy_backend() - if (identical(prepared$exposure_type, "continuous")) { - if (has_positive_tolerance(prepared$constraints)) { - warn_ignored_tolerance() - } - return(fit_energy_continuous(method, prepared, backend)) - } - enforce <- requests_moments(prepared$constraints) + if (!enforce && has_positive_tolerance(prepared$constraints)) { warn_ignored_tolerance() } + if (identical(prepared$exposure_type, "continuous")) { + return(fit_energy_continuous(method, prepared, enforce, backend)) + } + fit_energy_discrete(method, prepared, enforce, backend) } @@ -383,20 +475,22 @@ fit_energy_discrete <- function(method, prepared, enforce, backend) { nvar <- n - length(groups[[focal]]) n_group_levels <- 1L } - result <- solve_energy( - covs, - treat, - s, - method@distance, - core_estimand, - method@improved, - moment_covs, - targets, - tols, - method@min_weight, - method@weight_penalty, - options - ) + result <- solve_energy_with_fallback(method, options, function(opts) { + solve_energy( + covs, + treat, + s, + method@distance, + core_estimand, + method@improved, + moment_covs, + targets, + tols, + method@min_weight, + method@weight_penalty, + opts + ) + }) } else { treat_idx <- match(key, levels) - 1L if (identical(estimand, "ate")) { @@ -410,25 +504,34 @@ fit_energy_discrete <- function(method, prepared, enforce, backend) { nvar <- n - length(groups[[focal]]) n_group_levels <- length(levels) - 1L } - result <- solve_energy_multi( - covs, - as.integer(treat_idx), - as.integer(focal_idx), - s, - method@distance, - core_estimand, - method@improved, - moment_covs, - targets, - tols, - method@min_weight, - method@weight_penalty, - options - ) + result <- solve_energy_with_fallback(method, options, function(opts) { + solve_energy_multi( + covs, + as.integer(treat_idx), + as.integer(focal_idx), + s, + method@distance, + core_estimand, + method@improved, + moment_covs, + targets, + tols, + method@min_weight, + method@weight_penalty, + opts + ) + }) } duals <- energy_duals_frame(result$duals, nvar, n_group_levels) - assemble_energy(result, method, prepared, duals, approximate = !enforce) + assemble_energy( + result, + method, + prepared, + duals, + approximate = !enforce, + enforced_tolerance = if (enforce) NULL else 0 + ) } # Shift each distribution-moment column to its mean under the base measure. The @@ -446,7 +549,101 @@ center_on_measure <- function(columns, measure) { sweep(columns, 2, centers, "-") } -fit_energy_continuous <- function(method, prepared, backend) { +# The first-moment marginal columns of a continuous fit: one indicator per level +# of a factor covariate, the covariate itself where it is already an indicator, +# and the standardized first power of a numeric covariate. Returns the columns +# alongside the highest marginal power each covariate reached, which +# higher_covariate_marginals() continues from. +# +# They are built from the covariates rather than read off the constraint recipe +# because a covariate's marginal distribution is not what the constraint set +# selects. Reading them off the recipe left `moments` a second route to the +# marginals: `balance_terms(moments = c(x1 = 0))` drops x1's constraint record, +# and with it x1's marginal row, so a fit asked to leave x1 out of the +# correlation rows stopped holding x1's own distribution as well. +# +# The columns cross the boundary on the same scale the constraint matrix uses, +# so they are built through the same records and the same rebuild, and the +# constant and aliased columns are dropped exactly as the constraint build drops +# them. A factor's indicators sum to the constant every method carries, so one +# of them is redundant against the fit's own total-sum row. The drops are silent +# here: the constraint build has already reported whatever it dropped, and these +# rows are the fit's own bookkeeping rather than a set the caller named. +marginal_distribution_columns <- function(data, covariates, sampling_weights) { + center_fn <- if (is.null(sampling_weights)) { + mean + } else { + function(x) weighted_center(x, sampling_weights) + } + scale_fn <- if (is.null(sampling_weights)) { + stats::sd + } else { + function(x) weighted_scale(x, sampling_weights) + } + + records <- list() + for (cov in covariates) { + v <- covariate_values(data, cov) + if (is.factor(v) || is.character(v)) { + levels <- if (is.factor(v)) { + levels(v) + } else { + sort(unique(as.character(v))) + } + for (level in levels) { + records[[length(records) + 1L]] <- new_recipe_record( + term = paste0(cov, "_", level), + kind = "moment", + type = "indicator", + source = cov, + level = level + ) + } + } else if (is.logical(v) || is_binary_numeric(v)) { + records[[length(records) + 1L]] <- new_recipe_record( + term = cov, + kind = "moment", + type = "indicator", + source = cov, + level = NA_character_ + ) + } else { + base_center <- center_fn(v) + raw <- v - base_center + scale <- scale_fn(raw) + if (scale == 0) { + scale <- 1 + } + records[[length(records) + 1L]] <- new_recipe_record( + term = cov, + kind = "moment", + type = "numeric", + source = cov, + power = 1L, + base_center = base_center, + center = center_fn(raw), + scale = scale + ) + } + } + + columns <- rebuild_constraint_matrix(records, data) + for (drop in list(constant_columns, aliased_columns)) { + dropped <- drop(columns) + if (length(dropped) > 0) { + keep <- setdiff(seq_along(records), dropped) + records <- records[keep] + columns <- columns[, keep, drop = FALSE] + } + } + + list( + columns = columns, + moments = covariate_constraint_moments(records, covariates) + ) +} + +fit_energy_continuous <- function(method, prepared, enforce, backend) { n <- prepared$n s <- prepared$sampling_weights covs <- distance_covariates(prepared$data, prepared$covariates) @@ -462,57 +659,145 @@ fit_energy_continuous <- function(method, prepared, backend) { # The distribution-moment constraints hold the weighted exposure and covariate # marginals equal to the sample under the base measure. Every one of those rows # takes the same measure, so a fit under informative sampling holds the - # exposure and the covariates to one population rather than two. They are - # raised to at least the constraint moments, with an alert when the requested - # value is smaller. The weighted distance covariance the objective minimizes is - # what drives the exposure-covariate association toward zero, so no separate - # correlation constraint is added in the default fit. - covariate_moments <- covariate_constraint_moments( - prepared$recipe, - prepared$covariates - ) - constraint_moments <- max(1L, max(covariate_moments, 0L)) - moments <- resolve_distribution_moments( - method@distribution_moments, - constraint_moments + # exposure and the covariates to one population rather than two. + # `distribution_moments` is the only argument that sets how many of them there + # are: the constraint set a caller passes to balance_terms() asks for + # exposure-covariate correlation rows here, and the marginal rows are built + # from the covariates and `distribution_moments` alone. + moments <- method@distribution_moments %||% 1L + marginals <- marginal_distribution_columns( + prepared$data, + prepared$covariates, + prepared$constraint_sampling_weights ) d_treat <- center_on_measure(moment_columns(exposure, moments), measure) extra_covariate_marginals <- higher_covariate_marginals( prepared$data, - covariate_moments, + marginals$moments, moments ) d_covs <- center_on_measure( - do.call(cbind, c(list(z), extra_covariate_marginals)), + do.call( + cbind, + c(list(marginals$columns), extra_covariate_marginals) + ), measure ) - bal_covs <- matrix(numeric(0), nrow = n, ncol = 0) - bal_tols <- numeric(0) + # The correlation rows hold the weighted correlation of the exposure with each + # constraint column inside that column's tolerance, which is what `moments` and + # `interactions` in balance_terms() ask for on a continuous exposure. The core + # standardizes the exposure on the base measure itself and the first + # distribution row pins its weighted mean there, so a row driven to zero is a + # weighted covariance of zero rather than one offset by the gap between the two + # exposure means, and a column whose own weighted mean is not pinned is covered + # as well. Without a requested constraint set the weighted distance covariance + # the objective minimizes is what drives the association toward zero, and no + # correlation row is added. + target <- if (enforce) { + prepared$tolerances + } else { + numeric(0) + } + bal_covs <- if (enforce) { + z + } else { + matrix(numeric(0), nrow = n, ncol = 0) + } options <- energy_options(method, backend) - result <- solve_energy_cont( - covs, - exposure, - s, - method@distance, - method@dimension_adjustment, - method@min_weight, - method@weight_penalty, - d_covs, - d_treat, - bal_covs, - bal_tols, - options - ) + # The row the quadratic program bounds is a linearized correlation whose + # exposure and covariate scales are fixed at the sampling-weight sample. + # Reweighting to meet the bound shrinks both weighted standard deviations, so + # the true weighted Pearson correlation the fit is judged on runs above the + # bound by the product of the two shrinkage ratios: a single solve at a + # tolerance of 0.05 lands between 0.070 and 0.086 at 200 to 1000 observations. + # The bound handed to the program is therefore tightened over a few passes + # until the reported correlation sits inside the requested band, the same + # refinement fit_sbw_continuous() runs against the same statistic. Each pass + # rescales a binding column's bound toward its target, never above it, so the + # loop tightens monotonically, and it stops once every column is inside the + # band the balance table judges it against. A band the passes cannot reach is + # kept at the last iterate that converged and reported: the table then judges + # it out of balance and the fit warns through the ordinary balance warning. + # + # Exact balance and a fit with no correlation rows have nothing to tighten and + # take a single pass. Each pass costs a whole solve, and the reported + # iterations sum every one of them. + effective <- target + iterations <- 0L + result <- NULL + last_converged <- NULL + for (pass in seq_len(correlation_refinement_passes)) { + result <- solve_energy_with_fallback(method, options, function(opts) { + solve_energy_cont( + covs, + exposure, + s, + method@distance, + method@dimension_adjustment, + method@min_weight, + method@weight_penalty, + d_covs, + d_treat, + bal_covs, + effective, + opts + ) + }) + iterations <- iterations + as.integer(result$iterations) + if (!isTRUE(result$converged)) { + # A tightened pass that certifies infeasibility means the requested + # correlation band is unreachable, which surfaces honestly as the + # infeasible condition. A pass that merely ran out of iterations falls + # back to the last converged iterate, which the balance warning then + # judges, rather than reporting the unsettled iterate a tightened bound + # left behind. + if ( + !identical(result$status, "primal_infeasible") && + !is.null(last_converged) + ) { + result <- last_converged + } + break + } + # A fit with nothing to tighten leaves before the measurement as well as + # before the second solve, so the default fit pays for no correlation it + # would not have computed. + if (!any(target > 0)) { + break + } + last_converged <- result + # cov.wt normalizes internally, so the composed sampling weights, not their + # renormalized copy, carry the reweighting the reported statistic reflects. + composed <- as.numeric(result$weights) * s + achieved <- weighted_exposure_correlations(exposure, z, composed) + binding <- target > 0 & achieved > target + balance_margin(target) + if (!any(binding)) { + break + } + ratio <- ifelse(achieved > 0, target / achieved, 1) + effective[binding] <- pmin( + target[binding], + effective[binding] * ratio[binding] * correlation_refinement_safety + ) + } + result$iterations <- iterations # The continuous solve carries one total-sum row followed by the distribution # rows; the box rows bound each of the n units. n_structural_leading <- 1L duals <- energy_duals_frame(result$duals, n, n_structural_leading) - assemble_energy(result, method, prepared, duals, approximate = TRUE) + assemble_energy( + result, + method, + prepared, + duals, + approximate = !enforce, + enforced_tolerance = if (enforce) NULL else 0 + ) } # The solver's dual variables for the structural constraint rows, dropping the @@ -549,7 +834,14 @@ energy_duals_frame <- function(duals, nvar, n_group_rows) { # scaled to the focal total, which leaves the focal group at its base weight. A # continuous fit is a single group scaled to the sampling-weight total. The # quadratic-program family carries no estimating equations. -assemble_energy <- function(result, method, prepared, duals, approximate) { +assemble_energy <- function( + result, + method, + prepared, + duals, + approximate, + enforced_tolerance = NULL +) { s <- prepared$sampling_weights estimand <- prepared$estimand focal <- prepared$focal_level @@ -597,6 +889,15 @@ assemble_energy <- function(result, method, prepared, duals, approximate) { # are enforced, so the balance warning must not fire against a tolerance the # fit does not target. approximate = approximate, + # The tolerance the fit held its rows at, where that is the method's own + # value rather than the one the specification asked for, so the balance + # table reports what the program enforced. A fit that added no constraint + # rows is the case: a tolerance reached no row of the program, so what it + # enforced is zero, and reporting the requested band instead would print a + # box nothing was placed in. A fit that did add rows holds them inside the + # requested band, so it leaves this `NULL` and the table reads the + # per-column tolerances the specification named. + enforced_tolerance = enforced_tolerance, groups = groups ) } diff --git a/R/method-entropy.R b/R/method-entropy.R index f955d9a..c471804 100644 --- a/R/method-entropy.R +++ b/R/method-entropy.R @@ -54,9 +54,14 @@ #' the inexact problem, solved by FISTA against the relative change in the #' loss; that criterion is the weaker of the two, so the value is tightened to #' at most `1e-14` to hold the achieved balance inside the requested box, and -#' anything above `1e-14` is inert there. -#' @param max_iterations The maximum solver iterations, or `NULL` for the core -#' default. +#' anything above `1e-14` is inert there. `1e-10` is both this argument's +#' default and the value the solver resolves for `NULL`. +#' @param max_iterations The maximum solver iterations, or `NULL` for the +#' resolved default of 1000. When the L-BFGS then Newton hybrid runs, either +#' as the automatic retry of a Newton solve that came back short or because +#' `options(balancing.entropy_solver = "lbfgs_then_newton")` asked for it, the +#' cap applies to each phase separately and the reported iteration count is +#' the sum of the two, so such a fit can report more iterations than the cap. #' @param ... Reserved for future extensions; must be empty. Tuning parameters #' must be passed by name. #' @@ -292,15 +297,35 @@ entropy_solve_succeeded <- function(result) { # constraint row uses. A numeric column already standardized to that scale has a # unit standard deviation, so its box equals the tolerance; a raw indicator or # quantile column is scaled by its own standard deviation. +# +# The weighted branch reads every column in one pass of column arithmetic, which +# is the same arithmetic in the same order as the per-column form and so gives +# the same box to the bit. The unweighted branch stays on `stats::sd()` a column +# at a time, which is the faster of the two there: its long double correction is +# carried in C, and reproducing it in R costs more than the per-column dispatch +# saves. +# +# A column with no spread has nothing to convert its tolerance against, so it +# keeps the tolerance as its box. Which columns those are is read from the values +# through `column_is_constant()` (R/balance-table.R) rather than from an exact +# zero in the scale computed here, for the reason recorded there: the weighted +# center divides a sum of products by a sum of weights and need not return the +# repeated value exactly, so a constant column under non-uniform sampling weights +# comes back with a rounding residual for a standard deviation. Testing the scale +# for equality with zero misses that residual and scales the column's box by +# noise, which constrains the fit against rounding rather than against the +# tolerance the caller asked for. Reading the values also keeps this box and the +# balance table it is measured against agreeing on which columns have no spread. solver_box <- function(z, tolerances, sampling_weights = NULL) { weighted <- !is.null(sampling_weights) && length(unique(sampling_weights)) > 1L column_sd <- if (weighted) { - apply(z, 2, weighted_scale, w = sampling_weights) + centers <- column_weighted_means(z, sampling_weights) + centered_column_scales(sweep(z, 2, centers, "-"), sampling_weights) } else { apply(z, 2, stats::sd) } - column_sd[column_sd == 0] <- 1 + column_sd[column_is_constant(z) | column_sd == 0] <- 1 tolerances * column_sd } @@ -661,23 +686,40 @@ fit_entropy_continuous <- function(method, prepared) { # constraints drive each weighted exposure-covariate product to zero. The # distribution moments extend the marginals: they are raised to at least the # constraint moments, with an alert when the requested value is smaller. - covariate_moments <- covariate_constraint_moments( - prepared$recipe, - prepared$covariates + # + # The covariate marginals are built from the covariates rather than read off + # the constraint matrix, for the reason marginal_distribution_columns() + # records: a covariate's marginal distribution is not what the constraint set + # selects, and reading the marginals off the constraint matrix left `moments` a + # second route to them. `balance_terms(moments = c(x1 = 0))` drops x1's + # constraint column, and with it x1's marginal rows, so a fit asked to leave x1 + # out of the products stopped holding x1's own distribution as well. The + # products stay on the constraint matrix, which is exactly the set of + # associations the constraint set names. + constraint_moments <- max( + 1L, + max(covariate_constraint_moments(prepared$recipe, prepared$covariates), 0L) ) - constraint_moments <- max(1L, max(covariate_moments, 0L)) moments <- resolve_distribution_moments( method@distribution_moments, constraint_moments ) + covariate_marginals <- marginal_distribution_columns( + prepared$data, + prepared$covariates, + prepared$constraint_sampling_weights + ) exposure_marginals <- moment_columns(exposure, moments) extra_marginals <- higher_covariate_marginals( prepared$data, - covariate_moments, + covariate_marginals$moments, moments ) - marginals <- do.call(cbind, c(list(exposure_marginals, z), extra_marginals)) + marginals <- do.call( + cbind, + c(list(exposure_marginals, covariate_marginals$columns), extra_marginals) + ) products <- z * e covs <- cbind(marginals, products) @@ -739,8 +781,18 @@ fit_entropy_continuous <- function(method, prepared) { ) result <- solved$result + # The whole sample is one group here, so the reporting scale is a single + # constant rather than the per-group vector the discrete path builds. The + # divergence check the discrete renormalization applies still has to run: a + # tilt that overflowed leaves this total missing, and that is a failed solve + # rather than a reporting-scale question. w <- result$weights current <- sum(s * w) + check_finite_weight_total( + current, + solvers = solved$solvers_tried, + call = rlang::current_env() + ) if (current > 0) { w <- w * (n_eff / current) } diff --git a/R/method-ipt.R b/R/method-ipt.R index d6975ba..5abe325 100644 --- a/R/method-ipt.R +++ b/R/method-ipt.R @@ -31,9 +31,10 @@ #' @param link The propensity link, one of `"logit"`, `"probit"`, or #' `"cloglog"`. #' @param convergence_tolerance The solver convergence tolerance on the tilting -#' moment. -#' @param max_iterations The maximum solver iterations, or `NULL` for the core -#' default. +#' moment. `1e-10` is both this argument's default and the value the solver +#' resolves for `NULL`. +#' @param max_iterations The maximum solver iterations, or `NULL` for the +#' resolved default of 1000. #' @param ... Reserved for future extensions; must be empty. Tuning parameters #' must be passed by name. #' diff --git a/R/method-sbw.R b/R/method-sbw.R index c715413..b7ccb9c 100644 --- a/R/method-sbw.R +++ b/R/method-sbw.R @@ -69,10 +69,16 @@ #' squared weights, minimum variance), `"l1"` (the sum of absolute deviations #' from one), or `"linf"` (the largest absolute deviation from one). #' @param min_weight The smallest permitted weight. -#' @param convergence_tolerance The quadratic-program solver tolerance, or `NULL` -#' for the core default. -#' @param max_iterations The maximum solver iterations, or `NULL` for the core -#' default. +#' @param convergence_tolerance The quadratic-program solver tolerance, or +#' `NULL` for the resolved default of `1e-8`, which the solver applies as both +#' its absolute and its relative tolerance. Under the default backend, a +#' tolerance below what the problem can reach spends the full iteration cap and +#' then warns. +#' @param max_iterations The maximum solver iterations, or `NULL` for the +#' resolved default of 200000. A continuous fit with a positive tolerance +#' refines the bound it hands the solver over several passes, each a solve +#' given this same cap, and the reported `@iterations` sums them, so such a +#' fit can report more iterations than this. #' @param ... Reserved for future extensions; must be empty. Tuning parameters #' must be passed by name. #' @@ -375,33 +381,6 @@ fit_sbw_discrete <- function(method, prepared) { assemble_sbw(result, method, prepared, duals = duals) } -# The largest number of correlation-refinement passes and the fraction of the -# room to the target the effective tolerance is tightened to on each pass, held -# just under one so a converged fit sits inside the band rather than on its edge. -sbw_cont_max_passes <- 8L -sbw_cont_safety <- 0.98 - -# Absolute weighted exposure-covariate Pearson correlations under weights `w`, the -# statistic the continuous fit is judged on and the quantity the balance table -# reports, so the refinement loop measures the same thing the specs assert. A -# column with no weighted spread has no correlation to report: it is met by every -# weighting, so it reads as zero rather than carrying an undefined value into the -# comparison that decides which tolerances still bind. -sbw_weighted_correlations <- function(exposure, z, w) { - vapply( - seq_len(ncol(z)), - function(j) { - correlation <- stats::cov.wt( - cbind(exposure, z[, j]), - wt = w, - cor = TRUE - )$cor[1, 2] - if (is.finite(correlation)) abs(correlation) else 0 - }, - numeric(1) - ) -} - fit_sbw_continuous <- function(method, prepared) { z <- prepared$matrix s <- prepared$sampling_weights @@ -419,12 +398,14 @@ fit_sbw_continuous <- function(method, prepared) { # weighted Pearson correlation the specs check, on the reported weights (the # balancing weights composed with the sampling weights), and rescales each # column's effective tolerance toward its target, never above it, so the loop - # tightens monotonically and stops once every column is inside its band. + # tightens monotonically and stops once every column is inside its band. Each + # pass costs a whole solve, and the reported iterations sum every one of them. target <- prepared$tolerances effective <- target + iterations <- 0L result <- NULL last_converged <- NULL - for (pass in seq_len(sbw_cont_max_passes)) { + for (pass in seq_len(correlation_refinement_passes)) { result <- solve_sbw_cont( exposure, z, @@ -434,6 +415,7 @@ fit_sbw_continuous <- function(method, prepared) { method@min_weight, options ) + iterations <- iterations + as.integer(result$iterations) if (!isTRUE(result$converged)) { # A tightened pass that certifies infeasibility means the requested # correlation band is unreachable, which surfaces honestly as the infeasible @@ -452,7 +434,7 @@ fit_sbw_continuous <- function(method, prepared) { # cov.wt normalizes internally, so the composed sampling weights, not their # renormalized copy, carry the reweighting the reported statistic reflects. composed <- as.numeric(result$weights) * s - achieved <- sbw_weighted_correlations(exposure, z, composed) + achieved <- weighted_exposure_correlations(exposure, z, composed) binding <- target > 0 & achieved > target + 1e-8 if (!any(binding)) { break @@ -460,9 +442,10 @@ fit_sbw_continuous <- function(method, prepared) { ratio <- ifelse(achieved > 0, target / achieved, 1) effective[binding] <- pmin( target[binding], - effective[binding] * ratio[binding] * sbw_cont_safety + effective[binding] * ratio[binding] * correlation_refinement_safety ) } + result$iterations <- iterations # The continuous solve carries one total-sum row followed by the correlation # rows; the box rows bound each of the n units, and the absolute-deviation norms diff --git a/R/utils.R b/R/utils.R index 066674a..6b79043 100644 --- a/R/utils.R +++ b/R/utils.R @@ -72,6 +72,46 @@ group_target_sums <- function(s, groups, focal_level = NULL) { targets } +# A solve that diverged returns weights that are not finite, which leaves the +# total a renormalization divides by as a missing value. That is a failed solve +# rather than a reporting-scale question, so it is refused with a classed error +# instead of steering a comparison with a missing value. Both exposure paths +# refuse it here so the failure reads the same either way. `solvers` names the +# solvers that produced the weights, so a fit that fell back from one solver to +# another reports both rather than an anonymous single failure. `level` names +# the exposure level whose total failed, which only a grouped fit has; the +# continuous path normalizes the sample as a whole and passes none. +check_finite_weight_total <- function( + total, + solvers = NULL, + level = NULL, + call = rlang::caller_env() +) { + if (is.finite(total)) { + return(invisible(NULL)) + } + tried <- solver_labels(solvers) + detail <- if (is.null(level)) { + "The weights do not sum to a finite total." + } else { + "The weights for exposure level {.val {level}} do not sum to a finite total." + } + bullets <- c( + "The solver did not produce finite weights.", + x = detail, + i = "Check the covariates for collinearity or for a column the exposure determines." + ) + if (length(tried) > 1L) { + bullets[[1L]] <- "Neither solver produced finite weights." + bullets <- append(bullets, c(x = "The fit tried {tried}."), after = 1L) + } + abort( + bullets, + error_class = "balancing_convergence_error", + call = call + ) +} + # Move each exposure group's weights onto its reported total. The solvers # normalize on their own internal convention and the reported convention places # each group's sampling-weighted total at `targets`, so the correction is one @@ -80,13 +120,6 @@ group_target_sums <- function(s, groups, focal_level = NULL) { # scale to move to and is left alone. The arguments are the weights together # with the groups and targets rather than a fitted object, so a caller # re-evaluating the weights at other parameters can apply the same convention. -# -# A solve that diverged returns weights that are not finite, which leaves the -# group total this divides by as a missing value. That is a failed solve rather -# than a reporting-scale question, so it is refused here with a classed error -# instead of steering the comparison below with a missing value. `solvers` names -# the solvers that produced the weights, so a fit that fell back from one solver -# to another reports both rather than an anonymous single failure. renormalize_group_weights <- function( w, s, @@ -95,26 +128,15 @@ renormalize_group_weights <- function( solvers = NULL, call = rlang::caller_env() ) { - tried <- solver_labels(solvers) for (level in names(groups)) { idx <- groups[[level]] current <- sum(s[idx] * w[idx]) - if (!is.finite(current)) { - bullets <- c( - "The solver did not produce finite weights.", - x = "The weights for exposure level {.val {level}} do not sum to a finite total.", - i = "Check the covariates for collinearity or for a column the exposure determines." - ) - if (length(tried) > 1L) { - bullets[[1L]] <- "Neither solver produced finite weights." - bullets <- append(bullets, c(x = "The fit tried {tried}."), after = 1L) - } - abort( - bullets, - error_class = "balancing_convergence_error", - call = call - ) - } + check_finite_weight_total( + current, + solvers = solvers, + level = level, + call = call + ) if (current > 0) { w[idx] <- w[idx] * (targets[[level]] / current) } @@ -256,6 +278,13 @@ check_tolerance <- function(tolerance, call = rlang::caller_env()) { # CRAN run never spawns more than the checker permits. The count is computed on # the R side and passed to the core, which re-checks OMP_THREAD_LIMIT as a # backstop. +# +# That list is the whole of it: RAYON_NUM_THREADS is not read anywhere. The core +# never installs a rayon global pool, and every parallel region runs inside a +# pool built with an explicit `num_threads()` (crates/core/src/threads.rs), which +# is the setting rayon consults the environment variable in place of. So the +# variable that would size a default rayon pool has no path to one here, and a +# user who sets it and sees no change is seeing the documented behavior. resolve_threads <- function(threads = NULL) { if (!is.null(threads)) { return(max(1L, as.integer(threads))) @@ -271,7 +300,7 @@ automatic_threads <- function() { if (nzchar(Sys.getenv("_R_CHECK_LIMIT_CORES_"))) { return(2L) } - physical <- parallel::detectCores(logical = FALSE) + physical <- physical_cores() if (is.na(physical) || physical < 1L) { physical <- 1L } @@ -283,6 +312,32 @@ automatic_threads <- function() { max(1L, as.integer(min(caps))) } +# Session state the package computes once and reads many times. It holds only +# values that cannot change while the session runs, so nothing invalidates an +# entry except a test that wants to observe the computation. +.balancing_cache <- new.env(parent = emptyenv()) + +# The number of physical cores, read once per session. `parallel::detectCores()` +# asks the operating system, which on macOS means launching `sysctl`: measured at +# 13 milliseconds, half of what a five-hundred-row entropy fit takes in total, +# and paid again on every fit that does not name its own thread count. The answer +# is a property of the machine rather than of the fit, so the first reading is +# recorded and every later one is answered from the record. +physical_cores <- function() { + if (is.null(.balancing_cache$physical_cores)) { + .balancing_cache$physical_cores <- parallel::detectCores(logical = FALSE) + } + .balancing_cache$physical_cores +} + +# Discard the recorded core count so the next reading asks the operating system +# again. Nothing in a fit calls this; it exists for the tests that mock +# `parallel::detectCores()` and need the record not to answer in its place. +reset_physical_cores <- function() { + .balancing_cache$physical_cores <- NULL + invisible(NULL) +} + # Resolve the solver for the exact entropy problem. The default is Newton, the # only solver that drives the estimating equations to machine precision. The # default is read from an option so it can change in one place without touching diff --git a/man/balance.Rd b/man/balance.Rd index 1b0369d..bf5c3d3 100644 --- a/man/balance.Rd +++ b/man/balance.Rd @@ -13,7 +13,7 @@ balance( ..., constraints = NULL, exposure_type = c("auto", "binary", "categorical", "continuous"), - focal_level = NULL, + .focal_level = NULL, sampling_weights = NULL ) } @@ -40,7 +40,7 @@ default.} \item{exposure_type}{One of \code{"auto"} (the default), \code{"binary"}, \code{"categorical"}, or \code{"continuous"}.} -\item{focal_level}{The focal exposure level for \code{"att"} and \code{"atc"}. Inferred +\item{.focal_level}{The focal exposure level for \code{"att"} and \code{"atc"}. Inferred for a binary exposure; required for a categorical exposure.} \item{sampling_weights}{Sampling weights, given as a bare column name or an @@ -62,7 +62,7 @@ informational message, which \code{options(balancing.quiet = TRUE)} suppresses. estimand vocabulary matches propensity: \code{"atc"} is accepted as a synonym for the untreated target and stored as \code{"atu"}. \code{"att"} and \code{"atc"} reweight toward a focal exposure level, inferred for a binary exposure and required -through \code{focal_level} for a categorical exposure. Continuous exposures permit +through \code{.focal_level} for a categorical exposure. Continuous exposures permit only \code{"ate"}. Constraints default to first-moment balance. Pass a \code{\link[=balance_terms]{balance_terms()}} @@ -76,6 +76,21 @@ informational alert naming the term. The dropped level is the last one, and balancing the levels that remain balances it too. The factor stays in \verb{@covariates}, and \verb{@balance_table} reports the surviving levels rather than the full set. + +A fit can be interrupted between solver iterations, so a long solve stops at +the next iteration rather than at the end of the fit. On Unix the poll reads +R's interrupt flag directly and does not service R's event loop, so a +\code{\link[=setTimeLimit]{setTimeLimit()}} set around the call fires when the call returns rather than +partway through the solve. + +A \code{difftime} covariate balances as the number it stores, in the unit its own +column declares. Nothing rescales it and nothing reinterprets the unit, so its +constraints, its recipe, and its balance table match those of the same +durations supplied as bare numbers. A \code{Date} or \code{POSIXt} covariate balances +the same way, as the number \code{as.numeric()} gives it: days since 1970-01-01 for +a date, seconds since then for a date-time. Both date-time representations +are read that way, so a \code{POSIXlt} column balances exactly as the \code{POSIXct} +column holding the same instants does. } \examples{ n <- 200 diff --git a/man/balance_method.Rd b/man/balance_method.Rd index 6d2b02e..4d6f078 100644 --- a/man/balance_method.Rd +++ b/man/balance_method.Rd @@ -18,11 +18,15 @@ quadratic_program_method( ) } \arguments{ -\item{convergence_tolerance}{The solver convergence tolerance, or \code{NULL} for -the core default.} +\item{convergence_tolerance}{The solver convergence tolerance, or \code{NULL} to +leave it to the solver. The value resolved for \code{NULL} differs by family: +\code{1e-10} on the gradient for the estimating-equation methods, and \code{1e-8} as +both the absolute and the relative tolerance for the quadratic-program +methods.} -\item{max_iterations}{The maximum solver iterations, or \code{NULL} for the core -default.} +\item{max_iterations}{The maximum solver iterations, or \code{NULL} to leave the +cap to the solver. The value resolved for \code{NULL} is 1000 for the +estimating-equation methods and 200000 for the quadratic-program methods.} \item{weight_penalty}{The L2 penalty on the weights.} diff --git a/man/balance_terms.Rd b/man/balance_terms.Rd index 1331e4a..bbc3309 100644 --- a/man/balance_terms.Rd +++ b/man/balance_terms.Rd @@ -14,7 +14,9 @@ balance_terms( } \arguments{ \item{moments}{The highest covariate power to balance. A single whole number -or a named integer vector; \code{NULL} (the default) resolves to first moments.} +or a named integer vector; \code{NULL} (the default) resolves to first moments. +For a continuous exposure each power is held at zero weighted correlation +with the exposure instead.} \item{interactions}{Whether to add pairwise interactions of the base columns. These expand the constraint set the weights must balance, adding the @@ -66,6 +68,16 @@ value selects the inexact problem for entropy balancing and is the central tuning parameter for stable balancing weights. } +For a continuous exposure there are no groups to equate, so a constraint +column is instead held within \code{tolerance} of zero weighted correlation with +the exposure. On the continuous energy path this is what \code{moments} and +\code{interactions} request, and there the correlation is held exactly whatever +\code{tolerance} says, for the reason \code{\link[=bw_energy]{bw_energy()}} records. The marginal +distribution of the exposure and of the covariates is a separate matter, +held by \code{distribution_moments} in \code{\link[=bw_energy]{bw_energy()}} and \code{\link[=bw_entropy]{bw_entropy()}}; asking +for correlation constraints does not add marginal rows, and raising +\code{distribution_moments} adds no correlation constraint. + A factor covariate contributes one indicator per level rather than the reference coding a model formula would use. Those indicators sum to the constant every balancing method carries, so one of them is redundant and the diff --git a/man/balancing.Rd b/man/balancing.Rd index aee34d7..1180f0f 100644 --- a/man/balancing.Rd +++ b/man/balancing.Rd @@ -32,7 +32,8 @@ energy or kernel balancing with no moment constraints, therefore records no covariates even though its objective reads every selected one.} \item{focal_level}{The focal exposure level for \code{"att"} and \code{"atc"}, or -\code{NULL}.} +\code{NULL}. This is the fitted object's property, set from the \code{.focal_level} +argument of \code{\link[=balance]{balance()}}.} \item{n}{The number of observations.} @@ -48,7 +49,15 @@ covariates even though its objective reads every selected one.} \item{converged}{Whether the solver met its convergence criterion.} -\item{iterations}{The solver iteration count.} +\item{iterations}{The solver iteration count. An energy fit that could not +reach its tolerance re-solves at a reachable one, and when that re-solve +converges this sums the original and the fallback solve, so it can exceed +the requested \code{max_iterations}. When the re-solve does not converge the +fit reports the original solve alone, so the count stays within the cap. +A continuous energy or stable balancing fit with a positive tolerance +refines the bound it hands the solver over several passes, each a solve of +its own, and this sums every one of them. See \code{\link[=bw_energy]{bw_energy()}} and \code{\link[=bw_sbw]{bw_sbw()}} +for the fuller account.} \item{objective}{The solved objective value.} diff --git a/man/balancing_options.Rd b/man/balancing_options.Rd index 8edd38e..d068b8f 100644 --- a/man/balancing_options.Rd +++ b/man/balancing_options.Rd @@ -15,7 +15,9 @@ how a fit runs without changing any function's signature. \item \code{balancing.threads}: the number of worker threads the Rust core may use. When unset, the count is resolved automatically from the physical core count, capped by \code{OMP_THREAD_LIMIT} and \code{OMP_NUM_THREADS}, and forced to two -under \verb{R CMD check}. +under \verb{R CMD check}. The count is decided in R and handed to the core, which +sizes its worker pool from it: \code{RAYON_NUM_THREADS} is never read, so setting +that environment variable changes nothing about how a fit runs. \item \code{balancing.entropy_solver}: the solver for the exact entropy problem, one of \code{"newton"} (the default), \code{"lbfgs"}, or \code{"lbfgs_then_newton"}. Newton is the only solver that drives the estimating equations to machine precision; diff --git a/man/bw_cbps.Rd b/man/bw_cbps.Rd index 2752343..5af7034 100644 --- a/man/bw_cbps.Rd +++ b/man/bw_cbps.Rd @@ -31,10 +31,11 @@ Ignored, with a warning, whenever the fit is not over-identified.} and consume it. A continuous exposure fits none, so the setting is ignored, with a warning, there.} -\item{convergence_tolerance}{The solver convergence tolerance.} +\item{convergence_tolerance}{The solver convergence tolerance. \code{1e-10} is +both this argument's default and the value the solver resolves for \code{NULL}.} -\item{max_iterations}{The maximum solver iterations, or \code{NULL} for the core -default.} +\item{max_iterations}{The maximum solver iterations, or \code{NULL} for the +resolved default of 1000.} } \value{ A \code{bw_cbps} specification, a \link{balance_method}. diff --git a/man/bw_cfd.Rd b/man/bw_cfd.Rd index 0474969..8fd3ab5 100644 --- a/man/bw_cfd.Rd +++ b/man/bw_cfd.Rd @@ -45,11 +45,16 @@ quadratic program.} \item{min_weight}{The smallest permitted weight.} -\item{convergence_tolerance}{The quadratic-program solver tolerance, or \code{NULL} -for the core default.} +\item{convergence_tolerance}{The quadratic-program solver tolerance, or +\code{NULL} for the resolved default of \code{1e-8}, which the solver applies as both +its absolute and its relative tolerance. Under the alternating-direction +backend, which the other kernels take by default and which the \code{"energy"} +kernel always takes because its quadratic form is indefinite, a tolerance +below what the problem can reach spends the full iteration cap and then +warns.} -\item{max_iterations}{The maximum solver iterations, or \code{NULL} for the core -default.} +\item{max_iterations}{The maximum solver iterations, or \code{NULL} for the +resolved default of 200000.} } \value{ A \code{bw_cfd} specification, a \link{balance_method}. diff --git a/man/bw_energy.Rd b/man/bw_energy.Rd index c640b92..274d332 100644 --- a/man/bw_energy.Rd +++ b/man/bw_energy.Rd @@ -12,7 +12,7 @@ bw_energy( min_weight = 1e-08, distribution_moments = NULL, dimension_adjustment = TRUE, - convergence_tolerance = NULL, + convergence_tolerance = 1e-06, max_iterations = NULL ) } @@ -21,14 +21,16 @@ bw_energy( must be passed by name.} \item{distance}{The covariate distance definition the energy objective is -built on, one of \code{"scaled_euclidean"} (each covariate divided by its -standard deviation), \code{"mahalanobis"}, or \code{"euclidean"}.} +built on, one of \code{"scaled_euclidean"} (each covariate centered at its +weighted mean and divided by its weighted standard deviation), +\code{"mahalanobis"}, or \code{"euclidean"}.} \item{improved}{Whether to add the between-group energy distance of the improved variant for the average treatment effect with a discrete exposure.} \item{weight_penalty}{The L2 penalty on the weights, which stabilizes the -quadratic program.} +quadratic program. For a continuous exposure it is also what sets the +residual exposure-covariate correlation, as the details section explains.} \item{min_weight}{The smallest permitted weight. The reported weights average one within each exposure group, so a floor approaching one leaves almost no @@ -41,19 +43,35 @@ refuses the same floor as infeasible instead.} \item{distribution_moments}{For a continuous exposure, the number of exposure and covariate marginal moments held equal to the sample under the base -measure, or \code{NULL} for the constraint moments. Raised automatically when -smaller than the constraint moments. Energy balancing carries no base -weights, so the base measure is the sampling weights, and without them the -marginals are held equal to the unweighted sample.} +measure, or \code{NULL} for the first moments. This is the only route to those +rows: the \code{moments} in \code{\link[=balance_terms]{balance_terms()}} asks for exposure-covariate +correlation constraints instead and leaves the marginals here. Energy balancing carries no base weights, so the base +measure is the sampling weights, and without them the marginals are held +equal to the unweighted sample.} \item{dimension_adjustment}{For a continuous exposure, whether to weight the covariate energy distance by the covariate dimensionality adjustment.} -\item{convergence_tolerance}{The quadratic-program solver tolerance, or \code{NULL} -for the core default.} +\item{convergence_tolerance}{The quadratic-program solver tolerance, which +the solver applies as both its absolute and its relative tolerance, or +\code{NULL} for the family default of \code{1e-8}. Energy balancing defaults to +\code{1e-6} rather than to that family default because its quadratic form is +indefinite: on a small sample the alternating-direction residual floors +above \code{1e-8}, and a run that keeps going past that floor walks away from +the optimum instead of stalling at it. The energy objective always solves +through the alternating-direction backend, whatever \code{balancing.qp_backend} +names, so there is no backend to choose here: a tolerance below what the +problem can reach spends the full iteration cap, then warns and reports the +iterate of a re-solve at a tolerance the problem does reach, provided that +re-solve converges within the same \code{max_iterations}. When it does not, the +fit reports the iterate of the original solve.} -\item{max_iterations}{The maximum solver iterations, or \code{NULL} for the core -default.} +\item{max_iterations}{The maximum solver iterations, or \code{NULL} for the +resolved default of 200000. The re-solve above is given the same cap, and +when it converges the reported \verb{@iterations} sums the two solves, so an +energy fit that could not reach its tolerance can report more iterations +than this. The refinement passes of a continuous fit with a positive +tolerance are summed the same way, each pass being a solve of its own.} } \value{ An \code{bw_energy} specification, a \link{balance_method}. @@ -82,11 +100,44 @@ marginal moments are held equal to the sample under the base measure, and \code{dimension_adjustment} reweights the covariate energy distance by the covariate dimensionality. +The two knobs a continuous fit carries are separate. \code{moments} in +\code{\link[=balance_terms]{balance_terms()}} adds a constraint that holds the weighted correlation of +the exposure with each covariate power within its tolerance, which defaults +to zero, and \code{distribution_moments} pins the marginal moments of the +exposure and of the covariates. Neither sets the other: a fit that wants +both asks for both. The correlation rows are held within the tolerance +\code{\link[=balance_terms]{balance_terms()}} carries, and reaching that band takes more than one solve. +The quadratic program bounds a linearized correlation whose exposure and +covariate scales are fixed at the sample, and the spread of energy weights +shrinks both weighted standard deviations, so a single solve at the requested +band overshoots it: a band of \code{0.05} lands between 0.070 and 0.086 at 200 to +1000 observations. The fit therefore tightens the bound it hands the program +and re-solves, up to eight passes, until the reported correlation sits inside +the band. A band of \code{0.05} took two passes at 350 and at 1000 observations, so +it costs about two solves against the one the same fit at exact balance takes, +exact balance having nothing to tighten. A band the passes cannot reach is +reported at its last iterate, and the balance warning judges it as it judges +any other fit. + +Without those rows the continuous objective targets distributional +independence between the exposure and the covariates rather than zero +correlations, and it does not drive the correlations to zero. A residual +weighted correlation of roughly 0.1 to 0.3 is ordinary at a few hundred to a +few thousand observations. What holds it up is \code{weight_penalty}, which trades that +residual against effective sample size: at its default of \code{1e-4} the penalty +term is about three quarters of the objective at 1000 observations, leaving a +largest correlation near 0.22 to 0.25 at an effective sample size near 71 +percent, while a penalty of zero brings the correlation down to 0.05 to 0.07 +and the effective sample size down to about 20 percent. Ask for +\code{balance_terms(moments = 1)} to remove the correlation outright, at a cost in +effective sample size of its own. + Energy balancing belongs to the quadratic-program family, which has no estimating equations, so a fit produces no estimating-equations container and -the tolerance in \code{\link[=balance_terms]{balance_terms()}} relaxes any added moment constraints rather -than selecting an inexact solver. A tolerance supplied without moment -constraints has nothing to relax, so it is warned and ignored. +the tolerance in \code{\link[=balance_terms]{balance_terms()}} relaxes the constraints a fit added rather +than selecting an inexact solver. A tolerance supplied without those +constraints has nothing to relax, so it is warned and ignored, and the balance +table reports the tolerance the fit enforced, which is zero. } \examples{ n <- 200 diff --git a/man/bw_entropy.Rd b/man/bw_entropy.Rd index 5f2aa7d..93c13b1 100644 --- a/man/bw_entropy.Rd +++ b/man/bw_entropy.Rd @@ -34,10 +34,15 @@ and responds to this value across its range. A positive tolerance selects the inexact problem, solved by FISTA against the relative change in the loss; that criterion is the weaker of the two, so the value is tightened to at most \code{1e-14} to hold the achieved balance inside the requested box, and -anything above \code{1e-14} is inert there.} +anything above \code{1e-14} is inert there. \code{1e-10} is both this argument's +default and the value the solver resolves for \code{NULL}.} -\item{max_iterations}{The maximum solver iterations, or \code{NULL} for the core -default.} +\item{max_iterations}{The maximum solver iterations, or \code{NULL} for the +resolved default of 1000. When the L-BFGS then Newton hybrid runs, either +as the automatic retry of a Newton solve that came back short or because +\code{options(balancing.entropy_solver = "lbfgs_then_newton")} asked for it, the +cap applies to each phase separately and the reported iteration count is +the sum of the two, so such a fit can report more iterations than the cap.} } \value{ An \code{bw_entropy} specification, a \link{balance_method}. diff --git a/man/bw_ipt.Rd b/man/bw_ipt.Rd index f23abef..0b723d3 100644 --- a/man/bw_ipt.Rd +++ b/man/bw_ipt.Rd @@ -19,10 +19,11 @@ must be passed by name.} \code{"cloglog"}.} \item{convergence_tolerance}{The solver convergence tolerance on the tilting -moment.} +moment. \code{1e-10} is both this argument's default and the value the solver +resolves for \code{NULL}.} -\item{max_iterations}{The maximum solver iterations, or \code{NULL} for the core -default.} +\item{max_iterations}{The maximum solver iterations, or \code{NULL} for the +resolved default of 1000.} } \value{ An \code{bw_ipt} specification, a \link{balance_method}. diff --git a/man/bw_sbw.Rd b/man/bw_sbw.Rd index c52b966..7fe4da3 100644 --- a/man/bw_sbw.Rd +++ b/man/bw_sbw.Rd @@ -22,11 +22,17 @@ from one), or \code{"linf"} (the largest absolute deviation from one).} \item{min_weight}{The smallest permitted weight.} -\item{convergence_tolerance}{The quadratic-program solver tolerance, or \code{NULL} -for the core default.} +\item{convergence_tolerance}{The quadratic-program solver tolerance, or +\code{NULL} for the resolved default of \code{1e-8}, which the solver applies as both +its absolute and its relative tolerance. Under the default backend, a +tolerance below what the problem can reach spends the full iteration cap and +then warns.} -\item{max_iterations}{The maximum solver iterations, or \code{NULL} for the core -default.} +\item{max_iterations}{The maximum solver iterations, or \code{NULL} for the +resolved default of 200000. A continuous fit with a positive tolerance +refines the bound it hands the solver over several passes, each a solve +given this same cap, and the reported \verb{@iterations} sums them, so such a +fit can report more iterations than this.} } \value{ An \code{bw_sbw} specification, a \link{balance_method}. diff --git a/src/rust/crates/core/Cargo.toml b/src/rust/crates/core/Cargo.toml index 09072d3..cc32697 100644 --- a/src/rust/crates/core/Cargo.toml +++ b/src/rust/crates/core/Cargo.toml @@ -45,3 +45,7 @@ harness = false [[bench]] name = "sbw_backends" harness = false + +[[bench]] +name = "transforms" +harness = false diff --git a/src/rust/crates/core/benches/transforms.rs b/src/rust/crates/core/benches/transforms.rs new file mode 100644 index 0000000..d1d2826 --- /dev/null +++ b/src/rust/crates/core/benches/transforms.rs @@ -0,0 +1,80 @@ +//! Criterion benchmarks for the covariate distance transforms. +//! +//! `dist::transform` is the standardizing pass that every energy and +//! covariate-function-of-distance fit runs before the pairwise matrix is +//! assembled. It is `O(n p)` in front of `O(n^2 p)` work, so it should never be +//! the visible cost, and the two benchmarks that touch it indirectly cannot say +//! so: `kernels` measures the kernel build the transform feeds, and +//! `qp_backends` reaches it through a full energy solve where it is a rounding +//! error. This file measures the pass on its own, which is what makes the price +//! of the second moment scan and of centering readable rather than inferred. +//! +//! Grid: ten covariates at n = 20000 and n = 50000, the two sizes where the +//! transform is large enough to time cleanly and which bracket the range an +//! energy fit can reach. Each size is measured on well-scaled covariates and on +//! the same covariates shifted to date-time magnitude. The offset copy is the +//! case the two-pass variance and the centering exist for, and it costs the same +//! arithmetic, so measuring both confirms the accuracy is not bought with a +//! branch that only the ordinary case avoids. + +use std::time::Duration; + +use criterion::{BenchmarkId, Criterion, criterion_group, criterion_main}; +use std::hint::black_box; + +use balancing_core::dist::Distance; +use balancing_core::dist::transform::transform; + +mod common; +use common::make_problem; + +/// The magnitude `as.numeric()` gives a POSIXct, added to a well-scaled column +/// to reproduce a date-time covariate: a mean roughly half a million standard +/// deviations from zero. +const DATE_TIME_OFFSET: f64 = 1.7e9; + +/// One covariate-matrix size to measure. The transform is linear in both, so `n` +/// dominates at the widths a balancing fit uses. +struct Point { + n: usize, + p: usize, +} + +// Ordered fast to slow. Each benchmark's estimate is saved as it finishes, so a +// run stopped early still yields the smaller size. +const POINTS: &[Point] = &[Point { n: 20_000, p: 10 }, Point { n: 50_000, p: 10 }]; + +fn bench_transform(c: &mut Criterion) { + let mut group = c.benchmark_group("dist_transform"); + // The pass is a few milliseconds at these sizes, so a modest sample gives a + // stable median without a long run. + group.sample_size(20); + group.warm_up_time(Duration::from_millis(500)); + group.measurement_time(Duration::from_secs(3)); + + for point in POINTS { + let prob = make_problem(point.n, point.p, 0x7A05_5EED); + let offset: Vec = prob.covs.iter().map(|&x| DATE_TIME_OFFSET + x).collect(); + let scalings: [(&str, &[f64]); 2] = [("scaled", &prob.covs), ("offset", &offset)]; + + for (scaling, covs) in scalings { + for (name, distance) in [ + ("scaled_euclidean", Distance::ScaledEuclidean), + ("mahalanobis", Distance::Mahalanobis), + ] { + let id = format!("{name}_{scaling}_n{}_p{}", point.n, point.p); + group.bench_with_input(BenchmarkId::from_parameter(&id), &covs, |b, covs| { + b.iter(|| { + let out = + transform(black_box(covs), point.n, point.p, distance, &prob.s, 1); + black_box(out.len()) + }); + }); + } + } + } + group.finish(); +} + +criterion_group!(benches, bench_transform); +criterion_main!(benches); diff --git a/src/rust/crates/core/src/dist/kernels.rs b/src/rust/crates/core/src/dist/kernels.rs index 8168eca..888a3f3 100644 --- a/src/rust/crates/core/src/dist/kernels.rs +++ b/src/rust/crates/core/src/dist/kernels.rs @@ -511,6 +511,55 @@ mod tests { } } + /// A date-time covariate enters the kernel as seconds since the epoch, so + /// its values sit near 1.7e9 while its spread is an hour. The + /// scaled-Euclidean transform centers at the weighted column mean before it + /// scales, so the standardized column is the same whether the epoch offset + /// rides along or is removed beforehand, and the t kernel built on it is the + /// same matrix. + /// + /// The t kernel is where the centering is worth the most. It reads a cosine + /// and a sine at each unit's projection angle, and without the centering the + /// standardized values would carry the offset divided by the spread, here + /// about 1.3e6. The features would then be evaluated a few million radians + /// from zero, where a unit in the last place is already 1e-9 wide, and the + /// separation between two units would be quantized against that. Measured on + /// this fixture with the uncentered transform the two matrices differ by + /// 4.9e-10, against 2.8e-16 with it. + #[test] + fn the_t_kernel_is_accurate_at_a_date_time_offset() { + // Seconds since the epoch near 2023-11-14, at irregular times within one + // hour, and the same instants shifted to a mean of zero. + let offset = 1.7e9; + let within: [f64; 10] = [ + 0.0, 137.0, 412.0, 900.0, 1355.0, 1801.0, 2260.0, 2712.0, 3140.0, 3599.0, + ]; + let n = within.len(); + let p = 1; + let mean = within.iter().sum::() / n as f64; + let stamped: Vec = within.iter().map(|v| offset + v).collect(); + let centered: Vec = within.iter().map(|v| v - mean).collect(); + + let s = vec![1.0; n]; + let proj = [2.9, -4.3, 1.7, -3.5, 5.1, -2.2]; // p by d column-major + let tp = KernelParams { + kernel: Kernel::T, + bw_scale: 1.0, + matern_nu: MaternNu::ThreeHalves, + t_proj: &proj, + n_draws: proj.len(), + }; + + let stamped_kernel = build_kernel(&stamped, n, p, &s, &tp, &[], 1); + let centered_kernel = build_kernel(¢ered, n, p, &s, &tp, &[], 1); + for (a, b) in stamped_kernel.iter().zip(¢ered_kernel) { + assert!( + (a - b).abs() < 1e-10, + "t kernel differs under a date-time offset: {a} against {b}" + ); + } + } + #[test] fn the_kernel_is_invariant_to_a_uniform_covariate_rescaling() { // Standardizing first makes the gaussian kernel identical after scaling diff --git a/src/rust/crates/core/src/dist/mod.rs b/src/rust/crates/core/src/dist/mod.rs index a33f3ba..8df01da 100644 --- a/src/rust/crates/core/src/dist/mod.rs +++ b/src/rust/crates/core/src/dist/mod.rs @@ -14,15 +14,18 @@ pub mod transform; /// The distance definition the energy objective is built on. /// /// Each variant names a transform applied to the covariates before Euclidean -/// distances are taken. `ScaledEuclidean` divides each column by its weighted -/// standard deviation; `Mahalanobis` whitens by the weighted covariance; -/// `Euclidean` uses the covariates unchanged. +/// distances are taken. `ScaledEuclidean` centers each column at its weighted +/// mean and divides by its weighted standard deviation; `Mahalanobis` centers +/// and whitens by the weighted covariance; `Euclidean` uses the covariates +/// unchanged. Centering shifts every row alike and so leaves the distances +/// themselves untouched. #[derive(Debug, Clone, Copy, PartialEq, Eq)] pub enum Distance { - /// Euclidean distance on columns divided by their weighted standard - /// deviation. + /// Euclidean distance on columns centered at their weighted mean and + /// divided by their weighted standard deviation. ScaledEuclidean, - /// Euclidean distance after whitening by the weighted covariance. + /// Euclidean distance after centering and whitening by the weighted + /// covariance. Mahalanobis, /// Euclidean distance on the covariates as supplied. Euclidean, diff --git a/src/rust/crates/core/src/dist/transform.rs b/src/rust/crates/core/src/dist/transform.rs index f84c50c..9ce9308 100644 --- a/src/rust/crates/core/src/dist/transform.rs +++ b/src/rust/crates/core/src/dist/transform.rs @@ -2,14 +2,20 @@ //! //! Rescaling the covariates once and then taking plain Euclidean distances is //! equivalent to, and cheaper than, evaluating the target metric on every pair. -//! Scaled Euclidean divides each column by its weighted standard deviation; -//! Mahalanobis whitens by the weighted covariance through its eigendecomposition -//! so that Euclidean distance on the whitened rows equals the Mahalanobis -//! distance; plain Euclidean leaves the covariates unchanged. +//! Scaled Euclidean centers each column at its weighted mean and divides by its +//! weighted standard deviation; Mahalanobis centers as well and whitens by the +//! weighted covariance through its eigendecomposition so that Euclidean distance +//! on the whitened rows equals the Mahalanobis distance; plain Euclidean leaves +//! the covariates unchanged. +//! +//! Centering is invisible to the metric, since a common shift of every row +//! cancels in every pairwise difference, and it is what keeps the transformed +//! values at the spread's own scale rather than at the column's offset. use faer::{Mat, Side}; use super::Distance; +use crate::stats::reliability_variance; use crate::threads::{deterministic_map_reduce, get_pool}; /// Relative eigenvalue floor for the whitening pseudo-inverse: directions whose @@ -18,36 +24,44 @@ use crate::threads::{deterministic_map_reduce, get_pool}; /// generalized-inverse behavior used elsewhere for singular covariances. const WHITEN_RCOND: f64 = 1e-12; -/// Per-column weighted mean and variance, and the summed weight statistics. -struct Moments { +/// Weight totals and per-column weighted sums, the first pass of the moments. +struct ColumnSums { /// Total weight `sum_i w_i`. sw: f64, /// Summed squared weight `sum_i w_i^2`. sw2: f64, /// Weighted column sums `sum_i w_i x_ic`. sx: Vec, - /// Weighted column sums of squares `sum_i w_i x_ic^2`. - sxx: Vec, } -impl Moments { +impl ColumnSums { fn zeros(p: usize) -> Self { Self { sw: 0.0, sw2: 0.0, sx: vec![0.0; p], - sxx: vec![0.0; p], } } } /// Weighted mean and reliability-weighted variance of each column. /// -/// The variance uses the frequency-weight-free (reliability) denominator -/// `1 - sum_i wn_i^2` with normalized weights `wn = w / sum(w)`, which reduces to -/// the usual `n - 1` sample variance when the weights are equal. A column with no -/// variance is reported with variance zero; callers substitute one so the column -/// is left unscaled rather than dividing by zero. +/// The variance is accumulated in two scans of the covariates, the first +/// producing the weight totals and the column means and the second the weighted +/// squared deviations from those means. Forming the deviations explicitly is +/// what keeps the result accurate on a column whose mean is large against its +/// spread; the `stats` module records why that case is the ordinary one +/// rather than a corner. The alternative single-scan form, Welford's weighted online +/// update, would save the second read of the data but needs a division by the +/// running total inside the inner loop and a guarded pairwise merge to combine +/// the chunk accumulators, and the transform is `O(n p)` in front of the +/// `O(n^2 p)` pairwise work it feeds, so the second scan is not a cost worth +/// that complexity. Both scans stay column-major and both reduce through +/// [`deterministic_map_reduce`], so the result is still independent of the +/// thread count. +/// +/// A column with no variance is reported with variance zero; callers substitute +/// one so the column is left unscaled rather than dividing by zero. fn weighted_moments( covs: &[f64], n: usize, @@ -59,15 +73,13 @@ fn weighted_moments( let acc = deterministic_map_reduce( &pool, n, - || Moments::zeros(p), + || ColumnSums::zeros(p), |acc, i| { let wi = w[i]; acc.sw += wi; acc.sw2 += wi * wi; for j in 0..p { - let x = covs[j * n + i]; - acc.sx[j] += wi * x; - acc.sxx[j] += wi * x * x; + acc.sx[j] += wi * covs[j * n + i]; } }, |acc, other| { @@ -75,30 +87,38 @@ fn weighted_moments( acc.sw2 += other.sw2; for j in 0..p { acc.sx[j] += other.sx[j]; - acc.sxx[j] += other.sxx[j]; } }, ); let sw = acc.sw; - let mut means = vec![0.0; p]; - let mut vars = vec![0.0; p]; if sw <= 0.0 { - return (means, vars); - } - // The reliability denominator; guarded so a single dominant weight does not - // produce a negative or zero divisor. - let denom = 1.0 - acc.sw2 / (sw * sw); - for j in 0..p { - let mean = acc.sx[j] / sw; - means[j] = mean; - let second = acc.sxx[j] / sw - mean * mean; - vars[j] = if denom > 0.0 { - (second / denom).max(0.0) - } else { - 0.0 - }; + return (vec![0.0; p], vec![0.0; p]); } + let means: Vec = acc.sx.iter().map(|&sxj| sxj / sw).collect(); + + let ss = deterministic_map_reduce( + &pool, + n, + || vec![0.0_f64; p], + |acc, i| { + let wi = w[i]; + for j in 0..p { + let d = covs[j * n + i] - means[j]; + acc[j] += wi * d * d; + } + }, + |acc, other| { + for j in 0..p { + acc[j] += other[j]; + } + }, + ); + + let vars = ss + .iter() + .map(|&ssj| reliability_variance(ssj, sw, acc.sw2)) + .collect(); (means, vars) } @@ -124,16 +144,27 @@ pub fn transform( } } -/// Divide each column by its weighted standard deviation. A column with no -/// variance is left unscaled. +/// Subtract each column's weighted mean and divide by its weighted standard +/// deviation. A column with no variance is centered but left unscaled, so it +/// comes back as exactly zero. +/// +/// Subtracting the mean changes no pairwise Euclidean distance: it shifts every +/// row by the same vector, which cancels in every difference. What it buys is +/// the range the output occupies. A date-time column, which `as.numeric()` puts +/// near 1.7e9, with an hour of spread divides to about 8e5 with deviations of +/// order one, and a unit in the last place there is about 1.2e-10, so the +/// distances built from it are quantized ten digits coarser than the doubles +/// carrying them. Centering leaves the output at the deviations' own scale and +/// costs one subtraction per entry, on a pass that already reads and writes +/// every entry. The Mahalanobis transform centers for the same reason. fn scaled_euclidean(covs: &[f64], n: usize, p: usize, w: &[f64], threads: usize) -> Vec { - let (_means, vars) = weighted_moments(covs, n, p, w, threads); - let mut out = covs.to_vec(); + let (means, vars) = weighted_moments(covs, n, p, w, threads); + let mut out = vec![0.0; n * p]; for j in 0..p { let sd = vars[j].sqrt(); let scale = if sd > 0.0 { 1.0 / sd } else { 1.0 }; for i in 0..n { - out[j * n + i] *= scale; + out[j * n + i] = (covs[j * n + i] - means[j]) * scale; } } out @@ -253,6 +284,8 @@ fn mahalanobis(covs: &[f64], n: usize, p: usize, w: &[f64], threads: usize) -> V #[cfg(test)] mod tests { use super::*; + use crate::dist::pairwise; + use crate::threads::REDUCE_CHUNK; #[test] fn equal_weights_reproduce_the_sample_variance() { @@ -266,22 +299,25 @@ mod tests { } #[test] - fn scaled_euclidean_divides_by_the_standard_deviation() { + fn scaled_euclidean_centers_and_divides_by_the_standard_deviation() { let covs = [1.0, 2.0, 3.0, 4.0]; let w = [1.0, 1.0, 1.0, 1.0]; let out = scaled_euclidean(&covs, 4, 1, &w, 1); let sd = (5.0_f64 / 3.0).sqrt(); for i in 0..4 { - assert!((out[i] - covs[i] / sd).abs() < 1e-12); + assert!((out[i] - (covs[i] - 2.5) / sd).abs() < 1e-12); } } #[test] - fn a_constant_column_is_left_unscaled() { + fn a_constant_column_centers_to_zero_and_is_left_unscaled() { + // Centering sends a column with no spread onto exactly zero, which is + // also where the Mahalanobis standardization puts it. The scale stays at + // one rather than dividing by a zero standard deviation. let covs = [2.0, 2.0, 2.0]; let w = [1.0, 1.0, 1.0]; let out = scaled_euclidean(&covs, 3, 1, &w, 1); - assert_eq!(out, covs.to_vec()); + assert_eq!(out, vec![0.0, 0.0, 0.0]); } #[test] @@ -477,4 +513,242 @@ mod tests { assert!((cov[3] - 1.0).abs() < 1e-6, "cov[1,1] = {}", cov[3]); assert!(cov[1].abs() < 1e-6, "off-diagonal = {}", cov[1]); } + + /// A deterministic stream on the unit interval from a linear congruential + /// generator. The offset fixtures below need many values with no structure, + /// and generating them here keeps the numbers identical on every platform + /// without reaching for a random-number dependency. + fn lcg_unit(n: usize, seed: u64) -> Vec { + let mut state = seed; + (0..n) + .map(|_| { + state = state + .wrapping_mul(6_364_136_223_846_793_005) + .wrapping_add(1_442_695_040_888_963_407); + (state >> 11) as f64 / 9_007_199_254_740_992.0 + }) + .collect() + } + + /// The offset the fixtures below sit at: the magnitude `as.numeric()` gives a + /// POSIXct, with an hour of spread around it. + const DATE_TIME_OFFSET: f64 = 1.7e9; + + /// `n` rows of two columns and their non-uniform weights. Column zero sits at + /// date-time scale, `offset + spread * z` with the offset above and the + /// spread one hour, which is the shape that makes a one-pass variance + /// cancel: the mean is roughly half a million standard deviations from zero. + /// Column one is an ordinary unit-scale column carried alongside so the same + /// fixture covers the undemanding case. + fn offset_fixture_n(n: usize) -> (Vec, Vec) { + let spread = 3600.0; + let z = lcg_unit(n, 20_250_828); + let plain = lcg_unit(n, 12_345_677); + let weight_draws = lcg_unit(n, 987_654_321); + let mut covs = Vec::with_capacity(2 * n); + covs.extend( + z.iter() + .map(|&zi| DATE_TIME_OFFSET + spread * (2.0 * zi - 1.0)), + ); + covs.extend(plain.iter().map(|&pi| 2.0 * pi - 1.0)); + let w = weight_draws.iter().map(|&vi| 0.25 + 1.5 * vi).collect(); + (covs, w) + } + + /// The fifty-row instance of that fixture, with its row count and offset, for + /// the tests that center by the offset exactly. + fn offset_fixture() -> (Vec, Vec, usize, f64) { + let n = 50; + let (covs, w) = offset_fixture_n(n); + (covs, w, n, DATE_TIME_OFFSET) + } + + /// Two-pass reliability-weighted variance: the weighted mean first, then the + /// weighted squared deviations from it. The deviations are formed at the + /// column's own scale rather than as a difference of two large sums, so this + /// stays accurate at any offset and is the reference `weighted_moments` has to + /// reproduce. + fn two_pass_variance(x: &[f64], w: &[f64]) -> f64 { + let sw: f64 = w.iter().sum(); + let sw2: f64 = w.iter().map(|wi| wi * wi).sum(); + let mean: f64 = x.iter().zip(w).map(|(&xi, &wi)| wi * xi).sum::() / sw; + let ss: f64 = x + .iter() + .zip(w) + .map(|(&xi, &wi)| { + let d = xi - mean; + wi * d * d + }) + .sum(); + (ss / sw) / (1.0 - sw2 / (sw * sw)) + } + + #[test] + fn the_standardizing_sd_survives_a_date_time_offset() { + // Subtracting the offset from a column built as `offset + spread * z` is + // exact in binary floating point, both values being within a factor of + // two of each other, so the centered column holds precisely the + // deviations the stored column has and its two-pass variance is the + // variance the transform is being asked for. + let (covs, w, n, offset) = offset_fixture(); + let centered: Vec = covs[..n].iter().map(|&xi| xi - offset).collect(); + let want = two_pass_variance(¢ered, &w).sqrt(); + + let (_means, vars) = weighted_moments(&covs, n, 2, &w, 1); + let got = vars[0].sqrt(); + let rel = (got - want).abs() / want; + assert!( + rel < 1e-12, + "standardizing sd {got} against the two-pass reference {want}, relative error {rel}" + ); + } + + /// Weighted mean of a single column, the reference the centered transform's + /// output is read against. + fn two_pass_mean(x: &[f64], w: &[f64]) -> f64 { + let sw: f64 = w.iter().sum(); + x.iter().zip(w).map(|(&xi, &wi)| wi * xi).sum::() / sw + } + + #[test] + fn a_scaled_column_has_zero_mean_and_unit_weighted_sd_at_a_date_time_offset() { + // Scaled Euclidean subtracts each column's weighted mean and divides by + // its weighted standard deviation, so every transformed column must read + // back a weighted mean of zero and a weighted standard deviation of one. + // The offset column is the demanding one; the plain column establishes + // that the check itself is satisfiable. + // + // The standard deviation is held to 1e-12 because centering leaves the + // output at the deviations' own scale. Without it the offset column would + // come back around 8e5 with deviations of order one, so a unit in the + // last place of the output would be about 1e-10 and any reading taken + // from it would inherit that granularity, ten digits coarser than the + // statistic the transform computed. + // + // The mean is held to 1e-9 instead, and the looser bound is a property of + // the stored input rather than of the centering. A double near 1.7e9 + // resolves to about 2.4e-7, so the exact weighted mean of the stored + // column cannot be named to better than half of that, which is 5.9e-11 + // of the hour of spread the column is divided by. That floor is not the + // whole of the residual: `sx`, the weighted sum the mean divides, + // accumulates one row at a time, and its own rounding error is of the + // same order, so what the measurement reads is the two together. No + // arrangement of the arithmetic reaches 1e-12 here; the measured + // residual, 8.9e-11, is already inside one unit in the last place of the + // input read in standard deviations. The plain column, which has no such + // floor, comes back at 4e-17 and shows the check is not merely loose. + let (covs, w, n, _offset) = offset_fixture(); + let out = scaled_euclidean(&covs, n, 2, &w, 1); + for j in 0..2 { + let column = &out[j * n..(j + 1) * n]; + let mean = two_pass_mean(column, &w); + assert!( + mean.abs() < 1e-9, + "column {j} has weighted mean {mean} after scaling" + ); + let sd = two_pass_variance(column, &w).sqrt(); + assert!( + (sd - 1.0).abs() < 1e-12, + "column {j} has weighted sd {sd} after scaling" + ); + } + } + + #[test] + fn centering_leaves_the_scaled_euclidean_distances_where_they_were() { + // Subtracting a per-column constant shifts every row by the same vector, + // which cancels in every pairwise difference, so centering is a change of + // representation and not of the metric. On well-scaled covariates, where + // the uncentered form loses nothing to cancellation, the two must agree + // to rounding: the reference divides by the same standard deviations + // without subtracting the means. + let n = 40; + let p = 3; + let draws = lcg_unit(n * p, 24_680_135); + let covs: Vec = draws + .iter() + .enumerate() + .map(|(k, &u)| 2.0 * u - 1.0 + 3.0 * ((k / n) as f64 + 1.0)) + .collect(); + let weight_draws = lcg_unit(n, 13_579_246); + let w: Vec = weight_draws.iter().map(|&vi| 0.25 + 1.5 * vi).collect(); + + let (means, vars) = weighted_moments(&covs, n, p, &w, 1); + // Every column sits well away from zero, or centering would be a no-op + // and the agreement below would hold for the wrong reason. + for (j, mean) in means.iter().enumerate() { + assert!(*mean > 1.0, "column {j} has weighted mean {mean}"); + } + let mut uncentered = covs.clone(); + for (j, var) in vars.iter().enumerate() { + let sd = var.sqrt(); + let scale = if sd > 0.0 { 1.0 / sd } else { 1.0 }; + for i in 0..n { + uncentered[j * n + i] *= scale; + } + } + + let out = transform(&covs, n, p, Distance::ScaledEuclidean, &w, 1); + let got = pairwise::euclidean(&out, n, p, 1); + let want = pairwise::euclidean(&uncentered, n, p, 1); + for (k, (&a, &b)) in got.iter().zip(&want).enumerate() { + assert!( + (a - b).abs() < 1e-12, + "entry {k}: centered distance {a}, uncentered reference {b}" + ); + } + } + + #[test] + fn the_moments_are_bit_identical_across_thread_counts() { + // The chunked reduction fixes its summation tree independently of the + // pool size, but a fixture below `REDUCE_CHUNK` never forms more than one + // chunk and so never exercises the combine. These sizes do: one an exact + // multiple of the chunk length and one that leaves a short final chunk. + // The offset column is carried because a large mean is where a reordered + // sum shows first. + for n in [2 * REDUCE_CHUNK, 10_000] { + let (covs, w) = offset_fixture_n(n); + let (means_one, vars_one) = weighted_moments(&covs, n, 2, &w, 1); + let (means_many, vars_many) = weighted_moments(&covs, n, 2, &w, 4); + for j in 0..2 { + assert_eq!( + means_one[j].to_bits(), + means_many[j].to_bits(), + "n {n}, column {j}: mean {} against {}", + means_one[j], + means_many[j] + ); + assert_eq!( + vars_one[j].to_bits(), + vars_many[j].to_bits(), + "n {n}, column {j}: variance {} against {}", + vars_one[j], + vars_many[j] + ); + } + } + } + + #[test] + fn the_transforms_are_bit_identical_across_thread_counts() { + // The same guarantee at the transform's own output. Mahalanobis reduces a + // second time for the covariance, so it needs its own multi-chunk check + // rather than inheriting the moments one. + for n in [2 * REDUCE_CHUNK, 10_000] { + let (covs, w) = offset_fixture_n(n); + for distance in [Distance::ScaledEuclidean, Distance::Mahalanobis] { + let one = transform(&covs, n, 2, distance, &w, 1); + let many = transform(&covs, n, 2, distance, &w, 4); + assert_eq!(one.len(), many.len()); + for (k, (&a, &b)) in one.iter().zip(&many).enumerate() { + assert_eq!( + a.to_bits(), + b.to_bits(), + "n {n}, {distance:?}, entry {k}: {a} against {b}" + ); + } + } + } + } } diff --git a/src/rust/crates/core/src/lib.rs b/src/rust/crates/core/src/lib.rs index 7146a1a..08fb2f8 100644 --- a/src/rust/crates/core/src/lib.rs +++ b/src/rust/crates/core/src/lib.rs @@ -12,6 +12,7 @@ pub mod linalg; pub mod links; pub mod methods; pub mod qp; +mod stats; pub mod threads; pub mod weights; diff --git a/src/rust/crates/core/src/methods/energy.rs b/src/rust/crates/core/src/methods/energy.rs index bf79f0f..405c5dd 100644 --- a/src/rust/crates/core/src/methods/energy.rs +++ b/src/rust/crates/core/src/methods/energy.rs @@ -24,6 +24,7 @@ use rayon::iter::{IntoParallelIterator, ParallelIterator}; use crate::dist::{Distance, distance_matrix, pairwise}; use crate::qp::osqp::Osqp; use crate::qp::{Convexity, QpBackend, QpOptions, QpSpec, QpStatus, objective}; +use crate::stats::weighted_variance; use crate::threads::get_pool; use super::qp_balance::{ @@ -422,31 +423,6 @@ pub struct EnergyContInputs<'a> { pub qp: QpOptions, } -/// Reliability-weighted variance of a single vector, the denominator matching the -/// per-column variance used by the distance transforms. -fn weighted_variance(x: &[f64], w: &[f64]) -> f64 { - let mut sw = 0.0; - let mut sw2 = 0.0; - let mut swx = 0.0; - let mut swxx = 0.0; - for (&xi, &wi) in x.iter().zip(w) { - sw += wi; - sw2 += wi * wi; - swx += wi * xi; - swxx += wi * xi * xi; - } - if sw <= 0.0 { - return 0.0; - } - let mean = swx / sw; - let denom = 1.0 - sw2 / (sw * sw); - if denom > 0.0 { - ((swxx / sw - mean * mean) / denom).max(0.0) - } else { - 0.0 - } -} - /// Double-center a symmetric distance matrix: `A_ij + grand - row_i - row_j`. fn double_center(d: &[f64], n: usize) -> Vec { let mut row_means = vec![0.0; n]; @@ -1119,4 +1095,81 @@ mod tests { } } } + + /// A deterministic stream on the unit interval from a linear congruential + /// generator. The offset fixture below needs many values with no structure, + /// and generating them here keeps the numbers identical on every platform + /// without reaching for a random-number dependency. + fn lcg_unit(n: usize, seed: u64) -> Vec { + let mut state = seed; + (0..n) + .map(|_| { + state = state + .wrapping_mul(6_364_136_223_846_793_005) + .wrapping_add(1_442_695_040_888_963_407); + (state >> 11) as f64 / 9_007_199_254_740_992.0 + }) + .collect() + } + + /// Fifty exposure values at date-time scale and their non-uniform weights. + /// The column is `offset + spread * z` with the offset the magnitude + /// `as.numeric()` gives a POSIXct and the spread one hour, which is the shape + /// that makes a one-pass variance cancel: the mean is roughly half a million + /// standard deviations from zero. The offset is returned because the test + /// centers by it exactly. + fn offset_exposure() -> (Vec, Vec, f64) { + let n = 50; + let offset = 1.7e9; + let spread = 3600.0; + let z = lcg_unit(n, 20_250_828); + let weight_draws = lcg_unit(n, 987_654_321); + let x = z + .iter() + .map(|&zi| offset + spread * (2.0 * zi - 1.0)) + .collect(); + let w = weight_draws.iter().map(|&vi| 0.25 + 1.5 * vi).collect(); + (x, w, offset) + } + + /// Two-pass reliability-weighted variance: the weighted mean first, then the + /// weighted squared deviations from it. The deviations are formed at the + /// column's own scale rather than as a difference of two large sums, so this + /// stays accurate at any offset and is the reference `weighted_variance` has to + /// reproduce. + fn two_pass_variance(x: &[f64], w: &[f64]) -> f64 { + let sw: f64 = w.iter().sum(); + let sw2: f64 = w.iter().map(|wi| wi * wi).sum(); + let mean: f64 = x.iter().zip(w).map(|(&xi, &wi)| wi * xi).sum::() / sw; + let ss: f64 = x + .iter() + .zip(w) + .map(|(&xi, &wi)| { + let d = xi - mean; + wi * d * d + }) + .sum(); + (ss / sw) / (1.0 - sw2 / (sw * sw)) + } + + #[test] + fn the_exposure_sd_survives_a_date_time_offset() { + // The continuous solver standardizes the exposure by this variance, so an + // error here scales every correlation constraint it goes on to impose. + // Subtracting the offset from a column built as `offset + spread * z` is + // exact in binary floating point, both values being within a factor of + // two of each other, so the centered column holds precisely the + // deviations the stored column has and its two-pass variance is the + // variance being asked for. + let (x, w, offset) = offset_exposure(); + let centered: Vec = x.iter().map(|&xi| xi - offset).collect(); + let want = two_pass_variance(¢ered, &w).sqrt(); + + let got = weighted_variance(&x, &w).sqrt(); + let rel = (got - want).abs() / want; + assert!( + rel < 1e-12, + "exposure sd {got} against the two-pass reference {want}, relative error {rel}" + ); + } } diff --git a/src/rust/crates/core/src/methods/sbw.rs b/src/rust/crates/core/src/methods/sbw.rs index bbf3748..e91deca 100644 --- a/src/rust/crates/core/src/methods/sbw.rs +++ b/src/rust/crates/core/src/methods/sbw.rs @@ -32,6 +32,7 @@ use crate::qp::{ Convexity, PMat, QpError, QpOptions, QpSolution, QpSpec, QpStatus, RoutedSolution, solve_psd, }; +use crate::stats::weighted_variance; use super::qp_balance::{ConstraintBuilder, ZERO_SW, expand_and_floor, group_normalized}; @@ -418,32 +419,6 @@ pub struct SbwContInputs<'a> { pub qp: QpOptions, } -/// Reliability-weighted variance of a vector, matching the denominator the -/// distance transforms use, so a bounded weighted product of standardized columns -/// reads as a bounded correlation. -fn weighted_variance(x: &[f64], w: &[f64]) -> f64 { - let mut sw = 0.0; - let mut sw2 = 0.0; - let mut swx = 0.0; - let mut swxx = 0.0; - for (&xi, &wi) in x.iter().zip(w) { - sw += wi; - sw2 += wi * wi; - swx += wi * xi; - swxx += wi * xi * xi; - } - if sw <= 0.0 { - return 0.0; - } - let mean = swx / sw; - let denom = 1.0 - sw2 / (sw * sw); - if denom > 0.0 { - ((swxx / sw - mean * mean) / denom).max(0.0) - } else { - 0.0 - } -} - /// Solve a continuous-exposure stable balancing problem. pub fn solve_cont( inputs: &SbwContInputs<'_>, @@ -1258,4 +1233,81 @@ mod tests { let err = solve_discrete(&inputs, &|| false).unwrap_err(); assert_eq!(err, SbwError::BackendUnavailable("clarabel")); } + + /// A deterministic stream on the unit interval from a linear congruential + /// generator. The offset fixture below needs many values with no structure, + /// and generating them here keeps the numbers identical on every platform + /// without reaching for a random-number dependency. + fn lcg_unit(n: usize, seed: u64) -> Vec { + let mut state = seed; + (0..n) + .map(|_| { + state = state + .wrapping_mul(6_364_136_223_846_793_005) + .wrapping_add(1_442_695_040_888_963_407); + (state >> 11) as f64 / 9_007_199_254_740_992.0 + }) + .collect() + } + + /// Fifty exposure values at date-time scale and their non-uniform weights. + /// The column is `offset + spread * z` with the offset the magnitude + /// `as.numeric()` gives a POSIXct and the spread one hour, which is the shape + /// that makes a one-pass variance cancel: the mean is roughly half a million + /// standard deviations from zero. The offset is returned because the test + /// centers by it exactly. + fn offset_exposure() -> (Vec, Vec, f64) { + let n = 50; + let offset = 1.7e9; + let spread = 3600.0; + let z = lcg_unit(n, 20_250_828); + let weight_draws = lcg_unit(n, 987_654_321); + let x = z + .iter() + .map(|&zi| offset + spread * (2.0 * zi - 1.0)) + .collect(); + let w = weight_draws.iter().map(|&vi| 0.25 + 1.5 * vi).collect(); + (x, w, offset) + } + + /// Two-pass reliability-weighted variance: the weighted mean first, then the + /// weighted squared deviations from it. The deviations are formed at the + /// column's own scale rather than as a difference of two large sums, so this + /// stays accurate at any offset and is the reference `weighted_variance` has to + /// reproduce. + fn two_pass_variance(x: &[f64], w: &[f64]) -> f64 { + let sw: f64 = w.iter().sum(); + let sw2: f64 = w.iter().map(|wi| wi * wi).sum(); + let mean: f64 = x.iter().zip(w).map(|(&xi, &wi)| wi * xi).sum::() / sw; + let ss: f64 = x + .iter() + .zip(w) + .map(|(&xi, &wi)| { + let d = xi - mean; + wi * d * d + }) + .sum(); + (ss / sw) / (1.0 - sw2 / (sw * sw)) + } + + #[test] + fn the_exposure_sd_survives_a_date_time_offset() { + // The continuous solver standardizes the exposure by this variance, so an + // error here scales every correlation constraint it goes on to impose. + // Subtracting the offset from a column built as `offset + spread * z` is + // exact in binary floating point, both values being within a factor of + // two of each other, so the centered column holds precisely the + // deviations the stored column has and its two-pass variance is the + // variance being asked for. + let (x, w, offset) = offset_exposure(); + let centered: Vec = x.iter().map(|&xi| xi - offset).collect(); + let want = two_pass_variance(¢ered, &w).sqrt(); + + let got = weighted_variance(&x, &w).sqrt(); + let rel = (got - want).abs() / want; + assert!( + rel < 1e-12, + "exposure sd {got} against the two-pass reference {want}, relative error {rel}" + ); + } } diff --git a/src/rust/crates/core/src/qp/clarabel.rs b/src/rust/crates/core/src/qp/clarabel.rs index a844afa..ef12b3a 100644 --- a/src/rust/crates/core/src/qp/clarabel.rs +++ b/src/rust/crates/core/src/qp/clarabel.rs @@ -64,7 +64,7 @@ impl QpBackend for Clarabel { // own dimension check accepts it. With constraint rows still present it // returns an infeasibility certificate against rows no variable can satisfy; // with no rows either, the KKT system is empty and its factorization indexes - // the first entry of nothing. OSQP's data validation refuses the same spec, + // the first entry of nothing. The OSQP backend refuses the same spec, // and every method turns that refusal into a degenerate result carrying a // failure status, so refusing it here keeps the two backends interchangeable // and keeps the R layer raising one condition rather than two. @@ -430,7 +430,7 @@ mod tests { #[test] fn a_spec_with_no_decision_variables_is_refused_by_both_backends() { - // OSQP's data validation refuses a spec with no variables, and the methods + // The OSQP backend refuses a spec with no variables, and the methods // turn that refusal into a degenerate result carrying a failure status. // Clarabel's own dimension check accepts it, so without a guard the same // spec would reach the R layer as an infeasibility certificate under one diff --git a/src/rust/crates/core/src/qp/osqp.rs b/src/rust/crates/core/src/qp/osqp.rs index 2392c1c..ef762f6 100644 --- a/src/rust/crates/core/src/qp/osqp.rs +++ b/src/rust/crates/core/src/qp/osqp.rs @@ -46,6 +46,18 @@ impl QpBackend for Osqp { interrupt: &dyn Fn() -> bool, ) -> Result { let n = spec.n; + // A spec with no decision variables has nothing to solve for. OSQP's C + // core validates the same condition, but it prints its complaint to + // stdout before returning an error that carries no text of its own, so a + // relayed refusal is an empty `DataInvalid` preceded by a line no caller + // asked for and none can suppress. The refusal therefore belongs to the + // wrapper, where it can be named and where the C core is never reached. + if n == 0 { + return Err(QpError::Setup( + "the problem has no decision variables".to_string(), + )); + } + let (p_indptr, p_indices, p_values) = upper_triangular_csc(&spec.p, n); let p_csc = CscMatrix { nrows: n, @@ -389,4 +401,46 @@ mod tests { .expect("setup succeeds"); assert!(sol.status.is_solved()); } + + /// A spec with no decision variables and `rows` constraint rows. This is the + /// shape a stable-balancing solve assembles when its active set turns out + /// empty: the balance rows survive and demand a group total from nothing at + /// all. + fn empty_spec(rows: usize) -> QpSpec { + QpSpec { + n: 0, + m: rows, + p: PMat::Diagonal(vec![]), + q: vec![], + a_indptr: vec![0], + a_indices: vec![], + a_values: vec![], + l: vec![1.0; rows], + u: vec![1.0; rows], + convexity: Convexity::Psd, + } + } + + #[test] + fn a_spec_with_no_decision_variables_is_refused_before_the_c_core() { + // OSQP's C core validates that the variable count is positive, but it + // reports the refusal by printing to stdout before it returns, so every + // solve of this shape prints a line no caller asked for and none can + // suppress. The wrapper therefore refuses the spec on its own terms and + // never reaches the C core, which is observable in the refusal message: + // the wrapper names the missing decision variables, where the relayed C + // refusal is an empty `DataInvalid`. + for rows in [0usize, 1, 3] { + let err = Osqp + .solve(&empty_spec(rows), &QpOptions::default(), &|| false) + .unwrap_err(); + let QpError::Setup(message) = &err else { + panic!("{rows} rows: expected a setup refusal, got {err:?}"); + }; + assert!( + message.contains("decision variable"), + "{rows} rows: refusal message {message:?} does not name the missing decision variables" + ); + } + } } diff --git a/src/rust/crates/core/src/stats.rs b/src/rust/crates/core/src/stats.rs new file mode 100644 index 0000000..690f18b --- /dev/null +++ b/src/rust/crates/core/src/stats.rs @@ -0,0 +1,67 @@ +//! Weighted moments shared by the standardizing statistics. +//! +//! Every method that standardizes a covariate or an exposure needs the same +//! reliability-weighted variance, and each one needs it computed in a way that +//! survives a large offset. The compact one-pass form, `sum_i w_i x_i^2 / sw` +//! minus the squared mean, subtracts two quantities that agree in their leading +//! digits whenever the mean is large against the spread, so the digits carrying +//! the variance are exactly the ones the subtraction destroys. A date-time +//! covariate is the ordinary case rather than an exotic one: `as.numeric()` on a +//! POSIXct is about 1.7e9, and an hour of spread around that leaves only a few +//! digits of the double intact, which cost the standardizing standard deviation +//! a relative error near 3e-4. Accumulating deviations from the weighted mean +//! instead forms every term at the spread's own scale, so the accuracy no longer +//! depends on where the column sits. +//! +//! Sharing the denominator as well as the deviations matters because the methods +//! compare against each other: a column standardized by the distance transforms +//! and the same column standardized inside a continuous solve have to agree, so +//! that a bounded weighted product of standardized columns reads as a bounded +//! correlation. + +/// Finish a reliability-weighted variance from a weighted sum of squared +/// deviations and the weight totals. +/// +/// The denominator is the frequency-weight-free (reliability) form +/// `1 - sum_i wn_i^2` with normalized weights `wn = w / sum(w)`, which reduces to +/// the usual `n - 1` sample variance when the weights are equal. A non-positive +/// total weight reports zero, as does a single dominant weight that drives the +/// denominator to zero or below, and a sum of squares that rounds negative is +/// clamped up. +pub(crate) fn reliability_variance(ss: f64, sw: f64, sw2: f64) -> f64 { + if sw <= 0.0 { + return 0.0; + } + let denom = 1.0 - sw2 / (sw * sw); + if denom > 0.0 { + ((ss / sw) / denom).max(0.0) + } else { + 0.0 + } +} + +/// Reliability-weighted variance of a single vector. +/// +/// The weight totals and the weighted mean come from the first pass, the squared +/// deviations from that mean from the second. A vector of no positive total +/// weight has variance zero. +pub(crate) fn weighted_variance(x: &[f64], w: &[f64]) -> f64 { + let mut sw = 0.0; + let mut sw2 = 0.0; + let mut swx = 0.0; + for (&xi, &wi) in x.iter().zip(w) { + sw += wi; + sw2 += wi * wi; + swx += wi * xi; + } + if sw <= 0.0 { + return 0.0; + } + let mean = swx / sw; + let mut ss = 0.0; + for (&xi, &wi) in x.iter().zip(w) { + let d = xi - mean; + ss += wi * d * d; + } + reliability_variance(ss, sw, sw2) +} diff --git a/src/rust/crates/savvy/src/convert.rs b/src/rust/crates/savvy/src/convert.rs index 4609925..759bf1c 100644 --- a/src/rust/crates/savvy/src/convert.rs +++ b/src/rust/crates/savvy/src/convert.rs @@ -127,8 +127,10 @@ pub fn parse_entropy_options(options: ListSexp) -> savvy::Result Ok(resolved) } -/// Resolved solver options for the inverse probability tilting entrypoints. -pub struct IptOptions { +/// Resolved solver options shared by the inverse probability tilting and +/// covariate balancing propensity score entrypoints, which reach the same core +/// solver for their score equations. +pub struct ScoreOptions { pub threads: usize, pub max_iter: usize, pub tol: f64, @@ -137,12 +139,11 @@ pub struct IptOptions { /// The defaults the boundary resolves when the option list omits a value, reached /// by the same two routes as the entropy defaults above. /// -/// This parser serves the covariate balancing propensity score entrypoints as well -/// as the tilting ones, so the cap here is the budget for both families, and both -/// R constructors leave `max_iterations` unset by default. It matches the entropy -/// cap so that methods solving the same fit at the same tolerance are given the -/// same budget to reach it. -impl Default for IptOptions { +/// The cap is the budget for both families that solve here, and every one of +/// their R constructors leaves `max_iterations` unset by default. It matches the +/// entropy cap so that methods solving the same fit at the same tolerance are +/// given the same budget to reach it. +impl Default for ScoreOptions { fn default() -> Self { Self { threads: balancing_core::available_threads().0, @@ -152,10 +153,10 @@ impl Default for IptOptions { } } -/// Parse the option list for an inverse probability tilting solve, rejecting -/// unknown names. The link and estimand cross the boundary as their own -/// arguments, so the option list carries only the solver tuning. -pub fn parse_ipt_options(options: ListSexp) -> savvy::Result { +/// Parse the option list for a score equation solve, rejecting unknown names. +/// The link and estimand cross the boundary as their own arguments, so the +/// option list carries only the solver tuning. +pub fn parse_score_options(options: ListSexp) -> savvy::Result { const ALLOWED: [&str; 3] = ["threads", "max_iterations", "convergence_tolerance"]; for name in options.names_iter() { @@ -167,7 +168,7 @@ pub fn parse_ipt_options(options: ListSexp) -> savvy::Result { } } - let mut resolved = IptOptions::default(); + let mut resolved = ScoreOptions::default(); if let Some(value) = options.get("threads") { resolved.threads = option_usize(value, "threads")?.max(1); @@ -597,20 +598,39 @@ mod tests { // The iteration cap the boundary resolves is a portability contract rather // than a tuning preference, so it is pinned here. An option list arriving - // without `max_iterations` leaves the parser at these values, and an entropy - // or tilting fit that needs more iterations than the cap allows stops short - // of its tolerance and warns. The solvers walk a different floating-point - // path on each platform, so a cap tight enough that a fit converges just - // under it on one platform leaves the same fit warning on another. The cap - // has to be wide enough that the platform spread sits well inside it. + // without `max_iterations` leaves the parser at these values, and an entropy, + // tilting or covariate balancing fit that needs more iterations than the cap + // allows stops short of its tolerance and warns. The solvers walk a different + // floating-point path on each platform, so a cap tight enough that a fit + // converges just under it on one platform leaves the same fit warning on + // another. The cap has to be wide enough that the platform spread sits well + // inside it. The tolerance is pinned alongside it because the two halves only + // mean something together: a budget is generous or tight only relative to the + // convergence target it is spent reaching, and the documentation states both, + // so a change to either has to be a deliberate one. #[test] - fn the_entropy_default_iteration_cap_absorbs_platform_spread() { + fn the_entropy_solver_defaults_pin_the_iteration_cap_and_tolerance() { assert_eq!(EntropyOptions::default().max_iter, 1000); + assert_eq!(EntropyOptions::default().tol, 1e-10); } #[test] - fn the_tilting_default_iteration_cap_absorbs_platform_spread() { - assert_eq!(IptOptions::default().max_iter, 1000); + fn the_score_solver_defaults_pin_the_iteration_cap_and_tolerance() { + assert_eq!(ScoreOptions::default().max_iter, 1000); + assert_eq!(ScoreOptions::default().tol, 1e-10); + } + + // The quadratic-program defaults reach the boundary by a different route: + // the parsers do not carry their own copies, they start from + // `QpOptions::default()` and overwrite only what the option list names. That + // makes the core's defaults the ones the sbw, energy and cfd fits run under, + // and the ones the documentation states, so they are pinned here too. + #[test] + fn the_quadratic_program_defaults_pin_the_tolerances_and_iteration_cap() { + let qp = QpOptions::default(); + assert_eq!(qp.eps_abs, 1e-8); + assert_eq!(qp.eps_rel, 1e-8); + assert_eq!(qp.max_iter, 200_000); } #[test] diff --git a/src/rust/crates/savvy/src/interrupt.rs b/src/rust/crates/savvy/src/interrupt.rs index 0a9238a..f0fce5f 100644 --- a/src/rust/crates/savvy/src/interrupt.rs +++ b/src/rust/crates/savvy/src/interrupt.rs @@ -1,24 +1,95 @@ //! User-interrupt polling that never unwinds through Rust. //! -//! `R_CheckUserInterrupt` longjmps when an interrupt is pending, which would -//! skip Rust destructors if it fired inside the solver. Running it under -//! `R_ToplevelExec` contains the longjmp: the wrapper returns `FALSE` when the -//! check jumped, which the solver reads as a request to stop and then unwinds -//! normally. The check runs only on the main thread, between solver iterations, -//! never inside a parallel region. +//! The solvers poll between iterations, on the thread that entered the FFI and +//! never inside a parallel region, and they only need an answer: the core +//! unwinds normally, reports an `interrupted` flag, and `balance()` re-signals +//! with `rlang::interrupt()` once the call returns. Detection is therefore the +//! whole job here. `R_CheckUserInterrupt` delivers an interrupt by longjmp, +//! which would skip Rust destructors, so it is never called bare. +//! +//! On Unix the detection is two reads, mirroring R's own test. +//! `R_interrupts_pending` is the flag R's `SIGINT` handler sets, and +//! `R_interrupts_suspended` gates it the way R gates it: while interrupts are +//! suspended, R records the interrupt and returns rather than jumping, so a +//! poll must report nothing pending. Reporting one anyway would stop the solve +//! and then hand `balance()` a stopped fit that `rlang::interrupt()` declines +//! to signal, which would fall through to the non-convergence path. R declares +//! both flags `LibExtern`, so both are exported. Both are read through an +//! `AtomicI32` with relaxed ordering and neither is ever written. +//! +//! Reading the flags pushes nothing on R's context stack, which is the reason +//! for the platform split. The earlier implementation wrapped +//! `R_CheckUserInterrupt` in `R_ToplevelExec` on every platform to contain the +//! longjmp, and R's profiler does not survive a `CTXT_TOPLEVEL` context pushed +//! inside a `.Call`. Under `profvis` on macOS a `SIGPROF` sample landed in the +//! pop window, at the instruction after `Rf_endcontext` returned and before +//! `R_ToplevelContext` was restored; R's `findProfContext` walked a null +//! context pointer and the session died with a segmentation fault inside the +//! entropy solver. That window is well under a microsecond, so the crash was +//! rare, but every solver iteration of every profiled fit was exposed to it. +//! +//! Windows keeps the `R_ToplevelExec` path, because there a user's interrupt +//! is registered by `R_ProcessEvents` from inside `R_CheckUserInterrupt` +//! rather than by a signal handler, and polling the flag alone would miss it. +//! That branch therefore keeps the exposure: Windows profiles on a thread that +//! suspends the R thread and walks its contexts too, so the race is narrowed +//! to one platform rather than removed. +//! +//! One thing the Unix path gives up: `R_CheckUserInterrupt` also ran +//! `R_ProcessEvents`, which services polled GUI events and `setTimeLimit()` +//! checks. Neither matters to a solve, but a time limit set around +//! `balance()` now fires when the call returns rather than at the next +//! iteration. +#[cfg(windows)] use std::ffi::c_void; +#[cfg(not(windows))] +use std::sync::atomic::{AtomicI32, Ordering}; +// R names these in its own style, which is not Rust's convention for statics. +#[cfg(not(windows))] +#[allow(non_upper_case_globals)] +unsafe extern "C" { + /// Nonzero once R's `SIGINT` handler has recorded an interrupt, until R + /// delivers it. + static mut R_interrupts_pending: std::ffi::c_int; + /// Nonzero while R has interrupt delivery suspended. + static mut R_interrupts_suspended: std::ffi::c_int; +} + +#[cfg(windows)] unsafe extern "C" { fn R_CheckUserInterrupt(); fn R_ToplevelExec(fun: extern "C" fn(*mut c_void), data: *mut c_void) -> i32; } +#[cfg(windows)] extern "C" fn check(_data: *mut c_void) { unsafe { R_CheckUserInterrupt() }; } /// Return `true` when a user interrupt is pending. +#[cfg(not(windows))] +pub fn pending() -> bool { + // Both flags are written by R's signal handler, which is another thread of + // execution as far as the abstract machine is concerned, so a plain or + // volatile read of them is a data race. Reading them as relaxed atomics is + // the defined way to say "some value that was written, no ordering implied", + // which is exactly what a poll wants: no synchronization is needed, only a + // read the compiler may not hoist out of the solver's loop or invent a value + // for. `c_int` is `i32` on every target this builds for, and `AtomicI32` has + // the layout and alignment of `i32`, so the cast reads the same object. + // + // `R_interrupts_suspended` is `Rboolean` in R's headers, an int-sized enum on + // every supported target, and is read here as a `c_int`. + unsafe { + (*(&raw const R_interrupts_suspended).cast::()).load(Ordering::Relaxed) == 0 + && (*(&raw const R_interrupts_pending).cast::()).load(Ordering::Relaxed) != 0 + } +} + +/// Return `true` when a user interrupt is pending. +#[cfg(windows)] pub fn pending() -> bool { // `R_ToplevelExec` returns TRUE (nonzero) when `check` completed and FALSE // (zero) when it longjmped, which happens exactly when an interrupt fired. diff --git a/src/rust/crates/savvy/src/lib.rs b/src/rust/crates/savvy/src/lib.rs index 9eb60a7..c2ecd57 100644 --- a/src/rust/crates/savvy/src/lib.rs +++ b/src/rust/crates/savvy/src/lib.rs @@ -29,8 +29,8 @@ use savvy::{ use convert::{ parse_binary_estimand, parse_cbps_estimand, parse_cbps_multi_estimand, parse_cfd_options, - parse_distance, parse_entropy_options, parse_ipt_options, parse_kernel, parse_kernel_options, - parse_link, parse_multi_estimand, parse_qp_options, parse_sbw_norm, parse_sbw_options, + parse_distance, parse_entropy_options, parse_kernel, parse_kernel_options, parse_link, + parse_multi_estimand, parse_qp_options, parse_sbw_norm, parse_sbw_options, parse_score_options, parse_smoothness, real_matrix, real_vector, require_binary_treat, require_dense_levels, require_finite, }; @@ -762,7 +762,7 @@ fn solve_ipt( ) -> savvy::Result { let n = s_weights.len(); let p = covs.len().checked_div(n).unwrap_or(0); - let opts = parse_ipt_options(options)?; + let opts = parse_score_options(options)?; let link = parse_link(link)?; let estimand = parse_binary_estimand(estimand)?; @@ -821,7 +821,7 @@ fn solve_ipt_multi( ) -> savvy::Result { let n = s_weights.len(); let p = covs.len().checked_div(n).unwrap_or(0); - let opts = parse_ipt_options(options)?; + let opts = parse_score_options(options)?; let link = parse_link(link)?; if n == 0 || covs.len() != n * p { @@ -1075,7 +1075,7 @@ fn solve_cbps( let n = s_weights.len(); let p_mod = covs_mod.len().checked_div(n).unwrap_or(0); let p_bal = covs_bal.len().checked_div(n).unwrap_or(0); - let opts = parse_ipt_options(options)?; + let opts = parse_score_options(options)?; let link = parse_link(link)?; let estimand = parse_cbps_estimand(estimand)?; @@ -1276,7 +1276,7 @@ fn solve_cbps_multi( ) -> savvy::Result { let n = s_weights.len(); let p = covs.len().checked_div(n).unwrap_or(0); - let opts = parse_ipt_options(options)?; + let opts = parse_score_options(options)?; let link = parse_link(link)?; let estimand = parse_cbps_multi_estimand(estimand)?; @@ -1340,7 +1340,7 @@ fn solve_cbps_cont( ) -> savvy::Result { let n = s_weights.len(); let p = covs.len().checked_div(n).unwrap_or(0); - let opts = parse_ipt_options(options)?; + let opts = parse_score_options(options)?; if n == 0 || covs.len() != n * p { return Err(savvy::Error::new(format!( diff --git a/tests/testthat/_snaps/errors.md b/tests/testthat/_snaps/errors.md index 522e87f..1ad4a6f 100644 --- a/tests/testthat/_snaps/errors.md +++ b/tests/testthat/_snaps/errors.md @@ -82,13 +82,13 @@ ! Inverse probability tilting does not support a "continuous" exposure. i Supported exposure types are "binary" and "categorical". -# balancing_estimand_error: a categorical att without focal_level +# balancing_estimand_error: a categorical att without .focal_level Code balance(data, exposure, c(x1, x2), method = bw_entropy(), estimand = "att") Condition Error in `balance()`: - ! `focal_level` is required for the "att" estimand with a categorical exposure. + ! `.focal_level` is required for the "att" estimand with a categorical exposure. i Supply the exposure level to target, one of "a", "b", and "c". # causalgenerics_forced_exposure_type: forced type contradicts data @@ -171,7 +171,7 @@ Code balance(data, exposure, c(x1, x2), method = bw_entropy(), estimand = "att", - focal_level = 1) + .focal_level = 1) Condition Error in `balance()`: ! Balancing needs an exposure with at least two levels. diff --git a/tests/testthat/_snaps/ipw-deli.md b/tests/testthat/_snaps/ipw-deli.md new file mode 100644 index 0000000..45dec2a --- /dev/null +++ b/tests/testthat/_snaps/ipw-deli.md @@ -0,0 +1,36 @@ +# balancing_internal_error: a matrix block of the wrong width + + Code + stack_psi_blocks(list(wide_enough, too_narrow), n) + Condition + Error in `stack_psi_blocks()`: + ! Every block of the stacked estimating function must cover every observation. + x Block 2 carries 2 columns for a sample of 4. + +# balancing_internal_error: a bare-vector block of the wrong length + + Code + stack_psi_blocks(list(wide_enough, c(1, 2)), n) + Condition + Error in `stack_psi_blocks()`: + ! Every block of the stacked estimating function must cover every observation. + x Block 2 holds 2 values for a sample of 4. + +# balancing_internal_error: a bare-vector block the reduction refuses + + Code + sum_psi_blocks(list(wide_enough, c(1, 2)), n) + Condition + Error in `sum_psi_blocks()`: + ! Every block of the stacked estimating function must cover every observation. + x Block 2 holds 2 values for a sample of 4. + +# balancing_internal_error: a block that does not hold doubles + + Code + sum_psi_blocks(list(wide_enough, seq_len(n)), n) + Condition + Error in `sum_psi_blocks()`: + ! Every block of the stacked estimating function must hold doubles. + x Block 2 holds values. + diff --git a/tests/testthat/_snaps/ipw.md b/tests/testthat/_snaps/ipw.md index 1d070c6..d0938e7 100644 --- a/tests/testthat/_snaps/ipw.md +++ b/tests/testthat/_snaps/ipw.md @@ -100,6 +100,26 @@ i Supply a model of class or . x `outcome_mod` has class . +# ipw() rejects an outcome model with an aliased exposure coefficient + + Code + stop(cnd) + Condition + Error in `ipw()`: + ! `outcome_mod` must have an estimate for every coefficient. + x It is rank deficient, so the coefficient "I(2 * exposure)" is not estimable. + i Drop the aliased term from `outcome_mod` and fit it again before calling `ipw()`. + +# ipw() rejects an outcome model with an aliased covariate coefficient + + Code + stop(cnd) + Condition + Error in `ipw()`: + ! `outcome_mod` must have an estimate for every coefficient. + x It is rank deficient, so the coefficient "I(2 * x1)" is not estimable. + i Drop the aliased term from `outcome_mod` and fit it again before calling `ipw()`. + # ipw() rejects an outcome model fitted without weights Code @@ -187,6 +207,20 @@ x The reported weights move along 1 unidentified direction, which carries the deficiency into the effect standard errors. i Refit the weights on covariates whose constraint columns are independent, or see the inference vignette for a bootstrap workflow. +# the non-finite refusal reads as the package's own + + Code + stacked_covariance(nonfinite_stack(n), theta, n, jacobian = diag(c(2, 1, 0.5))) + Condition + Error: + ! The stacked variance could not be computed for this outcome model. + x The stacked estimating functions are not finite at the fitted parameters. + i The stack carries the balancing fit's estimating equations alongside the outcome model's score, so a non-finite weight, or an outcome the model cannot score at those weights, reaches it as one of these values. + i See the inference vignette for a bootstrap workflow. + Caused by error in `deli::compute_sandwich()`: + ! `stacked_equations` returned non-finite values at `theta`. + i Both the bread and the meat are built from this return, so a non-finite value in it leaves the whole sandwich undefined. + # ipw() names the rank of a deficient fit block deli refuses Code diff --git a/tests/testthat/_snaps/messages.md b/tests/testthat/_snaps/messages.md index 3e4da25..1e62b9a 100644 --- a/tests/testthat/_snaps/messages.md +++ b/tests/testthat/_snaps/messages.md @@ -14,7 +14,7 @@ Observations: 500 Solver: did not converge in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0000 (standardized mean difference) + Largest imbalance: <1e-7 (standardized mean difference) # balancing_balance_warning: achieved balance exceeds the tolerance @@ -24,7 +24,7 @@ Condition Warning in `balance()`: The achieved balance exceeds the requested tolerance. - x The largest imbalance is 0.1751. + x The largest imbalance is 0.175. i Raise `tolerance` in `balance_terms()`, lower the moments, or drop interactions. Output -- Entropy balancing ----------------------------------------------------------- @@ -33,7 +33,7 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0.1) - Largest imbalance: 0.1751 (correlation) + Largest imbalance: 0.175 (correlation) # balancing_ignored_argument_warning: two_step without over_identified @@ -51,7 +51,7 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0000 (standardized mean difference) + Largest imbalance: <1e-7 (standardized mean difference) # balancing_ignored_argument_warning: over_identified for a categorical exposure @@ -69,7 +69,7 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0000 (standardized mean difference) + Largest imbalance: <1e-7 (standardized mean difference) # balancing_ignored_argument_warning: over_identified for a continuous exposure @@ -87,7 +87,7 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0000 (correlation) + Largest imbalance: <1e-7 (correlation) # balancing_ignored_argument_warning: link for a continuous exposure @@ -104,7 +104,7 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0000 (correlation) + Largest imbalance: <1e-7 (correlation) # balancing_ignored_argument_warning: every argument a categorical fit ignores @@ -125,7 +125,7 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0000 (standardized mean difference) + Largest imbalance: <1e-7 (standardized mean difference) # balancing_ignored_argument_warning: a clarabel pin the energy kernel cannot honor @@ -164,14 +164,14 @@ Constraints: 2 terms (tolerance 0) Largest imbalance: 0.0118 (standardized mean difference) -# balancing_ignored_argument_warning: focal_level with a pooled estimand +# balancing_ignored_argument_warning: .focal_level with a pooled estimand Code balance(data, exposure, c(x1, x2), method = bw_entropy(), estimand = "ate", - focal_level = 1) + .focal_level = 1) Condition Warning in `balance()`: - `focal_level` applies to the "att" and "atc" estimands and is ignored. + `.focal_level` applies to the "att" and "atc" estimands and is ignored. i The "ate" estimand reweights every exposure group rather than holding one fixed. Output -- Entropy balancing ----------------------------------------------------------- @@ -180,7 +180,7 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0000 (standardized mean difference) + Largest imbalance: <1e-7 (standardized mean difference) # balancing_class_downgrade_warning: mismatched estimands diff --git a/tests/testthat/_snaps/method-cbps.md b/tests/testthat/_snaps/method-cbps.md index 93d99d6..382e449 100644 --- a/tests/testthat/_snaps/method-cbps.md +++ b/tests/testthat/_snaps/method-cbps.md @@ -10,5 +10,5 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0000 (standardized mean difference) + Largest imbalance: <1e-7 (standardized mean difference) diff --git a/tests/testthat/_snaps/method-cfd.md b/tests/testthat/_snaps/method-cfd.md index d0c4e59..dd52edf 100644 --- a/tests/testthat/_snaps/method-cfd.md +++ b/tests/testthat/_snaps/method-cfd.md @@ -1,3 +1,21 @@ +# the ignored-tolerance warning records its class and printed tolerance + + Code + balance(data, exposure, c(x1, x2), method = bw_cfd(), estimand = "ate", + constraints = balance_terms(tolerance = 0.1)) + Condition + Warning in `method(fit_method, balancing::bw_cfd)`: + `tolerance` relaxes added constraints, but this fit has none to relax. + i Drop `tolerance` from `balance_terms()`, or add constraints with `moments` or `interactions`, or with `quantiles` for a discrete exposure. + Output + -- Characteristic function distance balancing ---------------------------------- + Exposure: "exposure" (binary) + Estimand: "ate" + Observations: 150 + Solver: converged in iterations + Constraints: 2 terms (tolerance 0) + Largest imbalance: 0.0329 (standardized mean difference) + # a kernel balancing fit prints its summary block Code @@ -10,5 +28,5 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0051 (standardized mean difference) + Largest imbalance: 0.00515 (standardized mean difference) diff --git a/tests/testthat/_snaps/method-energy.md b/tests/testthat/_snaps/method-energy.md index eab7e2f..d159c2d 100644 --- a/tests/testthat/_snaps/method-energy.md +++ b/tests/testthat/_snaps/method-energy.md @@ -5,15 +5,15 @@ constraints = balance_terms(tolerance = 0.1)) Condition Warning in `method(fit_method, balancing::bw_energy)`: - `tolerance` relaxes added moment constraints, but this fit has none to relax. - i Drop `tolerance` from `balance_terms()`, or add moment constraints with `moments`, `quantiles`, or `interactions` for a discrete exposure. + `tolerance` relaxes added constraints, but this fit has none to relax. + i Drop `tolerance` from `balance_terms()`, or add constraints with `moments` or `interactions`, or with `quantiles` for a discrete exposure. Output -- Energy balancing ------------------------------------------------------------ Exposure: "exposure" (binary) Estimand: "ate" Observations: 150 Solver: converged in iterations - Constraints: 2 terms (tolerance 0.1) + Constraints: 2 terms (tolerance 0) Largest imbalance: 0.0437 (standardized mean difference) # a continuous tolerance warns and is ignored @@ -23,16 +23,16 @@ constraints = balance_terms(tolerance = 0.1)) Condition Warning in `method(fit_method, balancing::bw_energy)`: - `tolerance` relaxes added moment constraints, but this fit has none to relax. - i Drop `tolerance` from `balance_terms()`, or add moment constraints with `moments`, `quantiles`, or `interactions` for a discrete exposure. + `tolerance` relaxes added constraints, but this fit has none to relax. + i Drop `tolerance` from `balance_terms()`, or add constraints with `moments` or `interactions`, or with `quantiles` for a discrete exposure. Output -- Energy balancing ------------------------------------------------------------ Exposure: "exposure" (continuous) Estimand: "ate" Observations: 500 Solver: converged in iterations - Constraints: 2 terms (tolerance 0.1) - Largest imbalance: 0.1882 (correlation) + Constraints: 2 terms (tolerance 0) + Largest imbalance: 0.188 (correlation) # an infeasible constraint set raises balancing_infeasible_error diff --git a/tests/testthat/_snaps/method-ipt.md b/tests/testthat/_snaps/method-ipt.md index 41aa028..5c5a5c2 100644 --- a/tests/testthat/_snaps/method-ipt.md +++ b/tests/testthat/_snaps/method-ipt.md @@ -10,5 +10,5 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0000 (standardized mean difference) + Largest imbalance: <1e-7 (standardized mean difference) diff --git a/tests/testthat/_snaps/method-sbw.md b/tests/testthat/_snaps/method-sbw.md index 7118f44..eab9213 100644 --- a/tests/testthat/_snaps/method-sbw.md +++ b/tests/testthat/_snaps/method-sbw.md @@ -39,5 +39,5 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0.05) - Largest imbalance: 0.1000 (standardized mean difference) + Largest imbalance: 0.1 (standardized mean difference) diff --git a/tests/testthat/_snaps/print.md b/tests/testthat/_snaps/print.md index 3bd067d..4fc1a35 100644 --- a/tests/testthat/_snaps/print.md +++ b/tests/testthat/_snaps/print.md @@ -9,7 +9,7 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0000 (standardized mean difference) + Largest imbalance: <1e-7 (standardized mean difference) # summary() of a binary ate fit is stable @@ -22,22 +22,22 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0000 (standardized mean difference) + Largest imbalance: <1e-7 (standardized mean difference) -- Weights -- Range: 0.220 to 3.122 Mean: 1.000 - Coefficient of variation: 0.398 + Coefficient of variation: 0.40 -- Balance -- - term kind statistic group unweighted weighted tolerance - 1 x1 moment smd 1 0.552 1.24e-11 0 - 2 x2 moment smd 1 0.416 1.42e-11 0 - within_tolerance - 1 TRUE - 2 TRUE + term kind statistic group unweighted weighted tolerance + 1 x1 moment smd 1 0.552 <1e-7 0 + 2 x2 moment smd 1 0.416 <1e-7 0 + within_tolerance + 1 TRUE + 2 TRUE # print() of a binary att fit renders the focal level @@ -50,7 +50,7 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0000 (standardized mean difference) + Largest imbalance: <1e-7 (standardized mean difference) # print() of a continuous ate fit is stable @@ -63,7 +63,7 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0000 (correlation) + Largest imbalance: <1e-7 (correlation) # print() of a categorical ate fit lists every level @@ -76,7 +76,20 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0000 (standardized mean difference) + Largest imbalance: <1e-7 (standardized mean difference) + +# print() of a fit whose factor lost a level is stable + + Code + print(fit) + Output + -- Entropy balancing ----------------------------------------------------------- + Exposure: "exposure" (binary) + Estimand: "ate" + Observations: 500 + Solver: converged in iterations + Constraints: 4 terms (tolerance 0) + Largest imbalance: <1e-7 (standardized mean difference) # print() of an energy fit is stable @@ -108,14 +121,14 @@ Range: 0.027 to 7.351 Mean: 1.000 - Coefficient of variation: 0.769 + Coefficient of variation: 0.77 Weights at the minimum-weight floor: of 500 -- Balance -- - term kind statistic group unweighted weighted tolerance within_tolerance - 1 x1 moment smd 1 0.552 0.0118 0 FALSE - 2 x2 moment smd 1 0.416 0.00511 0 FALSE + term kind statistic group unweighted weighted tolerance within_tolerance + 1 x1 moment smd 1 0.552 0.0118 0 FALSE + 2 x2 moment smd 1 0.416 0.00511 0 FALSE # summary() of a stable balancing fit reports the weight floor count @@ -128,20 +141,20 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0.05) - Largest imbalance: 0.1000 (standardized mean difference) + Largest imbalance: 0.1 (standardized mean difference) -- Weights -- Range: 0.000 to 1.957 Mean: 1.000 - Coefficient of variation: 0.305 + Coefficient of variation: 0.30 Weights at the minimum-weight floor: of 500 -- Balance -- - term kind statistic group unweighted weighted tolerance within_tolerance - 1 x1 moment smd 1 0.552 0.1 0.05 TRUE - 2 x2 moment smd 1 0.416 0.1 0.05 TRUE + term kind statistic group unweighted weighted tolerance within_tolerance + 1 x1 moment smd 1 0.552 0.1 0.05 TRUE + 2 x2 moment smd 1 0.416 0.1 0.05 TRUE # summary() of a cfd fit reports the weight floor count @@ -154,18 +167,18 @@ Observations: 500 Solver: converged in iterations Constraints: 2 terms (tolerance 0) - Largest imbalance: 0.0051 (standardized mean difference) + Largest imbalance: 0.00515 (standardized mean difference) -- Weights -- Range: 0.000 to 20.5 Mean: 1.000 - Coefficient of variation: 1.732 + Coefficient of variation: 1.73 Weights at the minimum-weight floor: of 500 -- Balance -- - term kind statistic group unweighted weighted tolerance within_tolerance - 1 x1 moment smd 1 0.552 0.00515 0 FALSE - 2 x2 moment smd 1 0.416 0.00222 0 FALSE + term kind statistic group unweighted weighted tolerance within_tolerance + 1 x1 moment smd 1 0.552 0.00515 0 FALSE + 2 x2 moment smd 1 0.416 0.00222 0 FALSE diff --git a/tests/testthat/helper-dgp.R b/tests/testthat/helper-dgp.R index 3c4fb04..40a36d7 100644 --- a/tests/testthat/helper-dgp.R +++ b/tests/testthat/helper-dgp.R @@ -61,3 +61,99 @@ sim_continuous <- function(n = 500, seed = 2024) { exposure <- 0.9 * x1 - 0.6 * x2 + stats::rnorm(n) data.frame(exposure = exposure, x1 = x1, x2 = x2) } + +# The two fixtures below are shaped for one route each rather than being general +# processes, and they live here because more than one file draws on them: a +# fixture reachable from only the file it was written in cannot be used by a +# spec that has to cross routes. + +# A binary-exposure fixture whose effect differs across the levels of a +# two-level modifier. The modifier confounds the exposure as well as modifying +# its effect, so a fit that balances it has real work to do, and it rides along +# as a numeric indicator, `modifier_hi`, because that is the parameterization +# the weight parameters stay identified in. +# +# The modifier declares its levels in reverse alphabetical order on purpose. The +# reference subgroup every contrast of subgroups is measured against is the +# modifier's first level, which is `"lo"` here and would be `"hi"` for an +# implementation that sorted the levels itself. +ipw_by_fixture <- function(n = 400) { + withr::with_seed(808, { + x1 <- stats::rnorm(n) + x2 <- stats::rnorm(n) + modifier <- factor( + sample(c("lo", "hi"), n, replace = TRUE), + levels = c("lo", "hi") + ) + modifier_hi <- as.numeric(modifier == "hi") + exposure <- stats::rbinom( + n, + 1L, + stats::plogis(0.7 * x1 - 0.5 * x2 + 0.6 * modifier_hi) + ) + y <- stats::rbinom( + n, + 1L, + stats::plogis( + -0.6 + + 0.2 * exposure + + 0.5 * x1 + + 0.3 * modifier_hi + + 1.4 * exposure * modifier_hi + ) + ) + y_cont <- 1 + + 0.2 * exposure + + 0.5 * x1 - + 0.3 * x2 + + 1.2 * exposure * modifier_hi + + stats::rnorm(n) + data.frame( + exposure = exposure, + x1 = x1, + x2 = x2, + modifier = modifier, + modifier_hi = modifier_hi, + y = y, + y_cont = y_cont + ) + }) +} + +# Two binary treatments, the second depending on the first and both on a +# covariate, with an outcome carrying a real interaction between them. A binary +# and a gaussian outcome are drawn so each reported scale has something to read, +# and a modifier is drawn for the `.by` refusal. +ipw_joint_fixture <- function(n = 700) { + withr::with_seed(4210, { + x1 <- stats::rnorm(n) + a <- stats::rbinom(n, 1L, stats::plogis(0.3 * x1)) + e <- stats::rbinom(n, 1L, stats::plogis(-0.2 + 0.5 * x1 - 0.4 * a)) + y <- stats::rbinom( + n, + 1L, + stats::plogis(-0.5 + 0.7 * a + 0.5 * e + 0.6 * x1 + 0.9 * a * e) + ) + y_cont <- 1 + + 0.6 * a + + 0.4 * e + + 0.5 * x1 + + 0.8 * a * e + + stats::rnorm(n) + data <- data.frame( + x1 = x1, + y = y, + y_cont = y_cont, + a = factor(a, levels = c(0L, 1L)), + e = factor(e, levels = c(0L, 1L)), + modifier = factor( + ifelse(x1 > 0, "hi", "lo"), + levels = c("lo", "hi") + ) + ) + # Assigned rather than built inside `data.frame()`, which would coerce the + # crossing away before anything could read it. + data$joint <- causalgenerics::joint_exposure(a = data$a, e = data$e) + data + }) +} diff --git a/tests/testthat/helper-expectations.R b/tests/testthat/helper-expectations.R index 825f3cd..2ab873b 100644 --- a/tests/testthat/helper-expectations.R +++ b/tests/testthat/helper-expectations.R @@ -86,3 +86,216 @@ expect_balanced <- function(x, .data, tolerance = 0) { testthat::expect_lte(max(achieved), tolerance + 1e-6) } + +# expect_stacked_psi_matches_rbind() pins both readings of the stacked +# estimating function against the `rbind()` of its blocks. The meat's evaluation +# builds the S-by-n matrix block by block through `stack_psi_blocks()`, and the +# bread's evaluations skip that matrix and take its row sums block by block +# through `sum_psi_blocks()`. The claim this helper makes is that filling a +# preallocated matrix produces exactly what stacking the same blocks with +# `rbind()` produces, to the bit, and that reducing them produces exactly the +# row sums of that same stack. +# +# Both halves are stated here because the two routes now carry the same fit +# between them, and a reduction that disagreed with the assembly by a bit would +# move the bread while leaving the meat where it was. +# +# The comparison is made on the matrix itself rather than on the variance the +# fit reports, because the variance would not see every difference: +# `stacked_covariance()` overwrites the covariance dimnames with the stacked +# parameter names, so an assembly that dropped or invented row names would still +# return the reference variance. It is also made on the blocks a real fit builds +# rather than on a hand-written list, because the shapes vary with the exposure, +# the outcome model, and whether subgroups or a crossing were declared, and no +# fixed list reaches all of them. +# +# The stand-ins delegate to the real helpers and return their values, so the fit +# running under them is the fit the package performs and every evaluation the +# finite difference asks for is compared, not only the one at the root. +# Mismatches are collected and reported once at the end: the finite difference +# calls the closure twice per stacked coordinate, and an expectation inside a +# stand-in would turn a single defect into hundreds of failures. The call counts +# are asserted too, so a route that stopped assembling or reducing its psi +# blocks through these helpers would fail here rather than pass vacuously. +expect_stacked_psi_matches_rbind <- function(expr) { + assemble <- stack_psi_blocks + reduce <- sum_psi_blocks + mismatches <- character() + calls <- 0L + reductions <- 0L + + testthat::local_mocked_bindings( + stack_psi_blocks = function(blocks, n) { + calls <<- calls + 1L + stacked <- assemble(blocks, n) + expected <- do.call(rbind, blocks) + if (!identical(stacked, expected)) { + mismatches <<- c( + mismatches, + paste0( + "call ", + calls, + ": assembled ", + paste(dim(stacked), collapse = " by "), + ", rbind gives ", + paste(dim(expected), collapse = " by ") + ) + ) + } + stacked + }, + sum_psi_blocks = function(blocks, n) { + reductions <<- reductions + 1L + sums <- reduce(blocks, n) + expected <- unname(rowSums(do.call(rbind, blocks))) + if (!identical(sums, expected)) { + gap <- if (length(sums) == length(expected)) { + paste0(", largest difference ", format(max(abs(sums - expected)))) + } else { + "" + } + mismatches <<- c( + mismatches, + paste0( + "reduction ", + reductions, + ": reduced ", + length(sums), + " rows, rbind gives ", + length(expected), + gap + ) + ) + } + sums + } + ) + + value <- force(expr) + + testthat::expect_identical(mismatches, character()) + testthat::expect_gt(calls, 0L) + testthat::expect_gt(reductions, 0L) + + invisible(value) +} + +# expect_finite_column() asserts that a data frame carries the named column, +# that the column holds at least one value, and that every value in it is +# finite. +# +# All three parts are load-bearing, and the first is the reason the helper +# exists. `is.finite()` on a column a data frame does not have returns +# `logical(0)`, `all(logical(0))` is TRUE, and so a bare +# `all(is.finite(df$column))` passes without reading anything whenever the +# column it names is absent. The suite asserts finiteness on reported columns +# dozens of times, and every one of those assertions would go quiet under a +# rename of the reported schema rather than reporting it. Testing membership +# first turns that case into a failure that names the missing column. +# +# A zero-row frame reaches `all(logical(0))` by the other route, with the column +# present and empty, which is the shape a reporting path returns when it builds +# its schema and fills no rows. Requiring at least one value, as +# `expect_column_all()` does, closes that case too. +expect_finite_column <- function(object, column) { + testthat::expect_true( + column %in% names(object), + info = paste0("expected a column named ", column) + ) + values <- object[[column]] + testthat::expect_true( + length(values) > 0L, + info = paste0("expected ", column, " to hold at least one value") + ) + testthat::expect_true( + all(is.finite(values)), + info = paste0("expected every value of ", column, " to be finite") + ) + invisible(object) +} + +# expect_column_all() asserts that a data frame or list carries the named +# column, that the column holds at least one value, and that a predicate holds +# for every value in it. +# +# It exists for the same reason `expect_finite_column()` does, and closes the +# same hole one step further out. A bare `all(object$column > 0)` reads +# `NULL > 0` as `logical(0)` when the column is absent and `all(logical(0))` as +# TRUE, so the assertion passes without reading anything; a column present but +# empty passes the same way. Naming the column as a string and testing +# membership and length first turns both cases into failures that say which +# column went missing. +# +# The predicate's result is required to carry one value per row rather than only +# to be all-true. Several assertions compare a column against a sibling column, +# where the predicate closes over the object, and a missing sibling would reopen +# the hole from the other side: `values < NULL` is `logical(0)` whatever +# `values` holds. +# +# A missing answer is rejected on its own rather than through `all()`, which +# returns NA and reports a failure reading as though the predicate had been +# answered and found false. A predicate that cannot answer is a different defect +# from one that answers no, and the column that produced it is worth naming. +expect_column_all <- function(object, column, predicate) { + testthat::expect_true( + column %in% names(object), + info = paste0("expected a column named ", column) + ) + values <- object[[column]] + testthat::expect_true( + length(values) > 0L, + info = paste0("expected ", column, " to hold at least one value") + ) + held <- predicate(values) + testthat::expect_length(held, length(values)) + testthat::expect_false( + anyNA(held), + info = paste0( + "expected the predicate to answer no missing values for ", + column + ) + ) + testthat::expect_true( + all(held), + info = paste0("expected the predicate to hold for every value of ", column) + ) + invisible(object) +} + +# expect_all() asserts that a vector holds at least one value and that a +# predicate holds for every value in it. +# +# It is `expect_column_all()` for a value the test already holds rather than for +# a named column of a frame, and it closes the same hole. The suite asserts a +# predicate over a bare vector in about a hundred places, most often over the +# weights a fit produced, and `all(w >= 0)` on a zero-length `w` is TRUE, so any +# of those would pass on a vector a fit failed to fill or a subscript selected +# nothing from. Requiring at least one value turns that into a failure. +# +# The predicate's answer is required to carry one value per element and to be +# free of missing values, for the reasons `expect_column_all()` records: a +# comparison against a sibling vector reopens the hole from the other side when +# the sibling is not there, and a predicate that cannot answer is a different +# defect from one that answers no. The vector's expression is deparsed so every +# failure names what was read. +expect_all <- function(values, predicate) { + label <- deparse1(substitute(values)) + testthat::expect_true( + length(values) > 0L, + info = paste0("expected ", label, " to hold at least one value") + ) + held <- predicate(values) + testthat::expect_length(held, length(values)) + testthat::expect_false( + anyNA(held), + info = paste0( + "expected the predicate to answer no missing values for ", + label + ) + ) + testthat::expect_true( + all(held), + info = paste0("expected the predicate to hold for every value of ", label) + ) + invisible(values) +} diff --git a/tests/testthat/helper-ipw-stack.R b/tests/testthat/helper-ipw-stack.R new file mode 100644 index 0000000..186cee6 --- /dev/null +++ b/tests/testthat/helper-ipw-stack.R @@ -0,0 +1,283 @@ +# A reference implementation of the stacked variance system `ipw()` reports, +# built here rather than read out of the package, and the evaluation counter the +# cost of that system is pinned with. +# +# The contrast rows of the stack are deterministic functions of the marginal +# means, so their bread rows are known without differencing anything and their +# meat is zero at the solution. An implementation is free to fill those rows in +# analytically and difference a narrower system, which is cheaper by two closure +# evaluations per contrast. What it is not free to do is change the answer, and +# that is what this file exists to hold it to. +# +# `ipw_reference_stack()` assembles the whole system the way the package +# assembles it today, differences every row of it, and returns the parameter +# vector and the covariance that fall out. It reuses the pieces the arithmetic is +# defined in, the container's own hooks, `deli::ee_glm()` for the outcome score, +# and the contrast formulas, so it restates no method's math; what it does not +# reuse is the assembly and the sandwich call under `ipw()`, which is the code an +# analytic contrast block changes. The blocks are built as matrices here and +# stacked with `rbind()`, rather than handed a row at a time to +# `stack_psi_blocks()` to be written into a preallocated destination, for that +# reason: this is the assembly the package performed before it wrote its rows in +# place, and the specs reading this system are what hold the two to the same +# answer. The assembly is pinned against `rbind()` a second time, on the entries +# the package hands it, by `expect_stacked_psi_matches_rbind()` elsewhere in +# this suite. +# +# The deli call is copied argument for argument from `stacked_covariance()`, +# central differences at a step of 1e-6 with no pseudoinverse fallback, and the +# result is divided by the sample size and named the same way, because agreement +# is asserted with `identical()` rather than to a tolerance. Every one of those +# choices moves the last bits of the answer. +# +# The widths of the blocks travel back with the system. The evaluation count an +# analytic contrast block reaches is written from them, so the two readings of +# how many rows are deterministic cannot come apart. +ipw_reference_stack <- function( + container, + outcome_mod, + frame, + exposure_name, + levels, + categorical = FALSE, + by = NULL, + joint = NULL, + sampling_weights = NULL, + focal_level = NULL +) { + n <- nrow(frame) + family <- stats::family(outcome_mod) + continuous <- is_gaussian_outcome(outcome_mod) + distribution <- deli_distribution(family) + outcome <- resolve_outcome_response(outcome_mod) + design <- stats::model.matrix(outcome_mod) + offset <- outcome_mod$offset + + pieces <- lapply( + resolve_level_values(frame[[exposure_name]], levels), + function(value) { + fixed_exposure_pieces( + outcome_mod, + frame, + exposure_name, + value, + offset = offset + ) + } + ) + + sampling <- sampling_weights %||% rep(1, n) + key <- as.character(frame[[exposure_name]]) + groups <- stats::setNames( + lapply(levels, function(level) which(key == level)), + levels + ) + targets <- group_target_sums(sampling, groups, focal_level) + tilt <- if (is.null(focal_level)) { + sampling + } else { + sampling * (key == focal_level) + } + + weight_parameters <- container@parameters + p <- length(weight_parameters) + coefficients <- stats::coef(outcome_mod) + q <- length(coefficients) + means <- vapply( + pieces, + function(piece) sum(tilt * piece$mu) / sum(tilt), + numeric(1) + ) + m <- length(means) + contrasts <- ipw_contrast_values(means, continuous) + effects <- ipw_contrast_names(continuous, if (categorical) levels else NULL) + if (!is.null(joint)) { + contrasts <- ipw_joint_values(joint, means, continuous) + effects <- ipw_joint_names(joint) + } + k <- length(effects) + + by_stack <- ipw_by_stack(by, pieces, tilt, continuous, levels, categorical) + m_by <- length(by_stack$means) + k_by <- length(by_stack$contrasts) + + theta <- c( + weight_parameters, + coefficients, + means, + contrasts, + by_stack$means, + by_stack$contrasts + ) + names(theta) <- c( + paste0("theta_w", seq_len(p)), + paste0("beta_", colnames(design)), + ipw_mean_names(levels, categorical), + effects, + by_stack$mean_names, + by_stack$contrast_names + ) + + rescale <- function(weights) { + renormalize_group_weights(weights, sampling, groups, targets) + } + hooks_at <- make_hooks_cache( + container, + rescale, + as.numeric(weight_parameters) + ) + + stacked_equations <- function(theta) { + beta <- theta[p + seq_len(q)] + mean_theta <- theta[p + q + seq_len(m)] + contrast_theta <- theta[p + q + m + seq_len(k)] + + hooks <- hooks_at(as.numeric(theta[seq_len(p)])) + score <- deli::ee_glm( + beta, + X = design, + y = outcome, + distribution = distribution, + link = family$link, + weights = hooks$weights * sampling, + offset = offset + ) + + fixed <- lapply(seq_len(m), function(j) { + eta <- as.numeric(pieces[[j]]$design %*% beta) + if (!is.null(offset)) { + eta <- eta + offset + } + family$linkinv(eta) + }) + mean_rows <- do.call( + rbind, + lapply(seq_len(m), function(j) tilt * (fixed[[j]] - mean_theta[[j]])) + ) + contrast_values <- if (is.null(joint)) { + ipw_contrast_values(mean_theta, continuous) - contrast_theta + } else { + ipw_joint_row_values(joint, mean_theta, contrast_theta, continuous) + } + contrast_rows <- matrix(contrast_values, nrow = k, ncol = n) + by_mean_theta <- theta[p + q + m + k + seq_len(m_by)] + by_contrast_theta <- theta[p + q + m + k + m_by + seq_len(k_by)] + by_mean_rows <- NULL + by_contrast_rows <- NULL + if (!is.null(by_stack)) { + by_mean_rows <- do.call( + rbind, + lapply(seq_len(m_by), function(row) { + stratum <- (row - 1L) %/% m + 1L + level <- (row - 1L) %% m + 1L + by_stack$tilts[[stratum]] * (fixed[[level]] - by_mean_theta[[row]]) + }) + ) + by_contrast_rows <- matrix( + ipw_by_contrast_row_values( + by_stack = by_stack, + mean_theta = by_mean_theta, + contrast_theta = by_contrast_theta, + continuous = continuous, + n_levels = m + ), + nrow = k_by, + ncol = n + ) + } + + do.call( + rbind, + list( + hooks$psi, + score, + mean_rows, + contrast_rows, + by_mean_rows, + by_contrast_rows + ) + ) + } + + covariance <- deli::compute_sandwich( + stacked_equations, + theta, + deriv_method = "capprox", + dx = 1e-6, + allow_pinv = FALSE + ) / + n + dimnames(covariance) <- list(names(theta), names(theta)) + + list( + theta = theta, + vcov = covariance, + width = length(theta), + # The rows a deterministic function of the means fills: the whole-sample + # contrast block, and every stratum and stratum-against-stratum block a + # `.by` request adds. + deterministic = k + k_by + ) +} + +# Assert that `ipw()` reports the system the reference builds, to the bit, and +# that the block of it the reported effects are read from is the block the +# reference produces. +# +# All three surfaces are checked because none of them subsumes the others. The +# fit's copy is the whole system, the reported block is the slice a caller reads +# standard errors and confidence intervals off, and the parameter vector is what +# both are indexed by. `stacked_covariance()` renames the covariance it returns, +# and `attach_effect_covariance()` renames it again, so a block read from the +# wrong rows would still carry the right labels; comparing values under the +# observed dimnames is what makes the assertion about the numbers. +expect_ipw_matches_reference_stack <- function(result, reference, keys) { + testthat::expect_identical(result$fit$theta, reference$theta) + testthat::expect_identical(result$fit$vcov, reference$vcov) + + observed <- attr(result$estimates, "ipw_vcov") + expected <- reference$vcov[keys, keys, drop = FALSE] + dimnames(expected) <- dimnames(observed) + testthat::expect_identical(observed, expected) + + invisible(result) +} + +# The number of times a call assembles the stacked estimating functions, which +# is the number of times the sandwich evaluates the closure. +# +# deli's central difference evaluates the closure once at the fitted parameters +# and twice more per differenced coordinate, once on each side, so a system of +# width S written out in full costs 2S + 1 evaluations. Rows the implementation +# fills in analytically are neither differenced nor carried, so each of them +# saves two. +# +# The count is read at the two places a route takes delivery of its blocks: +# `stack_psi_blocks()`, which the meat's single evaluation assembles its matrix +# through, and `sum_psi_blocks()`, which every evaluation the bread differences +# reduces through. Between them they see every evaluation and each of them sees +# it once, so their sum is the number the sandwich costs. Each stand-in +# delegates to the real helper and returns its value, so the call running under +# them is the call the package performs. +expect_stacked_evaluations <- function(expr, expected) { + assemble <- stack_psi_blocks + reduce <- sum_psi_blocks + evaluations <- 0L + + testthat::local_mocked_bindings( + stack_psi_blocks = function(blocks, n) { + evaluations <<- evaluations + 1L + assemble(blocks, n) + }, + sum_psi_blocks = function(blocks, n) { + evaluations <<- evaluations + 1L + reduce(blocks, n) + } + ) + + value <- force(expr) + + testthat::expect_identical(evaluations, expected) + + invisible(value) +} diff --git a/tests/testthat/helper-snapshot.R b/tests/testthat/helper-snapshot.R index ade71ae..6153b94 100644 --- a/tests/testthat/helper-snapshot.R +++ b/tests/testthat/helper-snapshot.R @@ -36,6 +36,16 @@ expect_balancing_snapshot <- function(expr) { # keeps what these snapshots are for, the shape and wording of the output, and # gives up the values that cannot be pinned portably. # +# A balance value below 1e-7 goes further and loses its digits entirely. A +# term the fit drove to zero leaves behind whatever residual its arithmetic +# happened to accumulate, and at that magnitude the residual is a report on the +# platform's floating-point path rather than on the fit: the mantissa and the +# exponent both differ from one machine to the next, so rounding cannot make two +# platforms agree the way it can for a number the fit actually resolved. The one +# thing such a value states, that the term balanced, is what the placeholder +# keeps. The rule is on magnitude rather than on a column, because which columns +# hold a driven-to-zero value depends on the method and the constraint set. +# # testthat passes a transform to the Output and Condition blocks but not to the # recorded Code block, so a call in a snapshot is never rewritten. The patterns # are still written to leave a short number alone, which keeps them safe for the @@ -66,19 +76,146 @@ scrub_platform_values <- function(lines) { lines, perl = TRUE ) - round_wide_decimals(lines) + # Ahead of the rounding: a value like 6.438292e-11 is wide enough to round, + # and rounding it to 6.44e-11 would leave an exponent that still says nothing + # portable. Matching the exponent at or below -8 catches both forms, single + # digit and padded, and the guards on either side keep the pattern off a + # number that merely ends in something exponent-shaped. + # + # The rule reads the exponent rather than the value, so the largest number it + # can match is just under 1e-7 rather than just under 1e-8, and the + # placeholder states the cutoff the rule reaches rather than one it does not. + # Narrowing the rule to the values below 1e-8 alone would mean parsing every + # match, which buys nothing: a value between the two is as unportable as one + # below both. + # + # A number the text introduces as a tolerance is exempt. The package's own + # tolerances live in this magnitude range, and a message that reports one is + # reporting a constant the package chose rather than a residual a platform + # arrived at, so scrubbing it would hide the value the message is about. The + # exemption is written as three fixed-width lookbehinds because PCRE takes no + # variable-width one, and they cover the forms a message uses: the bare word, + # an equals sign, and "of". + lines <- gsub( + paste0( + "(? 0L && + nzchar(words[[1L]]) && + all(words %in% balance_table_column_names) } # Round a printed decimal to three significant digits once it carries more than # four, which is the width at which the platform difference starts. Anything # shorter is left byte-identical: a tolerance such as `0.05`, an imbalance such -# as `0.0118` from formatC(digits = 4), a weight range such as `0.220`, and any -# integer all survive untouched. Leading zeros do not count toward the width, so -# `0.005149743` is seven digits wide rather than ten. +# as `0.00515` from formatC(format = "g", digits = 3), a weight range such as +# `0.220`, and any integer all survive untouched. Leading zeros do not count +# toward the width, so `0.005149743` is seven digits wide rather than ten. That +# three-significant-digit rendering also puts an imbalance the fit drove to zero +# in exponent form, where the near-zero rule above replaces it with the `<1e-7` +# placeholder rather than leaving a platform-specific mantissa. # # Rounding the parsed value rather than truncating the text is what makes two # platforms agree: 6.438292e-11 and 6.438290e-11 are different doubles that both # carry 6.44e-11. +# The coefficient of variation in a summary's weights block prints three +# decimals, and on a fit whose solve differs across floating-point paths (the +# cfd fixture with weights on the floor) the third decimal moves between +# platforms: 1.732 on macOS arm64 against 1.734 on Windows. Two decimals is +# inside that drift, so the scrub rounds the line to two. +round_variation_coefficient <- function(lines) { + marked <- grepl("Coefficient of variation: [0-9]+[.][0-9]+", lines) + lines[marked] <- vapply( + lines[marked], + function(line) { + found <- regmatches(line, regexpr("[0-9]+[.][0-9]+", line)) + value <- formatC(as.numeric(found), format = "f", digits = 2) + sub("[0-9]+[.][0-9]+", value, line) + }, + character(1), + USE.NAMES = FALSE + ) + lines +} + round_wide_decimals <- function(lines) { found <- gregexpr("[0-9]*[.][0-9]+(e[-+][0-9]+)?", lines, perl = TRUE) regmatches(lines, found) <- lapply( diff --git a/tests/testthat/helper-state.R b/tests/testthat/helper-state.R new file mode 100644 index 0000000..e783e59 --- /dev/null +++ b/tests/testthat/helper-state.R @@ -0,0 +1,10 @@ +# The package records the physical core count for the session, so a test that +# wants to observe the reading has to clear the record on the way in and again +# on the way out. Clearing it on the way out matters as much: a test that mocks +# `parallel::detectCores()` would otherwise leave the mocked answer behind for +# every fit that follows it in the same run. +local_core_count_reset <- function(.env = parent.frame()) { + reset_physical_cores() + withr::defer(reset_physical_cores(), envir = .env) + invisible(NULL) +} diff --git a/tests/testthat/test-balance-table.R b/tests/testthat/test-balance-table.R new file mode 100644 index 0000000..536adad --- /dev/null +++ b/tests/testthat/test-balance-table.R @@ -0,0 +1,530 @@ +# compute_balance_table() assembles the balance table from the constraint +# matrix and the extracted weights. balance() has already built that matrix +# before it fits, so the table can be handed the built matrix rather than +# rebuilding it from the recipe. These specs pin that the two routes report the +# same table on every exposure type, estimand and weighting the fit supports, +# and pin the column statistics the table is assembled from against references +# written out in plain arithmetic, so a change of algorithm inside them has +# something independent to answer to. + +# ---- Prebuilt constraint matrix -------------------------------------------- + +# Reassemble the arguments balance() passes to compute_balance_table(), so the +# equivalence specs run on the geometry a real fit reports on rather than on a +# plausible-looking substitute. The pieces mirror balance(): the constraint +# matrix is built with the sampling weights for the quadratic-program family and +# without them otherwise, the groups are the row indices of each exposure level, +# the weights are the fitted weights with the sampling weights composed on, and +# the reference measure is the product of the sampling weights and the method's +# base weights. +balance_table_pieces <- function( + fit, + data, + covariates, + constraint_target = "pooled" +) { + constraint_sampling_weights <- if ( + S7::S7_inherits(fit@method, quadratic_program_method) + ) { + fit@sampling_weights + } else { + NULL + } + built <- build_constraint_matrix( + data, + covariates, + fit@constraints, + fit@exposure_type, + sampling_weights = constraint_sampling_weights + ) + + exposure_vec <- data[[fit@exposure]] + groups <- if (identical(fit@exposure_type, "continuous")) { + NULL + } else { + exposure_key <- as.character(exposure_vec) + stats::setNames( + lapply(fit@exposure_levels, function(level) which(exposure_key == level)), + fit@exposure_levels + ) + } + + sampling_weights <- fit@sampling_weights %||% rep(1, fit@n) + base_weights <- if ("base_weights" %in% S7::prop_names(fit@method)) { + fit@method@base_weights %||% rep(1, fit@n) + } else { + rep(1, fit@n) + } + + args <- list( + recipe = built$recipe, + data = data, + exposure_vec = exposure_vec, + exposure_type = fit@exposure_type, + estimand = fit@estimand, + focal_level = fit@focal_level, + groups = groups, + weights = as.numeric(stats::weights(fit)), + tolerance = 0, + reference = sampling_weights * base_weights, + constraint_target = constraint_target, + sampling_weights = fit@sampling_weights + ) + + list(args = args, matrix = built$matrix) +} + +# The rebuild route is asserted against the fit's own table first, so the +# reassembled arguments are held to reproducing what balance() reported rather +# than only to agreeing with themselves. +expect_prebuilt_matrix_equivalence <- function( + fit, + data, + covariates, + constraint_target = "pooled" +) { + pieces <- balance_table_pieces(fit, data, covariates, constraint_target) + rebuilt <- do.call(compute_balance_table, pieces$args) + expect_identical(rebuilt, fit@balance_table) + + prebuilt <- do.call( + compute_balance_table, + c(pieces$args, list(matrix = pieces$matrix)) + ) + expect_identical(prebuilt, rebuilt) +} + +test_that("a prebuilt matrix reports the binary average-treatment-effect table", { + data <- sim_binary(n = 200) + fit <- balance(data, exposure, c(x1, x2, x3), method = bw_entropy()) + + expect_prebuilt_matrix_equivalence(fit, data, c("x1", "x2", "x3")) +}) + +test_that("a prebuilt matrix reports the binary focal table", { + # A focal estimand holds one arm fixed, so the table's target level and its + # constraint geometry both differ from the average-treatment-effect case. + data <- sim_binary(n = 200) + fit <- balance( + data, + exposure, + c(x1, x2, x3), + method = bw_entropy(), + estimand = "att" + ) + + expect_prebuilt_matrix_equivalence(fit, data, c("x1", "x2", "x3")) +}) + +test_that("a prebuilt matrix reports the multi-group categorical table", { + # Three exposure levels put two arms in the pairwise maximum, so the group + # label the table reports comes from an argmax rather than a single contrast. + data <- sim_categorical(n = 200) + fit <- balance(data, exposure, c(x1, x2), method = bw_entropy()) + + expect_prebuilt_matrix_equivalence(fit, data, c("x1", "x2")) +}) + +test_that("a prebuilt matrix reports the continuous correlation table", { + data <- sim_continuous(n = 200) + fit <- balance(data, exposure, c(x1, x2), method = bw_entropy()) + + expect_prebuilt_matrix_equivalence(fit, data, c("x1", "x2")) +}) + +test_that("a prebuilt matrix reports the sampling-weighted table", { + # Sampling weights move both the standardization the table reports on and the + # reference measure the pooled constraint target is taken against. + data <- sim_binary(n = 200) + data$sw <- withr::with_seed(11, stats::runif(nrow(data), 0.5, 2)) + fit <- balance( + data, + exposure, + c(x1, x2, x3), + method = bw_entropy(), + sampling_weights = sw + ) + + expect_prebuilt_matrix_equivalence(fit, data, c("x1", "x2", "x3")) +}) + +test_that("a prebuilt matrix reports the per-term tolerance table", { + # Per-term tolerances reach the table through the recipe rather than the + # `tolerance` argument, and the quadratic-program family builds its constraint + # matrix on the sampling-weighted scale, so this case covers both. + data <- sim_binary(n = 200) + data$sw <- withr::with_seed(12, stats::runif(nrow(data), 0.5, 2)) + fit <- balance( + data, + exposure, + c(x1, x2, x3), + method = bw_sbw(), + constraints = balance_terms( + tolerance = c(x1 = 0.02, x2 = 0.05, x3 = 0.1) + ), + sampling_weights = sw + ) + + expect_prebuilt_matrix_equivalence(fit, data, c("x1", "x2", "x3")) +}) + +test_that("a prebuilt matrix reports the arm-to-arm constraint table", { + # The covariate balancing propensity score equates the arms directly, so its + # fit reports an arm-to-arm constraint target rather than the pooled one. + data <- sim_binary(n = 200) + fit <- balance(data, exposure, c(x1, x2, x3), method = bw_cbps()) + + expect_prebuilt_matrix_equivalence( + fit, + data, + c("x1", "x2", "x3"), + constraint_target = "arms" + ) +}) + +test_that("a prebuilt matrix reports the base-weighted pooled target table", { + # Entropy balancing is the only method carrying base weights, and they enter + # the table as the reference measure the average-treatment-effect pooled + # target is taken against. Non-uniform base weights move that target away from + # the plain column mean, so this pins the branch a uniform measure hides. + data <- sim_binary(n = 200) + base_weights <- withr::with_seed(13, stats::runif(nrow(data), 0.5, 2)) + fit <- balance( + data, + exposure, + c(x1, x2, x3), + method = bw_entropy(base_weights = base_weights) + ) + + expect_prebuilt_matrix_equivalence(fit, data, c("x1", "x2", "x3")) +}) + +# ---- Column statistics ----------------------------------------------------- + +# A fixture with the features the column statistics have to survive: a column +# with no spread, which the zero-scale guard leaves unscaled; an indicator, whose +# scale is small next to the continuous columns; sampling weights that are not +# uniform, so the weighted and unweighted statistics differ; and a group +# membership that splits the rows unevenly, so a subset mean is not the whole +# column's mean. +# +# The column with no spread holds a power of two so that its weighted mean comes +# out exactly, in any summation order: scaling a weight by two is exact, so the +# weighted sum is exactly twice the sum of the weights and the centered column is +# exactly zero. A constant that is not a power of two leaves rounding noise in +# the centered column, the weighted scale picks that noise up instead of +# reporting zero, and the guard is never reached. +column_statistic_fixture <- function() { + withr::with_seed(303, { + n <- 40 + m <- cbind( + x1 = stats::rnorm(n), + x2 = stats::runif(n, -2, 3), + constant = rep(2, n), + indicator = as.numeric(stats::rbinom(n, 1L, 0.4)) + ) + list( + m = m, + sampling_weights = stats::runif(n, 0.3, 2.5), + weights = stats::runif(n, 0.1, 4), + idx = which(stats::rbinom(n, 1L, 0.35) == 1L) + ) + }) +} + +test_that("standardize_columns() centers and scales on the unweighted scale", { + fixture <- column_statistic_fixture() + m <- fixture$m + + expected <- m + for (j in seq_len(ncol(m))) { + column <- m[, j] + center <- sum(column) / length(column) + variance <- sum((column - center)^2) / (length(column) - 1) + scale <- sqrt(variance) + if (scale == 0) { + scale <- 1 + } + expected[, j] <- (column - center) / scale + } + + expect_equal(standardize_columns(m), expected, tolerance = 1e-12) +}) + +test_that("standardize_columns() centers and scales on the sampling-weighted scale", { + fixture <- column_statistic_fixture() + m <- fixture$m + w <- fixture$sampling_weights + + expected <- m + for (j in seq_len(ncol(m))) { + column <- m[, j] + center <- sum(w * column) / sum(w) + denominator <- sum(w) - sum(w * w) / sum(w) + variance <- sum(w * (column - center)^2) / denominator + scale <- sqrt(variance) + if (scale == 0) { + scale <- 1 + } + expected[, j] <- (column - center) / scale + } + + expect_equal( + standardize_columns(m, sampling_weights = w), + expected, + tolerance = 1e-12 + ) +}) + +test_that("standardize_columns() reproduces the per-column weighted statistics", { + # The vectorized weighted branch is bit for bit the per-column formulation it + # replaced, so this pins identity rather than agreement to a tolerance. A + # tolerance here would let a genuine change of accumulation order pass. + fixture <- column_statistic_fixture() + m <- fixture$m + w <- fixture$sampling_weights + + centers <- apply(m, 2, weighted_center, w = w) + scales <- apply(m, 2, weighted_scale, w = w) + scales[scales == 0] <- 1 + expected <- sweep(sweep(m, 2, centers, "-"), 2, scales, "/") + + expect_identical(standardize_columns(m, sampling_weights = w), expected) +}) + +test_that("standardize_columns() agrees with stats::sd() to rounding", { + # The unweighted scale carries the same corrected two-pass center `stats::sd()` + # does, but `stats::sd()` carries the correction in long double, so the two + # agree to a unit in the last place rather than exactly. + fixture <- column_statistic_fixture() + m <- fixture$m + + scales <- apply(m, 2, stats::sd) + scales[scales == 0] <- 1 + expected <- sweep(sweep(m, 2, colMeans(m), "-"), 2, scales, "/") + + expect_equal(standardize_columns(m), expected, tolerance = 1e-14) + + # An offset of 1e14 on the non-constant columns is large enough against their + # spread to separate the corrected two-pass center from the plain one: on this + # input the plain form departs from `stats::sd()` by a relative 1.2e-4, well + # outside the tolerance below, while the corrected form still tracks it. + shifted <- m + offset <- setdiff(colnames(m), "constant") + shifted[, offset] <- shifted[, offset] + 1e14 + + shifted_scales <- apply(shifted, 2, stats::sd) + shifted_scales[shifted_scales == 0] <- 1 + shifted_expected <- sweep( + sweep(shifted, 2, colMeans(shifted), "-"), + 2, + shifted_scales, + "/" + ) + + expect_equal( + standardize_columns(shifted), + shifted_expected, + tolerance = 1e-14 + ) +}) + +test_that("standardize_columns() leaves a column with no spread unscaled", { + # The zero-scale guard divides by one rather than by zero, so the constant + # column comes out as zeros instead of as missing values. + fixture <- column_statistic_fixture() + m <- fixture$m + + unweighted <- standardize_columns(m) + weighted <- standardize_columns( + m, + sampling_weights = fixture$sampling_weights + ) + + expect_equal(unweighted[, "constant"], rep(0, nrow(m)), tolerance = 1e-12) + expect_equal(weighted[, "constant"], rep(0, nrow(m)), tolerance = 1e-12) +}) + +# A constant column whose value is not exactly representable in the weighted +# center's arithmetic does not center to zero. `sum(w * x) / sum(w)` rounds +# twice, so the centered column holds a rounding residual rather than a zero, +# the weighted scale reports that residual as the column's spread, and dividing +# by it turns a column with nothing in it into order-one values. The column has +# no spread whatever the arithmetic says, so it standardizes to zero. +test_that("standardize_columns() flattens a constant column under sampling weights", { + n <- 20L + w <- withr::with_seed(1, stats::runif(n, 0.5, 2)) + m <- matrix(0.98, nrow = n, ncol = 1L, dimnames = list(NULL, "constant")) + + # Whether `sum(w * x) / sum(w)` misses 0.98 is platform arithmetic: it misses + # by an ulp where long double is double (macOS arm64) and can round exactly + # back where sum() accumulates in 80 bits (Linux x86_64). The rule under test + # must flatten the column either way, so nothing here asserts the miss. + + expect_identical( + standardize_columns(m, sampling_weights = w), + matrix(0, nrow = n, ncol = 1L, dimnames = list(NULL, "constant")) + ) + expect_identical( + standardize_columns(m), + matrix(0, nrow = n, ncol = 1L, dimnames = list(NULL, "constant")) + ) +}) + +# The other side of the same rule. A column that barely varies still varies, and +# a spread of 1e-6 around 0.98 is a real one rather than a rounding residual, so +# it is standardized rather than flattened. +test_that("standardize_columns() leaves a nearly constant column alone", { + n <- 20L + w <- withr::with_seed(1, stats::runif(n, 0.5, 2)) + m <- matrix( + 0.98 + 1e-6 * seq_len(n), + nrow = n, + ncol = 1L, + dimnames = list(NULL, "nearly") + ) + + weighted <- standardize_columns(m, sampling_weights = w) + unweighted <- standardize_columns(m) + + expect_equal(stats::sd(unweighted[, 1L]), 1, tolerance = 1e-8) + expect_gt(diff(range(weighted[, 1L])), 1) + expect_gt(diff(range(unweighted[, 1L])), 1) +}) + +# `column_is_constant()` reads the values rather than the computed scale, and it +# reads them with a comparison that a missing value answers with a missing +# value. A column carrying one would therefore make the reading itself missing, +# and the two places that consume it index with it: `centered[, constant] <- 0` +# and `scales[constant | scales == 0] <- 1` both refuse a missing subscript in an +# assignment, so a single missing value would stop the standardization with a +# base error rather than a classed one. +# +# A column with a missing value is read as not constant. That is the reading +# that leaves the rest of the standardization behaving exactly as it did: the +# column keeps its computed center and scale, and the missing value propagates +# through them into the standardized column, where it is visible for what it is. +# The constraint columns a fit builds carry no missing values, which the fit +# validates before a constraint matrix exists, so this governs only the direct +# callers. +test_that("column_is_constant() reads a column with a missing value as varying", { + m <- cbind( + constant = rep(0.98, 4), + missing_constant = c(0.98, NA, 0.98, 0.98), + all_missing = rep(NA_real_, 4), + varying = c(1, 2, 3, 4) + ) + + expect_identical( + column_is_constant(m), + c( + constant = TRUE, + missing_constant = FALSE, + all_missing = FALSE, + varying = FALSE + ) + ) +}) + +# A matrix with no rows has no first row for the comparison to read, and +# without a guard ahead of it the subscript fails with a base error rather than +# one of the package's classed conditions. Nothing can be constant over no rows +# either, so every column reads as varying and both consumers of the reading +# write into a zero-length selection, leaving their columns as they found them. +test_that("column_is_constant() reads every column of a zero-row matrix as varying", { + m <- matrix( + numeric(0), + nrow = 0L, + ncol = 3L, + dimnames = list(NULL, c("value", "missing", "other")) + ) + + expect_identical( + column_is_constant(m), + c(value = FALSE, missing = FALSE, other = FALSE) + ) +}) + +test_that("column_is_constant() reads every column of a single row as constant", { + m <- matrix( + c(0.98, NA, 3), + nrow = 1L, + dimnames = list(NULL, c("value", "missing", "other")) + ) + + expect_identical( + column_is_constant(m), + c(value = TRUE, missing = FALSE, other = TRUE) + ) +}) + +test_that("standardize_columns() carries a missing value through the column", { + n <- 20L + w <- withr::with_seed(1, stats::runif(n, 0.5, 2)) + values <- rep(0.98, n) + values[[3L]] <- NA_real_ + m <- matrix(values, nrow = n, ncol = 1L, dimnames = list(NULL, "constant")) + + weighted <- standardize_columns(m, sampling_weights = w) + unweighted <- standardize_columns(m) + + expect_identical(dim(weighted), c(n, 1L)) + expect_identical(dim(unweighted), c(n, 1L)) + expect_true(is.na(weighted[3L, 1L])) + expect_true(is.na(unweighted[3L, 1L])) +}) + +# The column arithmetic the weighted standardization and the solver's tolerance +# box both read their scales from. It takes an already-centered matrix because +# both callers have one in hand, and it reproduces the per-column +# `weighted_scale()` bit for bit rather than approximately. +test_that("centered_column_scales() reproduces the per-column weighted scale", { + fixture <- column_statistic_fixture() + m <- fixture$m + w <- fixture$sampling_weights + centered <- sweep(m, 2, apply(m, 2, weighted_center, w = w), "-") + + expect_identical( + centered_column_scales(centered, w), + apply(m, 2, weighted_scale, w = w) + ) +}) + +test_that("weighted_column_means() averages each column over the row subset", { + fixture <- column_statistic_fixture() + z <- standardize_columns(fixture$m, fixture$sampling_weights) + w <- fixture$weights + idx <- fixture$idx + + expected <- vapply( + colnames(z), + function(term) { + column <- z[idx, term] + sum(w[idx] * column) / sum(w[idx]) + }, + numeric(1) + ) + + expect_equal( + weighted_column_means(z, idx, w), + expected, + tolerance = 1e-12 + ) +}) + +test_that("weighted_column_means() averages over every row under unit weights", { + # The table takes its unweighted arm means through the same helper with a unit + # weight vector, so that path is pinned as well. + fixture <- column_statistic_fixture() + z <- standardize_columns(fixture$m) + idx <- seq_len(nrow(z)) + w <- rep(1, nrow(z)) + + expected <- vapply( + colnames(z), + function(term) sum(z[, term]) / nrow(z), + numeric(1) + ) + + expect_equal(weighted_column_means(z, idx, w), expected, tolerance = 1e-12) +}) diff --git a/tests/testthat/test-balance.R b/tests/testthat/test-balance.R index 741dcf1..3217a92 100644 --- a/tests/testthat/test-balance.R +++ b/tests/testthat/test-balance.R @@ -58,7 +58,7 @@ test_that("everything() excludes the exposure from its own covariates", { expect_identical(fit@covariates, c("x1", "x2", "x3")) expect_false("exposure" %in% fit@balance_table$term) - expect_true(all(is.finite(as.numeric(stats::weights(fit))))) + expect_all(as.numeric(stats::weights(fit)), is.finite) }) test_that("a covariate selection naming only the exposure is a classed error", { @@ -193,7 +193,7 @@ test_that("a binary factor with an unused level fits an estimating-equation meth data$exposure <- factor(data$exposure, levels = c(0, 1, 2)) fit <- balance(data, exposure, c(x1, x2), method = bw_entropy()) expect_equal(fit@exposure_levels, c("0", "1")) - expect_true(all(is.finite(as.numeric(stats::weights(fit))))) + expect_all(as.numeric(stats::weights(fit)), is.finite) }) test_that("a binary factor with an unused level fits a quadratic-program method", { @@ -215,7 +215,7 @@ test_that("a binary factor with an unused level fits a quadratic-program method" function(idx) sum(w[idx])^2 / sum(w[idx]^2), numeric(1) ) - expect_true(all(is.finite(group_ess))) + expect_all(group_ess, is.finite) }) test_that("a categorical factor with an unused level fits an estimating-equation method", { @@ -228,7 +228,7 @@ test_that("a categorical factor with an unused level fits an estimating-equation ) fit <- balance(data, exposure, c(x1, x2), method = bw_ipt()) expect_false("zzz" %in% fit@exposure_levels) - expect_true(all(is.finite(as.numeric(stats::weights(fit))))) + expect_all(as.numeric(stats::weights(fit)), is.finite) }) test_that("a categorical factor with an unused level keeps a finite effective sample size", { @@ -248,7 +248,7 @@ test_that("a categorical factor with an unused level keeps a finite effective sa function(idx) sum(w[idx])^2 / sum(w[idx]^2), numeric(1) ) - expect_true(all(is.finite(group_ess))) + expect_all(group_ess, is.finite) }) test_that("dropping an unused exposure level announces itself", { @@ -494,13 +494,39 @@ test_that("a focal estimand needs a level outside the focal group", { c(x1, x2), method = bw_entropy(), estimand = "att", - focal_level = 1 + .focal_level = 1 ), class = "balancing_estimand_error" ) }) -test_that("a binary att infers the treated level without focal_level", { +# ---- The public focal-level argument --------------------------------------- + +# The user-facing argument is `.focal_level`, which is the name propensity's +# weight constructors use for the same quantity, while the property it resolves +# to on the fit keeps the bare name. The package is unreleased, so the old +# argument name is not accepted anywhere: `balance()` closes its dots, and a +# name it does not have is refused there rather than absorbed in silence. +test_that("balance() takes .focal_level rather than focal_level", { + arguments <- names(formals(balance)) + expect_true(".focal_level" %in% arguments) + expect_false("focal_level" %in% arguments) + + data <- sim_categorical(n = 200) + expect_error( + balance( + data, + exposure, + c(x1, x2), + method = bw_entropy(), + estimand = "att", + focal_level = "b" + ), + class = "rlib_error_dots_nonempty" + ) +}) + +test_that("a binary att infers the treated level without .focal_level", { data <- sim_binary(n = 200) fit <- balance( data, @@ -512,7 +538,7 @@ test_that("a binary att infers the treated level without focal_level", { expect_identical(fit@focal_level, "1") }) -test_that("a categorical att requires focal_level", { +test_that("a categorical att requires .focal_level", { data <- sim_categorical(n = 200) expect_error( balance( @@ -526,7 +552,7 @@ test_that("a categorical att requires focal_level", { ) }) -test_that("a categorical att honors a supplied focal_level", { +test_that("a categorical att honors a supplied .focal_level", { data <- sim_categorical(n = 200) fit <- balance( data, @@ -534,7 +560,7 @@ test_that("a categorical att honors a supplied focal_level", { c(x1, x2), method = bw_entropy(), estimand = "att", - focal_level = "b" + .focal_level = "b" ) expect_identical(fit@focal_level, "b") }) @@ -546,7 +572,7 @@ test_that("a categorical att honors a supplied focal_level", { # reach the check that the supplied one is an exposure level at all. A level that # does not exist used to be accepted in silence, which reads as a fit that # targeted it. -test_that("focal_level with the average treatment effect warns and is ignored", { +test_that(".focal_level with the average treatment effect warns and is ignored", { data <- sim_binary(n = 200) expect_warning( fit <- balance( @@ -555,14 +581,14 @@ test_that("focal_level with the average treatment effect warns and is ignored", c(x1, x2), method = bw_entropy(), estimand = "ate", - focal_level = 1 + .focal_level = 1 ), class = "balancing_ignored_argument_warning" ) expect_null(fit@focal_level) }) -test_that("a focal_level that is not an exposure level still warns", { +test_that("a .focal_level that is not an exposure level still warns", { data <- sim_binary(n = 200) expect_warning( balance( @@ -571,13 +597,13 @@ test_that("a focal_level that is not an exposure level still warns", { c(x1, x2), method = bw_entropy(), estimand = "ate", - focal_level = "nonesuch" + .focal_level = "nonesuch" ), class = "balancing_ignored_argument_warning" ) }) -test_that("focal_level with the overlap estimand warns and is ignored", { +test_that(".focal_level with the overlap estimand warns and is ignored", { data <- sim_binary(n = 200) expect_warning( fit <- balance( @@ -586,14 +612,14 @@ test_that("focal_level with the overlap estimand warns and is ignored", { c(x1, x2), method = bw_cbps(), estimand = "ato", - focal_level = 0 + .focal_level = 0 ), class = "balancing_ignored_argument_warning" ) expect_null(fit@focal_level) }) -test_that("a pooled estimand without focal_level is silent", { +test_that("a pooled estimand without .focal_level is silent", { data <- sim_binary(n = 200) expect_no_warning( balance(data, exposure, c(x1, x2), method = bw_entropy(), estimand = "ate") @@ -603,7 +629,7 @@ test_that("a pooled estimand without focal_level is silent", { ) }) -test_that("a focal estimand with focal_level does not warn", { +test_that("a focal estimand with .focal_level does not warn", { data <- sim_categorical(n = 200) expect_no_warning( balance( @@ -612,7 +638,7 @@ test_that("a focal estimand with focal_level does not warn", { c(x1, x2), method = bw_entropy(), estimand = "att", - focal_level = "b" + .focal_level = "b" ) ) }) @@ -649,7 +675,7 @@ test_that("a single-level exposure is refused for every estimand", { c(x1, x2), method = bw_entropy(), estimand = "att", - focal_level = 1 + .focal_level = 1 ), class = "balancing_estimand_error" ) @@ -919,8 +945,8 @@ test_that("partly zero sampling weights that leave every group mass still fit", method = bw_entropy(), sampling_weights = sampling ) - expect_true(all(is.finite(as.numeric(stats::weights(fit))))) - expect_true(all(is.finite(fit@balance_table$weighted))) + expect_all(as.numeric(stats::weights(fit)), is.finite) + expect_finite_column(fit@balance_table, "weighted") }) # The base-weight length mismatch belongs to the entropy fit, which names the @@ -1032,7 +1058,7 @@ test_that("a constant covariate leaves a continuous-exposure fit intact", { # The constant column is dropped before the fit, so the balance table reports # only the covariates that carry information and every verdict resolves. expect_false("fixed" %in% fit@balance_table$term) - expect_true(all(is.finite(fit@balance_table$weighted))) + expect_finite_column(fit@balance_table, "weighted") expect_true(all(fit@balance_table$within_tolerance)) }) @@ -1042,7 +1068,7 @@ test_that("a single-level factor leaves a continuous-exposure fit intact", { fit <- balance(data, exposure, c(x1, x2, f), method = bw_entropy()) expect_false("f_a" %in% fit@balance_table$term) - expect_true(all(is.finite(fit@balance_table$weighted))) + expect_finite_column(fit@balance_table, "weighted") expect_true(all(fit@balance_table$within_tolerance)) }) @@ -1052,7 +1078,7 @@ test_that("a single-level factor leaves a binary-exposure fit intact", { fit <- balance(data, exposure, c(x1, x2, f), method = bw_entropy()) expect_false("f_a" %in% fit@balance_table$term) - expect_true(all(fit@balance_table$within_tolerance)) + expect_column_all(fit@balance_table, "within_tolerance", function(x) x) }) test_that("a constant covariate leaves a binary-exposure fit and ipw() intact", { @@ -1062,7 +1088,7 @@ test_that("a constant covariate leaves a binary-exposure fit and ipw() intact", fit <- balance(data, exposure, c(x1, x2, fixed), method = bw_entropy()) expect_false("fixed" %in% fit@balance_table$term) - expect_true(all(fit@balance_table$within_tolerance)) + expect_column_all(fit@balance_table, "within_tolerance", function(x) x) data$.wts <- as.numeric(stats::weights(fit)) outcome_model <- suppressWarnings(stats::glm( @@ -1071,8 +1097,8 @@ test_that("a constant covariate leaves a binary-exposure fit and ipw() intact", weights = .wts )) result <- ipw(fit, outcome_model) - expect_true(all(is.finite(result$estimates$estimate))) - expect_true(all(is.finite(result$estimates$std.err))) + expect_finite_column(result$estimates, "estimate") + expect_finite_column(result$estimates, "std.err") }) # ---- What @covariates records ---------------------------------------------- @@ -1352,3 +1378,197 @@ test_that("a one-row data frame is a classed error", { expect_match(conditionMessage(cnd), "\\b(1|one|2|two)\\b") } }) + +# ---- difftime covariates --------------------------------------------------- + +# A duration column carries its number in a plain numeric vector with a `units` +# attribute, so the arithmetic the constraint expansion performs on a numeric +# covariate is defined for it apart from `^`, which base R refuses for the class. +# The contract is that such a column balances exactly as the same durations +# stored as bare numbers in the column's own unit would: the fit reads the +# number, not the unit, so no rescaling and no reinterpretation happens on the +# way in. The covariate is a product of the two continuous confounders so that it +# is neither constant nor an affine function of anything else in the selection, +# which would send it to the aliasing drop before the arithmetic is reached. +test_that("a difftime covariate balances as its numeric value does", { + data <- sim_binary(n = 200) + data$dt <- as.difftime( + 3600 * data$x1 * data$x2 + 7 * 3600, + units = "secs" + ) + numeric_data <- data + numeric_data$dt <- as.numeric(numeric_data$dt) + + fit <- balance(data, exposure, c(x1, x2, dt), method = bw_entropy()) + numeric_fit <- balance( + numeric_data, + exposure, + c(x1, x2, dt), + method = bw_entropy() + ) + + expect_identical(fit@covariates, c("x1", "x2", "dt")) + expect_true("dt" %in% fit@balance_table$term) + expect_identical( + fit@balance_table[fit@balance_table$term == "dt", ], + numeric_fit@balance_table[numeric_fit@balance_table$term == "dt", ] + ) + expect_identical(fit@balance_table, numeric_fit@balance_table) + expect_identical( + as.numeric(stats::weights(fit)), + as.numeric(stats::weights(numeric_fit)) + ) +}) + +# The kernel-distance methods do not read their covariates through the constraint +# builder: they cross the raw columns into a distance matrix. A duration read +# there as a categorical column becomes one indicator per distinct value, which +# is a different fit rather than a differently scaled one, so the contract needs +# checking on that path too. Both fits are seeded because the conditional +# feature-density draws are random; the quadratic program itself reproduces +# bit for bit run to run. +test_that("a difftime covariate crosses the kernel distance as its number", { + data <- sim_binary(n = 200) + data$dt <- as.difftime( + 3600 * data$x1 * data$x2 + 7 * 3600, + units = "secs" + ) + numeric_data <- data + numeric_data$dt <- as.numeric(numeric_data$dt) + + for (method in list(bw_energy(), bw_cfd())) { + fit <- withr::with_seed( + 2024, + balance(data, exposure, c(x1, x2, dt), method = method) + ) + numeric_fit <- withr::with_seed( + 2024, + balance(numeric_data, exposure, c(x1, x2, dt), method = method) + ) + + expect_identical(fit@covariates, c("x1", "x2", "dt")) + expect_identical(fit@balance_table, numeric_fit@balance_table) + expect_identical( + as.numeric(stats::weights(fit)), + as.numeric(stats::weights(numeric_fit)) + ) + } +}) + +# ---- Date and POSIXct covariates ------------------------------------------- + +# A date and a date-time reach the fit as the numbers they store, days since +# 1970-01-01 and seconds since then, the same contract a duration carries. Both +# the constraint route and the kernel-distance route are pinned, because the two +# read the column through the same accessor for different reasons: the constraint +# expansion needs a number it can raise to a power, and the distance needs a +# number rather than one indicator per distinct instant. The offset is what makes +# the date-time case worth its own fixture, since a stamp near 1.7e9 with hours +# of spread is a column whose standardization constants sit nine orders of +# magnitude above its own spread. +test_that("a Date covariate balances as the number it stores", { + data <- sim_binary(n = 200) + data$day <- as.Date("2020-01-01") + 30 * data$x1 * data$x2 + numeric_data <- data + numeric_data$day <- as.numeric(numeric_data$day) + + for (method in list(bw_entropy(), bw_energy())) { + fit <- withr::with_seed( + 2024, + balance(data, exposure, c(x1, x2, day), method = method) + ) + numeric_fit <- withr::with_seed( + 2024, + balance(numeric_data, exposure, c(x1, x2, day), method = method) + ) + + expect_identical(fit@covariates, c("x1", "x2", "day")) + expect_true("day" %in% fit@balance_table$term) + expect_equal( + fit@balance_table[fit@balance_table$term == "day", ], + numeric_fit@balance_table[numeric_fit@balance_table$term == "day", ], + tolerance = 1e-8 + ) + expect_equal( + as.numeric(stats::weights(fit)), + as.numeric(stats::weights(numeric_fit)), + tolerance = 1e-8 + ) + } +}) + +test_that("a POSIXct covariate balances as the number it stores", { + data <- sim_binary(n = 200) + data$stamp <- as.POSIXct( + 1.7e9 + 3600 * data$x1 * data$x2, + origin = "1970-01-01", + tz = "UTC" + ) + numeric_data <- data + numeric_data$stamp <- as.numeric(numeric_data$stamp) + + for (method in list(bw_entropy(), bw_energy())) { + fit <- withr::with_seed( + 2024, + balance(data, exposure, c(x1, x2, stamp), method = method) + ) + numeric_fit <- withr::with_seed( + 2024, + balance(numeric_data, exposure, c(x1, x2, stamp), method = method) + ) + + expect_identical(fit@covariates, c("x1", "x2", "stamp")) + expect_true("stamp" %in% fit@balance_table$term) + expect_equal( + fit@balance_table[fit@balance_table$term == "stamp", ], + numeric_fit@balance_table[numeric_fit@balance_table$term == "stamp", ], + tolerance = 1e-8 + ) + expect_equal( + as.numeric(stats::weights(fit)), + as.numeric(stats::weights(numeric_fit)), + tolerance = 1e-8 + ) + } +}) + +# A POSIXlt date-time stores the same instant as a POSIXct one, split into +# calendar components rather than held as a count of seconds, and `as.numeric()` +# gives both the same seconds since 1970-01-01. Only the class differs, so the +# two must reach the fit as the same column. Before the coercion read the shared +# `POSIXt` class, a POSIXlt covariate met base R's own error from raising a +# difftime to a power, which names neither the covariate nor the class that +# could not be read. +test_that("a POSIXlt covariate balances as the POSIXct one it stores", { + data <- sim_binary(n = 200) + stamp <- as.POSIXct( + 1.7e9 + 3600 * data$x1 * data$x2, + origin = "1970-01-01", + tz = "UTC" + ) + lt_data <- data + lt_data$stamp <- as.POSIXlt(stamp) + ct_data <- data + ct_data$stamp <- stamp + + for (method in list(bw_entropy(), bw_energy())) { + lt_fit <- withr::with_seed( + 2024, + balance(lt_data, exposure, c(x1, x2, stamp), method = method) + ) + ct_fit <- withr::with_seed( + 2024, + balance(ct_data, exposure, c(x1, x2, stamp), method = method) + ) + + expect_identical(lt_fit@covariates, c("x1", "x2", "stamp")) + expect_equal( + lt_fit@balance_table[lt_fit@balance_table$term == "stamp", ], + ct_fit@balance_table[ct_fit@balance_table$term == "stamp", ] + ) + expect_equal( + as.numeric(stats::weights(lt_fit)), + as.numeric(stats::weights(ct_fit)) + ) + } +}) diff --git a/tests/testthat/test-constraints.R b/tests/testthat/test-constraints.R index d0c6f43..45fe35a 100644 --- a/tests/testthat/test-constraints.R +++ b/tests/testthat/test-constraints.R @@ -61,7 +61,7 @@ test_that("numeric covariates become one mean-balance column each", { expect_identical(ncol(built$matrix), 2L) kinds <- vapply(built$recipe, function(term) term$kind, character(1)) - expect_true(all(kinds == "moment")) + expect_all(kinds, function(value) value == "moment") }) test_that("factor covariates expand to a level indicator set less the alias", { @@ -106,7 +106,7 @@ test_that("moments above one add centered raw powers", { expect_identical(ncol(built$matrix), 3L) expect_identical(sort(powers), c(1L, 2L, 3L)) expect_identical(kinds[powers == 1L], "moment") - expect_true(all(kinds[powers > 1L] == "power")) + expect_all(kinds[powers > 1L], function(value) value == "power") }) test_that("the recipe records the standardization center and scale", { @@ -491,6 +491,12 @@ test_that("indicator and quantile columns keep their full set", { exposure_type = "binary" ) ) + expect_length(evaluated$messages, 2L) + expect_match( + evaluated$messages, + "moments above one for the binary covariate", + all = FALSE + ) expect_match(evaluated$messages, "aliased", all = FALSE) built <- evaluated$result terms <- vapply(built$recipe, function(record) record$term, character(1)) @@ -967,7 +973,7 @@ test_that("objective-driven methods fit with an empty constraint set", { constraints = no_moment_constraints() ) expect_identical(nrow(fit@balance_table), 0L) - expect_true(all(is.finite(as.numeric(stats::weights(fit))))) + expect_all(as.numeric(stats::weights(fit)), is.finite) fit_categorical <- balance( categorical, @@ -976,7 +982,7 @@ test_that("objective-driven methods fit with an empty constraint set", { method = method, constraints = no_moment_constraints() ) - expect_true(all(is.finite(as.numeric(stats::weights(fit_categorical))))) + expect_all(as.numeric(stats::weights(fit_categorical)), is.finite) } fit_continuous <- balance( @@ -986,7 +992,7 @@ test_that("objective-driven methods fit with an empty constraint set", { method = bw_energy(), constraints = no_moment_constraints() ) - expect_true(all(is.finite(as.numeric(stats::weights(fit_continuous))))) + expect_all(as.numeric(stats::weights(fit_continuous)), is.finite) }) test_that("a fit with no constraint terms prints and summarizes cleanly", { @@ -1004,3 +1010,152 @@ test_that("a fit with no constraint terms prints and summarizes cleanly", { expect_false(any(grepl("Inf", printed, fixed = TRUE))) expect_no_warning(utils::capture.output(summary(fit))) }) + +# ---- difftime covariates --------------------------------------------------- + +# The expansion reads a duration column as the number it stores, in whatever unit +# the column declares, so every record it produces matches the record the same +# durations written as bare numbers produce. Both halves of the expansion are +# pinned: the moment and power records, which raise the centered column to a +# power and so used to meet base R's refusal of `^` on the class, and the +# quantile records, which used to be skipped altogether because the column does +# not answer `is.numeric()`. The cutpoints and the standardization constants the +# records carry must be plain numbers, which `expect_identical()` against the +# numeric expansion enforces along with the terms themselves. +test_that("a difftime covariate expands as its numeric value does", { + data <- sim_binary(n = 200) + data$dt <- as.difftime( + 3600 * data$x1 * data$x2 + 7 * 3600, + units = "secs" + ) + numeric_data <- data + numeric_data$dt <- as.numeric(numeric_data$dt) + + terms <- balance_terms(moments = 2L, quantiles = c(0.25, 0.75)) + built <- build_constraint_matrix( + data, + c("x1", "x2", "dt"), + terms, + exposure_type = "binary" + ) + numeric_built <- build_constraint_matrix( + numeric_data, + c("x1", "x2", "dt"), + terms, + exposure_type = "binary" + ) + + built_terms <- vapply(built$recipe, function(r) r$term, character(1)) + expect_true(all(c("dt", "dt^2", "dt_q0.25", "dt_q0.75") %in% built_terms)) + expect_identical(built$recipe, numeric_built$recipe) + expect_identical(built$matrix, numeric_built$matrix) +}) + +# ---- Date and POSIXct covariates ------------------------------------------- + +# A date and a date-time are the same case as a duration one step further out: +# each stores a plain number, each refuses `^` on its own class, and neither +# answers `is.numeric()`, so the expansion has to read the number rather than the +# column. The number is the one `as.numeric()` gives, days since 1970-01-01 for a +# date and seconds since then for a date-time, and the contract is that the +# column expands exactly as those numbers written bare would. The covariate is +# built from the two continuous confounders so it is neither constant nor an +# affine function of anything else in the selection. +test_that("a Date covariate expands as the number it stores", { + data <- sim_binary(n = 200) + data$day <- as.Date("2020-01-01") + 30 * data$x1 * data$x2 + numeric_data <- data + numeric_data$day <- as.numeric(numeric_data$day) + + terms <- balance_terms(moments = 2L, quantiles = c(0.25, 0.75)) + built <- build_constraint_matrix( + data, + c("x1", "x2", "day"), + terms, + exposure_type = "binary" + ) + numeric_built <- build_constraint_matrix( + numeric_data, + c("x1", "x2", "day"), + terms, + exposure_type = "binary" + ) + + built_terms <- vapply(built$recipe, function(r) r$term, character(1)) + expect_true( + all(c("day", "day^2", "day_q0.25", "day_q0.75") %in% built_terms) + ) + expect_identical(built$recipe, numeric_built$recipe) + expect_identical(built$matrix, numeric_built$matrix) +}) + +test_that("a POSIXct covariate expands as the number it stores", { + data <- sim_binary(n = 200) + data$stamp <- as.POSIXct( + 1.7e9 + 3600 * data$x1 * data$x2, + origin = "1970-01-01", + tz = "UTC" + ) + numeric_data <- data + numeric_data$stamp <- as.numeric(numeric_data$stamp) + + terms <- balance_terms(moments = 2L, quantiles = c(0.25, 0.75)) + built <- build_constraint_matrix( + data, + c("x1", "x2", "stamp"), + terms, + exposure_type = "binary" + ) + numeric_built <- build_constraint_matrix( + numeric_data, + c("x1", "x2", "stamp"), + terms, + exposure_type = "binary" + ) + + built_terms <- vapply(built$recipe, function(r) r$term, character(1)) + expect_true( + all(c("stamp", "stamp^2", "stamp_q0.25", "stamp_q0.75") %in% built_terms) + ) + expect_identical(built$recipe, numeric_built$recipe) + expect_identical(built$matrix, numeric_built$matrix) +}) + +# Which branch of the expansion a covariate takes is decided from the numbers it +# stores, which is the same rule a duration follows and the reason nothing about +# the branching needed widening alongside the coercion. `is_binary_numeric()` +# reads values rather than classes, so a date column holding two distinct dates +# is a two-valued numeric column whose values are not zero and one: it takes the +# moment branch, exactly as the numbers it stores do. A column whose two dates +# were the first two days of 1970 would store zero and one and take the indicator +# branch, again exactly as those numbers do. Its square is then dropped as an +# affine function of the column, which is what a two-valued column's square is, +# and that too happens on both sides alike. +test_that("a two-valued Date covariate is classified by the numbers it stores", { + data <- sim_binary(n = 200) + data$day <- as.Date(ifelse(data$x1 > 0, "2020-01-01", "2020-06-01")) + numeric_data <- data + numeric_data$day <- as.numeric(numeric_data$day) + + terms <- balance_terms(moments = 2L) + built <- build_constraint_matrix( + data, + c("x1", "x2", "day"), + terms, + exposure_type = "binary" + ) + numeric_built <- build_constraint_matrix( + numeric_data, + c("x1", "x2", "day"), + terms, + exposure_type = "binary" + ) + + built_terms <- vapply(built$recipe, function(r) r$term, character(1)) + expect_true("day" %in% built_terms) + # A column read as categorical would contribute one indicator per distinct + # date, named for the level rather than for the covariate. + expect_false(any(grepl("^day_", built_terms))) + expect_identical(built$recipe, numeric_built$recipe) + expect_identical(built$matrix, numeric_built$matrix) +}) diff --git a/tests/testthat/test-errors.R b/tests/testthat/test-errors.R index 65b94d8..13fa1f5 100644 --- a/tests/testthat/test-errors.R +++ b/tests/testthat/test-errors.R @@ -79,7 +79,7 @@ test_that("balancing_exposure_type_error: a method rejects an exposure type", { ) }) -test_that("balancing_estimand_error: a categorical att without focal_level", { +test_that("balancing_estimand_error: a categorical att without .focal_level", { data <- sim_categorical(n = 150) expect_balancing_error( balance( @@ -200,7 +200,7 @@ test_that("balancing_estimand_error: a focal estimand with one exposure level", c(x1, x2), method = bw_entropy(), estimand = "att", - focal_level = 1 + .focal_level = 1 ) ) }) diff --git a/tests/testthat/test-expectations.R b/tests/testthat/test-expectations.R new file mode 100644 index 0000000..b33a960 --- /dev/null +++ b/tests/testthat/test-expectations.R @@ -0,0 +1,150 @@ +# Unit tests for the custom expectations in helper-expectations.R. An +# expectation that cannot fail reports nothing, so the failing cases are worth +# pinning on their own rather than only through the assertions they stand +# behind. +# +# The failures are caught as conditions rather than through `expect_failure()`, +# which reads exactly one expectation and `expect_finite_column()` makes three. + +# `is.finite()` on an absent column returns `logical(0)` and `all(logical(0))` +# is TRUE, so the finiteness half alone would pass on a data frame that does not +# carry the column at all. The membership half is what makes a renamed or +# dropped reporting column a failure instead of silence. +test_that("expect_finite_column() fails when the column is missing", { + estimates <- data.frame(estimate = 1:3, std.err = c(0.1, 0.2, 0.3)) + + expect_error( + expect_finite_column(estimates, "std.error"), + class = "expectation_failure" + ) + expect_finite_column(estimates, "std.err") +}) + +# A present but empty column slips through the finiteness half the same way an +# absent one does: `all(is.finite(numeric(0)))` is TRUE. A zero-row frame is the +# shape a reporting path returns when it builds its schema and fills no rows, so +# the helper requires the column to hold at least one value. +test_that("expect_finite_column() fails on a column with no values", { + expect_error( + expect_finite_column(data.frame(std.err = numeric(0)), "std.err"), + class = "expectation_failure" + ) +}) + +test_that("expect_finite_column() fails on a non-finite value", { + expect_error( + expect_finite_column(data.frame(std.err = c(0.1, NA)), "std.err"), + class = "expectation_failure" + ) + expect_error( + expect_finite_column(data.frame(std.err = c(0.1, Inf)), "std.err"), + class = "expectation_failure" + ) +}) + +# The same hole reaches every sibling comparison the suite makes on a reported +# column: `all(estimates$std.err > 0)` on a frame that does not carry `std.err` +# compares `NULL` against zero, gets `logical(0)`, and passes. Requiring the +# column to be present closes that, and requiring it to hold at least one value +# closes the case a present-but-empty column would still slip through. +test_that("expect_column_all() fails when the column is missing", { + estimates <- data.frame(estimate = 1:3, std.err = c(0.1, 0.2, 0.3)) + + expect_error( + expect_column_all(estimates, "std.error", function(x) x > 0), + class = "expectation_failure" + ) + expect_column_all(estimates, "std.err", function(x) x > 0) +}) + +test_that("expect_column_all() fails on a column with no values", { + expect_error( + expect_column_all( + data.frame(std.err = numeric(0)), + "std.err", + function(x) x > 0 + ), + class = "expectation_failure" + ) +}) + +test_that("expect_column_all() fails when the predicate does not hold", { + expect_error( + expect_column_all( + data.frame(std.err = c(0.1, -0.2)), + "std.err", + function(x) x > 0 + ), + class = "expectation_failure" + ) +}) + +# A predicate that answers NA already fails, because `all()` returns NA and +# `expect_true(NA)` is a failure, but it fails as though the predicate had been +# answered and found false. Rejecting a missing answer on its own reports what +# actually happened. +test_that("expect_column_all() reports a missing predicate answer as missing", { + expect_error( + expect_column_all( + data.frame(std.err = c(0.1, NA)), + "std.err", + function(x) x > 0 + ), + regexp = "missing values for std\\.err", + class = "expectation_failure" + ) +}) + +# Several call sites compare a column against a sibling column, and a missing +# sibling reopens the hole from the other side: `x < NULL` is `logical(0)` +# whatever `x` holds. The predicate is therefore required to answer with one +# value per row rather than only to answer TRUE everywhere it answers at all. +test_that("expect_column_all() fails when the predicate answers a short vector", { + estimates <- data.frame(std.err = c(0.1, 0.2)) + + expect_error( + expect_column_all(estimates, "std.err", function(x) x < estimates$absent), + class = "expectation_failure" + ) +}) + +# `expect_all()` is `expect_column_all()` for a vector the test already holds. +# The suite asserts a predicate over a bare vector in about a hundred places, +# most often over the weights a fit produced, and `all()` on a zero-length +# vector is TRUE, so any of those would pass on a vector a fit failed to fill or +# a subscript selected nothing from. +test_that("expect_all() fails on a vector with no values", { + expect_error( + expect_all(numeric(0), function(value) value > 0), + class = "expectation_failure" + ) + expect_all(c(0.1, 0.2), function(value) value > 0) +}) + +test_that("expect_all() fails when the predicate does not hold", { + expect_error( + expect_all(c(0.1, -0.2), function(value) value > 0), + class = "expectation_failure" + ) +}) + +# The sibling-comparison hole reaches a bare vector the same way it reaches a +# column: comparing against a vector that is not there answers `logical(0)`. +test_that("expect_all() fails when the predicate answers a short vector", { + absent <- numeric(0) + + expect_error( + expect_all(c(0.1, 0.2), function(value) value < absent), + class = "expectation_failure" + ) +}) + +test_that("expect_all() names the vector when the predicate answers NA", { + values <- c(0.1, NA) + + expect_error( + expect_all(values, function(value) value > 0), + regexp = "missing values for values", + class = "expectation_failure" + ) +}) diff --git a/tests/testthat/test-ipw-accessors.R b/tests/testthat/test-ipw-accessors.R index 787ef9e..13f25d4 100644 --- a/tests/testthat/test-ipw-accessors.R +++ b/tests/testthat/test-ipw-accessors.R @@ -249,7 +249,7 @@ test_that("a binary att result carries the covariance of its means and effects", c(x1, x2), method = bw_entropy(), estimand = "att", - focal_level = "1" + .focal_level = "1" ) w <- stats::weights(fit) outcome_mod <- fit_accessor_outcome( @@ -1060,7 +1060,9 @@ test_that("the ipw accessors are the ones causalgenerics registers", { ) }) -test_that("balancing registers no S3 method on class ipw", { +test_that("balancing registers no S3 method on the ipw result classes", { + # `pool_ipw()` returns an `ipw_pooled` object, so the pooled result carries the + # same borrowed accessor surface as a single fit and is swept alongside it. specs <- c( "coef.ipw", "vcov.ipw", @@ -1072,7 +1074,19 @@ test_that("balancing registers no S3 method on class ipw", { "as.data.frame.ipw", "vcov.ipw_model", "as_marginal.ipw", - "as_conditional.ipw" + "as_conditional.ipw", + "estimand.ipw", + "coef.ipw_pooled", + "vcov.ipw_pooled", + "confint.ipw_pooled", + "nobs.ipw_pooled", + "df.residual.ipw_pooled", + "weights.ipw_pooled", + "print.ipw_pooled", + "as.data.frame.ipw_pooled", + "as_marginal.ipw_pooled", + "as_conditional.ipw_pooled", + "estimand.ipw_pooled" ) defined <- vapply(specs, defined_in_balancing, logical(1)) expect_identical( @@ -1083,7 +1097,7 @@ test_that("balancing registers no S3 method on class ipw", { # A method under a generic this list does not name would still be recorded in # the table belonging to that generic's package, so every table the ipw # methods live in is read whole rather than only at the expected names. - pattern <- "\\.ipw(_model)?$" + pattern <- "\\.ipw(_model|_pooled)?$" sources <- c( registered_sources(baseenv(), pattern), registered_sources(asNamespace("stats"), pattern), diff --git a/tests/testthat/test-ipw-by.R b/tests/testthat/test-ipw-by.R index 72b529f..f618bc3 100644 --- a/tests/testthat/test-ipw-by.R +++ b/tests/testthat/test-ipw-by.R @@ -14,60 +14,8 @@ # ---- Fixtures -------------------------------------------------------------- -# A binary-exposure fixture whose effect differs across the levels of a -# two-level modifier. The modifier confounds the exposure as well as modifying -# its effect, so a fit that balances it has real work to do, and it rides along -# as a numeric indicator, `modifier_hi`, because that is the parameterization -# the weight parameters stay identified in. -# -# The modifier declares its levels in reverse alphabetical order on purpose. The -# reference subgroup every contrast of subgroups is measured against is the -# modifier's first level, which is `"lo"` here and would be `"hi"` for an -# implementation that sorted the levels itself. -ipw_by_fixture <- function(n = 400) { - withr::with_seed(808, { - x1 <- stats::rnorm(n) - x2 <- stats::rnorm(n) - modifier <- factor( - sample(c("lo", "hi"), n, replace = TRUE), - levels = c("lo", "hi") - ) - modifier_hi <- as.numeric(modifier == "hi") - exposure <- stats::rbinom( - n, - 1L, - stats::plogis(0.7 * x1 - 0.5 * x2 + 0.6 * modifier_hi) - ) - y <- stats::rbinom( - n, - 1L, - stats::plogis( - -0.6 + - 0.2 * exposure + - 0.5 * x1 + - 0.3 * modifier_hi + - 1.4 * exposure * modifier_hi - ) - ) - y_cont <- 1 + - 0.2 * exposure + - 0.5 * x1 - - 0.3 * x2 + - 1.2 * exposure * modifier_hi + - stats::rnorm(n) - data.frame( - exposure = exposure, - x1 = x1, - x2 = x2, - modifier = modifier, - modifier_hi = modifier_hi, - y = y, - y_cont = y_cont - ) - }) -} - -# A three-level categorical exposure crossed with the same two-level modifier. +# A three-level categorical exposure crossed with the two-level modifier of +# `ipw_by_fixture()` in helper-dgp.R. # The exposure comes from the shared `sim_categorical()` process; the modifier # and the outcome are drawn here under their own seed, with the interaction # concentrated on the `"c"` level so the two subgroups disagree about one @@ -269,7 +217,7 @@ test_that("a .by fit reports the whole sample, each stratum, then their contrast ) ) expect_identical(nrow(estimates), 15L) - expect_true(all(is.finite(estimates$estimate))) + expect_finite_column(estimates, "estimate") # A block of means is never split by the contrasts built from it: the # whole-sample pair leads the table and the stratum pairs sit together after @@ -769,10 +717,10 @@ test_that("a .by fit reports a usable standard error for every row", { estimates <- result$estimates expect_identical(nrow(estimates), 15L) - expect_true(all(is.finite(estimates$std.err))) - expect_true(all(estimates$std.err > 0)) - expect_true(all(estimates$ci.lower < estimates$estimate)) - expect_true(all(estimates$ci.upper > estimates$estimate)) + expect_finite_column(estimates, "std.err") + expect_column_all(estimates, "std.err", function(x) x > 0) + expect_column_all(estimates, "ci.lower", function(x) x < estimates$estimate) + expect_column_all(estimates, "ci.upper", function(x) x > estimates$estimate) expect_equal( unname(sqrt(diag(stats::vcov(result)))), estimates$std.err, @@ -952,6 +900,33 @@ test_that("a .by att fit couples its subgroups through the focal tilt", { ))) }) +# The six blocks the stack is assembled from are only all present under a +# request: an ungrouped fit leaves the last two absent. The assembly of those +# blocks into the stacked matrix claims agreement with `rbind()` to the bit, and +# this is the route that states the claim over a full stack. What the +# expectation compares is the assembled matrix itself, at every evaluation the +# finite difference asks the closure for. + +test_that("a .by fit stacks its psi blocks as rbind would", { + data <- ipw_by_fixture() + fit <- balance( + data, + exposure, + c(x1, x2, modifier_hi), + method = bw_entropy(), + estimand = "ate" + ) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_by_outcome( + y ~ exposure * modifier, + data, + w, + stats::binomial() + ) + + expect_stacked_psi_matches_rbind(ipw(fit, outcome_mod, .by = modifier)) +}) + # ---- Labels ---------------------------------------------------------------- # The measure repeats across subgroups and names no row on its own, so every @@ -1915,3 +1890,191 @@ test_that("balancing_ipw_by_interaction_warning: no term reads both columns", { invisible(ipw(fit, outcome_mod, .by = modifier)) ) }) + +# ---- The analytic contrast block ------------------------------------------ + +# A request appends two more deterministic blocks to the stack: each stratum's +# contrasts, written from that stratum's means, and each non-reference stratum's +# contrasts against the reference stratum's, written from the stratum contrast +# parameters. Both are constant across units, so both are candidates for an +# analytic bread row alongside the whole-sample contrasts, and a grouped fit is +# where the saving is largest. +# +# The reference system differences every one of those rows, which is what the +# package does today, and the reported system has to stay identical to it to the +# bit. The evaluation count beside it is red until they leave the differenced +# system. + +test_that("a .by fit reports the fully differenced stacked system", { + data <- ipw_by_fixture() + fit <- balance( + data, + exposure, + c(x1, x2, modifier_hi), + method = bw_entropy(), + estimand = "ate" + ) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_by_outcome( + y ~ exposure * modifier, + data, + w, + stats::binomial() + ) + + frame <- stats::model.frame(outcome_mod) + by <- ipw_resolve_by( + rlang::quo(modifier), + frame = frame, + exposure = frame[["exposure"]], + exposure_levels = fit@exposure_levels, + exposure_name = "exposure", + outcome_mod = outcome_mod + ) + reference <- ipw_reference_stack( + container = estimating_equations(fit), + outcome_mod = outcome_mod, + frame = frame, + exposure_name = "exposure", + levels = fit@exposure_levels, + by = by + ) + + expect_ipw_matches_reference_stack( + ipw(fit, outcome_mod, .by = modifier), + reference, + keys = c( + "mu0", + "mu1", + "rd", + "log(rr)", + "log(or)", + "mu0_modifier = lo", + "mu1_modifier = lo", + "mu0_modifier = hi", + "mu1_modifier = hi", + "rd_modifier = lo", + "log(rr)_modifier = lo", + "rd_modifier = hi", + "log(rr)_modifier = hi", + "rd_modifier = hi vs modifier = lo", + "log(rr)_modifier = hi vs modifier = lo" + ) + ) +}) + +test_that("a .by fit differences no contrast row", { + data <- ipw_by_fixture() + fit <- balance( + data, + exposure, + c(x1, x2, modifier_hi), + method = bw_entropy(), + estimand = "ate" + ) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_by_outcome( + y ~ exposure * modifier, + data, + w, + stats::binomial() + ) + + frame <- stats::model.frame(outcome_mod) + by <- ipw_resolve_by( + rlang::quo(modifier), + frame = frame, + exposure = frame[["exposure"]], + exposure_levels = fit@exposure_levels, + exposure_name = "exposure", + outcome_mod = outcome_mod + ) + reference <- ipw_reference_stack( + container = estimating_equations(fit), + outcome_mod = outcome_mod, + frame = frame, + exposure_name = "exposure", + levels = fit@exposure_levels, + by = by + ) + + expect_stacked_evaluations( + ipw(fit, outcome_mod, .by = modifier), + 2L * (reference$width - reference$deterministic) + 1L + ) +}) + +# The two cases above hold the ate surface of an entropy fit. What they cannot +# see is whether the analytic block still agrees once the rows around it change +# shape: a focal estimand standardizes every mean over the treated units alone, +# and non-uniform sampling weights enter the tilt and the reported weight scale +# both. Neither reaches the deterministic rows directly, since those rows read +# mean and contrast parameters and nothing else, and that is exactly why the +# case is worth pinning. An implementation that let the tilt leak into the +# rows it fills in analytically would still agree with the reference on the ate +# surface and disagree here. + +test_that("a focal .by fit under sampling weights matches the differenced system", { + data <- ipw_by_fixture() + sampling <- withr::with_seed(2718, stats::runif(nrow(data), 0.4, 2.6)) + fit <- balance( + data, + exposure, + c(x1, x2, modifier_hi), + method = bw_ipt(), + estimand = "att", + sampling_weights = sampling + ) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_by_outcome( + y ~ exposure * modifier, + data, + w, + stats::binomial() + ) + + frame <- stats::model.frame(outcome_mod) + by <- ipw_resolve_by( + rlang::quo(modifier), + frame = frame, + exposure = frame[["exposure"]], + exposure_levels = fit@exposure_levels, + exposure_name = "exposure", + outcome_mod = outcome_mod + ) + reference <- ipw_reference_stack( + container = estimating_equations(fit), + outcome_mod = outcome_mod, + frame = frame, + exposure_name = "exposure", + levels = fit@exposure_levels, + by = by, + sampling_weights = fit@sampling_weights, + focal_level = fit@focal_level + ) + + expect_stacked_evaluations( + expect_ipw_matches_reference_stack( + ipw(fit, outcome_mod, .by = modifier), + reference, + keys = c( + "mu0", + "mu1", + "rd", + "log(rr)", + "log(or)", + "mu0_modifier = lo", + "mu1_modifier = lo", + "mu0_modifier = hi", + "mu1_modifier = hi", + "rd_modifier = lo", + "log(rr)_modifier = lo", + "rd_modifier = hi", + "log(rr)_modifier = hi", + "rd_modifier = hi vs modifier = lo", + "log(rr)_modifier = hi vs modifier = lo" + ) + ), + 2L * (reference$width - reference$deterministic) + 1L + ) +}) diff --git a/tests/testthat/test-ipw-deli.R b/tests/testthat/test-ipw-deli.R new file mode 100644 index 0000000..85204ec --- /dev/null +++ b/tests/testthat/test-ipw-deli.R @@ -0,0 +1,328 @@ +# Specs for the assembly of the stacked estimating function that `ipw()`'s +# variance is read from. The stack is built one block at a time, and the blocks +# themselves are pinned elsewhere: what these cover is only the step that puts +# them together into the S-by-n matrix the sandwich differentiates. +# +# The step is `stack_psi_blocks()`, which fills a preallocated matrix rather +# than growing one through `rbind()`. Its whole contract is that the two agree +# to the bit, values and dimnames alike, so both halves of that contract are +# stated here: the helper against `rbind()` on blocks written out by hand, +# including the shapes a stack actually presents it with, and the helper against +# `rbind()` on the blocks a real fit builds. +# +# Beside it sits `sum_psi_blocks()`, which the bread reaches instead, since the +# bread reads only row sums and has no use for the matrix. Its contract is the +# assembly's read through `rowSums()`, and it is stated the same two ways. + +# ---- Fixtures -------------------------------------------------------------- + +# A binary-exposure fixture with an outcome that depends on the exposure and on +# one covariate, so an adjusted outcome model has something to adjust for and +# the mean rows standardize over predictions that vary by unit. The exposure and +# the covariates come from the shared `sim_binary()` process; the outcome is +# drawn here under its own seed. +ipw_deli_fixture <- function(n = 200) { + data <- sim_binary(n) + withr::with_seed(717, { + data$y <- stats::rbinom( + n, + 1L, + stats::plogis(-0.3 + 0.5 * data$exposure + 0.4 * data$x1) + ) + }) + data +} + +# The same shape at three exposure levels, which is what puts more than one +# contrast row in the stack. +ipw_deli_categorical_fixture <- function(n = 200) { + data <- sim_categorical(n) + withr::with_seed(818, { + linear_predictor <- -0.4 + + 0.3 * (data$exposure == "b") + + 0.6 * (data$exposure == "c") + + 0.5 * data$x1 + data$y <- stats::rbinom(n, 1L, stats::plogis(linear_predictor)) + }) + data +} + +# A weighted outcome model of the shape `ipw()` expects, with the weights riding +# along as a column so the model frame resolves them. +fit_deli_outcome <- function(formula, data, wts, family) { + data[[".wts"]] <- wts + suppressWarnings( + stats::glm(formula, data = data, family = family, weights = .wts) + ) +} + +# ---- The assembly itself --------------------------------------------------- + +# The blocks a stack presents are not all matrices of the same shape. A route +# that reports no contrasts of its own passes nothing for that block, and a +# request that adds a block the fit turned out to have no rows for passes an +# empty one, so both have to stack to what `rbind()` stacks them to: dropped +# entirely, contributing no row and no row name. +# +# Every block a stack carries holds doubles, so the blocks written out here hold +# doubles too. Nothing states what the assembly does with an integer block, +# because nothing builds one. + +test_that("stack_psi_blocks() stacks present, absent, and empty blocks as rbind does", { + n <- 4L + weight_block <- matrix( + seq_len(2L * n) / 10, + nrow = 2L, + dimnames = list(c("theta_w1", "theta_w2"), NULL) + ) + score_block <- matrix(seq_len(3L * n) * 2.5, nrow = 3L) + empty_block <- matrix(numeric(), nrow = 0L, ncol = n) + contrast_block <- matrix( + -1, + nrow = 1L, + ncol = n, + dimnames = list("rd", NULL) + ) + + blocks <- list( + weight_block, + score_block, + NULL, + empty_block, + contrast_block + ) + + expect_identical( + stack_psi_blocks(blocks, n), + rbind(weight_block, score_block, empty_block, contrast_block) + ) +}) + +# Row names are the half of the contract a preallocated matrix is most likely to +# get wrong, and it can be got wrong in either direction: naming rows `rbind()` +# left unnamed, or leaving unnamed the rows it fills in with an empty string +# because some other block carried names. Both are stated here rather than left +# to the fits, whose blocks carry no row names at all. + +test_that("stack_psi_blocks() names no rows when no block does", { + n <- 3L + first <- matrix(seq_len(2L * n) + 0.5, nrow = 2L) + second <- matrix(seq_len(n) - 0.5, nrow = 1L) + + stacked <- stack_psi_blocks(list(first, second), n) + + expect_identical(stacked, rbind(first, second)) + expect_null(rownames(stacked)) +}) + +test_that("stack_psi_blocks() pads unnamed rows the way rbind does", { + n <- 2L + named <- matrix( + c(1, 2, 3, 4), + nrow = 2L, + dimnames = list(c("mu0", "mu1"), NULL) + ) + unnamed <- matrix(c(5, 6), nrow = 1L) + + stacked <- stack_psi_blocks(list(named, unnamed), n) + + expect_identical(stacked, rbind(named, unnamed)) + expect_identical(rownames(stacked), c("mu0", "mu1", "")) +}) + +# The buffer is allocated at the width the caller declares, so a block that is +# not that wide is a mistake in the block rather than something to fit in. R +# would recycle it into the rows instead, and the stack would carry a psi matrix +# whose values belong to no unit, so the width is checked rather than trusted. +# The refusal is worded from what the entry is and reported at the assembly the +# entries were handed to: a matrix entry is the only kind with columns to count, +# while a bare vector is one row, so what is wrong with it is how many values it +# holds. Neither is refused from the `vapply()` closure the count is taken in, +# which is a frame no caller wrote and which names no block. + +test_that("balancing_internal_error: a matrix block of the wrong width", { + n <- 4L + wide_enough <- matrix(seq_len(n) + 0.5, nrow = 1L) + too_narrow <- matrix(c(1, 2), nrow = 1L) + + expect_balancing_error(stack_psi_blocks(list(wide_enough, too_narrow), n)) +}) + +test_that("balancing_internal_error: a bare-vector block of the wrong length", { + n <- 4L + wide_enough <- matrix(seq_len(n) + 0.5, nrow = 1L) + + expect_balancing_error(stack_psi_blocks(list(wide_enough, c(1, 2)), n)) +}) + +test_that("balancing_internal_error: a bare-vector block the reduction refuses", { + n <- 4L + wide_enough <- matrix(seq_len(n) + 0.5, nrow = 1L) + + expect_balancing_error(sum_psi_blocks(list(wide_enough, c(1, 2)), n)) +}) + +# The two readings agree only while every block holds doubles. `rowSums()` on +# the assembled stack returns a double whatever the block's storage was, while +# the reduction takes a per-observation row with `sum()`, which returns an +# integer for an integer row and can overflow it to `NA`. No route builds such a +# row today, so the storage is refused where the width is rather than left to +# make the two readings differ. + +test_that("balancing_internal_error: a block that does not hold doubles", { + n <- 4L + wide_enough <- matrix(seq_len(n) + 0.5, nrow = 1L) + + expect_balancing_error(sum_psi_blocks(list(wide_enough, seq_len(n)), n)) +}) + +test_that("the assembly refuses a block that does not hold doubles", { + n <- 4L + wide_enough <- matrix(seq_len(n) + 0.5, nrow = 1L) + + expect_error( + stack_psi_blocks(list(wide_enough, matrix(seq_len(n), nrow = 1L)), n), + class = "balancing_internal_error" + ) +}) + +# The blocks a stack carries are not all matrices, and two kinds of them used to +# be. A route's mean rows were stacked into a block of their own before that +# block was copied into the destination, and its contrast rows were expanded +# into a block holding one value repeated across every column. Both are written +# a row at a time now, and the deterministic rows are written as the single +# value they repeat, so what the assembly returns has to be what stacking those +# blocks returned, to the bit. All four of the kinds a `.by` request puts in the +# stack are present here: the whole-sample mean and contrast rows, and the +# stratum rows of each. + +test_that("stack_psi_blocks() writes rows where blocks were stacked before", { + n <- 5L + weight_block <- matrix(seq_len(2L * n) / 10, nrow = 2L) + score_block <- matrix(seq_len(3L * n) * 2.5, nrow = 3L) + mean_rows <- list(seq_len(n) + 0.25, seq_len(n) - 0.75) + contrast_values <- c(rd = -0.5, "log(rr)" = 0.25, "log(or)" = 1.5) + by_mean_rows <- list(seq_len(n) * 0.5, seq_len(n) * -0.5) + by_contrast_values <- c("rd_g = lo" = 0.1, "rd_g = hi" = -0.2) + + stacked <- stack_psi_blocks( + c( + list(weight_block, score_block), + mean_rows, + constant_psi_rows(contrast_values), + by_mean_rows, + constant_psi_rows(by_contrast_values) + ), + n + ) + + expect_identical( + stacked, + rbind( + weight_block, + score_block, + do.call(rbind, mean_rows), + matrix(contrast_values, nrow = 3L, ncol = n), + do.call(rbind, by_mean_rows), + matrix(by_contrast_values, nrow = 2L, ncol = n) + ) + ) +}) + +# ---- The reduction the bread reads ----------------------------------------- + +# The bread never looks at the stack itself, only at its row sums, so the sums +# are taken block by block where the blocks are built and the S-by-n +# destination is never allocated on that path. That is worth having only while +# the two readings agree to the bit, which is what these state: the reduction of +# a list of blocks has to be the row sums of the matrix the same list assembles +# to, over the shapes a stack presents and over the absent and empty entries a +# route that carries no block of some kind passes. + +test_that("sum_psi_blocks() reduces to the row sums of the assembled stack", { + n <- 5L + weight_block <- matrix(seq_len(2L * n) / 10, nrow = 2L) + score_block <- matrix(seq_len(3L * n) * 2.5, nrow = 3L) + mean_rows <- list(seq_len(n) + 0.25, seq_len(n) - 0.75) + contrast_values <- c(rd = -0.5, "log(rr)" = 0.25, "log(or)" = 1.5) + by_mean_rows <- list(seq_len(n) * 0.5, seq_len(n) * -0.5) + by_contrast_values <- c("rd_g = lo" = 0.1, "rd_g = hi" = -0.2) + + blocks <- c( + list(weight_block, score_block), + mean_rows, + constant_psi_rows(contrast_values), + by_mean_rows, + constant_psi_rows(by_contrast_values) + ) + + expect_identical( + sum_psi_blocks(blocks, n), + unname(rowSums(stack_psi_blocks(blocks, n))) + ) +}) + +test_that("sum_psi_blocks() drops absent and empty blocks as the assembly does", { + n <- 4L + weight_block <- matrix(seq_len(2L * n) / 10, nrow = 2L) + empty_block <- matrix(numeric(0), nrow = 0L, ncol = n) + blocks <- list(weight_block, NULL, empty_block, seq_len(n) + 0.5, 1.25) + + expect_identical( + sum_psi_blocks(blocks, n), + unname(rowSums(stack_psi_blocks(blocks, n))) + ) +}) + +# ---- The assembly a real fit performs -------------------------------------- + +# Four routes build four different sets of blocks: a binary exposure two mean +# rows and one block of contrasts, a categorical one a mean row per level and a +# block of contrasts per non-reference level, a `.by` request two further blocks +# after those, and a declared crossing the same means under contrasts written in +# the two treatments. The whole-sample routes leave the two subgroup blocks +# absent, so between them the four cover the blocks that are always there and +# the ones that are only sometimes. +# +# The two whole-sample routes are stated here. The other two are stated beside +# the fixtures they need, in test-ipw-by.R and test-ipw-joint.R. + +test_that("a binary fit stacks its psi blocks as rbind would", { + data <- ipw_deli_fixture() + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_entropy(), + estimand = "ate" + ) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_deli_outcome( + y ~ exposure + x1, + data, + w, + stats::binomial() + ) + + expect_stacked_psi_matches_rbind(ipw(fit, outcome_mod)) +}) + +test_that("a categorical fit stacks its psi blocks as rbind would", { + data <- ipw_deli_categorical_fixture() + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_entropy(), + estimand = "ate" + ) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_deli_outcome( + y ~ exposure + x1, + data, + w, + stats::binomial() + ) + + expect_stacked_psi_matches_rbind(ipw(fit, outcome_mod)) +}) diff --git a/tests/testthat/test-ipw-joint.R b/tests/testthat/test-ipw-joint.R index 479fe06..6a28fe2 100644 --- a/tests/testthat/test-ipw-joint.R +++ b/tests/testthat/test-ipw-joint.R @@ -27,45 +27,8 @@ # ---- Fixtures -------------------------------------------------------------- -# Two binary treatments, the second depending on the first and both on a -# covariate, with an outcome carrying a real interaction between them. A binary -# and a gaussian outcome are drawn so each reported scale has something to read, -# and a modifier is drawn for the `.by` refusal. -ipw_joint_fixture <- function(n = 700) { - withr::with_seed(4210, { - x1 <- stats::rnorm(n) - a <- stats::rbinom(n, 1L, stats::plogis(0.3 * x1)) - e <- stats::rbinom(n, 1L, stats::plogis(-0.2 + 0.5 * x1 - 0.4 * a)) - y <- stats::rbinom( - n, - 1L, - stats::plogis(-0.5 + 0.7 * a + 0.5 * e + 0.6 * x1 + 0.9 * a * e) - ) - y_cont <- 1 + - 0.6 * a + - 0.4 * e + - 0.5 * x1 + - 0.8 * a * e + - stats::rnorm(n) - data <- data.frame( - x1 = x1, - y = y, - y_cont = y_cont, - a = factor(a, levels = c(0L, 1L)), - e = factor(e, levels = c(0L, 1L)), - modifier = factor( - ifelse(x1 > 0, "hi", "lo"), - levels = c("lo", "hi") - ) - ) - # Assigned rather than built inside `data.frame()`, which would coerce the - # crossing away before anything could read it. - data$joint <- causalgenerics::joint_exposure(a = data$a, e = data$e) - data - }) -} - -# The same two treatments crossed under one name, assembled from the parts +# The two treatments of `ipw_joint_fixture()` in helper-dgp.R crossed under one +# name, assembled from the parts # rather than declared through `causalgenerics::joint_exposure()`, which now # refuses two components sharing a name. # @@ -138,7 +101,7 @@ fit_joint_weights <- function(data, estimand = "ate", focal_level = NULL) { c(x1), method = bw_ipt(), estimand = estimand, - focal_level = focal_level + .focal_level = focal_level ) } @@ -256,7 +219,7 @@ test_that("the fixture declares the crossing the joint surface is written in", { # Every cell is populated, which is what a crossing needs to be identified and # what the four mean rows each stand for. - expect_true(all(table(data$joint) > 0L)) + expect_all(table(data$joint), function(value) value > 0L) }) # A declared column is a factor over the cells, so weighting it is weighting @@ -342,7 +305,7 @@ test_that("a declared crossing reports cell means, simple effects, and their int ) ) expect_identical(nrow(estimates), 14L) - expect_true(all(is.finite(estimates$estimate))) + expect_finite_column(estimates, "estimate") }) # The whole point of the declaration is that the cells stop being the vocabulary @@ -657,10 +620,10 @@ test_that("a declared crossing reports a usable standard error for every row", { estimates <- result$estimates expect_identical(nrow(estimates), 14L) - expect_true(all(is.finite(estimates$std.err))) - expect_true(all(estimates$std.err > 0)) - expect_true(all(estimates$ci.lower < estimates$estimate)) - expect_true(all(estimates$ci.upper > estimates$estimate)) + expect_finite_column(estimates, "std.err") + expect_column_all(estimates, "std.err", function(x) x > 0) + expect_column_all(estimates, "ci.lower", function(x) x < estimates$estimate) + expect_column_all(estimates, "ci.upper", function(x) x > estimates$estimate) expect_equal( unname(sqrt(diag(stats::vcov(result)))), estimates$std.err, @@ -716,6 +679,26 @@ test_that("a declared crossing's covariance couples the rows it reports", { ))) }) +# A declared crossing takes the contrast block over rather than sitting beside +# it, so the assembly of the stacked matrix meets a block of a shape no other +# exposure produces. What the expectation compares is the assembled matrix +# against the `rbind()` of the same blocks, at every evaluation the finite +# difference asks the closure for. + +test_that("a declared crossing stacks its psi blocks as rbind would", { + data <- ipw_joint_fixture() + fit <- fit_joint_weights(data) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_joint_outcome( + y ~ joint + x1, + data, + w, + stats::binomial() + ) + + expect_stacked_psi_matches_rbind(joint_ipw(fit, outcome_mod)) +}) + # ---- Labels ---------------------------------------------------------------- # The measure repeats across the simple effects and the cells, so a row is named @@ -884,7 +867,7 @@ test_that("a declared crossing refuses two treatments under one name", { c("a", "a") ) expect_identical(anyDuplicated(levels(data$joint)), 0L) - expect_true(all(table(data$joint) > 0L)) + expect_all(table(data$joint), function(value) value > 0L) fit <- fit_joint_weights(data) w <- as.numeric(stats::weights(fit)) @@ -1028,3 +1011,89 @@ test_that("a continuous component cannot be declared at all", { causalgenerics::joint_exposure(a = data$a, dose = coarse) )) }) + +# ---- The analytic contrast block ------------------------------------------ + +# A declared crossing replaces the vs-reference contrast block with the simple +# effects and the interaction, and those rows are deterministic on the same +# terms: a simple effect is a contrast of two mean parameters and an interaction +# row is the difference of two simple-effect parameters, so both are constant +# across units and both have bread rows that are known without differencing +# anything. This is the widest contrast block any surface reports, so it is the +# one an analytic bread block saves the most on. +# +# The reference system differences every one of those rows, which is what the +# package does today, and the reported system has to stay identical to it to the +# bit. The evaluation count beside it is red until they leave the differenced +# system. + +test_that("a declared crossing reports the fully differenced stacked system", { + data <- ipw_joint_fixture() + fit <- fit_joint_weights(data) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_joint_outcome(y ~ joint + x1, data, w, stats::binomial()) + + frame <- stats::model.frame(outcome_mod) + joint <- ipw_joint_plan( + frame[["joint"]], + fit@exposure_levels, + is_gaussian_outcome(outcome_mod) + ) + frame[["joint"]] <- ipw_joint_bare(frame[["joint"]]) + reference <- ipw_reference_stack( + container = estimating_equations(fit), + outcome_mod = outcome_mod, + frame = frame, + exposure_name = "joint", + levels = fit@exposure_levels, + categorical = TRUE, + joint = joint + ) + + expect_ipw_matches_reference_stack( + expect_joint_quiet(ipw(fit, outcome_mod)), + reference, + keys = c( + paste0("mu_", joint_cells), + "rd_a: 1 vs 0 e = 0", + "log(rr)_a: 1 vs 0 e = 0", + "rd_a: 1 vs 0 e = 1", + "log(rr)_a: 1 vs 0 e = 1", + "rd_e: 1 vs 0 a = 0", + "log(rr)_e: 1 vs 0 a = 0", + "rd_e: 1 vs 0 a = 1", + "log(rr)_e: 1 vs 0 a = 1", + "rd_a: 1 vs 0 e = 1 vs e = 0", + "log(rr)_a: 1 vs 0 e = 1 vs e = 0" + ) + ) +}) + +test_that("a declared crossing differences no contrast row", { + data <- ipw_joint_fixture() + fit <- fit_joint_weights(data) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_joint_outcome(y ~ joint + x1, data, w, stats::binomial()) + + frame <- stats::model.frame(outcome_mod) + joint <- ipw_joint_plan( + frame[["joint"]], + fit@exposure_levels, + is_gaussian_outcome(outcome_mod) + ) + frame[["joint"]] <- ipw_joint_bare(frame[["joint"]]) + reference <- ipw_reference_stack( + container = estimating_equations(fit), + outcome_mod = outcome_mod, + frame = frame, + exposure_name = "joint", + levels = fit@exposure_levels, + categorical = TRUE, + joint = joint + ) + + expect_stacked_evaluations( + expect_joint_quiet(ipw(fit, outcome_mod)), + 2L * (reference$width - reference$deterministic) + 1L + ) +}) diff --git a/tests/testthat/test-ipw-level-means.R b/tests/testthat/test-ipw-level-means.R index 403ed25..e218298 100644 --- a/tests/testthat/test-ipw-level-means.R +++ b/tests/testthat/test-ipw-level-means.R @@ -294,7 +294,7 @@ test_that("a focal estimand standardizes its mean rows over the focal group", { c(x1, x2), method = bw_entropy(), estimand = "att", - focal_level = "1" + .focal_level = "1" ) w <- as.numeric(stats::weights(fit)) outcome_mod <- fit_level_means_outcome( @@ -362,7 +362,7 @@ test_that("each binary contrast is the transform of the means above it", { # A counterfactual risk is a probability, so both means lie strictly inside # the unit interval and every transform below is defined. - expect_true(all(mu > 0 & mu < 1)) + expect_all(mu, function(value) value > 0 & value < 1) expect_equal(effects[["rd"]], mu[["1"]] - mu[["0"]], tolerance = 1e-8) expect_equal( @@ -396,10 +396,10 @@ test_that("every binary mean row carries usable inference", { means <- level_mean_rows(ipw(fit, outcome_mod)$estimates) - expect_true(all(is.finite(means$std.err))) - expect_true(all(means$std.err > 0)) - expect_true(all(means$ci.lower < means$estimate)) - expect_true(all(means$estimate < means$ci.upper)) + expect_finite_column(means, "std.err") + expect_column_all(means, "std.err", function(x) x > 0) + expect_column_all(means, "ci.lower", function(x) x < means$estimate) + expect_column_all(means, "estimate", function(x) x < means$ci.upper) expect_equal(means$z, means$estimate / means$std.err, tolerance = 1e-12) # The interval is the normal approximation the rest of the table is built on. @@ -649,6 +649,56 @@ test_that("the categorical mean rows match a g-computation plug-in", { ) }) +test_that("a categorical focal estimand standardizes its mean rows over the focal group", { + data <- level_means_categorical_fixture() + # The focal level is neither the reference level nor the last one, so a mean + # block standardized over the wrong group could not pass by coincidence of + # position. + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_ipt(), + estimand = "att", + .focal_level = "b" + ) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_level_means_outcome( + y ~ exposure + x1, + data, + w, + stats::binomial() + ) + + estimates <- ipw(fit, outcome_mod)$estimates + values <- level_mean_values(data$exposure) + tilt <- as.numeric(data$exposure == "b") + + focal <- vapply( + values, + function(value) { + level_mean_plugin(outcome_mod, data, "exposure", value, tilt = tilt) + }, + numeric(1) + ) + pooled <- vapply( + values, + function(value) level_mean_plugin(outcome_mod, data, "exposure", value), + numeric(1) + ) + + expect_equal( + level_mean_rows(estimates)$estimate, + focal, + tolerance = 1e-8 + ) + + # The two standardizations disagree on this fixture, so the assertion above + # is a check on the population averaged over rather than on the predictions + # alone. + expect_false(isTRUE(all.equal(focal, pooled))) +}) + test_that("each categorical contrast is the transform of the two means it names", { data <- level_means_categorical_fixture() fit <- balance( @@ -848,8 +898,8 @@ test_that("a .by fit gives every mean row a usable standard error", { result <- ipw(fit, outcome_mod, .by = modifier) means <- level_mean_rows(result$estimates) - expect_true(all(is.finite(means$std.err))) - expect_true(all(means$std.err > 0)) + expect_finite_column(means, "std.err") + expect_column_all(means, "std.err", function(x) x > 0) # The stratum means are parameters of the same stacked system, so their # standard errors are the diagonal of the sandwich the rest of the table is diff --git a/tests/testthat/test-ipw-msm-basis.R b/tests/testthat/test-ipw-msm-basis.R index 5e69fff..e7d3196 100644 --- a/tests/testthat/test-ipw-msm-basis.R +++ b/tests/testthat/test-ipw-msm-basis.R @@ -148,9 +148,9 @@ expect_basis_msm_accessors <- function(result, effect, outcome_mod) { testthat::expect_identical(estimates$effect, rep(effect, nrow(estimates))) testthat::expect_identical(anyDuplicated(labels), 0L) - testthat::expect_true(all(is.finite(estimates$std.err))) - testthat::expect_true(all(estimates$std.err > 0)) - testthat::expect_true(all(estimates$ci.lower < estimates$ci.upper)) + expect_finite_column(estimates, "std.err") + expect_column_all(estimates, "std.err", function(x) x > 0) + expect_column_all(estimates, "ci.lower", function(x) x < estimates$ci.upper) testthat::expect_identical(result$effects, "conditional") testthat::expect_identical(result$readings, "conditional") @@ -175,14 +175,14 @@ expect_basis_msm_accessors <- function(result, effect, outcome_mod) { covariance <- stats::vcov(result) testthat::expect_equal(covariance, t(covariance), tolerance = 1e-12) off_diagonal <- covariance[upper.tri(covariance)] - testthat::expect_true(all(is.finite(off_diagonal))) + expect_all(off_diagonal, is.finite) testthat::expect_gt(max(abs(off_diagonal)), 1e-8) # The stacked parameter vector names the stored entries by the estimates # table's own labels, which is what lets the stored estimates and standard # errors be read back out of the variance system the result carries. theta <- result$fit$theta - testthat::expect_true(all(labels %in% names(theta))) + expect_all(labels, function(value) value %in% names(theta)) testthat::expect_equal( unname(theta[labels]), estimates$estimate, @@ -781,9 +781,9 @@ test_that("the basis standard errors account for having estimated the weights", numeric(1) ) - expect_true(all(is.finite(reported))) - expect_true(all(reported > 0)) - expect_true(all(abs(reported / naive - 1) > 1e-6)) + expect_all(reported, is.finite) + expect_all(reported, function(value) value > 0) + expect_all(abs(reported / naive - 1), function(value) value > 1e-6) } }) @@ -1221,3 +1221,39 @@ test_that("a basis fit reports the stacked variance system it was read from", { list(names(result$fit$theta), names(result$fit$theta)) ) }) + +# The surface is the one description of what the exposure contributed to the +# outcome design, and the sandwich has to work it out before it can name the +# stacked parameters it returns. Handing it back is what keeps the caller from +# deriving the same description a second time, so the two cannot disagree about +# which columns carry the dose response or what their rows are called. Both +# shapes are pinned, since a lone exposure column and a basis describe the +# surface differently and only one of them is exercised by the naming above. + +test_that("the msm sandwich returns the coefficient surface it named from", { + data <- msm_basis_fixture() + fit <- msm_basis_fit(data) + w <- as.numeric(stats::weights(fit)) + container <- estimating_equations(fit) + + formulas <- list( + bare = y_cont ~ exposure, + basis = y_cont ~ poly(exposure, 2) + ) + + for (formula in formulas) { + outcome_mod <- fit_basis_msm(formula, data, w) + result <- ipw_deli_msm_sandwich( + container = container, + outcome_mod = outcome_mod, + exposure_name = "exposure", + sampling_weights = fit@sampling_weights + ) + + expect_true("surface" %in% names(result)) + expect_identical( + result$surface, + msm_coefficient_identity(outcome_mod, "exposure") + ) + } +}) diff --git a/tests/testthat/test-ipw-pooling.R b/tests/testthat/test-ipw-pooling.R index 242719d..c4b8610 100644 --- a/tests/testthat/test-ipw-pooling.R +++ b/tests/testthat/test-ipw-pooling.R @@ -80,12 +80,12 @@ test_that("pool_ipw() pools balancing results across imputations", { pooled$estimates$contrast, c("0", "1", rep("1 vs 0", 3L)) ) - expect_true(all(is.finite(pooled$estimates$estimate))) - expect_true(all(is.finite(pooled$estimates$std.err))) + expect_finite_column(pooled$estimates, "estimate") + expect_finite_column(pooled$estimates, "std.err") # A finite pooled degrees of freedom is what says the Barnard-Rubin # adjustment ran rather than falling back to a normal reference. - expect_true(all(is.finite(pooled$estimates$df))) + expect_finite_column(pooled$estimates, "df") }) # The complete-data degrees of freedom are looked for on the results first and @@ -113,7 +113,7 @@ test_that("the pooled degrees of freedom fall back to the outcome models", { numeric(1) ) - expect_true(all(is.na(result_df))) + expect_all(result_df, is.na) expect_false(is.na(pooled$dfcom)) expect_false(is.infinite(pooled$dfcom)) expect_equal(pooled$dfcom, min(outcome_df)) @@ -326,7 +326,7 @@ test_that("pool_ipw() over basis fits pools the conditional reading", { expect_identical(pooled$effects, "conditional") expect_identical(pooled$estimates$effect, coefficients) expect_identical(pooled$m, 3L) - expect_true(all(is.finite(pooled$estimates$std.err))) + expect_finite_column(pooled$estimates, "std.err") # Rubin's rule pools point estimates by averaging them, so each pooled row is # the mean of that coefficient across the analyses. Reading the analyses @@ -462,9 +462,9 @@ test_that("pool_ipw() keys grouped balancing results by effect and subgroup", { expect_identical(fit$estimates$group, pooled$estimates$group) } - expect_true(all(is.finite(pooled$estimates$estimate))) - expect_true(all(is.finite(pooled$estimates$std.err))) - expect_true(all(is.finite(pooled$estimates$df))) + expect_finite_column(pooled$estimates, "estimate") + expect_finite_column(pooled$estimates, "std.err") + expect_finite_column(pooled$estimates, "df") # The pooled accessors label their rows by measure, contrast, and subgroup # together, the way each analysis labels its own. diff --git a/tests/testthat/test-ipw.R b/tests/testthat/test-ipw.R index e531f08..addcad5 100644 --- a/tests/testthat/test-ipw.R +++ b/tests/testthat/test-ipw.R @@ -330,6 +330,23 @@ singular_stack <- function(n) { } } +# The same system with one non-finite contribution in it, which is what deli +# refuses before it differences anything. The row is otherwise ordinary, so the +# refusal is about the value rather than about the shape of the return. +nonfinite_stack <- function(n) { + values <- withr::with_seed(707, matrix(stats::rnorm(3L * n), nrow = 3L)) + values <- values - rowMeans(values) + function(theta) { + rows <- rbind( + values[1L, ] - theta[[1L]], + values[2L, ] - theta[[2L]], + values[3L, ] - theta[[3L]] + ) + rows[3L, 1L] <- Inf + rows + } +} + # ---- Estimating-equations container contract ------------------------------ # These pin the container ipw() consumes. The dimension and column-sum @@ -486,7 +503,7 @@ expect_weights_fn_contract <- function(fit, data) { # renormalized base weights, so the ratio is well defined here rather than # merely guarded. raw <- ee@weights_raw - expect_true(all(raw != 0)) + expect_all(raw, function(value) value != 0) rescaled <- (reported / raw) * ee@weight_jacobian finite_diff <- vapply( @@ -617,7 +634,7 @@ for (spec in list( c(x1, x2), method = eval(spec$method), estimand = spec$estimand, - focal_level = spec$focal, + .focal_level = spec$focal, sampling_weights = sampling ) expect_weights_fn_contract(fit, data) @@ -637,7 +654,7 @@ test_that("ipw() returns the binary-outcome effect rows for an entropy fit", { c(x1, x2), method = bw_entropy(), estimand = "att", - focal_level = "1" + .focal_level = "1" ) w <- as.numeric(stats::weights(fit)) outcome_mod <- fit_outcome(y ~ exposure, data, w, stats::binomial()) @@ -661,7 +678,7 @@ test_that("ipw() returns a difference row and its means for a continuous outcome c(x1, x2), method = bw_entropy(), estimand = "att", - focal_level = "1" + .focal_level = "1" ) w <- as.numeric(stats::weights(fit)) outcome_mod <- fit_outcome(y_cont ~ exposure, data, w, stats::gaussian()) @@ -824,8 +841,8 @@ test_that("ipw() standard errors are finite and positive", { result <- ipw(fit, outcome_mod) estimates <- as.data.frame(result) - expect_true(all(is.finite(estimates$std.error))) - expect_true(all(estimates$std.error > 0)) + expect_finite_column(estimates, "std.error") + expect_column_all(estimates, "std.error", function(x) x > 0) }) test_that("a shift-related covariate leaves the ipw() chain identified", { @@ -871,8 +888,8 @@ test_that("a shift-related covariate leaves the ipw() chain identified", { estimates <- as.data.frame(ipw(fit, outcome_mod)) reduced_estimates <- as.data.frame(ipw(reduced, reduced_mod)) - expect_true(all(is.finite(estimates$std.error))) - expect_true(all(estimates$std.error > 0)) + expect_finite_column(estimates, "std.error") + expect_column_all(estimates, "std.error", function(x) x > 0) expect_equal(estimates$estimate, reduced_estimates$estimate) expect_equal(estimates$std.error, reduced_estimates$std.error) }) @@ -939,8 +956,8 @@ test_that("a factor covariate leaves the ipw() sandwich finite", { estimates <- as.data.frame(expect_no_warning(ipw(fit, outcome_mod))) reduced_estimates <- as.data.frame(ipw(reduced, reduced_mod)) - expect_true(all(is.finite(estimates$std.error))) - expect_true(all(estimates$std.error > 0)) + expect_finite_column(estimates, "std.error") + expect_column_all(estimates, "std.error", function(x) x > 0) expect_equal(estimates$estimate, reduced_estimates$estimate, tolerance = 1e-6) expect_equal( estimates$std.error, @@ -1039,7 +1056,7 @@ for (spec in list( c(x1, x2), method = eval(spec$method), estimand = spec$estimand, - focal_level = spec$focal + .focal_level = spec$focal ) w <- as.numeric(stats::weights(fit)) outcome_mod <- fit_outcome(y ~ exposure, data, w, stats::binomial()) @@ -1054,8 +1071,8 @@ for (spec in list( c("mean", "mean", "rd", "log(rr)", "log(or)") ) expect_identical(estimates$contrast, c("0", "1", rep("1 vs 0", 3L))) - expect_true(all(is.finite(estimates$std.error))) - expect_true(all(estimates$std.error > 0)) + expect_finite_column(estimates, "std.error") + expect_column_all(estimates, "std.error", function(x) x > 0) expect_equal(rd_se, oracle_se, tolerance = 1e-8) } ) @@ -1332,7 +1349,7 @@ adjusted_boot_rd_se <- function( c(x1, x2), method = eval(method), estimand = estimand, - focal_level = focal + .focal_level = focal ) boot_w <- as.numeric(stats::weights(boot_fit)) boot_mod <- fit_outcome( @@ -1402,7 +1419,7 @@ for (spec in list( c(x1, x2), method = eval(spec$method), estimand = spec$estimand, - focal_level = spec$focal + .focal_level = spec$focal ) w <- as.numeric(stats::weights(fit)) binary_mod <- fit_outcome( @@ -1494,10 +1511,10 @@ for (spec in list( expect_false(isTRUE(all.equal(pooled_means$mu1, binary_means$mu1))) } - expect_true(all(is.finite(binary_estimates$std.error))) - expect_true(all(binary_estimates$std.error > 0)) - expect_true(all(is.finite(continuous_estimates$std.error))) - expect_true(all(continuous_estimates$std.error > 0)) + expect_finite_column(binary_estimates, "std.error") + expect_column_all(binary_estimates, "std.error", function(x) x > 0) + expect_finite_column(continuous_estimates, "std.error") + expect_column_all(continuous_estimates, "std.error", function(x) x > 0) } ) }) @@ -1576,8 +1593,8 @@ test_that("ipw() standardizes an adjusted model over the sampling weights", { expect_false(isTRUE(all.equal(means$mu0, unweighted$mu0))) expect_equal(result$fit$theta[["mu0"]], means$mu0, tolerance = 1e-8) expect_equal(result$fit$theta[["mu1"]], means$mu1, tolerance = 1e-8) - expect_true(all(is.finite(estimates$std.error))) - expect_true(all(estimates$std.error > 0)) + expect_finite_column(estimates, "std.error") + expect_column_all(estimates, "std.error", function(x) x > 0) }) # The whole family is compared against the independent oracle, across estimands @@ -1644,7 +1661,7 @@ for (spec in list( c(x1, x2), method = eval(spec$method), estimand = spec$estimand, - focal_level = spec$focal + .focal_level = spec$focal ) w <- as.numeric(stats::weights(fit)) outcome_mod <- fit_outcome( @@ -1727,7 +1744,7 @@ test_that("ipw() adjusted-model standard errors track a bootstrap for bw_ipt att c(x1, x2), method = bw_ipt(), estimand = "att", - focal_level = "1" + .focal_level = "1" ) w <- as.numeric(stats::weights(fit)) outcome_mod <- fit_outcome(y ~ exposure + x1 + x2, data, w, stats::binomial()) @@ -1802,7 +1819,7 @@ test_that("supporting adjusted outcome models leaves the marginal ones alone", { c(x1, x2), method = bw_ipt(), estimand = "att", - focal_level = "1" + .focal_level = "1" ) for (fit in list(pooled, focal)) { @@ -1929,7 +1946,7 @@ test_that("ipw() supports an interaction between the exposure and a covariate", c(x1, x2), method = bw_ipt(), estimand = "att", - focal_level = "1" + .focal_level = "1" ) for (spec in list( @@ -1950,8 +1967,8 @@ test_that("ipw() supports an interaction between the exposure and a covariate", means$mu1 - means$mu0, tolerance = 1e-8 ) - expect_true(all(is.finite(estimates$std.error))) - expect_true(all(estimates$std.error > 0)) + expect_finite_column(estimates, "std.error") + expect_column_all(estimates, "std.error", function(x) x > 0) } }) @@ -2037,12 +2054,12 @@ test_that("the categorical estimates table keeps the shared column contract", { ) ) expect_identical(nrow(estimates), 9L) - expect_true(all(is.finite(estimates$estimate))) - expect_true(all(is.finite(estimates$std.err))) - expect_true(all(estimates$ci.lower < estimates$estimate)) - expect_true(all(estimates$ci.upper > estimates$estimate)) - expect_true(all(estimates$conf.level == 0.95)) - expect_true(all(estimates$p.value >= 0 & estimates$p.value <= 1)) + expect_finite_column(estimates, "estimate") + expect_finite_column(estimates, "std.err") + expect_column_all(estimates, "ci.lower", function(x) x < estimates$estimate) + expect_column_all(estimates, "ci.upper", function(x) x > estimates$estimate) + expect_column_all(estimates, "conf.level", function(x) x == 0.95) + expect_column_all(estimates, "p.value", function(x) x >= 0 & x <= 1) expect_equal( estimates$z, estimates$estimate / estimates$std.err, @@ -3409,7 +3426,7 @@ test_that("a categorical att standardizes an adjusted model over the focal group c(x1, x2), method = bw_ipt(), estimand = "att", - focal_level = "b" + .focal_level = "b" ) w <- as.numeric(stats::weights(fit)) outcome_mod <- fit_outcome(y ~ exposure + x1, data, w, stats::binomial()) @@ -3433,8 +3450,8 @@ test_that("a categorical att standardizes an adjusted model over the focal group # move the means. Without that the test would pass on an implementation that # ignored the estimand entirely. expect_false(isTRUE(all.equal(unname(focal), unname(pooled)))) - expect_true(all(is.finite(estimates$std.error))) - expect_true(all(estimates$std.error > 0)) + expect_finite_column(estimates, "std.error") + expect_column_all(estimates, "std.error", function(x) x > 0) }) # The standard errors are checked three ways: they are finite and positive @@ -3458,8 +3475,8 @@ test_that("categorical standard errors are finite and positive", { for (formula in list(y ~ exposure, y ~ exposure + x1, y ~ exposure * x1)) { outcome_mod <- fit_outcome(formula, data, w, stats::binomial()) estimates <- as.data.frame(ipw(fit, outcome_mod)) - expect_true(all(is.finite(estimates$std.error))) - expect_true(all(estimates$std.error > 0)) + expect_finite_column(estimates, "std.error") + expect_column_all(estimates, "std.error", function(x) x > 0) } }) @@ -3643,7 +3660,7 @@ for (spec in list( c(x1, x2), method = eval(spec$method), estimand = spec$estimand, - focal_level = spec$focal + .focal_level = spec$focal ) w <- as.numeric(stats::weights(fit)) outcome_mod <- fit_outcome(y ~ exposure, data, w, stats::binomial()) @@ -3670,8 +3687,8 @@ for (spec in list( unname(means), tolerance = 1e-8 ) - expect_true(all(is.finite(estimates$std.error))) - expect_true(all(estimates$std.error > 0)) + expect_finite_column(estimates, "std.error") + expect_column_all(estimates, "std.error", function(x) x > 0) }) }) } @@ -3816,8 +3833,8 @@ test_that("ipw() respects conf_level", { wide_width <- wide$ci.upper - wide$ci.lower narrow_width <- narrow$ci.upper - narrow$ci.lower - expect_true(all(narrow$conf.level == 0.80)) - expect_true(all(narrow_width < wide_width)) + expect_column_all(narrow, "conf.level", function(x) x == 0.80) + expect_all(narrow_width, function(value) value < wide_width) }) test_that("ipw() rejects an estimand that contradicts the fit", { @@ -3949,6 +3966,71 @@ test_that("ipw() rejects a supplied data frame without two exposure levels", { ) }) +# A design matrix whose columns are linearly dependent leaves the fit with an +# `NA` coefficient for every column the pivoting dropped. The stack reads those +# coefficients back to build the outcome score, so an aliased column makes every +# stacked estimating function non-finite and the variance engine refuses the +# whole sandwich. That refusal names neither the outcome model nor the column +# that caused it, and the caller can only see the fit they passed, so the +# preflight has to read the aliasing off the coefficients and say which column +# is redundant. + +test_that("ipw() rejects an outcome model with an aliased exposure coefficient", { + data <- ipw_fixture() + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_entropy(), + estimand = "ate" + ) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_outcome( + y ~ exposure + I(2 * exposure), + data, + w, + stats::binomial() + ) + + cnd <- expect_error( + ipw(fit, outcome_mod), + class = "balancing_ipw_input_error" + ) + message <- condition_line(cnd) + expect_match(message, "I(2 * exposure)", fixed = TRUE) + expect_match(message, "rank[- ]deficient") + + expect_snapshot(error = TRUE, cnd_class = TRUE, stop(cnd)) +}) + +test_that("ipw() rejects an outcome model with an aliased covariate coefficient", { + data <- ipw_fixture() + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_entropy(), + estimand = "ate" + ) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_outcome( + y ~ exposure + x1 + I(2 * x1), + data, + w, + stats::binomial() + ) + + cnd <- expect_error( + ipw(fit, outcome_mod), + class = "balancing_ipw_input_error" + ) + message <- condition_line(cnd) + expect_match(message, "I(2 * x1)", fixed = TRUE) + expect_match(message, "rank[- ]deficient") + + expect_snapshot(error = TRUE, cnd_class = TRUE, stop(cnd)) +}) + # ---- Weight consistency between the fit and the outcome model ------------- # The stacked variance differentiates the outcome-model score through the @@ -4288,8 +4370,8 @@ test_that("ipw() standard errors with an offset come from the variance engine", sampling_weights = fit@sampling_weights ) - expect_true(all(is.finite(estimates$std.error))) - expect_true(all(estimates$std.error > 0)) + expect_finite_column(estimates, "std.error") + expect_column_all(estimates, "std.error", function(x) x > 0) expect_equal( estimates$std.error, unname(sqrt(diag(engine$vcov))[ @@ -4826,7 +4908,7 @@ test_that("the categorical att cbps psi_fn reproduces the stored psi", { c(x1, x2), method = bw_cbps(), estimand = "att", - focal_level = "b" + .focal_level = "b" ) ee <- estimating_equations(fit) expect_equal(ee@psi_fn(ee@parameters), ee@psi, tolerance = 1e-10) @@ -5161,7 +5243,7 @@ for (spec in list( c(x1, x2), method = eval(spec$method), estimand = spec$estimand, - focal_level = spec$focal + .focal_level = spec$focal ) w <- as.numeric(stats::weights(fit)) outcome_mod <- fit_outcome(y ~ exposure, data, w, stats::binomial()) @@ -5416,7 +5498,7 @@ test_that("the stacked variance tolerates a deficiency the weights are flat alon sampling_weights = fit@sampling_weights ) - expect_true(all(is.finite(sqrt(diag(tolerated$vcov)[keys])))) + expect_all(sqrt(diag(tolerated$vcov)[keys]), is.finite) expect_equal( unname(sqrt(diag(tolerated$vcov)[keys])), unname(sqrt(diag(plain$vcov)[keys])) @@ -5650,6 +5732,52 @@ test_that("stacked_covariance() keeps the generic bullets for a full-rank fit bl expect_no_match(message, "rank", fixed = TRUE) }) +# ---- Translating a non-finite estimating function ------------------------- + +# deli refuses a stack whose estimating functions are not finite at the +# parameters, with a class of its own and a message written about +# `stacked_equations`, an argument the caller never passed and a frame they +# never wrote. Every other condition this route can raise is translated into the +# package's own vocabulary before it reaches them, and this one is translated the +# same way: the balancing class, the package's account of what went wrong, and +# deli's condition chained underneath so the original reading is still there for +# anyone who wants it. + +test_that("stacked_covariance() translates a non-finite estimating function", { + n <- 40L + theta <- c(theta_w1 = 0, theta_w2 = 0, theta_w3 = 0) + refuse <- function() { + stacked_covariance( + nonfinite_stack(n), + theta, + n, + jacobian = diag(c(2, 1, 0.5)) + ) + } + + cnd <- rlang::catch_cnd(refuse(), classes = "error") + expect_s3_class(cnd, "balancing_ipw_unsupported_error") + expect_false(inherits(cnd, "deli_psi_return_error")) + expect_s3_class(cnd$parent, "deli_psi_return_error") + + message <- condition_line(cnd) + expect_match(message, "not finite", fixed = TRUE) + expect_match(message, "bootstrap workflow", fixed = TRUE) +}) + +test_that("the non-finite refusal reads as the package's own", { + n <- 40L + theta <- c(theta_w1 = 0, theta_w2 = 0, theta_w3 = 0) + expect_balancing_error( + stacked_covariance( + nonfinite_stack(n), + theta, + n, + jacobian = diag(c(2, 1, 0.5)) + ) + ) +}) + # The same pair reached the way a caller reaches it. A container carrying one # extra weight parameter with no estimating equation of its own is rank # deficient by construction and its weight map is flat along that direction, so @@ -6254,8 +6382,143 @@ test_that("the deli sandwich carries a unit-varying offset into the means", { binary_se <- sqrt(diag(binary_result$vcov)) continuous_se <- sqrt(diag(continuous_result$vcov)) - expect_true(all(is.finite(binary_se))) - expect_true(all(binary_se > 0)) - expect_true(all(is.finite(continuous_se))) - expect_true(all(continuous_se > 0)) + expect_all(binary_se, is.finite) + expect_all(binary_se, function(value) value > 0) + expect_all(continuous_se, is.finite) + expect_all(continuous_se, function(value) value > 0) +}) + +# ---- The analytic contrast block ------------------------------------------ + +# The contrast rows of the stacked system are deterministic functions of the +# marginal means, so nothing about them has to be discovered by differencing: +# their meat is zero at the solution and their bread rows are minus one on their +# own diagonal, the derivative of the contrast with respect to each mean beside +# it, and zero everywhere else. Filling them in analytically saves two closure +# evaluations per contrast, and each of those evaluations crosses into the +# method's own weight hook over the whole sample. +# +# What must not move is the answer. These specs pin the answer independently of +# the code that produces it: `ipw_reference_stack()` writes the whole system out +# in this suite and differences every row of it, which is what the package does +# today, and the reported system has to stay identical to it to the bit. +# Alongside each of them sits the evaluation count an analytic block reaches, +# which is red until the contrast rows leave the differenced system. + +test_that("a binary fit reports the fully differenced stacked system", { + data <- ipw_fixture() + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_entropy(), + estimand = "ate" + ) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_outcome(y ~ exposure, data, w, stats::binomial()) + + reference <- ipw_reference_stack( + container = estimating_equations(fit), + outcome_mod = outcome_mod, + frame = stats::model.frame(outcome_mod), + exposure_name = "exposure", + levels = fit@exposure_levels + ) + + expect_ipw_matches_reference_stack( + ipw(fit, outcome_mod), + reference, + keys = c("mu0", "mu1", "rd", "log(rr)", "log(or)") + ) +}) + +test_that("a binary fit differences no contrast row", { + data <- ipw_fixture() + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_entropy(), + estimand = "ate" + ) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_outcome(y ~ exposure, data, w, stats::binomial()) + + reference <- ipw_reference_stack( + container = estimating_equations(fit), + outcome_mod = outcome_mod, + frame = stats::model.frame(outcome_mod), + exposure_name = "exposure", + levels = fit@exposure_levels + ) + + expect_stacked_evaluations( + ipw(fit, outcome_mod), + 2L * (reference$width - reference$deterministic) + 1L + ) +}) + +test_that("a categorical fit reports the fully differenced stacked system", { + data <- ipw_categorical_fixture() + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_entropy(), + estimand = "ate" + ) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_outcome(y ~ exposure, data, w, stats::binomial()) + + reference <- ipw_reference_stack( + container = estimating_equations(fit), + outcome_mod = outcome_mod, + frame = stats::model.frame(outcome_mod), + exposure_name = "exposure", + levels = fit@exposure_levels, + categorical = TRUE + ) + + expect_ipw_matches_reference_stack( + ipw(fit, outcome_mod), + reference, + keys = c( + "mu_a", + "mu_b", + "mu_c", + "rd_b", + "log(rr)_b", + "log(or)_b", + "rd_c", + "log(rr)_c", + "log(or)_c" + ) + ) +}) + +test_that("a categorical fit differences no contrast row", { + data <- ipw_categorical_fixture() + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_entropy(), + estimand = "ate" + ) + w <- as.numeric(stats::weights(fit)) + outcome_mod <- fit_outcome(y ~ exposure, data, w, stats::binomial()) + + reference <- ipw_reference_stack( + container = estimating_equations(fit), + outcome_mod = outcome_mod, + frame = stats::model.frame(outcome_mod), + exposure_name = "exposure", + levels = fit@exposure_levels, + categorical = TRUE + ) + + expect_stacked_evaluations( + ipw(fit, outcome_mod), + 2L * (reference$width - reference$deterministic) + 1L + ) }) diff --git a/tests/testthat/test-messages.R b/tests/testthat/test-messages.R index 6781857..dae8784 100644 --- a/tests/testthat/test-messages.R +++ b/tests/testthat/test-messages.R @@ -25,6 +25,150 @@ test_that("balancing_convergence_warning: the iteration cap is reached", { ) }) +# The two families fail the same criterion for opposite reasons, so they are +# advised differently and the difference is asserted rather than snapshotted: a +# snapshot would record the sentences but not that one leads with the tolerance +# and the other with the cap. cli wraps a bullet at the console width, so each +# message is compared with its line breaks folded into single spaces. +flatten_message <- function(condition) { + gsub("[[:space:]]+", " ", conditionMessage(condition)) +} + +test_that("balancing_convergence_warning: a quadratic program leads with the tolerance", { + # The energy quadratic form is indefinite, and once the alternating-direction + # iteration passes its residual floor it walks away from the optimum instead of + # stalling at it. A run that spent its cap therefore did not stop short of the + # answer, and raising the cap makes the iterate worse rather than better. The + # advice leads with loosening the tolerance, says the weights are not to be + # relied on, and mentions the cap last. + data <- sim_binary() + condition <- expect_warning( + balance( + data, + exposure, + c(x1, x2), + method = bw_energy(max_iterations = 5L), + estimand = "ate" + ), + class = "balancing_convergence_warning" + ) + message <- flatten_message(condition) + expect_match(message, "convergence_tolerance", fixed = TRUE) + expect_match(message, "max_iterations", fixed = TRUE) + expect_lt( + regexpr("convergence_tolerance", message, fixed = TRUE), + regexpr("max_iterations", message, fixed = TRUE) + ) + expect_match(message, "weights", fixed = TRUE) + expect_match(message, "rely on|relied on") +}) + +test_that("balancing_convergence_warning: a quadratic program names a reachable tolerance", { + # Telling a caller to loosen a tolerance is no help without a value to loosen + # it to, so a fit that asked for more than the solver can deliver is given one + # the objective reaches. + data <- sim_binary() + condition <- expect_warning( + balance( + data, + exposure, + c(x1, x2), + method = bw_energy(convergence_tolerance = 1e-10, max_iterations = 5L), + estimand = "ate" + ), + class = "balancing_convergence_warning" + ) + expect_match(flatten_message(condition), "1e-0?6") +}) + +test_that("balancing_convergence_warning: an indefinite objective keeps the residual-floor caveat", { + # Energy balancing and the characteristic function distance energy kernel are + # the two indefinite quadratic forms, and the caveat about the residual floor + # is theirs: past that floor the iteration walks away from the optimum, so a + # larger cap makes the iterate worse. + data <- sim_binary() + for (method in list( + bw_energy(max_iterations = 5L), + bw_cfd(kernel = "energy", max_iterations = 5L) + )) { + condition <- expect_warning( + balance(data, exposure, c(x1, x2), method = method, estimand = "ate"), + class = "balancing_convergence_warning" + ) + expect_match(flatten_message(condition), "residual floor", fixed = TRUE) + } +}) + +test_that("balancing_convergence_warning: a positive-semidefinite objective is not given the residual-floor caveat", { + # Every kernel but energy assembles a positive-semidefinite quadratic form, + # whose alternating-direction iteration descends toward the tolerance for as + # long as the cap allows. A run that spent its cap there really did stop short, + # so the cap is an ordinary lever rather than a last resort past a floor. + data <- sim_binary() + condition <- expect_warning( + balance( + data, + exposure, + c(x1, x2), + method = bw_cfd(max_iterations = 5L), + estimand = "ate" + ), + class = "balancing_convergence_warning" + ) + message <- flatten_message(condition) + expect_match(message, "max_iterations", fixed = TRUE) + expect_no_match(message, "residual floor", fixed = TRUE) + expect_no_match(message, "last resort", fixed = TRUE) +}) + +test_that("balancing_convergence_warning: the weights caveat names a solve that met no tolerance", { + # The energy fallback re-solves at a tolerance the problem does reach, and the + # fit still reports itself unconverged because the requested tolerance was not + # met. The caveat therefore has to be about a solve that met no tolerance at + # all rather than about one that missed the tolerance asked for, which would + # contradict the advice above it. + data <- sim_binary() + condition <- expect_warning( + balance( + data, + exposure, + c(x1, x2), + method = bw_energy(max_iterations = 5L), + estimand = "ate" + ), + class = "balancing_convergence_warning" + ) + expect_match( + flatten_message(condition), + "met no tolerance", + fixed = TRUE + ) +}) + +test_that("balancing_convergence_warning: the estimating-equation wording is unchanged", { + # The entropy and tilting solvers descend monotonically, so a run that spent its + # cap really did stop short and more iterations really do help. Their advice + # keeps leading with the cap, which is what separates the two families, and this + # spec holds it fixed while the quadratic-program wording moves. + withr::local_options(balancing.entropy_solver = "newton") + data <- sim_binary() + condition <- expect_warning( + balance( + data, + exposure, + c(x1, x2), + method = bw_entropy(max_iterations = 3L), + estimand = "ate" + ), + class = "balancing_convergence_warning" + ) + expect_match( + flatten_message(condition), + "Increase `max_iterations` or loosen `convergence_tolerance`", + fixed = TRUE + ) +}) + test_that("balancing_balance_warning: achieved balance exceeds the tolerance", { # A continuous tolerance without the second distribution moment leaves the # exposure variance free, so the weighted correlation exceeds the requested @@ -42,6 +186,40 @@ test_that("balancing_balance_warning: achieved balance exceeds the tolerance", { ) }) +# The two cases below assert the rendered magnitude directly rather than through +# a snapshot, because the value is the whole point of the sentence and a snapshot +# would record whatever the formatter happens to produce. + +test_that("balancing_balance_warning: a residual imbalance keeps its magnitude", { + # The warning names how far the fit missed, so an imbalance smaller than the + # display precision still has to read as a number. Printed at a fixed number of + # decimal places, 4.9e-06 becomes "0.0000", which states that the fit balanced + # exactly and contradicts the sentence above it. + condition <- expect_warning( + warn_balance_exceeded(4.9e-06), + class = "balancing_balance_warning" + ) + expect_match( + conditionMessage(condition), + "The largest imbalance is 4.9e-06.", + fixed = TRUE + ) +}) + +test_that("balancing_balance_warning: an ordinary imbalance stays legible", { + # The same format has to leave an imbalance at the scale a caller acts on + # readable, which is three significant digits rather than four decimal places. + condition <- expect_warning( + warn_balance_exceeded(0.1751), + class = "balancing_balance_warning" + ) + expect_match( + conditionMessage(condition), + "The largest imbalance is 0.175.", + fixed = TRUE + ) +}) + test_that("balancing_ignored_argument_warning: two_step without over_identified", { # The two-step weighting matrix belongs to the over-identified criterion, so # requesting it on a just-identified fit has no effect; the fit warns that the @@ -156,7 +334,7 @@ test_that("balancing_ignored_argument_warning: a clarabel pin energy balancing c ) }) -test_that("balancing_ignored_argument_warning: focal_level with a pooled estimand", { +test_that("balancing_ignored_argument_warning: .focal_level with a pooled estimand", { # The average treatment effect reweights every exposure group rather than # holding one fixed, so it has no focal level to resolve and a supplied one is # never validated against the data. The fit names the estimand that ignores it. @@ -168,7 +346,7 @@ test_that("balancing_ignored_argument_warning: focal_level with a pooled estiman c(x1, x2), method = bw_entropy(), estimand = "ate", - focal_level = 1 + .focal_level = 1 ) ) }) diff --git a/tests/testthat/test-method-cbps.R b/tests/testthat/test-method-cbps.R index 7c60569..764157f 100644 --- a/tests/testthat/test-method-cbps.R +++ b/tests/testthat/test-method-cbps.R @@ -231,7 +231,7 @@ test_that("bw_cbps balances a binary ate", { estimand = "ate" ) expect_arms_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("a binary ate fit reports arm-to-arm balance without a balance warning", { @@ -263,7 +263,7 @@ test_that("bw_cbps balances a binary att", { estimand = "att" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("bw_cbps balances a binary atc", { @@ -276,7 +276,7 @@ test_that("bw_cbps balances a binary atc", { estimand = "atc" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("the convergence verdict does not move with the sampling-weight scale", { @@ -377,7 +377,7 @@ test_that("the over-identified verdict does not move with the sampling-weight sc # ---- Explicit focal level on a binary exposure ---------------------------- # A binary focal estimand infers its target from the estimand alone only when the -# caller leaves focal_level unset. An explicit focal_level names the target +# caller leaves .focal_level unset. An explicit .focal_level names the target # population directly, so "att" with the first level as the focal targets that # level rather than the treated one, and "atu" with the second level targets the # treated one. The focal group then keeps its base weight and the other group is @@ -400,7 +400,7 @@ expect_tilted_to_focal <- function(fit, .data, focal_level) { } } -test_that("a binary att honors an explicit focal_level", { +test_that("a binary att honors an explicit .focal_level", { data <- sim_binary() fit <- balance( data, @@ -408,7 +408,7 @@ test_that("a binary att honors an explicit focal_level", { c(x1, x2), method = bw_cbps(), estimand = "att", - focal_level = "0" + .focal_level = "0" ) expect_identical(fit@estimand, "att") expect_identical(fit@focal_level, "0") @@ -425,7 +425,7 @@ test_that("a binary att honors an explicit focal_level", { c(x1, x2), method = bw_ipt(), estimand = "att", - focal_level = "0" + .focal_level = "0" ) expect_equal( normalize_by_group(w, data$exposure), @@ -434,7 +434,7 @@ test_that("a binary att honors an explicit focal_level", { ) }) -test_that("a binary atu honors an explicit focal_level", { +test_that("a binary atu honors an explicit .focal_level", { data <- sim_binary() fit <- balance( data, @@ -442,7 +442,7 @@ test_that("a binary atu honors an explicit focal_level", { c(x1, x2), method = bw_cbps(), estimand = "atu", - focal_level = "1" + .focal_level = "1" ) expect_identical(fit@estimand, "atu") expect_identical(fit@focal_level, "1") @@ -459,7 +459,7 @@ test_that("a binary atu honors an explicit focal_level", { c(x1, x2), method = bw_ipt(), estimand = "atu", - focal_level = "1" + .focal_level = "1" ) expect_equal( normalize_by_group(w, data$exposure), @@ -468,7 +468,7 @@ test_that("a binary atu honors an explicit focal_level", { ) }) -test_that("an explicit focal_level agrees with the estimand that infers it", { +test_that("an explicit .focal_level agrees with the estimand that infers it", { # Naming the first level as the focal for "att" targets the same population the # untreated estimand infers, so the two fits solve the same problem and their # weights agree; the same holds for "atu" against the treated target. @@ -479,7 +479,7 @@ test_that("an explicit focal_level agrees with the estimand that infers it", { c(x1, x2), method = bw_cbps(), estimand = "att", - focal_level = "0" + .focal_level = "0" ) atu_inferred <- balance( data, @@ -500,7 +500,7 @@ test_that("an explicit focal_level agrees with the estimand that infers it", { c(x1, x2), method = bw_cbps(), estimand = "atu", - focal_level = "1" + .focal_level = "1" ) att_inferred <- balance( data, @@ -516,7 +516,7 @@ test_that("an explicit focal_level agrees with the estimand that infers it", { ) }) -test_that("an over-identified binary fit honors an explicit focal_level", { +test_that("an over-identified binary fit honors an explicit .focal_level", { # The over-identified criterion stacks the response-residual moments onto the same # balancing conditions, so it reads the focal level through the same estimand # the just-identified form does. Naming the first level as the focal for "att" @@ -528,7 +528,7 @@ test_that("an over-identified binary fit honors an explicit focal_level", { c(x1, x2), method = bw_cbps(over_identified = TRUE), estimand = "att", - focal_level = "0" + .focal_level = "0" ) inferred <- balance( data, @@ -583,7 +583,7 @@ test_that("bw_cbps balances a categorical ate", { estimand = "ate" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("bw_cbps balances a categorical att", { @@ -594,10 +594,10 @@ test_that("bw_cbps balances a categorical att", { c(x1, x2), method = bw_cbps(), estimand = "att", - focal_level = "b" + .focal_level = "b" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) # ---- Statistical promises: continuous ------------------------------------- @@ -614,7 +614,7 @@ test_that("bw_cbps balances a continuous ate on the correlation scale", { estimand = "ate" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) # ---- Group sums ----------------------------------------------------------- @@ -729,7 +729,7 @@ test_that("bw_cbps ato weights take the overlap form", { estimand = "ato" ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) # Overlap weighting tilts by the overlap factor h = p(1 - p): a treated unit # is weighted by (1 - p) and a control unit by p, evaluated at the fitted @@ -820,7 +820,7 @@ test_that("the stored coefficients model the second level for every estimand", { c(x1, x2), method = bw_cbps(), estimand = estimand, - focal_level = focal_level + .focal_level = focal_level ) } } @@ -956,7 +956,7 @@ test_that("each link function fits and balances a binary ate", { estimand = "ate" ) expect_arms_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) } }) @@ -1264,7 +1264,7 @@ test_that("an over-identified fit succeeds and records its criterion", { method = bw_cbps(over_identified = TRUE), estimand = "ate" ) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) # The GMM criterion is recorded on the objective slot. expect_type(fit@objective, "double") expect_true(is.finite(fit@objective)) @@ -1432,7 +1432,7 @@ test_that("just-identified bw_cbps weights match WeightIt for a binary att with c(x1, x2), method = bw_cbps(), estimand = "att", - focal_level = "0" + .focal_level = "0" ) reference <- WeightIt::weightit( exposure ~ x1 + x2, diff --git a/tests/testthat/test-method-cfd-oracle.R b/tests/testthat/test-method-cfd-oracle.R index 44975cf..a3f543c 100644 --- a/tests/testthat/test-method-cfd-oracle.R +++ b/tests/testthat/test-method-cfd-oracle.R @@ -222,7 +222,7 @@ expect_cfd_matches_oracle <- function( c(x1, x2), method = bw_cfd(kernel = kernel, weight_penalty = penalty), estimand = estimand, - focal_level = focal_level + .focal_level = focal_level ) expect_true(fit@converged) @@ -276,8 +276,8 @@ expect_cfd_matches_oracle <- function( # neither objective is read at an infeasible point. expect_lt(max(abs(qp$eq %*% oracle$x - 1)), 1e-6) expect_lt(max(abs(qp$eq %*% solver_weights - 1)), 1e-6) - expect_true(all(oracle$x >= min_weight - 1e-8)) - expect_true(all(solver_weights >= min_weight - 1e-8)) + expect_column_all(oracle, "x", function(value) value >= min_weight - 1e-8) + expect_all(solver_weights, function(value) value >= min_weight - 1e-8) # A strictly convex program has a unique minimizer, so the weight vectors agree, # not only the objective. The indefinite energy assembly is compared on the diff --git a/tests/testthat/test-method-cfd.R b/tests/testthat/test-method-cfd.R index 17130dc..db1395f 100644 --- a/tests/testthat/test-method-cfd.R +++ b/tests/testthat/test-method-cfd.R @@ -164,7 +164,7 @@ test_that("a smoothness the constructor accepts always reaches the kernel", { estimand = "ate" ) expect_identical(fit@method@smoothness, 1.5) - expect_true(all(is.finite(as.numeric(stats::weights(fit))))) + expect_all(as.numeric(stats::weights(fit)), is.finite) }) test_that("bw_cfd() rejects a negative weight penalty", { @@ -317,8 +317,8 @@ test_that("a binary ate normalizes each group to its size", { estimand = "ate" ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) - expect_true(all(w >= 1e-8)) + expect_all(w, function(value) value >= 0) + expect_all(w, function(value) value >= 1e-8) treated <- data$exposure == 1 expect_equal(sum(w[treated]), sum(treated), tolerance = 1e-4) expect_equal(sum(w[!treated]), sum(!treated), tolerance = 1e-4) @@ -343,7 +343,7 @@ test_that("a binary att targets the treated total in both groups", { n_treated <- sum(treated) expect_equal(sum(w[treated]), n_treated, tolerance = 1e-4) expect_equal(sum(w[!treated]), n_treated, tolerance = 1e-4) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) expect_balanced(fit, data, tolerance = 0.1) }) @@ -357,8 +357,8 @@ test_that("a binary atc fit produces non-negative floored weights", { estimand = "atc" ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) - expect_true(all(w >= 1e-8)) + expect_all(w, function(value) value >= 0) + expect_all(w, function(value) value >= 1e-8) expect_balanced(fit, data, tolerance = 0.1) }) @@ -405,12 +405,12 @@ test_that("kernel balancing balances a factor covariate", { expect_true(fit@converged) expect_equal(sum(w[treated]), sum(treated), tolerance = 1e-4) expect_equal(sum(w[!treated]), control_target, tolerance = 1e-4) - expect_true(all(w >= 1e-8)) + expect_all(w, function(value) value >= 1e-8) # Every level's gap closes by at least a factor of four and lands inside a # ceiling no unweighted level clears. weighted <- level_gaps(w) - expect_true(all(weighted < unweighted / 4)) + expect_all(weighted, function(value) value < unweighted / 4) expect_lt(max(weighted), 0.01) expect_balanced(fit, data, tolerance = 0.1) } @@ -476,7 +476,7 @@ test_that("the per-group effective sample size rises with the weight penalty", { curve <- lapply(penalties, ess_at) for (step in seq_len(length(curve) - 1L)) { - expect_true(all(curve[[step + 1L]] > curve[[step]])) + expect_all(curve[[step + 1L]], function(value) value > curve[[step]]) } }) @@ -516,7 +516,7 @@ test_that("categorical ate kernel balancing produces valid weights", { estimand = "ate" ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) for (level in levels(data$exposure)) { idx <- data$exposure == level expect_equal(sum(w[idx]), sum(idx), tolerance = 1e-4) @@ -532,10 +532,10 @@ test_that("categorical att kernel balancing produces valid weights", { c(x1, x2), method = bw_cfd(), estimand = "att", - focal_level = "b" + .focal_level = "b" ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) expect_balanced(fit, data, tolerance = 0.1) }) @@ -557,8 +557,8 @@ test_that("every kernel converges to valid, floored weights", { fit <- fit_of(method) w <- as.numeric(stats::weights(fit)) expect_true(fit@converged) - expect_true(all(w >= 0)) - expect_true(all(w >= 1e-8)) + expect_all(w, function(value) value >= 0) + expect_all(w, function(value) value >= 1e-8) } }) @@ -753,6 +753,11 @@ test_that("moment constraints are satisfied within tolerance", { }) test_that("a positive tolerance relaxes the moment constraints", { + # A fit that did place rows in the requested band holds them there and reports + # that band as the tolerance it enforced, leaving the enforced tolerance unset + # so the table reads the per-column values the specification named. That is the + # other side of the zero the ignored-tolerance spec below pins, and it is + # reached on kernel balancing's own path rather than only on energy's. data <- sim_binary() fit <- balance( data, @@ -763,6 +768,11 @@ test_that("a positive tolerance relaxes the moment constraints", { constraints = balance_terms(moments = 1L, tolerance = 0.1) ) expect_balanced(fit, data, tolerance = 0.1) + expect_column_all( + as.data.frame(fit@balance_table), + "tolerance", + function(value) value == 0.1 + ) }) test_that("a tolerance without moment constraints warns and is ignored", { @@ -795,6 +805,48 @@ test_that("a tolerance without moment constraints warns and is ignored", { ) }) +test_that("a fit that added no constraint rows reports the tolerance it enforced", { + # A tolerance with no moment constraints to relax reaches no row of the + # program, so the table must not report it as the fit's tolerance: the fit + # enforced nothing, which is a tolerance of zero. A fit that did add rows + # holds them inside the requested band and reports that band, which the + # relaxation spec above covers. + data <- sim_binary(n = 200) + expect_warning( + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_cfd(), + estimand = "ate", + constraints = balance_terms(tolerance = 0.1) + ), + class = "balancing_ignored_argument_warning" + ) + expect_column_all( + as.data.frame(fit@balance_table), + "tolerance", + function(value) value == 0 + ) +}) + +test_that("the ignored-tolerance warning records its class and printed tolerance", { + # The printed block reads its tolerance from the balance table, so it is the + # visible half of the same contract: a fit given a band it never placed a row + # in reports the zero it enforced. + data <- sim_binary(n = 150) + expect_balancing_warning( + balance( + data, + exposure, + c(x1, x2), + method = bw_cfd(), + estimand = "ate", + constraints = balance_terms(tolerance = 0.1) + ) + ) +}) + # ---- Diagnostics ---------------------------------------------------------- test_that("the fit reports dual variables and the quadratic-program backend", { @@ -987,3 +1039,50 @@ test_that("a kernel balancing fit prints its summary block", { fit }) }) + +# ---- Solver tolerance box ------------------------------------------------- + +# The moment-constraint band a kernel balancing fit hands the solver is built by +# `solver_box()` (R/method-entropy.R), which the CFD assembly calls directly at +# R/method-cfd.R with the prepared matrix, the requested tolerances, and the +# sampling weights. A tolerance is written on the standardized scale, so the box +# converts it by the column's standard deviation, and a column holding one value +# repeated has no spread to convert against: its box is the tolerance itself. +# +# It does not arrive that way on its own. The weighted center divides a sum of +# products by a sum of weights and need not return the repeated value exactly, +# so the centered column carries a rounding residual and the computed scale +# reports that residual as the column's spread. Left alone, the constant 0.98 +# column below shrinks its own band by roughly fifteen orders of magnitude and +# the fit is constrained against rounding. This pins the guard on the call the +# CFD path makes rather than only on the entropy one. +cfd_solver_box_fixture <- function() { + withr::with_seed(707, { + n <- 300L + z <- cbind( + stats::rnorm(n), + stats::runif(n, -2, 3), + rep(0.98, n), + as.numeric(stats::rbinom(n, 1L, 0.4)) + ) + list(z = z, sampling_weights = stats::runif(n, 0.3, 2.5)) + }) +} + +test_that("the kernel balancing tolerance box leaves a constant column raw", { + fixture <- cfd_solver_box_fixture() + z <- fixture$z + w <- fixture$sampling_weights + tolerances <- seq_len(ncol(z)) / 100 + constant <- 3L + + expect_all(z[, constant], function(value) value == 0.98) + expect_identical( + solver_box(z, tolerances, w)[[constant]], + tolerances[[constant]] + ) + expect_identical( + solver_box(z, tolerances)[[constant]], + tolerances[[constant]] + ) +}) diff --git a/tests/testthat/test-method-energy.R b/tests/testthat/test-method-energy.R index 322b3bf..7884edc 100644 --- a/tests/testthat/test-method-energy.R +++ b/tests/testthat/test-method-energy.R @@ -103,10 +103,24 @@ test_that("bw_energy() carries its documented defaults", { expect_identical(spec@min_weight, 1e-8) expect_null(spec@distribution_moments) expect_true(spec@dimension_adjustment) - expect_null(spec@convergence_tolerance) + expect_identical(spec@convergence_tolerance, 1e-6) expect_null(spec@max_iterations) }) +test_that("the loosened solver tolerance is energy's alone", { + # Energy is the one quadratic program whose objective matrix is indefinite by + # construction, and the negative curvature it carries grows as the sample + # shrinks, so below a certain size the alternating-direction iteration stops + # contracting: its residuals bottom out well above 1e-8 and then grow. The + # method therefore names its own tolerance rather than taking the core default, + # and the two positive-semidefinite quadratic programs still take it. The + # contrast is pinned here so a later change to the shared default cannot move + # energy with it, and so a change to energy's cannot leak into the others. + expect_identical(bw_energy()@convergence_tolerance, 1e-6) + expect_null(bw_sbw()@convergence_tolerance) + expect_null(bw_cfd()@convergence_tolerance) +}) + test_that("bw_energy() stores supplied tuning parameters", { spec <- bw_energy( distance = "mahalanobis", @@ -181,7 +195,7 @@ test_that("bw_energy() rejects missing or multi-element distribution moments", { }) test_that("bw_energy() rejects a non-positive convergence tolerance", { - expect_null(bw_energy()@convergence_tolerance) + expect_identical(bw_energy()@convergence_tolerance, 1e-6) expect_error(bw_energy(convergence_tolerance = -1e-8)) }) @@ -253,8 +267,8 @@ test_that("energy balancing reduces the binary ate energy distance", { estimand = "ate" ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) - expect_true(all(w >= 1e-8)) + expect_all(w, function(value) value >= 0) + expect_all(w, function(value) value >= 1e-8) # Energy balancing drives balance through its objective rather than exact # moment constraints, so the achieved first-moment imbalance is verified @@ -297,7 +311,7 @@ test_that("a binary att targets the treated total in both groups", { n_treated <- sum(treated) expect_equal(sum(w[treated]), n_treated, tolerance = 1e-4) expect_equal(sum(w[!treated]), n_treated, tolerance = 1e-4) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) expect_balanced(fit, data, tolerance = 0.1) }) @@ -311,8 +325,8 @@ test_that("a binary atc fit produces non-negative weights", { estimand = "atc" ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) - expect_true(all(w >= 1e-8)) + expect_all(w, function(value) value >= 0) + expect_all(w, function(value) value >= 1e-8) expect_balanced(fit, data, tolerance = 0.1) }) @@ -360,12 +374,12 @@ test_that("energy balancing balances a factor covariate", { expect_true(fit@converged) expect_equal(sum(w[treated]), sum(treated), tolerance = 1e-4) expect_equal(sum(w[!treated]), control_target, tolerance = 1e-4) - expect_true(all(w >= 1e-8)) + expect_all(w, function(value) value >= 1e-8) # Every level's gap closes by at least a factor of four and lands inside a # ceiling no unweighted level clears. weighted <- level_gaps(w) - expect_true(all(weighted < unweighted / 4)) + expect_all(weighted, function(value) value < unweighted / 4) expect_lt(max(weighted), 0.01) expect_balanced(fit, data, tolerance = 0.1) } @@ -432,7 +446,7 @@ test_that("the per-group effective sample size rises with the weight penalty", { curve <- lapply(penalties, ess_at) for (step in seq_len(length(curve) - 1L)) { - expect_true(all(curve[[step + 1L]] > curve[[step]])) + expect_all(curve[[step + 1L]], function(value) value > curve[[step]]) } }) @@ -473,7 +487,7 @@ test_that("categorical ate energy balancing produces valid weights", { estimand = "ate" ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) for (level in levels(data$exposure)) { idx <- data$exposure == level expect_equal(sum(w[idx]), sum(idx), tolerance = 1e-4) @@ -489,10 +503,10 @@ test_that("categorical att energy balancing produces valid weights", { c(x1, x2), method = bw_energy(), estimand = "att", - focal_level = "b" + .focal_level = "b" ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) expect_balanced(fit, data, tolerance = 0.1) }) @@ -756,7 +770,7 @@ test_that("continuous energy balancing reduces the distance covariance", { estimand = "ate" ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) covariates <- as.matrix(data[c("x1", "x2")]) weighted <- weighted_distance_covariance(data$exposure, covariates, w) @@ -821,7 +835,7 @@ test_that("a continuous fit preserves an indicator covariate's marginal", { ) # The stratum keeps its share of the total weight rather than being annihilated. expect_equal(sum(w[data$g == 1]), sum(data$g == 1), tolerance = 1e-4) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) }) test_that("a continuous fit holds the base-measure marginals under sampling weights", { @@ -1002,6 +1016,424 @@ test_that("dimension_adjustment toggles the continuous solution", { ))) }) +# ---- Continuous correlation constraints ----------------------------------- + +# The weighted exposure-covariate Pearson correlation the balance table reports, +# computed here so the specs below judge the fit on the statistic a reader sees +# rather than on the solver's own row. +weighted_correlation <- function(exposure, column, weights) { + abs(stats::cov.wt(cbind(exposure, column), wt = weights, cor = TRUE)$cor[ + 1, + 2 + ]) +} + +test_that("moments requests exposure-covariate correlation constraints", { + # For a continuous exposure `balance_terms(moments = k)` asks for the weighted + # correlation of the exposure with each covariate power up to k to be held at + # zero, the meaning `moments` carries for a discrete exposure and the meaning + # WeightIt gives its own `moments` argument. The energy objective alone leaves + # a residual correlation of a tenth or more at these sample sizes, so a fit + # that meets this really did add the rows. + data <- sim_continuous(n = 350) + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy(), + estimand = "ate", + constraints = balance_terms(moments = 1L) + ) + w <- as.numeric(stats::weights(fit)) + for (column in c("x1", "x2")) { + expect_lt(weighted_correlation(data$exposure, data[[column]], w), 1e-6) + } + + default <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy(), + estimand = "ate" + ) + w_default <- as.numeric(stats::weights(default)) + expect_gt(weighted_correlation(data$exposure, data$x1, w_default), 0.05) +}) + +test_that("a second moment constrains the correlation with the covariate squares", { + # Each power of a covariate is its own constraint column, so the second moment + # adds the correlation of the exposure with the squares alongside the first. + data <- sim_continuous(n = 350) + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy(), + estimand = "ate", + constraints = balance_terms(moments = 2L) + ) + w <- as.numeric(stats::weights(fit)) + for (column in c("x1", "x2")) { + values <- data[[column]] + expect_lt(weighted_correlation(data$exposure, values, w), 1e-6) + expect_lt( + weighted_correlation(data$exposure, (values - mean(values))^2, w), + 1e-6 + ) + } +}) + +test_that("interactions constrain the correlation with the product column", { + # `interactions = TRUE` adds the product of two covariates as a constraint + # column, which on the continuous path is one more correlation row. + data <- sim_continuous(n = 350) + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy(), + estimand = "ate", + constraints = balance_terms(interactions = TRUE) + ) + w <- as.numeric(stats::weights(fit)) + expect_lt( + weighted_correlation(data$exposure, data$x1 * data$x2, w), + 1e-6 + ) +}) + +test_that("the balance table reports the correlation rows the fit constrained", { + # The rows a continuous fit constrains are the rows the table reports, so a + # second-moment request shows four correlation rows, each met within its + # tolerance. + data <- sim_continuous(n = 350) + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy(), + estimand = "ate", + constraints = balance_terms(moments = 2L) + ) + table <- as.data.frame(fit@balance_table) + expect_identical(table$term, c("x1", "x1^2", "x2", "x2^2")) + expect_true(all(table$statistic == "correlation")) + expect_lt(max(table$weighted), 1e-6) + expect_true(all(table$within_tolerance)) +}) + +# A continuous fit's achieved weighted exposure-covariate correlations, the +# statistic the correlation rows are judged on and the one the balance table +# reports. +achieved_correlations <- function(fit, data, covariates) { + w <- as.numeric(stats::weights(fit)) + vapply( + covariates, + function(covariate) { + weighted_correlation(data$exposure, data[[covariate]], w) + }, + numeric(1) + ) +} + +test_that("a continuous tolerance is honored as a band rather than held exactly", { + # The correlation rows are relaxable. The quadratic program bounds a + # linearized correlation whose exposure and covariate scales are fixed at the + # sample, so a single solve at the requested band overshoots it; the fit + # tightens the bound it hands the program over a few passes until the reported + # correlation sits inside the band. What that has to show is both halves: no + # correlation above the band, and at least one well inside it rather than at + # the zero exact rows would produce, so the band is used rather than ignored. + data <- sim_continuous(n = 350) + fit <- expect_no_warning(balance( + data, + exposure, + c(x1, x2), + method = bw_energy(), + estimand = "ate", + constraints = balance_terms(moments = 1L, tolerance = 0.05) + )) + achieved <- achieved_correlations(fit, data, c("x1", "x2")) + + expect_all(achieved, function(r) r <= 0.05 + balance_margin(0.05)) + expect_gt(max(achieved), 0.5 * 0.05) +}) + +test_that("a continuous tolerance of zero still holds the rows exactly", { + # Exact balance is the tolerance the refinement has nothing to tighten, so it + # reaches the same solution it always did, in a single solve. + data <- sim_continuous(n = 350) + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy(), + estimand = "ate", + constraints = balance_terms(moments = 1L) + ) + achieved <- achieved_correlations(fit, data, c("x1", "x2")) + + expect_all(achieved, function(r) r < 1e-6) +}) + +test_that("the refinement takes several passes and sums their iterations", { + # The pass count is what separates an honored band from a single overshooting + # solve, so it is counted at the solver rather than inferred from the weights, + # and the reported iterations have to account for every pass rather than for + # the last one alone. Exact balance is the control: it has nothing to tighten + # and takes one solve. + data <- sim_continuous(n = 350) + solves <- 0L + per_solve <- integer() + original <- solve_energy_cont + testthat::local_mocked_bindings( + solve_energy_cont = function(...) { + result <- original(...) + solves <<- solves + 1L + per_solve <<- c(per_solve, as.integer(result$iterations)) + result + } + ) + + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy(), + estimand = "ate", + constraints = balance_terms(moments = 1L, tolerance = 0.05) + ) + expect_gt(solves, 1L) + expect_identical(fit@iterations, sum(per_solve)) + + solves <- 0L + balance( + data, + exposure, + c(x1, x2), + method = bw_energy(), + estimand = "ate", + constraints = balance_terms(moments = 1L) + ) + expect_identical(solves, 1L) +}) + +test_that("a tightened pass that stops at the iteration cap keeps the last converged iterate", { + # A tightened bound is harder than the one before it, so a pass can spend the + # iteration cap on a band an earlier pass met comfortably. What the fit reports + # then is the last iterate that converged rather than the unsettled one the + # tightened pass left behind: the weights are the earlier pass's, the fit + # reports itself converged, and the correlations that iterate actually achieved + # sit above the requested band, so the ordinary balance warning judges them + # instead of a convergence warning claiming the solve failed. The reported + # iterations still account for every pass, the failed one included, because + # each pass cost a whole solve. + data <- sim_continuous(n = 350) + solves <- 0L + per_solve <- integer() + first_weights <- NULL + original <- solve_energy_cont + testthat::local_mocked_bindings( + solve_energy_cont = function(...) { + result <- original(...) + solves <<- solves + 1L + per_solve <<- c(per_solve, as.integer(result$iterations)) + if (solves == 1L) { + first_weights <<- as.numeric(result$weights) + } else { + result$converged <- FALSE + result$status <- "max_iter" + } + result + } + ) + + # Every warning is collected rather than one being matched, so a convergence + # warning raised alongside the balance warning fails here instead of passing + # under an expectation that looked only for the one it wanted. + seen <- character() + fit <- withCallingHandlers( + balance( + data, + exposure, + c(x1, x2), + # Pinned at the tolerance the problem is taken to reach, so the mocked + # failure cannot draw in the re-solve fallback and the two solves counted + # here are the two refinement passes. + method = bw_energy(convergence_tolerance = 1e-6), + estimand = "ate", + constraints = balance_terms(moments = 1L, tolerance = 0.05) + ), + warning = function(cnd) { + seen <<- c(seen, class(cnd)[[1]]) + invokeRestart("muffleWarning") + } + ) + + expect_identical(seen, "balancing_balance_warning") + expect_identical(solves, 2L) + expect_true(fit@converged) + expect_identical(fit@iterations, sum(per_solve)) + + # The reported weights renormalize the solver's, so the restored iterate shows + # as proportionality to the first pass's raw weights rather than as equality. + w <- as.numeric(stats::weights(fit)) + expect_equal( + w / sum(w), + first_weights / sum(first_weights), + tolerance = 1e-10 + ) + + table <- as.data.frame(fit@balance_table) + expect_all(table$weighted, function(r) r > 0.05 + balance_margin(0.05)) + expect_column_all(table, "within_tolerance", function(value) !value) +}) + +test_that("a tightened pass certified infeasible raises rather than restoring", { + # The other half of the same guard. An infeasibility certificate is a claim + # about the constraint set, not about the iteration cap, so restoring the + # looser iterate would answer a band the solver said cannot be met with + # weights that do not meet it. The certificate surfaces as the infeasible + # condition instead. + data <- sim_continuous(n = 350) + solves <- 0L + original <- solve_energy_cont + testthat::local_mocked_bindings( + solve_energy_cont = function(...) { + result <- original(...) + solves <<- solves + 1L + if (solves > 1L) { + result$converged <- FALSE + result$status <- "primal_infeasible" + } + result + } + ) + + expect_error( + balance( + data, + exposure, + c(x1, x2), + method = bw_energy(), + estimand = "ate", + constraints = balance_terms(moments = 1L, tolerance = 0.05) + ), + class = "balancing_infeasible_error" + ) + expect_identical(solves, 2L) +}) + +test_that("moments no longer sets the marginal distribution moments", { + # `distribution_moments` is the only route to the marginal rows. A + # second-moment constraint request therefore leaves the weighted exposure + # variance where the objective puts it, while `distribution_moments = 2` pins + # it at the sample value. + data <- sim_continuous(n = 350) + sample_variance <- sum((data$exposure - mean(data$exposure))^2) / nrow(data) + weighted_variance <- function(w) { + center <- stats::weighted.mean(data$exposure, w) + sum(w * (data$exposure - center)^2) / sum(w) + } + fit_terms <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy(), + estimand = "ate", + constraints = balance_terms(moments = 2L) + ) + fit_distribution <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy(distribution_moments = 2L), + estimand = "ate" + ) + w_terms <- as.numeric(stats::weights(fit_terms)) + w_distribution <- as.numeric(stats::weights(fit_distribution)) + expect_gt(abs(weighted_variance(w_terms) - sample_variance), 1e-3) + expect_equal( + weighted_variance(w_distribution), + sample_variance, + tolerance = 1e-3 + ) +}) + +test_that("a covariate left out of the constraint set keeps its marginal rows", { + # The marginal rows belong to the covariates, not to the constraint set, so + # `moments` must not reach them from either side. Excluding x1 from the + # constraint set drops x1's correlation row and nothing else: its weighted mean + # and variance stay at the sample values `distribution_moments` pins, exactly + # as x2's and the exposure's do. Reading the marginal columns off the + # constraint recipe dropped x1's marginal rows along with its correlation row, + # and its weighted variance then floated to wherever the objective put it. + data <- sim_continuous(n = 350) + central_moment <- function(values, weights, order) { + center <- stats::weighted.mean(values, weights) + sum(weights * (values - center)^order) / sum(weights) + } + uniform <- rep(1, nrow(data)) + + # The constraint sets differ in what they ask of the correlation rows and + # agree in what they leave to the marginals, so the marginals must come out + # the same under all three. The middle one is the case that failed: x1 has no + # constraint record to read a marginal off. The last one is its mirror, where + # x1's record reaches past the distribution moments. + constraint_sets <- list( + balance_terms(moments = 1L), + balance_terms(moments = c(x1 = 0L, x2 = 1L)), + balance_terms(moments = 3L) + ) + + for (constraints in constraint_sets) { + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy(distribution_moments = 2L), + estimand = "ate", + constraints = constraints + ) + w <- as.numeric(stats::weights(fit)) + for (column in c("exposure", "x1", "x2")) { + values <- data[[column]] + expect_equal( + stats::weighted.mean(values, w), + mean(values), + tolerance = 1e-8 + ) + expect_equal( + central_moment(values, w, 2), + central_moment(values, uniform, 2), + tolerance = 1e-8 + ) + } + } +}) + +test_that("the default continuous fit keeps the objective-driven solution", { + # The correlation rows are added only when the constraint set asks for them, + # so the default fit solves the same program it solved before: the weights + # average one, the correlation improves on the unweighted sample, and the + # residual the energy objective leaves behind is still there. + data <- sim_continuous(n = 350) + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy(), + estimand = "ate" + ) + w <- as.numeric(stats::weights(fit)) + expect_equal(mean(w), 1, tolerance = 1e-8) + expect_gt(weighted_correlation(data$exposure, data$x1, w), 0.05) + expect_lt( + weighted_correlation(data$exposure, data$x1, w), + abs(stats::cor(data$exposure, data$x1)) + ) +}) + # ---- Unsupported estimands ------------------------------------------------ # The overlap estimand is legal only for the covariate balancing propensity @@ -1069,6 +1501,49 @@ test_that("a continuous tolerance warns and is ignored", { ) }) +test_that("the balance table reports the tolerance a continuous fit enforced", { + # The correlation rows are held inside the band the specification asked for, + # so that band is what the table reports and what its verdict is judged + # against. + data <- sim_continuous(n = 350) + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy(), + estimand = "ate", + constraints = balance_terms(moments = 1L, tolerance = 0.05) + ) + table <- as.data.frame(fit@balance_table) + expect_column_all(table, "tolerance", function(value) value == 0.05) + expect_column_all(table, "within_tolerance", function(value) value) +}) + +test_that("a fit that added no constraint rows reports the tolerance it enforced", { + # A tolerance with no constraint rows to relax reaches no row of the program, + # so the table must not report it as the fit's tolerance: the fit enforced + # nothing, which is a tolerance of zero. Both exposure types answer the same + # way, the rows being absent for the same reason in each. + for (data in list(sim_binary(n = 200), sim_continuous(n = 200))) { + expect_warning( + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy(), + estimand = "ate", + constraints = balance_terms(tolerance = 0.1) + ), + class = "balancing_ignored_argument_warning" + ) + expect_column_all( + as.data.frame(fit@balance_table), + "tolerance", + function(value) value == 0 + ) + } +}) + # ---- Infeasible constraint set -------------------------------------------- test_that("an infeasible constraint set raises balancing_infeasible_error", { @@ -1095,6 +1570,196 @@ test_that("an infeasible constraint set raises balancing_infeasible_error", { ) }) +# ---- Small-sample convergence --------------------------------------------- + +# A frame with the shape the discrete energy objective destabilizes on: a +# three-level character covariate, a coarse numeric near 8e4 whose spread is small +# beside its mean, a numeric near 80, and a binary exposure with roughly a third +# of the sample treated, at n = 354. The energy quadratic form is the negated +# distance matrix, conditionally positive semidefinite, so it is indefinite and +# its negative curvature scales as 1/n. At this size the alternating-direction +# iteration is no longer a contraction: its residuals reach a floor above 1e-8, +# and a tolerance below that floor keeps the run going past the optimum until the +# iterate it carries is renormalized back to uniform weights, which balance +# nothing. The seed belongs to the fixture because whether a draw destabilizes +# before it clears its tolerance depends on the draw. +make_energy_frame <- function(seed, n = 354) { + withr::with_seed(seed, { + season <- sample( + c("peak", "regular", "value"), + n, + TRUE, + prob = c(0.22, 0.55, 0.23) + ) + shift <- c(peak = 1.4, regular = 0, value = -1.1)[season] + close <- sample( + c(59400, 64800, 72000, 75600, 79200, 82800, 86400, 90000), + n, + TRUE, + prob = c(0.02, 0.03, 0.16, 0.16, 0.2, 0.2, 0.15, 0.08) + ) + close <- pmin(pmax(close + 3600 * round(shift), 59400), 90000) + temp <- 82 + 4 * shift + stats::rnorm(n, 0, 8) + lp <- -0.9 + + 0.55 * (season == "peak") - + 0.35 * (season == "value") + + 0.9 * scale(close)[, 1] - + 0.5 * scale(temp)[, 1] + data.frame( + z = stats::rbinom(n, 1, stats::plogis(lp)), + season = season, + close = close, + temp = temp + ) + }) +} + +test_that("the default tolerance fits a small indefinite energy problem", { + # The default has to be a tolerance the objective can actually reach on an + # ordinary sample of this size, so the fit converges without warning and moves + # every covariate a long way toward balance. Under a tolerance below the + # solver's residual floor the same fit spends its whole iteration cap instead. + data <- make_energy_frame(9) + fit <- expect_no_warning( + balance(data, z, c(season, close, temp), method = bw_energy()), + class = "balancing_convergence_warning" + ) + expect_true(fit@converged) + table <- as.data.frame(fit@balance_table) + expect_gt(max(abs(table$unweighted)), 0.5) + expect_lt(max(abs(table$weighted)), 0.1) +}) + +test_that("a tolerance below the residual floor spends the iteration cap", { + # The counterpart of the spec above. The tolerance the default used to carry on + # this frame was 1e-8, which sits so close to the solver's residual floor here + # that scaling one covariate column by 1 + 5e-16 flips the verdict; a platform + # whose compiler contracts a multiply-add differently would disagree with this + # machine. The spec therefore asks for 1e-14, far below any residual floor the + # iteration reaches, so every platform spends the cap for the same reason. The + # cap is set well above the count a reachable tolerance converges in on this + # frame, so what the run fails on is the tolerance rather than the budget; the + # default cap of 200000 reaches the same verdict and costs two orders of + # magnitude more time. + data <- make_energy_frame(9) + expect_warning( + fit <- balance( + data, + z, + c(season, close, temp), + method = bw_energy(convergence_tolerance = 1e-14, max_iterations = 1000L) + ), + class = "balancing_convergence_warning" + ) + expect_false(fit@converged) +}) + +test_that("a fit that cannot reach its tolerance returns usable weights", { + # A run whose iterate walked away from the optimum must not hand that iterate + # back: the stable balancing weights continuous path keeps the last iterate that + # met its criterion rather than the failed one, and energy owes the same. The + # promises are the ones a caller can check on the returned object. The weights + # are finite, sit at or above the documented floor, and carry each group at its + # estimand target total. Their effective sample size is strictly inside the + # range a real fit occupies, below the group size that uniform weights sit at + # exactly and above the collapse a few dominating weights would leave. And the + # balance the fit reports improves on the unweighted sample rather than + # reproducing it. The tolerance is the 1e-14 of the spec above, and for the + # same reason: at the 1e-8 the default used to carry, whether this frame + # reaches its tolerance turns on the last bits of the draw. + data <- make_energy_frame(9) + expect_warning( + fit <- balance( + data, + z, + c(season, close, temp), + method = bw_energy(convergence_tolerance = 1e-14, max_iterations = 1000L) + ), + class = "balancing_convergence_warning" + ) + + w <- as.numeric(weights(fit)) + expect_all(w, is.finite) + expect_all(w, function(value) value >= bw_energy()@min_weight) + groups <- split(seq_len(nrow(data)), as.character(data$z)) + for (idx in groups) { + expect_equal(sum(w[idx]), length(idx)) + group_ess <- kish_ess(w[idx]) + expect_lt(group_ess, 0.95 * length(idx)) + expect_gt(group_ess, 0.25 * length(idx)) + } + + table <- as.data.frame(fit@balance_table) + expect_lt(max(abs(table$weighted)), 0.5 * max(abs(table$unweighted))) +}) + +test_that("a continuous fit that spends its cap reports the re-solve", { + # The re-solve at a reachable tolerance is not a discrete-path device: the + # continuous solve routes through the same fallback, and a run that ends at + # the iteration cap with a tolerance below the reachable 1e-6 is retried + # there. The fit still calls itself unconverged, because the tolerance asked + # for was not met, and its reported iterations are the two solves added + # together, so they exceed the cap the caller set. + # + # A small cap is what reaches this. The benchmark sweep that measured the + # continuous path against WeightIt never reached it at realistic settings: + # not one of eighty cells, up to a thousand observations at tolerances from + # 1e-5 to 1e-8, spent its cap. Driving it with the cap is legitimate all the + # same, since the fallback keys on the terminal status and the tolerance + # rather than on how the cap was reached. + data <- sim_continuous(n = 200) + cap <- 100L + expect_warning( + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy( + convergence_tolerance = 1e-14, + max_iterations = cap + ), + estimand = "ate" + ), + class = "balancing_convergence_warning" + ) + expect_false(fit@converged) + expect_gt(fit@iterations, cap) + + # The iterate the fit reports is the re-solve's, which is a real answer: the + # weights are finite, sit at or above the documented floor, carry the sample + # at its target total, and improve on the unweighted correlation. + w <- as.numeric(stats::weights(fit)) + expect_all(w, is.finite) + expect_all(w, function(value) value >= bw_energy()@min_weight) + expect_equal(mean(w), 1, tolerance = 1e-6) + table <- as.data.frame(fit@balance_table) + expect_lt(max(abs(table$weighted)), 0.5 * max(abs(table$unweighted))) +}) + +test_that("a continuous cap too small for the re-solve keeps the first iterate", { + # The retry is given the same cap, so a cap below what the reachable + # tolerance needs leaves it unconverged too, and the fit reports the original + # solve rather than a second failed one. The iteration count is then the cap + # itself rather than the sum. + data <- sim_continuous(n = 200) + cap <- 25L + expect_warning( + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_energy( + convergence_tolerance = 1e-14, + max_iterations = cap + ), + estimand = "ate" + ), + class = "balancing_convergence_warning" + ) + expect_false(fit@converged) + expect_identical(fit@iterations, cap) +}) + # ---- Live consistency against WeightIt ------------------------------------ test_that("energy weights meet the objective tolerance against WeightIt for a binary ate", { diff --git a/tests/testthat/test-method-entropy.R b/tests/testthat/test-method-entropy.R index e2205fc..d03ba99 100644 --- a/tests/testthat/test-method-entropy.R +++ b/tests/testthat/test-method-entropy.R @@ -124,7 +124,7 @@ test_that("entropy balancing balances a binary ate", { estimand = "ate" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("entropy balancing balances a binary att", { @@ -137,7 +137,7 @@ test_that("entropy balancing balances a binary att", { estimand = "att" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("entropy balancing balances a binary atc", { @@ -150,7 +150,7 @@ test_that("entropy balancing balances a binary atc", { estimand = "atc" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("entropy balancing balances a factor covariate for a binary ate", { @@ -181,7 +181,7 @@ test_that("entropy balancing balances a factor covariate for a binary ate", { ) expect_true(fit@converged) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) w <- as.numeric(stats::weights(fit)) for (level in levels(data$x3)) { @@ -219,7 +219,7 @@ test_that("entropy balancing balances a factor covariate for a binary att", { estimand = "att" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) w <- as.numeric(stats::weights(fit)) treated <- data$exposure == 1 @@ -280,7 +280,7 @@ test_that("a covariate set of several factors fits under the defaults", { ) expect_true(fit@converged) - expect_true(all(is.finite(as.numeric(stats::weights(fit))))) + expect_all(as.numeric(stats::weights(fit)), is.finite) expect_balanced(fit, data) }) @@ -327,7 +327,7 @@ test_that("entropy balancing balances a categorical ate", { estimand = "ate" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("entropy balancing balances a categorical att", { @@ -338,10 +338,10 @@ test_that("entropy balancing balances a categorical att", { c(x1, x2), method = bw_entropy(), estimand = "att", - focal_level = "b" + .focal_level = "b" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) # ---- Statistical promises: continuous ------------------------------------- @@ -356,7 +356,7 @@ test_that("entropy balancing balances a continuous ate", { estimand = "ate" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("a continuous fit preserves an indicator covariate's marginal", { @@ -381,7 +381,7 @@ test_that("a continuous fit preserves an indicator covariate's marginal", { # The stratum keeps its share of the total weight rather than being annihilated. expect_equal(sum(w[data$g == 1]), sum(data$g == 1), tolerance = 1e-4) expect_balanced(fit, data) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) }) test_that("a continuous fit holds the base-measure marginals under sampling weights", { @@ -819,6 +819,30 @@ test_that("non-finite weights from both entropy solvers name them in the error", expect_match(conditionMessage(condition), "BFGS") }) +test_that("non-finite continuous entropy weights name both solvers in the error", { + # An exposure that repeats a covariate makes the exact continuous problem + # infeasible. The exposure crosses that covariate into a column of squares, + # whose weighted mean is positive under any positive weights and so can never + # reach the zero target the cross constraints carry. The duals run off to the + # range where the exponential tilt overflows, so the Newton solve and the + # hybrid retry both return non-finite weights. The continuous path has to + # refuse that solve the way the discrete path does, naming the solvers that + # ran rather than failing on the arithmetic downstream. + data <- sim_continuous() + data$exposure <- data$x1 + + condition <- expect_error( + balance(data, exposure, c(x1, x2), method = bw_entropy(), estimand = "ate"), + class = "balancing_convergence_error" + ) + expect_match( + conditionMessage(condition), + "Neither solver produced finite weights" + ) + expect_match(conditionMessage(condition), "Newton") + expect_match(conditionMessage(condition), "BFGS") +}) + # ---- distribution_moments (continuous) ------------------------------------ test_that("distribution_moments holds the exposure variance", { @@ -880,6 +904,99 @@ test_that("distribution_moments is raised to the constraint moments with an aler ) }) +test_that("a covariate left out of the constraint set keeps its marginal rows", { + # The marginal rows belong to the covariates, not to the constraint set, so + # `moments` must not reach them from either side. Excluding x1 from the + # constraint set drops x1's product column and nothing else: its weighted mean + # and second central moment stay at the sample values `distribution_moments` + # pins, exactly as x2's and the exposure's do. Reading the marginal columns off + # the constraint matrix dropped x1's marginal rows along with its product + # column, and its weighted variance then floated to wherever the tilt put it. + data <- sim_continuous(n = 350) + central_moment <- function(values, weights, order) { + center <- stats::weighted.mean(values, weights) + sum(weights * (values - center)^order) / sum(weights) + } + uniform <- rep(1, nrow(data)) + + # The constraint sets differ in what they ask of the product columns and agree + # in what they leave to the marginals, so the marginals must come out the same + # under both. The second is the case that failed: x1 has no constraint column + # to read a marginal off. + constraint_sets <- list( + balance_terms(moments = 1L), + balance_terms(moments = c(x1 = 0L, x2 = 1L)) + ) + + for (constraints in constraint_sets) { + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_entropy(distribution_moments = 2L), + estimand = "ate", + constraints = constraints + ) + w <- as.numeric(stats::weights(fit)) + for (column in c("exposure", "x1", "x2")) { + values <- data[[column]] + expect_equal( + stats::weighted.mean(values, w), + mean(values), + tolerance = 1e-8 + ) + expect_equal( + central_moment(values, w, 2), + central_moment(values, uniform, 2), + tolerance = 1e-8 + ) + } + } +}) + +test_that("an interaction column carries a correlation row and no marginal row", { + # The marginal rows are built from the covariates alone, so an interaction + # contributes the association the constraint set named and nothing more: the + # fit drives the weighted exposure-product correlation to zero while the + # product's own weighted mean is free to move off the sample value. Pinning it + # as well would hold a joint distribution the constraint set never named, and + # would depart from the energy design this follows. The covariate marginals + # are the control: they are pinned in the same fit. + data <- sim_continuous(n = 350) + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_entropy(), + estimand = "ate", + constraints = balance_terms(moments = 1L, interactions = TRUE) + ) + w <- as.numeric(stats::weights(fit)) + + for (column in c("exposure", "x1", "x2")) { + values <- data[[column]] + expect_equal( + stats::weighted.mean(values, w), + mean(values), + tolerance = 1e-8 + ) + } + + product <- data$x1 * data$x2 + expect_lt( + abs(stats::cov.wt( + cbind(data$exposure, product), + wt = w, + cor = TRUE + )$cor[1, 2]), + 1e-8 + ) + # Measured at 0.31 sample standard deviations, so the threshold states "moved + # materially" rather than pinning a value the solver path decides. + shift <- abs(stats::weighted.mean(product, w) - mean(product)) + expect_gt(shift / stats::sd(product), 0.05) +}) + # ---- Continuous with tolerance -------------------------------------------- test_that("a continuous tolerance relaxes correlations but holds the marginals", { @@ -910,6 +1027,91 @@ test_that("a continuous tolerance relaxes correlations but holds the marginals", ) }) +# ---- The solver's tolerance box ------------------------------------------- + +# `solver_box()` converts a standardized-scale tolerance to the raw scale its +# constraint row is written on by multiplying it by the column's standard +# deviation, taken under the sampling weights when they vary and unweighted +# otherwise. The weighted branch reads the whole matrix in one pass of column +# arithmetic rather than a column at a time, and the two are the same arithmetic +# in the same order, so this pins identity rather than agreement to a tolerance. +# A tolerance would let a genuine change of accumulation order through, and a +# changed box is a changed fit. +# +# The fixture carries a constant column so the guard that leaves a column with no +# spread at its own tolerance is exercised on both branches. +solver_box_fixture <- function() { + withr::with_seed(404, { + n <- 300L + z <- cbind( + stats::rnorm(n), + stats::runif(n, -2, 3), + rep(0.98, n), + as.numeric(stats::rbinom(n, 1L, 0.4)), + 1e6 + stats::rnorm(n) + ) + list(z = z, sampling_weights = stats::runif(n, 0.3, 2.5)) + }) +} + +test_that("solver_box() reproduces the per-column weighted scale", { + fixture <- solver_box_fixture() + z <- fixture$z + w <- fixture$sampling_weights + tolerances <- seq_len(ncol(z)) / 100 + + column_sd <- apply(z, 2, weighted_scale, w = w) + column_sd[column_is_constant(z) | column_sd == 0] <- 1 + + expect_identical( + solver_box(z, tolerances, w), + tolerances * column_sd + ) +}) + +# A column holding one value repeated has no spread to convert a +# standardized-scale tolerance against, so its box is the tolerance itself. It +# does not arrive that way on its own: the weighted center divides a sum of +# products by a sum of weights and need not give the repeated value back +# exactly, so the centered column carries a rounding residual instead of zeros +# and the scale reports that residual as the column's spread. The constant 0.98 +# column below came out with a standard deviation of order 1e-16 under these +# weights, which shrank its box by fourteen orders of magnitude and constrained +# the fit against rounding. Reading the values rather than the computed scale is +# the guard `standardize_columns()` already carries, and the two have to agree +# on which columns have no spread or the box and the balance table disagree +# about the same column. +test_that("solver_box() leaves a constant column at its raw tolerance", { + fixture <- solver_box_fixture() + z <- fixture$z + w <- fixture$sampling_weights + tolerances <- seq_len(ncol(z)) / 100 + constant <- 3L + + expect_all(z[, constant], function(value) value == 0.98) + expect_identical( + solver_box(z, tolerances, w)[[constant]], + tolerances[[constant]] + ) + expect_identical( + solver_box(z, tolerances)[[constant]], + tolerances[[constant]] + ) +}) + +test_that("solver_box() reads uniform sampling weights on the unweighted scale", { + fixture <- solver_box_fixture() + z <- fixture$z + tolerances <- seq_len(ncol(z)) / 100 + + column_sd <- apply(z, 2, stats::sd) + column_sd[column_is_constant(z) | column_sd == 0] <- 1 + expected <- tolerances * column_sd + + expect_identical(solver_box(z, tolerances), expected) + expect_identical(solver_box(z, tolerances, rep(1, nrow(z))), expected) +}) + # ---- Property tests under sampling and base weights ----------------------- test_that("entropy balancing balances a binary ate under sampling weights", { @@ -927,7 +1129,7 @@ test_that("entropy balancing balances a binary ate under sampling weights", { # Balance holds against the sampling-weighted pooled reference, which # expect_balanced() derives from the fit's own sampling weights. expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("entropy balancing balances a binary att under sampling weights", { @@ -959,7 +1161,7 @@ test_that("entropy balancing balances a binary ate under base weights", { # The base measure moves the pooled target; expect_balanced() reads the base # weights from the fitted method. expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("entropy balancing balances a binary atu under base weights", { diff --git a/tests/testthat/test-method-ipt.R b/tests/testthat/test-method-ipt.R index 385d17e..5653376 100644 --- a/tests/testthat/test-method-ipt.R +++ b/tests/testthat/test-method-ipt.R @@ -126,7 +126,7 @@ test_that("bw_ipt balances a binary ate", { estimand = "ate" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("bw_ipt balances a binary att", { @@ -139,7 +139,7 @@ test_that("bw_ipt balances a binary att", { estimand = "att" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("bw_ipt balances a binary atc", { @@ -152,7 +152,7 @@ test_that("bw_ipt balances a binary atc", { estimand = "atc" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("bw_ipt balances a factor covariate for a binary ate", { @@ -169,7 +169,7 @@ test_that("bw_ipt balances a factor covariate for a binary ate", { estimand = "ate" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) w <- as.numeric(stats::weights(fit)) for (level in levels(data$x3)) { @@ -197,7 +197,7 @@ test_that("bw_ipt balances a factor covariate for a binary att", { estimand = "att" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) w <- as.numeric(stats::weights(fit)) treated <- data$exposure == 1 @@ -223,7 +223,7 @@ test_that("bw_ipt balances a categorical ate", { estimand = "ate" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("bw_ipt balances a categorical att", { @@ -234,10 +234,10 @@ test_that("bw_ipt balances a categorical att", { c(x1, x2), method = bw_ipt(), estimand = "att", - focal_level = "b" + .focal_level = "b" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) }) test_that("a capped iteration count warns about convergence", { @@ -307,7 +307,7 @@ test_that("bw_ipt balances a binary ate under sampling weights", { # Balance holds against the sampling-weighted pooled reference, which # expect_balanced() derives from the fit's own sampling weights. expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) # weights() folds the sampling weights in, so each group's total matches its # sampling-weighted size, the mean-one-per-group convention under weights. @@ -330,7 +330,7 @@ test_that("bw_ipt balances a binary att under sampling weights", { sampling_weights = sw ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) # The focal (treated) units keep base weight one, so their reported weight is # the sampling weight alone; the control group matches the focal total. @@ -350,11 +350,11 @@ test_that("bw_ipt balances a categorical att under sampling weights", { c(x1, x2), method = bw_ipt(), estimand = "att", - focal_level = "b", + .focal_level = "b", sampling_weights = sw ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) # Each non-focal level is tilted to the focal total, and the focal level keeps # base weight one. @@ -490,7 +490,7 @@ test_that("each link function fits and balances a binary ate", { estimand = "ate" ) expect_balanced(fit, data) - expect_true(all(stats::weights(fit) >= 0)) + expect_all(stats::weights(fit), function(value) value >= 0) } }) diff --git a/tests/testthat/test-method-sbw.R b/tests/testthat/test-method-sbw.R index 1c226a9..181a28b 100644 --- a/tests/testthat/test-method-sbw.R +++ b/tests/testthat/test-method-sbw.R @@ -248,8 +248,8 @@ test_that("a binary ate fit meets the tolerance and floors the weights", { constraints = balance_terms(tolerance = 0.05) ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) - expect_true(all(w >= 1e-8)) + expect_all(w, function(value) value >= 0) + expect_all(w, function(value) value >= 1e-8) expect_balanced(fit, data, tolerance = 0.05) }) @@ -284,7 +284,7 @@ test_that("a binary att targets the treated total in both groups", { n_treated <- sum(treated) expect_equal(sum(w[treated]), n_treated, tolerance = 1e-4) expect_equal(sum(w[!treated]), n_treated, tolerance = 1e-4) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) expect_balanced(fit, data, tolerance = 0.05) }) @@ -299,8 +299,8 @@ test_that("a binary atc fit produces non-negative floored weights", { constraints = balance_terms(tolerance = 0.05) ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) - expect_true(all(w >= 1e-8)) + expect_all(w, function(value) value >= 0) + expect_all(w, function(value) value >= 1e-8) expect_balanced(fit, data, tolerance = 0.05) }) @@ -348,7 +348,7 @@ test_that("the minimum-weight floor holds on the reported scale", { constraints = balance_terms(tolerance = 0.05) ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 1e-3)) + expect_all(w, function(value) value >= 1e-3) }) # ---- Sampling weights ----------------------------------------------------- @@ -416,7 +416,7 @@ test_that("a continuous ate meets the correlation tolerance under sampling weigh sampling_weights = sw ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) expect_equal(sum(w), sum(sw), tolerance = 1e-3) expect_balanced(fit, data, tolerance = 0.05) }) @@ -459,7 +459,7 @@ test_that("categorical ate stable balancing produces valid weights", { constraints = balance_terms(tolerance = 0.05) ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) for (level in levels(data$exposure)) { idx <- data$exposure == level expect_equal(sum(w[idx]), sum(idx), tolerance = 1e-4) @@ -475,11 +475,11 @@ test_that("categorical att stable balancing produces valid weights", { c(x1, x2), method = bw_sbw(), estimand = "att", - focal_level = "b", + .focal_level = "b", constraints = balance_terms(tolerance = 0.05) ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) expect_balanced(fit, data, tolerance = 0.05) }) @@ -496,11 +496,146 @@ test_that("continuous ate stable balancing meets the correlation tolerance", { constraints = balance_terms(tolerance = 0.05) ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) - expect_true(all(w >= 1e-8)) + expect_all(w, function(value) value >= 0) + expect_all(w, function(value) value >= 1e-8) expect_balanced(fit, data, tolerance = 0.05) }) +test_that("the continuous refinement takes several passes and sums their iterations", { + # The pass count is what separates an honored band from a single overshooting + # solve, so it is counted at the solver rather than inferred from the weights, + # and the reported iterations have to account for every pass rather than for + # the last one alone. This is the guarantee energy balancing already makes for + # the same loop. + data <- sim_continuous(n = 350) + solves <- 0L + per_solve <- integer() + original <- solve_sbw_cont + testthat::local_mocked_bindings( + solve_sbw_cont = function(...) { + result <- original(...) + solves <<- solves + 1L + per_solve <<- c(per_solve, as.integer(result$iterations)) + result + } + ) + + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_sbw(), + estimand = "ate", + constraints = balance_terms(tolerance = 0.05) + ) + + expect_gt(solves, 1L) + expect_identical(fit@iterations, sum(per_solve)) +}) + +test_that("a tightened continuous pass that stops at the iteration cap keeps the last converged iterate", { + # Stable balancing runs the correlation refinement energy balancing runs, + # against the same statistic, so it owes the same guarantee. A tightened bound + # is harder than the one before it, and a pass that spends the iteration cap on + # it leaves weights at the floor. The fit reports the last iterate that + # converged instead: it reports itself converged, its weights are the earlier + # pass's, and the correlations that iterate achieved sit above the requested + # band, so the ordinary balance warning judges them rather than a convergence + # warning claiming the solve failed. The reported iterations still account for + # every pass, the failed one included, because each pass cost a whole solve. + data <- sim_continuous(n = 350) + solves <- 0L + per_solve <- integer() + first_weights <- NULL + original <- solve_sbw_cont + testthat::local_mocked_bindings( + solve_sbw_cont = function(...) { + result <- original(...) + solves <<- solves + 1L + per_solve <<- c(per_solve, as.integer(result$iterations)) + if (solves == 1L) { + first_weights <<- as.numeric(result$weights) + } else { + result$converged <- FALSE + result$status <- "max_iter" + } + result + } + ) + + # Every warning is collected rather than one being matched, so a convergence + # warning raised alongside the balance warning fails here instead of passing + # under an expectation that looked only for the one it wanted. + seen <- character() + fit <- withCallingHandlers( + balance( + data, + exposure, + c(x1, x2), + method = bw_sbw(), + estimand = "ate", + constraints = balance_terms(tolerance = 0.05) + ), + warning = function(cnd) { + seen <<- c(seen, class(cnd)[[1]]) + invokeRestart("muffleWarning") + } + ) + + expect_identical(seen, "balancing_balance_warning") + expect_identical(solves, 2L) + expect_true(fit@converged) + expect_identical(fit@iterations, sum(per_solve)) + + # The reported weights renormalize the solver's, so the restored iterate shows + # as proportionality to the first pass's raw weights rather than as equality. + w <- as.numeric(stats::weights(fit)) + expect_equal( + w / sum(w), + first_weights / sum(first_weights), + tolerance = 1e-10 + ) + + table <- as.data.frame(fit@balance_table) + expect_all(table$weighted, function(r) r > 0.05 + balance_margin(0.05)) + expect_column_all(table, "within_tolerance", function(value) !value) +}) + +test_that("a tightened continuous pass certified infeasible raises rather than restoring", { + # The other half of the same guard. An infeasibility certificate is a claim + # about the constraint set, not about the iteration cap, so restoring the + # looser iterate would answer a band the solver said cannot be met with weights + # that do not meet it. The certificate surfaces as the infeasible condition + # instead. + data <- sim_continuous(n = 350) + solves <- 0L + original <- solve_sbw_cont + testthat::local_mocked_bindings( + solve_sbw_cont = function(...) { + result <- original(...) + solves <<- solves + 1L + if (solves > 1L) { + result$converged <- FALSE + result$status <- "primal_infeasible" + } + result + } + ) + + expect_error( + balance( + data, + exposure, + c(x1, x2), + method = bw_sbw(), + estimand = "ate", + constraints = balance_terms(tolerance = 0.05) + ), + class = "balancing_infeasible_error" + ) + expect_identical(solves, 2L) +}) + # ---- Tolerance semantics -------------------------------------------------- test_that("a fit without a positive tolerance raises balancing_constraints_error", { @@ -558,8 +693,8 @@ test_that("an l1 binary ate meets the tolerance and normalizes each group", { constraints = balance_terms(tolerance = 0.05) ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) - expect_true(all(w >= 1e-8)) + expect_all(w, function(value) value >= 0) + expect_all(w, function(value) value >= 1e-8) treated <- data$exposure == 1 expect_equal(sum(w[treated]), sum(treated), tolerance = 1e-3) expect_equal(sum(w[!treated]), sum(!treated), tolerance = 1e-3) @@ -577,7 +712,7 @@ test_that("an l1 binary att targets the treated total and meets the tolerance", constraints = balance_terms(tolerance = 0.05) ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) treated <- data$exposure == 1 n_treated <- sum(treated) expect_equal(sum(w[treated]), n_treated, tolerance = 1e-3) @@ -596,8 +731,8 @@ test_that("a linf binary ate meets the tolerance and normalizes each group", { constraints = balance_terms(tolerance = 0.05) ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) - expect_true(all(w >= 1e-8)) + expect_all(w, function(value) value >= 0) + expect_all(w, function(value) value >= 1e-8) treated <- data$exposure == 1 expect_equal(sum(w[treated]), sum(treated), tolerance = 1e-3) expect_equal(sum(w[!treated]), sum(!treated), tolerance = 1e-3) @@ -615,7 +750,7 @@ test_that("a linf binary att meets the tolerance", { constraints = balance_terms(tolerance = 0.05) ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) expect_balanced(fit, data, tolerance = 0.05) }) @@ -630,7 +765,7 @@ test_that("an l1 categorical ate produces valid balanced weights", { constraints = balance_terms(tolerance = 0.05) ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) for (level in levels(data$exposure)) { idx <- data$exposure == level expect_equal(sum(w[idx]), sum(idx), tolerance = 1e-3) @@ -649,7 +784,7 @@ test_that("a linf categorical ate produces valid balanced weights", { constraints = balance_terms(tolerance = 0.05) ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) expect_balanced(fit, data, tolerance = 0.05) }) @@ -664,8 +799,8 @@ test_that("an l1 continuous ate meets the correlation tolerance", { constraints = balance_terms(tolerance = 0.05) ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) - expect_true(all(w >= 1e-8)) + expect_all(w, function(value) value >= 0) + expect_all(w, function(value) value >= 1e-8) expect_balanced(fit, data, tolerance = 0.05) }) @@ -680,7 +815,7 @@ test_that("a linf continuous ate meets the correlation tolerance", { constraints = balance_terms(tolerance = 0.05) ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) expect_balanced(fit, data, tolerance = 0.05) }) @@ -720,7 +855,7 @@ test_that("a linf fit balances under non-uniform sampling weights", { sampling_weights = sw ) w <- as.numeric(stats::weights(fit)) - expect_true(all(w >= 0)) + expect_all(w, function(value) value >= 0) treated <- data$exposure == 1 expect_equal(sum(w[treated]), sum(sw[treated]), tolerance = 1e-3) expect_equal(sum(w[!treated]), sum(sw[!treated]), tolerance = 1e-3) @@ -862,7 +997,7 @@ test_that("the weighted correlations read a constant column as zero", { # from resolving to a missing value. exposure <- c(-1, 0, 1, 2, 0.5, -0.5) z <- cbind(varying = exposure, constant = rep(0, 6)) - achieved <- sbw_weighted_correlations(exposure, z, rep(1, 6)) + achieved <- weighted_exposure_correlations(exposure, z, rep(1, 6)) expect_equal(achieved, c(1, 0)) }) @@ -880,7 +1015,7 @@ test_that("a constant covariate leaves a continuous stable-balancing fit intact" ) expect_false("fixed" %in% fit@balance_table$term) - expect_true(all(is.finite(as.numeric(stats::weights(fit))))) + expect_all(as.numeric(stats::weights(fit)), is.finite) expect_balanced(fit, data, tolerance = 0.05) }) @@ -897,10 +1032,55 @@ test_that("a single-level factor leaves a continuous stable-balancing fit intact ) expect_false("f_a" %in% fit@balance_table$term) - expect_true(all(is.finite(as.numeric(stats::weights(fit))))) + expect_all(as.numeric(stats::weights(fit)), is.finite) expect_balanced(fit, data, tolerance = 0.05) }) +# The moment-constraint band a stable-balancing fit hands the solver is built by +# `solver_box()` (R/method-entropy.R), which the assembly calls directly at +# R/method-sbw.R with the prepared matrix, the requested tolerances, and the +# sampling weights. A tolerance is written on the standardized scale, so the box +# converts it by the column's standard deviation, and a column holding one value +# repeated has no spread to convert against: its box is the tolerance itself. +# +# It does not arrive that way on its own. The weighted center divides a sum of +# products by a sum of weights and need not return the repeated value exactly, +# so the centered column carries a rounding residual and the computed scale +# reports that residual as the column's spread. Left alone, the constant 0.98 +# column below shrinks its own band by roughly fifteen orders of magnitude and +# the fit is constrained against rounding. This pins the guard on the call the +# stable-balancing path makes rather than only on the entropy one. +sbw_solver_box_fixture <- function() { + withr::with_seed(808, { + n <- 300L + z <- cbind( + stats::rnorm(n), + stats::runif(n, -2, 3), + rep(0.98, n), + as.numeric(stats::rbinom(n, 1L, 0.4)) + ) + list(z = z, sampling_weights = stats::runif(n, 0.3, 2.5)) + }) +} + +test_that("the stable-balancing tolerance box leaves a constant column raw", { + fixture <- sbw_solver_box_fixture() + z <- fixture$z + w <- fixture$sampling_weights + tolerances <- seq_len(ncol(z)) / 100 + constant <- 3L + + expect_all(z[, constant], function(value) value == 0.98) + expect_identical( + solver_box(z, tolerances, w)[[constant]], + tolerances[[constant]] + ) + expect_identical( + solver_box(z, tolerances)[[constant]], + tolerances[[constant]] + ) +}) + # ---- Infeasible constraint set -------------------------------------------- test_that("an infeasible constraint set raises balancing_infeasible_error", { @@ -1003,8 +1183,8 @@ test_that("the default routing falls back to clarabel on an osqp infeasibility c expect_true(auto$fell_back) expect_identical(auto$solver_status, "clarabel") weights <- as.numeric(auto$weights) - expect_true(all(is.finite(weights))) - expect_true(all(weights >= 0)) + expect_all(weights, is.finite) + expect_all(weights, function(value) value >= 0) # The rescue matches a direct clarabel solve: the same strictly convex program, # solved to the same objective, so the fallback adds no accuracy cost. diff --git a/tests/testthat/test-print.R b/tests/testthat/test-print.R index b1f480b..50875d6 100644 --- a/tests/testthat/test-print.R +++ b/tests/testthat/test-print.R @@ -88,6 +88,25 @@ test_that("print() of a categorical ate fit lists every level", { expect_balancing_snapshot(print(fit)) }) +# A factor covariate contributes one constraint per level, and the full set is +# affine with the intercept, so the aliasing check drops the last level. The +# print block is the record that a fit still describes itself correctly once a +# constraint has gone: the term count is the surviving four, not the five the +# formula named. The block does not carry the balance table, so the surviving +# terms are asserted directly below it. +test_that("print() of a fit whose factor lost a level is stable", { + data <- sim_binary() + fit <- balance( + data, + exposure, + c(x1, x2, x3), + method = bw_entropy(), + estimand = "ate" + ) + expect_balancing_snapshot(print(fit)) + expect_identical(fit@balance_table$term, c("x1", "x2", "x3_a", "x3_b")) +}) + # The quadratic-program family reports a solver backend and a minimum-weight # floor, so its print and summary blocks differ from the estimating-equation # family. The weight summary names the count of weights resting on the floor. @@ -148,6 +167,80 @@ test_that("summary() of a cfd fit reports the weight floor count", { expect_gt(at_floor, 0) }) +# ---- The width of the largest-imbalance figure ------------------------------ + +# The headline figure and the balance-exceeded warning report the same quantity +# and render it the same way, to three significant digits. A fixed four decimal +# places spends its width on leading zeros, so it loses the digits that +# distinguish one small imbalance from another and collapses everything below +# half a ten-thousandth to the same "0.0000". The two fixtures below are the +# cases where the formats disagree: one imbalance a few thousandths wide, and +# one the fit drove to zero. Both are read off the fit rather than written in, +# because the low-order digits move with the platform's floating-point path. +# +# The `<1e-7` placeholder in helper-snapshot.R applies to recorded snapshots +# only. These tests capture the printed block directly, so they see the value +# the print method rendered. +test_that("print() renders the largest imbalance to three significant digits", { + data <- sim_binary() + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_cfd(), + estimand = "ate" + ) + largest <- max(abs(fit@balance_table$weighted)) + significant <- formatC(largest, format = "g", digits = 3) + fixed <- formatC(largest, format = "f", digits = 4) + # The fixture only says anything if the two formats disagree on it. + expect_false(identical(significant, fixed)) + + printed <- utils::capture.output(print(fit)) + line <- grep("Largest imbalance", printed, value = TRUE, fixed = TRUE) + expect_length(line, 1L) + # The trailing space and parenthesis pin the whole rendered figure. Without + # them the fixed rendering is a prefix of the significant one, so a bare + # substring test would accept either. + expect_match( + line, + paste0("Largest imbalance: ", significant, " ("), + fixed = TRUE + ) + expect_no_match( + line, + paste0("Largest imbalance: ", fixed, " ("), + fixed = TRUE + ) +}) + +test_that("print() keeps a largest imbalance below the fourth decimal legible", { + data <- sim_binary() + fit <- balance( + data, + exposure, + c(x1, x2), + method = bw_entropy(), + estimand = "ate" + ) + largest <- max(abs(fit@balance_table$weighted)) + expect_lt(largest, 1e-8) + + printed <- utils::capture.output(print(fit)) + line <- grep("Largest imbalance", printed, value = TRUE, fixed = TRUE) + expect_length(line, 1L) + expect_match( + line, + paste0( + "Largest imbalance: ", + formatC(largest, format = "g", digits = 3), + " (" + ), + fixed = TRUE + ) + expect_no_match(line, "Largest imbalance: 0.0000", fixed = TRUE) +}) + # ---- An imbalance that was never measured ---------------------------------- # A balance statistic that is not a number states no distance, so the display diff --git a/tests/testthat/test-snapshot-helpers.R b/tests/testthat/test-snapshot-helpers.R new file mode 100644 index 0000000..bace70c --- /dev/null +++ b/tests/testthat/test-snapshot-helpers.R @@ -0,0 +1,160 @@ +# Unit tests for the snapshot transform in helper-snapshot.R. The transform runs +# on every cli snapshot in the suite, so what it rewrites and what it leaves +# byte-identical is worth pinning on its own rather than only through the +# snapshots it feeds. + +# A balance statistic the fit drove to zero prints as whatever residual the +# solver's floating-point path left behind, and that residual differs on every +# platform down to its exponent. It states nothing about the fit beyond "this +# term balanced", so it is replaced by a placeholder that says exactly that. +test_that("scrub_platform_values() replaces a numerically zero balance value", { + line <- "1 x1 moment smd 1 0.552 1.24e-11 0" + expect_identical( + scrub_platform_values(line), + "1 x1 moment smd 1 0.552 <1e-7 0" + ) +}) + +# The rule is written on the exponent rather than on the value, so the largest +# number it can match is just under 1e-7 rather than just under 1e-8. The +# placeholder states the cutoff the rule actually applies. +test_that("scrub_platform_values() states the cutoff its exponent rule reaches", { + line <- "1 x1 moment smd 1 0.552 9.9e-8 0" + expect_identical( + scrub_platform_values(line), + "1 x1 moment smd 1 0.552 <1e-7 0" + ) +}) + +# An imbalance the fit drove to an exact zero renders as a bare "0" rather than +# in exponent form, and it says exactly what a residual of 1e-17 says. The two +# have to record the same placeholder, or which of them a platform reaches +# becomes the difference between a passing and a failing snapshot. +test_that("scrub_platform_values() replaces an exact zero on the largest-imbalance line", { + line <- "Largest imbalance: 0 (standardized mean difference)" + expect_identical( + scrub_platform_values(line), + "Largest imbalance: <1e-7 (standardized mean difference)" + ) +}) + +# The rule is on that line alone. A zero anywhere else in a printed fit is a +# count, a tolerance, or a column the fit reports as zero by construction, and +# each of those is portable and worth keeping. +test_that("scrub_platform_values() leaves a zero on any other line alone", { + line <- "Constraints: 2 terms (tolerance 0)" + expect_identical(scrub_platform_values(line), line) +}) + +# A tolerance a condition message reports is a constant the package chose, the +# same on every platform, and it is often the thing the message is about. It sits +# in the magnitude range the near-zero rule scrubs, so the rule has to step +# around it. +test_that("scrub_platform_values() leaves a tolerance a message reports alone", { + lines <- c( + "The solve met tolerance 1e-10.", + "The solve met tolerance = 1e-10.", + "The solve met tolerance of 1e-10.", + "The solve met Tolerance 1e-10." + ) + expect_identical(scrub_platform_values(lines), lines) +}) + +# The exemption is on the word before the number rather than on the magnitude, +# so a residual of the same size somewhere else is still scrubbed. +test_that("scrub_platform_values() still scrubs a near-zero the word does not cover", { + expect_identical( + scrub_platform_values("The solve left 1e-10 behind."), + "The solve left <1e-7 behind." + ) +}) + +# A method that balances a term only approximately reports a real distance, and +# that number is the point of the snapshot, so it has to survive untouched. +test_that("scrub_platform_values() leaves a measurable balance value alone", { + line <- "2 x2 moment smd 1 0.416 0.00511 0 FALSE" + expect_identical(scrub_platform_values(line), line) +}) + +# `print.data.frame()` right-aligns every column under a header sized to the +# widest value in it, so a value whose last digit drifts between platforms can +# change the column's width and shift the header even when the rounding above +# leaves the value itself alone: 0.00511 and 0.0051 print one character apart. A +# snapshot then flips with nothing visible changing. Inside a balance-table block +# the alignment carries no information the snapshot is for, so runs of spaces +# collapse to one and only the values and the column order remain. +test_that("scrub_platform_values() collapses balance-table alignment", { + wide <- c( + " term kind statistic group unweighted weighted tolerance", + "1 x1 moment smd 1 0.552 0.00511 0", + "2 x2 moment smd 1 0.416 0.00222 0" + ) + narrow <- c( + " term kind statistic group unweighted weighted tolerance", + "1 x1 moment smd 1 0.552 0.00511 0", + "2 x2 moment smd 1 0.416 0.00222 0" + ) + + expect_identical( + scrub_platform_values(wide), + scrub_platform_values(narrow) + ) + expect_identical( + scrub_platform_values(wide), + c( + "term kind statistic group unweighted weighted tolerance", + "1 x1 moment smd 1 0.552 0.00511 0", + "2 x2 moment smd 1 0.416 0.00222 0" + ) + ) +}) + +# The block runs from its header to its last row, and `print.data.frame()` wraps +# a table too wide for the console into further header-and-rows chunks, so a +# continuation header is part of the same block. Everything outside it keeps its +# spacing: the fit's own lines are cli output, whose alignment is written rather +# than computed from the values, and collapsing them would give up the layout +# these snapshots exist to pin. +test_that("scrub_platform_values() collapses only the balance-table block", { + lines <- c( + "-- Balance --", + "", + " term kind statistic group unweighted weighted tolerance", + "1 x1 moment smd 1 0.552 0.0118 0", + " within_tolerance", + "1 TRUE", + "", + "Range: 0.220 to 3.122" + ) + + expect_identical( + scrub_platform_values(lines), + c( + "-- Balance --", + "", + "term kind statistic group unweighted weighted tolerance", + "1 x1 moment smd 1 0.552 0.0118 0", + "within_tolerance", + "1 TRUE", + "", + "Range: 0.220 to 3.122" + ) + ) +}) + +test_that("the scrub rounds the variation coefficient to two decimals", { + # 1.732 and 1.734 are the same fit on two floating-point paths; both must + # scrub to one line. A number elsewhere on a line keeps its digits. + expect_identical( + scrub_platform_values(c( + "Coefficient of variation: 1.732", + "Coefficient of variation: 1.734", + "Mean: 1.000" + )), + c( + "Coefficient of variation: 1.73", + "Coefficient of variation: 1.73", + "Mean: 1.000" + ) + ) +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index a6c2817..d9538a5 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -118,6 +118,7 @@ test_that("automatic_threads() returns two under R CMD check", { }) test_that("automatic_threads() treats an unknown core count as one", { + local_core_count_reset() withr::local_envvar( `_R_CHECK_LIMIT_CORES_` = NA, OMP_THREAD_LIMIT = NA, @@ -130,6 +131,58 @@ test_that("automatic_threads() treats an unknown core count as one", { expect_identical(automatic_threads(), 1L) }) +test_that("physical_cores() asks the operating system once per session", { + local_core_count_reset() + calls <- 0L + testthat::local_mocked_bindings( + detectCores = function(...) { + calls <<- calls + 1L + 6L + }, + .package = "parallel" + ) + expect_identical(physical_cores(), 6L) + expect_identical(physical_cores(), 6L) + expect_identical(calls, 1L) +}) + +test_that("resolve_threads() reads the cached core count", { + local_core_count_reset() + withr::local_envvar( + `_R_CHECK_LIMIT_CORES_` = NA, + OMP_THREAD_LIMIT = NA, + OMP_NUM_THREADS = NA + ) + testthat::local_mocked_bindings( + detectCores = function(...) 6L, + .package = "parallel" + ) + expect_identical(resolve_threads(), 6L) + + # A second reading of the same session answers from the record rather than + # from the operating system, so a changed answer never reaches the fit. + testthat::local_mocked_bindings( + detectCores = function(...) 3L, + .package = "parallel" + ) + expect_identical(resolve_threads(), 6L) +}) + +test_that("reset_physical_cores() clears the recorded count", { + local_core_count_reset() + testthat::local_mocked_bindings( + detectCores = function(...) 6L, + .package = "parallel" + ) + expect_identical(physical_cores(), 6L) + reset_physical_cores() + testthat::local_mocked_bindings( + detectCores = function(...) 3L, + .package = "parallel" + ) + expect_identical(physical_cores(), 3L) +}) + test_that("env_thread_cap() parses a positive integer and rejects the rest", { withr::local_envvar(OMP_THREAD_LIMIT = "4") expect_identical(env_thread_cap("OMP_THREAD_LIMIT"), 4L) diff --git a/tests/testthat/test-weights.R b/tests/testthat/test-weights.R index a5061bd..bcc3ced 100644 --- a/tests/testthat/test-weights.R +++ b/tests/testthat/test-weights.R @@ -72,7 +72,7 @@ test_that("combining bw vectors with mismatched estimands warns and downgrades", }) test_that("combining a bw with a psw warns and downgrades", { - skip_if_not_installed("propensity") + skip_if_not_installed("propensity", minimum_version = "0.1.0.9000") x <- bw(c(1, 2), estimand = "ate") y <- propensity::psw(c(3, 4), estimand = "ate") expect_warning( @@ -171,7 +171,7 @@ test_that("combining an integer with a bw yields a plain double", { }) test_that("combining a psw before a bw warns and downgrades", { - skip_if_not_installed("propensity") + skip_if_not_installed("propensity", minimum_version = "0.1.0.9000") x <- propensity::psw(c(1, 2), estimand = "ate") y <- bw(c(3, 4), estimand = "ate") expect_warning( diff --git a/vignettes/choosing-a-method.Rmd b/vignettes/choosing-a-method.Rmd index d1a4d07..0d9efca 100644 --- a/vignettes/choosing-a-method.Rmd +++ b/vignettes/choosing-a-method.Rmd @@ -189,7 +189,9 @@ dose_fit For a continuous exposure the printed summary reports the largest weighted exposure-covariate correlation rather than a standardized mean difference. -For `bw_entropy()` and `bw_energy()`, the `distribution_moments` argument on the method constructor sets how many moments of the exposure and covariate marginals are held equal to the sample, extending the identifying conditions beyond the correlation constraints. Both measure that sample under the base measure: any sampling weights, times the `base_weights` of `bw_entropy()`, which `bw_energy()` does not carry. With neither in play the marginals are held equal to the unweighted sample. It is raised automatically to at least the moments the constraints require. +`bw_energy()` is the exception to that target. Its objective minimizes the weighted distance covariance, which asks for full distributional independence rather than for zero correlations, and it leaves a residual weighted correlation of roughly 0.1 to 0.3 at ordinary sample sizes. Pass `constraints = balance_terms(moments = 1)` to add the correlation constraints outright, which costs effective sample size; `?bw_energy` describes the trade and the part `weight_penalty` plays in it. + +For `bw_entropy()` and `bw_energy()`, the `distribution_moments` argument on the method constructor sets how many moments of the exposure and covariate marginals are held equal to the sample, extending the identifying conditions beyond the correlation constraints. Both measure that sample under the base measure: any sampling weights, times the `base_weights` of `bw_entropy()`, which `bw_energy()` does not carry. With neither in play the marginals are held equal to the unweighted sample. For `bw_entropy()` it is raised automatically to at least the moments the constraints require; for `bw_energy()` it stands alone, since there `moments` asks for correlation constraints rather than marginal ones. ```{r distribution-moments} dose_moments <- balance( diff --git a/vignettes/inference.Rmd b/vignettes/inference.Rmd index c26de5f..397ddc3 100644 --- a/vignettes/inference.Rmd +++ b/vignettes/inference.Rmd @@ -90,7 +90,7 @@ data.frame( ### Categorical exposures -A categorical exposure works the same way, with one marginal mean per level. The stacked system carries all of them, and the table reports each of those means and then the contrasts of each non-reference level against the reference level, which is the first of the exposure's own levels. The outcome model enters the exposure as a factor. +A categorical exposure works the same way, with one marginal mean per level. The stacked system carries all of them, and the table reports each of those means and then, for a plain categorical exposure, the contrasts of each non-reference level against the reference level, which is the first of the exposure's own levels. A crossing of two treatments declared with `causalgenerics::joint_exposure()` is reported in the treatments rather than in the cells, and the section on joint exposures below describes those rows. The outcome model enters the exposure as a factor. ```{r categorical} odds_medium <- exp(0.6 * age - 0.3 * score) @@ -139,7 +139,118 @@ ipw(arm_fit, arm_mod) The table leads with the marginal mean of each arm and then reports each effect measure once per contrast, and the `contrast` column names what each row belongs to: the level itself for a mean, and the two levels compared for an effect. A binary exposure is read by the same rule, its means named for the two levels and its single comparison named as a contrast of them. Everything else carries over unchanged: the outcome model may adjust for covariates, the marginal means standardize over the estimand's target population, and the standard errors account for having estimated the weights. -A categorical exposure that `causalgenerics::joint_exposure()` declares as a crossing of two treatments is reported in those treatments instead of cell against cell: the cell means, each treatment's simple effects within the levels of the other, and their interaction. See `?ipw.balancing` for that surface. `ipw()` also takes a `.by` argument, which reports the effects again within the levels of a modifier and contrasts the subgroups, documented on the same page. +### Effect modification with `.by` + +`.by` names a modifier, and the result reports the rows it would report without one, then the marginal means and effects within each level of the modifier, then each non-reference subgroup against the reference one. The table gains a `group` column naming the subgroup a row was estimated in, placed after `contrast`, since a subgroup qualifies a whole comparison rather than one side of it. + +The data below carry a treatment whose effect is larger among men than among women by construction. + +```{r by-data} +set.seed(7) +m <- 500 +severity <- rnorm(m) +comorbidity <- rnorm(m) +sex <- factor( + sample(c("female", "male"), m, replace = TRUE), + levels = c("female", "male") +) +treated <- rbinom(m, 1, plogis(0.5 * severity - 0.4 * comorbidity)) +recovery <- rbinom( + m, + 1, + plogis( + -0.4 + + 0.45 * treated + + 0.9 * treated * (sex == "male") + + 0.4 * severity - + 0.3 * comorbidity + ) +) + +trial <- data.frame(treated, severity, comorbidity, sex, recovery) +``` + +The weights are fit once, over the whole sample, and the outcome model interacts the exposure with the modifier so that the fitted response is free to differ between the two groups. + +```{r by} +trial_fit <- balance( + trial, + treated, + c(severity, comorbidity), + method = bw_entropy(), + estimand = "ate" +) +trial$trial_w <- weights(trial_fit) + +trial_mod <- glm( + recovery ~ treated * sex, + data = trial, + family = quasibinomial(), + weights = trial_w +) + +ipw(trial_fit, trial_mod, .by = sex) +``` + +The `overall` block is the result an ungrouped call reports, and the blocks after it are the effect within each level of `sex`. A subgroup's marginal means are the g-computation means over that subgroup's units alone, and its risk difference is the contrast of those two means. Nothing is refit inside a subgroup: the weights are the ones the single fit produced, and no subgroup gets balance conditions of its own. The last two rows compare the subgroups, and since every row here is a parameter of the same stacked system, that comparison is a parameter as well rather than a difference taken between two separately fitted effects. Its standard error therefore carries the covariance between the two subgroups, which share the weight parameters and the outcome model's coefficients; adding two independently estimated variances would miss that covariance, in a direction the design decides. + +The log odds ratio stays among the whole-sample rows. It is noncollapsible, so the odds ratio over a sample is not an average of the odds ratios within its subgroups, and a difference of two of them moves with each subgroup's baseline risk whether or not the effect is modified at all. The collapsible measures, `rd` and `log(rr)`, are the ones reported for the subgroups and for their contrast. + +The subgroup contrast is not what the interaction term in `recovery ~ treated * sex` reports. That coefficient belongs to the outcome model's conditional surface: it is the change in the model's log odds ratio between the two levels of `sex`, on the link scale the model was fitted with. The `.by` rows are an estimand instead, the marginal effect of treating standardized over each subgroup's own covariate distribution, and their contrast is the difference between two such effects on each collapsible scale. The two are different quantities and generally different numbers, so a term in the model is not a reading of the request and the request is not a reading of the term. What `.by` does need from the model is room for the effect to differ. The subgroup rows are g-computation on the model as it was specified, so a model carrying no term that reads both the exposure and the modifier is warned about rather than refused: the modification may reach it through a column derived from the modifier instead. + +### Joint exposures + +Intervening on two treatments at once is a third question again, and it is not the one `.by` answers. `causalgenerics::joint_exposure()` crosses two discrete treatments into one categorical exposure and records the crossing on the column. `balance()` weights that column as it weights any factor over the same cells, so what the declaration changes is which effects are reported rather than which population is balanced. + +```{r joint-data} +set.seed(21) +k <- 500 +frailty <- rnorm(k) +drug <- rbinom(k, 1, plogis(0.4 * frailty)) +diet <- rbinom(k, 1, plogis(-0.2 + 0.5 * frailty + 0.6 * drug)) +remission <- rbinom( + k, + 1, + plogis(-1.4 + 0.3 * drug + 0.3 * diet + 1.6 * drug * diet + 0.5 * frailty) +) + +regimens <- data.frame( + frailty = frailty, + remission = remission, + drug = factor(drug), + diet = factor(diet) +) +# Built after the frame so the crossing reads the same two columns the frame +# carries. +regimens$regimen <- causalgenerics::joint_exposure( + drug = regimens$drug, + diet = regimens$diet +) +``` + +```{r joint} +regimen_fit <- balance( + regimens, + regimen, + c(frailty), + method = bw_ipt(), + estimand = "ate" +) +regimens$regimen_w <- weights(regimen_fit) + +regimen_mod <- glm( + remission ~ regimen + frailty, + data = regimens, + family = quasibinomial(), + weights = regimen_w +) + +ipw(regimen_fit, regimen_mod) +``` + +The table leads with the counterfactual mean of each cell, one per combination of the two treatments, each standardized over the whole sample. The simple effects follow: each treatment against its own reference level, within a level of the other that the `group` column names. The last pair of rows is the interaction, the difference between the drug's effect at `diet = 1` and its effect at `diet = 0`, which is large here because each treatment does much less on its own than the two do together. Reported as a plain categorical exposure, these four cells would give each cell against the reference cell, under contrasts like `"drug = 1, diet = 0 vs drug = 0, diet = 0"`; the declaration replaces those rows rather than adding to them, so no row here is named that way. The interaction appears once, under the first treatment's framing, because it is symmetric in the two: the change in the drug's effect across the levels of the diet is the change in the diet's effect across the levels of the drug, and reporting it twice would put one quantity in the table under two names. No contrast row carries a log odds ratio, for the reason no subgroup row does. + +The declaration is read off the exposure column of the frame `ipw()` resolves, which is the outcome model's own frame here, so dropping it with `factor()` returns the cell-against-cell rows. A declared crossing is reported for the ATE alone, and `.by` on one is refused: effect modification of a joint intervention is a three-way question, and this surface reports neither it nor a projection of it. `?ipw.balancing` gives the full row set and both restrictions. ### Continuous exposures