github/shiny
1
1
Fork 0
mirror of https://github.com/rstudio/shiny.git synced 2026-04-29 03:00:45 -04:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #2429 from rstudio/wch-fastmap

Browse Source 
Use fastmap as backing store for Map class
This commit is contained in:
Winston Chang
2019-05-31 15:39:34 -05:00
committed by GitHub
parent b0a1821d95 8f24d667d6
commit 17afce6fa1
7 changed files with 85 additions and 85 deletions
Download Patch File Download Diff File Expand all files Collapse all files

35
R/cache-memory.R
View File

@@ -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
)
},

43
R/map.R
View File

@@ -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
)
)

65
R/reactives.R
View File

@@ -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()

5
R/shiny.R
View File

@@ -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 {