1#' @include utils.R 2NULL 3 4#' Web Application Framework for R 5#' 6#' Shiny makes it incredibly easy to build interactive web applications with R. 7#' Automatic "reactive" binding between inputs and outputs and extensive 8#' prebuilt widgets make it possible to build beautiful, responsive, and 9#' powerful applications with minimal effort. 10#' 11#' The Shiny tutorial at <https://shiny.rstudio.com/tutorial/> explains 12#' the framework in depth, walks you through building a simple application, and 13#' includes extensive annotated examples. 14#' 15#' @seealso [shiny-options] for documentation about global options. 16#' 17#' @name shiny-package 18#' @aliases shiny 19#' @docType package 20NULL 21 22createUniqueId <- function(bytes, prefix = "", suffix = "") { 23 withPrivateSeed({ 24 paste( 25 prefix, 26 paste( 27 format(as.hexmode(sample(256, bytes, replace = TRUE)-1), width=2), 28 collapse = ""), 29 suffix, 30 sep = "" 31 ) 32 }) 33} 34 35toJSON <- function(x, ..., dataframe = "columns", null = "null", na = "null", 36 auto_unbox = TRUE, digits = getOption("shiny.json.digits", 16), 37 use_signif = TRUE, force = TRUE, POSIXt = "ISO8601", UTC = TRUE, 38 rownames = FALSE, keep_vec_names = TRUE, strict_atomic = TRUE) { 39 40 if (strict_atomic) { 41 x <- I(x) 42 } 43 44 # I(x) is so that length-1 atomic vectors get put in []. 45 jsonlite::toJSON(x, dataframe = dataframe, null = null, na = na, 46 auto_unbox = auto_unbox, digits = digits, use_signif = use_signif, 47 force = force, POSIXt = POSIXt, UTC = UTC, rownames = rownames, 48 keep_vec_names = keep_vec_names, json_verbatim = TRUE, ...) 49} 50 51# If the input to jsonlite::fromJSON is not valid JSON, it will try to fetch a 52# URL or read a file from disk. We don't want to allow that. 53safeFromJSON <- function(txt, ...) { 54 if (!jsonlite::validate(txt)) { 55 stop("Argument 'txt' is not a valid JSON string.") 56 } 57 jsonlite::fromJSON(txt, ...) 58} 59 60# Call the workerId func with no args to get the worker id, and with an arg to 61# set it. 62# 63# A worker ID is an opaque string that is passed in by the caller. The ID is 64# added as a URL parameter (?w=<worker_id>) to any URLs that need to refer back 65# to the app. This can be used as a hint for load balancers to direct requests 66# to this particular process. Since the worker refers to a process, it's 67# inherently global, and should never need to change. 68workerId <- local({ 69 .workerId <- NULL 70 function(value) { 71 if (missing(value)) { 72 .workerId 73 } else { 74 if (!is.null(.workerId)) { 75 if (!identical(value, .workerId)) { 76 warning("Ignoring workerId value--", 77 "it's already been set to a different value") 78 } 79 } else { 80 .workerId <<- value 81 } 82 } 83 } 84}) 85 86#' Session object 87#' 88#' Shiny server functions can optionally include `session` as a parameter 89#' (e.g. `function(input, output, session)`). The session object is an 90#' environment that can be used to access information and functionality 91#' relating to the session. The following list describes the items available 92#' in the environment; they can be accessed using the `$` operator (for 93#' example, `session$clientData$url_search`). 94#' 95#' @return 96#' \item{allowReconnect(value)}{ 97#' If `value` is `TRUE` and run in a hosting environment (Shiny 98#' Server or Connect) with reconnections enabled, then when the session ends 99#' due to the network connection closing, the client will attempt to 100#' reconnect to the server. If a reconnection is successful, the browser will 101#' send all the current input values to the new session on the server, and 102#' the server will recalculate any outputs and send them back to the client. 103#' If `value` is `FALSE`, reconnections will be disabled (this is 104#' the default state). If `"force"`, then the client browser will always 105#' attempt to reconnect. The only reason to use `"force"` is for testing 106#' on a local connection (without Shiny Server or Connect). 107#' } 108#' \item{clientData}{ 109#' A [reactiveValues()] object that contains information about the client. 110#' \itemize{ 111#' \item{`pixelratio` reports the "device pixel ratio" from the web browser, 112#' or 1 if none is reported. The value is 2 for Apple Retina displays. 113#' } 114#' \item{`singletons` - for internal use} 115#' \item{`url_protocol`, `url_hostname`, `url_port`, 116#' `url_pathname`, `url_search`, `url_hash_initial` 117#' and `url_hash` can be used to get the components of the URL 118#' that was requested by the browser to load the Shiny app page. 119#' These values are from the browser's perspective, so neither HTTP 120#' proxies nor Shiny Server will affect these values. The 121#' `url_search` value may be used with [parseQueryString()] 122#' to access query string parameters. 123#' } 124#' } 125#' `clientData` also contains information about each output. 126#' \code{output_\var{outputId}_width} and \code{output_\var{outputId}_height} 127#' give the dimensions (using `offsetWidth` and `offsetHeight`) of 128#' the DOM element that is bound to \code{\var{outputId}}, and 129#' \code{output_\var{outputId}_hidden} is a logical that indicates whether 130#' the element is hidden. These values may be `NULL` if the output is 131#' not bound. 132#' } 133#' \item{input}{ 134#' The session's `input` object (the same as is passed into the Shiny 135#' server function as an argument). 136#' } 137#' \item{isClosed()}{A function that returns `TRUE` if the client has 138#' disconnected. 139#' } 140#' \item{ns(id)}{ 141#' Server-side version of [`ns <- NS(id)`][NS]. If bare IDs need to be 142#' explicitly namespaced for the current module, `session$ns("name")` 143#' will return the fully-qualified ID. 144#' } 145#' \item{onEnded(callback)}{ 146#' Synonym for `onSessionEnded`. 147#' } 148#' \item{onFlush(func, once=TRUE)}{ 149#' Registers a function to be called before the next time (if `once=TRUE`) 150#' or every time (if `once=FALSE`) Shiny flushes the reactive system. 151#' Returns a function that can be called with no arguments to cancel the 152#' registration. 153#' } 154#' \item{onFlushed(func, once=TRUE)}{ 155#' Registers a function to be called after the next time (if `once=TRUE`) 156#' or every time (if `once=FALSE`) Shiny flushes the reactive system. 157#' Returns a function that can be called with no arguments to cancel the 158#' registration. 159#' } 160#' \item{onSessionEnded(callback)}{ 161#' Registers a function to be called after the client has disconnected. 162#' Returns a function that can be called with no arguments to cancel the 163#' registration. 164#' } 165#' \item{output}{ 166#' The session's `output` object (the same as is passed into the Shiny 167#' server function as an argument). 168#' } 169#' \item{reactlog}{ 170#' For internal use. 171#' } 172#' \item{registerDataObj(name, data, filterFunc)}{ 173#' Publishes any R object as a URL endpoint that is unique to this session. 174#' `name` must be a single element character vector; it will be used 175#' to form part of the URL. `filterFunc` must be a function that takes 176#' two arguments: `data` (the value that was passed into 177#' `registerDataObj`) and `req` (an environment that implements 178#' the Rook specification for HTTP requests). `filterFunc` will be 179#' called with these values whenever an HTTP request is made to the URL 180#' endpoint. The return value of `filterFunc` should be a Rook-style 181#' response. 182#' } 183#' \item{reload()}{ 184#' The equivalent of hitting the browser's Reload button. Only works if the 185#' session is actually connected. 186#' } 187#' \item{request}{ 188#' An environment that implements the Rook specification for HTTP requests. 189#' This is the request that was used to initiate the websocket connection 190#' (as opposed to the request that downloaded the web page for the app). 191#' } 192#' \item{userData}{ 193#' An environment for app authors and module/package authors to store whatever 194#' session-specific data they want. 195#' } 196#' \item{user}{ 197#' User's log-in information. Useful for identifying users on hosted platforms 198#' such as RStudio Connect and Shiny Server. 199#' } 200#' \item{groups}{ 201#' The `user`'s relevant group information. Useful for determining what 202#' privileges the user should or shouldn't have. 203#' } 204#' \item{resetBrush(brushId)}{ 205#' Resets/clears the brush with the given `brushId`, if it exists on 206#' any `imageOutput` or `plotOutput` in the app. 207#' } 208#' \item{sendCustomMessage(type, message)}{ 209#' Sends a custom message to the web page. `type` must be a 210#' single-element character vector giving the type of message, while 211#' `message` can be any jsonlite-encodable value. Custom messages 212#' have no meaning to Shiny itself; they are used soley to convey information 213#' to custom JavaScript logic in the browser. You can do this by adding 214#' JavaScript code to the browser that calls 215#' \code{Shiny.addCustomMessageHandler(type, function(message){...})} 216#' as the page loads; the function you provide to 217#' `addCustomMessageHandler` will be invoked each time 218#' `sendCustomMessage` is called on the server. 219#' } 220#' \item{sendBinaryMessage(type, message)}{ 221#' Similar to `sendCustomMessage`, but the message must be a raw vector 222#' and the registration method on the client is 223#' \code{Shiny.addBinaryMessageHandler(type, function(message){...})}. The 224#' message argument on the client will be a 225#' [DataView](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView). 226#' } 227#' \item{sendInputMessage(inputId, message)}{ 228#' Sends a message to an input on the session's client web page; if the input 229#' is present and bound on the page at the time the message is received, then 230#' the input binding object's `receiveMessage(el, message)` method will 231#' be called. `sendInputMessage` should generally not be called directly 232#' from Shiny apps, but through friendlier wrapper functions like 233#' [updateTextInput()]. 234#' } 235#' \item{setBookmarkExclude(names)}{ 236#' Set input names to be excluded from bookmarking. 237#' } 238#' \item{getBookmarkExclude()}{ 239#' Returns the set of input names to be excluded from bookmarking. 240#' } 241#' \item{onBookmark(fun)}{ 242#' Registers a function that will be called just before bookmarking state. 243#' } 244#' \item{onBookmarked(fun)}{ 245#' Registers a function that will be called just after bookmarking state. 246#' } 247#' \item{onRestore(fun)}{ 248#' Registers a function that will be called when a session is restored, before 249#' all other reactives, observers, and render functions are run. 250#' } 251#' \item{onRestored(fun)}{ 252#' Registers a function that will be called when a session is restored, after 253#' all other reactives, observers, and render functions are run. 254#' } 255#' \item{doBookmark()}{ 256#' Do bookmarking and invoke the onBookmark and onBookmarked callback functions. 257#' } 258#' \item{exportTestValues()}{ 259#' Registers expressions for export in test mode, available at the test 260#' snapshot URL. 261#' } 262#' \item{getTestSnapshotUrl(input=TRUE, output=TRUE, export=TRUE, 263#' format="json")}{ 264#' Returns a URL for the test snapshots. Only has an effect when the 265#' `shiny.testmode` option is set to TRUE. For the input, output, and 266#' export arguments, TRUE means to return all of these values. It is also 267#' possible to specify by name which values to return by providing a 268#' character vector, as in `input=c("x", "y")`. The format can be 269#' "rds" or "json". 270#' } 271#' \item{setCurrentTheme(theme)}{ 272#' Sets the current [bootstrapLib()] theme, which updates the value of 273#' [getCurrentTheme()], invalidates `session$getCurrentTheme()`, and calls 274#' function(s) registered with [registerThemeDependency()] with provided 275#' `theme`. If those function calls return [htmltools::htmlDependency()]s with 276#' `stylesheet`s, then those stylesheets are "refreshed" (i.e., the new 277#' stylesheets are inserted on the page and the old ones are disabled and 278#' removed). 279#' } 280#' \item{getCurrentTheme()}{ 281#' A reactive read of the current [bootstrapLib()] theme. 282#' } 283#' 284#' @name session 285NULL 286 287#' Namespaced IDs for inputs/outputs 288#' 289#' The `NS` function creates namespaced IDs out of bare IDs, by joining 290#' them using `ns.sep` as the delimiter. It is intended for use in Shiny 291#' modules. See <https://shiny.rstudio.com/articles/modules.html>. 292#' 293#' Shiny applications use IDs to identify inputs and outputs. These IDs must be 294#' unique within an application, as accidentally using the same input/output ID 295#' more than once will result in unexpected behavior. The traditional solution 296#' for preventing name collisions is *namespaces*; a namespace is to an ID 297#' as a directory is to a file. Use the `NS` function to turn a bare ID 298#' into a namespaced one, by combining them with `ns.sep` in between. 299#' 300#' @param namespace The character vector to use for the namespace. This can have 301#' any length, though a single element is most common. Length 0 will cause the 302#' `id` to be returned without a namespace, and length 2 will be 303#' interpreted as multiple namespaces, in increasing order of specificity 304#' (i.e. starting with the top-level namespace). 305#' @param id The id string to be namespaced (optional). 306#' @return If `id` is missing, returns a function that expects an id string 307#' as its only argument and returns that id with the namespace prepended. 308#' @seealso <https://shiny.rstudio.com/articles/modules.html> 309#' @export 310NS <- function(namespace, id = NULL) { 311 if (length(namespace) == 0) 312 ns_prefix <- character(0) 313 else 314 ns_prefix <- paste(namespace, collapse = ns.sep) 315 316 f <- function(id) { 317 if (length(id) == 0) 318 return(ns_prefix) 319 if (length(ns_prefix) == 0) 320 return(id) 321 322 paste(ns_prefix, id, sep = ns.sep) 323 } 324 325 if (missing(id)) { 326 f 327 } else { 328 f(id) 329 } 330} 331 332#' @rdname NS 333#' @export 334ns.sep <- "-" 335 336 337#' @include utils.R 338ShinySession <- R6Class( 339 'ShinySession', 340 private = list( 341 # There are some private items with a leading "."; except for the dot, these 342 # items share a name with a public item. 343 websocket = 'ANY', 344 invalidatedOutputValues = 'Map', 345 invalidatedOutputErrors = 'Map', 346 inputMessageQueue = 'fastqueue', # A list of inputMessages to send when flushed 347 cycleStartActionQueue = 'fastqueue', # A list of actions to perform to start a cycle 348 .outputs = list(), # Keeps track of all the output observer objects 349 .outputOptions = list(), # Options for each of the output observer objects 350 progressKeys = 'character', 351 showcase = FALSE, 352 fileUploadContext = 'FileUploadContext', 353 .input = 'ANY', # Internal ReactiveValues object for normal input sent from client 354 .clientData = 'ANY', # Internal ReactiveValues object for other data sent from the client 355 busyCount = 0L, # Number of observer callbacks that are pending. When 0, we are idle 356 closedCallbacks = 'Callbacks', 357 flushCallbacks = 'Callbacks', 358 flushedCallbacks = 'Callbacks', 359 inputReceivedCallbacks = 'Callbacks', 360 bookmarkCallbacks = 'Callbacks', 361 bookmarkedCallbacks = 'Callbacks', 362 restoreCallbacks = 'Callbacks', 363 restoredCallbacks = 'Callbacks', 364 bookmarkExclude = character(0), # Names of inputs to exclude from bookmarking 365 getBookmarkExcludeFuns = list(), 366 timingRecorder = 'ShinyServerTimingRecorder', 367 368 testMode = FALSE, # Are we running in test mode? 369 testExportExprs = list(), 370 outputValues = list(), # Saved output values (for testing mode) 371 currentOutputName = NULL, # Name of the currently-running output 372 outputInfo = list(), # List of information for each output 373 testSnapshotUrl = character(0), 374 currentThemeDependency = NULL, # ReactiveVal for taking dependency on theme 375 376 sendResponse = function(requestMsg, value) { 377 if (is.null(requestMsg$tag)) { 378 warning("Tried to send response for untagged message; method: ", 379 requestMsg$method) 380 return() 381 } 382 private$sendMessage( 383 response = list(tag = requestMsg$tag, value = value) 384 ) 385 }, 386 sendErrorResponse = function(requestMsg, error) { 387 if (is.null(requestMsg$tag)) 388 return() 389 private$sendMessage( 390 response = list(tag = requestMsg$tag, error = error) 391 ) 392 }, 393 write = function(json) { 394 if (self$closed){ 395 return() 396 } 397 traceOption <- getOption('shiny.trace', FALSE) 398 if (isTRUE(traceOption) || traceOption == "send") 399 message('SEND ', 400 gsub('(?m)base64,[a-zA-Z0-9+/=]+','[base64 data]',json,perl=TRUE)) 401 private$websocket$send(json) 402 }, 403 sendMessage = function(...) { 404 # This function is a wrapper for $write 405 msg <- list(...) 406 if (anyUnnamed(msg)) { 407 stop("All arguments to sendMessage must be named.") 408 } 409 private$write(toJSON(msg)) 410 }, 411 getOutputOption = function(outputName, propertyName, defaultValue) { 412 opts <- private$.outputOptions[[outputName]] 413 if (is.null(opts)) 414 return(defaultValue) 415 result <- opts[[propertyName]] 416 if (is.null(result)) 417 return(defaultValue) 418 return(result) 419 }, 420 withCurrentOutput = function(name, expr) { 421 if (!is.null(private$currentOutputName)) { 422 stop("Nested calls to withCurrentOutput() are not allowed.") 423 } 424 425 promises::with_promise_domain( 426 createVarPromiseDomain(private, "currentOutputName", name), 427 expr 428 ) 429 }, 430 shouldSuspend = function(name) { 431 # Find corresponding hidden state clientData variable, with the format 432 # "output_foo_hidden". (It comes from .clientdata_output_foo_hidden 433 # on the JS side) 434 # Some tricky stuff: instead of accessing names using input$names(), 435 # get the names directly via input$.values, to avoid triggering reactivity. 436 # Need to handle cases where the output object isn't actually used 437 # in the web page; in these cases, there's no output_foo_hidden flag, 438 # and hidden should be TRUE. In other words, NULL and TRUE should map to 439 # TRUE, FALSE should map to FALSE. 440 hidden <- private$.clientData$.values$get(paste0("output_", name, "_hidden")) 441 if (is.null(hidden)) hidden <- TRUE 442 443 return(hidden && private$getOutputOption(name, 'suspendWhenHidden', TRUE)) 444 }, 445 446 registerSessionEndCallbacks = function() { 447 # This is to be called from the initialization. It registers functions 448 # that are called when a session ends. 449 450 # Clear file upload directories, if present 451 self$onSessionEnded(private$fileUploadContext$rmUploadDirs) 452 }, 453 454 # Modules (scopes) call this to register a function that returns a vector 455 # of names to exclude from bookmarking. The function should return 456 # something like c("scope1-x", "scope1-y"). This doesn't use a Callback 457 # object because the return values of the functions are needed, but 458 # Callback$invoke() discards return values. 459 registerBookmarkExclude = function(fun) { 460 len <- length(private$getBookmarkExcludeFuns) + 1 461 private$getBookmarkExcludeFuns[[len]] <- fun 462 }, 463 464 # Save output values and errors. This is only used for testing mode. 465 storeOutputValues = function(values = NULL) { 466 private$outputValues <- mergeVectors(private$outputValues, values) 467 }, 468 469 enableTestSnapshot = function() { 470 private$testSnapshotUrl <- self$registerDataObj("shinytest", NULL, 471 function(data, req) { 472 if (!isTRUE(private$testMode)) { 473 return() 474 } 475 476 params <- parseQueryString(req$QUERY_STRING) 477 # The format of the response that will be sent back. Defaults to 478 # "json" unless requested otherwise. The only other valid value is 479 # "rds". 480 format <- params$format %||% "json" 481 482 values <- list() 483 484 if (!is.null(params$input)) { 485 486 # The isolate and reactiveValuesToList calls are being executed 487 # in a non-reactive context, but will produce output in the reactlog 488 # Seeing new, unlabelled reactives ONLY when calling shinytest is 489 # jarring / frustrating to debug. 490 # Since labeling these values is not currently supported in reactlog, 491 # it is better to hide them. 492 # Hopefully we can replace this with something like 493 # `with_reactlog_group("shinytest", {})`, which would visibily explain 494 # why the new reactives are added when calling shinytest 495 withr::with_options( 496 list(shiny.reactlog = FALSE), 497 { 498 allInputs <- isolate( 499 reactiveValuesToList(self$input, all.names = TRUE) 500 ) 501 } 502 ) 503 504 # If params$input is "1", return all; otherwise return just the 505 # inputs that are named in params$input, like "x,y,z". 506 if (params$input == "1") { 507 values$input <- allInputs 508 } else { 509 items <- strsplit(params$input, ",")[[1]] 510 items <- intersect(items, names(allInputs)) 511 values$input <- allInputs[items] 512 } 513 514 # Apply preprocessor functions for inputs that have them. 515 values$input <- lapply( 516 stats::setNames(names(values$input), names(values$input)), 517 function(name) { 518 preprocess <- private$getSnapshotPreprocessInput(name) 519 preprocess(values$input[[name]]) 520 } 521 ) 522 523 values$input <- sortByName(values$input) 524 } 525 526 if (!is.null(params$output)) { 527 528 if (params$output == "1") { 529 values$output <- private$outputValues 530 } else { 531 items <- strsplit(params$output, ",")[[1]] 532 items <- intersect(items, names(private$outputValues)) 533 values$output <- private$outputValues[items] 534 } 535 536 # Filter out those outputs that have the snapshotExclude attribute. 537 exclude_idx <- vapply(names(values$output), function(name) { 538 isTRUE(attr(private$.outputs[[name]], "snapshotExclude", TRUE)) 539 }, logical(1)) 540 values$output <- values$output[!exclude_idx] 541 542 # Apply snapshotPreprocess functions for outputs that have them. 543 values$output <- lapply( 544 stats::setNames(names(values$output), names(values$output)), 545 function(name) { 546 preprocess <- private$getSnapshotPreprocessOutput(name) 547 preprocess(values$output[[name]]) 548 } 549 ) 550 551 values$output <- sortByName(values$output) 552 } 553 554 if (!is.null(params$export)) { 555 556 if (params$export == "1") { 557 values$export <- isolate( 558 lapply(private$testExportExprs, function(item) { 559 eval(item$expr, envir = item$env) 560 }) 561 ) 562 } else { 563 items <- strsplit(params$export, ",")[[1]] 564 items <- intersect(items, names(private$testExportExprs)) 565 values$export <- isolate( 566 lapply(private$testExportExprs[items], function(item) { 567 eval(item$expr, envir = item$env) 568 }) 569 ) 570 } 571 572 values$export <- sortByName(values$export) 573 } 574 575 # Make sure input, output, and export are all named lists (at this 576 # point, they could be unnamed if they are empty lists). This is so 577 # that the resulting object is represented as an object in JSON 578 # instead of an array, and so that the RDS data structure is of a 579 # consistent type. 580 values <- lapply(values, asNamed) 581 582 if (length(values) == 0) { 583 return(httpResponse(400, "text/plain", 584 "None of export, input, or output requested." 585 )) 586 } 587 588 if (identical(format, "json")) { 589 content <- toJSON(values, pretty = TRUE) 590 httpResponse(200, "application/json", content) 591 592 } else if (identical(format, "rds")) { 593 tmpfile <- tempfile("shinytest", fileext = ".rds") 594 saveRDS(values, tmpfile) 595 on.exit(unlink(tmpfile), add = TRUE) 596 597 content <- readBin(tmpfile, "raw", n = file.info(tmpfile)$size) 598 httpResponse(200, "application/octet-stream", content) 599 600 } else { 601 httpResponse(400, "text/plain", paste("Invalid format requested:", format)) 602 } 603 } 604 ) 605 }, 606 607 # Get the snapshotPreprocessOutput function for an output name. If no preprocess 608 # function has been set, return the identity function. 609 getSnapshotPreprocessOutput = function(name) { 610 fun <- attr(private$.outputs[[name]], "snapshotPreprocess", exact = TRUE) 611 fun %||% identity 612 }, 613 614 # Get the snapshotPreprocessInput function for an input name. If no preprocess 615 # function has been set, return the identity function. 616 getSnapshotPreprocessInput = function(name) { 617 fun <- private$.input$getMeta(name, "shiny.snapshot.preprocess") 618 fun %||% identity 619 }, 620 621 # See cycleStartAction 622 startCycle = function() { 623 # TODO: This should check for busyCount == 0L, and remove the checks from 624 # the call sites 625 if (private$cycleStartActionQueue$size() > 0) { 626 head <- private$cycleStartActionQueue$remove() 627 628 # After we execute the current cycleStartAction (head), there may be 629 # more items left on the queue. If the current busyCount > 0, then that 630 # means an async task is running; whenever that task finishes, it will 631 # decrement the busyCount back to 0 and a startCycle will then be 632 # scheduled. But if the current busyCount is 0, it means that either 633 # busyCount was incremented and then decremented; OR that running head() 634 # never touched busyCount (one example of the latter is that an input 635 # changed that didn't actually cause any observers to be invalidated, 636 # i.e. an input that's used in the body of an observeEvent). Because of 637 # the possibility of the latter case, we need to conditionally schedule 638 # a startCycle ourselves to ensure that the remaining queue items get 639 # processed. 640 # 641 # Since we can't actually tell whether head() increment and decremented 642 # busyCount, it's possible we're calling startCycle spuriously; that's 643 # OK, it's essentially a no-op in that case. 644 on.exit({ 645 if (private$busyCount == 0L && private$cycleStartActionQueue$size() > 0L) { 646 later::later(function() { 647 if (private$busyCount == 0L) { 648 private$startCycle() 649 } 650 }) 651 } 652 }, add = TRUE) 653 654 head() 655 } 656 657 invisible() 658 } 659 ), 660 public = list( 661 restoreContext = NULL, 662 progressStack = 'Stack', # Stack of progress objects 663 input = 'reactivevalues', # Externally-usable S3 wrapper object for .input 664 output = 'ANY', # Externally-usable S3 wrapper object for .outputs 665 clientData = 'reactivevalues', # Externally-usable S3 wrapper object for .clientData 666 token = 'character', # Used to identify this instance in URLs 667 files = 'Map', # For keeping track of files sent to client 668 downloads = 'Map', 669 closed = logical(0), 670 request = 'ANY', # Websocket request object 671 singletons = character(0), # Tracks singleton HTML fragments sent to the page 672 userData = 'environment', 673 cache = NULL, # A cache object used in the session 674 user = NULL, 675 groups = NULL, 676 options = NULL, # For session-specific shinyOptions() 677 678 initialize = function(websocket) { 679 private$websocket <- websocket 680 self$closed <- FALSE 681 # TODO: Put file upload context in user/app-specific dir if possible 682 683 private$inputMessageQueue <- fastmap::fastqueue() 684 private$cycleStartActionQueue <- fastmap::fastqueue() 685 private$invalidatedOutputValues <- Map$new() 686 private$invalidatedOutputErrors <- Map$new() 687 private$fileUploadContext <- FileUploadContext$new() 688 private$closedCallbacks <- Callbacks$new() 689 private$flushCallbacks <- Callbacks$new() 690 private$flushedCallbacks <- Callbacks$new() 691 private$inputReceivedCallbacks <- Callbacks$new() 692 private$.input <- ReactiveValues$new(dedupe = FALSE, label = "input") 693 private$.clientData <- ReactiveValues$new(dedupe = TRUE, label = "clientData") 694 private$timingRecorder <- ShinyServerTimingRecorder$new() 695 self$progressStack <- fastmap::faststack() 696 self$files <- Map$new() 697 self$downloads <- Map$new() 698 self$userData <- new.env(parent = emptyenv()) 699 700 self$input <- .createReactiveValues(private$.input, readonly=TRUE) 701 self$clientData <- .createReactiveValues(private$.clientData, readonly=TRUE) 702 703 self$output <- .createOutputWriter(self) 704 705 self$token <- createUniqueId(16) 706 private$.outputs <- list() 707 private$.outputOptions <- list() 708 709 # Copy app-level options 710 self$options <- getCurrentAppState()$options 711 712 self$cache <- cachem::cache_mem(max_size = 200 * 1024^2) 713 714 private$bookmarkCallbacks <- Callbacks$new() 715 private$bookmarkedCallbacks <- Callbacks$new() 716 private$restoreCallbacks <- Callbacks$new() 717 private$restoredCallbacks <- Callbacks$new() 718 719 private$testMode <- getShinyOption("testmode", default = FALSE) 720 private$enableTestSnapshot() 721 722 # This `withReactiveDomain` is used only to satisfy the reactlog, so that 723 # it knows to scope this reactiveVal to this session. 724 # https://github.com/rstudio/shiny/pull/3182 725 withReactiveDomain(self, 726 private$currentThemeDependency <- reactiveVal(0, label = "Theme Counter") 727 ) 728 729 private$registerSessionEndCallbacks() 730 731 if (!is.null(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)) { 732 try({ 733 creds <- safeFromJSON(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS) 734 self$user <- creds$user 735 self$groups <- creds$groups 736 }, silent=FALSE) 737 } 738 739 # session$request should throw an error if httpuv doesn't have 740 # websocket$request, but don't throw it until a caller actually 741 # tries to access session$request 742 delayedAssign('request', websocket$request, assign.env = self) 743 744 private$sendMessage( 745 config = list( 746 workerId = workerId(), 747 sessionId = self$token, 748 user = self$user 749 ) 750 ) 751 }, 752 startTiming = function(guid) { 753 if (!is.null(guid)) { 754 private$timingRecorder$start(guid) 755 self$onFlush(private$timingRecorder$stop) 756 } 757 }, 758 requestFlush = function() { 759 appsNeedingFlush$set(self$token, self) 760 }, 761 .scheduleTask = function(millis, callback) { 762 scheduleTask(millis, callback) 763 }, 764 .now = function(){ 765 getTimeMs() 766 }, 767 rootScope = function() { 768 self 769 }, 770 makeScope = function(namespace) { 771 ns <- NS(namespace) 772 773 # Private items for this scope. Can't be part of the scope object because 774 # `$<-.session_proxy` doesn't allow assignment on overidden names. 775 bookmarkCallbacks <- Callbacks$new() 776 restoreCallbacks <- Callbacks$new() 777 restoredCallbacks <- Callbacks$new() 778 bookmarkExclude <- character(0) 779 780 scope <- createSessionProxy(self, 781 input = .createReactiveValues(private$.input, readonly = TRUE, ns = ns), 782 output = .createOutputWriter(self, ns = ns), 783 sendInputMessage = function(inputId, message) { 784 .subset2(self, "sendInputMessage")(ns(inputId), message) 785 }, 786 registerDataObj = function(name, data, filterFunc) { 787 .subset2(self, "registerDataObj")(ns(name), data, filterFunc) 788 }, 789 ns = ns, 790 makeScope = function(namespace) { 791 self$makeScope(ns(namespace)) 792 }, 793 794 setBookmarkExclude = function(names) { 795 bookmarkExclude <<- names 796 }, 797 getBookmarkExclude = function() { 798 bookmarkExclude 799 }, 800 onBookmark = function(fun) { 801 if (!is.function(fun) || length(fun) != 1) { 802 stop("`fun` must be a function that takes one argument") 803 } 804 bookmarkCallbacks$register(fun) 805 }, 806 onBookmarked = function(fun) { 807 stop("onBookmarked() can't be used in a module.") 808 }, 809 onRestore = function(fun) { 810 if (!is.function(fun) || length(fun) != 1) { 811 stop("`fun` must be a function that takes one argument") 812 } 813 restoreCallbacks$register(fun) 814 }, 815 onRestored = function(fun) { 816 if (!is.function(fun) || length(fun) != 1) { 817 stop("`fun` must be a function that takes one argument") 818 } 819 restoredCallbacks$register(fun) 820 }, 821 exportTestValues = function(..., quoted_ = FALSE, env_ = parent.frame()) { 822 if (quoted_) { 823 dots <- list(...) 824 } else { 825 dots <- eval(substitute(alist(...))) 826 } 827 828 if (anyUnnamed(dots)) 829 stop("exportTestValues: all arguments must be named.") 830 831 names(dots) <- ns(names(dots)) 832 833 do.call( 834 .subset2(self, "exportTestValues"), 835 c(dots, quoted_ = TRUE, env_ = env_), 836 quote = TRUE 837 ) 838 } 839 ) 840 841 # Given a char vector, return a logical vector indicating which of those 842 # strings are names of things in the namespace. 843 filterNamespace <- function(x) { 844 nsString <- paste0(namespace, ns.sep) 845 substr(x, 1, nchar(nsString)) == nsString 846 } 847 848 # Given a char vector of namespaced names, return a char vector of corresponding 849 # names with namespace prefix removed. 850 unNamespace <- function(x) { 851 if (!all(filterNamespace(x))) { 852 stop("x contains strings(s) that do not have namespace prefix ", namespace) 853 } 854 855 nsString <- paste0(namespace, ns.sep) 856 substring(x, nchar(nsString) + 1) 857 } 858 859 # Given a restore state object (a list), return a modified version that's 860 # scoped to this namespace. 861 scopeRestoreState <- function(state) { 862 # State is a list. We need to copy and transform some things for the 863 # scope. 864 scopeState <- state 865 # `values` is an environment and we don't want to modify the original. 866 scopeState$values <- new.env(parent = emptyenv()) 867 868 # Keep only inputs that are in the scope, and rename them 869 scopeState$input <- scopeState$input[filterNamespace(names(scopeState$input))] 870 names(scopeState$input) <- unNamespace(names(scopeState$input)) 871 872 # Same for values. This is an environment so we have to handle a little 873 # differently. 874 origNames <- names(state$values) 875 origNames <- origNames[filterNamespace(origNames)] 876 lapply(origNames, function(origName) { 877 scopedName <- unNamespace(origName) 878 scopeState$values[[scopedName]] <- state$values[[origName]] 879 }) 880 881 if (!is.null(state$dir)) { 882 dir <- file.path(state$dir, namespace) 883 if (dirExists(dir)) 884 scopeState$dir <- dir 885 } 886 887 scopeState 888 } 889 890 # When scope is created, register these bookmarking callbacks on the main 891 # session object. They will invoke the scope's own callbacks, if any are 892 # present. 893 self$onBookmark(function(state) { 894 # Exit if no user-defined callbacks. 895 if (bookmarkCallbacks$count() == 0) 896 return() 897 898 scopeState <- ShinySaveState$new(scope$input, scope$getBookmarkExclude()) 899 900 # Create subdir for this scope 901 if (!is.null(state$dir)) { 902 scopeState$dir <- file.path(state$dir, namespace) 903 if (!dirExists(scopeState$dir)) { 904 res <- dir.create(scopeState$dir) 905 if (res == FALSE) { 906 stop("Error creating subdirectory for scope ", namespace) 907 } 908 } 909 } 910 911 # Invoke the callback on the scopeState object 912 bookmarkCallbacks$invoke(scopeState) 913 914 # Copy `values` from scopeState to state, adding namespace 915 if (length(scopeState$values) != 0) { 916 if (anyUnnamed(scopeState$values)) { 917 stop("All scope values in must be named.") 918 } 919 920 lapply(names(scopeState$values), function(origName) { 921 scopedName <- ns(origName) 922 state$values[[scopedName]] <- scopeState$values[[origName]] 923 }) 924 } 925 }) 926 927 self$onRestore(function(state) { 928 # Exit if no user-defined callbacks. 929 if (restoreCallbacks$count() == 0) 930 return() 931 932 scopeState <- scopeRestoreState(state) 933 # Invoke user callbacks 934 restoreCallbacks$invoke(scopeState) 935 }) 936 937 self$onRestored(function(state) { 938 # Exit if no user-defined callbacks. 939 if (restoredCallbacks$count() == 0) 940 return() 941 942 scopeState <- scopeRestoreState(state) 943 # Invoke user callbacks 944 restoredCallbacks$invoke(scopeState) 945 }) 946 947 # Returns the excluded names with the scope's ns prefix on them. 948 private$registerBookmarkExclude(function() { 949 excluded <- scope$getBookmarkExclude() 950 ns(excluded) 951 }) 952 953 scope 954 }, 955 ns = function(id) { 956 NS(NULL, id) 957 }, 958 959 # Freeze a value until the flush cycle completes 960 freezeValue = function(x, name) { 961 if (!is.reactivevalues(x)) 962 stop("x must be a reactivevalues object") 963 964 impl <- .subset2(x, 'impl') 965 key <- .subset2(x, 'ns')(name) 966 967 is_input <- identical(impl, private$.input) 968 969 # There's no good reason for us not to just do force=TRUE, except that we 970 # know this fixes problems for freezeReactiveValue(input) but we don't 971 # currently even know what you would use freezeReactiveValue(rv) for. In 972 # the spirit of not breaking things we don't understand, we're making as 973 # targeted a fix as possible, while emitting a deprecation warning (below) 974 # that should help us gather more data about the other case. 975 impl$freeze(key, invalidate = is_input) 976 977 if (is_input) { 978 # Notify the client that this input was frozen. The client will ensure 979 # that the next time it sees a value for that input, even if the value 980 # has not changed from the last known value of that input, it will be 981 # sent to the server anyway. 982 private$sendMessage(frozen = list( 983 ids = list(key) 984 )) 985 } else { 986 if (getOption("shiny.deprecation.messages", TRUE) && getOption("shiny.deprecation.messages.freeze", TRUE)) { 987 rlang::warn( 988 "Support for calling freezeReactiveValue() with non-`input` reactiveValues objects is soft-deprecated, and may be removed in a future version of Shiny. (See https://github.com/rstudio/shiny/issues/3063)", 989 .frequency = "once", .frequency_id = "freezeReactiveValue") 990 } 991 } 992 993 self$onFlushed(function() impl$thaw(key)) 994 }, 995 996 onSessionEnded = function(sessionEndedCallback) { 997 "Registers the given callback to be invoked when the session is closed 998 (i.e. the connection to the client has been severed). The return value 999 is a function which unregisters the callback. If multiple callbacks are 1000 registered, the order in which they are invoked is not guaranteed." 1001 return(private$closedCallbacks$register(sessionEndedCallback)) 1002 }, 1003 onEnded = function(endedCallback) { 1004 "Synonym for onSessionEnded" 1005 return(self$onSessionEnded(endedCallback)) 1006 }, 1007 onInputReceived = function(callback) { 1008 "Registers the given callback to be invoked when the session receives 1009 new data from the client." 1010 return(private$inputReceivedCallbacks$register(callback)) 1011 }, 1012 unhandledError = function(e) { 1013 self$close() 1014 }, 1015 close = function() { 1016 if (!self$closed) { 1017 private$websocket$close() 1018 } 1019 }, 1020 wsClosed = function() { 1021 self$closed <- TRUE 1022 for (output in private$.outputs) { 1023 output$suspend() 1024 } 1025 # ..stacktraceon matches with the top-level ..stacktraceoff.. 1026 withReactiveDomain(self, { 1027 private$closedCallbacks$invoke(onError = printError, ..stacktraceon = TRUE) 1028 }) 1029 }, 1030 isClosed = function() { 1031 return(self$closed) 1032 }, 1033 isEnded = function() { 1034 return(self$isClosed()) 1035 }, 1036 setShowcase = function(value) { 1037 private$showcase <- !is.null(value) && as.logical(value) 1038 }, 1039 1040 allowReconnect = function(value) { 1041 if (!(identical(value, TRUE) || identical(value, FALSE) || identical(value, "force"))) { 1042 stop('value must be TRUE, FALSE, or "force"') 1043 } 1044 private$write(toJSON(list(allowReconnect = value))) 1045 }, 1046 1047 defineOutput = function(name, func, label) { 1048 "Binds an output generating function to this name. The function can either 1049 take no parameters, or have named parameters for \\code{name} and 1050 \\code{shinysession} (in the future this list may expand, so it is a good idea 1051 to also include \\code{...} in your function signature)." 1052 1053 # jcheng 08/31/2012: User submitted an example of a dynamically calculated 1054 # name not working unless name was eagerly evaluated. Yikes! 1055 force(name) 1056 1057 # If overwriting an output object, destroy the previous copy of it 1058 if (!is.null(private$.outputs[[name]])) { 1059 private$.outputs[[name]]$destroy() 1060 } 1061 1062 if (is.null(func)) { 1063 # If func is null, give it an "empty" output function so it can go 1064 # through the logic below. If we simply returned at this point, the 1065 # previous output (if any) would continue to show in the client. 1066 func <- missingOutput 1067 } 1068 1069 if (is.function(func)) { 1070 # Extract any output attributes attached to the render function. These 1071 # will be attached to the observer after it's created. 1072 outputAttrs <- attr(func, "outputAttrs", TRUE) 1073 1074 # Save this for getOutput purposes 1075 outputAttrs$renderFunc <- func 1076 1077 funcFormals <- formals(func) 1078 # ..stacktraceon matches with the top-level ..stacktraceoff.., because 1079 # the observer we set up below has ..stacktraceon=FALSE 1080 func <- wrapFunctionLabel(func, paste0("output$", name), ..stacktraceon = TRUE) 1081 if (length(funcFormals) != 0) { 1082 orig <- func 1083 func <- function() { 1084 orig(name=name, shinysession=self) 1085 } 1086 } 1087 1088 # Preserve source reference and file information when formatting the 1089 # label for display in the reactive graph 1090 srcref <- attr(label, "srcref") 1091 srcfile <- attr(label, "srcfile") 1092 label <- sprintf('output$%s', name) 1093 attr(label, "srcref") <- srcref 1094 attr(label, "srcfile") <- srcfile 1095 1096 obs <- observe(..stacktraceon = FALSE, { 1097 1098 private$sendMessage(recalculating = list( 1099 name = name, status = 'recalculating' 1100 )) 1101 1102 # This shinyCallingHandlers should maybe be at a higher level, 1103 # to include the $then/$catch calls below? 1104 hybrid_chain( 1105 hybrid_chain( 1106 { 1107 private$withCurrentOutput(name, { 1108 shinyCallingHandlers(func()) 1109 }) 1110 }, 1111 catch = function(cond) { 1112 if (inherits(cond, "shiny.custom.error")) { 1113 if (isTRUE(getOption("show.error.messages"))) printError(cond) 1114 structure(list(), class = "try-error", condition = cond) 1115 } else if (inherits(cond, "shiny.output.cancel")) { 1116 structure(list(), class = "cancel-output") 1117 } else if (inherits(cond, "shiny.silent.error")) { 1118 # Don't let shiny.silent.error go through the normal stop 1119 # path of try, because we don't want it to print. But we 1120 # do want to try to return the same looking result so that 1121 # the code below can send the error to the browser. 1122 structure(list(), class = "try-error", condition = cond) 1123 } else { 1124 if (isTRUE(getOption("show.error.messages"))) printError(cond) 1125 if (getOption("shiny.sanitize.errors", FALSE)) { 1126 cond <- simpleError(paste("An error has occurred. Check your", 1127 "logs or contact the app author for", 1128 "clarification.")) 1129 } 1130 invisible(structure(list(), class = "try-error", condition = cond)) 1131 } 1132 } 1133 ), 1134 function(value) { 1135 # Needed so that Shiny knows to flush the outputs. Even if no 1136 # outputs/errors are queued, it's necessary to flush so that the 1137 # client knows that progress is over. 1138 self$requestFlush() 1139 1140 private$sendMessage(recalculating = list( 1141 name = name, status = 'recalculated' 1142 )) 1143 1144 if (inherits(value, "cancel-output")) { 1145 return() 1146 } 1147 1148 private$invalidatedOutputErrors$remove(name) 1149 private$invalidatedOutputValues$remove(name) 1150 1151 if (inherits(value, 'try-error')) { 1152 cond <- attr(value, 'condition') 1153 type <- setdiff(class(cond), c('simpleError', 'error', 'condition')) 1154 private$invalidatedOutputErrors$set( 1155 name, 1156 list(message = cond$message, 1157 call = utils::capture.output(print(cond$call)), 1158 type = if (length(type)) type)) 1159 } 1160 else 1161 private$invalidatedOutputValues$set(name, value) 1162 } 1163 ) 1164 }, suspended=private$shouldSuspend(name), label=label) 1165 1166 # If any output attributes were added to the render function attach 1167 # them to observer. 1168 lapply(names(outputAttrs), function(name) { 1169 attr(obs, name) <- outputAttrs[[name]] 1170 }) 1171 1172 obs$onInvalidate(function() { 1173 self$showProgress(name) 1174 }) 1175 1176 private$.outputs[[name]] <- obs 1177 if (is.null(private$.outputOptions[[name]])) 1178 private$.outputOptions[[name]] <- list() 1179 } 1180 else { 1181 rlang::abort(c( 1182 paste0("Unexpected ", class(func)[[1]], " object for output$", name), 1183 i = "Did you forget to use a render function?" 1184 )) 1185 } 1186 }, 1187 getOutput = function(name) { 1188 attr(private$.outputs[[name]], "renderFunc", exact = TRUE) 1189 }, 1190 flushOutput = function() { 1191 if (private$busyCount > 0) 1192 return() 1193 1194 appsNeedingFlush$remove(self$token) 1195 1196 if (self$isClosed()) 1197 return() 1198 1199 # This is the only place in the session where the restoreContext is 1200 # flushed. 1201 if (!is.null(self$restoreContext)) 1202 self$restoreContext$flushPending() 1203 1204 # Return TRUE if there's any stuff to send to the client. 1205 hasPendingUpdates <- function() { 1206 # Even though progressKeys isn't sent to the client, we use it in this 1207 # check. This is because if it is non-empty, sending `values` to the 1208 # client tells it that the flushReact loop is finished, and the client 1209 # then knows to stop showing progress. 1210 return( 1211 length(private$progressKeys) != 0 || 1212 length(private$invalidatedOutputValues) != 0 || 1213 length(private$invalidatedOutputErrors) != 0 || 1214 private$inputMessageQueue$size() != 0 1215 ) 1216 } 1217 1218 withReactiveDomain(self, { 1219 # ..stacktraceon matches with the top-level ..stacktraceoff.. 1220 private$flushCallbacks$invoke(..stacktraceon = TRUE) 1221 1222 # Schedule execution of onFlushed callbacks 1223 on.exit({ 1224 withReactiveDomain(self, { 1225 # ..stacktraceon matches with the top-level ..stacktraceoff.. 1226 private$flushedCallbacks$invoke(..stacktraceon = TRUE) 1227 }) 1228 }, add = TRUE) 1229 1230 if (!hasPendingUpdates()) { 1231 # Normally, if there are no updates, simply return without sending 1232 # anything to the client. But if we are in test mode, we still want to 1233 # send a message with blank `values`, so that the client knows that 1234 # any changed inputs have been received by the server and processed. 1235 if (isTRUE(private$testMode)) { 1236 private$sendMessage( values = list() ) 1237 } 1238 return(invisible()) 1239 } 1240 1241 private$progressKeys <- character(0) 1242 values <- as.list(private$invalidatedOutputValues) 1243 private$invalidatedOutputValues <- Map$new() 1244 errors <- as.list(private$invalidatedOutputErrors) 1245 private$invalidatedOutputErrors <- Map$new() 1246 inputMessages <- private$inputMessageQueue$as_list() 1247 private$inputMessageQueue$reset() 1248 1249 if (isTRUE(private$testMode)) { 1250 private$storeOutputValues(mergeVectors(values, errors)) 1251 } 1252 1253 private$sendMessage( 1254 errors = errors, 1255 values = values, 1256 inputMessages = inputMessages 1257 ) 1258 }) 1259 }, 1260 # Schedule an action to execute not (necessarily) now, but when no observers 1261 # that belong to this session are busy executing. This helps prevent (but 1262 # does not guarantee) inputs and reactive values from changing underneath 1263 # async observers as they run. 1264 cycleStartAction = function(callback) { 1265 private$cycleStartActionQueue$add(callback) 1266 # If no observers are running in this session, we're safe to proceed. 1267 # Otherwise, startCycle() will be called later, via decrementBusyCount(). 1268 if (private$busyCount == 0L) { 1269 private$startCycle() 1270 } 1271 }, 1272 showProgress = function(id) { 1273 'Send a message to the client that recalculation of the output identified 1274 by \\code{id} is in progress. There is currently no mechanism for 1275 explicitly turning off progress for an output component; instead, all 1276 progress is implicitly turned off when flushOutput is next called.' 1277 1278 # If app is already closed, be sure not to show progress, otherwise we 1279 # will get an error because of the closed websocket 1280 if (self$closed) 1281 return() 1282 1283 if (id %in% private$progressKeys) 1284 return() 1285 1286 private$progressKeys <- c(private$progressKeys, id) 1287 1288 self$sendProgress('binding', list(id = id)) 1289 }, 1290 sendProgress = function(type, message) { 1291 private$sendMessage( 1292 progress = list(type = type, message = message) 1293 ) 1294 }, 1295 sendNotification = function(type, message) { 1296 private$sendMessage( 1297 notification = list(type = type, message = message) 1298 ) 1299 }, 1300 sendModal = function(type, message) { 1301 private$sendMessage( 1302 modal = list(type = type, message = message) 1303 ) 1304 }, 1305 1306 getCurrentTheme = function() { 1307 private$currentThemeDependency() 1308 getCurrentTheme() 1309 }, 1310 1311 setCurrentTheme = function(theme) { 1312 # This function does three things: (1) sets theme as the current 1313 # bootstrapTheme, (2) re-executes any registered theme dependencies, and 1314 # (3) sends the resulting dependencies to the client. 1315 1316 if (!is_bs_theme(theme)) { 1317 stop("`session$setCurrentTheme()` expects a `bslib::bs_theme()` object.", call. = FALSE) 1318 } 1319 1320 # Switching Bootstrap versions has weird & complex consequences 1321 # for the JS logic, so we forbid it 1322 current_version <- bslib::theme_version(getCurrentTheme()) 1323 next_version <- bslib::theme_version(theme) 1324 if (!identical(current_version, next_version)) { 1325 stop( 1326 "session$setCurrentTheme() cannot be used to change the Bootstrap version ", 1327 "from ", current_version, " to ", next_version, ". ", 1328 "Try using `bs_theme(version = ", next_version, ")` for initial theme.", 1329 call. = FALSE 1330 ) 1331 } 1332 1333 # Note that this will automatically scope to the session. 1334 setCurrentTheme(theme) 1335 1336 # Invalidate 1337 private$currentThemeDependency(isolate(private$currentThemeDependency()) + 1) 1338 1339 # Call any theme dependency functions and make sure we get a list of deps back 1340 funcs <- getShinyOption("themeDependencyFuncs", default = list()) 1341 deps <- lapply(funcs, function(func) { 1342 deps <- func(theme) 1343 if (length(deps) == 0) return(NULL) 1344 if (inherits(deps, "html_dependency")) return(list(deps)) 1345 is_dep <- vapply(deps, inherits, logical(1), "html_dependency") 1346 if (all(is_dep)) return(deps) 1347 stop("All registerThemeDependency() functions must yield htmlDependency() object(s)", call. = FALSE) 1348 }) 1349 # Work with a flat list of dependencies 1350 deps <- unlist(dropNulls(deps), recursive = FALSE) 1351 # Add a special flag to let Shiny.renderDependencies() know that, even 1352 # though we've already rendered the dependency, that we need to re-render 1353 # the stylesheets 1354 deps <- lapply(deps, function(dep) { 1355 dep$restyle <- TRUE 1356 dep 1357 }) 1358 1359 # Send any dependencies to be re-rendered 1360 if (length(deps)) { 1361 insertUI(selector = "body", where = "afterEnd", ui = tagList(deps)) 1362 } 1363 }, 1364 1365 dispatch = function(msg) { 1366 method <- paste('@', msg$method, sep='') 1367 func <- try(self[[method]], silent = TRUE) 1368 if (inherits(func, 'try-error')) { 1369 private$sendErrorResponse(msg, paste('Unknown method', msg$method)) 1370 } 1371 1372 value <- try(do.call(func, as.list(append(msg$args, msg$blobs))), 1373 silent=TRUE) 1374 if (inherits(value, 'try-error')) { 1375 private$sendErrorResponse(msg, conditionMessage(attr(value, 'condition'))) 1376 } 1377 else { 1378 private$sendResponse(msg, value) 1379 } 1380 }, 1381 sendBinaryMessage = function(type, message) { 1382 typeBytes <- charToRaw(type) 1383 if (length(typeBytes) > 255) { 1384 stop("'type' argument is too long") 1385 } 1386 private$write(c(as.raw(length(typeBytes)), typeBytes, message)) 1387 }, 1388 sendCustomMessage = function(type, message) { 1389 data <- list() 1390 data[[type]] <- message 1391 private$sendMessage(custom = data) 1392 }, 1393 sendInputMessage = function(inputId, message) { 1394 data <- list(id = inputId, message = message) 1395 1396 private$inputMessageQueue$add(data) 1397 # Needed so that Shiny knows to actually flush the input message queue 1398 self$requestFlush() 1399 }, 1400 onFlush = function(flushCallback, once = TRUE) { 1401 if (!isTRUE(once)) { 1402 return(private$flushCallbacks$register(flushCallback)) 1403 } else { 1404 dereg <- private$flushCallbacks$register(function() { 1405 dereg() 1406 flushCallback() 1407 }) 1408 return(dereg) 1409 } 1410 }, 1411 onFlushed = function(flushedCallback, once = TRUE) { 1412 if (!isTRUE(once)) { 1413 return(private$flushedCallbacks$register(flushedCallback)) 1414 } else { 1415 dereg <- private$flushedCallbacks$register(function() { 1416 dereg() 1417 flushedCallback() 1418 }) 1419 return(dereg) 1420 } 1421 }, 1422 1423 getCurrentOutputInfo = function() { 1424 name <- private$currentOutputName 1425 if (is.null(name)) { 1426 return(NULL) 1427 } 1428 1429 if (!is.null(private$outputInfo[[name]])) { 1430 return(private$outputInfo[[name]]) 1431 } 1432 1433 # The following code will only run the first time this function has been 1434 # called for this output. 1435 1436 tmp_info <- list(name = name) 1437 1438 # cd_names() returns names of all items in clientData, without taking a 1439 # reactive dependency. It is a function and it's memoized, so that we do 1440 # the (relatively) expensive isolate(names(...)) call only when needed, 1441 # and at most one time in this function. 1442 cd_names <- isolate(names(self$clientData)) 1443 1444 # parseCssColors() currently errors out if you hand it any NAs 1445 # This'll make sure we're always working with a string (and if 1446 # that string isn't a valid CSS color, will return NA) 1447 # https://github.com/rstudio/htmltools/issues/161 1448 parse_css_colors <- function(x) { 1449 htmltools::parseCssColors(x %||% "", mustWork = FALSE) 1450 } 1451 1452 1453 # This function conditionally adds an item to tmp_info (for "width", it 1454 # would create tmp_info$width). It is added _if_ there is an entry in 1455 # clientData like "output_foo_width", where "foo" is the name of the 1456 # output. The first time `tmp_info$width()` is called, it creates a 1457 # reactive expression that reads `clientData$output_foo_width`, saves it, 1458 # then invokes that reactive. On subsequent calls, the reactive already 1459 # exists, so it simply invokes it. 1460 # 1461 # The reason it creates the reactive only on first use is so that it 1462 # doesn't spuriously create reactives. 1463 # 1464 # This function essentially generalizes the code below for names other 1465 # than just "width". 1466 # 1467 # width_name <- paste0("output_", name, "_width") 1468 # if (width_name %in% cd_names()) { 1469 # width_r <- NULL 1470 # tmp_info$width <- function() { 1471 # if (is.null(width_r)) { 1472 # width_r <<- reactive({ 1473 # parse_css_colors(self$clientData[[width_name]]) 1474 # }) 1475 # } 1476 # 1477 # width_r() 1478 # } 1479 # } 1480 add_conditional_reactive <- function(prop, wrapfun = identity) { 1481 force(prop) 1482 force(wrapfun) 1483 1484 prop_name <- paste0("output_", name, "_", prop) 1485 1486 # Only add tmp_info$width if clientData has "output_foo_width" 1487 if (prop_name %in% cd_names) { 1488 r <- NULL 1489 1490 # Turn it into a function that creates a reactive on the first 1491 # invocation of getCurrentOutputInfo()$width() and saves it; future 1492 # invocations of getCurrentOutputInfo()$width() use the existing 1493 # reactive and save it. 1494 tmp_info[[prop]] <<- function() { 1495 if (is.null(r)) { 1496 r <<- reactive(label = prop_name, { 1497 wrapfun(self$clientData[[prop_name]]) 1498 }) 1499 } 1500 1501 r() 1502 } 1503 } 1504 } 1505 1506 1507 # Note that all the following clientData values (which are reactiveValues) 1508 # are wrapped in reactive() so that users can take a dependency on 1509 # particular output info (i.e., just depend on width/height, or just 1510 # depend on bg, fg, etc). To put it another way, if getCurrentOutputInfo() 1511 # simply returned a list of values from self$clientData, than anything 1512 # that calls getCurrentOutputInfo() would take a reactive dependency on 1513 # all of these values. 1514 add_conditional_reactive("width") 1515 add_conditional_reactive("height") 1516 add_conditional_reactive("bg", parse_css_colors) 1517 add_conditional_reactive("fg", parse_css_colors) 1518 add_conditional_reactive("accent", parse_css_colors) 1519 add_conditional_reactive("font") 1520 1521 private$outputInfo[[name]] <- tmp_info 1522 private$outputInfo[[name]] 1523 }, 1524 1525 createBookmarkObservers = function() { 1526 # This registers observers for bookmarking to work. 1527 1528 # Get bookmarking config 1529 store <- getShinyOption("bookmarkStore", default = "disable") 1530 if (store == "disable") 1531 return() 1532 1533 # Warn if trying to enable save-to-server bookmarking on a version of SS, 1534 # SSP, or Connect that doesn't support it. 1535 if (store == "server" && inShinyServer() && 1536 is.null(getShinyOption("save.interface", default = NULL))) 1537 { 1538 showNotification( 1539 "This app tried to enable saved-to-server bookmarking, but it is not supported by the hosting environment.", 1540 duration = NULL, type = "warning", session = self 1541 ) 1542 return() 1543 } 1544 1545 withReactiveDomain(self, { 1546 # This observer fires when the bookmark button is clicked. 1547 observeEvent(self$input[["._bookmark_"]], { 1548 self$doBookmark() 1549 }) 1550 1551 # If there was an error initializing the current restore context, show 1552 # notification in the client. 1553 observe({ 1554 rc <- getCurrentRestoreContext() 1555 if (!is.null(rc$initErrorMessage)) { 1556 showNotification( 1557 paste("Error in RestoreContext initialization:", rc$initErrorMessage), 1558 duration = NULL, type = "error" 1559 ) 1560 } 1561 }) 1562 1563 # Run the onRestore function at the beginning of the flush cycle, but after 1564 # the server function has been executed. 1565 observe({ 1566 if (private$restoreCallbacks$count() > 0) { 1567 tryCatch( 1568 withLogErrors( 1569 isolate({ 1570 rc <- getCurrentRestoreContext() 1571 if (rc$active) { 1572 restoreState <- getCurrentRestoreContext()$asList() 1573 private$restoreCallbacks$invoke(restoreState) 1574 } 1575 }) 1576 ), 1577 error = function(e) { 1578 showNotification( 1579 paste0("Error calling onRestore callback: ", e$message), 1580 duration = NULL, type = "error" 1581 ) 1582 } 1583 ) 1584 } 1585 }, priority = 1000000) 1586 1587 # Run the onRestored function after the flush cycle completes and information 1588 # is sent to the client. 1589 self$onFlushed(function() { 1590 if (private$restoredCallbacks$count() > 0) { 1591 1592 tryCatch( 1593 withLogErrors( 1594 isolate({ 1595 rc <- getCurrentRestoreContext() 1596 if (rc$active) { 1597 restoreState <- getCurrentRestoreContext()$asList() 1598 private$restoredCallbacks$invoke(restoreState) 1599 } 1600 }) 1601 ), 1602 error = function(e) { 1603 msg <- paste0("Error calling onRestored callback: ", e$message) 1604 showNotification(msg, duration = NULL, type = "error") 1605 } 1606 ) 1607 } 1608 }) 1609 1610 }) # withReactiveDomain 1611 }, 1612 1613 setBookmarkExclude = function(names) { 1614 private$bookmarkExclude <- names 1615 }, 1616 getBookmarkExclude = function() { 1617 scopedExcludes <- lapply(private$getBookmarkExcludeFuns, function(f) f()) 1618 scopedExcludes <- unlist(scopedExcludes) 1619 1620 c(private$bookmarkExclude, scopedExcludes) 1621 }, 1622 1623 onBookmark = function(fun) { 1624 if (!is.function(fun) || length(fun) != 1) { 1625 stop("`fun` must be a function that takes one argument") 1626 } 1627 private$bookmarkCallbacks$register(fun) 1628 }, 1629 onBookmarked = function(fun) { 1630 if (!is.function(fun) || length(fun) != 1) { 1631 stop("`fun` must be a function that takes one argument") 1632 } 1633 private$bookmarkedCallbacks$register(fun) 1634 }, 1635 onRestore = function(fun) { 1636 if (!is.function(fun) || length(fun) != 1) { 1637 stop("`fun` must be a function that takes one argument") 1638 } 1639 private$restoreCallbacks$register(fun) 1640 }, 1641 onRestored = function(fun) { 1642 if (!is.function(fun) || length(fun) != 1) { 1643 stop("`fun` must be a function that takes one argument") 1644 } 1645 private$restoredCallbacks$register(fun) 1646 }, 1647 doBookmark = function() { 1648 # Get bookmarking store config 1649 store <- getShinyOption("bookmarkStore", default = "disable") 1650 if (store == "disable") 1651 return() 1652 1653 tryCatch( 1654 withLogErrors({ 1655 saveState <- ShinySaveState$new( 1656 input = self$input, 1657 exclude = self$getBookmarkExclude(), 1658 onSave = function(state) { 1659 private$bookmarkCallbacks$invoke(state) 1660 } 1661 ) 1662 1663 if (store == "server") { 1664 url <- saveShinySaveState(saveState) 1665 } else if (store == "url") { 1666 url <- encodeShinySaveState(saveState) 1667 } else { 1668 stop("Unknown store type: ", store) 1669 } 1670 1671 clientData <- self$clientData 1672 url <- paste0( 1673 clientData$url_protocol, "//", 1674 clientData$url_hostname, 1675 if (nzchar(clientData$url_port)) paste0(":", clientData$url_port), 1676 clientData$url_pathname, 1677 "?", url 1678 ) 1679 1680 1681 # If onBookmarked callback was provided, invoke it; if not call 1682 # the default. 1683 if (private$bookmarkedCallbacks$count() > 0) { 1684 private$bookmarkedCallbacks$invoke(url) 1685 } else { 1686 showBookmarkUrlModal(url) 1687 } 1688 }), 1689 error = function(e) { 1690 msg <- paste0("Error bookmarking state: ", e$message) 1691 showNotification(msg, duration = NULL, type = "error") 1692 } 1693 ) 1694 }, 1695 1696 exportTestValues = function(..., quoted_ = FALSE, env_ = parent.frame()) { 1697 # Get a named list of unevaluated expressions. 1698 if (quoted_) { 1699 dots <- list(...) 1700 } else { 1701 dots <- eval(substitute(alist(...))) 1702 } 1703 1704 if (anyUnnamed(dots)) 1705 stop("exportTestValues: all arguments must be named.") 1706 1707 # Create a named list where each item is a list with an expression and 1708 # environment in which to eval the expression. 1709 items <- lapply(dots, function(expr) { 1710 list(expr = expr, env = env_) 1711 }) 1712 1713 private$testExportExprs <- mergeVectors(private$testExportExprs, items) 1714 }, 1715 1716 getTestSnapshotUrl = function(input = TRUE, output = TRUE, export = TRUE, 1717 format = "json") { 1718 reqString <- function(group, value) { 1719 if (isTRUE(value)) 1720 paste0(group, "=1") 1721 else if (is.character(value)) 1722 paste0(group, "=", paste(value, collapse = ",")) 1723 else 1724 "" 1725 } 1726 paste( 1727 private$testSnapshotUrl, 1728 reqString("input", input), 1729 reqString("output", output), 1730 reqString("export", export), 1731 paste0("format=", format), 1732 sep = "&" 1733 ) 1734 }, 1735 1736 reactlog = function(logEntry) { 1737 # Use sendCustomMessage instead of sendMessage, because the handler in 1738 # shiny-showcase.js only has access to public API of the Shiny object. 1739 if (private$showcase) { 1740 srcref <- logEntry$srcref 1741 srcfile <- logEntry$srcfile 1742 if (!is.null(srcref) && !is.null(srcfile)) { 1743 # only send needed information, not all of reactlog info. 1744 self$sendCustomMessage("showcase-src", list(srcref = srcref, srcfile = srcfile)) 1745 } 1746 } 1747 }, 1748 reload = function() { 1749 private$sendMessage(reload = TRUE) 1750 }, 1751 sendInsertUI = function(selector, multiple, where, content) { 1752 private$sendMessage( 1753 `shiny-insert-ui` = list( 1754 selector = selector, 1755 multiple = multiple, 1756 where = where, 1757 content = content 1758 ) 1759 ) 1760 }, 1761 sendRemoveUI = function(selector, multiple) { 1762 private$sendMessage( 1763 `shiny-remove-ui` = list( 1764 selector = selector, 1765 multiple = multiple 1766 ) 1767 ) 1768 }, 1769 sendInsertTab = function(inputId, liTag, divTag, menuName, 1770 target, position, select) { 1771 private$sendMessage( 1772 `shiny-insert-tab` = list( 1773 inputId = inputId, 1774 liTag = liTag, 1775 divTag = divTag, 1776 menuName = menuName, 1777 target = target, 1778 position = position, 1779 select = select 1780 ) 1781 ) 1782 }, 1783 sendRemoveTab = function(inputId, target) { 1784 private$sendMessage( 1785 `shiny-remove-tab` = list( 1786 inputId = inputId, 1787 target = target 1788 ) 1789 ) 1790 }, 1791 sendChangeTabVisibility = function(inputId, target, type) { 1792 private$sendMessage( 1793 `shiny-change-tab-visibility` = list( 1794 inputId = inputId, 1795 target = target, 1796 type = type 1797 ) 1798 ) 1799 }, 1800 updateQueryString = function(queryString, mode) { 1801 private$sendMessage(updateQueryString = list( 1802 queryString = queryString, mode = mode)) 1803 }, 1804 resetBrush = function(brushId) { 1805 private$sendMessage( 1806 resetBrush = list( 1807 brushId = brushId 1808 ) 1809 ) 1810 }, 1811 1812 `@uploadInit` = function(fileInfos) { 1813 maxSize <- getOption('shiny.maxRequestSize', 5 * 1024 * 1024) 1814 fileInfos <- lapply(fileInfos, function(fi) { 1815 if (is.null(fi$type)) 1816 fi$type <- getContentType(fi$name) 1817 fi 1818 }) 1819 sizes <- sapply(fileInfos, function(fi){ fi$size }) 1820 if (maxSize > 0 && any(sizes > maxSize)) { 1821 stop("Maximum upload size exceeded") 1822 } 1823 1824 jobId <- private$fileUploadContext$createUploadOperation(fileInfos) 1825 return(list(jobId=jobId, 1826 uploadUrl=paste('session', self$token, 'upload', 1827 paste(jobId, "?w=", workerId(), sep=""), 1828 sep='/'))) 1829 }, 1830 `@uploadEnd` = function(jobId, inputId) { 1831 fileData <- private$fileUploadContext$getUploadOperation(jobId)$finish() 1832 private$.input$set(inputId, fileData) 1833 1834 setSerializer(inputId, serializerFileInput) 1835 snapshotPreprocessInput(inputId, snapshotPreprocessorFileInput) 1836 1837 invisible() 1838 }, 1839 # Provides a mechanism for handling direct HTTP requests that are posted 1840 # to the session (rather than going through the websocket) 1841 handleRequest = function(req) { 1842 # TODO: Turn off caching for the response 1843 subpath <- req$PATH_INFO 1844 1845 matches <- regmatches(subpath, 1846 regexec("^/([a-z]+)/([^?]*)", 1847 subpath, 1848 ignore.case=TRUE))[[1]] 1849 if (length(matches) == 0) 1850 return(httpResponse(400, 'text/html', '<h1>Bad Request</h1>')) 1851 1852 if (matches[2] == 'file') { 1853 savedFile <- self$files$get(URLdecode(matches[3])) 1854 if (is.null(savedFile)) 1855 return(httpResponse(404, 'text/html', '<h1>Not Found</h1>')) 1856 1857 return(httpResponse(200, savedFile$contentType, savedFile$data)) 1858 } 1859 1860 if (matches[2] == 'upload' && identical(req$REQUEST_METHOD, "POST")) { 1861 job <- private$fileUploadContext$getUploadOperation(matches[3]) 1862 if (!is.null(job)) { 1863 fileName <- req$HTTP_SHINY_FILE_NAME 1864 fileType <- req$HTTP_SHINY_FILE_TYPE 1865 fileSize <- req$CONTENT_LENGTH 1866 job$fileBegin() 1867 1868 reqInput <- req$rook.input 1869 while (length(buf <- reqInput$read(2^16)) > 0) 1870 job$fileChunk(buf) 1871 1872 job$fileEnd() 1873 1874 return(httpResponse(200, 'text/plain', 'OK')) 1875 } 1876 } 1877 1878 1879 if (matches[2] == 'download') { 1880 1881 # A bunch of ugliness here. Filenames can be dynamically generated by 1882 # the user code, so we don't know what they'll be in advance. But the 1883 # most reliable way to use non-ASCII filenames for downloads is to 1884 # put the actual filename in the URL. So we will start with URLs in 1885 # the form: 1886 # 1887 # /session/$TOKEN/download/$NAME 1888 # 1889 # When a request matching that pattern is received, we will calculate 1890 # the filename and see if it's non-ASCII; if so, we'll redirect to 1891 # 1892 # /session/$TOKEN/download/$NAME/$FILENAME 1893 # 1894 # And when that pattern is received, we will actually return the file. 1895 # Note that this means the filename and contents could be determined 1896 # a few moments apart from each other (an HTTP roundtrip basically), 1897 # hopefully that won't be enough to matter for anyone. 1898 1899 dlmatches <- regmatches(matches[3], 1900 regexec("^([^/]+)(/[^/]+)?$", 1901 matches[3]))[[1]] 1902 dlname <- URLdecode(dlmatches[2]) 1903 download <- self$downloads$get(dlname) 1904 if (is.null(download)) 1905 return(httpResponse(404, 'text/html', '<h1>Not Found</h1>')) 1906 1907 filename <- ifelse(is.function(download$filename), 1908 Context$new(getDefaultReactiveDomain(), '[download]')$run( 1909 download$filename 1910 ), 1911 download$filename) 1912 1913 # If the URL does not contain the filename, and the desired filename 1914 # contains non-ASCII characters, then do a redirect with the desired 1915 # name tacked on the end. 1916 if (dlmatches[3] == '' && grepl('[^ -~]', filename)) { 1917 1918 return(httpResponse(302, 'text/html', '<h1>Found</h1>', c( 1919 'Location' = sprintf('%s/%s', 1920 URLencode(dlname, TRUE), 1921 URLencode(filename, TRUE)), 1922 'Cache-Control' = 'no-cache'))) 1923 } 1924 1925 # Make temp file with the same extension as the user-visible filename. 1926 # If the extension is not used, some functions such as pdf() and zip() 1927 # may append the extension they expect, meaning the data we want will 1928 # be written to a file other than our temp file (e.g. file1231.zip 1929 # instead of file1231.zip). 1930 ext <- tools::file_ext(filename) 1931 if (nzchar(ext)) 1932 ext <- paste(".", ext, sep = "") 1933 tmpdata <- tempfile(fileext = ext) 1934 return(Context$new(getDefaultReactiveDomain(), '[download]')$run(function() { 1935 promises::with_promise_domain(reactivePromiseDomain(), { 1936 promises::with_promise_domain(createStackTracePromiseDomain(), { 1937 self$incrementBusyCount() 1938 hybrid_chain( 1939 # ..stacktraceon matches with the top-level ..stacktraceoff.. 1940 try(..stacktraceon..(download$func(tmpdata)), silent = TRUE), 1941 function(result) { 1942 if (inherits(result, 'try-error')) { 1943 unlink(tmpdata) 1944 stop(attr(result, "condition", exact = TRUE)) 1945 } 1946 if (!file.exists(tmpdata)) { 1947 # If no file was created, return a 404 1948 return(httpResponse(404, content = "404 Not found")) 1949 } 1950 return(httpResponse( 1951 200, 1952 download$contentType %||% getContentType(filename), 1953 # owned=TRUE means tmpdata will be deleted after response completes 1954 list(file=tmpdata, owned=TRUE), 1955 c( 1956 'Content-Disposition' = ifelse( 1957 dlmatches[3] == '', 1958 paste0( 1959 'attachment; filename="', 1960 gsub('(["\\\\])', '\\\\\\1', filename), 1961 '"' 1962 ), 1963 'attachment' 1964 ), 1965 'Cache-Control'='no-cache'))) 1966 }, 1967 finally = function() { 1968 self$decrementBusyCount() 1969 } 1970 ) 1971 }) 1972 }) 1973 })) 1974 } 1975 1976 if (matches[2] == 'dataobj') { 1977 # /session/$TOKEN/dataobj/$NAME 1978 dlmatches <- regmatches(matches[3], 1979 regexec("^([^/]+)(/[^/]+)?$", 1980 matches[3]))[[1]] 1981 dlname <- URLdecode(dlmatches[2]) 1982 download <- self$downloads$get(dlname) 1983 return(download$filter(download$data, req)) 1984 } 1985 1986 return(httpResponse(404, 'text/html', '<h1>Not Found</h1>')) 1987 }, 1988 # Send a file to the client 1989 fileUrl = function(name, file, contentType='application/octet-stream') { 1990 "Return a URL for a file to be sent to the client. The file will be base64 1991 encoded and embedded in the URL." 1992 bytes <- file.info(file)$size 1993 if (is.na(bytes)) 1994 return(NULL) 1995 1996 fileData <- readBin(file, 'raw', n=bytes) 1997 1998 b64 <- rawToBase64(fileData) 1999 return(paste('data:', contentType, ';base64,', b64, sep='')) 2000 }, 2001 registerDownload = function(name, filename, contentType, func) { 2002 2003 self$downloads$set(name, list(filename = filename, 2004 contentType = contentType, 2005 func = func)) 2006 return(sprintf('session/%s/download/%s?w=%s', 2007 URLencode(self$token, TRUE), 2008 URLencode(name, TRUE), 2009 workerId())) 2010 }, 2011 # register a data object on the server side (for datatable or selectize, etc) 2012 registerDataObj = function(name, data, filterFunc) { 2013 # abusing downloads at the moment 2014 self$downloads$set(name, list(data = data, filter = filterFunc)) 2015 return(sprintf('session/%s/dataobj/%s?w=%s&nonce=%s', 2016 URLencode(self$token, TRUE), 2017 URLencode(name, TRUE), 2018 workerId(), 2019 URLencode(createUniqueId(8), TRUE))) 2020 }, 2021 # This function suspends observers for hidden outputs and resumes observers 2022 # for un-hidden outputs. 2023 manageHiddenOutputs = function(outputsToCheck = NULL) { 2024 if (is.null(outputsToCheck)) { 2025 outputsToCheck <- names(private$.outputs) 2026 } 2027 2028 # Find hidden state for each output, and suspend/resume accordingly 2029 for (outputName in outputsToCheck) { 2030 if (private$shouldSuspend(outputName)) { 2031 private$.outputs[[outputName]]$suspend() 2032 } else { 2033 private$.outputs[[outputName]]$resume() 2034 } 2035 } 2036 }, 2037 # Set the normal and client data input variables. Normally, managing 2038 # inputs doesn't take immediate effect when there are observers that 2039 # are pending execution or currently executing (including having 2040 # started async operations that have yielded control, but not yet 2041 # completed). The `now` argument can force this. It should generally 2042 # not be used, but we're adding it to get around a show-stopping bug 2043 # for Shiny v1.1 (see the call site for more details). 2044 manageInputs = function(data, now = FALSE) { 2045 force(data) 2046 doManageInputs <- function() { 2047 private$inputReceivedCallbacks$invoke(data) 2048 2049 data_names <- names(data) 2050 2051 # Separate normal input variables from client data input variables 2052 clientdata_idx <- grepl("^.clientdata_", data_names) 2053 2054 # Set normal (non-clientData) input values 2055 private$.input$mset(data[data_names[!clientdata_idx]]) 2056 2057 # Strip off .clientdata_ from clientdata input names, and set values 2058 input_clientdata <- data[data_names[clientdata_idx]] 2059 names(input_clientdata) <- sub("^.clientdata_", "", 2060 names(input_clientdata)) 2061 private$.clientData$mset(input_clientdata) 2062 2063 self$manageHiddenOutputs() 2064 } 2065 if (isTRUE(now)) { 2066 doManageInputs() 2067 } else { 2068 self$cycleStartAction(doManageInputs) 2069 } 2070 }, 2071 outputOptions = function(name, ...) { 2072 # If no name supplied, return the list of options for all outputs 2073 if (is.null(name)) 2074 return(private$.outputOptions) 2075 if (! name %in% names(private$.outputs)) 2076 stop(name, " is not in list of output objects") 2077 2078 opts <- list(...) 2079 # If no options are set, return the options for the specified output 2080 if (length(opts) == 0) 2081 return(private$.outputOptions[[name]]) 2082 2083 # Set the appropriate option 2084 validOpts <- c("suspendWhenHidden", "priority") 2085 for (optname in names(opts)) { 2086 if (! optname %in% validOpts) 2087 stop(optname, " is not a valid option") 2088 2089 private$.outputOptions[[name]][[optname]] <- opts[[optname]] 2090 } 2091 2092 # If any changes to suspendWhenHidden, need to re-run manageHiddenOutputs 2093 if ("suspendWhenHidden" %in% names(opts)) { 2094 self$manageHiddenOutputs(name) 2095 } 2096 2097 if ("priority" %in% names(opts)) { 2098 private$.outputs[[name]]$setPriority(opts[['priority']]) 2099 } 2100 2101 invisible() 2102 }, 2103 incrementBusyCount = function() { 2104 if (private$busyCount == 0L) { 2105 rLog$asyncStart(domain = self) 2106 private$sendMessage(busy = "busy") 2107 } 2108 private$busyCount <- private$busyCount + 1L 2109 }, 2110 decrementBusyCount = function() { 2111 private$busyCount <- private$busyCount - 1L 2112 if (private$busyCount == 0L) { 2113 rLog$asyncStop(domain = self) 2114 private$sendMessage(busy = "idle") 2115 self$requestFlush() 2116 # We defer the call to startCycle() using later(), to defend against 2117 # cycles where we continually call startCycle which causes an observer 2118 # to fire which calls startCycle which causes an observer to fire... 2119 # 2120 # It's OK for these cycles to occur, but we must return control to the 2121 # event loop between iterations (or at least sometimes) in order to not 2122 # make the whole Shiny app go unresponsive. 2123 later::later(function() { 2124 if (private$busyCount == 0L) { 2125 private$startCycle() 2126 } 2127 }) 2128 } 2129 } 2130 ) 2131) 2132 2133.createOutputWriter <- function(shinysession, ns = identity) { 2134 structure(list(impl=shinysession, ns=ns), class='shinyoutput') 2135} 2136 2137#' @export 2138`$<-.shinyoutput` <- function(x, name, value) { 2139 name <- .subset2(x, 'ns')(name) 2140 2141 label <- deparse(substitute(value)) 2142 if (length(substitute(value)) > 1) { 2143 # value is an object consisting of a call and its arguments. Here we want 2144 # to find the source references for the first argument (if there are 2145 # arguments), which generally corresponds to the reactive expression-- 2146 # e.g. in renderTable({ x }), { x } is the expression to trace. 2147 attr(label, "srcref") <- srcrefFromShinyCall(substitute(value)[[2]]) 2148 srcref <- attr(substitute(value)[[2]], "srcref") 2149 if (length(srcref) > 0) 2150 attr(label, "srcfile") <- srcFileOfRef(srcref[[1]]) 2151 } 2152 .subset2(x, 'impl')$defineOutput(name, value, label) 2153 return(invisible(x)) 2154} 2155 2156#' @export 2157`[[<-.shinyoutput` <- `$<-.shinyoutput` 2158 2159#' @export 2160`$.shinyoutput` <- function(x, name) { 2161 name <- .subset2(x, 'ns')(name) 2162 2163 if (getOption("shiny.allowoutputreads", FALSE)) { 2164 .subset2(x, 'impl')$getOutput(name) 2165 } else { 2166 rlang::abort(paste0("Can't read output '", name, "'")) 2167 } 2168} 2169 2170#' @export 2171`[[.shinyoutput` <- `$.shinyoutput` 2172 2173#' @export 2174`[.shinyoutput` <- function(values, name) { 2175 rlang::abort("Can't index shinyoutput with `[`.") 2176} 2177 2178#' @export 2179`[<-.shinyoutput` <- function(values, name, value) { 2180 rlang::abort("Can't index shinyoutput with `[[`.") 2181} 2182 2183#' Set options for an output object. 2184#' 2185#' These are the available options for an output object: 2186#' \itemize{ 2187#' \item suspendWhenHidden. When `TRUE` (the default), the output object 2188#' will be suspended (not execute) when it is hidden on the web page. When 2189#' `FALSE`, the output object will not suspend when hidden, and if it 2190#' was already hidden and suspended, then it will resume immediately. 2191#' \item priority. The priority level of the output object. Queued outputs 2192#' with higher priority values will execute before those with lower values. 2193#' } 2194#' 2195#' @examples 2196#' \dontrun{ 2197#' # Get the list of options for all observers within output 2198#' outputOptions(output) 2199#' 2200#' # Disable suspend for output$myplot 2201#' outputOptions(output, "myplot", suspendWhenHidden = FALSE) 2202#' 2203#' # Change priority for output$myplot 2204#' outputOptions(output, "myplot", priority = 10) 2205#' 2206#' # Get the list of options for output$myplot 2207#' outputOptions(output, "myplot") 2208#' } 2209#' 2210#' @param x A shinyoutput object (typically `output`). 2211#' @param name The name of an output observer in the shinyoutput object. 2212#' @param ... Options to set for the output observer. 2213#' @export 2214outputOptions <- function(x, name, ...) { 2215 if (!inherits(x, "shinyoutput")) { 2216 stop("x must be a shinyoutput object.") 2217 } 2218 2219 if (!missing(name)) { 2220 name <- .subset2(x, 'ns')(name) 2221 } else { 2222 name <- NULL 2223 } 2224 2225 .subset2(x, 'impl')$outputOptions(name, ...) 2226} 2227 2228 2229#' Get output information 2230#' 2231#' Returns information about the currently executing output, including its `name` (i.e., `outputId`); 2232#' and in some cases, relevant sizing and styling information. 2233#' 2234#' @param session The current Shiny session. 2235#' 2236#' @return `NULL` if called outside of an output context; otherwise, 2237#' a list which includes: 2238#' * The `name` of the output (reported for any output). 2239#' * If the output is a `plotOutput()` or `imageOutput()`, then: 2240#' * `height`: a reactive expression which returns the height in pixels. 2241#' * `width`: a reactive expression which returns the width in pixels. 2242#' * If the output is a `plotOutput()`, `imageOutput()`, or contains a `shiny-report-theme` class, then: 2243#' * `bg`: a reactive expression which returns the background color. 2244#' * `fg`: a reactive expression which returns the foreground color. 2245#' * `accent`: a reactive expression which returns the hyperlink color. 2246#' * `font`: a reactive expression which returns a list of font information, including: 2247#' * `families`: a character vector containing the CSS `font-family` property. 2248#' * `size`: a character string containing the CSS `font-size` property 2249#' 2250#' @export 2251#' @examples 2252#' 2253#' if (interactive()) { 2254#' shinyApp( 2255#' fluidPage( 2256#' tags$style(HTML("body {background-color: black; color: white; }")), 2257#' tags$style(HTML("body a {color: purple}")), 2258#' tags$style(HTML("#info {background-color: teal; color: orange; }")), 2259#' plotOutput("p"), 2260#' "Computed CSS styles for the output named info:", 2261#' tagAppendAttributes( 2262#' textOutput("info"), 2263#' class = "shiny-report-theme" 2264#' ) 2265#' ), 2266#' function(input, output) { 2267#' output$p <- renderPlot({ 2268#' info <- getCurrentOutputInfo() 2269#' par(bg = info$bg(), fg = info$fg(), col.axis = info$fg(), col.main = info$fg()) 2270#' plot(1:10, col = info$accent(), pch = 19) 2271#' title("A simple R plot that uses its CSS styling") 2272#' }) 2273#' output$info <- renderText({ 2274#' info <- getCurrentOutputInfo() 2275#' jsonlite::toJSON( 2276#' list( 2277#' bg = info$bg(), 2278#' fg = info$fg(), 2279#' accent = info$accent(), 2280#' font = info$font() 2281#' ), 2282#' auto_unbox = TRUE 2283#' ) 2284#' }) 2285#' } 2286#' ) 2287#' } 2288#' 2289#' 2290getCurrentOutputInfo <- function(session = getDefaultReactiveDomain()) { 2291 if (is.null(session)) return(NULL) 2292 session$getCurrentOutputInfo() 2293} 2294 2295#' Add callbacks for Shiny session events 2296#' 2297#' These functions are for registering callbacks on Shiny session events. 2298#' `onFlush` registers a function that will be called before Shiny flushes 2299#' the reactive system. `onFlushed` registers a function that will be 2300#' called after Shiny flushes the reactive system. `onSessionEnded` 2301#' registers a function to be called after the client has disconnected. 2302#' 2303#' These functions should be called within the application's server function. 2304#' 2305#' All of these functions return a function which can be called with no 2306#' arguments to cancel the registration. 2307#' 2308#' @param fun A callback function. 2309#' @param once Should the function be run once, and then cleared, or should it 2310#' re-run each time the event occurs. (Only for `onFlush` and 2311#' `onFlushed`.) 2312#' @param session A shiny session object. 2313#' 2314#' @export 2315onFlush <- function(fun, once = TRUE, session = getDefaultReactiveDomain()) { 2316 session$onFlush(fun, once = once) 2317} 2318 2319#' @rdname onFlush 2320#' @export 2321onFlushed <- function(fun, once = TRUE, session = getDefaultReactiveDomain()) { 2322 session$onFlushed(fun, once = once) 2323} 2324 2325#' @rdname onFlush 2326#' 2327#' @seealso [onStop()] for registering callbacks that will be 2328#' invoked when the application exits, or when a session ends. 2329#' @export 2330onSessionEnded <- function(fun, session = getDefaultReactiveDomain()) { 2331 session$onSessionEnded(fun) 2332} 2333 2334 2335flushPendingSessions <- function() { 2336 lapply(appsNeedingFlush$values(), function(shinysession) { 2337 tryCatch( 2338 shinysession$flushOutput(), 2339 2340 stop = function(e) { 2341 # If there are any uncaught errors that bubbled up to here, close the 2342 # session. 2343 shinysession$close() 2344 } 2345 ) 2346 NULL 2347 }) 2348} 2349 2350.globals$onStopCallbacks <- Callbacks$new() 2351 2352#' Run code after an application or session ends 2353#' 2354#' This function registers callback functions that are invoked when the 2355#' application exits (when [runApp()] exits), or after each user 2356#' session ends (when a client disconnects). 2357#' 2358#' @param fun A function that will be called after the app has finished running. 2359#' @param session A scope for when the callback will run. If `onStop` is 2360#' called from within the server function, this will default to the current 2361#' session, and the callback will be invoked when the current session ends. If 2362#' `onStop` is called outside a server function, then the callback will 2363#' be invoked with the application exits. If `NULL`, it is the same as 2364#' calling `onStop` outside of the server function, and the callback will 2365#' be invoked when the application exits. 2366#' 2367#' 2368#' @seealso [onSessionEnded()] for the same functionality, but at 2369#' the session level only. 2370#' 2371#' @return A function which, if invoked, will cancel the callback. 2372#' @examples 2373#' ## Only run this example in interactive R sessions 2374#' if (interactive()) { 2375#' # Open this application in multiple browsers, then close the browsers. 2376#' shinyApp( 2377#' ui = basicPage("onStop demo"), 2378#' 2379#' server = function(input, output, session) { 2380#' onStop(function() cat("Session stopped\n")) 2381#' }, 2382#' 2383#' onStart = function() { 2384#' cat("Doing application setup\n") 2385#' 2386#' onStop(function() { 2387#' cat("Doing application cleanup\n") 2388#' }) 2389#' } 2390#' ) 2391#' } 2392#' # In the example above, onStop() is called inside of onStart(). This is 2393#' # the pattern that should be used when creating a shinyApp() object from 2394#' # a function, or at the console. If instead you are writing an app.R which 2395#' # will be invoked with runApp(), you can do it that way, or put the onStop() 2396#' # before the shinyApp() call, as shown below. 2397#' 2398#' \dontrun{ 2399#' # ==== app.R ==== 2400#' cat("Doing application setup\n") 2401#' onStop(function() { 2402#' cat("Doing application cleanup\n") 2403#' }) 2404#' 2405#' shinyApp( 2406#' ui = basicPage("onStop demo"), 2407#' 2408#' server = function(input, output, session) { 2409#' onStop(function() cat("Session stopped\n")) 2410#' } 2411#' ) 2412#' # ==== end app.R ==== 2413#' 2414#' 2415#' # Similarly, if you have a global.R, you can call onStop() from there. 2416#' # ==== global.R ==== 2417#' cat("Doing application setup\n") 2418#' onStop(function() { 2419#' cat("Doing application cleanup\n") 2420#' }) 2421#' # ==== end global.R ==== 2422#' } 2423#' @export 2424onStop <- function(fun, session = getDefaultReactiveDomain()) { 2425 if (is.null(session)) { 2426 return(.globals$onStopCallbacks$register(fun)) 2427 } else { 2428 # Note: In the future if we allow scoping the onStop() callback to modules 2429 # and allow modules to be stopped, then session_proxy objects will need 2430 # its own implementation of $onSessionEnded. 2431 return(session$onSessionEnded(fun)) 2432 } 2433} 2434 2435# Helper class for emitting log messages to stdout that will be interpreted by 2436# a Shiny Server parent process. The duration it's trying to record is the time 2437# between a websocket message being received, and the next flush to the client. 2438ShinyServerTimingRecorder <- R6Class("ShinyServerTimingRecorder", 2439 cloneable = FALSE, 2440 public = list( 2441 initialize = function() { 2442 private$shiny_stdout <- if (exists(".shiny__stdout", globalenv())) 2443 get(".shiny__stdout", globalenv()) 2444 else 2445 NULL 2446 private$guid <- NULL 2447 }, 2448 start = function(guid) { 2449 if (is.null(private$shiny_stdout)) return() 2450 2451 private$guid <- guid 2452 if (!is.null(guid)) { 2453 private$write("n") 2454 } 2455 }, 2456 stop = function() { 2457 if (is.null(private$shiny_stdout)) return() 2458 2459 if (!is.null(private$guid)) { 2460 private$write("x") 2461 private$guid <- NULL 2462 } 2463 } 2464 ), 2465 private = list( 2466 shiny_stdout = NULL, 2467 guid = character(), 2468 write = function(code) { 2469 # eNter or eXit a flushReact 2470 writeLines(paste("_", code, "_flushReact ", private$guid, 2471 " @ ", sprintf("%.3f", as.numeric(Sys.time())), 2472 sep=""), con=private$shiny_stdout) 2473 flush(private$shiny_stdout) 2474 } 2475 ) 2476) 2477 2478missingOutput <- function(...) req(FALSE) 2479 2480#' Insert inline Markdown 2481#' 2482#' This function accepts 2483#' [Markdown](https://en.wikipedia.org/wiki/Markdown)-syntax text and returns 2484#' HTML that may be included in Shiny UIs. 2485#' 2486#' Leading whitespace is trimmed from Markdown text with [glue::trim()]. 2487#' Whitespace trimming ensures Markdown is processed correctly even when the 2488#' call to `markdown()` is indented within surrounding R code. 2489#' 2490#' By default, [Github extensions][commonmark::extensions] are enabled, but this 2491#' can be disabled by passing `extensions = FALSE`. 2492#' 2493#' Markdown rendering is performed by [commonmark::markdown_html()]. Additional 2494#' arguments to `markdown()` are passed as arguments to `markdown_html()` 2495#' 2496#' @param mds A character vector of Markdown source to convert to HTML. If the 2497#' vector has more than one element, a single-element character vector of 2498#' concatenated HTML is returned. 2499#' @param extensions Enable Github syntax extensions; defaults to `TRUE`. 2500#' @param .noWS Character vector used to omit some of the whitespace that would 2501#' normally be written around generated HTML. Valid options include `before`, 2502#' `after`, and `outside` (equivalent to `before` and `end`). 2503#' @param ... Additional arguments to pass to [commonmark::markdown_html()]. 2504#' These arguments are _[dynamic][rlang::dyn-dots]_. 2505#' 2506#' @return a character vector marked as HTML. 2507#' @export 2508#' @examples 2509#' ui <- fluidPage( 2510#' markdown(" 2511#' # Markdown Example 2512#' 2513#' This is a markdown paragraph, and will be contained within a `<p>` tag 2514#' in the UI. 2515#' 2516#' The following is an unordered list, which will be represented in the UI as 2517#' a `<ul>` with `<li>` children: 2518#' 2519#' * a bullet 2520#' * another 2521#' 2522#' [Links](https://developer.mozilla.org/en-US/docs/Web/HTML/Element/a) work; 2523#' so does *emphasis*. 2524#' 2525#' To see more of what's possible, check out [commonmark.org/help](https://commonmark.org/help). 2526#' ") 2527#' ) 2528markdown <- function(mds, extensions = TRUE, .noWS = NULL, ...) { 2529 html <- rlang::exec(commonmark::markdown_html, glue::trim(mds), extensions = extensions, ...) 2530 htmltools::HTML(html, .noWS = .noWS) 2531} 2532 2533 2534# Check that an object is a ShinySession object, and give an informative error. 2535# The default label is the caller function's name. 2536validate_session_object <- function(session, label = as.character(sys.call(sys.parent())[[1]])) { 2537 if (missing(session) || 2538 !inherits(session, c("ShinySession", "MockShinySession", "session_proxy"))) 2539 { 2540 stop(call. = FALSE, 2541 sprintf( 2542 "`session` must be a 'ShinySession' object. Did you forget to pass `session` to `%s()`?", 2543 label 2544 ) 2545 ) 2546 } 2547} 2548