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