Merge pull request #2022 from rstudio/joe/bugfix/timer-leak

Fix #2021: Memory leak with reactiveTimer and invalidateLater

NEWS.md

@@ -55,6 +55,8 @@ This is a significant release for Shiny, with a major new feature that was nearl
 
 * Fixed [#2000](https://github.com/rstudio/shiny/issues/2000): Implicit calls to xxxOutput not working inside modules. (Thanks, @GregorDeCillia! [#2010](https://github.com/rstudio/shiny/pull/2010))
 
+* Fixed [#2021](https://github.com/rstudio/shiny/issues/2021): Memory leak with reactiveTimer and invalidateLater ([#2022](https://github.com/rstudio/shiny/pull/2022))
+
 ### Library updates
 
 * Updated to ion.rangeSlider 2.2.0. ([#1955](https://github.com/rstudio/shiny/pull/1955))

R/reactives.R

@@ -1392,15 +1392,15 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
   # Need to make sure that session is resolved at creation, not when the
   # callback below is fired (see #1621).
   force(session)
-
+  
   dependents <- Map$new()
-  timerCallbacks$schedule(intervalMs, function() {
+  timerHandle <- scheduleTask(intervalMs, function() {
     # Quit if the session is closed
     if (!is.null(session) && session$isClosed()) {
       return(invisible())
     }
 
-    timerCallbacks$schedule(intervalMs, sys.function())
+    timerHandle <<- scheduleTask(intervalMs, sys.function())
     lapply(
       dependents$values(),
       function(dep.ctx) {
@@ -1408,6 +1408,11 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
         NULL
       })
   })
+
+  if (!is.null(session)) {
+    session$onEnded(timerHandle)
+  }
+
   return(function() {
     ctx <- .getReactiveEnvironment()$currentContext()
     if (!dependents$containsKey(ctx$id)) {
@@ -1477,7 +1482,7 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
 invalidateLater <- function(millis, session = getDefaultReactiveDomain()) {
   force(session)
   ctx <- .getReactiveEnvironment()$currentContext()
-  timerCallbacks$schedule(millis, function() {
+  timerHandle <- scheduleTask(millis, function() {
     if (is.null(session)) {
       ctx$invalidate()
       return(invisible())
@@ -1491,6 +1496,11 @@ invalidateLater <- function(millis, session = getDefaultReactiveDomain()) {
 
     invisible()
   })
+  
+  if (!is.null(session)) {
+    session$onEnded(timerHandle)
+  }
+  
   invisible()
 }
 

R/timer.R

@@ -42,6 +42,17 @@ TimerCallbacks <- R6Class(
 
       return(id)
     },
+    unschedule = function(id) {
+      toRemoveIndices <- .times$id %in% id
+      toRemoveIds <- .times[toRemoveIndices, "id", drop = TRUE]
+      if (length(toRemoveIds) > 0) {
+        .times <<- .times[!toRemoveIndices,]
+        for (toRemoveId in as.character(toRemoveIds)) {
+          .funcs$remove(toRemoveId)
+        }
+      }
+      return(id %in% toRemoveIds)
+    },
     timeToNextEvent = function() {
       if (dim(.times)[1] == 0)
         return(Inf)
@@ -79,13 +90,9 @@ timerCallbacks <- TimerCallbacks$new()
 
 scheduleTask <- function(millis, callback) {
   cancelled <- FALSE
-  timerCallbacks$schedule(millis, function() {
-    if (!cancelled)
-      callback()
-  })
+  id <- timerCallbacks$schedule(millis, callback)
 
   function() {
-    cancelled <<- TRUE
-    callback <<- NULL # to allow for callback to be gc'ed
+    invisible(timerCallbacks$unschedule(id))
   }
 }

tests/testthat/test-timer.R

@@ -23,3 +23,26 @@ test_that("Scheduling works", {
   expect_false(timerCallbacks$executeElapsed())
   expect_equal(0, nrow(timerCallbacks$takeElapsed()))
 })
+
+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)
+})
+
+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))
+})