Merge pull request #215 from jdblischak/create-cutting-test

Add `create_cutting_test()` and `multitest()`

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: simtrial
 Type: Package
 Title: Clinical Trial Simulation
-Version: 0.3.2.7
+Version: 0.3.2.10
 Authors@R: c(
     person("Keaven", "Anderson", email = "keaven_anderson@merck.com", role = c("aut")),
     person("Yilong", "Zhang", email = "elong0527@gmail.com", role =  c("aut")),

NAMESPACE

@@ -2,6 +2,7 @@
 
 export(counting_process)
 export(create_cutting)
+export(create_cutting_test)
 export(cut_data_by_date)
 export(cut_data_by_event)
 export(early_zero)
@@ -15,6 +16,7 @@ export(maxcombo)
 export(mb)
 export(mb_weight)
 export(milestone)
+export(multitest)
 export(pvalue_maxcombo)
 export(randomize_by_fixed_block)
 export(rmst)

R/input_checking.R

@@ -87,7 +87,7 @@ input_check_vector <- function(x = NA, require_whole_number = FALSE) {
 #' @param tol tolerance
 #'
 #' @return TRUE, FALSE, or NA
-#' @seealso \code{\link[base]{is.integer}}
+#' @seealso [base::is.integer()]
 #' @noRd
 #' @examples
 #' x <- c(1.1, -1.1, 0, 2, NA)

R/maxcombo.R

@@ -22,15 +22,15 @@
 #' arguments will change as we add additional features.
 #'
 #' @param data a tte dataset
-#' @param rho Numeric vector passed to \code{\link{fh_weight}}. Must be greater
-#'   than or equal to zero. Must be the same length as \code{gamma}.
-#' @param gamma Numeric vector passed to \code{\link{fh_weight}}. Must be
-#'   greater than or equal to zero. Must be the same length as \code{rho}.
+#' @param rho Numeric vector passed to [fh_weight()]. Must be greater
+#'   than or equal to zero. Must be the same length as `gamma`.
+#' @param gamma Numeric vector passed to [fh_weight()]. Must be
+#'   greater than or equal to zero. Must be the same length as `rho`.
 #'
 #' @return pvalues
 #' @export
 #'
-#' @seealso \code{\link{fh_weight}}
+#' @seealso [fh_weight()]
 #'
 #' @examples
 #' sim_pw_surv(n = 200) |>

R/rmst.R

@@ -197,8 +197,8 @@ diff_rmst <- function(x, op_single, reference, trunc_time, alpha = alpha) {
 #'
 #' @return
 #' A data frame of
-#' - Cutoff time: same as \code{tau};
-#' - Group label: same as \code{group_label};
+#' - Cutoff time: same as `tau`;
+#' - Group label: same as `group_label`;
 #' - Estimated RMST;
 #' - Variance, standard error, and CIs of the estimated RMST;
 #' - Number of events.

R/sim_gs_n.R

@@ -22,9 +22,13 @@
 #' arguments will change as we add additional features.
 #'
 #' @inheritParams sim_fixed_n
-#' @param test A test function such as [wlr()],
-#'   [maxcombo()], or [rmst()]. The simulated data set is
-#'   passed as the first positional argument to the test function provided.
+#' @param test A test function such as [wlr()], [maxcombo()], or [rmst()]. The
+#'   simulated data set is passed as the first positional argument to the test
+#'   function provided. Alternatively a list of functions created by
+#'   [create_cutting_test()]. The list form is experimental and currently
+#'   limited. It only accepts one test per cutting (in the future multiple tests
+#'   may be accepted), and all the tests must consistently return the same exact
+#'   results (again this may be more flexible in the future).
 #' @param cutting A list of cutting functions created by [create_cutting()],
 #'   see examples.
 #' @param seed Random seed.
@@ -268,6 +272,17 @@ sim_gs_n <- function(
     cut_date <- rep(-100, n_analysis)
     ans_1sim <- NULL
 
+    # Organize tests for each cutting
+    if (is.function(test)) {
+      test_single <- test
+      test <- vector(mode = "list", length = n_analysis)
+      test[] <- list(test_single)
+    }
+    if (length(test) != length(cutting)) {
+      stop("If you want to run different tests at each cutting, the list of
+           tests must be the same length as the list of cuttings")
+    }
+
     for (i_analysis in seq_len(n_analysis)) {
       # Get cut date
       cut_date[i_analysis] <- cutting[[i_analysis]](data = simu_data)
@@ -276,7 +291,7 @@ sim_gs_n <- function(
       simu_data_cut <- simu_data |> cut_data_by_date(cut_date[i_analysis])
 
       # Test
-      ans_1sim_new <- test(simu_data_cut, ...)
+      ans_1sim_new <- test[[i_analysis]](simu_data_cut, ...)
       ans_1sim_new$analysis <- i_analysis
       ans_1sim_new$cut_date <- cut_date[i_analysis]
       ans_1sim_new$sim_id <- sim_id
@@ -294,16 +309,16 @@ sim_gs_n <- function(
 
 #' Create a cutting function
 #'
-#' Create a cutting function for use with \code{\link{sim_gs_n}}
+#' Create a cutting function for use with [sim_gs_n()]
 #'
-#' @param ... Arguments passed to \code{\link{get_analysis_date}}
+#' @param ... Arguments passed to [get_analysis_date()]
 #'
 #' @return A function that accepts a data frame of simulated trial data and
 #'   returns a cut date
 #'
 #' @export
 #'
-#' @seealso \code{\link{get_analysis_date}}, \code{\link{sim_gs_n}}
+#' @seealso [get_analysis_date()], [sim_gs_n()]
 #'
 #' @examples
 #' # Simulate trial data
@@ -324,3 +339,84 @@ create_cutting <- function(...) {
     get_analysis_date(data, ...)
   }
 }
+
+#' Create a cutting test function
+#'
+#' Create a cutting test function for use with [sim_gs_n()]
+#'
+#' @param test A test function such as [wlr()], [maxcombo()], or [rmst()]
+#' @param ... Arguments passed to the cutting test function
+#'
+#' @return A function that accepts a data frame of simulated trial data and
+#'   returns a test result
+#'
+#' @export
+#'
+#' @seealso [sim_gs_n()], [create_cutting()]
+#'
+#' @examples
+#' # Simulate trial data
+#' trial_data <- sim_pw_surv()
+#'
+#' # Cut after 150 events
+#' trial_data_cut <- cut_data_by_event(trial_data, 150)
+#'
+#' # Create a cutting test function that can be used by sim_gs_n()
+#' regular_logrank_test <- create_cutting_test(wlr, weight = fh(rho = 0, gamma = 0))
+#'
+#' # Test the cutting
+#' regular_logrank_test(trial_data_cut)
+#'
+#' # The results are the same as directly calling the function
+#' stopifnot(all.equal(
+#'   regular_logrank_test(trial_data_cut),
+#'   wlr(trial_data_cut, weight = fh(rho = 0, gamma = 0))
+#' ))
+create_cutting_test <- function(test, ...) {
+  stopifnot(is.function(test))
+  function(data) {
+    test(data, ...)
+  }
+}
+
+#' Perform multiple tests on trial data cutting
+#'
+#' WARNING: This experimental function is a work-in-progress. The function
+#' arguments and/or returned output format may change as we add additional
+#' features.
+#'
+#' @param data Trial data cut by [cut_data_by_event()] or [cut_data_by_date()]
+#' @param ... One or more test functions. Use [create_cutting_test()] to change
+#'   the default arguments of each test function.
+#'
+#' @return A list of test results, one per test. If the test functions are named
+#'   in the call to `multitest()`, the returned list uses the same names.
+#'
+#' @export
+#'
+#' @seealso [create_cutting_test()]
+#'
+#' @examples
+#' trial_data <- sim_pw_surv(n = 200)
+#' trial_data_cut <- cut_data_by_event(trial_data, 150)
+#'
+#' # create cutting test functions
+#' wlr_partial <- create_cutting_test(wlr, weight = fh(rho = 0, gamma = 0))
+#' rmst_partial <- create_cutting_test(rmst, tau = 20)
+#' maxcombo_partial <- create_cutting_test(maxcombo, rho = c(0, 0), gamma = c(0, 0.5))
+#'
+#' multitest(
+#'   data = trial_data_cut,
+#'   wlr = wlr_partial,
+#'   rmst = rmst_partial,
+#'   maxcombo = maxcombo_partial
+#' )
+multitest <- function(data, ...) {
+  tests <- list(...)
+  output <- vector(mode = "list", length = length(tests))
+  names(output) <- names(tests)
+  for (i in seq_along(tests)) {
+    output[[i]] <- tests[[i]](data)
+  }
+  return(output)
+}

R/wlr.R

@@ -19,8 +19,8 @@
 #' Weighted logrank test
 #'
 #' @param data cutted dataset generated by sim_pw_surv
-#' @param weight weighting functions, such as \code{\link{fh_weight}},
-#'   \code{\link{mb_weight}}, and \code{\link{early_zero_weight}}.
+#' @param weight weighting functions, such as [fh_weight()], [mb_weight()], and
+#'   [early_zero_weight()].
 #'
 #' @return test results
 #'

R/wlr_weight.R

@@ -18,8 +18,8 @@
 
 #' Fleming-Harrington weighting function
 #'
-#' @param rho Non-negative number. \code{rho = 0, gamma = 0} is equivalent to regular logrank test.
-#' @param gamma Non-negative number. \code{rho = 0, gamma = 0} is equivalent to regular logrank test.
+#' @param rho Non-negative number. `rho = 0, gamma = 0` is equivalent to regular logrank test.
+#' @param gamma Non-negative number. `rho = 0, gamma = 0` is equivalent to regular logrank test.
 #'
 #' @export
 #' @return A list of parameters of the Fleming-Harrington weighting function

_pkgdown.yml

@@ -53,6 +53,8 @@ reference:
     - milestone
     - wlr
     - maxcombo
+    - create_cutting_test
+    - multitest
 
 - title: "Randomization algorithms"
   contents: