diff --git a/DESCRIPTION b/DESCRIPTION index 22f439f0a..0377e9c17 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -77,17 +77,20 @@ Imports: promises (>= 1.0.1), tools, crayon, - rlang + rlang, + fastmap Suggests: datasets, Cairo (>= 1.5-5), - testthat, + testthat (>= 2.1.1), knitr (>= 1.6), markdown, rmarkdown, ggplot2, reactlog (>= 1.0.0), magrittr +Remotes: + r-lib/fastmap URL: http://shiny.rstudio.com BugReports: https://github.com/rstudio/shiny/issues Collate: diff --git a/NAMESPACE b/NAMESPACE index 174f2dce4..ce7de6ef8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -301,5 +301,6 @@ import(httpuv) import(methods) import(mime) import(xtable) +importFrom(fastmap,fastmap) importFrom(grDevices,dev.cur) importFrom(grDevices,dev.set) diff --git a/R/cache-memory.R b/R/cache-memory.R index c7f1b5036..0d6c22426 100644 --- a/R/cache-memory.R +++ b/R/cache-memory.R @@ -179,7 +179,7 @@ MemoryCache <- R6Class("MemoryCache", if (!is.numeric(max_size)) stop("max_size must be a number. Use `Inf` for no limit.") if (!is.numeric(max_age)) stop("max_age must be a number. Use `Inf` for no limit.") if (!is.numeric(max_n)) stop("max_n must be a number. Use `Inf` for no limit.") - private$cache <- new.env(parent = emptyenv()) + private$cache <- fastmap() private$max_size <- max_size private$max_age <- max_age private$max_n <- max_n @@ -208,7 +208,7 @@ MemoryCache <- R6Class("MemoryCache", } private$log(paste0('get: key "', key, '" found')) - value <- private$cache[[key]]$value + value <- private$cache$get(key)$value value }, @@ -226,37 +226,36 @@ MemoryCache <- R6Class("MemoryCache", size <- NULL } - private$cache[[key]] <- list( + private$cache$set(key, list( key = key, value = value, size = size, mtime = time, atime = time - ) + )) self$prune() invisible(self) }, exists = function(key) { validate_key(key) - # Faster than `exists(key, envir = private$cache, inherits = FALSE) - !is.null(private$cache[[key]]) + private$cache$has(key) }, keys = function() { - ls(private$cache, sorted = FALSE) # Faster with sorted=FALSE + private$cache$keys() }, remove = function(key) { private$log(paste0('remove: key "', key, '"')) validate_key(key) - rm(list = key, envir = private$cache) + private$cache$remove(key) invisible(self) }, reset = function() { private$log(paste0('reset')) - rm(list = self$keys(), envir = private$cache) + private$cache$reset() invisible(self) }, @@ -271,7 +270,7 @@ MemoryCache <- R6Class("MemoryCache", rm_idx <- timediff > private$max_age if (any(rm_idx)) { private$log(paste0("prune max_age: Removing ", paste(info$key[rm_idx], collapse = ", "))) - rm(list = info$key[rm_idx], envir = private$cache) + private$cache$remove(info$key[rm_idx]) info <- info[!rm_idx, ] } } @@ -298,7 +297,7 @@ MemoryCache <- R6Class("MemoryCache", ensure_info_is_sorted() rm_idx <- seq_len(nrow(info)) > private$max_n private$log(paste0("prune max_n: Removing ", paste(info$key[rm_idx], collapse = ", "))) - rm(list = info$key[rm_idx], envir = private$cache) + private$cache$remove(info$key[rm_idx]) info <- info[!rm_idx, ] } @@ -308,7 +307,7 @@ MemoryCache <- R6Class("MemoryCache", cum_size <- cumsum(info$size) rm_idx <- cum_size > private$max_size private$log(paste0("prune max_size: Removing ", paste(info$key[rm_idx], collapse = ", "))) - rm(list = info$key[rm_idx], envir = private$cache) + private$cache$remove(info$key[rm_idx]) info <- info[!rm_idx, ] } @@ -335,23 +334,23 @@ MemoryCache <- R6Class("MemoryCache", maybe_prune_single = function(key) { if (!is.finite(private$max_age)) return() - obj <- private$cache[[key]] + obj <- private$cache$get(key) if (is.null(obj)) return() timediff <- as.numeric(Sys.time()) - obj$mtime if (timediff > private$max_age) { private$log(paste0("pruning single object exceeding max_age: Removing ", key)) - rm(list = key, envir = private$cache) + private$cache$remove(key) } }, object_info = function() { - keys <- ls(private$cache, sorted = FALSE) + keys <- private$cache$keys() data.frame( key = keys, - size = vapply(keys, function(key) private$cache[[key]]$size, 0), - mtime = vapply(keys, function(key) private$cache[[key]]$mtime, 0), - atime = vapply(keys, function(key) private$cache[[key]]$atime, 0), + size = vapply(keys, function(key) private$cache$get(key)$size, 0), + mtime = vapply(keys, function(key) private$cache$get(key)$mtime, 0), + atime = vapply(keys, function(key) private$cache$get(key)$atime, 0), stringsAsFactors = FALSE ) }, diff --git a/R/map.R b/R/map.R index 91790b8b0..c435b70ff 100644 --- a/R/map.R +++ b/R/map.R @@ -9,63 +9,58 @@ # Remove of unknown key does nothing # Setting a key twice always results in last-one-wins # /TESTS + +# Note that Map objects can't be saved in one R session and restored in +# another, because they are based on fastmap, which uses an external pointer, +# and external pointers can't be saved and restored in another session. +#' @importFrom fastmap fastmap Map <- R6Class( 'Map', portable = FALSE, public = list( initialize = function() { - private$env <- new.env(parent=emptyenv()) + private$map <<- fastmap() }, get = function(key) { - env[[key]] + map$get(key) }, set = function(key, value) { - env[[key]] <- value + map$set(key, value) value }, mget = function(keys) { - base::mget(keys, env) + map$mget(keys) }, mset = function(...) { - args <- list(...) - if (length(args) == 0) - return() - - arg_names <- names(args) - if (is.null(arg_names) || any(!nzchar(arg_names))) - stop("All elements must be named") - - list2env(args, envir = env) + map$mset(...) }, remove = function(key) { - if (!self$containsKey(key)) + if (!map$has(key)) return(NULL) - result <- env[[key]] - rm(list=key, envir=env, inherits=FALSE) + result <- map$get(key) + map$remove(key) result }, containsKey = function(key) { - exists(key, envir=env, inherits=FALSE) + map$has(key) }, keys = function() { - # Sadly, this is much faster than ls(), because it doesn't sort the keys. - names(as.list(env, all.names=TRUE)) + map$keys() }, values = function() { - as.list(env, all.names=TRUE) + map$as_list() }, clear = function() { - private$env <- new.env(parent=emptyenv()) - invisible(NULL) + map$reset() }, size = function() { - length(env) + map$size() } ), private = list( - env = 'environment' + map = NULL ) ) diff --git a/R/reactives.R b/R/reactives.R index c1e2e1872..ff9c11fdd 100644 --- a/R/reactives.R +++ b/R/reactives.R @@ -292,9 +292,9 @@ ReactiveValues <- R6Class( # For debug purposes .reactId = character(0), .label = character(0), - .values = 'environment', - .metadata = 'environment', - .dependents = 'environment', + .values = 'Map', + .metadata = 'Map', + .dependents = 'Map', # Dependents for the list of all names, including hidden .namesDeps = 'Dependents', # Dependents for all values, including hidden @@ -312,9 +312,9 @@ ReactiveValues <- R6Class( ) { .reactId <<- nextGlobalReactId() .label <<- label - .values <<- new.env(parent=emptyenv()) - .metadata <<- new.env(parent=emptyenv()) - .dependents <<- new.env(parent=emptyenv()) + .values <<- Map$new() + .metadata <<- Map$new() + .dependents <<- Map$new() .hasRetrieved <<- list(names = FALSE, asListAll = FALSE, asList = FALSE, keys = list()) .namesDeps <<- Dependents$new(reactId = rLog$namesIdStr(.reactId)) .allValuesDeps <<- Dependents$new(reactId = rLog$asListAllIdStr(.reactId)) @@ -324,16 +324,13 @@ ReactiveValues <- R6Class( get = function(key) { # get value right away to use for logging - if (!exists(key, envir=.values, inherits=FALSE)) - keyValue <- NULL - else - keyValue <- .values[[key]] + keyValue <- .values$get(key) # 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 (!exists(dep.key, envir=.dependents, inherits=FALSE)) { + if (!.dependents$containsKey(dep.key)) { reactKeyId <- rLog$keyIdStr(.reactId, key) if (!isTRUE(.hasRetrieved$keys[[key]])) { @@ -341,10 +338,10 @@ ReactiveValues <- R6Class( .hasRetrieved$keys[[key]] <<- TRUE } rLog$dependsOnKey(ctx$.reactId, .reactId, key, ctx$id, ctx$.domain) - .dependents[[dep.key]] <- ctx + .dependents$set(dep.key, ctx) ctx$onInvalidate(function() { rLog$dependsOnKeyRemove(ctx$.reactId, .reactId, key, ctx$id, ctx$.domain) - rm(list=dep.key, envir=.dependents, inherits=FALSE) + .dependents$remove(dep.key) }) } @@ -384,16 +381,16 @@ ReactiveValues <- R6Class( domain <- getDefaultReactiveDomain() hidden <- substr(key, 1, 1) == "." - key_exists <- exists(key, envir=.values, inherits=FALSE) + key_exists <- .values$containsKey(key) if (key_exists) { - if (.dedupe && identical(.values[[key]], value)) { + if (.dedupe && identical(.values$get(key), value)) { return(invisible()) } } # set the value for better logging - .values[[key]] <- value + .values$set(key, value) # key has been depended upon if (isTRUE(.hasRetrieved$keys[[key]])) { @@ -408,30 +405,31 @@ ReactiveValues <- R6Class( # only invalidate if there are deps if (!key_exists && isTRUE(.hasRetrieved$names)) { - rLog$valueChangeNames(.reactId, ls(.values, all.names = TRUE), domain) + rLog$valueChangeNames(.reactId, .values$keys(), domain) .namesDeps$invalidate() } if (hidden) { if (isTRUE(.hasRetrieved$asListAll)) { - rLog$valueChangeAsListAll(.reactId, as.list(.values, all.names = TRUE), domain) + rLog$valueChangeAsListAll(.reactId, .values$values(), domain) .allValuesDeps$invalidate() } } else { if (isTRUE(.hasRetrieved$asList)) { + react_vals <- .values$values() + react_vals <- react_vals[!grepl("^\\.", base::names(react_vals))] # leave as is. both object would be registered to the listening object - rLog$valueChangeAsList(.reactId, as.list(.values, all.names = FALSE), domain) + rLog$valueChangeAsList(.reactId, react_vals, domain) .valuesDeps$invalidate() } } - dep.keys <- objects( - envir=.dependents, - pattern=paste('^\\Q', key, ':', '\\E', '\\d+$', sep=''), - all.names=TRUE + dep.keys <- .dependents$keys() + dep.keys <- grep( + paste('^\\Q', key, ':', '\\E', '\\d+$', sep=''), dep.keys, value = TRUE ) lapply( - mget(dep.keys, envir=.dependents), + .dependents$mget(dep.keys), function(ctx) { ctx$invalidate() NULL @@ -448,7 +446,7 @@ ReactiveValues <- R6Class( }, names = function() { - nameValues <- ls(.values, all.names=TRUE) + nameValues <- .values$keys() if (!isTRUE(.hasRetrieved$names)) { domain <- getDefaultReactiveDomain() rLog$defineNames(.reactId, nameValues, .label, domain) @@ -462,7 +460,7 @@ ReactiveValues <- R6Class( getMeta = function(key, metaKey) { # Make sure to use named (not numeric) indexing into list. metaKey <- as.character(metaKey) - .metadata[[key]][[metaKey]] + .metadata$get(key)[[metaKey]] }, # Set a metadata value. Does not trigger reactivity. @@ -470,11 +468,13 @@ ReactiveValues <- R6Class( # Make sure to use named (not numeric) indexing into list. metaKey <- as.character(metaKey) - if (!exists(key, envir = .metadata, inherits = FALSE)) { - .metadata[[key]] <<- list() + if (!.metadata$containsKey(key)) { + .metadata$set(key, list()) } - .metadata[[key]][[metaKey]] <<- value + m <- .metadata$get(key) + m[[metaKey]] <- value + .metadata$set(key, m) }, # Mark a value as frozen If accessed while frozen, a shiny.silent.error will @@ -496,7 +496,10 @@ ReactiveValues <- R6Class( }, toList = function(all.names=FALSE) { - listValue <- as.list(.values, all.names=all.names) + listValue <- .values$values() + if (!all.names) { + listValue <- listValue[!grepl("^\\.", base::names(listValue))] + } if (all.names) { if (!isTRUE(.hasRetrieved$asListAll)) { domain <- getDefaultReactiveDomain() @@ -509,7 +512,7 @@ ReactiveValues <- R6Class( if (!isTRUE(.hasRetrieved$asList)) { domain <- getDefaultReactiveDomain() # making sure the value being recorded is with `all.names = FALSE` - rLog$defineAsList(.reactId, as.list(.values, all.names=FALSE), .label, domain) + rLog$defineAsList(.reactId, listValue[!grepl("^\\.", base::names(listValue))], .label, domain) .hasRetrieved$asList <<- TRUE } .valuesDeps$register() diff --git a/R/shiny.R b/R/shiny.R index ba94c1b8c..96d285012 100644 --- a/R/shiny.R +++ b/R/shiny.R @@ -513,8 +513,7 @@ ShinySession <- R6Class( # in the web page; in these cases, there's no output_foo_hidden flag, # and hidden should be TRUE. In other words, NULL and TRUE should map to # TRUE, FALSE should map to FALSE. - hidden <- private$.clientData$.values[[paste("output_", name, "_hidden", - sep="")]] + hidden <- private$.clientData$.values$get(paste0("output_", name, "_hidden")) if (is.null(hidden)) hidden <- TRUE return(hidden && private$getOutputOption(name, 'suspendWhenHidden', TRUE)) @@ -1917,7 +1916,7 @@ ShinySession <- R6Class( fileData <- readBin(file, 'raw', n=bytes) - if (isTRUE(private$.clientData$.values$allowDataUriScheme)) { + if (isTRUE(private$.clientData$.values$get("allowDataUriScheme"))) { b64 <- rawToBase64(fileData) return(paste('data:', contentType, ';base64,', b64, sep='')) } else { diff --git a/tests/testthat/test-reactivity.r b/tests/testthat/test-reactivity.r index ff24b144a..1c4190187 100644 --- a/tests/testthat/test-reactivity.r +++ b/tests/testthat/test-reactivity.r @@ -94,12 +94,12 @@ test_that("ReactiveValues", { # Initializing with NULL value values <- reactiveValues(a=NULL, b=2) # a should exist and be NULL - expect_equal(isolate(names(values)), c("a", "b")) + expect_setequal(isolate(names(values)), c("a", "b")) expect_true(is.null(isolate(values$a))) # Assigning NULL should keep object (not delete it), and set value to NULL values$b <- NULL - expect_equal(isolate(names(values)), c("a", "b")) + expect_setequal(isolate(names(values)), c("a", "b")) expect_true(is.null(isolate(values$b))) @@ -517,12 +517,12 @@ test_that("names() and reactiveValuesToList()", { }) # names() returns all names - expect_equal(sort(isolate(names(values))), sort(c(".B", "A"))) + expect_setequal(isolate(names(values)), c(".B", "A")) # Assigning names fails expect_error(isolate(names(v) <- c('x', 'y'))) - expect_equal(isolate(reactiveValuesToList(values)), list(A=1)) - expect_equal(isolate(reactiveValuesToList(values, all.names=TRUE)), list(A=1, .B=2)) + expect_mapequal(isolate(reactiveValuesToList(values)), list(A=1)) + expect_mapequal(isolate(reactiveValuesToList(values, all.names=TRUE)), list(A=1, .B=2)) flushReact() @@ -1137,10 +1137,10 @@ test_that("reactive domain works across async handlers", { ~{hasReactiveDomain <<- identical(getDefaultReactiveDomain(), obj)} ) }) - + while (is.null(hasReactiveDomain) && !later::loop_empty()) { later::run_now() } - + testthat::expect_true(hasReactiveDomain) })