app.R

# TODO: Subapp global.R

#' Create a Shiny app object
#'
#' These functions create Shiny app objects from either an explicit UI/server
#' pair (\code{shinyApp}), or by passing the path of a directory that contains a
#' Shiny app (\code{shinyAppDir}). You generally shouldn't need to use these
#' functions to create/run applications; they are intended for interoperability
#' purposes, such as embedding Shiny apps inside a \pkg{knitr} document.
#'
#' Normally when this function is used at the R console, the Shiny app object is
#' automatically passed to the \code{print()} function, which runs the app. If
#' this is called in the middle of a function, the value will not be passed to
#' \code{print()} and the app will not be run. To make the app run, pass the app
#' object to \code{print()} or \code{\link{runApp}()}.
#'
#' @param ui The UI definition of the app (for example, a call to
#'   \code{fluidPage()} with nested controls)
#' @param server A server function
#' @param onStart A function that will be called before the app is actually run.
#'   This is only needed for \code{shinyAppObj}, since in the \code{shinyAppDir}
#'   case, a \code{global.R} file can be used for this purpose.
#' @param options Named options that should be passed to the `runApp` call. You
#'   can also specify \code{width} and \code{height} parameters which provide a
#'   hint to the embedding environment about the ideal height/width for the app.
#' @param uiPattern A regular expression that will be applied to each \code{GET}
#'   request to determine whether the \code{ui} should be used to handle the
#'   request. Note that the entire request path must match the regular
#'   expression in order for the match to be considered successful.
#' @return An object that represents the app. Printing the object or passing it
#'   to \code{\link{runApp}} will run the app.
#'
#' @examples
#' ## Only run this example in interactive R sessions
#' if (interactive()) {
#'   shinyApp(
#'     ui = fluidPage(
#'       numericInput("n", "n", 1),
#'       plotOutput("plot")
#'     ),
#'     server = function(input, output) {
#'       output$plot <- renderPlot( plot(head(cars, input$n)) )
#'     }
#'   )
#'
#'   shinyAppDir(system.file("examples/01_hello", package="shiny"))
#'
#'
#'   # The object can be passed to runApp()
#'   app <- shinyApp(
#'     ui = fluidPage(
#'       numericInput("n", "n", 1),
#'       plotOutput("plot")
#'     ),
#'     server = function(input, output) {
#'       output$plot <- renderPlot( plot(head(cars, input$n)) )
#'     }
#'   )
#'
#'   runApp(app)
#' }
#'
#' @export
shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
                     uiPattern="/") {
  if (is.null(server)) {
    stop("`server` missing from shinyApp")
  }

  # Ensure that the entire path is a match
  uiPattern <- sprintf("^%s$", uiPattern)

  httpHandler <- uiHttpHandler(ui, uiPattern)

  serverFuncSource <- function() {
    server
  }

  structure(
    list(
      httpHandler = httpHandler,
      serverFuncSource = serverFuncSource,
      onStart = onStart,
      options = options),
    class = "shiny.appobj"
  )
}

#' @rdname shinyApp
#' @param appDir Path to directory that contains a Shiny app (i.e. a server.R
#'   file and either ui.R or www/index.html)
#' @export
shinyAppDir <- function(appDir, options=list()) {
  if (!file_test('-d', appDir)) {
    stop("No Shiny application exists at the path \"", appDir, "\"")
  }

  # In case it's a relative path, convert to absolute (so we're not adversely
  # affected by future changes to the path)
  appDir <- normalizePath(appDir, mustWork = TRUE)

  if (file.exists.ci(appDir, "server.R")) {
    shinyAppDir_serverR(appDir, options = options)
  } else if (file.exists.ci(appDir, "app.R")) {
    shinyAppDir_appR(appDir, options = options)
  } else {
    stop("App dir must contain either app.R or server.R.")
  }
}

