Do equivalent of "mkdir -p" when making state dir

Add ability to reset brush with session$resetBrush/Shiny.resetBrush

.gitignore

@@ -8,3 +8,4 @@
 /src-x86_64/
 shinyapps/
 README.html
+.*.Rnb.cached

.travis.yml

@@ -1,13 +1,6 @@
 language: r
-warnings_are_errors: true
-
-r_binary_packages:
-  - Rcpp
-  - cairo
-  - knitr
-
-r_github_packages:
-  - rstudio/htmltools
+sudo: false
+cache: packages
 
 notifications:
   email:

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 0.13.1
+Version: 0.13.2.9004
 Date: 2016-02-17
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
@@ -70,8 +70,9 @@ Imports:
     jsonlite (>= 0.9.16),
     xtable,
     digest,
-    htmltools (>= 0.3),
-    R6 (>= 2.0)
+    htmltools (>= 0.3.5),
+    R6 (>= 2.0),
+    sourcetools
 Suggests:
     datasets,
     Cairo (>= 1.5-5),
@@ -92,6 +93,7 @@ Collate:
     'utils.R'
     'bootstrap.R'
     'cache.R'
+    'diagnose.R'
     'fileupload.R'
     'stack.R'
     'graph.R'
@@ -115,10 +117,13 @@ Collate:
     'input-submit.R'
     'input-text.R'
     'input-utils.R'
+    'insert-ui.R'
     'jqueryui.R'
     'middleware-shiny.R'
     'middleware.R'
+    'modal.R'
     'modules.R'
+    'notifications.R'
     'priorityqueue.R'
     'progress.R'
     'react.R'
@@ -127,8 +132,12 @@ Collate:
     'render-plot.R'
     'render-table.R'
     'run-url.R'
+    'save-state-local.R'
+    'save-state.R'
+    'serializers.R'
     'server-input-handlers.R'
     'server.R'
+    'shiny-options.R'
     'shiny.R'
     'shinyui.R'
     'shinywrappers.R'

NAMESPACE

@@ -46,6 +46,7 @@ export(browserViewer)
 export(brushOpts)
 export(brushedPoints)
 export(callModule)
+export(cancelOutput)
 export(captureStackTraces)
 export(checkboxGroupInput)
 export(checkboxInput)
@@ -54,6 +55,7 @@ export(code)
 export(column)
 export(conditionStackTrace)
 export(conditionalPanel)
+export(configureBookmarking)
 export(createWebDependency)
 export(dataTableOutput)
 export(dateInput)
@@ -80,6 +82,7 @@ export(fluidPage)
 export(fluidRow)
 export(formatStackTrace)
 export(getDefaultReactiveDomain)
+export(getShinyOption)
 export(h1)
 export(h2)
 export(h3)
@@ -102,8 +105,10 @@ export(includeMarkdown)
 export(includeScript)
 export(includeText)
 export(inputPanel)
+export(insertUI)
 export(installExprFunction)
 export(invalidateLater)
+export(invalidateReactiveValue)
 export(is.reactive)
 export(is.reactivevalues)
 export(is.shiny.appobj)
@@ -119,6 +124,8 @@ export(mainPanel)
 export(makeReactiveBinding)
 export(markRenderFunction)
 export(maskReactiveContext)
+export(modalButton)
+export(modalDialog)
 export(navbarMenu)
 export(navbarPage)
 export(navlistPanel)
@@ -154,6 +161,9 @@ export(reactiveValues)
 export(reactiveValuesToList)
 export(registerInputHandler)
 export(removeInputHandler)
+export(removeModal)
+export(removeNotification)
+export(removeUI)
 export(renderDataTable)
 export(renderImage)
 export(renderPlot)
@@ -163,12 +173,15 @@ export(renderText)
 export(renderUI)
 export(repeatable)
 export(req)
+export(restoreInput)
 export(runApp)
 export(runExample)
 export(runGadget)
 export(runGist)
 export(runGitHub)
 export(runUrl)
+export(safeError)
+export(saveStateButton)
 export(selectInput)
 export(selectizeInput)
 export(serverInfo)
@@ -176,8 +189,11 @@ export(setProgress)
 export(shinyApp)
 export(shinyAppDir)
 export(shinyAppFile)
+export(shinyOptions)
 export(shinyServer)
 export(shinyUI)
+export(showModal)
+export(showNotification)
 export(showReactLog)
 export(sidebarLayout)
 export(sidebarPanel)
@@ -203,10 +219,12 @@ export(textInput)
 export(textOutput)
 export(titlePanel)
 export(uiOutput)
+export(updateActionButton)
 export(updateCheckboxGroupInput)
 export(updateCheckboxInput)
 export(updateDateInput)
 export(updateDateRangeInput)
+export(updateLocationBar)
 export(updateNavbarPage)
 export(updateNavlistPanel)
 export(updateNumericInput)
@@ -216,6 +234,7 @@ export(updateSelectizeInput)
 export(updateSliderInput)
 export(updateTabsetPanel)
 export(updateTextInput)
+export(urlModal)
 export(validate)
 export(validateCssUnit)
 export(verbatimTextOutput)

NEWS

