github/shiny
1
1
Fork 0
mirror of https://github.com/rstudio/shiny.git synced 2026-01-10 15:38:19 -05:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #2484 from rstudio/weakref

Browse Source 
Use weakrefs for reactive value to reactive expression dependencies
This commit is contained in:
Winston Chang
2019-07-03 20:49:33 -05:00
committed by GitHub
parent da18390f3e b392bf8298
commit 25ccc8a77a
6 changed files with 199 additions and 49 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
DESCRIPTION
View File

@@ -77,7 +77,7 @@ Imports:
promises (>= 1.0.1),
tools,
crayon,
rlang,
rlang (>= 0.4.0),
fastmap (>= 0.0.0.9001)
Suggests:
datasets,
@@ -89,9 +89,9 @@ Suggests:
ggplot2,
reactlog (>= 1.0.0),
magrittr
URL: http://shiny.rstudio.com
Remotes:
r-lib/fastmap
URL: http://shiny.rstudio.com
BugReports: https://github.com/rstudio/shiny/issues
Collate:
'app.R'

8
R/react.R
View File

@@ -31,11 +31,13 @@ Context <- R6Class(
.flushCallbacks = list(),
.domain = NULL,
.pid = NULL,
.weak = NULL,
initialize = function(
domain, label='', type='other', prevId='',
reactId = rLog$noReactId,
id = .getReactiveEnvironment()$nextId() # For dummy context
id = .getReactiveEnvironment()$nextId(), # For dummy context
weak = FALSE
) {
id <<- id
.label <<- label
@@ -43,6 +45,7 @@ Context <- R6Class(
.pid <<- processId()
.reactId <<- reactId
.reactType <<- type
.weak <<- weak
rLog$createContext(id, label, type, prevId, domain)
},
run = function(func) {
@@ -108,6 +111,9 @@ Context <- R6Class(
lapply(.flushCallbacks, function(flushCallback) {
flushCallback()
})
},
isWeak = function() {
.weak
}
)
)

76
R/reactives.R
View File

@@ -24,7 +24,11 @@ Dependents <- R6Class(
rLog$dependsOn(ctx$.reactId, .reactId, ctx$id, ctx$.domain)
}
.dependents$set(ctx$id, ctx)
if (ctx$isWeak()) {
.dependents$set(ctx$id, rlang::new_weakref(ctx))
} else {
.dependents$set(ctx$id, ctx)
}
ctx$onInvalidate(function() {
rLog$dependsOnRemove(ctx$.reactId, .reactId, ctx$id, ctx$.domain)
@@ -46,6 +50,13 @@ Dependents <- R6Class(
lapply(
.dependents$values(sort = TRUE),
function(ctx) {
if (rlang::is_weakref(ctx)) {
ctx <- rlang::wref_key(ctx)
if (is.null(ctx)) {
# Can get here if weakref target was GC'd
return()
}
}
ctx$invalidate()
NULL
}
@@ -294,6 +305,7 @@ ReactiveValues <- R6Class(
.label = character(0),
.values = 'Map',
.metadata = 'Map',
# A map of Dependents objects, one for each key
.dependents = 'Map',
# Dependents for the list of all names, including hidden
.namesDeps = 'Dependents',
@@ -315,7 +327,7 @@ ReactiveValues <- R6Class(
.values <<- Map$new()
.metadata <<- Map$new()
.dependents <<- Map$new()
.hasRetrieved <<- list(names = FALSE, asListAll = FALSE, asList = FALSE, keys = list())
.hasRetrieved <<- list(names = FALSE, asListAll = FALSE, asList = FALSE)
.namesDeps <<- Dependents$new(reactId = rLog$namesIdStr(.reactId))
.allValuesDeps <<- Dependents$new(reactId = rLog$asListAllIdStr(.reactId))
.valuesDeps <<- Dependents$new(reactId = rLog$asListIdStr(.reactId))
@@ -326,24 +338,18 @@ ReactiveValues <- R6Class(
# get value right away to use for logging
keyValue <- .values$get(key)
if (!.dependents$containsKey(key)) {
# If we got here, this is the first time someone has tried to access
# this key.
rLog$defineKey(.reactId, keyValue, key, .label, getCurrentContext()$.domain)
reactKeyId <- rLog$keyIdStr(.reactId, key)
.dependents$set(key, Dependents$new(reactKeyId))
}
# Register the "downstream" reactive which is accessing this value, so
# that we know to invalidate them when this value changes.
ctx <- getCurrentContext()
dep.key <- paste(key, ':', ctx$id, sep='')
if (!.dependents$containsKey(dep.key)) {
reactKeyId <- rLog$keyIdStr(.reactId, key)
if (!isTRUE(.hasRetrieved$keys[[key]])) {
rLog$defineKey(.reactId, keyValue, key, .label, ctx$.domain)
.hasRetrieved$keys[[key]] <<- TRUE
}
rLog$dependsOnKey(ctx$.reactId, .reactId, key, ctx$id, ctx$.domain)
.dependents$set(dep.key, ctx)
ctx$onInvalidate(function() {
rLog$dependsOnKeyRemove(ctx$.reactId, .reactId, key, ctx$id, ctx$.domain)
.dependents$remove(dep.key)
})
}
.dependents$get(key)$register()
if (isFrozen(key))
reactiveStop()
@@ -393,14 +399,9 @@ ReactiveValues <- R6Class(
.values$set(key, value)
# key has been depended upon
if (isTRUE(.hasRetrieved$keys[[key]])) {
if (.dependents$containsKey(key)) {
rLog$valueChangeKey(.reactId, key, value, domain)
keyReactId <- rLog$keyIdStr(.reactId, key)
rLog$invalidateStart(keyReactId, NULL, "other", domain)
on.exit(
rLog$invalidateEnd(keyReactId, NULL, "other", domain),
add = TRUE
)
.dependents$get(key)$invalidate()
}
# only invalidate if there are deps
@@ -424,17 +425,6 @@ ReactiveValues <- R6Class(
}
}
dep.keys <- .dependents$keys()
dep.keys <- grep(
paste('^\\Q', key, ':', '\\E', '\\d+$', sep=''), dep.keys, value = TRUE
)
lapply(
.dependents$mget(dep.keys),
function(ctx) {
ctx$invalidate()
NULL
}
)
invisible()
},
@@ -803,6 +793,7 @@ Observable <- R6Class(
.visible = logical(0),
.execCount = integer(0),
.mostRecentCtxId = character(0),
.ctx = 'Context',
initialize = function(func, label = deparse(substitute(func)),
domain = getDefaultReactiveDomain(),
@@ -832,6 +823,7 @@ Observable <- R6Class(
.running <<- FALSE
.execCount <<- 0L
.mostRecentCtxId <<- ""
.ctx <<- NULL
rLog$define(.reactId, .value, .label, type = "observable", .domain)
},
getValue = function() {
@@ -858,12 +850,22 @@ Observable <- R6Class(
},
.updateValue = function() {
ctx <- Context$new(.domain, .label, type = 'observable',
prevId = .mostRecentCtxId, reactId = .reactId)
prevId = .mostRecentCtxId, reactId = .reactId,
weak = TRUE)
.mostRecentCtxId <<- ctx$id
# A Dependency object will have a weak reference to the context, which
# doesn't prevent it from being GC'd. However, as long as this
# Observable object is reachable and not invalidated, we need to make
# sure the context isn't GC'd. To do that we need a strong reference to
# the context.
.ctx <<- ctx
ctx$onInvalidate(function() {
.invalidated <<- TRUE
.value <<- NULL # Value can be GC'd, it won't be read once invalidated
.dependents$invalidate(log = FALSE)
.ctx <<- NULL # No longer need to prevent the context from being GC'd.
})
.execCount <<- .execCount + 1L

6
tests/testthat/helper.R
View File

@@ -48,3 +48,9 @@ contents_identical <- function(a, b) {
TRUE
}
# Don't print out stack traces (which go to stderr)
suppress_stacktrace <- function(expr) {
capture.output(force(expr), type = "message")
}

14
tests/testthat/test-bookmarking.R
View File

@@ -32,16 +32,16 @@ test_that("Inputs and values in query string", {
expect_identical(as.list(vals$values), list())
# Multiple instances of _inputs_ or _values_
expect_warning(suppressMessages(RestoreContext$new("?_inputs_&a=1&_inputs_")))
expect_warning(suppressMessages(RestoreContext$new("?_inputs_&a=1&_inputs_&")))
expect_warning(suppressMessages(RestoreContext$new("?_inputs_&a=1&_inputs_&b=2")))
expect_warning(suppressMessages(RestoreContext$new("?_inputs_&a=1&_values_&b=2&_inputs_&")))
expect_warning(suppressMessages(RestoreContext$new("?_values_&a=1&_values_")))
expect_warning(suppressMessages(RestoreContext$new("?_inputs_&a=1&_values_&_values&b=2")))
suppress_stacktrace(expect_warning(RestoreContext$new("?_inputs_&a=1&_inputs_")))
suppress_stacktrace(expect_warning(RestoreContext$new("?_inputs_&a=1&_inputs_&")))
suppress_stacktrace(expect_warning(RestoreContext$new("?_inputs_&a=1&_inputs_&b=2")))
suppress_stacktrace(expect_warning(RestoreContext$new("?_inputs_&a=1&_values_&b=2&_inputs_&")))
suppress_stacktrace(expect_warning(RestoreContext$new("?_values_&a=1&_values_")))
suppress_stacktrace(expect_warning(RestoreContext$new("?_inputs_&a=1&_values_&_values&b=2")))
# If there's an error in the conversion from query string, should have
# blank values.
expect_warning(suppressMessages(rc <- RestoreContext$new("?_inputs_&a=[x&b=1")))
suppress_stacktrace(expect_warning(rc <- RestoreContext$new("?_inputs_&a=[x&b=1")))
expect_identical(rc$input$asList(), list())
expect_identical(as.list(rc$values), list())
expect_identical(rc$dir, NULL)

140
tests/testthat/test-reactivity.r
View File

@@ -1029,8 +1029,10 @@ test_that("Flush completes even when errors occur", {
# Trigger an error
vals$x <- 0
# Errors in reactive are translated to warnings in observers by default
expect_warning(flushReact())
suppress_stacktrace(
# Errors in reactive are translated to warnings in observers by default
expect_warning(flushReact())
)
# Both observers should run up until the reactive that errors
expect_true(all(c(n11, n12, n21, n22) == c(2,1,2,1)))
@@ -1184,3 +1186,137 @@ test_that("reactive domain works across async handlers", {
testthat::expect_true(hasReactiveDomain)
})
# For #2441, #2423
test_that("Unreachable reactives are GC'd", {
v <- reactiveVal(1)
r <- reactive({
v()
12345
})
o <- observe({
r()
})
# Finalizer on the reactive's underlying Observable object
r_finalized <- FALSE
reg.finalizer(attr(r, "observable"), function(e) {
r_finalized <<- TRUE
})
# Finalizer on the Observer
o_finalized <- FALSE
reg.finalizer(o, function(e) {
o_finalized <<- TRUE
})
flushReact()
gc()
expect_false(r_finalized)
rm(r) # Remove the only (strong) reference to r
gc()
expect_true(r_finalized)
expect_false(o_finalized)
rm(o) # Remove the only reference to o
gc()
expect_true(o_finalized)
rm(v)
gc()
# Same, with reactiveValues instead of reactiveVal
v <- reactiveValues(x = 1)
r <- reactive({
v$x
12345
})
o <- observe({
r()
})
# Finalizer on the reactive's underlying Observable object
r_finalized <- FALSE
reg.finalizer(attr(r, "observable"), function(e) {
r_finalized <<- TRUE
})
# Finalizer on the Observer
o_finalized <- FALSE
reg.finalizer(o, function(e) {
o_finalized <<- TRUE
})
flushReact()
gc()
expect_false(r_finalized)
rm(r) # Remove the only (strong) reference to r
gc()
expect_true(r_finalized)
expect_false(o_finalized)
rm(o) # Remove the only reference to o
gc()
expect_true(o_finalized)
})
test_that("Reactive contexts are not GC'd too early", {
# When a ReactiveVal or ReactiveValue has an dependency arrow pointing to a
# reactive expression (Observable object), it's implemented by having a weak
# reference to a reactive context. We need to make sure that the reactive
# context is not GC'd too early. This is done by having the Observable have a
# strong reference to the context.
# Check reactiveVal
v <- reactiveVal(1)
r <- reactive({
v()
})
o <- observe({
r()
gc()
})
# Finalizer on the reactive's underlying Observable object
r_finalized <- FALSE
reg.finalizer(attr(r, "observable"), function(e) {
r_finalized <<- TRUE
})
for (i in 1:3) {
v(isolate(v()) + 1)
flushReact()
}
expect_identical(execCount(r), 3L)
expect_false(r_finalized)
o$destroy()
rm(v, r, o)
gc()
expect_true(r_finalized)
# Same, but with reactiveValues
v <- reactiveValues(x=1)
r <- reactive({
v$x
})
o <- observe({
r()
gc()
})
# Finalizer on the reactive's underlying Observable object
r_finalized <- FALSE
reg.finalizer(attr(r, "observable"), function(e) {
r_finalized <<- TRUE
})
for (i in 1:3) {
v$x <- (isolate(v$x) + 1)
flushReact()
}
expect_identical(execCount(r), 3L)
expect_false(r_finalized)
})