tests/testthat/test-generate_subgroup.R

In SimNPH: Simulate Non-Proportional Hazards

test_that("assumptions_subgroup outputs correct tibble", {
  capture_output(
    expect_invisible(
      assumptions_subgroup(),
      label = "assumptions_subgroup returns invisibly"
    )
  )

  expect_output(
    assumptions_subgroup(print=TRUE),
    regexp = "^expand.grid.*",
    label = "assumptions_subgroup prints something with createDesign"
  )

  capture_output(
    test_design <- assumptions_subgroup()
  )

  expect_true(
    all(hasName(
      test_design,
      c("hazard_ctrl", "hazard_trt", "hazard_subgroup", "prevalence", "random_withdrawal")
    )),
    label = "output of assumptions_subgroup has the right columns"
  )

  expect_true(
    test_design[, c("hazard_ctrl", "hazard_trt", "hazard_subgroup", "prevalence", "random_withdrawal")] |>
      sapply(is.numeric) |>
      all(),
    label = "columns of output of assumptions_subgroup have the right datatype"
  )

})

test_that("test that generate_subgroup outputs correct tibble", {
  capture_output(
    scenario <- merge(
      assumptions_subgroup(),
      design_fixed_followup(),
      by=NULL
    )[2, ]
  )
  one_simulation <- generate_subgroup(scenario)

  expect_equal(
    nrow(one_simulation),
    scenario$n_trt + scenario$n_ctrl,
    label = "nrow equals treatment + control"
  )

  expect_true(
    all(hasName(
      one_simulation,
      c("t", "trt", "evt", "subgroup")
    )),
    label = "simulated dataset has the right columns"
  )

  expect_equal(
    sapply(one_simulation[, c("t", "trt", "evt")], class),
    c(t="numeric", trt="numeric", evt="logical"),
    label = "columns of simulated dataset have the right datatypes"
  )

})

test_that("generate_subgroup fails on proportion not between 0 and 1", {
  capture_output(
    scenario <- scenario <- merge(
      assumptions_subgroup(),
      design_fixed_followup(),
      by=NULL
    ) |>
      head(1)
  )

  scenario$prevalence <- -1

  expect_error(
    generate_subgroup(scenario)
  )

  scenario$prevalence <- 2

  expect_error(
    generate_subgroup(scenario)
  )
})


test_that("test that true_summary_statistics_subgroup works", {
  test_design <- createDesign(
    n_trt=50,
    n_ctrl=50,
    prevalence=c(0, 0.5, 1),
    hazard_ctrl=0.2,
    hazard_trt=c(0.2, 0.02),
    hazard_subgroup=1e-4,
    random_withdrawal=0.01
  )

  test_design1 <- test_design |>
    true_summary_statistics_subgroup(cutoff_stats = c(7, 15), milestones = c(10))

  expect_named(test_design1, c("n_trt", "n_ctrl", "prevalence", "hazard_ctrl", "hazard_trt",
                               "hazard_subgroup", "random_withdrawal",
                               "median_survival_trt", "median_survival_ctrl", "rmst_trt_7",
                               "rmst_ctrl_7", "gAHR_7", "AHR_7", "AHRoc_7", "AHRoc_robust_7", "rmst_trt_15", "rmst_ctrl_15",
                               "gAHR_15", "AHR_15", "AHRoc_15", "AHRoc_robust_15", "milestone_survival_trt_10", "milestone_survival_ctrl_10"
  ))

  expect(all(test_design1$gAHR_7[(test_design1$prevalence == 0) & (test_design1$hazard_ctrl == test_design1$hazard_trt)] == 1), "all gAHR should be 1 for equal hazards and prevalence == 0")
  expect(all(test_design1$ AHR_15[(test_design1$prevalence == 0) & (test_design1$hazard_ctrl == test_design1$hazard_trt)] == 1), "all AHR should be 1 for equal hazards and prevalence == 0")

  expect(all(test_design1$gAHR_7[(test_design1$prevalence == 0) & (test_design1$hazard_ctrl == test_design1$hazard_trt)] == 1), "all gAHR should be 1 for equal hazards and prevalence == 0")
  expect(all(test_design1$ AHR_15[(test_design1$prevalence == 0) & (test_design1$hazard_ctrl == test_design1$hazard_trt)] == 1), "all AHR should be 1 for equal hazards and prevalence == 0")

})

