Best-effort task scheduling through the session

Currently a no-op change, as the session just passes through to the global scheduleTask implementation. But this allows us to mock the method for testing.

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 <- scheduleTask(intervalMs, function() {
+  timerHandle <- scheduler(intervalMs, function() {
     # Quit if the session is closed
     if (!is.null(session) && session$isClosed()) {
       return(invisible())
     }
 
-    timerHandle <<- scheduleTask(intervalMs, sys.function())
+    timerHandle <<- scheduler(intervalMs, sys.function())
 
     doInvalidate <- function() {
       lapply(
@@ -1613,15 +1615,16 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
 #' }
 #' @export
 invalidateLater <- function(millis, session = getDefaultReactiveDomain()) {
-
   force(session)
 
   ctx <- getCurrentContext()
   rLog$invalidateLater(ctx$.reactId, ctx$id, millis, session)
 
   clear_on_ended_callback <- function() {}
 
-  timerHandle <- scheduleTask(millis, function() {
+  scheduler <- defineScheduler(session)
+
+  timerHandle <- scheduler(millis, function() {
     if (is.null(session)) {
       ctx$invalidate()
       return(invisible())

R/shiny.R

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

R/timer.R

@@ -96,3 +96,15 @@ 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)){
+    if (!is.null(session$scheduleTask)){
+      return(session$scheduleTask)
+    }
+  }
+  scheduleTask
+}

tests/testthat/test-reactivity.r

@@ -1366,3 +1366,59 @@ test_that("reactivePoll doesn't leak observer (#1548)", {
 
   expect_equal(i, 3L)
 })
+
+test_that("reactivePoll prefers session$scheduleTask", {
+  called <- 0
+  session <- list(reactlog = function(...){}, onEnded = function(...){}, scheduleTask = function(millis, cb){
+    expect_equal(millis, 50)
+    called <<- called + 1
+  })
+
+  count <- reactivePoll(50, session, function(){}, function(){})
+  observe({
+    count()
+  })
+
+  for (i in 1:4) {
+    Sys.sleep(0.05)
+    shiny:::flushReact()
+  }
+  expect_gt(called, 0)
+})
+
+test_that("invalidateLater prefers session$scheduleTask", {
+  called <- 0
+  session <- list(reactlog = function(...){}, onEnded = function(...){}, scheduleTask = function(millis, cb){
+    expect_equal(millis, 10)
+    called <<- called + 1
+  })
+
+  observe({
+    invalidateLater(10, session)
+  })
+
+  for (i in 1:4) {
+    Sys.sleep(0.05)
+    shiny:::flushReact()
+  }
+  expect_gt(called, 0)
+})
+
+test_that("reactiveTimer prefers session$scheduleTask", {
+  called <- 0
+  session <- list(reactlog = function(...){}, onEnded = function(...){}, scheduleTask = function(millis, cb){
+    expect_equal(millis, 10)
+    called <<- called + 1
+  })
+
+  rt <- reactiveTimer(10, session)
+  observe({
+    rt()
+  })
+
+  for (i in 1:4) {
+    Sys.sleep(0.05)
+    shiny:::flushReact()
+  }
+  expect_gt(called, 0)
+})

tests/testthat/test-timer.R

@@ -27,13 +27,13 @@ test_that("Scheduling works", {
 test_that("Unscheduling works", {
   origTimes <- timerCallbacks$.times
   origFuncKeys <- timerCallbacks$.funcs$keys()
-  
+
   taskHandle <- scheduleTask(1000, function() {
     message("Whatever")
   })
   # Unregister
   taskHandle()
-  
+
   expect_identical(timerCallbacks$.times, origTimes)
   expect_identical(timerCallbacks$.funcs$keys(), origFuncKeys)
 })
@@ -42,7 +42,13 @@ test_that("Vectorized unscheduling works", {
   key1 <- timerCallbacks$schedule(1000, function() {})
   key2 <- timerCallbacks$schedule(1000, function() {})
   key3 <- timerCallbacks$schedule(1000, function() {})
-  
+
   expect_identical(timerCallbacks$unschedule(key2), TRUE)
   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)
+})