# This reads in an app dir in the case that there's a server.R (and ui.R/www)
# present, and returns a shiny.appobj.
shinyAppDir_serverR <- function(appDir, options=list()) {
  # Most of the complexity here comes from needing to hot-reload if the .R files
  # change on disk, or are created, or are removed.

  # uiHandlerSource is a function that returns an HTTP handler for serving up
  # ui.R as a webpage. The "cachedFuncWithFile" call makes sure that the closure
  # we're creating here only gets executed when ui.R's contents change.
  uiHandlerSource <- cachedFuncWithFile(appDir, "ui.R", case.sensitive = FALSE,
    function(uiR) {
      if (file.exists(uiR)) {
        # If ui.R contains a call to shinyUI (which sets .globals$ui), use that.
        # If not, then take the last expression that's returned from ui.R.
        .globals$ui <- NULL
        on.exit(.globals$ui <- NULL, add = FALSE)
        ui <- sourceUTF8(uiR, local = new.env(parent = globalenv()))$value
        if (!is.null(.globals$ui)) {
          ui <- .globals$ui[[1]]
        }
        return(uiHttpHandler(ui))
      } else {
        return(function(req) NULL)
      }
    }
  )
  uiHandler <- function(req) {
    uiHandlerSource()(req)
  }

  wwwDir <- file.path.ci(appDir, "www")
  fallbackWWWDir <- system.file("www-dir", package = "shiny")
  serverSource <- cachedFuncWithFile(appDir, "server.R", case.sensitive = FALSE,
    function(serverR) {
      # If server.R contains a call to shinyServer (which sets .globals$server),
      # use that. If not, then take the last expression that's returned from
      # server.R.
      .globals$server <- NULL
      on.exit(.globals$server <- NULL, add = TRUE)
      result <- sourceUTF8(serverR, local = new.env(parent = globalenv()))$value
      if (!is.null(.globals$server)) {
        result <- .globals$server[[1]]
      }
      return(result)
    }
  )

  # This function stands in for the server function, and reloads the
  # real server function as necessary whenever server.R changes
  serverFuncSource <- function() {
    serverFunction <- serverSource()
    if (is.null(serverFunction)) {
      return(function(input, output) NULL)
    } else if (is.function(serverFunction)) {
      # This is what we normally expect; run the server function
      return(serverFunction)
    } else {
      stop("server.R returned an object of unexpected type: ",
        typeof(serverFunction))
    }
  }

  oldwd <- NULL
  onStart <- function() {
    oldwd <<- getwd()
    setwd(appDir)
    if (file.exists(file.path.ci(appDir, "global.R")))
      sourceUTF8(file.path.ci(appDir, "global.R"))
  }
  onEnd <- function() {
    setwd(oldwd)
  }

  structure(
    list(
      httpHandler = joinHandlers(c(uiHandler, wwwDir, fallbackWWWDir)),
      serverFuncSource = serverFuncSource,
      onStart = onStart,
      onEnd = onEnd,
      options = options),
    class = "shiny.appobj"
  )
}

# This reads in an app dir in the case that there's a app.R present, and returns
# a shiny.appobj.
shinyAppDir_appR <- function(appDir, options=list()) {
  fullpath <- file.path.ci(appDir, "app.R")

  # This sources app.R and caches the content. When appObj() is called but
  # app.R hasn't changed, it won't re-source the file. But if called and
  # app.R has changed, it'll re-source the file and return the result.
  appObj <- cachedFuncWithFile(appDir, "app.R", case.sensitive = FALSE,
    function(appR) {
      result <- sourceUTF8(fullpath, local = new.env(parent = globalenv()))$value

      if (!is.shiny.appobj(result))
        stop("app.R did not return a shiny.appobj object.")

      return(result)
    }
  )

  # A function that invokes the http handler from the appObj in app.R, but
  # since this uses appObj(), it only re-sources the file when it changes.
  dynHttpHandler <- function(...) {
    appObj()$httpHandler(...)
  }

  dynServerFuncSource <- function(...) {
    appObj()$serverFuncSource(...)
  }

  wwwDir <- file.path.ci(appDir, "www")
  fallbackWWWDir <- system.file("www-dir", package = "shiny")

  oldwd <- NULL
  onStart <- function() {
    oldwd <<- getwd()
    setwd(appDir)
  }
  onEnd <- function() {
    setwd(oldwd)
  }

  structure(
    list(
      httpHandler = joinHandlers(c(dynHttpHandler, wwwDir, fallbackWWWDir)),
      serverFuncSource = dynServerFuncSource,
      onStart = onStart,
      onEnd = onEnd,
      options = options
    ),
    class = "shiny.appobj"
  )
}


#' @rdname shinyApp
#' @param x Object to convert to a Shiny app.
#' @export
as.shiny.appobj <- function(x) {
  UseMethod("as.shiny.appobj", x)
}

