Skip to content

Commit

Permalink
Merge pull request #2022 from rstudio/joe/bugfix/timer-leak
Browse files Browse the repository at this point in the history
Fix #2021: Memory leak with reactiveTimer and invalidateLater
  • Loading branch information
jcheng5 committed Apr 19, 2018
2 parents 66f970e + 31c4e0f commit ffe883a
Show file tree
Hide file tree
Showing 4 changed files with 52 additions and 10 deletions.
2 changes: 2 additions & 0 deletions NEWS.md
Expand Up @@ -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))
Expand Down
18 changes: 14 additions & 4 deletions R/reactives.R
Expand Up @@ -1392,22 +1392,27 @@ 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) {
dep.ctx$invalidate()
NULL
})
})

if (!is.null(session)) {
session$onEnded(timerHandle)
}

return(function() {
ctx <- .getReactiveEnvironment()$currentContext()
if (!dependents$containsKey(ctx$id)) {
Expand Down Expand Up @@ -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())
Expand All @@ -1491,6 +1496,11 @@ invalidateLater <- function(millis, session = getDefaultReactiveDomain()) {

invisible()
})

if (!is.null(session)) {
session$onEnded(timerHandle)
}

invisible()
}

Expand Down
19 changes: 13 additions & 6 deletions R/timer.R
Expand Up @@ -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)
Expand Down Expand Up @@ -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))
}
}
23 changes: 23 additions & 0 deletions tests/testthat/test-timer.R
Expand Up @@ -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))
})

0 comments on commit ffe883a

Please sign in to comment.