Make tests self-contained

.lintr

@@ -21,7 +21,7 @@ exclusions:
       "tests/testthat/helper.R" = list(
         object_name_linter = Inf
       ),
-      "tests/testthat/test-double_programming_ppwe.R" = list(
+      "tests/testthat/helper-ppwe.R" = list(
         object_name_linter = Inf
       ),
       "tests/testthat/test-independent_test_gs_design_wlr.R" = list(
@@ -35,9 +35,11 @@ exclusions:
         object_name_linter = Inf,
         commented_code_linter = Inf
       ),
-      "tests/testthat/test-independent-expected_accrual.R" = list(
-        object_name_linter = Inf,
-        commented_code_linter = Inf
+      "tests/testthat/helper-expected_accrual.R" = list(
+        object_name_linter = Inf
+      ),
+      "tests/testthat/helper-expected_event.R" = list(
+        object_name_linter = Inf
       ),
       "tests/testthat/test-independent-expected_event.R" = list(
         object_name_linter = Inf
@@ -64,6 +66,7 @@ exclusions:
         object_name_linter = Inf
       ),
       "tests/testthat/test-independent-hupdate.R" = list(
-        object_name_linter = Inf
+        object_name_linter = Inf,
+        commented_code_linter = Inf
       )
     )

tests/testthat/helper-ahr.R

@@ -0,0 +1,25 @@
+# Helper functions used by test-independent-AHR.R
+
+test_ahr <- function() {
+  load("fixtures/simulation_test_data.Rdata")
+
+  enroll_rate <- define_enroll_rate(
+    duration = c(2, 2, 10),
+    rate = c(3, 6, 9)
+  )
+  fail_rate <- define_fail_rate(
+    stratum = "All",
+    duration = c(3, 100),
+    fail_rate = log(2) / c(9, 18),
+    hr = c(.9, .6),
+    dropout_rate = rep(.001, 2)
+  )
+
+  list(
+    "simulation_ahr1" = simulation_AHR1,
+    "simulation_ahr2" = simulation_AHR2,
+    "simulation_ahr3" = simulation_AHR3,
+    "enroll_rate" = enroll_rate,
+    "fail_rate" = fail_rate
+  )
+}

tests/testthat/helper-expected_accrual.R

@@ -0,0 +1,26 @@
+# Helper functions used by test-independent-expected_accrual.R
+
+test_eAccrual <- function(x, enroll_rate) {
+  boundary <- cumsum(enroll_rate$duration)
+  rate <- enroll_rate$rate
+  xvals <- unique(c(x, boundary))
+
+  eAc2 <- numeric(length(xvals))
+  for (t in seq_along(xvals)) {
+    val <- xvals[t]
+    if (val <= boundary[1]) {
+      eAc2[t] <- val * rate[1]
+    } else if (val <= boundary[2]) {
+      eAc2[t] <- boundary[1] * rate[1] + (val - boundary[1]) * rate[2]
+    } else if (val <= boundary[3]) {
+      eAc2[t] <- boundary[1] * rate[1] +
+        (boundary[2] - boundary[1]) * rate[2] + (val - boundary[2]) * rate[3]
+    } else {
+      eAc2[t] <- boundary[1] * rate[1] +
+        (boundary[2] - boundary[1]) * rate[2] + (boundary[3] - boundary[2]) * rate[3]
+    }
+  }
+
+  ind <- !is.na(match(xvals, x))
+  return(eAc2[ind])
+}

tests/testthat/helper-expected_event.R

@@ -0,0 +1,81 @@
+# Helper functions used by test-independent-expected_event.R
+
+n_event <- function(failRates, followup) {
+  failduration <- failRates$duration
+  failtime <- cumsum(failduration)
+  failRate <- failRates$failRate
+  dropoutRate <- failRates$dropoutRate
+  lamda <- failRate + dropoutRate
+  lamda1 <- c(lamda, dplyr::last(lamda))
+  failRate1 <- c(failRate, dplyr::last(failRate))
+
+  failtimeend <- c(0, failtime[failtime < followup], followup)
+  failtimeend1 <- c(failtime[failtime < followup], followup)
+  lamda2 <- lamda1[c(1:(length(failtimeend) - 1))]
+  failRate2 <- failRate1[c(1:(length(failtimeend) - 1))]
+
+  failduration <- diff(failtimeend)
+  failduration2 <- followup - failtimeend1
+
+  fail <- lamda2 * failduration
+  sumfail <- cumsum(fail)
+  Bi1 <- c(1, exp(-sumfail))
+  diffbi <- diff(Bi1)
+  Bi <- Bi1[c(1:(length(Bi1) - 1))]
+
+  totalevent <- diffbi * (1 / lamda2 - failduration2) + Bi * failduration
+
+  failevent <- totalevent * (failRate2 / lamda2)
+  return(sum(failevent))
+}
+
+test_expected_event <- function(enrollRates, failRates, totalDuration) {
+  enrolltime <- c(0, cumsum(enrollRates$duration))
+  Event <- 0
+  for (i in seq_along(enrollRates$duration)) {
+    enrollmentstart <- 0
+    enrollmentend <- enrollRates$duration[i]
+    enrollrate <- enrollRates$rate[i]
+    followup <- totalDuration - enrolltime[i]
+    nEventnum <- 0
+
+    if (followup > 0 && followup <= enrollmentend) {
+      nEventnum <- n_event(failRates, followup) * enrollrate
+    } else if (followup > 0 && followup > enrollmentend) {
+      nEventnum <- (n_event(failRates, followup) - n_event(failRates, followup - enrollmentend)) * enrollrate
+    } else {
+      nEventnum <- 0
+    }
+    Event <- Event + nEventnum
+  }
+  return(Event)
+}
+
+params_expected_event <- function() {
+  enroll_rate <- define_enroll_rate(
+    duration = c(50),
+    rate = c(10)
+  )
+
+  fail_rate <- define_fail_rate(
+    duration = c(10, 20, 10),
+    fail_rate = log(2) / c(5, 10, 5),
+    dropout_rate = c(0.1, 0.2, 0),
+    hr = 1
+  )
+
+  fail_rate$failRate <- fail_rate$fail_rate
+  fail_rate$dropoutRate <- fail_rate$dropout_rate
+  failRates <- fail_rate
+
+  total_duration <- 5
+  simple <- TRUE
+
+  list(
+    "enroll_rate" = enroll_rate,
+    "fail_rate" = fail_rate,
+    "failRates" = failRates,
+    "total_duration" = total_duration,
+    "simple" = simple
+  )
+}

tests/testthat/helper-expected_time.R

@@ -0,0 +1,27 @@
+# Helper functions used by test-independent-expected_time.R
+
+test_expected_time <- function() {
+  enroll_rate <- define_enroll_rate(
+    duration = c(2, 2, 10),
+    rate = c(3, 6, 9) * 5
+  )
+
+  fail_rate <- define_fail_rate(
+    duration = c(3, 100),
+    fail_rate = log(2) / c(9, 18),
+    dropout_rate = rep(.001, 2),
+    hr = c(.9, .6)
+  )
+
+  target_event <- 150
+  interval <- c(.01, 100)
+
+  t1 <- expected_time(
+    enroll_rate = enroll_rate,
+    fail_rate = fail_rate,
+    target_event = target_event,
+    interval = interval
+  )
+
+  list("enroll_rate" = enroll_rate, "fail_rate" = fail_rate, "t1" = t1)
+}

tests/testthat/helper-fixed_design.R

@@ -0,0 +1,30 @@
+# Helper functions used by test-independent-fixed_design.R
+
+test_fixed_design <- function() {
+  # Enrollment rate
+  enroll_rate <- define_enroll_rate(
+    duration = 18,
+    rate = 20
+  )
+
+  # Failure rates
+  fail_rate <- define_fail_rate(
+    duration = c(4, 100),
+    fail_rate = log(2) / 12,
+    dropout_rate = .001,
+    hr = c(1, .6)
+  )
+
+  # Study duration in months
+  study_duration <- 36
+
+  # Experimental / Control randomization ratio
+  ratio <- 1
+
+  list(
+    "enroll_rate" = enroll_rate,
+    "fail_rate" = fail_rate,
+    "study_duration" = study_duration,
+    "ratio" = ratio
+  )
+}

tests/testthat/helper-gs_design_combo.R

@@ -0,0 +1,97 @@
+# Helper functions used by test-independent-gs_design_combo.R
+
+test_gs_design_combo <- function() {
+  load("fixtures/sim_gsd_pMaxCombo_exp1_H0_test.Rdata")
+  load("fixtures/sim_gsd_pMaxCombo_exp1_H1_test.Rdata")
+
+  ratio <- 1
+  algorithm <- mvtnorm::GenzBretz(maxpts = 1e5, abseps = 1e-5)
+  alpha <- 0.025
+  beta <- 0.2
+  enroll_rate <- define_enroll_rate(duration = 12, rate = 500 / 12)
+  fail_rate <- define_fail_rate(
+    duration = c(4, 100),
+    fail_rate = log(2) / 15, # Median survival 15 month
+    dropout_rate = 0.001,
+    hr = c(1, .6)
+  )
+
+  fh_test <- rbind(
+    data.frame(
+      rho = 0,
+      gamma = 0,
+      tau = -1,
+      test = 1,
+      analysis = 1:3,
+      analysis_time = c(12, 24, 36)
+    ),
+    data.frame(
+      rho = c(0, 0.5),
+      gamma = 0.5,
+      tau = -1,
+      test = 2:3,
+      analysis = 3,
+      analysis_time = 36
+    )
+  )
+
+  x <- gsDesign::gsSurv(
+    k = 3,
+    test.type = 4,
+    alpha = 0.025,
+    beta = 0.2,
+    astar = 0,
+    timing = c(1),
+    sfu = gsDesign::sfLDOF,
+    sfupar = c(0),
+    sfl = gsDesign::sfLDOF,
+    sflpar = c(0),
+    lambdaC = c(0.1),
+    hr = 0.6,
+    hr0 = 1,
+    eta = 0.01,
+    gamma = c(10),
+    R = c(12),
+    S = NULL,
+    T = 36,
+    minfup = 24,
+    ratio = 1
+  )
+
+  # User-defined boundary
+  gs_design_combo_test1 <- gs_design_combo(
+    enroll_rate = enroll_rate,
+    fail_rate = fail_rate,
+    fh_test = fh_test,
+    alpha = alpha,
+    beta = beta,
+    ratio = 1,
+    binding = FALSE, # test.type = 4 non-binding futility bound
+    upar = x$upper$bound,
+    lpar = x$lower$bound
+  )
+
+  # Boundary derived by spending function testing
+  gs_design_combo_test2 <- gs_design_combo(
+    enroll_rate = enroll_rate,
+    fail_rate = fail_rate,
+    fh_test = fh_test,
+    alpha = 0.025,
+    beta = 0.2,
+    ratio = 1,
+    binding = FALSE, # test.type = 4 non-binding futility bound
+    upper = gs_spending_combo,
+    upar = list(sf = gsDesign::sfLDOF, total_spend = 0.025), # alpha spending
+    lower = gs_spending_combo,
+    lpar = list(sf = gsDesign::sfLDOF, total_spend = 0.2), # beta spending
+  )
+
+  list(
+    "alpha" = alpha,
+    "beta" = beta,
+    "enroll_rate" = enroll_rate,
+    "fail_rate" = fail_rate,
+    "fh_test" = fh_test,
+    "gs_design_combo_test2" = gs_design_combo_test2
+  )
+}

tests/testthat/helper-gs_design_npe.R

@@ -0,0 +1,14 @@
+# Helper functions used by test-independent-gs_design_npe.R
+
+# Parameters used repeatedly
+params_gs_design_npe <- list(
+  K = 3,
+  timing = c(.45, .8, 1),
+  sfu = gsDesign::sfPower,
+  sfupar = 4,
+  sfl = gsDesign::sfHSD,
+  sflpar = 2,
+  delta = .2,
+  alpha = .02,
+  beta = .15
+)

tests/testthat/helper-gs_info_ahr.R

@@ -0,0 +1,16 @@
+# Helper functions used by test-independent-gs_info_ahr.R
+
+test_gs_info_ahr <- function() {
+  enroll_rate <- define_enroll_rate(
+    duration = c(2, 2, 10),
+    rate = c(3, 6, 9)
+  )
+  fail_rate <- define_fail_rate(
+    duration = c(3, 100),
+    fail_rate = log(2) / c(9, 18),
+    hr = c(0.9, 0.6),
+    dropout_rate = 0.001
+  )
+
+  list("enroll_rate" = enroll_rate, "fail_rate" = fail_rate)
+}

tests/testthat/helper-gs_info_combo.R

@@ -0,0 +1,37 @@
+# Helper functions used by test-independent-gs_info_combo.R
+
+test_gs_info_combo <- function() {
+  rho <- c(1, 1, 0, 0)
+  gamma <- c(0, 1, 0, 1)
+  tau <- c(-1, -1, -1, -1)
+  enroll_rate <- define_enroll_rate(
+    duration = c(2, 2, 30),
+    rate = c(3, 6, 9)
+  )
+  fail_rate <- define_fail_rate(
+    duration = c(3, 100),
+    fail_rate = log(2) / c(9, 18),
+    dropout_rate = rep(.001, 2),
+    hr = c(.9, .6)
+  )
+  info_combo <- gsDesign2::gs_info_combo(
+    enroll_rate = enroll_rate,
+    fail_rate = fail_rate,
+    ratio = 1, # Experimental:Control randomization ratio
+    event = NULL, # Events at analyses
+    analysis_time = 30, # Times of analyses
+    rho = rho,
+    gamma = gamma,
+    tau = rep(-1, length(rho)),
+    approx = "asymptotic"
+  )
+
+  list(
+    "rho" = rho,
+    "gamma" = gamma,
+    "tau" = tau,
+    "enroll_rate" = enroll_rate,
+    "fail_rate" = fail_rate,
+    "info_combo" = info_combo
+  )
+}