test_that("test that true_summary_statistics_subgroup fails prevalence not in [0,1]", {
  capture_output(
    scenario <- merge(assumptions_subgroup(), design_fixed_followup(), by=NULL)[1, ]
  )

  scenario$prevalence <- -1

  expect_error(
    true_summary_statistics_subgroup(scenario)
  )

  scenario$prevalence <- 2

  expect_error(
    true_summary_statistics_subgroup(scenario)
  )
})

test_that("hazard_subgroup_from_PH_effect_size works", {

  capture_output(
    my_design <- merge(
      assumptions_subgroup(),
      design_fixed_followup(),
      by=NULL
    )
  )

  my_design_2 <- my_design

  my_design$hazard_trt <- NA
  my_design$hazard_subgroup <- NA
  my_design$hr_subgroup_relative <- 0.9
  my_design$final_events <- ceiling((my_design$n_ctrl + my_design$n_trt) * 0.75)

  my_design_3 <- my_design
  my_design_3$effect_size_ph <- c(0, 0.7, 0.8, 0.9)

  result_1 <- hazard_subgroup_from_PH_effect_size(my_design, target_power_ph=0.9)
  result_3 <- hazard_subgroup_from_PH_effect_size(my_design_3)

  expect_named(result_1, c("hazard_ctrl", "hazard_trt", "hazard_subgroup", "prevalence",
                            "random_withdrawal", "n_trt", "n_ctrl", "followup", "recruitment",
                            "hr_subgroup_relative", "final_events", "target_median_trt"))

  expect_lt(max(abs((result_1$hazard_subgroup / result_1$hazard_trt) - result_1$hr_subgroup_relative), na.rm = TRUE), 1e-15)
  expect_true(all(!is.na(result_1$hazard_subgroup)))
  expect_true(all(!is.na(result_1$hazard_trt)))

  expect_named(result_3, c("hazard_ctrl", "hazard_trt", "hazard_subgroup", "prevalence",
                           "random_withdrawal", "n_trt", "n_ctrl", "followup", "recruitment",
                           "hr_subgroup_relative", "final_events", "effect_size_ph", "target_median_trt"))

  expect_lt(max(abs((result_3$hazard_subgroup / result_3$hazard_trt) - result_3$hr_subgroup_relative), na.rm = TRUE), 1e-15)
  expect_true(all(!is.na(result_3$hazard_subgroup)))
  expect_true(all(!is.na(result_3$hazard_trt)))


  expect_error(hazard_subgroup_from_PH_effect_size(my_design_2, target_power_ph=0.9))
  expect_error(hazard_subgroup_from_PH_effect_size(my_design))


})

test_that("cen_rate_from_cen_prop_subgroup works", {
  design <- expand.grid(
    hazard_ctrl=0.2,                   # hazard under control and before treatment effect
    hazard_trt=0.02,                   # hazard after onset of treatment effect
    hazard_subgroup=0.01,              # hazard in the subgroup in treatment
    prevalence = c(0.2, 0.5),           # subgroup prevalence
    censoring_prop=c(0.1, 0.25, 0.01), # 10%, 25%, 1% random censoring
    followup=100,                      # followup of 100 days
    n_trt=50,                          # 50 patients treatment
    n_ctrl=50                          # 50 patients control
  )

  design$censoring_prop[1] <- 0
  design$hazard_trt[2] <- NA_real_

  result <- cen_rate_from_cen_prop_subgroup(design)

  expect_named(result, c("hazard_ctrl", "hazard_trt", "hazard_subgroup", "prevalence",
                         "censoring_prop", "followup", "n_trt", "n_ctrl", "random_withdrawal"
  ))

  expect_equal(result$random_withdrawal[1], 0)
  expect_true(is.na(result$random_withdrawal[2]))
  expect_true(all(!is.na(tail(result$random_withdrawal, -2))))

})