perf(bootstrap): draw all replicate samples in one vectorized call

R/bootstrap.R

@@ -170,14 +170,22 @@ new_qdr_bootstrap <- function(estimates, object, resample, backend) {
 
 generate_bootstrap_tasks <- function(object, probability, times, seed) {
   generate <- function() {
+    groups <- nrow(object$data)
+    total <- object$data$total
+    # One vectorized draw for every replicate. rbinom() consumes the random
+    # stream in order, so this is identical to drawing each replicate in turn,
+    # and far cheaper than building a tibble per replicate with tibble().
+    draws <- matrix(
+      stats::rbinom(groups * times, size = rep(total, times), prob = rep(probability, times)),
+      nrow = groups
+    )
     lapply(seq_len(times), function(replicate) {
-      positive <- stats::rbinom(nrow(object$data), size = object$data$total, prob = probability)
+      positive <- draws[, replicate]
       list(
         replicate = replicate,
-        sample_data = tibble::tibble(
-          dose = object$data$dose,
-          positive = positive,
-          negative = object$data$total - positive
+        sample_data = tibble::new_tibble(
+          list(dose = object$data$dose, positive = positive, negative = total - positive),
+          nrow = groups
         )
       )
     })

tests/testthat/test-bootstrap-tasks.R

@@ -0,0 +1,82 @@
+# The one-draw-per-replicate algorithm that generate_bootstrap_tasks() replaced.
+# The vectorized version must reproduce it exactly, so existing seeds keep giving
+# the same replicates.
+reference_tasks <- function(object, probability, times, seed) {
+  generate <- function() {
+    lapply(seq_len(times), function(replicate) {
+      positive <- stats::rbinom(nrow(object$data), size = object$data$total, prob = probability)
+      list(
+        replicate = replicate,
+        sample_data = tibble::tibble(
+          dose = object$data$dose,
+          positive = positive,
+          negative = object$data$total - positive
+        )
+      )
+    })
+  }
+  if (is.null(seed)) generate() else withr::with_seed(seed, generate())
+}
+
+ward_fit <- function(model = "beta_poisson") {
+  data <- read_dose_response(system.file("extdata", "Ward_rotavirus.txt", package = "singlehit"))
+  fit_dose_response(data, model)
+}
+
+test_that("vectorized task generation reproduces the per-replicate algorithm exactly", {
+  fit <- ward_fit()
+  for (probability in list(fit$data$response, fit$fitted)) {
+    expect_identical(
+      generate_bootstrap_tasks(fit, probability, 60L, seed = 7L),
+      reference_tasks(fit, probability, 60L, seed = 7L)
+    )
+  }
+})
+
+test_that("every model type and a single replicate produce the same tasks", {
+  for (model in c("exponential", "exact_beta_poisson")) {
+    fit <- ward_fit(model)
+    expect_identical(
+      generate_bootstrap_tasks(fit, fit$fitted, 25L, seed = 3L),
+      reference_tasks(fit, fit$fitted, 25L, seed = 3L)
+    )
+  }
+  fit <- ward_fit()
+  expect_identical(
+    generate_bootstrap_tasks(fit, fit$data$response, 1L, seed = 11L),
+    reference_tasks(fit, fit$data$response, 1L, seed = 11L)
+  )
+})
+
+test_that("tasks are numbered, well formed samples of the original groups", {
+  fit <- ward_fit()
+  tasks <- generate_bootstrap_tasks(fit, fit$data$response, 40L, seed = NULL)
+  expect_length(tasks, 40L)
+  expect_equal(vapply(tasks, function(task) task$replicate, integer(1)), 1:40)
+  for (task in tasks) {
+    sample <- task$sample_data
+    expect_s3_class(sample, "tbl_df")
+    expect_equal(sample$dose, fit$data$dose)
+    expect_equal(sample$positive + sample$negative, fit$data$total)
+    expect_true(all(sample$positive >= 0 & sample$negative >= 0))
+  }
+})
+
+test_that("a seed makes the tasks reproducible and leaves the global random stream alone", {
+  fit <- ward_fit()
+  withr::local_seed(99)
+  before <- .Random.seed
+  first <- generate_bootstrap_tasks(fit, fit$data$response, 30L, seed = 5L)
+  expect_identical(.Random.seed, before)
+  expect_identical(first, generate_bootstrap_tasks(fit, fit$data$response, 30L, seed = 5L))
+  expect_false(identical(first, generate_bootstrap_tasks(fit, fit$data$response, 30L, seed = 6L)))
+})
+
+test_that("bootstrap replicates are unchanged end to end", {
+  fit <- ward_fit()
+  tasks <- reference_tasks(fit, fit$data$response, 12L, seed = 21L)
+  expected <- dplyr::bind_rows(lapply(tasks, function(task) bootstrap_refit(fit, task$sample_data, task$replicate)))
+  boot <- bootstrap_dose_response(fit, times = 12L, seed = 21L, backend = "sequential")
+  expect_equal(boot$deviance, expected$deviance)
+  expect_equal(boot$converged, expected$converged)
+})