Bump version to 1.0.3

* Make fileInput progress bar change color on error. Fixes #1672

* Grunt

* Update NEWS

.Rbuildignore

@@ -16,3 +16,5 @@
 ^CONTRIBUTING.md$
 ^cran-comments.md$
 ^.*\.o$
+^appveyor\.yml$
+^revdep$

.gitignore

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

.travis.yml

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

CONTRIBUTING.md

@@ -1,10 +1,38 @@
-
 We welcome contributions to the **shiny** package. To submit a contribution:
 
 1. [Fork](https://github.com/rstudio/shiny/fork) the repository and make your changes.
 
-2. Ensure that you have signed the [individual](http://www.rstudio.com/wp-content/uploads/2014/06/RStudioIndividualContributorAgreement.pdf) or [corporate](http://www.rstudio.com/wp-content/uploads/2014/06/RStudioCorporateContributorAgreement.pdf) contributor agreement as appropriate. You can send the signed copy to jj@rstudio.com.
+2. If the change is non-trivial, ensure that you have signed the [individual](http://www.rstudio.com/wp-content/uploads/2014/06/RStudioIndividualContributorAgreement.pdf) or [corporate](http://www.rstudio.com/wp-content/uploads/2014/06/RStudioCorporateContributorAgreement.pdf) contributor agreement as appropriate. You can send the signed copy to jj@rstudio.com. For trivial changes (like typo fixes), a contributor agreement is not needed.
 
 3. Submit a [pull request](https://help.github.com/articles/using-pull-requests).
 
-We'll try to be as responsive as possible in reviewing and accepting pull requests. We appreciate your contributions!
+We generally do not merge pull requests that update included web libraries (such as Bootstrap or jQuery) because it is difficult for us to verify that the update is done correctly; we prefer to update these libraries ourselves.
+
+
+## How to make changes
+
+Before you submit a pull request, please do the following:
+
+* Add an entry to NEWS.md concisely describing what you changed.
+
+* If appropriate, add unit tests in the tests/ directory.
+
+* If you made any changes to the JavaScript files in the srcjs/ directory, make sure you build the output JavaScript files. See tools/README.md file for information on using the build system.
+
+* Run Build->Check Package in the RStudio IDE, or `devtools::check()`, to make sure your change did not add any messages, warnings, or errors.
+
+Doing these things will make it easier for the Shiny development team to evaluate your pull request. Even so, we may still decide to modify your code or even not merge it at all. Factors that may prevent us from merging the pull request include:
+
+* breaking backward compatibility
+* adding a feature that we do not consider relevant for Shiny
+* is hard to understand
+* is hard to maintain in the future
+* is computationally expensive
+* is not intuitive for people to use
+
+We will try to be responsive and provide feedback in case we decide not to merge your pull request.
+
+
+## Filing issues
+
+If you find a bug in Shiny, you can also [file an issue](https://github.com/rstudio/shiny/issues/new). Please provide as much relevant information as you can, and include a minimal reproducible example if possible.

DESCRIPTION

@@ -1,8 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 0.13.0
-Date: 2016-01-12
+Version: 1.0.3
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
     person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
@@ -15,7 +14,7 @@ Authors@R: c(
     person(family = "jQuery contributors", role = c("ctb", "cph"),
     comment = "jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt"),
     person(family = "jQuery UI contributors", role = c("ctb", "cph"),
-    comment = "jQuery UI library; authors listed in inst/www/shared/jqueryui/1.10.4/AUTHORS.txt"),
+    comment = "jQuery UI library; authors listed in inst/www/shared/jqueryui/AUTHORS.txt"),
     person("Mark", "Otto", role = "ctb",
     comment = "Bootstrap library"),
     person("Jacob", "Thornton", role = "ctb",
@@ -57,7 +56,7 @@ Authors@R: c(
     )
 Description: Makes it incredibly easy to build interactive web
     applications with R. Automatic "reactive" binding between inputs and
-    outputs and extensive pre-built widgets make it possible to build
+    outputs and extensive prebuilt widgets make it possible to build
     beautiful, responsive, and powerful applications with minimal effort.
 License: GPL-3 | file LICENSE
 Depends:
@@ -70,8 +69,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),
@@ -79,12 +79,15 @@ Suggests:
     knitr (>= 1.6),
     markdown,
     rmarkdown,
-    ggplot2
+    ggplot2,
+    magrittr
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
-VignetteBuilder: knitr
 Collate:
     'app.R'
+    'bookmark-state-local.R'
+    'stack.R'
+    'bookmark-state.R'
     'bootstrap-layout.R'
     'conditions.R'
     'map.R'
@@ -92,9 +95,12 @@ Collate:
     'utils.R'
     'bootstrap.R'
     'cache.R'
+    'diagnose.R'
     'fileupload.R'
-    'stack.R'
     'graph.R'
+    'reactives.R'
+    'reactive-domains.R'
+    'history.R'
     'hooks.R'
     'html-deps.R'
     'htmltools.R'
@@ -114,26 +120,31 @@ Collate:
     'input-slider.R'
     'input-submit.R'
     'input-text.R'
+    'input-textarea.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'
-    'reactive-domains.R'
-    'reactives.R'
     'render-plot.R'
     'render-table.R'
     'run-url.R'
+    'serializers.R'
     'server-input-handlers.R'
     'server.R'
+    'shiny-options.R'
     'shiny.R'
     'shinyui.R'
     'shinywrappers.R'
     'showcase.R'
     'tar.R'
+    'test-export.R'
     'timer.R'
     'update-input.R'
-RoxygenNote: 5.0.1
+RoxygenNote: 6.0.1

LICENSE

@@ -12,7 +12,7 @@ these components are included below):
 - Respond.js, https://github.com/scottjehl/Respond
 - bootstrap-datepicker, https://github.com/eternicode/bootstrap-datepicker
 - Font Awesome, https://github.com/FortAwesome/Font-Awesome
-- selectize.js, https://github.com/brianreavis/selectize.js
+- selectize.js, https://github.com/selectize/selectize.js
 - es5-shim, https://github.com/es-shims/es5-shim
 - ion.rangeSlider, https://github.com/IonDen/ion.rangeSlider
 - strftime for Javascript, https://github.com/samsonjs/strftime

NAMESPACE

@@ -11,6 +11,7 @@ S3method("[",shinyoutput)
 S3method("[<-",reactivevalues)
 S3method("[<-",shinyoutput)
 S3method("[[",reactivevalues)
+S3method("[[",session_proxy)
 S3method("[[",shinyoutput)
 S3method("[[<-",reactivevalues)
 S3method("[[<-",shinyoutput)
@@ -21,6 +22,8 @@ S3method(as.shiny.appobj,list)
 S3method(as.shiny.appobj,shiny.appobj)
 S3method(as.tags,shiny.appobj)
 S3method(as.tags,shiny.render.function)
+S3method(format,reactiveExpr)
+S3method(format,reactiveVal)
 S3method(names,reactivevalues)
 S3method(print,reactive)
 S3method(print,shiny.appobj)
@@ -39,6 +42,7 @@ export(addResourcePath)
 export(animationOptions)
 export(as.shiny.appobj)
 export(basicPage)
+export(bookmarkButton)
 export(bootstrapLib)
 export(bootstrapPage)
 export(br)
@@ -59,13 +63,16 @@ export(dataTableOutput)
 export(dateInput)
 export(dateRangeInput)
 export(dblclickOpts)
+export(debounce)
 export(dialogViewer)
 export(div)
 export(downloadButton)
 export(downloadHandler)
 export(downloadLink)
 export(em)
+export(enableBookmarking)
 export(eventReactive)
+export(exportTestValues)
 export(exprToFunction)
 export(extractStackTrace)
 export(fileInput)
@@ -79,7 +86,12 @@ export(flowLayout)
 export(fluidPage)
 export(fluidRow)
 export(formatStackTrace)
+export(freezeReactiveVal)
+export(freezeReactiveValue)
 export(getDefaultReactiveDomain)
+export(getQueryString)
+export(getShinyOption)
+export(getUrlHash)
 export(h1)
 export(h2)
 export(h3)
@@ -102,12 +114,14 @@ export(includeMarkdown)
 export(includeScript)
 export(includeText)
 export(inputPanel)
+export(insertUI)
 export(installExprFunction)
 export(invalidateLater)
 export(is.reactive)
 export(is.reactivevalues)
 export(is.shiny.appobj)
 export(is.singleton)
+export(isTruthy)
 export(isolate)
 export(knit_print.html)
 export(knit_print.reactive)
@@ -119,6 +133,8 @@ export(mainPanel)
 export(makeReactiveBinding)
 export(markRenderFunction)
 export(maskReactiveContext)
+export(modalButton)
+export(modalDialog)
 export(navbarMenu)
 export(navbarPage)
 export(navlistPanel)
@@ -128,7 +144,14 @@ export(ns.sep)
 export(numericInput)
 export(observe)
 export(observeEvent)
+export(onBookmark)
+export(onBookmarked)
+export(onFlush)
+export(onFlushed)
 export(onReactiveDomainEnded)
+export(onRestore)
+export(onRestored)
+export(onSessionEnded)
 export(outputOptions)
 export(p)
 export(pageWithSidebar)
@@ -150,10 +173,14 @@ export(reactiveTable)
 export(reactiveText)
 export(reactiveTimer)
 export(reactiveUI)
+export(reactiveVal)
 export(reactiveValues)
 export(reactiveValuesToList)
 export(registerInputHandler)
 export(removeInputHandler)
+export(removeModal)
+export(removeNotification)
+export(removeUI)
 export(renderDataTable)
 export(renderImage)
 export(renderPlot)
@@ -163,26 +190,34 @@ 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(selectInput)
 export(selectizeInput)
 export(serverInfo)
+export(setBookmarkExclude)
 export(setProgress)
 export(shinyApp)
 export(shinyAppDir)
 export(shinyAppFile)
+export(shinyOptions)
 export(shinyServer)
 export(shinyUI)
+export(showBookmarkUrlModal)
+export(showModal)
+export(showNotification)
 export(showReactLog)
 export(sidebarLayout)
 export(sidebarPanel)
 export(singleton)
 export(sliderInput)
+export(snapshotExclude)
 export(span)
 export(splitLayout)
 export(stopApp)
@@ -199,10 +234,13 @@ export(tagAppendChildren)
 export(tagList)
 export(tagSetChildren)
 export(tags)
+export(textAreaInput)
 export(textInput)
 export(textOutput)
+export(throttle)
 export(titlePanel)
 export(uiOutput)
+export(updateActionButton)
 export(updateCheckboxGroupInput)
 export(updateCheckboxInput)
 export(updateDateInput)
@@ -210,12 +248,15 @@ export(updateDateRangeInput)
 export(updateNavbarPage)
 export(updateNavlistPanel)
 export(updateNumericInput)
+export(updateQueryString)
 export(updateRadioButtons)
 export(updateSelectInput)
 export(updateSelectizeInput)
 export(updateSliderInput)
 export(updateTabsetPanel)
+export(updateTextAreaInput)
 export(updateTextInput)
+export(urlModal)
 export(validate)
 export(validateCssUnit)
 export(verbatimTextOutput)

NEWS

@@ -1,952 +0,0 @@
-shiny 0.13.0
---------------------------------------------------------------------------------
-
-* Fixed #962: plot interactions did not work with the development version of
-  ggplot2 (after ggplot2 1.0.1).
-
-* Fixed #902: the `drag_drop` plugin of the selectize input did not work.
-
-* Fixed #933: `updateSliderInput()` does not work when only the label is
-  updated.
-
-* Multiple imageOutput/plotOutput calls can now share the same brush id. Shiny
-  will ensure that performing a brush operation will clear any other brush with
-  the same id.
-
-* Added `placeholder` option to `textInput`.
-
-* Improved support for Unicode characters on Windows (#968).
-
-* Fixed bug in `selectInput` and `selectizeInput` where values with double
-  quotes were not properly escaped.
-
-* `runApp()` can now take a path to any .R file that yields a `shinyApp` object;
-  previously, the path had to be a directory that contained an app.R file (or
-  server.R if using separately defined server and UI). Similarly, introduced
-  `shinyAppFile()` function which creates a `shinyApp` object for an .R file
-  path, just as `shinyAppDir()` does for a directory path.
-
-* Introduced Shiny Modules, which are designed to 1) simplify the reuse of
-  Shiny UI/server logic and 2) make authoring and maintaining complex Shiny
-  apps much easier. See the article linked from `?callModule`.
-
-* `invalidateLater` and `reactiveTimer` no longer require an explicit `session`
-  argument; the default value uses the current session.
-
-* Added `session$reload()` method, the equivalent of hitting the browser's
-  Reload button.
-
-* Added `shiny.autoreload` option, which will automatically cause browsers to
-  reload whenever Shiny app files change on disk. This is intended to shorten
-  the feedback cycle when tweaking UI code.
-
-* Errors are now printed with stack traces! This should make it tremendously
-  easier to track down the causes of errors in Shiny. Try it by calling
-  `stop("message")` from within an output, reactive, or observer. Shiny itself
-  adds a lot of noise to the call stack, so by default, it attempts to hide all
-  but the relevant levels of the call stack. You can turn off this behavior by
-  setting `options(shiny.fullstacktrace=TRUE)` before or during app startup.
-
-* Fixed #1018: the selected value of a selectize input is guaranteed to be
-  selected in server-side mode.
-
-* Added `req` function, which provides a simple way to prevent a reactive,
-  observer, or output from executing until all required inputs and values are
-  available. (Similar functionality has been available for a while using
-  validate/need, but req provides a much simpler and more direct interface.)
-
-* Improve stability with Shiny Server when many subapps are used, by deferring
-  the loading of subapp iframes until a connection has first been established
-  with the server.
-
-* Upgrade to Font Awesome 4.5.0.
-
-* Upgraded to Bootstrap 3.3.5.
-
-* Switched to an almost-complete build of jQuery UI with the exception of the
-  datepicker extension, which conflicts with Shiny's date picker.
-
-* Added `fillPage` function, an alternative to `fluidPage`, `fixedPage`, etc.
-  that is designed for apps that fill the entire available page width/height.
-
-* Added `fillRow` and `fillCol` functions, for laying out proportional grids in
-  `fillPage`. For modern browsers only.
-
-* Added `runGadget`, `paneViewer`, `dialogViewer`, and `browserViewer`
-  functions to support Shiny Gadgets. More detailed docs about gadgets coming
-  soon.
-
-* Added support for the new htmltools 0.3 feature `htmlTemplate`. It's now
-  possible to use regular HTML markup to design your UI, but still use R
-  expressions to define inputs, outputs, and HTML widgets.
-
-shiny 0.12.2
---------------------------------------------------------------------------------
-
-* GitHub changed URLs for gists from .tar.gz to .zip, so `runGist` was updated
-  to work with the new URLs.
-
-* Callbacks from the session object are now guaranteed to execute in the order
-  in which registration occurred.
-
-* Minor bugs in sliderInput's animation behavior have been fixed. (#852)
-
-* Updated to ion.rangeSlider to 2.0.12.
-
-* Added `shiny.minified` option, which controls whether the minified version
-  of shiny.js is used. Setting it to FALSe can be useful for debugging. (#826,
-  #850)
-
-* Fixed an issue for outputting plots from ggplot objects which also have an
-  additional class whose print method takes precedence over `print.ggplot`.
-  (#840, 841)
-
-* Added `width` option to Shiny's input functions. (#589, #834)
-
-* Added two alias functions of `updateTabsetPanel()` to update the selected tab:
-  `updateNavbarPage()` and `updateNavlistPanel()`. (#881)
-
-* All non-base functions are now explicitly namespaced, to pass checks in
-  R-devel.
-
-* Shiny now correctly handles HTTP HEAD requests. (#876)
-
-shiny 0.12.1
---------------------------------------------------------------------------------
-
-* Fixed an issue where unbindAll() causes subsequent bindAll() to be ignored for
-  previously bound outputs. (#856)
-
-* Undeprecate `dataTableOutput` and `renderDataTable`, which had been deprecated
-  in favor of the new DT package. The DT package is a bit too new and has a
-  slightly different API, we were too hasty in deprecating the existing Shiny
-  functions.
-
-shiny 0.12.0
---------------------------------------------------------------------------------
-
-* Switched from RJSONIO to jsonlite. This improves consistency and speed when
-  converting between R data structures and JSON. One notable change is that
-  POSIXt objects are now serialized to JSON in UTC8601 format (like
-  "2015-03-20T20:00:00Z"), instead of as seconds from the epoch).
-
-* In addition to the existing support for clicking and hovering on plots
-  created by base graphics, added support for double-clicking and brushing.
-  (#769)
-
-* Added support for clicking, hovering, double-clicking, and brushing for
-  plots created by ggplot2, including support for facets. (#802)
-
-* Added `nearPoints` and `brushedPoints` functions for easily selecting rows of
-  data that are clicked/hovered, or brushed. (#802)
-
-* Added `shiny.port` option. If this is option is set, `runApp()` will listen on
-  this port by default. (#756)
-
-* `runUrl`, `runGist`, and `runGitHub` now can save downloaded applications,
-  with the `destdir` argument. (#688)
-
-* Restored ability to set labels for `selectInput`. (#741)
-
-* Travis continuous integration now uses Travis's native R support.
-
-* Fixed encoding issue when the server receives data from the client browser.
-  (#742)
-
-* The `session` object now has class `ShinySession`, making it easier to test
-  whether an object is indeed a session object. (#720, #746)
-
-* Fix JavaScript error when an output appears in nested uiOutputs. (Thanks,
-  Gregory Zhang. #749)
-
-* Eliminate delay on receiving new value when `updateSliderInput(value=...)` is
-  called.
-
-* Updated to DataTables (Javascript library) 1.10.5.
-
-* Fixed downloading of files that have no filename extension. (#575, #753)
-
-* Fixed bug where nested UI outputs broke outputs. (#749, #750)
-
-* Removed unneeded HTML ID attributes for `checkboxGroupInputs` and
-  `radioButtons`. (#684)
-
-* Fixed bug where checkboxes were still active even after `Shiny.unbindAll()`
-  was called. (#206)
-
-* The server side selectize input will load the first 1000 options by default
-  before users start to type and search in the box. (#823)
-
-* renderDataTable() and dataTableOutput() have been deprecated in shiny and will
-  be removed in future versions of shiny. Please use the DT package instead:
-  http://rstudio.github.io/DT/ (#807)
-
-shiny 0.11.1
---------------------------------------------------------------------------------
-
-* Major client-side performance improvements for pages that have many
-  conditionalPanels, tabPanels, and plotOutputs. (#693, #717, #723)
-
-* `tabPanel`s now use the `title` for `value` by default. This fixes a bug
-  in which an icon in the title caused problems with a conditionalPanel's test
-  condition. (#725, #728)
-
-* `selectInput` now has a `size` argument to control the height of the input
-  box. (#729)
-
-* `navbarPage` no longer includes a first row of extra whitespace when
-  `header=NULL`. (#722)
-
-* `selectInput`s now use Bootstrap styling when `selectize=FALSE`. (#724)
-
-* Better vertical spacing of label for checkbox groups and radio buttons.
-
-* `selectInput` correctly uses width for both selectize and non-selectize
-  inputs. (#702)
-
-* The wrapper tag generated by `htmlOutput` and `uiOutput` can now be any type
-  of HTML tag, instead of just span and div. Also, custom classes are now
-  allowed on the tag. (#704)
-
-* Slider problems in IE 11 and Chrome on touchscreen-equipped Windows computers
-  have been fixed. (#700)
-
-* Sliders now work correctly with draggable panels. (#711)
-
-* Fixed arguments in `fixedPanel`. (#709)
-
-* downloadHandler content callback functions are now invoked with a temp file
-  name that has the same extension as the final filename that will be used by
-  the download. This is to deal with the fact that some file writing functions
-  in R will auto-append the extension for their file type (pdf, zip).
-
-shiny 0.11
---------------------------------------------------------------------------------
-
-* Changed sliders from jquery-slider to ion.rangeSlider. These sliders have
-  an improved appearance, support updating more properties from the server,
-  and can be controlled with keyboard input.
-
-* Switched from Bootstrap 2 to Bootstrap 3. For most users, this will work
-  seamlessly, but some users may need to use the shinybootstrap2 package for
-  backward compatibility.
-
-* The UI of a Shiny app can now have a body tag. This is useful for CSS
-  templates that use classes on the body tag.
-
-* `actionButton` and `actionLink` now pass their `...` arguments to the
-  underlying tag function. (#607)
-
-* Added `observeEvent` and `eventReactive` functions for clearer, more concise
-  handling of `actionButton`, plot clicks, and other naturally-imperative
-  inputs.
-
-* Errors that happen in reactives no longer prevent any remaining pending
-  observers from executing. It is also now possible for users to control how
-  errors are handled, with the 'shiny.observer.error' global option. (#603,
-  #604)
-
-* Added an `escape` argument to `renderDataTable()` to escape the HTML entities
-  in the data table for security reasons. This might break tables from previous
-  versions of shiny that use raw HTML in the table content, and the old behavior
-  can be brought back by `escape = FALSE` if you are aware of the security
-  implications. (#627)
-
-* Changed the URI encoding/decoding functions internally to use `encodeURI()`,
-  `encodeURIComponent()`, and `decodeURIComponent()` from the httpuv package
-  instead of `utils::URLencode()` and `utils::URLdecode()`. (#630)
-
-* Shiny's web assets are now minified.
-
-* The default reactive domain is now available in event handler functions. (#669)
-
-* Password input fields can now be used, with `passwordInput()`. (#672)
-
-shiny 0.10.2.2
---------------------------------------------------------------------------------
-
-* Remove use of `rstudio::viewer` in a code example, for R CMD check.
-
-shiny 0.10.2.1
---------------------------------------------------------------------------------
-
-* Changed some examples to use \donttest instead of \dontrun.
-
-shiny 0.10.2
---------------------------------------------------------------------------------
-
-* The minimal version of R required for the shiny package is 3.0.0 now.
-
-* Shiny apps can now consist of a single file, app.R, instead of ui.R and
-  server.R.
-
-* Upgraded DataTables from 1.9.4 to 1.10.2. This might be a breaking change if
-  you have customized the DataTables options in your apps. (More info:
-  https://github.com/rstudio/shiny/pull/558)
-
-* File uploading via `fileInput()` works for Internet Explorer 8 and 9 now. Note
-  IE8/9 do not support multiple files from a single file input. If you need to
-  upload multiple files, you have to use one file input for each file.
-
-* Switched away from reference classes to R6.
-
-* Reactive log performance has been greatly improved.
-
-* Added `Progress` and `withProgress`, to display the progress of computation
-  on the client browser.
-
-* Fixed #557: updateSelectizeInput(choices, server = TRUE) did not work when
-  `choices` is a character vector.
-
-* Searching in DataTables is case-insensitive and the search strings are not
-  treated as regular expressions by default now. If you want case-sensitive
-  searching or regular expressions, you can use the configuration options
-  `search$caseInsensitive` and `search$regex`, e.g. `renderDataTable(...,
-  options = list(search = list(caseInsensitve = FALSE, regex = TRUE)))`.
-
-* Added support for `htmltools::htmlDependency`'s new `attachment` parameter to
-  `renderUI`/`uiOutput`.
-
-* Exported `createWebDependency`. It takes an `htmltools::htmlDependency` object
-  and makes it available over Shiny's built-in web server.
-
-* Custom output bindings can now render `htmltools::htmlDependency` objects at
-  runtime using `Shiny.renderDependencies()`.
-
-* Fixes to rounding behavior of sliderInput. (#301, #502)
-
-* Updated selectize.js to version 0.11.2. (#596)
-* Added `position` parameter to `navbarPage`.
-
-shiny 0.10.1
---------------------------------------------------------------------------------
-
-* Added Unicode support for Windows. Shiny apps running on Windows must use the
-  UTF-8 encoding for ui.R and server.R (also the optional global.R) if they
-  contain non-ASCII characters. See this article for details and examples:
-  http://shiny.rstudio.com/gallery/unicode-characters.html (#516)
-
-* `runGitHub()` also allows the 'username/repo' syntax now, which is equivalent
-  to `runGitHub('repo', 'username')`. (#427)
-
-* `navbarPage()` now accepts a `windowTitle` parameter to set the web browser
-  page title to something other than the title displayed in the navbar.
-
-* Added an `inline` argument to `textOutput()`, `imageOutput()`, `plotOutput()`,
-  and `htmlOutput()`. When `inline = TRUE`, these outputs will be put in
-  `span()` instead of the default `div()`. This occurs automatically when these
-  outputs are created via the inline expressions (e.g. `r renderText(expr)`) in
-  R Markdown documents. See an R Markdown example at
-  http://shiny.rstudio.com/gallery/inline-output.html (#512)
-
-* Added support for option groups in the select/selectize inputs. When the
-  `choices` argument for `selectInput()`/`selectizeInput()` is a list of
-  sub-lists and any sub-list is of length greater than 1, the HTML tag
-  `<optgroup>` will be used. See an example at
-  http://shiny.rstudio.com/gallery/option-groups-for-selectize-input.html (#542)
-
-shiny 0.10.0
---------------------------------------------------------------------------------
-
-* BREAKING CHANGE: By default, observers now terminate themselves if they were
-  created during a session and that session ends. See ?domains for more details.
-
-* Shiny can now be used in R Markdown v2 documents, to create "Shiny Docs":
-  reports and presentations that combine narrative, statically computed output,
-  and fully dynamic inputs and outputs. For more info, including examples, see
-  http://rmarkdown.rstudio.com/authoring_shiny.html.
-
-* The `session` object that can be passed into a server function (e.g.
-  shinyServer(function(input, output, session) {...})) is now documented: see
-  `?session`.
-
-* Most inputs can now accept `NULL` label values to omit the label altogether.
-
-* New `actionLink` input control; like `actionButton`, but with the appearance
-  of a normal link.
-
-* `renderPlot` now calls `print` on its result if it's visible (i.e. no more
-  explicit `print()` required for ggplot2).
-
-* Introduced Shiny app objects (see `?shinyApp`). These essentially replace the
-  little-advertised ability for `runApp` to take a `list(ui=..., server=...)`
-  as the first argument instead of a directory (though that ability remains for
-  backward compatibility). Unlike those lists, Shiny app objects are tagged with
-  class `shiny.appobj` so they can be run simply by printing them.
-
-* Added `maskReactiveContext` function. It blocks the current reactive context,
-  to evaluate expressions that shouldn't use reactive sources directly. (This
-  should not be commonly needed.)
-
-* Added `flowLayout`, `splitLayout`, and `inputPanel` functions for putting UI
-  elements side by side. `flowLayout` lays out its children in a left-to-right,
-  top-to-bottom arrangement. `splitLayout` evenly divides its horizontal space
-  among its children (or unevenly divides if `cellWidths` argument is provided).
-  `inputPanel` is like `flowPanel`, but with a light grey background, and is
-  intended to be used to encapsulate small input controls wherever vertical
-  space is at a premium.
-
-* Added `serverInfo` to obtain info about the Shiny Server if the app is served
-  through it.
-
-* Added an `inline` argument (TRUE/FALSE) in `checkboxGroupInput()` and
-  `radioButtons()` to allow the horizontal layout (inline = TRUE) of checkboxes
-  or radio buttons. (Thanks, @saurfang, #481)
-
-* `sliderInput` and `selectizeInput`/`selectInput` now use a standard horizontal
-  size instead of filling up all available horizontal space. Pass `width="100%"`
-  explicitly for the old behavior.
-
-* Added the `updateSelectizeInput()` function to make it possible to process
-  searching on the server side (i.e. using R), which can be much faster than the
-  client side processing (i.e. using HTML and JavaScript). See the article at
-  http://shiny.rstudio.com/articles/selectize.html for a detailed introduction.
-
-* Fixed a bug of renderDataTable() when the data object only has 1 row and 1
-  column. (Thanks, ZJ Dai, #429)
-
-* `renderPrint` gained a new argument 'width' to control the width of the text
-  output, e.g. renderPrint({mtcars}, width = 40).
-
-* Fixed #220: the zip file for a directory created by some programs may not have
-  the directory name as its first entry, in which case runUrl() can fail. (#220)
-
-* `runGitHub()` can also take a value of the form "username/repo" in its first
-  argument, e.g. both runGitHub("shiny_example", "rstudio") and
-  runGitHub("rstudio/shiny_example") are valid ways to run the GitHub repo.
-
-shiny 0.9.1
---------------------------------------------------------------------------------
-
-* Fixed warning 'Error in Context$new : could not find function "loadMethod"'
-  that was happening to dependent packages on "R CMD check".
-
-shiny 0.9.0
---------------------------------------------------------------------------------
-
-* BREAKING CHANGE: Added a `host` parameter to runApp() and runExample(),
-  which defaults to the shiny.host option if it is non-NULL, or "127.0.0.1"
-  otherwise. This means that by default, Shiny applications can only be
-  accessed on the same machine from which they are served. To allow other
-  clients to connect, as in previous versions of Shiny, use "0.0.0.0"
-  (or the IP address of one of your network interfaces, if you care to be
-  explicit about it).
-
-* Added a new function `selectizeInput()` to use the JavaScript library
-  selectize.js (https://github.com/brianreavis/selectize.js), which extends
-  the basic select input in many aspects.
-
-* The `selectInput()` function also gained a new argument `selectize = TRUE`
-  to makes use of selectize.js by default. If you want to revert back to the
-  original select input, you have to call selectInput(..., selectize = FALSE).
-
-* Added Showcase mode, which displays the R code for an app right in the app
-  itself. You can invoke Showcase mode by passing `display.mode="showcase"`
-  to the `runApp()` function. Or, if an app is designed to run in Showcase
-  mode by default, add a DESCRIPTION file in the app dir with Title, Author,
-  and License fields; with "Type: Shiny"; and with "DisplayMode: Showcase".
-
-* Upgraded to Bootstrap 2.3.2 and jQuery 1.11.0.
-
-* Make `tags$head()` and `singleton()` behave correctly when used with
-  `renderUI()` and `uiOutput()`. Previously, "hoisting content to the head"
-  and "only rendering items a single time" were features that worked only
-  when the page was initially loading, not in dynamic rendering.
-
-* Files are now sourced with the `keep.source` option, to help with debugging
-  and profiling.
-
-* Support user-defined input parsers for data coming in from JavaScript using
-  the parseShinyInput method.
-
-* Fixed the bug #299: renderDataTable() can deal with 0-row data frames now.
-  (reported by Harlan Harris)
-
-* Added `navbarPage()` and `navbarMenu()` functions to create applications
-  with multiple top level panels.
-
-* Added `navlistPanel()` function to create layouts with a a bootstrap
-  navlist on the left and tabPanels on the right
-
-* Added `type` parameter to `tabsetPanel()` to enable the use of pill
-  style tabs in addition to the standard ones.
-
-* Added `position` paramter to `tabsetPanel()` to enable positioning of tabs
-  above, below, left, or right of tab content.
-
-* Added `fluidPage()` and `fixedPage()` functions as well as related row and
-  column layout functions for creating arbitrary bootstrap grid layouts.
-
-* Added `hr()` builder function for creating horizontal rules.
-
-* Automatically concatenate duplicate attributes in tag definitions
-
-* Added `responsive` parameter to page building functions for opting-out of
-  bootstrap responsive css.
-
-* Added `theme` parameter to page building functions for specifying alternate
-  bootstrap css styles.
-
-* Added `icon()` function for embedding icons from the
-  [font awesome](http://fontawesome.io/) icon library
-
-* Added `makeReactiveBinding` function to turn a "regular" variable into a
-  reactive one (i.e. reading the variable makes the current reactive context
-  dependent on it, and setting the variable is a source of reactivity).
-
-* Added a function `withMathJax()` to include the MathJax library in an app.
-
-* The argument `selected` in checkboxGroupInput(), selectInput(), and
-  radioButtons() refers to the value(s) instead of the name(s) of the
-  argument `choices` now. For example, the value of the `selected` argument
-  in selectInput(..., choices = c('Label 1' = 'x1', 'Label 2' = 'x2'),
-  selected = 'Label 2') must be updated to 'x2', although names/labels will
-  be automatically converted to values internally for backward
-  compatibility. The same change applies to updateCheckboxGroupInput(),
-  updateSelectInput(), and updateRadioButtons() as well. (#340)
-
-* Now it is possible to only update the value of a checkbox group, select input,
-  or radio buttons using the `selected` argument without providing the
-  `choices` argument in updateCheckboxGroupInput(), updateSelectInput(), and
-  updateRadioButtons(), respectively. (#340)
-
-* Added `absolutePanel` and `fixedPanel` functions for creating absolute-
-  and fixed-position panels. They can be easily made user-draggable by
-  specifying `draggable = TRUE`.
-
-* For the `options` argument of the function `renderDataTable()`, we can
-  pass literal JavaScript code to the DataTables library via `I()`. This
-  makes it possible to use any JavaScript object in the options, e.g. a
-  JavaScript function (which is not supported in JSON). See
-  `?renderDataTable` for details and examples.
-
-* DataTables also works under IE8 now.
-
-* Fixed a bug in DataTables pagination when searching is turned on, which
-  caused failures for matrices as well as empty rows when displaying data
-  frames using renderDataTable().
-
-* The `options` argument in `renderDataTable()` can also take a function
-  that returns a list. This makes it possible to use reactive values in the
-  options. (#392)
-
-* `renderDataTable()` respects more DataTables options now: (1) either
-  bPaginate = FALSE or iDisplayLength = -1 will disable pagination (i.e. all
-  rows are returned from the data); besides, this means we can also use -1
-  in the length menu, e.g. aLengthMenu = list(c(10, 30, -1), list(10, 30,
-  'All')); (2) we can disable searching for individual columns through the
-  bSearchable option, e.g. aoColumns = list(list(bSearchable = FALSE),
-  list(bSearchable = TRUE),...) (the search box for the first column is
-  hidden); (3) we can turn off searching entirely (for both global searching
-  and individual columns) using the option bFilter = FALSE.
-
-* Added an argument `callback` in `renderDataTable()` so that a custom
-  JavaScript function can be applied to the DataTable object. This makes it
-  much easier to use DataTables plug-ins.
-
-* For numeric columns in a DataTable, the search boxes support lower and
-  upper bounds now: a search query of the form "lower,upper" (without
-  quotes) indicates the limits [lower, upper]. For a column X, this means
-  the rows corresponding to X >= lower & X <= upper are returned. If we omit
-  either the lower limit or the upper limit, only the other limit will be
-  used, e.g. ",upper" means X <= upper.
-
-* `updateNumericInput(value)` tries to preserve numeric precision by avoiding
-  scientific notation when possible, e.g. 102145 is no longer rounded to
-  1.0214e+05 = 102140. (Thanks, Martin Loos. #401)
-
-* `sliderInput()` no longer treats a label wrapped in HTML() as plain text,
-  e.g. the label in sliderInput(..., label = HTML('<em>A Label</em>')) will
-  not be escaped any more. (#119)
-
-* Fixed #306: the trailing slash in a path could fail `addResourcePath()`
-  under Windows. (Thanks, ZJ Dai)
-
-* Dots are now legal characters for inputId/outputId. (Thanks, Kevin
-  Lindquist. #358)
-
-shiny 0.8.0
---------------------------------------------------------------------------------
-
-* Debug hooks are registered on all user-provided functions and (reactive)
-  expressions (e.g., in renderPlot()), which makes it possible to set
-  breakpoints in these functions using the latest version of the RStudio
-  IDE, and the RStudio visual debugging tools can be used to debug Shiny
-  apps. Internally, the registration is done via installExprFunction(),
-  which is a new function introduced in this version to replace
-  exprToFunction() so that the registration can be automatically done.
-
-* Added a new function renderDataTable() to display tables using the
-  JavaScript library DataTables. It includes basic features like pagination,
-  searching (global search or search by individual columns), sorting (by
-  single or multiple columns). All these features are implemented on the R
-  side; for example, we can use R regular expressions for searching.
-  Besides, it also uses the Bootstrap CSS style. See the full
-  documentation and examples in the tutorial:
-  http://rstudio.github.io/shiny/tutorial/#datatables
-
-* Added a new option `shiny.error` which can take a function as an error
-  handler. It is called when an error occurs in an app (in user-provided
-  code), e.g., after we set options(shiny.error = recover), we can enter a
-  specified environment in the call stack to debug our code after an error
-  occurs.
-
-* The argument `launch.browser` in runApp() can also be a function,
-  which takes the URL of the shiny app as its input value.
-
-* runApp() uses a random port between 3000 and 8000 instead of 8100 now. It
-  will try up to 20 ports in case certain ports are not available.
-
-* Fixed a bug for conditional panels: the value `input.id` in the condition
-  was not correctly retrieved when the input widget had a type, such as
-  numericInput(). (reported by Jason Bryer)
-
-* Fixed two bugs in plotOutput(); clickId and hoverId did not give correct
-  coordinates in Firefox, or when the axis limits of the plot were changed.
-  (reported by Chris Warth and Greg D)
-
-* The minimal required version for the httpuv package was increased to 1.2
-  (on CRAN now).
-
-
-shiny 0.7.0
---------------------------------------------------------------------------------
-
-* Stopped sending websocket subprotocol. This fixes a compatibility issue with
-  Google Chrome 30.
-
-* The `input` and `output` objects are now also accessible via `session$input`
-  and `session$output`.
-
-* Added click and hover events for static plots; see `?plotOutput` for details.
-
-* Added optional logging of the execution states of a reactive program, and
-  tools for visualizing the log data. To use, start a new R session and call
-  `options(shiny.reactlog=TRUE)`. Then launch a Shiny app and interact with it.
-  Press Ctrl+F3 (or for Mac, Cmd+F3) in the browser to launch an interactive
-  visualization of the reactivity that has occurred. See `?showReactLog` for
-  more information.
-
-* Added `includeScript()` and `includeCSS()` functions.
-
-* Reactive expressions now have class="reactive" attribute. Also added
-  `is.reactive()` and `is.reactivevalues()` functions.
-
-* New `stopApp()` function, which stops an app and returns a value to the caller
-  of `runApp()`.
-
-* Added the `shiny.usecairo` option, which can be used to tell Shiny not to use
-  Cairo for PNG output even when it is installed. (Defaults to `TRUE`.)
-
-* Speed increases for `selectInput()` and `radioButtons()`, and their
-  corresponding updater functions, for when they have many options.
-
-* Added `tagSetChildren()` and `tagAppendChildren()` functions.
-
-* The HTTP request object that created the websocket is now accessible from the
-  `session` object, as `session$request`. This is a Rook-like request
-  environment that can be used to access HTTP headers, among other things.
-  (Note: When running in a Shiny Server environment, the request will reflect
-  the proxy HTTP request that was made from the Shiny Server process to the R
-  process, not the request that was made from the web browser to Shiny Server.)
-
-* Fix `getComputedStyle` issue, for IE8 browser compatibility (#196). Note:
-  Shiny Server is still required for IE8/9 compatibility.
-
-* Add shiny.sharedSecret option, to require the HTTP header Shiny-Shared-Secret
-  to be set to the given value.
-
-shiny 0.6.0
---------------------------------------------------------------------------------
-
-* `tabsetPanel()` can be directed to start with a specific tab selected.
-
-* Fix bug where multiple file uploads with 3 or more files result in incorrect
-  data.
-
-* Add `withTags()` function.
-
-* Add dateInput and dateRangeInput.
-
-* `shinyServer()` now takes an optional `session` argument, which is used for
-  communication with the session object.
-
-* Add functions to update values of existing inputs on a page, instead of
-  replacing them entirely.
-
-* Allow listening on domain sockets.
-
-* Added `actionButton()` to Shiny.
-
-* The server can now send custom JSON messages to the client. On the client
-  side, functions can be registered to handle these messages.
-
-* Callbacks can be registered to be called at the end of a client session.
-
-* Add ability to set priority of observers and outputs. Each priority level
-  gets its own queue.
-
-* Fix bug where the presence of a submit button would prevent sending of
-  metadata until the button was clicked.
-
-* `reactiveTimer()` and `invalidateLater()` by default no longer invalidate
-  reactive objects after the client session has closed.
-
-* Shiny apps can be run without a server.r and ui.r file.
-
-shiny 0.5.0
---------------------------------------------------------------------------------
-
-* Switch from websockets package for handling websocket connections to httpuv.
-
-* New method for detecting hidden output objects. Instead of checking that
-  height and width are 0, it checks that the object or any ancestor in the DOM
-  has style display:none.
-
-* Add `clientData` reactive values object, which carries information about the
-  client. This includes the hidden status of output objects, height/width plot
-  output objects, and the URL of the browser.
-
-* Add `parseQueryString()` function.
-
-* Add `renderImage()` function for sending arbitrary image files to the client,
-  and its counterpart, `imageOutput()`.
-
-* Add support for high-resolution (Retina) displays.
-
-* Fix bug #55, where `renderTable()` would throw error with an empty data frame.
-
-shiny 0.4.1
---------------------------------------------------------------------------------
-
-* Fix bug where width and height weren't passed along properly from
-  `reactivePlot` to `renderPlot`.
-
-* Fix bug where infinite recursion would happen when `reactivePlot` was passed
-  a function for width or height.
-
-shiny 0.4.0
---------------------------------------------------------------------------------
-
-* Added suspend/resume capability to observers.
-
-* Output objects are automatically suspended when they are hidden on the user's
-  web browser.
-
-* `runGist()` accepts GitHub's new URL format, which includes the username.
-
-* `reactive()` and `observe()` now take expressions instead of functions.
-
-* `reactiveText()`, `reactivePlot()`, and so on, have been renamed to
-  `renderText()`, `renderPlot()`, etc.  They also now take expressions instead
-  of functions.
-
-* Fixed a bug where empty values in a numericInput were sent to the R process
-  as 0. They are now sent as NA.
-
-shiny 0.3.1
---------------------------------------------------------------------------------
-
-* Fix issue #91: bug where downloading files did not work.
-
-* Add [[<- operator for shinyoutput object, making it possible to assign values
-  with `output[['plot1']] <- ...`.
-
-* Reactive functions now preserve the visible/invisible state of their returned
-  values.
-
-shiny 0.3.0
---------------------------------------------------------------------------------
-
-* Reactive functions are now evaluated lazily.
-
-* Add `reactiveValues()`.
-
-* Using `as.list()` to convert a reactivevalues object (like `input`) to a list
-  is deprecated. The new function `reactiveValuesToList()` should be used
-  instead.
-
-* Add `isolate()`. This function is used for accessing reactive functions,
-  without them invalidating their parent contexts.
-
-* Fix issue #58: bug where reactive functions are not re-run when all items in
-  a checkboxGroup are unchecked.
-
-* Fix issue #71, where `reactiveTable()` would return blank if the first
-  element of a data frame was NA.
-
-* In `plotOutput`, better validation for CSS units when specifying width and
-  height.
-
-* `reactivePrint()` no longer displays invisible output.
-
-* `reactiveText()` no longer displays printed output, only the return value
-  from a function.
-
-* The `runGitHub()` and `runUrl()` functions have been added, for running
-  Shiny apps from GitHub repositories and zip/tar files at remote URLs.
-
-* Fix issue #64, where pressing Enter in a textbox would cause a form to
-  submit.
-
-shiny 0.2.4
---------------------------------------------------------------------------------
-
-* `runGist` has been updated to use the new download URLs from
-  https://gist.github.com.
-
-* Shiny now uses `CairoPNG()` for output, when the Cairo package is available.
-  This provides better-looking output on Linux and Windows.
-
-shiny 0.2.3
---------------------------------------------------------------------------------
-
-* Ignore request variables for routing purposes
-
-shiny 0.2.2
---------------------------------------------------------------------------------
-
-* Fix CRAN warning (assigning to global environment)
-
-
-shiny 0.2.1
---------------------------------------------------------------------------------
-
-* [BREAKING] Modify API of `downloadHandler`: The `content` function now takes
-  a file path, not writable connection, as an argument. This makes it much
-  easier to work with APIs that only write to file paths, not connections.
-
-
-shiny 0.2.0
---------------------------------------------------------------------------------
-
-* Fix subtle name resolution bug--the usual symptom being S4 methods not being
-  invoked correctly when called from inside of ui.R or server.R
-
-
-shiny 0.1.14
---------------------------------------------------------------------------------
-
-* Fix slider animator, which broke in 0.1.10
-
-
-shiny 0.1.13
---------------------------------------------------------------------------------
-
-* Fix temp file leak in reactivePlot
-
-
-shiny 0.1.12
---------------------------------------------------------------------------------
-
-* Fix problems with runGist on Windows
-* Add feature for on-the-fly file downloads (e.g. CSV data, PDFs)
-* Add CSS hooks for app-wide busy indicators
-
-
-shiny 0.1.11
---------------------------------------------------------------------------------
-
-* Fix input binding with IE8 on Shiny Server
-* Fix issue #41: reactiveTable should allow print options too
-* Allow dynamic sizing of reactivePlot (i.e. using a function instead of a fixed
-  value)
-
-
-shiny 0.1.10
---------------------------------------------------------------------------------
-
-* Support more MIME types when serving out of www
-* Fix issue #35: Allow modification of untar args
-* headerPanel can take an explicit window title parameter
-* checkboxInput uses correct attribute `checked` instead of `selected`
-* Fix plot rendering with IE8 on Shiny Server
-
-
-shiny 0.1.9
---------------------------------------------------------------------------------
-
-* Much less flicker when updating plots
-* More customizable error display
-* Add `includeText`, `includeHTML`, and `includeMarkdown` functions for putting
-  text, HTML, and Markdown content from external files in the application's UI.
-
-
-shiny 0.1.8
---------------------------------------------------------------------------------
-
-* Add `runGist` function for conveniently running a Shiny app that is published
-  on gist.github.com.
-* Fix issue #27: Warnings cause reactive functions to stop executing.
-* The server.R and ui.R filenames are now case insensitive.
-* Add `wellPanel` function for creating inset areas on the page.
-* Add `bootstrapPage` function for creating new Bootstrap based
-  layouts from scratch.
-
-
-shiny 0.1.7
---------------------------------------------------------------------------------
-
-* Fix issue #26: Shiny.OutputBindings not correctly exported.
-* Add `repeatable` function for making easily repeatable versions of random
-  number generating functions.
-* Transcode JSON into UTF-8 (prevents non-ASCII reactivePrint values from
-  causing errors on Windows).
-
-
-shiny 0.1.6
---------------------------------------------------------------------------------
-
-* Import package dependencies, instead of attaching them (with the exception of
-  websockets, which doesn't currently work unless attached).
-* conditionalPanel was animated, now it is not.
-* bindAll was not correctly sending initial values to the server; fixed.
-
-
-shiny 0.1.5
---------------------------------------------------------------------------------
-
-* BREAKING CHANGE: JS APIs Shiny.bindInput and Shiny.bindOutput removed and
-  replaced with Shiny.bindAll; Shiny.unbindInput and Shiny.unbindOutput removed
-  and replaced with Shiny.unbindAll.
-* Add file upload support (currently only works with Chrome and Firefox). Use
-  a normal HTML file input, or call the `fileInput` UI function.
-* Shiny.unbindOutputs did not work, now it does.
-* Generally improved robustness of dynamic input/output bindings.
-* Add conditionalPanel UI function to allow showing/hiding UI based on a JS
-  expression; for example, whether an input is a particular value. Also works in
-  raw HTML (add the `data-display-if` attribute to the element that should be
-  shown/hidden).
-* htmlOutput (CSS class `shiny-html-output`) can contain inputs and outputs.
-
-
-shiny 0.1.4
---------------------------------------------------------------------------------
-
-* Allow Bootstrap tabsets to act as reactive inputs; their value indicates which
-  tab is active
-* Upgrade to Bootstrap 2.1
-* Add `checkboxGroupInput` control, which presents a list of checkboxes and
-  returns a vector of the selected values
-* Add `addResourcePath`, intended for reusable component authors to access CSS,
-  JavaScript, image files, etc. from their package directories
-* Add Shiny.bindInputs(scope), .unbindInputs(scope), .bindOutputs(scope), and
-  .unbindOutputs(scope) JS API calls to allow dynamic binding/unbinding of HTML
-  elements
-
-
-shiny 0.1.3
---------------------------------------------------------------------------------
-
-* Introduce Shiny.inputBindings.register JS API and InputBinding class, for
-  creating custom input controls
-* Add `step` parameter to numericInput
-* Read names of input using `names(input)`
-* Access snapshot of input as a list using `as.list(input)`
-* Fix issue #10: Plots in tabsets not rendered
-
-
-shiny 0.1.2
---------------------------------------------------------------------------------
-
-Initial private beta release!

R/app.R

@@ -20,19 +20,29 @@
 #' @param onStart A function that will be called before the app is actually run.
 #'   This is only needed for \code{shinyAppObj}, since in the \code{shinyAppDir}
 #'   case, a \code{global.R} file can be used for this purpose.
-#' @param options Named options that should be passed to the `runApp` call. You
-#'   can also specify \code{width} and \code{height} parameters which provide a
-#'   hint to the embedding environment about the ideal height/width for the app.
+#' @param options Named options that should be passed to the \code{runApp} call
+#'   (these can be any of the following: "port", "launch.browser", "host", "quiet",
+#'   "display.mode" and "test.mode"). You can also specify \code{width} and
+#'   \code{height} parameters which provide a hint to the embedding environment
+#'   about the ideal height/width for the app.
 #' @param uiPattern A regular expression that will be applied to each \code{GET}
 #'   request to determine whether the \code{ui} should be used to handle the
 #'   request. Note that the entire request path must match the regular
 #'   expression in order for the match to be considered successful.
+#' @param enableBookmarking Can be one of \code{"url"}, \code{"server"}, or
+#'   \code{"disable"}. This is equivalent to calling the
+#'   \code{\link{enableBookmarking}()} function just before calling
+#'   \code{shinyApp()}. With the default value (\code{NULL}), the app will
+#'   respect the setting from any previous calls to \code{enableBookmarking()}.
+#'   See \code{\link{enableBookmarking}} for more information.
 #' @return An object that represents the app. Printing the object or passing it
 #'   to \code{\link{runApp}} will run the app.
 #'
 #' @examples
 #' ## Only run this example in interactive R sessions
 #' if (interactive()) {
+#'   options(device.ask.default = FALSE)
+#'
 #'   shinyApp(
 #'     ui = fluidPage(
 #'       numericInput("n", "n", 1),
@@ -59,10 +69,9 @@
 #'
 #'   runApp(app)
 #' }
-#'
 #' @export
 shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
-                     uiPattern="/") {
+                     uiPattern="/", enableBookmarking = NULL) {
   if (is.null(server)) {
     stop("`server` missing from shinyApp")
   }
@@ -76,12 +85,24 @@ shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
     server
   }
 
+  if (!is.null(enableBookmarking)) {
+    bookmarkStore <- match.arg(enableBookmarking, c("url", "server", "disable"))
+    enableBookmarking(bookmarkStore)
+  }
+
+  # Store the appDir and bookmarking-related options, so that we can read them
+  # from within the app.
+  shinyOptions(appDir = getwd())
+  appOptions <- consumeAppOptions()
+
   structure(
     list(
       httpHandler = httpHandler,
       serverFuncSource = serverFuncSource,
       onStart = onStart,
-      options = options),
+      options = options,
+      appOptions = appOptions
+    ),
     class = "shiny.appobj"
   )
 }
@@ -113,7 +134,9 @@ 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)
+
+  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)
@@ -178,6 +201,8 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
     }
   }
 
+  shinyOptions(appDir = appDir)
+
   oldwd <- NULL
   monitorHandle <- NULL
   onStart <- function() {
@@ -199,7 +224,8 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
       serverFuncSource = serverFuncSource,
       onStart = onStart,
       onEnd = onEnd,
-      options = options),
+      options = options
+    ),
     class = "shiny.appobj"
   )
 }
@@ -209,13 +235,13 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
 # ignored when checking extensions. If any changes are detected, all connected
 # Shiny sessions are reloaded.
 #
-# Use option(shiny.autoreload = TRUE) to enable this behavior. Since monitoring
+# Use options(shiny.autoreload = TRUE) to enable this behavior. Since monitoring
 # for changes is expensive (we are polling for mtimes here, nothing fancy) this
 # feature is intended only for development.
 #
 # You can customize the file patterns Shiny will monitor by setting the
 # shiny.autoreload.pattern option. For example, to monitor only ui.R:
-# option(shiny.autoreload.pattern = glob2rx("ui.R"))
+# options(shiny.autoreload.pattern = glob2rx("ui.R"))
 #
 # The return value is a function that halts monitoring when called.
 initAutoReloadMonitor <- function(dir) {
@@ -252,7 +278,8 @@ initAutoReloadMonitor <- function(dir) {
 
 # This reads in an app dir for a single-file application (e.g. app.R), and
 # returns a shiny.appobj.
-shinyAppDir_appR <- function(fileName, appDir, options=list()) {
+shinyAppDir_appR <- function(fileName, appDir, options=list())
+{
   fullpath <- file.path.ci(appDir, fileName)
 
   # This sources app.R and caches the content. When appObj() is called but
@@ -265,6 +292,8 @@ shinyAppDir_appR <- function(fileName, appDir, options=list()) {
       if (!is.shiny.appobj(result))
         stop("app.R did not return a shiny.appobj object.")
 
+      unconsumeAppOptions(result$appOptions)
+
       return(result)
     }
   )
@@ -348,7 +377,8 @@ is.shiny.appobj <- function(x) {
 print.shiny.appobj <- function(x, ...) {
   opts <- x$options %OR% list()
   opts <- opts[names(opts) %in%
-      c("port", "launch.browser", "host", "quiet", "display.mode")]
+      c("port", "launch.browser", "host", "quiet",
+        "display.mode", "test.mode")]
 
   args <- c(list(x), opts)
 

R/bookmark-state-local.R

@@ -0,0 +1,28 @@
+# Function wrappers for saving and restoring state to/from disk 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.
+
+saveInterfaceLocal <- function(id, callback) {
+  # Try to save in app directory
+  appDir <- getShinyOption("appDir", default = getwd())
+
+  stateDir <- file.path(appDir, "shiny_bookmarks", id)
+  if (!dirExists(stateDir))
+    dir.create(stateDir, recursive = TRUE)
+
+  callback(stateDir)
+}
+
+loadInterfaceLocal <- function(id, callback) {
+  # Try to load from app directory
+  appDir <- getShinyOption("appDir", default = getwd())
+
+  stateDir <- file.path(appDir, "shiny_bookmarks", id)
+  callback(stateDir)
+}

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,12 @@ titlePanel <- function(title, windowTitle=title) {
 #'   layout.
 #'
 #' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#' options(device.ask.default = FALSE)
+#'
 #' # Define UI
-#' shinyUI(fluidPage(
+#' ui <- fluidPage(
 #'
 #'   # Application title
 #'   titlePanel("Hello Shiny!"),
@@ -248,8 +301,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 +349,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 +387,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()) {
 
@@ -346,7 +419,6 @@ flowLayout <- function(..., cellArgs = list()) {
 #' suitable for wrapping inputs.
 #'
 #' @param ... Input controls or other HTML elements.
-#'
 #' @export
 inputPanel <- function(...) {
   div(class = "shiny-input-panel",
@@ -369,21 +441,34 @@ inputPanel <- function(...) {
 #'   of the layout.
 #'
 #' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#' options(device.ask.default = FALSE)
+#'
+#' # 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 +476,8 @@ inputPanel <- function(...) {
 #'   plotOutput("plot2"),
 #'   plotOutput("plot3")
 #' )
+#' shinyApp(ui, server)
+#' }
 #' @export
 splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
 
@@ -460,10 +547,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 +567,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)
@@ -525,6 +608,8 @@ flexfill <- function(..., direction, flex, width = width, height = height) {
       display = "-webkit-flex",
       display = "-ms-flexbox",
       display = "flex",
+      .webkit.flex.direction = direction,
+      .ms.flex.direction = direction,
       flex.direction = direction,
       width = validateCssUnit(width),
       height = validateCssUnit(height)

R/bootstrap.R

@@ -25,7 +25,6 @@ NULL
 #'   \code{\link{fluidPage}} function instead.
 #'
 #' @seealso \code{\link{fluidPage}}, \code{\link{fixedPage}}
-#'
 #' @export
 bootstrapPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
 
@@ -43,7 +42,7 @@ bootstrapPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
       # remainder of tags passed to the function
       list(...)
     ),
-    bootstrapDependency()
+    bootstrapLib()
   )
 }
 
@@ -61,11 +60,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.7",
     c(
       href = "shared/bootstrap",
       file = system.file("www/shared/bootstrap", package = "shiny")
@@ -157,7 +152,6 @@ basicPage <- function(...) {
 #'     div(style = "background-color: blue; width: 100%; height: 100%;")
 #'   )
 #' )
-#'
 #' @export
 fillPage <- function(..., padding = 0, title = NULL, bootstrap = TRUE,
   theme = NULL) {
@@ -200,7 +194,7 @@ collapseSizes <- function(padding) {
 #'
 #' @examples
 #' # Define UI
-#' shinyUI(pageWithSidebar(
+#' pageWithSidebar(
 #'
 #'   # Application title
 #'   headerPanel("Hello Shiny!"),
@@ -218,8 +212,7 @@ collapseSizes <- function(padding) {
 #'   mainPanel(
 #'     plotOutput("distPlot")
 #'   )
-#' ))
-#'
+#' )
 #' @export
 pageWithSidebar <- function(headerPanel,
                             sidebarPanel,
@@ -246,18 +239,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 +288,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,
@@ -333,14 +335,25 @@ navbarPage <- function(title,
   if (inverse)
     navbarClass <- paste(navbarClass, "navbar-inverse")
 
+  if (!is.null(id))
+    selected <- restoreInput(id = id, default = selected)
+
   # build the tabset
   tabs <- list(...)
-  tabset <- buildTabset(tabs, "nav navbar-nav", NULL, id)
+  tabset <- buildTabset(tabs, "nav navbar-nav", NULL, id, selected)
+
+  # function to return plain or fluid class name
+  className <- function(name) {
+    if (fluid)
+      paste(name, "-fluid", sep="")
+    else
+      name
+  }
 
   # built the container div dynamically to support optional collapsibility
   if (collapsible) {
     navId <- paste("navbar-collapse-", p_randomInt(1000, 10000), sep="")
-    containerDiv <- div(class="container",
+    containerDiv <- div(class=className("container"),
       div(class="navbar-header",
         tags$button(type="button", class="navbar-toggle collapsed",
           `data-toggle`="collapse", `data-target`=paste0("#", navId),
@@ -354,7 +367,7 @@ navbarPage <- function(title,
       div(class="navbar-collapse collapse", id=navId, tabset$navList)
     )
   } else {
-    containerDiv <- div(class="container",
+    containerDiv <- div(class=className("container"),
       div(class="navbar-header",
         span(class="navbar-brand", pageTitle)
       ),
@@ -362,14 +375,6 @@ navbarPage <- function(title,
     )
   }
 
-  # function to return plain or fluid class name
-  className <- function(name) {
-    if (fluid)
-      paste(name, "-fluid", sep="")
-    else
-      name
-  }
-
   # build the main tab content div
   contentDiv <- div(class=className("container"))
   if (!is.null(header))
@@ -425,7 +430,6 @@ headerPanel <- function(title, windowTitle=title) {
 #'
 #' @param ... UI elements to include inside the panel.
 #' @return The newly created panel.
-#'
 #' @export
 wellPanel <- function(...) {
   div(class="well", ...)
@@ -529,7 +533,6 @@ mainPanel <- function(..., width = 8) {
 #'       )
 #'    )
 #' )
-#'
 #' @export
 conditionalPanel <- function(condition, ...) {
   div('data-display-if'=condition, ...)
@@ -602,10 +605,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 +626,28 @@ 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")
+  }
+
+  if (!is.null(id))
+    selected <- restoreInput(id = id, default = selected)
 
   # 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 +678,7 @@ tabsetPanel <- function(...,
 #'
 #' @seealso \code{\link{tabPanel}}, \code{\link{updateNavlistPanel}}
 #' @examples
-#' shinyUI(fluidPage(
+#' fluidPage(
 #'
 #'   titlePanel("Application Title"),
 #'
@@ -684,7 +688,7 @@ tabsetPanel <- function(...,
 #'     tabPanel("Second"),
 #'     tabPanel("Third")
 #'   )
-#' ))
+#' )
 #' @export
 navlistPanel <- function(...,
                          id = NULL,
@@ -698,6 +702,9 @@ navlistPanel <- function(...,
       tags$li(class="navbar-brand", text)
   }
 
+  if (!is.null(id))
+    selected <- restoreInput(id = id, default = selected)
+
   # build the tabset
   tabs <- list(...)
   tabset <- buildTabset(tabs,
@@ -720,117 +727,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)
 }
 
 
@@ -857,21 +935,34 @@ textOutput <- function(outputId, container = if (inline) span else div, inline =
 #' Render a reactive output variable as verbatim text within an
 #' application page. The text will be included within an HTML \code{pre} tag.
 #' @param outputId output variable to read the value from
+#' @param placeholder if the output is empty or \code{NULL}, should an empty
+#'   rectangle be displayed to serve as a placeholder? (does not affect
+#'   behavior when the the output in nonempty)
 #' @return A verbatim text output element that can be included in a panel
 #' @details Text is HTML-escaped prior to rendering. This element is often used
-#' with the \link{renderPrint} function to preserve fixed-width formatting
-#' of printed objects.
+#'   with the \link{renderPrint} function to preserve fixed-width formatting
+#'   of printed objects.
 #' @examples
-#' mainPanel(
-#'   h4("Summary"),
-#'   verbatimTextOutput("summary"),
-#'
-#'   h4("Observations"),
-#'   tableOutput("view")
-#' )
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'   shinyApp(
+#'     ui = basicPage(
+#'       textInput("txt", "Enter the text to display below:"),
+#'       verbatimTextOutput("default"),
+#'       verbatimTextOutput("placeholder", placeholder = TRUE)
+#'     ),
+#'     server = function(input, output) {
+#'       output$default <- renderText({ input$txt })
+#'       output$placeholder <- renderText({ input$txt })
+#'     }
+#'   )
+#' }
 #' @export
-verbatimTextOutput <- function(outputId) {
-  textOutput(outputId, container = pre)
+verbatimTextOutput <- function(outputId, placeholder = FALSE) {
+  pre(id = outputId,
+      class = paste(c("shiny-text-output", if (!placeholder) "noplaceholder"),
+                    collapse = " ")
+      )
 }
 
 
@@ -1045,7 +1136,7 @@ imageOutput <- function(outputId, width = "100%", height="400px",
 #'   same \code{id} to disappear.
 #' @inheritParams textOutput
 #' @note The arguments \code{clickId} and \code{hoverId} only work for R base
-#'   graphics (see the \pkg{\link{graphics}} package). They do not work for
+#'   graphics (see the \pkg{\link[graphics:graphics-package]{graphics}} package). They do not work for
 #'   \pkg{\link[grid:grid-package]{grid}}-based graphics, such as \pkg{ggplot2},
 #'   \pkg{lattice}, and so on.
 #'
@@ -1343,6 +1434,7 @@ uiOutput <- htmlOutput
 #'   is assigned to.
 #' @param label The label that should appear on the button.
 #' @param class Additional CSS classes to apply to the tag, if any.
+#' @param ... Other arguments to pass to the container tag function.
 #'
 #' @examples
 #' \dontrun{
@@ -1361,27 +1453,29 @@ uiOutput <- htmlOutput
 #' }
 #'
 #' @aliases downloadLink
-#' @seealso downloadHandler
+#' @seealso \code{\link{downloadHandler}}
 #' @export
 downloadButton <- function(outputId,
                            label="Download",
-                           class=NULL) {
+                           class=NULL, ...) {
   aTag <- tags$a(id=outputId,
                  class=paste('btn btn-default shiny-download-link', class),
                  href='',
                  target='_blank',
+                 download=NA,
                  icon("download"),
-                 label)
+                 label, ...)
 }
 
 #' @rdname downloadButton
 #' @export
-downloadLink <- function(outputId, label="Download", class=NULL) {
+downloadLink <- function(outputId, label="Download", class=NULL, ...) {
   tags$a(id=outputId,
          class=paste(c('shiny-download-link', class), collapse=" "),
          href='',
          target='_blank',
-         label)
+         download=NA,
+         label, ...)
 }
 
 
@@ -1417,12 +1511,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") {
   prefixes <- list(
@@ -1450,7 +1543,7 @@ icon <- function(name, class = NULL, lib = "font-awesome") {
   # font-awesome needs an additional dependency (glyphicon is in bootstrap)
   if (lib == "font-awesome") {
     htmlDependencies(iconTag) <- htmlDependency(
-      "font-awesome", "4.5.0", c(href="shared/font-awesome"),
+      "font-awesome", "4.7.0", c(href="shared/font-awesome"),
       stylesheet = "css/font-awesome.min.css"
     )
   }

R/conditions.R

@@ -76,7 +76,7 @@ getCallNames <- function(calls) {
 }
 
 getLocs <- function(calls) {
-  sapply(calls, function(call) {
+  vapply(calls, function(call) {
     srcref <- attr(call, "srcref", exact = TRUE)
     if (!is.null(srcref)) {
       srcfile <- attr(srcref, "srcfile", exact = TRUE)
@@ -86,7 +86,7 @@ getLocs <- function(calls) {
       }
     }
     return("")
-  })
+  }, character(1))
 }
 
 #' @details \code{captureStackTraces} runs the given \code{expr} and if any
@@ -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/fileupload.R

@@ -94,7 +94,7 @@ FileUploadContext <- R6Class(
     },
     createUploadOperation = function(fileInfos) {
       while (TRUE) {
-        id <- paste(as.raw(p_runif(12, min=0, max=0xFF)), collapse='')
+        id <- createUniqueId(12)
         private$ids <- c(private$ids, id)
         dir <- file.path(private$basedir, id)
         if (!dir.create(dir))

R/graph.R

@@ -41,12 +41,14 @@ 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 +57,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/history.R

@@ -0,0 +1,95 @@
+
+#' @include reactive-domains.R
+NULL
+
+#' @include reactives.R
+NULL
+
+#' Get the query string / hash component from the URL
+#'
+#' Two user friendly wrappers for getting the query string and the hash
+#' component from the app's URL.
+#'
+#' These can be particularly useful if you want to display different content
+#' depending on the values in the query string / hash (e.g. instead of basing
+#' the conditional on an input or a calculated reactive, you can base it on the
+#' query string). However, note that, if you're changing the query string / hash
+#' programatically from within the server code, you must use
+#' \code{updateQueryString(_yourNewQueryString_, mode = "push")}. The default
+#' \code{mode} for \code{updateQueryString} is \code{"replace"}, which doesn't
+#' raise any events, so any observers or reactives that depend on it will
+#' \emph{not} get triggered. However, if you're changing the query string / hash
+#' directly by typing directly in the browser and hitting enter, you don't have
+#' to worry about this.
+#'
+#' @param session	A Shiny session object.
+#'
+#' @return For \code{getQueryString}, a named list. For example, the query
+#'   string \code{?param1=value1&param2=value2} becomes \code{list(param1 =
+#'   value1, param2 = value2)}. For \code{getUrlHash}, a character vector with
+#'   the hash (including the leading \code{#} symbol).
+#'
+#' @seealso \code{\link{updateQueryString}}
+#'
+#' @examples
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'
+#'   ## App 1: getQueryString
+#'   ## Printing the value of the query string
+#'   ## (Use the back and forward buttons to see how the browser
+#'   ## keeps a record of each state)
+#'   shinyApp(
+#'     ui = fluidPage(
+#'       textInput("txt", "Enter new query string"),
+#'       helpText("Format: ?param1=val1&param2=val2"),
+#'       actionButton("go", "Update"),
+#'       hr(),
+#'       verbatimTextOutput("query")
+#'     ),
+#'     server = function(input, output, session) {
+#'       observeEvent(input$go, {
+#'         updateQueryString(input$txt, mode = "push")
+#'       })
+#'       output$query <- renderText({
+#'         query <- getQueryString()
+#'         queryText <- paste(names(query), query,
+#'                        sep = "=", collapse=", ")
+#'         paste("Your query string is:\n", queryText)
+#'       })
+#'     }
+#'   )
+#'
+#'   ## App 2: getUrlHash
+#'   ## Printing the value of the URL hash
+#'   ## (Use the back and forward buttons to see how the browser
+#'   ## keeps a record of each state)
+#'   shinyApp(
+#'     ui = fluidPage(
+#'       textInput("txt", "Enter new hash"),
+#'       helpText("Format: #hash"),
+#'       actionButton("go", "Update"),
+#'       hr(),
+#'       verbatimTextOutput("hash")
+#'     ),
+#'     server = function(input, output, session) {
+#'       observeEvent(input$go, {
+#'         updateQueryString(input$txt, mode = "push")
+#'       })
+#'       output$hash <- renderText({
+#'         hash <- getUrlHash()
+#'         paste("Your hash is:\n", hash)
+#'       })
+#'     }
+#'   )
+#' }
+#' @export
+getQueryString <- function(session = getDefaultReactiveDomain()) {
+  parseQueryString(session$clientData$url_search)
+}
+
+#' @rdname getQueryString
+#' @export
+getUrlHash <- function(session = getDefaultReactiveDomain()) {
+  session$clientData$url_hash
+}

R/html-deps.R

@@ -6,7 +6,7 @@
 #' URL.
 #'
 #' @param dependency A single HTML dependency object, created using
-#'   \code{\link{htmlDependency}}. If the \code{src} value is named, then
+#'   \code{\link[htmltools]{htmlDependency}}. If the \code{src} value is named, then
 #'   \code{href} and/or \code{file} names must be present.
 #'
 #' @return A single HTML dependency object that has an \code{href}-named element
@@ -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/imageutils.R

@@ -21,11 +21,10 @@
 #' @param width Width in pixels.
 #' @param height Height in pixels.
 #' @param res Resolution in pixels per inch. This value is passed to
-#'   \code{\link{png}}. Note that this affects the resolution of PNG rendering in
+#'   \code{\link[grDevices]{png}}. Note that this affects the resolution of PNG rendering in
 #'   R; it won't change the actual ppi of the browser.
 #' @param ... Arguments to be passed through to \code{\link[grDevices]{png}}.
 #'   These can be used to set the width, height, background color, etc.
-#'
 #' @export
 plotPNG <- function(func, filename=tempfile(fileext='.png'),
                     width=400, height=400, res=72, ...) {

R/input-action.R

@@ -11,30 +11,43 @@
 #'
 #' @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}}
-#'
 #' @export
 actionButton <- function(inputId, label, icon = NULL, width = NULL, ...) {
+
+  value <- restoreInput(id = inputId, default = NULL)
+
   tags$button(id=inputId,
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     type="button",
     class="btn btn-default action-button",
-    list(icon, label),
+    `data-val` = value,
+    list(validateIcon(icon), label),
     ...
   )
 }
@@ -42,10 +55,32 @@ actionButton <- function(inputId, label, icon = NULL, width = NULL, ...) {
 #' @rdname actionButton
 #' @export
 actionLink <- function(inputId, label, icon = NULL, ...) {
+  value <- restoreInput(id = inputId, default = NULL)
+
   tags$a(id=inputId,
     href="#",
     class="action-button",
-    list(icon, label),
+    `data-val` = value,
+    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

@@ -6,30 +6,84 @@
 #'
 #' @inheritParams textInput
 #' @param choices List of values to show checkboxes for. If elements of the list
-#'   are named then that name rather than the value is displayed to the user.
+#'   are named then that name rather than the value is displayed to the user. If
+#'   this argument is provided, then \code{choiceNames} and \code{choiceValues}
+#'   must not be provided, and vice-versa.
 #' @param selected The values that should be initially selected, if any.
 #' @param inline If \code{TRUE}, render the choices inline (i.e. horizontally)
+#' @param choiceNames,choiceValues List of names and values, respectively,
+#'   that are displayed to the user in the app and correspond to the each
+#'   choice (for this reason, \code{choiceNames} and \code{choiceValues}
+#'   must have the same length). If either of these arguments is
+#'   provided, then the other \emph{must} be provided and \code{choices}
+#'   \emph{must not} be provided. The advantage of using both of these over
+#'   a named list for \code{choices} is that \code{choiceNames} allows any
+#'   type of UI object to be passed through (tag objects, icons, HTML code,
+#'   ...), instead of just simple text. See Examples.
+#'
 #' @return A list of HTML elements that can be added to a UI definition.
 #'
 #' @family input elements
 #' @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, session) {
+#'   output$data <- renderTable({
+#'     mtcars[, c("mpg", input$variable), drop = FALSE]
+#'   }, rownames = TRUE)
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#' ui <- fluidPage(
+#'   checkboxGroupInput("icons", "Choose icons:",
+#'     choiceNames =
+#'       list(icon("calendar"), icon("bed"),
+#'            icon("cog"), icon("bug")),
+#'     choiceValues =
+#'       list("calendar", "bed", "cog", "bug")
+#'   ),
+#'   textOutput("txt")
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   output$txt <- renderText({
+#'     icons <- paste(input$icons, collapse = ", ")
+#'     paste("You chose", icons)
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
 #' @export
-checkboxGroupInput <- function(inputId, label, choices, selected = NULL,
-  inline = FALSE, width = NULL) {
+checkboxGroupInput <- function(inputId, label, choices = NULL, selected = NULL,
+  inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL) {
 
-  # resolve names
-  choices <- choicesWithNames(choices)
-  if (!is.null(selected))
-    selected <- validateSelected(selected, choices, inputId)
+  # keep backward compatibility with Shiny < 1.0.1 (see #1649)
+  if (is.null(choices) && is.null(choiceNames) && is.null(choiceValues)) {
+    choices <- character(0)
+  }
 
-  options <- generateOptions(inputId, choices, selected, inline)
+  args <- normalizeChoicesArgs(choices, choiceNames, choiceValues)
+
+  selected <- restoreInput(id = inputId, default = selected)
+
+  # default value if it's not specified
+  if (!is.null(selected)) selected <- as.character(selected)
+
+  options <- generateOptions(inputId, selected, inline,
+    'checkbox', args$choiceNames, args$choiceValues)
 
   divClass <- "form-group shiny-input-checkboxgroup shiny-input-container"
   if (inline)

R/input-date.R

@@ -10,7 +10,7 @@
 #'   \item \code{yy} Year without century (12)
 #'   \item \code{yyyy} Year with century (2012)
 #'   \item \code{mm} Month number, with leading zero (01-12)
-#'   \item \code{m} Month number, without leading zero (01-12)
+#'   \item \code{m} Month number, without leading zero (1-12)
 #'   \item \code{M} Abbreviated month name
 #'   \item \code{MM} Full month name
 #'   \item \code{dd} Day of month with leading zero
@@ -21,48 +21,58 @@
 #'
 #' @inheritParams textInput
 #' @param value The starting date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format. If NULL (the default), will use the current
-#'   date in the client's time zone.
+#'   \code{yyyy-mm-dd} format. If NULL (the default), will use the current date
+#'   in the client's time zone.
 #' @param min The minimum allowed date. Either a Date object, or a string in
 #'   \code{yyyy-mm-dd} format.
 #' @param max The maximum allowed date. Either a Date object, or a string in
 #'   \code{yyyy-mm-dd} format.
 #' @param format The format of the date to display in the browser. Defaults to
 #'   \code{"yyyy-mm-dd"}.
-#' @param startview The date range shown when the input object is first
-#'   clicked. Can be "month" (the default), "year", or "decade".
+#' @param startview The date range shown when the input object is first clicked.
+#'   Can be "month" (the default), "year", or "decade".
 #' @param weekstart Which day is the start of the week. Should be an integer
 #'   from 0 (Sunday) to 6 (Saturday).
 #' @param language The language used for month and day names. Default is "en".
-#'   Other valid values include "bg", "ca", "cs", "da", "de", "el", "es", "fi",
-#'   "fr", "he", "hr", "hu", "id", "is", "it", "ja", "kr", "lt", "lv", "ms",
-#'   "nb", "nl", "pl", "pt", "pt-BR", "ro", "rs", "rs-latin", "ru", "sk", "sl",
-#'   "sv", "sw", "th", "tr", "uk", "zh-CN", and "zh-TW".
+#'   Other valid values include "ar", "az", "bg", "bs", "ca", "cs", "cy", "da",
+#'   "de", "el", "en-AU", "en-GB", "eo", "es", "et", "eu", "fa", "fi", "fo",
+#'   "fr-CH", "fr", "gl", "he", "hr", "hu", "hy", "id", "is", "it-CH", "it",
+#'   "ja", "ka", "kh", "kk", "ko", "kr", "lt", "lv", "me", "mk", "mn", "ms",
+#'   "nb", "nl-BE", "nl", "no", "pl", "pt-BR", "pt", "ro", "rs-latin", "rs",
+#'   "ru", "sk", "sl", "sq", "sr-latin", "sr", "sv", "sw", "th", "tr", "uk",
+#'   "vi", "zh-CN", and "zh-TW".
 #'
 #' @family input elements
 #' @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:",
-#'           language = "de",
-#'           weekstart = 1)
+#'   # Pass in a Date object
+#'   dateInput("date4", "Date:", value = Sys.Date()-10),
 #'
-#' # Start with decade view instead of default month view
-#' dateInput("date", "Date:",
-#'           startview = "decade")
+#'   # Use different language and different first day of week
+#'   dateInput("date5", "Date:",
+#'           language = "ru",
+#'           weekstart = 1),
 #'
+#'   # 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,29 +84,36 @@ 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")
 
-  attachDependencies(
-    tags$div(id = inputId,
-      class = "shiny-date-input form-group shiny-input-container",
-      style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+  value <- restoreInput(id = inputId, default = value)
 
-      controlLabel(inputId, label),
-      tags$input(type = "text",
-                 # datepicker class necessary for dropdown to display correctly
-                 class = "form-control datepicker",
-                 `data-date-language` = language,
-                 `data-date-weekstart` = weekstart,
-                 `data-date-format` = format,
-                 `data-date-start-view` = startview,
-                 `data-min-date` = min,
-                 `data-max-date` = max,
-                 `data-initial-date` = value
-      )
+  tags$div(id = inputId,
+    class = "shiny-date-input form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+
+    controlLabel(inputId, label),
+    tags$input(type = "text",
+               class = "form-control",
+               `data-date-language` = language,
+               `data-date-week-start` = weekstart,
+               `data-date-format` = format,
+               `data-date-start-view` = startview,
+               `data-min-date` = min,
+               `data-max-date` = max,
+               `data-initial-date` = value
     ),
     datePickerDependency
   )
 }
 
 datePickerDependency <- htmlDependency(
-  "bootstrap-datepicker", "1.0.2", c(href = "shared/datepicker"),
+  "bootstrap-datepicker", "1.6.4", c(href = "shared/datepicker"),
   script = "js/bootstrap-datepicker.min.js",
-  stylesheet = "css/datepicker.css")
+  stylesheet = "css/bootstrap-datepicker3.min.css",
+  # Need to enable noConflict mode. See #1346.
+  head = "<script>
+(function() {
+  var datepicker = $.fn.datepicker.noConflict();
+  $.fn.bsDatepicker = datepicker;
+})();
+</script>"
+)

R/input-daterange.R

@@ -10,7 +10,7 @@
 #'   \item \code{yy} Year without century (12)
 #'   \item \code{yyyy} Year with century (2012)
 #'   \item \code{mm} Month number, with leading zero (01-12)
-#'   \item \code{m} Month number, without leading zero (01-12)
+#'   \item \code{m} Month number, without leading zero (1-12)
 #'   \item \code{M} Abbreviated month name
 #'   \item \code{MM} Full month name
 #'   \item \code{dd} Day of month with leading zero
@@ -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",
@@ -87,7 +98,7 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
           class = "input-sm form-control",
           type = "text",
           `data-date-language` = language,
-          `data-date-weekstart` = weekstart,
+          `data-date-week-start` = weekstart,
           `data-date-format` = format,
           `data-date-start-view` = startview,
           `data-min-date` = min,
@@ -99,7 +110,7 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
           class = "input-sm form-control",
           type = "text",
           `data-date-language` = language,
-          `data-date-weekstart` = weekstart,
+          `data-date-week-start` = weekstart,
           `data-date-format` = format,
           `data-date-start-view` = startview,
           `data-min-date` = min,

R/input-file.R

@@ -27,21 +27,96 @@
 #'   Internet Explorer 9 and earlier.}
 #' @param accept A character vector of MIME types; gives the browser a hint of
 #'   what kind of files the server is expecting.
+#' @param buttonLabel The label used on the button. Can be text or an HTML tag
+#'   object.
+#' @param placeholder The text to show before a file has been uploaded.
 #'
+#' @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) {
+  width = NULL, buttonLabel = "Browse...", placeholder = "No file selected") {
+
+  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
+  )
 
-  inputTag <- tags$input(id = inputId, name = inputId, type = "file")
   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",
+          buttonLabel,
+          inputTag
+        )
+      ),
+      tags$input(type = "text", class = "form-control",
+        placeholder = placeholder, 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

@@ -11,39 +11,93 @@
 #'
 #' @inheritParams textInput
 #' @param choices List of values to select from (if elements of the list are
-#' named then that name rather than the value is displayed to the user)
+#'   named then that name rather than the value is displayed to the user). If
+#'   this argument is provided, then \code{choiceNames} and \code{choiceValues}
+#'   must not be provided, and vice-versa.
 #' @param selected The initially selected value (if not specified then
-#' defaults to the first value)
+#'   defaults to the first value)
 #' @param inline If \code{TRUE}, render the choices inline (i.e. horizontally)
 #' @return A set of radio buttons that can be added to a UI definition.
+#' @param choiceNames,choiceValues List of names and values, respectively,
+#'   that are displayed to the user in the app and correspond to the each
+#'   choice (for this reason, \code{choiceNames} and \code{choiceValues}
+#'   must have the same length). If either of these arguments is
+#'   provided, then the other \emph{must} be provided and \code{choices}
+#'   \emph{must not} be provided. The advantage of using both of these over
+#'   a named list for \code{choices} is that \code{choiceNames} allows any
+#'   type of UI object to be passed through (tag objects, icons, HTML code,
+#'   ...), instead of just simple text. See Examples.
 #'
 #' @family input elements
 #' @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)
+#'
+#' ui <- fluidPage(
+#'   radioButtons("rb", "Choose one:",
+#'                choiceNames = list(
+#'                  icon("calendar"),
+#'                  HTML("<p style='color:red;'>Red Text</p>"),
+#'                  "Normal text"
+#'                ),
+#'                choiceValues = list(
+#'                  "icon", "html", "text"
+#'                )),
+#'   textOutput("txt")
+#' )
+#'
+#' server <- function(input, output) {
+#'   output$txt <- renderText({
+#'     paste("You chose", input$rb)
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
 #' @export
-radioButtons <- function(inputId, label, choices, selected = NULL,
-  inline = FALSE, width = NULL) {
+radioButtons <- function(inputId, label, choices = NULL, selected = NULL,
+  inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL) {
 
-  # resolve names
-  choices <- choicesWithNames(choices)
+  args <- normalizeChoicesArgs(choices, choiceNames, choiceValues)
+
+  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)
-  }
+  selected <- if (is.null(selected)) args$choiceValues[[1]] else as.character(selected)
+
   if (length(selected) > 1) stop("The 'selected' argument must be of length 1")
 
-  options <- generateOptions(inputId, choices, selected, inline, type = 'radio')
+  options <- generateOptions(inputId, selected, inline,
+    'radio', args$choiceNames, args$choiceValues)
 
   divClass <- "form-group shiny-input-radiogroup shiny-input-container"
-  if (inline)
-    divClass <- paste(divClass, "shiny-input-container-inline")
+  if (inline) divClass <- paste(divClass, "shiny-input-container-inline")
 
   tags$div(id = inputId,
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),

R/input-select.R

@@ -5,7 +5,7 @@
 #'
 #' By default, \code{selectInput()} and \code{selectizeInput()} use the
 #' JavaScript library \pkg{selectize.js}
-#' (\url{https://github.com/brianreavis/selectize.js}) to instead of the basic
+#' (\url{https://github.com/selectize/selectize.js}) to instead of the basic
 #' select input element. To use the standard HTML select input element, use
 #' \code{selectInput()} with \code{selectize=FALSE}.
 #'
@@ -15,7 +15,12 @@
 #'
 #' @inheritParams textInput
 #' @param choices List of values to select from. If elements of the list are
-#'   named then that name rather than the value is displayed to the user.
+#'   named, then that name rather than the value is displayed to the user.
+#'   This can also be a named list whose elements are (either named or
+#'   unnamed) lists or vectors. If this is the case, the outermost names
+#'   will be used as the "optgroup" label for the elements in the respective
+#'   sublist. This allows you to group and label similar choices. See the
+#'   example section for a small demo of this feature.
 #' @param selected The initially selected value (or multiple values if
 #'   \code{multiple = TRUE}). If not specified then defaults to the first value
 #'   for single-select lists and no values for multiple select lists.
@@ -31,21 +36,56 @@
 #' @seealso \code{\link{updateSelectInput}}
 #'
 #' @examples
-#' selectInput("variable", "Variable:",
-#'             c("Cylinders" = "cyl",
-#'               "Transmission" = "am",
-#'               "Gears" = "gear"))
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' # basic example
+#' shinyApp(
+#'   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)
+#'   }
+#' )
+#'
+#' # demoing optgroup support in the `choices` arg
+#' shinyApp(
+#'   ui = fluidPage(
+#'     selectInput("state", "Choose a state:",
+#'       list(`East Coast` = c("NY", "NJ", "CT"),
+#'            `West Coast` = c("WA", "OR", "CA"),
+#'            `Midwest` = c("MN", "WI", "IA"))
+#'     ),
+#'     textOutput("result")
+#'   ),
+#'   server = function(input, output) {
+#'     output$result <- renderText({
+#'       paste("You chose", input$state)
+#'     })
+#'   }
+#' )
+#' }
 #' @export
 selectInput <- function(inputId, label, choices, selected = NULL,
-                        multiple = FALSE, selectize = TRUE, width = NULL,
-                        size = NULL) {
+  multiple = FALSE, selectize = TRUE, width = NULL,
+  size = NULL) {
+
+  selected <- restoreInput(id = inputId, default = selected)
+
   # resolve names
   choices <- choicesWithNames(choices)
 
   # default value if it's not specified
   if (is.null(selected)) {
     if (!multiple) selected <- firstChoice(choices)
-  } else selected <- validateSelected(selected, choices, inputId)
+  } else selected <- as.character(selected)
 
   if (!is.null(size) && selectize) {
     stop("'size' argument is incompatible with 'selectize=TRUE'.")
@@ -115,7 +155,7 @@ needOptgroup <- function(choices) {
 #' @rdname selectInput
 #' @param ... Arguments passed to \code{selectInput()}.
 #' @param options A list of options. See the documentation of \pkg{selectize.js}
-#'   for possible options (character option values inside \code{\link{I}()} will
+#'   for possible options (character option values inside \code{\link[base]{I}()} will
 #'   be treated as literal JavaScript code; see \code{\link{renderDataTable}()}
 #'   for details).
 #' @param width The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
@@ -154,7 +194,7 @@ selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
 
   if ('drag_drop' %in% options$plugins) {
     selectizeDep <- list(selectizeDep, htmlDependency(
-      'jqueryui', '1.11.4', c(href = 'shared/jqueryui'),
+      'jqueryui', '1.12.1', c(href = 'shared/jqueryui'),
       script = 'jquery-ui.min.js'
     ))
   }

R/input-slider.R

@@ -36,7 +36,7 @@
 #'   format string, to be passed to the Javascript strftime library. See
 #'   \url{https://github.com/samsonjs/strftime} for more details. The allowed
 #'   format specifications are very similar, but not identical, to those for R's
-#'   \code{\link{strftime}} function. For Dates, the default is \code{"\%F"}
+#'   \code{\link[base]{strftime}} function. For Dates, the default is \code{"\%F"}
 #'   (like \code{"2015-07-01"}), and for POSIXt, the default is \code{"\%F \%T"}
 #'   (like \code{"2015-07-01 15:32:10"}).
 #' @param timezone Only used if the values are POSIXt objects. A string
@@ -48,6 +48,28 @@
 #' @family input elements
 #' @seealso \code{\link{updateSliderInput}}
 #'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#' options(device.ask.default = FALSE)
+#'
+#' 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 +86,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)
@@ -141,11 +165,14 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
     `data-grid-num` = n_ticks,
     `data-grid-snap` = FALSE,
     `data-prettify-separator` = sep,
+    `data-prettify-enabled` = (sep != ""),
     `data-prefix` = pre,
     `data-postfix` = post,
     `data-keyboard` = TRUE,
     `data-keyboard-step` = step / (max - min) * 100,
-    `data-drag-interval` = dragRange,
+    # This value is only relevant for range sliders; for non-range sliders it
+    # causes problems since ion.RangeSlider 2.1.2 (issue #1605).
+    `data-drag-interval` = if (length(value) > 1) dragRange,
     # The following are ignored by the ion.rangeSlider, but are used by Shiny.
     `data-data-type` = dataType,
     `data-time-format` = timeFormat,
@@ -191,7 +218,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.6", c(href="shared/ionrangeslider"),
       script = "js/ion.rangeSlider.min.js",
       # ion.rangeSlider also needs normalize.css, which is already included in
       # Bootstrap.
@@ -221,7 +248,6 @@ hasDecimals <- function(value) {
 #'   or list of tags (using \code{\link{tag}} and friends), or raw HTML (using
 #'   \code{\link{HTML}}).
 #' @param pauseButton Similar to \code{playButton}, but for the pause button.
-#'
 #' @export
 animationOptions <- function(interval=1000,
                              loop=FALSE,

R/input-submit.R

@@ -1,8 +1,27 @@
 #' Create a submit button
 #'
-#' Create a submit button for an input form. Forms that include a submit
+#' Create a submit button for an app. Apps that include a submit
 #' button do not automatically update their outputs when inputs change,
 #' rather they wait until the user explicitly clicks the submit button.
+#' The use of \code{submitButton} is generally discouraged in favor of
+#' the more versatile \code{\link{actionButton}} (see details below).
+#'
+#' Submit buttons are unusual Shiny inputs, and we recommend using
+#' \code{\link{actionButton}} instead of \code{submitButton} when you
+#' want to delay a reaction.
+#' See \href{http://shiny.rstudio.com/articles/action-buttons.html}{this
+#' article} for more information (including a demo of how to "translate"
+#' code using a \code{submitButton} to code using an \code{actionButton}).
+#'
+#' In essence, the presence of a submit button stops all inputs from
+#' sending their values automatically to the server. This means, for
+#' instance, that if there are \emph{two} submit buttons in the same app,
+#' clicking either one will cause all inputs in the app to send their
+#' values to the server. This is probably not what you'd want, which is
+#' why submit button are unwieldy for all but the simplest apps. There
+#' are other problems with submit buttons: for example, dynamically
+#' created submit buttons (for example, with \code{\link{renderUI}}
+#' or \code{\link{insertUI}}) will not work.
 #'
 #' @param text Button caption
 #' @param icon Optional \code{\link{icon}} to appear on the button
@@ -13,8 +32,26 @@
 #' @family input elements
 #'
 #' @examples
-#' submitButton("Update View")
-#' submitButton("Update View", icon("refresh"))
+#' if (interactive()) {
+#'
+#' shinyApp(
+#'   ui = basicPage(
+#'     numericInput("num", label = "Make changes", value = 1),
+#'     submitButton("Update View", icon("refresh")),
+#'     helpText("When you click the button above, you should see",
+#'              "the output below update to reflect the value you",
+#'              "entered at the top:"),
+#'     verbatimTextOutput("value")
+#'   ),
+#'   server = function(input, output) {
+#'
+#'     # submit buttons do not have a value of their own,
+#'     # they control when the app accesses values of other widgets.
+#'     # input$num is the value of the number widget.
+#'     output$value <- renderPrint({ input$num })
+#'   }
+#' )
+#' }
 #' @export
 submitButton <- function(text = "Apply Changes", icon = NULL, width = NULL) {
   div(

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/input-textarea.R

@@ -0,0 +1,69 @@
+#' Create a textarea input control
+#'
+#' Create a textarea input control for entry of unstructured text values.
+#'
+#' @inheritParams textInput
+#' @param height The height of the input, e.g. \code{'400px'}, or
+#'   \code{'100\%'}; see \code{\link{validateCssUnit}}.
+#' @param cols Value of the visible character columns of the input, e.g.
+#'   \code{80}. If used with \code{width}, \code{width} will take precedence in
+#'   the browser's rendering.
+#' @param rows The value of the visible character rows of the input, e.g.
+#'   \code{6}. If used with \code{height}, \code{height} will take precedence in
+#'   the browser's rendering.
+#' @param resize Which directions the textarea box can be resized. Can be one of
+#'   \code{"both"}, \code{"none"}, \code{"vertical"}, and \code{"horizontal"}.
+#'   The default, \code{NULL}, will use the client browser's default setting for
+#'   resizing textareas.
+#' @return A textarea input control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateTextAreaInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   textAreaInput("caption", "Caption", "Data Summary", width = "1000px"),
+#'   verbatimTextOutput("value")
+#' )
+#' server <- function(input, output) {
+#'   output$value <- renderText({ input$caption })
+#' }
+#' shinyApp(ui, server)
+#'
+#' }
+#' @export
+textAreaInput <- function(inputId, label, value = "", width = NULL, height = NULL,
+  cols = NULL, rows = NULL, placeholder = NULL, resize = NULL) {
+
+  value <- restoreInput(id = inputId, default = value)
+
+  if (!is.null(resize)) {
+    resize <- match.arg(resize, c("both", "none", "vertical", "horizontal"))
+  }
+
+  style <- paste(
+    if (!is.null(width))  paste0("width: ",  validateCssUnit(width),  ";"),
+    if (!is.null(height)) paste0("height: ", validateCssUnit(height), ";"),
+    if (!is.null(resize)) paste0("resize: ", resize, ";")
+  )
+
+  # Workaround for tag attribute=character(0) bug:
+  #   https://github.com/rstudio/htmltools/issues/65
+  if (length(style) == 0) style <- NULL
+
+  div(class = "form-group shiny-input-container",
+    label %AND% tags$label(label, `for` = inputId),
+    tags$textarea(
+      id = inputId,
+      class = "form-control",
+      placeholder = placeholder,
+      style = style,
+      rows = rows,
+      cols = cols,
+      value
+    )
+  )
+}

R/input-utils.R

@@ -2,42 +2,62 @@ controlLabel <- function(controlName, label) {
   label %AND% tags$label(class = "control-label", `for` = controlName, label)
 }
 
-
-# Before shiny 0.9, `selected` refers to names/labels of `choices`; now it
-# refers to values. Below is a function for backward compatibility.
-validateSelected <- function(selected, choices, inputId) {
-  # drop names, otherwise toJSON() keeps them too
-  selected <- unname(selected)
-  # if you are using optgroups, you're using shiny > 0.10.0, and you should
-  # already know that `selected` must be a value instead of a label
-  if (needOptgroup(choices)) return(selected)
-
-  if (is.list(choices)) choices <- unlist(choices)
-
-  nms <- names(choices)
-  # labels and values are identical, no need to validate
-  if (identical(nms, unname(choices))) return(selected)
-  # when selected labels instead of values
-  i <- (selected %in% nms) & !(selected %in% choices)
-  if (any(i)) {
-    warnFun <- if (all(i)) {
-      # replace names with values
-      selected <- unname(choices[selected])
-      warning
-    } else stop  # stop when it is ambiguous (some labels == values)
-    warnFun("'selected' must be the values instead of names of 'choices' ",
-            "for the input '", inputId, "'")
+# This function takes in either a list or vector for `choices` (and
+# `choiceNames` and `choiceValues` are passed in as NULL) OR it takes
+# in a list or vector for both `choiceNames` and `choiceValues` (and
+# `choices` is passed as NULL) and returns a list of two elements:
+#    - `choiceNames` is a vector or list that holds the options names
+#      (each element can be arbitrary UI, or simple text)
+#    - `choiceValues` is a vector or list that holds the options values
+#       (each element must be simple text)
+normalizeChoicesArgs <- function(choices, choiceNames, choiceValues,
+  mustExist = TRUE) {
+  # if-else to check that either choices OR (choiceNames + choiceValues)
+  # were correctly provided
+  if (is.null(choices)) {
+    if (is.null(choiceNames) || is.null(choiceValues)) {
+      if (mustExist) {
+        stop("Please specify a non-empty vector for `choices` (or, ",
+             "alternatively, for both `choiceNames` AND `choiceValues`).")
+      } else {
+        if (is.null(choiceNames) && is.null(choiceValues)) {
+          # this is useful when we call this function from `updateInputOptions()`
+          # in which case, all three `choices`, `choiceNames` and `choiceValues`
+          # may legitimately be NULL
+          return(list(choiceNames = NULL, choiceValues = NULL))
+        } else {
+          stop("One of `choiceNames` or `choiceValues` was set to ",
+               "NULL, but either both or none should be NULL.")
+        }
+      }
+    }
+    if (length(choiceNames) != length(choiceValues)) {
+      stop("`choiceNames` and `choiceValues` must have the same length.")
+    }
+    if (anyNamed(choiceNames) || anyNamed(choiceValues)) {
+      stop("`choiceNames` and `choiceValues` must not be named.")
+    }
+  } else {
+    if (!is.null(choiceNames) || !is.null(choiceValues)) {
+      warning("Using `choices` argument; ignoring `choiceNames` and `choiceValues`.")
+    }
+    choices <- choicesWithNames(choices) # resolve names if not specified
+    choiceNames <- names(choices)
+    choiceValues <- unname(choices)
   }
-  selected
-}
 
+  return(list(choiceNames = as.list(choiceNames),
+              choiceValues = as.list(as.character(choiceValues))))
+}
 
 # generate options for radio buttons and checkbox groups (type = 'checkbox' or
 # 'radio')
-generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox') {
+generateOptions <- function(inputId, selected, inline, type = 'checkbox',
+                            choiceNames, choiceValues,
+                            session = getDefaultReactiveDomain()) {
   # generate a list of <input type=? [checked] />
   options <- mapply(
-    choices, names(choices),
+    choiceValues, choiceNames,
     FUN = function(value, name) {
       inputTag <- tags$input(
         type = type, name = inputId, value = value
@@ -45,14 +65,18 @@ generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox
       if (value %in% selected)
         inputTag$attribs$checked <- "checked"
 
+      # in case, the options include UI code other than text
+      # (arbitrary HTML using the tags() function or equivalent)
+      pd <- processDeps(name, session)
+
       # If inline, there's no wrapper div, and the label needs a class like
       # checkbox-inline.
       if (inline) {
-        tags$label(class = paste0(type, "-inline"), inputTag, tags$span(name))
+        tags$label(class = paste0(type, "-inline"), inputTag,
+                   tags$span(pd$html, pd$dep))
       } else {
-        tags$div(class = type,
-          tags$label(inputTag, tags$span(name))
-        )
+        tags$div(class = type, tags$label(inputTag,
+                 tags$span(pd$html, pd$dep)))
       }
     },
     SIMPLIFY = FALSE, USE.NAMES = FALSE
@@ -63,7 +87,7 @@ generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox
 
 
 # Takes a vector or list, and adds names (same as the value) to any entries
-# without names.
+# without names. Coerces all leaf nodes to `character`.
 choicesWithNames <- function(choices) {
   # Take a vector or list, and convert to list. Also, if any children are
   # vectors with length > 1, convert those to list. If the list is unnamed,
@@ -79,7 +103,7 @@ choicesWithNames <- function(choices) {
       if (is.list(val))
         listify(val)
       else if (length(val) == 1 && is.null(names(val)))
-        val
+        as.character(val)
       else
         makeNamed(as.list(val))
     })

R/insert-ui.R

@@ -0,0 +1,174 @@
+#' 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 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 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 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,
+  where = c("beforeBegin", "afterBegin", "beforeEnd", "afterEnd"),
+  ui,
+  multiple = FALSE,
+  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/jqueryui.R

@@ -53,7 +53,6 @@
 #'   over text). The default is \code{"auto"}, which is equivalent to
 #'   \code{ifelse(draggable, "move", "inherit")}.
 #' @return An HTML element or list of elements.
-#'
 #' @export
 absolutePanel <- function(...,
                           top = NULL, left = NULL, right = NULL, bottom = NULL,
@@ -80,8 +79,6 @@ absolutePanel <- function(...,
   if (isTRUE(draggable)) {
     divTag <- tagAppendAttributes(divTag, class='draggable')
     return(tagList(
-      # IMPORTANT NOTE: If you update jqueryui, make sure you DON'T include the datepicker,
-      # as it collides with our bootstrap datepicker!
       singleton(tags$head(tags$script(src='shared/jqueryui/jquery-ui.min.js'))),
       divTag,
       tags$script('$(".draggable").draggable();')

R/middleware.R

@@ -191,7 +191,7 @@ staticHandler <- function(root) {
     if (!identical(req$REQUEST_METHOD, 'GET'))
       return(NULL)
 
-    path <- req$PATH_INFO
+    path <- URLdecode(req$PATH_INFO)
 
     if (is.null(path))
       return(httpResponse(400, content="<h1>Bad Request</h1>"))
@@ -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,183 @@
+#' 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 size One of \code{"s"} for small, \code{"m"} (the default) for medium,
+#'   or \code{"l"} for large.
+#' @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.
+#' @param fade If \code{FALSE}, the modal dialog will have no fade-in animation
+#'   (it will simply appear rather than fade in to view).
+#'
+#' @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 (!is.null(input$dataset) && nzchar(input$dataset) &&
+#'           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"),
+  size = c("m", "s", "l"), easyClose = FALSE, fade = TRUE) {
+
+  size <- match.arg(size)
+
+  cls <- if (fade) "modal fade" else "modal"
+  div(id = "shiny-modal", class = cls, tabindex = "-1",
+    `data-backdrop` = if (!easyClose) "static",
+    `data-keyboard` = if (!easyClose) "false",
+
+    div(
+      class = "modal-dialog",
+      class = switch(size, s = "modal-sm", m = NULL, l = "modal-lg"),
+      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/modules.R

@@ -1,4 +1,4 @@
-# Creates an object whose $ and $<- pass through to the parent
+# Creates an object whose $ and [[ pass through to the parent
 # session, unless the name is matched in ..., in which case
 # that value is returned instead. (See Decorator pattern.)
 createSessionProxy <- function(parentSession, ...) {
@@ -14,18 +14,24 @@ createSessionProxy <- function(parentSession, ...) {
 
 #' @export
 `$.session_proxy` <- function(x, name) {
-  if (name %in% names(x[["overrides"]]))
-    x[["overrides"]][[name]]
+  if (name %in% names(.subset2(x, "overrides")))
+    .subset2(x, "overrides")[[name]]
   else
-    x[["parent"]][[name]]
+    .subset2(x, "parent")[[name]]
 }
 
+#' @export
+`[[.session_proxy` <- `$.session_proxy`
+
+
 #' @export
 `$<-.session_proxy` <- function(x, name, value) {
-  x[["parent"]][[name]] <- value
-  x
+  stop("Attempted to assign value on session proxy.")
 }
 
+`[[<-.session_proxy` <- `$<-.session_proxy`
+
+
 #' Invoke a Shiny module
 #'
 #' Shiny's module feature lets you break complicated UI and server logic into
@@ -42,7 +48,6 @@ createSessionProxy <- function(parentSession, ...) {
 #'
 #' @return The return value, if any, from executing the module server function
 #' @seealso \url{http://shiny.rstudio.com/articles/modules.html}
-#'
 #' @export
 callModule <- function(module, id, ..., session = getDefaultReactiveDomain()) {
   childScope <- session$makeScope(id)

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

@@ -12,6 +12,14 @@
 #' method is called. Calling \code{close} will cause the progress panel
 #' to be removed.
 #'
+#' As of version 0.14, the progress indicators use Shiny's new notification API.
+#' If you want to use the old styling (for example, you may have used customized
+#' CSS), you can use \code{style="old"} each time you call
+#' \code{Progress$new()}. If you don't want to set the style each time
+#' \code{Progress$new} is called, you can instead call
+#' \code{\link{shinyOptions}(progress.style="old")} just once, inside the server
+#' function.
+#'
 #' \strong{Methods}
 #'   \describe{
 #'     \item{\code{initialize(session, min = 0, max = 1)}}{
@@ -47,7 +55,10 @@
 #'   de-emphasized appearance relative to \code{message}.
 #' @param value A numeric value at which to set
 #'   the progress bar, relative to \code{min} and \code{max}.
-#'   \code{NULL} hides the progress bar, if it is currently visible.
+#' @param style Progress display style. If \code{"notification"} (the default),
+#'   the progress indicator will show using Shiny's notification API. If
+#'   \code{"old"}, use the same HTML and CSS used in Shiny 0.13.2 and below
+#'   (this is for backward-compatibility).
 #' @param amount Single-element numeric vector; the value at which to set
 #'   the progress bar, relative to \code{min} and \code{max}.
 #'   \code{NULL} hides the progress bar, if it is currently visible.
@@ -55,11 +66,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 +87,9 @@
 #'     }
 #'     plot(cars)
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @seealso \code{\link{withProgress}}
 #' @format NULL
@@ -79,21 +97,24 @@
 #' @export
 Progress <- R6Class(
   'Progress',
-  portable = TRUE,
   public = list(
 
-    initialize = function(session = getDefaultReactiveDomain(), min = 0, max = 1) {
+    initialize = function(session = getDefaultReactiveDomain(),
+      min = 0, max = 1,
+      style = getShinyOption("progress.style", default = "notification"))
+    {
       if (is.null(session$progressStack))
         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
+      private$style <- match.arg(style, choices = c("notification", "old"))
       private$closed <- FALSE
 
-      session$sendProgress('open', list(id = private$id))
+      session$sendProgress('open', list(id = private$id, style = private$style))
     },
 
     set = function(value = NULL, message = NULL, detail = NULL) {
@@ -102,27 +123,31 @@ Progress <- R6Class(
         return()
       }
 
-      if (is.null(value) || is.na(value)) {
+      if (is.null(value) || is.na(value))
         value <- NULL
-      } else {
+
+      if (!is.null(value)) {
+        private$value <- value
         # Normalize value to number between 0 and 1
         value <- min(1, max(0, (value - private$min) / (private$max - private$min)))
       }
 
-      private$value <- value
-
       data <- dropNulls(list(
         id = private$id,
         message = message,
         detail = detail,
-        value = value
+        value = value,
+        style = private$style
       ))
 
-       private$session$sendProgress('update', data)
+      private$session$sendProgress('update', data)
     },
 
     inc = function(amount = 0.1, message = NULL, detail = NULL) {
-      value <- min(self$getValue() + amount, private$max)
+      if (is.null(private$value))
+        private$value <- private$min
+
+      value <- min(private$value + amount, private$max)
       self$set(value, message, detail)
     },
 
@@ -130,10 +155,7 @@ Progress <- R6Class(
 
     getMax = function() private$max,
 
-    # Return value (not the normalized 0-1 value, but in the original range)
-    getValue = function() {
-      private$value * (private$max - private$min) + private$min
-    },
+    getValue = function() private$value,
 
     close = function() {
       if (private$closed) {
@@ -141,17 +163,20 @@ Progress <- R6Class(
         return()
       }
 
-      private$session$sendProgress('close', list(id = private$id))
+      private$session$sendProgress('close',
+        list(id = private$id, style = private$style)
+      )
       private$closed <- TRUE
     }
   ),
 
   private = list(
-    session = 'environment',
+    session = 'ShinySession',
     id = character(0),
     min = numeric(0),
     max = numeric(0),
-    value = NULL,
+    style = character(0),
+    value = numeric(0),
     closed = logical(0)
   )
 )
@@ -179,6 +204,14 @@ Progress <- R6Class(
 #' is not common) or otherwise cannot be encapsulated by a single scope. In that
 #' case, you can use the \code{Progress} reference class.
 #'
+#' As of version 0.14, the progress indicators use Shiny's new notification API.
+#' If you want to use the old styling (for example, you may have used customized
+#' CSS), you can use \code{style="old"} each time you call
+#' \code{withProgress()}. If you don't want to set the style each time
+#' \code{withProgress} is called, you can instead call
+#' \code{\link{shinyOptions}(progress.style="old")} just once, inside the server
+#' function.
+#'
 #' @param session The Shiny session object, as provided by \code{shinyServer} to
 #'   the server function. The default is to automatically find the session by
 #'   using the current reactive domain.
@@ -199,14 +232,23 @@ Progress <- R6Class(
 #'   displayed to the user, or \code{NULL} to hide the current detail message
 #'   (if any). The detail message will be shown with a de-emphasized appearance
 #'   relative to \code{message}.
+#' @param style Progress display style. If \code{"notification"} (the default),
+#'   the progress indicator will show using Shiny's notification API. If
+#'   \code{"old"}, use the same HTML and CSS used in Shiny 0.13.2 and below
+#'   (this is for backward-compatibility).
 #' @param value Single-element numeric vector; the value at which to set the
-#'   progress bar, relative to \code{min} and \code{max}. \code{NULL} hides the
-#'   progress bar, if it is currently visible.
+#'   progress bar, relative to \code{min} and \code{max}.
 #'
 #' @examples
-#' \dontrun{
-#' # server.R
-#' shinyServer(function(input, output) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#' options(device.ask.default = FALSE)
+#'
+#' 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,16 +259,20 @@ Progress <- R6Class(
 #'     })
 #'     plot(cars)
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @seealso \code{\link{Progress}}
 #' @rdname withProgress
 #' @export
 withProgress <- function(expr, min = 0, max = 1,
-                         value = min + (max - min) * 0.1,
-                         message = NULL, detail = NULL,
-                         session = getDefaultReactiveDomain(),
-                         env = parent.frame(), quoted = FALSE) {
+  value = min + (max - min) * 0.1,
+  message = NULL, detail = NULL,
+  style = getShinyOption("progress.style", default = "notification"),
+  session = getDefaultReactiveDomain(),
+  env = parent.frame(), quoted = FALSE)
+{
 
   if (!quoted)
     expr <- substitute(expr)
@@ -234,7 +280,9 @@ withProgress <- function(expr, min = 0, max = 1,
   if (is.null(session$progressStack))
     stop("'session' is not a ShinySession object.")
 
-  p <- Progress$new(session, min = min, max = max)
+  style <- match.arg(style, c("notification", "old"))
+
+  p <- Progress$new(session, min = min, max = max, style = style)
 
   session$progressStack$push(p)
   on.exit({

R/react.R

@@ -115,13 +115,16 @@ ReactiveEnvironment <- R6Class(
     addPendingFlush = function(ctx, priority) {
       .pendingFlush$enqueue(ctx, priority)
     },
+    hasPendingFlush = function() {
+      return(!.pendingFlush$isEmpty())
+    },
     flush = function() {
       # If already in a flush, don't start another one
       if (.inFlush) return()
       .inFlush <<- TRUE
       on.exit(.inFlush <<- FALSE)
 
-      while (!.pendingFlush$isEmpty()) {
+      while (hasPendingFlush()) {
         ctx <- .pendingFlush$dequeue()
         ctx$executeFlushCallbacks()
       }

R/reactive-domains.R

@@ -42,11 +42,11 @@ NULL
 #
 ## ------------------------------------------------------------------------
 createMockDomain <- function() {
-  callbacks <- list()
+  callbacks <- Callbacks$new()
   ended <- FALSE
   domain <- new.env(parent = emptyenv())
   domain$onEnded <- function(callback) {
-    callbacks <<- c(callbacks, callback)
+    return(callbacks$register(callback))
   }
   domain$isEnded <- function() {
     ended
@@ -55,7 +55,7 @@ createMockDomain <- function() {
   domain$end <- function() {
     if (!ended) {
       ended <<- TRUE
-      lapply(callbacks, do.call, list())
+      callbacks$invoke()
     }
     invisible()
   }

R/render-table.R

@@ -3,57 +3,221 @@
 #' 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("")
+  dots <- list(...)  ## used later (but defined here because of scoping)
+
+  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(...)
     xtable_argnames <- setdiff(names(formals(xtable)), c("x", "..."))
     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,
+      x = xtable_res,
       type = 'html',
-      html.table.attributes = paste('class="', htmlEscape(classNames, TRUE),
-                                    '"', sep='')
-    )
-    print_args <- c(print_args, non_xtable_args)
+      include.rownames = {
+        if ("include.rownames" %in% names(dots)) dots$include.rownames
+        else rownames
+      },
+      include.colnames = {
+        if ("include.colnames" %in% names(dots)) dots$include.colnames
+        else colnames
+      },
+      NA.string = {
+        if ("NA.string" %in% names(dots)) dots$NA.string
+        else na
+      },
+      html.table.attributes =
+        paste0({
+          if ("html.table.attributes" %in% names(dots)) dots$html.table.attributes
+          else ""
+        }, " ",
+        "class = '", htmlEscape(classNames, TRUE), "' ",
+        "style = 'width:", validateCssUnit(width), ";'"))
 
-    return(paste(
-      utils::capture.output(
-        do.call(print, print_args)
-      ),
-      collapse="\n"
-    ))
-  })
+    print_args <- c(print_args, non_xtable_args)
+    print_args <- print_args[unique(names(print_args))]
+
+    # 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/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

@@ -71,6 +71,63 @@ removeInputHandler <- function(type){
   inputHandlers$remove(type)
 }
 
+
+# Apply input handler to a single input value
+applyInputHandler <- function(name, val, shinysession) {
+  splitName <- strsplit(name, ':')[[1]]
+  if (length(splitName) > 1) {
+    if (!inputHandlers$containsKey(splitName[[2]])) {
+      # No input handler registered for this type
+      stop("No handler registered for type ", name)
+    }
+
+    inputName <- splitName[[1]]
+
+    # 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)
+  }
+}
+
+#' Apply input handlers to raw input values
+#'
+#' The purpose of this function is to make it possible for external packages to
+#' test Shiny inputs. It takes a named list of raw input values, applies input
+#' handlers to those values, and then returns a named list of the processed
+#' values.
+#'
+#' The raw input values should be in a named list. Some values may have names
+#' like \code{"x:shiny.date"}. This function would apply the \code{"shiny.date"}
+#' input handler to the value, and then rename the result to \code{"x"}, in the
+#' output.
+#'
+#' @param inputs A named list of input values.
+#' @param shinysession A Shiny session object.
+#'
+#' @seealso registerInputHandler
+#' @keywords internal
+applyInputHandlers <- function(inputs, shinysession = getDefaultReactiveDomain()) {
+  inputs <- mapply(applyInputHandler, names(inputs), inputs,
+                   MoreArgs = list(shinysession = shinysession),
+                   SIMPLIFY = FALSE)
+
+  # Convert names like "button1:shiny.action" to "button1"
+  names(inputs) <- vapply(
+    names(inputs),
+    function(name) { strsplit(name, ":")[[1]][1] },
+    FUN.VALUE = character(1)
+  )
+
+  inputs
+}
+
+
 # Takes a list-of-lists and returns a matrix. The lists
 # must all be the same length. NULL is replaced by NA.
 registerInputHandler("shiny.matrix", function(data, ...) {
@@ -89,10 +146,29 @@ 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)
-  as.Date(unlist(datelist))
+
+  res <- NULL
+  tryCatch({
+      res <- as.Date(unlist(datelist))
+    },
+    error = function(e) {
+      # It's possible for client to send a string like "99999-01-01", which
+      # as.Date can't handle.
+      warning(e$message)
+      res <<- as.Date(rep(NA, length(datelist)))
+    }
+  )
+
+  res
 })
 
 registerInputHandler("shiny.datetime", function(val, ...){
@@ -104,8 +180,41 @@ 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 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)
+
+  # `val$datapath` should be a filename without a path, for security reasons.
+  if (basename(val$datapath) != val$datapath) {
+    stop("Invalid '/' found in file input path.")
+  }
+
+  # Prepend the persistent dir
+  oldfile <- file.path(getCurrentRestoreContext()$dir, val$datapath)
+
+  # Copy the original file to a new temp dir, so that a restored session can't
+  # modify the original.
+  newdir <- file.path(tempdir(), createUniqueId(12))
+  dir.create(newdir)
+  val$datapath <- file.path(newdir, val$datapath)
+  file.copy(oldfile, val$datapath)
+
+  # Need to mark this input value with the correct serializer. When a file is
+  # uploaded the usual way (instead of being restored), this occurs in
+  # session$`@uploadEnd`.
+  .subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerFileInput)
+
+  val
+})

R/server.R

@@ -34,7 +34,7 @@ registerClient <- function(client) {
 #' JavaScript/CSS files available to their components.
 #'
 #' @param prefix The URL prefix (without slashes). Valid characters are a-z,
-#'   A-Z, 0-9, hyphen, period, and underscore; and must begin with a-z or A-Z.
+#'   A-Z, 0-9, hyphen, period, and underscore.
 #'   For example, a value of 'foo' means that any request paths that begin with
 #'   '/foo' will be mapped to the given directory.
 #' @param directoryPath The directory that contains the static resources to be
@@ -49,11 +49,10 @@ registerClient <- function(client) {
 #'
 #' @examples
 #' addResourcePath('datasets', system.file('data', package='datasets'))
-#'
 #' @export
 addResourcePath <- function(prefix, directoryPath) {
   prefix <- prefix[1]
-  if (!grepl('^[a-z][a-z0-9\\-_.]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
+  if (!grepl('^[a-z0-9\\-_][a-z0-9\\-_.]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
     stop("addResourcePath called with invalid prefix; please see documentation")
   }
 
@@ -141,7 +140,6 @@ resourcePathHandler <- function(req) {
 #'   })
 #' }
 #' }
-#'
 #' @export
 shinyServer <- function(func) {
   .globals$server <- list(func)
@@ -220,7 +218,8 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
           if (is.character(msg))
             msg <- charToRaw(msg)
 
-          if (isTRUE(getOption('shiny.trace'))) {
+          traceOption <- getOption('shiny.trace', FALSE)
+          if (isTRUE(traceOption) || traceOption == "recv") {
             if (binary)
               message("RECV ", '$$binary data$$')
             else
@@ -232,121 +231,105 @@ 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]]
-
-              splitName <- strsplit(name, ':')[[1]]
-              if (length(splitName) > 1) {
-                msg$data[[name]] <- NULL
-
-                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)
-
-                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
-                }
-              }
+          # 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)) {
+            bookmarkStore <- getShinyOption("bookmarkStore", default = "disable")
+            if (bookmarkStore == "disable") {
+              # If bookmarking is disabled, use empty context
+              shinysession$restoreContext <- RestoreContext$new()
+            } else {
+              # If there's bookmarked state, save it on the session object
+              shinysession$restoreContext <- RestoreContext$new(msg$data$.clientdata_url_search)
             }
           }
 
-          switch(
-            msg$method,
-            init = {
+          withRestoreContext(shinysession$restoreContext, {
 
-              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")
+            msg$data <- applyInputHandlers(msg$data)
+
+            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()
+            }
+
+            flushAllSessions()
           })
         })
       }
@@ -387,9 +370,9 @@ argsForServerFunc <- function(serverFunc, session) {
 }
 
 getEffectiveBody <- function(func) {
-  # Note: NULL values are OK. isS4(NULL) returns FALSE, body(NULL)
-  # returns NULL.
-  if (isS4(func) && class(func) == "functionWithTrace")
+  if (is.null(func))
+    NULL
+  else if (isS4(func) && class(func) == "functionWithTrace")
     body(func@original)
   else
     body(func)
@@ -447,6 +430,12 @@ startApp <- function(appObj, port, host, quiet) {
       message('\n', 'Listening on domain socket ', port)
     }
     mask <- attr(port, 'mask')
+    if (is.null(mask)) {
+      stop("`port` is not a valid domain socket (missing `mask` attribute). ",
+           "Note that if you're using the default `host` + `port` ",
+           "configuration (and not domain sockets), then `port` must ",
+           "be numeric, not a string.")
+    }
     return(startPipeServer(port, mask, handlerManager$createHttpuvApp()))
   }
 }
@@ -460,10 +449,7 @@ serviceApp <- function() {
     }
 
     flushReact()
-
-    for (shinysession in appsByToken$values()) {
-      shinysession$flushOutput()
-    }
+    flushAllSessions()
   }
 
   # If this R session is interactive, then call service() with a short timeout
@@ -476,6 +462,9 @@ serviceApp <- function() {
 
 .shinyServerMinVersion <- '0.3.4'
 
+# Global flag that's TRUE whenever we're inside of the scope of a call to runApp
+.globals$running <- FALSE
+
 #' Run Shiny Application
 #'
 #' Runs a Shiny application. This function normally does not return; interrupt R
@@ -517,6 +506,9 @@ serviceApp <- function() {
 #'   application. If set to \code{"normal"}, displays the application normally.
 #'   Defaults to \code{"auto"}, which displays the application in the mode given
 #'   in its \code{DESCRIPTION} file, if any.
+#' @param test.mode Should the application be launched in test mode? This is
+#'   only used for recording or running automated tests. Defaults to the
+#'   \code{shiny.testmode} option, or FALSE if the option is not set.
 #'
 #' @examples
 #' \dontrun{
@@ -529,6 +521,8 @@ serviceApp <- function() {
 #'
 #' ## Only run this example in interactive R sessions
 #' if (interactive()) {
+#'   options(device.ask.default = FALSE)
+#'
 #'   # Apps can be run without a server.r and ui.r file
 #'   runApp(list(
 #'     ui = bootstrapPage(
@@ -560,22 +554,76 @@ runApp <- function(appDir=getwd(),
                                             interactive()),
                    host=getOption('shiny.host', '127.0.0.1'),
                    workerId="", quiet=FALSE,
-                   display.mode=c("auto", "normal", "showcase")) {
+                   display.mode=c("auto", "normal", "showcase"),
+                   test.mode=getOption('shiny.testmode', FALSE)) {
   on.exit({
     handlerManager$clear()
   }, add = TRUE)
 
+  if (.globals$running) {
+    stop("Can't call `runApp()` from within `runApp()`. If your ",
+         "application code contains `runApp()`, please remove it.")
+  }
+  .globals$running <- TRUE
+  on.exit({
+    .globals$running <- FALSE
+  }, add = TRUE)
 
-  if (is.null(host) || is.na(host))
-    host <- '0.0.0.0'
+  # Enable per-app Shiny options
+  oldOptionSet <- .globals$options
+  on.exit({
+    .globals$options <- oldOptionSet
+  },add = TRUE)
 
   # Make warnings print immediately
-  ops <- options(warn = 1)
+  # Set pool.scheduler to support pool package
+  ops <- options(warn = 1, pool.scheduler = scheduleTask)
   on.exit(options(ops), add = TRUE)
 
+  appParts <- as.shiny.appobj(appDir)
+
+  # The lines below set some of the app's running options, which
+  # can be:
+  #   - left unspeficied (in which case the arguments' default
+  #     values from `runApp` kick in);
+  #   - passed through `shinyApp`
+  #   - passed through `runApp` (this function)
+  #   - passed through both `shinyApp` and `runApp` (the latter
+  #     takes precedence)
+  #
+  # Matrix of possibilities:
+  # | IN shinyApp | IN runApp | result       | check                                                                                                                                  |
+  # |-------------|-----------|--------------|----------------------------------------------------------------------------------------------------------------------------------------|
+  # | no          | no        | use defaults | exhaust all possibilities: if it's missing (runApp does not specify); THEN if it's not in shinyApp appParts$options; THEN use defaults |
+  # | yes         | no        | use shinyApp | if it's missing (runApp does not specify); THEN if it's in shinyApp appParts$options; THEN use shinyApp                                |
+  # | no          | yes       | use runApp   | if it's not missing (runApp specifies), use those                                                                                      |
+  # | yes         | yes       | use runApp   | if it's not missing (runApp specifies), use those                                                                                      |
+  #
+  # I tried to make this as compact and intuitive as possible,
+  # given that there are four distinct possibilities to check
+  appOps <- appParts$options
+  findVal <- function(arg, default) {
+    if (arg %in% names(appOps)) appOps[[arg]] else default
+  }
+
+  if (missing(port))
+    port <- findVal("port", port)
+  if (missing(launch.browser))
+    launch.browser <- findVal("launch.browser", launch.browser)
+  if (missing(host))
+    host <- findVal("host", host)
+  if (missing(quiet))
+    quiet <- findVal("quiet", quiet)
+  if (missing(display.mode))
+    display.mode <- findVal("display.mode", display.mode)
+  if (missing(test.mode))
+    test.mode <- findVal("test.mode", test.mode)
+
+  if (is.null(host) || is.na(host)) host <- '0.0.0.0'
+
   workerId(workerId)
 
-  if (nzchar(Sys.getenv('SHINY_PORT'))) {
+  if (inShinyServer()) {
     # If SHINY_PORT is set, we're running under Shiny Server. Check the version
     # to make sure it is compatible. Older versions of Shiny Server don't set
     # SHINY_SERVER_VERSION, those will return "" which is considered less than
@@ -592,6 +640,11 @@ runApp <- function(appDir=getwd(),
   # the display.mode parameter. The latter takes precedence.
   setShowcaseDefault(0)
 
+  .globals$testMode <- test.mode
+  if (test.mode) {
+    message("Running application in test mode.")
+  }
+
   # If appDir specifies a path, and display mode is specified in the
   # DESCRIPTION file at that path, apply it here.
   if (is.character(appDir)) {
@@ -607,21 +660,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)
 
@@ -642,7 +712,14 @@ runApp <- function(appDir=getwd(),
       }
       else {
         # Try up to 20 random ports
-        port <- p_randomInt(3000, 8000)
+        while (TRUE) {
+          port <- p_randomInt(3000, 8000)
+          # Reject ports in this range that are considered unsafe by Chrome
+          # http://superuser.com/questions/188058/which-ports-are-considered-unsafe-on-chrome
+          if (!port %in% c(3659, 4045, 6000, 6665:6669)) {
+            break
+          }
+        }
       }
 
       # Test port to see if we can use it
@@ -655,7 +732,11 @@ runApp <- function(appDir=getwd(),
     }
   }
 
-  appParts <- as.shiny.appobj(appDir)
+  # Extract appOptions (which is a list) and store them as shinyOptions, for
+  # this app. (This is the only place we have to store settings that are
+  # accessible both the UI and server portion of the app.)
+  unconsumeAppOptions(appParts$appOptions)
+
   # Set up the onEnd before we call onStart, so that it gets called even if an
   # error happens in onStart.
   if (!is.null(appParts$onEnd))
@@ -694,12 +775,16 @@ runApp <- function(appDir=getwd(),
   # Top-level ..stacktraceoff..; matches with ..stacktraceon in observe(),
   # reactive(), Callbacks$invoke(), and others
   ..stacktraceoff..(
-    captureStackTraces(
+    captureStackTraces({
+      # If any observers were created before runApp was called, this will make
+      # sure they run once the app starts. (Issue #1013)
+      scheduleFlush()
+
       while (!.globals$stopped) {
         serviceApp()
         Sys.sleep(0.001)
       }
-    )
+    })
   )
 
   if (isTRUE(.globals$reterror)) {
@@ -718,7 +803,6 @@ runApp <- function(appDir=getwd(),
 #'
 #' @param returnValue The value that should be returned from
 #'   \code{\link{runApp}}.
-#'
 #' @export
 stopApp <- function(returnValue = invisible()) {
   # reterror will indicate whether retval is an error (i.e. it should be passed
@@ -837,7 +921,6 @@ runExample <- function(example=NA,
 #' # ...or as a single app object
 #' runGadget(shinyApp(ui, server))
 #' }
-#'
 #' @export
 runGadget <- function(app, server = NULL, port = getOption("shiny.port"),
   viewer = paneViewer(), stopOnCancel = TRUE) {
@@ -933,3 +1016,9 @@ browserViewer <- function(browser = getOption("browser")) {
     utils::browseURL(url, browser = browser)
   }
 }
+
+# Returns TRUE if we're running in Shiny Server or other hosting environment,
+# otherwise returns FALSE.
+inShinyServer <- function() {
+  nzchar(Sys.getenv('SHINY_PORT'))
+}

R/shiny-options.R

@@ -0,0 +1,83 @@
+.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 <- dropNulls(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
+}
+
+
+# Get specific shiny options and put them in a list, reset those shiny options,
+# and then return the options list. This should be during the creation of a
+# shiny app object, which happens before another option frame is added to the
+# options stack (the new option frame is added when the app is run). This
+# function "consumes" the options when the shinyApp object is created, so the
+# options won't affect another app that is created later.
+consumeAppOptions <- function() {
+  options <- list(
+    appDir = getwd(),
+    bookmarkStore = getShinyOption("bookmarkStore")
+  )
+
+  shinyOptions(appDir = NULL, bookmarkStore = NULL)
+
+  options
+}
+
+# Do the inverse of consumeAppOptions. This should be called once the app is
+# started.
+unconsumeAppOptions <- function(options) {
+  if (!is.null(options)) {
+    do.call(shinyOptions, options)
+  }
+}

R/shinyui.R

@@ -14,17 +14,17 @@ NULL
 #' # now we can just write "static" content without withMathJax()
 #' div("more math here $$\\sqrt{2}$$")
 withMathJax <- function(...) {
-  path <- 'https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML'
+  path <- 'https://mathjax.rstudio.com/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML'
   tagList(
     tags$head(
       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]);'))
   )
 }
 
-renderPage <- function(ui, connection, showcase=0) {
+renderPage <- function(ui, connection, showcase=0, testMode=FALSE) {
   # If the ui is a NOT complete document (created by htmlTemplate()), then do some
   # preprocessing and make sure it's a complete document.
   if (!inherits(ui, "html_document")) {
@@ -44,11 +44,19 @@ 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("jquery", "1.12.4", c(href="shared"), script = "jquery.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")
   )
+
+  if (testMode) {
+    # Add code injection listener if in test mode
+    shiny_deps[[length(shiny_deps) + 1]] <-
+      htmlDependency("shiny-testmode", utils::packageVersion("shiny"),
+        c(href="shared"), script = "shiny-testmode.js")
+  }
+
   html <- renderDocument(ui, shiny_deps, processDep = createWebDependency)
   writeUTF8(html, con = connection)
 }
@@ -63,7 +71,6 @@ renderPage <- function(ui, connection, showcase=0) {
 #'
 #' @param ui A user interace definition
 #' @return The user interface definition, without modifications or side effects.
-#'
 #' @export
 shinyUI <- function(ui) {
   .globals$ui <- list(ui)
@@ -90,21 +97,40 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
       if (!is.null(mode))
         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())
-      }
+
+    testMode <- .globals$testMode %OR% FALSE
+
+    # Create a restore context using query string
+    bookmarkStore <- getShinyOption("bookmarkStore", default = "disable")
+    if (bookmarkStore == "disable") {
+      # If bookmarking is disabled, use empty context
+      restoreContext <- RestoreContext$new()
     } else {
-      ui
+      restoreContext <- RestoreContext$new(req$QUERY_STRING)
     }
+
+    withRestoreContext(restoreContext, {
+      uiValue <- NULL
+
+      if (is.function(ui)) {
+        if (length(formals(ui)) > 0) {
+          # No corresponding ..stacktraceoff.., this is pure user code
+          uiValue <- ..stacktraceon..(ui(req))
+        } else {
+          # No corresponding ..stacktraceoff.., this is pure user code
+          uiValue <- ..stacktraceon..(ui())
+        }
+      } else {
+        if (getCurrentRestoreContext()$active) {
+          warning("Trying to restore saved app state, but UI code must be a function for this to work! See ?enableBookmarking")
+        }
+        uiValue <- ui
+      }
+    })
     if (is.null(uiValue))
       return(NULL)
 
-    renderPage(uiValue, textConn, showcaseMode)
+    renderPage(uiValue, textConn, showcaseMode, testMode)
     html <- paste(readLines(textConn, encoding = 'UTF-8'), collapse='\n')
     return(httpResponse(200, content=enc2utf8(html)))
   }

R/shinywrappers.R

@@ -12,24 +12,74 @@ 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
@@ -38,6 +88,26 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
   useRenderFunction(x, inline = inline)
 }
 
+
+#' Mark a render function with attributes that will be used by the output
+#'
+#' @inheritParams markRenderFunction
+#' @param snapshotExclude If TRUE, exclude the output from test snapshots.
+#'
+#' @keywords internal
+markOutputAttrs <- function(renderFunc, snapshotExclude = NULL) {
+  # Add the outputAttrs attribute if necessary
+  if (is.null(attr(renderFunc, "outputAttrs", TRUE))) {
+    attr(renderFunc, "outputAttrs") <- list()
+  }
+
+  if (!is.null(snapshotExclude)) {
+    attr(renderFunc, "outputAttrs")$snapshotExclude <- snapshotExclude
+  }
+
+  renderFunc
+}
+
 #' Image file output
 #'
 #' Renders a reactive image that is suitable for assigning to an \code{output}
@@ -69,13 +139,24 @@ 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()) {
+#' options(device.ask.default = FALSE)
 #'
-#' 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 +178,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 +196,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 +206,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 +231,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)
 }
 
 
@@ -155,7 +241,7 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
 #'
 #' Makes a reactive version of the given function that captures any printed
 #' output, and also captures its printable result (unless
-#' \code{\link{invisible}}), into a string. The resulting function is suitable
+#' \code{\link[base]{invisible}}), into a string. The resulting function is suitable
 #' for assigning to an  \code{output} slot.
 #'
 #' The corresponding HTML output tag can be anything (though \code{pre} is
@@ -167,34 +253,33 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
 #'
 #' Note that unlike most other Shiny output functions, if the given function
 #' returns \code{NULL} then \code{NULL} will actually be visible in the output.
-#' To display nothing, make your function return \code{\link{invisible}()}.
+#' To display nothing, make your function return \code{\link[base]{invisible}()}.
 #'
 #' @param expr An expression that may print output and/or return a printable R
 #'   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).
-#' @param width The value for \code{\link{options}('width')}.
+#'   is useful if you want to save an expression in a variable.
+#' @param width The value for \code{\link[base]{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,26 +300,25 @@ 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.
 #'
 #' @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 +334,44 @@ 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 +397,42 @@ 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)
-  }))
+  }
+  snapshotExclude(
+    markRenderFunction(downloadButton, renderFunc, outputArgs = outputArgs)
+  )
 }
 
 #' Table output with the JavaScript library DataTables
@@ -347,7 +443,7 @@ downloadHandler <- function(filename, content, contentType=NA) {
 #' the server infrastructure.
 #'
 #' For the \code{options} argument, the character elements that have the class
-#' \code{"AsIs"} (usually returned from \code{\link{I}()}) will be evaluated in
+#' \code{"AsIs"} (usually returned from \code{\link[base]{I}()}) will be evaluated in
 #' JavaScript. This is useful when the type of the option value is not supported
 #' in JSON, e.g., a JavaScript function, which can be obtained by evaluating a
 #' character string. Note this only applies to the root-level elements of the
@@ -367,6 +463,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 +501,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 +531,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

@@ -18,7 +18,8 @@ licenseLink <- function(licenseName) {
     "Artistic-2.0" = "http://www.r-project.org/Licenses/Artistic-2.0",
     "BSD_2_clause" = "http://www.r-project.org/Licenses/BSD_2_clause",
     "BSD_3_clause" = "http://www.r-project.org/Licenses/BSD_3_clause",
-    "MIT" = "http://www.r-project.org/Licenses/MIT")
+    "MIT" = "http://www.r-project.org/Licenses/MIT",
+    "CC-BY-SA-4.0" = "https://www.r-project.org/Licenses/CC-BY-SA-4.0")
   if (exists(licenseName, where = licenses)) {
     tags$a(href=licenses[[licenseName]], licenseName)
   } else {
@@ -31,7 +32,7 @@ licenseLink <- function(licenseName) {
 showcaseHead <- function() {
 
   deps  <- list(
-    htmlDependency("jqueryui", "1.11.4", c(href="shared/jqueryui"),
+    htmlDependency("jqueryui", "1.12.1", c(href="shared/jqueryui"),
       script = "jquery-ui.min.js"),
     htmlDependency("showdown", "0.3.1", c(href="shared/showdown/compressed"),
       script = "showdown.js"),
@@ -77,10 +78,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 +139,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 +222,4 @@ showcaseUI <- function(ui) {
     showcaseBody(ui)
   )
 }
+

R/test-export.R

@@ -0,0 +1,61 @@
+#' Register expressions for export in test mode
+#'
+#' This function registers expressions that will be evaluated when a test export
+#' event occurs. These events are triggered by accessing a snapshot URL.
+#'
+#' This function only has an effect if the app is launched in test mode. This is
+#' done by calling \code{runApp()} with \code{test.mode=TRUE}, or by setting the
+#' global option \code{shiny.testmode} to \code{TRUE}.
+#'
+#' @param quoted_ Are the expression quoted? Default is \code{FALSE}.
+#' @param env_ The environment in which the expression should be evaluated.
+#' @param session_ A Shiny session object.
+#' @param ... Named arguments that are quoted or unquoted expressions that will
+#'   be captured and evaluated when snapshot URL is visited.
+#' @examples
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'
+#' options(shiny.testmode = TRUE)
+#'
+#' # This application shows the test snapshot URL; clicking on it will
+#' # fetch the input, output, and exported values in JSON format.
+#' shinyApp(
+#'   ui = basicPage(
+#'     h4("Snapshot URL: "),
+#'     uiOutput("url"),
+#'     h4("Current values:"),
+#'     verbatimTextOutput("values"),
+#'     actionButton("inc", "Increment x")
+#'   ),
+#'
+#'   server = function(input, output, session) {
+#'     vals <- reactiveValues(x = 1)
+#'     y <- reactive({ vals$x + 1 })
+#'
+#'     observeEvent(input$inc, {
+#'       vals$x <<- vals$x + 1
+#'     })
+#'
+#'     exportTestValues(
+#'       x = vals$x,
+#'       y = y()
+#'     )
+#'
+#'     output$url <- renderUI({
+#'       url <- session$getTestSnapshotUrl(format="json")
+#'       a(href = url, url)
+#'     })
+#'
+#'     output$values <- renderText({
+#'       paste0("vals$x: ", vals$x, "\ny: ", y())
+#'     })
+#'   }
+#' )
+#' }
+#' @export
+exportTestValues <- function(..., quoted_ = FALSE, env_ = parent.frame(),
+  session_ = getDefaultReactiveDomain())
+{
+  session_$exportTestValues(..., quoted_ = quoted_, env_ = env_)
+}

R/timer.R

@@ -22,6 +22,11 @@ TimerCallbacks <- R6Class(
       .times <<- data.frame()
     },
     schedule = function(millis, func) {
+      # If args could fail to evaluate, let's make them do that before
+      # we change any state
+      force(millis)
+      force(func)
+
       id <- .nextId
       .nextId <<- .nextId + 1L
 
@@ -56,7 +61,7 @@ TimerCallbacks <- R6Class(
     },
     executeElapsed = function() {
       elapsed <- takeElapsed()
-      if (length(elapsed) == 0)
+      if (nrow(elapsed) == 0)
         return(FALSE)
 
       for (id in elapsed$id) {
@@ -71,3 +76,16 @@ TimerCallbacks <- R6Class(
 )
 
 timerCallbacks <- TimerCallbacks$new()
+
+scheduleTask <- function(millis, callback) {
+  cancelled <- FALSE
+  timerCallbacks$schedule(millis, function() {
+    if (!cancelled)
+      callback()
+  })
+
+  function() {
+    cancelled <<- TRUE
+    callback <<- NULL # to allow for callback to be gc'ed
+  }
+}

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) {
@@ -30,6 +39,44 @@ updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
   session$sendInputMessage(inputId, message)
 }
 
+#' Change the value of a textarea input on the client
+#'
+#' @template update-input
+#' @param value The value to set for the input object.
+#'
+#' @seealso \code{\link{textAreaInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 0, 20, 10),
+#'   textAreaInput("inText", "Input textarea"),
+#'   textAreaInput("inText2", "Input textarea 2")
+#' )
+#'
+#' 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
+#'
+#'     # This will change the value of input$inText, based on x
+#'     updateTextAreaInput(session, "inText", value = paste("New text", x))
+#'
+#'     # Can also set the label, this time for input$inText2
+#'     updateTextAreaInput(session, "inText2",
+#'       label = paste("New label", x),
+#'       value = paste("New text", x))
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#' @export
+updateTextAreaInput <- updateTextInput
+
 
 #' Change the value of a checkbox input on the client
 #'
@@ -39,26 +86,87 @@ 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
 #' @param value The desired date value. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   \code{yyyy-mm-dd} format. Supply \code{NA} to clear the date.
 #' @param min The minimum allowed date. Either a Date object, or a string in
 #'   \code{yyyy-mm-dd} format.
 #' @param max The maximum allowed date. Either a Date object, or a string in
@@ -67,32 +175,44 @@ 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("n", "Day of month", 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.
-#'     x <- input$controller
-#'
+#'     date <- as.Date(paste0("2013-04-", input$n))
 #'     updateDateInput(session, "inDate",
-#'       label = paste("Date label", x),
-#'       value = paste("2013-04-", x, sep=""),
-#'       min   = paste("2013-04-", x-1, sep=""),
-#'       max   = paste("2013-04-", x+1, sep="")
+#'       label = paste("Date label", input$n),
+#'       value = date,
+#'       min   = date - 3,
+#'       max   = date + 3
 #'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateDateInput <- function(session, inputId, label = NULL, value = NULL,
                             min = NULL, max = NULL) {
 
-  # If value is a date object, convert it to a string with yyyy-mm-dd format
-  # Same for min and max
-  if (inherits(value, "Date"))  value <- format(value, "%Y-%m-%d")
-  if (inherits(min, "Date"))    min   <- format(min,   "%Y-%m-%d")
-  if (inherits(max, "Date"))    max   <- format(max,   "%Y-%m-%d")
+  # Make sure values are NULL or Date objects. This is so we can ensure that
+  # they will be formatted correctly. For example, the string "2016-08-9" is not
+  # correctly formatted, but the conversion to Date and back to string will fix
+  # it.
+  formatDate <- function(x) {
+    if (is.null(x))
+      return(NULL)
+    format(as.Date(x), "%Y-%m-%d")
+  }
+  value <- formatDate(value)
+  min   <- formatDate(min)
+  max   <- formatDate(max)
 
   message <- dropNulls(list(label=label, value=value, min=min, max=max))
   session$sendInputMessage(inputId, message)
@@ -103,9 +223,9 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 #'
 #' @template update-input
 #' @param start The start date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   \code{yyyy-mm-dd} format. Supplying \code{NA} clears the start date.
 #' @param end The end date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   \code{yyyy-mm-dd} format. Supplying \code{NA} clears the end date.
 #' @param min The minimum allowed date. Either a Date object, or a string in
 #'   \code{yyyy-mm-dd} format.
 #' @param max The maximum allowed date. Either a Date object, or a string in
@@ -114,20 +234,29 @@ 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("n", "Day of month", 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.
-#'     x <- input$controller
+#'     date <- as.Date(paste0("2013-04-", input$n))
 #'
 #'     updateDateRangeInput(session, "inDateRange",
-#'       label = paste("Date range label", x),
-#'       start = paste("2013-01-", x, sep=""))
-#'       end = paste("2013-12-", x, sep=""))
+#'       label = paste("Date range label", input$n),
+#'       start = date - 1,
+#'       end = date + 1,
+#'       min = date - 5,
+#'       max = date + 5
+#'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateDateRangeInput <- function(session, inputId, label = NULL,
@@ -142,7 +271,7 @@ updateDateRangeInput <- function(session, inputId, label = NULL,
 
   message <- dropNulls(list(
     label = label,
-    value = c(start, end),
+    value = dropNulls(list(start = start, end = end)),
     min = min,
     max = max
   ))
@@ -162,22 +291,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 +342,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 +364,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,
@@ -304,16 +452,18 @@ updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
 
 
 updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
-                               selected = NULL, inline = FALSE,
-                               type = 'checkbox') {
-  if (!is.null(choices))
-    choices <- choicesWithNames(choices)
-  if (!is.null(selected))
-    selected <- validateSelected(selected, choices, inputId)
+                               selected = NULL, inline = FALSE, type = NULL,
+                               choiceNames = NULL, choiceValues = NULL) {
+  if (is.null(type)) stop("Please specify the type ('checkbox' or 'radio')")
 
-  options <- if (!is.null(choices)) {
+  args <- normalizeChoicesArgs(choices, choiceNames, choiceValues, mustExist = FALSE)
+
+  if (!is.null(selected)) selected <- as.character(selected)
+
+  options <- if (!is.null(args$choiceValues)) {
     format(tagList(
-      generateOptions(inputId, choices, selected, inline, type = type)
+      generateOptions(session$ns(inputId), selected, inline, type,
+        args$choiceNames, args$choiceValues)
     ))
   }
 
@@ -330,37 +480,42 @@ 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,
-                                     choices = NULL, selected = NULL,
-                                     inline = FALSE) {
-  updateInputOptions(session, inputId, label, choices, selected, inline)
+  choices = NULL, selected = NULL, inline = FALSE,
+  choiceNames = NULL, choiceValues = NULL) {
+  updateInputOptions(session, inputId, label, choices, selected,
+                     inline, "checkbox", choiceNames, choiceValues)
 }
 
 
@@ -372,36 +527,43 @@ 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,
-                               selected = NULL, inline = FALSE) {
+                               selected = NULL, inline = FALSE,
+                               choiceNames = NULL, choiceValues = NULL) {
   # you must select at least one radio button
-  if (is.null(selected) && !is.null(choices)) selected <- choices[[1]]
-  updateInputOptions(session, inputId, label, choices, selected, inline, type = 'radio')
+  if (is.null(selected)) {
+    if (!is.null(choices)) selected <- choices[[1]]
+    else if (!is.null(choiceValues)) selected <- choiceValues[[1]]
+  }
+  updateInputOptions(session, inputId, label, choices, selected,
+    inline, 'radio', choiceNames, choiceValues)
 }
 
 
@@ -413,39 +575,41 @@ 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,
                               selected = NULL) {
   choices <- if (!is.null(choices)) choicesWithNames(choices)
-  if (!is.null(selected))
-    selected <- validateSelected(selected, choices, inputId)
+  if (!is.null(selected)) selected <- as.character(selected)
   options <- if (!is.null(choices)) selectOptions(choices, selected)
   message <- dropNulls(list(label = label, options = options, value = selected))
   session$sendInputMessage(inputId, message)
@@ -465,7 +629,7 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
     res <- checkAsIs(options)
     cfg <- tags$script(
       type = 'application/json',
-      `data-for` = inputId,
+      `data-for` = session$ns(inputId),
       `data-eval` = if (length(res$eval)) HTML(toJSON(res$eval)),
       HTML(toJSON(res$options))
     )

R/utils.R

@@ -23,7 +23,6 @@ NULL
 #' rnormA(3)  # [1]  1.8285879 -0.7468041 -0.4639111
 #' rnormA(5)  # [1]  1.8285879 -0.7468041 -0.4639111 -1.6510126 -1.4686924
 #' rnormB(5)  # [1] -0.7946034  0.2568374 -0.6567597  1.2451387 -0.8375699
-#'
 #' @export
 repeatable <- function(rngfunc, seed = stats::runif(1, 0, .Machine$integer.max)) {
   force(seed)
@@ -155,6 +154,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 +182,55 @@ anyUnnamed <- function(x) {
   any(!nzchar(nms))
 }
 
+
+# Given a vector/list, returns a named vector (the labels will be blank).
+asNamedVector <- function(x) {
+  if (!is.null(names(x)))
+    return(x)
+
+  names(x) <- rep.int("", length(x))
+  x
+}
+
+# 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]
+}
+
+# Sort a vector by the names of items. If there are multiple items with the
+# same name, preserve the original order of those items. For empty
+# vectors/lists/NULL, return the original value.
+sortByName <- function(x) {
+  if (anyUnnamed(x))
+    stop("All items must be named")
+
+  # Special case for empty vectors/lists, and NULL
+  if (length(x) == 0)
+    return(x)
+
+  x[order(names(x))]
+}
+
+# Wrapper around list2env with a NULL check. In R <3.2.0, if an empty unnamed
+# list is passed to list2env(), it errors. But an empty named list is OK. For
+# R >=3.2.0, this wrapper is not necessary.
+list2env2 <- function(x, ...) {
+  # Ensure that zero-length lists have a name attribute
+   if (length(x) == 0)
+    attr(x, "names") <- character(0)
+
+  list2env(x, ...)
+}
+
 # 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 +273,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.
@@ -343,8 +411,6 @@ makeFunction <- function(args = pairlist(), body, env = parent.frame()) {
 #' @param env The desired environment for the function. Defaults to the
 #'   calling environment two steps back.
 #' @param quoted Is the expression quoted?
-#' @param caller_offset If specified, the offset in the callstack of the
-#'   functiont to be treated as the caller.
 #'
 #' @examples
 #' # Example of a new renderer, similar to renderText
@@ -378,35 +444,14 @@ makeFunction <- function(args = pairlist(), body, env = parent.frame()) {
 #'
 #' isolate(tripleA())
 #' # "text, text, text"
-#'
 #' @export
-exprToFunction <- function(expr, env=parent.frame(2), quoted=FALSE,
-                           caller_offset=1) {
-  # Get the quoted expr from two calls back
-  expr_sub <- eval(substitute(substitute(expr)), parent.frame(caller_offset))
-
-  # Check if expr is a function, making sure not to evaluate expr, in case it
-  # is actually an unquoted expression.
-  # If expr is a single token, then indexing with [[ will error; if it has multiple
-  # tokens, then [[ works. In the former case it will be a name object; in the
-  # latter, it will be a language object.
-  if (!is.null(expr_sub) && !is.name(expr_sub) && expr_sub[[1]] == as.name('function')) {
-    # Get name of function that called this function
-    called_fun <- sys.call(-1 * caller_offset)[[1]]
-
-    shinyDeprecated(msg = paste("Passing functions to '", called_fun,
-      "' is deprecated. Please use expressions instead. See ?", called_fun,
-      " for more information.", sep=""))
-    return(expr)
+exprToFunction <- function(expr, env=parent.frame(), quoted=FALSE) {
+  if (!quoted) {
+    expr <- eval(substitute(substitute(expr)), parent.frame())
   }
 
-  if (quoted) {
-    # expr is a quoted expression
-    makeFunction(body=expr, env=env)
-  } else {
-    # expr is an unquoted expression
-    makeFunction(body=expr_sub, env=env)
-  }
+  # expr is a quoted expression
+  makeFunction(body=expr, env=env)
 }
 
 #' Install an expression as a function
@@ -432,7 +477,6 @@ exprToFunction <- function(expr, env=parent.frame(2), quoted=FALSE,
 #'   the name of the calling function.
 #' @param wrappedWithLabel,..stacktraceon Advanced use only. For stack manipulation purposes; see
 #'   \code{\link{stacktrace}}.
-#'
 #' @export
 installExprFunction <- function(expr, name, eval.env = parent.frame(2),
                                 quoted = FALSE,
@@ -440,7 +484,12 @@ installExprFunction <- function(expr, name, eval.env = parent.frame(2),
                                 label = deparse(sys.call(-1)[[1]]),
                                 wrappedWithLabel = TRUE,
                                 ..stacktraceon = FALSE) {
-  func <- exprToFunction(expr, eval.env, quoted, 2)
+  if (!quoted) {
+    quoted <- TRUE
+    expr <- eval(substitute(substitute(expr)), parent.frame())
+  }
+
+  func <- exprToFunction(expr, eval.env, quoted)
   if (length(label) > 1) {
     # Just in case the deparsed code is more complicated than we imagine. If we
     # have a label with length > 1 it causes warnings in wrapFunctionLabel.
@@ -448,9 +497,10 @@ installExprFunction <- function(expr, name, eval.env = parent.frame(2),
   }
   if (wrappedWithLabel) {
     func <- wrapFunctionLabel(func, label, ..stacktraceon = ..stacktraceon)
+  } else {
+    registerDebugHook(name, assign.env, label)
   }
   assign(name, func, envir = assign.env)
-  registerDebugHook(name, assign.env, label)
 }
 
 #' Parse a GET query string from a URL
@@ -470,7 +520,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)
@@ -486,7 +536,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) {
@@ -498,6 +548,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))
@@ -613,7 +665,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) {
@@ -663,6 +718,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']] != '') {
@@ -863,6 +933,143 @@ 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
+}
+
+#***********************************************************************#
+#**** Keep this function internal for now, may chnage in the future ****#
+#***********************************************************************#
+# #' Propagate an error through Shiny, but catch it before it throws
+# #'
+# #' Throws a type of exception that is caught by observers. When such an
+# #' exception is triggered, all reactive links are broken. So, essentially,
+# #' \code{reactiveStop()} behaves just like \code{stop()}, except that
+# #' instead of ending the session, it is silently swalowed by Shiny.
+# #'
+# #' This function should be used when you want to disrupt the reactive
+# #' links in a reactive chain, but do not want to end the session. For
+# #' example, this enables you to disallow certain inputs, but get back
+# #' to business as usual when valid inputs are re-entered.
+# #' \code{reactiveStop} is also called internally by Shiny to create
+# #' special errors, such as the ones generated by \code{\link{validate}()},
+# #' \code{\link{req}()} and \code{\link{cancelOutput}()}.
+# #'
+# #' @param message An optional error message.
+# #' @param class An optional class to add to the error.
+# #' @export
+# #' @examples
+# #' ## Note: the breaking of the reactive chain that happens in the app
+# #' ## below (when input$txt = 'bad' and input$allowBad = 'FALSE') is
+# #' ## easily visualized with `showReactLog()`
+# #'
+# #' ## Only run examples in interactive R sessions
+# #' if (interactive()) {
+# #'
+# #' ui <- fluidPage(
+# #'   textInput('txt', 'Enter some text...'),
+# #'   selectInput('allowBad', 'Allow the string \'bad\'?',
+# #'               c('TRUE', 'FALSE'), selected = 'FALSE')
+# #' )
+# #'
+# #' server <- function(input, output) {
+# #'   val <- reactive({
+# #'     if (!(as.logical(input$allowBad))) {
+# #'       if (identical(input$txt, "bad")) {
+# #'         reactiveStop()
+# #'       }
+# #'     }
+## '   })
+# #'
+# #'   observe({
+# #'     val()
+# #'   })
+# #' }
+# #'
+# #' shinyApp(ui, server)
+# #' }
+# #' @export
+reactiveStop <- function(message = "", class = NULL) {
+  stopWithCondition(c("shiny.silent.error", class), message)
+}
+
 #' Validate input values and other conditions
 #'
 #' For an output rendering function (e.g. \code{\link{renderPlot}()}), you may
@@ -919,15 +1126,17 @@ columnToRowData <- function(data) {
 #'   \code{shiny-output-error-} prepended to this value.
 #' @export
 #' @examples
-#' # in ui.R
-#' fluidPage(
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#' options(device.ask.default = FALSE)
+#'
+#' ui <- fluidPage(
 #'   checkboxGroupInput('in1', 'Check some letters', choices = head(LETTERS)),
 #'   selectizeInput('in2', 'Select a state', choices = state.name),
 #'   plotOutput('plot')
 #' )
 #'
-#' # in server.R
-#' function(input, output) {
+#' server <- function(input, output) {
 #'   output$plot <- renderPlot({
 #'     validate(
 #'       need(input$in1, 'Check at least one letter!'),
@@ -936,6 +1145,10 @@ columnToRowData <- function(data) {
 #'     plot(1:10, main = paste(c(input$in1, input$in2), collapse = ', '))
 #'   })
 #' }
+#'
+#' shinyApp(ui, server)
+#'
+#' }
 validate <- function(..., errorClass = character(0)) {
   results <- sapply(list(...), function(x) {
     # Detect NULL or NA
@@ -956,8 +1169,7 @@ 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"))
+  reactiveStop(paste(results, collapse="\n"), c(errorClass, "validation"))
 }
 
 #' @param expr An expression to test. The condition will pass if the expression
@@ -1019,7 +1231,7 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #' \strong{Truthy and falsy values}
 #'
 #' The terms "truthy" and "falsy" generally indicate whether a value, when
-#' coerced to a \code{\link{logical}}, is \code{TRUE} or \code{FALSE}. We use
+#' coerced to a \code{\link[base]{logical}}, is \code{TRUE} or \code{FALSE}. We use
 #' the term a little loosely here; our usage tries to match the intuitive
 #' notions of "Is this value missing or available?", or "Has the user provided
 #' an answer?", or in the case of action buttons, "Has the button been
@@ -1051,14 +1263,69 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #'
 #' \code{req(input$a != 0)}
 #'
-#' @param ... Values to check for truthiness.
-#' @return The first value that was passed in.
+#' \strong{Using \code{req(FALSE)}}
 #'
+#' You can use \code{req(FALSE)} (i.e. no condition) if you've already performed
+#' all the checks you needed to by that point and just want to stop the reactive
+#' chain now. There is no advantange to this, except perhaps ease of readibility
+#' if you have a complicated condition to check for (or perhaps if you'd like to
+#' divide your condition into nested \code{if} statements).
+#'
+#' \strong{Using \code{cancelOutput = TRUE}}
+#'
+#' When \code{req(..., cancelOutput = TRUE)} is used, the "silent" exception is
+#' also raised, but it is treated slightly differently if one or more outputs are
+#' currently being evaluated. In those cases, the reactive chain does not proceed
+#' or update, but the output(s) are left is whatever state they happen to be in
+#' (whatever was their last valid state).
+#'
+#' Note that this is always going to be the case if
+#' this is used inside an output context (e.g. \code{output$txt <- ...}). It may
+#' or may not be the case if it is used inside a non-output context (e.g.
+#' \code{\link{reactive}}, \code{\link{observe}} or \code{\link{observeEvent}})
+#' -- depending on whether or not there is an \code{output$...} that is triggered
+#' as a result of those calls. See the examples below for concrete scenarios.
+#'
+#' @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.
+#' @param x An expression whose truthiness value we want to determine
+#' @return The first value that was passed in.
 #' @export
-req <- function(...) {
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'   ui <- fluidPage(
+#'     textInput('data', 'Enter a dataset from the "datasets" package', 'cars'),
+#'     p('(E.g. "cars", "mtcars", "pressure", "faithful")'), hr(),
+#'     tableOutput('tbl')
+#'   )
+#'
+#'   server <- function(input, output) {
+#'     output$tbl <- renderTable({
+#'
+#'       ## to require that the user types something, use: `req(input$data)`
+#'       ## but better: require that input$data is valid and leave the last
+#'       ## valid table up
+#'       req(exists(input$data, "package:datasets", inherits = FALSE),
+#'           cancelOutput = TRUE)
+#'
+#'       head(get(input$data, "package:datasets", inherits = FALSE))
+#'     })
+#'   }
+#'
+#'   shinyApp(ui, server)
+#' }
+req <- function(..., cancelOutput = FALSE) {
   dotloop(function(item) {
-    if (!isTruthy(item))
-      stopWithCondition("validation", "")
+    if (!isTruthy(item)) {
+      if (isTRUE(cancelOutput)) {
+        cancelOutput()
+      } else {
+        reactiveStop(class = "validation")
+      }
+    }
   }, ...)
 
   if (!missing(..1))
@@ -1067,6 +1334,46 @@ req <- function(...) {
     invisible()
 }
 
+#***********************************************************************#
+#**** Keep this function internal for now, may chnage in the future ****#
+#***********************************************************************#
+# #' 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
+# #' @examples
+# #' ## Only run examples in interactive R sessions
+# #' if (interactive()) {
+# #'
+# #' # uncomment the desired line to experiment with cancelOutput() vs. req()
+# #'
+# #' ui <- fluidPage(
+# #'   textInput('txt', 'Enter text'),
+# #'   textOutput('check')
+# #' )
+# #'
+# #' server <- function(input, output) {
+# #'   output$check <- renderText({
+# #'     # req(input$txt)
+# #'     if (input$txt == 'hi') return('hi')
+# #'     else if (input$txt == 'bye') return('bye')
+# #'     # else cancelOutput()
+# #'   })
+# #' }
+# #'
+# #' shinyApp(ui, server)
+# #' }
+cancelOutput <- function() {
+  reactiveStop(class = "shiny.output.cancel")
+}
+
 # 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.
@@ -1079,6 +1386,8 @@ dotloop <- function(fun_, ...) {
   invisible()
 }
 
+#' @export
+#' @rdname req
 isTruthy <- function(x) {
   if (inherits(x, 'try-error'))
     return(FALSE)
@@ -1107,7 +1416,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)
 }
@@ -1158,6 +1467,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'
 }
 
@@ -1190,7 +1503,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,6 +1555,7 @@ wrapFunctionLabel <- function(func, name, ..stacktraceon = FALSE) {
     stop("Invalid name for wrapFunctionLabel: ", name)
   }
   assign(name, func, environment())
+  registerDebugHook(name, environment(), name)
 
   relabelWrapper <- eval(substitute(
     function(...) {
@@ -1253,3 +1571,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 }
+  )
+)

README.md

@@ -1,6 +1,8 @@
 # Shiny
 
-[![Build Status](https://travis-ci.org/rstudio/shiny.svg?branch=master)](https://travis-ci.org/rstudio/shiny)
+*Travis:* [![Travis Build Status](https://travis-ci.org/rstudio/shiny.svg?branch=master)](https://travis-ci.org/rstudio/shiny)
+
+*AppVeyor:* [![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/rstudio/shiny?branch=master&svg=true)](https://ci.appveyor.com/project/rstudio/shiny)
 
 Shiny is a new package from RStudio that makes it incredibly easy to build interactive web applications with R.
 
@@ -12,9 +14,9 @@ For an introduction and examples, visit the [Shiny Dev Center](http://shiny.rstu
 * Shiny applications are automatically "live" in the same way that spreadsheets are live. Outputs change instantly as users modify inputs, without requiring a reload of the browser.
 * Shiny user interfaces can be built entirely using R, or can be written directly in HTML, CSS, and JavaScript for more flexibility.
 * Works in any R environment (Console R, Rgui for Windows or Mac, ESS, StatET, RStudio, etc.).
-* Attractive default UI theme based on [Bootstrap](http://getbootstrap.com/2.3.2/).
+* Attractive default UI theme based on [Bootstrap](http://getbootstrap.com/).
 * A highly customizable slider widget with built-in support for animation.
-* Pre-built output widgets for displaying plots, tables, and printed output of R objects.
+* Prebuilt output widgets for displaying plots, tables, and printed output of R objects.
 * Fast bidirectional communication between the web browser and R using the [httpuv](https://github.com/rstudio/httpuv) package.
 * Uses a [reactive](http://en.wikipedia.org/wiki/Reactive_programming) programming model that eliminates messy event handling code, so you can focus on the code that really matters.
 * Develop and redistribute your own Shiny widgets that other developers can easily drop into their own applications (coming soon!).
@@ -57,6 +59,10 @@ devtools::install_version("shiny", version = "0.10.2.2")
 
 The Javascript code in Shiny is minified using tools that run on Node.js. See the tools/ directory for more information.
 
+## Guidelines for contributing
+
+We welcome contributions to the **shiny** package. Please see our [CONTRIBUTING.md](CONTRIBUTING.md) file for detailed guidelines of how to contribute.
+
 ## License
 
 The shiny package is licensed under the GPLv3. See these files in the inst directory for additional details:

appveyor.yml

@@ -0,0 +1,45 @@
+# DO NOT CHANGE the "init" and "install" sections below
+
+# Download script file from GitHub
+init:
+  ps: |
+        $ErrorActionPreference = "Stop"
+        Invoke-WebRequest http://raw.github.com/krlmlr/r-appveyor/master/scripts/appveyor-tool.ps1 -OutFile "..\appveyor-tool.ps1"
+        Import-Module '..\appveyor-tool.ps1'
+
+install:
+  ps: Bootstrap
+
+cache:
+  - C:\RLibrary
+
+# Adapt as necessary starting from here
+
+build_script:
+  - travis-tool.sh install_deps
+
+test_script:
+  - travis-tool.sh run_tests
+
+on_failure:
+  - 7z a failure.zip *.Rcheck\*
+  - appveyor PushArtifact failure.zip
+
+artifacts:
+  - path: '*.Rcheck\**\*.log'
+    name: Logs
+
+  - path: '*.Rcheck\**\*.out'
+    name: Logs
+
+  - path: '*.Rcheck\**\*.fail'
+    name: Logs
+
+  - path: '*.Rcheck\**\*.Rout'
+    name: Logs
+
+  - path: '\*_*.tar.gz'
+    name: Bits
+
+  - path: '\*_*.zip'
+    name: Bits

inst/examples/01_hello/rsconnect/localhost/admin/01_hello.dcf

@@ -1,6 +0,0 @@
-name: 01_hello
-account: admin
-server: localhost
-bundleId: 1
-url: http://localhost:3939/admin/01_hello/
-when: 1436550957.65385

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"),
@@ -17,11 +17,11 @@ shinyUI(fluidPage(
     ),
     
     # Show a summary of the dataset and an HTML table with the 
-	 # requested number of observations
+    # requested number of observations
     mainPanel(
       verbatimTextOutput("summary"),
       
       tableOutput("view")
     )
   )
-))
+)

inst/examples/03_reactivity/server.R

@@ -3,14 +3,14 @@ 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:
   #
   #  1) It is only called when the inputs it depends on changes
   #  2) The computation and result are shared by all the callers 
-  #	  (it only executes a single time)
+  #     (it only executes a single time)
   #
   datasetInput <- reactive({
     switch(input$dataset,
@@ -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"),
@@ -22,7 +22,7 @@ shinyUI(fluidPage(
     
     
     # Show the caption, a summary of the dataset and an HTML 
-	 # table with the requested number of observations
+    # table with the requested number of observations
     mainPanel(
       h3(textOutput("caption", container = span)),
       
@@ -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"),
@@ -18,12 +18,12 @@ shinyUI(fluidPage(
       checkboxInput("outliers", "Show outliers", FALSE)
     ),
     
-	 # Show the caption and plot of the requested variable against
-	 # mpg
+    # Show the caption and plot of the requested variable against
+    # mpg
     mainPanel(
       h3(textOutput("caption")),
       
       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"),
@@ -23,16 +23,16 @@ shinyUI(fluidPage(
                   min = 1, max = 1000, value = c(200,500)),
 
       # Provide a custom currency format for value display,
-		# with basic animation
+    # with basic animation
       sliderInput("format", "Custom Format:",
                   min = 0, max = 10000, value = 0, step = 2500,
                   pre = "$", sep = ",", animate=TRUE),
 
       # Animation with custom interval (in ms) to control speed,
-		# plus looping
+    # plus looping
       sliderInput("animation", "Looping Animation:", 1, 2000, 1,
-					  	step = 10, animate=
-							animationOptions(interval=300, loop=TRUE))
+                  step = 10, animate =
+                  animationOptions(interval=300, loop=TRUE))
     ),
 
     # Show a table summarizing the values entered
@@ -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/Readme.md

@@ -1 +1 @@
-This example demonstrates some additional widgets included in Shiny, such as `helpText` and `submitButton`. The latter is used to delay rendering output until the user explicitly requests it.
+This example demonstrates some additional widgets included in Shiny, such as `helpText` and `actionButton`. The latter is used to delay rendering output until the user explicitly requests it (a construct which also introduces two important server functions, `eventReactive` and `isolate`).

inst/examples/07_widgets/server.R

@@ -1,26 +1,32 @@
 library(shiny)
 library(datasets)
 
-# Define server logic required to summarize and view the 
+# Define server logic required to summarize and view the
 # selected dataset
-shinyServer(function(input, output) {
-  
-  # Return the requested dataset
-  datasetInput <- reactive({
+function(input, output) {
+
+  # Return the requested dataset. Note that we use `eventReactive()`
+  # here, which takes a dependency on input$update (the action
+  # button), so that the output is only updated when the user
+  # clicks the button.
+  datasetInput <- eventReactive(input$update, {
     switch(input$dataset,
            "rock" = rock,
            "pressure" = pressure,
            "cars" = cars)
-  })
-  
+  }, ignoreNULL = FALSE)
+
   # Generate a summary of the dataset
   output$summary <- renderPrint({
     dataset <- datasetInput()
     summary(dataset)
   })
-  
-  # Show the first "n" observations
+
+  # Show the first "n" observations. The use of `isolate()` here
+  # is necessary because we don't want the table to update
+  # whenever input$obs changes (only when the user clicks the
+  # action button).
   output$view <- renderTable({
-    head(datasetInput(), n = input$obs)
+    head(datasetInput(), n = isolate(input$obs))
   })
-})
+}

inst/examples/07_widgets/ui.R

@@ -1,33 +1,33 @@
 library(shiny)
 
 # Define UI for dataset viewer application
-shinyUI(fluidPage(
-  
+fluidPage(
+
   # Application title.
   titlePanel("More Widgets"),
-  
+
   # Sidebar with controls to select a dataset and specify the
   # number of observations to view. The helpText function is
   # also used to include clarifying text. Most notably, the
-  # inclusion of a submitButton defers the rendering of output
+  # inclusion of an actionButton defers the rendering of output
   # until the user explicitly clicks the button (rather than
   # doing it immediately when inputs change). This is useful if
   # the computations required to render output are inordinately
   # time-consuming.
   sidebarLayout(
     sidebarPanel(
-      selectInput("dataset", "Choose a dataset:", 
+      selectInput("dataset", "Choose a dataset:",
                   choices = c("rock", "pressure", "cars")),
-      
+
       numericInput("obs", "Number of observations to view:", 10),
-      
+
       helpText("Note: while the data view will show only the specified",
                "number of observations, the summary will still be based",
                "on the full dataset."),
-      
-      submitButton("Update View")
+
+      actionButton("update", "Update View")
     ),
-    
+
     # Show a summary of the dataset and an HTML table with the
     # requested number of observations. Note the use of the h4
     # function to provide an additional header above each output
@@ -35,9 +35,9 @@ shinyUI(fluidPage(
     mainPanel(
       h4("Summary"),
       verbatimTextOutput("summary"),
-      
+
       h4("Observations"),
       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
@@ -14,7 +14,7 @@ shinyServer(function(input, output) {
     if (is.null(inFile))
       return(NULL)
     
-    read.csv(inFile$datapath, header=input$header, sep=input$sep, 
-				 quote=input$quote)
+    read.csv(inFile$datapath, header=input$header, sep=input$sep,
+             quote=input$quote)
   })
-})
+}

inst/examples/09_upload/ui.R

@@ -1,13 +1,13 @@
 library(shiny)
 
-shinyUI(fluidPage(
+fluidPage(
   titlePanel("Uploading Files"),
   sidebarLayout(
     sidebarPanel(
       fileInput('file1', 'Choose CSV File',
                 accept=c('text/csv', 
-								 'text/comma-separated-values,text/plain', 
-								 '.csv')),
+                'text/comma-separated-values,text/plain',
+                '.csv')),
       tags$hr(),
       checkboxInput('header', 'Header', TRUE),
       radioButtons('sep', 'Separator',
@@ -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,
@@ -12,10 +12,10 @@ shinyServer(function(input, output) {
   
   output$downloadData <- downloadHandler(
     filename = function() { 
-		 paste(input$dataset, '.csv', sep='') 
-	 },
+      paste(input$dataset, '.csv', sep='')
+    },
     content = function(file) {
       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

@@ -44,7 +44,10 @@ sd_section("UI Inputs",
     "sliderInput",
     "submitButton",
     "textInput",
+    "textAreaInput",
     "passwordInput",
+    "modalButton",
+    "updateActionButton",
     "updateCheckboxGroupInput",
     "updateCheckboxInput",
     "updateDateInput",
@@ -54,7 +57,10 @@ sd_section("UI Inputs",
     "updateSelectInput",
     "updateSliderInput",
     "updateTabsetPanel",
-    "updateTextInput"
+    "updateTextInput",
+    "updateTextAreaInput",
+    "updateQueryString",
+    "getQueryString"
   )
 )
 sd_section("UI Outputs",
@@ -68,7 +74,11 @@ sd_section("UI Outputs",
     "verbatimTextOutput",
     "downloadButton",
     "Progress",
-    "withProgress"
+    "withProgress",
+    "modalDialog",
+    "urlModal",
+    "showModal",
+    "showNotification"
   )
 )
 sd_section("Interface builder functions",
@@ -83,7 +93,9 @@ sd_section("Interface builder functions",
     "withTags",
     "htmlTemplate",
     "bootstrapLib",
-    "suppressDependencies"
+    "suppressDependencies",
+    "insertUI",
+    "removeUI"
   )
 )
 sd_section("Rendering functions",
@@ -104,23 +116,26 @@ sd_section("Rendering functions",
     "reactiveUI"
   )
 )
-sd_section("Reactive constructs",
+sd_section("Reactive programming",
   "A sub-library that provides reactive programming facilities for R.",
   c(
-    "invalidateLater",
-    "is.reactivevalues",
-    "isolate",
-    "makeReactiveBinding",
+    "reactive",
     "observe",
     "observeEvent",
-    "reactive",
+    "reactiveVal",
+    "reactiveValues",
+    "reactiveValuesToList",
+    "is.reactivevalues",
+    "isolate",
+    "invalidateLater",
+    "debounce",
+    "showReactLog",
+    "makeReactiveBinding",
     "reactiveFileReader",
     "reactivePoll",
     "reactiveTimer",
-    "reactiveValues",
-    "reactiveValuesToList",
     "domains",
-    "showReactLog"
+    "freezeReactiveValue"
   )
 )
 sd_section("Boilerplate",
@@ -142,6 +157,16 @@ sd_section("Running",
     "viewer"
   )
 )
+sd_section("Bookmarking state",
+  "Functions that are used for bookmarking and restoring state.",
+  c(
+    "bookmarkButton",
+    "enableBookmarking",
+    "setBookmarkExclude",
+    "showBookmarkUrlModal",
+    "onBookmark"
+  )
+)
 sd_section("Extending Shiny",
   "Functions that are intended to be called by third-party packages that extend Shiny.",
   c(
@@ -158,10 +183,18 @@ sd_section("Utility functions",
     "req",
     "validate",
     "session",
+    "shinyOptions",
+    "safeError",
+    "onFlush",
+    "restoreInput",
+    "applyInputHandlers",
     "exprToFunction",
     "installExprFunction",
     "parseQueryString",
     "plotPNG",
+    "exportTestValues",
+    "snapshotExclude",
+    "markOutputAttrs",
     "repeatable",
     "shinyDeprecated",
     "serverInfo",

inst/tests/test-bootstrap.r

@@ -1,154 +0,0 @@
-context("bootstrap")
-
-test_that("CSS unit validation", {
-  # On error, return NA; on success, return result
-  validateCssUnit_wrap <- function(x) {
-    tryCatch(validateCssUnit(x), error = function(e) { NA_character_ })
-  }
-
-  # Test strings and expected results
-  strings  <- c("100x", "10px", "10.4px", ".4px", "1px0", "px", "5",  "%", "5%", "auto", "1auto", "")
-  expected <- c(NA,     "10px", "10.4px", ".4px", NA,       NA, "5px", NA, "5%", "auto", NA,      NA)
-  results <- vapply(strings, validateCssUnit_wrap, character(1), USE.NAMES = FALSE)
-  expect_equal(results, expected)
-
-  # Numbers should return string with "px"
-  expect_equal(validateCssUnit(100), "100px")
-})
-
-
-test_that("Repeated names for selectInput and radioButtons choices", {
-  # These test might be a bit too closely tied to the exact structure of the
-  # tag object, but they get the job done for now.
-
-  # Select input
-  x <- selectInput('id','label', choices = c(a='x1', a='x2', b='x3'), selectize = FALSE)
-  expect_true(grepl(fixed = TRUE,
-    '<select id="id" class="form-control"><option value="x1" selected>a</option>\n<option value="x2">a</option>\n<option value="x3">b</option></select>',
-     format(x)
-  ))
-
-
-  # Radio buttons
-  x <- radioButtons('id','label', choices = c(a='x1', a='x2', b='x3'))
-  choices <- x$children
-
-  expect_equal(choices[[2]]$children[[1]][[1]]$children[[1]]$children[[2]]$children[[1]], 'a')
-  expect_equal(choices[[2]]$children[[1]][[1]]$children[[1]]$children[[1]]$attribs$value, 'x1')
-  expect_equal(choices[[2]]$children[[1]][[1]]$children[[1]]$children[[1]]$attribs$checked, 'checked')
-
-  expect_equal(choices[[2]]$children[[1]][[2]]$children[[1]]$children[[2]]$children[[1]], 'a')
-  expect_equal(choices[[2]]$children[[1]][[2]]$children[[1]]$children[[1]]$attribs$value, 'x2')
-  expect_equal(choices[[2]]$children[[1]][[2]]$children[[1]]$children[[1]]$attribs$checked, NULL)
-
-  expect_equal(choices[[2]]$children[[1]][[3]]$children[[1]]$children[[2]]$children[[1]], 'b')
-  expect_equal(choices[[2]]$children[[1]][[3]]$children[[1]]$children[[1]]$attribs$value, 'x3')
-  expect_equal(choices[[2]]$children[[1]][[3]]$children[[1]]$children[[1]]$attribs$checked, NULL)
-})
-
-
-test_that("Choices are correctly assigned names", {
-  # Unnamed vector
-  expect_identical(
-    choicesWithNames(c("a","b","3")),
-    list(a="a", b="b", "3"="3")
-  )
-  # Unnamed list
-  expect_identical(
-    choicesWithNames(list("a","b",3)),
-    list(a="a", b="b", "3"=3)
-  )
-  # Vector, with some named, some not
-  expect_identical(
-    choicesWithNames(c(A="a", "b", C="3", "4")),
-    list(A="a", "b"="b", C="3", "4"="4")
-  )
-  # List, with some named, some not
-  expect_identical(
-    choicesWithNames(list(A="a", "b", C=3, 4)),
-    list(A="a", "b"="b", C=3, "4"=4)
-  )
-  # List, named, with a sub-vector
-  expect_identical(
-    choicesWithNames(list(A="a", B="b", C=c("d", "e"))),
-    list(A="a", B="b", C=list(d="d", e="e"))
-  )
-  # List, named, with sublist
-  expect_identical(
-    choicesWithNames(list(A="a", B="b", C=list("d", "e"))),
-    list(A="a", B="b", C=list(d="d", e="e"))
-  )
-  # List, named, with a named sub-vector of length 1
-  expect_identical(
-    choicesWithNames(list(A="a", B="b", C=c(D="d"))),
-    list(A="a", B="b", C=list(D="d"))
-  )
-  # List, some named, with sublist
-  expect_identical(
-    choicesWithNames(list(A="a", "b", C=list("d", E="e"))),
-    list(A="a", b="b", C=list(d="d", E="e"))
-  )
-  # Deeper nesting
-  expect_identical(
-    choicesWithNames(list(A="a", "b", C=list(D=list("e", "f"), G=c(H="h", "i")))),
-    list(A="a", b="b", C=list(D=list(e="e", f="f"), G=list(H="h", i="i")))
-  )
-  # Error when sublist is unnamed
-  expect_error(choicesWithNames(list(A="a", "b", list(1,2))))
-})
-
-
-test_that("selectOptions returns correct HTML", {
-  # None selected
-  expect_identical(
-    selectOptions(choicesWithNames(list("a", "b")), list()),
-    HTML("<option value=\"a\">a</option>\n<option value=\"b\">b</option>")
-  )
-  # One selected
-  expect_identical(
-    selectOptions(choicesWithNames(list("a", "b")), "a"),
-    HTML("<option value=\"a\" selected>a</option>\n<option value=\"b\">b</option>")
-  )
-  # One selected, with named items
-  expect_identical(
-    selectOptions(choicesWithNames(list(A="a", B="b")), "a"),
-    HTML("<option value=\"a\" selected>A</option>\n<option value=\"b\">B</option>")
-  )
-  # Two selected, with optgroup
-  expect_identical(
-    selectOptions(choicesWithNames(list("a", B=list("c", D="d"))), c("a", "d")),
-    HTML("<option value=\"a\" selected>a</option>\n<optgroup label=\"B\">\n<option value=\"c\">c</option>\n<option value=\"d\" selected>D</option>\n</optgroup>")
-  )
-
-  # Escape HTML in strings
-  expect_identical(
-    selectOptions(choicesWithNames(list("<A>"="a", B="b")), "a"),
-    HTML("<option value=\"a\" selected>&lt;A&gt;</option>\n<option value=\"b\">B</option>")
-  )
-})
-
-test_that("selectInput selects items by default", {
-  # None specified as selected (defaults to first)
-  expect_true(grepl(fixed = TRUE,
-    '<option value="a" selected>',
-    selectInput('x', 'x', list("a", "b"))
-  ))
-
-  # Nested list (optgroup)
-  expect_true(grepl(fixed = TRUE,
-    '<option value="a" selected>',
-    selectInput('x', 'x', list(A=list("a", "b"), "c"))
-  ))
-
-  # Nothing selected when choices=NULL
-  expect_true(grepl(fixed = TRUE,
-    '<select id="x" class="form-control"></select>',
-    format(selectInput('x', NULL, NULL, selectize = FALSE))
-  ))
-
-  # None specified as selected. With multiple=TRUE, none selected by default.
-  expect_true(grepl(fixed = TRUE,
-    '<option value="a">',
-    selectInput('x', 'x', list("a", "b"), multiple = TRUE)
-  ))
-})

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

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

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

@@ -1,6 +1,6 @@
 /*!
- * Bootstrap v3.3.5 (http://getbootstrap.com)
- * Copyright 2011-2015 Twitter, Inc.
+ * Bootstrap v3.3.7 (http://getbootstrap.com)
+ * Copyright 2011-2016 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  */
 /*! normalize.css v3.0.3 | MIT License | github.com/necolas/normalize.css */
@@ -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 {
@@ -1106,7 +1106,6 @@ a:focus {
   text-decoration: underline;
 }
 a:focus {
-  outline: thin dotted;
   outline: 5px auto -webkit-focus-ring-color;
   outline-offset: -2px;
 }
@@ -2537,7 +2536,6 @@ select[size] {
 input[type="file"]:focus,
 input[type="radio"]:focus,
 input[type="checkbox"]:focus {
-  outline: thin dotted;
   outline: 5px auto -webkit-focus-ring-color;
   outline-offset: -2px;
 }
@@ -2582,6 +2580,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 +2990,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;
   }
 }
@@ -3025,7 +3027,6 @@ select[multiple].input-lg {
 .btn.focus,
 .btn:active.focus,
 .btn.active.focus {
-  outline: thin dotted;
   outline: 5px auto -webkit-focus-ring-color;
   outline-offset: -2px;
 }
@@ -3096,9 +3097,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 +3105,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 +3154,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 +3162,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 +3211,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 +3219,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 +3268,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 +3276,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 +3325,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 +3333,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 +3382,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 +3390,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 +3764,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 +3772,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 +3830,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 +4744,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 +4755,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 +4976,8 @@ a.badge:focus {
 }
 .container .jumbotron,
 .container-fluid .jumbotron {
+  padding-right: 15px;
+  padding-left: 15px;
   border-radius: 6px;
 }
 .jumbotron .container {
@@ -5978,7 +5932,6 @@ button.close {
   opacity: .5;
 }
 .modal-header {
-  min-height: 16.42857143px;
   padding: 15px;
   border-bottom: 1px solid #e5e5e5;
 }
@@ -6371,6 +6324,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 +6438,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 +6486,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 +6507,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,6 +1,6 @@
 /*!
- * Bootstrap v3.3.5 (http://getbootstrap.com)
- * Copyright 2011-2015 Twitter, Inc.
+ * Bootstrap v3.3.7 (http://getbootstrap.com)
+ * Copyright 2011-2016 Twitter, Inc.
  * Licensed under the MIT license
  */
 
@@ -11,16 +11,16 @@ 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] > 3)) {
+    throw new Error('Bootstrap\'s JavaScript requires jQuery version 1.9.1 or higher, but lower than version 4')
   }
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: transition.js v3.3.5
+ * Bootstrap: transition.js v3.3.7
  * http://getbootstrap.com/javascript/#transitions
  * ========================================================================
- * Copyright 2011-2015 Twitter, Inc.
+ * Copyright 2011-2016 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  * ======================================================================== */
 
@@ -77,10 +77,10 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: alert.js v3.3.5
+ * Bootstrap: alert.js v3.3.7
  * http://getbootstrap.com/javascript/#alerts
  * ========================================================================
- * Copyright 2011-2015 Twitter, Inc.
+ * Copyright 2011-2016 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  * ======================================================================== */
 
@@ -96,7 +96,7 @@ if (typeof jQuery === 'undefined') {
     $(el).on('click', dismiss, this.close)
   }
 
-  Alert.VERSION = '3.3.5'
+  Alert.VERSION = '3.3.7'
 
   Alert.TRANSITION_DURATION = 150
 
@@ -109,7 +109,7 @@ if (typeof jQuery === 'undefined') {
       selector = selector && selector.replace(/.*(?=#[^\s]*$)/, '') // strip for ie7
     }
 
-    var $parent = $(selector)
+    var $parent = $(selector === '#' ? [] : selector)
 
     if (e) e.preventDefault()
 
@@ -172,10 +172,10 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: button.js v3.3.5
+ * Bootstrap: button.js v3.3.7
  * http://getbootstrap.com/javascript/#buttons
  * ========================================================================
- * Copyright 2011-2015 Twitter, Inc.
+ * Copyright 2011-2016 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  * ======================================================================== */
 
@@ -192,7 +192,7 @@ if (typeof jQuery === 'undefined') {
     this.isLoading = false
   }
 
-  Button.VERSION  = '3.3.5'
+  Button.VERSION  = '3.3.7'
 
   Button.DEFAULTS = {
     loadingText: 'loading...'
@@ -214,10 +214,10 @@ if (typeof jQuery === 'undefined') {
 
       if (state == 'loadingText') {
         this.isLoading = true
-        $el.addClass(d).attr(d, d)
+        $el.addClass(d).attr(d, d).prop(d, true)
       } else if (this.isLoading) {
         this.isLoading = false
-        $el.removeClass(d).removeAttr(d)
+        $el.removeClass(d).removeAttr(d).prop(d, false)
       }
     }, this), 0)
   }
@@ -281,10 +281,15 @@ if (typeof jQuery === 'undefined') {
 
   $(document)
     .on('click.bs.button.data-api', '[data-toggle^="button"]', function (e) {
-      var $btn = $(e.target)
-      if (!$btn.hasClass('btn')) $btn = $btn.closest('.btn')
+      var $btn = $(e.target).closest('.btn')
       Plugin.call($btn, 'toggle')
-      if (!($(e.target).is('input[type="radio"]') || $(e.target).is('input[type="checkbox"]'))) e.preventDefault()
+      if (!($(e.target).is('input[type="radio"], input[type="checkbox"]'))) {
+        // Prevent double click on radios, and the double selections (so cancellation) on checkboxes
+        e.preventDefault()
+        // The target component still receive the focus
+        if ($btn.is('input,button')) $btn.trigger('focus')
+        else $btn.find('input:visible,button:visible').first().trigger('focus')
+      }
     })
     .on('focus.bs.button.data-api blur.bs.button.data-api', '[data-toggle^="button"]', function (e) {
       $(e.target).closest('.btn').toggleClass('focus', /^focus(in)?$/.test(e.type))
@@ -293,10 +298,10 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: carousel.js v3.3.5
+ * Bootstrap: carousel.js v3.3.7
  * http://getbootstrap.com/javascript/#carousel
  * ========================================================================
- * Copyright 2011-2015 Twitter, Inc.
+ * Copyright 2011-2016 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  * ======================================================================== */
 
@@ -324,7 +329,7 @@ if (typeof jQuery === 'undefined') {
       .on('mouseleave.bs.carousel', $.proxy(this.cycle, this))
   }
 
-  Carousel.VERSION  = '3.3.5'
+  Carousel.VERSION  = '3.3.7'
 
   Carousel.TRANSITION_DURATION = 600
 
@@ -531,13 +536,14 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: collapse.js v3.3.5
+ * Bootstrap: collapse.js v3.3.7
  * http://getbootstrap.com/javascript/#collapse
  * ========================================================================
- * Copyright 2011-2015 Twitter, Inc.
+ * Copyright 2011-2016 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  * ======================================================================== */
 
+/* jshint latedef: false */
 
 +function ($) {
   'use strict';
@@ -561,7 +567,7 @@ if (typeof jQuery === 'undefined') {
     if (this.options.toggle) this.toggle()
   }
 
-  Collapse.VERSION  = '3.3.5'
+  Collapse.VERSION  = '3.3.7'
 
   Collapse.TRANSITION_DURATION = 350
 
@@ -743,10 +749,10 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: dropdown.js v3.3.5
+ * Bootstrap: dropdown.js v3.3.7
  * http://getbootstrap.com/javascript/#dropdowns
  * ========================================================================
- * Copyright 2011-2015 Twitter, Inc.
+ * Copyright 2011-2016 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  * ======================================================================== */
 
@@ -763,7 +769,7 @@ if (typeof jQuery === 'undefined') {
     $(element).on('click.bs.dropdown', this.toggle)
   }
 
-  Dropdown.VERSION = '3.3.5'
+  Dropdown.VERSION = '3.3.7'
 
   function getParent($this) {
     var selector = $this.attr('data-target')
@@ -795,7 +801,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 +835,7 @@ if (typeof jQuery === 'undefined') {
 
       $parent
         .toggleClass('open')
-        .trigger('shown.bs.dropdown', relatedTarget)
+        .trigger($.Event('shown.bs.dropdown', relatedTarget))
     }
 
     return false
@@ -909,10 +915,10 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: modal.js v3.3.5
+ * Bootstrap: modal.js v3.3.7
  * http://getbootstrap.com/javascript/#modals
  * ========================================================================
- * Copyright 2011-2015 Twitter, Inc.
+ * Copyright 2011-2016 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  * ======================================================================== */
 
@@ -943,7 +949,7 @@ if (typeof jQuery === 'undefined') {
     }
   }
 
-  Modal.VERSION  = '3.3.5'
+  Modal.VERSION  = '3.3.7'
 
   Modal.TRANSITION_DURATION = 300
   Modal.BACKDROP_TRANSITION_DURATION = 150
@@ -1050,7 +1056,9 @@ if (typeof jQuery === 'undefined') {
     $(document)
       .off('focusin.bs.modal') // guard against infinite focus loop
       .on('focusin.bs.modal', $.proxy(function (e) {
-        if (this.$element[0] !== e.target && !this.$element.has(e.target).length) {
+        if (document !== e.target &&
+            this.$element[0] !== e.target &&
+            !this.$element.has(e.target).length) {
           this.$element.trigger('focus')
         }
       }, this))
@@ -1247,11 +1255,11 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: tooltip.js v3.3.5
+ * Bootstrap: tooltip.js v3.3.7
  * http://getbootstrap.com/javascript/#tooltip
  * Inspired by the original jQuery.tipsy by Jason Frame
  * ========================================================================
- * Copyright 2011-2015 Twitter, Inc.
+ * Copyright 2011-2016 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  * ======================================================================== */
 
@@ -1274,7 +1282,7 @@ if (typeof jQuery === 'undefined') {
     this.init('tooltip', element, options)
   }
 
-  Tooltip.VERSION  = '3.3.5'
+  Tooltip.VERSION  = '3.3.7'
 
   Tooltip.TRANSITION_DURATION = 150
 
@@ -1565,9 +1573,11 @@ if (typeof jQuery === 'undefined') {
 
     function complete() {
       if (that.hoverState != 'in') $tip.detach()
-      that.$element
-        .removeAttr('aria-describedby')
-        .trigger('hidden.bs.' + that.type)
+      if (that.$element) { // TODO: Check whether guarding this code with this `if` is really necessary.
+        that.$element
+          .removeAttr('aria-describedby')
+          .trigger('hidden.bs.' + that.type)
+      }
       callback && callback()
     }
 
@@ -1610,7 +1620,10 @@ if (typeof jQuery === 'undefined') {
       // width and height are missing in IE8, so compute them manually; see https://github.com/twbs/bootstrap/issues/14093
       elRect = $.extend({}, elRect, { width: elRect.right - elRect.left, height: elRect.bottom - elRect.top })
     }
-    var elOffset  = isBody ? { top: 0, left: 0 } : $element.offset()
+    var isSvg = window.SVGElement && el instanceof window.SVGElement
+    // Avoid using $.offset() on SVGs since it gives incorrect results in jQuery 3.
+    // See https://github.com/twbs/bootstrap/issues/20280
+    var elOffset  = isBody ? { top: 0, left: 0 } : (isSvg ? null : $element.offset())
     var scroll    = { scroll: isBody ? document.documentElement.scrollTop || document.body.scrollTop : $element.scrollTop() }
     var outerDims = isBody ? { width: $(window).width(), height: $(window).height() } : null
 
@@ -1726,6 +1739,7 @@ if (typeof jQuery === 'undefined') {
       that.$tip = null
       that.$arrow = null
       that.$viewport = null
+      that.$element = null
     })
   }
 
@@ -1762,10 +1776,10 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: popover.js v3.3.5
+ * Bootstrap: popover.js v3.3.7
  * http://getbootstrap.com/javascript/#popovers
  * ========================================================================
- * Copyright 2011-2015 Twitter, Inc.
+ * Copyright 2011-2016 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  * ======================================================================== */
 
@@ -1782,7 +1796,7 @@ if (typeof jQuery === 'undefined') {
 
   if (!$.fn.tooltip) throw new Error('Popover requires tooltip.js')
 
-  Popover.VERSION  = '3.3.5'
+  Popover.VERSION  = '3.3.7'
 
   Popover.DEFAULTS = $.extend({}, $.fn.tooltip.Constructor.DEFAULTS, {
     placement: 'right',
@@ -1871,10 +1885,10 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: scrollspy.js v3.3.5
+ * Bootstrap: scrollspy.js v3.3.7
  * http://getbootstrap.com/javascript/#scrollspy
  * ========================================================================
- * Copyright 2011-2015 Twitter, Inc.
+ * Copyright 2011-2016 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  * ======================================================================== */
 
@@ -1900,7 +1914,7 @@ if (typeof jQuery === 'undefined') {
     this.process()
   }
 
-  ScrollSpy.VERSION  = '3.3.5'
+  ScrollSpy.VERSION  = '3.3.7'
 
   ScrollSpy.DEFAULTS = {
     offset: 10
@@ -2044,10 +2058,10 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: tab.js v3.3.5
+ * Bootstrap: tab.js v3.3.7
  * http://getbootstrap.com/javascript/#tabs
  * ========================================================================
- * Copyright 2011-2015 Twitter, Inc.
+ * Copyright 2011-2016 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  * ======================================================================== */
 
@@ -2064,7 +2078,7 @@ if (typeof jQuery === 'undefined') {
     // jscs:enable requireDollarBeforejQueryAssignment
   }
 
-  Tab.VERSION = '3.3.5'
+  Tab.VERSION = '3.3.7'
 
   Tab.TRANSITION_DURATION = 150
 
@@ -2200,10 +2214,10 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: affix.js v3.3.5
+ * Bootstrap: affix.js v3.3.7
  * http://getbootstrap.com/javascript/#affix
  * ========================================================================
- * Copyright 2011-2015 Twitter, Inc.
+ * Copyright 2011-2016 Twitter, Inc.
  * Licensed under MIT (https://github.com/twbs/bootstrap/blob/master/LICENSE)
  * ======================================================================== */
 
@@ -2229,7 +2243,7 @@ if (typeof jQuery === 'undefined') {
     this.checkPosition()
   }
 
-  Affix.VERSION  = '3.3.5'
+  Affix.VERSION  = '3.3.7'
 
   Affix.RESET    = 'affix affix-top affix-bottom'
 

inst/www/shared/datepicker/css/bootstrap-datepicker3.css

@@ -0,0 +1,678 @@
+/*!
+ * Datepicker for Bootstrap v1.6.4 (https://github.com/eternicode/bootstrap-datepicker)
+ *
+ * Copyright 2012 Stefan Petre
+ * Improvements by Andrew Rowls
+ * Licensed under the Apache License v2.0 (http://www.apache.org/licenses/LICENSE-2.0)
+ */
+.datepicker {
+  border-radius: 4px;
+  direction: ltr;
+}
+.datepicker-inline {
+  width: 220px;
+}
+.datepicker.datepicker-rtl {
+  direction: rtl;
+}
+.datepicker.datepicker-rtl table tr td span {
+  float: right;
+}
+.datepicker-dropdown {
+  top: 0;
+  left: 0;
+  padding: 4px;
+}
+.datepicker-dropdown:before {
+  content: '';
+  display: inline-block;
+  border-left: 7px solid transparent;
+  border-right: 7px solid transparent;
+  border-bottom: 7px solid rgba(0, 0, 0, 0.15);
+  border-top: 0;
+  border-bottom-color: rgba(0, 0, 0, 0.2);
+  position: absolute;
+}
+.datepicker-dropdown:after {
+  content: '';
+  display: inline-block;
+  border-left: 6px solid transparent;
+  border-right: 6px solid transparent;
+  border-bottom: 6px solid #fff;
+  border-top: 0;
+  position: absolute;
+}
+.datepicker-dropdown.datepicker-orient-left:before {
+  left: 6px;
+}
+.datepicker-dropdown.datepicker-orient-left:after {
+  left: 7px;
+}
+.datepicker-dropdown.datepicker-orient-right:before {
+  right: 6px;
+}
+.datepicker-dropdown.datepicker-orient-right:after {
+  right: 7px;
+}
+.datepicker-dropdown.datepicker-orient-bottom:before {
+  top: -7px;
+}
+.datepicker-dropdown.datepicker-orient-bottom:after {
+  top: -6px;
+}
+.datepicker-dropdown.datepicker-orient-top:before {
+  bottom: -7px;
+  border-bottom: 0;
+  border-top: 7px solid rgba(0, 0, 0, 0.15);
+}
+.datepicker-dropdown.datepicker-orient-top:after {
+  bottom: -6px;
+  border-bottom: 0;
+  border-top: 6px solid #fff;
+}
+.datepicker table {
+  margin: 0;
+  -webkit-touch-callout: none;
+  -webkit-user-select: none;
+  -khtml-user-select: none;
+  -moz-user-select: none;
+  -ms-user-select: none;
+  user-select: none;
+}
+.datepicker table tr td,
+.datepicker table tr th {
+  text-align: center;
+  width: 30px;
+  height: 30px;
+  border-radius: 4px;
+  border: none;
+}
+.table-striped .datepicker table tr td,
+.table-striped .datepicker table tr th {
+  background-color: transparent;
+}
+.datepicker table tr td.old,
+.datepicker table tr td.new {
+  color: #777777;
+}
+.datepicker table tr td.day:hover,
+.datepicker table tr td.focused {
+  background: #eeeeee;
+  cursor: pointer;
+}
+.datepicker table tr td.disabled,
+.datepicker table tr td.disabled:hover {
+  background: none;
+  color: #777777;
+  cursor: default;
+}
+.datepicker table tr td.highlighted {
+  color: #000;
+  background-color: #d9edf7;
+  border-color: #85c5e5;
+  border-radius: 0;
+}
+.datepicker table tr td.highlighted:focus,
+.datepicker table tr td.highlighted.focus {
+  color: #000;
+  background-color: #afd9ee;
+  border-color: #298fc2;
+}
+.datepicker table tr td.highlighted:hover {
+  color: #000;
+  background-color: #afd9ee;
+  border-color: #52addb;
+}
+.datepicker table tr td.highlighted:active,
+.datepicker table tr td.highlighted.active {
+  color: #000;
+  background-color: #afd9ee;
+  border-color: #52addb;
+}
+.datepicker table tr td.highlighted:active:hover,
+.datepicker table tr td.highlighted.active:hover,
+.datepicker table tr td.highlighted:active:focus,
+.datepicker table tr td.highlighted.active:focus,
+.datepicker table tr td.highlighted:active.focus,
+.datepicker table tr td.highlighted.active.focus {
+  color: #000;
+  background-color: #91cbe8;
+  border-color: #298fc2;
+}
+.datepicker table tr td.highlighted.disabled:hover,
+.datepicker table tr td.highlighted[disabled]:hover,
+fieldset[disabled] .datepicker table tr td.highlighted:hover,
+.datepicker table tr td.highlighted.disabled:focus,
+.datepicker table tr td.highlighted[disabled]:focus,
+fieldset[disabled] .datepicker table tr td.highlighted:focus,
+.datepicker table tr td.highlighted.disabled.focus,
+.datepicker table tr td.highlighted[disabled].focus,
+fieldset[disabled] .datepicker table tr td.highlighted.focus {
+  background-color: #d9edf7;
+  border-color: #85c5e5;
+}
+.datepicker table tr td.highlighted.focused {
+  background: #afd9ee;
+}
+.datepicker table tr td.highlighted.disabled,
+.datepicker table tr td.highlighted.disabled:active {
+  background: #d9edf7;
+  color: #777777;
+}
+.datepicker table tr td.today {
+  color: #000;
+  background-color: #ffdb99;
+  border-color: #ffb733;
+}
+.datepicker table tr td.today:focus,
+.datepicker table tr td.today.focus {
+  color: #000;
+  background-color: #ffc966;
+  border-color: #b37400;
+}
+.datepicker table tr td.today:hover {
+  color: #000;
+  background-color: #ffc966;
+  border-color: #f59e00;
+}
+.datepicker table tr td.today:active,
+.datepicker table tr td.today.active {
+  color: #000;
+  background-color: #ffc966;
+  border-color: #f59e00;
+}
+.datepicker table tr td.today:active:hover,
+.datepicker table tr td.today.active:hover,
+.datepicker table tr td.today:active:focus,
+.datepicker table tr td.today.active:focus,
+.datepicker table tr td.today:active.focus,
+.datepicker table tr td.today.active.focus {
+  color: #000;
+  background-color: #ffbc42;
+  border-color: #b37400;
+}
+.datepicker table tr td.today.disabled:hover,
+.datepicker table tr td.today[disabled]:hover,
+fieldset[disabled] .datepicker table tr td.today:hover,
+.datepicker table tr td.today.disabled:focus,
+.datepicker table tr td.today[disabled]:focus,
+fieldset[disabled] .datepicker table tr td.today:focus,
+.datepicker table tr td.today.disabled.focus,
+.datepicker table tr td.today[disabled].focus,
+fieldset[disabled] .datepicker table tr td.today.focus {
+  background-color: #ffdb99;
+  border-color: #ffb733;
+}
+.datepicker table tr td.today.focused {
+  background: #ffc966;
+}
+.datepicker table tr td.today.disabled,
+.datepicker table tr td.today.disabled:active {
+  background: #ffdb99;
+  color: #777777;
+}
+.datepicker table tr td.range {
+  color: #000;
+  background-color: #eeeeee;
+  border-color: #bbbbbb;
+  border-radius: 0;
+}
+.datepicker table tr td.range:focus,
+.datepicker table tr td.range.focus {
+  color: #000;
+  background-color: #d5d5d5;
+  border-color: #7c7c7c;
+}
+.datepicker table tr td.range:hover {
+  color: #000;
+  background-color: #d5d5d5;
+  border-color: #9d9d9d;
+}
+.datepicker table tr td.range:active,
+.datepicker table tr td.range.active {
+  color: #000;
+  background-color: #d5d5d5;
+  border-color: #9d9d9d;
+}
+.datepicker table tr td.range:active:hover,
+.datepicker table tr td.range.active:hover,
+.datepicker table tr td.range:active:focus,
+.datepicker table tr td.range.active:focus,
+.datepicker table tr td.range:active.focus,
+.datepicker table tr td.range.active.focus {
+  color: #000;
+  background-color: #c3c3c3;
+  border-color: #7c7c7c;
+}
+.datepicker table tr td.range.disabled:hover,
+.datepicker table tr td.range[disabled]:hover,
+fieldset[disabled] .datepicker table tr td.range:hover,
+.datepicker table tr td.range.disabled:focus,
+.datepicker table tr td.range[disabled]:focus,
+fieldset[disabled] .datepicker table tr td.range:focus,
+.datepicker table tr td.range.disabled.focus,
+.datepicker table tr td.range[disabled].focus,
+fieldset[disabled] .datepicker table tr td.range.focus {
+  background-color: #eeeeee;
+  border-color: #bbbbbb;
+}
+.datepicker table tr td.range.focused {
+  background: #d5d5d5;
+}
+.datepicker table tr td.range.disabled,
+.datepicker table tr td.range.disabled:active {
+  background: #eeeeee;
+  color: #777777;
+}
+.datepicker table tr td.range.highlighted {
+  color: #000;
+  background-color: #e4eef3;
+  border-color: #9dc1d3;
+}
+.datepicker table tr td.range.highlighted:focus,
+.datepicker table tr td.range.highlighted.focus {
+  color: #000;
+  background-color: #c1d7e3;
+  border-color: #4b88a6;
+}
+.datepicker table tr td.range.highlighted:hover {
+  color: #000;
+  background-color: #c1d7e3;
+  border-color: #73a6c0;
+}
+.datepicker table tr td.range.highlighted:active,
+.datepicker table tr td.range.highlighted.active {
+  color: #000;
+  background-color: #c1d7e3;
+  border-color: #73a6c0;
+}
+.datepicker table tr td.range.highlighted:active:hover,
+.datepicker table tr td.range.highlighted.active:hover,
+.datepicker table tr td.range.highlighted:active:focus,
+.datepicker table tr td.range.highlighted.active:focus,
+.datepicker table tr td.range.highlighted:active.focus,
+.datepicker table tr td.range.highlighted.active.focus {
+  color: #000;
+  background-color: #a8c8d8;
+  border-color: #4b88a6;
+}
+.datepicker table tr td.range.highlighted.disabled:hover,
+.datepicker table tr td.range.highlighted[disabled]:hover,
+fieldset[disabled] .datepicker table tr td.range.highlighted:hover,
+.datepicker table tr td.range.highlighted.disabled:focus,
+.datepicker table tr td.range.highlighted[disabled]:focus,
+fieldset[disabled] .datepicker table tr td.range.highlighted:focus,
+.datepicker table tr td.range.highlighted.disabled.focus,
+.datepicker table tr td.range.highlighted[disabled].focus,
+fieldset[disabled] .datepicker table tr td.range.highlighted.focus {
+  background-color: #e4eef3;
+  border-color: #9dc1d3;
+}
+.datepicker table tr td.range.highlighted.focused {
+  background: #c1d7e3;
+}
+.datepicker table tr td.range.highlighted.disabled,
+.datepicker table tr td.range.highlighted.disabled:active {
+  background: #e4eef3;
+  color: #777777;
+}
+.datepicker table tr td.range.today {
+  color: #000;
+  background-color: #f7ca77;
+  border-color: #f1a417;
+}
+.datepicker table tr td.range.today:focus,
+.datepicker table tr td.range.today.focus {
+  color: #000;
+  background-color: #f4b747;
+  border-color: #815608;
+}
+.datepicker table tr td.range.today:hover {
+  color: #000;
+  background-color: #f4b747;
+  border-color: #bf800c;
+}
+.datepicker table tr td.range.today:active,
+.datepicker table tr td.range.today.active {
+  color: #000;
+  background-color: #f4b747;
+  border-color: #bf800c;
+}
+.datepicker table tr td.range.today:active:hover,
+.datepicker table tr td.range.today.active:hover,
+.datepicker table tr td.range.today:active:focus,
+.datepicker table tr td.range.today.active:focus,
+.datepicker table tr td.range.today:active.focus,
+.datepicker table tr td.range.today.active.focus {
+  color: #000;
+  background-color: #f2aa25;
+  border-color: #815608;
+}
+.datepicker table tr td.range.today.disabled:hover,
+.datepicker table tr td.range.today[disabled]:hover,
+fieldset[disabled] .datepicker table tr td.range.today:hover,
+.datepicker table tr td.range.today.disabled:focus,
+.datepicker table tr td.range.today[disabled]:focus,
+fieldset[disabled] .datepicker table tr td.range.today:focus,
+.datepicker table tr td.range.today.disabled.focus,
+.datepicker table tr td.range.today[disabled].focus,
+fieldset[disabled] .datepicker table tr td.range.today.focus {
+  background-color: #f7ca77;
+  border-color: #f1a417;
+}
+.datepicker table tr td.range.today.disabled,
+.datepicker table tr td.range.today.disabled:active {
+  background: #f7ca77;
+  color: #777777;
+}
+.datepicker table tr td.selected,
+.datepicker table tr td.selected.highlighted {
+  color: #fff;
+  background-color: #777777;
+  border-color: #555555;
+  text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25);
+}
+.datepicker table tr td.selected:focus,
+.datepicker table tr td.selected.highlighted:focus,
+.datepicker table tr td.selected.focus,
+.datepicker table tr td.selected.highlighted.focus {
+  color: #fff;
+  background-color: #5e5e5e;
+  border-color: #161616;
+}
+.datepicker table tr td.selected:hover,
+.datepicker table tr td.selected.highlighted:hover {
+  color: #fff;
+  background-color: #5e5e5e;
+  border-color: #373737;
+}
+.datepicker table tr td.selected:active,
+.datepicker table tr td.selected.highlighted:active,
+.datepicker table tr td.selected.active,
+.datepicker table tr td.selected.highlighted.active {
+  color: #fff;
+  background-color: #5e5e5e;
+  border-color: #373737;
+}
+.datepicker table tr td.selected:active:hover,
+.datepicker table tr td.selected.highlighted:active:hover,
+.datepicker table tr td.selected.active:hover,
+.datepicker table tr td.selected.highlighted.active:hover,
+.datepicker table tr td.selected:active:focus,
+.datepicker table tr td.selected.highlighted:active:focus,
+.datepicker table tr td.selected.active:focus,
+.datepicker table tr td.selected.highlighted.active:focus,
+.datepicker table tr td.selected:active.focus,
+.datepicker table tr td.selected.highlighted:active.focus,
+.datepicker table tr td.selected.active.focus,
+.datepicker table tr td.selected.highlighted.active.focus {
+  color: #fff;
+  background-color: #4c4c4c;
+  border-color: #161616;
+}
+.datepicker table tr td.selected.disabled:hover,
+.datepicker table tr td.selected.highlighted.disabled:hover,
+.datepicker table tr td.selected[disabled]:hover,
+.datepicker table tr td.selected.highlighted[disabled]:hover,
+fieldset[disabled] .datepicker table tr td.selected:hover,
+fieldset[disabled] .datepicker table tr td.selected.highlighted:hover,
+.datepicker table tr td.selected.disabled:focus,
+.datepicker table tr td.selected.highlighted.disabled:focus,
+.datepicker table tr td.selected[disabled]:focus,
+.datepicker table tr td.selected.highlighted[disabled]:focus,
+fieldset[disabled] .datepicker table tr td.selected:focus,
+fieldset[disabled] .datepicker table tr td.selected.highlighted:focus,
+.datepicker table tr td.selected.disabled.focus,
+.datepicker table tr td.selected.highlighted.disabled.focus,
+.datepicker table tr td.selected[disabled].focus,
+.datepicker table tr td.selected.highlighted[disabled].focus,
+fieldset[disabled] .datepicker table tr td.selected.focus,
+fieldset[disabled] .datepicker table tr td.selected.highlighted.focus {
+  background-color: #777777;
+  border-color: #555555;
+}
+.datepicker table tr td.active,
+.datepicker table tr td.active.highlighted {
+  color: #fff;
+  background-color: #337ab7;
+  border-color: #2e6da4;
+  text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25);
+}
+.datepicker table tr td.active:focus,
+.datepicker table tr td.active.highlighted:focus,
+.datepicker table tr td.active.focus,
+.datepicker table tr td.active.highlighted.focus {
+  color: #fff;
+  background-color: #286090;
+  border-color: #122b40;
+}
+.datepicker table tr td.active:hover,
+.datepicker table tr td.active.highlighted:hover {
+  color: #fff;
+  background-color: #286090;
+  border-color: #204d74;
+}
+.datepicker table tr td.active:active,
+.datepicker table tr td.active.highlighted:active,
+.datepicker table tr td.active.active,
+.datepicker table tr td.active.highlighted.active {
+  color: #fff;
+  background-color: #286090;
+  border-color: #204d74;
+}
+.datepicker table tr td.active:active:hover,
+.datepicker table tr td.active.highlighted:active:hover,
+.datepicker table tr td.active.active:hover,
+.datepicker table tr td.active.highlighted.active:hover,
+.datepicker table tr td.active:active:focus,
+.datepicker table tr td.active.highlighted:active:focus,
+.datepicker table tr td.active.active:focus,
+.datepicker table tr td.active.highlighted.active:focus,
+.datepicker table tr td.active:active.focus,
+.datepicker table tr td.active.highlighted:active.focus,
+.datepicker table tr td.active.active.focus,
+.datepicker table tr td.active.highlighted.active.focus {
+  color: #fff;
+  background-color: #204d74;
+  border-color: #122b40;
+}
+.datepicker table tr td.active.disabled:hover,
+.datepicker table tr td.active.highlighted.disabled:hover,
+.datepicker table tr td.active[disabled]:hover,
+.datepicker table tr td.active.highlighted[disabled]:hover,
+fieldset[disabled] .datepicker table tr td.active:hover,
+fieldset[disabled] .datepicker table tr td.active.highlighted:hover,
+.datepicker table tr td.active.disabled:focus,
+.datepicker table tr td.active.highlighted.disabled:focus,
+.datepicker table tr td.active[disabled]:focus,
+.datepicker table tr td.active.highlighted[disabled]:focus,
+fieldset[disabled] .datepicker table tr td.active:focus,
+fieldset[disabled] .datepicker table tr td.active.highlighted:focus,
+.datepicker table tr td.active.disabled.focus,
+.datepicker table tr td.active.highlighted.disabled.focus,
+.datepicker table tr td.active[disabled].focus,
+.datepicker table tr td.active.highlighted[disabled].focus,
+fieldset[disabled] .datepicker table tr td.active.focus,
+fieldset[disabled] .datepicker table tr td.active.highlighted.focus {
+  background-color: #337ab7;
+  border-color: #2e6da4;
+}
+.datepicker table tr td span {
+  display: block;
+  width: 23%;
+  height: 54px;
+  line-height: 54px;
+  float: left;
+  margin: 1%;
+  cursor: pointer;
+  border-radius: 4px;
+}
+.datepicker table tr td span:hover,
+.datepicker table tr td span.focused {
+  background: #eeeeee;
+}
+.datepicker table tr td span.disabled,
+.datepicker table tr td span.disabled:hover {
+  background: none;
+  color: #777777;
+  cursor: default;
+}
+.datepicker table tr td span.active,
+.datepicker table tr td span.active:hover,
+.datepicker table tr td span.active.disabled,
+.datepicker table tr td span.active.disabled:hover {
+  color: #fff;
+  background-color: #337ab7;
+  border-color: #2e6da4;
+  text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25);
+}
+.datepicker table tr td span.active:focus,
+.datepicker table tr td span.active:hover:focus,
+.datepicker table tr td span.active.disabled:focus,
+.datepicker table tr td span.active.disabled:hover:focus,
+.datepicker table tr td span.active.focus,
+.datepicker table tr td span.active:hover.focus,
+.datepicker table tr td span.active.disabled.focus,
+.datepicker table tr td span.active.disabled:hover.focus {
+  color: #fff;
+  background-color: #286090;
+  border-color: #122b40;
+}
+.datepicker table tr td span.active:hover,
+.datepicker table tr td span.active:hover:hover,
+.datepicker table tr td span.active.disabled:hover,
+.datepicker table tr td span.active.disabled:hover:hover {
+  color: #fff;
+  background-color: #286090;
+  border-color: #204d74;
+}
+.datepicker table tr td span.active:active,
+.datepicker table tr td span.active:hover:active,
+.datepicker table tr td span.active.disabled:active,
+.datepicker table tr td span.active.disabled:hover:active,
+.datepicker table tr td span.active.active,
+.datepicker table tr td span.active:hover.active,
+.datepicker table tr td span.active.disabled.active,
+.datepicker table tr td span.active.disabled:hover.active {
+  color: #fff;
+  background-color: #286090;
+  border-color: #204d74;
+}
+.datepicker table tr td span.active:active:hover,
+.datepicker table tr td span.active:hover:active:hover,
+.datepicker table tr td span.active.disabled:active:hover,
+.datepicker table tr td span.active.disabled:hover:active:hover,
+.datepicker table tr td span.active.active:hover,
+.datepicker table tr td span.active:hover.active:hover,
+.datepicker table tr td span.active.disabled.active:hover,
+.datepicker table tr td span.active.disabled:hover.active:hover,
+.datepicker table tr td span.active:active:focus,
+.datepicker table tr td span.active:hover:active:focus,
+.datepicker table tr td span.active.disabled:active:focus,
+.datepicker table tr td span.active.disabled:hover:active:focus,
+.datepicker table tr td span.active.active:focus,
+.datepicker table tr td span.active:hover.active:focus,
+.datepicker table tr td span.active.disabled.active:focus,
+.datepicker table tr td span.active.disabled:hover.active:focus,
+.datepicker table tr td span.active:active.focus,
+.datepicker table tr td span.active:hover:active.focus,
+.datepicker table tr td span.active.disabled:active.focus,
+.datepicker table tr td span.active.disabled:hover:active.focus,
+.datepicker table tr td span.active.active.focus,
+.datepicker table tr td span.active:hover.active.focus,
+.datepicker table tr td span.active.disabled.active.focus,
+.datepicker table tr td span.active.disabled:hover.active.focus {
+  color: #fff;
+  background-color: #204d74;
+  border-color: #122b40;
+}
+.datepicker table tr td span.active.disabled:hover,
+.datepicker table tr td span.active:hover.disabled:hover,
+.datepicker table tr td span.active.disabled.disabled:hover,
+.datepicker table tr td span.active.disabled:hover.disabled:hover,
+.datepicker table tr td span.active[disabled]:hover,
+.datepicker table tr td span.active:hover[disabled]:hover,
+.datepicker table tr td span.active.disabled[disabled]:hover,
+.datepicker table tr td span.active.disabled:hover[disabled]:hover,
+fieldset[disabled] .datepicker table tr td span.active:hover,
+fieldset[disabled] .datepicker table tr td span.active:hover:hover,
+fieldset[disabled] .datepicker table tr td span.active.disabled:hover,
+fieldset[disabled] .datepicker table tr td span.active.disabled:hover:hover,
+.datepicker table tr td span.active.disabled:focus,
+.datepicker table tr td span.active:hover.disabled:focus,
+.datepicker table tr td span.active.disabled.disabled:focus,
+.datepicker table tr td span.active.disabled:hover.disabled:focus,
+.datepicker table tr td span.active[disabled]:focus,
+.datepicker table tr td span.active:hover[disabled]:focus,
+.datepicker table tr td span.active.disabled[disabled]:focus,
+.datepicker table tr td span.active.disabled:hover[disabled]:focus,
+fieldset[disabled] .datepicker table tr td span.active:focus,
+fieldset[disabled] .datepicker table tr td span.active:hover:focus,
+fieldset[disabled] .datepicker table tr td span.active.disabled:focus,
+fieldset[disabled] .datepicker table tr td span.active.disabled:hover:focus,
+.datepicker table tr td span.active.disabled.focus,
+.datepicker table tr td span.active:hover.disabled.focus,
+.datepicker table tr td span.active.disabled.disabled.focus,
+.datepicker table tr td span.active.disabled:hover.disabled.focus,
+.datepicker table tr td span.active[disabled].focus,
+.datepicker table tr td span.active:hover[disabled].focus,
+.datepicker table tr td span.active.disabled[disabled].focus,
+.datepicker table tr td span.active.disabled:hover[disabled].focus,
+fieldset[disabled] .datepicker table tr td span.active.focus,
+fieldset[disabled] .datepicker table tr td span.active:hover.focus,
+fieldset[disabled] .datepicker table tr td span.active.disabled.focus,
+fieldset[disabled] .datepicker table tr td span.active.disabled:hover.focus {
+  background-color: #337ab7;
+  border-color: #2e6da4;
+}
+.datepicker table tr td span.old,
+.datepicker table tr td span.new {
+  color: #777777;
+}
+.datepicker .datepicker-switch {
+  width: 145px;
+}
+.datepicker .datepicker-switch,
+.datepicker .prev,
+.datepicker .next,
+.datepicker tfoot tr th {
+  cursor: pointer;
+}
+.datepicker .datepicker-switch:hover,
+.datepicker .prev:hover,
+.datepicker .next:hover,
+.datepicker tfoot tr th:hover {
+  background: #eeeeee;
+}
+.datepicker .cw {
+  font-size: 10px;
+  width: 12px;
+  padding: 0 2px 0 5px;
+  vertical-align: middle;
+}
+.input-group.date .input-group-addon {
+  cursor: pointer;
+}
+.input-daterange {
+  width: 100%;
+}
+.input-daterange input {
+  text-align: center;
+}
+.input-daterange input:first-child {
+  border-radius: 3px 0 0 3px;
+}
+.input-daterange input:last-child {
+  border-radius: 0 3px 3px 0;
+}
+.input-daterange .input-group-addon {
+  width: auto;
+  min-width: 16px;
+  padding: 4px 5px;
+  line-height: 1.42857143;
+  text-shadow: 0 1px 0 #fff;
+  border-width: 1px 0;
+  margin-left: -5px;
+  margin-right: -5px;
+}
+/*# sourceMappingURL=bootstrap-datepicker3.css.map */