Merge pull request #435 from Merck/ahr-blinded-test

Add tests for `ahr_blinded()`

R/ahr_blinded.R

@@ -91,7 +91,7 @@ ahr_blinded <- function(
     stop("'intervals' must be a vector of positive numbers.")
   }
   if (length(intervals) != length(hr)) {
-    stop("the piecewise model specified 'hr' and 'intervals' differ in length.")
+    stop("The piecewise model specified 'hr' and 'intervals' differ in length.")
   }
 
   # Set final element of "intervals" to Inf

tests/testthat/test-independent-ahr_blinded.R

@@ -0,0 +1,112 @@
+test_that("ahr_blinded throws an error for non-numeric or negative hr", {
+  expect_error(
+    ahr_blinded(hr = c(1, -2, 3)),
+    "'hr' must be a vector of positive numbers."
+  )
+  expect_error(
+    ahr_blinded(hr = "abc"),
+    "'hr' must be a vector of positive numbers."
+  )
+})
+
+test_that("ahr_blinded throws an error when intervals and hr are not aligned", {
+  expect_error(
+    ahr_blinded(intervals = c(3, 6), hr = c(1)),
+    "The piecewise model specified 'hr' and 'intervals' differ in length."
+  )
+})
+
+test_that("Correct computation of blinded AHR and information adjustment", {
+  surv <- survival::Surv(simtrial::ex2_delayed_effect$month, event = simtrial::ex2_delayed_effect$evntd)
+  intervals <- c(3, Inf)
+  hr <- c(1, 0.6)
+  ratio <- 1
+  event <- simtrial::fit_pwexp(surv, intervals)[, 3]
+
+  expected_event <- sum(surv[, "status"])
+  expected_theta <- -sum(log(hr[1:length(event)]) * event) / sum(event)
+  expected_ahr <- exp(-(-sum(log(hr[1:length(event)]) * event) / sum(event)))
+  expected_info0 <- sum(surv[, "status"]) * (1 - ratio / (1 + ratio)) * (ratio / (1 + ratio))
+
+  result <- ahr_blinded(surv = surv, intervals = intervals, hr = hr, ratio = ratio)
+
+  expect_equal(result$event, expected_event)
+  expect_equal(result$ahr, expected_ahr, tolerance = 0.001)
+  expect_equal(result$theta, expected_theta, tolerance = 0.001)
+  expect_equal(result$info0, expected_info0)
+})
+
+test_that("ahr_blinded computes theta with constant hazard ratios correctly", {
+  surv <- survival::Surv(
+    simtrial::ex1_delayed_effect$month,
+    simtrial::ex1_delayed_effect$evntd
+  )
+  intervals <- c(3, 6, Inf)
+  hr <- c(1, 1, 1)
+  result <- ahr_blinded(surv = surv, intervals = intervals, hr = hr)
+
+  # When all hr = 1, theta should be 0
+  expect_equal(result$theta, 0)
+})
+
+test_that("ahr_blinded handles zero events", {
+  surv <- survival::Surv(time = c(1, 2, 3, 4, 5), event = c(0, 0, 0, 0, 0)) # No events
+  intervals <- c(2, 3, Inf)
+  hr <- c(0.8, 0.9, 1)
+
+  result <- ahr_blinded(surv = surv, intervals = intervals, hr = hr)
+
+  expect_equal(result$event, 0)
+  expect_true(is.nan(result$ahr))
+  expect_true(is.nan(result$theta))
+  expect_equal(result$info0, 0)
+})
+
+test_that("ahr_blinded handles all events in the first interval", {
+  surv <- survival::Surv(time = c(1, 2, 2.5, 3, 3.5), event = c(1, 1, 1, 1, 1))
+  # Only the first interval contains events
+  intervals <- c(4, Inf)
+  hr <- c(0.5, 0.7)
+
+  result <- ahr_blinded(surv = surv, intervals = intervals, hr = hr)
+
+  # All events are in the first interval, so result should reflect hr[1]
+  expected_theta <- -sum(log(hr[1]) * sum(surv[, "status"])) / sum(surv[, "status"])
+  expect_equal(result$theta, expected_theta)
+  expect_equal(result$event, sum(surv[, "status"]))
+})
+
+test_that("ahr_blinded handles very small hazard ratios", {
+  surv <- survival::Surv(time = c(1, 2, 3, 4, 5), event = c(1, 1, 1, 1, 1))
+  intervals <- c(2, 3, Inf)
+  hr <- c(0.1, 0.2, 0.3)
+
+  res <- ahr_blinded(surv = surv, intervals = intervals, hr = hr)
+
+  expect_true(res$theta > 0)
+  expect_true(res$ahr < 1)
+})
+
+test_that("ahr_blinded handles very high randomization ratio", {
+  surv <- survival::Surv(time = c(1, 2, 3, 4, 5), event = c(1, 1, 1, 1, 1))
+  intervals <- c(2, 3, Inf)
+  hr <- c(0.8, 0.9, 0.95)
+  ratio <- 100
+
+  result <- ahr_blinded(surv = surv, intervals = intervals, hr = hr, ratio = ratio)
+
+  # info0 should be near 0
+  expect_equal(result$info0, 0, tolerance = 0.05)
+})
+
+test_that("ahr_blinded returns a tibble with correct structure and types", {
+  result <- ahr_blinded()
+
+  expect_true(tibble::is_tibble(result))
+  expect_named(result, c("event", "ahr", "theta", "info0"))
+  expect_true(nrow(result) == 1L)
+  expect_type(result$event, "double")
+  expect_type(result$ahr, "double")
+  expect_type(result$theta, "double")
+  expect_type(result$info0, "double")
+})