mirror of
https://github.com/rstudio/shiny.git
synced 2026-04-07 03:00:20 -04:00
use an rLog object to do all logging
This commit is contained in:
Barret Schloerke
485
R/graph.R
485
R/graph.R
@@ -1,6 +1,7 @@
|
||||
# domain is like session
|
||||
|
||||
# used to help define truely global node id's.
|
||||
|
||||
# used to help define truely global react id's.
|
||||
# should work accross session and in global namespace
|
||||
.globals$reactIdCounter <- 0L
|
||||
nextGlobalReactId <- function() {
|
||||
@@ -11,7 +12,7 @@ nextGlobalReactId <- function() {
|
||||
|
||||
|
||||
writeReactLog <- function(file=stdout(), sessionToken = NULL) {
|
||||
log <- rlogStack$as_list()
|
||||
log <- rLog$logStack$as_list()
|
||||
if (!is.null(sessionToken)) {
|
||||
log <- Filter(function(x) {
|
||||
is.null(x$session) || identical(x$session, sessionToken)
|
||||
@@ -60,11 +61,6 @@ showReactLog <- function(time = TRUE) {
|
||||
utils::browseURL(renderReactLog(time = as.logical(time)))
|
||||
}
|
||||
|
||||
displayReactLogMessages <- function() {
|
||||
for (msg in rLogMsg$messages) {
|
||||
message(msg)
|
||||
}
|
||||
}
|
||||
|
||||
renderReactLog <- function(sessionToken = NULL, time = TRUE) {
|
||||
templateFile <- system.file('www/reactive-graph.html', package='shiny')
|
||||
@@ -81,257 +77,292 @@ renderReactLog <- function(sessionToken = NULL, time = TRUE) {
|
||||
return(file)
|
||||
}
|
||||
|
||||
rlogAppend <- function(domain, logEntry) {
|
||||
if (isTRUE(getOption('shiny.reactlog'))) {
|
||||
sessionToken <- if (is.null(domain)) NULL else domain$token
|
||||
rlogStack$push(c(logEntry, list(
|
||||
session = sessionToken,
|
||||
time = as.numeric(Sys.time())
|
||||
)))
|
||||
}
|
||||
|
||||
if (!is.null(domain)) {
|
||||
domain$reactlog(logEntry)
|
||||
}
|
||||
}
|
||||
RLog <- R6Class(
|
||||
'RLog',
|
||||
portable = FALSE,
|
||||
private = list(
|
||||
option = "shiny.reactlog",
|
||||
|
||||
appendEntry = function(domain, logEntry) {
|
||||
if (isTRUE(getOption(private$option))) {
|
||||
sessionToken <- if (is.null(domain)) NULL else domain$token
|
||||
logStack$push(c(logEntry, list(
|
||||
session = sessionToken,
|
||||
time = as.numeric(Sys.time())
|
||||
)))
|
||||
}
|
||||
if (!is.null(domain)) domain$reactlog(logEntry)
|
||||
}
|
||||
),
|
||||
public = list(
|
||||
msg = "MessageLogger",
|
||||
logStack = "Stack",
|
||||
|
||||
ctxIdStr = function(ctxId) paste0("ctx", ctxId),
|
||||
namesIdStr = function(reactId) paste0("names(", reactId, ")"),
|
||||
asListIdStr = function(reactId) paste0("as.list(", reactId, ", all.names = TRUE)"),
|
||||
asListAllIdStr = function(reactId) paste0("as.list(", reactId, ")"),
|
||||
keyIdStr = function(reactId, key) paste0(reactId, "$", key),
|
||||
|
||||
|
||||
# rlogDependsOnReactiveValueKey <- function(reactId, depOnReactId, key) {
|
||||
# rLogMsg$log("dependsOnReactiveValueKey: ", rLogMsg$react(reactId), " ", rLogMsg$react(depOnReactId), " ", key)
|
||||
# rlogAppend(list(
|
||||
# action = "depReactiveValueKey",
|
||||
# reactId = reactId,
|
||||
# depOnReactId = depOnReactId,
|
||||
# key = key
|
||||
# ))
|
||||
# }
|
||||
# rlogDependsOnReactiveValueNames <- function(reactId, depOnReactId) {
|
||||
# rLogMsg$log("dependsOnReactiveValueNames: ", rLogMsg$node(reactId), " ", rLogMsg$node(depOnReactId))
|
||||
# rlogAppend(list(
|
||||
# action = "depReactiveValueNames",
|
||||
# reactId = reactId,
|
||||
# depOnReactId = depOnReactId
|
||||
# ))
|
||||
# }
|
||||
# rlogDependsOnReactiveValueToList <- function(reactId, depOnReactId) {
|
||||
# rLogMsg$log("dependsOnReactiveValueToList: ", rLogMsg$node(reactId), " ", rLogMsg$node(depOnReactId))
|
||||
# rlogAppend(list(
|
||||
# action = "dependsOnReactiveValuetoList",
|
||||
# reactId = reactId,
|
||||
# depOnReactId = depOnReactId
|
||||
# ))
|
||||
# }
|
||||
|
||||
rlogCtxId <- function(ctxId) paste0("ctx", ctxId)
|
||||
initialize = function(option = "shiny.reactlog", display = TRUE, depth = 0) {
|
||||
private$option <- option
|
||||
self$logStack <- Stack$new()
|
||||
self$msg <- MessageLogger$new(display = display, depth = depth, option = option)
|
||||
},
|
||||
displayMessages = function() {
|
||||
for (msg in msg$messages) {
|
||||
message(msg)
|
||||
}
|
||||
},
|
||||
|
||||
rlogReactivesNamesId <- function(reactId) paste0("names(", reactId, ")")
|
||||
rlogReactivesAsListId <- function(reactId) paste0("as.list(", reactId, ", all.names = TRUE)")
|
||||
rlogReactivesAsListAllId <- function(reactId) paste0("as.list(", reactId, ")")
|
||||
rlogReactivesKeyId <- function(reactId, key) paste0(reactId, "$", key)
|
||||
define = function(reactId, label, type, domain) {
|
||||
if (msg$hasReact(reactId)) {
|
||||
stop("react definition for id: ", reactId, " already found!!", "Label: ", label, "Type: ", type)
|
||||
}
|
||||
msg$setReact(list(reactId = reactId, label = label))
|
||||
msg$log("define: ", msg$reactStr(reactId), " - ", type)
|
||||
private$appendEntry(domain, list(
|
||||
action = "define",
|
||||
reactId = reactId,
|
||||
label = label,
|
||||
type = type
|
||||
))
|
||||
},
|
||||
defineNames = function(reactId, label, domain)
|
||||
define(namesIdStr(reactId), namesIdStr(label), "reactiveValuesNames", domain),
|
||||
defineAsList = function(reactId, label, domain)
|
||||
define(asListIdStr(reactId), asListIdStr(label), "reactiveValuesAsList", domain),
|
||||
defineAsListAll = function(reactId, label, domain)
|
||||
define(asListAllIdStr(reactId), asListAllIdStr(label), "reactiveValuesAsListAll", domain),
|
||||
defineKey = function(reactId, key, label, domain)
|
||||
define(keyIdStr(reactId, key), keyIdStr(label, key), "reactiveValuesKey", domain),
|
||||
|
||||
rlogDependsOn <- function(reactId, depOnReactId, ctxId, domain) {
|
||||
ctxId <- rlogCtxId(ctxId)
|
||||
rLogMsg$log("dependsOn: ", rLogMsg$node(reactId), " on ", rLogMsg$node(depOnReactId), " in ", ctxId)
|
||||
rlogAppend(domain, list(
|
||||
action = "dep",
|
||||
reactId = reactId,
|
||||
depOnReactId = depOnReactId,
|
||||
ctxId = ctxId
|
||||
))
|
||||
}
|
||||
rlogDependsOnRemove <- function(reactId, depOnReactId, ctxId, domain) {
|
||||
ctxId <- rlogCtxId(ctxId)
|
||||
rLogMsg$log("dependsOnRemove: ", rLogMsg$node(reactId), " on ", rLogMsg$node(depOnReactId), " in ", ctxId)
|
||||
rlogAppend(domain, list(
|
||||
action = "depOnRemove",
|
||||
reactId = reactId,
|
||||
depOnReactId = depOnReactId
|
||||
))
|
||||
}
|
||||
updateReactLabel = function(reactId, label, domain) {
|
||||
msgObj <- msg$getReact(reactId)
|
||||
if (!is.null(msgObj)) {
|
||||
msgObj$label <- label
|
||||
msg$setReact(msgObj)
|
||||
}
|
||||
msg$log("updateLabel: ", msg$reactStr(reactId))
|
||||
private$appendEntry(domain, list(
|
||||
action = "updateLabel",
|
||||
reactId = reactId,
|
||||
label = label
|
||||
))
|
||||
},
|
||||
updateReactLabelNames = function(reactId, label, domain)
|
||||
updateReactLabel(namesIdStr(reactId), namesIdStr(label), domain),
|
||||
updateReactLabelAsList = function(reactId, label, domain)
|
||||
updateReactLabel(asListIdStr(reactId), asListIdStr(label), domain),
|
||||
updateReactLabelAsListAll = function(reactId, label, domain)
|
||||
updateReactLabel(asListAllIdStr(reactId), asListAllIdStr(label), domain),
|
||||
updateReactLabelKey = function(reactId, key, label, domain)
|
||||
updateReactLabel(keyIdStr(reactId, key), keyIdStr(label, key), domain),
|
||||
|
||||
# init a node id with a label
|
||||
rlogReactDef <- function(reactId, label, type, domain) {
|
||||
if (!is.null(rLogMsg$nodeCache[[reactId]])) {
|
||||
stop("node definition for id: ", reactId, " already found!!", "Label: ", label, "Type: ", type)
|
||||
}
|
||||
rLogMsg$nodeCache[[reactId]] <- list(reactId = reactId, label = label)
|
||||
rLogMsg$log("def: ", rLogMsg$node(reactId), " - ", type)
|
||||
rlogAppend(domain, list(
|
||||
action = "def",
|
||||
reactId = reactId,
|
||||
label = label,
|
||||
type = type
|
||||
))
|
||||
}
|
||||
rlogUpdateNodeLabel <- function(reactId, label, domain) {
|
||||
rLogMsg$nodeCache[[reactId]]$label <<- label
|
||||
rLogMsg$log("updateNodeLabel: ", rLogMsg$node(reactId))
|
||||
rlogAppend(domain, list(
|
||||
action = "updateNodeLabel",
|
||||
reactId = reactId,
|
||||
label = label
|
||||
))
|
||||
}
|
||||
dependsOn = function(reactId, depOnReactId, ctxId, domain) {
|
||||
ctxId <- ctxIdStr(ctxId)
|
||||
msg$log("dependsOn: ", msg$reactStr(reactId), " on ", msg$reactStr(depOnReactId), " in ", ctxId)
|
||||
private$appendEntry(domain, list(
|
||||
action = "dep",
|
||||
reactId = reactId,
|
||||
depOnReactId = depOnReactId,
|
||||
ctxId = ctxId
|
||||
))
|
||||
},
|
||||
dependsOnKey = function(reactId, depOnReactId, key, ctxId, domain)
|
||||
dependsOn(reactId, keyIdStr(depOnReactId, key), ctxId, domain),
|
||||
|
||||
# rlogCreateContext <- function(id, label, type, prevId, domain) {
|
||||
# message("!!createContext: create graph context is deprecated!!")
|
||||
# rlogAppend(list(
|
||||
# action='ctx', ctxId = id, label = paste(label, collapse='\n'),
|
||||
# srcref=as.vector(attr(label, "srcref")), srcfile=attr(label, "srcfile"),
|
||||
# type=type, prevId=prevId
|
||||
# ), domain = domain)
|
||||
# }
|
||||
dependsOnRemove = function(reactId, depOnReactId, ctxId, domain) {
|
||||
ctxId <- ctxIdStr(ctxId)
|
||||
msg$log("dependsOnRemove: ", msg$reactStr(reactId), " on ", msg$reactStr(depOnReactId), " in ", ctxId)
|
||||
private$appendEntry(domain, list(
|
||||
action = "depOnRemove",
|
||||
reactId = reactId,
|
||||
depOnReactId = depOnReactId
|
||||
))
|
||||
},
|
||||
dependsOnKeyRemove = function(reactId, depOnReactId, key, ctxId, domain)
|
||||
dependsOnRemove(reactId, keyIdStr(depOnReactId, key), ctxId, domain),
|
||||
|
||||
rlogEnter <- function(reactId, ctxId, type, domain) {
|
||||
ctxId <- rlogCtxId(ctxId)
|
||||
if (identical(type, "isolate")) {
|
||||
rLogMsg$log("isolateEnter: ", rLogMsg$node(reactId), " in ", ctxId)
|
||||
rLogMsg$depthIncrement()
|
||||
rlogAppend(domain, list(
|
||||
action = 'isolateEnter',
|
||||
reactId = reactId,
|
||||
ctxId = ctxId
|
||||
))
|
||||
} else {
|
||||
rLogMsg$log("enter: ", rLogMsg$node(reactId), " in ", ctxId, " - ", type)
|
||||
rLogMsg$depthIncrement()
|
||||
rlogAppend(domain, list(
|
||||
action = 'enter',
|
||||
reactId = reactId,
|
||||
ctxId = ctxId,
|
||||
type = type
|
||||
))
|
||||
}
|
||||
}
|
||||
enter = function(reactId, ctxId, type, domain) {
|
||||
ctxId <- ctxIdStr(ctxId)
|
||||
if (identical(type, "isolate")) {
|
||||
msg$log("isolateEnter: ", msg$reactStr(reactId), " in ", ctxId)
|
||||
msg$depthIncrement()
|
||||
private$appendEntry(domain, list(
|
||||
action = 'isolateEnter',
|
||||
reactId = reactId,
|
||||
ctxId = ctxId
|
||||
))
|
||||
} else {
|
||||
msg$log("enter: ", msg$reactStr(reactId), " in ", ctxId, " - ", type)
|
||||
msg$depthIncrement()
|
||||
private$appendEntry(domain, list(
|
||||
action = 'enter',
|
||||
reactId = reactId,
|
||||
ctxId = ctxId,
|
||||
type = type
|
||||
))
|
||||
}
|
||||
},
|
||||
exit = function(reactId, ctxId, type, domain) {
|
||||
ctxId <- ctxIdStr(ctxId)
|
||||
if (identical(type, "isolate")) {
|
||||
msg$depthDecrement()
|
||||
msg$log("isolateExit: ", msg$reactStr(reactId), " in ", ctxId)
|
||||
private$appendEntry(domain, list(
|
||||
action = 'isolateExit',
|
||||
reactId = reactId,
|
||||
ctxId = ctxId
|
||||
))
|
||||
} else {
|
||||
msg$depthDecrement()
|
||||
msg$log("exit: ", msg$reactStr(reactId), " in ", ctxId, " - ", type)
|
||||
private$appendEntry(domain, list(
|
||||
action = 'exit',
|
||||
reactId = reactId,
|
||||
ctxId = ctxId,
|
||||
type = type
|
||||
))
|
||||
}
|
||||
},
|
||||
|
||||
rlogExit <- function(reactId, ctxId, type, domain) {
|
||||
ctxId <- rlogCtxId(ctxId)
|
||||
if (identical(type, "isolate")) {
|
||||
rLogMsg$depthDecrement()
|
||||
rLogMsg$log("isolateExit: ", rLogMsg$node(reactId), " in ", ctxId)
|
||||
rlogAppend(domain, list(
|
||||
action = 'isolateExit',
|
||||
reactId = reactId,
|
||||
ctxId = ctxId
|
||||
))
|
||||
} else {
|
||||
rLogMsg$depthDecrement()
|
||||
rLogMsg$log("exit: ", rLogMsg$node(reactId), " in ", ctxId, " - ", type)
|
||||
rlogAppend(domain, list(
|
||||
action = 'exit',
|
||||
reactId = reactId,
|
||||
ctxId = ctxId,
|
||||
type = type
|
||||
))
|
||||
}
|
||||
}
|
||||
valueChange = function(reactId, value, display, domain) {
|
||||
valueStr <- paste(utils::capture.output(utils::str(value)), collapse='\n')
|
||||
if (isTRUE(display)) {
|
||||
msg$log("valueChange: ", msg$reactStr(reactId), " '", valueStr, "'")
|
||||
} else {
|
||||
msg$log("valueChange: ", msg$reactStr(reactId))
|
||||
}
|
||||
private$appendEntry(domain, list(
|
||||
action = 'valueChange',
|
||||
reactId = reactId,
|
||||
value = valueStr
|
||||
))
|
||||
},
|
||||
valueChangeNames = function(reactId, nameValues, domain)
|
||||
valueChange(namesIdStr(reactId), nameValues, FALSE, domain),
|
||||
valueChangeAsList = function(reactId, listValue, domain)
|
||||
valueChange(asListIdStr(.reactId), listValue, FALSE, domain),
|
||||
valueChangeAsListAll = function(reactId, listValue, domain)
|
||||
valueChange(asListAllIdStr(.reactId), listValue, FALSE, domain),
|
||||
valueChangeKey = function(reactId, key, value, domain)
|
||||
valueChange(keyIdStr(reactId, key), value, FALSE, domain),
|
||||
|
||||
# id = ctx id
|
||||
# domain is like session
|
||||
rlogValueChange <- function(reactId, value, display, domain) {
|
||||
valueStr <- paste(utils::capture.output(utils::str(value)), collapse='\n')
|
||||
if (isTRUE(display)) {
|
||||
rLogMsg$log("valueChange: ", rLogMsg$node(reactId), " '", valueStr, "'")
|
||||
} else {
|
||||
rLogMsg$log("valueChange: ", rLogMsg$node(reactId))
|
||||
}
|
||||
rlogAppend(domain, list(
|
||||
action = 'valueChange',
|
||||
reactId = reactId,
|
||||
value = valueStr
|
||||
))
|
||||
}
|
||||
|
||||
rlogInvalidateStart <- function(reactId, ctxId, type, domain) {
|
||||
ctxId <- rlogCtxId(ctxId)
|
||||
if (identical(type, "isolate")) {
|
||||
rLogMsg$log("isolateInvalidateStart: ", rLogMsg$node(reactId), " in ", ctxId)
|
||||
rLogMsg$depthIncrement()
|
||||
rlogAppend(domain, list(
|
||||
action = "isolateInvalidateStart",
|
||||
reactId = reactId,
|
||||
ctxId = ctxId
|
||||
))
|
||||
} else {
|
||||
rLogMsg$log("invalidateStart", ": ", rLogMsg$node(reactId), " in ", ctxId, " - ", type)
|
||||
rLogMsg$depthIncrement()
|
||||
rlogAppend(domain, list(
|
||||
action = "invalidateStart",
|
||||
reactId = reactId,
|
||||
ctxId = ctxId,
|
||||
type = type
|
||||
))
|
||||
}
|
||||
}
|
||||
rlogInvalidateEnd <- function(reactId, ctxId, type, domain) {
|
||||
ctxId <- rlogCtxId(ctxId)
|
||||
if (identical(type, "isolate")) {
|
||||
rLogMsg$depthDecrement()
|
||||
rLogMsg$log("isolateInvalidateEnd: ", rLogMsg$node(reactId), " in ", ctxId)
|
||||
rlogAppend(domain, list(
|
||||
action = "isolateInvalidateEnd",
|
||||
reactId = reactId,
|
||||
ctxId = ctxId
|
||||
))
|
||||
} else {
|
||||
rLogMsg$depthDecrement()
|
||||
rLogMsg$log("invalidateEnd: ", rLogMsg$node(reactId), " in ", ctxId, " - ", type)
|
||||
rlogAppend(domain, list(
|
||||
action = "invalidateEnd",
|
||||
reactId = reactId,
|
||||
ctxId = ctxId,
|
||||
type = type
|
||||
))
|
||||
}
|
||||
}
|
||||
invalidateStart = function(reactId, ctxId, type, domain) {
|
||||
ctxId <- ctxIdStr(ctxId)
|
||||
if (identical(type, "isolate")) {
|
||||
msg$log("isolateInvalidateStart: ", msg$reactStr(reactId), " in ", ctxId)
|
||||
msg$depthIncrement()
|
||||
private$appendEntry(domain, list(
|
||||
action = "isolateInvalidateStart",
|
||||
reactId = reactId,
|
||||
ctxId = ctxId
|
||||
))
|
||||
} else {
|
||||
msg$log("invalidateStart", ": ", msg$reactStr(reactId), " in ", ctxId, " - ", type)
|
||||
msg$depthIncrement()
|
||||
private$appendEntry(domain, list(
|
||||
action = "invalidateStart",
|
||||
reactId = reactId,
|
||||
ctxId = ctxId,
|
||||
type = type
|
||||
))
|
||||
}
|
||||
},
|
||||
invalidateEnd = function(reactId, ctxId, type, domain) {
|
||||
ctxId <- ctxIdStr(ctxId)
|
||||
if (identical(type, "isolate")) {
|
||||
msg$depthDecrement()
|
||||
msg$log("isolateInvalidateEnd: ", msg$reactStr(reactId), " in ", ctxId)
|
||||
private$appendEntry(domain, list(
|
||||
action = "isolateInvalidateEnd",
|
||||
reactId = reactId,
|
||||
ctxId = ctxId
|
||||
))
|
||||
} else {
|
||||
msg$depthDecrement()
|
||||
msg$log("invalidateEnd: ", msg$reactStr(reactId), " in ", ctxId, " - ", type)
|
||||
private$appendEntry(domain, list(
|
||||
action = "invalidateEnd",
|
||||
reactId = reactId,
|
||||
ctxId = ctxId,
|
||||
type = type
|
||||
))
|
||||
}
|
||||
},
|
||||
|
||||
rlogQueueEmpty <- function(domain = NULL) {
|
||||
rLogMsg$log("queueEmpty")
|
||||
rlogAppend(domain, list(
|
||||
action = "queueEmpty"
|
||||
))
|
||||
}
|
||||
queueEmpty = function(domain = NULL) {
|
||||
msg$log("queueEmpty")
|
||||
private$appendEntry(domain, list(
|
||||
action = "queueEmpty"
|
||||
))
|
||||
},
|
||||
|
||||
rlogAsyncStart <- function(domain = NULL) {
|
||||
rLogMsg$log("asyncStart")
|
||||
rlogAppend(domain, list(
|
||||
action = "asyncStart"
|
||||
))
|
||||
}
|
||||
rlogAsyncStop <- function(domain = NULL) {
|
||||
rLogMsg$log("asyncStop")
|
||||
rlogAppend(domain, list(
|
||||
action = "asyncStop"
|
||||
))
|
||||
}
|
||||
asyncStart = function(domain = NULL) {
|
||||
msg$log("asyncStart")
|
||||
private$appendEntry(domain, list(
|
||||
action = "asyncStart"
|
||||
))
|
||||
},
|
||||
asyncStop = function(domain = NULL) {
|
||||
msg$log("asyncStop")
|
||||
private$appendEntry(domain, list(
|
||||
action = "asyncStop"
|
||||
))
|
||||
}
|
||||
|
||||
)
|
||||
)
|
||||
|
||||
MessageLogger = R6Class(
|
||||
'Stack',
|
||||
'MessageLogger',
|
||||
portable = FALSE,
|
||||
class = FALSE,
|
||||
public = list(
|
||||
depth = 0L,
|
||||
display = TRUE,
|
||||
messages = c(),
|
||||
nodeCache = list(),
|
||||
reactCache = list(),
|
||||
option = "shiny.reactlog",
|
||||
|
||||
initialize = function(display, depth) {
|
||||
initialize = function(display, depth, option) {
|
||||
if (!missing(display)) self$display <- display
|
||||
if (!missing(depth)) self$depth <- depth
|
||||
if (!missing(option)) self$option <- option
|
||||
},
|
||||
depthIncrement = function() {
|
||||
if (!isTRUE(getOption(option))) return(NULL)
|
||||
self$depth <- self$depth + 1
|
||||
},
|
||||
depthDecrement = function() {
|
||||
if (!isTRUE(getOption(option))) return(NULL)
|
||||
self$depth <- self$depth - 1
|
||||
},
|
||||
node = function(reactId) {
|
||||
nodeInfo <- nodeCache[[reactId]]
|
||||
hasReact = function(reactId) {
|
||||
if (!isTRUE(getOption(option))) return(FALSE)
|
||||
!is.null(getReact(reactId))
|
||||
},
|
||||
getReact = function(reactId) {
|
||||
if (!isTRUE(getOption(option))) return(NULL)
|
||||
reactCache[[reactId]]
|
||||
},
|
||||
setReact = function(reactObj) {
|
||||
if (!isTRUE(getOption(option))) return(NULL)
|
||||
self$reactCache[[reactObj$reactId]] <- reactObj
|
||||
},
|
||||
reactStr = function(reactId) {
|
||||
if (!isTRUE(getOption(option))) return(NULL)
|
||||
reactInfo <- getReact(reactId)
|
||||
paste0(
|
||||
nodeInfo$reactId, ":", nodeInfo$label
|
||||
reactInfo$reactId, ":", reactInfo$label
|
||||
)
|
||||
},
|
||||
log = function(...) {
|
||||
if (!isTRUE(getOption(option))) return(NULL)
|
||||
msg <- paste0(
|
||||
paste0(rep("· ", depth), collapse = ""), "- ", paste0(..., collapse = ""),
|
||||
collapse = ""
|
||||
@@ -343,12 +374,12 @@ MessageLogger = R6Class(
|
||||
}
|
||||
)
|
||||
)
|
||||
rLogMsg <- MessageLogger$new(TRUE, 0)
|
||||
|
||||
|
||||
#' @include stack.R
|
||||
rlogStack <- Stack$new()
|
||||
|
||||
#' TODO-barret set TRUE to FALSE before release
|
||||
#' TODO-barret remove option set
|
||||
options("shiny.reactlog" = TRUE)
|
||||
rLog <- RLog$new("shiny.reactlog", TRUE, 0)
|
||||
|
||||
|
||||
#############################################################################
|
||||
|
||||
10
R/react.R
10
R/react.R
@@ -46,8 +46,8 @@ Context <- R6Class(
|
||||
promises::with_promise_domain(reactivePromiseDomain(), {
|
||||
withReactiveDomain(.domain, {
|
||||
env <- .getReactiveEnvironment()
|
||||
rlogEnter(.reactId, id, .reactType, .domain)
|
||||
on.exit(rlogExit(.reactId, id, .reactType, .domain), add = TRUE)
|
||||
rLog$enter(.reactId, id, .reactType, .domain)
|
||||
on.exit(rLog$exit(.reactId, id, .reactType, .domain), add = TRUE)
|
||||
env$runWith(self, func)
|
||||
})
|
||||
})
|
||||
@@ -64,8 +64,8 @@ Context <- R6Class(
|
||||
return()
|
||||
.invalidated <<- TRUE
|
||||
|
||||
rlogInvalidateStart(.reactId, id, .reactType, .domain)
|
||||
on.exit(rlogInvalidateEnd(.reactId, id, .reactType, .domain), add = TRUE)
|
||||
rLog$invalidateStart(.reactId, id, .reactType, .domain)
|
||||
on.exit(rLog$invalidateEnd(.reactId, id, .reactType, .domain), add = TRUE)
|
||||
|
||||
lapply(.invalidateCallbacks, function(func) {
|
||||
func()
|
||||
@@ -157,7 +157,7 @@ ReactiveEnvironment <- R6Class(
|
||||
.inFlush <<- TRUE
|
||||
on.exit({
|
||||
.inFlush <<- FALSE
|
||||
rlogQueueEmpty(domain = NULL)
|
||||
rLog$queueEmpty(domain = NULL)
|
||||
})
|
||||
|
||||
while (hasPendingFlush()) {
|
||||
|
||||
@@ -21,12 +21,12 @@ Dependents <- R6Class(
|
||||
if (!.dependents$containsKey(ctx$id)) {
|
||||
.dependents$set(ctx$id, ctx)
|
||||
ctx$onInvalidate(function() {
|
||||
rlogDependsOnRemove(ctx$.reactId, .reactId, ctx$id, ctx$.domain)
|
||||
rLog$dependsOnRemove(ctx$.reactId, .reactId, ctx$id, ctx$.domain)
|
||||
.dependents$remove(ctx$id)
|
||||
})
|
||||
|
||||
if (is.character(.reactId) && is.character(ctx$.reactId)) {
|
||||
rlogDependsOn(ctx$.reactId, .reactId, ctx$id, ctx$.domain)
|
||||
rLog$dependsOn(ctx$.reactId, .reactId, ctx$id, ctx$.domain)
|
||||
} else {
|
||||
# TODO-barret remove before shipping. This should never be reached
|
||||
stop("ERROR: dependents does not have node id: ", .reactId, " and ", ctx$.reactId)
|
||||
@@ -35,8 +35,8 @@ Dependents <- R6Class(
|
||||
},
|
||||
# at times, the context is run in a ctx$onInvalidate(...) which has no runtime context
|
||||
invalidate = function(ctx = getCurrentContext()) {
|
||||
rlogInvalidateStart(.reactId, ctx$id, ctx$.reactType, ctx$.domain)
|
||||
on.exit(rlogInvalidateEnd(.reactId, ctx$id, ctx$.reactType, ctx$.domain), add = TRUE)
|
||||
rLog$invalidateStart(.reactId, ctx$id, ctx$.reactType, ctx$.domain)
|
||||
on.exit(rLog$invalidateEnd(.reactId, ctx$id, ctx$.reactType, ctx$.domain), add = TRUE)
|
||||
lapply(
|
||||
.dependents$values(),
|
||||
function(ctx) {
|
||||
@@ -68,7 +68,7 @@ ReactiveVal <- R6Class(
|
||||
private$value <- value
|
||||
private$label <- label
|
||||
private$dependents <- Dependents$new(reactId = private$reactId)
|
||||
rlogReactDef(private$reactId, private$label, type = "reactiveVal", getDefaultReactiveDomain())
|
||||
rLog$define(private$reactId, private$label, type = "reactiveVal", getDefaultReactiveDomain())
|
||||
},
|
||||
get = function() {
|
||||
private$dependents$register()
|
||||
@@ -82,7 +82,7 @@ ReactiveVal <- R6Class(
|
||||
if (identical(private$value, value)) {
|
||||
return(invisible(FALSE))
|
||||
}
|
||||
rlogValueChange(private$reactId, value, TRUE, getDefaultReactiveDomain())
|
||||
rLog$valueChange(private$reactId, value, TRUE, getDefaultReactiveDomain())
|
||||
private$value <- value
|
||||
private$dependents$invalidate()
|
||||
invisible(TRUE)
|
||||
@@ -306,9 +306,9 @@ ReactiveValues <- R6Class(
|
||||
.metadata <<- new.env(parent=emptyenv())
|
||||
.dependents <<- new.env(parent=emptyenv())
|
||||
.hasRetrieved <<- list(names = FALSE, asListAll = FALSE, asList = FALSE, keys = list())
|
||||
.namesDeps <<- Dependents$new(reactId = rlogReactivesNamesId(.reactId))
|
||||
.allValuesDeps <<- Dependents$new(reactId = rlogReactivesAsListAllId(.reactId))
|
||||
.valuesDeps <<- Dependents$new(reactId = rlogReactivesAsListId(.reactId))
|
||||
.namesDeps <<- Dependents$new(reactId = rLog$namesIdStr(.reactId))
|
||||
.allValuesDeps <<- Dependents$new(reactId = rLog$asListAllIdStr(.reactId))
|
||||
.valuesDeps <<- Dependents$new(reactId = rLog$asListIdStr(.reactId))
|
||||
},
|
||||
|
||||
get = function(key) {
|
||||
@@ -323,20 +323,17 @@ ReactiveValues <- R6Class(
|
||||
ctx <- getCurrentContext()
|
||||
dep.key <- paste(key, ':', ctx$id, sep='')
|
||||
if (!exists(dep.key, envir=.dependents, inherits=FALSE)) {
|
||||
reactKeyId <- rlogReactivesKeyId(.reactId, key)
|
||||
reactKeyId <- rLog$keyIdStr(.reactId, key)
|
||||
|
||||
if (!isTRUE(.hasRetrieved$keys[[key]])) {
|
||||
rlogReactDef(
|
||||
reactKeyId, label = rlogReactivesKeyId(.label, key),
|
||||
type = "reactiveValuesKey", ctx$.domain
|
||||
)
|
||||
rlogValueChange(reactKeyId, keyValue, TRUE, ctx$.domain)
|
||||
rLog$defineKey(.reactId, key, .label, ctx$.domain)
|
||||
rLog$valueChangeKey(.reactId, key, keyValue, ctx$.domain)
|
||||
.hasRetrieved$keys[[key]] <<- TRUE
|
||||
}
|
||||
rlogDependsOn(ctx$.reactId, reactKeyId, ctx$id, ctx$.domain)
|
||||
rLog$dependsOnKey(ctx$.reactId, .reactId, key, ctx$id, ctx$.domain)
|
||||
.dependents[[dep.key]] <- ctx
|
||||
ctx$onInvalidate(function() {
|
||||
rlogDependsOnRemove(ctx$.reactId, reactKeyId, ctx$id, ctx$.domain)
|
||||
rLog$dependsOnKeyRemove(ctx$.reactId, .reactId, key, ctx$id, ctx$.domain)
|
||||
rm(list=dep.key, envir=.dependents, inherits=FALSE)
|
||||
})
|
||||
}
|
||||
@@ -378,41 +375,32 @@ ReactiveValues <- R6Class(
|
||||
|
||||
# key has be depended upon (can not happen if the key is being set)
|
||||
if (isTRUE(.hasRetrieved$keys[[key]])) {
|
||||
rlogValueChange(rlogReactivesKeyId(.reactId, key), value, TRUE, domain)
|
||||
rLog$valueChangeKey(.reactId, key, value, domain)
|
||||
}
|
||||
}
|
||||
else {
|
||||
# only invalidate if there are deps
|
||||
if (isTRUE(.hasRetrieved$names)) {
|
||||
rlogValueChange(
|
||||
rlogReactivesNamesId(.reactId), ls(.values, all.names=TRUE),
|
||||
FALSE,
|
||||
domain)
|
||||
.namesDeps$invalidate()
|
||||
rLog$valueChangeNames(.reactId, .values, domain)
|
||||
}
|
||||
}
|
||||
|
||||
if (hidden) {
|
||||
if (isTRUE(.hasRetrieved$asListAll)) {
|
||||
rlogValueChange(
|
||||
rlogReactivesAsListAllId(.reactId), as.list(.values, all.names=TRUE),
|
||||
display = FALSE,
|
||||
domain)
|
||||
rLog$valueChangeAsListAll(.reactId, .values, domain)
|
||||
.allValuesDeps$invalidate()
|
||||
}
|
||||
} else {
|
||||
if (isTRUE(.hasRetrieved$asList)) {
|
||||
# leave as is. both object would be registered to the listening object
|
||||
rlogValueChange(
|
||||
rlogReactivesAsListId(.reactId), as.list(.values, all.names=FALSE),
|
||||
FALSE,
|
||||
domain)
|
||||
rLog$valueChangeAsList(.reactId, .values, domain)
|
||||
.valuesDeps$invalidate()
|
||||
}
|
||||
}
|
||||
|
||||
.values[[key]] <- value
|
||||
|
||||
# TODO-barret start key invalidate?
|
||||
dep.keys <- objects(
|
||||
envir=.dependents,
|
||||
pattern=paste('^\\Q', key, ':', '\\E', '\\d+$', sep=''),
|
||||
@@ -439,11 +427,8 @@ ReactiveValues <- R6Class(
|
||||
nameValues <- ls(.values, all.names=TRUE)
|
||||
if (!isTRUE(.hasRetrieved$names)) {
|
||||
domain <- getDefaultReactiveDomain()
|
||||
rlogReactDef(
|
||||
rlogReactivesNamesId(.reactId), rlogReactivesNamesId(.label),
|
||||
type = "reactiveValuesNames",
|
||||
domain)
|
||||
rlogValueChange(rlogReactivesNamesId(.reactId), nameValues, FALSE, domain)
|
||||
rLog$defineNames(.reactId, .label, domain)
|
||||
rLog$valueChangeNames(.reactId, nameValues, domain)
|
||||
.hasRetrieved$names <<- TRUE
|
||||
}
|
||||
.namesDeps$register()
|
||||
@@ -488,11 +473,8 @@ ReactiveValues <- R6Class(
|
||||
if (all.names) {
|
||||
if (!isTRUE(.hasRetrieved$asListAll)) {
|
||||
domain <- getDefaultReactiveDomain()
|
||||
rlogReactDef(
|
||||
rlogReactivesAsListAllId(.reactId), rlogReactivesAsListAllId(.label),
|
||||
type = "reactiveValuesAsListAll",
|
||||
domain)
|
||||
rlogValueChange(rlogReactivesAsListAllId(.reactId), listValue, FALSE, domain)
|
||||
rLog$defineAsListAll(.reactId, .label, domain)
|
||||
rLog$valueChangeAsListAll(.reactId, listValue, domain)
|
||||
.hasRetrieved$asListAll <<- TRUE
|
||||
}
|
||||
.allValuesDeps$register()
|
||||
@@ -500,11 +482,8 @@ ReactiveValues <- R6Class(
|
||||
|
||||
if (!isTRUE(hasRetrieved$asList)) {
|
||||
domain <- getDefaultReactiveDomain()
|
||||
rlogReactDef(
|
||||
rlogReactivesAsListId(.reactId), rlogReactivesAsListId(.label),
|
||||
type = "reactiveValuesAsList",
|
||||
domain)
|
||||
rlogValueChange(rlogReactivesAsListId(.reactId), c(), FALSE, domain)
|
||||
rLog$defineAsList(.reactId, .label, domain)
|
||||
rLog$valueChange(.reactId, listValue, domain)
|
||||
.hasRetrieved$asList <<- TRUE
|
||||
}
|
||||
.valuesDeps$register()
|
||||
@@ -514,18 +493,15 @@ ReactiveValues <- R6Class(
|
||||
|
||||
.setLabel = function(label) {
|
||||
domain <- getDefaultReactiveDomain()
|
||||
if (isTRUE(.hasRetrieved$names)) {
|
||||
rlogUpdateNodeLabel(rlogReactivesNamesId(.reactId), rlogReactivesNamesId(label), domain)
|
||||
}
|
||||
if (isTRUE(.hasRetrieved$asListAll)) {
|
||||
rlogUpdateNodeLabel(rlogReactivesAsListAllId(.reactId), rlogReactivesAsListAllId(label), domain)
|
||||
}
|
||||
if (isTRUE(.hasRetrieved$asList)) {
|
||||
rlogUpdateNodeLabel(rlogReactivesAsListId(.reactId), rlogReactivesAsListId(label), domain)
|
||||
}
|
||||
if (isTRUE(.hasRetrieved$names))
|
||||
rLog$updateReactLabelNames(.reactId, label, domain)
|
||||
if (isTRUE(.hasRetrieved$asList))
|
||||
rLog$updateReactLabelAsList(.reactId, label, domain)
|
||||
if (isTRUE(.hasRetrieved$asListAll))
|
||||
rLog$updateReactLabelAsListAll(.reactId, label, domain)
|
||||
for (key in .hasRetrieved$keys) {
|
||||
if (isTRUE(.hasRetrieved$keys[[key]])) {
|
||||
rlogUpdateNodeLabel(rlogReactivesKeyId(.reactId, key), rlogReactivesKeyId(label, key), domain)
|
||||
rLog$updateReactLabelKey(.reactId, key, label, domain)
|
||||
}
|
||||
}
|
||||
.label <<- label
|
||||
@@ -847,7 +823,7 @@ Observable <- R6Class(
|
||||
.running <<- FALSE
|
||||
.execCount <<- 0L
|
||||
.mostRecentCtxId <<- ""
|
||||
rlogReactDef(.reactId, .label, type = "observable", .domain)
|
||||
rLog$define(.reactId, .label, type = "observable", .domain)
|
||||
},
|
||||
getValue = function() {
|
||||
.dependents$register()
|
||||
@@ -1116,7 +1092,7 @@ registerDebugHook("observerFunc", environment(), label)
|
||||
setAutoDestroy(autoDestroy)
|
||||
|
||||
.reactId <<- nextGlobalReactId()
|
||||
rlogReactDef(.reactId, .label, type = "observer", .domain)
|
||||
rLog$define(.reactId, .label, type = "observer", .domain)
|
||||
|
||||
# Defer the first running of this until flushReact is called
|
||||
.createContext()$invalidate()
|
||||
@@ -1524,9 +1500,9 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
|
||||
# callback below is fired (see #1621).
|
||||
force(session)
|
||||
|
||||
# Barret
|
||||
# TODO-barret
|
||||
# reactId <- nextGlobalReactId()
|
||||
# rlogReactDef(reactId, paste0("timer(", intervalMs, ")"))
|
||||
# rLog$define(reactId, paste0("timer(", intervalMs, ")"))
|
||||
|
||||
dependents <- Map$new()
|
||||
timerCallbacks$schedule(intervalMs, function() {
|
||||
|
||||
@@ -1918,7 +1918,7 @@ ShinySession <- R6Class(
|
||||
},
|
||||
incrementBusyCount = function() {
|
||||
if (private$busyCount == 0L) {
|
||||
rlogAsyncStart(domain = NULL)
|
||||
rLog$asyncStart(domain = NULL)
|
||||
private$sendMessage(busy = "busy")
|
||||
}
|
||||
private$busyCount <- private$busyCount + 1L
|
||||
@@ -1926,7 +1926,7 @@ ShinySession <- R6Class(
|
||||
decrementBusyCount = function() {
|
||||
private$busyCount <- private$busyCount - 1L
|
||||
if (private$busyCount == 0L) {
|
||||
rlogAsyncStop(domain = NULL)
|
||||
rLog$asyncStop(domain = NULL)
|
||||
private$sendMessage(busy = "idle")
|
||||
self$requestFlush()
|
||||
# We defer the call to startCycle() using later(), to defend against
|
||||
|
||||
Reference in New Issue
Block a user