tests/testthat/test-bootstrap-helpers.R

In bschneidr/svrep: Tools for Creating, Updating, and Analyzing Survey Replicate Weights

suppressWarnings({
  suppressPackageStartupMessages({
    library(survey)
    library(dplyr)
    library(svrep)
    library(testthat)
  })
})

# Create an example bootstrap survey design object ----
 library(survey)
 data('api', package = 'survey')

 boot_design <- svydesign(id=~1,strata=~stype, weights=~pw,
                          data=apistrat, fpc=~fpc) |>
   svrep::as_bootstrap_design(replicates = 100)

# Calculate estimates of interest and retain estimates from each replicate ----

 estimated_means_and_proportions <- svymean(x = ~ api00 + api99 + stype, design = boot_design,
                                            return.replicates = TRUE)
 custom_statistic <- withReplicates(design = boot_design,
                                    return.replicates = TRUE,
                                    theta = function(wts, data) {
                                      numerator <- sum(data$api00 * wts)
                                      denominator <- sum(data$api99 * wts)
                                      statistic <- numerator/denominator
                                      return(statistic)
                                    })

# Consistent results between functions ----

  current_sim_cv <- estimate_boot_sim_cv(estimated_means_and_proportions)

  test_that(
    "Consistent calculations from different functions", {
      expect_equal(
        object = estimate_boot_reps_for_target_cv(
          estimated_means_and_proportions,
          target_cv = c(current_sim_cv$SIMULATION_CV[1],
                        current_sim_cv$SIMULATION_CV[3])
        )[c(1,2),c('api00', 'stypeE')] |> as.matrix() |> diag(),
        expected = rep(current_sim_cv$N_REPLICATES[1], 2)
      )
  })

# Sanity check ----

  library(survey)
  data("election", package = "survey")

  ht_quad_form_matrix <- make_quad_form_matrix(variance_estimator = "Horvitz-Thompson",
                                               joint_probs = election_jointprob)
  ##_ Produce variance estimate
  wtd_y <- as.matrix(election_pps$wt * election_pps$Bush)
  expected_value <- as.numeric(t(wtd_y) %*% ht_quad_form_matrix %*% wtd_y)

  set.seed(2014)
  sim_results <- replicate(n = 200, expr = {
    adj_factors <- make_gen_boot_factors(Sigma = ht_quad_form_matrix,
                                         num_replicates = 50,
                                         tau = "auto")
    election_pps_bootstrap_design <- svrepdesign(
      data = election_pps,
      weights = 1 / diag(election_jointprob),
      repweights = adj_factors,
      combined.weights = FALSE,
      type = "other",
      scale = attr(adj_factors, 'scale'),
      rscales = attr(adj_factors, 'rscales')
    )

    estimate <- svytotal(x = ~ Bush, design = election_pps_bootstrap_design,
                         return.replicates = TRUE)

    sim_cv_estimate <- estimate_boot_sim_cv(estimate)[['SIMULATION_CV']]
    var_estimate <- as.numeric(vcov(estimate))
    c('sim_cv' = sim_cv_estimate, 'var_estimate' = var_estimate)
  })

  empirical_sim_cv <- sd(sim_results['var_estimate',]) / expected_value
  mean_estimated_sim_cv <- mean(sim_results['sim_cv',])

  rel_abs_error <- abs(mean_estimated_sim_cv - empirical_sim_cv)/empirical_sim_cv

  test_that(
    "`estimate_boot_sim_cv() produces correct results", {
      expect_lt(
        object = rel_abs_error,
        expected = 0.05
      )
    }
  )