1# TODO: Subapp global.R 2 3#' Create a Shiny app object 4#' 5#' These functions create Shiny app objects from either an explicit UI/server 6#' pair (`shinyApp`), or by passing the path of a directory that contains a 7#' Shiny app (`shinyAppDir`). 8#' 9#' Normally when this function is used at the R console, the Shiny app object is 10#' automatically passed to the `print()` function, which runs the app. If 11#' this is called in the middle of a function, the value will not be passed to 12#' `print()` and the app will not be run. To make the app run, pass the app 13#' object to `print()` or [runApp()]. 14#' 15#' @param ui The UI definition of the app (for example, a call to 16#' `fluidPage()` with nested controls). 17#' 18#' If bookmarking is enabled (see `enableBookmarking`), this must be 19#' a single argument function that returns the UI definition. 20#' @param server A function with three parameters: `input`, `output`, and 21#' `session`. The function is called once for each session ensuring that each 22#' app is independent. 23#' @param onStart A function that will be called before the app is actually run. 24#' This is only needed for `shinyAppObj`, since in the `shinyAppDir` 25#' case, a `global.R` file can be used for this purpose. 26#' @param options Named options that should be passed to the `runApp` call 27#' (these can be any of the following: "port", "launch.browser", "host", "quiet", 28#' "display.mode" and "test.mode"). You can also specify `width` and 29#' `height` parameters which provide a hint to the embedding environment 30#' about the ideal height/width for the app. 31#' @param uiPattern A regular expression that will be applied to each `GET` 32#' request to determine whether the `ui` should be used to handle the 33#' request. Note that the entire request path must match the regular 34#' expression in order for the match to be considered successful. 35#' @param enableBookmarking Can be one of `"url"`, `"server"`, or 36#' `"disable"`. The default value, `NULL`, will respect the setting from 37#' any previous calls to [enableBookmarking()]. See [enableBookmarking()] 38#' for more information on bookmarking your app. 39#' @return An object that represents the app. Printing the object or passing it 40#' to [runApp()] will run the app. 41#' 42#' @examples 43#' ## Only run this example in interactive R sessions 44#' if (interactive()) { 45#' options(device.ask.default = FALSE) 46#' 47#' shinyApp( 48#' ui = fluidPage( 49#' numericInput("n", "n", 1), 50#' plotOutput("plot") 51#' ), 52#' server = function(input, output) { 53#' output$plot <- renderPlot( plot(head(cars, input$n)) ) 54#' } 55#' ) 56#' 57#' shinyAppDir(system.file("examples/01_hello", package="shiny")) 58#' 59#' 60#' # The object can be passed to runApp() 61#' app <- shinyApp( 62#' ui = fluidPage( 63#' numericInput("n", "n", 1), 64#' plotOutput("plot") 65#' ), 66#' server = function(input, output) { 67#' output$plot <- renderPlot( plot(head(cars, input$n)) ) 68#' } 69#' ) 70#' 71#' runApp(app) 72#' } 73#' @export 74shinyApp <- function(ui, server, onStart=NULL, options=list(), 75 uiPattern="/", enableBookmarking=NULL) { 76 if (!is.function(server)) { 77 stop("`server` must be a function", call. = FALSE) 78 } 79 80 # Ensure that the entire path is a match 81 uiPattern <- sprintf("^%s$", uiPattern) 82 83 httpHandler <- uiHttpHandler(ui, uiPattern) 84 85 serverFuncSource <- function() { 86 server 87 } 88 89 if (!is.null(enableBookmarking)) { 90 bookmarkStore <- match.arg(enableBookmarking, c("url", "server", "disable")) 91 enableBookmarking(bookmarkStore) 92 } 93 94 # Store the appDir and bookmarking-related options, so that we can read them 95 # from within the app. 96 appOptions <- captureAppOptions() 97 98 structure( 99 list( 100 httpHandler = httpHandler, 101 serverFuncSource = serverFuncSource, 102 onStart = onStart, 103 options = options, 104 appOptions = appOptions 105 ), 106 class = "shiny.appobj" 107 ) 108} 109 110#' @rdname shinyApp 111#' @param appDir Path to directory that contains a Shiny app (i.e. a server.R 112#' file and either ui.R or www/index.html) 113#' @export 114shinyAppDir <- function(appDir, options=list()) { 115 if (!utils::file_test('-d', appDir)) { 116 rlang::abort( 117 paste0("No Shiny application exists at the path \"", appDir, "\""), 118 class = "invalidShinyAppDir" 119 ) 120 } 121 122 # In case it's a relative path, convert to absolute (so we're not adversely 123 # affected by future changes to the path) 124 appDir <- normalizePath(appDir, mustWork = TRUE) 125 126 if (file.exists.ci(appDir, "server.R")) { 127 shinyAppDir_serverR(appDir, options = options) 128 } else if (file.exists.ci(appDir, "app.R")) { 129 shinyAppDir_appR("app.R", appDir, options = options) 130 } else { 131 rlang::abort( 132 "App dir must contain either app.R or server.R.", 133 class = "invalidShinyAppDir" 134 ) 135 } 136} 137 138#' @rdname shinyApp 139#' @param appFile Path to a .R file containing a Shiny application 140#' @export 141shinyAppFile <- function(appFile, options=list()) { 142 appFile <- normalizePath(appFile, mustWork = TRUE) 143 appDir <- dirname(appFile) 144 145 shinyAppDir_appR(basename(appFile), appDir, options = options) 146} 147 148# This reads in an app dir in the case that there's a server.R (and ui.R/www) 149# present, and returns a shiny.appobj. 150# appDir must be a normalized (absolute) path, not a relative one 151shinyAppDir_serverR <- function(appDir, options=list()) { 152 # Most of the complexity here comes from needing to hot-reload if the .R files 153 # change on disk, or are created, or are removed. 154 155 # In an upcoming version of shiny, this option will go away. 156 if (getOption("shiny.autoload.r", TRUE)) { 157 # Create a child env which contains all the helpers and will be the shared parent 158 # of the ui.R and server.R load. 159 sharedEnv <- new.env(parent = globalenv()) 160 } else { 161 # old behavior 162 sharedEnv <- globalenv() 163 } 164 165 # uiHandlerSource is a function that returns an HTTP handler for serving up 166 # ui.R as a webpage. The "cachedFuncWithFile" call makes sure that the closure 167 # we're creating here only gets executed when ui.R's contents change. 168 uiHandlerSource <- cachedFuncWithFile(appDir, "ui.R", case.sensitive = FALSE, 169 function(uiR) { 170 if (file.exists(uiR)) { 171 # If ui.R contains a call to shinyUI (which sets .globals$ui), use that. 172 # If not, then take the last expression that's returned from ui.R. 173 .globals$ui <- NULL 174 on.exit(.globals$ui <- NULL, add = FALSE) 175 ui <- sourceUTF8(uiR, envir = new.env(parent = sharedEnv)) 176 if (!is.null(.globals$ui)) { 177 ui <- .globals$ui[[1]] 178 } 179 return(uiHttpHandler(ui)) 180 } else { 181 return(function(req) NULL) 182 } 183 } 184 ) 185 uiHandler <- function(req) { 186 uiHandlerSource()(req) 187 } 188 189 wwwDir <- file.path.ci(appDir, "www") 190 if (dirExists(wwwDir)) { 191 staticPaths <- list("/" = staticPath(wwwDir, indexhtml = FALSE, fallthrough = TRUE)) 192 } else { 193 staticPaths <- list() 194 } 195 196 fallbackWWWDir <- system.file("www-dir", package = "shiny") 197 198 serverSource <- cachedFuncWithFile(appDir, "server.R", case.sensitive = FALSE, 199 function(serverR) { 200 # If server.R contains a call to shinyServer (which sets .globals$server), 201 # use that. If not, then take the last expression that's returned from 202 # server.R. 203 .globals$server <- NULL 204 on.exit(.globals$server <- NULL, add = TRUE) 205 result <- sourceUTF8(serverR, envir = new.env(parent = sharedEnv)) 206 if (!is.null(.globals$server)) { 207 result <- .globals$server[[1]] 208 } 209 return(result) 210 } 211 ) 212 213 # This function stands in for the server function, and reloads the 214 # real server function as necessary whenever server.R changes 215 serverFuncSource <- function() { 216 serverFunction <- serverSource() 217 if (is.null(serverFunction)) { 218 return(function(input, output) NULL) 219 } else if (is.function(serverFunction)) { 220 # This is what we normally expect; run the server function 221 return(serverFunction) 222 } else { 223 stop("server.R returned an object of unexpected type: ", 224 typeof(serverFunction)) 225 } 226 } 227 228 shinyOptions(appDir = appDir) 229 230 oldwd <- NULL 231 monitorHandle <- NULL 232 onStart <- function() { 233 oldwd <<- getwd() 234 setwd(appDir) 235 # TODO: we should support hot reloading on global.R and R/*.R changes. 236 if (getOption("shiny.autoload.r", TRUE)) { 237 loadSupport(appDir, renv=sharedEnv, globalrenv=globalenv()) 238 } else { 239 if (file.exists(file.path.ci(appDir, "global.R"))) 240 sourceUTF8(file.path.ci(appDir, "global.R")) 241 } 242 monitorHandle <<- initAutoReloadMonitor(appDir) 243 } 244 onStop <- function() { 245 setwd(oldwd) 246 # It is possible that while calling appObj()$onStart() or loadingSupport, an error occured 247 # This will cause `onStop` to be called. 248 # The `oldwd` will exist, but `monitorHandle` is not a function yet. 249 if (is.function(monitorHandle)) { 250 monitorHandle() 251 monitorHandle <<- NULL 252 } 253 } 254 255 structure( 256 list( 257 staticPaths = staticPaths, 258 # Even though the wwwDir is handled as a static path, we need to include 259 # it here to be handled by R as well. This is because the special case 260 # of index.html: it is specifically not handled as a staticPath for 261 # reasons explained above, but if someone does want to serve up an 262 # index.html, we need to handle it, and we do it by using the 263 # staticHandler in the R code path. (#2380) 264 httpHandler = joinHandlers(c(uiHandler, wwwDir, fallbackWWWDir)), 265 serverFuncSource = serverFuncSource, 266 onStart = onStart, 267 onStop = onStop, 268 options = options 269 ), 270 class = "shiny.appobj" 271 ) 272} 273 274# Start a reactive observer that continually monitors dir for changes to files 275# that have the extensions: r, htm, html, js, css, png, jpg, jpeg, gif. Case is 276# ignored when checking extensions. If any changes are detected, all connected 277# Shiny sessions are reloaded. 278# 279# Use options(shiny.autoreload = TRUE) to enable this behavior. Since monitoring 280# for changes is expensive (we are polling for mtimes here, nothing fancy) this 281# feature is intended only for development. 282# 283# You can customize the file patterns Shiny will monitor by setting the 284# shiny.autoreload.pattern option. For example, to monitor only ui.R: 285# options(shiny.autoreload.pattern = glob2rx("ui.R")) 286# 287# The return value is a function that halts monitoring when called. 288initAutoReloadMonitor <- function(dir) { 289 if (!getOption("shiny.autoreload", FALSE)) { 290 return(function(){}) 291 } 292 293 filePattern <- getOption("shiny.autoreload.pattern", 294 ".*\\.(r|html?|js|css|png|jpe?g|gif)$") 295 296 lastValue <- NULL 297 observeLabel <- paste0("File Auto-Reload - '", basename(dir), "'") 298 obs <- observe(label = observeLabel, { 299 files <- sort_c( 300 list.files(dir, pattern = filePattern, recursive = TRUE, ignore.case = TRUE) 301 ) 302 times <- file.info(files)$mtime 303 names(times) <- files 304 305 if (is.null(lastValue)) { 306 # First run 307 lastValue <<- times 308 } else if (!identical(lastValue, times)) { 309 # We've changed! 310 lastValue <<- times 311 autoReloadCallbacks$invoke() 312 } 313 314 invalidateLater(getOption("shiny.autoreload.interval", 500)) 315 }) 316 317 onStop(obs$destroy) 318 319 obs$destroy 320} 321 322#' Load an app's supporting R files 323#' 324#' Loads all of the supporting R files of a Shiny application. Specifically, 325#' this function loads any top-level supporting `.R` files in the `R/` directory 326#' adjacent to the `app.R`/`server.R`/`ui.R` files. 327#' 328#' Since Shiny 1.5.0, this function is called by default when running an 329#' application. If it causes problems, there are two ways to opt out. You can 330#' either place a file named `_disable_autoload.R` in your R/ directory, or 331#' set `options(shiny.autoload.r=FALSE)`. If you set this option, it will 332#' affect any application that runs later in the same R session, potentially 333#' breaking it, so after running your application, you should unset option with 334#' `options(shiny.autoload.r=NULL)` 335#' 336#' @details The files are sourced in alphabetical order (as determined by 337#' [list.files]). `global.R` is evaluated before the supporting R files in the 338#' `R/` directory. 339#' @param appDir The application directory. If `appDir` is `NULL` or 340#' not supplied, the nearest enclosing directory that is a Shiny app, starting 341#' with the current directory, is used. 342#' @param renv The environmeny in which the files in the `R/` directory should 343#' be evaluated. 344#' @param globalrenv The environment in which `global.R` should be evaluated. If 345#' `NULL`, `global.R` will not be evaluated at all. 346#' @export 347loadSupport <- function(appDir=NULL, renv=new.env(parent=globalenv()), globalrenv=globalenv()){ 348 require(shiny) 349 350 if (is.null(appDir)) { 351 appDir <- findEnclosingApp(".") 352 } 353 354 descFile <- file.path.ci(appDir, "DESCRIPTION") 355 if (file.exists(file.path.ci(appDir, "NAMESPACE")) || 356 (file.exists(descFile) && 357 identical(as.character(read.dcf(descFile, fields = "Type")), "Package"))) 358 { 359 warning( 360 "Loading R/ subdirectory for Shiny application, but this directory appears ", 361 "to contain an R package. Sourcing files in R/ may cause unexpected behavior." 362 ) 363 } 364 365 if (!is.null(globalrenv)){ 366 # Evaluate global.R, if it exists. 367 globalPath <- file.path.ci(appDir, "global.R") 368 if (file.exists(globalPath)){ 369 withr::with_dir(appDir, { 370 sourceUTF8(basename(globalPath), envir=globalrenv) 371 }) 372 } 373 } 374 375 376 helpersDir <- file.path(appDir, "R") 377 378 disabled <- list.files(helpersDir, pattern="^_disable_autoload\\.r$", recursive=FALSE, ignore.case=TRUE) 379 if (length(disabled) > 0){ 380 return(invisible(renv)) 381 } 382 383 helpers <- list.files(helpersDir, pattern="\\.[rR]$", recursive=FALSE, full.names=TRUE) 384 # Ensure files in R/ are sorted according to the 'C' locale before sourcing. 385 # This convention is based on the default for packages. For details, see: 386 # https://cran.r-project.org/doc/manuals/r-release/R-exts.html#The-DESCRIPTION-file 387 helpers <- sort_c(helpers) 388 helpers <- normalizePath(helpers) 389 390 withr::with_dir(appDir, { 391 lapply(helpers, sourceUTF8, envir=renv) 392 }) 393 394 invisible(renv) 395} 396 397# This reads in an app dir for a single-file application (e.g. app.R), and 398# returns a shiny.appobj. 399# appDir must be a normalized (absolute) path, not a relative one 400shinyAppDir_appR <- function(fileName, appDir, options=list()) 401{ 402 fullpath <- file.path.ci(appDir, fileName) 403 404 # This sources app.R and caches the content. When appObj() is called but 405 # app.R hasn't changed, it won't re-source the file. But if called and 406 # app.R has changed, it'll re-source the file and return the result. 407 appObj <- cachedFuncWithFile(appDir, fileName, case.sensitive = FALSE, 408 function(appR) { 409 wasDir <- setwd(appDir) 410 on.exit(setwd(wasDir)) 411 412 # TODO: we should support hot reloading on R/*.R changes. 413 # In an upcoming version of shiny, this option will go away. 414 if (getOption("shiny.autoload.r", TRUE)) { 415 # Create a child env which contains all the helpers and will be the shared parent 416 # of the ui.R and server.R load. 417 sharedEnv <- new.env(parent = globalenv()) 418 loadSupport(appDir, renv=sharedEnv, globalrenv=NULL) 419 } else { 420 sharedEnv <- globalenv() 421 } 422 result <- sourceUTF8(fullpath, envir = new.env(parent = sharedEnv)) 423 424 if (!is.shiny.appobj(result)) 425 stop("app.R did not return a shiny.appobj object.") 426 427 applyCapturedAppOptions(result$appOptions) 428 429 return(result) 430 } 431 ) 432 433 # A function that invokes the http handler from the appObj in app.R, but 434 # since this uses appObj(), it only re-sources the file when it changes. 435 dynHttpHandler <- function(...) { 436 appObj()$httpHandler(...) 437 } 438 439 dynServerFuncSource <- function(...) { 440 appObj()$serverFuncSource(...) 441 } 442 443 wwwDir <- file.path.ci(appDir, "www") 444 if (dirExists(wwwDir)) { 445 # wwwDir is a static path served by httpuv. It does _not_ serve up 446 # index.html, for two reasons. (1) It's possible that the user's 447 # www/index.html file is not actually used as the index, but as a template 448 # that gets processed before being sent; and (2) the index content may be 449 # modified by the hosting environment (as in SockJSAdapter.R). 450 # 451 # The call to staticPath normalizes the path, so that if the working dir 452 # later changes, it will continue to point to the right place. 453 staticPaths <- list("/" = staticPath(wwwDir, indexhtml = FALSE, fallthrough = TRUE)) 454 } else { 455 staticPaths <- list() 456 } 457 458 fallbackWWWDir <- system.file("www-dir", package = "shiny") 459 460 oldwd <- NULL 461 monitorHandle <- NULL 462 onStart <- function() { 463 oldwd <<- getwd() 464 setwd(appDir) 465 if (!is.null(appObj()$onStart)) appObj()$onStart() 466 monitorHandle <<- initAutoReloadMonitor(appDir) 467 invisible() 468 } 469 onStop <- function() { 470 setwd(oldwd) 471 # It is possible that while calling appObj()$onStart() or loadingSupport, an error occured 472 # This will cause `onStop` to be called. 473 # The `oldwd` will exist, but `monitorHandle` is not a function yet. 474 if (is.function(monitorHandle)) { 475 monitorHandle() 476 monitorHandle <<- NULL 477 } 478 } 479 480 appObjOptions <- appObj()$options 481 482 structure( 483 list( 484 # fallbackWWWDir is _not_ listed in staticPaths, because it needs to 485 # come after the uiHandler. It also does not need to be fast, since it 486 # should rarely be hit. The order is wwwDir (in staticPaths), then 487 # uiHandler, then falbackWWWDir (which is served up by the R 488 # staticHandler function). 489 staticPaths = staticPaths, 490 # Even though the wwwDir is handled as a static path, we need to include 491 # it here to be handled by R as well. This is because the special case 492 # of index.html: it is specifically not handled as a staticPath for 493 # reasons explained above, but if someone does want to serve up an 494 # index.html, we need to handle it, and we do it by using the 495 # staticHandler in the R code path. (#2380) 496 httpHandler = joinHandlers(c(dynHttpHandler, wwwDir, fallbackWWWDir)), 497 serverFuncSource = dynServerFuncSource, 498 onStart = onStart, 499 onStop = onStop, 500 options = joinOptions(appObjOptions, options) 501 ), 502 class = "shiny.appobj" 503 ) 504} 505 506 507#' Shiny App object 508#' 509#' Internal methods for the `shiny.appobj` S3 class. 510#' 511#' @keywords internal 512#' @name shiny.appobj 513NULL 514 515#' @rdname shiny.appobj 516#' @param x Object to convert to a Shiny app. 517#' @export 518as.shiny.appobj <- function(x) { 519 UseMethod("as.shiny.appobj", x) 520} 521 522#' @rdname shiny.appobj 523#' @export 524as.shiny.appobj.shiny.appobj <- function(x) { 525 x 526} 527 528#' @rdname shiny.appobj 529#' @export 530as.shiny.appobj.list <- function(x) { 531 shinyApp(ui = x$ui, server = x$server) 532} 533 534#' @rdname shiny.appobj 535#' @export 536as.shiny.appobj.character <- function(x) { 537 if (identical(tolower(tools::file_ext(x)), "r")) 538 shinyAppFile(x) 539 else 540 shinyAppDir(x) 541} 542 543#' @rdname shiny.appobj 544#' @export 545is.shiny.appobj <- function(x) { 546 inherits(x, "shiny.appobj") 547} 548 549#' @rdname shiny.appobj 550#' @param ... Ignored. 551#' @export 552print.shiny.appobj <- function(x, ...) { 553 runApp(x) 554} 555 556# Joins two options objects (i.e. the `options` argument to shinyApp(), 557# shinyAppDir(), etc.). The values in `b` should take precedence over the values 558# in `a`. Given the current options available, it is safe to throw away any 559# values in `a` that are provided in `b`. But in the future, if new options are 560# introduced that need to be combined in some way instead of simply overwritten, 561# then this will be the place to do it. See the implementations of 562# print.shiny.appobj() and runApp() (for the latter, look specifically for 563# "findVal()") to determine the set of possible options. 564joinOptions <- function(a, b) { 565 stopifnot(is.null(a) || is.list(a)) 566 stopifnot(is.null(b) || is.list(b)) 567 568 mergeVectors(a, b) 569} 570 571#' @rdname shiny.appobj 572#' @method as.tags shiny.appobj 573#' @export 574as.tags.shiny.appobj <- function(x, ...) { 575 # jcheng 06/06/2014: Unfortunate copy/paste between this function and 576 # knit_print.shiny.appobj, but I am trying to make the most conservative 577 # change possible due to upcoming release. 578 opts <- x$options %||% list() 579 width <- if (is.null(opts$width)) "100%" else opts$width 580 height <- if (is.null(opts$height)) "400" else opts$height 581 582 path <- addSubApp(x) 583 deferredIFrame(path, width, height) 584} 585 586# Generate subapp iframes in such a way that they will not actually load right 587# away. Loading subapps immediately upon app load can result in a storm of 588# connections, all of which are contending for the few concurrent connections 589# that a browser will make to a specific origin. Instead, we load dummy iframes 590# and let the client load them when convenient. (See the initIframes function in 591# init_shiny.js.) 592deferredIFrame <- function(path, width, height) { 593 tags$iframe("data-deferred-src" = path, 594 width = width, height = height, 595 class = "shiny-frame shiny-frame-deferred" 596 ) 597} 598