perf: replace stats::stepfun with stepfun2 in expected_event

R/expected_event.R

@@ -165,22 +165,13 @@ expected_event <- function(
 
   # Create 3 step functions (sf) ----
   # Step function to define enrollment rates over time
-  sf_enroll_rate <- stats::stepfun(c(0, cumsum(enroll_rate$duration)),
-    c(0, enroll_rate$rate, 0),
-    right = FALSE
-  )
+  sf_enroll_rate <- stepfun2(c(0, cumsum(enroll_rate$duration)), c(0, enroll_rate$rate, 0))
   # step function to define failure rates over time
   start_fail <- c(0, cumsum(fail_rate$duration))
   fail_rate_last <- nrow(fail_rate)
-  sf_fail_rate <- stats::stepfun(start_fail,
-    c(0, fail_rate$fail_rate, fail_rate$fail_rate[fail_rate_last]),
-    right = FALSE
-  )
+  sf_fail_rate <- stepfun2(start_fail, c(0, fail_rate$fail_rate, fail_rate$fail_rate[fail_rate_last]))
   # step function to define dropout rates over time
-  sf_dropout_rate <- stats::stepfun(start_fail,
-    c(0, fail_rate$dropout_rate, fail_rate$dropout_rate[fail_rate_last]),
-    right = FALSE
-  )
+  sf_dropout_rate <- stepfun2(start_fail, c(0, fail_rate$dropout_rate, fail_rate$dropout_rate[fail_rate_last]))
 
   # combine sub-intervals from enroll + failure + dropout #
   # impute the NA by step functions
@@ -223,7 +214,7 @@ expected_event <- function(
   if (simple) {
     ans <- sum(df$nbar)
   } else {
-    sf_start_fail <- stats::stepfun(start_fail, c(0, start_fail), right = FALSE)
+    sf_start_fail <- stepfun2(start_fail, c(0, start_fail))
     ans <- data.frame(
       fail_rate = df$fail_rate_var,
       event = df$nbar,

R/utils.R

@@ -48,12 +48,21 @@ is_wholenumber <- function (x, tol = .Machine$double.eps^0.5)  {
   abs(x - round(x)) < tol
 }
 
-# a faster version of stats::stepfun() since we don't need to consider interpolation
+# a faster version of stats::stepfun() since we don't need to consider interpolation;
+# right = FALSE means left-closed intervals [x0[i], x0[i+1]), i.e., the function jumps
+# at x0[i] (right-continuous); right = TRUE means right-closed (x0[i], x0[i+1]]
 stepfun2 <- function(x0, y, right = FALSE) {
   x0; y  # avoid lazy evaluation: evaluate right now
-  function(x) {
-    i <- findInterval(x, x0, left.open = right)
-    y[i + 1]
+  # for small breakpoint vectors, a for-loop of vectorized comparisons (x >= b)
+  # is faster than findInterval(), which has dispatch overhead and uses binary
+  # search (overkill for 3-5 breakpoints)
+  if (length(x0) <= 10L) {
+    if (right)
+      function(x) { i <- 1L; for (b in x0) i <- i + (x > b); y[i] }
+    else
+      function(x) { i <- 1L; for (b in x0) i <- i + (x >= b); y[i] }
+  } else {
+    function(x) y[findInterval(x, x0, left.open = right) + 1L]
   }
 }