Merge pull request #91 from Remove rlang::expr, add custom trigger arithmetic

Remove rlang::expr, add custom trigger arithmetic

Author: saumil-sh

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: rxsim
 Type: Package
 Title: Reducing friction for Randomized Clinical Trial simulations
-Version: 0.1.3.9000
+Version: 0.1.4.9000
 Authors@R: c(
     person(
       "Matthew", "Valko",

NAMESPACE

@@ -1,12 +1,17 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("&",rxsim_trigger)
+S3method("|",rxsim_trigger)
 export(Condition)
 export(Population)
 export(Timer)
 export(Trial)
 export(add_timepoints)
+export(calendar_trigger)
 export(clone_trial)
 export(collect_results)
+export(count_trigger)
+export(enroll_trigger)
 export(gen_plan)
 export(gen_population)
 export(gen_timepoints)
@@ -16,6 +21,7 @@ export(replicate_trial)
 export(run_trials)
 export(trigger_by_calendar)
 export(trigger_by_fraction)
+export(value_trigger)
 export(vector_to_dataframe)
 importFrom(dplyr,.data)
 importFrom(dplyr,arrange)
@@ -26,5 +32,4 @@ importFrom(dplyr,select)
 importFrom(dplyr,ungroup)
 importFrom(rlang,":=")
 importFrom(rlang,enquos)
-importFrom(rlang,quos)
 importFrom(utils,tail)

R/Condition.R

@@ -1,3 +1,25 @@
+.trigger_to_quosures <- function(trigger) {
+  if (!is.null(trigger$type)) {
+    expr <- if (identical(trigger$type, "value")) {
+      call(trigger$op, call("[[", quote(.data), trigger$col), trigger$rhs)
+    } else {
+      call(trigger$op,
+           call("sum", call("!", call("is.na", call("[[", quote(.data), trigger$col)))),
+           trigger$rhs)
+    }
+    return(list(rlang::new_quosure(expr, env = rlang::current_env())))
+  }
+
+  if (identical(trigger$combinator, "&")) {
+    return(unlist(lapply(trigger$predicates, .trigger_to_quosures), recursive = FALSE))
+  }
+
+  left_quos  <- .trigger_to_quosures(trigger$left)
+  right_quos <- .trigger_to_quosures(trigger$right)
+  expr <- call("|", rlang::get_expr(left_quos[[1L]]), rlang::get_expr(right_quos[[1L]]))
+  list(rlang::new_quosure(expr, env = rlang::current_env()))
+}
+
 #' Condition: Stateful trigger and analysis unit
 #'
 #' @description
@@ -29,8 +51,9 @@
 #' is not updated.
 #'
 #' On a successful trigger, the condition calls
-#' `analysis(filtered_data, current_time)` and stores the result under
-#' `name` (or `1L` when no name is set). If no analysis function is
+#' `analysis(df, current_time, ...)` and stores the result under
+#' `name` (or `1L` when no name is set). Any values in `analysis_args` are
+#' appended as additional named arguments. If no analysis function is
 #' provided, the filtered data frame is returned as-is with a warning.
 #'
 #' @section Fields:
@@ -39,9 +62,11 @@
 #'     `dplyr::filter()` predicates. Pass `NULL` or an empty list to skip
 #'     filtering and pass the full snapshot to the analysis.}
 #'   \item{\code{analysis}}{`function` or `NULL`. Called as
-#'     `analysis(filtered_data, current_time)` on a successful trigger.
-#'     Should return a `data.frame` or named list. If `NULL`, the filtered
-#'     data frame is returned with a warning.}
+#'     `analysis(df, current_time, ...)` on a successful trigger, where `...`
+#'     are any values from `analysis_args`. Should return a `data.frame` or
+#'     named list. If `NULL`, the filtered data frame is returned with a warning.}
+#'   \item{\code{analysis_args}}{`list` or `NULL`. Named list of extra arguments
+#'     injected into every call to `analysis`.}
 #'   \item{\code{name}}{`character` or `NULL`. Key used to label the result
 #'     in the returned list. Falls back to `1L` when `NULL`.}
 #'   \item{\code{cooldown}}{`numeric`. Minimum time units that must elapse
@@ -74,6 +99,8 @@
 #'   \item [`Trial`] for running the simulation and iterating over conditions
 #'   \item [`trigger_by_calendar()`] and [`trigger_by_fraction()`] for
 #'     convenient `Condition` constructors
+#'   \item [value_trigger()], [count_trigger()], [enroll_trigger()],
+#'     [calendar_trigger()] for building safe trigger specifications
 #'   \item [`dplyr::filter()`] for predicate syntax
 #' }
 #'
@@ -86,8 +113,8 @@
 #' )
 #'
 #' # Analysis function: count active subjects per arm
-#' count_fn <- function(dat, current_time) {
-#'   data.frame(n_active = nrow(dat), fired_at = current_time)
+#' count_fn <- function(df, current_time) {
+#'   data.frame(n_active = nrow(df), fired_at = current_time)
 #' }
 #'
 #' # Condition fires once when arm A has active subjects (max_triggers = 1)
@@ -115,13 +142,19 @@ Condition <- R6::R6Class(
   public = list(
     # --- fields ---
     #' @field where `list` of quosures (`rlang::quos()`) used as `dplyr::filter()`
-    #'   predicates. `NULL` or empty list passes the full snapshot.
+    #'   predicates, or an `rxsim_trigger` (converted automatically). `NULL` or
+    #'   empty list passes the full snapshot.
     where = NULL,
 
     #' @field analysis `function` or `NULL`. Called as
-    #'   `analysis(filtered_data, current_time)` on a successful trigger.
+    #'   `analysis(df, current_time, ...)` on a successful trigger, where `...`
+    #'   are any values from `analysis_args`.
     analysis = NULL,
 
+    #' @field analysis_args `list` or `NULL`. Named list of extra values injected
+    #'   into the analysis function call as additional named arguments.
+    analysis_args = NULL,
+
     #' @field name `character` or `NULL`. Key labelling the result in the output
     #'   list. Falls back to `1L` when `NULL`.
     name = NULL,
@@ -146,26 +179,33 @@ Condition <- R6::R6Class(
     #' @description
     #' Create a new `Condition` instance.
     #'
-    #' @param where `list` of quosures (from `rlang::quos()`) used as filter
-    #'   predicates. Pass `NULL` or omit to use the full snapshot.
+    #' @param where `rxsim_trigger` (converted automatically to quosures), a
+    #'   `list` of quosures from `rlang::quos()`, or `NULL` to use the full
+    #'   snapshot.
     #' @param analysis `function` or `NULL`. Called as
-    #'   `analysis(filtered_data, current_time)` on a successful trigger.
+    #'   `analysis(df, current_time, ...)` on a successful trigger, where `...`
+    #'   are the values from `analysis_args`.
+    #' @param analysis_args `list` or `NULL`. Named list of extra arguments
+    #'   passed to the analysis function after `df` and `current_time`.
     #' @param name `character` or `NULL`. Result key. Defaults to `1L`.
     #' @param cooldown `numeric`. Minimum time between triggers. Default `0`.
     #' @param max_triggers `integer`. Maximum trigger count. Default `1L`.
     #'   Use `Inf` for unlimited.
     #'
     #' @return A new `Condition` instance.
     initialize = function(
-      where        = NULL,
-      analysis     = NULL,
-      name         = NULL,
-      cooldown     = 0,
-      max_triggers = 1L
+      where         = NULL,
+      analysis      = NULL,
+      analysis_args = NULL,
+      name          = NULL,
+      cooldown      = 0,
+      max_triggers  = 1L
     ) {
-      self$where    <- where
-      self$analysis <- analysis
-      self$name     <- name
+      if (inherits(where, "rxsim_trigger")) where <- .trigger_to_quosures(where)
+      self$where         <- where
+      self$analysis      <- analysis
+      self$analysis_args <- analysis_args
+      self$name          <- name
 
       cooldown <- as.numeric(cooldown)
       if (length(cooldown) != 1L || cooldown < 0 || is.na(cooldown)) {
@@ -230,7 +270,7 @@ Condition <- R6::R6Class(
       }
 
       if (is.function(self$analysis)) {
-        results[[key]] <- self$analysis(df_i, current_time)
+        results[[key]] <- do.call(self$analysis, c(list(df_i, current_time), self$analysis_args))
       } else {
         results[[key]] <- df_i
         warning(

R/helpers.R

@@ -1,88 +1,3 @@
-#' Trigger Analysis at a Calendar Time
-#'
-#' Builds a [`Condition`] that fires when the trial clock reaches a specified
-#' calendar time. The returned `Condition` should be passed to
-#' `Trial$new(conditions = list(...))`.
-#'
-#' @param cal_time `numeric` Calendar time(s) at which to trigger.
-#' @param analysis `function` or `NULL` Optional analysis function called as
-#'   `analysis(filtered_data, current_time)`. If `NULL`, the filtered snapshot
-#'   is returned as-is with a warning.
-#' @param name `character` or `NULL` Result key. Defaults to
-#'   `"cal_time_<cal_time>"`.
-#'
-#' @return A [`Condition`] object.
-#'
-#' @seealso [Condition], [trigger_by_fraction()], [Trial].
-#'
-#' @export
-#'
-#' @examples
-#' cond <- trigger_by_calendar(
-#'   cal_time = 12,
-#'   analysis = function(df, current_time) {
-#'     data.frame(n_enrolled = sum(!is.na(df$enroll_time)))
-#'   }
-#' )
-#'
-#' @importFrom rlang quos
-#' @importFrom dplyr .data
-trigger_by_calendar <- function(cal_time, analysis = NULL, name = NULL) {
-  if (missing(cal_time)) stop("`cal_time` is required.")
-  stopifnot(is.numeric(cal_time))
-  if (is.null(name)) name <- paste0("cal_time_", paste(cal_time, collapse = "_"))
-
-  Condition$new(
-    where    = rlang::quos(.data$time %in% !!cal_time),
-    analysis = analysis,
-    name     = name
-  )
-}
-
-#' Trigger Analysis at a Sample Fraction
-#'
-#' Builds a [`Condition`] that fires when a given fraction of the target sample
-#' has been enrolled. The returned `Condition` should be passed to
-#' `Trial$new(conditions = list(...))`.
-#'
-#' @param fraction `numeric` Sample fraction (0 < fraction <= 1).
-#' @param sample_size `integer` Target sample size.
-#' @param analysis `function` or `NULL` Optional analysis function called as
-#'   `analysis(filtered_data, current_time)`. If `NULL`, the filtered snapshot
-#'   is returned as-is with a warning.
-#' @param name `character` or `NULL` Result key. Defaults to
-#'   `"frac_<fraction>"`.
-#'
-#' @return A [`Condition`] object.
-#'
-#' @seealso [Condition], [trigger_by_calendar()], [Trial].
-#'
-#' @export
-#'
-#' @examples
-#' cond <- trigger_by_fraction(
-#'   fraction    = 0.5,
-#'   sample_size = 100,
-#'   analysis    = function(df, current_time) {
-#'     data.frame(n_enrolled = sum(!is.na(df$enroll_time)))
-#'   }
-#' )
-#'
-#' @importFrom rlang quos
-#' @importFrom dplyr .data
-trigger_by_fraction <- function(fraction, sample_size, analysis = NULL, name = NULL) {
-  if (missing(fraction) || missing(sample_size)) stop("`fraction` and `sample_size` are required.")
-  stopifnot(is.numeric(sample_size) && length(sample_size) == 1L)
-  stopifnot(fraction > 0 && fraction <= 1)
-  if (is.null(name)) name <- paste0("frac_", fraction)
-  target_n <- fraction * sample_size
-
-  Condition$new(
-    where    = rlang::quos(sum(!is.na(.data$enroll_time)) >= !!target_n),
-    analysis = analysis,
-    name     = name
-  )
-}
 
 #' Add Timepoints to a Timer
 #'
@@ -159,8 +74,8 @@ add_timepoints <- function(timer, df) {
 #' )
 #' an_gens <- list(
 #'   final = list(
-#'     trigger  = rlang::exprs(sum(!is.na(enroll_time)) >= 20L),
-#'     analysis = function(df, timer) {
+#'     trigger  = count_trigger("enroll_time", ">=", 20L),
+#'     analysis = function(df, current_time) {
 #'       data.frame(mean_ctrl = mean(df$data[df$arm == "control"]))
 #'     }
 #'   )

R/trials.R

@@ -71,7 +71,10 @@ gen_population <- function(name, generator, sample_size = 1) {
 #' @param allocation `numeric` vector of arm allocation ratios.
 #' @param enrollment `function` that generates inter-enrollment times.
 #' @param dropout `function` that generates inter-dropout times.
-#' @param analysis_generators `list` (named) of analysis trigger specifications.
+#' @param analysis_generators `list` (named) of analysis specifications. Each
+#'   `$trigger` must be an `rxsim_trigger` object created by
+#'   `value_trigger()`, `count_trigger()`, `enroll_trigger()`, or
+#'   `calendar_trigger()`.
 #' @param population_generators `list` (named) of population generator functions.
 #' @param n `integer` Number of trials to create.
 #'
@@ -140,10 +143,18 @@ replicate_trial <- function(
 
   trials <- lapply(seq_len(n), function(i) {
     conditions <- lapply(names(analysis_generators), function(aname) {
+      trigger <- analysis_generators[[aname]]$trigger
+      if (!inherits(trigger, "rxsim_trigger")) {
+        stop(
+          "Trigger for '", aname, "' must be an `rxsim_trigger` object. ",
+          "Use `value_trigger()`, `count_trigger()`, `enroll_trigger()`, or `calendar_trigger()`."
+        )
+      }
       Condition$new(
-        where    = analysis_generators[[aname]]$trigger,
-        analysis = analysis_generators[[aname]]$analysis,
-        name     = aname
+        where         = trigger,
+        analysis      = analysis_generators[[aname]]$analysis,
+        analysis_args = analysis_generators[[aname]]$analysis_args,
+        name          = aname
       )
     })
     Trial$new(