Merge pull request #276 from jdblischak/wlr-s3

Convert wlr() to S3 generic to accept tte_data or counting_process

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: simtrial
 Type: Package
 Title: Clinical Trial Simulation
-Version: 0.4.1.9
+Version: 0.4.1.10
 Authors@R: c(
     person("Keaven", "Anderson", email = "keaven_anderson@merck.com", role = c("aut")),
     person("Yujie", "Zhao", email = "yujie.zhao@merck.com", role =  c("ctb","cre")),

NAMESPACE

@@ -2,6 +2,8 @@
 
 S3method(as_gt,simtrial_gs_wlr)
 S3method(summary,simtrial_gs_wlr)
+S3method(wlr,counting_process)
+S3method(wlr,tte_data)
 export(as_gt)
 export(counting_process)
 export(create_cut)

R/counting_process.R

@@ -64,7 +64,10 @@
 #' @details
 #' The output produced by [counting_process()] produces a
 #' counting process dataset grouped by stratum and sorted within stratum
-#' by increasing times where events occur.
+#' by increasing times where events occur. The object is assigned the class
+#' "counting_process". It also has the attributes "n_ctrl" and "n_exp",
+#' which are the totals of the control and experimental treatments,
+#' respectively, from the input time-to-event data.
 #'
 #' @examples
 #' # Example 1
@@ -144,6 +147,10 @@ counting_process <- function(x, arm) {
 
   setDF(ans)
   class(ans) <- c("counting_process", class(ans))
+  # Record number of control and experimental treatments, which is required for
+  # downstream test function wlr()
+  attr(ans, "n_ctrl") <- sum(x$treatment == "control")
+  attr(ans, "n_exp") <- sum(x$treatment == "experimental")
 
   return(ans)
 }

R/cut_data_by_date.R

@@ -40,5 +40,6 @@ cut_data_by_date <- function(x, cut_date) {
   ans <- ans[, c("tte", "event", "stratum", "treatment")]
 
   setDF(ans)
+  class(ans) <- c("tte_data", class(ans))
   return(ans)
 }

R/cut_data_by_event.R

@@ -36,5 +36,6 @@
 cut_data_by_event <- function(x, event) {
   cut_date <- get_cut_date_by_event(x, event)
   ans <- x |> cut_data_by_date(cut_date = cut_date)
+  class(ans) <- c("tte_data", class(ans))
   return(ans)
 }

R/wlr.R

@@ -18,7 +18,8 @@
 
 #' Weighted logrank test
 #'
-#' @param data Dataset that has been cut, generated by [sim_pw_surv()].
+#' @param data Dataset (generated by [sim_pw_surv()]) that has been cut by
+#'   [counting_process()], [cut_data_by_date()], or [cut_data_by_event()].
 #' @param weight Weighting functions, such as [fh()], [mb()], and
 #'   [early_zero()].
 #' @param return_variance A logical flag that, if `TRUE`, adds columns
@@ -85,12 +86,33 @@
 #'
 #' # Example 3: WLR test with early zero wights
 #' x |> wlr(weight = early_zero(early_period = 4))
+#'
+#' # For increased computational speed when running many WLR tests, you can
+#' # pre-compute the counting_process() step first, and then pass the result of
+#' # counting_process() directly to wlr()
+#' x <- x |> counting_process(arm = "experimental")
+#' x |> wlr(weight = fh(rho = 0, gamma = 1))
+#' x |> wlr(weight = mb(delay = 4, w_max = 2))
+#' x |> wlr(weight = early_zero(early_period = 4))
 wlr <- function(data, weight, return_variance = FALSE) {
+  UseMethod("wlr", data)
+}
+
+#' @rdname wlr
+#' @export
+wlr.tte_data <- function(data, weight, return_variance = FALSE) {
   x <- data |> counting_process(arm = "experimental")
+  wlr.counting_process(x, weight, return_variance = FALSE)
+}
+
+#' @rdname wlr
+#' @export
+wlr.counting_process <- function(data, weight, return_variance = FALSE) {
+  x <- data
 
   # calculate the sample size and randomization ratio
   n <- nrow(data)
-  ratio <- sum(data$treatment == "experimental") / sum(data$treatment == "control")
+  ratio <- attr(data, "n_exp") / attr(data, "n_ctrl")
   q_e <- ratio / (1 + ratio)
   q_c <- 1 - q_e
 

tests/testthat/test-unvalidated-data.table.R

@@ -12,7 +12,7 @@ test_that("functions that use data.table still return a data frame", {
 
   # cut_data_by_date()
   x <- sim_pw_surv(n = 20)
-  expect_identical(class(cut_data_by_date(x, 5)), class_expected)
+  expect_identical(class(cut_data_by_date(x, 5)), c("tte_data", class_expected))
 
   # early_zero_weight()
   x <- sim_pw_surv(n = 200)

tests/testthat/test-unvalidated-wlr.R

@@ -0,0 +1,28 @@
+test_that("wlr() accepts tte_data and counting_process objects as input", {
+  # cut_data_by_event()
+  x <- sim_pw_surv(n = 300) |> cut_data_by_event(100)
+  expect_s3_class(x, "tte_data")
+  results_tte_data <- x |> wlr(weight = fh(0, 0.5))
+
+  x <- x |> counting_process(arm = "experimental")
+  expect_s3_class(x, "counting_process")
+  results_counting_process <- x |> wlr(weight = fh(0, 0.5))
+
+  expect_equal(results_tte_data, results_counting_process)
+
+  # cut_data_by_date()
+  x <- sim_pw_surv(n = 300) |> cut_data_by_date(cut_date = 300)
+  expect_s3_class(x, "tte_data")
+  results_tte_data <- x |> wlr(weight = fh(0, 0.5))
+
+  x <- x |> counting_process(arm = "experimental")
+  expect_s3_class(x, "counting_process")
+  results_counting_process <- x |> wlr(weight = fh(0, 0.5))
+
+  expect_equal(results_tte_data, results_counting_process)
+})
+
+test_that("wlr() rejects input object without proper class", {
+  x <- mtcars
+  expect_error(wlr(x), "no applicable method")
+})