#' @rdname shinyApp
#' @export
as.shiny.appobj.shiny.appobj <- function(x) {
  x
}

#' @rdname shinyApp
#' @export
as.shiny.appobj.list <- function(x) {
  shinyApp(ui = x$ui, server = x$server)
}

#' @rdname shinyApp
#' @export
as.shiny.appobj.character <- function(x) {
  shinyAppDir(x)
}

#' @rdname shinyApp
#' @export
is.shiny.appobj <- function(x) {
  inherits(x, "shiny.appobj")
}

#' @rdname shinyApp
#' @param ... Additional parameters to be passed to print.
#' @export
print.shiny.appobj <- function(x, ...) {
  opts <- x$options %OR% list()
  opts <- opts[names(opts) %in%
      c("port", "launch.browser", "host", "quiet", "display.mode")]

  args <- c(list(x), opts)

  do.call(runApp, args)
}

#' @rdname shinyApp
#' @method as.tags shiny.appobj
#' @export
as.tags.shiny.appobj <- function(x, ...) {
  # jcheng 06/06/2014: Unfortunate copy/paste between this function and
  # knit_print.shiny.appobj, but I am trying to make the most conservative
  # change possible due to upcoming release.
  opts <- x$options %OR% list()
  width <- if (is.null(opts$width)) "100%" else opts$width
  height <- if (is.null(opts$height)) "400" else opts$height

  path <- addSubApp(x)
  tags$iframe(src=path, width=width, height=height, class="shiny-frame")
}

#' Knitr S3 methods
#'
#' These S3 methods are necessary to help Shiny applications and UI chunks embed
#' themselves in knitr/rmarkdown documents.
#'
#' @name knitr_methods
#' @param x Object to knit_print
#' @param ... Additional knit_print arguments
NULL

# If there's an R Markdown runtime option set but it isn't set to Shiny, then
# return a warning indicating the runtime is inappropriate for this object.
# Returns NULL in all other cases.
shiny_rmd_warning <- function() {
  runtime <- knitr::opts_knit$get("rmarkdown.runtime")
  if (!is.null(runtime) && runtime != "shiny")
    # note that the RStudio IDE checks for this specific string to detect Shiny
    # applications in static document
    list(structure(
      "Shiny application in a static R Markdown document",
      class = "rmd_warning"))
  else
    NULL
}

#' @rdname knitr_methods
#' @export
knit_print.shiny.appobj <- function(x, ...) {
  opts <- x$options %OR% list()
  width <- if (is.null(opts$width)) "100%" else opts$width
  height <- if (is.null(opts$height)) "400" else opts$height

  runtime <- knitr::opts_knit$get("rmarkdown.runtime")
  if (!is.null(runtime) && runtime != "shiny") {
    # If not rendering to a Shiny document, create a box exactly the same
    # dimensions as the Shiny app would have had (so the document continues to
    # flow as it would have with the app), and display a diagnostic message
    width <- validateCssUnit(width)
    height <- validateCssUnit(height)
    output <- tags$div(
      style=paste("width:", width, "; height:", height, "; text-align: center;",
                  "box-sizing: border-box;", "-moz-box-sizing: border-box;",
                  "-webkit-box-sizing: border-box;"),
      class="muted well",
      "Shiny applications not supported in static R Markdown documents")
  }
  else {
    path <- addSubApp(x)
    output <- tags$iframe(src=path, width=width, height=height,
                          class="shiny-frame")
  }

  # If embedded Shiny apps ever have JS/CSS dependencies (like pym.js) we'll
  # need to grab those and put them in meta, like in knit_print.shiny.tag. But
  # for now it's not an issue, so just return the HTML and warning.

  knitr::asis_output(htmlPreserve(format(output, indent=FALSE)),
                     meta = shiny_rmd_warning(), cacheable = FALSE)
}

# Let us use a nicer syntax in knitr chunks than literally
# calling output$value <- renderFoo(...) and fooOutput().
#' @rdname knitr_methods
#' @param inline Whether the object is printed inline.
#' @export
knit_print.shiny.render.function <- function(x, ..., inline = FALSE) {
  x <- htmltools::as.tags(x, inline = inline)
  output <- knitr::knit_print(tagList(x))
  attr(output, "knit_cacheable") <- FALSE
  attr(output, "knit_meta") <- append(attr(output, "knit_meta"),
                                      shiny_rmd_warning())
  output
}