@@ -1,11 +1,93 @@
+shiny 0.13.2.9001
+--------------------------------------------------------------------------------
+* `Display: Showcase` now displays the .js, .html and .css files in the `www`
+  directory by default. In order to use showcase mode and not display these,
+  include a new line in your Description file: `IncludeWWW: False`.
+
+* Added insertUI and removeUI functions to be able to add and remove chunks
+  of UI, standalone, and all independent of one another.
+
+* Added an error sanitization option: `options(shiny.sanitize.errors = TRUE)`.
+  By default, this option is `FALSE`. When `TRUE`, normal errors will be
+  sanitized, displaying only a generic error message. This changes the look
+  of an app when errors are printed (but the console log remains the same).
+
+* Closed #1161: Deprecated the `position` argument to `tabsetPanel()` since
+  Bootstrap 3 stopped supporting this feature.
+
+* BREAKING CHANGE: The long-deprecated ability to pass a `func` argument to
+  many of the `render` functions has been removed.
+
+* Added the option of passing arguments to an `xxxOutput()` function through
+  the corresponding `renderXXX()` function via an `outputArgs` parameter to the
+  latter. This is only valid for snippets of Shiny code in an interactive
+  `runtime: shiny` Rmd document (never for full apps, even if embedded in an
+  Rmd).
+
+* Added the ability for the client browser to reconnect to a new session on
+  the server, by setting `session$allowReconnect(TRUE)`. This requires a
+  version of Shiny Server that supports reconnections. (#1074)
+
+* Added a new notification API. From R, there are new functions
+  `showNotification` and `hideNotification`. From JavaScript, there is a new
+  `Shiny.notification` object that controls notifications. (#1141)
+
+* Improved `renderTable()` function to make the tables look prettier and also
+  provide the user with a lot more parameters to customize their tables with.
+
+* Added `updateActionButton()` function, so the user can change an Action Button's
+  (or Link's) label and/or icon. Also check that the icon argument (for both
+  creation and updating of a button) is valid and throw a warning otherwise.
+
+* Fixed #1056: Upgraded Bootstrap to 3.3.6.
+
+* Updated ion.RangeSlider to 2.1.2.
+
+* Fixed #561: DataTables might pop up a warning when the data is updated
+  extremely frequently.
+
+* Fixed #776: In some browsers, plots sometimes flickered when updated.
+
+* When resized, plots are drawn with `replayPlot()`, instead of re-executing
+  all plotting code. This results in faster plot rendering.
+
+* Added `cancelOutput` function, and a `cancelOutput` parameter to `req`. The
+  function causes the currently executing output to cancel its execution, and
+  leave its previous state alone (as opposed to clearing the output). The `req`
+  parameter similarly modifies the behavior of `req`.
+
+* Added code diagnostics: if there is an error parsing ui.R, server.R, app.R,
+  or global.R, Shiny will search the code for missing commas, extra commas,
+  and unmatched braces, parens, and brackets, and will print out messages
+  pointing out those problems.
+
+* Added support for horizontal dividers in `navbarMenu`. (#888)
+
+* Fixed #543, #855: When navbarPage had a navbarMenu as the first item, it
+  not automatically select an item.
+
+* navbarPage previously did not have an option to set the selected tab. (#970)
+
+* navbarMenu now has dividers and dropdown headers (#888)
+
+* Added `placeholder` option to `passwordInput`.
+
+* Almost all code examples now have a runnable example with `shinyApp()`, so
+  that users can run the examples and see them in action. (#1137, #1158)
+
+* Added `session$resetBrush(brushId)` (R) and `Shiny.resetBrush(brushId)` (JS)
+  to programatically clear brushes from `imageOutput`/`plotOutput`.
+
+shiny 0.13.2
+--------------------------------------------------------------------------------
+
+* Updated documentation for `htmlTemplate`.
+
 shiny 0.13.1
 --------------------------------------------------------------------------------
 
 * `flexCol` did not work on RStudio for Windows or Linux.
 
-* Fixed #561: DataTables might pop up a warning when the data is updated
-  extremely frequently.
-
 * Fixed RStudio debugger integration.
 
 * BREAKING CHANGE: The long-deprecated ability to pass functions (rather than

R/app.R

@@ -99,6 +99,10 @@ shinyAppDir <- function(appDir, options=list()) {
   # affected by future changes to the path)
   appDir <- normalizePath(appDir, mustWork = TRUE)
 
+  # Store appDir in options so that we can find out where we are from within the
+  # app.
+  shinyOptions(appDir = appDir)
+
   if (file.exists.ci(appDir, "server.R")) {
     shinyAppDir_serverR(appDir, options = options)
   } else if (file.exists.ci(appDir, "app.R")) {
@@ -113,7 +117,12 @@ shinyAppDir <- function(appDir, options=list()) {
 #' @export
 shinyAppFile <- function(appFile, options=list()) {
   appFile <- normalizePath(appFile, mustWork = TRUE)
-  shinyAppDir_appR(basename(appFile), dirname(appFile), options = options)
+  appDir <- dirname(appFile)
+
+  # Store appDir in options so that we can find out where we are
+  shinyOptions(appDir = appDir)
+
+  shinyAppDir_appR(basename(appFile), appDir, options = options)
 }
 
 # This reads in an app dir in the case that there's a server.R (and ui.R/www)

R/bootstrap-layout.R

@@ -31,7 +31,11 @@
 #' @seealso \code{\link{column}}, \code{\link{sidebarLayout}}
 #'
 #' @examples
-#' shinyUI(fluidPage(
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' # Example of UI with fluidPage
+#' ui <- fluidPage(
 #'
 #'   # Application title
 #'   titlePanel("Hello Shiny!"),
@@ -52,9 +56,21 @@
 #'       plotOutput("distPlot")
 #'     )
 #'   )
-#' ))
+#' )
 #'
-#' shinyUI(fluidPage(
+#' # Server logic
+#' server <- function(input, output) {
+#'   output$distPlot <- renderPlot({
+#'     hist(rnorm(input$obs))
+#'   })
+#' }
+#'
+#' # Complete app with UI and server components
+#' shinyApp(ui, server)
+#'
+#'
+#' # UI demonstrating column layouts
+#' ui <- fluidPage(
 #'   title = "Hello Shiny!",
 #'   fluidRow(
 #'     column(width = 4,
@@ -64,8 +80,10 @@
 #'       "3 offset 2"
 #'     )
 #'   )
-#' ))
+#' )
 #'
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #' @rdname fluidPage
 #' @export
 fluidPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
@@ -115,7 +133,10 @@ fluidRow <- function(...) {
 #' @seealso \code{\link{column}}
 #'
 #' @examples
-#' shinyUI(fixedPage(
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fixedPage(
 #'   title = "Hello, Shiny!",
 #'   fixedRow(
 #'     column(width = 4,
@@ -125,7 +146,10 @@ fluidRow <- function(...) {
 #'       "3 offset 2"
 #'     )
 #'   )
-#' ))
+#' )
+#'
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #'
 #' @rdname fixedPage
 #' @export
@@ -160,24 +184,43 @@ fixedRow <- function(...) {
 #' @seealso \code{\link{fluidRow}}, \code{\link{fixedRow}}.
 #'
 #' @examples
-#' fluidRow(
-#'   column(4,
-#'     sliderInput("obs", "Number of observations:",
-#'                 min = 1, max = 1000, value = 500)
-#'   ),
-#'   column(8,
-#'     plotOutput("distPlot")
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   fluidRow(
+#'     column(4,
+#'       sliderInput("obs", "Number of observations:",
+#'                   min = 1, max = 1000, value = 500)
+#'     ),
+#'     column(8,
+#'       plotOutput("distPlot")
+#'     )
 #'   )
 #' )
 #'
-#' fluidRow(
-#'   column(width = 4,
-#'     "4"
-#'   ),
-#'   column(width = 3, offset = 2,
-#'     "3 offset 2"
+#' server <- function(input, output) {
+#'   output$distPlot <- renderPlot({
+#'     hist(rnorm(input$obs))
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#'
+#'
+#' ui <- fluidPage(
+#'   fluidRow(
+#'     column(width = 4,
+#'       "4"
+#'     ),
+#'     column(width = 3, offset = 2,
+#'       "3 offset 2"
+#'     )
 #'   )
 #' )
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #' @export
 column <- function(width, ..., offset = 0) {
 
@@ -202,8 +245,14 @@ column <- function(width, ..., offset = 0) {
 #'
 #'
 #' @examples
-#' titlePanel("Hello Shiny!")
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   titlePanel("Hello Shiny!")
+#' )
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #' @export
 titlePanel <- function(title, windowTitle=title) {
   tagList(
@@ -226,8 +275,11 @@ titlePanel <- function(title, windowTitle=title) {
 #'   layout.
 #'
 #' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
 #' # Define UI
-#' shinyUI(fluidPage(
+#' ui <- fluidPage(
 #'
 #'   # Application title
 #'   titlePanel("Hello Shiny!"),
@@ -248,8 +300,18 @@ titlePanel <- function(title, windowTitle=title) {
 #'       plotOutput("distPlot")
 #'     )
 #'   )
-#' ))
+#' )
 #'
+#' # Server logic
+#' server <- function(input, output) {
+#'   output$distPlot <- renderPlot({
+#'     hist(rnorm(input$obs))
+#'   })
+#' }
+#'
+#' # Complete app with UI and server components
+#' shinyApp(ui, server)
+#' }
 #' @export
 sidebarLayout <- function(sidebarPanel,
                           mainPanel,
@@ -286,13 +348,18 @@ sidebarLayout <- function(sidebarPanel,
 #' @seealso \code{\link{fluidPage}}, \code{\link{flowLayout}}
 #'
 #' @examples
-#' shinyUI(fluidPage(
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
 #'   verticalLayout(
 #'     a(href="http://example.com/link1", "Link One"),
 #'     a(href="http://example.com/link2", "Link Two"),
 #'     a(href="http://example.com/link3", "Link Three")
 #'   )
-#' ))
+#' )
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #' @export
 verticalLayout <- function(..., fluid = TRUE) {
   lapply(list(...), function(row) {
@@ -319,11 +386,16 @@ verticalLayout <- function(..., fluid = TRUE) {
 #' @seealso \code{\link{verticalLayout}}
 #'
 #' @examples
-#' flowLayout(
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- flowLayout(
 #'   numericInput("rows", "How many rows?", 5),
 #'   selectInput("letter", "Which letter?", LETTERS),
 #'   sliderInput("value", "What value?", 0, 100, 50)
 #' )
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #' @export
 flowLayout <- function(..., cellArgs = list()) {
 
@@ -369,21 +441,33 @@ inputPanel <- function(...) {
 #'   of the layout.
 #'
 #' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' # Server code used for all examples
+#' server <- function(input, output) {
+#'   output$plot1 <- renderPlot(plot(cars))
+#'   output$plot2 <- renderPlot(plot(pressure))
+#'   output$plot3 <- renderPlot(plot(AirPassengers))
+#' }
+#'
 #' # Equal sizing
-#' splitLayout(
+#' ui <- splitLayout(
 #'   plotOutput("plot1"),
 #'   plotOutput("plot2")
 #' )
+#' shinyApp(ui, server)
 #'
 #' # Custom widths
-#' splitLayout(cellWidths = c("25%", "75%"),
+#' ui <- splitLayout(cellWidths = c("25%", "75%"),
 #'   plotOutput("plot1"),
 #'   plotOutput("plot2")
 #' )
+#' shinyApp(ui, server)
 #'
 #' # All cells at 300 pixels wide, with cell padding
 #' # and a border around everything
-#' splitLayout(
+#' ui <- splitLayout(
 #'   style = "border: 1px solid silver;",
 #'   cellWidths = 300,
 #'   cellArgs = list(style = "padding: 6px"),
@@ -391,6 +475,8 @@ inputPanel <- function(...) {
 #'   plotOutput("plot2"),
 #'   plotOutput("plot3")
 #' )
+#' shinyApp(ui, server)
+#' }
 #' @export
 splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
 
@@ -460,10 +546,7 @@ splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
 #'   not determined by the height of its contents.
 #'
 #' @examples
-#' \donttest{
 #' # Only run this example in interactive R sessions.
-#' # NOTE: This example should be run with example(fillRow, ask = FALSE) to
-#' # avoid being prompted to hit Enter during plot rendering.
 #' if (interactive()) {
 #'
 #' ui <- fillPage(fillRow(
@@ -483,7 +566,6 @@ splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
 #' shinyApp(ui, server)
 #'
 #' }
-#' }
 #' @export
 fillRow <- function(..., flex = 1, width = "100%", height = "100%") {
   flexfill(..., direction = "row", flex = flex, width = width, height = height)

R/bootstrap.R

@@ -43,7 +43,7 @@ bootstrapPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
       # remainder of tags passed to the function
       list(...)
     ),
-    bootstrapDependency()
+    bootstrapLib()
   )
 }
 
@@ -61,11 +61,7 @@ bootstrapPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
 #' @inheritParams bootstrapPage
 #' @export
 bootstrapLib <- function(theme = NULL) {
-  attachDependencies(tagList(), bootstrapDependency(theme))
-}
-
-bootstrapDependency <- function(theme = NULL) {
-  htmlDependency("bootstrap", "3.3.5",
+  htmlDependency("bootstrap", "3.3.6",
     c(
       href = "shared/bootstrap",
       file = system.file("www/shared/bootstrap", package = "shiny")
@@ -200,7 +196,7 @@ collapseSizes <- function(padding) {
 #'
 #' @examples
 #' # Define UI
-#' shinyUI(pageWithSidebar(
+#' pageWithSidebar(
 #'
 #'   # Application title
 #'   headerPanel("Hello Shiny!"),
@@ -218,7 +214,7 @@ collapseSizes <- function(padding) {
 #'   mainPanel(
 #'     plotOutput("distPlot")
 #'   )
-#' ))
+#' )
 #'
 #' @export
 pageWithSidebar <- function(headerPanel,
@@ -246,18 +242,24 @@ pageWithSidebar <- function(headerPanel,
 #' toggle a set of \code{\link{tabPanel}} elements.
 #'
 #' @param title The title to display in the navbar
-#' @param ... \code{\link{tabPanel}} elements to include in the page
+#' @param ... \code{\link{tabPanel}} elements to include in the page. The
+#'   \code{navbarMenu} function also accepts strings, which will be used as menu
+#'   section headers. If the string is a set of dashes like \code{"----"} a
+#'   horizontal separator will be displayed in the menu.
 #' @param id If provided, you can use \code{input$}\emph{\code{id}} in your
 #'   server logic to determine which of the current tabs is active. The value
 #'   will correspond to the \code{value} argument that is passed to
 #'   \code{\link{tabPanel}}.
+#' @param selected The \code{value} (or, if none was supplied, the \code{title})
+#'   of the tab that should be selected by default. If \code{NULL}, the first
+#'   tab will be selected.
 #' @param position Determines whether the navbar should be displayed at the top
-#'   of the page with normal scrolling behavior (\code{"static-top"}), pinned
-#'   at the top (\code{"fixed-top"}), or pinned at the bottom
+#'   of the page with normal scrolling behavior (\code{"static-top"}), pinned at
+#'   the top (\code{"fixed-top"}), or pinned at the bottom
 #'   (\code{"fixed-bottom"}). Note that using \code{"fixed-top"} or
 #'   \code{"fixed-bottom"} will cause the navbar to overlay your body content,
-#'   unless you add padding, e.g.:
-#'   \code{tags$style(type="text/css", "body {padding-top: 70px;}")}
+#'   unless you add padding, e.g.: \code{tags$style(type="text/css", "body
+#'   {padding-top: 70px;}")}
 #' @param header Tag or list of tags to display as a common header above all
 #'   tabPanels.
 #' @param footer Tag or list of tags to display as a common footer below all
@@ -289,23 +291,26 @@ pageWithSidebar <- function(headerPanel,
 #'   \code{\link{updateNavbarPage}}
 #'
 #' @examples
-#' shinyUI(navbarPage("App Title",
+#' navbarPage("App Title",
 #'   tabPanel("Plot"),
 #'   tabPanel("Summary"),
 #'   tabPanel("Table")
-#' ))
+#' )
 #'
-#' shinyUI(navbarPage("App Title",
+#' navbarPage("App Title",
 #'   tabPanel("Plot"),
 #'   navbarMenu("More",
 #'     tabPanel("Summary"),
+#'     "----",
+#'     "Section header",
 #'     tabPanel("Table")
 #'   )
-#' ))
+#' )
 #' @export
 navbarPage <- function(title,
                        ...,
                        id = NULL,
+                       selected = NULL,
                        position = c("static-top", "fixed-top", "fixed-bottom"),
                        header = NULL,
                        footer = NULL,
@@ -335,7 +340,7 @@ navbarPage <- function(title,
 
   # build the tabset
   tabs <- list(...)
-  tabset <- buildTabset(tabs, "nav navbar-nav", NULL, id)
+  tabset <- buildTabset(tabs, "nav navbar-nav", NULL, id, selected)
 
   # built the container div dynamically to support optional collapsibility
   if (collapsible) {
@@ -602,10 +607,8 @@ tabPanel <- function(title, ..., value = title, icon = NULL) {
 #'   tab will be selected.
 #' @param type Use "tabs" for the standard look; Use "pills" for a more plain
 #'   look where tabs are selected using a background fill color.
-#' @param position The position of the tabs relative to the content. Valid
-#'   values are "above", "below", "left", and "right" (defaults to "above").
-#'   Note that the \code{position} argument is not valid when \code{type} is
-#'   "pill".
+#' @param position This argument is deprecated; it has been discontinued in
+#'   Bootstrap 3.
 #' @return A tabset that can be passed to \code{\link{mainPanel}}
 #'
 #' @seealso \code{\link{tabPanel}}, \code{\link{updateTabsetPanel}}
@@ -625,25 +628,24 @@ tabsetPanel <- function(...,
                         id = NULL,
                         selected = NULL,
                         type = c("tabs", "pills"),
-                        position = c("above", "below", "left", "right")) {
+                        position = NULL) {
+  if (!is.null(position)) {
+    shinyDeprecated(msg = paste("tabsetPanel: argument 'position' is deprecated;",
+                                "it has been discontinued in Bootstrap 3."),
+                    version = "0.10.2.2")
+  }
 
   # build the tabset
   tabs <- list(...)
   type <- match.arg(type)
   tabset <- buildTabset(tabs, paste0("nav nav-", type), NULL, id, selected)
 
-  # position the nav list and content appropriately
-  position <- match.arg(position)
-  if (position %in% c("above", "left", "right")) {
-    first <- tabset$navList
-    second <- tabset$content
-  } else if (position %in% c("below")) {
-    first <- tabset$content
-    second <- tabset$navList
-  }
+  # create the content
+  first <- tabset$navList
+  second <- tabset$content
 
   # create the tab div
-  tags$div(class = paste("tabbable tabs-", position, sep=""), first, second)
+  tags$div(class = "tabbable", first, second)
 }
 
 #' Create a navigation list panel
@@ -674,7 +676,7 @@ tabsetPanel <- function(...,
 #'
 #' @seealso \code{\link{tabPanel}}, \code{\link{updateNavlistPanel}}
 #' @examples
-#' shinyUI(fluidPage(
+#' fluidPage(
 #'
 #'   titlePanel("Application Title"),
 #'
@@ -684,7 +686,7 @@ tabsetPanel <- function(...,
 #'     tabPanel("Second"),
 #'     tabPanel("Third")
 #'   )
-#' ))
+#' )
 #' @export
 navlistPanel <- function(...,
                          id = NULL,
@@ -720,117 +722,188 @@ navlistPanel <- function(...,
 }
 
 
-buildTabset <- function(tabs,
-                        ulClass,
-                        textFilter = NULL,
-                        id = NULL,
-                        selected = NULL) {
+buildTabset <- function(tabs, ulClass, textFilter = NULL,
+                        id = NULL, selected = NULL) {
 
-  # build tab nav list and tab content div
+  # This function proceeds in two phases. First, it scans over all the items
+  # to find and mark which tab should start selected. Then it actually builds
+  # the tab nav and tab content lists.
 
-  # add tab input sentinel class if we have an id
-  if (!is.null(id))
-    ulClass <- paste(ulClass, "shiny-tab-input")
-
-  tabNavList <- tags$ul(class = ulClass, id = id)
-  tabContent <- tags$div(class = "tab-content")
-  firstTab <- TRUE
-  tabsetId <- p_randomInt(1000, 10000)
-  tabId <- 1
-  for (divTag in tabs) {
-
-    # check for text; pass it to the textFilter or skip it if there is none
-    if (is.character(divTag)) {
-      if (!is.null(textFilter))
-        tabNavList <- tagAppendChild(tabNavList, textFilter(divTag))
-      next
-    }
-
-    # compute id and assign it to the div
-    thisId <- paste("tab", tabsetId, tabId, sep="-")
-    divTag$attribs$id <- thisId
-    tabId <- tabId + 1
-
-    tabValue <- divTag$attribs$`data-value`
-
-    # function to append an optional icon to an aTag
-    appendIcon <- function(aTag, iconClass) {
-      if (!is.null(iconClass)) {
-        # for font-awesome we specify fixed-width
-        if (grepl("fa-", iconClass, fixed = TRUE))
-          iconClass <- paste(iconClass, "fa-fw")
-        aTag <- tagAppendChild(aTag, icon(name = NULL, class = iconClass))
-      }
-      aTag
-    }
-
-    # check for a navbarMenu and handle appropriately
-    if (inherits(divTag, "shiny.navbarmenu")) {
-
-      # create the a tag
-      aTag <- tags$a(href="#",
-                     class="dropdown-toggle",
-                     `data-toggle`="dropdown")
-
-      # add optional icon
-      aTag <- appendIcon(aTag, divTag$iconClass)
-
-      # add the title and caret
-      aTag <- tagAppendChild(aTag, divTag$title)
-      aTag <- tagAppendChild(aTag, tags$b(class="caret"))
-
-      # build the dropdown list element
-      liTag <- tags$li(class = "dropdown", aTag)
-
-      # build the child tabset
-      tabset <- buildTabset(divTag$tabs, "dropdown-menu")
-      liTag <- tagAppendChild(liTag, tabset$navList)
-
-      # don't add a standard tab content div, rather add the list of tab
-      # content divs that are contained within the tabset
-      divTag <- NULL
-      tabContent <- tagAppendChildren(tabContent,
-                                      list = tabset$content$children)
-    }
-    # else it's a standard navbar item
-    else {
-      # create the a tag
-      aTag <- tags$a(href=paste("#", thisId, sep=""),
-                     `data-toggle` = "tab",
-                     `data-value` = tabValue)
-
-      # append optional icon
-      aTag <- appendIcon(aTag, divTag$attribs$`data-icon-class`)
-
-      # add the title
-      aTag <- tagAppendChild(aTag, divTag$attribs$title)
-
-      # create the li tag
-      liTag <- tags$li(aTag)
-    }
-
-    if (is.null(tabValue)) {
-      tabValue <- divTag$attribs$title
-    }
-
-    # If appropriate, make this the selected tab (don't ever do initial
-    # selection of tabs that are within a navbarMenu)
-    if ((ulClass != "dropdown-menu") &&
-       ((firstTab && is.null(selected)) ||
-        (!is.null(selected) && identical(selected, tabValue)))) {
-      liTag$attribs$class <- "active"
-      divTag$attribs$class <- "tab-pane active"
-      firstTab = FALSE
-    }
-
-    divTag$attribs$title <- NULL
-
-    # append the elements to our lists
-    tabNavList <- tagAppendChild(tabNavList, liTag)
-    tabContent <- tagAppendChild(tabContent, divTag)
+  # Mark an item as selected
+  markSelected <- function(x) {
+    attr(x, "selected") <- TRUE
+    x
   }
 
-  list(navList = tabNavList, content = tabContent)
+  # Returns TRUE if an item is selected
+  isSelected <- function(x) {
+    isTRUE(attr(x, "selected", exact = TRUE))
+  }
+
+  # Returns TRUE if a list of tab items contains a selected tab, FALSE
+  # otherwise.
+  containsSelected <- function(tabs) {
+    any(vapply(tabs, isSelected, logical(1)))
+  }
+
+  # Take a pass over all tabs, and mark the selected tab.
+  foundSelectedItem <- FALSE
+  findAndMarkSelected <- function(tabs, selected) {
+    lapply(tabs, function(divTag) {
+      if (foundSelectedItem) {
+        # If we already found the selected tab, no need to keep looking
+
+      } else if (is.character(divTag)) {
+        # Strings don't represent selectable items
+
+      } else if (inherits(divTag, "shiny.navbarmenu")) {
+        # Navbar menu
+        divTag$tabs <- findAndMarkSelected(divTag$tabs, selected)
+
+      } else {
+        # Regular tab item
+        if (is.null(selected)) {
+          # If selected tab isn't specified, mark first available item
+          # as selected.
+          foundSelectedItem <<- TRUE
+          divTag <- markSelected(divTag)
+
+        } else {
+          # If selected tab is specified, check for a match
+          tabValue <- divTag$attribs$`data-value` %OR% divTag$attribs$title
+          if (identical(selected, tabValue)) {
+            foundSelectedItem <<- TRUE
+            divTag <- markSelected(divTag)
+          }
+        }
+      }
+
+      return(divTag)
+    })
+  }
+
+
+  # Append an optional icon to an aTag
+  appendIcon <- function(aTag, iconClass) {
+    if (!is.null(iconClass)) {
+      # for font-awesome we specify fixed-width
+      if (grepl("fa-", iconClass, fixed = TRUE))
+        iconClass <- paste(iconClass, "fa-fw")
+      aTag <- tagAppendChild(aTag, icon(name = NULL, class = iconClass))
+    }
+    aTag
+  }
+
+  # Build the tabset
+  build <- function(tabs, ulClass, textFilter = NULL, id = NULL) {
+    # add tab input sentinel class if we have an id
+    if (!is.null(id))
+      ulClass <- paste(ulClass, "shiny-tab-input")
+
+    if (anyNamed(tabs)) {
+      nms <- names(tabs)
+      nms <- nms[nzchar(nms)]
+      stop("Tabs should all be unnamed arguments, but some are named: ",
+           paste(nms, collapse = ", "))
+    }
+
+    tabNavList <- tags$ul(class = ulClass, id = id)
+    tabContent <- tags$div(class = "tab-content")
+    tabsetId <- p_randomInt(1000, 10000)
+    tabId <- 1
+
+    buildItem <- function(divTag) {
+      # check for text; pass it to the textFilter or skip it if there is none
+      if (is.character(divTag)) {
+        if (!is.null(textFilter)) {
+          tabNavList <<- tagAppendChild(tabNavList, textFilter(divTag))
+        }
+
+      } else if (inherits(divTag, "shiny.navbarmenu")) {
+
+        # create the a tag
+        aTag <- tags$a(href="#",
+                       class="dropdown-toggle",
+                       `data-toggle`="dropdown")
+
+        # add optional icon
+        aTag <- appendIcon(aTag, divTag$iconClass)
+
+        # add the title and caret
+        aTag <- tagAppendChild(aTag, divTag$title)
+        aTag <- tagAppendChild(aTag, tags$b(class="caret"))
+
+        # build the dropdown list element
+        liTag <- tags$li(class = "dropdown", aTag)
+
+        # text filter for separators
+        textFilter <- function(text) {
+          if (grepl("^\\-+$", text))
+            tags$li(class="divider")
+          else
+            tags$li(class="dropdown-header", text)
+        }
+
+        # build the child tabset
+        tabset <- build(divTag$tabs, "dropdown-menu", textFilter)
+        liTag <- tagAppendChild(liTag, tabset$navList)
+
+        # If this navbar menu contains a selected item, mark it as active
+        if (containsSelected(divTag$tabs)) {
+          liTag$attribs$class <- paste(liTag$attribs$class, "active")
+        }
+
+        tabNavList <<- tagAppendChild(tabNavList, liTag)
+        # don't add a standard tab content div, rather add the list of tab
+        # content divs that are contained within the tabset
+        tabContent <<- tagAppendChildren(tabContent,
+                                        list = tabset$content$children)
+
+      } else {
+        # Standard navbar item
+        # compute id and assign it to the div
+        thisId <- paste("tab", tabsetId, tabId, sep="-")
+        divTag$attribs$id <- thisId
+        tabId <<- tabId + 1
+
+        tabValue <- divTag$attribs$`data-value`
+
+        # create the a tag
+        aTag <- tags$a(href=paste("#", thisId, sep=""),
+                       `data-toggle` = "tab",
+                       `data-value` = tabValue)
+
+        # append optional icon
+        aTag <- appendIcon(aTag, divTag$attribs$`data-icon-class`)
+
+        # add the title
+        aTag <- tagAppendChild(aTag, divTag$attribs$title)
+
+        # create the li tag
+        liTag <- tags$li(aTag)
+
+        # If selected, set appropriate classes on li tag and div tag.
+        if (isSelected(divTag)) {
+          liTag$attribs$class <- "active"
+          divTag$attribs$class <- "tab-pane active"
+        }
+
+        divTag$attribs$title <- NULL
+
+        # append the elements to our lists
+        tabNavList <<- tagAppendChild(tabNavList, liTag)
+        tabContent <<- tagAppendChild(tabContent, divTag)
+      }
+    }
+
+    lapply(tabs, buildItem)
+    list(navList = tabNavList, content = tabContent)
+  }
+
+
+  # Finally, actually invoke the functions to do the processing.
+  tabs <- findAndMarkSelected(tabs, selected)
+  build(tabs, ulClass, textFilter, id)
 }
 
 
@@ -1417,11 +1490,11 @@ downloadLink <- function(outputId, label="Download", class=NULL) {
 #' # add an icon to a submit button
 #' submitButton("Update View", icon = icon("refresh"))
 #'
-#' shinyUI(navbarPage("App Title",
+#' navbarPage("App Title",
 #'   tabPanel("Plot", icon = icon("bar-chart-o")),
 #'   tabPanel("Summary", icon = icon("list-alt")),
 #'   tabPanel("Table", icon = icon("table"))
-#' ))
+#' )
 #'
 #' @export
 icon <- function(name, class = NULL, lib = "font-awesome") {

R/conditions.R

@@ -131,9 +131,10 @@ withLogErrors <- function(expr,
     captureStackTraces(expr),
     error = function(cond) {
       # Don't print shiny.silent.error (i.e. validation errors)
-      if (inherits(cond, "shiny.silent.error"))
-        return()
-      printError(cond, full = full, offset = offset)
+      if (inherits(cond, "shiny.silent.error")) return()
+      if (isTRUE(getOption("show.error.messages"))) {
+        printError(cond, full = full, offset = offset)
+      }
     }
   )
 }

R/diagnose.R

@@ -0,0 +1,157 @@
+# Analyze an R file for possible extra or missing commas. Returns FALSE if any
+# problems detected, TRUE otherwise.
+diagnoseCode <- function(path = NULL, text = NULL) {
+  if (!xor(is.null(path), is.null(text))) {
+    stop("Must specify `path` or `text`, but not both.")
+  }
+
+  if (!is.null(path)) {
+    tokens <- sourcetools::tokenize_file(path)
+  } else {
+    tokens <- sourcetools::tokenize_string(text)
+  }
+
+  find_scopes <- function(tokens) {
+    # Strip whitespace and comments
+    tokens <- tokens[!(tokens$type %in% c("whitespace", "comment")),]
+
+    # Replace various types of things with "value"
+    tokens$type[tokens$type %in% c("string", "number", "symbol", "keyword")] <- "value"
+
+    # Record types for close and open brace/bracket/parens, and commas
+    brace_idx <- tokens$value %in% c("(", ")", "{", "}", "[", "]", ",")
+    tokens$type[brace_idx] <- tokens$value[brace_idx]
+
+    # Stack-related function for recording scope. Starting scope is "{"
+    stack <- "{"
+    push <- function(x) {
+      stack <<- c(stack, x)
+    }
+    pop <- function() {
+      if (length(stack) == 1) {
+        # Stack underflow, but we need to keep going
+        return(NA_character_)
+      }
+      res <- stack[length(stack)]
+      stack <<- stack[-length(stack)]
+      res
+    }
+    peek <- function() {
+      stack[length(stack)]
+    }
+
+    # First, establish a scope for each token. For opening and closing
+    # braces/brackets/parens, the scope at that location is the *surrounding*
+    # scope, not the new scope created by the brace/bracket/paren.
+    for (i in seq_len(nrow(tokens))) {
+      value <- tokens$value[i]
+
+      tokens$scope[i] <- peek()
+      if (value %in% c("{", "(", "[")) {
+        push(value)
+
+      } else if (value == "}") {
+        if (!identical(pop(), "{"))
+          tokens$err[i] <- "unmatched_brace"
+        # For closing brace/paren/bracket, get the scope after popping
+        tokens$scope[i] <- peek()
+
+      } else if (value == ")") {
+        if (!identical(pop(), "("))
+          tokens$err[i] <- "unmatched_paren"
+        tokens$scope[i] <- peek()
+
+      } else if (value == "]") {
+        if (!identical(pop(), "["))
+          tokens$err[i] <- "unmatched_bracket"
+        tokens$scope[i] <- peek()
+      }
+    }
+
+    tokens
+  }
+
+  check_commas <- function(tokens) {
+    # Find extra and missing commas
+    tokens$err <- mapply(
+      tokens$type,
+      c("", tokens$type[-length(tokens$type)]),
+      c(tokens$type[-1],  ""),
+      tokens$scope,
+      tokens$err,
+      SIMPLIFY = FALSE,
+      FUN = function(type, prevType, nextType, scope, err) {
+        # If an error was already found, just return it. This could have
+        # happened in the brace/paren/bracket matching phase.
+        if (!is.na(err)) {
+          return(err)
+        }
+        if (scope == "(") {
+          if (type == "," &&
+              (prevType == "(" || prevType == "," || nextType == ")"))
+          {
+            return("extra_comma")
+          }
+
+          if ((prevType == ")" && type == "value") ||
+              (prevType == "value" && type == "value")) {
+            return("missing_comma")
+          }
+        }
+
+        NA_character_
+      }
+    )
+
+    tokens
+  }
+
+
+  tokens$err <- NA_character_
+  tokens <- find_scopes(tokens)
+  tokens <- check_commas(tokens)
+
+  # No errors found
+  if (all(is.na(tokens$err))) {
+    return(TRUE)
+  }
+
+  # If we got here, errors were found; print messages.
+  if (!is.null(path)) {
+    lines <- readLines(path)
+  } else {
+    lines <- strsplit(text, "\n")[[1]]
+  }
+
+  # Print out the line of code with the error, and point to the column with
+  # the error.
+  show_code_error <- function(msg, lines, row, col) {
+    message(paste0(
+      msg, "\n",
+      row, ":", lines[row], "\n",
+      paste0(rep.int(" ", nchar(as.character(row)) + 1), collapse = ""),
+      gsub(perl = TRUE, "[^\\s]", " ", substr(lines[row], 1, col-1)), "^"
+    ))
+  }
+
+  err_idx <- which(!is.na(tokens$err))
+  msg <- ""
+  for (i in err_idx) {
+    row <- tokens$row[i]
+    col <- tokens$column[i]
+    err <- tokens$err[i]
+
+    if (err == "missing_comma") {
+      show_code_error("Possible missing comma at:", lines, row, col)
+    } else if (err == "extra_comma") {
+      show_code_error("Possible extra comma at:", lines, row, col)
+    } else if (err == "unmatched_brace") {
+      show_code_error("Possible unmatched '}' at:", lines, row, col)
+    } else if (err == "unmatched_paren") {
+      show_code_error("Possible unmatched ')' at:", lines, row, col)
+    } else if (err == "unmatched_bracket") {
+      show_code_error("Possible unmatched ']' at:", lines, row, col)
+    }
+  }
+  return(FALSE)
+}

R/graph.R

@@ -41,12 +41,15 @@ writeReactLog <- function(file=stdout(), sessionToken = NULL) {
 #' enabled, it's possible for any user of your app to see at least some
 #' of the source code of your reactive expressions and observers.
 #'
+#' @param time A boolean that specifies whether or not to display the
+#' time that each reactive.
+#'
 #' @export
-showReactLog <- function() {
-  utils::browseURL(renderReactLog())
+showReactLog <- function(time = TRUE) {
+  utils::browseURL(renderReactLog(time = as.logical(time)))
 }
 
-renderReactLog <- function(sessionToken = NULL) {
+renderReactLog <- function(sessionToken = NULL, time = TRUE) {
   templateFile <- system.file('www/reactive-graph.html', package='shiny')
   html <- paste(readLines(templateFile, warn=FALSE), collapse='\r\n')
   tc <- textConnection(NULL, 'w')
@@ -55,6 +58,7 @@ renderReactLog <- function(sessionToken = NULL) {
   cat('\n', file=tc)
   flush(tc)
   html <- sub('__DATA__', paste(textConnectionValue(tc), collapse='\r\n'), html, fixed=TRUE)
+  html <- sub('__TIME__', paste0('"', time, '"'), html, fixed=TRUE)
   file <- tempfile(fileext = '.html')
   writeLines(html, file)
   return(file)

R/html-deps.R

@@ -27,3 +27,21 @@ createWebDependency <- function(dependency) {
 
   return(dependency)
 }
+
+
+# Given a Shiny tag object, process singletons and dependencies. Returns a list
+# with rendered HTML and dependency objects.
+processDeps <- function(tags, session) {
+  ui <- takeSingletons(tags, session$singletons, desingleton=FALSE)$ui
+  ui <- surroundSingletons(ui)
+  dependencies <- lapply(
+    resolveDependencies(findDependencies(ui)),
+    createWebDependency
+  )
+  names(dependencies) <- NULL
+
+  list(
+    html = doRenderTags(ui),
+    deps = dependencies
+  )
+}

R/input-action.R

@@ -11,19 +11,29 @@
 #'
 #' @family input elements
 #' @examples
-#' \dontrun{
-#' # In server.R
-#' output$distPlot <- renderPlot({
-#'   # Take a dependency on input$goButton
-#'   input$goButton
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
-#'   # Use isolate() to avoid dependency on input$obs
-#'   dist <- isolate(rnorm(input$obs))
-#'   hist(dist)
-#' })
+#' ui <- fluidPage(
+#'   sliderInput("obs", "Number of observations", 0, 1000, 500),
+#'   actionButton("goButton", "Go!"),
+#'   plotOutput("distPlot")
+#' )
+#'
+#' server <- function(input, output) {
+#'   output$distPlot <- renderPlot({
+#'     # Take a dependency on input$goButton. This will run once initially,
+#'     # because the value changes from NULL to 0.
+#'     input$goButton
+#'
+#'     # Use isolate() to avoid dependency on input$obs
+#'     dist <- isolate(rnorm(input$obs))
+#'     hist(dist)
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
 #'
-#' # In ui.R
-#' actionButton("goButton", "Go!")
 #' }
 #'
 #' @seealso \code{\link{observeEvent}} and \code{\link{eventReactive}}
@@ -34,7 +44,7 @@ actionButton <- function(inputId, label, icon = NULL, width = NULL, ...) {
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     type="button",
     class="btn btn-default action-button",
-    list(icon, label),
+    list(validateIcon(icon), label),
     ...
   )
 }
@@ -45,7 +55,26 @@ actionLink <- function(inputId, label, icon = NULL, ...) {
   tags$a(id=inputId,
     href="#",
     class="action-button",
-    list(icon, label),
+    list(validateIcon(icon), label),
     ...
   )
 }
+
+
+# Check that the icon parameter is valid:
+# 1) Check  if the user wants to actually add an icon:
+#    -- if icon=NULL, it means leave the icon unchanged
+#    -- if icon=character(0), it means don't add an icon or, more usefully,
+#       remove the previous icon
+# 2) If so, check that the icon has the right format (this does not check whether
+# it is a *real* icon - currently that would require a massive cross reference
+# with the "font-awesome" and the "glyphicon" libraries)
+validateIcon <- function(icon) {
+  if (is.null(icon) || identical(icon, character(0))) {
+    return(icon)
+  } else if (inherits(icon, "shiny.tag") && icon$name == "i") {
+    return(icon)
+  } else {
+    stop("Invalid icon. Use Shiny's 'icon()' function to generate a valid icon")
+  }
+}

R/input-checkbox.R

@@ -10,9 +10,23 @@
 #' @seealso \code{\link{checkboxGroupInput}}, \code{\link{updateCheckboxInput}}
 #'
 #' @examples
-#' checkboxInput("outliers", "Show outliers", FALSE)
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   checkboxInput("somevalue", "Some value", FALSE),
+#'   verbatimTextOutput("value")
+#' )
+#' server <- function(input, output) {
+#'   output$value <- renderText({ input$somevalue })
+#' }
+#' shinyApp(ui, server)
+#' }
 #' @export
 checkboxInput <- function(inputId, label, value = FALSE, width = NULL) {
+
+  value <- restoreInput(id = inputId, default = value)
+
   inputTag <- tags$input(id = inputId, type="checkbox")
   if (!is.null(value) && value)
     inputTag$attribs$checked <- "checked"

R/input-checkboxgroup.R

@@ -15,15 +15,31 @@
 #' @seealso \code{\link{checkboxInput}}, \code{\link{updateCheckboxGroupInput}}
 #'
 #' @examples
-#' checkboxGroupInput("variable", "Variable:",
-#'                    c("Cylinders" = "cyl",
-#'                      "Transmission" = "am",
-#'                      "Gears" = "gear"))
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   checkboxGroupInput("variable", "Variables to show:",
+#'                      c("Cylinders" = "cyl",
+#'                        "Transmission" = "am",
+#'                        "Gears" = "gear")),
+#'   tableOutput("data")
+#' )
+#'
+#' server <- function(input, output) {
+#'   output$data <- renderTable({
+#'     mtcars[, c("mpg", input$variable), drop = FALSE]
+#'   }, rownames = TRUE)
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
 #' @export
 checkboxGroupInput <- function(inputId, label, choices, selected = NULL,
   inline = FALSE, width = NULL) {
 
+  selected <- restoreInput(id = inputId, default = selected)
+
   # resolve names
   choices <- choicesWithNames(choices)
   if (!is.null(selected))

R/input-date.R

@@ -43,26 +43,33 @@
 #' @seealso \code{\link{dateRangeInput}}, \code{\link{updateDateInput}}
 #'
 #' @examples
-#' dateInput("date", "Date:", value = "2012-02-29")
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
-#' # Default value is the date in client's time zone
-#' dateInput("date", "Date:")
+#' ui <- fluidPage(
+#'   dateInput("date1", "Date:", value = "2012-02-29"),
 #'
-#' # value is always yyyy-mm-dd, even if the display format is different
-#' dateInput("date", "Date:", value = "2012-02-29", format = "mm/dd/yy")
+#'   # Default value is the date in client's time zone
+#'   dateInput("date2", "Date:"),
 #'
-#' # Pass in a Date object
-#' dateInput("date", "Date:", value = Sys.Date()-10)
+#'   # value is always yyyy-mm-dd, even if the display format is different
+#'   dateInput("date3", "Date:", value = "2012-02-29", format = "mm/dd/yy"),
 #'
-#' # Use different language and different first day of week
-#' dateInput("date", "Date:",
+#'   # Pass in a Date object
+#'   dateInput("date4", "Date:", value = Sys.Date()-10),
+#'
+#'   # Use different language and different first day of week
+#'   dateInput("date5", "Date:",
 #'           language = "de",
-#'           weekstart = 1)
+#'           weekstart = 1),
 #'
-#' # Start with decade view instead of default month view
-#' dateInput("date", "Date:",
-#'           startview = "decade")
+#'   # Start with decade view instead of default month view
+#'   dateInput("date6", "Date:",
+#'             startview = "decade")
+#' )
 #'
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #' @export
 dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
   format = "yyyy-mm-dd", startview = "month", weekstart = 0, language = "en",
@@ -74,6 +81,8 @@ dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
   if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
   if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")
 
+  value <- restoreInput(id = inputId, default = value)
+
   attachDependencies(
     tags$div(id = inputId,
       class = "shiny-date-input form-group shiny-input-container",

R/input-daterange.R

@@ -32,37 +32,44 @@
 #' @seealso \code{\link{dateInput}}, \code{\link{updateDateRangeInput}}
 #'
 #' @examples
-#' dateRangeInput("daterange", "Date range:",
-#'                start = "2001-01-01",
-#'                end   = "2010-12-31")
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
-#' # Default start and end is the current date in the client's time zone
-#' dateRangeInput("daterange", "Date range:")
+#' ui <- fluidPage(
+#'   dateRangeInput("daterange1", "Date range:",
+#'                  start = "2001-01-01",
+#'                  end   = "2010-12-31"),
 #'
-#' # start and end are always specified in yyyy-mm-dd, even if the display
-#' # format is different
-#' dateRangeInput("daterange", "Date range:",
-#'                start  = "2001-01-01",
-#'                end    = "2010-12-31",
-#'                min    = "2001-01-01",
-#'                max    = "2012-12-21",
-#'                format = "mm/dd/yy",
-#'                separator = " - ")
+#'   # Default start and end is the current date in the client's time zone
+#'   dateRangeInput("daterange2", "Date range:"),
 #'
-#' # Pass in Date objects
-#' dateRangeInput("daterange", "Date range:",
-#'                start = Sys.Date()-10,
-#'                end = Sys.Date()+10)
+#'   # start and end are always specified in yyyy-mm-dd, even if the display
+#'   # format is different
+#'   dateRangeInput("daterange3", "Date range:",
+#'                  start  = "2001-01-01",
+#'                  end    = "2010-12-31",
+#'                  min    = "2001-01-01",
+#'                  max    = "2012-12-21",
+#'                  format = "mm/dd/yy",
+#'                  separator = " - "),
 #'
-#' # Use different language and different first day of week
-#' dateRangeInput("daterange", "Date range:",
-#'                language = "de",
-#'                weekstart = 1)
+#'   # Pass in Date objects
+#'   dateRangeInput("daterange4", "Date range:",
+#'                  start = Sys.Date()-10,
+#'                  end = Sys.Date()+10),
 #'
-#' # Start with decade view instead of default month view
-#' dateRangeInput("daterange", "Date range:",
-#'                startview = "decade")
+#'   # Use different language and different first day of week
+#'   dateRangeInput("daterange5", "Date range:",
+#'                  language = "de",
+#'                  weekstart = 1),
 #'
+#'   # Start with decade view instead of default month view
+#'   dateRangeInput("daterange6", "Date range:",
+#'                  startview = "decade")
+#' )
+#'
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #' @export
 dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
     min = NULL, max = NULL, format = "yyyy-mm-dd", startview = "month",
@@ -75,6 +82,10 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
   if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
   if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")
 
+  restored <- restoreInput(id = inputId, default = list(start, end))
+  start <- restored[[1]]
+  end <- restored[[2]]
+
   attachDependencies(
     div(id = inputId,
       class = "shiny-date-range-input form-group shiny-input-container",

R/input-file.R

@@ -28,20 +28,92 @@
 #' @param accept A character vector of MIME types; gives the browser a hint of
 #'   what kind of files the server is expecting.
 #'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   sidebarLayout(
+#'     sidebarPanel(
+#'       fileInput("file1", "Choose CSV File",
+#'         accept = c(
+#'           "text/csv",
+#'           "text/comma-separated-values,text/plain",
+#'           ".csv")
+#'         ),
+#'       tags$hr(),
+#'       checkboxInput("header", "Header", TRUE)
+#'     ),
+#'     mainPanel(
+#'       tableOutput("contents")
+#'     )
+#'   )
+#' )
+#'
+#' server <- function(input, output) {
+#'   output$contents <- renderTable({
+#'     # input$file1 will be NULL initially. After the user selects
+#'     # and uploads a file, it will be a data frame with 'name',
+#'     # 'size', 'type', and 'datapath' columns. The 'datapath'
+#'     # column will contain the local filenames where the data can
+#'     # be found.
+#'     inFile <- input$file1
+#'
+#'     if (is.null(inFile))
+#'       return(NULL)
+#'
+#'     read.csv(inFile$datapath, header = input$header)
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
 #' @export
 fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
   width = NULL) {
 
-  inputTag <- tags$input(id = inputId, name = inputId, type = "file")
+  restoredValue <- restoreInput(id = inputId, default = NULL)
+
+  # Catch potential edge case - ensure that it's either NULL or a data frame.
+  if (!is.null(restoredValue) && !is.data.frame(restoredValue)) {
+    warning("Restored value for ", inputId, " has incorrect format.")
+    restoredValue <- NULL
+  }
+
+  if (!is.null(restoredValue)) {
+    restoredValue <- toJSON(restoredValue, strict_atomic = FALSE)
+  }
+
+  inputTag <- tags$input(
+    id = inputId,
+    name = inputId,
+    type = "file",
+    style = "display: none;",
+    `data-restore` = restoredValue
+  )
+
   if (multiple)
     inputTag$attribs$multiple <- "multiple"
   if (length(accept) > 0)
     inputTag$attribs$accept <- paste(accept, collapse=',')
 
+
   div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     label %AND% tags$label(label),
-    inputTag,
+
+    div(class = "input-group",
+      tags$label(class = "input-group-btn",
+        span(class = "btn btn-default btn-file",
+          "Browse...",
+          inputTag
+        )
+      ),
+      tags$input(type = "text", class = "form-control",
+        placeholder = "No file selected", readonly = "readonly"
+      )
+    ),
+
     tags$div(
       id=paste(inputId, "_progress", sep=""),
       class="progress progress-striped active shiny-file-input-progress",

R/input-numeric.R

@@ -1,4 +1,3 @@
-
 #' Create a numeric input control
 #'
 #' Create an input control for entry of numeric values
@@ -13,12 +12,24 @@
 #' @seealso \code{\link{updateNumericInput}}
 #'
 #' @examples
-#' numericInput("obs", "Observations:", 10,
-#'              min = 1, max = 100)
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   numericInput("obs", "Observations:", 10, min = 1, max = 100),
+#'   verbatimTextOutput("value")
+#' )
+#' server <- function(input, output) {
+#'   output$value <- renderText({ input$obs })
+#' }
+#' shinyApp(ui, server)
+#' }
 #' @export
 numericInput <- function(inputId, label, value, min = NA, max = NA, step = NA,
   width = NULL) {
 
+  value <- restoreInput(id = inputId, default = value)
+
   # build input tag
   inputTag <- tags$input(id = inputId, type = "number", class="form-control",
                          value = formatNoSci(value))

R/input-password.R

@@ -9,12 +9,29 @@
 #' @seealso \code{\link{updateTextInput}}
 #'
 #' @examples
-#' passwordInput("password", "Password:")
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   passwordInput("password", "Password:"),
+#'   actionButton("go", "Go"),
+#'   verbatimTextOutput("value")
+#' )
+#' server <- function(input, output) {
+#'   output$value <- renderText({
+#'     req(input$go)
+#'     isolate(input$password)
+#'   })
+#' }
+#' shinyApp(ui, server)
+#' }
 #' @export
-passwordInput <- function(inputId, label, value = "", width = NULL) {
+passwordInput <- function(inputId, label, value = "", width = NULL,
+                          placeholder = NULL) {
   div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     label %AND% tags$label(label, `for` = inputId),
-    tags$input(id = inputId, type="password", class="form-control", value=value)
+    tags$input(id = inputId, type="password", class="form-control", value=value,
+               placeholder = placeholder)
   )
 }

R/input-radiobuttons.R

@@ -21,11 +21,33 @@
 #' @seealso \code{\link{updateRadioButtons}}
 #'
 #' @examples
-#' radioButtons("dist", "Distribution type:",
-#'              c("Normal" = "norm",
-#'                "Uniform" = "unif",
-#'                "Log-normal" = "lnorm",
-#'                "Exponential" = "exp"))
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   radioButtons("dist", "Distribution type:",
+#'                c("Normal" = "norm",
+#'                  "Uniform" = "unif",
+#'                  "Log-normal" = "lnorm",
+#'                  "Exponential" = "exp")),
+#'   plotOutput("distPlot")
+#' )
+#'
+#' server <- function(input, output) {
+#'   output$distPlot <- renderPlot({
+#'     dist <- switch(input$dist,
+#'                    norm = rnorm,
+#'                    unif = runif,
+#'                    lnorm = rlnorm,
+#'                    exp = rexp,
+#'                    rnorm)
+#'
+#'     hist(dist(500))
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
 #' @export
 radioButtons <- function(inputId, label, choices, selected = NULL,
   inline = FALSE, width = NULL) {
@@ -33,6 +55,8 @@ radioButtons <- function(inputId, label, choices, selected = NULL,
   # resolve names
   choices <- choicesWithNames(choices)
 
+  selected <- restoreInput(id = inputId, default = selected)
+
   # default value if it's not specified
   selected <- if (is.null(selected)) choices[[1]] else {
     validateSelected(selected, choices, inputId)

R/input-select.R

@@ -31,14 +31,32 @@
 #' @seealso \code{\link{updateSelectInput}}
 #'
 #' @examples
-#' selectInput("variable", "Variable:",
-#'             c("Cylinders" = "cyl",
-#'               "Transmission" = "am",
-#'               "Gears" = "gear"))
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   selectInput("variable", "Variable:",
+#'               c("Cylinders" = "cyl",
+#'                 "Transmission" = "am",
+#'                 "Gears" = "gear")),
+#'   tableOutput("data")
+#' )
+#'
+#' server <- function(input, output) {
+#'   output$data <- renderTable({
+#'     mtcars[, c("mpg", input$variable), drop = FALSE]
+#'   }, rownames = TRUE)
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
 #' @export
 selectInput <- function(inputId, label, choices, selected = NULL,
                         multiple = FALSE, selectize = TRUE, width = NULL,
                         size = NULL) {
+
+  selected <- restoreInput(id = inputId, default = selected)
+
   # resolve names
   choices <- choicesWithNames(choices)
 

R/input-slider.R

@@ -48,6 +48,27 @@
 #' @family input elements
 #' @seealso \code{\link{updateSliderInput}}
 #'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   sliderInput("obs", "Number of observations:",
+#'     min = 0, max = 1000, value = 500
+#'   ),
+#'   plotOutput("distPlot")
+#' )
+#'
+#' # Server logic
+#' server <- function(input, output) {
+#'   output$distPlot <- renderPlot({
+#'     hist(rnorm(input$obs))
+#'   })
+#' }
+#'
+#' # Complete app with UI and server components
+#' shinyApp(ui, server)
+#' }
 #' @export
 sliderInput <- function(inputId, label, min, max, value, step = NULL,
                         round = FALSE, format = NULL, locale = NULL,
@@ -64,6 +85,8 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
                     version = "0.10.2.2")
   }
 
+  value <- restoreInput(id = inputId, default = value)
+
   # If step is NULL, use heuristic to set the step size.
   findStepSize <- function(min, max, step) {
     if (!is.null(step)) return(step)
@@ -191,7 +214,7 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
   }
 
   dep <- list(
-    htmlDependency("ionrangeslider", "2.0.12", c(href="shared/ionrangeslider"),
+    htmlDependency("ionrangeslider", "2.1.2", c(href="shared/ionrangeslider"),
       script = "js/ion.rangeSlider.min.js",
       # ion.rangeSlider also needs normalize.css, which is already included in
       # Bootstrap.

R/input-text.R

@@ -16,11 +16,24 @@
 #' @seealso \code{\link{updateTextInput}}
 #'
 #' @examples
-#' textInput("caption", "Caption:", "Data Summary")
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   textInput("caption", "Caption", "Data Summary"),
+#'   verbatimTextOutput("value")
+#' )
+#' server <- function(input, output) {
+#'   output$value <- renderText({ input$caption })
+#' }
+#' shinyApp(ui, server)
+#' }
 #' @export
 textInput <- function(inputId, label, value = "", width = NULL,
   placeholder = NULL) {
 
+  value <- restoreInput(id = inputId, default = value)
+
   div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     label %AND% tags$label(label, `for` = inputId),

R/insert-ui.R

@@ -0,0 +1,176 @@
+#' Insert UI objects
+#'
+#' Insert a UI object into the app.
+#'
+#' This function allows you to dynamically add an arbitrarily large UI
+#' object into your app, whenever you want, as many times as you want.
+#' Unlike \code{\link{renderUI}}, the UI generated with \code{insertUI}
+#' is not updatable as a whole: once it's created, it stays there. Each
+#' new call to \code{insertUI} creates more UI objects, in addition to
+#' the ones already there (all independent from one another). To
+#' update a part of the UI (ex: an input object), you must use the
+#' appropriate \code{render} function or a customized \code{reactive}
+#' function. To remove any part of your UI, use \code{\link{removeUI}}.
+#'
+#' @param selector A string that is accepted by jQuery's selector (i.e. the
+#' string \code{s} to be placed in a \code{$(s)} jQuery call). This selector
+#' will determine the element(s) relative to which you want to insert your
+#' UI object.
+#'
+#' @param multiple In case your selector matches more than one element,
+#' \code{multiple} determines whether Shiny should insert the UI object
+#' relative to all matched elements or just relative to the first
+#' matched element (default).
+#'
+#' @param where Where your UI object should go relative to the selector:
+#' \describe{
+#'   \item{\code{beforeBegin}}{Before the selector element itself}
+#'   \item{\code{afterBegin}}{Just inside the selector element, before its
+#'   first child}
+#'   \item{\code{beforeEnd}}{Just inside the selector element, after its
+#'   last child (default)}
+#'   \item{\code{afterEnd}}{After the selector element itself}
+#' }
+#' Adapted from
+#' \href{https://developer.mozilla.org/en-US/docs/Web/API/Element/insertAdjacentHTML}{here}.
+#'
+#' @param ui The UI object you want to insert. This can be anything that
+#' you usually put inside your apps's \code{ui} function. If you're inserting
+#' multiple elements in one call, make sure to wrap them in either a
+#' \code{tagList()} or a \code{tags$div()} (the latter option has the
+#' advantage that you can give it an \code{id} to make it easier to
+#' reference or remove it later on). If you want to insert raw html, use
+#' \code{ui = HTML()}.
+#'
+#' @param immediate Whether the UI object should be immediately inserted into
+#' the app when you call \code{insertUI}, or whether Shiny should wait until
+#' all outputs have been updated and all observers have been run (default).
+#'
+#' @param session The shiny session within which to call \code{insertUI}.
+#'
+#' @seealso \code{\link{removeUI}}
+#'
+#' @examples
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#' # Define UI
+#' ui <- fluidPage(
+#'   actionButton("add", "Add UI")
+#' )
+#'
+#' # Server logic
+#' server <- function(input, output, session) {
+#'   observeEvent(input$add, {
+#'     insertUI(
+#'       selector = "#add",
+#'       where = "afterEnd",
+#'       ui = textInput(paste0("txt", input$add),
+#'                      "Insert some text")
+#'     )
+#'   })
+#' }
+#'
+#' # Complete app with UI and server components
+#' shinyApp(ui, server)
+#' }
+#'
+#' @export
+insertUI <- function(selector,
+  multiple = FALSE,
+  where = c("beforeBegin", "afterBegin", "beforeEnd", "afterEnd"),
+  ui,
+  immediate = FALSE,
+  session = getDefaultReactiveDomain()) {
+
+  force(selector)
+  force(ui)
+  force(session)
+  force(multiple)
+  if (missing(where)) where <- "beforeEnd"
+  where <- match.arg(where)
+
+  callback <- function() {
+    session$sendInsertUI(selector = selector,
+                         multiple = multiple,
+                         where = where,
+                         content = processDeps(ui, session))
+  }
+
+  if (!immediate) session$onFlushed(callback, once = TRUE)
+  else callback()
+}
+
+
+#' Remove UI objects
+#'
+#' Remove a UI object from the app.
+#'
+#' This function allows you to remove any part of your UI. Once \code{removeUI}
+#' is executed on some element, it is gone forever.
+#'
+#' While it may be a particularly useful pattern to pair this with
+#' \code{\link{insertUI}} (to remove some UI you had previously inserted),
+#' there is no restriction on what you can use \code{removeUI} on. Any
+#' element that can be selected through a jQuery selector can be removed
+#' through this function.
+#'
+#' @param selector A string that is accepted by jQuery's selector (i.e. the
+#' string \code{s} to be placed in a \code{$(s)} jQuery call). This selector
+#' will determine the element(s) to be removed. If you want to remove a
+#' Shiny input or output, note that many of these are wrapped in \code{div}s,
+#' so you may need to use a somewhat complex selector -- see the Examples below.
+#' (Alternatively, you could also wrap the inputs/outputs that you want to be
+#' able to remove easily in a \code{div} with an id.)
+#'
+#' @param multiple In case your selector matches more than one element,
+#' \code{multiple} determines whether Shiny should remove all the matched
+#' elements or just the first matched element (default).
+#'
+#' @param immediate Whether the element(s) should be immediately removed from
+#' the app when you call \code{removeUI}, or whether Shiny should wait until
+#' all outputs have been updated and all observers have been run (default).
+#'
+#' @param session The shiny session within which to call \code{removeUI}.
+#'
+#' @seealso \code{\link{insertUI}}
+#'
+#' @examples
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#' # Define UI
+#' ui <- fluidPage(
+#'   actionButton("rmv", "Remove UI"),
+#'   textInput("txt", "This is no longer useful")
+#' )
+#'
+#' # Server logic
+#' server <- function(input, output, session) {
+#'   observeEvent(input$rmv, {
+#'     removeUI(
+#'       selector = "div:has(> #txt)"
+#'     )
+#'   })
+#' }
+#'
+#' # Complete app with UI and server components
+#' shinyApp(ui, server)
+#' }
+#'
+#' @export
+removeUI <- function(selector,
+  multiple = FALSE,
+  immediate = FALSE,
+  session = getDefaultReactiveDomain()) {
+
+  force(selector)
+  force(multiple)
+  force(session)
+
+  callback <- function() {
+    session$sendRemoveUI(selector = selector,
+                         multiple = multiple)
+  }
+
+  if (!immediate) session$onFlushed(callback, once = TRUE)
+  else callback()
+}

R/middleware.R

@@ -299,9 +299,7 @@ HandlerManager <- R6Class("HandlerManager",
 
           if (reqSize > maxSize) {
             return(list(status = 413L,
-              headers = list(
-                'Content-Type' = 'text/plain'
-              ),
+              headers = list('Content-Type' = 'text/plain'),
               body = 'Maximum upload size exceeded'))
           }
           else {
@@ -310,7 +308,18 @@ HandlerManager <- R6Class("HandlerManager",
         },
         call = .httpServer(
           function (req) {
-            withLogErrors(handlers$invoke(req))
+            withCallingHandlers(withLogErrors(handlers$invoke(req)),
+              error = function(cond) {
+                sanitizeErrors <- getOption('shiny.sanitize.errors', FALSE)
+                if (inherits(cond, 'shiny.custom.error') || !sanitizeErrors) {
+                  stop(cond$message, call. = FALSE)
+                } else {
+                  stop(paste("An error has occurred. Check your logs or",
+                             "contact the app author for clarification."),
+                       call. = FALSE)
+                }
+              }
+            )
           },
           getOption('shiny.sharedSecret')
         ),
@@ -333,7 +342,7 @@ HandlerManager <- R6Class("HandlerManager",
         }
 
         # Catch HEAD requests. For the purposes of handler functions, they
-        # should be treated like GET. The difference is that  they shouldn't
+        # should be treated like GET. The difference is that they shouldn't
         # return a body in the http response.
         head_request <- FALSE
         if (identical(req$REQUEST_METHOD, "HEAD")) {

R/modal.R

@@ -0,0 +1,173 @@
+#' Show or remove a modal dialog
+#'
+#' This causes a modal dialog to be displayed in the client browser, and is
+#' typically used with \code{\link{modalDialog}}.
+#'
+#' @param ui UI content to show in the modal.
+#' @param session The \code{session} object passed to function given to
+#'   \code{shinyServer}.
+#'
+#' @seealso \code{\link{modalDialog}} for examples.
+#' @export
+showModal <- function(ui, session = getDefaultReactiveDomain()) {
+  res <- processDeps(ui, session)
+
+  session$sendModal("show",
+    list(
+      html = res$html,
+      deps = res$deps
+    )
+  )
+}
+
+#' @rdname showModal
+#' @export
+removeModal <- function(session = getDefaultReactiveDomain()) {
+  session$sendModal("remove", NULL)
+}
+
+
+#' Create a modal dialog UI
+#'
+#' This creates the UI for a modal dialog, using Bootstrap's modal class. Modals
+#' are typically used for showing important messages, or for presenting UI that
+#' requires input from the user, such as a username and password input.
+#'
+#' @param ... UI elements for the body of the modal dialog box.
+#' @param title An optional title for the dialog.
+#' @param footer UI for footer. Use \code{NULL} for no footer.
+#' @param easyClose If \code{TRUE}, the modal dialog can be dismissed by
+#'   clicking outside the dialog box, or be pressing the Escape key. If
+#'   \code{FALSE} (the default), the modal dialog can't be dismissed in those
+#'   ways; instead it must be dismissed by clicking on the dismiss button, or
+#'   from a call to \code{\link{removeModal}} on the server.
+#'
+#' @examples
+#' if (interactive()) {
+#' # Display an important message that can be dismissed only by clicking the
+#' # dismiss button.
+#' shinyApp(
+#'   ui = basicPage(
+#'     actionButton("show", "Show modal dialog")
+#'   ),
+#'   server = function(input, output) {
+#'     observeEvent(input$show, {
+#'       showModal(modalDialog(
+#'         title = "Important message",
+#'         "This is an important message!"
+#'       ))
+#'     })
+#'   }
+#' )
+#'
+#'
+#' # Display a message that can be dismissed by clicking outside the modal dialog,
+#' # or by pressing Esc.
+#' shinyApp(
+#'   ui = basicPage(
+#'     actionButton("show", "Show modal dialog")
+#'   ),
+#'   server = function(input, output) {
+#'     observeEvent(input$show, {
+#'       showModal(modalDialog(
+#'         title = "Somewhat important message",
+#'         "This is a somewhat important message.",
+#'         easyClose = TRUE,
+#'         footer = NULL
+#'       ))
+#'     })
+#'   }
+#' )
+#'
+#'
+# Display a modal that requires valid input before continuing.
+#' shinyApp(
+#'   ui = basicPage(
+#'     actionButton("show", "Show modal dialog"),
+#'     verbatimTextOutput("dataInfo")
+#'   ),
+#'
+#'   server = function(input, output) {
+#'     # reactiveValues object for storing current data set.
+#'     vals <- reactiveValues(data = NULL)
+#'
+#'     # Return the UI for a modal dialog with data selection input. If 'failed' is
+#'     # TRUE, then display a message that the previous value was invalid.
+#'     dataModal <- function(failed = FALSE) {
+#'       modalDialog(
+#'         textInput("dataset", "Choose data set",
+#'           placeholder = 'Try "mtcars" or "abc"'
+#'         ),
+#'         span('(Try the name of a valid data object like "mtcars", ',
+#'              'then a name of a non-existent object like "abc")'),
+#'         if (failed)
+#'           div(tags$b("Invalid name of data object", style = "color: red;")),
+#'
+#'         footer = tagList(
+#'           modalButton("Cancel"),
+#'           actionButton("ok", "OK")
+#'         )
+#'       )
+#'     }
+#'
+#'     # Show modal when button is clicked.
+#'     observeEvent(input$show, {
+#'       showModal(dataModal())
+#'     })
+#'
+#'     # When OK button is pressed, attempt to load the data set. If successful,
+#'     # remove the modal. If not show another modal, but this time with a failure
+#'     # message.
+#'     observeEvent(input$ok, {
+#'       # Check that data object exists and is data frame.
+#'       if (exists(input$dataset) && is.data.frame(get(input$dataset))) {
+#'         vals$data <- get(input$dataset)
+#'         removeModal()
+#'       } else {
+#'         showModal(dataModal(failed = TRUE))
+#'       }
+#'     })
+#'
+#'     # Display information about selected data
+#'     output$dataInfo <- renderPrint({
+#'       if (is.null(vals$data))
+#'         "No data selected"
+#'       else
+#'         summary(vals$data)
+#'     })
+#'   }
+#' )
+#' }
+#' @export
+modalDialog <- function(..., title = NULL, footer = modalButton("Dismiss"),
+                        easyClose = FALSE) {
+
+  div(id = "shiny-modal", class = "modal fade", tabindex = "-1",
+    `data-backdrop` = if (!easyClose) "static",
+    `data-keyboard` = if (!easyClose) "false",
+
+    div(class = "modal-dialog",
+      div(class = "modal-content",
+        if (!is.null(title)) div(class = "modal-header",
+          tags$h4(class = "modal-title", title)
+        ),
+        div(class = "modal-body", ...),
+        if (!is.null(footer)) div(class = "modal-footer", footer)
+      )
+    ),
+    tags$script("$('#shiny-modal').modal().focus();")
+  )
+}
+
+#' Create a button for a modal dialog
+#'
+#' When clicked, a \code{modalButton} will dismiss the modal dialog.
+#'
+#' @inheritParams actionButton
+#' @seealso \code{\link{modalDialog}} for examples.
+#' @export
+modalButton <- function(label, icon = NULL) {
+  tags$button(type = "button", class = "btn btn-default",
+    `data-dismiss` = "modal", validateIcon(icon), label
+  )
+}

R/notifications.R

@@ -0,0 +1,106 @@
+#' Show or remove a notification
+#'
+#' These functions show and remove notifications in a Shiny application.
+#'
+#' @param ui Content of message.
+#' @param action Message content that represents an action. For example, this
+#'   could be a link that the user can click on. This is separate from \code{ui}
+#'   so customized layouts can handle the main notification content separately
+#'   from action content.
+#' @param duration Number of seconds to display the message before it
+#'   disappears. Use \code{NULL} to make the message not automatically
+#'   disappear.
+#' @param closeButton If \code{TRUE}, display a button which will make the
+#'   notification disappear when clicked. If \code{FALSE} do not display.
+#' @param id An ID string. This can be used to change the contents of an
+#'   existing message with \code{showNotification}, or to remove it with
+#'   \code{removeNotification}. If not provided, one will be generated
+#'   automatically. If an ID is provided and there does not currently exist a
+#'   notification with that ID, a new notification will be created with that ID.
+#' @param type A string which controls the color of the notification. One of
+#'   "default" (gray), "message" (blue), "warning" (yellow), or "error" (red).
+#' @param session Session object to send notification to.
+#'
+#' @return An ID for the notification.
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#' # Show a message when button is clicked
+#' shinyApp(
+#'   ui = fluidPage(
+#'     actionButton("show", "Show")
+#'   ),
+#'   server = function(input, output) {
+#'     observeEvent(input$show, {
+#'       showNotification("Message text",
+#'         action = a(href = "javascript:location.reload();", "Reload page")
+#'       )
+#'     })
+#'   }
+#' )
+#'
+#' # App with show and remove buttons
+#' shinyApp(
+#'   ui = fluidPage(
+#'     actionButton("show", "Show"),
+#'     actionButton("remove", "Remove")
+#'   ),
+#'   server = function(input, output) {
+#'     # A queue of notification IDs
+#'     ids <- character(0)
+#'     # A counter
+#'     n <- 0
+#'
+#'     observeEvent(input$show, {
+#'       # Save the ID for removal later
+#'       id <- showNotification(paste("Message", n), duration = NULL)
+#'       ids <<- c(ids, id)
+#'       n <<- n + 1
+#'     })
+#'
+#'     observeEvent(input$remove, {
+#'       if (length(ids) > 0)
+#'         removeNotification(ids[1])
+#'       ids <<- ids[-1]
+#'     })
+#'   }
+#' )
+#' }
+#' @export
+showNotification <- function(ui, action = NULL, duration = 5,
+  closeButton = TRUE, id = NULL,
+  type = c("default", "message", "warning", "error"),
+  session = getDefaultReactiveDomain())
+{
+
+  if (is.null(id))
+    id <- createUniqueId(8)
+
+  res <- processDeps(ui, session)
+  actionRes <- processDeps(action, session)
+
+  session$sendNotification("show",
+    list(
+      html = res$html,
+      action = actionRes$html,
+      deps = c(res$deps, actionRes$deps),
+      duration = if (!is.null(duration)) duration * 1000,
+      closeButton = closeButton,
+      id = id,
+      type = match.arg(type)
+    )
+  )
+
+  id
+}
+
+#' @rdname showNotification
+#' @export
+removeNotification <- function(id = NULL, session = getDefaultReactiveDomain()) {
+  if (is.null(id)) {
+    stop("id is required.")
+  }
+  session$sendNotification("remove", id)
+  id
+}

R/progress.R

@@ -55,11 +55,16 @@
 #'   progress bar.
 #'
 #' @examples
-#' \dontrun{
-#' # server.R
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   plotOutput("plot")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   output$plot <- renderPlot({
-#'     progress <- shiny::Progress$new(session, min=1, max=15)
+#'     progress <- Progress$new(session, min=1, max=15)
 #'     on.exit(progress$close())
 #'
 #'     progress$set(message = 'Calculation in progress',
@@ -71,7 +76,9 @@
 #'     }
 #'     plot(cars)
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @seealso \code{\link{withProgress}}
 #' @format NULL
@@ -87,7 +94,7 @@ Progress <- R6Class(
         stop("'session' is not a ShinySession object.")
 
       private$session <- session
-      private$id <- paste(as.character(as.raw(stats::runif(8, min=0, max=255))), collapse='')
+      private$id <- createUniqueId(8)
       private$min <- min
       private$max <- max
       private$value <- NULL
@@ -204,9 +211,14 @@ Progress <- R6Class(
 #'   progress bar, if it is currently visible.
 #'
 #' @examples
-#' \dontrun{
-#' # server.R
-#' shinyServer(function(input, output) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   plotOutput("plot")
+#' )
+#'
+#' server <- function(input, output) {
 #'   output$plot <- renderPlot({
 #'     withProgress(message = 'Calculation in progress',
 #'                  detail = 'This may take a while...', value = 0, {
@@ -217,7 +229,9 @@ Progress <- R6Class(
 #'     })
 #'     plot(cars)
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @seealso \code{\link{Progress}}
 #' @rdname withProgress

R/reactives.R

@@ -47,6 +47,7 @@ ReactiveValues <- R6Class(
     # For debug purposes
     .label = character(0),
     .values = 'environment',
+    .metadata = 'environment',
     .dependents = 'environment',
     # Dependents for the list of all names, including hidden
     .namesDeps = 'Dependents',
@@ -60,32 +61,40 @@ ReactiveValues <- R6Class(
                        p_randomInt(1000, 10000),
                        sep="")
       .values <<- new.env(parent=emptyenv())
+      .metadata <<- new.env(parent=emptyenv())
       .dependents <<- new.env(parent=emptyenv())
       .namesDeps <<- Dependents$new()
       .allValuesDeps <<- Dependents$new()
       .valuesDeps <<- Dependents$new()
     },
+
     get = function(key) {
+      # Register the "downstream" reactive which is accessing this value, so
+      # that we know to invalidate them when this value changes.
       ctx <- .getReactiveEnvironment()$currentContext()
       dep.key <- paste(key, ':', ctx$id, sep='')
-      if (!exists(dep.key, where=.dependents, inherits=FALSE)) {
+      if (!exists(dep.key, envir=.dependents, inherits=FALSE)) {
         .graphDependsOn(ctx$id, sprintf('%s$%s', .label, key))
-        assign(dep.key, ctx, pos=.dependents, inherits=FALSE)
+        .dependents[[dep.key]] <- ctx
         ctx$onInvalidate(function() {
-          rm(list=dep.key, pos=.dependents, inherits=FALSE)
+          rm(list=dep.key, envir=.dependents, inherits=FALSE)
         })
       }
 
-      if (!exists(key, where=.values, inherits=FALSE))
+      if (isInvalid(key))
+        stopWithCondition(c("validation", "shiny.silent.error"), "")
+
+      if (!exists(key, envir=.values, inherits=FALSE))
         NULL
       else
-        base::get(key, pos=.values, inherits=FALSE)
+        .values[[key]]
     },
+
     set = function(key, value) {
       hidden <- substr(key, 1, 1) == "."
 
-      if (exists(key, where=.values, inherits=FALSE)) {
-        if (identical(base::get(key, pos=.values, inherits=FALSE), value)) {
+      if (exists(key, envir=.values, inherits=FALSE)) {
+        if (identical(.values[[key]], value)) {
           return(invisible())
         }
       }
@@ -98,14 +107,14 @@ ReactiveValues <- R6Class(
       else
         .valuesDeps$invalidate()
 
-      assign(key, value, pos=.values, inherits=FALSE)
+      .values[[key]] <- value
 
       .graphValueChange(sprintf('names(%s)', .label), ls(.values, all.names=TRUE))
       .graphValueChange(sprintf('%s (all)', .label), as.list(.values))
       .graphValueChange(sprintf('%s$%s', .label, key), value)
 
       dep.keys <- objects(
-        pos=.dependents,
+        envir=.dependents,
         pattern=paste('^\\Q', key, ':', '\\E', '\\d+$', sep=''),
         all.names=TRUE
       )
@@ -118,18 +127,54 @@ ReactiveValues <- R6Class(
       )
       invisible()
     },
+
     mset = function(lst) {
       lapply(base::names(lst),
              function(name) {
                self$set(name, lst[[name]])
              })
     },
+
     names = function() {
       .graphDependsOn(.getReactiveEnvironment()$currentContext()$id,
                       sprintf('names(%s)', .label))
       .namesDeps$register()
       return(ls(.values, all.names=TRUE))
     },
+
+    # Get a metadata value. Does not trigger reactivity.
+    getMeta = function(key, metaKey) {
+      # Make sure to use named (not numeric) indexing into list.
+      metaKey <- as.character(metaKey)
+      .metadata[[key]][[metaKey]]
+    },
+
+    # Set a metadata value. Does not trigger reactivity.
+    setMeta = function(key, metaKey, value) {
+      # Make sure to use named (not numeric) indexing into list.
+      metaKey <- as.character(metaKey)
+
+      if (!exists(key, envir = .metadata, inherits = FALSE)) {
+        .metadata[[key]] <<- list()
+      }
+
+      .metadata[[key]][[metaKey]] <<- value
+    },
+
+    # Mark a value as invalid. If accessed while invalid, a shiny.silent.error
+    # will be thrown.
+    invalidate = function(key) {
+      setMeta(key, "invalid", TRUE)
+    },
+
+    unInvalidate = function(key) {
+      setMeta(key, "invalid", NULL)
+    },
+
+    isInvalid = function(key) {
+      isTRUE(getMeta(key, "invalid"))
+    },
+
     toList = function(all.names=FALSE) {
       .graphDependsOn(.getReactiveEnvironment()$currentContext()$id,
                       sprintf('%s (all)', .label))
@@ -140,6 +185,7 @@ ReactiveValues <- R6Class(
 
       return(as.list(.values, all.names=all.names))
     },
+
     .setLabel = function(label) {
       .label <<- label
     }
@@ -334,6 +380,32 @@ str.reactivevalues <- function(object, indent.str = " ", ...) {
   utils::str(class(object))
 }
 
+
+#' Invalidate a reactive value
+#'
+#' This invalidates a reactive value. If the value is accessed while invalid, a
+#' "silent" exception is raised and the operation is stopped. This is the same
+#' thing that happens if \code{req(FALSE)} is called. The value is
+#' un-invalidated (accessing it will no longer raise an exception) when the
+#' current reactive domain is flushed; in a Shiny application, this occurs after
+#' all of the observers are executed.
+#'
+#' @param x A \code{\link{reactiveValues}} object (like \code{input}).
+#' @param name The name of a value in the \code{\link{reactiveValues}} object.
+#'
+#' @seealso \code{\link{req}}
+#' @export
+invalidateReactiveValue <- function(x, name) {
+  domain <- getDefaultReactiveDomain()
+  if (is.null(getDefaultReactiveDomain)) {
+    stop("invalidateReactiveValue() must be called when a default reactive domain is active.")
+  }
+
+  domain$invalidateValue(x, name)
+  invisible()
+}
+
+
 # Observable ----------------------------------------------------------------
 
 Observable <- R6Class(
@@ -360,7 +432,16 @@ Observable <- R6Class(
              "or more parameters; only functions without parameters can be ",
              "reactive.")
 
-      .func <<- wrapFunctionLabel(func, paste("reactive", label),
+      # This is to make sure that the function labels that show in the profiler
+      # and in stack traces doesn't contain whitespace. See
+      # https://github.com/rstudio/profvis/issues/58
+      if (grepl("\\s", label, perl = TRUE)) {
+        funcLabel <- "<reactive>"
+      } else {
+        funcLabel <- paste0("<reactive:", label, ">")
+      }
+
+      .func <<- wrapFunctionLabel(func, funcLabel,
         ..stacktraceon = ..stacktraceon)
       .label <<- label
       .domain <<- domain
@@ -553,7 +634,7 @@ srcrefToLabel <- function(srcref, defaultLabel) {
 
 #' @export
 print.reactive <- function(x, ...) {
-  label <- attr(x, "observable")$.label
+  label <- attr(x, "observable", exact = TRUE)$.label
   cat(label, "\n")
 }
 
@@ -564,7 +645,7 @@ is.reactive <- function(x) inherits(x, "reactive")
 # Return the number of times that a reactive expression or observer has been run
 execCount <- function(x) {
   if (is.reactive(x))
-    return(attr(x, "observable")$.execCount)
+    return(attr(x, "observable", exact = TRUE)$.execCount)
   else if (inherits(x, 'Observer'))
     return(x$.execCount)
   else
@@ -856,9 +937,9 @@ observe <- function(x, env=parent.frame(), quoted=FALSE, label=NULL,
 #' }
 #' @export
 makeReactiveBinding <- function(symbol, env = parent.frame()) {
-  if (exists(symbol, where = env, inherits = FALSE)) {
-    initialValue <- get(symbol, pos = env, inherits = FALSE)
-    rm(list = symbol, pos = env, inherits = FALSE)
+  if (exists(symbol, envir = env, inherits = FALSE)) {
+    initialValue <- env[[symbol]]
+    rm(list = symbol, envir = env, inherits = FALSE)
   }
   else
     initialValue <- NULL
@@ -931,8 +1012,15 @@ setAutoflush <- local({
 #' @seealso \code{\link{invalidateLater}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   sliderInput("n", "Number of observations", 2, 1000, 500),
+#'   plotOutput("plot")
+#' )
+#'
+#' server <- function(input, output) {
 #'
 #'   # Anything that calls autoInvalidate will automatically invalidate
 #'   # every 2 seconds.
@@ -953,9 +1041,11 @@ setAutoflush <- local({
 #'   # input$n changes.
 #'   output$plot <- renderPlot({
 #'     autoInvalidate()
-#'     hist(isolate(input$n))
+#'     hist(rnorm(isolate(input$n)))
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #'
 #' @export
@@ -1009,8 +1099,15 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
 #' @seealso \code{\link{reactiveTimer}} is a slightly less safe alternative.
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   sliderInput("n", "Number of observations", 2, 1000, 500),
+#'   plotOutput("plot")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'
 #'   observe({
 #'     # Re-execute this reactive expression after 1000 milliseconds
@@ -1027,11 +1124,12 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
 #'   output$plot <- renderPlot({
 #'     # Re-execute this reactive expression after 2000 milliseconds
 #'     invalidateLater(2000)
-#'     hist(isolate(input$n))
+#'     hist(rnorm(isolate(input$n)))
 #'   })
-#' })
 #' }
 #'
+#' shinyApp(ui, server)
+#' }
 #' @export
 invalidateLater <- function(millis, session = getDefaultReactiveDomain()) {
   ctx <- .getReactiveEnvironment()$currentContext()
@@ -1101,14 +1199,12 @@ coerceToFunc <- function(x) {
 #' @seealso \code{\link{reactiveFileReader}}
 #'
 #' @examples
-#' \dontrun{
 #' # Assume the existence of readTimestamp and readValue functions
-#' shinyServer(function(input, output, session) {
+#' function(input, output, session) {
 #'   data <- reactivePoll(1000, session, readTimestamp, readValue)
 #'   output$dataTable <- renderTable({
 #'     data()
 #'   })
-#' })
 #' }
 #'
 #' @export
@@ -1170,7 +1266,7 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
 #' @examples
 #' \dontrun{
 #' # Per-session reactive file reader
-#' shinyServer(function(input, output, session)) {
+#' function(input, output, session) {
 #'   fileData <- reactiveFileReader(1000, session, 'data.csv', read.csv)
 #'
 #'   output$data <- renderTable({
@@ -1182,7 +1278,7 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
 #' # the same reader, so read.csv only gets executed once no matter how many
 #' # user sessions are connected.
 #' fileData <- reactiveFileReader(1000, session, 'data.csv', read.csv)
-#' shinyServer(function(input, output, session)) {
+#' function(input, output, session) {
 #'   output$data <- renderTable({
 #'     fileData()
 #'   })

R/render-plot.R

@@ -35,12 +35,20 @@
 #' @param env The environment in which to evaluate \code{expr}.
 #' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
 #'   is useful if you want to save an expression in a variable.
-#' @param func A function that generates a plot (deprecated; use \code{expr}
-#'   instead).
-#'
+#' @param execOnResize If \code{FALSE} (the default), then when a plot is
+#'   resized, Shiny will \emph{replay} the plot drawing commands with
+#'   \code{\link[grDevices]{replayPlot}()} instead of re-executing \code{expr}.
+#'   This can result in faster plot redrawing, but there may be rare cases where
+#'   it is undesirable. If you encounter problems when resizing a plot, you can
+#'   have Shiny re-execute the code on resize by setting this to \code{TRUE}.
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{plotOutput}} when \code{renderPlot} is used in an
+#'   interactive R Markdown document.
 #' @export
 renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
-                       env=parent.frame(), quoted=FALSE, func=NULL) {
+                       env=parent.frame(), quoted=FALSE,
+                       execOnResize=FALSE, outputArgs=list()
+) {
   # This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
   # is called
   installExprFunction(expr, "func", env, quoted, ..stacktraceon = TRUE)
@@ -50,66 +58,169 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   if (is.function(width))
     widthWrapper <- reactive({ width() })
   else
-    widthWrapper <- NULL
+    widthWrapper <- function() { width }
 
   if (is.function(height))
     heightWrapper <- reactive({ height() })
   else
-    heightWrapper <- NULL
+    heightWrapper <- function() { height }
 
-  # If renderPlot isn't going to adapt to the height of the div, then the
-  # div needs to adapt to the height of renderPlot. By default, plotOutput
-  # sets the height to 400px, so to make it adapt we need to override it
-  # with NULL.
-  outputFunc <- plotOutput
-  if (!identical(height, 'auto')) formals(outputFunc)['height'] <- list(NULL)
+  # A modified version of print.ggplot which returns the built ggplot object
+  # as well as the gtable grob. This overrides the ggplot::print.ggplot
+  # method, but only within the context of renderPlot. The reason this needs
+  # to be a (pseudo) S3 method is so that, if an object has a class in
+  # addition to ggplot, and there's a print method for that class, that we
+  # won't override that method. https://github.com/rstudio/shiny/issues/841
+  print.ggplot <- function(x) {
+    grid::grid.newpage()
 
-  return(markRenderFunction(outputFunc, function(shinysession, name, ...) {
-    if (!is.null(widthWrapper))
-      width <- widthWrapper()
-    if (!is.null(heightWrapper))
-      height <- heightWrapper()
+    build <- ggplot2::ggplot_build(x)
+
+    gtable <- ggplot2::ggplot_gtable(build)
+    grid::grid.draw(gtable)
+
+    structure(list(
+      build = build,
+      gtable = gtable
+    ), class = "ggplot_build_gtable")
+  }
+
+
+  getDims <- function() {
+    width <- widthWrapper()
+    height <- heightWrapper()
 
     # Note that these are reactive calls. A change to the width and height
     # will inherently cause a reactive plot to redraw (unless width and
     # height were explicitly specified).
-    prefix <- 'output_'
     if (width == 'auto')
-      width <- shinysession$clientData[[paste(prefix, name, '_width', sep='')]];
+      width <- session$clientData[[paste0('output_', outputName, '_width')]]
     if (height == 'auto')
-      height <- shinysession$clientData[[paste(prefix, name, '_height', sep='')]];
+      height <- session$clientData[[paste0('output_', outputName, '_height')]]
 
-    if (is.null(width) || is.null(height) || width <= 0 || height <= 0)
+    list(width = width, height = height)
+  }
+
+  # Vars to store session and output, so that they can be accessed from
+  # the plotObj() reactive.
+  session <- NULL
+  outputName <- NULL
+
+  # This function is the one that's returned from renderPlot(), and gets
+  # wrapped in an observer when the output value is assigned. The expression
+  # passed to renderPlot() is actually run in plotObj(); this function can only
+  # replay a plot if the width/height changes.
+  renderFunc <- function(shinysession, name, ...) {
+    session <<- shinysession
+    outputName <<- name
+
+    dims <- getDims()
+
+    if (is.null(dims$width) || is.null(dims$height) ||
+        dims$width <= 0 || dims$height <= 0) {
       return(NULL)
+    }
+
+    # The reactive that runs the expr in renderPlot()
+    plotData <- plotObj()
+
+    img <- plotData$img
+
+    # If only the width/height have changed, simply replay the plot and make a
+    # new img.
+    if (dims$width != img$width || dims$height != img$height) {
+      pixelratio <- session$clientData$pixelratio %OR% 1
+
+      coordmap <- NULL
+      plotFunc <- function() {
+        ..stacktraceon..(grDevices::replayPlot(plotData$recordedPlot))
+
+        # Coordmap must be recalculated after replaying plot, because pixel
+        # dimensions will have changed.
+        if (inherits(plotData$plotResult, "ggplot_build_gtable")) {
+          coordmap <<- getGgplotCoordmap(plotData$plotResult, pixelratio, res)
+        } else {
+          coordmap <<- getPrevPlotCoordmap(dims$width, dims$height)
+        }
+      }
+      outfile <- ..stacktraceoff..(
+        plotPNG(plotFunc, width = dims$width*pixelratio, height = dims$height*pixelratio,
+                res = res*pixelratio)
+      )
+      on.exit(unlink(outfile))
+
+      img <- dropNulls(list(
+        src = session$fileUrl(name, outfile, contentType='image/png'),
+        width = dims$width,
+        height = dims$height,
+        coordmap = coordmap,
+        # Get coordmap error message if present
+        error = attr(coordmap, "error", exact = TRUE)
+      ))
+    }
+
+    img
+  }
+
+
+  plotObj <- reactive(label = "plotObj", {
+    if (execOnResize) {
+      isolate({ dims <- getDims() })
+    } else {
+      dims <- getDims()
+    }
+
+    if (is.null(dims$width) || is.null(dims$height) ||
+        dims$width <= 0 || dims$height <= 0) {
+      return(NULL)
+    }
 
     # Resolution multiplier
-    pixelratio <- shinysession$clientData$pixelratio
-    if (is.null(pixelratio))
-      pixelratio <- 1
+    pixelratio <- session$clientData$pixelratio %OR% 1
 
+    plotResult <- NULL
+    recordedPlot <- NULL
     coordmap <- NULL
     plotFunc <- function() {
-      # Actually perform the plotting
-      result <- withVisible(func())
-
-      coordmap <<- NULL
+      success <-FALSE
+      tryCatch(
+        {
+          # Actually perform the plotting
+          result <- withVisible(func())
+          success <- TRUE
+        },
+        finally = {
+          if (!success) {
+            # If there was an error in making the plot, there's a good chance
+            # it's "Error in plot.new: figure margins too large". We need to
+            # take a reactive dependency on the width and height, so that the
+            # user's plotting code will re-execute when the plot is resized,
+            # instead of just replaying the previous plot (which errored).
+            getDims()
+          }
+        }
+      )
 
       if (result$visible) {
         # Use capture.output to squelch printing to the actual console; we
         # are only interested in plot output
-
-        # Special case for ggplot objects - need to capture coordmap
-        if (inherits(result$value, "ggplot")) {
-          utils::capture.output(coordmap <<- getGgplotCoordmap(result$value, pixelratio))
-        } else {
-          # This ..stacktraceon.. negates the ..stacktraceoff.. that wraps the
-          # call to plotFunc
-          utils::capture.output(..stacktraceon..(print(result$value)))
-        }
+        utils::capture.output({
+          # This ..stacktraceon.. negates the ..stacktraceoff.. that wraps
+          # the call to plotFunc. The value needs to be printed just in case
+          # it's an object that requires printing to generate plot output,
+          # similar to ggplot2. But for base graphics, it would already have
+          # been rendered when func was called above, and the print should
+          # have no effect.
+          plotResult <<- ..stacktraceon..(print(result$value))
+        })
       }
 
-      if (is.null(coordmap)) {
-        coordmap <<- getPrevPlotCoordmap(width, height)
+      recordedPlot <<- grDevices::recordPlot()
+
+      if (inherits(plotResult, "ggplot_build_gtable")) {
+        coordmap <<- getGgplotCoordmap(plotResult, pixelratio, res)
+      } else {
+        coordmap <<- getPrevPlotCoordmap(dims$width, dims$height)
       }
     }
 
@@ -118,25 +229,38 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
     # renderPlot, and by the ..stacktraceon.. in plotFunc where ggplot objects
     # are printed
     outfile <- ..stacktraceoff..(
-      do.call(plotPNG, c(plotFunc, width=width*pixelratio,
-        height=height*pixelratio, res=res*pixelratio, args))
+      do.call(plotPNG, c(plotFunc, width=dims$width*pixelratio,
+        height=dims$height*pixelratio, res=res*pixelratio, args))
     )
     on.exit(unlink(outfile))
 
-    # A list of attributes for the img
-    res <- list(
-      src=shinysession$fileUrl(name, outfile, contentType='image/png'),
-      width=width, height=height, coordmap=coordmap
+    list(
+      # img is the content that gets sent to the client.
+      img = dropNulls(list(
+        src = session$fileUrl(outputName, outfile, contentType='image/png'),
+        width = dims$width,
+        height = dims$height,
+        coordmap = coordmap,
+        # Get coordmap error message if present.
+        error = attr(coordmap, "error", exact = TRUE)
+      )),
+      # Returned value from expression in renderPlot() -- may be a printable
+      # object like ggplot2. Needed just in case we replayPlot and need to get
+      # a coordmap again.
+      plotResult = plotResult,
+      recordedPlot = recordedPlot
     )
+  })
 
-    # Get error message if present (from attribute on the coordmap)
-    error <- attr(coordmap, "error", exact = TRUE)
-    if (!is.null(error)) {
-      res$error <- error
-    }
 
-    res
-  }))
+  # If renderPlot isn't going to adapt to the height of the div, then the
+  # div needs to adapt to the height of renderPlot. By default, plotOutput
+  # sets the height to 400px, so to make it adapt we need to override it
+  # with NULL.
+  outputFunc <- plotOutput
+  if (!identical(height, 'auto')) formals(outputFunc)['height'] <- list(NULL)
+
+  markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
 }
 
 # The coordmap extraction functions below return something like the examples
@@ -288,47 +412,12 @@ getPrevPlotCoordmap <- function(width, height) {
   ))
 }
 
-# Print a ggplot object and return a coordmap for it.
-getGgplotCoordmap <- function(p, pixelratio) {
-  if (!inherits(p, "ggplot"))
+
+# Given a ggplot_build_gtable object, return a coordmap for it.
+getGgplotCoordmap <- function(p, pixelratio, res) {
+  if (!inherits(p, "ggplot_build_gtable"))
     return(NULL)
 
-  # A modified version of print.ggplot which returns the built ggplot object as
-  # well as the gtable grob. This overrides the ggplot::print.ggplot method, but
-  # only within the context of getGgplotCoordmap. The reason this needs to be an
-  # (pseudo) S3 method is so that, if an object has a class in addition to
-  # ggplot, and there's a print method for that class, that we won't override
-  # that method.
-  # https://github.com/rstudio/shiny/issues/841
-  print.ggplot <- function(x) {
-    grid::grid.newpage()
-
-    build <- ggplot2::ggplot_build(x)
-
-    gtable <- ggplot2::ggplot_gtable(build)
-    grid::grid.draw(gtable)
-
-    list(
-      build = build,
-      gtable = gtable
-    )
-  }
-
-  # Given the name of a generic function and an object, return the class name
-  # for the method that would be used on the object.
-  which_method <- function(generic, x) {
-    classes <- class(x)
-    method_names <- paste(generic, classes, sep = ".")
-    idx <- which(method_names %in% utils::methods(generic))
-
-    if (length(idx) == 0)
-      return(NULL)
-
-    # Return name of first class with matching method
-    classes[idx[1]]
-  }
-
-
   # Given a built ggplot object, return x and y domains (data space coords) for
   # each panel.
   find_panel_info <- function(b) {
@@ -385,7 +474,7 @@ getGgplotCoordmap <- function(p, pixelratio) {
   # ggplot object, return the domain.
   find_panel_domain <- function(b, panel_num, scalex_num = 1, scaley_num = 1) {
     range <- b$panel$ranges[[panel_num]]
-    res <- list(
+    domain <- list(
       left   = range$x.range[1],
       right  = range$x.range[2],
       bottom = range$y.range[1],
@@ -397,15 +486,15 @@ getGgplotCoordmap <- function(p, pixelratio) {
     yscale <- b$panel$y_scales[[scaley_num]]
 
     if (!is.null(xscale$trans) && xscale$trans$name == "reverse") {
-      res$left  <- -res$left
-      res$right <- -res$right
+      domain$left  <- -domain$left
+      domain$right <- -domain$right
     }
     if (!is.null(yscale$trans) && yscale$trans$name == "reverse") {
-      res$top    <- -res$top
-      res$bottom <- -res$bottom
+      domain$top    <- -domain$top
+      domain$bottom <- -domain$bottom
     }
 
-    res
+    domain
   }
 
   # Given built ggplot object, return object with the log base for x and y if
@@ -513,9 +602,22 @@ getGgplotCoordmap <- function(p, pixelratio) {
       }
     }
 
+    # Workaround for a bug in the quartz device. If you have a 400x400 image and
+    # run `convertWidth(unit(1, "npc"), "native")`, the result will depend on
+    # res setting of the device. If res=72, then it returns 400 (as expected),
+    # but if, e.g., res=96, it will return 300, which is incorrect.
+    devScaleFactor <- 1
+    if (grepl("quartz", names(grDevices::dev.cur()), fixed = TRUE)) {
+      devScaleFactor <- res / 72
+    }
+
     # Convert a unit (or vector of units) to a numeric vector of pixel sizes
-    h_px <- function(x) as.numeric(grid::convertHeight(x, "native"))
-    w_px <- function(x) as.numeric(grid::convertWidth(x, "native"))
+    h_px <- function(x) {
+      devScaleFactor * grid::convertHeight(x, "native", valueOnly = TRUE)
+    }
+    w_px <- function(x) {
+      devScaleFactor * grid::convertWidth(x, "native", valueOnly = TRUE)
+    }
 
     # Given a vector of relative sizes (in grid units), and a function for
     # converting grid units to numeric pixels, return a numeric vector of
@@ -582,36 +684,25 @@ getGgplotCoordmap <- function(p, pixelratio) {
     })
   }
 
-  # If print(p) gets dispatched to print.ggplot(p), attempt to extract coordmap.
-  # If dispatched to another method, just print the object and don't attempt to
-  # extract the coordmap. This can happen if there's another print method that
-  # takes precedence.
-  if (identical(which_method("print", p), "ggplot")) {
-    res <- print(p)
 
-    tryCatch({
-      # Get info from built ggplot object
-      info <- find_panel_info(res$build)
+  tryCatch({
+    # Get info from built ggplot object
+    info <- find_panel_info(p$build)
 
-      # Get ranges from gtable - it's possible for this to return more elements than
-      # info, because it calculates positions even for panels that aren't present.
-      # This can happen with facet_wrap.
-      ranges <- find_panel_ranges(res$gtable, pixelratio)
+    # Get ranges from gtable - it's possible for this to return more elements than
+    # info, because it calculates positions even for panels that aren't present.
+    # This can happen with facet_wrap.
+    ranges <- find_panel_ranges(p$gtable, pixelratio)
 
-      for (i in seq_along(info)) {
-        info[[i]]$range <- ranges[[i]]
-      }
+    for (i in seq_along(info)) {
+      info[[i]]$range <- ranges[[i]]
+    }
 
-      return(info)
+    return(info)
 
-    }, error = function(e) {
-      # If there was an error extracting info from the ggplot object, just return
-      # a list with the error message.
-      return(structure(list(), error = e$message))
-    })
-
-  } else {
-    print(p)
-    return(list())
-  }
+  }, error = function(e) {
+    # If there was an error extracting info from the ggplot object, just return
+    # a list with the error message.
+    return(structure(list(), error = e$message))
+  })
 }

R/render-table.R

@@ -3,33 +3,114 @@
 #' Creates a reactive table that is suitable for assigning to an \code{output}
 #' slot.
 #'
-#' The corresponding HTML output tag should be \code{div} and have the CSS class
-#' name \code{shiny-html-output}.
+#' The corresponding HTML output tag should be \code{div} and have the CSS
+#' class name \code{shiny-html-output}.
 #'
 #' @param expr An expression that returns an R object that can be used with
 #'   \code{\link[xtable]{xtable}}.
-#' @param ... Arguments to be passed through to \code{\link[xtable]{xtable}} and
-#'   \code{\link[xtable]{print.xtable}}.
+#' @param striped,hover,bordered Logicals: if \code{TRUE}, apply the
+#'   corresponding Bootstrap table format to the output table.
+#' @param spacing The spacing between the rows of the table (\code{xs}
+#'   stands for "extra small", \code{s} for "small", \code{m} for "medium"
+#'   and \code{l} for "large").
+#' @param width Table width. Must be a valid CSS unit (like "100%", "400px",
+#'   "auto") or a number, which will be coerced to a string and
+#'   have "px" appended.
+#' @param align A string that specifies the column alignment. If equal to
+#'   \code{'l'}, \code{'c'} or \code{'r'}, then all columns will be,
+#'   respectively, left-, center- or right-aligned. Otherwise, \code{align}
+#'   must have the same number of characters as the resulting table (if
+#'   \code{rownames = TRUE}, this will be equal to \code{ncol()+1}), with
+#'   the \emph{i}-th character specifying the alignment for the
+#'   \emph{i}-th column (besides \code{'l'}, \code{'c'} and
+#'   \code{'r'}, \code{'?'} is also permitted - \code{'?'} is a placeholder
+#'   for that particular column, indicating that it should keep its default
+#'   alignment). If \code{NULL}, then all numeric/integer columns (including
+#'   the row names, if they are numbers) will be right-aligned and
+#'   everything else will be left-aligned (\code{align = '?'} produces the
+#'   same result).
+#' @param rownames,colnames Logicals: include rownames? include colnames
+#'   (column headers)?
+#' @param digits An integer specifying the number of decimal places for
+#'   the numeric columns (this will not apply to columns with an integer
+#'   class). If \code{digits} is set to a negative value, then the numeric
+#'   columns will be displayed in scientific format with a precision of
+#'   \code{abs(digits)} digits.
+#' @param na The string to use in the table cells whose values are missing
+#'   (i.e. they either evaluate to \code{NA} or \code{NaN}).
+#' @param ... Arguments to be passed through to \code{\link[xtable]{xtable}}
+#'   and \code{\link[xtable]{print.xtable}}.
 #' @param env The environment in which to evaluate \code{expr}.
-#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
-#'   is useful if you want to save an expression in a variable.
-#' @param func A function that returns an R object that can be used with
-#'   \code{\link[xtable]{xtable}} (deprecated; use \code{expr} instead).
+#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})?
+#'   This is useful if you want to save an expression in a variable.
+#' @param outputArgs A list of arguments to be passed through to the
+#'   implicit call to \code{\link{tableOutput}} when \code{renderTable} is
+#'   used in an interactive R Markdown document.
 #'
 #' @export
-renderTable <- function(expr, ..., env=parent.frame(), quoted=FALSE, func=NULL) {
-  if (!is.null(func)) {
-    shinyDeprecated(msg="renderTable: argument 'func' is deprecated. Please use 'expr' instead.")
-  } else {
-    installExprFunction(expr, "func", env, quoted)
+renderTable <- function(expr, striped = FALSE, hover = FALSE,
+                        bordered = FALSE, spacing = c("s", "xs", "m", "l"),
+                        width = "auto", align = NULL,
+                        rownames = FALSE, colnames = TRUE,
+                        digits = NULL, na = "NA", ...,
+                        env = parent.frame(), quoted = FALSE,
+                        outputArgs=list()) {
+  installExprFunction(expr, "func", env, quoted)
+
+  if (!is.function(spacing)) spacing <- match.arg(spacing)
+
+  # A small helper function to create a wrapper for an argument that was
+  # passed to renderTable()
+  createWrapper <- function(arg) {
+    if (is.function(arg)) wrapper <- arg
+    else wrapper <- function() arg
+    return(wrapper)
   }
 
-  markRenderFunction(tableOutput, function() {
-    classNames <- getOption('shiny.table.class') %OR% 'data table table-bordered table-condensed'
-    data <- func()
+  # Create wrappers for most arguments so that functions can also be passed
+  # in, rather than only literals (useful for shiny apps)
+  stripedWrapper <- createWrapper(striped)
+  hoverWrapper <- createWrapper(hover)
+  borderedWrapper <- createWrapper(bordered)
+  spacingWrapper <- createWrapper(spacing)
+  widthWrapper <- createWrapper(width)
+  alignWrapper <- createWrapper(align)
+  rownamesWrapper <- createWrapper(rownames)
+  colnamesWrapper <- createWrapper(colnames)
+  digitsWrapper <- createWrapper(digits)
+  naWrapper <- createWrapper(na)
 
-    if (is.null(data) || identical(data, data.frame()))
-      return("")
+  renderFunc <- function(shinysession, name, ...) {
+    striped <- stripedWrapper()
+    hover <- hoverWrapper()
+    bordered <- borderedWrapper()
+    format <- c(striped = striped, hover = hover, bordered = bordered)
+    spacing <- spacingWrapper()
+    width <- widthWrapper()
+    align <- alignWrapper()
+    rownames <- rownamesWrapper()
+    colnames <- colnamesWrapper()
+    digits <- digitsWrapper()
+    na <- naWrapper()
+
+    spacing_choices <- c("s", "xs", "m", "l")
+    if (!(spacing %in% spacing_choices)) {
+      stop(paste("`spacing` must be one of",
+                 paste0("'", spacing_choices, "'", collapse=", ")))
+    }
+
+    # For css styling
+    classNames <- paste0("table shiny-table",
+                         paste0(" table-", names(format)[format], collapse = "" ),
+                         paste0(" spacing-", spacing))
+
+    data <- func()
+    data <- as.data.frame(data)
+
+    # Return NULL if no data is provided
+    if (is.null(data) ||
+        (is.data.frame(data) && nrow(data) == 0 && ncol(data) == 0))
+      return(NULL)
 
     # Separate the ... args to pass to xtable() vs print.xtable()
     dots <- list(...)
@@ -37,23 +118,91 @@ renderTable <- function(expr, ..., env=parent.frame(), quoted=FALSE, func=NULL)
     xtable_args <- dots[intersect(names(dots), xtable_argnames)]
     non_xtable_args <- dots[setdiff(names(dots), xtable_argnames)]
 
-    # Call xtable with its args
+    # By default, numbers are right-aligned and everything else is left-aligned.
+    defaultAlignment <- function(col) {
+      if (is.numeric(col)) "r" else "l"
+    }
+
+    # Figure out column alignment
+    ## Case 1: default alignment
+    if (is.null(align) || align == "?") {
+      names <- defaultAlignment(attr(data, "row.names"))
+      cols <- paste(vapply(data, defaultAlignment, character(1)), collapse = "")
+      cols <- paste0(names, cols)
+    } else {
+      ## Case 2: user-specified alignment
+      num_cols <- if (rownames) nchar(align) else nchar(align)+1
+      valid <- !grepl("[^lcr\\?]", align)
+      if (num_cols == ncol(data)+1 && valid) {
+        cols <- if (rownames) align else paste0("r", align)
+        defaults <- grep("\\?", strsplit(cols,"")[[1]])
+        if (length(defaults) != 0) {
+          vals <- vapply(data[,defaults-1], defaultAlignment, character(1))
+          for (i in seq_len(length(defaults))) {
+            substr(cols, defaults[i], defaults[i]) <- vals[i]
+          }
+        }
+      } else if (nchar(align) == 1 && valid) {
+        cols <- paste0(rep(align, ncol(data)+1), collapse="")
+      } else {
+        stop("`align` must contain only the characters `l`, `c`, `r` and/or `?` and",
+             "have length either equal to 1 or to the total number of columns")
+      }
+    }
+
+    # Call xtable with its (updated) args
+    xtable_args <- c(xtable_args, align = cols, digits = digits)
     xtable_res <- do.call(xtable, c(list(data), xtable_args))
 
     # Set up print args
     print_args <- list(
       xtable_res,
       type = 'html',
-      html.table.attributes = paste('class="', htmlEscape(classNames, TRUE),
-                                    '"', sep='')
-    )
+      include.rownames = rownames,
+      include.colnames = colnames,
+      NA.string = na,
+      html.table.attributes = paste0("class = '", htmlEscape(classNames, TRUE), "' ",
+                                     "style = 'width:", validateCssUnit(width), ";'"))
+
     print_args <- c(print_args, non_xtable_args)
 
-    return(paste(
-      utils::capture.output(
-        do.call(print, print_args)
-      ),
-      collapse="\n"
-    ))
-  })
+    # Capture the raw html table returned by print.xtable(), and store it in
+    # a variable for further processing
+    tab <- paste(utils::capture.output(do.call(print, print_args)),collapse = "\n")
+
+    # Add extra class to cells with NA value, to be able to style them separately
+    tab <- gsub(paste(">", na, "<"), paste(" class='NA'>", na, "<"), tab)
+
+    # All further processing concerns the table headers, so we don't need to run
+    # any of this if colnames=FALSE
+    if (colnames) {
+      # Make sure that the final html table has a proper header (not included
+      # in the print.xtable() default)
+      tab <- sub("<tr>", "<thead> <tr>", tab)
+      tab <- sub("</tr>", "</tr> </thead> <tbody>", tab)
+      tab <- sub("</table>$", "</tbody> </table>", tab)
+
+      # Update the `cols` string (which stores the alignment of each column) so
+      # that it only includes the alignment for the table variables (and not
+      # for the row.names)
+      cols <- if (rownames) cols else substr(cols, 2, nchar(cols))
+
+      # Create a vector whose i-th entry corresponds to the i-th table variable
+      # alignment (substituting "l" by "left", "c" by "center" and "r" by "right")
+      cols <- strsplit(cols, "")[[1]]
+      cols[cols == "l"] <- "left"
+      cols[cols == "r"] <- "right"
+      cols[cols == "c"] <- "center"
+
+      # Align each header accordingly (this guarantees that each header and its
+      # corresponding column have the same alignment)
+      for (i in seq_len(length(cols))) {
+        tab <- sub("<th>", paste0("<th style='text-align: ", cols[i], ";'>"), tab)
+      }
+    }
+    return(tab)
+  }
+
+  # Main render function
+  markRenderFunction(tableOutput, renderFunc, outputArgs = outputArgs)
 }

R/run-url.R

@@ -22,7 +22,7 @@
 #' @export
 #' @examples
 #' ## Only run this example in interactive R sessions
-#'   if (interactive()) {
+#' if (interactive()) {
 #'   runUrl('https://github.com/rstudio/shiny_example/archive/master.tar.gz')
 #'
 #'   # Can run an app from a subdirectory in the archive

R/save-state-local.R

@@ -0,0 +1,29 @@
+# Function wrappers for persisting or restoring state when running Shiny locally
+#
+# These functions provide a directory to the callback function.
+#
+# @param id A session ID to save.
+# @param callback A callback function that saves state to or restores state from
+#   a directory. It must take one argument, \code{stateDir}, which is a
+#   directory to which it writes/reads.
+
+persistInterfaceLocal <- function(id, callback) {
+  # Try to save in app directory, or, if that's not available, in the current
+  # directory.
+  appDir <- getShinyOption("appDir", default = getwd())
+
+  stateDir <- file.path(appDir, "shiny_persist", id)
+  if (!dirExists(stateDir))
+    dir.create(stateDir, recursive = TRUE)
+
+  callback(stateDir)
+}
+
+loadInterfaceLocal <- function(id, callback) {
+  # Try to save in app directory, or, if that's not available, in the current
+  # directory.
+  appDir <- getShinyOption("appDir", default = getwd())
+
+  stateDir <- file.path(appDir, "shiny_persist", id)
+  callback(stateDir)
+}

R/save-state.R

@@ -0,0 +1,525 @@
+ShinySaveState <- R6Class("ShinySaveState",
+  public = list(
+    input = NULL,
+    exclude = NULL,
+    onSave = NULL, # A callback to invoke during the saving process.
+
+    # These are set not in initialize(), but by external functions that modify
+    # the ShinySaveState object.
+    dir = NULL,
+    values = NULL,
+
+    initialize = function(input = NULL, exclude = NULL, onSave = NULL)
+    {
+      self$input   <- input
+      self$exclude <- exclude
+      self$onSave  <- onSave
+    },
+
+    # Persist this state object to disk. Returns a query string which can be
+    # used to restore the session.
+    persist = function() {
+      id <- createUniqueId(8)
+
+      persistInterface <- getShinyOption("persist.interface",
+                                         default = persistInterfaceLocal)
+
+      persistInterface(id, function(stateDir) {
+        # Directory is provided by the persistInterface function.
+        self$dir <- stateDir
+
+        # Allow user-supplied onSave function to do things like add self$values, or
+        # save data to state dir.
+        if (!is.null(self$onSave))
+          isolate(self$onSave(self))
+
+        # Serialize values, possibly saving some extra data to stateDir
+        inputValues <- serializeReactiveValues(self$input, self$exclude, self$dir)
+        saveRDS(inputValues, file.path(stateDir, "input.rds"))
+
+        # If there values passed in, save them also
+        if (!is.null(self$values))
+          saveRDS(self$values, file.path(stateDir, "values.rds"))
+      })
+
+      paste0("__state_id__=", encodeURIComponent(id))
+    },
+
+    # Encode the state to a URL. This does not save to disk.
+    encode = function() {
+      inputVals <- serializeReactiveValues(self$input, self$exclude, stateDir = NULL)
+
+      # Allow user-supplied onSave function to do things like add self$values.
+      if (!is.null(self$onSave))
+        self$onSave(self)
+
+      inputVals <- vapply(inputVals,
+        function(x) toJSON(x, strict_atomic = FALSE),
+        character(1),
+        USE.NAMES = TRUE
+      )
+
+      res <- paste0(
+        encodeURIComponent(names(inputVals)),
+        "=",
+        encodeURIComponent(inputVals),
+        collapse = "&"
+      )
+
+      # If 'values' is present, add them as well.
+      if (length(self$values) != 0) {
+        values <- vapply(self$values,
+          function(x) toJSON(x, strict_atomic = FALSE),
+          character(1),
+          USE.NAMES = TRUE
+        )
+
+        res <- paste0(res, "&_values_&",
+          paste0(
+            encodeURIComponent(names(values)),
+            "=",
+            encodeURIComponent(values),
+            collapse = "&"
+          )
+        )
+      }
+
+      res
+    }
+  )
+)
+
+
+RestoreContext <- R6Class("RestoreContext",
+  public = list(
+    # This is a RestoreInputSet for input values. This is a key-value store with
+    # some special handling.
+    input = NULL,
+
+    # Directory for extra files, if restoring from persisted state
+    dir = NULL,
+
+    # For values other than input values. These values don't need the special
+    # phandling that's needed for input values, because they're only accessed
+    # from the onRestore function.
+    values = NULL,
+
+    initialize = function(queryString = NULL) {
+      if (!is.null(queryString)) {
+        tryCatch(
+          {
+            qsValues <- parseQueryString(queryString, nested = TRUE)
+
+            if (!is.null(qsValues[["__subapp__"]]) && qsValues[["__subapp__"]] == 1) {
+              # Ignore subapps in shiny docs
+              self$reset()
+
+            } else if (!is.null(qsValues[["__state_id__"]]) && nzchar(qsValues[["__state_id__"]])) {
+              # If we have a "__state_id__" key, restore from persisted state and ignore
+              # other key/value pairs. If not, restore from key/value pairs in the
+              # query string.
+              private$loadStateQueryString(queryString)
+
+            } else {
+              # The query string contains the saved keys and values
+              private$decodeStateQueryString(queryString)
+            }
+          },
+          error = function(e) {
+            # If there's an error in restoring problem, just reset these values
+            self$reset()
+            warning(e$message)
+          }
+        )
+      }
+    },
+
+    reset = function() {
+      self$input <- RestoreInputSet$new(list())
+      self$values <- list()
+      self$dir <- NULL
+    },
+
+    # This should be called before a restore context is popped off the stack.
+    flushPending = function() {
+      self$input$flushPending()
+    },
+
+
+    # Returns a list representation of the RestoreContext object. This is passed
+    # to the app author's onRestore function. An important difference between
+    # the RestoreContext object and the list is that the former's `input` field
+    # is a RestoreInputSet object, while the latter's `input` field is just a
+    # list.
+    asList = function() {
+      list(
+        input = self$input$asList(),
+        dir = self$dir,
+        values = self$values
+      )
+    }
+  ),
+
+  private = list(
+    # Given a query string with a __state_id__, load persisted state with that ID.
+    loadStateQueryString = function(queryString) {
+      values <- parseQueryString(queryString, nested = TRUE)
+      id <- values[["__state_id__"]]
+
+      # This function is passed to the loadInterface function; given a
+      # directory, it will load state from that directory
+      loadFun <- function(stateDir) {
+        self$dir <- stateDir
+
+        inputValues <- readRDS(file.path(stateDir, "input.rds"))
+        self$input <- RestoreInputSet$new(inputValues)
+
+        valuesFile <- file.path(stateDir, "values.rds")
+        if (file.exists(valuesFile)) {
+          self$values <- readRDS(valuesFile)
+        } else {
+          self$values <- list()
+        }
+      }
+
+      loadInterface <- getShinyOption("load.interface", default = loadInterfaceLocal)
+      loadInterface(id, loadFun)
+
+      invisible()
+    },
+
+    # Given a query string with values encoded in it, restore persisted state
+    # from those values.
+    decodeStateQueryString = function(queryString) {
+      # Remove leading '?'
+      if (substr(queryString, 1, 1) == '?')
+        queryString <- substr(queryString, 2, nchar(queryString))
+
+      if (grepl("(^|&)_values_(&|$)", queryString)) {
+        splitStr <- strsplit(queryString, "(^|&)_values_(&|$)")[[1]]
+        inputValueStr <- splitStr[1]
+        valueStr <- splitStr[2]
+        if (is.na(valueStr))
+          valueStr <- ""
+
+      } else {
+        inputValueStr <- queryString
+        valueStr <- ""
+      }
+
+      inputValues <- parseQueryString(inputValueStr, nested = TRUE)
+      values <- parseQueryString(valueStr, nested = TRUE)
+
+      valuesFromJSON <- function(vals) {
+        mapply(names(vals), vals, SIMPLIFY = FALSE,
+          FUN = function(name, value) {
+            tryCatch(
+              jsonlite::fromJSON(value),
+              error = function(e) {
+                stop("Failed to parse URL parameter \"", name, "\"")
+              }
+            )
+          }
+        )
+      }
+
+      inputValues <- valuesFromJSON(inputValues)
+      self$input <- RestoreInputSet$new(inputValues)
+
+      self$values <- valuesFromJSON(values)
+    }
+  )
+)
+
+
+# Restore input set. This is basically a key-value store, except for one
+# important difference: When the user `get()`s a value, the value is marked as
+# pending; when `flushPending()` is called, those pending values are marked as
+# used. When a value is marked as used, `get()` will not return it, unless
+# called with `force=TRUE`. This is to make sure that a particular value can be
+# restored only within a single call to `withRestoreContext()`. Without this, if
+# a value is restored in a dynamic UI, it could completely prevent any other
+# (non- restored) kvalue from being used.
+RestoreInputSet <- R6Class("RestoreInputSet",
+  private = list(
+    values = NULL,
+    pending = character(0),
+    used = character(0)     # Names of values which have been used
+  ),
+
+  public = list(
+    initialize = function(values) {
+      private$values <- new.env(parent = emptyenv())
+      list2env(values, private$values)
+    },
+
+    exists = function(name) {
+      exists(name, envir = private$values)
+    },
+
+    # Return TRUE if the value exists and has not been marked as used.
+    available = function(name) {
+      self$exists(name) && !self$isUsed(name)
+    },
+
+    isPending = function(name) {
+      name %in% private$pending
+    },
+
+    isUsed = function(name) {
+      name %in% private$used
+    },
+
+    # Get a value. If `force` is TRUE, get the value without checking whether
+    # has been used, and without marking it as pending.
+    get = function(name, force = FALSE) {
+      if (force)
+        return(private$values[[name]])
+
+      if (!self$available(name))
+        return(NULL)
+
+      # Mark this name as pending. Use unique so that it's not added twice.
+      private$pending <- unique(c(private$pending, name))
+      private$values[[name]]
+    },
+
+    # Take pending names and mark them as used, then clear pending list.
+    flushPending = function() {
+      private$used <- unique(c(private$used, private$pending))
+      private$pending <- character(0)
+    },
+
+    asList = function() {
+      as.list.environment(private$values)
+    }
+  )
+)
+
+
+restoreCtxStack <- Stack$new()
+
+withRestoreContext <- function(ctx, expr) {
+  restoreCtxStack$push(ctx)
+
+  on.exit({
+    # Mark pending names as used
+    restoreCtxStack$peek()$flushPending()
+    restoreCtxStack$pop()
+  }, add = TRUE)
+
+  force(expr)
+}
+
+# Is there a current restore context?
+hasCurrentRestoreContext <- function() {
+  restoreCtxStack$size() > 0
+}
+
+# Call to access the current restore context
+getCurrentRestoreContext <- function() {
+  ctx <- restoreCtxStack$peek()
+  if (is.null(ctx)) {
+    stop("No restore context found")
+  }
+  ctx
+}
+
+#' Restore an input value
+#'
+#' This restores an input value from the current restore context..
+#'
+#' @param id Name of the input value to restore.
+#' @param default A default value to use, if there's no value to restore.
+#'
+#' @export
+restoreInput <- function(id, default) {
+  # Need to evaluate `default` in case it contains reactives like input$x. If we
+  # don't, then the calling code won't take a reactive dependency on input$x
+  # when restoring a value.
+  force(default)
+
+  if (identical(getShinyOption("restorable"), FALSE) || !hasCurrentRestoreContext())
+    return(default)
+
+  oldInputs <- getCurrentRestoreContext()$input
+  if (oldInputs$available(id)) {
+    oldInputs$get(id)
+  } else {
+    default
+  }
+}
+
+#' Update URL in browser's location bar
+#'
+#' @param queryString The new query string to show in the location bar.
+#' @param session A Shiny session object.
+#' @export
+updateLocationBar <- function(queryString, session = getDefaultReactiveDomain()) {
+  session$updateLocationBar(queryString)
+}
+
+#' Create a button for bookmarking/sharing
+#'
+#' A \code{bookmarkButton} is a \code{\link{actionButton}} with a default label
+#' that consists of a link icon and the text "Share...". It is meant to be used
+#' for bookmarking state.
+#'
+#' @seealso configureBookmarking
+#' @inheritParams actionButton
+#' @export
+saveStateButton <- function(inputId, label = "Save and share...",
+  icon = shiny::icon("link", lib = "glyphicon"),
+  title = "Save this application's current state and get a URL for sharing.",
+  ...)
+{
+  actionButton(inputId, label, icon, title = title, ...)
+}
+
+
+#' Generate a modal dialog that displays a URL
+#'
+#' The modal dialog generated by \code{urlModal} will display the URL in a
+#' textarea input, and the URL text will be selected so that it can be easily
+#' copied. The result from \code{urlModal} should be passed to the
+#' \code{\link{showModal}} function to display it in the browser.
+#'
+#' @param url A URL to display in the dialog box.
+#' @param title A title for the dialog box.
+#' @param subtitle Text to display underneath URL.
+#' @export
+urlModal <- function(url, title = "Saved application link", subtitle = NULL) {
+
+  subtitleTag <- NULL
+  if (!is.null(subtitle)) {
+    subtitleTag <- tagList(
+      br(),
+      span(class = "text-muted", subtitle)
+    )
+  }
+
+  modalDialog(
+    title = title,
+    easyClose = TRUE,
+    footer = NULL,
+    tags$textarea(class = "form-control", rows = "1", style = "resize: none;",
+      readonly = "readonly",
+      url
+    ),
+    subtitleTag,
+    # Need separate show and shown listeners. The show listener sizes the
+    # textarea just as the modal starts to fade in. The 200ms delay is needed
+    # because if we try to resize earlier, it can't calculate the text height
+    # (scrollHeight will be reported as zero). The shown listener selects the
+    # text; it's needed because because selection has to be done after the fade-
+    # in is completed.
+    tags$script(
+      "$('#shiny-modal').
+        one('show.bs.modal', function() {
+          setTimeout(function() {
+            var $textarea = $('#shiny-modal textarea');
+            $textarea.innerHeight($textarea[0].scrollHeight);
+          }, 200);
+        });
+      $('#shiny-modal')
+        .one('shown.bs.modal', function() {
+          $('#shiny-modal textarea').select().focus();
+        });"
+    )
+  )
+}
+
+
+#' Configure bookmarking for the current session
+#'
+#' There are two types of bookmarking: saving state, and encoding state.
+#'
+#' @param eventExpr An expression to listen for, similar to
+#'   \code{\link{observeEvent}}.
+#' @param type Either \code{"encode"}, which encodes all of the relevant values
+#'   in a URL, \code{"persist"}, which saves to disk, or \code{"disable"}, which
+#'   disables any previously-enabled bookmarking.
+#' @param exclude Input values to exclude from bookmarking.
+#' @param onBookmark A function to call before saving state. This function
+#'   should return a list, which will be saved as \code{values}.
+#' @param onRestore A function to call when a session is restored. It will be
+#'   passed one argument, a restoreContext object.
+#' @param onBookmarked A callback function to invoke after the bookmarking has
+#'   been done.
+#' @param session A Shiny session object.
+#' @export
+configureBookmarking <- function(eventExpr,
+  type = c("encode", "persist", "disable"), exclude = NULL,
+  onBookmark = NULL, onRestore = NULL, onBookmarked = NULL,
+  session = getDefaultReactiveDomain())
+{
+
+  eventExpr <- substitute(eventExpr)
+  type <- match.arg(type)
+
+  # If there's an existing onBookmarked observer, destroy it before creating a
+  # new one.
+  if (!is.null(session$bookmarkObserver)) {
+    session$bookmarkObserver$destroy()
+    session$bookmarkObserver <- NULL
+  }
+
+  if (type == "disable") {
+    return(invisible())
+  }
+
+  # If no onBookmarked function is provided, use one of these defaults.
+  if (is.null(onBookmarked)) {
+    if (type == "persist") {
+      onBookmarked <- function(url) {
+        showModal(urlModal(
+          url,
+          subtitle = "The current state of this application has been persisted."
+        ))
+      }
+    } else if (type == "encode") {
+      onBookmarked <- function(url) {
+        showModal(urlModal(
+          url,
+          subtitle = "This link encodes the current state of this application."
+        ))
+      }
+    }
+  } else if (!is.function(onBookmarked)) {
+    stop("onBookmarked must be a function.")
+  }
+
+  session$bookmarkObserver <- observeEvent(
+    eventExpr,
+    event.env = parent.frame(),
+    event.quoted = TRUE,
+    {
+      saveState <- ShinySaveState$new(session$input, exclude, onBookmark)
+
+      if (type == "persist") {
+        url <- saveState$persist()
+      } else {
+        url <- saveState$encode()
+      }
+
+      clientData <- session$clientData
+      url <- paste0(
+        clientData$url_protocol, "//",
+        clientData$url_hostname,
+        if (nzchar(clientData$url_port)) paste0(":", clientData$url_port),
+        clientData$url_pathname,
+        "?", url
+      )
+
+      onBookmarked(url)
+    }
+  )
+
+  # Run the onRestore function immediately
+  if (!is.null(onRestore)) {
+    restoreState <- getCurrentRestoreContext()$asList()
+    onRestore(restoreState)
+  }
+
+  invisible()
+}

R/serializers.R

@@ -0,0 +1,72 @@
+# For most types of values, simply return the value unchanged.
+serializerDefault <- function(value, stateDir) {
+  value
+}
+
+
+serializerFileInput <- function(value, stateDir = NULL) {
+  # File inputs can be serialized only if there's a stateDir
+  if (is.null(stateDir)) {
+    return(serializerUnserializable())
+  }
+
+  # value is a data frame. When persisting files, we need to copy the file to
+  # the persistent dir and then strip the original path before saving.
+  newpaths <- file.path(stateDir, basename(value$datapath))
+  file.copy(value$datapath, newpaths, overwrite = TRUE)
+  value$datapath <- basename(newpaths)
+
+  value
+}
+
+
+# Return a sentinel value that represents "unserializable". This is applied to
+# for example, passwords and actionButtons.
+serializerUnserializable <- function(value, stateDir) {
+  structure(
+    list(),
+    serializable = FALSE
+  )
+}
+
+# Is this an "unserializable" sentinel value?
+isUnserializable <- function(x) {
+  identical(
+    attr(x, "serializable", exact = TRUE),
+    FALSE
+  )
+}
+
+
+# Given a reactiveValues object and optional directory for saving state, apply
+# serializer function to each of the values, and return a list of the returned
+# values. This function passes stateDir to the serializer functions, so if
+# stateDir is non-NULL, it can have a side effect of writing values to disk (in
+# stateDir).
+serializeReactiveValues <- function(values, exclude, stateDir = NULL) {
+  impl <- .subset2(values, "impl")
+
+  # Get named list where keys and values are the names of inputs; we'll retrieve
+  # actual values later.
+  vals <- isolate(impl$names())
+  vals <- setdiff(vals, exclude)
+  names(vals) <- vals
+
+  # Get values and apply serializer functions
+  vals <- lapply(vals, function(name) {
+    val <- impl$get(name)
+
+    # Get the serializer function for this input value. If none specified, use
+    # the default.
+    serializer <- impl$getMeta(name, "shiny.serializer")
+    if (is.null(serializer))
+      serializer <- serializerDefault
+
+    # Apply serializer function.
+    serializer(val, stateDir)
+  })
+
+  # Filter out any values that were marked as unserializable.
+  vals <- Filter(Negate(isUnserializable), vals)
+  vals
+}

R/server-input-handlers.R

@@ -89,6 +89,12 @@ registerInputHandler("shiny.number", function(val, ...){
   ifelse(is.null(val), NA, val)
 })
 
+registerInputHandler("shiny.password", function(val, shinysession, name) {
+  # Mark passwords as not serializable
+  .subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerUnserializable)
+  val
+})
+
 registerInputHandler("shiny.date", function(val, ...){
   # First replace NULLs with NA, then convert to Date vector
   datelist <- ifelse(lapply(val, is.null), NA, val)
@@ -104,8 +110,33 @@ registerInputHandler("shiny.datetime", function(val, ...){
   as.POSIXct(unlist(times), origin = "1970-01-01", tz = "UTC")
 })
 
-registerInputHandler("shiny.action", function(val, ...) {
+registerInputHandler("shiny.action", function(val, shinysession, name) {
+  # Mark as not serializable
+  .subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerUnserializable)
+
   # mark up the action button value with a special class so we can recognize it later
   class(val) <- c(class(val), "shinyActionButtonValue")
   val
 })
+
+registerInputHandler("shiny.file", function(val, shinysession, name) {
+  # This function is only used when restoring a Shiny fileInput. When a file is
+  # uploaded the usual way, it takes a different code path and won't hit this
+  # function.
+  if (is.null(val))
+    return(NULL)
+
+  # The data will be a named list of lists; convert to a data frame.
+  val <- as.data.frame(lapply(val, unlist), stringsAsFactors = FALSE)
+
+  # Make sure that the paths don't go up the directory tree, for security
+  # reasons.
+  if (any(grepl("..", val$datapath, fixed = TRUE))) {
+    stop("Invalid '..' found in file input path.")
+  }
+
+  # Prepend the persistent dir
+  val$datapath <- file.path(getCurrentRestoreContext()$dir, val$datapath)
+
+  val
+})

R/server.R

@@ -232,121 +232,132 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
 
           msg <- decodeMessage(msg)
 
-          # Do our own list simplifying here. sapply/simplify2array give names to
-          # character vectors, which is rarely what we want.
-          if (!is.null(msg$data)) {
-            for (name in names(msg$data)) {
-              val <- msg$data[[name]]
+          # Set up a restore context from .clientdata_url_search before
+          # handling all the input values, because the restore context may be
+          # used by an input handler (like the one for "shiny.file"). This
+          # should only happen once, when the app starts.
+          if (is.null(shinysession$restoreContext)) {
+            # If there's bookmarked state, save it on the session object
+            shinysession$restoreContext <- RestoreContext$new(msg$data$.clientdata_url_search)
+          }
 
+          withRestoreContext(shinysession$restoreContext, {
+
+            unpackInput <- function(name, val) {
               splitName <- strsplit(name, ':')[[1]]
               if (length(splitName) > 1) {
-                msg$data[[name]] <- NULL
-
-                if (!inputHandlers$containsKey(splitName[[2]])){
+                if (!inputHandlers$containsKey(splitName[[2]])) {
                   # No input handler registered for this type
                   stop("No handler registered for for type ", name)
                 }
 
-                msg$data[[ splitName[[1]] ]] <-
-                  inputHandlers$get(splitName[[2]])(
-                    val,
-                    shinysession,
-                    splitName[[1]] )
-              }
-              else if (is.list(val) && is.null(names(val))) {
-                val_flat <- unlist(val, recursive = TRUE)
+                inputName <- splitName[[1]]
 
-                if (is.null(val_flat)) {
-                  # This is to assign NULL instead of deleting the item
-                  msg$data[name] <- list(NULL)
-                } else {
-                  msg$data[[name]] <- val_flat
-                }
+                # Get the function for processing this type of input
+                inputHandler <- inputHandlers$get(splitName[[2]])
+
+                return(inputHandler(val, shinysession, inputName))
+
+              } else if (is.list(val) && is.null(names(val))) {
+                return(unlist(val, recursive = TRUE))
+              } else {
+                return(val)
               }
             }
-          }
 
-          switch(
-            msg$method,
-            init = {
+            msg$data <- mapply(unpackInput, names(msg$data), msg$data,
+                               SIMPLIFY = FALSE)
 
-              serverFunc <- withReactiveDomain(NULL, serverFuncSource())
-              if (!identicalFunctionBodies(serverFunc, appvars$server)) {
-                appvars$server <- serverFunc
-                if (!is.null(appvars$server))
-                {
-                  # Tag this function as the Shiny server function. A debugger may use this
-                  # tag to give this function special treatment.
-                  # It's very important that it's appvars$server itself and NOT a copy that
-                  # is invoked, otherwise new breakpoints won't be picked up.
-                  attr(appvars$server, "shinyServerFunction") <- TRUE
-                  registerDebugHook("server", appvars, "Server Function")
+            # Convert names like "button1:shiny.action" to "button1"
+            names(msg$data) <- vapply(
+              names(msg$data),
+              function(name) { strsplit(name, ":")[[1]][1] },
+              FUN.VALUE = character(1)
+            )
+
+
+            switch(
+              msg$method,
+              init = {
+
+                serverFunc <- withReactiveDomain(NULL, serverFuncSource())
+                if (!identicalFunctionBodies(serverFunc, appvars$server)) {
+                  appvars$server <- serverFunc
+                  if (!is.null(appvars$server))
+                  {
+                    # Tag this function as the Shiny server function. A debugger may use this
+                    # tag to give this function special treatment.
+                    # It's very important that it's appvars$server itself and NOT a copy that
+                    # is invoked, otherwise new breakpoints won't be picked up.
+                    attr(appvars$server, "shinyServerFunction") <- TRUE
+                    registerDebugHook("server", appvars, "Server Function")
+                  }
                 }
-              }
 
-              # Check for switching into/out of showcase mode
-              if (.globals$showcaseOverride &&
-                  exists(".clientdata_url_search", where = msg$data)) {
-                mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
-                if (!is.null(mode))
-                  shinysession$setShowcase(mode)
-              }
+                # Check for switching into/out of showcase mode
+                if (.globals$showcaseOverride &&
+                    exists(".clientdata_url_search", where = msg$data)) {
+                  mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
+                  if (!is.null(mode))
+                    shinysession$setShowcase(mode)
+                }
 
-              shinysession$manageInputs(msg$data)
+                shinysession$manageInputs(msg$data)
 
-              # The client tells us what singletons were rendered into
-              # the initial page
-              if (!is.null(msg$data$.clientdata_singletons)) {
-                shinysession$singletons <- strsplit(
-                  msg$data$.clientdata_singletons, ',')[[1]]
-              }
+                # The client tells us what singletons were rendered into
+                # the initial page
+                if (!is.null(msg$data$.clientdata_singletons)) {
+                  shinysession$singletons <- strsplit(
+                    msg$data$.clientdata_singletons, ',')[[1]]
+                }
 
-              local({
-                args <- argsForServerFunc(serverFunc, shinysession)
+                local({
+                  args <- argsForServerFunc(serverFunc, shinysession)
 
-                withReactiveDomain(shinysession, {
-                  do.call(
-                    # No corresponding ..stacktraceoff; the server func is pure
-                    # user code
-                    wrapFunctionLabel(appvars$server, "server",
-                      ..stacktraceon = TRUE
-                    ),
-                    args
-                  )
+                  withReactiveDomain(shinysession, {
+                    do.call(
+                      # No corresponding ..stacktraceoff; the server func is pure
+                      # user code
+                      wrapFunctionLabel(appvars$server, "server",
+                        ..stacktraceon = TRUE
+                      ),
+                      args
+                    )
+                  })
                 })
-              })
-            },
-            update = {
-              shinysession$manageInputs(msg$data)
-            },
-            shinysession$dispatch(msg)
-          )
-          shinysession$manageHiddenOutputs()
+              },
+              update = {
+                shinysession$manageInputs(msg$data)
+              },
+              shinysession$dispatch(msg)
+            )
+            shinysession$manageHiddenOutputs()
 
-          if (exists(".shiny__stdout", globalenv()) &&
-              exists("HTTP_GUID", ws$request)) {
-            # safe to assume we're in shiny-server
-            shiny_stdout <- get(".shiny__stdout", globalenv())
+            if (exists(".shiny__stdout", globalenv()) &&
+                exists("HTTP_GUID", ws$request)) {
+              # safe to assume we're in shiny-server
+              shiny_stdout <- get(".shiny__stdout", globalenv())
 
-            # eNter a flushReact
-            writeLines(paste("_n_flushReact ", get("HTTP_GUID", ws$request),
-              " @ ", sprintf("%.3f", as.numeric(Sys.time())),
-              sep=""), con=shiny_stdout)
-            flush(shiny_stdout)
+              # eNter a flushReact
+              writeLines(paste("_n_flushReact ", get("HTTP_GUID", ws$request),
+                " @ ", sprintf("%.3f", as.numeric(Sys.time())),
+                sep=""), con=shiny_stdout)
+              flush(shiny_stdout)
 
-            flushReact()
+              flushReact()
 
-            # eXit a flushReact
-            writeLines(paste("_x_flushReact ", get("HTTP_GUID", ws$request),
-              " @ ", sprintf("%.3f", as.numeric(Sys.time())),
-              sep=""), con=shiny_stdout)
-            flush(shiny_stdout)
-          } else {
-            flushReact()
-          }
-          lapply(appsByToken$values(), function(shinysession) {
-            shinysession$flushOutput()
-            NULL
+              # eXit a flushReact
+              writeLines(paste("_x_flushReact ", get("HTTP_GUID", ws$request),
+                " @ ", sprintf("%.3f", as.numeric(Sys.time())),
+                sep=""), con=shiny_stdout)
+              flush(shiny_stdout)
+            } else {
+              flushReact()
+            }
+            lapply(appsByToken$values(), function(shinysession) {
+              shinysession$flushOutput()
+              NULL
+            })
           })
         })
       }
@@ -565,6 +576,11 @@ runApp <- function(appDir=getwd(),
     handlerManager$clear()
   }, add = TRUE)
 
+  # Enable per-app Shiny options
+  oldOptionSet <- .globals$options
+  on.exit({
+    .globals$options <- oldOptionSet
+  },add = TRUE)
 
   if (is.null(host) || is.na(host))
     host <- '0.0.0.0'
@@ -607,21 +623,38 @@ runApp <- function(appDir=getwd(),
       on.exit(close(con), add = TRUE)
       settings <- read.dcf(con)
       if ("DisplayMode" %in% colnames(settings)) {
-        mode <- settings[1,"DisplayMode"]
+        mode <- settings[1, "DisplayMode"]
         if (mode == "Showcase") {
           setShowcaseDefault(1)
+          if ("IncludeWWW" %in% colnames(settings)) {
+            .globals$IncludeWWW <- as.logical(settings[1, "IncludeWWW"])
+            if (is.na(.globals$IncludeWWW)) {
+              stop("In your Description file, `IncludeWWW` ",
+                   "must be set to `True` (default) or `False`")
+            }
+          } else {
+            .globals$IncludeWWW <- TRUE
+          }
         }
       }
     }
   }
 
+  ## default is to show the .js, .css and .html files in the www directory
+  ## (if not in showcase mode, this variable will simply be ignored)
+  if (is.null(.globals$IncludeWWW) || is.na(.globals$IncludeWWW)) {
+    .globals$IncludeWWW <- TRUE
+  }
+
   # If display mode is specified as an argument, apply it (overriding the
   # value specified in DESCRIPTION, if any).
   display.mode <- match.arg(display.mode)
-  if (display.mode == "normal")
+  if (display.mode == "normal") {
     setShowcaseDefault(0)
-  else if (display.mode == "showcase")
+  }
+  else if (display.mode == "showcase") {
     setShowcaseDefault(1)
+  }
 
   require(shiny)
 

R/shiny-options.R

@@ -0,0 +1,57 @@
+.globals$options <- list()
+
+#' @param name Name of an option to get.
+#' @param default Value to be returned if the option is not currently set.
+#' @rdname shinyOptions
+#' @export
+getShinyOption <- function(name, default = NULL) {
+  # Make sure to use named (not numeric) indexing
+  name <- as.character(name)
+
+  if (name %in% names(.globals$options))
+    .globals$options[[name]]
+  else
+    default
+}
+
+#' Get or set Shiny options
+#'
+#' \code{getShinyOption} retrieves the value of a Shiny option.
+#' \code{shinyOptions} sets the value of Shiny options; it can also be used to
+#' return a list of all currently-set Shiny options.
+#'
+#' There is a global option set, which is available by default. When a Shiny
+#' application is run with \code{\link{runApp}}, that option set is duplicated
+#' and the new option set is available for getting or setting values. If options
+#' are set from global.R, app.R, ui.R, or server.R, or if they are set from
+#' inside the server function, then the options will be scoped to the
+#' application. When the application exits, the new option set is discarded and
+#' the global option set is restored.
+#'
+#' @param ... Options to set, with the form \code{name = value}.
+#'
+#' @examples
+#' \dontrun{
+#' shinyOptions(myOption = 10)
+#' getShinyOption("myOption")
+#' }
+#' @export
+shinyOptions <- function(...) {
+  newOpts <- list(...)
+
+  if (length(newOpts) > 0) {
+    .globals$options <- mergeVectors(.globals$options, newOpts)
+    invisible(.globals$options)
+  } else {
+    .globals$options
+  }
+}
+
+
+# Eval an expression with a new option set
+withLocalOptions <- function(expr) {
+  oldOptionSet <- .globals$options
+  on.exit(.globals$options <- oldOptionSet)
+
+  expr
+}

R/shiny.R

@@ -96,6 +96,14 @@ NULL
 #'     an arguably more intuitive arrangement for casual R users, as the name
 #'     of a function appears next to the srcref where it is defined, rather than
 #'     where it is currently being called from.}
+#'   \item{shiny.sanitize.errors}{If \code{TRUE}, then normal errors (i.e.
+#'     errors not wrapped in \code{safeError}) won't show up in the app; a simple
+#'     generic error message is printed instead (the error and strack trace printed
+#'     to the console remain unchanged). The default is \code{FALSE} (unsanitized
+#'     errors).If you want to sanitize errors in general, but you DO want a
+#'     particular error \code{e} to get displayed to the user, then set this option
+#'     to \code{TRUE} and use \code{stop(safeError(e))} for errors you want the
+#'     user to see.}
 #' }
 #' @name shiny-options
 NULL
@@ -115,10 +123,14 @@ createUniqueId <- function(bytes, prefix = "", suffix = "") {
 toJSON <- function(x, ...,  dataframe = "columns", null = "null", na = "null",
   auto_unbox = TRUE, digits = getOption("shiny.json.digits", 16),
   use_signif = TRUE, force = TRUE, POSIXt = "ISO8601", UTC = TRUE,
-  rownames = FALSE, keep_vec_names = TRUE) {
+  rownames = FALSE, keep_vec_names = TRUE, strict_atomic = TRUE) {
+
+  if (strict_atomic) {
+    x <- I(x)
+  }
 
   # I(x) is so that length-1 atomic vectors get put in [].
-  jsonlite::toJSON(I(x), dataframe = dataframe, null = null, na = na,
+  jsonlite::toJSON(x, dataframe = dataframe, null = null, na = na,
    auto_unbox = auto_unbox, digits = digits, use_signif = use_signif,
    force = force, POSIXt = POSIXt, UTC = UTC, rownames = rownames,
    keep_vec_names = keep_vec_names, json_verbatim = TRUE, ...)
@@ -160,6 +172,18 @@ workerId <- local({
 #' example, \code{session$clientData$url_search}).
 #'
 #' @return
+#' \item{allowReconnect(value)}{
+#'   If \code{value} is \code{TRUE} and run in a hosting environment (Shiny
+#'   Server or Connect) with reconnections enabled,  then when the session ends
+#'   due to the network connection closing, the client will attempt to
+#'   reconnect to the server. If a reconnection is successful, the browser will
+#'   send all the current input values to the new session on the server, and
+#'   the server will recalculate any outputs and send them back to the client.
+#'   If \code{value} is \code{FALSE}, reconnections will be disabled (this is
+#'   the default state). If \code{"force"}, then the client browser will always
+#'   attempt to reconnect. The only reason to use \code{"force"} is for testing
+#'   on a local connection (without Shiny Server or Connect).
+#' }
 #' \item{clientData}{
 #'   A \code{\link{reactiveValues}} object that contains information about the client.
 #'   \itemize{
@@ -194,6 +218,11 @@ workerId <- local({
 #' \item{isClosed()}{A function that returns \code{TRUE} if the client has
 #'   disconnected.
 #' }
+#' \item{ns(id)}{
+#'   Server-side version of \code{ns <- \link{NS}(id)}. If bare IDs need to be
+#'   explicitly namespaced for the current module, \code{session$ns("name")}
+#'   will return the fully-qualified ID.
+#' }
 #' \item{onEnded(callback)}{
 #'   Synonym for \code{onSessionEnded}.
 #' }
@@ -241,6 +270,10 @@ workerId <- local({
 #'   This is the request that was used to initiate the websocket connection
 #'   (as opposed to the request that downloaded the web page for the app).
 #' }
+#' \item{resetBrush(brushId)}{
+#'   Resets/clears the brush with the given \code{brushId}, if it exists on
+#'   any \code{imageOutput} or \code{plotOutput} in the app.
+#' }
 #' \item{sendCustomMessage(type, message)}{
 #'   Sends a custom message to the web page. \code{type} must be a
 #'   single-element character vector giving the type of message, while
@@ -261,11 +294,6 @@ workerId <- local({
 #'   from Shiny apps, but through friendlier wrapper functions like
 #'   \code{\link{updateTextInput}}.
 #' }
-#' \item{ns(id)}{
-#'   Server-side version of \code{ns <- \link{NS}(id)}. If bare IDs need to be
-#'   explicitly namespaced for the current module, \code{session$ns("name")}
-#'   will return the fully-qualified ID.
-#' }
 #'
 #' @name session
 NULL
@@ -336,12 +364,16 @@ ShinySession <- R6Class(
                 requestMsg$method)
         return()
       }
-      private$write(toJSON(list(response=list(tag=requestMsg$tag, value=value))))
+      private$sendMessage(
+        response = list(tag = requestMsg$tag, value = value)
+      )
     },
     sendErrorResponse = function(requestMsg, error) {
       if (is.null(requestMsg$tag))
         return()
-      private$write(toJSON(list(response=list(tag=requestMsg$tag, error=error))))
+      private$sendMessage(
+        response = list(tag = requestMsg$tag, error = error)
+      )
     },
     write = function(json) {
       if (self$closed){
@@ -352,6 +384,14 @@ ShinySession <- R6Class(
            gsub('(?m)base64,[a-zA-Z0-9+/=]+','[base64 data]',json,perl=TRUE))
       private$websocket$send(json)
     },
+    sendMessage = function(...) {
+      # This function is a wrapper for $write
+      msg <- list(...)
+      if (anyUnnamed(msg)) {
+        stop("All arguments to sendMessage must be named.")
+      }
+      private$write(toJSON(msg))
+    },
     getOutputOption = function(outputName, propertyName, defaultValue) {
       opts <- private$.outputOptions[[outputName]]
       if (is.null(opts))
@@ -387,6 +427,8 @@ ShinySession <- R6Class(
     }
   ),
   public = list(
+    restoreContext = NULL,
+    bookmarkObserver = NULL,
     progressStack = 'Stack', # Stack of progress objects
     input       = 'reactivevalues', # Externally-usable S3 wrapper object for .input
     output      = 'ANY',    # Externally-usable S3 wrapper object for .outputs
@@ -444,10 +486,12 @@ ShinySession <- R6Class(
       # tries to access session$request
       delayedAssign('request', websocket$request, assign.env = self)
 
-      private$write(toJSON(list(config = list(
-        workerId = workerId(),
-        sessionId = self$token
-      ))))
+      private$sendMessage(
+        config = list(
+          workerId = workerId(),
+          sessionId = self$token
+        )
+      )
     },
     makeScope = function(namespace) {
       ns <- NS(namespace)
@@ -470,6 +514,17 @@ ShinySession <- R6Class(
     ns = function(id) {
       NS(NULL, id)
     },
+
+    # Invalidate a value until the flush cycle completes
+    invalidateValue = function(x, name) {
+      if (!is.reactivevalues(x))
+        stop("x must be a reactivevalues object")
+
+      impl <- .subset2(x, 'impl')
+      impl$invalidate(name)
+      self$onFlushed(function() impl$unInvalidate(name))
+    },
+
     onSessionEnded = function(sessionEndedCallback) {
       "Registers the given callback to be invoked when the session is closed
       (i.e. the connection to the client has been severed). The return value
@@ -516,6 +571,14 @@ ShinySession <- R6Class(
     setShowcase = function(value) {
       private$showcase <- !is.null(value) && as.logical(value)
     },
+
+    allowReconnect = function(value) {
+      if (!(identical(value, TRUE) || identical(value, FALSE) || identical(value, "force"))) {
+        stop('value must be TRUE, FALSE, or "force"')
+      }
+      private$write(toJSON(list(allowReconnect = value)))
+    },
+
     defineOutput = function(name, func, label) {
       "Binds an output generating function to this name. The function can either
       take no parameters, or have named parameters for \\code{name} and
@@ -553,35 +616,45 @@ ShinySession <- R6Class(
 
         obs <- observe(..stacktraceon = FALSE, {
 
-          self$sendCustomMessage('recalculating', list(
+          private$sendMessage(recalculating = list(
             name = name, status = 'recalculating'
           ))
 
           value <- tryCatch(
             shinyCallingHandlers(func()),
+            shiny.custom.error = function(cond) {
+              if (isTRUE(getOption("show.error.messages"))) printError(cond)
+              structure(NULL, class = "try-error", condition = cond)
+            },
+            shiny.output.cancel = function(cond) {
+              structure(NULL, class = "cancel-output")
+            },
             shiny.silent.error = function(cond) {
               # Don't let shiny.silent.error go through the normal stop
               # path of try, because we don't want it to print. But we
               # do want to try to return the same looking result so that
               # the code below can send the error to the browser.
-              structure(
-                NULL,
-                class = "try-error",
-                condition = cond
-              )
+              structure(NULL, class = "try-error", condition = cond)
             },
             error = function(cond) {
-              msg <- paste0("Error in output$", name, ": ", conditionMessage(cond), "\n")
-              if (isTRUE(getOption("show.error.messages"))) {
-                printError(cond)
+              if (isTRUE(getOption("show.error.messages"))) printError(cond)
+              if (getOption("shiny.sanitize.errors", FALSE)) {
+                cond <- simpleError(paste("An error has occurred. Check your",
+                                          "logs or contact the app author for",
+                                          "clarification."))
               }
-              invisible(structure(msg, class = "try-error", condition = cond))
+              invisible(structure(NULL, class = "try-error", condition = cond))
+            },
+            finally = {
+              private$sendMessage(recalculating = list(
+                name = name, status = 'recalculated'
+              ))
             }
           )
 
-          self$sendCustomMessage('recalculating', list(
-            name = name, status = 'recalculated'
-          ))
+          if (inherits(value, "cancel-output")) {
+            return()
+          }
 
           private$invalidatedOutputErrors$remove(name)
           private$invalidatedOutputValues$remove(name)
@@ -634,11 +707,11 @@ ShinySession <- R6Class(
       inputMessages <- private$inputMessageQueue
       private$inputMessageQueue <- list()
 
-      json <- toJSON(list(errors=as.list(errors),
-                          values=as.list(values),
-                          inputMessages=inputMessages))
-
-      private$write(json)
+      private$sendMessage(
+        errors = as.list(errors),
+        values = as.list(values),
+        inputMessages = inputMessages
+      )
     },
     showProgress = function(id) {
       'Send a message to the client that recalculation of the output identified
@@ -659,16 +732,23 @@ ShinySession <- R6Class(
       self$sendProgress('binding', list(id = id))
     },
     sendProgress = function(type, message) {
-      json <- toJSON(list(
+      private$sendMessage(
         progress = list(type = type, message = message)
-      ))
-      private$write(json)
+      )
+    },
+    sendNotification = function(type, message) {
+      private$sendMessage(
+        notification = list(type = type, message = message)
+      )
+    },
+    sendModal = function(type, message) {
+      private$sendMessage(
+        modal = list(type = type, message = message)
+      )
     },
     dispatch = function(msg) {
       method <- paste('@', msg$method, sep='')
-      # we must use $ instead of [[ here at the moment; see
-      # https://github.com/rstudio/shiny/issues/274
-      func <- try(do.call(`$`, list(self, method)), silent=TRUE)
+      func <- try(self[[method]], silent = TRUE)
       if (inherits(func, 'try-error')) {
         private$sendErrorResponse(msg, paste('Unknown method', msg$method))
       }
@@ -685,7 +765,7 @@ ShinySession <- R6Class(
     sendCustomMessage = function(type, message) {
       data <- list()
       data[[type]] <- message
-      private$write(toJSON(list(custom=data)))
+      private$sendMessage(custom = data)
     },
     sendInputMessage = function(inputId, message) {
       data <- list(id = inputId, message = message)
@@ -717,10 +797,38 @@ ShinySession <- R6Class(
     },
     reactlog = function(logEntry) {
       if (private$showcase)
-        self$sendCustomMessage("reactlog", logEntry)
+        private$sendMessage(reactlog = logEntry)
     },
     reload = function() {
-      self$sendCustomMessage("reload", TRUE)
+      private$sendMessage(reload = TRUE)
+    },
+    sendInsertUI = function(selector, multiple, where, content) {
+      private$sendMessage(
+        `shiny-insert-ui` = list(
+          selector = selector,
+          multiple = multiple,
+          where = where,
+          content = content
+        )
+      )
+    },
+    sendRemoveUI = function(selector, multiple) {
+      private$sendMessage(
+        `shiny-remove-ui` = list(
+          selector = selector,
+          multiple = multiple
+        )
+      )
+    },
+    resetBrush = function(brushId) {
+      private$sendMessage(
+        resetBrush = list(
+          brushId = brushId
+        )
+      )
+    },
+    updateLocationBar = function(url) {
+      private$sendMessage(updateLocationBar = list(url = url))
     },
 
     # Public RPC methods
@@ -748,6 +856,9 @@ ShinySession <- R6Class(
     `@uploadEnd` = function(jobId, inputId) {
       fileData <- private$fileUploadContext$getUploadOperation(jobId)$finish()
       private$.input$set(inputId, fileData)
+
+      private$.input$setMeta(inputId, "shiny.serializer", serializerFileInput)
+
       invisible()
     },
     # Provides a mechanism for handling direct HTTP requests that are posted
@@ -854,13 +965,10 @@ ShinySession <- R6Class(
         # ..stacktraceon matches with the top-level ..stacktraceoff..
         result <- try(shinyCallingHandlers(Context$new(getDefaultReactiveDomain(), '[download]')$run(
           function() { ..stacktraceon..(download$func(tmpdata)) }
-        )))
+        )), silent = TRUE)
         if (inherits(result, 'try-error')) {
-          cond <- attr(result, 'condition', exact = TRUE)
-          printError(cond)
           unlink(tmpdata)
-          return(httpResponse(500, 'text/plain; charset=UTF-8',
-                              enc2utf8(conditionMessage(cond))))
+          stop(attr(result, "condition", exact = TRUE))
         }
         return(httpResponse(
           200,
@@ -1002,14 +1110,14 @@ ShinySession <- R6Class(
     },
     incrementBusyCount = function() {
       if (private$busyCount == 0L) {
-        self$sendCustomMessage("busy", "busy")
+        private$sendMessage(busy = "busy")
       }
       private$busyCount <- private$busyCount + 1L
     },
     decrementBusyCount = function() {
       private$busyCount <- private$busyCount - 1L
       if (private$busyCount == 0L) {
-        self$sendCustomMessage("busy", "idle")
+        private$sendMessage(busy = "idle")
       }
     }
   ),

R/shinyui.R

@@ -20,7 +20,7 @@ withMathJax <- function(...) {
       singleton(tags$script(src = path, type = 'text/javascript'))
     ),
     ...,
-    tags$script(HTML('MathJax.Hub.Queue(["Typeset", MathJax.Hub]);'))
+    tags$script(HTML('if (window.MathJax) MathJax.Hub.Queue(["Typeset", MathJax.Hub]);'))
   )
 }
 
@@ -45,6 +45,7 @@ renderPage <- function(ui, connection, showcase=0) {
   shiny_deps <- list(
     htmlDependency("json2", "2014.02.04", c(href="shared"), script = "json2-min.js"),
     htmlDependency("jquery", "1.11.3", c(href="shared"), script = "jquery.min.js"),
+    htmlDependency("babel-polyfill", "6.7.2", c(href="shared"), script = "babel-polyfill.min.js"),
     htmlDependency("shiny", utils::packageVersion("shiny"), c(href="shared"),
       script = if (getOption("shiny.minified", TRUE)) "shiny.min.js" else "shiny.js",
       stylesheet = "shiny.css")
@@ -91,13 +92,15 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
         showcaseMode <- mode
     }
     uiValue <- if (is.function(ui)) {
-      if (length(formals(ui)) > 0) {
-        # No corresponding ..stacktraceoff.., this is pure user code
-        ..stacktraceon..(ui(req))
-      } else {
-        # No corresponding ..stacktraceoff.., this is pure user code
-        ..stacktraceon..(ui())
-      }
+      withRestoreContext(RestoreContext$new(req$QUERY_STRING), {
+        if (length(formals(ui)) > 0) {
+          # No corresponding ..stacktraceoff.., this is pure user code
+          ..stacktraceon..(ui(req))
+        } else {
+          # No corresponding ..stacktraceoff.., this is pure user code
+          ..stacktraceon..(ui())
+        }
+      })
     } else {
       ui
     }

R/shinywrappers.R

@@ -12,24 +12,75 @@ globalVariables('func')
 #'   an output ID.
 #' @param renderFunc A function that is suitable for assigning to a Shiny output
 #'   slot.
+#' @param outputArgs A list of arguments to pass to the \code{uiFunc}. Render
+#'   functions should include \code{outputArgs = list()} in their own parameter
+#'   list, and pass through the value to \code{markRenderFunction}, to allow
+#'   app authors to customize outputs. (Currently, this is only supported for
+#'   dynamically generated UIs, such as those created by Shiny code snippets
+#'   embedded in R Markdown documents).
 #' @return The \code{renderFunc} function, with annotations.
 #'
 #' @export
-markRenderFunction <- function(uiFunc, renderFunc) {
+markRenderFunction <- function(uiFunc, renderFunc, outputArgs = list()) {
+  # a mutable object that keeps track of whether `useRenderFunction` has been
+  # executed (this usually only happens when rendering Shiny code snippets in
+  # an interactive R Markdown document); its initial value is FALSE
+  hasExecuted <- Mutable$new()
+  hasExecuted$set(FALSE)
+
+  origRenderFunc <- renderFunc
+  renderFunc <- function(...) {
+    # if the user provided something through `outputArgs` BUT the
+    # `useRenderFunction` was not executed, then outputArgs will be ignored,
+    # so throw a warning to let user know the correct usage
+    if (length(outputArgs) != 0 && !hasExecuted$get()) {
+      warning("Unused argument: outputArgs. The argument outputArgs is only ",
+              "meant to be used when embedding snippets of Shiny code in an ",
+              "R Markdown code chunk (using runtime: shiny). When running a ",
+              "full Shiny app, please set the output arguments directly in ",
+              "the corresponding output function of your UI code.")
+      # stop warning from happening again for the same object
+      hasExecuted$set(TRUE)
+    }
+    if (is.null(formals(origRenderFunc))) origRenderFunc()
+    else origRenderFunc(...)
+  }
+
   structure(renderFunc,
-            class      = c("shiny.render.function", "function"),
-            outputFunc = uiFunc)
+            class       = c("shiny.render.function", "function"),
+            outputFunc  = uiFunc,
+            outputArgs  = outputArgs,
+            hasExecuted = hasExecuted)
 }
 
 useRenderFunction <- function(renderFunc, inline = FALSE) {
   outputFunction <- attr(renderFunc, "outputFunc")
+  outputArgs <- attr(renderFunc, "outputArgs")
+  hasExecuted <- attr(renderFunc, "hasExecuted")
+  hasExecuted$set(TRUE)
+
+  for (arg in names(outputArgs)) {
+    if (!arg %in% names(formals(outputFunction))) {
+      stop(paste0("Unused argument: in 'outputArgs', '",
+                  arg, "' is not an valid argument for ",
+                  "the output function"))
+      outputArgs[[arg]] <- NULL
+    }
+  }
+
   id <- createUniqueId(8, "out")
+  # Make the id the first positional argument
+  outputArgs <- c(list(id), outputArgs)
+
   o <- getDefaultReactiveDomain()$output
   if (!is.null(o))
     o[[id]] <- renderFunc
-  if (is.logical(formals(outputFunction)[["inline"]])) {
-    outputFunction(id, inline = inline)
-  } else outputFunction(id)
+
+  if (is.logical(formals(outputFunction)[["inline"]]) && !("inline" %in% names(outputArgs))) {
+    outputArgs[["inline"]] <- inline
+  }
+
+  do.call(outputFunction, outputArgs)
 }
 
 #' @export
@@ -69,13 +120,23 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
 #'   it is sent to the client browser? Generally speaking, if the image is a
 #'   temp file generated within \code{func}, then this should be \code{TRUE};
 #'   if the image is not a temp file, this should be \code{FALSE}.
-#'
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{imageOutput}} when \code{renderImage} is used in an
+#'   interactive R Markdown document.
 #' @export
 #'
 #' @examples
-#' \dontrun{
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
-#' shinyServer(function(input, output, clientData) {
+#' ui <- fluidPage(
+#'   sliderInput("n", "Number of observations", 2, 1000, 500),
+#'   plotOutput("plot1"),
+#'   plotOutput("plot2"),
+#'   plotOutput("plot3")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'
 #'   # A plot of fixed size
 #'   output$plot1 <- renderImage({
@@ -97,14 +158,14 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
 #'   output$plot2 <- renderImage({
 #'     # Read plot2's width and height. These are reactive values, so this
 #'     # expression will re-run whenever these values change.
-#'     width  <- clientData$output_plot2_width
-#'     height <- clientData$output_plot2_height
+#'     width  <- session$clientData$output_plot2_width
+#'     height <- session$clientData$output_plot2_height
 #'
 #'     # A temp file to save the output.
 #'     outfile <- tempfile(fileext='.png')
 #'
 #'     png(outfile, width=width, height=height)
-#'     hist(rnorm(input$obs))
+#'     hist(rnorm(input$n))
 #'     dev.off()
 #'
 #'     # Return a list containing the filename
@@ -115,6 +176,8 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
 #'   }, deleteFile = TRUE)
 #'
 #'   # Send a pre-rendered image, and don't delete the image after sending it
+#'   # NOTE: For this example to work, it would require files in a subdirectory
+#'   # named images/
 #'   output$plot3 <- renderImage({
 #'     # When input$n is 1, filename is ./images/image1.jpeg
 #'     filename <- normalizePath(file.path('./images',
@@ -123,14 +186,15 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
 #'     # Return a list containing the filename
 #'     list(src = filename)
 #'   }, deleteFile = FALSE)
-#' })
+#' }
 #'
+#' shinyApp(ui, server)
 #' }
 renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
-                        deleteFile=TRUE) {
+                        deleteFile=TRUE, outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  return(markRenderFunction(imageOutput, function(shinysession, name, ...) {
+  renderFunc <- function(shinysession, name, ...) {
     imageinfo <- func()
     # Should the file be deleted after being sent? If .deleteFile not set or if
     # TRUE, then delete; otherwise don't delete.
@@ -147,7 +211,9 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
     # Return a list with src, and other img attributes
     c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType),
       extra_attr)
-  }))
+  }
+
+  markRenderFunction(imageOutput, renderFunc, outputArgs = outputArgs)
 }
 
 
@@ -173,28 +239,28 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
 #'   object.
 #' @param env The environment in which to evaluate \code{expr}.
 #' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
-#' @param func A function that may print output and/or return a printable R
-#'   object (deprecated; use \code{expr} instead).
+#'   is useful if you want to save an expression in a variable.
 #' @param width The value for \code{\link{options}('width')}.
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{verbatimTextOutput}} when \code{renderPrint} is used
+#'   in an interactive R Markdown document.
 #' @seealso \code{\link{renderText}} for displaying the value returned from a
 #'   function, instead of the printed output.
 #'
 #' @example res/text-example.R
 #'
 #' @export
-renderPrint <- function(expr, env = parent.frame(), quoted = FALSE, func = NULL,
-                        width = getOption('width')) {
-  if (!is.null(func)) {
-    shinyDeprecated(msg="renderPrint: argument 'func' is deprecated. Please use 'expr' instead.")
-  } else {
-    installExprFunction(expr, "func", env, quoted)
-  }
+renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
+                        width = getOption('width'), outputArgs=list()) {
+  installExprFunction(expr, "func", env, quoted)
 
-  markRenderFunction(verbatimTextOutput, function() {
+  renderFunc <- function(shinysession, name, ...) {
     op <- options(width = width)
     on.exit(options(op), add = TRUE)
     paste(utils::capture.output(func()), collapse = "\n")
-  })
+  }
+
+  markRenderFunction(verbatimTextOutput, renderFunc, outputArgs = outputArgs)
 }
 
 #' Text Output
@@ -215,8 +281,9 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE, func = NULL,
 #' @param env The environment in which to evaluate \code{expr}.
 #' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
 #'   is useful if you want to save an expression in a variable.
-#' @param func A function that returns an R object that can be used as an
-#'   argument to \code{cat}.(deprecated; use \code{expr} instead).
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{textOutput}} when \code{renderText} is used in an
+#'   interactive R Markdown document.
 #'
 #' @seealso \code{\link{renderPrint}} for capturing the print output of a
 #'   function, rather than the returned text value.
@@ -224,17 +291,16 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE, func = NULL,
 #' @example res/text-example.R
 #'
 #' @export
-renderText <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
-  if (!is.null(func)) {
-    shinyDeprecated(msg="renderText: argument 'func' is deprecated. Please use 'expr' instead.")
-  } else {
-    installExprFunction(expr, "func", env, quoted)
-  }
+renderText <- function(expr, env=parent.frame(), quoted=FALSE,
+                       outputArgs=list()) {
+  installExprFunction(expr, "func", env, quoted)
 
-  markRenderFunction(textOutput, function() {
+  renderFunc <- function(shinysession, name, ...) {
     value <- func()
     return(paste(utils::capture.output(cat(value)), collapse="\n"))
-  })
+  }
+
+  markRenderFunction(textOutput, renderFunc, outputArgs = outputArgs)
 }
 
 #' UI Output
@@ -250,46 +316,45 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
 #' @param env The environment in which to evaluate \code{expr}.
 #' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
 #'   is useful if you want to save an expression in a variable.
-#' @param func A function that returns a Shiny tag object, \code{\link{HTML}},
-#'   or a list of such objects (deprecated; use \code{expr} instead).
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{uiOutput}} when \code{renderUI} is used in an
+#'   interactive R Markdown document.
 #'
 #' @seealso conditionalPanel
 #'
 #' @export
 #' @examples
-#' \dontrun{
-#'   output$moreControls <- renderUI({
-#'     list(
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   uiOutput("moreControls")
+#' )
+#'
+#' server <- function(input, output) {
+#'   output$moreControls <- renderUI({
+#'     tagList(
+#'       sliderInput("n", "N", 1, 1000, 500),
+#'       textInput("label", "Label")
 #'     )
 #'   })
 #' }
-renderUI <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
-  if (!is.null(func)) {
-    shinyDeprecated(msg="renderUI: argument 'func' is deprecated. Please use 'expr' instead.")
-  } else {
-    installExprFunction(expr, "func", env, quoted)
-  }
+#' shinyApp(ui, server)
+#' }
+#'
+renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
+                     outputArgs=list()) {
+  installExprFunction(expr, "func", env, quoted)
 
-  markRenderFunction(uiOutput, function(shinysession, name, ...) {
+  renderFunc <- function(shinysession, name, ...) {
     result <- func()
     if (is.null(result) || length(result) == 0)
       return(NULL)
 
-    result <- takeSingletons(result, shinysession$singletons, desingleton=FALSE)$ui
-    result <- surroundSingletons(result)
-    dependencies <- lapply(resolveDependencies(findDependencies(result)),
-      createWebDependency)
-    names(dependencies) <- NULL
+    processDeps(result, shinysession)
+  }
 
-    # renderTags returns a list with head, singletons, and html
-    output <- list(
-      html = doRenderTags(result),
-      deps = dependencies
-    )
-
-    return(output)
-  })
+  markRenderFunction(uiOutput, renderFunc, outputArgs = outputArgs)
 }
 
 #' File Downloads
@@ -315,28 +380,40 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
 #'   example \code{"text/csv"} or \code{"image/png"}. If \code{NULL} or
 #'   \code{NA}, the content type will be guessed based on the filename
 #'   extension, or \code{application/octet-stream} if the extension is unknown.
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{downloadButton}} when \code{downloadHandler} is used
+#'   in an interactive R Markdown document.
 #'
 #' @examples
-#' \dontrun{
-#' # In server.R:
-#' output$downloadData <- downloadHandler(
-#'   filename = function() {
-#'     paste('data-', Sys.Date(), '.csv', sep='')
-#'   },
-#'   content = function(file) {
-#'     write.csv(data, file)
-#'   }
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   downloadLink("downloadData", "Download")
 #' )
 #'
-#' # In ui.R:
-#' downloadLink('downloadData', 'Download')
+#' server <- function(input, output) {
+#'   # Our dataset
+#'   data <- mtcars
+#'
+#'   output$downloadData <- downloadHandler(
+#'     filename = function() {
+#'       paste("data-", Sys.Date(), ".csv", sep="")
+#'     },
+#'     content = function(file) {
+#'       write.csv(data, file)
+#'     }
+#'   )
 #' }
 #'
+#' shinyApp(ui, server)
+#' }
 #' @export
-downloadHandler <- function(filename, content, contentType=NA) {
-  return(markRenderFunction(downloadButton, function(shinysession, name, ...) {
+downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()) {
+  renderFunc <- function(shinysession, name, ...) {
     shinysession$registerDownload(name, filename, contentType, content)
-  }))
+  }
+  markRenderFunction(downloadButton, renderFunc, outputArgs = outputArgs)
 }
 
 #' Table output with the JavaScript library DataTables
@@ -367,6 +444,10 @@ downloadHandler <- function(filename, content, contentType=NA) {
 #'   indicate which columns to escape, e.g. \code{1:5} (the first 5 columns),
 #'   \code{c(1, 3, 4)}, or \code{c(-1, -3)} (all columns except the first and
 #'   third), or \code{c('Species', 'Sepal.Length')}.
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{dataTableOutput}} when \code{renderDataTable} is used
+#'   in an interactive R Markdown document.
+#'
 #' @references \url{http://datatables.net}
 #' @note This function only provides the server-side version of DataTables
 #'   (using R to process the data object on the server side). There is a
@@ -401,10 +482,11 @@ downloadHandler <- function(filename, content, contentType=NA) {
 #' }
 renderDataTable <- function(expr, options = NULL, searchDelay = 500,
                             callback = 'function(oTable) {}', escape = TRUE,
-                            env = parent.frame(), quoted = FALSE) {
+                            env = parent.frame(), quoted = FALSE,
+                            outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  markRenderFunction(dataTableOutput, function(shinysession, name, ...) {
+  renderFunc <- function(shinysession, name, ...) {
     if (is.function(options)) options <- options()
     options <- checkDT9(options)
     res <- checkAsIs(options)
@@ -430,7 +512,9 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
       evalOptions = if (length(res$eval)) I(res$eval), searchDelay = searchDelay,
       callback = paste(callback, collapse = '\n'), escape = escape
     )
-  })
+  }
+
+  markRenderFunction(dataTableOutput, renderFunc, outputArgs = outputArgs)
 }
 
 # a data frame containing the DataTables 1.9 and 1.10 names

R/showcase.R

@@ -77,10 +77,60 @@ appMetadata <- function(desc) {
   else ""
 }
 
+navTabsHelper <- function(files, prefix = "") {
+  lapply(files, function(file) {
+    with(tags,
+      li(class=if (tolower(file) %in% c("app.r", "server.r")) "active" else "",
+         a(href=paste("#", gsub(".", "_", file, fixed=TRUE), "_code", sep=""),
+           "data-toggle"="tab", paste0(prefix, file)))
+    )
+  })
+}
+
+navTabsDropdown <- function(files) {
+  if (length(files) > 0) {
+    with(tags,
+      li(role="presentation", class="dropdown",
+        a(class="dropdown-toggle", `data-toggle`="dropdown", href="#",
+          role="button", `aria-haspopup`="true", `aria-expanded`="false",
+          "www", span(class="caret")
+        ),
+        ul(class="dropdown-menu", navTabsHelper(files))
+      )
+    )
+  }
+}
+
+tabContentHelper <- function(files, path, language) {
+  lapply(files, function(file) {
+    with(tags,
+      div(class=paste("tab-pane",
+                      if (tolower(file) %in% c("app.r", "server.r")) " active"
+                      else "",
+                      sep=""),
+          id=paste(gsub(".", "_", file, fixed=TRUE),
+                   "_code", sep=""),
+          pre(class="shiny-code",
+              # we need to prevent the indentation of <code> ... </code>
+              HTML(format(tags$code(
+                class=paste0("language-", language),
+                paste(readUTF8(file.path.ci(path, file)), collapse="\n")
+              ), indent = FALSE))))
+    )
+  })
+}
+
 # Returns tags containing the application's code in Bootstrap-style tabs in
 # showcase mode.
 showcaseCodeTabs <- function(codeLicense) {
   rFiles <- list.files(pattern = "\\.[rR]$")
+  wwwFiles <- list()
+  if (isTRUE(.globals$IncludeWWW)) {
+    path <- file.path(getwd(), "www")
+    wwwFiles$jsFiles <- list.files(path, pattern = "\\.js$")
+    wwwFiles$cssFiles <- list.files(path, pattern = "\\.css$")
+    wwwFiles$htmlFiles <- list.files(path, pattern = "\\.html$")
+  }
   with(tags, div(id="showcase-code-tabs",
     a(id="showcase-code-position-toggle",
       class="btn btn-default btn-sm",
@@ -88,27 +138,21 @@ showcaseCodeTabs <- function(codeLicense) {
       icon("level-up"),
       "show with app"),
     ul(class="nav nav-tabs",
-       lapply(rFiles, function(rFile) {
-         li(class=if (tolower(rFile) %in% c("app.r", "server.r")) "active" else "",
-            a(href=paste("#", gsub(".", "_", rFile, fixed=TRUE),
-                         "_code", sep=""),
-              "data-toggle"="tab", rFile))
-       })),
+       navTabsHelper(rFiles),
+       navTabsDropdown(unlist(wwwFiles))
+    ),
     div(class="tab-content", id="showcase-code-content",
-        lapply(rFiles, function(rFile) {
-          div(class=paste("tab-pane",
-                          if (tolower(rFile) %in% c("app.r", "server.r")) " active"
-                          else "",
-                          sep=""),
-              id=paste(gsub(".", "_", rFile, fixed=TRUE),
-                       "_code", sep=""),
-              pre(class="shiny-code",
-                  # we need to prevent the indentation of <code> ... </code>
-                  HTML(format(tags$code(
-                    class="language-r",
-                    paste(readUTF8(file.path.ci(getwd(), rFile)), collapse="\n")
-                  ), indent = FALSE))))
-        })),
+        tabContentHelper(rFiles, path = getwd(), language = "r"),
+        tabContentHelper(wwwFiles$jsFiles,
+                         path = paste0(getwd(), "/www"),
+                         language = "javascript"),
+        tabContentHelper(wwwFiles$cssFiles,
+                         path = paste0(getwd(), "/www"),
+                         language = "css"),
+        tabContentHelper(wwwFiles$htmlFiles,
+                         path = paste0(getwd(), "/www"),
+                         language = "xml")
+    ),
     codeLicense))
 }
 
@@ -177,3 +221,4 @@ showcaseUI <- function(ui) {
     showcaseBody(ui)
   )
 }
+

R/update-input.R

@@ -6,9 +6,16 @@
 #' @seealso \code{\link{textInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 0, 20, 10),
+#'   textInput("inText", "Input text"),
+#'   textInput("inText2", "Input text 2")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
 #'     # We'll use the input$controller variable multiple times, so save it as x
 #'     # for convenience.
@@ -22,7 +29,9 @@
 #'       label = paste("New label", x),
 #'       value = paste("New text", x))
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
@@ -39,21 +48,82 @@ updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
 #' @seealso \code{\link{checkboxInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 0, 1, 0, step = 1),
+#'   checkboxInput("inCheckbox", "Input checkbox")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # TRUE if input$controller is even, FALSE otherwise.
-#'     x_even <- input$controller %% 2 == 0
+#'     # TRUE if input$controller is odd, FALSE if even.
+#'     x_even <- input$controller %% 2 == 1
 #'
 #'     updateCheckboxInput(session, "inCheckbox", value = x_even)
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateCheckboxInput <- updateTextInput
 
 
+#' Change the label or icon of an action button on the client
+#'
+#' @template update-input
+#' @param icon The icon to set for the input object. To remove the
+#' current icon, use \code{icon=character(0)}.
+#'
+#' @seealso \code{\link{actionButton}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   actionButton("update", "Update other buttons"),
+#'   br(),
+#'   actionButton("goButton", "Go"),
+#'   br(),
+#'   actionButton("goButton2", "Go 2", icon = icon("area-chart")),
+#'   br(),
+#'   actionButton("goButton3", "Go 3")
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   observe({
+#'     req(input$update)
+#'
+#'     # Updates goButton's label and icon
+#'     updateActionButton(session, "goButton",
+#'       label = "New label",
+#'       icon = icon("calendar"))
+#'
+#'     # Leaves goButton2's label unchaged and
+#'     # removes its icon
+#'     updateActionButton(session, "goButton2",
+#'       icon = character(0))
+#'
+#'     # Leaves goButton3's icon, if it exists,
+#'     # unchaged and changes its label
+#'     updateActionButton(session, "goButton3",
+#'       label = "New label 3")
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#' @export
+updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
+  if (!is.null(icon)) icon <- as.character(validateIcon(icon))
+  message <- dropNulls(list(label=label, icon=icon))
+  session$sendInputMessage(inputId, message)
+}
+
+
 #' Change the value of a date input on the client
 #'
 #' @template update-input
@@ -67,9 +137,15 @@ updateCheckboxInput <- updateTextInput
 #' @seealso \code{\link{dateInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 1, 30, 10),
+#'   dateInput("inDate", "Input date")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
 #'     # We'll use the input$controller variable multiple times, so save it as x
 #'     # for convenience.
@@ -82,7 +158,9 @@ updateCheckboxInput <- updateTextInput
 #'       max   = paste("2013-04-", x+1, sep="")
 #'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateDateInput <- function(session, inputId, label = NULL, value = NULL,
@@ -114,9 +192,15 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 #' @seealso \code{\link{dateRangeInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 1, 30, 10),
+#'   dateRangeInput("inDateRange", "Input date range")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
 #'     # We'll use the input$controller variable multiple times, so save it as x
 #'     # for convenience.
@@ -124,10 +208,13 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 #'
 #'     updateDateRangeInput(session, "inDateRange",
 #'       label = paste("Date range label", x),
-#'       start = paste("2013-01-", x, sep=""))
-#'       end = paste("2013-12-", x, sep=""))
+#'       start = paste("2013-01-", x, sep=""),
+#'       end = paste("2013-12-", x, sep="")
+#'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateDateRangeInput <- function(session, inputId, label = NULL,
@@ -162,22 +249,31 @@ updateDateRangeInput <- function(session, inputId, label = NULL,
 #' \code{\link{navbarPage}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
-#'   observe({
-#'     # TRUE if input$controller is even, FALSE otherwise.
-#'     x_even <- input$controller %% 2 == 0
+#' ui <- fluidPage(sidebarLayout(
+#'   sidebarPanel(
+#'     sliderInput("controller", "Controller", 1, 3, 1)
+#'   ),
+#'   mainPanel(
+#'     tabsetPanel(id = "inTabset",
+#'       tabPanel(title = "Panel 1", value = "panel1", "Panel 1 content"),
+#'       tabPanel(title = "Panel 2", value = "panel2", "Panel 2 content"),
+#'       tabPanel(title = "Panel 3", value = "panel3", "Panel 3 content")
+#'     )
+#'   )
+#' ))
 #'
-#'     # Change the selected tab.
-#'     # Note that the tabset container must have been created with an 'id' argument
-#'     if (x_even) {
-#'       updateTabsetPanel(session, "inTabset", selected = "panel2")
-#'     } else {
-#'       updateTabsetPanel(session, "inTabset", selected = "panel1")
-#'     }
+#' server <- function(input, output, session) {
+#'   observeEvent(input$controller, {
+#'     updateTabsetPanel(session, "inTabset",
+#'       selected = paste0("panel", input$controller)
+#'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateTabsetPanel <- function(session, inputId, selected = NULL) {
@@ -204,10 +300,18 @@ updateNavlistPanel <- updateTabsetPanel
 #' @seealso \code{\link{numericInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
-#'   observe({
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 0, 20, 10),
+#'   numericInput("inNumber", "Input number", 0),
+#'   numericInput("inNumber2", "Input number 2", 0)
+#' )
+#'
+#' server <- function(input, output, session) {
+#'
+#'   observeEvent(input$controller, {
 #'     # We'll use the input$controller variable multiple times, so save it as x
 #'     # for convenience.
 #'     x <- input$controller
@@ -218,7 +322,9 @@ updateNavlistPanel <- updateTabsetPanel
 #'       label = paste("Number label ", x),
 #'       value = x, min = x-10, max = x+10, step = 5)
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
@@ -330,31 +436,35 @@ updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
 #' @seealso \code{\link{checkboxGroupInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   p("The first checkbox group controls the second"),
+#'   checkboxGroupInput("inCheckboxGroup", "Input checkbox",
+#'     c("Item A", "Item B", "Item C")),
+#'   checkboxGroupInput("inCheckboxGroup2", "Input checkbox 2",
+#'     c("Item A", "Item B", "Item C"))
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # We'll use the input$controller variable multiple times, so save it as x
-#'     # for convenience.
-#'     x <- input$controller
+#'     x <- input$inCheckboxGroup
 #'
-#'     # Create a list of new options, where the name of the items is something
-#'     # like 'option label x 1', and the values are 'option-x-1'.
-#'     cb_options <- list()
-#'     cb_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
-#'     cb_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
-#'
-#'     # Change values for input$inCheckboxGroup
-#'     updateCheckboxGroupInput(session, "inCheckboxGroup", choices = cb_options)
+#'     # Can use character(0) to remove all choices
+#'     if (is.null(x))
+#'       x <- character(0)
 #'
 #'     # Can also set the label and select items
 #'     updateCheckboxGroupInput(session, "inCheckboxGroup2",
-#'       label = paste("checkboxgroup label", x),
-#'       choices = cb_options,
-#'       selected = sprintf("option-%d-2", x)
+#'       label = paste("Checkboxgroup label", length(x)),
+#'       choices = x,
+#'       selected = x
 #'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateCheckboxGroupInput <- function(session, inputId, label = NULL,
@@ -372,29 +482,31 @@ updateCheckboxGroupInput <- function(session, inputId, label = NULL,
 #' @seealso \code{\link{radioButtons}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   p("The first radio button group controls the second"),
+#'   radioButtons("inRadioButtons", "Input radio buttons",
+#'     c("Item A", "Item B", "Item C")),
+#'   radioButtons("inRadioButtons2", "Input radio buttons 2",
+#'     c("Item A", "Item B", "Item C"))
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # We'll use the input$controller variable multiple times, so save it as x
-#'     # for convenience.
-#'     x <- input$controller
+#'     x <- input$inRadioButtons
 #'
-#'     r_options <- list()
-#'     r_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
-#'     r_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
-#'
-#'     # Change values for input$inRadio
-#'     updateRadioButtons(session, "inRadio", choices = r_options)
-#'
-#'     # Can also set the label and select an item
-#'     updateRadioButtons(session, "inRadio2",
-#'       label = paste("Radio label", x),
-#'       choices = r_options,
-#'       selected = sprintf("option-%d-2", x)
+#'     # Can also set the label and select items
+#'     updateRadioButtons(session, "inRadioButtons2",
+#'       label = paste("radioButtons label", x),
+#'       choices = x,
+#'       selected = x
 #'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
@@ -413,32 +525,35 @@ updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
 #' @seealso \code{\link{selectInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   p("The checkbox group controls the select input"),
+#'   checkboxGroupInput("inCheckboxGroup", "Input checkbox",
+#'     c("Item A", "Item B", "Item C")),
+#'   selectInput("inSelect", "Select input",
+#'     c("Item A", "Item B", "Item C"))
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # We'll use the input$controller variable multiple times, so save it as x
-#'     # for convenience.
-#'     x <- input$controller
+#'     x <- input$inCheckboxGroup
 #'
-#'     # Create a list of new options, where the name of the items is something
-#'     # like 'option label x 1', and the values are 'option-x-1'.
-#'     s_options <- list()
-#'     s_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
-#'     s_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
+#'     # Can use character(0) to remove all choices
+#'     if (is.null(x))
+#'       x <- character(0)
 #'
-#'     # Change values for input$inSelect
-#'     updateSelectInput(session, "inSelect", choices = s_options)
-#'
-#'     # Can also set the label and select an item (or more than one if it's a
-#'     # multi-select)
-#'     updateSelectInput(session, "inSelect2",
-#'       label = paste("Select label", x),
-#'       choices = s_options,
-#'       selected = sprintf("option-%d-2", x)
+#'     # Can also set the label and select items
+#'     updateSelectInput(session, "inSelect",
+#'       label = paste("Select input label", length(x)),
+#'       choices = x,
+#'       selected = tail(x, 1)
 #'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateSelectInput <- function(session, inputId, label = NULL, choices = NULL,

R/utils.R

@@ -155,6 +155,20 @@ dropNullsOrEmpty <- function(x) {
   x[!vapply(x, nullOrEmpty, FUN.VALUE=logical(1))]
 }
 
+# Given a vector/list, return TRUE if any elements are named, FALSE otherwise.
+anyNamed <- function(x) {
+  # Zero-length vector
+  if (length(x) == 0) return(FALSE)
+
+  nms <- names(x)
+
+  # List with no name attribute
+  if (is.null(nms)) return(FALSE)
+
+  # List with name attribute; check for any ""
+  any(nzchar(nms))
+}
+
 # Given a vector/list, return TRUE if any elements are unnamed, FALSE otherwise.
 anyUnnamed <- function(x) {
   # Zero-length vector
@@ -169,6 +183,21 @@ anyUnnamed <- function(x) {
   any(!nzchar(nms))
 }
 
+# Given two named vectors, join them together, and keep only the last element
+# with a given name in the resulting vector. If b has any elements with the same
+# name as elements in a, the element in a is dropped. Also, if there are any
+# duplicated names in a or b, only the last one with that name is kept.
+mergeVectors <- function(a, b) {
+  if (anyUnnamed(a) || anyUnnamed(b)) {
+    stop("Vectors must be either NULL or have names for all elements")
+  }
+
+  x <- c(a, b)
+  drop_idx <- duplicated(names(x), fromLast = TRUE)
+  x[!drop_idx]
+}
+
+
 # Combine dir and (file)name into a file path. If a file already exists with a
 # name differing only by case, then use it instead.
 file.path.ci <- function(...) {
@@ -211,6 +240,12 @@ find.file.ci <- function(...) {
   return(matches[1])
 }
 
+# The function base::dir.exists was added in R 3.2.0, but for backward
+# compatibility we need to add this function
+dirExists <- function(paths) {
+  file.exists(paths) & file.info(paths)$isdir
+}
+
 # Attempt to join a path and relative path, and turn the result into a
 # (normalized) absolute path. The result will only be returned if it is an
 # existing file/directory and is a descendant of dir.
@@ -454,7 +489,7 @@ installExprFunction <- function(expr, name, eval.env = parent.frame(2),
 #'
 #' \dontrun{
 #' # Example of usage within a Shiny app
-#' shinyServer(function(input, output, session) {
+#' function(input, output, session) {
 #'
 #'   output$queryText <- renderText({
 #'     query <- parseQueryString(session$clientData$url_search)
@@ -470,7 +505,7 @@ installExprFunction <- function(expr, name, eval.env = parent.frame(2),
 #'     # Return a string with key-value pairs
 #'     paste(names(query), query, sep = "=", collapse=", ")
 #'   })
-#' })
+#' }
 #' }
 #'
 parseQueryString <- function(str, nested = FALSE) {
@@ -482,6 +517,8 @@ parseQueryString <- function(str, nested = FALSE) {
     str <- substr(str, 2, nchar(str))
 
   pairs <- strsplit(str, '&', fixed = TRUE)[[1]]
+  # Drop any empty items (if there's leading/trailing/consecutive '&' chars)
+  pairs <- pairs[pairs != ""]
   pairs <- strsplit(pairs, '=', fixed = TRUE)
 
   keys   <- vapply(pairs, function(x) x[1], FUN.VALUE = character(1))
@@ -597,7 +634,10 @@ Callbacks <- R6Class(
     .callbacks = 'Map',
 
     initialize = function() {
-      .nextId <<- as.integer(.Machine$integer.max)
+      # NOTE: we avoid using '.Machine$integer.max' directly
+      # as R 3.3.0's 'radixsort' could segfault when sorting
+      # an integer vector containing this value
+      .nextId <<- as.integer(.Machine$integer.max - 1L)
       .callbacks <<- Map$new()
     },
     register = function(callback) {
@@ -647,6 +687,21 @@ dataTablesJSON <- function(data, req) {
   q <- parseQueryString(params, nested = TRUE)
   ci <- q$search[['caseInsensitive']] == 'true'
 
+  # data may have been replaced/updated in the new table while the Ajax request
+  # from the previous table is still on its way, so it is possible that the old
+  # request asks for more columns than the current data, in which case we should
+  # discard this request and return empty data; the next Ajax request from the
+  # new table will retrieve the correct number of columns of data
+  if (length(q$columns) != ncol(data)) {
+    res <- toJSON(list(
+      draw = as.integer(q$draw),
+      recordsTotal = n,
+      recordsFiltered = 0,
+      data = NULL
+    ))
+    return(httpResponse(200, 'application/json', enc2utf8(res)))
+  }
+
   # global searching
   i <- seq_len(n)
   if (length(q$search[['value']]) && q$search[['value']] != '') {
@@ -847,6 +902,87 @@ columnToRowData <- function(data) {
   )
 }
 
+#' Declare an error safe for the user to see
+#'
+#' This should be used when you want to let the user see an error
+#' message even if the default is to sanitize all errors. If you have an
+#' error \code{e} and call \code{stop(safeError(e))}, then Shiny will
+#' ignore the value of \code{getOption("shiny.sanitize.errors")} and always
+#' display the error in the app itself.
+#'
+#' @param error Either an "error" object or a "character" object (string).
+#' In the latter case, the string will become the message of the error
+#' returned by \code{safeError}.
+#'
+#' @return An "error" object
+#'
+#' @details An error generated by \code{safeError} has priority over all
+#' other Shiny errors. This can be dangerous. For example, if you have set
+#' \code{options(shiny.sanitize.errors = TRUE)}, then by default all error
+#' messages are omitted in the app, and replaced by a generic error message.
+#' However, this does not apply to \code{safeError}: whatever you pass
+#' through \code{error} will be displayed to the user. So, this should only
+#' be used when you are sure that your error message does not contain any
+#' sensitive information. In those situations, \code{safeError} can make
+#' your users' lives much easier by giving them a hint as to where the
+#' error occurred.
+#'
+#' @seealso \code{\link{shiny-options}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' # uncomment the desired line to experiment with shiny.sanitize.errors
+#' # options(shiny.sanitize.errors = TRUE)
+#' # options(shiny.sanitize.errors = FALSE)
+#'
+#' # Define UI
+#' ui <- fluidPage(
+#'   textInput('number', 'Enter your favorite number from 1 to 10', '5'),
+#'   textOutput('normalError'),
+#'   textOutput('safeError')
+#' )
+#'
+#' # Server logic
+#' server <- function(input, output) {
+#'   output$normalError <- renderText({
+#'     number <- input$number
+#'     if (number %in% 1:10) {
+#'       return(paste('You chose', number, '!'))
+#'     } else {
+#'       stop(
+#'         paste(number, 'is not a number between 1 and 10')
+#'       )
+#'     }
+#'   })
+#'   output$safeError <- renderText({
+#'     number <- input$number
+#'     if (number %in% 1:10) {
+#'       return(paste('You chose', number, '!'))
+#'     } else {
+#'       stop(safeError(
+#'         paste(number, 'is not a number between 1 and 10')
+#'       ))
+#'     }
+#'   })
+#' }
+#'
+#' # Complete app with UI and server components
+#' shinyApp(ui, server)
+#' }
+#' @export
+safeError <- function(error) {
+  if (inherits(error, "character")) {
+    error <- simpleError(error)
+  }
+  if (!inherits(error, "error")) {
+    stop("The class of the `error` parameter must be either 'error' or 'character'")
+  }
+  class(error) <- c("shiny.custom.error", class(error))
+  error
+}
+
 #' Validate input values and other conditions
 #'
 #' For an output rendering function (e.g. \code{\link{renderPlot}()}), you may
@@ -940,8 +1076,8 @@ validate <- function(..., errorClass = character(0)) {
   # There may be empty strings remaining; these are message-less failures that
   # started as FALSE
   results <- results[nzchar(results)]
-
-  stopWithCondition(c("validation", errorClass), paste(results, collapse="\n"))
+  stopWithCondition(c("validation", "shiny.silent.error", errorClass),
+                    paste(results, collapse="\n"))
 }
 
 #' @param expr An expression to test. The condition will pass if the expression
@@ -1036,13 +1172,21 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #' \code{req(input$a != 0)}
 #'
 #' @param ... Values to check for truthiness.
+#' @param cancelOutput If \code{TRUE} and an output is being evaluated, stop
+#'   processing as usual but instead of clearing the output, leave it in
+#'   whatever state it happens to be in.
 #' @return The first value that was passed in.
 #'
 #' @export
-req <- function(...) {
+req <- function(..., cancelOutput = FALSE) {
   dotloop(function(item) {
-    if (!isTruthy(item))
-      stopWithCondition("validation", "")
+    if (!isTruthy(item)) {
+      if (isTRUE(cancelOutput)) {
+        cancelOutput()
+      } else {
+        stopWithCondition(c("validation", "shiny.silent.error"), "")
+      }
+    }
   }, ...)
 
   if (!missing(..1))
@@ -1051,6 +1195,22 @@ req <- function(...) {
     invisible()
 }
 
+#' Cancel processing of the current output
+#'
+#' Signals an error that Shiny treats specially if an output is currently being
+#' evaluated. Execution will stop, but rather than clearing the output (as
+#' \code{\link{req}} does) or showing an error message (as \code{\link{stop}}
+#' does), the output simply remains unchanged.
+#'
+#' If \code{cancelOutput} is called in any non-output context (like in an
+#' \code{\link{observe}} or \code{\link{observeEvent}}), the effect is the same
+#' as \code{\link{req}(FALSE)}.
+#'
+#' @export
+cancelOutput <- function() {
+  stopWithCondition(c("shiny.output.cancel", "shiny.silent.error"), "")
+}
+
 # Execute a function against each element of ..., but only evaluate each element
 # after the previous element has been passed to fun_. The return value of fun_
 # is discarded, and only invisible() is returned from dotloop.
@@ -1091,7 +1251,7 @@ isTruthy <- function(x) {
 stopWithCondition <- function(class, message) {
   cond <- structure(
     list(message = message),
-    class = c(class, 'shiny.silent.error', 'error', 'condition')
+    class = c(class, 'error', 'condition')
   )
   stop(cond)
 }
@@ -1142,6 +1302,10 @@ checkEncoding <- function(file) {
             'http://shiny.rstudio.com/articles/unicode.html for more info.')
     return('UTF-8-BOM')
   }
+  x <- readChar(file, size, useBytes = TRUE)
+  if (is.na(iconv(x, 'UTF-8', 'UTF-8'))) {
+    warning('The input file ', file, ' does not seem to be encoded in UTF8')
+  }
   'UTF-8'
 }
 
@@ -1174,7 +1338,11 @@ sourceUTF8 <- function(file, envir = globalenv()) {
     file <- tempfile(); on.exit(unlink(file), add = TRUE)
     writeLines(lines, file)
   }
-  exprs <- parse(file, keep.source = FALSE, srcfile = src, encoding = enc)
+  exprs <- try(parse(file, keep.source = FALSE, srcfile = src, encoding = enc))
+  if (inherits(exprs, "try-error")) {
+    diagnoseCode(file)
+    stop("Error sourcing ", file)
+  }
 
   # Wrap the exprs in first `{`, then ..stacktraceon..(). It's only really the
   # ..stacktraceon..() that we care about, but the `{` is needed to make that
@@ -1238,3 +1406,17 @@ wrapFunctionLabel <- function(func, name, ..stacktraceon = FALSE) {
 
   relabelWrapper
 }
+
+
+# This is a very simple mutable object which only stores one value
+# (which we can set and get). Using this class is sometimes useful
+# when communicating persistent changes across functions.
+Mutable <- R6Class("Mutable",
+  private = list(
+    value = NULL
+  ),
+  public = list(
+    set = function(value) { private$value <- value },
+    get = function() { private$value }
+  )
+)

inst/examples/01_hello/server.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define server logic required to draw a histogram
-shinyServer(function(input, output) {
+function(input, output) {
 
   # Expression that generates a histogram. The expression is
   # wrapped in a call to renderPlot to indicate that:
@@ -18,4 +18,4 @@ shinyServer(function(input, output) {
     hist(x, breaks = bins, col = 'darkgray', border = 'white')
   })
 
-})
+}

inst/examples/01_hello/ui.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define UI for application that draws a histogram
-shinyUI(fluidPage(
+fluidPage(
 
   # Application title
   titlePanel("Hello Shiny!"),
@@ -21,4 +21,4 @@ shinyUI(fluidPage(
       plotOutput("distPlot")
     )
   )
-))
+)

inst/examples/02_text/server.R

@@ -3,7 +3,7 @@ library(datasets)
 
 # Define server logic required to summarize and view the selected
 # dataset
-shinyServer(function(input, output) {
+function(input, output) {
   
   # Return the requested dataset
   datasetInput <- reactive({
@@ -23,4 +23,4 @@ shinyServer(function(input, output) {
   output$view <- renderTable({
     head(datasetInput(), n = input$obs)
   })
-})
+}

inst/examples/02_text/ui.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define UI for dataset viewer application
-shinyUI(fluidPage(
+fluidPage(
   
   # Application title
   titlePanel("Shiny Text"),
@@ -24,4 +24,4 @@ shinyUI(fluidPage(
       tableOutput("view")
     )
   )
-))
+)

inst/examples/03_reactivity/server.R

@@ -3,7 +3,7 @@ library(datasets)
 
 # Define server logic required to summarize and view the selected
 # dataset
-shinyServer(function(input, output) {
+function(input, output) {
 
   # By declaring datasetInput as a reactive expression we ensure 
   # that:
@@ -50,4 +50,4 @@ shinyServer(function(input, output) {
   output$view <- renderTable({
     head(datasetInput(), n = input$obs)
   })
-})
+}

inst/examples/03_reactivity/ui.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define UI for dataset viewer application
-shinyUI(fluidPage(
+fluidPage(
   
   # Application title
   titlePanel("Reactivity"),
@@ -31,4 +31,4 @@ shinyUI(fluidPage(
       tableOutput("view")
     )
   )
-))
+)

inst/examples/04_mpg/server.R

@@ -11,7 +11,7 @@ mpgData$am <- factor(mpgData$am, labels = c("Automatic", "Manual"))
 
 # Define server logic required to plot various variables against
 # mpg
-shinyServer(function(input, output) {
+function(input, output) {
 
   # Compute the formula text in a reactive expression since it is
   # shared by the output$caption and output$mpgPlot functions
@@ -31,4 +31,4 @@ shinyServer(function(input, output) {
             data = mpgData,
             outline = input$outliers)
   })
-})
+}

inst/examples/04_mpg/ui.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define UI for miles per gallon application
-shinyUI(fluidPage(
+fluidPage(
   
   # Application title
   titlePanel("Miles Per Gallon"),
@@ -26,4 +26,4 @@ shinyUI(fluidPage(
       plotOutput("mpgPlot")
     )
   )
-))
+)

inst/examples/05_sliders/server.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define server logic for slider examples
-shinyServer(function(input, output) {
+function(input, output) {
   
   # Reactive expression to compose a data frame containing all of
   # the values
@@ -26,4 +26,4 @@ shinyServer(function(input, output) {
   output$values <- renderTable({
     sliderValues()
   })
-})
+}

inst/examples/05_sliders/ui.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define UI for slider demo application
-shinyUI(fluidPage(
+fluidPage(
 
   #  Application title
   titlePanel("Sliders"),
@@ -40,4 +40,4 @@ shinyUI(fluidPage(
       tableOutput("values")
     )
   )
-))
+)

inst/examples/06_tabsets/server.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define server logic for random distribution application
-shinyServer(function(input, output) {
+function(input, output) {
   
   # Reactive expression to generate the requested distribution.
   # This is called whenever the inputs change. The output
@@ -41,4 +41,4 @@ shinyServer(function(input, output) {
     data.frame(x=data())
   })
   
-})
+}

inst/examples/06_tabsets/ui.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define UI for random distribution application 
-shinyUI(fluidPage(
+fluidPage(
     
   # Application title
   titlePanel("Tabsets"),
@@ -35,4 +35,4 @@ shinyUI(fluidPage(
       )
     )
   )
-))
+)

inst/examples/07_widgets/server.R

@@ -3,7 +3,7 @@ library(datasets)
 
 # Define server logic required to summarize and view the 
 # selected dataset
-shinyServer(function(input, output) {
+function(input, output) {
   
   # Return the requested dataset
   datasetInput <- reactive({
@@ -23,4 +23,4 @@ shinyServer(function(input, output) {
   output$view <- renderTable({
     head(datasetInput(), n = input$obs)
   })
-})
+}

inst/examples/07_widgets/ui.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define UI for dataset viewer application
-shinyUI(fluidPage(
+fluidPage(
   
   # Application title.
   titlePanel("More Widgets"),
@@ -40,4 +40,4 @@ shinyUI(fluidPage(
       tableOutput("view")
     )
   )
-))
+)

inst/examples/08_html/server.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define server logic for random distribution application
-shinyServer(function(input, output) {
+function(input, output) {
   
   # Reactive expression to generate the requested distribution. This is 
   # called whenever the inputs change. The output expressions defined 
@@ -39,4 +39,4 @@ shinyServer(function(input, output) {
     data.frame(x=data())
   })
   
-})
+}

inst/examples/09_upload/server.R

@@ -1,6 +1,6 @@
 library(shiny)
 
-shinyServer(function(input, output) {
+function(input, output) {
   output$contents <- renderTable({
     
     # input$file1 will be NULL initially. After the user selects
@@ -17,4 +17,4 @@ shinyServer(function(input, output) {
     read.csv(inFile$datapath, header=input$header, sep=input$sep, 
 				 quote=input$quote)
   })
-})
+}

inst/examples/09_upload/ui.R

@@ -1,6 +1,6 @@
 library(shiny)
 
-shinyUI(fluidPage(
+fluidPage(
   titlePanel("Uploading Files"),
   sidebarLayout(
     sidebarPanel(
@@ -25,4 +25,4 @@ shinyUI(fluidPage(
       tableOutput('contents')
     )
   )
-))
+)

inst/examples/10_download/server.R

@@ -1,4 +1,4 @@
-shinyServer(function(input, output) {
+function(input, output) {
   datasetInput <- reactive({
     switch(input$dataset,
            "rock" = rock,
@@ -18,4 +18,4 @@ shinyServer(function(input, output) {
       write.csv(datasetInput(), file)
     }
   )
-})
+}

inst/examples/10_download/ui.R

@@ -1,4 +1,4 @@
-shinyUI(fluidPage(
+fluidPage(
   titlePanel('Downloading Data'),
   sidebarLayout(
     sidebarPanel(
@@ -10,4 +10,4 @@ shinyUI(fluidPage(
       tableOutput('table')
     )
   )
-))
+)

inst/examples/11_timer/server.R

@@ -1,6 +1,6 @@
-shinyServer(function(input, output, session) {
+function(input, output, session) {
   output$currentTime <- renderText({
     invalidateLater(1000, session)
     paste("The current time is", Sys.time())
   })
-})
+}

inst/examples/11_timer/ui.R

@@ -1,3 +1,3 @@
-shinyUI(fluidPage(
+fluidPage(
   textOutput("currentTime")
-))
+)

inst/staticdocs/index.r

@@ -45,6 +45,7 @@ sd_section("UI Inputs",
     "submitButton",
     "textInput",
     "passwordInput",
+    "updateActionButton",
     "updateCheckboxGroupInput",
     "updateCheckboxInput",
     "updateDateInput",
@@ -156,6 +157,7 @@ sd_section("Utility functions",
   "Miscellaneous utilities that may be useful to advanced users or when extending Shiny.",
   c(
     "req",
+    "cancelOutput",
     "validate",
     "session",
     "exprToFunction",

inst/www/shared/bootstrap/css/bootstrap-theme.css

@@ -1,5 +1,5 @@
 /*!
- * Bootstrap v3.3.5 (http://getbootstrap.com)
+ * Bootstrap v3.3.6 (http://getbootstrap.com)
  * Copyright 2011-2015 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  */

inst/www/shared/bootstrap/css/bootstrap.css

@@ -1,5 +1,5 @@
 /*!
- * Bootstrap v3.3.5 (http://getbootstrap.com)
+ * Bootstrap v3.3.6 (http://getbootstrap.com)
  * Copyright 2011-2015 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  */
@@ -279,10 +279,10 @@ th {
   -moz-osx-font-smoothing: grayscale;
 }
 .glyphicon-asterisk:before {
-  content: "\2a";
+  content: "\002a";
 }
 .glyphicon-plus:before {
-  content: "\2b";
+  content: "\002b";
 }
 .glyphicon-euro:before,
 .glyphicon-eur:before {
@@ -2582,6 +2582,10 @@ output {
 .form-control::-webkit-input-placeholder {
   color: #999;
 }
+.form-control::-ms-expand {
+  background-color: transparent;
+  border: 0;
+}
 .form-control[disabled],
 .form-control[readonly],
 fieldset[disabled] .form-control {
@@ -2988,7 +2992,7 @@ select[multiple].input-lg {
 }
 @media (min-width: 768px) {
   .form-horizontal .form-group-lg .control-label {
-    padding-top: 14.333333px;
+    padding-top: 11px;
     font-size: 18px;
   }
 }
@@ -3096,9 +3100,6 @@ fieldset[disabled] a.btn {
 .open > .dropdown-toggle.btn-default {
   background-image: none;
 }
-.btn-default.disabled,
-.btn-default[disabled],
-fieldset[disabled] .btn-default,
 .btn-default.disabled:hover,
 .btn-default[disabled]:hover,
 fieldset[disabled] .btn-default:hover,
@@ -3107,13 +3108,7 @@ fieldset[disabled] .btn-default:hover,
 fieldset[disabled] .btn-default:focus,
 .btn-default.disabled.focus,
 .btn-default[disabled].focus,
-fieldset[disabled] .btn-default.focus,
-.btn-default.disabled:active,
-.btn-default[disabled]:active,
-fieldset[disabled] .btn-default:active,
-.btn-default.disabled.active,
-.btn-default[disabled].active,
-fieldset[disabled] .btn-default.active {
+fieldset[disabled] .btn-default.focus {
   background-color: #fff;
   border-color: #ccc;
 }
@@ -3162,9 +3157,6 @@ fieldset[disabled] .btn-default.active {
 .open > .dropdown-toggle.btn-primary {
   background-image: none;
 }
-.btn-primary.disabled,
-.btn-primary[disabled],
-fieldset[disabled] .btn-primary,
 .btn-primary.disabled:hover,
 .btn-primary[disabled]:hover,
 fieldset[disabled] .btn-primary:hover,
@@ -3173,13 +3165,7 @@ fieldset[disabled] .btn-primary:hover,
 fieldset[disabled] .btn-primary:focus,
 .btn-primary.disabled.focus,
 .btn-primary[disabled].focus,
-fieldset[disabled] .btn-primary.focus,
-.btn-primary.disabled:active,
-.btn-primary[disabled]:active,
-fieldset[disabled] .btn-primary:active,
-.btn-primary.disabled.active,
-.btn-primary[disabled].active,
-fieldset[disabled] .btn-primary.active {
+fieldset[disabled] .btn-primary.focus {
   background-color: #337ab7;
   border-color: #2e6da4;
 }
@@ -3228,9 +3214,6 @@ fieldset[disabled] .btn-primary.active {
 .open > .dropdown-toggle.btn-success {
   background-image: none;
 }
-.btn-success.disabled,
-.btn-success[disabled],
-fieldset[disabled] .btn-success,
 .btn-success.disabled:hover,
 .btn-success[disabled]:hover,
 fieldset[disabled] .btn-success:hover,
@@ -3239,13 +3222,7 @@ fieldset[disabled] .btn-success:hover,
 fieldset[disabled] .btn-success:focus,
 .btn-success.disabled.focus,
 .btn-success[disabled].focus,
-fieldset[disabled] .btn-success.focus,
-.btn-success.disabled:active,
-.btn-success[disabled]:active,
-fieldset[disabled] .btn-success:active,
-.btn-success.disabled.active,
-.btn-success[disabled].active,
-fieldset[disabled] .btn-success.active {
+fieldset[disabled] .btn-success.focus {
   background-color: #5cb85c;
   border-color: #4cae4c;
 }
@@ -3294,9 +3271,6 @@ fieldset[disabled] .btn-success.active {
 .open > .dropdown-toggle.btn-info {
   background-image: none;
 }
-.btn-info.disabled,
-.btn-info[disabled],
-fieldset[disabled] .btn-info,
 .btn-info.disabled:hover,
 .btn-info[disabled]:hover,
 fieldset[disabled] .btn-info:hover,
@@ -3305,13 +3279,7 @@ fieldset[disabled] .btn-info:hover,
 fieldset[disabled] .btn-info:focus,
 .btn-info.disabled.focus,
 .btn-info[disabled].focus,
-fieldset[disabled] .btn-info.focus,
-.btn-info.disabled:active,
-.btn-info[disabled]:active,
-fieldset[disabled] .btn-info:active,
-.btn-info.disabled.active,
-.btn-info[disabled].active,
-fieldset[disabled] .btn-info.active {
+fieldset[disabled] .btn-info.focus {
   background-color: #5bc0de;
   border-color: #46b8da;
 }
@@ -3360,9 +3328,6 @@ fieldset[disabled] .btn-info.active {
 .open > .dropdown-toggle.btn-warning {
   background-image: none;
 }
-.btn-warning.disabled,
-.btn-warning[disabled],
-fieldset[disabled] .btn-warning,
 .btn-warning.disabled:hover,
 .btn-warning[disabled]:hover,
 fieldset[disabled] .btn-warning:hover,
@@ -3371,13 +3336,7 @@ fieldset[disabled] .btn-warning:hover,
 fieldset[disabled] .btn-warning:focus,
 .btn-warning.disabled.focus,
 .btn-warning[disabled].focus,
-fieldset[disabled] .btn-warning.focus,
-.btn-warning.disabled:active,
-.btn-warning[disabled]:active,
-fieldset[disabled] .btn-warning:active,
-.btn-warning.disabled.active,
-.btn-warning[disabled].active,
-fieldset[disabled] .btn-warning.active {
+fieldset[disabled] .btn-warning.focus {
   background-color: #f0ad4e;
   border-color: #eea236;
 }
@@ -3426,9 +3385,6 @@ fieldset[disabled] .btn-warning.active {
 .open > .dropdown-toggle.btn-danger {
   background-image: none;
 }
-.btn-danger.disabled,
-.btn-danger[disabled],
-fieldset[disabled] .btn-danger,
 .btn-danger.disabled:hover,
 .btn-danger[disabled]:hover,
 fieldset[disabled] .btn-danger:hover,
@@ -3437,13 +3393,7 @@ fieldset[disabled] .btn-danger:hover,
 fieldset[disabled] .btn-danger:focus,
 .btn-danger.disabled.focus,
 .btn-danger[disabled].focus,
-fieldset[disabled] .btn-danger.focus,
-.btn-danger.disabled:active,
-.btn-danger[disabled]:active,
-fieldset[disabled] .btn-danger:active,
-.btn-danger.disabled.active,
-.btn-danger[disabled].active,
-fieldset[disabled] .btn-danger.active {
+fieldset[disabled] .btn-danger.focus {
   background-color: #d9534f;
   border-color: #d43f3a;
 }
@@ -3817,6 +3767,7 @@ tbody.collapse.in {
   border-radius: 0;
 }
 .btn-group-vertical > .btn:first-child:not(:last-child) {
+  border-top-left-radius: 4px;
   border-top-right-radius: 4px;
   border-bottom-right-radius: 0;
   border-bottom-left-radius: 0;
@@ -3824,6 +3775,7 @@ tbody.collapse.in {
 .btn-group-vertical > .btn:last-child:not(:first-child) {
   border-top-left-radius: 0;
   border-top-right-radius: 0;
+  border-bottom-right-radius: 4px;
   border-bottom-left-radius: 4px;
 }
 .btn-group-vertical > .btn-group:not(:first-child):not(:last-child) > .btn {
@@ -3881,6 +3833,9 @@ tbody.collapse.in {
   width: 100%;
   margin-bottom: 0;
 }
+.input-group .form-control:focus {
+  z-index: 3;
+}
 .input-group-lg > .form-control,
 .input-group-lg > .input-group-addon,
 .input-group-lg > .input-group-btn > .btn {
@@ -4792,7 +4747,7 @@ fieldset[disabled] .navbar-inverse .btn-link:focus {
 .pagination > li > span:hover,
 .pagination > li > a:focus,
 .pagination > li > span:focus {
-  z-index: 3;
+  z-index: 2;
   color: #23527c;
   background-color: #eee;
   border-color: #ddd;
@@ -4803,7 +4758,7 @@ fieldset[disabled] .navbar-inverse .btn-link:focus {
 .pagination > .active > span:hover,
 .pagination > .active > a:focus,
 .pagination > .active > span:focus {
-  z-index: 2;
+  z-index: 3;
   color: #fff;
   cursor: default;
   background-color: #337ab7;
@@ -5024,6 +4979,8 @@ a.badge:focus {
 }
 .container .jumbotron,
 .container-fluid .jumbotron {
+  padding-right: 15px;
+  padding-left: 15px;
   border-radius: 6px;
 }
 .jumbotron .container {
@@ -5978,7 +5935,6 @@ button.close {
   opacity: .5;
 }
 .modal-header {
-  min-height: 16.42857143px;
   padding: 15px;
   border-bottom: 1px solid #e5e5e5;
 }
@@ -6371,6 +6327,7 @@ button.close {
   color: #fff;
   text-align: center;
   text-shadow: 0 1px 2px rgba(0, 0, 0, .6);
+  background-color: rgba(0, 0, 0, 0);
   filter: alpha(opacity=50);
   opacity: .5;
 }
@@ -6484,16 +6441,16 @@ button.close {
   .carousel-control .icon-next {
     width: 30px;
     height: 30px;
-    margin-top: -15px;
+    margin-top: -10px;
     font-size: 30px;
   }
   .carousel-control .glyphicon-chevron-left,
   .carousel-control .icon-prev {
-    margin-left: -15px;
+    margin-left: -10px;
   }
   .carousel-control .glyphicon-chevron-right,
   .carousel-control .icon-next {
-    margin-right: -15px;
+    margin-right: -10px;
   }
   .carousel-caption {
     right: 20%;
@@ -6532,6 +6489,8 @@ button.close {
 .pager:after,
 .panel-body:before,
 .panel-body:after,
+.modal-header:before,
+.modal-header:after,
 .modal-footer:before,
 .modal-footer:after {
   display: table;
@@ -6551,6 +6510,7 @@ button.close {
 .navbar-collapse:after,
 .pager:after,
 .panel-body:after,
+.modal-header:after,
 .modal-footer:after {
   clear: both;
 }

inst/www/shared/bootstrap/js/bootstrap.js

@@ -1,5 +1,5 @@
 /*!
- * Bootstrap v3.3.5 (http://getbootstrap.com)
+ * Bootstrap v3.3.6 (http://getbootstrap.com)
  * Copyright 2011-2015 Twitter, Inc.
  * Licensed under the MIT license
  */
@@ -11,13 +11,13 @@ if (typeof jQuery === 'undefined') {
 +function ($) {
   'use strict';
   var version = $.fn.jquery.split(' ')[0].split('.')
-  if ((version[0] < 2 && version[1] < 9) || (version[0] == 1 && version[1] == 9 && version[2] < 1)) {
-    throw new Error('Bootstrap\'s JavaScript requires jQuery version 1.9.1 or higher')
+  if ((version[0] < 2 && version[1] < 9) || (version[0] == 1 && version[1] == 9 && version[2] < 1) || (version[0] > 2)) {
+    throw new Error('Bootstrap\'s JavaScript requires jQuery version 1.9.1 or higher, but lower than version 3')
   }
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: transition.js v3.3.5
+ * Bootstrap: transition.js v3.3.6
  * http://getbootstrap.com/javascript/#transitions
  * ========================================================================
  * Copyright 2011-2015 Twitter, Inc.
@@ -77,7 +77,7 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: alert.js v3.3.5
+ * Bootstrap: alert.js v3.3.6
  * http://getbootstrap.com/javascript/#alerts
  * ========================================================================
  * Copyright 2011-2015 Twitter, Inc.
@@ -96,7 +96,7 @@ if (typeof jQuery === 'undefined') {
     $(el).on('click', dismiss, this.close)
   }
 
-  Alert.VERSION = '3.3.5'
+  Alert.VERSION = '3.3.6'
 
   Alert.TRANSITION_DURATION = 150
 
@@ -172,7 +172,7 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: button.js v3.3.5
+ * Bootstrap: button.js v3.3.6
  * http://getbootstrap.com/javascript/#buttons
  * ========================================================================
  * Copyright 2011-2015 Twitter, Inc.
@@ -192,7 +192,7 @@ if (typeof jQuery === 'undefined') {
     this.isLoading = false
   }
 
-  Button.VERSION  = '3.3.5'
+  Button.VERSION  = '3.3.6'
 
   Button.DEFAULTS = {
     loadingText: 'loading...'
@@ -293,7 +293,7 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: carousel.js v3.3.5
+ * Bootstrap: carousel.js v3.3.6
  * http://getbootstrap.com/javascript/#carousel
  * ========================================================================
  * Copyright 2011-2015 Twitter, Inc.
@@ -324,7 +324,7 @@ if (typeof jQuery === 'undefined') {
       .on('mouseleave.bs.carousel', $.proxy(this.cycle, this))
   }
 
-  Carousel.VERSION  = '3.3.5'
+  Carousel.VERSION  = '3.3.6'
 
   Carousel.TRANSITION_DURATION = 600
 
@@ -531,7 +531,7 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: collapse.js v3.3.5
+ * Bootstrap: collapse.js v3.3.6
  * http://getbootstrap.com/javascript/#collapse
  * ========================================================================
  * Copyright 2011-2015 Twitter, Inc.
@@ -561,7 +561,7 @@ if (typeof jQuery === 'undefined') {
     if (this.options.toggle) this.toggle()
   }
 
-  Collapse.VERSION  = '3.3.5'
+  Collapse.VERSION  = '3.3.6'
 
   Collapse.TRANSITION_DURATION = 350
 
@@ -743,7 +743,7 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: dropdown.js v3.3.5
+ * Bootstrap: dropdown.js v3.3.6
  * http://getbootstrap.com/javascript/#dropdowns
  * ========================================================================
  * Copyright 2011-2015 Twitter, Inc.
@@ -763,7 +763,7 @@ if (typeof jQuery === 'undefined') {
     $(element).on('click.bs.dropdown', this.toggle)
   }
 
-  Dropdown.VERSION = '3.3.5'
+  Dropdown.VERSION = '3.3.6'
 
   function getParent($this) {
     var selector = $this.attr('data-target')
@@ -795,7 +795,7 @@ if (typeof jQuery === 'undefined') {
       if (e.isDefaultPrevented()) return
 
       $this.attr('aria-expanded', 'false')
-      $parent.removeClass('open').trigger('hidden.bs.dropdown', relatedTarget)
+      $parent.removeClass('open').trigger($.Event('hidden.bs.dropdown', relatedTarget))
     })
   }
 
@@ -829,7 +829,7 @@ if (typeof jQuery === 'undefined') {
 
       $parent
         .toggleClass('open')
-        .trigger('shown.bs.dropdown', relatedTarget)
+        .trigger($.Event('shown.bs.dropdown', relatedTarget))
     }
 
     return false
@@ -909,7 +909,7 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: modal.js v3.3.5
+ * Bootstrap: modal.js v3.3.6
  * http://getbootstrap.com/javascript/#modals
  * ========================================================================
  * Copyright 2011-2015 Twitter, Inc.
@@ -943,7 +943,7 @@ if (typeof jQuery === 'undefined') {
     }
   }
 
-  Modal.VERSION  = '3.3.5'
+  Modal.VERSION  = '3.3.6'
 
   Modal.TRANSITION_DURATION = 300
   Modal.BACKDROP_TRANSITION_DURATION = 150
@@ -1247,7 +1247,7 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: tooltip.js v3.3.5
+ * Bootstrap: tooltip.js v3.3.6
  * http://getbootstrap.com/javascript/#tooltip
  * Inspired by the original jQuery.tipsy by Jason Frame
  * ========================================================================
@@ -1274,7 +1274,7 @@ if (typeof jQuery === 'undefined') {
     this.init('tooltip', element, options)
   }
 
-  Tooltip.VERSION  = '3.3.5'
+  Tooltip.VERSION  = '3.3.6'
 
   Tooltip.TRANSITION_DURATION = 150
 
@@ -1762,7 +1762,7 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: popover.js v3.3.5
+ * Bootstrap: popover.js v3.3.6
  * http://getbootstrap.com/javascript/#popovers
  * ========================================================================
  * Copyright 2011-2015 Twitter, Inc.
@@ -1782,7 +1782,7 @@ if (typeof jQuery === 'undefined') {
 
   if (!$.fn.tooltip) throw new Error('Popover requires tooltip.js')
 
-  Popover.VERSION  = '3.3.5'
+  Popover.VERSION  = '3.3.6'
 
   Popover.DEFAULTS = $.extend({}, $.fn.tooltip.Constructor.DEFAULTS, {
     placement: 'right',
@@ -1871,7 +1871,7 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: scrollspy.js v3.3.5
+ * Bootstrap: scrollspy.js v3.3.6
  * http://getbootstrap.com/javascript/#scrollspy
  * ========================================================================
  * Copyright 2011-2015 Twitter, Inc.
@@ -1900,7 +1900,7 @@ if (typeof jQuery === 'undefined') {
     this.process()
   }
 
-  ScrollSpy.VERSION  = '3.3.5'
+  ScrollSpy.VERSION  = '3.3.6'
 
   ScrollSpy.DEFAULTS = {
     offset: 10
@@ -2044,7 +2044,7 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: tab.js v3.3.5
+ * Bootstrap: tab.js v3.3.6
  * http://getbootstrap.com/javascript/#tabs
  * ========================================================================
  * Copyright 2011-2015 Twitter, Inc.
@@ -2064,7 +2064,7 @@ if (typeof jQuery === 'undefined') {
     // jscs:enable requireDollarBeforejQueryAssignment
   }
 
-  Tab.VERSION = '3.3.5'
+  Tab.VERSION = '3.3.6'
 
   Tab.TRANSITION_DURATION = 150
 
@@ -2200,7 +2200,7 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: affix.js v3.3.5
+ * Bootstrap: affix.js v3.3.6
  * http://getbootstrap.com/javascript/#affix
  * ========================================================================
  * Copyright 2011-2015 Twitter, Inc.
@@ -2229,7 +2229,7 @@ if (typeof jQuery === 'undefined') {
     this.checkPosition()
   }
 
-  Affix.VERSION  = '3.3.5'
+  Affix.VERSION  = '3.3.6'
 
   Affix.RESET    = 'affix affix-top affix-bottom'
 

inst/www/shared/highlight/rstudio.css

@@ -1,3 +1,7 @@
+code {
+  line-height: 150%;
+}
+
 pre .operator,
 pre .paren {
   color: rgb(104, 118, 135)
@@ -13,9 +17,11 @@ pre .number {
 
 pre .comment {
   color: rgb(76, 136, 107);
+  font-style: italic;
 }
 
-pre .keyword {
+pre .keyword,
+pre .id {
   color: rgb(0, 0, 255);
 }
 
@@ -23,7 +29,53 @@ pre .identifier {
   color: rgb(0, 0, 0);
 }
 
-pre .string {
+pre .string,
+pre .attribute {
   color: rgb(3, 106, 7);
 }
 
+pre .doctype {
+  color: rgb(104, 104, 92);
+}
+
+pre .tag,
+pre .title {
+  color: rgb(4, 29, 140);
+}
+
+pre .value {
+  color: rgb(13, 105, 18);
+}
+
+.language-xml .attribute {
+  color: rgb(0, 0, 0);
+}
+
+.language-css .attribute {
+  color: rgb(110, 124, 219);
+}
+
+.language-css .value {
+  color: rgb(23, 149, 30);
+}
+
+.language-css .number,
+.language-css .hexcolor {
+  color: rgb(7, 27, 201);
+}
+
+.language-css .function {
+  color: rgb(61, 77, 113);
+}
+
+.language-css .tag {
+  color: rgb(195, 13, 25);
+}
+
+.language-css .class {
+  color: rgb(53, 132, 148);
+}
+
+.language-css .pseudo {
+  color: rgb(13, 105, 18);
+}

inst/www/shared/shiny-showcase.js

@@ -54,13 +54,13 @@
           }
         }
       }
-      // If this is not a text node, descend recursively to see how many 
+      // If this is not a text node, descend recursively to see how many
       // lines it contains.
       else if (child.nodeType === 1) { // ELEMENT_NODE
         var ret = findTextPoint(child, line - newlines, col);
         if (ret.element !== null)
-          return ret; 
-        else 
+          return ret;
+        else
           newlines += ret.offset;
       }
     }
@@ -85,7 +85,7 @@
       var code = document.getElementById(srcfile.replace(/\./g, "_") + "_code");
       var start = findTextPoint(code, ref[0], ref[4]);
       var end = findTextPoint(code, ref[2], ref[5]);
-      
+
       // If the insertion point can't be found, bail out now
       if (start.element === null || end.element === null)
          return;
@@ -129,10 +129,10 @@
     var animateCodeMs = animate ? animateMs : 1;
 
     // set the source and targets for the tab move
-    var newHostElement = above ? 
+    var newHostElement = above ?
       document.getElementById("showcase-sxs-code") :
       document.getElementById("showcase-code-inline");
-    var currentHostElement = above ? 
+    var currentHostElement = above ?
       document.getElementById("showcase-code-inline") :
       document.getElementById("showcase-sxs-code");
 
@@ -162,7 +162,7 @@
 
       $(newHostElement).fadeIn();
       if (!above) {
-        // remove the applied width and zoom on the app container, and 
+        // remove the applied width and zoom on the app container, and
         // scroll smoothly down to the code's new home
         document.getElementById("showcase-app-container").removeAttribute("style");
         if (animate)
@@ -234,9 +234,9 @@
   };
 
   // make the code scrollable to about the height of the browser, less space
-  // for the tabs 
+  // for the tabs
   var setCodeHeightFromDocHeight = function() {
-    document.getElementById("showcase-code-content").style.height = 
+    document.getElementById("showcase-code-content").style.height =
       $(window).height() + "px";
   };
 
@@ -247,7 +247,7 @@
       // IE8 puts the content of <script> tags into innerHTML but
       // not innerText
       var content = mdContent.innerText || mdContent.innerHTML;
-      document.getElementById("readme-md").innerHTML = 
+      document.getElementById("readme-md").innerHTML =
         (new Showdown.converter()).makeHtml(content)
     }
   }

inst/www/shared/shiny.css

@@ -1,14 +1,68 @@
-body.disconnected {
+#shiny-disconnected-overlay {
+  position: fixed;
+  top: 0;
+  bottom: 0;
+  left: 0;
+  right: 0;
   background-color: #999;
   opacity: 0.5;
+  overflow: hidden;
+  z-index: 99998;
+  pointer-events: none;
 }
 
-table.data {
-  width: auto;
+.table.shiny-table > thead > tr > th,
+.table.shiny-table > tbody > tr > th,
+.table.shiny-table > tfoot > tr > th,
+.table.shiny-table > thead > tr > td,
+.table.shiny-table > tbody > tr > td,
+.table.shiny-table > tfoot > tr > td {
+  padding-left: 12px;
+  padding-right: 12px ;
 }
-table.data td[align=right] {
-  font-family: monospace;
-  text-align: right;
+
+.shiny-table.spacing-xs > thead > tr > th,
+.shiny-table.spacing-xs > tbody > tr > th,
+.shiny-table.spacing-xs > tfoot > tr > th,
+.shiny-table.spacing-xs > thead > tr > td,
+.shiny-table.spacing-xs > tbody > tr > td,
+.shiny-table.spacing-xs > tfoot > tr > td {
+  padding-top: 3px;
+  padding-bottom: 3px;
+}
+
+.shiny-table.spacing-s > thead > tr > th,
+.shiny-table.spacing-s > tbody > tr > th,
+.shiny-table.spacing-s > tfoot > tr > th,
+.shiny-table.spacing-s > thead > tr > td,
+.shiny-table.spacing-s > tbody > tr > td,
+.shiny-table.spacing-s > tfoot > tr > td {
+  padding-top: 5px;
+  padding-bottom: 5px;
+}
+
+.shiny-table.spacing-m > thead > tr > th,
+.shiny-table.spacing-m > tbody > tr > th,
+.shiny-table.spacing-m > tfoot > tr > th,
+.shiny-table.spacing-m > thead > tr > td,
+.shiny-table.spacing-m > tbody > tr > td,
+.shiny-table.spacing-m > tfoot > tr > td {
+  padding-top: 8px;
+  padding-bottom: 8px;
+}
+
+.shiny-table.spacing-l > thead > tr > th,
+.shiny-table.spacing-l > tbody > tr > th,
+.shiny-table.spacing-l > tfoot > tr > th,
+.shiny-table.spacing-l > thead > tr > td,
+.shiny-table.spacing-l > tbody > tr > td,
+.shiny-table.spacing-l > tfoot > tr > td {
+  padding-top: 10px;
+  padding-bottom: 10px;
+}
+
+.shiny-table .NA {
+  color: #909090;
 }
 
 .shiny-output-error {
@@ -222,3 +276,63 @@ table.data td[align=right] {
 .shiny-input-container > div > select:not(.selectized) {
   width: 100%;
 }
+
+
+#shiny-notification-panel {
+  position: fixed;
+  bottom: 0;
+  right: 0;
+  background-color: rgba(0,0,0,0);
+  padding: 2px;
+  width: 250px;
+  z-index: 99999;
+}
+
+.shiny-notification {
+  background-color: #e8e8e8;
+  color: #333;
+  border: 1px solid #ccc;
+  border-radius: 3px;
+  opacity: 0.85;
+  padding: 10px 8px 10px 10px;
+  margin: 2px;
+}
+
+.shiny-notification-message {
+  color: #31708f;
+  background-color: #d9edf7;
+  border: 1px solid #bce8f1;
+}
+
+.shiny-notification-warning {
+  color: #8a6d3b;
+  background-color: #fcf8e3;
+  border: 1px solid #faebcc;
+}
+
+.shiny-notification-error {
+  color: #a94442;
+  background-color: #f2dede;
+  border: 1px solid #ebccd1;
+}
+
+.shiny-notification-close {
+  float: right;
+  font-weight: bold;
+  font-size: 18px;
+  bottom: 9px;
+  position: relative;
+  padding-left: 4px;
+  color: #444;
+  cursor: default;
+}
+
+.shiny-notification-close:hover {
+  color: #000;
+}
+
+.shiny-notification-content-action a {
+  color: rgb(51, 122, 183);
+  text-decoration: underline;
+  font-weight: bold;
+}

man-roxygen/update-input.R

@@ -13,7 +13,7 @@
 #'
 #' For \code{\link{radioButtons}()}, \code{\link{checkboxGroupInput}()} and
 #' \code{\link{selectInput}()}, the set of choices can be cleared by using
-#' \code{choices=character(0)}
+#' \code{choices=character(0)}.
 #'
 #' @param session The \code{session} object passed to function given to
 #'   \code{shinyServer}.

man/Progress.Rd

@@ -69,11 +69,16 @@ to be removed.
   }
 }
 \examples{
-\dontrun{
-# server.R
-shinyServer(function(input, output, session) {
+## Only run examples in interactive R sessions
+if (interactive()) {
+
+ui <- fluidPage(
+  plotOutput("plot")
+)
+
+server <- function(input, output, session) {
   output$plot <- renderPlot({
-    progress <- shiny::Progress$new(session, min=1, max=15)
+    progress <- Progress$new(session, min=1, max=15)
     on.exit(progress$close())
 
     progress$set(message = 'Calculation in progress',
@@ -85,7 +90,9 @@ shinyServer(function(input, output, session) {
     }
     plot(cars)
   })
-})
+}
+
+shinyApp(ui, server)
 }
 }
 \seealso{

man/actionButton.Rd

@@ -27,19 +27,29 @@ Creates an action button or link whose value is initially zero, and increments b
 each time it is pressed.
 }
 \examples{
-\dontrun{
-# In server.R
-output$distPlot <- renderPlot({
-  # Take a dependency on input$goButton
-  input$goButton
+## Only run examples in interactive R sessions
+if (interactive()) {
 
-  # Use isolate() to avoid dependency on input$obs
-  dist <- isolate(rnorm(input$obs))
-  hist(dist)
-})
+ui <- fluidPage(
+  sliderInput("obs", "Number of observations", 0, 1000, 500),
+  actionButton("goButton", "Go!"),
+  plotOutput("distPlot")
+)
+
+server <- function(input, output) {
+  output$distPlot <- renderPlot({
+    # Take a dependency on input$goButton. This will run once initially,
+    # because the value changes from NULL to 0.
+    input$goButton
+
+    # Use isolate() to avoid dependency on input$obs
+    dist <- isolate(rnorm(input$obs))
+    hist(dist)
+  })
+}
+
+shinyApp(ui, server)
 
-# In ui.R
-actionButton("goButton", "Go!")
 }
 
 }

man/cancelOutput.Rd

@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/utils.R
+\name{cancelOutput}
+\alias{cancelOutput}
+\title{Cancel processing of the current output}
+\usage{
+cancelOutput()
+}
+\description{
+Signals an error that Shiny treats specially if an output is currently being
+evaluated. Execution will stop, but rather than clearing the output (as
+\code{\link{req}} does) or showing an error message (as \code{\link{stop}}
+does), the output simply remains unchanged.
+}
+\details{
+If \code{cancelOutput} is called in any non-output context (like in an
+\code{\link{observe}} or \code{\link{observeEvent}}), the effect is the same
+as \code{\link{req}(FALSE)}.
+}
+

man/checkboxGroupInput.Rd

@@ -31,11 +31,25 @@ independently. The server will receive the input as a character vector of the
 selected values.
 }
 \examples{
-checkboxGroupInput("variable", "Variable:",
-                   c("Cylinders" = "cyl",
-                     "Transmission" = "am",
-                     "Gears" = "gear"))
+## Only run examples in interactive R sessions
+if (interactive()) {
 
+ui <- fluidPage(
+  checkboxGroupInput("variable", "Variables to show:",
+                     c("Cylinders" = "cyl",
+                       "Transmission" = "am",
+                       "Gears" = "gear")),
+  tableOutput("data")
+)
+
+server <- function(input, output) {
+  output$data <- renderTable({
+    mtcars[, c("mpg", input$variable), drop = FALSE]
+  }, rownames = TRUE)
+}
+
+shinyApp(ui, server)
+}
 }
 \seealso{
 \code{\link{checkboxInput}}, \code{\link{updateCheckboxGroupInput}}

man/checkboxInput.Rd

@@ -23,7 +23,18 @@ A checkbox control that can be added to a UI definition.
 Create a checkbox that can be used to specify logical values.
 }
 \examples{
-checkboxInput("outliers", "Show outliers", FALSE)
+## Only run examples in interactive R sessions
+if (interactive()) {
+
+ui <- fluidPage(
+  checkboxInput("somevalue", "Some value", FALSE),
+  verbatimTextOutput("value")
+)
+server <- function(input, output) {
+  output$value <- renderText({ input$somevalue })
+}
+shinyApp(ui, server)
+}
 }
 \seealso{
 \code{\link{checkboxGroupInput}}, \code{\link{updateCheckboxInput}}

man/column.Rd

@@ -23,24 +23,43 @@ Create a column for use within a  \code{\link{fluidRow}} or
 \code{\link{fixedRow}}
 }
 \examples{
-fluidRow(
-  column(4,
-    sliderInput("obs", "Number of observations:",
-                min = 1, max = 1000, value = 500)
-  ),
-  column(8,
-    plotOutput("distPlot")
+## Only run examples in interactive R sessions
+if (interactive()) {
+
+ui <- fluidPage(
+  fluidRow(
+    column(4,
+      sliderInput("obs", "Number of observations:",
+                  min = 1, max = 1000, value = 500)
+    ),
+    column(8,
+      plotOutput("distPlot")
+    )
   )
 )
 
-fluidRow(
-  column(width = 4,
-    "4"
-  ),
-  column(width = 3, offset = 2,
-    "3 offset 2"
+server <- function(input, output) {
+  output$distPlot <- renderPlot({
+    hist(rnorm(input$obs))
+  })
+}
+
+shinyApp(ui, server)
+
+
+
+ui <- fluidPage(
+  fluidRow(
+    column(width = 4,
+      "4"
+    ),
+    column(width = 3, offset = 2,
+      "3 offset 2"
+    )
   )
 )
+shinyApp(ui, server = function(input, output) { })
+}
 }
 \seealso{
 \code{\link{fluidRow}}, \code{\link{fixedRow}}.

man/configureBookmarking.Rd

@@ -0,0 +1,35 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/save-state.R
+\name{configureBookmarking}
+\alias{configureBookmarking}
+\title{Configure bookmarking for the current session}
+\usage{
+configureBookmarking(eventExpr, type = c("encode", "persist", "disable"),
+  exclude = NULL, onBookmark = NULL, onRestore = NULL,
+  onBookmarked = NULL, session = getDefaultReactiveDomain())
+}
+\arguments{
+\item{eventExpr}{An expression to listen for, similar to
+\code{\link{observeEvent}}.}
+
+\item{type}{Either \code{"encode"}, which encodes all of the relevant values
+in a URL, \code{"persist"}, which saves to disk, or \code{"disable"}, which
+disables any previously-enabled bookmarking.}
+
+\item{exclude}{Input values to exclude from bookmarking.}
+
+\item{onBookmark}{A function to call before saving state. This function
+should return a list, which will be saved as \code{values}.}
+
+\item{onRestore}{A function to call when a session is restored. It will be
+passed one argument, a restoreContext object.}
+
+\item{onBookmarked}{A callback function to invoke after the bookmarking has
+been done.}
+
+\item{session}{A Shiny session object.}
+}
+\description{
+There are two types of bookmarking: saving state, and encoding state.
+}
+

man/dateInput.Rd

@@ -63,26 +63,33 @@ the browser. It allows the following values:
 }
 }
 \examples{
-dateInput("date", "Date:", value = "2012-02-29")
+## Only run examples in interactive R sessions
+if (interactive()) {
 
-# Default value is the date in client's time zone
-dateInput("date", "Date:")
+ui <- fluidPage(
+  dateInput("date1", "Date:", value = "2012-02-29"),
 
-# value is always yyyy-mm-dd, even if the display format is different
-dateInput("date", "Date:", value = "2012-02-29", format = "mm/dd/yy")
+  # Default value is the date in client's time zone
+  dateInput("date2", "Date:"),
 
-# Pass in a Date object
-dateInput("date", "Date:", value = Sys.Date()-10)
+  # value is always yyyy-mm-dd, even if the display format is different
+  dateInput("date3", "Date:", value = "2012-02-29", format = "mm/dd/yy"),
 
-# Use different language and different first day of week
-dateInput("date", "Date:",
+  # Pass in a Date object
+  dateInput("date4", "Date:", value = Sys.Date()-10),
+
+  # Use different language and different first day of week
+  dateInput("date5", "Date:",
           language = "de",
-          weekstart = 1)
+          weekstart = 1),
 
-# Start with decade view instead of default month view
-dateInput("date", "Date:",
-          startview = "decade")
+  # Start with decade view instead of default month view
+  dateInput("date6", "Date:",
+            startview = "decade")
+)
 
+shinyApp(ui, server = function(input, output) { })
+}
 }
 \seealso{
 \code{\link{dateRangeInput}}, \code{\link{updateDateInput}}

man/dateRangeInput.Rd

@@ -69,37 +69,44 @@ the browser. It allows the following values:
 }
 }
 \examples{
-dateRangeInput("daterange", "Date range:",
-               start = "2001-01-01",
-               end   = "2010-12-31")
+## Only run examples in interactive R sessions
+if (interactive()) {
 
-# Default start and end is the current date in the client's time zone
-dateRangeInput("daterange", "Date range:")
+ui <- fluidPage(
+  dateRangeInput("daterange1", "Date range:",
+                 start = "2001-01-01",
+                 end   = "2010-12-31"),
 
-# start and end are always specified in yyyy-mm-dd, even if the display
-# format is different
-dateRangeInput("daterange", "Date range:",
-               start  = "2001-01-01",
-               end    = "2010-12-31",
-               min    = "2001-01-01",
-               max    = "2012-12-21",
-               format = "mm/dd/yy",
-               separator = " - ")
+  # Default start and end is the current date in the client's time zone
+  dateRangeInput("daterange2", "Date range:"),
 
-# Pass in Date objects
-dateRangeInput("daterange", "Date range:",
-               start = Sys.Date()-10,
-               end = Sys.Date()+10)
+  # start and end are always specified in yyyy-mm-dd, even if the display
+  # format is different
+  dateRangeInput("daterange3", "Date range:",
+                 start  = "2001-01-01",
+                 end    = "2010-12-31",
+                 min    = "2001-01-01",
+                 max    = "2012-12-21",
+                 format = "mm/dd/yy",
+                 separator = " - "),
 
-# Use different language and different first day of week
-dateRangeInput("daterange", "Date range:",
-               language = "de",
-               weekstart = 1)
+  # Pass in Date objects
+  dateRangeInput("daterange4", "Date range:",
+                 start = Sys.Date()-10,
+                 end = Sys.Date()+10),
 
-# Start with decade view instead of default month view
-dateRangeInput("daterange", "Date range:",
-               startview = "decade")
+  # Use different language and different first day of week
+  dateRangeInput("daterange5", "Date range:",
+                 language = "de",
+                 weekstart = 1),
 
+  # Start with decade view instead of default month view
+  dateRangeInput("daterange6", "Date range:",
+                 startview = "decade")
+)
+
+shinyApp(ui, server = function(input, output) { })
+}
 }
 \seealso{
 \code{\link{dateInput}}, \code{\link{updateDateRangeInput}}

man/downloadHandler.Rd

@@ -4,7 +4,7 @@
 \alias{downloadHandler}
 \title{File Downloads}
 \usage{
-downloadHandler(filename, content, contentType = NA)
+downloadHandler(filename, content, contentType = NA, outputArgs = list())
 }
 \arguments{
 \item{filename}{A string of the filename, including extension, that the
@@ -22,6 +22,10 @@ function.)}
 example \code{"text/csv"} or \code{"image/png"}. If \code{NULL} or
 \code{NA}, the content type will be guessed based on the filename
 extension, or \code{application/octet-stream} if the extension is unknown.}
+
+\item{outputArgs}{A list of arguments to be passed through to the implicit
+call to \code{\link{downloadButton}} when \code{downloadHandler} is used
+in an interactive R Markdown document.}
 }
 \description{
 Allows content from the Shiny application to be made available to the user as
@@ -33,20 +37,28 @@ the user initiates the download. Assign the return value to a slot on
 download available.
 }
 \examples{
-\dontrun{
-# In server.R:
-output$downloadData <- downloadHandler(
-  filename = function() {
-    paste('data-', Sys.Date(), '.csv', sep='')
-  },
-  content = function(file) {
-    write.csv(data, file)
-  }
+## Only run examples in interactive R sessions
+if (interactive()) {
+
+ui <- fluidPage(
+  downloadLink("downloadData", "Download")
 )
 
-# In ui.R:
-downloadLink('downloadData', 'Download')
+server <- function(input, output) {
+  # Our dataset
+  data <- mtcars
+
+  output$downloadData <- downloadHandler(
+    filename = function() {
+      paste("data-", Sys.Date(), ".csv", sep="")
+    },
+    content = function(file) {
+      write.csv(data, file)
+    }
+  )
 }
 
+shinyApp(ui, server)
+}
 }
 

man/fileInput.Rd

@@ -42,6 +42,47 @@ the following columns:
   operation.}
 }
 }
+\examples{
+## Only run examples in interactive R sessions
+if (interactive()) {
+
+ui <- fluidPage(
+  sidebarLayout(
+    sidebarPanel(
+      fileInput("file1", "Choose CSV File",
+        accept = c(
+          "text/csv",
+          "text/comma-separated-values,text/plain",
+          ".csv")
+        ),
+      tags$hr(),
+      checkboxInput("header", "Header", TRUE)
+    ),
+    mainPanel(
+      tableOutput("contents")
+    )
+  )
+)
+
+server <- function(input, output) {
+  output$contents <- renderTable({
+    # input$file1 will be NULL initially. After the user selects
+    # and uploads a file, it will be a data frame with 'name',
+    # 'size', 'type', and 'datapath' columns. The 'datapath'
+    # column will contain the local filenames where the data can
+    # be found.
+    inFile <- input$file1
+
+    if (is.null(inFile))
+      return(NULL)
+
+    read.csv(inFile$datapath, header = input$header)
+  })
+}
+
+shinyApp(ui, server)
+}
+}
 \seealso{
 Other input.elements: \code{\link{actionButton}},
   \code{\link{checkboxGroupInput}},

man/fillRow.Rd

@@ -54,10 +54,7 @@ If you try to use \code{fillRow} and \code{fillCol} inside of other
   }
 }
 \examples{
-\donttest{
 # Only run this example in interactive R sessions.
-# NOTE: This example should be run with example(fillRow, ask = FALSE) to
-# avoid being prompted to hit Enter during plot rendering.
 if (interactive()) {
 
 ui <- fillPage(fillRow(
@@ -78,5 +75,4 @@ shinyApp(ui, server)
 
 }
 }
-}