Revert "PR feedback. Broke tests because of dependency on session, though, so might revert."

This reverts commit a003c4d.

Author: trestletech

R/reactives.R

@@ -1513,14 +1513,16 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
   # reactId <- nextGlobalReactId()
   # rLog$define(reactId, paste0("timer(", intervalMs, ")"))
 
+  scheduler <- defineScheduler(session)
+
   dependents <- Map$new()
-  timerHandle <- session$.scheduleTask(intervalMs, function() {
+  timerHandle <- scheduler(intervalMs, function() {
     # Quit if the session is closed
     if (!is.null(session) && session$isClosed()) {
       return(invisible())
     }
 
-    timerHandle <<- session$.scheduleTask(intervalMs, sys.function())
+    timerHandle <<- scheduler(intervalMs, sys.function())
 
     doInvalidate <- function() {
       lapply(
@@ -1620,7 +1622,9 @@ invalidateLater <- function(millis, session = getDefaultReactiveDomain()) {
 
   clear_on_ended_callback <- function() {}
 
-  timerHandle <- session$.scheduleTask(millis, function() {
+  scheduler <- defineScheduler(session)
+
+  timerHandle <- scheduler(millis, function() {
     if (is.null(session)) {
       ctx$invalidate()
       return(invisible())
@@ -2371,7 +2375,7 @@ debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
     }
 
     # The value (or possibly millis) changed. Start or reset the timer.
-    v$when <- domain$.now() + millis()/1000
+    v$when <- getTime(domain) + millis()/1000
   }, label = "debounce tracker", domain = domain, priority = priority)
 
   # This observer is the timer. It rests until v$when elapses, then touches
@@ -2380,7 +2384,7 @@ debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
     if (is.null(v$when))
       return()
 
-    now <- domain$.now()
+    now <- getTime(domain)
     if (now >= v$when) {
       # Mod by 999999999 to get predictable overflow behavior
       v$trigger <- isolate(v$trigger %OR% 0) %% 999999999 + 1
@@ -2431,12 +2435,12 @@ throttle <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
     if (is.null(v$lastTriggeredAt)) {
       0
     } else {
-      max(0, (v$lastTriggeredAt + millis()/1000) - domain$.now()) * 1000
+      max(0, (v$lastTriggeredAt + millis()/1000) - getTime(domain)) * 1000
     }
   }
 
   trigger <- function() {
-    v$lastTriggeredAt <- domain$.now()
+    v$lastTriggeredAt <- getTime(domain)
     # Mod by 999999999 to get predictable overflow behavior
     v$trigger <- isolate(v$trigger) %% 999999999 + 1
     v$pending <- FALSE

R/shiny.R

@@ -723,12 +723,9 @@ ShinySession <- R6Class(
     requestFlush = function() {
       appsNeedingFlush$set(self$token, self)
     },
-    .scheduleTask = function(millis, callback) {
+    scheduleTask = function(millis, callback) {
       scheduleTask(millis, callback)
     },
-    .now = function() {
-      getNow()
-    },
     rootScope = function() {
       self
     },

R/timer.R

@@ -119,3 +119,25 @@ scheduleTask <- function(millis, callback) {
     invisible(timerCallbacks$unschedule(id))
   }
 }
+
+#' Get a scheduler function for scheduling tasks. Give priority to the
+#' session scheduler, but if it doesn't exist, use the global one.
+#' @noRd
+defineScheduler <- function(session){
+  if (!is.null(session) && !is.null(session$scheduleTask)){
+    return(session$scheduleTask)
+  }
+  scheduleTask
+}
+
+
+#' Get the current time a la `Sys.time()`. Prefer to get it via the
+#' `session$now()` function, but if that's not available, just return the
+#' current system time.
+#' @noRd
+getTime <- function(session){
+  if (!is.null(session) && !is.null(session$now)){
+    return(session$now())
+  }
+  Sys.time()
+}

tests/testthat/test-app.R

@@ -99,7 +99,7 @@ test_that("With ui/server.R, global.R is loaded before R/ helpers and into the r
 })
 
 
-test_that("Loading supporting R files is opt-out", {
+test_that("Loading supporting R fils is opt-out", {
   calls <- list()
   sourceStub <- function(...){
     calls[[length(calls)+1]] <<- list(...)
@@ -128,7 +128,7 @@ test_that("Loading supporting R files is opt-out", {
 })
 
 
-test_that("Disabling supporting R files works", {
+test_that("Disabling supporting R fils works", {
   calls <- list()
   sourceStub <- function(...){
     calls[[length(calls)+1]] <<- list(...)

tests/testthat/test-timer.R

@@ -47,6 +47,12 @@ test_that("Vectorized unscheduling works", {
   expect_identical(timerCallbacks$unschedule(c(key1, key2, key3)), c(TRUE, FALSE, TRUE))
 })
 
+test_that("defineScheduler works", {
+  expect_identical(defineScheduler(NULL), scheduleTask)
+  expect_identical(defineScheduler(list()), scheduleTask)
+  expect_identical(defineScheduler(list(scheduleTask=123)), 123)
+})
+
 test_that("mockableTimer works", {
   mt <- MockableTimerCallbacks$new()
   called <- FALSE
@@ -64,3 +70,18 @@ test_that("mockableTimer works", {
   expect_true(mt$executeElapsed())
   expect_true(called)
 })
+
+test_that("getTime works", {
+  start <- Sys.time()
+  t1 <- getTime(NULL)
+  t2 <- getTime(list())
+  t3 <- getTime(list(now = function(){456}))
+  end <- Sys.time()
+
+  expect_gte(t1, start)
+  expect_gte(t2, start)
+  expect_lte(t1, end)
+  expect_lte(t2, end)
+
+  expect_equal(t3, 456)
+})