1# Check that the version of an suggested package satisfies the requirements 2# 3# @param package The name of the suggested package 4# @param version The version of the package 5check_suggested <- function(package, version = NULL) { 6 7 if (is_available(package, version)) { 8 return() 9 } 10 11 msg <- paste0( 12 sQuote(package), 13 if (is.na(version %||% NA)) "" else paste0("(>= ", version, ")"), 14 " must be installed for this functionality." 15 ) 16 17 if (interactive()) { 18 message(msg, "\nWould you like to install it?") 19 if (utils::menu(c("Yes", "No")) == 1) { 20 return(utils::install.packages(package)) 21 } 22 } 23 24 stop(msg, call. = FALSE) 25} 26 27 28 29 30# domain is like session 31 32 33# used to help define truly global react id's. 34# should work across session and in global namespace 35.globals$reactIdCounter <- 0L 36nextGlobalReactId <- function() { 37 .globals$reactIdCounter <- .globals$reactIdCounter + 1L 38 reactIdStr(.globals$reactIdCounter) 39} 40reactIdStr <- function(num) { 41 paste0("r", num) 42} 43 44 45#' Reactive Log Visualizer 46#' 47#' Provides an interactive browser-based tool for visualizing reactive 48#' dependencies and execution in your application. 49#' 50#' To use the reactive log visualizer, start with a fresh R session and 51#' run the command `options(shiny.reactlog=TRUE)`; then launch your 52#' application in the usual way (e.g. using [runApp()]). At 53#' any time you can hit Ctrl+F3 (or for Mac users, Command+F3) in your 54#' web browser to launch the reactive log visualization. 55#' 56#' The reactive log visualization only includes reactive activity up 57#' until the time the report was loaded. If you want to see more recent 58#' activity, refresh the browser. 59#' 60#' Note that Shiny does not distinguish between reactive dependencies 61#' that "belong" to one Shiny user session versus another, so the 62#' visualization will include all reactive activity that has taken place 63#' in the process, not just for a particular application or session. 64#' 65#' As an alternative to pressing Ctrl/Command+F3--for example, if you 66#' are using reactives outside of the context of a Shiny 67#' application--you can run the `reactlogShow` function, which will 68#' generate the reactive log visualization as a static HTML file and 69#' launch it in your default browser. In this case, refreshing your 70#' browser will not load new activity into the report; you will need to 71#' call `reactlogShow()` explicitly. 72#' 73#' For security and performance reasons, do not enable 74#' `shiny.reactlog` in production environments. When the option is 75#' enabled, it's possible for any user of your app to see at least some 76#' of the source code of your reactive expressions and observers. 77#' 78#' @name reactlog 79NULL 80 81 82#' @describeIn reactlog Return a list of reactive information. Can be used in conjunction with 83#' [reactlog::reactlog_show] to later display the reactlog graph. 84#' @export 85reactlog <- function() { 86 rLog$asList() 87} 88 89#' @describeIn reactlog Display a full reactlog graph for all sessions. 90#' @param time A boolean that specifies whether or not to display the 91#' time that each reactive takes to calculate a result. 92#' @export 93reactlogShow <- function(time = TRUE) { 94 check_reactlog() 95 reactlog::reactlog_show(reactlog(), time = time) 96} 97 98#' @describeIn reactlog Resets the entire reactlog stack. Useful for debugging and removing all prior reactive history. 99#' @export 100reactlogReset <- function() { 101 rLog$reset() 102} 103 104# called in "/reactlog" middleware 105renderReactlog <- function(sessionToken = NULL, time = TRUE) { 106 check_reactlog() 107 reactlog::reactlog_render( 108 reactlog(), 109 session_token = sessionToken, 110 time = time 111 ) 112} 113check_reactlog <- function() { 114 check_suggested("reactlog", reactlog_version()) 115} 116# read reactlog version from description file 117# prevents version mismatch in code and description file 118reactlog_version <- function() { 119 desc <- read.dcf(system.file("DESCRIPTION", package = "shiny", mustWork = TRUE)) 120 suggests <- desc[1,"Suggests"][[1]] 121 suggests_pkgs <- strsplit(suggests, "\n")[[1]] 122 123 reactlog_info <- suggests_pkgs[grepl("reactlog", suggests_pkgs)] 124 if (length(reactlog_info) == 0) { 125 stop("reactlog can not be found in shiny DESCRIPTION file") 126 } 127 128 reactlog_info <- sub("^[^\\(]*\\(", "", reactlog_info) 129 reactlog_info <- sub("\\)[^\\)]*$", "", reactlog_info) 130 reactlog_info <- sub("^[>= ]*", "", reactlog_info) 131 132 package_version(reactlog_info) 133} 134 135 136RLog <- R6Class( 137 "RLog", 138 portable = FALSE, 139 private = list( 140 option = "shiny.reactlog", 141 msgOption = "shiny.reactlog.console", 142 143 appendEntry = function(domain, logEntry) { 144 if (self$isLogging()) { 145 sessionToken <- if (is.null(domain)) NULL else domain$token 146 logStack$push(c(logEntry, list( 147 session = sessionToken, 148 time = as.numeric(Sys.time()) 149 ))) 150 } 151 if (!is.null(domain)) domain$reactlog(logEntry) 152 } 153 ), 154 public = list( 155 msg = "<MessageLogger>", 156 logStack = "<Stack>", 157 158 noReactIdLabel = "NoCtxReactId", 159 noReactId = reactIdStr("NoCtxReactId"), 160 dummyReactIdLabel = "DummyReactId", 161 dummyReactId = reactIdStr("DummyReactId"), 162 163 asList = function() { 164 ret <- self$logStack$as_list() 165 attr(ret, "version") <- "1" 166 ret 167 }, 168 169 ctxIdStr = function(ctxId) { 170 if (is.null(ctxId) || identical(ctxId, "")) return(NULL) 171 paste0("ctx", ctxId) 172 }, 173 namesIdStr = function(reactId) { 174 paste0("names(", reactId, ")") 175 }, 176 asListIdStr = function(reactId) { 177 paste0("reactiveValuesToList(", reactId, ")") 178 }, 179 asListAllIdStr = function(reactId) { 180 paste0("reactiveValuesToList(", reactId, ", all.names = TRUE)") 181 }, 182 keyIdStr = function(reactId, key) { 183 paste0(reactId, "$", key) 184 }, 185 186 valueStr = function(value, n = 200) { 187 if (!self$isLogging()) { 188 # return a placeholder string to avoid calling str 189 return("<reactlog is turned off>") 190 } 191 output <- try(silent = TRUE, { 192 # only capture the first level of the object 193 utils::capture.output(utils::str(value, max.level = 1)) 194 }) 195 outputTxt <- paste0(output, collapse="\n") 196 msg$shortenString(outputTxt, n = n) 197 }, 198 199 initialize = function(rlogOption = "shiny.reactlog", msgOption = "shiny.reactlog.console") { 200 private$option <- rlogOption 201 private$msgOption <- msgOption 202 203 self$reset() 204 }, 205 reset = function() { 206 .globals$reactIdCounter <- 0L 207 208 self$logStack <- fastmap::faststack() 209 self$msg <- MessageLogger$new(option = private$msgOption) 210 211 # setup dummy and missing react information 212 self$msg$setReact(force = TRUE, list(reactId = self$noReactId, label = self$noReactIdLabel)) 213 self$msg$setReact(force = TRUE, list(reactId = self$dummyReactId, label = self$dummyReactIdLabel)) 214 }, 215 isLogging = function() { 216 isTRUE(getOption(private$option, FALSE)) 217 }, 218 219 define = function(reactId, value, label, type, domain) { 220 valueStr <- self$valueStr(value) 221 if (msg$hasReact(reactId)) { 222 stop("react definition for id: ", reactId, " already found!!", "Label: ", label, "Type: ", type) 223 } 224 msg$setReact(list(reactId = reactId, label = label)) 225 msg$log("define:", msg$reactStr(reactId), msg$typeStr(type = type), msg$valueStr(valueStr)) 226 private$appendEntry(domain, list( 227 action = "define", 228 reactId = reactId, 229 label = msg$shortenString(label), 230 type = type, 231 value = valueStr 232 )) 233 }, 234 defineNames = function(reactId, value, label, domain) { 235 self$define(self$namesIdStr(reactId), value, self$namesIdStr(label), "reactiveValuesNames", domain) 236 }, 237 defineAsList = function(reactId, value, label, domain) { 238 self$define(self$asListIdStr(reactId), value, self$asListIdStr(label), "reactiveValuesAsList", domain) 239 }, 240 defineAsListAll = function(reactId, value, label, domain) { 241 self$define(self$asListAllIdStr(reactId), value, self$asListAllIdStr(label), "reactiveValuesAsListAll", domain) 242 }, 243 defineKey = function(reactId, value, key, label, domain) { 244 self$define(self$keyIdStr(reactId, key), value, self$keyIdStr(label, key), "reactiveValuesKey", domain) 245 }, 246 defineObserver = function(reactId, label, domain) { 247 self$define(reactId, value = NULL, label, "observer", domain) 248 }, 249 250 dependsOn = function(reactId, depOnReactId, ctxId, domain) { 251 if (is.null(reactId)) return() 252 ctxId <- ctxIdStr(ctxId) 253 msg$log("dependsOn:", msg$reactStr(reactId), " on", msg$reactStr(depOnReactId), msg$ctxStr(ctxId)) 254 private$appendEntry(domain, list( 255 action = "dependsOn", 256 reactId = reactId, 257 depOnReactId = depOnReactId, 258 ctxId = ctxId 259 )) 260 }, 261 dependsOnKey = function(reactId, depOnReactId, key, ctxId, domain) { 262 self$dependsOn(reactId, self$keyIdStr(depOnReactId, key), ctxId, domain) 263 }, 264 265 dependsOnRemove = function(reactId, depOnReactId, ctxId, domain) { 266 ctxId <- self$ctxIdStr(ctxId) 267 msg$log("dependsOnRemove:", msg$reactStr(reactId), " on", msg$reactStr(depOnReactId), msg$ctxStr(ctxId)) 268 private$appendEntry(domain, list( 269 action = "dependsOnRemove", 270 reactId = reactId, 271 depOnReactId = depOnReactId, 272 ctxId = ctxId 273 )) 274 }, 275 dependsOnKeyRemove = function(reactId, depOnReactId, key, ctxId, domain) { 276 self$dependsOnRemove(reactId, self$keyIdStr(depOnReactId, key), ctxId, domain) 277 }, 278 279 createContext = function(ctxId, label, type, prevCtxId, domain) { 280 ctxId <- self$ctxIdStr(ctxId) 281 prevCtxId <- self$ctxIdStr(prevCtxId) 282 msg$log("createContext:", msg$ctxPrevCtxStr(preCtxIdTxt = " ", ctxId, prevCtxId, type)) 283 private$appendEntry(domain, list( 284 action = "createContext", 285 ctxId = ctxId, 286 label = msg$shortenString(label), 287 type = type, 288 prevCtxId = prevCtxId, 289 srcref = as.vector(attr(label, "srcref")), srcfile=attr(label, "srcfile") 290 )) 291 }, 292 293 enter = function(reactId, ctxId, type, domain) { 294 ctxId <- self$ctxIdStr(ctxId) 295 if (identical(type, "isolate")) { 296 msg$log("isolateEnter:", msg$reactStr(reactId), msg$ctxStr(ctxId)) 297 msg$depthIncrement() 298 private$appendEntry(domain, list( 299 action = "isolateEnter", 300 reactId = reactId, 301 ctxId = ctxId 302 )) 303 } else { 304 msg$log("enter:", msg$reactStr(reactId), msg$ctxStr(ctxId, type)) 305 msg$depthIncrement() 306 private$appendEntry(domain, list( 307 action = "enter", 308 reactId = reactId, 309 ctxId = ctxId, 310 type = type 311 )) 312 } 313 }, 314 exit = function(reactId, ctxId, type, domain) { 315 ctxId <- self$ctxIdStr(ctxId) 316 if (identical(type, "isolate")) { 317 msg$depthDecrement() 318 msg$log("isolateExit:", msg$reactStr(reactId), msg$ctxStr(ctxId)) 319 private$appendEntry(domain, list( 320 action = "isolateExit", 321 reactId = reactId, 322 ctxId = ctxId 323 )) 324 } else { 325 msg$depthDecrement() 326 msg$log("exit:", msg$reactStr(reactId), msg$ctxStr(ctxId, type)) 327 private$appendEntry(domain, list( 328 action = "exit", 329 reactId = reactId, 330 ctxId = ctxId, 331 type = type 332 )) 333 } 334 }, 335 336 valueChange = function(reactId, value, domain) { 337 valueStr <- self$valueStr(value) 338 msg$log("valueChange:", msg$reactStr(reactId), msg$valueStr(valueStr)) 339 private$appendEntry(domain, list( 340 action = "valueChange", 341 reactId = reactId, 342 value = valueStr 343 )) 344 }, 345 valueChangeNames = function(reactId, nameValues, domain) { 346 self$valueChange(self$namesIdStr(reactId), nameValues, domain) 347 }, 348 valueChangeAsList = function(reactId, listValue, domain) { 349 self$valueChange(self$asListIdStr(reactId), listValue, domain) 350 }, 351 valueChangeAsListAll = function(reactId, listValue, domain) { 352 self$valueChange(self$asListAllIdStr(reactId), listValue, domain) 353 }, 354 valueChangeKey = function(reactId, key, value, domain) { 355 self$valueChange(self$keyIdStr(reactId, key), value, domain) 356 }, 357 358 359 invalidateStart = function(reactId, ctxId, type, domain) { 360 ctxId <- self$ctxIdStr(ctxId) 361 if (identical(type, "isolate")) { 362 msg$log("isolateInvalidateStart:", msg$reactStr(reactId), msg$ctxStr(ctxId)) 363 msg$depthIncrement() 364 private$appendEntry(domain, list( 365 action = "isolateInvalidateStart", 366 reactId = reactId, 367 ctxId = ctxId 368 )) 369 } else { 370 msg$log("invalidateStart:", msg$reactStr(reactId), msg$ctxStr(ctxId, type)) 371 msg$depthIncrement() 372 private$appendEntry(domain, list( 373 action = "invalidateStart", 374 reactId = reactId, 375 ctxId = ctxId, 376 type = type 377 )) 378 } 379 }, 380 invalidateEnd = function(reactId, ctxId, type, domain) { 381 ctxId <- self$ctxIdStr(ctxId) 382 if (identical(type, "isolate")) { 383 msg$depthDecrement() 384 msg$log("isolateInvalidateEnd:", msg$reactStr(reactId), msg$ctxStr(ctxId)) 385 private$appendEntry(domain, list( 386 action = "isolateInvalidateEnd", 387 reactId = reactId, 388 ctxId = ctxId 389 )) 390 } else { 391 msg$depthDecrement() 392 msg$log("invalidateEnd:", msg$reactStr(reactId), msg$ctxStr(ctxId, type)) 393 private$appendEntry(domain, list( 394 action = "invalidateEnd", 395 reactId = reactId, 396 ctxId = ctxId, 397 type = type 398 )) 399 } 400 }, 401 402 invalidateLater = function(reactId, runningCtx, millis, domain) { 403 msg$log("invalidateLater: ", millis, "ms", msg$reactStr(reactId), msg$ctxStr(runningCtx)) 404 private$appendEntry(domain, list( 405 action = "invalidateLater", 406 reactId = reactId, 407 ctxId = runningCtx, 408 millis = millis 409 )) 410 }, 411 412 idle = function(domain = NULL) { 413 msg$log("idle") 414 private$appendEntry(domain, list( 415 action = "idle" 416 )) 417 }, 418 419 asyncStart = function(domain = NULL) { 420 msg$log("asyncStart") 421 private$appendEntry(domain, list( 422 action = "asyncStart" 423 )) 424 }, 425 asyncStop = function(domain = NULL) { 426 msg$log("asyncStop") 427 private$appendEntry(domain, list( 428 action = "asyncStop" 429 )) 430 }, 431 432 freezeReactiveVal = function(reactId, domain) { 433 msg$log("freeze:", msg$reactStr(reactId)) 434 private$appendEntry(domain, list( 435 action = "freeze", 436 reactId = reactId 437 )) 438 }, 439 freezeReactiveKey = function(reactId, key, domain) { 440 self$freezeReactiveVal(self$keyIdStr(reactId, key), domain) 441 }, 442 443 thawReactiveVal = function(reactId, domain) { 444 msg$log("thaw:", msg$reactStr(reactId)) 445 private$appendEntry(domain, list( 446 action = "thaw", 447 reactId = reactId 448 )) 449 }, 450 thawReactiveKey = function(reactId, key, domain) { 451 self$thawReactiveVal(self$keyIdStr(reactId, key), domain) 452 }, 453 454 userMark = function(domain = NULL) { 455 msg$log("userMark") 456 private$appendEntry(domain, list( 457 action = "userMark" 458 )) 459 } 460 461 ) 462) 463 464MessageLogger = R6Class( 465 "MessageLogger", 466 portable = FALSE, 467 public = list( 468 depth = 0L, 469 reactCache = list(), 470 option = "shiny.reactlog.console", 471 472 initialize = function(option = "shiny.reactlog.console", depth = 0L) { 473 if (!missing(depth)) self$depth <- depth 474 if (!missing(option)) self$option <- option 475 }, 476 477 isLogging = function() { 478 isTRUE(getOption(self$option)) 479 }, 480 isNotLogging = function() { 481 ! isTRUE(getOption(self$option)) 482 }, 483 depthIncrement = function() { 484 if (self$isNotLogging()) return(NULL) 485 self$depth <- self$depth + 1L 486 }, 487 depthDecrement = function() { 488 if (self$isNotLogging()) return(NULL) 489 self$depth <- self$depth - 1L 490 }, 491 hasReact = function(reactId) { 492 if (self$isNotLogging()) return(FALSE) 493 !is.null(self$getReact(reactId)) 494 }, 495 getReact = function(reactId, force = FALSE) { 496 if (identical(force, FALSE) && self$isNotLogging()) return(NULL) 497 self$reactCache[[reactId]] 498 }, 499 setReact = function(reactObj, force = FALSE) { 500 if (identical(force, FALSE) && self$isNotLogging()) return(NULL) 501 self$reactCache[[reactObj$reactId]] <- reactObj 502 }, 503 shortenString = function(txt, n = 250) { 504 if (is.null(txt) || isTRUE(is.na(txt))) { 505 return("") 506 } 507 if (nchar(txt) > n) { 508 return( 509 paste0(substr(txt, 1, n - 3), "...") 510 ) 511 } 512 return(txt) 513 }, 514 singleLine = function(txt) { 515 gsub("([^\\])\\n", "\\1\\\\n", txt) 516 }, 517 valueStr = function(valueStr) { 518 paste0( 519 " '", self$shortenString(self$singleLine(valueStr)), "'" 520 ) 521 }, 522 reactStr = function(reactId) { 523 if (self$isNotLogging()) return(NULL) 524 reactInfo <- self$getReact(reactId) 525 if (is.null(reactInfo)) return(" <UNKNOWN_REACTID>") 526 paste0( 527 " ", reactInfo$reactId, ":'", self$shortenString(self$singleLine(reactInfo$label)), "'" 528 ) 529 }, 530 typeStr = function(type = NULL) { 531 self$ctxStr(ctxId = NULL, type = type) 532 }, 533 ctxStr = function(ctxId = NULL, type = NULL) { 534 if (self$isNotLogging()) return(NULL) 535 self$ctxPrevCtxStr(ctxId = ctxId, prevCtxId = NULL, type = type) 536 }, 537 ctxPrevCtxStr = function(ctxId = NULL, prevCtxId = NULL, type = NULL, preCtxIdTxt = " in ") { 538 if (self$isNotLogging()) return(NULL) 539 paste0( 540 if (!is.null(ctxId)) paste0(preCtxIdTxt, ctxId), 541 if (!is.null(prevCtxId)) paste0(" from ", prevCtxId), 542 if (!is.null(type) && !identical(type, "other")) paste0(" - ", type) 543 ) 544 }, 545 log = function(...) { 546 if (self$isNotLogging()) return(NULL) 547 msg <- paste0( 548 paste0(rep("= ", depth), collapse = ""), "- ", paste0(..., collapse = ""), 549 collapse = "" 550 ) 551 message(msg) 552 } 553 ) 554) 555 556rLog <- RLog$new("shiny.reactlog", "shiny.reactlog.console") 557