tests/testthat/test-bootstrap-weight-alignment.R

In WMAP: Weighted Meta-Analysis with Pseudo-Populations

# Verifies that the balancing weights used in each bootstrap moment calculation
# are the weights estimated from that same bootstrap sample, row for row.
#
# Background: in WMAP 1.3.1 the bootstrap estimated weights on one resample and
# then drew a second resample from the original data, using those weights as
# sampling probabilities. Moments were computed on the second sample with unit
# weights. The weights therefore referred to a different set of rows than the
# covariates they were applied to. This test fails under that behaviour and
# passes once the second resample is removed.
#
# The test intercepts balancing.weights() and fn.Stage2() during a real
# causal.estimate() run and compares, per replicate, what the weights were
# estimated from against what they were applied to.

test_that("bootstrap weights are applied to the sample they were estimated from", {

  data(demo, package = "WMAP", envir = environment())

  calls <- new.env(parent = emptyenv())
  calls$estimated_from <- list()
  calls$applied_to <- list()

  real_weights <- WMAP::balancing.weights
  real_stage2 <- utils::getFromNamespace("fn.Stage2", "WMAP")

  # record the sample each set of weights was estimated from
  spy_weights <- function(S, Z, X, ...) {
    res <- real_weights(S, Z, X, ...)
    calls$estimated_from[[length(calls$estimated_from) + 1L]] <-
      list(S = S, Z = Z, X = X, wt = res$wt.v)
    res
  }

  # record the sample and weights each moment calculation actually received
  spy_stage2 <- function(local_data, local_wt.v, ...) {
    calls$applied_to[[length(calls$applied_to) + 1L]] <-
      list(S = local_data$S, Z = local_data$Z, X = local_data$X, wt = local_wt.v)
    real_stage2(local_data, local_wt.v, ...)
  }

  local_mocked_bindings(
    balancing.weights = spy_weights,
    fn.Stage2 = spy_stage2,
    .package = "WMAP"
  )

  B <- 2L
  set.seed(123)
  invisible(
    WMAP::causal.estimate(S, Z, X, Y, B = B, method = "IC", verbose = FALSE)
  )

  # one call of each for the point estimate, then one per bootstrap replicate
  expect_length(calls$estimated_from, B + 1L)
  expect_length(calls$applied_to, B + 1L)

  # index 1 is the point estimate; the replicates are 2..(B + 1)
  for (b in seq_len(B) + 1L) {

    estimated_from <- calls$estimated_from[[b]]
    applied_to <- calls$applied_to[[b]]

    # the covariates scored are the covariates the weights came from
    expect_identical(applied_to$X, estimated_from$X)
    expect_identical(applied_to$S, estimated_from$S)
    expect_identical(applied_to$Z, estimated_from$Z)

    # and the weights carried through are the estimated ones
    expect_identical(applied_to$wt, estimated_from$wt)

    # not silently replaced by unit weights
    expect_gt(stats::sd(applied_to$wt), 0)
    expect_length(applied_to$wt, nrow(applied_to$X))
  }
})