mirror of
https://github.com/rstudio/shiny.git
synced 2026-02-09 06:04:58 -05:00
7b6cc50238
* master: fix shortString is NA or NULL logic add coverage for situation where label might be na or NULL increase default length of label to 250chars from 100chars make sure labels are short for reactlog
569 lines
18 KiB
R
569 lines
18 KiB
R
is_installed <- function(package, version) {
|
|
installedVersion <- tryCatch(utils::packageVersion(package), error = function(e) NA)
|
|
!is.na(installedVersion) && installedVersion >= version
|
|
}
|
|
|
|
# Check that the version of an suggested package satisfies the requirements
|
|
#
|
|
# @param package The name of the suggested package
|
|
# @param version The version of the package
|
|
check_suggested <- function(package, version, location) {
|
|
|
|
if (is_installed(package, version)) {
|
|
return()
|
|
}
|
|
|
|
missing_location <- missing(location)
|
|
msg <- paste0(
|
|
sQuote(package),
|
|
if (is.na(version)) "" else paste0("(>= ", version, ")"),
|
|
" must be installed for this functionality.",
|
|
if (!missing_location)
|
|
paste0(
|
|
"\nPlease install the missing package: \n",
|
|
" source(\"https://install-github.me/", location, "\")"
|
|
)
|
|
)
|
|
|
|
if (interactive() && missing_location) {
|
|
message(msg, "\nWould you like to install it?")
|
|
if (utils::menu(c("Yes", "No")) == 1) {
|
|
return(utils::install.packages(package))
|
|
}
|
|
}
|
|
|
|
stop(msg, call. = FALSE)
|
|
}
|
|
|
|
|
|
|
|
|
|
# domain is like session
|
|
|
|
|
|
# used to help define truly global react id's.
|
|
# should work across session and in global namespace
|
|
.globals$reactIdCounter <- 0L
|
|
nextGlobalReactId <- function() {
|
|
.globals$reactIdCounter <- .globals$reactIdCounter + 1L
|
|
reactIdStr(.globals$reactIdCounter)
|
|
}
|
|
reactIdStr <- function(num) {
|
|
paste0("r", num)
|
|
}
|
|
|
|
|
|
#' Reactive Log Visualizer
|
|
#'
|
|
#' Provides an interactive browser-based tool for visualizing reactive
|
|
#' dependencies and execution in your application.
|
|
#'
|
|
#' To use the reactive log visualizer, start with a fresh R session and
|
|
#' run the command \code{options(shiny.reactlog=TRUE)}; then launch your
|
|
#' application in the usual way (e.g. using \code{\link{runApp}}). At
|
|
#' any time you can hit Ctrl+F3 (or for Mac users, Command+F3) in your
|
|
#' web browser to launch the reactive log visualization.
|
|
#'
|
|
#' The reactive log visualization only includes reactive activity up
|
|
#' until the time the report was loaded. If you want to see more recent
|
|
#' activity, refresh the browser.
|
|
#'
|
|
#' Note that Shiny does not distinguish between reactive dependencies
|
|
#' that "belong" to one Shiny user session versus another, so the
|
|
#' visualization will include all reactive activity that has taken place
|
|
#' in the process, not just for a particular application or session.
|
|
#'
|
|
#' As an alternative to pressing Ctrl/Command+F3--for example, if you
|
|
#' are using reactives outside of the context of a Shiny
|
|
#' application--you can run the \code{reactlogShow} function, which will
|
|
#' generate the reactive log visualization as a static HTML file and
|
|
#' launch it in your default browser. In this case, refreshing your
|
|
#' browser will not load new activity into the report; you will need to
|
|
#' call \code{reactlogShow()} explicitly.
|
|
#'
|
|
#' For security and performance reasons, do not enable
|
|
#' \code{shiny.reactlog} in production environments. When the option is
|
|
#' enabled, it's possible for any user of your app to see at least some
|
|
#' of the source code of your reactive expressions and observers.
|
|
#'
|
|
#' @name reactlog
|
|
NULL
|
|
|
|
|
|
#' @describeIn reactlog Return a list of reactive information. Can be used in conjunction with
|
|
#' \code{reactlog::\link[reactlog]{reactlog_show}} to later display the reactlog graph.
|
|
#' @export
|
|
reactlog <- function() {
|
|
rLog$asList()
|
|
}
|
|
|
|
#' @describeIn reactlog Display a full reactlog graph for all sessions.
|
|
#' @inheritParams reactlog::reactlog_show
|
|
#' @export
|
|
reactlogShow <- function(time = TRUE) {
|
|
check_reactlog()
|
|
reactlog::reactlog_show(reactlog(), time = time)
|
|
}
|
|
#' @describeIn reactlog This function is deprecated. You should use \code{\link{reactlogShow}}
|
|
#' @export
|
|
# legacy purposes
|
|
showReactLog <- function(time = TRUE) {
|
|
shinyDeprecated(new = "`reactlogShow`", version = "1.2.0")
|
|
reactlogShow(time = time)
|
|
}
|
|
#' @describeIn reactlog Resets the entire reactlog stack. Useful for debugging and removing all prior reactive history.
|
|
#' @export
|
|
reactlogReset <- function() {
|
|
rLog$reset()
|
|
}
|
|
|
|
# called in "/reactlog" middleware
|
|
renderReactlog <- function(sessionToken = NULL, time = TRUE) {
|
|
check_reactlog()
|
|
reactlog::reactlog_render(
|
|
reactlog(),
|
|
session_token = sessionToken,
|
|
time = time
|
|
)
|
|
}
|
|
check_reactlog <- function() {
|
|
check_suggested("reactlog", reactlog_version())
|
|
}
|
|
# read reactlog version from description file
|
|
# prevents version mismatch in code and description file
|
|
reactlog_version <- function() {
|
|
desc <- read.dcf(system.file("DESCRIPTION", package = "shiny", mustWork = TRUE))
|
|
suggests <- desc[1,"Suggests"][[1]]
|
|
suggests_pkgs <- strsplit(suggests, "\n")[[1]]
|
|
|
|
reactlog_info <- suggests_pkgs[grepl("reactlog", suggests_pkgs)]
|
|
if (length(reactlog_info) == 0) {
|
|
stop("reactlog can not be found in shiny DESCRIPTION file")
|
|
}
|
|
|
|
reactlog_info <- sub("^[^\\(]*\\(", "", reactlog_info)
|
|
reactlog_info <- sub("\\)[^\\)]*$", "", reactlog_info)
|
|
reactlog_info <- sub("^[>= ]*", "", reactlog_info)
|
|
|
|
package_version(reactlog_info)
|
|
}
|
|
|
|
|
|
RLog <- R6Class(
|
|
"RLog",
|
|
portable = FALSE,
|
|
private = list(
|
|
option = "shiny.reactlog",
|
|
msgOption = "shiny.reactlog.console",
|
|
|
|
appendEntry = function(domain, logEntry) {
|
|
if (self$isLogging()) {
|
|
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>",
|
|
|
|
noReactIdLabel = "NoCtxReactId",
|
|
noReactId = reactIdStr("NoCtxReactId"),
|
|
dummyReactIdLabel = "DummyReactId",
|
|
dummyReactId = reactIdStr("DummyReactId"),
|
|
|
|
asList = function() {
|
|
ret <- self$logStack$as_list()
|
|
attr(ret, "version") <- "1"
|
|
ret
|
|
},
|
|
|
|
ctxIdStr = function(ctxId) {
|
|
if (is.null(ctxId) || identical(ctxId, "")) return(NULL)
|
|
paste0("ctx", ctxId)
|
|
},
|
|
namesIdStr = function(reactId) {
|
|
paste0("names(", reactId, ")")
|
|
},
|
|
asListIdStr = function(reactId) {
|
|
paste0("as.list(", reactId, ")")
|
|
},
|
|
asListAllIdStr = function(reactId) {
|
|
paste0("as.list(", reactId, ", all.names = TRUE)")
|
|
},
|
|
keyIdStr = function(reactId, key) {
|
|
paste0(reactId, "$", key)
|
|
},
|
|
|
|
valueStr = function(value, n = 200) {
|
|
output <- try(silent = TRUE, {
|
|
utils::capture.output(utils::str(value))
|
|
})
|
|
outputTxt <- paste0(output, collapse="\n")
|
|
msg$shortenString(outputTxt, n = n)
|
|
},
|
|
|
|
initialize = function(rlogOption = "shiny.reactlog", msgOption = "shiny.reactlog.console") {
|
|
private$option <- rlogOption
|
|
private$msgOption <- msgOption
|
|
|
|
self$reset()
|
|
},
|
|
reset = function() {
|
|
.globals$reactIdCounter <- 0L
|
|
|
|
self$logStack <- Stack$new()
|
|
self$msg <- MessageLogger$new(option = private$msgOption)
|
|
|
|
# setup dummy and missing react information
|
|
self$msg$setReact(force = TRUE, list(reactId = self$noReactId, label = self$noReactIdLabel))
|
|
self$msg$setReact(force = TRUE, list(reactId = self$dummyReactId, label = self$dummyReactIdLabel))
|
|
},
|
|
isLogging = function() {
|
|
isTRUE(getOption(private$option, FALSE))
|
|
},
|
|
|
|
define = function(reactId, value, label, type, domain) {
|
|
valueStr <- self$valueStr(value)
|
|
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), msg$typeStr(type = type), msg$valueStr(valueStr))
|
|
private$appendEntry(domain, list(
|
|
action = "define",
|
|
reactId = reactId,
|
|
label = msg$shortenString(label),
|
|
type = type,
|
|
value = valueStr
|
|
))
|
|
},
|
|
defineNames = function(reactId, value, label, domain) {
|
|
self$define(self$namesIdStr(reactId), value, self$namesIdStr(label), "reactiveValuesNames", domain)
|
|
},
|
|
defineAsList = function(reactId, value, label, domain) {
|
|
self$define(self$asListIdStr(reactId), value, self$asListIdStr(label), "reactiveValuesAsList", domain)
|
|
},
|
|
defineAsListAll = function(reactId, value, label, domain) {
|
|
self$define(self$asListAllIdStr(reactId), value, self$asListAllIdStr(label), "reactiveValuesAsListAll", domain)
|
|
},
|
|
defineKey = function(reactId, value, key, label, domain) {
|
|
self$define(self$keyIdStr(reactId, key), value, self$keyIdStr(label, key), "reactiveValuesKey", domain)
|
|
},
|
|
defineObserver = function(reactId, label, domain) {
|
|
self$define(reactId, value = NULL, label, "observer", domain)
|
|
},
|
|
|
|
dependsOn = function(reactId, depOnReactId, ctxId, domain) {
|
|
if (is.null(reactId)) return()
|
|
ctxId <- ctxIdStr(ctxId)
|
|
msg$log("dependsOn:", msg$reactStr(reactId), " on", msg$reactStr(depOnReactId), msg$ctxStr(ctxId))
|
|
private$appendEntry(domain, list(
|
|
action = "dependsOn",
|
|
reactId = reactId,
|
|
depOnReactId = depOnReactId,
|
|
ctxId = ctxId
|
|
))
|
|
},
|
|
dependsOnKey = function(reactId, depOnReactId, key, ctxId, domain) {
|
|
self$dependsOn(reactId, self$keyIdStr(depOnReactId, key), ctxId, domain)
|
|
},
|
|
|
|
dependsOnRemove = function(reactId, depOnReactId, ctxId, domain) {
|
|
ctxId <- self$ctxIdStr(ctxId)
|
|
msg$log("dependsOnRemove:", msg$reactStr(reactId), " on", msg$reactStr(depOnReactId), msg$ctxStr(ctxId))
|
|
private$appendEntry(domain, list(
|
|
action = "dependsOnRemove",
|
|
reactId = reactId,
|
|
depOnReactId = depOnReactId,
|
|
ctxId = ctxId
|
|
))
|
|
},
|
|
dependsOnKeyRemove = function(reactId, depOnReactId, key, ctxId, domain) {
|
|
self$dependsOnRemove(reactId, self$keyIdStr(depOnReactId, key), ctxId, domain)
|
|
},
|
|
|
|
createContext = function(ctxId, label, type, prevCtxId, domain) {
|
|
ctxId <- self$ctxIdStr(ctxId)
|
|
prevCtxId <- self$ctxIdStr(prevCtxId)
|
|
msg$log("createContext:", msg$ctxPrevCtxStr(preCtxIdTxt = " ", ctxId, prevCtxId, type))
|
|
private$appendEntry(domain, list(
|
|
action = "createContext",
|
|
ctxId = ctxId,
|
|
label = msg$shortenString(label),
|
|
type = type,
|
|
prevCtxId = prevCtxId,
|
|
srcref = as.vector(attr(label, "srcref")), srcfile=attr(label, "srcfile")
|
|
))
|
|
},
|
|
|
|
enter = function(reactId, ctxId, type, domain) {
|
|
ctxId <- self$ctxIdStr(ctxId)
|
|
if (identical(type, "isolate")) {
|
|
msg$log("isolateEnter:", msg$reactStr(reactId), msg$ctxStr(ctxId))
|
|
msg$depthIncrement()
|
|
private$appendEntry(domain, list(
|
|
action = "isolateEnter",
|
|
reactId = reactId,
|
|
ctxId = ctxId
|
|
))
|
|
} else {
|
|
msg$log("enter:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
|
|
msg$depthIncrement()
|
|
private$appendEntry(domain, list(
|
|
action = "enter",
|
|
reactId = reactId,
|
|
ctxId = ctxId,
|
|
type = type
|
|
))
|
|
}
|
|
},
|
|
exit = function(reactId, ctxId, type, domain) {
|
|
ctxId <- self$ctxIdStr(ctxId)
|
|
if (identical(type, "isolate")) {
|
|
msg$depthDecrement()
|
|
msg$log("isolateExit:", msg$reactStr(reactId), msg$ctxStr(ctxId))
|
|
private$appendEntry(domain, list(
|
|
action = "isolateExit",
|
|
reactId = reactId,
|
|
ctxId = ctxId
|
|
))
|
|
} else {
|
|
msg$depthDecrement()
|
|
msg$log("exit:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
|
|
private$appendEntry(domain, list(
|
|
action = "exit",
|
|
reactId = reactId,
|
|
ctxId = ctxId,
|
|
type = type
|
|
))
|
|
}
|
|
},
|
|
|
|
valueChange = function(reactId, value, domain) {
|
|
valueStr <- self$valueStr(value)
|
|
msg$log("valueChange:", msg$reactStr(reactId), msg$valueStr(valueStr))
|
|
private$appendEntry(domain, list(
|
|
action = "valueChange",
|
|
reactId = reactId,
|
|
value = valueStr
|
|
))
|
|
},
|
|
valueChangeNames = function(reactId, nameValues, domain) {
|
|
self$valueChange(self$namesIdStr(reactId), nameValues, domain)
|
|
},
|
|
valueChangeAsList = function(reactId, listValue, domain) {
|
|
self$valueChange(self$asListIdStr(reactId), listValue, domain)
|
|
},
|
|
valueChangeAsListAll = function(reactId, listValue, domain) {
|
|
self$valueChange(self$asListAllIdStr(reactId), listValue, domain)
|
|
},
|
|
valueChangeKey = function(reactId, key, value, domain) {
|
|
self$valueChange(self$keyIdStr(reactId, key), value, domain)
|
|
},
|
|
|
|
|
|
invalidateStart = function(reactId, ctxId, type, domain) {
|
|
ctxId <- self$ctxIdStr(ctxId)
|
|
if (identical(type, "isolate")) {
|
|
msg$log("isolateInvalidateStart:", msg$reactStr(reactId), msg$ctxStr(ctxId))
|
|
msg$depthIncrement()
|
|
private$appendEntry(domain, list(
|
|
action = "isolateInvalidateStart",
|
|
reactId = reactId,
|
|
ctxId = ctxId
|
|
))
|
|
} else {
|
|
msg$log("invalidateStart:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
|
|
msg$depthIncrement()
|
|
private$appendEntry(domain, list(
|
|
action = "invalidateStart",
|
|
reactId = reactId,
|
|
ctxId = ctxId,
|
|
type = type
|
|
))
|
|
}
|
|
},
|
|
invalidateEnd = function(reactId, ctxId, type, domain) {
|
|
ctxId <- self$ctxIdStr(ctxId)
|
|
if (identical(type, "isolate")) {
|
|
msg$depthDecrement()
|
|
msg$log("isolateInvalidateEnd:", msg$reactStr(reactId), msg$ctxStr(ctxId))
|
|
private$appendEntry(domain, list(
|
|
action = "isolateInvalidateEnd",
|
|
reactId = reactId,
|
|
ctxId = ctxId
|
|
))
|
|
} else {
|
|
msg$depthDecrement()
|
|
msg$log("invalidateEnd:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
|
|
private$appendEntry(domain, list(
|
|
action = "invalidateEnd",
|
|
reactId = reactId,
|
|
ctxId = ctxId,
|
|
type = type
|
|
))
|
|
}
|
|
},
|
|
|
|
invalidateLater = function(reactId, runningCtx, millis, domain) {
|
|
msg$log("invalidateLater: ", millis, "ms", msg$reactStr(reactId), msg$ctxStr(runningCtx))
|
|
private$appendEntry(domain, list(
|
|
action = "invalidateLater",
|
|
reactId = reactId,
|
|
ctxId = runningCtx,
|
|
millis = millis
|
|
))
|
|
},
|
|
|
|
idle = function(domain = NULL) {
|
|
msg$log("idle")
|
|
private$appendEntry(domain, list(
|
|
action = "idle"
|
|
))
|
|
},
|
|
|
|
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"
|
|
))
|
|
},
|
|
|
|
freezeReactiveVal = function(reactId, domain) {
|
|
msg$log("freeze:", msg$reactStr(reactId))
|
|
private$appendEntry(domain, list(
|
|
action = "freeze",
|
|
reactId = reactId
|
|
))
|
|
},
|
|
freezeReactiveKey = function(reactId, key, domain) {
|
|
self$freezeReactiveVal(self$keyIdStr(reactId, key), domain)
|
|
},
|
|
|
|
thawReactiveVal = function(reactId, domain) {
|
|
msg$log("thaw:", msg$reactStr(reactId))
|
|
private$appendEntry(domain, list(
|
|
action = "thaw",
|
|
reactId = reactId
|
|
))
|
|
},
|
|
thawReactiveKey = function(reactId, key, domain) {
|
|
self$thawReactiveVal(self$keyIdStr(reactId, key), domain)
|
|
},
|
|
|
|
userMark = function(domain = NULL) {
|
|
msg$log("userMark")
|
|
private$appendEntry(domain, list(
|
|
action = "userMark"
|
|
))
|
|
}
|
|
|
|
)
|
|
)
|
|
|
|
MessageLogger = R6Class(
|
|
"MessageLogger",
|
|
portable = FALSE,
|
|
public = list(
|
|
depth = 0L,
|
|
reactCache = list(),
|
|
option = "shiny.reactlog.console",
|
|
|
|
initialize = function(option = "shiny.reactlog.console", depth = 0L) {
|
|
if (!missing(depth)) self$depth <- depth
|
|
if (!missing(option)) self$option <- option
|
|
},
|
|
|
|
isLogging = function() {
|
|
isTRUE(getOption(self$option))
|
|
},
|
|
isNotLogging = function() {
|
|
! isTRUE(getOption(self$option))
|
|
},
|
|
depthIncrement = function() {
|
|
if (self$isNotLogging()) return(NULL)
|
|
self$depth <- self$depth + 1L
|
|
},
|
|
depthDecrement = function() {
|
|
if (self$isNotLogging()) return(NULL)
|
|
self$depth <- self$depth - 1L
|
|
},
|
|
hasReact = function(reactId) {
|
|
if (self$isNotLogging()) return(FALSE)
|
|
!is.null(self$getReact(reactId))
|
|
},
|
|
getReact = function(reactId, force = FALSE) {
|
|
if (identical(force, FALSE) && self$isNotLogging()) return(NULL)
|
|
self$reactCache[[reactId]]
|
|
},
|
|
setReact = function(reactObj, force = FALSE) {
|
|
if (identical(force, FALSE) && self$isNotLogging()) return(NULL)
|
|
self$reactCache[[reactObj$reactId]] <- reactObj
|
|
},
|
|
shortenString = function(txt, n = 250) {
|
|
if (is.null(txt) || isTRUE(is.na(txt))) {
|
|
return("")
|
|
}
|
|
if (nchar(txt) > n) {
|
|
return(
|
|
paste0(substr(txt, 1, n - 3), "...")
|
|
)
|
|
}
|
|
return(txt)
|
|
},
|
|
singleLine = function(txt) {
|
|
gsub("[^\\]\\n", "\\\\n", txt)
|
|
},
|
|
valueStr = function(valueStr) {
|
|
paste0(
|
|
" '", self$shortenString(self$singleLine(valueStr)), "'"
|
|
)
|
|
},
|
|
reactStr = function(reactId) {
|
|
if (self$isNotLogging()) return(NULL)
|
|
reactInfo <- self$getReact(reactId)
|
|
if (is.null(reactInfo)) return(" <UNKNOWN_REACTID>")
|
|
paste0(
|
|
" ", reactInfo$reactId, ":'", self$shortenString(self$singleLine(reactInfo$label)), "'"
|
|
)
|
|
},
|
|
typeStr = function(type = NULL) {
|
|
self$ctxStr(ctxId = NULL, type = type)
|
|
},
|
|
ctxStr = function(ctxId = NULL, type = NULL) {
|
|
if (self$isNotLogging()) return(NULL)
|
|
self$ctxPrevCtxStr(ctxId = ctxId, prevCtxId = NULL, type = type)
|
|
},
|
|
ctxPrevCtxStr = function(ctxId = NULL, prevCtxId = NULL, type = NULL, preCtxIdTxt = " in ") {
|
|
if (self$isNotLogging()) return(NULL)
|
|
paste0(
|
|
if (!is.null(ctxId)) paste0(preCtxIdTxt, ctxId),
|
|
if (!is.null(prevCtxId)) paste0(" from ", prevCtxId),
|
|
if (!is.null(type) && !identical(type, "other")) paste0(" - ", type)
|
|
)
|
|
},
|
|
log = function(...) {
|
|
if (self$isNotLogging()) return(NULL)
|
|
msg <- paste0(
|
|
paste0(rep("= ", depth), collapse = ""), "- ", paste0(..., collapse = ""),
|
|
collapse = ""
|
|
)
|
|
message(msg)
|
|
}
|
|
)
|
|
)
|
|
|
|
#' @include stack.R
|
|
rLog <- RLog$new("shiny.reactlog", "shiny.reactlog.console")
|