From c556cf1e69889825d4a279baf3b41f606e48aa3c Mon Sep 17 00:00:00 2001
From: Joe Cheng <joe@rstudio.com>
Date: Wed, 18 Apr 2018 12:30:14 -0700
Subject: [PATCH 1/3] Fix #2021: Memory leak with reactiveTimer and
 invalidateLater

---
 R/reactives.R               | 18 ++++++++++++++----
 R/timer.R                   | 19 +++++++++++++------
 tests/testthat/test-timer.R | 14 ++++++++++++++
 3 files changed, 41 insertions(+), 10 deletions(-)

diff --git a/R/reactives.R b/R/reactives.R
index 684aaec8b3..369b9416f7 100644
--- a/R/reactives.R
+++ b/R/reactives.R
@@ -1390,15 +1390,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) {
@@ -1406,6 +1406,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)) {
@@ -1475,7 +1480,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())
@@ -1489,6 +1494,11 @@ invalidateLater <- function(millis, session = getDefaultReactiveDomain()) {
 
     invisible()
   })
+  
+  if (!is.null(session)) {
+    session$onEnded(timerHandle)
+  }
+  
   invisible()
 }
 
diff --git a/R/timer.R b/R/timer.R
index 51f237bd37..e3d1f4b9ef 100644
--- a/R/timer.R
+++ b/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))
   }
 }
diff --git a/tests/testthat/test-timer.R b/tests/testthat/test-timer.R
index f4aef724b7..d33dcc5005 100644
--- a/tests/testthat/test-timer.R
+++ b/tests/testthat/test-timer.R
@@ -23,3 +23,17 @@ 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)
+})

From 3c7b1e7d2110cae7cde1549d309bed7df3bcdeaf Mon Sep 17 00:00:00 2001
From: Joe Cheng <joe@rstudio.com>
Date: Wed, 18 Apr 2018 12:32:16 -0700
Subject: [PATCH 2/3] Update NEWS

---
 NEWS.md | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/NEWS.md b/NEWS.md
index 17b0bd26f3..7f1bb62c9e 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -51,6 +51,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))

From 31c4e0fdfe8c12ed6acc8fda912bb433a4c82c4e Mon Sep 17 00:00:00 2001
From: Joe Cheng <joe@rstudio.com>
Date: Thu, 19 Apr 2018 12:51:44 -0700
Subject: [PATCH 3/3] Add test to demonstrate vectorized unscheduling

---
 tests/testthat/test-timer.R | 9 +++++++++
 1 file changed, 9 insertions(+)

diff --git a/tests/testthat/test-timer.R b/tests/testthat/test-timer.R
index d33dcc5005..bb55a2a476 100644
--- a/tests/testthat/test-timer.R
+++ b/tests/testthat/test-timer.R
@@ -37,3 +37,12 @@ test_that("Unscheduling works", {
   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))
+})